PDP-10 Archive: uetp/lib/ordent.cbl from AP-4171F-BM

Trailing-Edge - PDP-10 Archives - AP-4171F-BM - uetp/lib/ordent.cbl
There are 16 other files named ordent.cbl in the archive. Click here to see a list.
IDENTIFICATION DIVISION.
PROGRAM-ID. ORDEN2
AUTHOR.  R. HOGAN
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
DATA DIVISION.
SCHEMA SECTION.
*WORKING-STORAGE SECTION.
	INVOKE SUB-SCHEMA SUBS1 OF SCHEMA ORDENT PRIVACY KEY FOR COMPILE
	IS ORDER1ENTRY-LOCK.
WORKING-STORAGE SECTION.
01	QTR-MONTH-REC	PIC X(30).
01	QTR-MONTH-REC-DUMB	PIC X(30).

*	NOTE THAT ABOVE AREA FILLED IS IN WITH RECORD DESCRIPTIONS
*	FROM THE INVOKE OF THE SUBS1 SUB-SCHEMA OF THE ORDENT SCHEMA.

77	RECORD-TYPE	PIC X(6).
77	PKEY, PIC 9999, USAGE COMP.
77	CURRENT-OF-SLSENG	PIC 9(10) USAGE COMP.
01	FUNCTION.
	02  FUN-CODE	PIC X.
	02  FILLER	PIC X(7).
01	REPLY.
	02  REPLY-X	PIC X.
	88  REPLY-YES	VALUE 'Y'.
	88  REPLY-NO	VALUE 'N'.
	02  FILLER	PIC XX.
01	PAGREC.
	02 PAGEN, PIC 99999.
	02 FILLER, PIC XX, VALUE "  ".
	02 RECORD-NUM, PIC 999.
	02 FILLER, PIC XX, VALUE "  ".
01	ITEM-LINE-BUILD.
	02  ITEM-LINE-ORDER	PIC 9(6).
	02  ITEM-LINE-NUMBER	PIC 999.
77	KON, PIC 999999.
77	CUSTOM-CNT	PIC 9(10) COMP VALUE 0.
77	PURORD-CNT	PIC 9(10) COMP VALUE 0.
77	ITEM-CNT	PIC 9(10) COMP VALUE 0.

77	CUSCNT	PIC S9(10) COMP VALUE 1.
77	PRODCNT	PIC S9(10) COMP VALUE 1.

PROCEDURE DIVISION.
*	THE ABOVE SECTION OF THE PROCEDURE DIVISION IS FILLED IN WITH
*	A SET OF ENTER MACRO CALLS THAT 'BIND' THE SCHEMA, RECORDS
*	AND DATA ELEMENTS ASSOCIATED WITH THE SUBS1 SUB-SCHEMA.

FUNCTION-SECTION SECTION.
	MOVE "AREA1" TO IDAREA.
FIRST-START.
	DISPLAY "ENTER 'BEGIN' TO START: " WITH NO ADVANCING.
	ACCEPT FUNCTION.
	IF FUN-CODE EQUAL TO "B" GO TO BEGIN-ROUTINE.
	GO TO FIRST-START.
START.
	DISPLAY "FUNCTIONS ARE:  ENTER, CHANGE, INQUIRY, QUIT"
ACCEPT-FUNCTION.
	DISPLAY "ENTER FUNCTION: " WITH NO ADVANCING.
	ACCEPT FUNCTION.
	IF FUN-CODE EQUAL TO  "E" GO TO ENTER-ROUTINE.
	IF FUN-CODE EQUAL TO "C" GO TO CHANGE-ROUTINE.
	IF FUN-CODE EQUAL TO "I" GO TO INQUIRY-ROUTINE.
	IF FUN-CODE EQUAL TO "Q" GO TO ENTRY-WRAP-UP.
	DISPLAY "INVALID FUNCTION CODE: " FUNCTION.
	GO TO START.
DISPLAY-ERROR-STATUS.
	DISPLAY 'ERROR-STATUS: ' ERROR-STATUS.
INITIALIZE-SECTION SECTION.
BEGIN-NOTE.
	NOTE THAT THE BEGIN-ROUTINE IS A ONE-TIME
	INITIALIZATION OF THE ORDER SUMMARY DATA IN THE
	ORDSUM RECORD.
BEGIN-ROUTINE.
	PERFORM OPEN-AREA2-EXCL-UPDATE.
	PERFORM FIND-ORDSUM.
	IF ERROR-COUNT = 0
	CLOSE AREA AREA2
	GO TO START.
	MOVE 0 TO ORDSUM-ORDERS.
	MOVE 1 TO ORDSUM-NO.
BEGIN-ORDSUM-STORE.
	PERFORM STORE-ORDSUM.
BEGIN-ORDSUM-CLOSE.
	PERFORM CLOSE-ALL.
BEGIN-END.
	GO TO START.
ENTER-SECTION SECTION.
ENTER-ROUTINE.
	PERFORM OPEN-ALL-EXCL-UPDATE.
	PERFORM FIND-ORDSUM.
	IF ERROR-COUNT = 0
	PERFORM GET-ORDSUM
	GO TO ENTER-TYPE.
	DISPLAY 'ORDER SUMMARY RECORD NOT FOUND'.
	DISPLAY 'ORDER ENTRY SYSTEM NOT INITIALIZED - '
	'KEY-IN BEGIN'.
	PERFORM CLOSE-ALL.
	GO TO FIRST-START.
ENTER-TYPE.
	ENTER MACRO JRDATA USING SYSCOM,0.
	ENTER MACRO JRTEXT USING " CHANGING ENTER MODES".
	DISPLAY "RECORD TYPES ARE: PROD, SLSENG, CUSTOM, PURORD & ITEM".
	ACCEPT RECORD-TYPE.
	IF RECORD-TYPE EQUAL TO 'PROD' GO TO ENTER-PROD.
	IF RECORD-TYPE EQUAL TO 'SLSENG' GO TO ENTER-SLSENG.
	IF RECORD-TYPE EQUAL TO 'CUSTOM' GO TO ACCEPT-CUST-NAME.
	IF RECORD-TYPE EQUAL TO 'PURORD' GO TO ENTER-PURORD.
	IF RECORD-TYPE EQUAL TO 'ITEM' GO TO ENTER-ITEM.
	IF RECORD-TYPE EQUAL TO SPACES GO TO ENTER-CLOSE.
	DISPLAY "INVALID RECORD-TYPE: " RECORD-TYPE.
	GO TO ENTER-TYPE.
ENTER-CLOSE.
	PERFORM FIND-ORDSUM.
	PERFORM MODIFY-ORDSUM.
	PERFORM CLOSE-ALL.
	GO TO ACCEPT-FUNCTION.
ENTER-PROD.
	DISPLAY 'KEY-IN PROD-NO: ' WITH NO ADVANCING.
	ACCEPT PROD-NO.
CHECK-PROD.
	IF PROD-NO EQUAL SPACES GO TO ENTER-TYPE.

	ENTER MACRO JSTRAN USING "PROD",PRODCNT.
	PERFORM FIND-PROD.
	IF ERROR-STATUS EQUAL TO 326 OR 307
	GO TO GET-PROD-INFO.
	PERFORM DISPLAY-ERROR-STATUS.
	IF ERROR-COUNT EQUAL TO 0
	DISPLAY 'PROD-NO: ' PROD-NO ' ALREADY EXISTS'.
	GO TO ENTER-PROD.
GET-PROD-INFO.
	DISPLAY 'PROD DESC: ' WITH NO ADVANCING.
	ACCEPT PROD-DESC.
	DISPLAY 'PRODUCT PRICE: ' WITH NO ADVANCING.    
	ACCEPT PROD-PRICE.
	PERFORM STORE-PROD.
	ENTER MACRO JETRAN USING "PROD",PRODCNT.
	ADD 1 TO PRODCNT.
	GO TO ENTER-PROD.
ENTER-SLSENG.
	DISPLAY 'KEY-IN SALESENG NAME :'  WITH NO ADVANCING.
	ACCEPT SLSENG-NAME.
SLSENG-ACCEPTED.
	IF SLSENG-NAME EQUAL TO SPACES GO TO ENTER-TYPE.
	PERFORM FIND-SLSENG.
	IF ERROR-STATUS EQUAL TO 326 OR 307
	GO TO GET-SLSENG-INFO.
	PERFORM DISPLAY-ERROR-STATUS.
	IF ERROR-COUNT EQUAL TO 0
	DISPLAY 'SLSENG NAME: ' SLSENG ' ALREADY ON FILE'.
	GO TO ENTER-SLSENG.
GET-SLSENG-INFO.
	DISPLAY 'SALES OFFICE: ' WITH NO ADVANCING.
	ACCEPT SLSENG-OFFICE.
	DISPLAY 'PHONE - AREA CODE: ' WITH NO ADVANCING.
	ACCEPT SLSENG-AREA-NO.
	DISPLAY 'PHONE NUMBER AS XXX-XXXX ' WITH NO ADVANCING.
	ACCEPT SLSENG-PHONE-NO.
	DISPLAY 'EXTENSION: ' WITH NO ADVANCING.
	ACCEPT SLSENG-EXTENSION.
	PERFORM STORE-SLSENG.
	IF ERROR-COUNT NOT EQUAL TO 0
	DISPLAY 'SLSENG NOT ENTERED - ERROR-STATUS: ' ERROR-STATUS.
	GO TO ENTER-SLSENG.
ACCEPT-CUST-NAME.
	ENTER MACRO JSTRAN USING "CUSTOMER",CUSCNT.
	DISPLAY 'KEY-IN CUSTOMER NAME: '  WITH NO ADVANCING.
	ACCEPT CUST-NAME.
	ENTER MACRO JRTEXT USING "THIS IS SUPPOSED TO BE A
-	"MULTI-BLOCK TEXT EXAMPLE, I CERTAINLY HOPE THAT IT 
-	"ACTUALLY IS LONG ENOUGH".
GOT-CUST-NAME.
	PERFORM FIND-CUSTOM.
	IF ERROR-STATUS EQUAL TO 326 OR 307
	GO TO GET-CUST-INFO.
	PERFORM DISPLAY-ERROR-STATUS.
	IF ERROR-COUNT EQUAL TO 0
	DISPLAY "CUSTOMER-NAME: " CUST-NAME "ALREADY EXISTS"
	GO TO ACCEPT-CUST-NAME.
GET-CUST-INFO.
	DISPLAY "STREET ADDRESS: " WITH NO ADVANCING.
	ACCEPT STREET.
	DISPLAY "CITY: " WITH NO ADVANCING.
	ACCEPT CITY.
	DISPLAY "STATE: " WITH NO ADVANCING.
	ACCEPT STATE.
	DISPLAY "ZIP: " WITH NO ADVANCING.
	ACCEPT ZIP.
	PERFORM STORE-CUSTOM.
	IF ERROR-COUNT NOT EQUAL TO 0
	DISPLAY 'CUSTOMER: ' CUST-NAME ' NOT ENTERED'
	GO TO ACCEPT-CUST-NAME.
	MOVE PKEY TO CUST-KEY.
	ADD 1 TO CUSTOM-CNT.
OBTAIN-SLSENG.
	DISPLAY "SLSENG NAME (OR SPACE, IF NONE): " WITH NO ADVANCING.
	ACCEPT SLSENG-NAME.
	IF SLSENG-NAME EQUAL TO SPACES
	GO TO OBTAIN-ORDNUM.
	PERFORM FIND-SLSENG.
	IF ERROR-COUNT NOT EQUAL TO 0
	DISPLAY "NO SLSENG OF THIS NAME ON FILE - " SLSENG-NAME
	PERFORM DISPLAY-ERROR-STATUS
	GO TO OBTAIN-SLSENG.
	PERFORM FIND-CUSTOM.
	PERFORM INSERT-SLSCUS-SET.
	IF ERROR-COUNT EQUAL TO 0
	GO TO OBTAIN-ORDNUM.
	DISPLAY 'CUSTOM NOT ENTERED IN SLSCUS-SET'.
	PERFORM DISPLAY-ERROR-STATUS.
	GO TO OBTAIN-ORDNUM.
ENTER-PURORD.
	PERFORM ACCEPT-CUST-NAME.
	IF CUST-NAME EQUAL TO SPACES
	GO TO ENTER-TYPE.
	PERFORM FIND-CUSTOM.
	IF ERROR-COUNT EQUAL TO 0
	GO TO GOT-ORDNUM.
	DISPLAY 'NO CUSTOMER OF THIS NAME ON FILE'.
	GO TO ENTER-PURORD.
ACCEPT-ORDNUM.
	DISPLAY "ENTER ORDER-NUMBER: " WITH NO ADVANCING.
	ACCEPT ORDNUM.
OBTAIN-ORDNUM.
	DISPLAY "ANY ORDER TO BE ENTERED?  "
	WITH NO ADVANCING.
	ACCEPT REPLY.
ORDNUM-REPLY.
	IF NOT REPLY-YES
	ENTER MACRO JETRAN USING "CUSTOMER",CUSCNT
	ADD 1 TO CUSCNT
	GO TO ENTER-TYPE.
GOT-ORDNUM.
	MOVE ORDSUM-NO TO ORDNUM.
	PERFORM FIND-PURORD.
	IF ERROR-COUNT EQUAL TO 0
	DISPLAY "ORDNUM: " ORDNUM "ALREADY EXISTS"
	GO TO ENTER-PURORD.
	DISPLAY "NEW ORDER NUMBER IS: " ORDSUM-NO.
	DISPLAY "ORDER-DATE: " WITH NO ADVANCING.
	ACCEPT ORDER-DATE.
	MOVE 0 TO ORDER-NET.
	MOVE 0 TO ORDER-LINES.
	PERFORM STORE-PURORD.
	IF ERROR-COUNT EQUAL TO 0
	ADD 1 TO ORDSUM-NO
	ADD 1 TO ORDSUM-ORDERS
	ADD 1 TO PURORD-CNT
	GO TO ACCEPT-ITEM-LINE.
	DISPLAY "ORDER NUMBER: "   ORDNUM "  NOT ENTERED".
	GO TO OBTAIN-ORDNUM.
ENTER-ITEM.
	PERFORM ACCEPT-CUST-NAME.
	IF CUST-NAME EQUAL TO "    "
	GO TO ENTER-TYPE.
	PERFORM FIND-CUSTOM.
	IF ERROR-COUNT NOT EQUAL TO 0
	DISPLAY 'NO CUSTOMER OF THIS NAME ON FILE'
	GO TO ENTER-ITEM.
ITEM-ACCEPT-ORDNUM.
	PERFORM ACCEPT-ORDNUM.
	IF ORDNUM EQUAL TO 0
	GO TO ENTER-TYPE.
	PERFORM FIND-PURORD.
	IF ERROR-COUNT EQUAL TO 0
	PERFORM GET-PURORD
	MOVE ORDNUM TO ITEM-LINE-ORDER
	MOVE ORDER-LINES TO ITEM-LINE-NUMBER
	GO TO ACCEPT-ITEM-LINE.
	DISPLAY "ORDER NUMBER NOT IN DATA BASE".
	GO TO ITEM-ACCEPT-ORDNUM.
ITEM-GET-ORDNUM.
	PERFORM OBTAIN-ORDNUM.
	IF NOT REPLY-YES
	GO TO ENTER-TYPE.
ITEM-CHECK-ORDNUM.
	PERFORM FIND-PURORD.
	IF ERROR-COUNT EQUAL TO 0
	PERFORM GET-PURORD
	MOVE ORDNUM TO ITEM-LINE-ORDER
	MOVE ORDER-LINES TO ITEM-LINE-NUMBER
	GO TO ACCEPT-ITEM-LINE.
	DISPLAY "INVALID ORDER NUMBER".
	GO TO ITEM-GET-ORDNUM.
ENTER-ITEM-LINE.
	ADD 1 TO ORDER-LINES.
	ADD 1 TO ITEM-CNT.
	ADD ITEM-NET TO ORDER-NET.
ACCEPT-ITEM-LINE.
	DISPLAY "PRODUCT NUMBER: " WITH NO ADVANCING.
	ACCEPT ITEM-PROD-NO.
	IF ITEM-PROD-NO EQUAL TO SPACES
	PERFORM FIND-PURORD
	PERFORM MODIFY-PURORD
	MOVE 0 TO ITEM-LINE-NUMBER
	ENTER MACRO JETRAN USING "CUSTOMER",CUSCNT
	ADD 1 TO CUSCNT
	GO TO ENTER-TYPE.
	ADD 1 TO ITEM-LINE-NUMBER.
	MOVE ITEM-LINE-BUILD TO ITEM-LINE.
	MOVE ITEM-PROD-NO TO PROD-NO.
	PERFORM FIND-PROD.
	IF ERROR-COUNT EQUAL TO 0
	GO TO GET-ITEM-INFO.
	DISPLAY 'INVALID PROD-NO: ' ITEM-PROD-NO.
	GO TO ACCEPT-ITEM-LINE.
GET-ITEM-INFO.
	PERFORM GET-PROD.
	DISPLAY "QUANTITY ORDERED: " WITH NO ADVANCING.
	ACCEPT ITEM-QTY.
	MULTIPLY PROD-PRICE BY ITEM-QTY GIVING ITEM-NET.
	ADD ITEM-QTY TO PROD-ON-ORDER.
	PERFORM MODIFY-PROD.
	PERFORM STORE-ITEM.
	GO TO ENTER-ITEM-LINE.
ENTRY-WRAP-UP.
*	DISPLAY 'CUSTOM ENTRY COUNT: ' CUSTOM-CNT.
*	DISPLAY 'PURORD ENTRY COUNT: ' PURORD-CNT.
*	DISPLAY 'ITEM ENTRY COUNT:   ' ITEM-CNT.
        DISPLAY " ".
        DISPLAY " ".
        DISPLAY "THE FOLLOWING STATISTICS ROUTINE IS A DBMS-10".
        DISPLAY "UTILITY CALLED 'STATS' AND MAY BE CALLED AT ANY".
        DISPLAY "POINT IN A USER PROGRAM".
        DISPLAY " ".
        DISPLAY " ".
	ENTER MACRO STATS.
	CLOSE RUN-UNIT.
	STOP RUN.
CHANGE-ROUTINE.
	GO TO ACCEPT-FUNCTION.
INQUIRY-ROUTINE.
	OPEN ALL USAGE-MODE IS RETRIEVAL.
INQUIRY-REQUEST.
	DISPLAY 'PROD, SLSENG, CUSTOM OR PURORD INQUIRY? ' 
	WITH NO ADVANCING.
	ACCEPT RECORD-TYPE.
	IF RECORD-TYPE EQUAL TO 'PROD' GO TO INQUIRY-PROD.
	IF RECORD-TYPE EQUAL TO 'SLSENG' GO TO INQUIRY-SLSENG.
	IF RECORD-TYPE EQUAL TO 'CUSTOM' GO TO INQUIRY-CUSTOM.
	IF RECORD-TYPE EQUAL TO 'PURORD' GO TO INQUIRY-PURORD.
	IF RECORD-TYPE EQUAL TO SPACES GO TO INQUIRY-END.
	DISPLAY 'INVALID INQUIRY TYPE - ' RECORD-TYPE.
	GO TO INQUIRY-REQUEST.
INQUIRY-PROD.
	PERFORM ENTER-PROD.
	IF PROD-NO EQUAL TO SPACES
	GO TO INQUIRY-REQUEST.
	PERFORM FIND-PROD.
	IF ERROR-COUNT EQUAL TO 0
	PERFORM GET-PROD
	PERFORM PROD-DISPLAY
	GO TO INQUIRY-PROD-ITEM.
	DISPLAY 'PROD-NO: ' PROD-NO ' NOT IN DATA BASE'.
	GO TO INQUIRY-REQUEST.
INQUIRY-PROD-ITEM.
	DISPLAY 'DISPLAY ORDER INFO FOR THIS PROD-NO? '
	WITH NO ADVANCING.
	ACCEPT REPLY.
	IF REPLY-YES
	GO TO INQUIRY-PROD-ITEM-PATH.
	IF REPLY-NO
	GO TO INQUIRY-REQUEST.
	DISPLAY 'YES OR NO PLEASE'.
	GO TO INQUIRY-PROD-ITEM.
INQUIRY-PROD-ITEM-PATH.
	PERFORM FIND-NEXT-PROD-ITEM.
	IF ERROR-STATUS EQUAL TO 307
	DISPLAY 'NO PURORDS FOR THIS PROD-NO'
	GO TO INQUIRY-REQUEST.
	DISPLAY 'PURORD  LINE  QTY  CUSTOMER'.
	GO TO INQUIRY-GET-ITEM.
INQUIRY-PROD-ITEM-NEXT.
	PERFORM FIND-NEXT-PROD-ITEM.
	IF ERROR-STATUS EQUAL TO 307
	DISPLAY ' '
	GO TO INQUIRY-REQUEST.
INQUIRY-GET-ITEM.
	PERFORM GET-ITEM.
	PERFORM FIND-ORDITM-OWNER.
	IF ERROR-COUNT NOT EQUAL TO 0
	DISPLAY 'PURORD NOT FOUND FOR THIS ITEM'
	PERFORM DISPLAY-ERROR-STATUS
	GO TO INQUIRY-PROD-ITEM-NEXT.
	PERFORM GET-PURORD.
	PERFORM FIND-CUSORD-OWNER.
	IF ERROR-COUNT NOT EQUAL TO 0
	DISPLAY 'CUSTOM FOR THIS PURORD ITEM NOT FOUND'
	PERFORM DISPLAY-ERROR-STATUS
	GO TO INQUIRY-PROD-ITEM-NEXT.
	PERFORM GET-CUSTOM.
	PERFORM FIND-SLSCUS-OWNER.
	IF ERROR-COUNT NOT EQUAL TO 0
	MOVE 'NONE' TO SLSENG-NAME
	ELSE PERFORM GET-SLSENG.
	MOVE ITEM-LINE TO ITEM-LINE-BUILD.
	DISPLAY ORDNUM '      ' ITEM-LINE-NUMBER '      '
	ITEM-QTY '    ' CUST-NAME.
	GO TO INQUIRY-PROD-ITEM-NEXT.
INQUIRY-SLSENG.
	PERFORM ENTER-SLSENG.
	IF SLSENG-NAME EQUAL TO SPACES
	GO TO INQUIRY-REQUEST.
	PERFORM FIND-SLSENG.
	IF ERROR-COUNT EQUAL TO 0
	PERFORM GET-SLSENG
	PERFORM SLSENG-DISPLAY
	GO TO INQUIRY-SLSCUS.
	DISPLAY 'SLSENG: ' SLSENG-NAME ' NOT IN DATA BASE'.
	GO TO INQUIRY-REQUEST.
INQUIRY-SLSCUS.
	DISPLAY 'DISPLAY CUSTOMERS FOR THIS SLSENG? '
	WITH NO ADVANCING.
	ACCEPT REPLY.
	IF REPLY-YES
	GO TO INQUIRY-SLSCUS-PATH.
	IF REPLY-NO
	GO TO INQUIRY-REQUEST.
	DISPLAY 'YES OR NO PLEASE'.
	GO TO INQUIRY-SLSCUS.
INQUIRY-SLSCUS-PATH.
	PERFORM FIND-NEXT-SLSCUS.
	IF ERROR-STATUS EQUAL TO 307
	DISPLAY 'NO CUSTOMERS FOR THIS SLSENG'
	GO TO INQUIRY-REQUEST.
	GO TO INQUIRY-GET-CUST