Google
 

Trailing-Edge - PDP-10 Archives - DBMS-20_V6_BIN_19811001 - sources/thec74.cbl
There are 2 other files named thec74.cbl in the archive. Click here to see a list.
IDENTIFICATION DIVISION.
PROGRAM-ID.  DEMO.
AUTHOR.  SOFTWARE DOCUMENTATION.
INSTALLATION. DEC-MARLBOROUGH.
DATE-WRITTEN. 1 APRIL 1980.
SECURITY. TRIVIAL.
*REMARKS.*

*******************************************************************
*                                                                 *
*        copyright (c) 1980 DIGITAL Equipment Corporation         *
*                                                                 *
*  This program is for instructional purposes only; in order to   *
*  illustrate certain aspects of this software, this program may  *
*  contain constructs and practices that would not be suitable    *
*  for use in a production environment.  DIGITAL Equipment Cor-   *
*  poration assumes no responsibility for any errors which may    *
*  exist in this program.                                         *
*                                                                 *
*  This program was written by software documentation staff in    *
*  order to best explain concepts involved in using the DBMS DML. *
*  As such, the primary consideration was writing code that is,   *
*  for the most part, as simple as possible.  Consequently, the   *
*  approach taken was to write in-line code because, for the most *
*  part, it can be easier to understand, albeit harder to main-   *
*  tain.                                                          *
*                                                                 *
*  A second major factor in the writing of this program was that  *
*  only one program could be written.  This constraint was added  *
*  because the theme example programs are included on the dis-    *
*  tribution tape and we could only include one program there.    *
*  Consequently, the procedure shown here where everything is in- *
*  cluded in one program is not one that should be followed by    *
*  users performing similar kinds of functions.                   *
*                                                                 *
*  Also, this program was written solely to demonstrate a         *
*  series of functions.  While all these functions work, they     *
*  were not given the kind of load and performance testing that   *
*  should be, or are, given to true application software.         *
*                                                                 *
*******************************************************************
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. DECSYSTEM-20.
OBJECT-COMPUTER. DECSYSTEM-20.

DATA DIVISION.
SCHEMA SECTION.
	INVOKE SUB-SCHEMA COBSYS OF SCHEMA Theme
	PRIVACY KEY FOR COMPILE IS ACEDB.
WORKING-STORAGE SECTION.

***************************************************************
*                                                             *
*  The following working storage declarations replicate ele-  *
*  ments contained in the schema.  The reason for these de-   *
*  clarations is to receive user data without altering data   *
*  returned from the data base.  In some cases, where the     *
*  information is numeric, the user can enter alphabetic and  *
*  the program makes the check for correctness rather than    *
*  the COBOL compiler.                                        *
*                                                             *
***************************************************************

01 WS-Customer-Rec.
    02 WS-Cust-Num		PIC  X(05)		USAGE DISPLAY-7.
    02 WS-Cust-Name		PIC  X(20)		USAGE DISPLAY-7.
    02 WS-Cust-Address		PIC  X(45)		USAGE DISPLAY-7.
    02 WS-Cust-Rating		PIC  X(05)		USAGE DISPLAY-7.
    02 WS-Cust-Route		PIC  9(05)		USAGE DISPLAY-7.
    02 WS-Cust-Size		PIC  9(10)		USAGE DISPLAY-7.
    02 WS-Cust-Balance		PIC  9(08)V99		USAGE DISPLAY-7.

01 WS-Department-Rec.
    02 WS-Dept-Num		PIC  9(05)		USAGE DISPLAY-7.
    02 WS-Dept-Name		PIC  X(30)		USAGE DISPLAY-7.
    02 WS-Dept-Address.
       03 WS-Dept-Internal-No	PIC  X(05)		USAGE DISPLAY-7. 
       03 WS-Dept-Street	PIC  X(15)		USAGE DISPLAY-7.
       03 WS-Dept-City		PIC  X(15)		USAGE DISPLAY-7. 
       03 WS-Dept-State		PIC  X(05)		USAGE DISPLAY-7.
       03 WS-Dept-Zip		PIC  X(10)		USAGE DISPLAY-7. 
    02 WS-Dept-Phone		PIC  X(12)		USAGE DISPLAY-7.

01 WS-Employee-Rec.
    02 WS-Emp-Num		PIC  X(05)		USAGE DISPLAY-7.
    02 WS-Emp-Name.
       03 WS-Emp-Last-Name	PIC  X(15)		USAGE DISPLAY-7. 
       03 WS-Emp-First-Name	PIC  X(10)		USAGE DISPLAY-7. 
       03 WS-Emp-Middle-Init	PIC  X(01)		USAGE DISPLAY-7.
    02 WS-Emp-Address.
       03 WS-Emp-Street		PIC  X(15)		USAGE DISPLAY-7.
       03 WS-Emp-RFD-Apt	PIC  X(05)		USAGE DISPLAY-7. 
       03 WS-Emp-City		PIC  X(15)		USAGE DISPLAY-7. 
       03 WS-Emp-State		PIC  X(05)		USAGE DISPLAY-7. 
       03 WS-Emp-Zip		PIC  X(10)		USAGE DISPLAY-7. 
    02 WS-Emp-Sick-Leave	PIC  9(05)		USAGE DISPLAY-7.
    02 WS-Emp-Vacation		PIC  9(05)		USAGE DISPLAY-7.
    02 WS-Emp-Hour-Wage		PIC  9(03)V99		USAGE DISPLAY-7.

01 WS-Item-Rec.
    02 WS-Item-Part		PIC  X(05)		USAGE DISPLAY-7.
    02 WS-Item-Qty		PIC  9(08)V99		USAGE DISPLAY-7.
    02 WS-Item-Style		PIC  X(05)		USAGE DISPLAY-7.
    02 WS-Item-Fabric		PIC  X(20)		USAGE DISPLAY-7.
    02 WS-Item-Fabric-Num	PIC  9(05)		USAGE DISPLAY-7.
    02 WS-Item-Wood-Finish	PIC  X(05)		USAGE DISPLAY-7.
    02 WS-Item-Ship		PIC  9(05)		USAGE DISPLAY-7.
    02 WS-Item-Price		PIC  9(08)V99		USAGE DISPLAY-7.
    02 WS-Item-Weight		PIC  9(08)V99		USAGE DISPLAY-7.
    02 WS-Item-Volume		PIC  9(08)V99		USAGE DISPLAY-7.

01 WS-Location-Part-Rec.
    02 WS-Loc-Dept		PIC  9(05)		USAGE DISPLAY-7.
    02 WS-Loc-Qty		PIC  9(05)		USAGE DISPLAY-7.

01 WS-Manager-Link-Rec.
    02 WS-Num-Emp-Manage	PIC S9(10)		USAGE COMP.

01 WS-Order-Rec.
    02 WS-Ord-Num		PIC  9(10)		USAGE DISPLAY-7.
    02 WS-Ord-Due-Date		PIC  X(10)		USAGE DISPLAY-7.
    02 WS-Ord-Amt-Billed	PIC  9(08)V99		USAGE DISPLAY-7.
    02 WS-Ord-Amt-Outstand	PIC  9(08)V99		USAGE DISPLAY-7.
    02 WS-Ord-Ship-Method	PIC  X(01)		USAGE DISPLAY-7.

01 WS-Part-Rec.
    02 WS-Part-Num		PIC  X(05)		USAGE DISPLAY-7.
    02 WS-Part-Name		PIC  X(10)		USAGE DISPLAY-7.
    02 WS-Part-Available	PIC  9(05)		USAGE DISPLAY-7.
    02 WS-Part-Reserved		PIC  9(05)		USAGE DISPLAY-7.
    02 WS-Part-Ordered		PIC  9(05)		USAGE DISPLAY-7.
    02 WS-Part-Req-Reserved	PIC  9(05)		USAGE DISPLAY-7.
    02 WS-Part-Lead-Time	PIC  9(05)		USAGE DISPLAY-7.
    02 WS-Part-Std-Cost		PIC  9(08)V99		USAGE DISPLAY-7.
    02 WS-Part-Price		PIC  9(08)V99		USAGE DISPLAY-7.

01 WS-Truck-Rec.
    02 WS-Truck-Route		PIC  9(05)		USAGE DISPLAY-7.
    02 WS-Truck-Date		PIC  X(10)		USAGE DISPLAY-7.
    02 WS-Truck-Volume-Left	PIC  9(08)V99		USAGE DISPLAY-7.

01 WS-Work-Item-Rec.
    02 WS-WI-Time		PIC  9(08)V99		USAGE DISPLAY-7.
    02 WS-WI-Setup-Time		PIC  9(08)V99		USAGE DISPLAY-7.
    02 WS-WI-Operation		PIC  9(05)		USAGE DISPLAY-7.
    02 WS-WI-Station		PIC  9(05)		USAGE DISPLAY-7.

01 WS-Work-Order-Rec.
    02 WS-WO-Num		PIC  X(05)		USAGE DISPLAY-7.
    02 WS-WO-Qty		PIC  9(08)V99		USAGE DISPLAY-7.
    02 WS-WO-Count		PIC  9(10)		USAGE DISPLAY-7.
****************************************************************
*                                                              *
*   The following declarations are for elements only used      *
*   with the program.                                          *
*                                                              *
*   When the user is at the top level of the program and types *
*   a response, that response is compared to the values in     *
*   the following table.  Each response is two characters      *
*   long.  If the response is more than two characters, all    *
*   trailing characters are thrown away.  The list of respon-  *
*   ses is kept in alphabetical order so that a binary search  *
*   may be made of them.                                       *
*                                                              *
****************************************************************

01  RESPONSE-PROMPT					USAGE DISPLAY-6.
     02  RESPONSE-FILLER	PIC  X(42)
				VALUE IS "CLCUDEEMEXHEINMEMSORPASTTR ".
01  RESPONSES-OF-USERS		REDEFINES RESPONSE-PROMPT.
     02 RESPONSE-TABLE					USAGE DISPLAY-6
						OCCURS 21 TIMES
						ASCENDING KEY IS RESPONSE-TYPE
						INDEXED BY RESPONSE-INDEX.
        03 RESPONSE-TYPE	PIC  X(02).

* HOLDING ZONE FOR # OF ITEMS

01  Temp-Items		PIC  9(03)		USAGE DISPLAY-7.

***************************************************************
*                                                             *
*  Variable to which ERROR-STATUS is written after an         *
*  exception.                                                 *
*                                                             *
***************************************************************

01 TEMP-STATUS						USAGE DISPLAY-7.
    02 FILLER			PIC  9(01).
    02 VERB-TYPE		PIC  9(02).
    02 MESSAGE-TYPE		PIC  9(02).

* HOLDING ZONE FOR MOVE CURRENCY

01 TMP-CURR			PIC X(30)		USAGE DISPLAY-7.

* HOLDING ZONE FOR ORDER COST

01 Ord-Cost			PIC  9(10)V99		USAGE DISPLAY-7.


***************************************************************
*                                                             *
*  Conditions that may be set in DECLARATIVE section.         *
*                                                             *
***************************************************************

01 EXCEPTION-FLAG		PIC  9(01)		USAGE DISPLAY-7.
    88 OK					VALUE 0.
    88 RETRY					VALUE 1.
    88 END-OF-SET				VALUE 2.
    88 NO-SUCH-KEY				VALUE 3.
    88 FATAL					VALUE 4.
 
01 EXCEPTION-STATES					USAGE DISPLAY-6.
    02 OK-STATE			PIC  9(01)	VALUE 0.
    02 RETRY-STATE		PIC  9(01)	VALUE 1.
    02 END-OF-SET-STATE		PIC  9(01)	VALUE 2.
    02 NO-SUCH-KEY-STATE	PIC  9(01)	VALUE 3.
    02 FATAL-STATE		PIC  9(01)	VALUE 4.
    02 USER-REPLY-STATE		PIC  9(01)	VALUE 9.

****************************************************************
*                                                              *
*  Miscellaneous switches                                      *
*                                                              *
****************************************************************

01 FLAGS			PIC  9(01).
    88 MORE-ORDERS				VALUE 2.
    88 CHANGE-DEPT				VALUE 4.
    88 CHANGE-EMP				VALUE 5.
    88 FIRST-CUSTOMER				VALUE 7.

01 STATES						USAGE DISPLAY-6.
    02 MORE-ORDERS-STATE	PIC  9(01)	VALUE 2.
    02 CHANGE-DEPT-STATE	PIC  9(01)	VALUE 4.
    02 CHANGE-EMP-STATE		PIC  9(01)	VALUE 5.
    02 FIRST-CUSTOMER-STATE	PIC  9(01)	VALUE 7.

01 SWITCHES.
    02 TRUE			PIC  9(01)	VALUE 1.
    02 FALSE			PIC  9(01)	VALUE 0.
    02 AFFIRMATIVE		PIC  9(01)	VALUE 1.
   
01  MODIFY-FLAG			PIC  9(01).
    88 MODIFIED					VALUE 1.

01 DONE				PIC  9(01).
    88 FINISHED					VALUE 1.
    88 DECISION					VALUE 9.

01  BAD-NUMBER-FLAG		PIC  9(01).
    88 BAD-NUMBER				VALUE 1.

01  ITEM-FLAG			PIC  9(01).
    88 MORE-ITEMS				VALUE 1.

01 EXCEPTION-MSGS		PIC 9		VALUE 1.
    88 PRINT-EXCEPTIONS				VALUE 1.

***************************************************************
*                                                             *
*  Used to check that user input only contains numbers        *
*                                                             *
***************************************************************

01 WS-HOLD-ARRAY		PIC  X(12)		USAGE DISPLAY-6. 
01 WS-Num-Array					REDEFINES WS-HOLD-ARRAY
						OCCURS 12 TIMES.
    02 WS-Array			PIC  x(01).

77 COUNTER			PIC S9(03)		USAGE COMPUTATIONAL.
77 FUNCTION			PIC  X(02)		USAGE DISPLAY-6.
77 MODIFIED-STATE		PIC  9(01)	VALUE 1.
77 NON-MODIFIED-STATE		PIC  9(01)	VALUE 0.
77 TEMP-AREA			PIC  X(30)		USAGE DISPLAY-7.
77 TEMP-FUNCTION		PIC S9(06)		USAGE COMPUTATIONAL.
77 TEMP-REC			PIC  X(30)		USAGE DISPLAY-7.
77 SAVE-JOB-CLASS		PIC  X(05)		USAGE DISPLAY-7.
PROCEDURE DIVISION.
DECLARATIVES.

*****************************************************************
*                                                               *
*  Only the following exceptions are individually trapped:      *
*                                                               *
*    0240     Simultaneous Update Collision                     *
*    0307     End-of-Set                                        *
*    0326     No such CALC key                                  *
*                                                               *
*  All other exceptions are dealt with as follows:              *
*                                                               *
*      1.     The four digit exception number is moved to the   *
*             TEMP-STATUS variable.  At the 02 level, it is     *
*             divided into two parts: VERB-TYPE and MESSAGE-    *
*             TYPE.                                             *
*      2.     The number for each is then deciphered to display *
*             a discrete message.  These messages are identical *
*             to those in the DDL Manual.                       *
*                                                               *
*****************************************************************

EXCEPTION-DELETE SECTION.
	USE ERROR-STATUS 0240.
PARA-240.
	SET EXCEPTION-FLAG TO RETRY-STATE.
EXCEPTION-EXIT.
	EXIT.

EXCEPTION-FIND-SET SECTION.
	USE ERROR-STATUS 0307,0326.
PARA-300.
	IF ERROR-STATUS EQUALS 307
		SET EXCEPTION-FLAG TO END-OF-SET-STATE
	ELSE
		SET EXCEPTION-FLAG TO NO-SUCH-KEY-STATE.
FIND-EXIT.
	EXIT.

EXCEPTION-OTHER SECTION.
	USE ERROR-STATUS.
PARA-OTHER.
	IF NOT PRINT-EXCEPTIONS GO TO END-MESSAGES.
	MOVE ERROR-STATUS TO TEMP-STATUS.
	     IF VERB-TYPE EQUALS 0  DISPLAY "Host Verbs"
		SET DONE TO TRUE
	ELSE IF VERB-TYPE EQUALS 1  DISPLAY "Close Error"
		SET DONE TO TRUE
	ELSE IF VERB-TYPE EQUALS 2  DISPLAY "Delete Error"
		SET DONE TO USER-REPLY-STATE
	ELSE IF VERB-TYPE EQUALS 3  DISPLAY "Find Error"
		SET DONE TO USER-REPLY-STATE
	ELSE IF VERB-TYPE EQUALS 5  DISPLAY "Get Error"
		SET DONE TO USER-REPLY-STATE
	ELSE IF VERB-TYPE EQUALS 7  DISPLAY "Insert Error"
		SET DONE TO USER-REPLY-STATE
	ELSE IF VERB-TYPE EQUALS 8  DISPLAY "Modify Error".
		SET DONE TO USER-REPLY-STATE.
	     IF VERB-TYPE EQUALS 9  DISPLAY "Open Error"
		SET DONE TO TRUE
	ELSE IF VERB-TYPE EQUALS 11 DISPLAY "Remove Error"
		SET DONE TO USER-REPLY-STATE
        ELSE IF VERB-TYPE EQUALS 12 DISPLAY "Store Error"
		SET DONE TO USER-REPLY-STATE
        ELSE IF VERB-TYPE EQUALS 15 DISPLAY "Bind Error"
		SET DONE TO TRUE
        ELSE IF VERB-TYPE EQUALS 16 DISPLAY "Call Error"
		SET DONE TO TRUE.
MESSAGES-TEXT.
	IF MESSAGE-TYPE IS GREATER THAN 60 GO TO 60-MESSAGES.
	IF MESSAGE-TYPE IS GREATER THAN 50 GO TO 50-MESSAGES.
	IF MESSAGE-TYPE IS GREATER THAN 40 GO TO 40-MESSAGES.
	IF MESSAGE-TYPE IS GREATER THAN 30 GO TO 30-MESSAGES.
	IF MESSAGE-TYPE IS GREATER THAN 20 GO TO 20-MESSAGES.
	IF MESSAGE-TYPE IS GREATER THAN 10 GO TO 10-MESSAGES.

	IF MESSAGE-TYPE EQUALS 0
		DISPLAY "A warning.  Compile-time and run-time versions of"
		DISPLAY "schema differ"
	ELSE IF MESSAGE-TYPE EQUALS 1
		DISPLAY "Area not open."
	ELSE IF MESSAGE-TYPE EQUALS 2
		DISPLAY "Data base key inconsistent with area-name.  Can also"
		DISPLAY "indicate that a referenced page number is in an area"
		DISPLAY "that is not in the invoked sub-schema"
	ELSE IF MESSAGE-TYPE EQUALS 3
		DISPLAY "Record affected (deleted or removed) by concurrent"
		DISPLAY "application."
	ELSE IF MESSAGE-TYPE EQUALS 4
		DISPLAY "Data name invalid or inconsistent.  This can occur"
		DISPLAY "during GET or MODIFY with a data-name list."
	ELSE IF MESSAGE-TYPE EQUALS 5
		DISPLAY "Violation of DUPLICATES NOT ALLOWED clause."
	ELSE IF MESSAGE-TYPE EQUALS 6
		DISPLAY "Current of set, area, or record-name not known."
	ELSE IF MESSAGE-TYPE EQUALS 7
		DISPLAY "End of set, area, or record."
	ELSE IF MESSAGE-TYPE EQUALS 8
		DISPLAY "Referenced area, record, or set-name not in sub-"
		DISPLAY "schema.  This may occur because:"
		DISPLAY "1. DBCS encounters a record type not in the sub-"
		DISPLAY "   schema when traversing a set."
		DISPLAY "2. Set type owned by the object record type is not"
		DISPLAY "   in the sub-schea."
		DISPLAY "3. The VIA set is not in sub-schema--during set"
		DISPLAY "   selection occurrence."
		DISPLAY "4. All subkeys are not in the sub-schema during CALC"
		DISPLAY "   processing or searching a sorted set."
                DISPLAY "5. The sort key or a set not in the sub-schema is"
		DISPLAY "   modified."
        ELSE	DISPLAY "Update usage mode required.  This is an attempt to"
		DISPLAY "use an updating verb when the specified area is open"
		DISPLAY "for retrieval".
	GO TO END-MESSAGES.

10-MESSAGES.
	     IF MESSAGE-TYPE EQUALS 10
		DISPLAY "Privacy breach attempted."
	ELSE IF MESSAGE-TYPE EQUALS 11
		DISPLAY "Physical space not available.  No room remains for"
		DISPLAY "storing records.  This can occur while DBCS is trying"
		DISPLAY "to store an internal record type such as an index"
		DISPLAY "or buoy."
	ELSE IF MESSAGE-TYPE EQUALS 12
		DISPLAY "Line numbers for data base keys are exhausted."
	ELSE IF MESSAGE-TYPE EQUALS 13
		DISPLAY "No current record of run-unit."
	ELSE IF MESSAGE-TYPE EQUALS 14
		DISPLAY "Object record is MANDATORY AUTOMATIC member in"
		DISPLAY "named set."
	ELSE IF MESSAGE-TYPE EQUALS 15
		DISPLAY "Object record is MANDATORY type or not member type"
		DISPLAY "at all in named set.  This is an attempt to REMOVE"
		DISPLAY "a record which is either a MANDATORY member or not"
		DISPLAY "a member type of named set."
	ELSE IF MESSAGE-TYPE EQUALS 16
		DISPLAY "Record is already a member of named set."
	ELSE IF MESSAGE-TYPE EQUALS 17
		DISPLAY "Record has been deleted.  This can occur during a"
		DISPLAY "FIND CURRENT of RECORD, SET, AREA, or RUN-UNIT"
		DISPLAY "or during a FIND NEXT of SET or AREA."
	ELSE    DISPLAY "Data Conversion Unsuccessful.".
	GO TO END-MESSAGES.

20-MESSAGES.
	     IF MESSAGE-TYPE EQUALS 20
		DISPLAY "Current record of run-unit not of correct record-"
		DISPLAY "type."
	ELSE IF MESSAGE-TYPE EQUALS 22
		DISPLAY "Record not currently member of named or implied set."
	ELSE IF MESSAGE-TYPE EQUALS 23
		DISPLAY "Illegal area-name passed in area identification."
	ELSE IF MESSAGE-TYPE EQUALS 24
		DISPLAY "Temporary and permanent areas referenced in same"
		DISPLAY "DML verb."
	ELSE IF MESSAGE-TYPE EQUALS 25
		DISPLAY "No set occurrence satisfies argument values.  This"
		DISPLAY "can mean, for example, that the CALC value in the"
		DISPLAY "UWA matched no owner record."
	ELSE IF MESSAGE-TYPE EQUALS 26
		DISPLAY "No record satisfies RSE specified.  This is a"
		DISPLAY "catch-all exception for the FIND verb."
	ELSE    DISPLAY "Area already open.".
	GO TO END-MESSAGES.

30-MESSAGES.
	     IF MESSAGE-TYPE EQUALS 30
		DISPLAY "Unqualified DELETE attempted on non-empty set."
	ELSE IF MESSAGE-TYPE EQUALS 31
		DISPLAY "Unable to open the Schema File."
	ELSE IF MESSAGE-TYPE EQUALS 32
		DISPLAY "Insufficient space allocated for the data-name."
		DISPLAY "The SIZE clause specifies less space than the"
		DISPLAY "compiler needs."
	ELSE IF MESSAGE-TYPE EQUALS 33
		DISPLAY "None of the areas a record type can be within"
		DISPLAY "are in the sub-schema."
	ELSE IF MESSAGE-TYPE EQUALS 34
		DISPLAY "A set is in the sub-schema, but its owner record"
		DISPLAY "type is not."
	ELSE IF MESSAGE-TYPE EQUALS 35
		DISPLAY "Dynamic use-vector is full (FORTRAN ONLY)."
	ELSE IF MESSAGE-TYPE EQUALS 36
		DISPLAY "Attempt to invoke too many sub-schemas (more than"
		DISPLAY "8); or attempt to use UNSET with empty sub-schema"
		DISPLAY "stack, or SETDB with a full sub-schema stack."
	ELSE IF MESSAGE-TYPE EQUALS 37
		DISPLAY "Sub-schema passed to SETDB is not already invoked."
	ELSE IF MESSAGE-TYPE EQUALS 38
		DISPLAY "Duplicate operation attempted on a resource.  This"
		DISPLAY "can occur because: 1) you attempt to open the"
		DISPLAY "journal file twice (you have opened it in EXCLUSIVE"
		DISPLAY "UPDATE usage-mode and are now opening a data area"
		DISPLAY "in UPDATE usage-mode), or 2) you call JSTRAN while"
		DISPLAY "a transaction is already active, or 3) you have"
		DISPLAY "multiple INVOKE statements and attempt to open"
		DISPLAY "the same area twice."
	ELSE	DISPLAY "Data base file not found.".
	GO TO END-MESSAGES.

40-MESSAGES.
	     IF MESSAGE-TYPE EQUALS 40
		DISPLAY "Request access conflicts with existing access; that"
		DISPLAY "is, resource is not available.  This can result from"
		DISPLAY "an attempt to:"
		DISPLAY "1. open an area in a USAGE-MODE incompatible with"
		DISPLAY "   that of another run-unit using the same area."
		DISPLAY "2. open the journal in a way that results in a"
		DISPLAY "   USAGE-MODE conflict."
		DISPLAY "3. DELETE a record retained by another run-unit."
		DISPLAY "4. attempt to open area or the journal and the"
		DISPLAY "   file system signals a file-protection error."
	ELSE IF MESSAGE-TYPE EQUALS 41
		DISPLAY "No JFNs available. An attempt to open too many areas."
	ELSE IF MESSAGE-TYPE EQUALS 42
		DISPLAY "Area in undefined state.  Use DBMEND to force open"
		DISPLAY "the area and return it to a valid state."
	ELSE IF MESSAGE-TYPE EQUALS 43
		DISPLAY "Area in creation state.  This can happen to the"
		DISPLAY "system area only.  This will occur if run-unit"
		DISPLAY "execution aborts at just the right time during"
		DISPLAY "the first OPEN of the system area.  Should this occur"
		DISPLAY "either rerun SCHEMA or create a 0-length file with"
		DISPLAY "a text editor."
	ELSE IF MESSAGE-TYPE EQUALS 44
		DISPLAY "Attempt to call a journal-processing entry point"
		DISPLAY "before the journalling system has been initialized"
		DISPLAY "(by the first OPEN that requires journalling)."
	ELSE IF MESSAGE-TYPE EQUALS 45
		DISPLAY "Attempt to backup the data base with JBTRAN 1)"
		DISPLAY "while DBCS's Cannot-Backup-Updates bit is set, or"
		DISPLAY "2) when the journal is shared and commands are the"
		DISPLAY "interleaving unit, or 3) when the journal is shared,"
		DISPLAY "transactions are the interleaving unit, and the"
		DISPLAY "argument given to JBTRAN is greater than 0"
	ELSE IF MESSAGE-TYPE EQUALS 46
		DISPLAY "Magnetic tape service is not available.  DAEMDB"
		DISPLAY "has returned an exception code."
	ELSE	DISPLAY "Transaction not active.".
	GO TO END-MESSAGES.

50-MESSAGES.
	     IF MESSAGE-TYPE EQUALS 55
		DISPLAY "Pseudo-exception.  DBCS types message that no"
		DISPLAY "sub-schema yet initialized."
	ELSE IF MESSAGE-TYPE EQUALS 56
		DISPLAY "Inconsistent data in the data base file.  DBMEND"
		DISPLAY "should be used to restore the data base to a valid"
		DISPLAY "state.  If the problem can be reproduced, it"
		DISPLAY "probably indicates a DBCS software error."
	ELSE IF MESSAGE-TYPE EQUALS 57
		DISPLAY "Probably a DBCS software error.  If this recurs,"
		DISPLAY "report it."
	ELSE IF MESSAGE-TYPE EQUALS 58
		DISPLAY "Illegal argument passed by programmer or setup"
		DISPLAY "host interface; for example, passing a set-name"
		DISPLAY "with the STORE command."
	ELSE	DISPLAY "No more memory available.".
	GO TO END-MESSAGES.

60-MESSAGES.
	     IF MESSAGE-TYPE EQUALS 60
		DISPLAY "Unable to access a data base file.  The operating"
		DISPLAY "system reported an I/O error, either in normal"
		DISPLAY "operations or in trying to open a journal for"
		DISPLAY "appending."
	ELSE IF MESSAGE-TYPE EQUALS 61
		DISPLAY "Unable to append to journal (that is, the journal"
		DISPLAY "is in an aborted state but has not been designated"
		DISPLAY "as being done with)."
	ELSE IF MESSAGE-TYPE EQUALS 62
		DISPLAY "Attempt to enter DBCS at other than JBTRAN, SBIND,"
		DISPLAY "SETDB, or UNSET while the system-in-undefined-state"
		DISPLAY "bit is on."
	ELSE IF MESSAGE-TYPE EQUALS 63
		DISPLAY "Unable to complete restoration of the proper data"
		DISPLAY "base state.  This occurs either during JBTRAN"
		DISPLAY "initialization of a run-unit at the start of a"
		DISPLAY "command or transaction."
	ELSE IF MESSAGE-TYPE EQUALS 64
		DISPLAY "Exceptions while processing exception."
	ELSE IF MESSAGE-TYPE EQUALS 65
		DISPLAY "Monitor space for ENQUEUE entries exhausted, or"
		DISPLAY "ENQUEUE quota exceeded."
	ELSE IF MESSAGE-TYPE EQUALS 66
		DISPLAY "ENQUEUE/DEQUEUE failure (for example, you do not"
		DISPLAY "have ENQUEUE capabilities, or an unacceptable"
		DISPLAY "argument block has been created by DBCS)."
	ELSE	DISPLAY "Unable to initialize magnetic tape service because,"
		DISPLAY "for example, the IPCF block is bad; the IPCF"
		DISPLAY "message is too long; or DAEMDB is not running.".

END-MESSAGES.
	SET EXCEPTION-FLAG TO FATAL-STATE.
	DISPLAY " ".
	DISPLAY "ERROR STATUS = ", ERROR-STATUS.
	DISPLAY "ERROR SET    = ", ERROR-SET.
	DISPLAY "ERROR RECORD = ", ERROR-RECORD.
	DISPLAY "ERROR AREA   = ", ERROR-AREA.
	DISPLAY "ERROR COUNT  = ", ERROR-COUNT.
	MOVE AREA-NAME TO TEMP-AREA.
*	EXAMINE TEMP-AREA REPLACING ALL LOW-VALUE BY " ".*
	INSPECT TEMP-AREA REPLACING ALL LOW-VALUE BY " ".
	DISPLAY "AREA NAME    = ", TEMP-AREA.
	MOVE RECORD-NAME TO TEMP-REC.
*	EXAMINE TEMP-REC REPLACING ALL LOW-VALUE BY " ".*
	INSPECT TEMP-REC REPLACING ALL LOW-VALUE BY " ".
	DISPLAY "RECORD NAME  = ", TEMP-REC.
	DISPLAY "?  ".

END DECLARATIVES.
******************************************************************
*                                                                *
*  The next few lines of code set some switches and opens data   *
*  base areas.                                                   *
*                                                                *
******************************************************************

   SET Exception-Msgs TO True.
   SET Done TO False.

   SET Exception-Flag TO OK-State.

   OPEN AREA Head-Area
	USAGE-MODE IS EXCLUSIVE UPDATE
	PRIVACY KEY IS N1234.
   IF ERROR-STATUS NOT = 0 AND FATAL
	DISPLAY "? Not able to open Head-Area"
	GO TO FINIS.

   OPEN AREA Index-Block-Area
	USAGE-MODE IS EXCLUSIVE UPDATE
	PRIVACY KEY IS N1234.
   IF ERROR-STATUS NOT = 0 AND FATAL
	DISPLAY "? Not able to open Index-Block-Area"
	GO TO FINIS.

   OPEN AREA Inventory-Area
	USAGE-MODE IS EXCLUSIVE UPDATE
	PRIVACY KEY IS N1234.
   IF ERROR-STATUS NOT = 0 AND FATAL
	DISPLAY "? Not able to open Inventory-Area"
	GO TO FINIS.

   OPEN AREA Manufacturing-Area
	USAGE-MODE IS EXCLUSIVE UPDATE
	PRIVACY KEY IS N1234.
   IF ERROR-STATUS NOT = 0 AND FATAL
	DISPLAY "? Not able to open Manufacturing-Area"
	GO TO FINIS.

   OPEN AREA Orders-Area
	USAGE-MODE IS EXCLUSIVE UPDATE
	PRIVACY KEY IS N1234.
   IF ERROR-STATUS NOT = 0 AND FATAL
	DISPLAY "? Not able to open Orders-Area"
        GO TO FINIS.

   OPEN AREA Personnel-Area
	USAGE-MODE IS EXCLUSIVE UPDATE
	PRIVACY KEY IS N1234.
   IF ERROR-STATUS NOT = 0 AND FATAL
	DISPLAY "? Not able to open Personnel-Area"
        GO TO FINIS.

   OPEN AREA Personal-Area
	USAGE-MODE IS EXCLUSIVE UPDATE
	PRIVACY KEY IS N1234.
   IF ERROR-STATUS NOT = 0 AND FATAL
	DISPLAY "? Not able to open Personal-Area"
        GO TO FINIS.

******************************************************************
*                                                                *
*  When searching for information in the response table, we want *
*  blank spaces at the end of the RESPONSE string to be          *
*  correctly searched if there are blanks at the end as there    *
*  are in this case.  However, this means that single character  *
*  responses cannot be located using a search all command        *
*                                                                *
******************************************************************

*   EXAMINE RESPONSE-FILLER REPLACING ALL " " BY HIGH-VALUES.*
    INSPECT RESPONSE-FILLER REPLACING ALL " " BY HIGH-VALUES.
******************************************************************
*                                                                *
*  These are the key values for the head records.  They are in-  *
*  itialized here and then ignored.                              *
*                                                                *
******************************************************************

   MOVE HIGH-VALUES TO Cust-Dummy.
   MOVE HIGH-VALUES TO Emp-Dummy.
   MOVE HIGH-VALUES TO PO-Dummy.
   MOVE HIGH-VALUES TO WO-Dummy.
   MOVE HIGH-VALUES TO Number-Dummy.
   FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Access failure for Employee-Head ???"
	GO TO FINIS.
   FIND FIRST Cust-Head-Rec RECORD OF Cust-Head-Sys SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Access failure for Cust-Head ???"
	GO TO FINIS.
   FIND FIRST Work-Order-Head-Rec RECORD OF Work-Order-Sys Set.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Access failure for Work-Order-Head ???"
	GO TO FINIS.
   DISPLAY " ".
   DISPLAY "Digital DBMS-10/20 Theme Example".
   DISPLAY " ".
******************************************************************
*                                                                *
*  This asks if user wants to receive complete error messages or *
*  just the exception code.                                      *
*                                                                *
******************************************************************

   PERFORM EXCEPTION-MSG-PARA.

******************************************************************
*                                                                *
*  This is the only main line code statement.  DISPATCH is a     *
*  routine that accepts the user response to the top level       *
*  prompt.  After the user response is interpreted, the program  *
*  branches to the routine called for to process the records     *
*  called for in the response.                                   *
*                                                                *
******************************************************************

   PERFORM DISPATCH THROUGH DISPATCH-EXIT UNTIL FINISHED.

******************************************************************
*                                                                *
*  The next lines of code close data base files and put the      *
*  journal into a "done-with" state.                             *
*                                                                *
******************************************************************

FINIS.
   CLOSE RUN-UNIT.
*   CLOSE JOURNAL.
   STOP RUN.
******************************************************************
*                                                                *
*                   D I S P A T C H                              *
*                                                                *
*  This routine accepts the user response and then uses a        *
*  GO TO DEPENDING ON to branch to appropriate routine.  For this*
*  routine to work properly, the responses in the response table *
*  must be in alphabetical order and the paragraph labels in the *
*  GO TO must be in the same order.                              *
*                                                                *
******************************************************************

DISPATCH.
   SET Exception-Flag TO OK-State.
   DISPLAY " ".
   DISPLAY "THEME-MAIN-MENU>" WITH NO ADVANCING.
   ACCEPT Function.
   IF Function = "@" GO TO EXIT-PARA.
   IF Function = "?"  PERFORM HELP-PARA
	GO TO DISPATCH.
   SEARCH ALL Response-Table
			AT END PERFORM INVALID-RESPONSE-PARA THROUGH HELP-PARA
			       GO TO DISPATCH-EXIT
	WHEN Response-Type (Response-Index) = Function
		SET Temp-Function TO Response-Index
		GO TO
		     CLASSIFICATION-PARA
		     CUSTOMER-PARA
		     DEPARTMENT-PARA
		     EMPLOYEE-PARA
		     EXIT-PARA
		     HELP-PARA
		     INIT-PARA
		     MENU-PARA
		     EXCEPTION-MSG-PARA
		     ORDER-PROCESS-PARA
		     PART-PARA
		     STATS-PARA
		     TRUCK-PARA
				DEPENDING ON Temp-Function.

DISPATCH-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         C L A S S I F I C A T I O N - P A R A                  *
*                                                                *
*  This paragraph accepts a response and performs the Function   *
*  called for.  The Functions called for immediately follow      *
*  this paragraph.                                               *
*                                                                *
******************************************************************

CLASSIFICATION-PARA.
   PERFORM CLASSIFICATION-HELP.
   DISPLAY "CLASS-MENU>" WITH NO ADVANCING.
   ACCEPT Function.
   IF Function = "AD" PERFORM ADD-CLASSIFICATION THROUGH
			      ADD-CLASSIFICATION-EXIT
      ELSE
   IF Function = "DE" PERFORM DELETE-CLASSIFICATION THROUGH
			      DELETE-CLASSIFICATION-EXIT
      ELSE
   IF Function = "?" OR "HE" GO TO CLASSIFICATION-PARA
      ELSE
   IF Function = "LI" PERFORM LIST-CLASSIFICATION THROUGH
			      LIST-CLASSIFICATION-EXIT
      ELSE
   IF Function = "@" GO TO DISPATCH-EXIT
   ELSE DISPLAY Function, " is undefined ??? "
             GO TO CLASSIFICATION-PARA.
   GO TO DISPATCH-EXIT.
******************************************************************
*                                                                *
*         C L A S S I F I C A T I O N - H E L P                  *
*                                                                *
*  This is a list of available Functions for dealing with        *
*  CLASSIFICATION records.                                       *
*                                                                *
******************************************************************

CLASSIFICATION-HELP.
   DISPLAY " ".
   DISPLAY "@	Abort and return to THEME-MAIN-MENU".
   DISPLAY " ?	Display this Message".
   DISPLAY "AD	Add Classification".
   DISPLAY "DE	Delete Classification".
   DISPLAY "HE	Display this Message".
   DISPLAY "LI	List All Classifications".
   DISPLAY " ".
******************************************************************
*                                                                *
*         A D D - C L A S S I F I C A T I O N                    *
*                                                                *
*  This routine add one classification record to the data base.  *
*                                                                *
******************************************************************

ADD-CLASSIFICATION.
   DISPLAY " ".
   DISPLAY "ADD CLASSIFICATION--Type job classification>"
		WITH NO ADVANCING.
   ACCEPT Job-Class.
   IF Job-Class = "@" GO TO ADD-CLASSIFICATION-EXIT.
   IF Job-Class = "?" or "HE"
	DISPLAY "HELP--Type the five character classification code"
        GO TO ADD-CLASSIFICATION.

******************************************************************
*                                                                *
*  Check to insure not already in the data base.                 *
*                                                                *
******************************************************************
*                                                                *
*  Routine is really rather simple-minded.  It simply prompts for*
*  which item to input, gives you the option to abort if you type*
*  an @ sign, then goes to next data item.                       *
*                                                                *
******************************************************************

   FIND Classification-Rec.
   IF ERROR-STATUS = 0 OR OK,
         DISPLAY Job-Class, " already stored"
         GO TO ADD-CLASSIFICATION-EXIT.
   IF ERROR-STATUS NOT = 0 AND NOT NO-SUCH-KEY,
	GO TO ADD-CLASSIFICATION-EXIT.

REDO-JOB-DESCRIPTION.
   DISPLAY "ADD CLASSIFICATION--Type job description>"
		 WITH NO ADVANCING.
   ACCEPT Job-Description.
   IF Job-Description = "@" GO TO ADD-CLASSIFICATION-EXIT.
   IF Job-Description = "?" OR "HE"
	DISPLAY "HELP--Type the 1 to 20 letter classification name"
        GO TO REDO-JOB-DESCRIPTION.
   STORE CLassification-Rec.
   IF ERROR-STATUS NOT = 0 OR OK,
	DISPLAY "??? Classification Record not stored ???"
	DISPLAY "Your input was: ",Job-Class," ",Job-Description
   ELSE DISPLAY "*** Classification Record Stored ".

ADD-CLASSIFICATION-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         D E L E T E - C L A S S I F I C A T I O N              *
*                                                                *
*  On the surface, this might appear to be a rather simple rou-  *
*  tine.  However, in addition to deleting the classification    *
*  record, the program must also move each employee to a new     *
*  classification.  The program finds each employee and then asks*
*  you to specify which classification to transfer to.  This is  *
*  very direct--and very inefficient.  What should have been done*
*  is build a table of employees and then ask what classification*
*  to transfer to.  After the list is built up, the program      *
*  should go in and make all the changes at one time.  This      *
*  procedure was not seen as necessary for this example program. *
*                                                                *
******************************************************************

DELETE-CLASSIFICATION.
   DISPLAY "DELETE CLASSIFICATION--Type classification to be deleted>"
	WITH NO  ADVANCING.
   ACCEPT Job-Class.
   IF Job-Class = "@" GO TO DELETE-CLASSIFICATION-EXIT.
   IF Job-Class = "?" OR "HE"
	DISPLAY "HELP--Type the five character job classification"
        GO TO DELETE-CLASSIFICATION.
   MOVE Job-Class TO SAVE-JOB-CLASS.
   FIND Classification-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
        DISPLAY "??? Classification not found ???"
	GO TO DELETE-CLASSIFICATION-EXIT.
   FIND FIRST RECORD OF Class-Employee SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	GO TO DELETE-CLASSIFICATION-DEL.
   GO TO CHANGE-CLASS.

DELETE-CLASSIFICATION-LOOP.
   FIND NEXT RECORD OF Class-Employee SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
        GO TO DELETE-CLASSIFICATION-DEL.
CHANGE-CLASS.
   GET Employee-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
        GO TO DELETE-CLASSIFICATION-EXIT.
   REMOVE Employee-Rec  FROM Class-Employee.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
        GO TO DELETE-CLASSIFICATION-EXIT.
REDO-EMPLOYEE.
   DISPLAY "Employee ",EMP-NUM," ",EMP-NAME," is to be transferred to".
   DISPLAY "which Classification?  Type Job-Classification>"
	WITH NO ADVANCING.
   ACCEPT Job-Class.
   FIND Classification-Rec.
   IF ERROR-STATUS NOT = 0 AND NO-SUCH-KEY,
	DISPLAY "NO SUCH CLASS"
	GO TO REDO-EMPLOYEE.
   FIND CURRENT Employee-Rec RECORD.
   INSERT Employee-Rec INTO Class-Employee.
   MOVE SAVE-JOB-CLASS TO Job-Class.
   FIND Classification-Rec RECORD.
   IF ERROR-STATUS = 0 OR OK,
        GO TO DELETE-CLASSIFICATION-LOOP.

DELETE-CLASSIFICATION-DEL.
	MOVE SAVE-JOB-CLASS TO Job-Class.
	FIND Classification-Rec.
	IF ERROR-STATUS NOT = 0,
		GO TO DELETE-CLASSIFICATION-EXIT.
	DELETE Classification-Rec.
   IF ERROR-STATUS = 0
	DISPLAY "*** CLASIFICATION DELETED ***"
	ELSE DISPLAY "??? UNABLE TO DELETE ???".
DELETE-CLASSIFICATION-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         L I S T - C L A S S I F I C A T I O N                  *
*                                                                *
* This is a simple-minded routine that simply processes all recs *
* using a FIND NEXT of AREA.  The output is in the order in which*
* they are found.  The classification records were not put in a  *
* set this was not seen as as a normal Function.                 *
*                                                                *
******************************************************************

LIST-CLASSIFICATION.
   FIND FIRST Classification-Rec RECORD OF Personnel-Area AREA.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? No Classification Records Found, Data Base Corrupt ???"
	GO TO LIST-CLASSIFICATION-EXIT.
   DISPLAY "JOB-CLASS JOB-DESCRIPTION".
   DISPLAY "------------------------------------------------------------".
   GET Classification-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
        GO TO LIST-CLASSIFICATION-EXIT.
   DISPLAY Job-Class,"       ",Job-Description.

LIST-CLASSIFICATION-LOOP.
   FIND NEXT Classification-Rec RECORD OF Personnel-Area AREA.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
        GO TO LIST-CLASSIFICATION-EXIT.
   GET Classification-Rec.
   IF ERROR-STATUS = 0 OR OK,
        DISPLAY Job-Class,"       ",Job-Description
	GO TO LIST-CLASSIFICATION-LOOP.  

LIST-CLASSIFICATION-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         C U S T O M E R - P A R A                              *
*                                                                *
*  This is the menu for getting at customer-related Functions.   *
*                                                                *
******************************************************************

CUSTOMER-PARA.
   DISPLAY " ".
   DISPLAY "AL	List all customers and all orders".
   DISPLAY "HE	Display this listing".
   DISPLAY "LA	List all customers".
   DISPLAY "LO	List one customer and all orders for that customer"
   DISPLAY "@	Abort and return to main menu".
   DISPLAY " ?	Display this listing".
   DISPLAY " ".
   DISPLAY "CUSTOMER MENU>" WITH NO ADVANCING.
   ACCEPT Function.
   IF Function = "AL" SET FLAGS TO FIRST-CUSTOMER-STATE
		      PERFORM CUSTOMERS-ALL THROUGH CUSTOMERS-ALL-EXIT
      ELSE
   IF Function = "LA" PERFORM LIST-ALL-CUSTOMERS 
			      THROUGH LIST-ALL-CUSTOMERS-EXIT
      ELSE
   IF Function = "LO" PERFORM LIST-ONE-CUSTOMER
			      THROUGH LIST-ONE-CUSTOMER-EXIT
      ELSE
   IF Function = "?" OR "HE" GO TO CUSTOMER-PARA
      ELSE
   IF Function = "@" GO TO CUSTOMER-EXIT
	ELSE
   DISPLAY Function," is not defined".
   GO TO CUSTOMER-PARA.

CUSTOMER-EXIT.
   GO TO DISPATCH-EXIT.
******************************************************************
*                                                                *
*         C U S T O M E R S - A L L                              *
*                                                                *
******************************************************************

CUSTOMERS-ALL.
FIRST-CUST.
   FIND FIRST Customer-Rec RECORD OF Cust-Head SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
        DISPLAY "??? No Customers in Data Base ???"
        DISPLAY "    Data Base probably corrupt "
        GO TO CUSTOMERS-ALL-EXIT.
   GET Customer-Rec.
   DISPLAY"*--------------------------------------------------------*"
   DISPLAY Cust-Name.
   GO TO FIRST-ORDER.
NEXT-CUST.
   FIND NEXT Customer-Rec RECORD OF Cust-Head SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
        GO TO CUSTOMERS-ALL-EXIT.
   GET Customer-Rec.
   DISPLAY " ".
   DISPLAY"*--------------------------------------------------------*"
   DISPLAY " ".
   DISPLAY Cust-Name.
   SET FLAGS TO MORE-ORDERS-STATE.
FIRST-ORDER.
   FIND FIRST Order-Rec RECORD OF Cust-Ord SET.
   GET Order-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK AND NOT END-OF-SET,
	DISPLAY "+++ No Orders posted for this customer +++"
	SET EXCEPTION-FLAG TO OK-STATE
	GO TO CUSTOMERS-ALL.
   DISPLAY " ".
   DISPLAY "*************".
   DISPLAY " ".
   DISPLAY "ORDER NUMBER: " WITH NO ADVANCING.
   DISPLAY Ord-Num.
   DISPLAY "ENTERED: ", Ord-Entered-Date.
   DISPLAY "DUE: ", Ord-Due-Date.
   DISPLAY "BILLED: ", Ord-Amt-Billed.
   DISPLAY "OUTSANDING: ", Ord-Amt-Outstand.
   GO TO NEXT-ITEM.
NEXT-ORDER.
   FIND NEXT Order-Rec RECORD OF Cust-Ord SET.
   IF ERROR-STATUS NOT = 0,
	SET FLAGS, EXCEPTION-FLAG TO OK-STATE
	GO TO NEXT-CUST.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
        GO TO CUSTOMERS-ALL-EXIT.
   GET Order-Rec.
   DISPLAY " ".
   DISPLAY "*************".
   DISPLAY " ".
   DISPLAY "ORDER NUMBER: ", Ord-Num.
   DISPLAY "ENTERED: ", Ord-Entered-Date.
   DISPLAY "DUE: ", Ord-Due-Date.
   DISPLAY "BILLED: ", Ord-Amt-Billed.
   DISPLAY "OUTSTANDING: ", Ord-Amt-Outstand.
   SET ITEM-FLAG TO TRUE.
FIRST-ITEM.
   FIND FIRST Item-Rec RECORD OF Ord-Item SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK AND NOT END-OF-SET,
	DISPLAY "??? Data Base Problems, Orders Recorded ???"
	DISPLAY "    But There Are NO Items On Order."
	SET EXCEPTION-FLAG TO OK-STATE
	GO TO NEXT-CUST.
   GET Item-Rec.
   DISPLAY "ITEM   QTY     SHIPPED         PRICE".
   DISPLAY Item-Part,"   ", Item-Qty WITH NO ADVANCING.
   DISPLAY "      ",Item-Shipped-Date,"               ",Item-Price.
NEXT-ITEM.
   FIND NEXT Item-Rec RECORD OF Ord-Item SET.
   IF ERROR-STATUS NOT = 0 
	GO TO NEXT-ORDER.
   GET Item-Rec.
   DISPLAY "ITEM	QTY	SHIPPED		PRICE".
   DISPLAY Item-Part,"   ", Item-Qty WITH NO ADVANCING.
   DISPLAY "      ",Item-Shipped-Date,"               ",Item-Price.
   GO TO NEXT-ITEM.
CUSTOMERS-ALL-EXIT.
******************************************************************
*                                                                *
*         L I S T - A L L - C U S T O M E R S                    *
*                                                                *
******************************************************************

LIST-ALL-CUSTOMERS.
   FIND FIRST Customer-Rec RECORD OF Cust-Head SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? No customers in data base ???"
	DISPLAY "    Data base probably corrupt."
	GO TO LIST-ALL-CUSTOMERS-EXIT.

LIST-ALL-CUSTOMERS-LOOP.
   GET Customer-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	GO TO LIST-ALL-CUSTOMERS-EXIT.
   DISPLAY Cust-Num,"      ",Cust-Name.
   FIND NEXT Customer-Rec RECORD OF Cust-Head SET.
   IF ERROR-STATUS NOT = 0 AND END-OF-SET,
	GO TO LIST-ALL-CUSTOMERS-EXIT.
   IF ERROR-STATUS = 0,
	GO TO LIST-ALL-CUSTOMERS-LOOP.

LIST-ALL-CUSTOMERS-EXIT.
******************************************************************
*                                                                *
*         L I S T - O N E - C U S T O M E R                      *
*                                                                *
******************************************************************

LIST-ONE-CUSTOMER.
   DISPLAY "CUSTOMER--TYPE customer number >" WITH NO ADVANCING.
   ACCEPT Cust-Num.
   ENTER MACRO FINS6 USING "Customer-Rec", "Cust-Head".
   IF ERROR-STATUS NOT = 0 AND NOT OK,
        DISPLAY "??? Customer not found ???"
        GO TO LIST-ONE-CUSTOMER-EXIT.
   GET Customer-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	GO TO LIST-ONE-CUSTOMER-EXIT.
   DISPLAY "NAME: ", Cust-Name.
   DISPLAY "ADDRESS: ", Cust-Address.
   DISPLAY "RATING: ", Cust-Rating.
   DISPLAY "ROUTE: ", Cust-Route.
   DISPLAY "SIZE: ", Cust-Size.
   DISPLAY "BALANCE: ", Cust-Balance.
FIRST-ORDER-1.
   FIND FIRST Order-Rec RECORD OF Cust-Ord SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK AND NOT END-OF-SET,
	DISPLAY "+++ No Orders posted for this customer +++"
	GO TO LIST-ONE-CUSTOMER-EXIT.
NEXT-ORDER-1.
   GET Order-Rec.
   DISPLAY "ORDER-----------------ORDER".
   DISPLAY "ORDER: ",Ord-Num.
   DISPLAY "ENTERED: ", Ord-Entered-Date.
   DISPLAY "DUE: ", Ord-Due-Date.
   DISPLAY "BILLED: ", Ord-Amt-Billed.
   DISPLAY "OUTSTANDING: ", Ord-Amt-Outstand.
FIRST-ITEM-1.
   FIND FIRST Item-Rec RECORD OF Ord-Item SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK AND NOT END-OF-SET,
	DISPLAY "??? Data Base problems, Orders recorded ???"
	DISPLAY "    but there are not items on order"
	GO TO LIST-ONE-CUSTOMER-EXIT.
NEXT-ITEM-1.
   GET Item-Rec.
   DISPLAY"*********"
   DISPLAY "PART: ", Item-Part
   DISPLAY "QUANTITY: ", Item-Qty
   DISPLAY "SHIPPED: ", Item-Shipped-Date
   DISPLAY "PRICE: ", Item-Price
   FIND NEXT Item-Rec RECORD OF Ord-Item SET.
   IF ERROR-STATUS = 0 GO TO NEXT-ITEM-1.
   FIND NEXT Order-Rec RECORD OF Cust-Ord SET.
   IF ERROR-STATUS = 0 GO TO NEXT-ORDER-1.

LIST-ONE-CUSTOMER-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         D E P A R T M E N T - P A R A                          *
*                                                                *
******************************************************************

DEPARTMENT-PARA.
   PERFORM DEPARTMENT-HELP.
   DISPLAY "DEPT-MENU>" WITH NO ADVANCING.
   ACCEPT Function.
   IF Function = "?" OR "HE" GO TO DEPARTMENT-PARA
      ELSE
   IF Function = "@" GO TO DISPATCH-EXIT
      ELSE
   IF Function = "AD"
		MOVE 0 TO FLAGS
		PERFORM ADD-DEPARTMENT THROUGH ADD-DEPARTMENT-EXIT
      ELSE
   IF Function = "CH" PERFORM CHANGE-DEPARTMENT THROUGH ADD-DEPARTMENT-EXIT
      ELSE
   IF Function = "DE" PERFORM DELETE-DEPARTMENT THROUGH DELETE-DEPARTMENT-EXIT
      ELSE
   IF Function = "LI" PERFORM LIST-DEPARTMENT THROUGH LIST-DEPARTMENT-EXIT
      ELSE 
          DISPLAY "??? Undefined Function ???"
          GO TO DEPARTMENT-PARA.
   GO TO DISPATCH-EXIT.
******************************************************************
*                                                                *
*         D E P A R T M E N T - H E L P                          *
*                                                                *
******************************************************************

DEPARTMENT-HELP.
   DISPLAY " ".
   DISPLAY "AD	Add Department".
   DISPLAY "CH	Change Department Information".
   DISPLAY "DE	Delete Department".
   DISPLAY "LI	List All Departments".
   DISPLAY " ?	Display this listing".
   DISPLAY "HE	Display this listing".
   DISPLAY "@	Abort and return to main menu".
   DISPLAY " ".
******************************************************************
*                                                                *
*         C H A N G E - D E P A R T M E N T                      *
*                                                                *
******************************************************************

CHANGE-DEPARTMENT.
   SET FLAGS TO CHANGE-DEPT-STATE.
   DISPLAY " ".
   DISPLAY "If you do not wish to change a field, type a <CR>".
******************************************************************
*                                                                *
*         A D D - D E P A R T M E N T                            *
*                                                                *
******************************************************************

ADD-DEPARTMENT.
   DISPLAY " ".
   DISPLAY "DEPARTMENT--Type dept-number>" WITH NO ADVANCING.
   ACCEPT Dept-Num.
   FIND Department-Rec RECORD.
   IF CHANGE-DEPT
	IF ERROR-STATUS NOT = 0 AND NOT OK,
		DISPLAY "??? Department not stored ???"
                GO TO ADD-DEPARTMENT-EXIT
	ELSE
	    GET Department-Rec
		IF ERROR-STATUS NOT = 0 AND NOT OK,
			GO TO ADD-DEPARTMENT-EXIT
                ELSE DISPLAY Dept-Address, Dept-Phone
   ELSE
	IF ERROR-STATUS = 0 OR OK,
		DISPLAY "??? Department already stored ???"
	      GO TO ADD-DEPARTMENT-EXIT
	ELSE SET EXCEPTION-FLAG TO OK-STATE.
   MOVE Dept-Num TO WS-Dept-Num.

REDO-DEPARTMENT-NAME.
   DISPLAY "DEPARTMENT--Type dept-name>" WITH NO ADVANCING.
   ACCEPT WS-Dept-Name.
   IF WS-Dept-Name = "@" GO TO ADD-DEPARTMENT-EXIT.
   IF WS-Dept-Name = " " AND NOT CHANGE-DEPT
	DISPLAY "??? You must type a department name ???"
	GO TO REDO-DEPARTMENT-NAME.
   IF WS-Dept-Name = " " MOVE Dept-Name to WS-Dept-Name.
   DISPLAY "DEPARTMENT--Type dept-internal-no>" WITH NO ADVANCING.
   ACCEPT WS-Dept-Internal-No.
   IF WS-Dept-Internal-No = "@" GO TO ADD-DEPARTMENT-EXIT.
   IF WS-Dept-Internal-No = " "  AND CHANGE-DEPT
	MOVE Dept-Internal-No TO WS-Dept-Internal-No.

REDO-DEPARTMENT-STREET.
   DISPLAY "DEPARTMENT--Type dept-street>" WITH NO ADVANCING.
   ACCEPT WS-Dept-Street.
   IF WS-Dept-Street = "@" GO TO ADD-DEPARTMENT-EXIT.
   IF WS-Dept-Street = " " AND NOT CHANGE-DEPT
	DISPLAY "??? You must type an address ???"
	GO TO REDO-DEPARTMENT-STREET.
   IF WS-Dept-Street = " " MOVE Dept-Street to WS-Dept-Street.

REDO-DEPARTMENT-CITY.
   DISPLAY "DEPARTMENT--Type dept-city>" WITH NO ADVANCING.
   ACCEPT WS-Dept-City.
   IF WS-Dept-City = "@" GO TO ADD-DEPARTMENT-EXIT.
   IF WS-Dept-City = " " AND NOT CHANGE-DEPT
	DISPLAY "??? You must type a complete address ???"
	GO TO REDO-DEPARTMENT-CITY.
   IF WS-Dept-City = " " MOVE Dept-City to WS-Dept-City.

REDO-DEPARTMENT-STATE.
   DISPLAY "DEPARTMENT--Type dept-state>" WITH NO ADVANCING.
   ACCEPT WS-Dept-State.
   IF WS-Dept-State = "@" GO TO ADD-DEPARTMENT-EXIT.
   IF WS-Dept-State = " " AND NOT CHANGE-DEPT
	DISPLAY "??? You must type a complete address ???"
	GO TO REDO-DEPARTMENT-STATE.
   IF WS-Dept-State = " " MOVE Dept-State to WS-Dept-State.

REDO-DEPARTMENT-ZIP.
   DISPLAY "DEPARTMENT--Type dept-zip>" WITH NO ADVANCING.
   ACCEPT WS-Dept-Zip.
   IF WS-Dept-Zip = "@" GO TO ADD-DEPARTMENT-EXIT.
   IF WS-Dept-Zip = " " AND NOT CHANGE-DEPT
	DISPLAY "??? You must type a complete address ???"
	GO TO REDO-DEPARTMENT-ZIP.
   IF WS-Dept-Zip = " " MOVE Dept-Zip TO WS-Dept-Zip
   ELSE MOVE WS-Dept-Zip TO WS-HOLD-ARRAY
	SET BAD-NUMBER-FLAG TO FALSE
	PERFORM NUMERIC-CHECK VARYING COUNTER FROM 1 BY 1
		UNTIL COUNTER = 6 OR BAD-NUMBER
	IF BAD-NUMBER DISPLAY WS-Dept-Zip," contains non-numeric information"
		GO TO REDO-DEPARTMENT-ZIP.
REDO-DEPARTMENT-PHONE.
   DISPLAY "DEPARTMENT--Type dept-phone>" WITH NO ADVANCING.
   ACCEPT WS-Dept-Phone.
   IF WS-Dept-Phone = "@" GO TO ADD-DEPARTMENT-EXIT.
   IF WS-Dept-Phone = " " AND NOT CHANGE-DEPT
	DISPLAY "??? You must type a phone number ???"
	GO TO REDO-DEPARTMENT-PHONE.
   IF WS-Dept-Phone = " " MOVE Dept-Phone to WS-Dept-Phone.
   MOVE WS-Dept-Name TO Dept-Name.
   MOVE WS-Department-Rec TO Department-Rec.
   IF CHANGE-DEPT
        MODIFY Department-Rec
	IF ERROR-STATUS = 0 OR OK,
		DISPLAY "*** Department record modified ***"
		ELSE DISPLAY "??? Modification failed ???"
   ELSE
	STORE Department-Rec
	IF ERROR-STATUS = 0 OR OK,
		DISPLAY "*** Department record stored ***"
	ELSE
	  DISPLAY "??? Department record not stored ???"
	  DISPLAY "Your input was: ",Dept-Name," ",Dept-Address," ",Dept-Phone.

ADD-DEPARTMENT-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         D E L E T E - D E P A R T M E N T                      *
*                                                                *
******************************************************************

DELETE-DEPARTMENT.
   DISPLAY "DELETE DEPARTMENT -- Type dept-number>" WITH NO ADVANCING.
   ACCEPT Dept-Num.
   FIND Department-Rec.
   IF ERROR-STATUS NOT = 0 AND NO-SUCH-KEY,
	DISPLAY "Department not found"
	GO TO DELETE-DEPARTMENT-EXIT.
   FIND FIRST Customer-Rec RECORD OF Sales SET.
   IF ERROR-STATUS = 0,
	DISPLAY "Department has customers and may not be deleted"
	GO TO DELETE-DEPARTMENT-EXIT.
   FIND FIRST Truck-Rec RECORD OF Truck SET.
   IF ERROR-STATUS = 0,
	DISPLAY "Department has trucks and may not be deleted"
	GO TO DELETE-DEPARTMENT-EXIT.
   FIND FIRST Work-Item-Rec RECORD OF Dept-Work-Item SET.
   IF ERROR-STATUS = 0,
	DISPLAY "Department has work orders and may not be deleted"
	GO TO DELETE-DEPARTMENT-EXIT.
   FIND FIRST Employee-Rec RECORD OF Employees SET.
   IF ERROR-STATUS = 0,
	DISPLAY "Department has employees and may not be deleted"
	GO TO DELETE-DEPARTMENT-EXIT.
   DELETE Department-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "Department not deleted"
   ELSE
	DISPLAY "Department deleted".

DELETE-DEPARTMENT-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         L I S T - D E P A R T M E N T                          *
*                                                                *
******************************************************************

LIST-DEPARTMENT.
   SET ERROR-STATUS TO 0.
   FIND FIRST Department-Rec RECORD OF MANUFACTURING-AREA AREA.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? No Department Records Found, Data Base Corrupt ???"
	GO TO LIST-DEPARTMENT-EXIT.
   GET Department-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
		GO TO LIST-DEPARTMENT-EXIT.
   DISPLAY "DEPARTMENT # ", Dept-Num, "   NAME: ", Dept-Name.
   DISPLAY Dept-Address.
   DISPLAY Dept-Phone.
   DISPLAY "--------------------------------------------------------------".
LIST-DEPARTMENT-LOOP.
   FIND NEXT Department-Rec RECORD OF Manufacturing-Area AREA.
   IF ERROR-STATUS NOT = 0
	GO TO LIST-DEPARTMENT-EXIT.
   GET Department-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	GO TO LIST-DEPARTMENT-EXIT.
   DISPLAY "DEPARTMENT # ", Dept-Num, "   NAME: ", Dept-Name.
   DISPLAY Dept-Address,"     ", Dept-Phone.
   IF ERROR-STATUS = 0 OR NOT END-OF-SET,
	GO TO LIST-DEPARTMENT-LOOP.  

LIST-DEPARTMENT-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         E M P L O Y E E - P A R A                              *
*                                                                *
******************************************************************

EMPLOYEE-PARA.
   PERFORM EMPLOYEE-HELP.
   DISPLAY "EMPLOYEE-MENU>" WITH NO ADVANCING.
   MOVE " " TO Function.
   ACCEPT Function.
   IF Function = "?" OR "HE" GO TO EMPLOYEE-PARA
      ELSE
   IF Function = "@" GO TO DISPATCH-EXIT
      ELSE
   IF Function = "AC" PERFORM ADD-CHILD THROUGH ADD-CHILD-EXIT
      ELSE
   IF Function = "AD"
		MOVE 0 TO FLAGS
		PERFORM ADD-EMPLOYEE THROUGH ADD-EMPLOYEE-EXIT
      ELSE
   IF Function = "AS" PERFORM ADD-SPOUSE THROUGH ADD-SPOUSE-EXIT
      ELSE
   IF Function = "CH" PERFORM CHANGE-EMPLOYEE THROUGH ADD-EMPLOYEE-EXIT
      ELSE
   IF Function = "DE" PERFORM DELETE-EMPLOYEE THROUGH DELETE-EMPLOYEE-EXIT
      ELSE
   IF Function = "DI" PERFORM DISPLAY-EMPLOYEE THROUGH DISPLAY-EMPLOYEE-EXIT
      ELSE
   IF Function = "LI" PERFORM LIST-EMPLOYEES THROUGH LIST-EMPLOYEES-EXIT
      ELSE DISPLAY Function, "is not defined"
           GO TO EMPLOYEE-PARA.
   GO TO DISPATCH-EXIT.
******************************************************************
*                                                                *
*         E M P L O Y E E - H E L P                              *
*                                                                *
******************************************************************

EMPLOYEE-HELP.
   DISPLAY " ".
   DISPLAY "AC	Add Child".
   DISPLAY "AD	Add Employee".
   DISPLAY "AS	Add Spouse".
   DISPLAY "CH	Change Employee".
   DISPLAY "DE	Delete Employee".
   DISPLAY "DI	Display information about one employee".
   DISPLAY "LI	Display information about all employees".
   DISPLAY " ?	Display this listing".
   DISPLAY "HE	Display this listing".
   DISPLAY "@	Abort and return to main menu".
   DISPLAY " ".
******************************************************************
*                                                                *
*         C H A N G E - E M P L O Y E E                          *
*                                                                *
******************************************************************

CHANGE-EMPLOYEE.
   SET FLAGS TO CHANGE-EMP-STATE.
******************************************************************
*                                                                *
*         A D D - E M P L O Y E E                                *
*                                                                *
******************************************************************

ADD-EMPLOYEE.
   DISPLAY " ".
   DISPLAY "EMPLOYEE--Type emp-number>"
		WITH NO ADVANCING.
   ACCEPT Emp-Num.
   FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Employee-Head not found ???"
	DISPLAY "??? Data Base may be corrupt ???"
	DISPLAY "??? *** Execution Aborted ***???"
	SET DONE TO TRUE
        GO TO ADD-EMPLOYEE-EXIT.
   IF NOT CHANGE-EMP
	GET Employee-Head-Rec
	SET Num-of-Emp UP BY 1
	MODIFY Employee-Head-Rec Num-of-Emp
	IF ERROR-STATUS NOT = 0 AND NOT OK,
		GO TO ADD-EMPLOYEE-EXIT.
   ENTER MACRO FINS6 USING "Employee-Rec","Employee-Head".
   IF CHANGE-EMP
	IF ERROR-STATUS NOT = 0 AND NOT OK,
		DISPLAY "??? Employee not stored ???"
		  GO TO ADD-EMPLOYEE-EXIT
	ELSE
	    GET Employee-Rec
		IF ERROR-STATUS NOT = 0 AND NOT OK,
			GO TO ADD-EMPLOYEE-EXIT
            ELSE DISPLAY Emp-Name, Emp-Address
		 DISPLAY Emp-Sick-Leave, Emp-Vacation, Emp-Hour-Wage
   ELSE
	IF ERROR-STATUS NOT = 0 AND NOT OK,
		SET EXCEPTION-FLAG TO OK-STATE
        ELSE DISPLAY "??? Employee already stored ???"
		  GO TO ADD-EMPLOYEE-EXIT.
   DISPLAY "EMPLOYEE--Type emp-last-name>" WITH NO ADVANCING.
   ACCEPT Emp-Last-Name.
   DISPLAY "EMPLOYEE--Type emp-first-name>" WITH NO ADVANCING.
   ACCEPT Emp-First-Name.
   DISPLAY "EMPLOYEE--Type middle initial>" WITH NO ADVANCING.
   ACCEPT Emp-Middle-Init.
   DISPLAY "EMPLOYEE--Type emp-street>" WITH NO ADVANCING.
   ACCEPT Emp-Street.
   DISPLAY "EMPLOYEE--Type apt number or RFD>" WITH NO ADVANCING.
   ACCEPT Emp-RFD-Apt.
   DISPLAY "EMPLOYEE--Type emp-city>" WITH NO ADVANCING.
   ACCEPT Emp-City.
   DISPLAY "EMPLOYEE--Type emp-state>" WITH NO ADVANCING.
   ACCEPT Emp-State.
   DISPLAY "EMPLOYEE--Type emp-zip>" WITH NO ADVANCING.
   ACCEPT Emp-Zip.
   IF NOT CHANGE-EMP
	SET Emp-Sick-Leave TO 0
        SET Emp-Vacation TO 0.
   DISPLAY "EMPLOYEE--Type wage>" WITH NO ADVANCING.
   ACCEPT Emp-Hour-Wage.
   DISPLAY "EMPLOYEE--Type employee's dept num>" WITH NO ADVANCING.
   ACCEPT Dept-Num.
   DISPLAY "EMPLOYEE--Type employee's job class>" WITH NO ADVANCING.
   ACCEPT Job-Class
   SET MODIFY-FLAG TO FALSE.
   IF CHANGE-EMP SET MODIFY-FLAG TO TRUE.
   IF CHANGE-EMP
	FIND Department-Rec RECORD
	IF ERROR-STATUS NOT = 0 AND NOT OK,
		DISPLAY "NO SUCH DEPARTMENT, MODIFICATION TERMINATED."
		GO TO ADD-EMPLOYEE-EXIT
	ELSE FIND Classification-Rec RECORD
	IF ERROR-STATUS NOT = 0,
		DISPLAY "NO SUCH CLASS, MODIFICATION TERMINATED."
		GO TO ADD-EMPLOYEE-EXIT
	ELSE FIND CURRENT Employee-Rec RECORD
	MODIFY Employee-Rec
	IF ERROR-STATUS NOT = 0 AND NOT OK,
		DISPLAY "??? Modification failed ???"
	ELSE DISPLAY "*** Employee record modified ***"
   ELSE
	SET ERROR-STATUS TO 0
	FIND Department-Rec RECORD
	IF ERROR-STATUS NOT = 0 AND NOT OK,
		DISPLAY "NO SUCH DEPARTMENT--RECORD TERMINATED"
		GO TO ADD-EMPLOYEE-EXIT
	ELSE FIND Classification-Rec RECORD
		IF ERROR-STATUS NOT = 0 AND NOT OK,
			DISPLAY "NO SUCH CLASSIFICATION-STORE TERMINATED"
			GO TO ADD-EMPLOYEE-EXIT
	     ELSE STORE Employee-Rec
		IF ERROR-STATUS = 0 OR OK
			DISPLAY "*** employee record stored ***"
			ELSE DISPLAY "??? Employee record not stored ???".
   IF MODIFIED
	REMOVE Employee-Rec FROM Employees
	IF ERROR-STATUS NOT = 0 AND NOT OK,
		GO TO ADD-EMPLOYEE-EXIT
	ELSE FIND Department-Rec
	     IF ERROR-STATUS NOT = 0 AND NOT OK
		GO TO ADD-EMPLOYEE-EXIT
	     ELSE FIND CURRENT OF Employee-Rec RECORD
		  INSERT Employee-Rec INTO Employees
		  IF ERROR-STATUS NOT = 0 AND NOT OK,
			DISPLAY "??? Insertion into dept set failed ???"
	          ELSE DISPLAY "*** Add employee routine concluded ***".

ADD-EMPLOYEE-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         D E L E T E - E M P L O Y E E                          *
*                                                                *
******************************************************************

DELETE-EMPLOYEE.
   DISPLAY "DELETE EMPLOYEE -- Type employee number>" WITH NO ADVANCING.
   ACCEPT Emp-Num.
   FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Employee-Head not found ???"
	SET DONE TO TRUE
	GO TO DELETE-EMPLOYEE-EXIT.
   ENTER MACRO FINS6 USING "Employee-Rec", "Employee-Head".
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "Employee not found"
	GO TO DELETE-EMPLOYEE-EXIT.
   GET Employee-Rec.
   DISPLAY Employee-Rec.
   DELETE Employee-Rec ALL.
   IF ERROR-STATUS NOT = 0
	DISPLAY "Deletion failed"
   ELSE
	DISPLAY "Deleted"
	FIND CURRENT OF Employee-Head-Rec RECORD.
	GET Employee-Head-Rec
	SET Num-of-Emp DOWN BY 1
	MODIFY Employee-Head-Rec Num-of-Emp
	IF ERROR-STATUS Not = 0 AND NOT OK
		GO TO DELETE-EMPLOYEE-EXIT.

DELETE-EMPLOYEE-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         D I S P L A Y - E M P L O Y E E                        *
*                                                                *
******************************************************************

DISPLAY-EMPLOYEE.
   DISPLAY "DISPLAY EMPLOYEE--Type employee number>" WITH NO ADVANCING.
   ACCEPT Emp-Num.
   FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "???No employee-head ???"
	SET DONE TO TRUE
	GO TO DISPLAY-EMPLOYEE-EXIT.
   ENTER MACRO FINS6 USING "EMPLOYEE-Rec","EMPLOYEE-HEAD".
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Employee ",Emp-Num," not found ???"
        DISPLAY "??? TYPE 'R' TO RETRY >" WITH NO ADVANCING
        ACCEPT Function
        IF Function NOT = "R" GO TO DISPLAY-EMPLOYEE-EXIT
	ELSE GO TO DISPLAY-EMPLOYEE.
   GET Employee-Rec
   IF ERROR-STATUS NOT = 0
	DISPLAY "??? NO EMPLOYEE RECORD ???"
	GO TO DISPLAY-EMPLOYEE-EXIT.
   DISPLAY "EMPLOYEE # ",Emp-Num.
   DISPLAY "NAME: ", Emp-Name.
   DISPLAY"ADDRESS: ",Emp-Address.
   DISPLAY "SICK LEAVE: ", Emp-Sick-Leave.
   DISPLAY "VACATION: ", Emp-Vacation.
   DISPLAY "WAGE: ", Emp-Hour-Wage.
   DISPLAY "++++++++++++++++".
   FIND FIRST Spouse-Rec RECORD OF Family SET.
   IF ERROR-STATUS NOT = 0 GO TO DISPLAY-CHILDREN.
   DISPLAY"SPOUSE:".
   GET Spouse-Rec.
   DISPLAY Spouse-Name.
DISPLAY-CHILDREN.
   FIND FIRST Child-Rec RECORD OF Family SET.
   IF ERROR-STATUS NOT = 0 GO TO DISPLAY-EMPLOYEE-EXIT.
   GET Child-Rec.
   DISPLAY "CHILDREN:".
   DISPLAY Child-Name.
DISPLAY-CHILDREN-LOOP.
   FIND NEXT Child-Rec RECORD OF Family SET.
   IF ERROR-STATUS NOT = 0 GO TO DISPLAY-EMPLOYEE-EXIT.
   GET Child-Rec.
   DISPLAY Child-Name.
   GO TO DISPLAY-CHILDREN-LOOP.
DISPLAY-EMPLOYEE-EXIT.
******************************************************************
*                                                                *
*         L I S T - E M P L O Y E E S                            *
*                                                                *
******************************************************************

LIST-EMPLOYEES.
   FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? No employee-head ???"
	SET DONE TO TRUE
	GO TO LIST-EMPLOYEES-EXIT.
   FIND FIRST EMPLOYEE-REC RECORD OF EMPLOYEE-HEAD SET.
   IF ERROR-STATUS NOT = 0 AND END-OF-SET,
	DISPLAY "--- No Employees in Data Base ---"
	GO TO LIST-EMPLOYEES-EXIT
   ELSE IF ERROR-STATUS NOT = 0 AND NOT OK,
		GO TO LIST-EMPLOYEES-EXIT.
   GET Employee-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	GO TO LIST-EMPLOYEES-EXIT.
   DISPLAY Emp-Num,"             ",Emp-Name.

LIST-EMPLOYEES-LOOP.
   FIND NEXT Employee-Rec RECORD OF Employee-Head SET.
   IF ERROR-STATUS = 0 OR OK,
	GET Employee-Rec
	IF ERROR-STATUS = 0 OR OK,
		DISPLAY Emp-Num,"             ",Emp-Name
        GO TO LIST-EMPLOYEES-LOOP.   

LIST-EMPLOYEES-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         A D D - S P O U S E                                    *
*                                                                *
******************************************************************

ADD-SPOUSE.
   DISPLAY "ADD SPOUSE -- Type employee number>" WITH NO ADVANCING.
   ACCEPT Emp-Num.
   FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? No employee-head ???"
	SET DONE TO TRUE
	GO TO ADD-SPOUSE-EXIT.
   ENTER MACRO FINS6 USING "Employee-Rec", "Employee-Head".
   IF ERROR-STATUS NOT = 0,
	DISPLAY "Employee not found"
	GO TO ADD-SPOUSE-EXIT.
   DISPLAY "Type spouse's last name: " WITH NO ADVANCING.
   ACCEPT Last-name OF Spouse-Name.
   DISPLAY "Type spouse's first name: " WITH NO ADVANCING.
   ACCEPT First-Name OF Spouse-Name.
   DISPLAY "Type spouse's middle initial: " WITH NO ADVANCING.
   ACCEPT Middle-Initial OF Spouse-Name.
   DISPLAY "Type spouse's date of birth: " WITH NO ADVANCING.
   ACCEPT S-Date-of-Birth.
   DISPLAY "Type spouse's sex: " WITH NO ADVANCING.
   ACCEPT Spouse-Sex.
   STORE Spouse-Rec.
   IF ERROR-STATUS = 0
	DISPLAY "Spouse added"
   ELSE
	DISPLAY "Spouse not added".

ADD-SPOUSE-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         A D D - C H I L D                                      *
*                                                                *
******************************************************************

ADD-CHILD.
   DISPLAY "ADD CHILD -- Type employee number>" WITH NO ADVANCING.
   ACCEPT Emp-Num.
   FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? No employee-head ???"
	SET DONE TO TRUE
	GO TO ADD-CHILD-EXIT.
   ENTER MACRO FINS6 USING "Employee-Rec", "Employee-Head".
   IF ERROR-STATUS NOT = 0,
	DISPLAY "Employee not found"
	GO TO ADD-CHILD-EXIT.
   DISPLAY "Type child's last name: " WITH NO ADVANCING.
   ACCEPT Last-Name OF Child-Name.
   DISPLAY "Type child's first name: " WITH NO ADVANCING.
   ACCEPT First-Name of Child-Name.
   DISPLAY "Type child's middle initial: " WITH NO ADVANCING.
   ACCEPT Middle-Initial OF Child-Name.
   DISPLAY "Type child's date of birth: " WITH NO ADVANCING.
   ACCEPT Date-of-Birth.
   DISPLAY "Type child's sex: " WITH NO ADVANCING.
   ACCEPT Child-sex.
   STORE Child-Rec.
   IF ERROR-STATUS = 0
	DISPLAY "Child added"
   ELSE
	DISPLAY "Child not added".

ADD-CHILD-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         E X I T - P A R A                                      *
*                                                                *
******************************************************************

EXIT-PARA.
   SET DONE TO TRUE.
   GO TO DISPATCH-EXIT.
******************************************************************
*                                                                *
*         I N V A L I D - R E S P O N S E - P A R A              *
*                                                                *
******************************************************************

INVALID-RESPONSE-PARA.
   DISPLAY " ".
   DISPLAY Function, " is not defined."
******************************************************************
*                                                                *
*         H E L P - P A R A                                      *
*                                                                *
******************************************************************

HELP-PARA.
   DISPLAY "  ".
   DISPLAY "The Menus you may call are:".
   DISPLAY "CL	CLASSIFICATION".
   DISPLAY "	Add Classification".
   DISPLAY "	Delete Classification".
   DISPLAY "	List all classifications".
   DISPLAY "CU	CUSTOMERS".
   DISPLAY "	List all customers and orders".
   DISPLAY "	List all customers".
   DISPLAY "	List one customer and his orders".
   DISPLAY "DE	DEPARTMENT".
   DISPLAY "	Add Department".
   DISPLAY "	Change department".
   DISPLAY "	Delete Department".
   DISPLAY "	List departments".
   DISPLAY "EM	EMPLOYEE".
   DISPLAY "	Add Employee".
   DISPLAY "	Delete Employee".
   DISPLAY "	Display employees".
   DISPLAY "	Change Employee".
   DISPLAY "	Add Spouse".
   DISPLAY "	Add Child".
   DISPLAY "OR	ORDER PROCESSING".
   DISPLAY "PA	PARTS".
   DISPLAY "	Add part".
   DISPLAY "	Delete part".
   DISPLAY "	List parts".
   DISPLAY "	Show part".
   DISPLAY "ST	STATISTICS".
   DISPLAY "	Type Statistics on Terminal".
   DISPLAY "	Write Statistics to Variable".
   DISPLAY "TR	TRUCKS".
   DISPLAY "	Add Truck Route".
   DISPLAY "	Delete Truck Route".
   DISPLAY "	List Truck Routes".
   DISPLAY "	Show One Truck and Items on it".
   DISPLAY "  ".
   DISPLAY "The non-Menu Functions are:".
   DISPLAY "  ".
   DISPLAY "EX	Conclude Session".
   DISPLAY "HE	Type these Messages".
   DISPLAY "IN	Initialize Header Records".
   DISPLAY "ME	Type abbreviated command list".
   DISPLAY "MS	Set exception messages".
   DISPLAY "  ".

HELP-END.
   GO TO DISPATCH-EXIT.
******************************************************************
*                                                                *
*         M E N U - P A R A                                      *
*                                                                *
******************************************************************

MENU-PARA.
   DISPLAY "Available menus and functions are:".
   DISPLAY "	CL: AD, DE, HE, LI".
   DISPLAY "	CU: AL, HE, LA, LO".
   DISPLAY "	DE: AD, CH, DE, LI, HE".
   DISPLAY "	EM: AC, AD, AS, CH, DE, DI, HE, LI".
   DISPLAY "	EX".
   DISPLAY "	HE".
   DISPLAY "	IN".
   DISPLAY "	ME".
   DISPLAY "	MS".
   DISPLAY "	OR".
   DISPLAY "	PA: AD, DE, HE, LI, SH".
   DISPLAY "	ST: TE, VA".
   DISPLAY "	TR".
   DISPLAY " ".
   GO TO DISPATCH-EXIT.
******************************************************************
*                                                                *
*         I N I T - P A R A                                      *
*                                                                *
******************************************************************

INIT-PARA.
   SET Last-Order-Num TO 0
   STORE Number-of-Last-Order-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "Number of last order record not stored"
	GO TO DISPATCH-EXIT.
   SET Num-of-Cust TO 0.
   STORE Cust-Head-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "Cust-Head not stored."
        GO TO DISPATCH-EXIT.
   DISPLAY "Cust-Head stored."
   SET Num-of-Emp TO 0.
   STORE Employee-Head-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "Employee-Head not stored."
	GO TO DISPATCH-EXIT.
   DISPLAY "Employee-Head stored."
   SET Num-of-Parts TO 0.
   STORE Part-Head-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "Part-Head not stored."
        GO TO DISPATCH-EXIT.
   DISPLAY "Part-Head stored."
   SET Num-of-PO TO 0.
   STORE Purchase-Order-Head-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "Purchase-Order-Head not stored."
	GO TO DISPATCH-EXIT.
   SET Num-Work-Orders TO 0.
   STORE Work-Order-Head-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "Work-Order-Head not stored."
   ELSE DISPLAY "Work-Order-Head stored."
   GO TO DISPATCH-EXIT.
******************************************************************
*                                                                *
*         E X C E P T I O N - M S G - P A R A                    *
*                                                                *
* This routine is called to determine whether the user wants to  *
* the complete error messages or only the exception codes.       *
*                                                                *
******************************************************************

EXCEPTION-MSG-PARA.
   DISPLAY " ".
   DISPLAY "Do you want to receive exception messages?".
   DISPLAY "Type Y or N >" WITH NO ADVANCING.
   ACCEPT Function.
   IF Function = "Y" OR "YE"
	SET EXCEPTION-MSGS TO TRUE
   ELSE SET EXCEPTION-MSGS TO FALSE.

EXCEPTION-MSG-EXIT.
   GO TO DISPATCH-EXIT.
******************************************************************
*                                                                *
*         O R D E R - P R O C E S S - P A R A                    *
*                                                                *
******************************************************************

ORDER-PROCESS-PARA.
   DISPLAY "ORDER-PROCESSOR--Type customer number>" WITH NO ADVANCING.
   ACCEPT Cust-Num.
   IF Cust-Num = "@" GO TO ORDER-PROCESS-EXIT.
   IF Cust-Num = "?" OR "HE"
	DISPLAY "HELP--Type a five-digit customer number"
	GO TO ORDER-PROCESS-PARA.
   ENTER MACRO FINS6 USING "Customer-Rec","Cust-Head".
   IF ERROR-STATUS = 0 OR OK,
	GO TO PROCESS-ORDER.
   IF ERROR-STATUS = 0 OR NOT NO-SUCH-KEY,
	GO TO ORDER-PROCESS-EXIT.
   DISPLAY "This is the first time that the customer has placed an order".
   DISPLAY "The Customer-number that you typed is ",Cust-Num.
   DISPLAY " ".
   DISPLAY "Type Y if this is the right number".
   DISPLAY "Type R if you wish to reenter the number.".
   DISPLAY "Anything else aborts >" WITH NO ADVANCING.
   ACCEPT Function.
   IF Function = "R" OR "RE" GO TO ORDER-PROCESS-PARA.
   IF FUNCTION NOT = "Y" AND FUNCTION NOT = "YE"
	GO TO ORDER-PROCESS-EXIT.
   DISPLAY "ORDER PROCESSOR--Type customer's name>" WITH NO ADVANCING.
   ACCEPT Cust-Name.
   IF Cust-Name = "@" GO TO ORDER-PROCESS-EXIT.
   DISPLAY "ORDER PROCESSOR--Type customer's street>" WITH NO ADVANCING.
   ACCEPT Cust-Street.
   IF Cust-Street = "@" GO TO ORDER-PROCESS-EXIT.
   DISPLAY "ORDER PROCESSOR--Type customer's city>" WITH NO ADVANCING.
   ACCEPT Cust-City.
   IF Cust-City = "@" GO TO ORDER-PROCESS-EXIT.
   DISPLAY "ORDER PROCESSOR--Type customer's state>" WITH NO ADVANCING.
   ACCEPT Cust-State.
   IF Cust-State = "@" GO TO ORDER-PROCESS-EXIT.
   DISPLAY "ORDER PROCESSOR--Type customer's zip code>" WITH NO ADVANCING.
   ACCEPT Cust-Zip.
   MOVE 999 TO Cust-Rating.
   PERFORM CONVERT-ZIP-TO-ROUTE.
   SET Cust-Size TO 0.
   MOVE ZERO TO Cust-Balance.
   FIND FIRST Cust-Head-Rec RECORD OF Cust-Head-Sys SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? No Cust-Head ???"
	GO TO ORDER-PROCESS-EXIT.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	GO TO ORDER-PROCESS-EXIT.
   SET Num-of-Cust UP BY 1.
   MODIFY Cust-Head-Rec Num-of-Cust.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Unable TO CHANGE NUMBER OF CUSTOMERS"
	GO TO ORDER-PROCESS-EXIT.
   STORE Customer-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Unable to add new customer ???"
	GO TO ORDER-PROCESS-EXIT.

PROCESS-ORDER.
   FIND FIRST Number-of-Last-Order-Rec RECORD OF Head-Area AREA.
   GET Number-of-Last-Order-Rec.
   SET Last-Order-Num UP BY 1.
   MODIFY Number-of-Last-Order-Rec Last-Order-Num.
   SET Ord-Num TO Last-Order-Num.
   DISPLAY "ORDER PROCESSOR--Type today's date> " WITH NO ADVANCING.
   ACCEPT Ord-Entered-Date.
   DISPLAY "ORDER PROCESSOR--Type date when customer expects shipment> "
	WITH NO ADVANCING.
   ACCEPT Ord-Due-Date.
   STORE Order-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	GO TO ORDER-PROCESS-EXIT.
   FIND FIRST Part-Head-Rec RECORD OF Part-Head-Sys SET.
   IF ERROR-STATUS NOT = 0
	DISPLAY "??? No part head ???"
	GO TO ORDER-PROCESS-EXIT.
   SET ITEM-FLAG TO TRUE.
   FIND FIRST Part-Head-Rec RECORD OF Part-Head-Sys SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Part-Head not found ???"
	GO TO ORDER-PROCESS-EXIT.
   GET Part-Head-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	GO TO ORDER-PROCESS-EXIT.

REDO-PART-NUMBER.
   DISPLAY "ORDER PROCESSOR--Type part number>" WITH NO ADVANCING.
   ACCEPT Item-Part.
   IF Item-Part = "@" GO TO END-ORDER.
   MOVE Item-Part TO Part-Num.
   ENTER MACRO FINS6 USING "Part-Rec","Part-Head".
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Illegal part number, please retype ???"
	GO TO REDO-PART-NUMBER.
   GET Part-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	GO TO ORDER-PROCESS-EXIT.
   DISPLAY "Is ", Part-name, " correct? Type Y or N >" WITH NO ADVANCING.
   ACCEPT Function.
   IF Function = "N " OR "NO" GO TO REDO-PART-NUMBER.
   DISPLAY "ORDER PROCESSOR--Type quantity requested >" WITH NO ADVANCING.
   ACCEPT Item-Qty.
   IF Item-Qty < 0 GO TO ORDER-PROCESS-EXIT.
   MULTIPLY Item-Qty BY Part-Price GIVING Item-Price
   ADD Item-Price TO Ord-Cost.
   SUBTRACT Item-Qty FROM Part-Available GIVING Part-Req-Reserved.
   IF Part-Req-Reserved NOT < 0 GO TO ENOUGH-STOCKED.
	FIND CURRENT Part-Rec RECORD.
	MOVE Part-Lead-Time TO WS-Part-Lead-Time.
	DISPLAY "There are not enough in stock.".
	DISPLAY "More are being ordered.".
	MULTIPLY -1 BY Part-Req-Reserved.
	ADD Part-Req-Reserved TO Part-Ordered.
	SET Part-Reserved UP BY Part-Available.
	MOVE 0 TO Part-Available.
	MODIFY Part-Rec Part-Available,Part-Reserved,Part-Ordered.
	PERFORM SHIPPING-DATE THRU SHIPPING-DATE-EXIT.
	IF MORE-ITEMS GO TO NEXT-ITEM-2.
	GO TO END-ORDER.
ENOUGH-STOCKED.
   FIND CURRENT Part-Rec RECORD.
   MOVE 0 TO WS-Part-Lead-Time.
   DISPLAY "There are enough stocked to fill item.".
   SUBTRACT Item-Qty FROM Part-Available.
   ADD Item-Qty TO Part-Reserved.
   MODIFY Part-Rec Part-Available,Part-Reserved.
   PERFORM SHIPPING-DATE THRU SHIPPING-DATE-EXIT.
   IF MORE-ITEMS GO TO NEXT-ITEM-2.

* HERE WHEN ALL ITEMS ARE TYPED

END-ORDER.
   MOVE 0 TO Part-Req-Reserved.
   FIND CURRENT Order-Rec RECORD.
   GET Order-Rec.
   DISPLAY "ORDER PROCESSOR--Type Ammount Billed> " WITH NO ADVANCING.
   ACCEPT Ord-Amt-Billed.
   SUBTRACT Ord-Amt-Billed FROM Ord-Cost GIVING Ord-Amt-Outstand.
   DISPLAY "AMMOUNT OUTSTANDING IS *** ",Ord-Amt-Outstand.
   DISPLAY "This is order number ", Ord-Num.
   MODIFY Order-Rec Ord-Amt-Billed, Ord-Amt-Outstand.
   FIND CURRENT OF Customer-Rec RECORD.
   GET Customer-Rec.
   ADD Ord-Amt-Outstand TO Cust-Balance.
   MODIFY Customer-Rec Cust-Balance.
   MOVE 0 TO Ord-Cost.
   GO TO ORDER-PROCESS-EXIT.

NEXT-ITEM-2.
   FIND CURRENT Part-Rec RECORD.
   FIND CURRENT Order-Rec RECORD.
   SET ITEM-FLAG TO FALSE.
   ADD 1 TO Temp-Items.
   DISPLAY "ORDER PROCESSOR--Are there additional items? Type Y or N >"
	WITH NO ADVANCING.
   ACCEPT Function.
   IF Function = "Y" OR "YE"
	SET ITEM-FLAG TO TRUE
        GO TO REDO-PART-NUMBER.
   GO TO END-ORDER.

ORDER-PROCESS-EXIT.
   GO TO DISPATCH-EXIT.
******************************************************************
*                                                                *
*         P A R T - P A R A                                      *
*                                                                *
******************************************************************

PART-PARA.
   PERFORM PART-HELP.
   DISPLAY "PART-MENU>" WITH NO ADVANCING.
   ACCEPT Function.
   IF Function = "AD" PERFORM ADD-PART THROUGH ADD-PART-EXIT
	ELSE
   IF Function = "DE" PERFORM DELETE-PART THROUGH DELETE-PART-EXIT
	ELSE
   IF Function = "?" OR "HE" GO TO PART-PARA
	ELSE
   IF Function = "LI" PERFORM LIST-PARTS THROUGH LIST-PARTS-EXIT
	ELSE
   IF Function = "SH" PERFORM SHOW-PART THROUGH SHOW-PART-EXIT
	ELSE
   IF Function = "@" GO TO DISPATCH-EXIT
	ELSE
   DISPLAY Function, " is undefined???"
	GO TO PART-PARA.
   GO TO DISPATCH-EXIT.
******************************************************************
*                                                                *
*         P A R T - H E L P                                      *
*                                                                *
******************************************************************

PART-HELP.
   DISPLAY " ".
   DISPLAY "@	Abort and return to THEME-MAIN-MENU".
   DISPLAY " ?	Display this message".
   DISPLAY "AD	Add part".
   DISPLAY "DE	Delete part".
   DISPLAY "HE	Display this message".
   DISPLAY "LI	List parts".
   DISPLAY "SH	Show one part".
   DISPLAY " ".
******************************************************************
*                                                                *
*         A D D - P A R T                                        *
*                                                                *
******************************************************************

ADD-PART.
   DISPLAY " ".
   DISPLAY "ADD PART -- Type part number>" WITH NO ADVANCING.
   ACCEPT Part-Num.
   FIND FIRST Part-Head-Rec RECORD OF Part-Head-Sys SET.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Part-Head not found ???"
	GO TO ADD-PART-EXIT.
   GET Part-Head-Rec.
   FIND Part-Rec VIA CURRENT OF Part-Head USING Part-Num.
   IF ERROR-STATUS  EQUAL TO 0
	DISPLAY "This part already exists"
	GO TO ADD-PART-EXIT
   ELSE IF NOT NO-SUCH-KEY
	DISPLAY "??? Unable to find record ???"
	GO TO ADD-PART-EXIT.
   SET Num-of-Parts UP BY 1.
   MODIFY Part-Head-Rec Num-of-Parts.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	GO TO ADD-PART-EXIT.
   DISPLAY "ADD PART -- Type part name>" WITH NO ADVANCING.
   ACCEPT Part-Name.
   DISPLAY "ADD PART -- Type quantity available>" WITH NO ADVANCING.
   ACCEPT Part-Available.
   DISPLAY "ADD PART -- Type quantity reserved>" WITH NO ADVANCING.
   ACCEPT Part-Reserved.
   DISPLAY "ADD PART -- Type quantity ordered>" WITH NO ADVANCING.
   ACCEPT Part-Ordered.

   DISPLAY "ADD PART -- Type lead time>" WITH NO ADVANCING.
   ACCEPT Part-Lead-Time.
   DISPLAY "ADD PART -- Type cost>" WITH NO ADVANCING.
   ACCEPT Part-Std-Cost.
   COMPUTE Part-Price = 1.5 * Part-Std-Cost.
   DISPLAY "Price will be ", Part-Price.
   STORE Part-Rec.
   IF ERROR-STATUS = 0 OR OK
	DISPLAY "*** Part stored ***"
	ELSE DISPLAY "??? Part not stored ???".

   ADD-PART-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         D E L E T E - P A R T                                  *
*                                                                *
******************************************************************

DELETE-PART.
   DISPLAY "DELETE PART -- Type part number>" WITH NO ADVANCING.
   ACCEPT Part-Num.
   FIND FIRST Part-Head-Rec RECORD OF Part-Head-Sys SET.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? No Part-Head ???"
	GO TO DELETE-PART-EXIT.
   ENTER MACRO FINS6 USING "Part-Rec", "Part-Head".
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "Part not found"
	GO TO DELETE-PART-EXIT.
   DELETE Part-Rec ALL.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Deletion failed ???"
	GO TO DELETE-PART-EXIT.
   DISPLAY "Deleted".
   FIND CURRENT OF Part-Head-Rec RECORD.
   IF ERROR-STATUS NOT = 0,
	GO TO DELETE-PART-EXIT.
   GET Part-Head-Rec.
   IF ERROR-STATUS NOT = 0,
	GO TO DELETE-PART-EXIT.
   SET Num-of-Parts DOWN BY 1.
   MODIFY Part-Head-Rec Num-of-Parts.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	GO TO DELETE-PART-EXIT.

DELETE-PART-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         L I S T - P A R T S                                    *
*                                                                *
******************************************************************

LIST-PARTS.
   FIND FIRST Part-Head-Rec RECORD OF Part-Head-Sys SET.
   GET Part-Head-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? No Part-Head ???"
	GO TO LIST-PARTS-EXIT.
   FIND FIRST Part-Rec RECORD OF Part-Head SET.
   IF ERROR-STATUS NOT = 0 AND NO-SUCH-KEY,
	DISPLAY "--- No parts in database ---"
	GO TO LIST-PARTS-EXIT.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	GO TO LIST-PARTS-EXIT.
   GET Part-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	GO TO LIST-PARTS-EXIT.
   DISPLAY Part-Num, " ", Part-Name.

LIST-PARTS-LOOP.
   FIND NEXT Part-Rec RECORD OF Part-Head SET.
   IF ERROR-STATUS = 0 OR OK,
	GET Part-Rec
	IF ERROR-STATUS = 0 OR OK,
		DISPLAY Part-Num, " ", Part-Name
	GO TO LIST-PARTS-LOOP.


LIST-PARTS-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         S H O W - P A R T                                      *
*                                                                *
******************************************************************

SHOW-PART.
   DISPLAY "SHOW PART -- Type part number>" WITH NO ADVANCING.
   ACCEPT Part-Num.
   FIND FIRST Part-Head-Rec RECORD OF Part-Head-Sys SET.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? No Part-Head ???"
	GO TO SHOW-PART-EXIT.
   ENTER MACRO FINS6 USING "Part-Rec", "Part-Head".
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Part ", Part-Num, " not found ???"
	DISPLAY "Type 'R' to retry>" WITH NO ADVANCING
	ACCEPT Function
	IF Function = "R" GO TO SHOW-PART
	ELSE GO TO SHOW-PART-EXIT
   ELSE
	GET Part-Rec
	IF ERROR-STATUS = 0,
	DISPLAY "PART NUMBER: ", Part-Num.
	DISPLAY "NAME: ", Part-Name.
	DISPLAY "AVAILABLE: ", Part-Available.
	DISPLAY "RESERVED: ", Part-Reserved.
	DISPLAY "ORDERED: ", Part-Ordered.
	DISPLAY "LEAD TIME: ", Part-Lead-Time.
	DISPLAY "PRICE: ", Part-Price.

SHOW-PART-EXIT.
******************************************************************
*                                                                *
*         C O N V E R T - Z I P - T O - R O U T E                *
*                                                                *
******************************************************************

CONVERT-ZIP-TO-ROUTE.
   DIVIDE Cust-Zip BY 1000 GIVING Cust-Route.
   DISPLAY "Customer is on route # " WITH NO ADVANCING.
   DISPLAY Cust-Route.
******************************************************************
*                                                                *
*         S H I P P I N G - D A T E                              *
*                                                                *
******************************************************************

SHIPPING-DATE.

   DISPLAY "Item can be sent ", WS-Part-Lead-Time WITH NO ADVANCING.
   DISPLAY " Days from now.".
   FIND CURRENT Customer-Rec RECORD.
   IF ERROR-STATUS NOT = 0 GO TO SHIPPING-DATE-EXIT.
   GET Customer-Rec.
   DISPLAY "This Customer is on route #", Cust-Route.
   MOVE Cust-Route TO Truck-Route.
   FIND Truck-Rec RECORD.
   IF ERROR-STATUS NOT = 0
	DISPLAY"NO TRUCKS CARRY THAT ROUTE.  ARRANGE TO ADD ONE."
	STORE Item-Rec
	GO TO RESET-LEAD.
   GET Truck-Rec.
   DISPLAY "The next truck scheduled on that route is on ",
   DISPLAY Truck-Date.
   IF Truck-Volume-Left = 0 
	DISPLAY "But it is full."
	STORE Item-Rec
	GO TO RESET-LEAD.
   DISPLAY "Do you want to reserve space on it? " WITH NO ADVANCING.
   ACCEPT FUNCTION.
   IF FUNCTION NOT = "Y" AND NOT = "YES"
		STORE Item-Rec
		GO TO RESET-LEAD.
	IF Truck-Volume-Left < Temp-Items
		DISPLAY "There Is Not Enough Room For Item"
		STORE Item-Rec
		GO TO RESET-LEAD.
	MOVE Truck-Date TO Item-Shipped-Date.
	SET Truck-Volume-Left DOWN BY Temp-Items.
	MODIFY Truck-Rec Truck-Volume-Left.
	DISPLAY"Shipment will be sent on ",Truck-Date.
	STORE Item-Rec.
	IF ERROR-STATUS NOT = 0
		DISPLAY "???UNABLE TO CHANGE TRUCK VOLUME???"
		GO TO RESET-LEAD.
	DISPLAY "*** Space Reserved ***".
RESET-LEAD.
   MOVE 0 TO Temp-Items.
SHIPPING-DATE-EXIT.
EXIT.
******************************************************************
*                                                                *
*         S T A T S - P A R A                                    *
*                                                                *
******************************************************************

STATS-PARA.
   DISPLAY " ".
   DISPLAY "HE	Print this message".
   DISPLAY "TE	Print Statistics on Terminal".
   DISPLAY "VA	Write Statistics to Variable".
   DISPLAY " ?	Print this message".
   DISPLAY "@	Abort".
   DISPLAY " ".
   DISPLAY "STATS-MENU>" WITH NO ADVANCING.
   ACCEPT Function.
   IF Function = "@" GO TO DISPATCH-EXIT.
   IF Function = "HE" OR "?" GO TO STATS-PARA.
   IF Function = "TE" ENTER MACRO STATS
*   ELSE IF Function "VA" ENTER MACRO STATS USING DATA-ITEM
   ELSE DISPLAY Function, " is not defined, reenter command"
        GO TO STATS-PARA.
   GO TO DISPATCH-EXIT.
******************************************************************
*                                                                *
*         T R U C K - P A R A                                    *
*                                                                *
******************************************************************

TRUCK-PARA.
   
   PERFORM TRUCK-HELP.
   DISPLAY "TRUCK-PARA>" WITH NO ADVANCING.
   ACCEPT Function.
   IF Function = "AD" PERFORM ADD-TRUCK THRU ADD-TRUCK-EXIT
	ELSE
   IF Function = "DE" PERFORM DELETE-TRUCK THRU DELETE-TRUCK-EXIT
	ELSE
   IF Function = "HE" OR "?" GO TO TRUCK-PARA
	ELSE
   IF Function = "LI" PERFORM LIST-TRUCKS THRU LIST-TRUCKS-EXIT
	ELSE
   IF Function = "SH" PERFORM LIST-TRUCK-ITEMS THRU LIST-TRUCK-ITEMS-EXIT
	ELSE
   IF Function = "@" GO TO DISPATCH-EXIT
	ELSE
   DISPLAY Function, " is undefined???"
	GO TO TRUCK-PARA.
   GO TO DISPATCH-EXIT.
******************************************************************
*                                                                *
*         T R U C K - H E L P                                    *
*                                                                *
******************************************************************

TRUCK-HELP.
   DISPLAY " ".
   DISPLAY "@   Abort and return to THEME-MAIN-MENU".
   DISPLAY " ?   Display this message".
   DISPLAY "AD  Add truck route".
   DISPLAY "DE  Delete truck route".
   DISPLAY "HE  Display this message".
   DISPLAY "LI  List truck routes".
   DISPLAY "SH  Show one truck and its contents".
   DISPLAY " ".
******************************************************************
*                                                                *
*         A D D - T R U C K                                      *
*                                                                *
******************************************************************
ADD-TRUCK.
   FIND FIRST Department-Rec RECORD IN Manufacturing-Area AREA.
   IF ERROR-STATUS NOT = 0
	DISPLAY "NO DEPARTMENT RECORD???"
	GO TO ADD-TRUCK-EXIT.
   DISPLAY "ADD TRUCK--Type 2 digit route #> " 	WITH NO ADVANCING.
   ACCEPT Truck-Route.
   FIND Truck-Rec RECORD.
   IF ERROR-STATUS  = 0 
	DISPLAY "There is already a truck on this route."
	GO TO ADD-TRUCK-EXIT.
   DISPLAY "ADD TRUCK--Type date truck will travel> " WITH NO ADVANCING.
   ACCEPT Truck-Date.
   DISPLAY "ADD TRUCK--Type capacity (in number of items)> ",
	WITH NO ADVANCING.
   ACCEPT Truck-Volume-Left.
   STORE Truck-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "???TRUCK-RECORD NOT STORED???"
   ELSE DISPLAY "*** Truck Record Stored ***".
ADD-TRUCK-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         D E L E T E - T R U C K                                *
*                                                                *
******************************************************************
DELETE-TRUCK.
   DISPLAY "DELETE TRUCK--Type route number> " WITH NO ADVANCING.
   ACCEPT Truck-Route.
   FIND Truck-Rec RECORD.
   IF ERROR-STATUS NOT = 0
	DISPLAY "This Route not entered."
	GO TO DELETE-TRUCK-EXIT.
   GET Truck-Rec.
   FIND FIRST Item-Rec RECORD OF Shipping SET.
   IF ERROR-STATUS NOT = 0
	DELETE Truck-Rec
	DISPLAY "*** TRUCK RECORD DELETED ***"
	GO TO DELETE-TRUCK-EXIT.
   DISPLAY "THIS TRUCK IS CARRYING ORDERS AND CANNOT BE DELETED.".
DELETE-TRUCK-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         L I S T - T R U C K S                                  *
*                                                                *
******************************************************************
LIST-TRUCKS.
   FIND FIRST Department-Rec RECORD OF Manufacturing-Area AREA.
   IF ERROR-STATUS NOT = 0
	DISPLAY "??? NO DEPARTMENT RECORDS ???"
	GO TO LIST-TRUCKS-EXIT.
   FIND FIRST Truck-Rec RECORD OF Truck SET.
   IF ERROR-STATUS NOT = 0
	DISPLAY "??? No Trucks in data base???"
	GO TO LIST-TRUCKS-EXIT.
   GET Truck-Rec.
   DISPLAY "ROUTE	DATE			VOLUME LEFT".
   DISPLAY Truck-Route,"	",Truck-Date,"		",Truck-Volume-Left.

LIST-TRUCK-LOOP.
   FIND NEXT Truck-Rec RECORD OF Truck SET.
   IF ERROR-STATUS NOT = 0 GO TO LIST-TRUCKS-EXIT.
   GET Truck-Rec.
   DISPLAY Truck-Route,"	",Truck-Date,"		",Truck-Volume-Left.
   GO TO LIST-TRUCK-LOOP.
LIST-TRUCKS-EXIT.
   EXIT.
******************************************************************
* 								 *
*	L I S T - T R U C K - I T E M S			 	 *
*								 *
******************************************************************

LIST-TRUCK-ITEMS.
   DISPLAY"TRUCK--Type Truck Route #> "WITH NO ADVANCING.
   ACCEPT Truck-Route.
   FIND Truck-Rec RECORD.
   IF ERROR-STATUS NOT = 0
	DISPLAY "TRUCK NOT FOUND"
	GO TO LIST-TRUCK-ITEMS-EXIT.
   GET Truck-Rec.
   DISPLAY "######## ROUTE ",Truck-Route," ########".
   FIND FIRST Item-Rec RECORD OF Shipping SET.
   IF ERROR-STATUS NOT = 0 
	DISPLAY "+++ NO ITEMS ON TRUCK +++"
	GO TO LIST-TRUCK-ITEMS-EXIT.
   GET Item-Rec.
   DISPLAY "PART: ",Item-Part, "		QTY: ",Item-Qty.
LIST-TRUCK-ITEMS-LOOP.
   FIND NEXT Item-Rec RECORD OF Shipping SET.
   IF ERROR-STATUS NOT = 0 GO TO LIST-TRUCK-ITEMS-EXIT.
   GET Item-Rec.
   DISPLAY "PART: ",Item-Part, "		QTY: ",Item-Qty.
   GO TO LIST-TRUCK-ITEMS-LOOP.

LIST-TRUCK-ITEMS-EXIT.
   EXIT.
******************************************************************
*                                                                *
*         N U M E R I C - C H E C K                              *
*                                                                *
******************************************************************

NUMERIC-CHECK.
   IF (WS-ARRAY (COUNTER) < "0" OR > "9")
	AND WS-ARRAY (COUNTER) NOT = " " SET BAD-NUMBER-FLAG TO TRUE.