Trailing-Edge
-
PDP-10 Archives
-
DBMS-20_V6_BIN_19811001
-
sources/thec74.cbl
There are 2 other files named thec74.cbl in the archive. Click here to see a list.
IDENTIFICATION DIVISION.
PROGRAM-ID. DEMO.
AUTHOR. SOFTWARE DOCUMENTATION.
INSTALLATION. DEC-MARLBOROUGH.
DATE-WRITTEN. 1 APRIL 1980.
SECURITY. TRIVIAL.
*REMARKS.*
*******************************************************************
* *
* copyright (c) 1980 DIGITAL Equipment Corporation *
* *
* This program is for instructional purposes only; in order to *
* illustrate certain aspects of this software, this program may *
* contain constructs and practices that would not be suitable *
* for use in a production environment. DIGITAL Equipment Cor- *
* poration assumes no responsibility for any errors which may *
* exist in this program. *
* *
* This program was written by software documentation staff in *
* order to best explain concepts involved in using the DBMS DML. *
* As such, the primary consideration was writing code that is, *
* for the most part, as simple as possible. Consequently, the *
* approach taken was to write in-line code because, for the most *
* part, it can be easier to understand, albeit harder to main- *
* tain. *
* *
* A second major factor in the writing of this program was that *
* only one program could be written. This constraint was added *
* because the theme example programs are included on the dis- *
* tribution tape and we could only include one program there. *
* Consequently, the procedure shown here where everything is in- *
* cluded in one program is not one that should be followed by *
* users performing similar kinds of functions. *
* *
* Also, this program was written solely to demonstrate a *
* series of functions. While all these functions work, they *
* were not given the kind of load and performance testing that *
* should be, or are, given to true application software. *
* *
*******************************************************************
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. DECSYSTEM-20.
OBJECT-COMPUTER. DECSYSTEM-20.
DATA DIVISION.
SCHEMA SECTION.
INVOKE SUB-SCHEMA COBSYS OF SCHEMA Theme
PRIVACY KEY FOR COMPILE IS ACEDB.
WORKING-STORAGE SECTION.
***************************************************************
* *
* The following working storage declarations replicate ele- *
* ments contained in the schema. The reason for these de- *
* clarations is to receive user data without altering data *
* returned from the data base. In some cases, where the *
* information is numeric, the user can enter alphabetic and *
* the program makes the check for correctness rather than *
* the COBOL compiler. *
* *
***************************************************************
01 WS-Customer-Rec.
02 WS-Cust-Num PIC X(05) USAGE DISPLAY-7.
02 WS-Cust-Name PIC X(20) USAGE DISPLAY-7.
02 WS-Cust-Address PIC X(45) USAGE DISPLAY-7.
02 WS-Cust-Rating PIC X(05) USAGE DISPLAY-7.
02 WS-Cust-Route PIC 9(05) USAGE DISPLAY-7.
02 WS-Cust-Size PIC 9(10) USAGE DISPLAY-7.
02 WS-Cust-Balance PIC 9(08)V99 USAGE DISPLAY-7.
01 WS-Department-Rec.
02 WS-Dept-Num PIC 9(05) USAGE DISPLAY-7.
02 WS-Dept-Name PIC X(30) USAGE DISPLAY-7.
02 WS-Dept-Address.
03 WS-Dept-Internal-No PIC X(05) USAGE DISPLAY-7.
03 WS-Dept-Street PIC X(15) USAGE DISPLAY-7.
03 WS-Dept-City PIC X(15) USAGE DISPLAY-7.
03 WS-Dept-State PIC X(05) USAGE DISPLAY-7.
03 WS-Dept-Zip PIC X(10) USAGE DISPLAY-7.
02 WS-Dept-Phone PIC X(12) USAGE DISPLAY-7.
01 WS-Employee-Rec.
02 WS-Emp-Num PIC X(05) USAGE DISPLAY-7.
02 WS-Emp-Name.
03 WS-Emp-Last-Name PIC X(15) USAGE DISPLAY-7.
03 WS-Emp-First-Name PIC X(10) USAGE DISPLAY-7.
03 WS-Emp-Middle-Init PIC X(01) USAGE DISPLAY-7.
02 WS-Emp-Address.
03 WS-Emp-Street PIC X(15) USAGE DISPLAY-7.
03 WS-Emp-RFD-Apt PIC X(05) USAGE DISPLAY-7.
03 WS-Emp-City PIC X(15) USAGE DISPLAY-7.
03 WS-Emp-State PIC X(05) USAGE DISPLAY-7.
03 WS-Emp-Zip PIC X(10) USAGE DISPLAY-7.
02 WS-Emp-Sick-Leave PIC 9(05) USAGE DISPLAY-7.
02 WS-Emp-Vacation PIC 9(05) USAGE DISPLAY-7.
02 WS-Emp-Hour-Wage PIC 9(03)V99 USAGE DISPLAY-7.
01 WS-Item-Rec.
02 WS-Item-Part PIC X(05) USAGE DISPLAY-7.
02 WS-Item-Qty PIC 9(08)V99 USAGE DISPLAY-7.
02 WS-Item-Style PIC X(05) USAGE DISPLAY-7.
02 WS-Item-Fabric PIC X(20) USAGE DISPLAY-7.
02 WS-Item-Fabric-Num PIC 9(05) USAGE DISPLAY-7.
02 WS-Item-Wood-Finish PIC X(05) USAGE DISPLAY-7.
02 WS-Item-Ship PIC 9(05) USAGE DISPLAY-7.
02 WS-Item-Price PIC 9(08)V99 USAGE DISPLAY-7.
02 WS-Item-Weight PIC 9(08)V99 USAGE DISPLAY-7.
02 WS-Item-Volume PIC 9(08)V99 USAGE DISPLAY-7.
01 WS-Location-Part-Rec.
02 WS-Loc-Dept PIC 9(05) USAGE DISPLAY-7.
02 WS-Loc-Qty PIC 9(05) USAGE DISPLAY-7.
01 WS-Manager-Link-Rec.
02 WS-Num-Emp-Manage PIC S9(10) USAGE COMP.
01 WS-Order-Rec.
02 WS-Ord-Num PIC 9(10) USAGE DISPLAY-7.
02 WS-Ord-Due-Date PIC X(10) USAGE DISPLAY-7.
02 WS-Ord-Amt-Billed PIC 9(08)V99 USAGE DISPLAY-7.
02 WS-Ord-Amt-Outstand PIC 9(08)V99 USAGE DISPLAY-7.
02 WS-Ord-Ship-Method PIC X(01) USAGE DISPLAY-7.
01 WS-Part-Rec.
02 WS-Part-Num PIC X(05) USAGE DISPLAY-7.
02 WS-Part-Name PIC X(10) USAGE DISPLAY-7.
02 WS-Part-Available PIC 9(05) USAGE DISPLAY-7.
02 WS-Part-Reserved PIC 9(05) USAGE DISPLAY-7.
02 WS-Part-Ordered PIC 9(05) USAGE DISPLAY-7.
02 WS-Part-Req-Reserved PIC 9(05) USAGE DISPLAY-7.
02 WS-Part-Lead-Time PIC 9(05) USAGE DISPLAY-7.
02 WS-Part-Std-Cost PIC 9(08)V99 USAGE DISPLAY-7.
02 WS-Part-Price PIC 9(08)V99 USAGE DISPLAY-7.
01 WS-Truck-Rec.
02 WS-Truck-Route PIC 9(05) USAGE DISPLAY-7.
02 WS-Truck-Date PIC X(10) USAGE DISPLAY-7.
02 WS-Truck-Volume-Left PIC 9(08)V99 USAGE DISPLAY-7.
01 WS-Work-Item-Rec.
02 WS-WI-Time PIC 9(08)V99 USAGE DISPLAY-7.
02 WS-WI-Setup-Time PIC 9(08)V99 USAGE DISPLAY-7.
02 WS-WI-Operation PIC 9(05) USAGE DISPLAY-7.
02 WS-WI-Station PIC 9(05) USAGE DISPLAY-7.
01 WS-Work-Order-Rec.
02 WS-WO-Num PIC X(05) USAGE DISPLAY-7.
02 WS-WO-Qty PIC 9(08)V99 USAGE DISPLAY-7.
02 WS-WO-Count PIC 9(10) USAGE DISPLAY-7.
****************************************************************
* *
* The following declarations are for elements only used *
* with the program. *
* *
* When the user is at the top level of the program and types *
* a response, that response is compared to the values in *
* the following table. Each response is two characters *
* long. If the response is more than two characters, all *
* trailing characters are thrown away. The list of respon- *
* ses is kept in alphabetical order so that a binary search *
* may be made of them. *
* *
****************************************************************
01 RESPONSE-PROMPT USAGE DISPLAY-6.
02 RESPONSE-FILLER PIC X(42)
VALUE IS "CLCUDEEMEXHEINMEMSORPASTTR ".
01 RESPONSES-OF-USERS REDEFINES RESPONSE-PROMPT.
02 RESPONSE-TABLE USAGE DISPLAY-6
OCCURS 21 TIMES
ASCENDING KEY IS RESPONSE-TYPE
INDEXED BY RESPONSE-INDEX.
03 RESPONSE-TYPE PIC X(02).
* HOLDING ZONE FOR # OF ITEMS
01 Temp-Items PIC 9(03) USAGE DISPLAY-7.
***************************************************************
* *
* Variable to which ERROR-STATUS is written after an *
* exception. *
* *
***************************************************************
01 TEMP-STATUS USAGE DISPLAY-7.
02 FILLER PIC 9(01).
02 VERB-TYPE PIC 9(02).
02 MESSAGE-TYPE PIC 9(02).
* HOLDING ZONE FOR MOVE CURRENCY
01 TMP-CURR PIC X(30) USAGE DISPLAY-7.
* HOLDING ZONE FOR ORDER COST
01 Ord-Cost PIC 9(10)V99 USAGE DISPLAY-7.
***************************************************************
* *
* Conditions that may be set in DECLARATIVE section. *
* *
***************************************************************
01 EXCEPTION-FLAG PIC 9(01) USAGE DISPLAY-7.
88 OK VALUE 0.
88 RETRY VALUE 1.
88 END-OF-SET VALUE 2.
88 NO-SUCH-KEY VALUE 3.
88 FATAL VALUE 4.
01 EXCEPTION-STATES USAGE DISPLAY-6.
02 OK-STATE PIC 9(01) VALUE 0.
02 RETRY-STATE PIC 9(01) VALUE 1.
02 END-OF-SET-STATE PIC 9(01) VALUE 2.
02 NO-SUCH-KEY-STATE PIC 9(01) VALUE 3.
02 FATAL-STATE PIC 9(01) VALUE 4.
02 USER-REPLY-STATE PIC 9(01) VALUE 9.
****************************************************************
* *
* Miscellaneous switches *
* *
****************************************************************
01 FLAGS PIC 9(01).
88 MORE-ORDERS VALUE 2.
88 CHANGE-DEPT VALUE 4.
88 CHANGE-EMP VALUE 5.
88 FIRST-CUSTOMER VALUE 7.
01 STATES USAGE DISPLAY-6.
02 MORE-ORDERS-STATE PIC 9(01) VALUE 2.
02 CHANGE-DEPT-STATE PIC 9(01) VALUE 4.
02 CHANGE-EMP-STATE PIC 9(01) VALUE 5.
02 FIRST-CUSTOMER-STATE PIC 9(01) VALUE 7.
01 SWITCHES.
02 TRUE PIC 9(01) VALUE 1.
02 FALSE PIC 9(01) VALUE 0.
02 AFFIRMATIVE PIC 9(01) VALUE 1.
01 MODIFY-FLAG PIC 9(01).
88 MODIFIED VALUE 1.
01 DONE PIC 9(01).
88 FINISHED VALUE 1.
88 DECISION VALUE 9.
01 BAD-NUMBER-FLAG PIC 9(01).
88 BAD-NUMBER VALUE 1.
01 ITEM-FLAG PIC 9(01).
88 MORE-ITEMS VALUE 1.
01 EXCEPTION-MSGS PIC 9 VALUE 1.
88 PRINT-EXCEPTIONS VALUE 1.
***************************************************************
* *
* Used to check that user input only contains numbers *
* *
***************************************************************
01 WS-HOLD-ARRAY PIC X(12) USAGE DISPLAY-6.
01 WS-Num-Array REDEFINES WS-HOLD-ARRAY
OCCURS 12 TIMES.
02 WS-Array PIC x(01).
77 COUNTER PIC S9(03) USAGE COMPUTATIONAL.
77 FUNCTION PIC X(02) USAGE DISPLAY-6.
77 MODIFIED-STATE PIC 9(01) VALUE 1.
77 NON-MODIFIED-STATE PIC 9(01) VALUE 0.
77 TEMP-AREA PIC X(30) USAGE DISPLAY-7.
77 TEMP-FUNCTION PIC S9(06) USAGE COMPUTATIONAL.
77 TEMP-REC PIC X(30) USAGE DISPLAY-7.
77 SAVE-JOB-CLASS PIC X(05) USAGE DISPLAY-7.
PROCEDURE DIVISION.
DECLARATIVES.
*****************************************************************
* *
* Only the following exceptions are individually trapped: *
* *
* 0240 Simultaneous Update Collision *
* 0307 End-of-Set *
* 0326 No such CALC key *
* *
* All other exceptions are dealt with as follows: *
* *
* 1. The four digit exception number is moved to the *
* TEMP-STATUS variable. At the 02 level, it is *
* divided into two parts: VERB-TYPE and MESSAGE- *
* TYPE. *
* 2. The number for each is then deciphered to display *
* a discrete message. These messages are identical *
* to those in the DDL Manual. *
* *
*****************************************************************
EXCEPTION-DELETE SECTION.
USE ERROR-STATUS 0240.
PARA-240.
SET EXCEPTION-FLAG TO RETRY-STATE.
EXCEPTION-EXIT.
EXIT.
EXCEPTION-FIND-SET SECTION.
USE ERROR-STATUS 0307,0326.
PARA-300.
IF ERROR-STATUS EQUALS 307
SET EXCEPTION-FLAG TO END-OF-SET-STATE
ELSE
SET EXCEPTION-FLAG TO NO-SUCH-KEY-STATE.
FIND-EXIT.
EXIT.
EXCEPTION-OTHER SECTION.
USE ERROR-STATUS.
PARA-OTHER.
IF NOT PRINT-EXCEPTIONS GO TO END-MESSAGES.
MOVE ERROR-STATUS TO TEMP-STATUS.
IF VERB-TYPE EQUALS 0 DISPLAY "Host Verbs"
SET DONE TO TRUE
ELSE IF VERB-TYPE EQUALS 1 DISPLAY "Close Error"
SET DONE TO TRUE
ELSE IF VERB-TYPE EQUALS 2 DISPLAY "Delete Error"
SET DONE TO USER-REPLY-STATE
ELSE IF VERB-TYPE EQUALS 3 DISPLAY "Find Error"
SET DONE TO USER-REPLY-STATE
ELSE IF VERB-TYPE EQUALS 5 DISPLAY "Get Error"
SET DONE TO USER-REPLY-STATE
ELSE IF VERB-TYPE EQUALS 7 DISPLAY "Insert Error"
SET DONE TO USER-REPLY-STATE
ELSE IF VERB-TYPE EQUALS 8 DISPLAY "Modify Error".
SET DONE TO USER-REPLY-STATE.
IF VERB-TYPE EQUALS 9 DISPLAY "Open Error"
SET DONE TO TRUE
ELSE IF VERB-TYPE EQUALS 11 DISPLAY "Remove Error"
SET DONE TO USER-REPLY-STATE
ELSE IF VERB-TYPE EQUALS 12 DISPLAY "Store Error"
SET DONE TO USER-REPLY-STATE
ELSE IF VERB-TYPE EQUALS 15 DISPLAY "Bind Error"
SET DONE TO TRUE
ELSE IF VERB-TYPE EQUALS 16 DISPLAY "Call Error"
SET DONE TO TRUE.
MESSAGES-TEXT.
IF MESSAGE-TYPE IS GREATER THAN 60 GO TO 60-MESSAGES.
IF MESSAGE-TYPE IS GREATER THAN 50 GO TO 50-MESSAGES.
IF MESSAGE-TYPE IS GREATER THAN 40 GO TO 40-MESSAGES.
IF MESSAGE-TYPE IS GREATER THAN 30 GO TO 30-MESSAGES.
IF MESSAGE-TYPE IS GREATER THAN 20 GO TO 20-MESSAGES.
IF MESSAGE-TYPE IS GREATER THAN 10 GO TO 10-MESSAGES.
IF MESSAGE-TYPE EQUALS 0
DISPLAY "A warning. Compile-time and run-time versions of"
DISPLAY "schema differ"
ELSE IF MESSAGE-TYPE EQUALS 1
DISPLAY "Area not open."
ELSE IF MESSAGE-TYPE EQUALS 2
DISPLAY "Data base key inconsistent with area-name. Can also"
DISPLAY "indicate that a referenced page number is in an area"
DISPLAY "that is not in the invoked sub-schema"
ELSE IF MESSAGE-TYPE EQUALS 3
DISPLAY "Record affected (deleted or removed) by concurrent"
DISPLAY "application."
ELSE IF MESSAGE-TYPE EQUALS 4
DISPLAY "Data name invalid or inconsistent. This can occur"
DISPLAY "during GET or MODIFY with a data-name list."
ELSE IF MESSAGE-TYPE EQUALS 5
DISPLAY "Violation of DUPLICATES NOT ALLOWED clause."
ELSE IF MESSAGE-TYPE EQUALS 6
DISPLAY "Current of set, area, or record-name not known."
ELSE IF MESSAGE-TYPE EQUALS 7
DISPLAY "End of set, area, or record."
ELSE IF MESSAGE-TYPE EQUALS 8
DISPLAY "Referenced area, record, or set-name not in sub-"
DISPLAY "schema. This may occur because:"
DISPLAY "1. DBCS encounters a record type not in the sub-"
DISPLAY " schema when traversing a set."
DISPLAY "2. Set type owned by the object record type is not"
DISPLAY " in the sub-schea."
DISPLAY "3. The VIA set is not in sub-schema--during set"
DISPLAY " selection occurrence."
DISPLAY "4. All subkeys are not in the sub-schema during CALC"
DISPLAY " processing or searching a sorted set."
DISPLAY "5. The sort key or a set not in the sub-schema is"
DISPLAY " modified."
ELSE DISPLAY "Update usage mode required. This is an attempt to"
DISPLAY "use an updating verb when the specified area is open"
DISPLAY "for retrieval".
GO TO END-MESSAGES.
10-MESSAGES.
IF MESSAGE-TYPE EQUALS 10
DISPLAY "Privacy breach attempted."
ELSE IF MESSAGE-TYPE EQUALS 11
DISPLAY "Physical space not available. No room remains for"
DISPLAY "storing records. This can occur while DBCS is trying"
DISPLAY "to store an internal record type such as an index"
DISPLAY "or buoy."
ELSE IF MESSAGE-TYPE EQUALS 12
DISPLAY "Line numbers for data base keys are exhausted."
ELSE IF MESSAGE-TYPE EQUALS 13
DISPLAY "No current record of run-unit."
ELSE IF MESSAGE-TYPE EQUALS 14
DISPLAY "Object record is MANDATORY AUTOMATIC member in"
DISPLAY "named set."
ELSE IF MESSAGE-TYPE EQUALS 15
DISPLAY "Object record is MANDATORY type or not member type"
DISPLAY "at all in named set. This is an attempt to REMOVE"
DISPLAY "a record which is either a MANDATORY member or not"
DISPLAY "a member type of named set."
ELSE IF MESSAGE-TYPE EQUALS 16
DISPLAY "Record is already a member of named set."
ELSE IF MESSAGE-TYPE EQUALS 17
DISPLAY "Record has been deleted. This can occur during a"
DISPLAY "FIND CURRENT of RECORD, SET, AREA, or RUN-UNIT"
DISPLAY "or during a FIND NEXT of SET or AREA."
ELSE DISPLAY "Data Conversion Unsuccessful.".
GO TO END-MESSAGES.
20-MESSAGES.
IF MESSAGE-TYPE EQUALS 20
DISPLAY "Current record of run-unit not of correct record-"
DISPLAY "type."
ELSE IF MESSAGE-TYPE EQUALS 22
DISPLAY "Record not currently member of named or implied set."
ELSE IF MESSAGE-TYPE EQUALS 23
DISPLAY "Illegal area-name passed in area identification."
ELSE IF MESSAGE-TYPE EQUALS 24
DISPLAY "Temporary and permanent areas referenced in same"
DISPLAY "DML verb."
ELSE IF MESSAGE-TYPE EQUALS 25
DISPLAY "No set occurrence satisfies argument values. This"
DISPLAY "can mean, for example, that the CALC value in the"
DISPLAY "UWA matched no owner record."
ELSE IF MESSAGE-TYPE EQUALS 26
DISPLAY "No record satisfies RSE specified. This is a"
DISPLAY "catch-all exception for the FIND verb."
ELSE DISPLAY "Area already open.".
GO TO END-MESSAGES.
30-MESSAGES.
IF MESSAGE-TYPE EQUALS 30
DISPLAY "Unqualified DELETE attempted on non-empty set."
ELSE IF MESSAGE-TYPE EQUALS 31
DISPLAY "Unable to open the Schema File."
ELSE IF MESSAGE-TYPE EQUALS 32
DISPLAY "Insufficient space allocated for the data-name."
DISPLAY "The SIZE clause specifies less space than the"
DISPLAY "compiler needs."
ELSE IF MESSAGE-TYPE EQUALS 33
DISPLAY "None of the areas a record type can be within"
DISPLAY "are in the sub-schema."
ELSE IF MESSAGE-TYPE EQUALS 34
DISPLAY "A set is in the sub-schema, but its owner record"
DISPLAY "type is not."
ELSE IF MESSAGE-TYPE EQUALS 35
DISPLAY "Dynamic use-vector is full (FORTRAN ONLY)."
ELSE IF MESSAGE-TYPE EQUALS 36
DISPLAY "Attempt to invoke too many sub-schemas (more than"
DISPLAY "8); or attempt to use UNSET with empty sub-schema"
DISPLAY "stack, or SETDB with a full sub-schema stack."
ELSE IF MESSAGE-TYPE EQUALS 37
DISPLAY "Sub-schema passed to SETDB is not already invoked."
ELSE IF MESSAGE-TYPE EQUALS 38
DISPLAY "Duplicate operation attempted on a resource. This"
DISPLAY "can occur because: 1) you attempt to open the"
DISPLAY "journal file twice (you have opened it in EXCLUSIVE"
DISPLAY "UPDATE usage-mode and are now opening a data area"
DISPLAY "in UPDATE usage-mode), or 2) you call JSTRAN while"
DISPLAY "a transaction is already active, or 3) you have"
DISPLAY "multiple INVOKE statements and attempt to open"
DISPLAY "the same area twice."
ELSE DISPLAY "Data base file not found.".
GO TO END-MESSAGES.
40-MESSAGES.
IF MESSAGE-TYPE EQUALS 40
DISPLAY "Request access conflicts with existing access; that"
DISPLAY "is, resource is not available. This can result from"
DISPLAY "an attempt to:"
DISPLAY "1. open an area in a USAGE-MODE incompatible with"
DISPLAY " that of another run-unit using the same area."
DISPLAY "2. open the journal in a way that results in a"
DISPLAY " USAGE-MODE conflict."
DISPLAY "3. DELETE a record retained by another run-unit."
DISPLAY "4. attempt to open area or the journal and the"
DISPLAY " file system signals a file-protection error."
ELSE IF MESSAGE-TYPE EQUALS 41
DISPLAY "No JFNs available. An attempt to open too many areas."
ELSE IF MESSAGE-TYPE EQUALS 42
DISPLAY "Area in undefined state. Use DBMEND to force open"
DISPLAY "the area and return it to a valid state."
ELSE IF MESSAGE-TYPE EQUALS 43
DISPLAY "Area in creation state. This can happen to the"
DISPLAY "system area only. This will occur if run-unit"
DISPLAY "execution aborts at just the right time during"
DISPLAY "the first OPEN of the system area. Should this occur"
DISPLAY "either rerun SCHEMA or create a 0-length file with"
DISPLAY "a text editor."
ELSE IF MESSAGE-TYPE EQUALS 44
DISPLAY "Attempt to call a journal-processing entry point"
DISPLAY "before the journalling system has been initialized"
DISPLAY "(by the first OPEN that requires journalling)."
ELSE IF MESSAGE-TYPE EQUALS 45
DISPLAY "Attempt to backup the data base with JBTRAN 1)"
DISPLAY "while DBCS's Cannot-Backup-Updates bit is set, or"
DISPLAY "2) when the journal is shared and commands are the"
DISPLAY "interleaving unit, or 3) when the journal is shared,"
DISPLAY "transactions are the interleaving unit, and the"
DISPLAY "argument given to JBTRAN is greater than 0"
ELSE IF MESSAGE-TYPE EQUALS 46
DISPLAY "Magnetic tape service is not available. DAEMDB"
DISPLAY "has returned an exception code."
ELSE DISPLAY "Transaction not active.".
GO TO END-MESSAGES.
50-MESSAGES.
IF MESSAGE-TYPE EQUALS 55
DISPLAY "Pseudo-exception. DBCS types message that no"
DISPLAY "sub-schema yet initialized."
ELSE IF MESSAGE-TYPE EQUALS 56
DISPLAY "Inconsistent data in the data base file. DBMEND"
DISPLAY "should be used to restore the data base to a valid"
DISPLAY "state. If the problem can be reproduced, it"
DISPLAY "probably indicates a DBCS software error."
ELSE IF MESSAGE-TYPE EQUALS 57
DISPLAY "Probably a DBCS software error. If this recurs,"
DISPLAY "report it."
ELSE IF MESSAGE-TYPE EQUALS 58
DISPLAY "Illegal argument passed by programmer or setup"
DISPLAY "host interface; for example, passing a set-name"
DISPLAY "with the STORE command."
ELSE DISPLAY "No more memory available.".
GO TO END-MESSAGES.
60-MESSAGES.
IF MESSAGE-TYPE EQUALS 60
DISPLAY "Unable to access a data base file. The operating"
DISPLAY "system reported an I/O error, either in normal"
DISPLAY "operations or in trying to open a journal for"
DISPLAY "appending."
ELSE IF MESSAGE-TYPE EQUALS 61
DISPLAY "Unable to append to journal (that is, the journal"
DISPLAY "is in an aborted state but has not been designated"
DISPLAY "as being done with)."
ELSE IF MESSAGE-TYPE EQUALS 62
DISPLAY "Attempt to enter DBCS at other than JBTRAN, SBIND,"
DISPLAY "SETDB, or UNSET while the system-in-undefined-state"
DISPLAY "bit is on."
ELSE IF MESSAGE-TYPE EQUALS 63
DISPLAY "Unable to complete restoration of the proper data"
DISPLAY "base state. This occurs either during JBTRAN"
DISPLAY "initialization of a run-unit at the start of a"
DISPLAY "command or transaction."
ELSE IF MESSAGE-TYPE EQUALS 64
DISPLAY "Exceptions while processing exception."
ELSE IF MESSAGE-TYPE EQUALS 65
DISPLAY "Monitor space for ENQUEUE entries exhausted, or"
DISPLAY "ENQUEUE quota exceeded."
ELSE IF MESSAGE-TYPE EQUALS 66
DISPLAY "ENQUEUE/DEQUEUE failure (for example, you do not"
DISPLAY "have ENQUEUE capabilities, or an unacceptable"
DISPLAY "argument block has been created by DBCS)."
ELSE DISPLAY "Unable to initialize magnetic tape service because,"
DISPLAY "for example, the IPCF block is bad; the IPCF"
DISPLAY "message is too long; or DAEMDB is not running.".
END-MESSAGES.
SET EXCEPTION-FLAG TO FATAL-STATE.
DISPLAY " ".
DISPLAY "ERROR STATUS = ", ERROR-STATUS.
DISPLAY "ERROR SET = ", ERROR-SET.
DISPLAY "ERROR RECORD = ", ERROR-RECORD.
DISPLAY "ERROR AREA = ", ERROR-AREA.
DISPLAY "ERROR COUNT = ", ERROR-COUNT.
MOVE AREA-NAME TO TEMP-AREA.
* EXAMINE TEMP-AREA REPLACING ALL LOW-VALUE BY " ".*
INSPECT TEMP-AREA REPLACING ALL LOW-VALUE BY " ".
DISPLAY "AREA NAME = ", TEMP-AREA.
MOVE RECORD-NAME TO TEMP-REC.
* EXAMINE TEMP-REC REPLACING ALL LOW-VALUE BY " ".*
INSPECT TEMP-REC REPLACING ALL LOW-VALUE BY " ".
DISPLAY "RECORD NAME = ", TEMP-REC.
DISPLAY "? ".
END DECLARATIVES.
******************************************************************
* *
* The next few lines of code set some switches and opens data *
* base areas. *
* *
******************************************************************
SET Exception-Msgs TO True.
SET Done TO False.
SET Exception-Flag TO OK-State.
OPEN AREA Head-Area
USAGE-MODE IS EXCLUSIVE UPDATE
PRIVACY KEY IS N1234.
IF ERROR-STATUS NOT = 0 AND FATAL
DISPLAY "? Not able to open Head-Area"
GO TO FINIS.
OPEN AREA Index-Block-Area
USAGE-MODE IS EXCLUSIVE UPDATE
PRIVACY KEY IS N1234.
IF ERROR-STATUS NOT = 0 AND FATAL
DISPLAY "? Not able to open Index-Block-Area"
GO TO FINIS.
OPEN AREA Inventory-Area
USAGE-MODE IS EXCLUSIVE UPDATE
PRIVACY KEY IS N1234.
IF ERROR-STATUS NOT = 0 AND FATAL
DISPLAY "? Not able to open Inventory-Area"
GO TO FINIS.
OPEN AREA Manufacturing-Area
USAGE-MODE IS EXCLUSIVE UPDATE
PRIVACY KEY IS N1234.
IF ERROR-STATUS NOT = 0 AND FATAL
DISPLAY "? Not able to open Manufacturing-Area"
GO TO FINIS.
OPEN AREA Orders-Area
USAGE-MODE IS EXCLUSIVE UPDATE
PRIVACY KEY IS N1234.
IF ERROR-STATUS NOT = 0 AND FATAL
DISPLAY "? Not able to open Orders-Area"
GO TO FINIS.
OPEN AREA Personnel-Area
USAGE-MODE IS EXCLUSIVE UPDATE
PRIVACY KEY IS N1234.
IF ERROR-STATUS NOT = 0 AND FATAL
DISPLAY "? Not able to open Personnel-Area"
GO TO FINIS.
OPEN AREA Personal-Area
USAGE-MODE IS EXCLUSIVE UPDATE
PRIVACY KEY IS N1234.
IF ERROR-STATUS NOT = 0 AND FATAL
DISPLAY "? Not able to open Personal-Area"
GO TO FINIS.
******************************************************************
* *
* When searching for information in the response table, we want *
* blank spaces at the end of the RESPONSE string to be *
* correctly searched if there are blanks at the end as there *
* are in this case. However, this means that single character *
* responses cannot be located using a search all command *
* *
******************************************************************
* EXAMINE RESPONSE-FILLER REPLACING ALL " " BY HIGH-VALUES.*
INSPECT RESPONSE-FILLER REPLACING ALL " " BY HIGH-VALUES.
******************************************************************
* *
* These are the key values for the head records. They are in- *
* itialized here and then ignored. *
* *
******************************************************************
MOVE HIGH-VALUES TO Cust-Dummy.
MOVE HIGH-VALUES TO Emp-Dummy.
MOVE HIGH-VALUES TO PO-Dummy.
MOVE HIGH-VALUES TO WO-Dummy.
MOVE HIGH-VALUES TO Number-Dummy.
FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Access failure for Employee-Head ???"
GO TO FINIS.
FIND FIRST Cust-Head-Rec RECORD OF Cust-Head-Sys SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Access failure for Cust-Head ???"
GO TO FINIS.
FIND FIRST Work-Order-Head-Rec RECORD OF Work-Order-Sys Set.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Access failure for Work-Order-Head ???"
GO TO FINIS.
DISPLAY " ".
DISPLAY "Digital DBMS-10/20 Theme Example".
DISPLAY " ".
******************************************************************
* *
* This asks if user wants to receive complete error messages or *
* just the exception code. *
* *
******************************************************************
PERFORM EXCEPTION-MSG-PARA.
******************************************************************
* *
* This is the only main line code statement. DISPATCH is a *
* routine that accepts the user response to the top level *
* prompt. After the user response is interpreted, the program *
* branches to the routine called for to process the records *
* called for in the response. *
* *
******************************************************************
PERFORM DISPATCH THROUGH DISPATCH-EXIT UNTIL FINISHED.
******************************************************************
* *
* The next lines of code close data base files and put the *
* journal into a "done-with" state. *
* *
******************************************************************
FINIS.
CLOSE RUN-UNIT.
* CLOSE JOURNAL.
STOP RUN.
******************************************************************
* *
* D I S P A T C H *
* *
* This routine accepts the user response and then uses a *
* GO TO DEPENDING ON to branch to appropriate routine. For this*
* routine to work properly, the responses in the response table *
* must be in alphabetical order and the paragraph labels in the *
* GO TO must be in the same order. *
* *
******************************************************************
DISPATCH.
SET Exception-Flag TO OK-State.
DISPLAY " ".
DISPLAY "THEME-MAIN-MENU>" WITH NO ADVANCING.
ACCEPT Function.
IF Function = "@" GO TO EXIT-PARA.
IF Function = "?" PERFORM HELP-PARA
GO TO DISPATCH.
SEARCH ALL Response-Table
AT END PERFORM INVALID-RESPONSE-PARA THROUGH HELP-PARA
GO TO DISPATCH-EXIT
WHEN Response-Type (Response-Index) = Function
SET Temp-Function TO Response-Index
GO TO
CLASSIFICATION-PARA
CUSTOMER-PARA
DEPARTMENT-PARA
EMPLOYEE-PARA
EXIT-PARA
HELP-PARA
INIT-PARA
MENU-PARA
EXCEPTION-MSG-PARA
ORDER-PROCESS-PARA
PART-PARA
STATS-PARA
TRUCK-PARA
DEPENDING ON Temp-Function.
DISPATCH-EXIT.
EXIT.
******************************************************************
* *
* C L A S S I F I C A T I O N - P A R A *
* *
* This paragraph accepts a response and performs the Function *
* called for. The Functions called for immediately follow *
* this paragraph. *
* *
******************************************************************
CLASSIFICATION-PARA.
PERFORM CLASSIFICATION-HELP.
DISPLAY "CLASS-MENU>" WITH NO ADVANCING.
ACCEPT Function.
IF Function = "AD" PERFORM ADD-CLASSIFICATION THROUGH
ADD-CLASSIFICATION-EXIT
ELSE
IF Function = "DE" PERFORM DELETE-CLASSIFICATION THROUGH
DELETE-CLASSIFICATION-EXIT
ELSE
IF Function = "?" OR "HE" GO TO CLASSIFICATION-PARA
ELSE
IF Function = "LI" PERFORM LIST-CLASSIFICATION THROUGH
LIST-CLASSIFICATION-EXIT
ELSE
IF Function = "@" GO TO DISPATCH-EXIT
ELSE DISPLAY Function, " is undefined ??? "
GO TO CLASSIFICATION-PARA.
GO TO DISPATCH-EXIT.
******************************************************************
* *
* C L A S S I F I C A T I O N - H E L P *
* *
* This is a list of available Functions for dealing with *
* CLASSIFICATION records. *
* *
******************************************************************
CLASSIFICATION-HELP.
DISPLAY " ".
DISPLAY "@ Abort and return to THEME-MAIN-MENU".
DISPLAY " ? Display this Message".
DISPLAY "AD Add Classification".
DISPLAY "DE Delete Classification".
DISPLAY "HE Display this Message".
DISPLAY "LI List All Classifications".
DISPLAY " ".
******************************************************************
* *
* A D D - C L A S S I F I C A T I O N *
* *
* This routine add one classification record to the data base. *
* *
******************************************************************
ADD-CLASSIFICATION.
DISPLAY " ".
DISPLAY "ADD CLASSIFICATION--Type job classification>"
WITH NO ADVANCING.
ACCEPT Job-Class.
IF Job-Class = "@" GO TO ADD-CLASSIFICATION-EXIT.
IF Job-Class = "?" or "HE"
DISPLAY "HELP--Type the five character classification code"
GO TO ADD-CLASSIFICATION.
******************************************************************
* *
* Check to insure not already in the data base. *
* *
******************************************************************
* *
* Routine is really rather simple-minded. It simply prompts for*
* which item to input, gives you the option to abort if you type*
* an @ sign, then goes to next data item. *
* *
******************************************************************
FIND Classification-Rec.
IF ERROR-STATUS = 0 OR OK,
DISPLAY Job-Class, " already stored"
GO TO ADD-CLASSIFICATION-EXIT.
IF ERROR-STATUS NOT = 0 AND NOT NO-SUCH-KEY,
GO TO ADD-CLASSIFICATION-EXIT.
REDO-JOB-DESCRIPTION.
DISPLAY "ADD CLASSIFICATION--Type job description>"
WITH NO ADVANCING.
ACCEPT Job-Description.
IF Job-Description = "@" GO TO ADD-CLASSIFICATION-EXIT.
IF Job-Description = "?" OR "HE"
DISPLAY "HELP--Type the 1 to 20 letter classification name"
GO TO REDO-JOB-DESCRIPTION.
STORE CLassification-Rec.
IF ERROR-STATUS NOT = 0 OR OK,
DISPLAY "??? Classification Record not stored ???"
DISPLAY "Your input was: ",Job-Class," ",Job-Description
ELSE DISPLAY "*** Classification Record Stored ".
ADD-CLASSIFICATION-EXIT.
EXIT.
******************************************************************
* *
* D E L E T E - C L A S S I F I C A T I O N *
* *
* On the surface, this might appear to be a rather simple rou- *
* tine. However, in addition to deleting the classification *
* record, the program must also move each employee to a new *
* classification. The program finds each employee and then asks*
* you to specify which classification to transfer to. This is *
* very direct--and very inefficient. What should have been done*
* is build a table of employees and then ask what classification*
* to transfer to. After the list is built up, the program *
* should go in and make all the changes at one time. This *
* procedure was not seen as necessary for this example program. *
* *
******************************************************************
DELETE-CLASSIFICATION.
DISPLAY "DELETE CLASSIFICATION--Type classification to be deleted>"
WITH NO ADVANCING.
ACCEPT Job-Class.
IF Job-Class = "@" GO TO DELETE-CLASSIFICATION-EXIT.
IF Job-Class = "?" OR "HE"
DISPLAY "HELP--Type the five character job classification"
GO TO DELETE-CLASSIFICATION.
MOVE Job-Class TO SAVE-JOB-CLASS.
FIND Classification-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Classification not found ???"
GO TO DELETE-CLASSIFICATION-EXIT.
FIND FIRST RECORD OF Class-Employee SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO DELETE-CLASSIFICATION-DEL.
GO TO CHANGE-CLASS.
DELETE-CLASSIFICATION-LOOP.
FIND NEXT RECORD OF Class-Employee SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO DELETE-CLASSIFICATION-DEL.
CHANGE-CLASS.
GET Employee-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO DELETE-CLASSIFICATION-EXIT.
REMOVE Employee-Rec FROM Class-Employee.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO DELETE-CLASSIFICATION-EXIT.
REDO-EMPLOYEE.
DISPLAY "Employee ",EMP-NUM," ",EMP-NAME," is to be transferred to".
DISPLAY "which Classification? Type Job-Classification>"
WITH NO ADVANCING.
ACCEPT Job-Class.
FIND Classification-Rec.
IF ERROR-STATUS NOT = 0 AND NO-SUCH-KEY,
DISPLAY "NO SUCH CLASS"
GO TO REDO-EMPLOYEE.
FIND CURRENT Employee-Rec RECORD.
INSERT Employee-Rec INTO Class-Employee.
MOVE SAVE-JOB-CLASS TO Job-Class.
FIND Classification-Rec RECORD.
IF ERROR-STATUS = 0 OR OK,
GO TO DELETE-CLASSIFICATION-LOOP.
DELETE-CLASSIFICATION-DEL.
MOVE SAVE-JOB-CLASS TO Job-Class.
FIND Classification-Rec.
IF ERROR-STATUS NOT = 0,
GO TO DELETE-CLASSIFICATION-EXIT.
DELETE Classification-Rec.
IF ERROR-STATUS = 0
DISPLAY "*** CLASIFICATION DELETED ***"
ELSE DISPLAY "??? UNABLE TO DELETE ???".
DELETE-CLASSIFICATION-EXIT.
EXIT.
******************************************************************
* *
* L I S T - C L A S S I F I C A T I O N *
* *
* This is a simple-minded routine that simply processes all recs *
* using a FIND NEXT of AREA. The output is in the order in which*
* they are found. The classification records were not put in a *
* set this was not seen as as a normal Function. *
* *
******************************************************************
LIST-CLASSIFICATION.
FIND FIRST Classification-Rec RECORD OF Personnel-Area AREA.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? No Classification Records Found, Data Base Corrupt ???"
GO TO LIST-CLASSIFICATION-EXIT.
DISPLAY "JOB-CLASS JOB-DESCRIPTION".
DISPLAY "------------------------------------------------------------".
GET Classification-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO LIST-CLASSIFICATION-EXIT.
DISPLAY Job-Class," ",Job-Description.
LIST-CLASSIFICATION-LOOP.
FIND NEXT Classification-Rec RECORD OF Personnel-Area AREA.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO LIST-CLASSIFICATION-EXIT.
GET Classification-Rec.
IF ERROR-STATUS = 0 OR OK,
DISPLAY Job-Class," ",Job-Description
GO TO LIST-CLASSIFICATION-LOOP.
LIST-CLASSIFICATION-EXIT.
EXIT.
******************************************************************
* *
* C U S T O M E R - P A R A *
* *
* This is the menu for getting at customer-related Functions. *
* *
******************************************************************
CUSTOMER-PARA.
DISPLAY " ".
DISPLAY "AL List all customers and all orders".
DISPLAY "HE Display this listing".
DISPLAY "LA List all customers".
DISPLAY "LO List one customer and all orders for that customer"
DISPLAY "@ Abort and return to main menu".
DISPLAY " ? Display this listing".
DISPLAY " ".
DISPLAY "CUSTOMER MENU>" WITH NO ADVANCING.
ACCEPT Function.
IF Function = "AL" SET FLAGS TO FIRST-CUSTOMER-STATE
PERFORM CUSTOMERS-ALL THROUGH CUSTOMERS-ALL-EXIT
ELSE
IF Function = "LA" PERFORM LIST-ALL-CUSTOMERS
THROUGH LIST-ALL-CUSTOMERS-EXIT
ELSE
IF Function = "LO" PERFORM LIST-ONE-CUSTOMER
THROUGH LIST-ONE-CUSTOMER-EXIT
ELSE
IF Function = "?" OR "HE" GO TO CUSTOMER-PARA
ELSE
IF Function = "@" GO TO CUSTOMER-EXIT
ELSE
DISPLAY Function," is not defined".
GO TO CUSTOMER-PARA.
CUSTOMER-EXIT.
GO TO DISPATCH-EXIT.
******************************************************************
* *
* C U S T O M E R S - A L L *
* *
******************************************************************
CUSTOMERS-ALL.
FIRST-CUST.
FIND FIRST Customer-Rec RECORD OF Cust-Head SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? No Customers in Data Base ???"
DISPLAY " Data Base probably corrupt "
GO TO CUSTOMERS-ALL-EXIT.
GET Customer-Rec.
DISPLAY"*--------------------------------------------------------*"
DISPLAY Cust-Name.
GO TO FIRST-ORDER.
NEXT-CUST.
FIND NEXT Customer-Rec RECORD OF Cust-Head SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO CUSTOMERS-ALL-EXIT.
GET Customer-Rec.
DISPLAY " ".
DISPLAY"*--------------------------------------------------------*"
DISPLAY " ".
DISPLAY Cust-Name.
SET FLAGS TO MORE-ORDERS-STATE.
FIRST-ORDER.
FIND FIRST Order-Rec RECORD OF Cust-Ord SET.
GET Order-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK AND NOT END-OF-SET,
DISPLAY "+++ No Orders posted for this customer +++"
SET EXCEPTION-FLAG TO OK-STATE
GO TO CUSTOMERS-ALL.
DISPLAY " ".
DISPLAY "*************".
DISPLAY " ".
DISPLAY "ORDER NUMBER: " WITH NO ADVANCING.
DISPLAY Ord-Num.
DISPLAY "ENTERED: ", Ord-Entered-Date.
DISPLAY "DUE: ", Ord-Due-Date.
DISPLAY "BILLED: ", Ord-Amt-Billed.
DISPLAY "OUTSANDING: ", Ord-Amt-Outstand.
GO TO NEXT-ITEM.
NEXT-ORDER.
FIND NEXT Order-Rec RECORD OF Cust-Ord SET.
IF ERROR-STATUS NOT = 0,
SET FLAGS, EXCEPTION-FLAG TO OK-STATE
GO TO NEXT-CUST.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO CUSTOMERS-ALL-EXIT.
GET Order-Rec.
DISPLAY " ".
DISPLAY "*************".
DISPLAY " ".
DISPLAY "ORDER NUMBER: ", Ord-Num.
DISPLAY "ENTERED: ", Ord-Entered-Date.
DISPLAY "DUE: ", Ord-Due-Date.
DISPLAY "BILLED: ", Ord-Amt-Billed.
DISPLAY "OUTSTANDING: ", Ord-Amt-Outstand.
SET ITEM-FLAG TO TRUE.
FIRST-ITEM.
FIND FIRST Item-Rec RECORD OF Ord-Item SET.
IF ERROR-STATUS NOT = 0 AND NOT OK AND NOT END-OF-SET,
DISPLAY "??? Data Base Problems, Orders Recorded ???"
DISPLAY " But There Are NO Items On Order."
SET EXCEPTION-FLAG TO OK-STATE
GO TO NEXT-CUST.
GET Item-Rec.
DISPLAY "ITEM QTY SHIPPED PRICE".
DISPLAY Item-Part," ", Item-Qty WITH NO ADVANCING.
DISPLAY " ",Item-Shipped-Date," ",Item-Price.
NEXT-ITEM.
FIND NEXT Item-Rec RECORD OF Ord-Item SET.
IF ERROR-STATUS NOT = 0
GO TO NEXT-ORDER.
GET Item-Rec.
DISPLAY "ITEM QTY SHIPPED PRICE".
DISPLAY Item-Part," ", Item-Qty WITH NO ADVANCING.
DISPLAY " ",Item-Shipped-Date," ",Item-Price.
GO TO NEXT-ITEM.
CUSTOMERS-ALL-EXIT.
******************************************************************
* *
* L I S T - A L L - C U S T O M E R S *
* *
******************************************************************
LIST-ALL-CUSTOMERS.
FIND FIRST Customer-Rec RECORD OF Cust-Head SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? No customers in data base ???"
DISPLAY " Data base probably corrupt."
GO TO LIST-ALL-CUSTOMERS-EXIT.
LIST-ALL-CUSTOMERS-LOOP.
GET Customer-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO LIST-ALL-CUSTOMERS-EXIT.
DISPLAY Cust-Num," ",Cust-Name.
FIND NEXT Customer-Rec RECORD OF Cust-Head SET.
IF ERROR-STATUS NOT = 0 AND END-OF-SET,
GO TO LIST-ALL-CUSTOMERS-EXIT.
IF ERROR-STATUS = 0,
GO TO LIST-ALL-CUSTOMERS-LOOP.
LIST-ALL-CUSTOMERS-EXIT.
******************************************************************
* *
* L I S T - O N E - C U S T O M E R *
* *
******************************************************************
LIST-ONE-CUSTOMER.
DISPLAY "CUSTOMER--TYPE customer number >" WITH NO ADVANCING.
ACCEPT Cust-Num.
ENTER MACRO FINS6 USING "Customer-Rec", "Cust-Head".
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Customer not found ???"
GO TO LIST-ONE-CUSTOMER-EXIT.
GET Customer-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO LIST-ONE-CUSTOMER-EXIT.
DISPLAY "NAME: ", Cust-Name.
DISPLAY "ADDRESS: ", Cust-Address.
DISPLAY "RATING: ", Cust-Rating.
DISPLAY "ROUTE: ", Cust-Route.
DISPLAY "SIZE: ", Cust-Size.
DISPLAY "BALANCE: ", Cust-Balance.
FIRST-ORDER-1.
FIND FIRST Order-Rec RECORD OF Cust-Ord SET.
IF ERROR-STATUS NOT = 0 AND NOT OK AND NOT END-OF-SET,
DISPLAY "+++ No Orders posted for this customer +++"
GO TO LIST-ONE-CUSTOMER-EXIT.
NEXT-ORDER-1.
GET Order-Rec.
DISPLAY "ORDER-----------------ORDER".
DISPLAY "ORDER: ",Ord-Num.
DISPLAY "ENTERED: ", Ord-Entered-Date.
DISPLAY "DUE: ", Ord-Due-Date.
DISPLAY "BILLED: ", Ord-Amt-Billed.
DISPLAY "OUTSTANDING: ", Ord-Amt-Outstand.
FIRST-ITEM-1.
FIND FIRST Item-Rec RECORD OF Ord-Item SET.
IF ERROR-STATUS NOT = 0 AND NOT OK AND NOT END-OF-SET,
DISPLAY "??? Data Base problems, Orders recorded ???"
DISPLAY " but there are not items on order"
GO TO LIST-ONE-CUSTOMER-EXIT.
NEXT-ITEM-1.
GET Item-Rec.
DISPLAY"*********"
DISPLAY "PART: ", Item-Part
DISPLAY "QUANTITY: ", Item-Qty
DISPLAY "SHIPPED: ", Item-Shipped-Date
DISPLAY "PRICE: ", Item-Price
FIND NEXT Item-Rec RECORD OF Ord-Item SET.
IF ERROR-STATUS = 0 GO TO NEXT-ITEM-1.
FIND NEXT Order-Rec RECORD OF Cust-Ord SET.
IF ERROR-STATUS = 0 GO TO NEXT-ORDER-1.
LIST-ONE-CUSTOMER-EXIT.
EXIT.
******************************************************************
* *
* D E P A R T M E N T - P A R A *
* *
******************************************************************
DEPARTMENT-PARA.
PERFORM DEPARTMENT-HELP.
DISPLAY "DEPT-MENU>" WITH NO ADVANCING.
ACCEPT Function.
IF Function = "?" OR "HE" GO TO DEPARTMENT-PARA
ELSE
IF Function = "@" GO TO DISPATCH-EXIT
ELSE
IF Function = "AD"
MOVE 0 TO FLAGS
PERFORM ADD-DEPARTMENT THROUGH ADD-DEPARTMENT-EXIT
ELSE
IF Function = "CH" PERFORM CHANGE-DEPARTMENT THROUGH ADD-DEPARTMENT-EXIT
ELSE
IF Function = "DE" PERFORM DELETE-DEPARTMENT THROUGH DELETE-DEPARTMENT-EXIT
ELSE
IF Function = "LI" PERFORM LIST-DEPARTMENT THROUGH LIST-DEPARTMENT-EXIT
ELSE
DISPLAY "??? Undefined Function ???"
GO TO DEPARTMENT-PARA.
GO TO DISPATCH-EXIT.
******************************************************************
* *
* D E P A R T M E N T - H E L P *
* *
******************************************************************
DEPARTMENT-HELP.
DISPLAY " ".
DISPLAY "AD Add Department".
DISPLAY "CH Change Department Information".
DISPLAY "DE Delete Department".
DISPLAY "LI List All Departments".
DISPLAY " ? Display this listing".
DISPLAY "HE Display this listing".
DISPLAY "@ Abort and return to main menu".
DISPLAY " ".
******************************************************************
* *
* C H A N G E - D E P A R T M E N T *
* *
******************************************************************
CHANGE-DEPARTMENT.
SET FLAGS TO CHANGE-DEPT-STATE.
DISPLAY " ".
DISPLAY "If you do not wish to change a field, type a <CR>".
******************************************************************
* *
* A D D - D E P A R T M E N T *
* *
******************************************************************
ADD-DEPARTMENT.
DISPLAY " ".
DISPLAY "DEPARTMENT--Type dept-number>" WITH NO ADVANCING.
ACCEPT Dept-Num.
FIND Department-Rec RECORD.
IF CHANGE-DEPT
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Department not stored ???"
GO TO ADD-DEPARTMENT-EXIT
ELSE
GET Department-Rec
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO ADD-DEPARTMENT-EXIT
ELSE DISPLAY Dept-Address, Dept-Phone
ELSE
IF ERROR-STATUS = 0 OR OK,
DISPLAY "??? Department already stored ???"
GO TO ADD-DEPARTMENT-EXIT
ELSE SET EXCEPTION-FLAG TO OK-STATE.
MOVE Dept-Num TO WS-Dept-Num.
REDO-DEPARTMENT-NAME.
DISPLAY "DEPARTMENT--Type dept-name>" WITH NO ADVANCING.
ACCEPT WS-Dept-Name.
IF WS-Dept-Name = "@" GO TO ADD-DEPARTMENT-EXIT.
IF WS-Dept-Name = " " AND NOT CHANGE-DEPT
DISPLAY "??? You must type a department name ???"
GO TO REDO-DEPARTMENT-NAME.
IF WS-Dept-Name = " " MOVE Dept-Name to WS-Dept-Name.
DISPLAY "DEPARTMENT--Type dept-internal-no>" WITH NO ADVANCING.
ACCEPT WS-Dept-Internal-No.
IF WS-Dept-Internal-No = "@" GO TO ADD-DEPARTMENT-EXIT.
IF WS-Dept-Internal-No = " " AND CHANGE-DEPT
MOVE Dept-Internal-No TO WS-Dept-Internal-No.
REDO-DEPARTMENT-STREET.
DISPLAY "DEPARTMENT--Type dept-street>" WITH NO ADVANCING.
ACCEPT WS-Dept-Street.
IF WS-Dept-Street = "@" GO TO ADD-DEPARTMENT-EXIT.
IF WS-Dept-Street = " " AND NOT CHANGE-DEPT
DISPLAY "??? You must type an address ???"
GO TO REDO-DEPARTMENT-STREET.
IF WS-Dept-Street = " " MOVE Dept-Street to WS-Dept-Street.
REDO-DEPARTMENT-CITY.
DISPLAY "DEPARTMENT--Type dept-city>" WITH NO ADVANCING.
ACCEPT WS-Dept-City.
IF WS-Dept-City = "@" GO TO ADD-DEPARTMENT-EXIT.
IF WS-Dept-City = " " AND NOT CHANGE-DEPT
DISPLAY "??? You must type a complete address ???"
GO TO REDO-DEPARTMENT-CITY.
IF WS-Dept-City = " " MOVE Dept-City to WS-Dept-City.
REDO-DEPARTMENT-STATE.
DISPLAY "DEPARTMENT--Type dept-state>" WITH NO ADVANCING.
ACCEPT WS-Dept-State.
IF WS-Dept-State = "@" GO TO ADD-DEPARTMENT-EXIT.
IF WS-Dept-State = " " AND NOT CHANGE-DEPT
DISPLAY "??? You must type a complete address ???"
GO TO REDO-DEPARTMENT-STATE.
IF WS-Dept-State = " " MOVE Dept-State to WS-Dept-State.
REDO-DEPARTMENT-ZIP.
DISPLAY "DEPARTMENT--Type dept-zip>" WITH NO ADVANCING.
ACCEPT WS-Dept-Zip.
IF WS-Dept-Zip = "@" GO TO ADD-DEPARTMENT-EXIT.
IF WS-Dept-Zip = " " AND NOT CHANGE-DEPT
DISPLAY "??? You must type a complete address ???"
GO TO REDO-DEPARTMENT-ZIP.
IF WS-Dept-Zip = " " MOVE Dept-Zip TO WS-Dept-Zip
ELSE MOVE WS-Dept-Zip TO WS-HOLD-ARRAY
SET BAD-NUMBER-FLAG TO FALSE
PERFORM NUMERIC-CHECK VARYING COUNTER FROM 1 BY 1
UNTIL COUNTER = 6 OR BAD-NUMBER
IF BAD-NUMBER DISPLAY WS-Dept-Zip," contains non-numeric information"
GO TO REDO-DEPARTMENT-ZIP.
REDO-DEPARTMENT-PHONE.
DISPLAY "DEPARTMENT--Type dept-phone>" WITH NO ADVANCING.
ACCEPT WS-Dept-Phone.
IF WS-Dept-Phone = "@" GO TO ADD-DEPARTMENT-EXIT.
IF WS-Dept-Phone = " " AND NOT CHANGE-DEPT
DISPLAY "??? You must type a phone number ???"
GO TO REDO-DEPARTMENT-PHONE.
IF WS-Dept-Phone = " " MOVE Dept-Phone to WS-Dept-Phone.
MOVE WS-Dept-Name TO Dept-Name.
MOVE WS-Department-Rec TO Department-Rec.
IF CHANGE-DEPT
MODIFY Department-Rec
IF ERROR-STATUS = 0 OR OK,
DISPLAY "*** Department record modified ***"
ELSE DISPLAY "??? Modification failed ???"
ELSE
STORE Department-Rec
IF ERROR-STATUS = 0 OR OK,
DISPLAY "*** Department record stored ***"
ELSE
DISPLAY "??? Department record not stored ???"
DISPLAY "Your input was: ",Dept-Name," ",Dept-Address," ",Dept-Phone.
ADD-DEPARTMENT-EXIT.
EXIT.
******************************************************************
* *
* D E L E T E - D E P A R T M E N T *
* *
******************************************************************
DELETE-DEPARTMENT.
DISPLAY "DELETE DEPARTMENT -- Type dept-number>" WITH NO ADVANCING.
ACCEPT Dept-Num.
FIND Department-Rec.
IF ERROR-STATUS NOT = 0 AND NO-SUCH-KEY,
DISPLAY "Department not found"
GO TO DELETE-DEPARTMENT-EXIT.
FIND FIRST Customer-Rec RECORD OF Sales SET.
IF ERROR-STATUS = 0,
DISPLAY "Department has customers and may not be deleted"
GO TO DELETE-DEPARTMENT-EXIT.
FIND FIRST Truck-Rec RECORD OF Truck SET.
IF ERROR-STATUS = 0,
DISPLAY "Department has trucks and may not be deleted"
GO TO DELETE-DEPARTMENT-EXIT.
FIND FIRST Work-Item-Rec RECORD OF Dept-Work-Item SET.
IF ERROR-STATUS = 0,
DISPLAY "Department has work orders and may not be deleted"
GO TO DELETE-DEPARTMENT-EXIT.
FIND FIRST Employee-Rec RECORD OF Employees SET.
IF ERROR-STATUS = 0,
DISPLAY "Department has employees and may not be deleted"
GO TO DELETE-DEPARTMENT-EXIT.
DELETE Department-Rec.
IF ERROR-STATUS NOT = 0,
DISPLAY "Department not deleted"
ELSE
DISPLAY "Department deleted".
DELETE-DEPARTMENT-EXIT.
EXIT.
******************************************************************
* *
* L I S T - D E P A R T M E N T *
* *
******************************************************************
LIST-DEPARTMENT.
SET ERROR-STATUS TO 0.
FIND FIRST Department-Rec RECORD OF MANUFACTURING-AREA AREA.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? No Department Records Found, Data Base Corrupt ???"
GO TO LIST-DEPARTMENT-EXIT.
GET Department-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO LIST-DEPARTMENT-EXIT.
DISPLAY "DEPARTMENT # ", Dept-Num, " NAME: ", Dept-Name.
DISPLAY Dept-Address.
DISPLAY Dept-Phone.
DISPLAY "--------------------------------------------------------------".
LIST-DEPARTMENT-LOOP.
FIND NEXT Department-Rec RECORD OF Manufacturing-Area AREA.
IF ERROR-STATUS NOT = 0
GO TO LIST-DEPARTMENT-EXIT.
GET Department-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO LIST-DEPARTMENT-EXIT.
DISPLAY "DEPARTMENT # ", Dept-Num, " NAME: ", Dept-Name.
DISPLAY Dept-Address," ", Dept-Phone.
IF ERROR-STATUS = 0 OR NOT END-OF-SET,
GO TO LIST-DEPARTMENT-LOOP.
LIST-DEPARTMENT-EXIT.
EXIT.
******************************************************************
* *
* E M P L O Y E E - P A R A *
* *
******************************************************************
EMPLOYEE-PARA.
PERFORM EMPLOYEE-HELP.
DISPLAY "EMPLOYEE-MENU>" WITH NO ADVANCING.
MOVE " " TO Function.
ACCEPT Function.
IF Function = "?" OR "HE" GO TO EMPLOYEE-PARA
ELSE
IF Function = "@" GO TO DISPATCH-EXIT
ELSE
IF Function = "AC" PERFORM ADD-CHILD THROUGH ADD-CHILD-EXIT
ELSE
IF Function = "AD"
MOVE 0 TO FLAGS
PERFORM ADD-EMPLOYEE THROUGH ADD-EMPLOYEE-EXIT
ELSE
IF Function = "AS" PERFORM ADD-SPOUSE THROUGH ADD-SPOUSE-EXIT
ELSE
IF Function = "CH" PERFORM CHANGE-EMPLOYEE THROUGH ADD-EMPLOYEE-EXIT
ELSE
IF Function = "DE" PERFORM DELETE-EMPLOYEE THROUGH DELETE-EMPLOYEE-EXIT
ELSE
IF Function = "DI" PERFORM DISPLAY-EMPLOYEE THROUGH DISPLAY-EMPLOYEE-EXIT
ELSE
IF Function = "LI" PERFORM LIST-EMPLOYEES THROUGH LIST-EMPLOYEES-EXIT
ELSE DISPLAY Function, "is not defined"
GO TO EMPLOYEE-PARA.
GO TO DISPATCH-EXIT.
******************************************************************
* *
* E M P L O Y E E - H E L P *
* *
******************************************************************
EMPLOYEE-HELP.
DISPLAY " ".
DISPLAY "AC Add Child".
DISPLAY "AD Add Employee".
DISPLAY "AS Add Spouse".
DISPLAY "CH Change Employee".
DISPLAY "DE Delete Employee".
DISPLAY "DI Display information about one employee".
DISPLAY "LI Display information about all employees".
DISPLAY " ? Display this listing".
DISPLAY "HE Display this listing".
DISPLAY "@ Abort and return to main menu".
DISPLAY " ".
******************************************************************
* *
* C H A N G E - E M P L O Y E E *
* *
******************************************************************
CHANGE-EMPLOYEE.
SET FLAGS TO CHANGE-EMP-STATE.
******************************************************************
* *
* A D D - E M P L O Y E E *
* *
******************************************************************
ADD-EMPLOYEE.
DISPLAY " ".
DISPLAY "EMPLOYEE--Type emp-number>"
WITH NO ADVANCING.
ACCEPT Emp-Num.
FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Employee-Head not found ???"
DISPLAY "??? Data Base may be corrupt ???"
DISPLAY "??? *** Execution Aborted ***???"
SET DONE TO TRUE
GO TO ADD-EMPLOYEE-EXIT.
IF NOT CHANGE-EMP
GET Employee-Head-Rec
SET Num-of-Emp UP BY 1
MODIFY Employee-Head-Rec Num-of-Emp
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO ADD-EMPLOYEE-EXIT.
ENTER MACRO FINS6 USING "Employee-Rec","Employee-Head".
IF CHANGE-EMP
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Employee not stored ???"
GO TO ADD-EMPLOYEE-EXIT
ELSE
GET Employee-Rec
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO ADD-EMPLOYEE-EXIT
ELSE DISPLAY Emp-Name, Emp-Address
DISPLAY Emp-Sick-Leave, Emp-Vacation, Emp-Hour-Wage
ELSE
IF ERROR-STATUS NOT = 0 AND NOT OK,
SET EXCEPTION-FLAG TO OK-STATE
ELSE DISPLAY "??? Employee already stored ???"
GO TO ADD-EMPLOYEE-EXIT.
DISPLAY "EMPLOYEE--Type emp-last-name>" WITH NO ADVANCING.
ACCEPT Emp-Last-Name.
DISPLAY "EMPLOYEE--Type emp-first-name>" WITH NO ADVANCING.
ACCEPT Emp-First-Name.
DISPLAY "EMPLOYEE--Type middle initial>" WITH NO ADVANCING.
ACCEPT Emp-Middle-Init.
DISPLAY "EMPLOYEE--Type emp-street>" WITH NO ADVANCING.
ACCEPT Emp-Street.
DISPLAY "EMPLOYEE--Type apt number or RFD>" WITH NO ADVANCING.
ACCEPT Emp-RFD-Apt.
DISPLAY "EMPLOYEE--Type emp-city>" WITH NO ADVANCING.
ACCEPT Emp-City.
DISPLAY "EMPLOYEE--Type emp-state>" WITH NO ADVANCING.
ACCEPT Emp-State.
DISPLAY "EMPLOYEE--Type emp-zip>" WITH NO ADVANCING.
ACCEPT Emp-Zip.
IF NOT CHANGE-EMP
SET Emp-Sick-Leave TO 0
SET Emp-Vacation TO 0.
DISPLAY "EMPLOYEE--Type wage>" WITH NO ADVANCING.
ACCEPT Emp-Hour-Wage.
DISPLAY "EMPLOYEE--Type employee's dept num>" WITH NO ADVANCING.
ACCEPT Dept-Num.
DISPLAY "EMPLOYEE--Type employee's job class>" WITH NO ADVANCING.
ACCEPT Job-Class
SET MODIFY-FLAG TO FALSE.
IF CHANGE-EMP SET MODIFY-FLAG TO TRUE.
IF CHANGE-EMP
FIND Department-Rec RECORD
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "NO SUCH DEPARTMENT, MODIFICATION TERMINATED."
GO TO ADD-EMPLOYEE-EXIT
ELSE FIND Classification-Rec RECORD
IF ERROR-STATUS NOT = 0,
DISPLAY "NO SUCH CLASS, MODIFICATION TERMINATED."
GO TO ADD-EMPLOYEE-EXIT
ELSE FIND CURRENT Employee-Rec RECORD
MODIFY Employee-Rec
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Modification failed ???"
ELSE DISPLAY "*** Employee record modified ***"
ELSE
SET ERROR-STATUS TO 0
FIND Department-Rec RECORD
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "NO SUCH DEPARTMENT--RECORD TERMINATED"
GO TO ADD-EMPLOYEE-EXIT
ELSE FIND Classification-Rec RECORD
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "NO SUCH CLASSIFICATION-STORE TERMINATED"
GO TO ADD-EMPLOYEE-EXIT
ELSE STORE Employee-Rec
IF ERROR-STATUS = 0 OR OK
DISPLAY "*** employee record stored ***"
ELSE DISPLAY "??? Employee record not stored ???".
IF MODIFIED
REMOVE Employee-Rec FROM Employees
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO ADD-EMPLOYEE-EXIT
ELSE FIND Department-Rec
IF ERROR-STATUS NOT = 0 AND NOT OK
GO TO ADD-EMPLOYEE-EXIT
ELSE FIND CURRENT OF Employee-Rec RECORD
INSERT Employee-Rec INTO Employees
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Insertion into dept set failed ???"
ELSE DISPLAY "*** Add employee routine concluded ***".
ADD-EMPLOYEE-EXIT.
EXIT.
******************************************************************
* *
* D E L E T E - E M P L O Y E E *
* *
******************************************************************
DELETE-EMPLOYEE.
DISPLAY "DELETE EMPLOYEE -- Type employee number>" WITH NO ADVANCING.
ACCEPT Emp-Num.
FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Employee-Head not found ???"
SET DONE TO TRUE
GO TO DELETE-EMPLOYEE-EXIT.
ENTER MACRO FINS6 USING "Employee-Rec", "Employee-Head".
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "Employee not found"
GO TO DELETE-EMPLOYEE-EXIT.
GET Employee-Rec.
DISPLAY Employee-Rec.
DELETE Employee-Rec ALL.
IF ERROR-STATUS NOT = 0
DISPLAY "Deletion failed"
ELSE
DISPLAY "Deleted"
FIND CURRENT OF Employee-Head-Rec RECORD.
GET Employee-Head-Rec
SET Num-of-Emp DOWN BY 1
MODIFY Employee-Head-Rec Num-of-Emp
IF ERROR-STATUS Not = 0 AND NOT OK
GO TO DELETE-EMPLOYEE-EXIT.
DELETE-EMPLOYEE-EXIT.
EXIT.
******************************************************************
* *
* D I S P L A Y - E M P L O Y E E *
* *
******************************************************************
DISPLAY-EMPLOYEE.
DISPLAY "DISPLAY EMPLOYEE--Type employee number>" WITH NO ADVANCING.
ACCEPT Emp-Num.
FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "???No employee-head ???"
SET DONE TO TRUE
GO TO DISPLAY-EMPLOYEE-EXIT.
ENTER MACRO FINS6 USING "EMPLOYEE-Rec","EMPLOYEE-HEAD".
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Employee ",Emp-Num," not found ???"
DISPLAY "??? TYPE 'R' TO RETRY >" WITH NO ADVANCING
ACCEPT Function
IF Function NOT = "R" GO TO DISPLAY-EMPLOYEE-EXIT
ELSE GO TO DISPLAY-EMPLOYEE.
GET Employee-Rec
IF ERROR-STATUS NOT = 0
DISPLAY "??? NO EMPLOYEE RECORD ???"
GO TO DISPLAY-EMPLOYEE-EXIT.
DISPLAY "EMPLOYEE # ",Emp-Num.
DISPLAY "NAME: ", Emp-Name.
DISPLAY"ADDRESS: ",Emp-Address.
DISPLAY "SICK LEAVE: ", Emp-Sick-Leave.
DISPLAY "VACATION: ", Emp-Vacation.
DISPLAY "WAGE: ", Emp-Hour-Wage.
DISPLAY "++++++++++++++++".
FIND FIRST Spouse-Rec RECORD OF Family SET.
IF ERROR-STATUS NOT = 0 GO TO DISPLAY-CHILDREN.
DISPLAY"SPOUSE:".
GET Spouse-Rec.
DISPLAY Spouse-Name.
DISPLAY-CHILDREN.
FIND FIRST Child-Rec RECORD OF Family SET.
IF ERROR-STATUS NOT = 0 GO TO DISPLAY-EMPLOYEE-EXIT.
GET Child-Rec.
DISPLAY "CHILDREN:".
DISPLAY Child-Name.
DISPLAY-CHILDREN-LOOP.
FIND NEXT Child-Rec RECORD OF Family SET.
IF ERROR-STATUS NOT = 0 GO TO DISPLAY-EMPLOYEE-EXIT.
GET Child-Rec.
DISPLAY Child-Name.
GO TO DISPLAY-CHILDREN-LOOP.
DISPLAY-EMPLOYEE-EXIT.
******************************************************************
* *
* L I S T - E M P L O Y E E S *
* *
******************************************************************
LIST-EMPLOYEES.
FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? No employee-head ???"
SET DONE TO TRUE
GO TO LIST-EMPLOYEES-EXIT.
FIND FIRST EMPLOYEE-REC RECORD OF EMPLOYEE-HEAD SET.
IF ERROR-STATUS NOT = 0 AND END-OF-SET,
DISPLAY "--- No Employees in Data Base ---"
GO TO LIST-EMPLOYEES-EXIT
ELSE IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO LIST-EMPLOYEES-EXIT.
GET Employee-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO LIST-EMPLOYEES-EXIT.
DISPLAY Emp-Num," ",Emp-Name.
LIST-EMPLOYEES-LOOP.
FIND NEXT Employee-Rec RECORD OF Employee-Head SET.
IF ERROR-STATUS = 0 OR OK,
GET Employee-Rec
IF ERROR-STATUS = 0 OR OK,
DISPLAY Emp-Num," ",Emp-Name
GO TO LIST-EMPLOYEES-LOOP.
LIST-EMPLOYEES-EXIT.
EXIT.
******************************************************************
* *
* A D D - S P O U S E *
* *
******************************************************************
ADD-SPOUSE.
DISPLAY "ADD SPOUSE -- Type employee number>" WITH NO ADVANCING.
ACCEPT Emp-Num.
FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? No employee-head ???"
SET DONE TO TRUE
GO TO ADD-SPOUSE-EXIT.
ENTER MACRO FINS6 USING "Employee-Rec", "Employee-Head".
IF ERROR-STATUS NOT = 0,
DISPLAY "Employee not found"
GO TO ADD-SPOUSE-EXIT.
DISPLAY "Type spouse's last name: " WITH NO ADVANCING.
ACCEPT Last-name OF Spouse-Name.
DISPLAY "Type spouse's first name: " WITH NO ADVANCING.
ACCEPT First-Name OF Spouse-Name.
DISPLAY "Type spouse's middle initial: " WITH NO ADVANCING.
ACCEPT Middle-Initial OF Spouse-Name.
DISPLAY "Type spouse's date of birth: " WITH NO ADVANCING.
ACCEPT S-Date-of-Birth.
DISPLAY "Type spouse's sex: " WITH NO ADVANCING.
ACCEPT Spouse-Sex.
STORE Spouse-Rec.
IF ERROR-STATUS = 0
DISPLAY "Spouse added"
ELSE
DISPLAY "Spouse not added".
ADD-SPOUSE-EXIT.
EXIT.
******************************************************************
* *
* A D D - C H I L D *
* *
******************************************************************
ADD-CHILD.
DISPLAY "ADD CHILD -- Type employee number>" WITH NO ADVANCING.
ACCEPT Emp-Num.
FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? No employee-head ???"
SET DONE TO TRUE
GO TO ADD-CHILD-EXIT.
ENTER MACRO FINS6 USING "Employee-Rec", "Employee-Head".
IF ERROR-STATUS NOT = 0,
DISPLAY "Employee not found"
GO TO ADD-CHILD-EXIT.
DISPLAY "Type child's last name: " WITH NO ADVANCING.
ACCEPT Last-Name OF Child-Name.
DISPLAY "Type child's first name: " WITH NO ADVANCING.
ACCEPT First-Name of Child-Name.
DISPLAY "Type child's middle initial: " WITH NO ADVANCING.
ACCEPT Middle-Initial OF Child-Name.
DISPLAY "Type child's date of birth: " WITH NO ADVANCING.
ACCEPT Date-of-Birth.
DISPLAY "Type child's sex: " WITH NO ADVANCING.
ACCEPT Child-sex.
STORE Child-Rec.
IF ERROR-STATUS = 0
DISPLAY "Child added"
ELSE
DISPLAY "Child not added".
ADD-CHILD-EXIT.
EXIT.
******************************************************************
* *
* E X I T - P A R A *
* *
******************************************************************
EXIT-PARA.
SET DONE TO TRUE.
GO TO DISPATCH-EXIT.
******************************************************************
* *
* I N V A L I D - R E S P O N S E - P A R A *
* *
******************************************************************
INVALID-RESPONSE-PARA.
DISPLAY " ".
DISPLAY Function, " is not defined."
******************************************************************
* *
* H E L P - P A R A *
* *
******************************************************************
HELP-PARA.
DISPLAY " ".
DISPLAY "The Menus you may call are:".
DISPLAY "CL CLASSIFICATION".
DISPLAY " Add Classification".
DISPLAY " Delete Classification".
DISPLAY " List all classifications".
DISPLAY "CU CUSTOMERS".
DISPLAY " List all customers and orders".
DISPLAY " List all customers".
DISPLAY " List one customer and his orders".
DISPLAY "DE DEPARTMENT".
DISPLAY " Add Department".
DISPLAY " Change department".
DISPLAY " Delete Department".
DISPLAY " List departments".
DISPLAY "EM EMPLOYEE".
DISPLAY " Add Employee".
DISPLAY " Delete Employee".
DISPLAY " Display employees".
DISPLAY " Change Employee".
DISPLAY " Add Spouse".
DISPLAY " Add Child".
DISPLAY "OR ORDER PROCESSING".
DISPLAY "PA PARTS".
DISPLAY " Add part".
DISPLAY " Delete part".
DISPLAY " List parts".
DISPLAY " Show part".
DISPLAY "ST STATISTICS".
DISPLAY " Type Statistics on Terminal".
DISPLAY " Write Statistics to Variable".
DISPLAY "TR TRUCKS".
DISPLAY " Add Truck Route".
DISPLAY " Delete Truck Route".
DISPLAY " List Truck Routes".
DISPLAY " Show One Truck and Items on it".
DISPLAY " ".
DISPLAY "The non-Menu Functions are:".
DISPLAY " ".
DISPLAY "EX Conclude Session".
DISPLAY "HE Type these Messages".
DISPLAY "IN Initialize Header Records".
DISPLAY "ME Type abbreviated command list".
DISPLAY "MS Set exception messages".
DISPLAY " ".
HELP-END.
GO TO DISPATCH-EXIT.
******************************************************************
* *
* M E N U - P A R A *
* *
******************************************************************
MENU-PARA.
DISPLAY "Available menus and functions are:".
DISPLAY " CL: AD, DE, HE, LI".
DISPLAY " CU: AL, HE, LA, LO".
DISPLAY " DE: AD, CH, DE, LI, HE".
DISPLAY " EM: AC, AD, AS, CH, DE, DI, HE, LI".
DISPLAY " EX".
DISPLAY " HE".
DISPLAY " IN".
DISPLAY " ME".
DISPLAY " MS".
DISPLAY " OR".
DISPLAY " PA: AD, DE, HE, LI, SH".
DISPLAY " ST: TE, VA".
DISPLAY " TR".
DISPLAY " ".
GO TO DISPATCH-EXIT.
******************************************************************
* *
* I N I T - P A R A *
* *
******************************************************************
INIT-PARA.
SET Last-Order-Num TO 0
STORE Number-of-Last-Order-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "Number of last order record not stored"
GO TO DISPATCH-EXIT.
SET Num-of-Cust TO 0.
STORE Cust-Head-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "Cust-Head not stored."
GO TO DISPATCH-EXIT.
DISPLAY "Cust-Head stored."
SET Num-of-Emp TO 0.
STORE Employee-Head-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "Employee-Head not stored."
GO TO DISPATCH-EXIT.
DISPLAY "Employee-Head stored."
SET Num-of-Parts TO 0.
STORE Part-Head-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "Part-Head not stored."
GO TO DISPATCH-EXIT.
DISPLAY "Part-Head stored."
SET Num-of-PO TO 0.
STORE Purchase-Order-Head-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "Purchase-Order-Head not stored."
GO TO DISPATCH-EXIT.
SET Num-Work-Orders TO 0.
STORE Work-Order-Head-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "Work-Order-Head not stored."
ELSE DISPLAY "Work-Order-Head stored."
GO TO DISPATCH-EXIT.
******************************************************************
* *
* E X C E P T I O N - M S G - P A R A *
* *
* This routine is called to determine whether the user wants to *
* the complete error messages or only the exception codes. *
* *
******************************************************************
EXCEPTION-MSG-PARA.
DISPLAY " ".
DISPLAY "Do you want to receive exception messages?".
DISPLAY "Type Y or N >" WITH NO ADVANCING.
ACCEPT Function.
IF Function = "Y" OR "YE"
SET EXCEPTION-MSGS TO TRUE
ELSE SET EXCEPTION-MSGS TO FALSE.
EXCEPTION-MSG-EXIT.
GO TO DISPATCH-EXIT.
******************************************************************
* *
* O R D E R - P R O C E S S - P A R A *
* *
******************************************************************
ORDER-PROCESS-PARA.
DISPLAY "ORDER-PROCESSOR--Type customer number>" WITH NO ADVANCING.
ACCEPT Cust-Num.
IF Cust-Num = "@" GO TO ORDER-PROCESS-EXIT.
IF Cust-Num = "?" OR "HE"
DISPLAY "HELP--Type a five-digit customer number"
GO TO ORDER-PROCESS-PARA.
ENTER MACRO FINS6 USING "Customer-Rec","Cust-Head".
IF ERROR-STATUS = 0 OR OK,
GO TO PROCESS-ORDER.
IF ERROR-STATUS = 0 OR NOT NO-SUCH-KEY,
GO TO ORDER-PROCESS-EXIT.
DISPLAY "This is the first time that the customer has placed an order".
DISPLAY "The Customer-number that you typed is ",Cust-Num.
DISPLAY " ".
DISPLAY "Type Y if this is the right number".
DISPLAY "Type R if you wish to reenter the number.".
DISPLAY "Anything else aborts >" WITH NO ADVANCING.
ACCEPT Function.
IF Function = "R" OR "RE" GO TO ORDER-PROCESS-PARA.
IF FUNCTION NOT = "Y" AND FUNCTION NOT = "YE"
GO TO ORDER-PROCESS-EXIT.
DISPLAY "ORDER PROCESSOR--Type customer's name>" WITH NO ADVANCING.
ACCEPT Cust-Name.
IF Cust-Name = "@" GO TO ORDER-PROCESS-EXIT.
DISPLAY "ORDER PROCESSOR--Type customer's street>" WITH NO ADVANCING.
ACCEPT Cust-Street.
IF Cust-Street = "@" GO TO ORDER-PROCESS-EXIT.
DISPLAY "ORDER PROCESSOR--Type customer's city>" WITH NO ADVANCING.
ACCEPT Cust-City.
IF Cust-City = "@" GO TO ORDER-PROCESS-EXIT.
DISPLAY "ORDER PROCESSOR--Type customer's state>" WITH NO ADVANCING.
ACCEPT Cust-State.
IF Cust-State = "@" GO TO ORDER-PROCESS-EXIT.
DISPLAY "ORDER PROCESSOR--Type customer's zip code>" WITH NO ADVANCING.
ACCEPT Cust-Zip.
MOVE 999 TO Cust-Rating.
PERFORM CONVERT-ZIP-TO-ROUTE.
SET Cust-Size TO 0.
MOVE ZERO TO Cust-Balance.
FIND FIRST Cust-Head-Rec RECORD OF Cust-Head-Sys SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? No Cust-Head ???"
GO TO ORDER-PROCESS-EXIT.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO ORDER-PROCESS-EXIT.
SET Num-of-Cust UP BY 1.
MODIFY Cust-Head-Rec Num-of-Cust.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Unable TO CHANGE NUMBER OF CUSTOMERS"
GO TO ORDER-PROCESS-EXIT.
STORE Customer-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Unable to add new customer ???"
GO TO ORDER-PROCESS-EXIT.
PROCESS-ORDER.
FIND FIRST Number-of-Last-Order-Rec RECORD OF Head-Area AREA.
GET Number-of-Last-Order-Rec.
SET Last-Order-Num UP BY 1.
MODIFY Number-of-Last-Order-Rec Last-Order-Num.
SET Ord-Num TO Last-Order-Num.
DISPLAY "ORDER PROCESSOR--Type today's date> " WITH NO ADVANCING.
ACCEPT Ord-Entered-Date.
DISPLAY "ORDER PROCESSOR--Type date when customer expects shipment> "
WITH NO ADVANCING.
ACCEPT Ord-Due-Date.
STORE Order-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO ORDER-PROCESS-EXIT.
FIND FIRST Part-Head-Rec RECORD OF Part-Head-Sys SET.
IF ERROR-STATUS NOT = 0
DISPLAY "??? No part head ???"
GO TO ORDER-PROCESS-EXIT.
SET ITEM-FLAG TO TRUE.
FIND FIRST Part-Head-Rec RECORD OF Part-Head-Sys SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Part-Head not found ???"
GO TO ORDER-PROCESS-EXIT.
GET Part-Head-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO ORDER-PROCESS-EXIT.
REDO-PART-NUMBER.
DISPLAY "ORDER PROCESSOR--Type part number>" WITH NO ADVANCING.
ACCEPT Item-Part.
IF Item-Part = "@" GO TO END-ORDER.
MOVE Item-Part TO Part-Num.
ENTER MACRO FINS6 USING "Part-Rec","Part-Head".
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Illegal part number, please retype ???"
GO TO REDO-PART-NUMBER.
GET Part-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO ORDER-PROCESS-EXIT.
DISPLAY "Is ", Part-name, " correct? Type Y or N >" WITH NO ADVANCING.
ACCEPT Function.
IF Function = "N " OR "NO" GO TO REDO-PART-NUMBER.
DISPLAY "ORDER PROCESSOR--Type quantity requested >" WITH NO ADVANCING.
ACCEPT Item-Qty.
IF Item-Qty < 0 GO TO ORDER-PROCESS-EXIT.
MULTIPLY Item-Qty BY Part-Price GIVING Item-Price
ADD Item-Price TO Ord-Cost.
SUBTRACT Item-Qty FROM Part-Available GIVING Part-Req-Reserved.
IF Part-Req-Reserved NOT < 0 GO TO ENOUGH-STOCKED.
FIND CURRENT Part-Rec RECORD.
MOVE Part-Lead-Time TO WS-Part-Lead-Time.
DISPLAY "There are not enough in stock.".
DISPLAY "More are being ordered.".
MULTIPLY -1 BY Part-Req-Reserved.
ADD Part-Req-Reserved TO Part-Ordered.
SET Part-Reserved UP BY Part-Available.
MOVE 0 TO Part-Available.
MODIFY Part-Rec Part-Available,Part-Reserved,Part-Ordered.
PERFORM SHIPPING-DATE THRU SHIPPING-DATE-EXIT.
IF MORE-ITEMS GO TO NEXT-ITEM-2.
GO TO END-ORDER.
ENOUGH-STOCKED.
FIND CURRENT Part-Rec RECORD.
MOVE 0 TO WS-Part-Lead-Time.
DISPLAY "There are enough stocked to fill item.".
SUBTRACT Item-Qty FROM Part-Available.
ADD Item-Qty TO Part-Reserved.
MODIFY Part-Rec Part-Available,Part-Reserved.
PERFORM SHIPPING-DATE THRU SHIPPING-DATE-EXIT.
IF MORE-ITEMS GO TO NEXT-ITEM-2.
* HERE WHEN ALL ITEMS ARE TYPED
END-ORDER.
MOVE 0 TO Part-Req-Reserved.
FIND CURRENT Order-Rec RECORD.
GET Order-Rec.
DISPLAY "ORDER PROCESSOR--Type Ammount Billed> " WITH NO ADVANCING.
ACCEPT Ord-Amt-Billed.
SUBTRACT Ord-Amt-Billed FROM Ord-Cost GIVING Ord-Amt-Outstand.
DISPLAY "AMMOUNT OUTSTANDING IS *** ",Ord-Amt-Outstand.
DISPLAY "This is order number ", Ord-Num.
MODIFY Order-Rec Ord-Amt-Billed, Ord-Amt-Outstand.
FIND CURRENT OF Customer-Rec RECORD.
GET Customer-Rec.
ADD Ord-Amt-Outstand TO Cust-Balance.
MODIFY Customer-Rec Cust-Balance.
MOVE 0 TO Ord-Cost.
GO TO ORDER-PROCESS-EXIT.
NEXT-ITEM-2.
FIND CURRENT Part-Rec RECORD.
FIND CURRENT Order-Rec RECORD.
SET ITEM-FLAG TO FALSE.
ADD 1 TO Temp-Items.
DISPLAY "ORDER PROCESSOR--Are there additional items? Type Y or N >"
WITH NO ADVANCING.
ACCEPT Function.
IF Function = "Y" OR "YE"
SET ITEM-FLAG TO TRUE
GO TO REDO-PART-NUMBER.
GO TO END-ORDER.
ORDER-PROCESS-EXIT.
GO TO DISPATCH-EXIT.
******************************************************************
* *
* P A R T - P A R A *
* *
******************************************************************
PART-PARA.
PERFORM PART-HELP.
DISPLAY "PART-MENU>" WITH NO ADVANCING.
ACCEPT Function.
IF Function = "AD" PERFORM ADD-PART THROUGH ADD-PART-EXIT
ELSE
IF Function = "DE" PERFORM DELETE-PART THROUGH DELETE-PART-EXIT
ELSE
IF Function = "?" OR "HE" GO TO PART-PARA
ELSE
IF Function = "LI" PERFORM LIST-PARTS THROUGH LIST-PARTS-EXIT
ELSE
IF Function = "SH" PERFORM SHOW-PART THROUGH SHOW-PART-EXIT
ELSE
IF Function = "@" GO TO DISPATCH-EXIT
ELSE
DISPLAY Function, " is undefined???"
GO TO PART-PARA.
GO TO DISPATCH-EXIT.
******************************************************************
* *
* P A R T - H E L P *
* *
******************************************************************
PART-HELP.
DISPLAY " ".
DISPLAY "@ Abort and return to THEME-MAIN-MENU".
DISPLAY " ? Display this message".
DISPLAY "AD Add part".
DISPLAY "DE Delete part".
DISPLAY "HE Display this message".
DISPLAY "LI List parts".
DISPLAY "SH Show one part".
DISPLAY " ".
******************************************************************
* *
* A D D - P A R T *
* *
******************************************************************
ADD-PART.
DISPLAY " ".
DISPLAY "ADD PART -- Type part number>" WITH NO ADVANCING.
ACCEPT Part-Num.
FIND FIRST Part-Head-Rec RECORD OF Part-Head-Sys SET.
IF ERROR-STATUS NOT = 0,
DISPLAY "??? Part-Head not found ???"
GO TO ADD-PART-EXIT.
GET Part-Head-Rec.
FIND Part-Rec VIA CURRENT OF Part-Head USING Part-Num.
IF ERROR-STATUS EQUAL TO 0
DISPLAY "This part already exists"
GO TO ADD-PART-EXIT
ELSE IF NOT NO-SUCH-KEY
DISPLAY "??? Unable to find record ???"
GO TO ADD-PART-EXIT.
SET Num-of-Parts UP BY 1.
MODIFY Part-Head-Rec Num-of-Parts.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO ADD-PART-EXIT.
DISPLAY "ADD PART -- Type part name>" WITH NO ADVANCING.
ACCEPT Part-Name.
DISPLAY "ADD PART -- Type quantity available>" WITH NO ADVANCING.
ACCEPT Part-Available.
DISPLAY "ADD PART -- Type quantity reserved>" WITH NO ADVANCING.
ACCEPT Part-Reserved.
DISPLAY "ADD PART -- Type quantity ordered>" WITH NO ADVANCING.
ACCEPT Part-Ordered.
DISPLAY "ADD PART -- Type lead time>" WITH NO ADVANCING.
ACCEPT Part-Lead-Time.
DISPLAY "ADD PART -- Type cost>" WITH NO ADVANCING.
ACCEPT Part-Std-Cost.
COMPUTE Part-Price = 1.5 * Part-Std-Cost.
DISPLAY "Price will be ", Part-Price.
STORE Part-Rec.
IF ERROR-STATUS = 0 OR OK
DISPLAY "*** Part stored ***"
ELSE DISPLAY "??? Part not stored ???".
ADD-PART-EXIT.
EXIT.
******************************************************************
* *
* D E L E T E - P A R T *
* *
******************************************************************
DELETE-PART.
DISPLAY "DELETE PART -- Type part number>" WITH NO ADVANCING.
ACCEPT Part-Num.
FIND FIRST Part-Head-Rec RECORD OF Part-Head-Sys SET.
IF ERROR-STATUS NOT = 0,
DISPLAY "??? No Part-Head ???"
GO TO DELETE-PART-EXIT.
ENTER MACRO FINS6 USING "Part-Rec", "Part-Head".
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "Part not found"
GO TO DELETE-PART-EXIT.
DELETE Part-Rec ALL.
IF ERROR-STATUS NOT = 0,
DISPLAY "??? Deletion failed ???"
GO TO DELETE-PART-EXIT.
DISPLAY "Deleted".
FIND CURRENT OF Part-Head-Rec RECORD.
IF ERROR-STATUS NOT = 0,
GO TO DELETE-PART-EXIT.
GET Part-Head-Rec.
IF ERROR-STATUS NOT = 0,
GO TO DELETE-PART-EXIT.
SET Num-of-Parts DOWN BY 1.
MODIFY Part-Head-Rec Num-of-Parts.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO DELETE-PART-EXIT.
DELETE-PART-EXIT.
EXIT.
******************************************************************
* *
* L I S T - P A R T S *
* *
******************************************************************
LIST-PARTS.
FIND FIRST Part-Head-Rec RECORD OF Part-Head-Sys SET.
GET Part-Head-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? No Part-Head ???"
GO TO LIST-PARTS-EXIT.
FIND FIRST Part-Rec RECORD OF Part-Head SET.
IF ERROR-STATUS NOT = 0 AND NO-SUCH-KEY,
DISPLAY "--- No parts in database ---"
GO TO LIST-PARTS-EXIT.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO LIST-PARTS-EXIT.
GET Part-Rec.
IF ERROR-STATUS NOT = 0 AND NOT OK,
GO TO LIST-PARTS-EXIT.
DISPLAY Part-Num, " ", Part-Name.
LIST-PARTS-LOOP.
FIND NEXT Part-Rec RECORD OF Part-Head SET.
IF ERROR-STATUS = 0 OR OK,
GET Part-Rec
IF ERROR-STATUS = 0 OR OK,
DISPLAY Part-Num, " ", Part-Name
GO TO LIST-PARTS-LOOP.
LIST-PARTS-EXIT.
EXIT.
******************************************************************
* *
* S H O W - P A R T *
* *
******************************************************************
SHOW-PART.
DISPLAY "SHOW PART -- Type part number>" WITH NO ADVANCING.
ACCEPT Part-Num.
FIND FIRST Part-Head-Rec RECORD OF Part-Head-Sys SET.
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? No Part-Head ???"
GO TO SHOW-PART-EXIT.
ENTER MACRO FINS6 USING "Part-Rec", "Part-Head".
IF ERROR-STATUS NOT = 0 AND NOT OK,
DISPLAY "??? Part ", Part-Num, " not found ???"
DISPLAY "Type 'R' to retry>" WITH NO ADVANCING
ACCEPT Function
IF Function = "R" GO TO SHOW-PART
ELSE GO TO SHOW-PART-EXIT
ELSE
GET Part-Rec
IF ERROR-STATUS = 0,
DISPLAY "PART NUMBER: ", Part-Num.
DISPLAY "NAME: ", Part-Name.
DISPLAY "AVAILABLE: ", Part-Available.
DISPLAY "RESERVED: ", Part-Reserved.
DISPLAY "ORDERED: ", Part-Ordered.
DISPLAY "LEAD TIME: ", Part-Lead-Time.
DISPLAY "PRICE: ", Part-Price.
SHOW-PART-EXIT.
******************************************************************
* *
* C O N V E R T - Z I P - T O - R O U T E *
* *
******************************************************************
CONVERT-ZIP-TO-ROUTE.
DIVIDE Cust-Zip BY 1000 GIVING Cust-Route.
DISPLAY "Customer is on route # " WITH NO ADVANCING.
DISPLAY Cust-Route.
******************************************************************
* *
* S H I P P I N G - D A T E *
* *
******************************************************************
SHIPPING-DATE.
DISPLAY "Item can be sent ", WS-Part-Lead-Time WITH NO ADVANCING.
DISPLAY " Days from now.".
FIND CURRENT Customer-Rec RECORD.
IF ERROR-STATUS NOT = 0 GO TO SHIPPING-DATE-EXIT.
GET Customer-Rec.
DISPLAY "This Customer is on route #", Cust-Route.
MOVE Cust-Route TO Truck-Route.
FIND Truck-Rec RECORD.
IF ERROR-STATUS NOT = 0
DISPLAY"NO TRUCKS CARRY THAT ROUTE. ARRANGE TO ADD ONE."
STORE Item-Rec
GO TO RESET-LEAD.
GET Truck-Rec.
DISPLAY "The next truck scheduled on that route is on ",
DISPLAY Truck-Date.
IF Truck-Volume-Left = 0
DISPLAY "But it is full."
STORE Item-Rec
GO TO RESET-LEAD.
DISPLAY "Do you want to reserve space on it? " WITH NO ADVANCING.
ACCEPT FUNCTION.
IF FUNCTION NOT = "Y" AND NOT = "YES"
STORE Item-Rec
GO TO RESET-LEAD.
IF Truck-Volume-Left < Temp-Items
DISPLAY "There Is Not Enough Room For Item"
STORE Item-Rec
GO TO RESET-LEAD.
MOVE Truck-Date TO Item-Shipped-Date.
SET Truck-Volume-Left DOWN BY Temp-Items.
MODIFY Truck-Rec Truck-Volume-Left.
DISPLAY"Shipment will be sent on ",Truck-Date.
STORE Item-Rec.
IF ERROR-STATUS NOT = 0
DISPLAY "???UNABLE TO CHANGE TRUCK VOLUME???"
GO TO RESET-LEAD.
DISPLAY "*** Space Reserved ***".
RESET-LEAD.
MOVE 0 TO Temp-Items.
SHIPPING-DATE-EXIT.
EXIT.
******************************************************************
* *
* S T A T S - P A R A *
* *
******************************************************************
STATS-PARA.
DISPLAY " ".
DISPLAY "HE Print this message".
DISPLAY "TE Print Statistics on Terminal".
DISPLAY "VA Write Statistics to Variable".
DISPLAY " ? Print this message".
DISPLAY "@ Abort".
DISPLAY " ".
DISPLAY "STATS-MENU>" WITH NO ADVANCING.
ACCEPT Function.
IF Function = "@" GO TO DISPATCH-EXIT.
IF Function = "HE" OR "?" GO TO STATS-PARA.
IF Function = "TE" ENTER MACRO STATS
* ELSE IF Function "VA" ENTER MACRO STATS USING DATA-ITEM
ELSE DISPLAY Function, " is not defined, reenter command"
GO TO STATS-PARA.
GO TO DISPATCH-EXIT.
******************************************************************
* *
* T R U C K - P A R A *
* *
******************************************************************
TRUCK-PARA.
PERFORM TRUCK-HELP.
DISPLAY "TRUCK-PARA>" WITH NO ADVANCING.
ACCEPT Function.
IF Function = "AD" PERFORM ADD-TRUCK THRU ADD-TRUCK-EXIT
ELSE
IF Function = "DE" PERFORM DELETE-TRUCK THRU DELETE-TRUCK-EXIT
ELSE
IF Function = "HE" OR "?" GO TO TRUCK-PARA
ELSE
IF Function = "LI" PERFORM LIST-TRUCKS THRU LIST-TRUCKS-EXIT
ELSE
IF Function = "SH" PERFORM LIST-TRUCK-ITEMS THRU LIST-TRUCK-ITEMS-EXIT
ELSE
IF Function = "@" GO TO DISPATCH-EXIT
ELSE
DISPLAY Function, " is undefined???"
GO TO TRUCK-PARA.
GO TO DISPATCH-EXIT.
******************************************************************
* *
* T R U C K - H E L P *
* *
******************************************************************
TRUCK-HELP.
DISPLAY " ".
DISPLAY "@ Abort and return to THEME-MAIN-MENU".
DISPLAY " ? Display this message".
DISPLAY "AD Add truck route".
DISPLAY "DE Delete truck route".
DISPLAY "HE Display this message".
DISPLAY "LI List truck routes".
DISPLAY "SH Show one truck and its contents".
DISPLAY " ".
******************************************************************
* *
* A D D - T R U C K *
* *
******************************************************************
ADD-TRUCK.
FIND FIRST Department-Rec RECORD IN Manufacturing-Area AREA.
IF ERROR-STATUS NOT = 0
DISPLAY "NO DEPARTMENT RECORD???"
GO TO ADD-TRUCK-EXIT.
DISPLAY "ADD TRUCK--Type 2 digit route #> " WITH NO ADVANCING.
ACCEPT Truck-Route.
FIND Truck-Rec RECORD.
IF ERROR-STATUS = 0
DISPLAY "There is already a truck on this route."
GO TO ADD-TRUCK-EXIT.
DISPLAY "ADD TRUCK--Type date truck will travel> " WITH NO ADVANCING.
ACCEPT Truck-Date.
DISPLAY "ADD TRUCK--Type capacity (in number of items)> ",
WITH NO ADVANCING.
ACCEPT Truck-Volume-Left.
STORE Truck-Rec.
IF ERROR-STATUS NOT = 0,
DISPLAY "???TRUCK-RECORD NOT STORED???"
ELSE DISPLAY "*** Truck Record Stored ***".
ADD-TRUCK-EXIT.
EXIT.
******************************************************************
* *
* D E L E T E - T R U C K *
* *
******************************************************************
DELETE-TRUCK.
DISPLAY "DELETE TRUCK--Type route number> " WITH NO ADVANCING.
ACCEPT Truck-Route.
FIND Truck-Rec RECORD.
IF ERROR-STATUS NOT = 0
DISPLAY "This Route not entered."
GO TO DELETE-TRUCK-EXIT.
GET Truck-Rec.
FIND FIRST Item-Rec RECORD OF Shipping SET.
IF ERROR-STATUS NOT = 0
DELETE Truck-Rec
DISPLAY "*** TRUCK RECORD DELETED ***"
GO TO DELETE-TRUCK-EXIT.
DISPLAY "THIS TRUCK IS CARRYING ORDERS AND CANNOT BE DELETED.".
DELETE-TRUCK-EXIT.
EXIT.
******************************************************************
* *
* L I S T - T R U C K S *
* *
******************************************************************
LIST-TRUCKS.
FIND FIRST Department-Rec RECORD OF Manufacturing-Area AREA.
IF ERROR-STATUS NOT = 0
DISPLAY "??? NO DEPARTMENT RECORDS ???"
GO TO LIST-TRUCKS-EXIT.
FIND FIRST Truck-Rec RECORD OF Truck SET.
IF ERROR-STATUS NOT = 0
DISPLAY "??? No Trucks in data base???"
GO TO LIST-TRUCKS-EXIT.
GET Truck-Rec.
DISPLAY "ROUTE DATE VOLUME LEFT".
DISPLAY Truck-Route," ",Truck-Date," ",Truck-Volume-Left.
LIST-TRUCK-LOOP.
FIND NEXT Truck-Rec RECORD OF Truck SET.
IF ERROR-STATUS NOT = 0 GO TO LIST-TRUCKS-EXIT.
GET Truck-Rec.
DISPLAY Truck-Route," ",Truck-Date," ",Truck-Volume-Left.
GO TO LIST-TRUCK-LOOP.
LIST-TRUCKS-EXIT.
EXIT.
******************************************************************
* *
* L I S T - T R U C K - I T E M S *
* *
******************************************************************
LIST-TRUCK-ITEMS.
DISPLAY"TRUCK--Type Truck Route #> "WITH NO ADVANCING.
ACCEPT Truck-Route.
FIND Truck-Rec RECORD.
IF ERROR-STATUS NOT = 0
DISPLAY "TRUCK NOT FOUND"
GO TO LIST-TRUCK-ITEMS-EXIT.
GET Truck-Rec.
DISPLAY "######## ROUTE ",Truck-Route," ########".
FIND FIRST Item-Rec RECORD OF Shipping SET.
IF ERROR-STATUS NOT = 0
DISPLAY "+++ NO ITEMS ON TRUCK +++"
GO TO LIST-TRUCK-ITEMS-EXIT.
GET Item-Rec.
DISPLAY "PART: ",Item-Part, " QTY: ",Item-Qty.
LIST-TRUCK-ITEMS-LOOP.
FIND NEXT Item-Rec RECORD OF Shipping SET.
IF ERROR-STATUS NOT = 0 GO TO LIST-TRUCK-ITEMS-EXIT.
GET Item-Rec.
DISPLAY "PART: ",Item-Part, " QTY: ",Item-Qty.
GO TO LIST-TRUCK-ITEMS-LOOP.
LIST-TRUCK-ITEMS-EXIT.
EXIT.
******************************************************************
* *
* N U M E R I C - C H E C K *
* *
******************************************************************
NUMERIC-CHECK.
IF (WS-ARRAY (COUNTER) < "0" OR > "9")
AND WS-ARRAY (COUNTER) NOT = " " SET BAD-NUMBER-FLAG TO TRUE.