Trailing-Edge
-
PDP-10 Archives
-
AP-D471B-SB_1978
-
regula.cbl
There are no other files named regula.cbl in the archive.
IDENTIFICATION DIVISION.
PROGRAM-ID. REGULA.
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT INVENTORY-FILE ASSIGN TO DSK
ACCESS MODE IS INDEXED
SYMBOLIC KEY IS S-ITEM-NO
RECORD KEY IS ITEM-NO
RECORDING MODE IS SIXBIT.
DATA DIVISION.
FILE SECTION.
FD INVENTORY-FILE
VALUE OF ID "INVENTIDX"
BLOCK CONTAINS 12 RECORDS.
01 INVENTORY-RECORD.
02 ITEM-NO PIC 9(9).
02 DESCRIPTION PIC X(25).
02 ON-HAND PIC S9(9).
02 ON-ORDER PIC 9(9).
COMMUNICATION SECTION.
CD IN-ORDER FOR INPUT
QUEUE PRIME
SUB-QUEUE-1 SUB1
MESSAGE DATE IS M-DATE
MESSAGE TIME IS M-TIME
SYMBOLIC SOURCE IS M-SOURCE
TEXT LENGTH IS M-LENGTH
END KEY IS IN-END-KEY
STATUS KEY IS IN-STATUS-KEY.
CD OUT-ORDER FOR OUTPUT
TEXT LENGTH IS M-OUT-LENGTH
STATUS KEY IS OUT-STATUS-KEY
ERROR KEY IS PUT-ERROR-KEY
SYMBOLIC DESTINATION IS OUT-DESTINATION
DESTINATION COUNT IS DESTINATION-COUNT.
WORKING-STORAGE SECTION.
77 JUNK PIC X(72).
77 DELIVERY-AREA PIC X(50).
77 NUMERIC-QUANTITY PIC 9(9).
77 EXAMINE-QUANTITY REDEFINES NUMERIC-QUANTITY PIC X(9).
77 ITEM-SUB PIC S99 COMP VALUE 1.
77 DELIVER-SUB PIC S99 COMP VALUE 1.
77 S-ITEM-NO PIC 9(9) VALUE ZERO.
77 ORDER-ERROR PIC X(31)
VALUE "YOU BLEW IT-RESTART WITH ORDER#".
01 ORDER-GROUP.
02 ORDER-NO PIC X(9) VALUE ZEROS.
02 ITEMS OCCURS 10 TIMES.
03 ITEM PIC X(9).
03 FILLER PIC X(5).
03 DESCRPT PIC X(25).
03 FILLER PIC XX.
03 QUANTITY PIC X(9).
01 DUMMY-COMP PIC S9(10) VALUE 14 COMP.
01 DUMMY-ASCII REDEFINES DUMMY-COMP USAGE DISPLAY-7.
02 FILLER PIC X(4).
02 BELL PIC X.
01 NO-ITEM-MSG.
02 FILLER PIC X(22)
VALUE "INVALID ITEM NO. FOR ".
02 BAD-ONE PIC 9(9).
PROCEDURE DIVISION.
START.
OPEN I-O INVENTORY-FILE.
RESTART.
MOVE 'REGULAR' TO PRIME.
MOVE SPACES TO SUB1.
RECEIVE-ORDER-NO.
MOVE 1 TO ITEM-SUB.
RECEIVE IN-ORDER SEGMENT INTO ORDER-NO.
IF IN-END-KEY EQUALS ZERO OR IN-END-KEY
NOT EQUAL TO "1" GO TO FLUSH.
RECEIVE-ITEM-NO.
RECEIVE IN-ORDER SEGMENT INTO ITEM(ITEM-SUB).
IF IN-END-KEY EQUALS ZERO
OR IN-END-KEY NOT EQUAL TO "1" GO TO FLUSH.
MOVE ITEM (ITEM-SUB) TO S-ITEM-NO.
RECEIVE-QUANTITY.
RECEIVE IN-ORDER MESSAGE INTO QUANTITY (ITEM-SUB).
IF IN-END-KEY EQUALS ZERO
OR IN-END-KEY LESS THAN "2" GO TO FLUSH.
READ-INVENTORY.
READ INVENTORY-FILE INVALID KEY GO TO NO-ITEM.
MOVE DESCRIPTION TO DESCRPT (ITEM-SUB).
UPDATE-INVENTORY.
UNSTRING QUANTITY (ITEM-SUB) DELIMITED BY SPACE
INTO NUMERIC-QUANTITY.
EXAMINE EXAMINE-QUANTITY REPLACING ALL SPACES
BY ZEROS.
COMPUTE ON-HAND = ON-HAND - NUMERIC-QUANTITY.
REWRITE INVENTORY-RECORD INVALID KEY GO TO WRONG-WRITE.
CHECK-FOR-DELIVERY-TIME.
IF ITEM-SUB GREATER THAN 9 OR IN-END-KEY EQUALS "3"
GO TO DELIVER.
ADD 1 TO ITEM-SUB.
GO TO RECEIVE-ITEM-NO.
DELIVER.
MOVE 1 TO DELIVER-SUB.
MOVE 1 TO DESTINATION-COUNT.
MOVE 1 TO M-OUT-LENGTH.
MOVE "WAREHOUSE" TO OUT-DESTINATION.
PERFORM ATTENTION 6 TIMES.
MOVE 9 TO M-OUT-LENGTH.
SEND OUT-ORDER FROM ORDER-NO WITH EMI
AFTER ADVANCING 5 LINES.
ITEM-LOOP.
MOVE 50 TO M-OUT-LENGTH.
MOVE ITEMS (DELIVER-SUB) TO DELIVERY-AREA.
SEND OUT-ORDER FROM DELIVERY-AREA WITH EMI
AFTER ADVANCING 1 LINE.
ADD 1 TO DELIVER-SUB.
IF DELIVER-SUB GREATER THAN ITEM-SUB
MOVE 0 TO M-OUT-LENGTH
SEND OUT-ORDER WITH EPI
MOVE 1 TO DELIVER-SUB ITEM-SUB
GO TO RESTART
ELSE GO TO ITEM-LOOP.
NO-ITEM.
MOVE ITEM (ITEM-SUB) TO BAD-ONE.
MOVE 31 TO M-OUT-LENGTH.
MOVE M-SOURCE TO OUT-DESTINATION.
MOVE 1 TO DESTINATION-COUNT.
SEND OUT-ORDER FROM NO-ITEM-MSG WITH EMI
AFTER ADVANCING 3 LINES.
IF IN-END-KEY EQUALS "3" SEND OUT-ORDER WITH EPI
GO TO CLEAR-ITEMS
ELSE GO TO RECEIVE-ITEM-NO.
ATTENTION.
SEND OUT-ORDER FROM BELL.
CLEAR-ITEMS.
MOVE ZEROS TO ORDER-NO.
MOVE 1 TO DELIVER-SUB.
KEEP-CLEAR.
MOVE SPACES TO ITEMS (DELIVER-SUB).
ADD 1 TO DELIVER-SUB.
IF DELIVER-SUB GREATER THAN ITEM-SUB
GO TO RECEIVE-ORDER-NO
ELSE GO TO KEEP-CLEAR.
FLUSH.
RECEIVE IN-ORDER MESSAGE INTO JUNK.
IF IN-END-KEY NOT EQUAL TO "3" GO TO FLUSH.
MOVE 31 TO M-OUT-LENGTH.
MOVE 1 TO DESTINATION-COUNT.
MOVE M-SOURCE TO OUT-DESTINATION.
SEND OUT-ORDER FROM ORDER-ERROR WITH EPI
AFTER ADVANCING 3 LINES.
GO TO RESTART.
WRONG-WRITE.
CLOSE INVENTORY-FILE.
DISPLAY "?PROBLEM ON INVENTORY FILE".
STOP RUN.