SUBROUTINE CMSD.INV.MASTER(IMA.DATA)
*----------------------------------------------------------------------
*PGM NAME:     CMSD.INV.MASTER
*PURPOSE:      PERFORM ALL INVENTORY UPDATES - RETURN PASS/FAIL RESULT
*AUTHOR:       BARKSDALE
*CREATED:      08/12/94
*----------------------------------------------------------------------
*            
* BEWARE!!!  This program performs all updates which affect quantity
* available and physical quantity to inventory including transaction
* detail and summarized activity (historical record-keeping) for any
* inventory item.  It is called from a significant number of programs
* system-wide as well as from itself (recursive).  Please exercise
* EXTREME CAUTION when making additions or changes to code contained
* herein!
*
*--explanation of reject reason codes:
*   1 - quantity is zero or null
*   2 - invalid date
*   3 - cannot assemble non-assembled items
*   4 - transactions not valid against assembled items
*   5 - invalid warehouse
*   6 - transfers must be reductions to FROM warehouse (negative qty)
*   7 - transfers must have valid TO warehouse
*   8 - inventory item not on file
*   9 - insufficient quantity available
*  10 - item has backorders waiting for release
*  11 - cannot assemble sufficient quantity
*
*--include data
$INCLUDE GEN.COMMON
$INCLUDE IMA
$INCLUDE IVT
$INCLUDE INV
$INCLUDE IA
$INCLUDE IC
*
*--initialize tables
READ WHSE.CODES FROM GEN.KEYS,"WAREHOUSE.CODES" ELSE WHSE.CODES=""
READ TYPE.CODES FROM GEN.KEYS,"INVTRANS.TYPE" ELSE TYPE.CODES=""
*
*--initialize other variables
READU NEXT.JRNL FROM GEN.KEYS,"NEXT.INV.JOURNAL" THEN
  NEXT.JRNL=NEXT.JRNL+1
END ELSE
  NEXT.JRNL=1
END
WRITE NEXT.JRNL ON GEN.KEYS,"NEXT.INV.JOURNAL"
EQU TRUE TO 1
EQU FALSE TO 0
*
*----
* Check to see if IMA.DATA contains all the necessary data to
* perform update to inventory and verify validity of several
* of the fields.
*----
REJECT=FALSE
REJECT.REASON=""
CHANGED.FIELDS=""
*----
*  Log error in case of ultimate failure to update in any capacity
*  by the calling program.  For example:
*      - this program was unable to read the inventory item
*      - the calling program is not defining IMA.DATA properly
*----
IF IMA.DATA<IMA$FUNCTION>="REPORT.ERROR" THEN GO 100000
READ IREC FROM INVENTORY,IMA.DATA<IMA$ITEM> THEN
  IF IREC<INV$ORDER.CODE>="N" THEN
    INXFLAG=TRUE
  END ELSE
    INXFLAG=FALSE
  END
  IF IREC<INV$ASSEMBLED>="Y" THEN
    ASMFLAG=TRUE
  END ELSE
    ASMFLAG=FALSE
  END
  IF IMA.DATA<IMA$QUANTITY>="" OR IMA.DATA<IMA$QUANTITY>=0 THEN
    IF IMA.DATA<IMA$FUNCTION>="PO.ADD" OR IMA.DATA<IMA$FUNCTION>="PO.DELETE" ELSE
      *--zero or null would be valid only if change PO E.T.A.
      REJECT=TRUE
      REJECT.REASON=1
    END
  END
  IF IMA.DATA<IMA$DATE>="" THEN
    REJECT=TRUE
    REJECT.REASON=2
  END
  *----
  * check to see if valid function
  *----
  BEGIN CASE
  CASE IMA.DATA<IMA$FUNCTION>="CHECK.AVAILABLE"
  CASE IMA.DATA<IMA$FUNCTION>="COMMIT"
  CASE IMA.DATA<IMA$FUNCTION>="UNCOMMIT"
  CASE IMA.DATA<IMA$FUNCTION>="ADD.BACKORDER"
  CASE IMA.DATA<IMA$FUNCTION>="DELETE.BACKORDER"
  CASE IMA.DATA<IMA$FUNCTION>="RELEASE.BACKORDER"
  CASE IMA.DATA<IMA$FUNCTION>="ASSEMBLE"
    IF ASMFLAG ELSE
      REJECT=TRUE;*--may only assemble assembled items
      REJECT.REASON=3
    END
  CASE IMA.DATA<IMA$FUNCTION>="ASM.ADD"
  CASE IMA.DATA<IMA$FUNCTION>="PO.ADD"
  CASE IMA.DATA<IMA$FUNCTION>="PO.DELETE"
  CASE IMA.DATA<IMA$FUNCTION>="PO.RECEIVE"
  CASE IMA.DATA<IMA$FUNCTION>="COST.UPDATE"
  CASE IMA.DATA<IMA$FUNCTION>="RETURN.GOOD"
  CASE IMA.DATA<IMA$FUNCTION>="RETURN.DAMAGED"
  CASE IMA.DATA<IMA$FUNCTION>="RETURN.DEFECTIVE"
  CASE IMA.DATA<IMA$FUNCTION>="REPORT.ERROR"
  CASE 1
    LOCATE(IMA.DATA<IMA$FUNCTION>,TYPE.CODES,1;FND) ELSE REJECT=1
    IF ASMFLAG THEN
      IF IMA.DATA<IMA$PROCESS>="CMSD.INVTRANS" OR IMA.DATA<IMA$PROCESS>="CMSD.IVT.MULTI" THEN
        REJECT=TRUE;*--transactions invalid for assembled item
        REJECT.REASON=4
      END
    END
  END CASE
  IF IMA.DATA<IMA$WAREHOUSE>="" THEN
    REJECT=TRUE
    REJECT.REASON=5
  END
  LOCATE(IMA.DATA<IMA$WAREHOUSE>,WHSE.CODES,1;FND) ELSE
    REJECT=TRUE
    REJECT.REASON=5
  END
  IF IMA.DATA<IMA$FUNCTION>="TRF" THEN
    IF IMA.DATA<IMA$QUANTITY> > 0 THEN
      REJECT=TRUE
      REJECT.REASON=6
    END
    IF IMA.DATA<IMA$TO.WHSE>="" THEN
      REJECT=TRUE
      REJECT.REASON=7
    END
    LOCATE(IMA.DATA<IMA$TO.WHSE>,WHSE.CODES,1;FND) ELSE
      REJECT=TRUE
      REJECT.REASON=7
    END
  END
END ELSE
  REJECT=TRUE
  REJECT.REASON=8
END
IF REJECT THEN GO 100000
*
*--initialize variables
MINUS=-1
ITEM=IMA.DATA<IMA$ITEM>
QTY=IMA.DATA<IMA$QUANTITY>
YEAR=OCONV(IMA.DATA<IMA$DATE>,"DY")
MONTH=OCONV(IMA.DATA<IMA$DATE>,"DM")'R%2'
ACTION=IMA.DATA<IMA$FUNCTION>
IF ACTION="ASM.ADD" THEN ACTION="ASM"
TYPE=ACTION
TDATE=IMA.DATA<IMA$DATE>
USER=IMA.DATA<IMA$USER>
TREF=IMA.DATA<IMA$REFERENCE>
FLOC=IMA.DATA<IMA$WAREHOUSE>
TLOC=IMA.DATA<IMA$TO.WHSE>
CMNT=IMA.DATA<IMA$COMMENT>
WHSE=IMA.DATA<IMA$WAREHOUSE>
ENTRY.DATE=DATE()
EFFPD=YEAR[3,2]:"-":MONTH
TREC=''; IREC=''; AREC=''
IKEY=ITEM
TKEY=EFFPD:'|':ITEM
AKEY=YEAR:"|":WHSE:"|":ITEM
TYPWHS=TYPE:"|":WHSE:"|":TDATE
*
*--------------------main program section-----------------------------
BEGIN CASE
CASE ACTION="CHECK.AVAILABLE"
  *----
  * This is a request to see if sufficient quantity is available to
  * fulfill a request for an item.  It returns a pass/fail result
  * and is informational only - ABSOLUTELY NO UPDATE to inventory
  * will occur as a result of this requested action.  The purpose for
  * using this program to simply check availability of an item is to
  * insure that the verification of availability follows the same
  * procedural steps as an actual update to inventory and thereby
  * yields more consistent results.
  *----
  IF QTY < 0 ELSE
    *--if negative quantity then result is always "PASS"
    IF INXFLAG ELSE
      *--if inexhaustible supply then result is always "PASS"
      IF ASMFLAG THEN
        GOSUB 7000
        IF REJECT THEN REJECT.REASON=11
      END ELSE
        QTY=QTY*MINUS
        GOSUB 1000
        IF REJECT THEN REJECT.REASON=9
      END 
    END
  END
CASE ACTION="COMMIT"
  *----
  * This is a request to commit inventory.  Quantity should always be
  * a positive number.  An attempt will be made to reduce
  * INV$QTY.AVAILABLE for item.  If quantity available is insufficient
  * to commit inventory the following other actions will be attempted:
  *   - If INV$ORDER.CODE = "N" then item has an inexhaustible supply
  *     and sufficient quantity will be added to fulfill request.
  *   - If INV$ASSEMBLED = "Y" then item is assembled from components.
  *     An attempt will be made to assemble enough to cover requested
  *     quantity.
  * If quantity remains insufficient to fulfill request or backorders
  * already exist for this item then request will be rejected and
  * the result "FAIL" will be returned to calling program.
  * "PHYSICAL" quantity remains unaffected regardless of result.
  *----
  IF INXFLAG THEN GOSUB 6000 ;*--inexhaustible supply
  IF ASMFLAG THEN GOSUB 7000 ;*--assembled item
  QTY=QTY*MINUS
  GOSUB 1000;*--deduct from available quantity
CASE ACTION="UNCOMMIT"
  *----
  * This is a request to release inventory which has previously been
  * committed.  Quantity should always be a positive number.
  * INV$QTY.AVAILABLE will be increased.  No attempt will be made to
  * undo updates resulting from inexhaustible supply or assembled
  * inventory processes.
  * Result is always "PASS" to a request to uncommit.
  * "PHYSICAL" quantity remains unaffected.
  *----
  GOSUB 1000;*--add back to available quantity
CASE ACTION="ADD.BACKORDER"
  *----
  * This is a request to backorder inventory.  Quantity should always
  * be a positive number.  INV$QTY.BACKORDERED will be increased.
  * Result is always "PASS" to a request to backorder.
  * "PHYSICAL" quantity remains unaffected.
  *----
  GOSUB 2000;*--add to backorder quantity
CASE ACTION="DELETE.BACKORDER"
  *----
  * This is a request to reduce quantity on backorder.  Quantity should
  * always be a positive number.  INV$QTY.BACKORDERED will be reduced.
  * Result is always "PASS" to a request to delete a backorder.
  * "PHYSICAL" quantity remains unaffected.
  *----
  QTY=QTY*MINUS
  GOSUB 2000;*--reduce backorder quantity
CASE ACTION="RELEASE.BACKORDER"
  *----
  * This indicates backorder is being released to ship.  Quantity should
  * always be a positive number.  Both INV$QTY.AVAILABLE and 
  * INV$QTY.BACKORDERED will be reduced.
  * "PHYSICAL" quantity remains unaffected.
  *----
  IF INXFLAG THEN GOSUB 6000;*--inexhaustible supply
  IF ASMFLAG THEN GOSUB 7000;*--assembled item
  QTY=QTY*MINUS
  GOSUB 1000;*--reduce quantity available
  IF NOT(REJECT) THEN GOSUB 2000;*--reduce backorder quantity
CASE ACTION="ASSEMBLE"
  *----
  * This is a request to assemble a specified quantity of an item
  * from its component parts.  A "PASS" result indicates a reduction
  * to "PHYSICAL" and "AVAILABLE" quantity for each of the component
  * items and an offsetting increase to the assembled item itself.
  * A "FAIL" result indicates at least one of the component items
  * was on backorder or had insufficient supply to fulfill request.
  *----
  GOSUB 7000
CASE ACTION="PO.ADD"
  *----
  * This is a request to add to the ON ORDER quantity of an item.
  * Sub-valued data relevant to PO within WHSE will be updated.
  * All other quantity fields will be unaffected.
  *----
  GOSUB 8000
CASE ACTION="PO.DELETE"
  *----
  * This action will do exactly the same as above except the quantity
  * will be subtracted from the ON ORDER number for this PO
  *----
  QTY=QTY*MINUS
  GOSUB 8000
CASE ACTION="PO.RECEIVE"
  *----
  * This action is similar to PO.DELETE accept that ETA will not be
  * updated.
  *----
  QTY=QTY*MINUS
  GOSUB 9000
CASE ACTION="COST.UPDATE"
  *----
  * This action signifies an update to the INV.COST file which is
  * used to calculate unit cost.  No quantity fields on the inventory
  * record are updated
  *----
  GOSUB 10000
CASE ACTION="RETURN.GOOD"
CASE ACTION="RETURN.DAMAGED"
CASE ACTION="RETURN.DEFECTIVE"
CASE ACTION="SLS"
  *----
  * This is a request to record the actual shipment of product to a
  * customer.  INV$QTY.REDUCTIONS will be increased, and appropriate
  * entries will be recorded in INV.TRANS and INV.ACTIVITY files to
  * reflect change in "PHYSICAL" quantity.
  * INV$QTY.AVAILABLE is unaffected by this action.
  *----
  QTY=QTY*MINUS
  GOSUB 3000;*--create transaction
  GOSUB 4000;*--reduce physical quantity
  GOSUB 5000;*--update activity (summary)
CASE ACTION="TRF"
  *----
  * This is a request to transfer quantity from one warehouse to 
  * another.  It requires that the quantity to be transferred MUST
  * be available in the FROM warehouse.  No attempt is made to 
  * assemble sufficient quantity or to add quantity due to the
  * inexhaustibility of the item being transferred.
  * A quantity adjustment will be made to 2 (two) warehouses.
  * Both "PHYSICAL" and "AVAILABLE" quantity will be updated.
  *----
  GOSUB 1000;*--reduce available quantity - FROM warehouse
  IF NOT(REJECT) THEN GOSUB 3000;*--create transaction - FROM warehouse
  IF NOT(REJECT) THEN GOSUB 4000;*--reduce physical - FROM warehouse
  IF NOT(REJECT) THEN GOSUB 5000;*--update activity - FROM warehouse
  WHSE=TLOC 
  AKEY=YEAR:"|":WHSE:"|":ITEM
  QTY=QTY*MINUS
  IF NOT(REJECT) THEN GOSUB 1000;*--increase available - TO warehouse
  IF NOT(REJECT) THEN GOSUB 3000;*--create transaction - TO warehouse
  IF NOT(REJECT) THEN GOSUB 4000;*--increase physical - TO warehouse
  IF NOT(REJECT) THEN GOSUB 5000;*--update activity - TO warehouse
CASE 1
  *----
  * All other actions are valid inventory transactions which
  * will affect both the physical and available quantities.
  *----
  IF QTY < 0 AND INXFLAG THEN GOSUB 6000 ;*--inexhaustible supply
  GOSUB 1000;*--update available quantity
  IF NOT(REJECT) THEN GOSUB 3000;*--create transaction
  IF NOT(REJECT) THEN GOSUB 4000;*--update physical quantity
  IF NOT(REJECT) THEN GOSUB 5000;*--update activity (summary)
END CASE
GO 100000 ;*--end of program
*---------------------------------------------------------------------
*
1000 *---update inventory quantity available
READU IREC FROM INVENTORY,ITEM THEN
  LOCATE(WHSE,IREC,INV$WAREHOUSE;FND;"AR") ELSE
    IREC=INSERT(IREC,INV$WAREHOUSE,FND;WHSE)
    IREC=INSERT(IREC,INV$QTY.INCREASES,FND;0)
    IREC=INSERT(IREC,INV$QTY.REDUCTIONS,FND;0)
    IREC=INSERT(IREC,INV$QTY.AVAILABLE,FND;0)
    IREC=INSERT(IREC,INV$QTY.BACKORDERED,FND;0)
    IREC=INSERT(IREC,INV$QTY.ON.ORDER,FND;"")
    IREC=INSERT(IREC,INV$EST.TIME.ARRIVAL,FND;"")
    IREC=INSERT(IREC,INV$PO.NUMBER,FND;"")
    IREC=INSERT(IREC,INV$ACTIVITY.YEARS,FND;"")
    IREC=INSERT(IREC,INV$LEAD.TIME,FND;"")
    IREC=INSERT(IREC,INV$REORDER.POINT,FND;0)
    IREC=INSERT(IREC,INV$SAFETY.STOCK,FND;0)
    IREC=INSERT(IREC,INV$EST.MONTHLY.USAGE,FND;0)
    IREC=INSERT(IREC,INV$PROJECTED.OS.DATE,FND;"")
    IREC=INSERT(IREC,INV$PRIMARY.LOCATION,FND;"")
    IREC=INSERT(IREC,INV$ALTERNATE.LOCATION1,FND;"")
    IREC=INSERT(IREC,INV$ALTERNATE.LOCATION2,FND;"")
  END
  IF QTY < 0 THEN
    LOCATE(ACTION,TYPE.CODES,1;IDX) ELSE
      IF IREC<INV$QTY.AVAILABLE,FND> >= ABS(QTY) ELSE
        REJECT=TRUE;*--insufficient quantity to fulfill request
        REJECT.REASON=9
        RETURN
      END
      QOB=IREC<INV$QTY.BACKORDERED,FND>
      IF QOB > 0 AND ACTION#"RELEASE.BACKORDER" THEN
        REJECT=TRUE;*--waiting backorders take priority over new orders
        REJECT.REASON=10
        RETURN
      END
    END
  END
  IREC<INV$QTY.AVAILABLE,FND>=IREC<INV$QTY.AVAILABLE,FND>+QTY
  IF ACTION="CHECK.AVAILABLE" ELSE
    *--do not WRITE if only checking availability
    IF IREC<INV$QTY.AVAILABLE,FND> < 0 THEN
      CRT @(0,22):CL:BEEP:"Warning!  Quantity available for ":ITEM:" is negative - <return>":
      *ANY=""; INPUT ANY
      CHANGED.FIELDS=CHANGED.FIELDS:"-A"
    END ELSE
      CHANGED.FIELDS=CHANGED.FIELDS:"A"
    END
    WRITE IREC ON INVENTORY,ITEM
    IF ACTION="COMMIT" OR ACTION="UNCOMMIT" THEN
      CHANGED.FIELDS=CHANGED.FIELDS:"U"
    END
  END
END
RETURN
*
2000 *---update backorder quantity (INVENTORY)
READU IREC FROM INVENTORY,ITEM THEN
  LOCATE(WHSE,IREC,INV$WAREHOUSE;FND;"AR") THEN
    IREC<INV$QTY.BACKORDERED,FND>=IREC<INV$QTY.BACKORDERED,FND>+QTY
  END ELSE
    IREC=INSERT(IREC,INV$WAREHOUSE,FND;WHSE)
    IREC=INSERT(IREC,INV$QTY.INCREASES,FND;0)
    IREC=INSERT(IREC,INV$QTY.REDUCTIONS,FND;0)
    IREC=INSERT(IREC,INV$QTY.AVAILABLE,FND;0)
    IREC=INSERT(IREC,INV$QTY.BACKORDERED,FND;0)
    IREC=INSERT(IREC,INV$QTY.ON.ORDER,FND;"")
    IREC=INSERT(IREC,INV$EST.TIME.ARRIVAL,FND;"")
    IREC=INSERT(IREC,INV$PO.NUMBER,FND;"")
    IREC=INSERT(IREC,INV$ACTIVITY.YEARS,FND;"")
    IREC=INSERT(IREC,INV$LEAD.TIME,FND;"")
    IREC=INSERT(IREC,INV$REORDER.POINT,FND;0)
    IREC=INSERT(IREC,INV$SAFETY.STOCK,FND;0)
    IREC=INSERT(IREC,INV$EST.MONTHLY.USAGE,FND;0)
    IREC=INSERT(IREC,INV$PROJECTED.OS.DATE,FND;"")
    IREC=INSERT(IREC,INV$PRIMARY.LOCATION,FND;"")
    IREC=INSERT(IREC,INV$ALTERNATE.LOCATION1,FND;"")
    IREC=INSERT(IREC,INV$ALTERNATE.LOCATION2,FND;"")
    IREC<INV$QTY.BACKORDERED,FND>=QTY
  END
  IF IREC<INV$QTY.BACKORDERED,FND> < 0 THEN
    CRT @(0,22):CL:BEEP:"Warning!  Quantity backordered for ":ITEM:" is negative - <return>":
    *ANY=""; INPUT ANY
    CHANGED.FIELDS=CHANGED.FIELDS:"-B"
  END ELSE
    CHANGED.FIELDS=CHANGED.FIELDS:"B"
  END
  WRITE IREC ON INVENTORY,ITEM
END
RETURN
*
3000 *---update inventory transactions (INV.TRANS)
READU TREC FROM INV.TRANS,TKEY THEN
  BEGIN CASE
    CASE TYPE='SLS'
      LOCATE(TYPWHS,TREC,IVT$SORT.KEY;WH) THEN
        TREC<IVT$QUANTITY,WH>=TREC<IVT$QUANTITY,WH>+QTY
        TREC<IVT$TIME,WH>=TIME()
      END ELSE
        GOSUB 3100
      END
    CASE TYPE='RTS'
      LOCATE(TYPWHS,TREC,IVT$SORT.KEY;WH) THEN
        IF TREC<IVT$DATE,WH>=TDATE THEN
          TREC<IVT$QUANTITY,WH>=TREC<IVT$QUANTITY,WH>+QTY
          TREC<IVT$TIME,WH>=TIME()
        END ELSE
          GOSUB 3100
        END
      END ELSE
        GOSUB 3100
      END
    CASE TYPE='INX'
      LOCATE(TYPWHS,TREC,IVT$SORT.KEY;WH) THEN
        TREC<IVT$QUANTITY,WH>=TREC<IVT$QUANTITY,WH>+QTY
        TREC<IVT$TIME,WH>=TIME()
      END ELSE
        GOSUB 3100
      END
    CASE TYPE='ASM'
      FOUND=FALSE
      LOCATE(TYPWHS,TREC,IVT$SORT.KEY;WH) THEN
        LOOP
        UNTIL TREC<IVT$SORT.KEY,WH>#TYPWHS OR FOUND DO
          IF TREC<IVT$COMMENT,WH>=CMNT THEN
            TREC<IVT$QUANTITY,WH>=TREC<IVT$QUANTITY,WH>+QTY
            TREC<IVT$TIME,WH>=TIME()
            FOUND=TRUE
          END
          WH=WH+1
        REPEAT
        IF NOT(FOUND) THEN GOSUB 3100
      END ELSE
        GOSUB 3100
      END
    CASE 1
      GOSUB 3100
  END CASE
END ELSE
  TREC<IVT$TYPE>=TYPE
  TREC<IVT$QUANTITY>=QTY
  TREC<IVT$DATE>=TDATE
  TREC<IVT$TIME>=TIME()
  TREC<IVT$OPERATOR>=USER
  TREC<IVT$REFERENCE.NUMBER>=TREF
  TREC<IVT$FROM.LOCATION>=FLOC
  TREC<IVT$TO.LOCATION>=TLOC
  TREC<IVT$COMMENT>=CMNT
  TREC<IVT$ENTRY.DATE>=ENTRY.DATE
  TREC<IVT$SORT.KEY>=TYPWHS 
END
WRITE TREC ON INV.TRANS,TKEY
RETURN
*
3100 *----insert new transaction----
LOCATE(TDATE,TREC,IVT$DATE;WH;'DR') THEN NULL
TREC=INSERT(TREC,IVT$TYPE,WH;TYPE)
TREC=INSERT(TREC,IVT$QUANTITY,WH;QTY)
TREC=INSERT(TREC,IVT$DATE,WH;TDATE)
TREC=INSERT(TREC,IVT$TIME,WH;TIME())
TREC=INSERT(TREC,IVT$OPERATOR,WH;USER)
TREC=INSERT(TREC,IVT$REFERENCE.NUMBER,WH;TREF)
TREC=INSERT(TREC,IVT$FROM.LOCATION,WH;FLOC)
TREC=INSERT(TREC,IVT$TO.LOCATION,WH;TLOC)
TREC=INSERT(TREC,IVT$COMMENT,WH;CMNT)
TREC=INSERT(TREC,IVT$ENTRY.DATE,WH;ENTRY.DATE)
TREC=INSERT(TREC,IVT$SORT.KEY,WH;TYPWHS)      
RETURN 
*
4000 *---update shelf quantity (INVENTORY)
IF QTY > 0 THEN
  IATTR=INV$QTY.INCREASES
END ELSE
  IATTR=INV$QTY.REDUCTIONS
END
READU IREC FROM INVENTORY,IKEY THEN
  LOCATE(WHSE,IREC,INV$WAREHOUSE;FND;'AR') THEN
    IREC<IATTR,FND>=IREC<IATTR,FND>+ABS(QTY)
    LOCATE(YEAR,IREC,INV$ACTIVITY.YEARS,FND;WH;'DR') ELSE
      IREC=INSERT(IREC,INV$ACTIVITY.YEARS,FND,WH;YEAR)
    END
  END ELSE
    IREC=INSERT(IREC,INV$WAREHOUSE,FND;WHSE)
    IREC=INSERT(IREC,INV$QTY.INCREASES,FND;0)
    IREC=INSERT(IREC,INV$QTY.REDUCTIONS,FND;0)
    IREC=INSERT(IREC,INV$QTY.AVAILABLE,FND;0)
    IREC=INSERT(IREC,INV$QTY.BACKORDERED,FND;0)
    IREC=INSERT(IREC,INV$QTY.ON.ORDER,FND;"")
    IREC=INSERT(IREC,INV$EST.TIME.ARRIVAL,FND;"")
    IREC=INSERT(IREC,INV$PO.NUMBER,FND;"")
    IREC=INSERT(IREC,INV$ACTIVITY.YEARS,FND;"")
    IREC=INSERT(IREC,INV$LEAD.TIME,FND;"")
    IREC=INSERT(IREC,INV$REORDER.POINT,FND;0)
    IREC=INSERT(IREC,INV$SAFETY.STOCK,FND;0)
    IREC=INSERT(IREC,INV$EST.MONTHLY.USAGE,FND;0)
    IREC=INSERT(IREC,INV$PROJECTED.OS.DATE,FND;"")
    IREC=INSERT(IREC,INV$PRIMARY.LOCATION,FND;"")
    IREC=INSERT(IREC,INV$ALTERNATE.LOCATION1,FND;"")
    IREC=INSERT(IREC,INV$ALTERNATE.LOCATION2,FND;"")
    IREC<IATTR,FND>=ABS(QTY)
  END
  PHYSICAL=IREC<INV$QTY.INCREASES,FND>-IREC<INV$QTY.REDUCTIONS,FND>
  IF PHYSICAL < 0 THEN
    CRT @(0,22):CL:BEEP:"Warning!  Physical quantity for ":ITEM:" is negative - <return>":
    *ANY=""; INPUT ANY
    CHANGED.FIELDS=CHANGED.FIELDS:"-P"
  END ELSE
    CHANGED.FIELDS=CHANGED.FIELDS:"P" 
  END
  WRITE IREC ON INVENTORY,IKEY
END
RETURN
*
5000 *---update INV.ACTIVITY
HOLD.QTY=QTY ;*--save original value because we might change its sign
BEGIN CASE
  CASE TYPE='SLS'
    QTY=QTY*MINUS
    ATTR=IA$SALES
  CASE TYPE='RTS'
    ATTR=IA$RETURNS
  CASE QTY > 0
    ATTR=IA$INCREASES
  CASE QTY < 0
    QTY=QTY*MINUS
    ATTR=IA$REDUCTIONS
END CASE
READU AREC FROM INV.ACTIVITY,AKEY THEN
  LOCATE(EFFPD,AREC,IA$PERIOD;WH;'DL') THEN
    AREC<ATTR,WH>=AREC<ATTR,WH>+QTY    
  END ELSE
    AREC=INSERT(AREC,IA$PERIOD,WH;EFFPD)
    AREC=INSERT(AREC,IA$SALES,WH;0)
    AREC=INSERT(AREC,IA$RETURNS,WH;0)
    AREC=INSERT(AREC,IA$INCREASES,WH;0)
    AREC=INSERT(AREC,IA$REDUCTIONS,WH;0)
    AREC<ATTR,WH>=AREC<ATTR,WH>+QTY
  END
END ELSE
  GOSUB 5100 ;*--determine beginning qty
  AREC<IA$PERIOD>=EFFPD
  AREC<IA$BEGIN.QTY>=BEGQTY
  AREC<IA$SALES>=0
  AREC<IA$RETURNS>=0
  AREC<IA$INCREASES>=0
  AREC<IA$REDUCTIONS>=0
  AREC<ATTR>=AREC<ATTR>+QTY
END
WRITE AREC ON INV.ACTIVITY,AKEY
QTY=HOLD.QTY ;*--restore qty variable to original value
RETURN
*
5100 *---determine warehouse beginning quantity for new year
BEGQTY=0
DONE=FALSE
CHECK.YEAR=YEAR
LOOP
UNTIL DONE DO
  KEY=CHECK.YEAR:"|":WHSE:"|":ITEM
  READ REC FROM INV.ACTIVITY,KEY THEN
    BEGQTY=REC<IA$BEGIN.QTY>-SUM(REC<IA$SALES>)+SUM(REC<IA$RETURNS>)+SUM(REC<IA$INCREASES>)-SUM(REC<IA$REDUCTIONS>)
    DONE=TRUE
  END ELSE
    IF CHECK.YEAR > 1970 THEN
      CHECK.YEAR=CHECK.YEAR-1
    END ELSE
      BEGQTY=0
      DONE=TRUE
    END
  END
REPEAT
RETURN
*
6000 *--inexhaustible supply update
READU IREC FROM INVENTORY,ITEM THEN
  LOCATE(WHSE,IREC,INV$WAREHOUSE;FND;"AR") THEN
    QOH=IREC<INV$QTY.AVAILABLE,FND>
  END ELSE
    QOH=0
  END
  IF QTY > 0 THEN
    QOH=QOH-QTY
  END ELSE
    QOH=QOH+QTY
  END
  IF QOH < 0 THEN
    QTY.NEEDED=ABS(QOH)
    PASS.DATA=IMA.DATA
    PASS.DATA<IMA$FUNCTION>="INX"
    PASS.DATA<IMA$QUANTITY>=QTY.NEEDED
    PASS.DATA<IMA$COMMENT>="Automatic Supply Increase"
    CALL CMSD.INV.MASTER(PASS.DATA) ;*--recursive call
  END
END
RETURN
*
7000 *--assembled item update
READU IREC FROM INVENTORY,ITEM THEN
  LOCATE(WHSE,IREC,INV$WAREHOUSE;FND;"AR") THEN
    QOH=IREC<INV$QTY.AVAILABLE,FND>
  END ELSE
    QOH=0
  END
  *----
  * The following lines of code are designed to insure the correct
  * quantity is assembled.  If action is ASSEMBLE then we are talking
  * about the manual process (from CMSD.ASSEMBLE.ITEMS) otherwise
  * we are simply doing an ASM transaction for the difference
  * between what is already available and what has been requested.
  *----
  IF ACTION="ASSEMBLE" THEN
    QOH=0
  END
  QOH=QOH-QTY
  IF QOH < 0 THEN
    QTY.NEEDED=ABS(QOH)
    MAX.AVAIL=999999999999
    CCT=DCOUNT(IREC<INV$COMPONENT.ITEMS>,VM)
    FOR C=1 TO CCT UNTIL MAX.AVAIL=0
      CKEY=IREC<INV$COMPONENT.ITEMS,C>
      CQTY=IREC<INV$COMPONENT.QTY,C>
      READU CREC FROM INVENTORY,CKEY THEN
        IF CREC<INV$ASSEMBLED>="Y" THEN MAX.AVAIL=0
        IF CREC<INV$ORDER.CODE>#"N" THEN
          LOCATE(WHSE,CREC,INV$WAREHOUSE;FND;"AR") THEN
            MAX.QTY=INT(CREC<INV$QTY.AVAILABLE,FND>/CQTY)
            IF MAX.QTY < MAX.AVAIL THEN MAX.AVAIL=MAX.QTY
          END ELSE
            MAX.AVAIL=0
          END
        END 
      END ELSE
        MAX.AVAIL=0
      END
    NEXT C
    IF ACTION="CHECK.AVAILABLE" THEN
      *--no updates will be performed
      FOR C=1 TO CCT
        *--release component items which have been locked
        RELEASE INVENTORY,IREC<INV$COMPONENT.ITEMS,C>
      NEXT C
      IF MAX.AVAIL < QTY.NEEDED THEN REJECT=1
      RETURN 
    END
    IF MAX.AVAIL >= QTY.NEEDED THEN
      PASS.DATA=IMA.DATA
      PASS.DATA<IMA$FUNCTION>="ASM"
      PASS.DATA<IMA$COMMENT>="Assembled into ":ITEM
      FOR C=1 TO CCT
        *----
        * Loop through component items and call CMSD.INV.MASTER
        * to perform updates to inventory.  As items remain locked
        * (preventing any updates) as a result of above evaluation,
        * and sufficient quantity has already been verified, 
        * PASS.DATA will always return a "PASS" result back to this
        * program so IMA$RESULT does not need to be checked.
        * SPECIAL NOTE!!!  This is a recursive call of a program
        * from within itself.  Exercise EXTREME CAUTION when changing! 
        *----
        CITEM=IREC<INV$COMPONENT.ITEMS,C>
        CQTY=IREC<INV$COMPONENT.QTY,C>
        PASS.DATA<IMA$ITEM>=CITEM
        PASS.DATA<IMA$QUANTITY>=QTY.NEEDED*CQTY*MINUS
        CALL CMSD.INV.MASTER(PASS.DATA) ;*--recursive call
      NEXT C
      PASS.DATA=IMA.DATA
      PASS.DATA<IMA$FUNCTION>="ASM.ADD"
      PASS.DATA<IMA$QUANTITY>=QTY.NEEDED
      PASS.DATA<IMA$COMMENT>="Assembled from Components"
      CALL CMSD.INV.MASTER(PASS.DATA) ;*--recursive call
    END ELSE
      FOR C=1 TO CCT
        *--release component items which have been locked
        RELEASE INVENTORY,IREC<INV$COMPONENT.ITEMS,C>
      NEXT C
      REJECT=TRUE;*--cannot assemble enough to fulfill request
      REJECT.REASON=11
      RETURN
    END 
  END ELSE
    *----
    * there is no need to assemble any items - sufficient
    * quantity is already available
    *----
  END
END
RETURN
*
8000 *--update PO related fields (PO.ADD & PO.DELETE)
READU IREC FROM INVENTORY,ITEM THEN
  LOCATE(WHSE,IREC,INV$WAREHOUSE;FND;'AR') THEN
    LOCATE(TREF,IREC,INV$PO.NUMBER,FND;WH;'AR') THEN
      IREC<INV$QTY.ON.ORDER,FND,WH>=IREC<INV$QTY.ON.ORDER,FND,WH>+QTY
      IREC<INV$EST.TIME.ARRIVAL,FND,WH>=TDATE
      *--verify ON ORDER is not zero else delete
      IF IREC<INV$QTY.ON.ORDER,FND,WH>=0 THEN
        IREC=DELETE(IREC,INV$PO.NUMBER,FND,WH)
        IREC=DELETE(IREC,INV$QTY.ON.ORDER,FND,WH)
        IREC=DELETE(IREC,INV$EST.TIME.ARRIVAL,FND,WH)
      END
    END ELSE
      IREC=INSERT(IREC,INV$PO.NUMBER,FND,WH;TREF)
      IREC=INSERT(IREC,INV$QTY.ON.ORDER,FND,WH;QTY)
      IREC=INSERT(IREC,INV$EST.TIME.ARRIVAL,FND,WH;TDATE)
    END
  END ELSE
    IREC=INSERT(IREC,INV$WAREHOUSE,FND;WHSE)
    IREC=INSERT(IREC,INV$QTY.INCREASES,FND;0)
    IREC=INSERT(IREC,INV$QTY.REDUCTIONS,FND;0)
    IREC=INSERT(IREC,INV$QTY.AVAILABLE,FND;0)
    IREC=INSERT(IREC,INV$QTY.BACKORDERED,FND;0)
    IREC=INSERT(IREC,INV$QTY.ON.ORDER,FND;QTY)
    IREC=INSERT(IREC,INV$EST.TIME.ARRIVAL,FND;TDATE)
    IREC=INSERT(IREC,INV$PO.NUMBER,FND;TREF)
    IREC=INSERT(IREC,INV$ACTIVITY.YEARS,FND;"")
    IREC=INSERT(IREC,INV$LEAD.TIME,FND;"")
    IREC=INSERT(IREC,INV$REORDER.POINT,FND;0)
    IREC=INSERT(IREC,INV$SAFETY.STOCK,FND;0)
    IREC=INSERT(IREC,INV$EST.MONTHLY.USAGE,FND;0)
    IREC=INSERT(IREC,INV$PROJECTED.OS.DATE,FND;"")
    IREC=INSERT(IREC,INV$PRIMARY.LOCATION,FND;"")
    IREC=INSERT(IREC,INV$ALTERNATE.LOCATION1,FND;"")
    IREC=INSERT(IREC,INV$ALTERNATE.LOCATION2,FND;"")
  END
  WRITE IREC ON INVENTORY,ITEM
  CHANGED.FIELDS=CHANGED.FIELDS:"O"
END
RETURN
*
9000 *--update PO related fields (PO.RECEIVE)
READU IREC FROM INVENTORY,ITEM THEN
  LOCATE(WHSE,IREC,INV$WAREHOUSE;FND;'AR') THEN
    LOCATE(TREF,IREC,INV$PO.NUMBER,FND;WH;'AR') THEN
      IREC<INV$QTY.ON.ORDER,FND,WH>=IREC<INV$QTY.ON.ORDER,FND,WH>+QTY
      * Verify ON ORDER is greater than zero else delete
      * NOTE: PO.RECEIVE of more than ordered quantity (overruns)
      * will leave nothing on order for specified PO.
      *----
      IF IREC<INV$QTY.ON.ORDER,FND,WH> LE 0 THEN
        IREC=DELETE(IREC,INV$PO.NUMBER,FND,WH)
        IREC=DELETE(IREC,INV$QTY.ON.ORDER,FND,WH)
        IREC=DELETE(IREC,INV$EST.TIME.ARRIVAL,FND,WH)
      END
      WRITE IREC ON INVENTORY,ITEM
      CHANGED.FIELDS=CHANGED.FIELDS:"O"
    END ELSE
      *--nothing on order so nothing to do
      REJECT=TRUE
    END
  END ELSE
    *--nothing on order so nothing to do
    REJECT=TRUE
  END
END
RETURN
*
10000 *--update INV.COST record
COST=FIELD(CMNT,"|",2)
SOURCE=FIELD(CMNT,"|",1)
CKEY=WHSE:"|":ITEM
CREC=""
READU CREC FROM INV.COST,CKEY THEN
  IF CREC<IC$UNIT.COST,1>=COST THEN
    CREC<IC$DATE.RECEIVED,1>=TDATE
    CREC<IC$QTY.RECEIVED,1>=CREC<IC$QTY.RECEIVED,1>+QTY
    CREC<IC$SOURCE,1>=SOURCE
    CREC<IC$REFERENCE,1>=TREF
  END ELSE
    CREC=INSERT(CREC,IC$DATE.RECEIVED,1;TDATE)
    CREC=INSERT(CREC,IC$QTY.RECEIVED,1;QTY)
    CREC=INSERT(CREC,IC$UNIT.COST,1;COST)
    CREC=INSERT(CREC,IC$SOURCE,1;SOURCE)
    CREC=INSERT(CREC,IC$REFERENCE,1;TREF)
  END
END ELSE
  CREC<IC$DATE.RECEIVED>=TDATE
  CREC<IC$QTY.RECEIVED>=QTY
  CREC<IC$UNIT.COST>=COST
  CREC<IC$SOURCE>=SOURCE
  CREC<IC$REFERENCE>=TREF
END
WRITE CREC ON INV.COST,CKEY
RETURN
*
100000 *--return to calling program
IF REJECT THEN
  IMA.DATA<IMA$RESULT>="FAIL"
END ELSE
  IMA.DATA<IMA$RESULT>="PASS"
END
IMA.DATA<IMA$PROCESS.DATE>=DATE()
IMA.DATA<IMA$PROCESS.TIME>=TIME()
IMA.DATA<IMA$FAIL.REASON>=REJECT.REASON
IMA.DATA<IMA$CHANGES>=CHANGED.FIELDS
WRITE IMA.DATA ON INV.JOURNAL,NEXT.JRNL
RELEASE INVENTORY,IMA.DATA<IMA$ITEM>
RETURN