Google
 

Trailing-Edge - PDP-10 Archives - DBMS-20_V6.0_bin_9-25-81 - sources/thecbl.cbl
There are 2 other files named thecbl.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 59 GO TO 60-MESSAGES.
	IF MESSAGE-TYPE IS GREATER THAN 49 GO TO 50-MESSAGES.
	IF MESSAGE-TYPE IS GREATER THAN 39 GO TO 40-MESSAGES.
	IF MESSAGE-TYPE IS GREATER THAN 29 GO TO 30-MESSAGES.
	IF MESSAGE-TYPE IS GREATER THAN 19 GO TO 20-MESSAGES.
	IF MESSAGE-TYPE IS GREATER THAN 9 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.

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.
   CLOSE TRANSACTION.

******************************************************************
*                                                                *
*  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.
   CLOSE TRANSACTION.
DISPATCH-EXIT-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" OPEN TRANSACTION CLASS-UPDATE
		      PERFORM ADD-CLASSIFICATION THROUGH
		      ADD-CLASSIFICATION-EXIT

   ELSE
   IF Function = "DE" OPEN TRANSACTION CLASS-UPDATE
		      PERFORM DELETE-CLASSIFICATION THROUGH
		      DELETE-CLASSIFICATION-EXIT
   
   ELSE
   IF Function = "?" OR "HE" GO TO CLASSIFICATION-PARA
   
   ELSE
   IF Function = "LI" OPEN TRANSACTION CLASS-RETRIEVAL
		      PERFORM LIST-CLASSIFICATION THROUGH
		      LIST-CLASSIFICATION-EXIT
      
   ELSE
   IF Function = "@" OPEN TRANSACTION DUMMY-TRANSACTION
		     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 
         DISPLAY Job-Class, " already stored"
         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
	GO TO DEL-TRAN
   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.

   GET Classification-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	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-CLASS-EMPLOYEE-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,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   REMOVE Employee-Rec  FROM Class-Employee.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Remove Error ???"
	GO TO DEL-TRAN.

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.
   GET Classification-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   FIND CURRENT Employee-Rec RECORD.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Employee Record Lost ???"
	GO TO DEL-TRAN.
   GET Employee-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   INSERT Employee-Rec INTO Class-Employee.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Insert Error ???"
	GO TO DEL-TRAN.
   GO TO DELETE-CLASS-EMPLOYEE-LOOP.

DELETE-CLASSIFICATION-DEL.
   MOVE SAVE-JOB-CLASS TO Job-Class.
   FIND Classification-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Classification-Rec Lost ???"
	GO TO DEL-TRAN.
   GET Classification-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   DELETE Classification-Rec.
   IF ERROR-STATUS = 0
	DISPLAY "*** Clasification Deleted ***"
   ELSE DISPLAY "??? Unable To Delete ???"
	GO TO DEL-TRAN.
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 ???"
	GO TO LIST-CLASSIFICATION-EXIT.
   DISPLAY "JOB-CLASS JOB-DESCRIPTION".
   DISPLAY "------------------------------------------------------------".
   GET Classification-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
        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 NOT = 0,
	DISPLAY "??? Get Error ???"
        GO TO LIST-CLASSIFICATION-EXIT.
   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" OPEN TRANSACTION CUSTOMER-RETRIEVAL
		      SET FLAGS TO FIRST-CUSTOMER-STATE
		      PERFORM CUSTOMERS-ALL THROUGH CUSTOMERS-ALL-EXIT
   ELSE
   IF Function = "LA" OPEN TRANSACTION CUSTOMER-RETRIEVAL
		      PERFORM LIST-ALL-CUSTOMERS 
		      THROUGH LIST-ALL-CUSTOMERS-EXIT
   ELSE
   IF Function = "LO" OPEN TRANSACTION CUSTOMER-RETRIEVAL
		      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".
   CLOSE TRANSACTION.
   GO TO CUSTOMER-PARA.

CUSTOMER-EXIT.
   OPEN TRANSACTION DUMMY-TRANSACTION.
   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 ???"
        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.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   DISPLAY " ".
   DISPLAY"*--------------------------------------------------------*"
   DISPLAY " ".
   DISPLAY Cust-Name.
   SET FLAGS TO MORE-ORDERS-STATE.
FIRST-ORDER.
   FIND FIRST Order-Rec RECORD OF Cust-Ord SET.
   IF ERROR-STATUS NOT = 0 AND NOT END-OF-SET,
	DISPLAY "??? No Orders Posted For This Customer ???"
	GO TO NEXT-CUST.
   GET Order-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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 FIRST-ITEM.
NEXT-ORDER.
   FIND NEXT Order-Rec RECORD OF Cust-Ord SET.
   IF ERROR-STATUS NOT = 0,
	GO TO NEXT-CUST.
   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,
	DISPLAY "??? Data Base Problems, Orders Recorded ???"
	DISPLAY "??? But NO Items On Order ???"
	GO TO NEXT-CUST.
   GET Item-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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 ???"
	GO TO LIST-ALL-CUSTOMERS-EXIT.

LIST-ALL-CUSTOMERS-LOOP.
   GET Customer-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   DISPLAY Cust-Num,"      ",Cust-Name.
   FIND NEXT Customer-Rec RECORD OF Cust-Head SET.
   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.
   FIND Customer-Rec VIA CURRENT OF Cust-Head USING Cust-Num.
   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,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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,
	DISPLAY "??? No Orders posted for this customer ???"
	GO TO LIST-ONE-CUSTOMER-EXIT.
NEXT-ORDER-1.
   GET Order-Rec.
   DISPLAY ">>>>>-----------------<<<<<".
   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,
	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.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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 = "@" OPEN TRANSACTION DUMMY-TRANSACTION
		     GO TO DISPATCH-EXIT
   ELSE
   IF Function = "AD" OPEN TRANSACTION DEPARTMENT-UPDATE
		      MOVE 0 TO FLAGS
		      PERFORM ADD-DEPARTMENT THROUGH ADD-DEPARTMENT-EXIT
   ELSE
   IF Function = "CH" OPEN TRANSACTION DEPARTMENT-UPDATE
		      PERFORM CHANGE-DEPARTMENT THROUGH ADD-DEPARTMENT-EXIT
   ELSE
   IF Function = "DE" OPEN TRANSACTION DEPARTMENT-UPDATE
		      PERFORM DELETE-DEPARTMENT THROUGH DELETE-DEPARTMENT-EXIT
   ELSE
   IF Function = "LI"OPEN TRANSACTION DEPARTMENT-RETRIEVAL
		      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 AND ERROR-STATUS NOT = 0,
	DISPLAY "??? Department Not Stored ???"
	GO TO ADD-DEPARTMENT-EXIT.

   IF NOT CHANGE-DEPT AND ERROR-STATUS = 0,
	DISPLAY "??? Department Already Stored ???"
	GO TO ADD-DEPARTMENT-EXIT.

   MOVE Dept-Num TO WS-Dept-Num.
   IF NOT CHANGE-DEPT GO TO REDO-DEPARTMENT-NAME.
   GET Department-Rec
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   DISPLAY Dept-Address, Dept-Phone

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.
   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
   ELSE STORE Department-Rec.
   IF ERROR-STATUS = 0 OR OK,
	DISPLAY "*** Department Record Stored (Modified) ***"
   ELSE DISPLAY "??? Department Record Not Stored (Modified) ???"
	DISPLAY "Your input was: ",Dept-Name," ",Dept-Address," ",Dept-Phone
	GO TO DEL-TRAN.
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 ???"
	GO TO DEL-TRAN.
   DISPLAY "*** Department Deleted ***".

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

LIST-DEPARTMENT.
   FIND FIRST Department-Rec RECORD OF Manufacturing-Area AREA.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? No Department Records Found ???"
	GO TO LIST-DEPARTMENT-EXIT.
   GET Department-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   DISPLAY "DEPARTMENT # ", Dept-Num, "   NAME: ", Dept-Name.
   DISPLAY Dept-Address,"     ", Dept-Phone.
   DISPLAY "--------------------------------------------------------------".
   IF ERROR-STATUS = 0 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 = "@" OPEN TRANSACTION DUMMY-TRANSACTION
		     GO TO DISPATCH-EXIT
   ELSE
   IF Function = "AC" OPEN TRANSACTION CHILD-UPDATE
		      PERFORM ADD-CHILD THROUGH ADD-CHILD-EXIT
   ELSE
   IF Function = "AD" OPEN TRANSACTION EMPLOYEE-UPDATE
		      MOVE 0 TO FLAGS
		      PERFORM ADD-EMPLOYEE THROUGH ADD-EMPLOYEE-EXIT
   ELSE
   IF Function = "AS" OPEN TRANSACTION SPOUSE-UPDATE
		      PERFORM ADD-SPOUSE THROUGH ADD-SPOUSE-EXIT
   ELSE
   IF Function = "CH" OPEN TRANSACTION EMPLOYEE-UPDATE
		      PERFORM CHANGE-EMPLOYEE THROUGH ADD-EMPLOYEE-EXIT
   ELSE
   IF Function = "DE" OPEN TRANSACTION EMPLOYEE-UPDATE
		      PERFORM DELETE-EMPLOYEE THROUGH DELETE-EMPLOYEE-EXIT
   ELSE
   IF Function = "DI" OPEN TRANSACTION EMPLOYEE-RETRIEVAL
		      PERFORM DISPLAY-EMPLOYEE THROUGH DISPLAY-EMPLOYEE-EXIT
   ELSE
   IF Function = "LI" OPEN TRANSACTION EMPLOYEE-RETRIEVAL
		      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,
		DISPLAY "??? Can't Modify # Of Employees ???"
		GO TO DEL-TRAN.
   FIND Employee-Rec VIA CURRENT OF Employee-Head USING Emp-Num.
   IF ERROR-STATUS NOT = 0 AND CHANGE-EMP,
	DISPLAY "Employee Not Stored"
	GO TO ADD-EMPLOYEE-EXIT.
   
   IF ERROR-STATUS = 0 AND NOT CHANGE-EMP,
	DISPLAY "Employee Already Stored"
	GO TO ADD-EMPLOYEE-EXIT.

   IF NOT CHANGE-EMP GO TO ACCEPT-EMPLOYEE.
   DISPLAY Emp-Name, Emp-Address.
   DISPLAY Emp-Sick-Leave, Emp-Vacation, Emp-Hour-Wage.

ACCEPT-EMPLOYEE.
   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.
   FIND Department-Rec RECORD
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "No Such Department, Modification Terminated."
	GO TO ADD-EMPLOYEE-EXIT.
   FIND Classification-Rec RECORD
   IF ERROR-STATUS NOT = 0,
	DISPLAY "NO SUCH CLASS, MODIFICATION TERMINATED."
	GO TO ADD-EMPLOYEE-EXIT.
   IF CHANGE-EMP MODIFY Employee-Rec
   ELSE STORE Employee-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Store (Modification) failed ???"
	ELSE DISPLAY "*** Employee record Stored (modified) ***"

   IF NOT MODIFIED GO TO ADD-EMPLOYEE-EXIT.
   REMOVE Employee-Rec FROM Employees.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Remove Error ???"
	GO TO DEL-TRAN.
   FIND Department-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Department Record Lost ???"
	GO TO DEL-TRAN.
   FIND CURRENT Employee-Rec RECORD.
   INSERT Employee-Rec INTO Employees.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Insertion into dept set failed ???"
	GO TO DEL-TRAN.	
   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.
   FIND Employee-Rec VIA CURRENT OF Employee-Head USING Emp-Num.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "Employee not found"
	GO TO DELETE-EMPLOYEE-EXIT.
   GET Employee-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   DISPLAY Employee-Rec.
   DELETE Employee-Rec ALL.
   IF ERROR-STATUS NOT = 0
	DISPLAY "Deletion failed"
	GO TO DEL-TRAN.
   DISPLAY "*** Employee 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
	DISPLAY "??? Modify Error ???"
	GO TO DEL-TRAN.

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.
   FIND Employee-Rec VIA CURRENT OF Employee-Head USING Emp-Num.
   IF ERROR-STATUS NOT = 0,
	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 "??? Get Error ???"
	GO TO DEL-TRAN.
   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.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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
	DISPLAY "??? No Employees in Data Base ???"
	GO TO LIST-EMPLOYEES-EXIT.
   GET Employee-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   DISPLAY Emp-Num,"             ",Emp-Name.

LIST-EMPLOYEES-LOOP.
   FIND NEXT Employee-Rec RECORD OF Employee-Head SET.
   IF ERROR-STATUS NOT = 0 GO TO LIST-EMPLOYEES-EXIT.
   GET Employee-Rec
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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.
   FIND Employee-Rec VIA CURRENT OF Employee-Head USING Emp-Num.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "Employee not found"
	GO TO ADD-SPOUSE-EXIT.
   DISPLAY "SPOUSE--Type spouse's last name: " WITH NO ADVANCING.
   ACCEPT Last-name OF Spouse-Name.
   DISPLAY "SPOUSE--Type spouse's first name: " WITH NO ADVANCING.
   ACCEPT First-Name OF Spouse-Name.
   DISPLAY "SPOUSE--Type spouse's middle initial: " WITH NO ADVANCING.
   ACCEPT Middle-Initial OF Spouse-Name.
   DISPLAY "SPOUSE--Type spouse's date of birth: " WITH NO ADVANCING.
   ACCEPT S-Date-of-Birth.
   DISPLAY "SPOUSE--Type spouse's sex: " WITH NO ADVANCING.
   ACCEPT Spouse-Sex.
   STORE Spouse-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Can't Store Spouse ???"
	GO TO DEL-TRAN.
   DISPLAY "*** Spouse 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.
   FIND Employee-Rec VIA CURRENT OF Employee-Head USING Emp-Num.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "Employee not found"
	GO TO ADD-CHILD-EXIT.
   DISPLAY "CHILD--Type child's last name> " WITH NO ADVANCING.
   ACCEPT Last-Name OF Child-Name.
   DISPLAY "CHILD--Type child's first name> " WITH NO ADVANCING.
   ACCEPT First-Name of Child-Name.
   DISPLAY "CHILD--Type child's middle initial> " WITH NO ADVANCING.
   ACCEPT Middle-Initial OF Child-Name.
   DISPLAY "CHILD--Type child's date of birth> " WITH NO ADVANCING.
   ACCEPT Date-of-Birth.
   DISPLAY "CHILD--Type child's sex> " WITH NO ADVANCING.
   ACCEPT Child-sex.
   STORE Child-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Can't Store Child ???"
	GO TO DEL-TRAN.
   DISPLAY "*** Child Added ***".

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

EXIT-PARA.
   OPEN TRANSACTION DUMMY-TRANSACTION.
   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.
   IF Function NOT = "?" OPEN TRANSACTION DUMMY-TRANSACTION.
   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 "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.
   OPEN TRANSACTION DUMMY-TRANSACTION
   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.
   DISPLAY "This Function Has Been Removed".
   DISPLAY "Use THEINI Program To Initialize".
INIT-PARA-EXIT.
OPEN TRANSACTION DUMMY-TRANSACTION.
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.
   OPEN TRANSACTION DUMMY-TRANSACTION
   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 = "@" OPEN TRANSACTION DUMMY-TRANSACTION
	GO TO ORDER-PROCESS-EXIT.
   IF Cust-Num = "?" OR "HE"
	DISPLAY "HELP--Type a five-digit customer number"
	GO TO ORDER-PROCESS-PARA.

   OPEN TRANSACTION ORDER-UPDATE
   FIND Customer-Rec VIA CURRENT OF Cust-Head USING Cust-Num.
   IF ERROR-STATUS = 0 OR OK,
	GO TO PROCESS-ORDER.
   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 DEL-TRAN.
   STORE Customer-Rec.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Unable to add new customer ???"
	GO TO DEL-TRAN.

PROCESS-ORDER.
   FIND FIRST Number-of-Last-Order-Rec RECORD OF Head-Area AREA.
   GET Number-of-Last-Order-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   SET Last-Order-Num UP BY 1.
   MODIFY Number-of-Last-Order-Rec Last-Order-Num.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Modify Error ???"
	GO TO DEL-TRAN.
   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,
	DISPLAY "??? Store Error ???"
	GO TO DEL-TRAN.
   FIND FIRST Part-Head-Rec RECORD OF Part-Head-Sys SET.
   IF ERROR-STATUS NOT = 0
	DISPLAY "??? No part head ???"
	GO TO DEL-TRAN.
   SET ITEM-FLAG TO TRUE.
   GET Part-Head-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.

REDO-PART-NUMBER.
   DISPLAY "ORDER PROCESSOR--Type part number>" WITH NO ADVANCING.
   ACCEPT Item-Part.
   IF Item-Part = "@",
	DELETE TRANSACTION
	OPEN TRANSACTION DUMMY-TRANSACTION
	GO TO ORDER-PROCESS-EXIT.
   MOVE Item-Part TO Part-Num.
   FIND Part-Rec VIA CURRENT OF Part-Head USING Part-Num.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Illegal part number, please retype ???"
	DISPLAY "Type '@' To Abort"
	GO TO REDO-PART-NUMBER.
   GET Part-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   DISPLAY "Is ", Part-name, " correct? Type Y or N >" WITH NO ADVANCING.
   ACCEPT Function.
   IF Function NOT = "Y" AND NOT = "YE" GO TO REDO-PART-NUMBER.
   DISPLAY "ORDER PROCESSOR--Type quantity requested >" WITH NO ADVANCING.
   ACCEPT Item-Qty.
   IF Item-Qty < 0,
	DISPLAY "Illegal Entry, Please Retype From Part #"
	DISPLAY "Type '@' To Abort"
	GO TO REDO-PART-NUMBER.

   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 Part-Req-Reserved BY -1 GIVING 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.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Can't Find Current Part-Rec ???"
	GO TO DEL-TRAN.
   GET Part-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Can't Modify Part-Rec ???"
	GO TO DEL-TRAN.
   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.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Order Record Lost ???"
	GO TO DEL-TRAN.
   GET Order-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Modify Failure ???"
	GO TO DEL-TRAN.
   FIND CURRENT Customer-Rec RECORD.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Lost Customer Record ???"
	GO TO DEL-TRAN.
   GET Customer-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   ADD Ord-Amt-Outstand TO Cust-Balance.
   MODIFY Customer-Rec Cust-Balance.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Modify Failure ???"
	GO TO DEL-TRAN.
   MOVE 0 TO Ord-Cost.
   GO TO ORDER-PROCESS-EXIT.

NEXT-ITEM-2.
   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" OPEN TRANSACTION PART-UPDATE
		      PERFORM ADD-PART THROUGH ADD-PART-EXIT
   ELSE
   IF Function = "DE" OPEN TRANSACTION PART-UPDATE
		      PERFORM DELETE-PART THROUGH DELETE-PART-EXIT
   ELSE
   IF Function = "?" OR "HE" GO TO PART-PARA
   ELSE
   IF Function = "LI" OPEN TRANSACTION PART-RETRIEVAL
		      PERFORM LIST-PARTS THROUGH LIST-PARTS-EXIT
   ELSE
   IF Function = "SH" OPEN TRANSACTION PART-RETRIEVAL
		      PERFORM SHOW-PART THROUGH SHOW-PART-EXIT
   ELSE
   IF Function = "@" OPEN TRANSACTION DUMMY-TRANSACTION
	     	     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 ???"
	SET DONE TO TRUE
	GO TO ADD-PART-EXIT.
   GET Part-Head-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   FIND Part-Rec VIA CURRENT OF Part-Head USING Part-Num.
   IF ERROR-STATUS = 0,
	DISPLAY "This part already exists"
	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,
	DISPLAY "??? Modify Failure ???"
	GO TO DEL-TRAN.
   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 ???"
	GO TO DEL-TRAN.

   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.
   FIND Part-Rec VIA CURRENT OF Part-Head USING Part-Num.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "Part not found"
	GO TO DELETE-PART-EXIT.
   GET Part-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Failure ???"
	GO TO DEL-TRAN.
   DELETE Part-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Deletion failed ???"
	GO TO DEL-TRAN.
   DISPLAY "*** Part Deleted ***".
   FIND CURRENT OF Part-Head-Rec RECORD.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Part Head Record Lost ???"
	GO TO DEL-TRAN.
   GET Part-Head-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   SET Num-of-Parts DOWN BY 1.
   MODIFY Part-Head-Rec Num-of-Parts.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? Modify Failure ???"
	GO TO DEL-TRAN.

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.
   IF ERROR-STATUS NOT = 0 AND NOT OK,
	DISPLAY "??? No Part-Head ???"
	SET DONE TO TRUE
	GO TO LIST-PARTS-EXIT.
   GET Part-Head-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   FIND FIRST Part-Rec RECORD OF Part-Head SET.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? No parts in database ???"
	GO TO LIST-PARTS-EXIT.
   GET Part-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   DISPLAY Part-Num, " ", Part-Name.

LIST-PARTS-LOOP.
   FIND NEXT Part-Rec RECORD OF Part-Head SET.
   IF ERROR-STATUS NOT = 0 GO TO LIST-PARTS-EXIT.
   GET Part-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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 ???"
	SET DONE TO TRUE
	GO TO SHOW-PART-EXIT.
   FIND Part-Rec VIA CURRENT OF Part-Head USING Part-Num.
   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.
   GET Part-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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.
CONVERT-ZIP-TO-ROUTE-EXIT.
EXIT.
******************************************************************
*                                                                *
*         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,
	DISPLAY "??? Customer Lost ???"
	GO TO DEL-TRAN.
   GET Customer-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   DISPLAY "This Customer is on route #", Cust-Route.
   MOVE Cust-Route TO Truck-Route.
   FIND Truck-Rec RECORD.
   IF ERROR-STATUS = 0 GO TO TRUCK-ITEM.
   DISPLAY"No Trucks Carry That Route.  Arrange To Add One.".
   FIND CURRENT Order-Rec RECORD.
   IF ERROR-STATUS NOT = 0,
	DISPLAY"??? Order-Rec lost ???"
	GO TO DEL-TRAN.
   GET Order-Rec
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   STORE Item-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Cannot Store Item-Rec ???"
	GO TO DEL-TRAN.
   GO TO RESET-LEAD.
TRUCK-ITEM.
   GET Truck-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   DISPLAY "The next truck scheduled on that route is on " WITH NO ADVANCING.
   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 = "YE",
	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.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Modify Failure ???"
	GO TO DEL-TRAN.
   DISPLAY"Shipment will be sent on ",Truck-Date.
   STORE Item-Rec.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Can't Store Item ???"
	GO TO DEL-TRAN.
   INSERT Item-Rec INTO Shipping.
   IF ERROR-STATUS NOT = 0
	DISPLAY "??? UNABLE TO CHANGE TRUCK VOLUME ???"
	GO TO DEL-TRAN.
   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.
   OPEN TRANSACTION DUMMY-TRANSACTION
   ENTER MACRO STATS
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" OPEN TRANSACTION TRUCK-UPDATE
		      PERFORM ADD-TRUCK THRU ADD-TRUCK-EXIT
   ELSE
   IF Function = "DE" OPEN TRANSACTION TRUCK-UPDATE
		      PERFORM DELETE-TRUCK THRU DELETE-TRUCK-EXIT
   ELSE
   IF Function = "HE" OR "?" GO TO TRUCK-PARA
   ELSE
   IF Function = "LI" OPEN TRANSACTION TRUCK-RETRIEVAL
		      PERFORM LIST-TRUCKS THRU LIST-TRUCKS-EXIT
   ELSE
   IF Function = "SH" OPEN TRANSACTION TRUCK-RETRIEVAL
		      PERFORM LIST-TRUCK-ITEMS THRU LIST-TRUCK-ITEMS-EXIT
   ELSE
   IF Function = "@" OPEN TRANSACTION DUMMY-TRANSACTION
		     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???"
	GO TO DEL-TRAN.
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.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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.
   IF ERROR-STATUS NOT = 0,
	DISPLAY "??? Get Error ???"
	GO TO DEL-TRAN.
   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.
******************************************************************
*								 *
*	D E L E T E - T R A N S A C T I O N			 *
*								 *
******************************************************************

DEL-TRAN.
	DISPLAY "??? Unexpected Error , Deleting Transaction ???".
	DELETE TRANSACTION.
	IF ERROR-STATUS NOT = 0,
		DISPLAY "??? Cannot Delete Transaction, use DBMEND ???"
		SET DONE TO TRUE
		GO TO DISPATCH-EXIT.
	DISPLAY "Transaction Deleted".
	GO TO FINIS.