Google
 

Trailing-Edge - PDP-10 Archives - DBMS-20_V6_BIN_19811001 - sources/thefor.fml
There are 2 other files named thefor.fml in the archive. Click here to see a list.
	PROGRAM DEMO
	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, EXMS, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /EX/ EXMS
	COMMON /UTIL/ FUNCTN


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

*DBMS
	OPEN AREA Head-Area
		USAGE-MODE IS EXCLUSIVE UPDATE
		PRIVACY KEY IS N1234.
	IF (ERSTAT .EQ. 0) GO TO 1
		TYPE 2
2		FORMAT (' ? Not able to open Head-Area.')
		GO TO 999
1	CONTINUE
*DBMS
	OPEN AREA Index-Block-Area
		USAGE-MODE IS EXCLUSIVE UPDATE
		PRIVACY KEY IS N1234.
	IF (ERSTAT .EQ. 0) GO TO 3
		TYPE 4
4		FORMAT (' Not able to open Index-Block-area.')
		GO TO 999
3	CONTINUE
*DBMS
	OPEN AREA Inventory-Area
		USAGE-MODE IS EXCLUSIVE UPDATE
		PRIVACY KEY IS N1234.
	IF (ERSTAT .EQ. 0) GO TO 5
		TYPE 6
6		FORMAT (' Not able to open Inventory-Area.')
		GO TO 999
5	CONTINUE
*DBMS
	OPEN AREA Manufacturing-Area
		USAGE-MODE IS EXCLUSIVE UPDATE
		PRIVACY KEY IS N1234.
	IF (ERSTAT .EQ. 0) GO TO 7
		TYPE 8
8		FORMAT (' Not able to open Manufacturing-Area.')
		GO TO 999
7	CONTINUE
*DBMS
	OPEN AREA Orders-Area
		USAGE-MODE IS EXCLUSIVE UPDATE
		PRIVACY KEY IS N1234.
	IF (ERSTAT .EQ. 0) GO TO 9
		TYPE 88
88		FORMAT (' Not able to open Orders-Area.')
		GO TO 999
9	CONTINUE
*DBMS
	OPEN AREA Personnel-Area
		USAGE-MODE IS EXCLUSIVE UPDATE
		PRIVACY KEY IS N1234.
	IF (ERSTAT .EQ. 0) GO TO 10
		TYPE 11
11		FORMAT (' Not able to open Personnel-Area.')
		GO TO 999
10	CONTINUE
*DBMS
	OPEN AREA Personal-Area
		USAGE-MODE IS EXCLUSIVE UPDATE
		PRIVACY KEY IS N1234.
	IF (ERSTAT .EQ. 0) GO TO 21
		TYPE 22
22		FORMAT (' Not able to open Personal-Area')
		GO TO 999
21	CONTINUE

	CHDUM = -1
	EHDUM = -1
	PRDUM = -1
	WHDUM = -1
	OHDUM = -1
*DBMS
	FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
	IF (ERSTAT .EQ. 0 .OR. OK) GO TO 15
		TYPE 16
16		FORMAT (' ???Access failure for Employee-Head???')
		GO TO 999
15	CONTINUE
*DBMS
	FIND FIRST Cust-Head-Rec RECORD OF Cust-Head-Sys SET.
	IF (ERSTAT .EQ. 0 .OR. OK) GO TO 17
		TYPE 18
18		FORMAT (' ???Access failure for Cust-Head???')
		GO TO 999
17	CONTINUE
*DBMS
	FIND FIRST Work-Order-Head-Rec RECORD OF Work-Order-Sys SET.
	IF (ERSTAT .EQ. 0 .OR. OK) GO TO 19
		TYPE 20
20		FORMAT (' ???Access failure for Work-Order-Head???')
		GO TO 999

19	TYPE 14
14	FORMAT ('0Digital DBMS-10/20 Theme Example')
	DONE = .FALSE.
	CALL EXCMSG
	CALL DSPTCH
C*******************************************************************************
C*                                                                             *
C* The next lines of code close data base files and put the journal into a     *
C* "done-with" state.                                                          *
C*                                                                             *
C*******************************************************************************

999	CONTINUE
*DBMS
	CLOSE RUN-UNIT.
*DBMS
	CLOSE JOURNAL.
*DBMS
	END DEMO.
	SUBROUTINE ERRTN

C*******************************************************************************
C*                                                                             *
C*          E R R T N                                                          *
C*                                                                             *
C* FORTRAN USE procedure.                                                      *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, EXMS, DONE, FINAL
	COMMON /EX/ EXMS
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	INTEGER VMSGS (51)

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

	DATA (VMSGS(I),I=1,51)/'Host ','Verbs','     ',
	1 'Close',' Erro','r    ', 'Delet','e Err','or   ',
	3 'Find ','Error','     ', '     ','     ','     ',
	5 'Get E','rror ','     ', '     ','     ','     ',
	7 'Inser','t Err','or   ', 'Modif','y Err','or   ',
	9 'Open ','Error','     ', '     ','     ','     ',
	1 'Remov','e Err','or   ', 'Store',' Erro','r    ',
	3 '     ','     ','     ', '     ','     ','     ',
	5 'Bind ','Error','     ', 'Call ','Error','     '/

	INVKEY = .FALSE.
	ENDSET = .FALSE.
	SIMDEL = .FALSE.
	OK = .FALSE.
	IF (ERSTAT .NE. 240) GO TO 101
		SIMDEL = .TRUE.
		GO TO 999
101	IF (ERSTAT .NE. 307) GO TO 102
		ENDSET = .TRUE.
		GO TO 999
102	IF (ERSTAT .NE. 326) GO TO 103
		INVKEY = .TRUE.
		GO TO 999
103	IF (.NOT. EXMS) GO TO 998
	VERB = ERSTAT / 100
	MSG = ERSTAT - VERB*100
	TYPE 104,(VMSGS(VERB*3+I),I=1,3)
104	FORMAT (1X,3A5)
	IF (VERB .EQ. 0 .OR. VERB .EQ. 1 .OR. VERB .EQ. 9) DONE = .TRUE.
	IF (VERB .EQ. 15 .OR. VERB .EQ. 16) DONE = .TRUE.
	IF (MSG .NE. 0) GO TO 801
		TYPE 105
		GO TO 998
801	IF (MSG .NE. 1) GO TO 802
		TYPE 1
		GO TO 998
802	IF (MSG .NE. 2) GO TO 803
		TYPE 2
		GO TO 998
803	IF (MSG .NE. 3) GO TO 804
		TYPE 3
		GO TO 998
804	IF (MSG .NE. 4) GO TO 805
		TYPE 4
		GO TO 998
805	IF (MSG .NE. 5) GO TO 806
		TYPE 5
		GO TO 998
806	IF (MSG .NE. 6) GO TO 807
		TYPE 6
		GO TO 998
807	IF (MSG .NE. 7) GO TO 808
		TYPE 7
		GO TO 998
808	IF (MSG .NE. 8) GO TO 809
		TYPE 8
		GO TO 998
809	IF (MSG .NE. 9) GO TO 810
		TYPE 9
		GO TO 998
810	IF (MSG .NE. 10) GO TO 811
		TYPE 10
		GO TO 998
811	IF (MSG .NE. 11) GO TO 812
		TYPE 11
		GO TO 998
812	IF (MSG .NE. 12) GO TO 813
		TYPE 12
		GO TO 998
813	IF (MSG .NE. 13) GO TO 814
		TYPE 13
		GO TO 998
814	IF (MSG .NE. 14) GO TO 815
		TYPE 14
		GO TO 998
815	IF (MSG .NE. 15) GO TO 816
		TYPE 15
		GO TO 998
816	IF (MSG .NE. 16) GO TO 817
		TYPE 16
		GO TO 998
817	IF (MSG .NE. 17) GO TO 818
		TYPE 17
		GO TO 998
818	IF (MSG .NE. 18) GO TO 819
		TYPE 18
		GO TO 998
819	IF (MSG .NE. 19) GO TO 820
C		NO ERROR 19
		GO TO 998
820	IF (MSG .NE. 20) GO TO 821
		TYPE 20
		GO TO 998
821	IF (MSG .NE. 21) GO TO 822
C		NO ERROR 21
		GO TO 998
822	IF (MSG .NE. 22) GO TO 823
		TYPE 22
		GO TO 998
823	IF (MSG .NE. 23) GO TO 824
		TYPE 23
		GO TO 998
824	IF (MSG .NE. 24) GO TO 825
		TYPE 24
		GO TO 998
825	IF (MSG .NE. 25) GO TO 826
		TYPE 25
		GO TO 998
826	IF (MSG .NE. 26) GO TO 827
		TYPE 26
		GO TO 998
827	IF (MSG .NE. 27) GO TO 828
C		NO ERROR 27
		GO TO 998
828	IF (MSG .NE. 28) GO TO 829
		TYPE 28
		GO TO 998
829	IF (MSG .NE. 29) GO TO 830
C		NO ERROR 29
		GO TO 998
830	IF (MSG .NE. 30) GO TO 831
		TYPE 30
		GO TO 998
831	IF (MSG .NE. 31) GO TO 832
		TYPE 31
		GO TO 998
832	IF (MSG .NE. 32) GO TO 833
		TYPE 32
		GO TO 998
833	IF (MSG .NE. 33) GO TO 834
		TYPE 33
		GO TO 998
834	IF (MSG .NE. 34) GO TO 835
		TYPE 34
		GO TO 998
835	IF (MSG .NE. 35) GO TO 836
		TYPE 35
		GO TO 998
836	IF (MSG .NE. 36) GO TO 837
		TYPE 36
		GO TO 998
837	IF (MSG .NE. 37) GO TO 838
		TYPE 37
		GO TO 998
838	IF (MSG .NE. 38) GO TO 839
		TYPE 38
		GO TO 998
839	IF (MSG .NE. 39) GO TO 840
		TYPE 39
		GO TO 998
840	IF (MSG .NE. 40) GO TO 841
		TYPE 40
		GO TO 998
841	IF (MSG .NE. 41) GO TO 842
		TYPE 41
		GO TO 998
842	IF (MSG .NE. 42) GO TO 843
		TYPE 42
		GO TO 998
843	IF (MSG .NE. 43) GO TO 844
		TYPE 43
		GO TO 998
844	IF (MSG .NE. 44) GO TO 845
		TYPE 44
		GO TO 998
845	IF (MSG .NE. 45) GO TO 846
		TYPE 45
		GO TO 998
846	IF (MSG .NE. 46) GO TO 847
C		NO ERROR 46
		GO TO 998
847	IF (MSG .NE. 47) GO TO 848
C		NO ERROR 47
		GO TO 998
848	IF (MSG .NE. 48) GO TO 849
C		NO ERROR 48
		GO TO 998
849	IF (MSG .NE. 49) GO TO 850
C		NO ERROR 49
		GO TO 998
850	IF (MSG .NE. 50) GO TO 851
C		NO ERROR 50
		GO TO 998
851	IF (MSG .NE. 51) GO TO 852
C		NO ERROR 51
		GO TO 998
852	IF (MSG .NE. 52) GO TO 853
C		NO ERROR 52
		GO TO 998
853	IF (MSG .NE. 53) GO TO 854
C		NO ERROR 53
		GO TO 998
854	IF (MSG .NE. 54) GO TO 855
C		NO ERROR 54
		GO TO 998
855	IF (MSG .NE. 55) GO TO 856
		TYPE 55
		GO TO 998
856	IF (MSG .NE. 56) GO TO 857
		TYPE 56
		GO TO 998
857	IF (MSG .NE. 57) GO TO 858
		TYPE 57
		GO TO 998
858	IF (MSG .NE. 58) GO TO 859
		TYPE 58
		GO TO 998
859	IF (MSG .NE. 59) GO TO 860
		TYPE 59
		GO TO 998
860	IF (MSG .NE. 60) GO TO 861
		TYPE 60
		GO TO 998
861	IF (MSG .NE. 61) GO TO 862
		TYPE 61
		GO TO 998
862	IF (MSG .NE. 62) GO TO 863
		TYPE 62
		GO TO 998
863	IF (MSG .NE. 63) GO TO 864
		TYPE 63
		GO TO 998
864	IF (MSG .NE. 64) GO TO 865
		TYPE 64
		GO TO 998
865	IF (MSG .NE. 65) GO TO 866
		TYPE 65
		GO TO 998
866	IF (MSG .NE. 66) GO TO 867
		TYPE 66
		GO TO 998
867	IF (MSG .NE. 67) GO TO 868
		TYPE 67
		GO TO 998
868	IF (MSG .NE. 68) GO TO 869
C		NO ERROR 68
		GO TO 998
869	IF (MSG .NE. 69) GO TO 998
C		NO ERROR 69

998	FATAL = .TRUE.
	TYPE 1000, ERSTAT, ERSET, ERREC, ERAREA, ERCNT
1000	FORMAT (/,' ERROR STATUS = ', I5, /,
	1 ' ERROR SET = ', 6A5,/,
	2 ' ERROR RECORD = ', 6A5,/,
	3 ' ERROR AREA = ', 6A5,/,
	4 ' ERROR COUNT = ', I10)
C ERROR MESSAGES

105	FORMAT (' A warning.  Compile-time and run-time versions of',/,
	1       ' schema differ.')
1	FORMAT (' Area not open.')
2	FORMAT (' Data base key inconsistent with area-name.  Can also',/,
	1       ' indicate that a referenced page number is in an area',/,
	2       ' that is not in the invoked sub-schema.')
3	FORMAT (' Record affected (deleted or removed) by concurrent',/,
	1       ' application.')
4	FORMAT (' Data name invalid or inconsistent.  This can occur',/,
	1       ' during GET or MODIFY with a data-name list.')
5	FORMAT (' Violation of DUPLICATES NOT ALLOWED clause.')
6	FORMAT (' Current of set, area, or record-name not known.')
7	FORMAT (' End of set, area, or record.')
8	FORMAT (' Referenced area, record, or set-name not in sub-',/,
	1 ' schema.  This may occur because:',/,
	2 ' 1.  DBCS encounters a record type not in the sub-',/,
	3 '     schema when traversing a set.',/,
	4 ' 2.  Set type owned by the object record type is not',/,
	5 '     in the sub-schema.',/,
	6 ' 3.  The VIA set is not in the sub-schema -- during set',/,
	7 '     selection occurrence.',/,
	8 ' 4.  All subkeys are not in the sub-schema during CALC',/,
	9 '     processing or searching a sorted set.',/,
	1 ' 5.  The sort key or a set not in the sub-schema is',/,
	2 '     modified.')
9	FORMAT (' Update usage mode required.  This is an attempt to',/,
	1       ' use an updating verb when the specified area is open',/,
	2       ' for retrieval.')
10	FORMAT (' Privacy breach attempted.')
11	FORMAT (' Physical space not available.  No room remains for',/,
	1       ' storing records.  This can occur while DBCS is trying',/,
	2       ' to store an internal record type such as an index',/,
	3       ' or buoy.')
12	FORMAT (' Line numbers for data base keys are exhausted.')
13	FORMAT (' No current record of run-unit.')
14	FORMAT (' Object record is MANDATORY AUTOMATIC member of',/,
	1       ' named set.')
15	FORMAT (' Oject record is MANDATORY type or not member type',/,
	1       ' at all in named set.  This is an attempt to REMOVE',/,
	2       ' a record which is either a MANDATORY member or not',/,
	3       ' a member of named set.')
16	FORMAT (' Record is already a member of named set.')
17	FORMAT (' Record has been deleted.  This can occur during a',/,
	1       ' FIND CURRENT of RECORD, SET, AREA, or RUN-UNIT',/,
	2       ' or during a FIND NEXT of SET or AREA.')
18	FORMAT (' Data conversion unsuccessful.')
C NO ERROR 19
20	FORMAT (' Current record of run-unit not of correct record-',/,
	1       ' type.')
C NO ERROR 21
22	FORMAT (' Record not currently member of named or implied set.')
23	FORMAT (' Illegal area-name passed in area identification.')
24	FORMAT (' Temporary and permanent areas referenced in same',/,
	1       ' DML verb.')
25	FORMAT (' No set occurrence satisfies argument values.  This',/,
	1       ' can mean, for example, that the CALC value in the',/,
	2       ' UWA matched no owner record.')
26	FORMAT (' No record satisfies RSE specified.  This is a',/,
	1       ' catch-all exception for the FIND verb.')
C NO ERROR 27
28	FORMAT (' Area already open.')
C NO ERROR 29
30	FORMAT (' Unqualified DELETE attempted on non-empty set.')
31	FORMAT (' Unable to open the Schema File.')
32	FORMAT (' Insufficient space allocated for the data-name.',/,
	1       ' The SIZE clause specifies less space than the',/,
	2       ' compiler needs.')
33	FORMAT (' None of the areas a record type can be within',/,
	1       ' are in the sub-schema.')
34	FORMAT (' A set is in the sub-schema, but its owner record',/,
	1       ' type is not.')
35	FORMAT (' Dynamic use-vector is full (FORTRAN ONLY).')
36	FORMAT (' Attempt to invoke too many sub-schemas (more than',/,
	1       ' 8); or attempt to use UNSET with empty sub-schema',/,
	2       ' stack, or SETDB with a full sub-schema stack.')
37	FORMAT (' Sub-schema passed to SETDB is not already invoked.')
38	FORMAT (' Duplicate operation attempted on a resource.  This',/,
	1       ' can occur because: 1) you attempt to open the',/,
	2       ' journal file twice (you have opened it in EXCLUSIVE',/,
	3       ' UPDATE usage-mode and are now opening a data area',/,
	4       ' in UPDATE usage-mode), or 2) you call JSTRAN while',/,
	5       ' a transaction is already active, or 3) you have',/,
	6       ' multiple INVOKE statements and attempt to open',/,
	7       ' the same area twice.')
39	FORMAT (' data base file not found.')
40	FORMAT (' Request access conflicts with existing access; that',/,
	1       ' is, resource is not available.  This can result from',/,
	2       ' an attempt to:',/,
	3       ' 1.  Open an area in a USAGE-MODE incompatible with',/,
	4       '     that of another run-unit using the same area.',/,
	5       ' 2.  Open the journal in a way that results in a',/,
	6       '     USAGE-MODE conflict.',/,
	7       ' 3.  DELETE a record retained by another run-unit.',/,
	8       ' 4.  Attempt to open area or the journal and the',/,
	9       '     file system signals a file-protection error.')
41	FORMAT (' No JFNs available.  An attempt to open too many areas.')
42	FORMAT (' Area in undefined state.  Use DBMEND to force open',/,
	1       ' the area and return it to a valid state.')
43	FORMAT (' Area in creation state.  This can happen to the',/,
	1       ' system area only.  This will occur if run-unit',/,
	2       ' execution aborts at just the right time during',/,
	3       ' the first OPEN of the system area.  Should this occur',/,
	4       ' either rerun SCHEMA or create a 0-length file with',/,
	5       ' a text editor.')
44	FORMAT (' Attempt to call a journal-processing entry point',/,
	1       ' before the journalling system has been initialized',/,
	2       ' (by the first OPEN that requires journalling).')
45	FORMAT (' Attempt to backup the database with JBTRAN 1)',/,
	1       ' while DBCS''s Cannot-Backup-Updates bit is set, or',/,
	2       ' 2) when the journal is shared and commands are the',/,
	3       ' interleaving unit, or 3) when the journal is shared,',/,
	4       ' transactions are the interleaving unit, and the',/,
	5       ' argument given to JBTRAN is greater than 0.')
C NO ERROR 46
C NO ERROR 47
C NO ERROR 48
C NO ERROR 49
C NO ERROR 50
C NO ERROR 51
C NO ERROR 52
C NO ERROR 53
C NO ERROR 54
55	FORMAT (' Pseudo-exception.  DBCS types message that no',/,
	1       ' sub-schema yet initialized.')
56	FORMAT (' Inconsistent data in the data base file.  DBMEND',/,
	1       ' should be used to restore the data base to a valid',/,
	2       ' state.  If the problem can be reproduced, it',/,
	3       ' probably indicates a DBCS software error.')
57	FORMAT (' Probably a DBCS software error.  If this recurs,',/,
	1       ' report it.')
58	FORMAT (' Illegal argument passed by programmer or setup',/,
	1       ' host interface; for example, passing a set-name',/,
	2       ' with the STORE command.')
59	FORMAT (' No more memory available.')
60	FORMAT (' Unable to access a database file.  The operating',/,
	1       ' system reported an I/O error, either in normal',/,
	2       ' operations or in trying to open a journal for',/,
	3       ' appending.')
61	FORMAT (' Unable to append to journal (that is, the journal',/,
	1       ' is in an aborted state but has not been designated',/,
	2       ' as being done with).')
62	FORMAT (' Attempt to enter DBCS at other than JBTRAN, SBIND,',/,
	1       ' SETDB, or UNSET while the system-in-undefined-state',/,
	2       ' bit is on.')
63	FORMAT (' Unable to complete restoration of the proper data',/,
	1       ' base state.  This occurs either during JBTRAN',/,
	2       ' initialization of a run-unit at the start of a ',/,
	3       ' command or transaction.')
64	FORMAT (' Exceptions while processing exception.')
65	FORMAT (' Monitor space for ENQUEUE entries exhausted, or',/,
	1       ' ENQUEUE quota exceeded.')
66	FORMAT (' ENQUEUE/DEQUEUE failure (for example, you do not',/,
	1       ' have ENQUEUE capabilities, or an unacceptable',/,
	2       ' argument block has been created by DBCS).')
67	FORMAT (' Unable to initialize magnetic tape service because,',/,
	1       ' for example, the IPCF block is bad; the IPCF',/,
	2       ' message is too long; or DAEMDB is not running.')
C NO ERROR 68
C NO ERROR 69

999	RETURN
*DBMS
	END ERRTN.
	SUBROUTINE DSPTCH

C*******************************************************************************
C*                                                                             *
C*          D S P T C H                                                        *
C*                                                                             *
C* This routine accepts user response and calls the appropriate routine.       *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /UTIL/ FUNCTN


1	IF (DONE) GO TO 999
	TYPE 2
2	FORMAT (' THEME-MAIN-MENU>',$)
	ACCEPT 3,FUNCTN
3	FORMAT (1A2)
	IF (FUNCTN .EQ. '@') GO TO 999
	IF (FUNCTN .NE. 'CL' .AND. FUNCTN .NE. 'cl') GO TO 4
		CALL CLASS
		GO TO 1
4	IF (FUNCTN .NE. 'CU' .AND. FUNCTN .NE. 'cu') GO TO 5
		CALL CUST
		GO TO 1
5	IF (FUNCTN .NE. 'DE' .AND. FUNCTN .NE. 'de') GO TO 6
		CALL DEPT
		GO TO 1
6	IF (FUNCTN .NE. 'EM' .AND. FUNCTN .NE. 'em') GO TO 7
		CALL EMPLOY
		GO TO 1
7	IF (FUNCTN .EQ. 'EX' .OR. FUNCTN .EQ. 'ex') GO TO 999
	IF(FUNCTN.NE.'HE'.AND.FUNCTN.NE.'?'.AND.FUNCTN.NE.'he')GO TO 9
		CALL HELPM
		GO TO 1
9	IF (FUNCTN .NE. 'ME' .AND. FUNCTN .NE. 'me') GO TO 10
		CALL MENU
		GO TO 1
10	IF (FUNCTN .NE. 'MS' .AND. FUNCTN .NE. 'ms') GO TO 11
		CALL EXCMSG
		GO TO 1
11	IF (FUNCTN .NE. 'OR' .AND. FUNCTN .NE. 'or') GO TO 112
		CALL ORDER
		GO TO 1
112	IF (FUNCTN .NE. 'PA' .AND. FUNCTN .NE. 'pa') GO TO 12
		CALL PART
		GO TO 1
12	IF (FUNCTN .NE. 'ST' .AND. FUNCTN .NE. 'st') GO TO 13
		CALL STATSP
		GO TO 1
13	IF (FUNCTN .NE. 'TR'.AND. FUNCTN .NE. 'tr') GO TO 14
		CALL TRUCK
		GO TO 1
14	TYPE 15,FUNCTN
15	FORMAT (1X,1A2,' is not defined.')
	CALL HELPM
	GO TO 1

999	RETURN
	END
	SUBROUTINE CLASS

C*******************************************************************************
C*                                                                             *
C*          C L A S S                                                          *
C*                                                                             *
C* This routine accepts a response and calls the function called for.  The     *
C* functions follow this routine.                                              *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /UTIL/ FUNCTN


1	CALL HELPC
	TYPE 2
2	FORMAT (' CLASS-MENU>',$)
	ACCEPT 3,FUNCTN
3	FORMAT (1A2)
	IF (FUNCTN .NE. 'AD' .AND. FUNCTN .NE. 'ad') GO TO 4
		CALL ACLASS
		GO TO 999
4	IF (FUNCTN .NE. 'DE' .AND. FUNCTN .NE. 'de') GO TO 5
		CALL DCLASS
		GO TO 999
5	IF (FUNCTN .EQ. 'HE' .OR. FUNCTN .EQ. 'he') GO TO 1
	IF (FUNCTN .EQ. '? ') GO TO 1
	IF (FUNCTN .NE. 'LI' .AND. FUNCTN .NE. 'li') GO TO 6
		CALL LCLASS
		GO TO 999
6	IF (FUNCTN .EQ. '@ ') GO TO 999
	TYPE 7, FUNCTN
7	FORMAT (1X,1A2,' is undefined.')
	GO TO 1

999	RETURN
	END
	SUBROUTINE HELPC

C*******************************************************************************
C*                                                                             *
C*          H E L P C                                                          *
C*                                                                             *
C*  This is a list of available functions for dealing with CLASSIFICATION      *
C*  records.                                                                   *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE


	TYPE 1
1	FORMAT (/,' @	Abort and return to THEME-MAIN-MENU',/,
	1         '  ?	Display this message',/,
	2         ' AD	Add classification',/,
	3         ' DE	Delete classification',/,
	4         ' HE	Display this message',/,
	5         ' LI	List all classifications',/)

999	RETURN
	END
	SUBROUTINE ACLASS

C*******************************************************************************
C*                                                                             *
C*          A C L A S S                                                        *
C*                                                                             *
C*  This routine adds a classification.                                        *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.
*DBMS
	OPEN TRANSACTION D-B-UPDATE.

5	TYPE 1
1	FORMAT (/,' ADD CLASSIFICATION--Type job classification>',$)
	ACCEPT 2, JBCLAS
2	FORMAT (1A5)
	IF (JBCLAS .EQ. '@    ') GO TO 998
	IF(JBCLAS.NE.'HE'.AND.JBCLAS.NE.'?'.AND.JBCLAS.NE.'he') GO TO 3
		TYPE 4
		GO TO 5
4	FORMAT (' HELP--Type the five character classification code')
3	CONTINUE
*DBMS
	FIND Classification-Rec.
	IF (ERSTAT .NE. 0) GO TO 8
		TYPE 7, JBCLAS
7		FORMAT (1X, 1A5, ' already stored')
		GO TO 998
8	TYPE 9
9	FORMAT (' ADD CLASSIFICATION--Type job description>',$)
	ACCEPT 10,JBDESC
10	FORMAT (4A5)
	IF(JBDESC(1).EQ. '@    ') GO TO 998
	IF (JBDESC(1) .NE. '?' .AND. JBDESC(1) .NE. 'HE' .AND.
	1	JBDESC(1) .NE. 'he') GO TO 11
		TYPE 12
		GO TO 8
12	FORMAT (' HELP--Type the 1 to 20 letter classification name')
11	CONTINUE
*DBMS
	STORE Classification-Rec.
	IF (ERSTAT .NE. 0) GO TO 112
		TYPE 13
13		FORMAT (' ***Classification Record Stored')
*DBMS
		CLOSE TRANSACTION D-B-UPDATE.
		GO TO 999
112	TYPE 14, JBCLAS, JBDESC
14	FORMAT (' ???Classificaiton Record not stored ???',/,
	1       ' Your input was: ',1A5, 1X, 5A5)

998	CONTINUE
*DBMS
	DELETE TRANSACTION D-B-UPDATE.

999	RETURN
*DBMS
	END ACLASS.
	SUBROUTINE DCLASS

C*******************************************************************************
C*                                                                             *
C*          D C L A S S                                                        *
C*                                                                             *
C*  This routine deletes a classification.                                     *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.
1	TYPE 2
2	FORMAT (' DELETE CLASSIFICATION'
	1 '--Type classification to be deleted>',$)
	ACCEPT 3, JBCLAS
3	FORMAT (1A5)
	IF (JBCLAS .EQ. '@    ') GO TO 999
	IF (JBCLAS .NE. 'HE   ' .AND. JBCLAS .NE. '?    '
	1	.AND. JBCLAS .NE. 'he   ') GO TO 5
		TYPE 4
4		FORMAT (' HELP--Type the five character job description')
		GO TO 1

5	SVJBCL = JBCLAS
*DBMS
	FIND Classification-Rec.
	IF (ERSTAT .EQ. 0 .OR. OK) GO TO 7
		TYPE 6
6		FORMAT (' ???Classification not found???')
		GO TO 999
7	CONTINUE
*DBMS
	FIND NEXT RECORD OF Class-Employee SET.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 998
*DBMS
	GET Employee-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
*DBMS
	REMOVE Employee-Rec FROM Class-Employee.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
	TYPE 8, EPNUM, EPNAME
8	FORMAT (' Employee ',1A5, 1X,6A5,' is to be transferred to',/,
	1       ' which classification?  Type Job-Classification>',$)
	ACCEPT 9, JBCLAS
9	FORMAT (1A5)
*DBMS
	FIND Classification-Rec.
	IF (ERSTAT .NE. 0 .AND. INVKEY) GO TO 999
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
*DBMS
	INSERT Employee-Rec INTO Class-Employee.
	IF (ERSTAT .EQ. 0 .OR. OK) GO TO 7

998	JBCLAS = SVJBCL
*DBMS
	FIND Classification-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
*DBMS
	DELETE Classification-Rec.
999	RETURN
*DBMS
	END DCLASS.
	SUBROUTINE LCLASS

C*******************************************************************************
C*                                                                             *
C*          L C L A S S                                                        *
C*                                                                             *
C*  This is a simple-minded routine which processes all records using a FIND   *
C*  NEXT OF AREA.  The output is in the order in which the records are found.  *
C*  The classification records were not put in a set as this was not seen as   *
C*  a normal function.                                                         *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

*DBMS
	FIND FIRST Classification-Rec RECORD OF Personnel-Area AREA.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 998
	TYPE 1
1	FORMAT (' JOB-CLASS JOB-DESCRIPTION',/,40('-'))
*DBMS
	GET Classification-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
	TYPE 2,JBCLAS,JBDESC
2	FORMAT (1X,1A5,10X,4A5)

3	CONTINUE
*DBMS
	FIND NEXT Classification-Rec RECORD OF Personnel-Area AREA.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
*DBMS
	GET Classification-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
	TYPE 2, JBCLAS, JBDESC
	GO TO 3

998	TYPE 4
4	FORMAT (' ??? No classification records found,',/,
	1       '     data base corrupt ???')

999	RETURN
*DBMS
	END LCLASS.
	SUBROUTINE CUST

C*******************************************************************************
C*                                                                             *
C*          C U S T                                                            *
C*                                                                             *
C*  This is the menu for getting at customer-related functions.                *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /UTIL/ FUNCTN


1	TYPE 2
2	FORMAT (/,' AL	List all customers and all orders',/,
	1 ' HE	Display this listing',/,
	2 ' LA	List all customers',/,
	3 ' LO	List one customer and all orders for that customer',/,
	4 ' @	Abort and return to main menu',/,
	5 '  ?Display this listing',/)
	TYPE 8
8	FORMAT (' CUSTOMER-MENU>',$)
	ACCEPT 3, FUNCTN
3	FORMAT (1A2)
	IF (FUNCTN .NE. 'AL' .AND. FUNCTN .NE. 'al') GO TO 4
		CALL CUSTAL
		GO TO 999
4	IF (FUNCTN .NE. 'LA' .AND. FUNCTN .NE. 'la') GO TO 5
		CALL CUSTAO
		GO TO 999
5	IF (FUNCTN .NE. 'LO' .AND. FUNCTN .NE. 'lo') GO TO 6
		CALL CUSTON
		GO TO 999
6	IF (FUNCTN .EQ. 'HE' .OR. FUNCTN .EQ. 'he') GO TO 1
	IF (FUNCTN .EQ. '? ') GO TO 1
	IF (FUNCTN .EQ. '@ ') GO TO 999
	TYPE 7, FUNCTN
7	FORMAT (1X,1A2,' is not defined.')
	GO TO 1

999	RETURN
	END
	SUBROUTINE CUSTAL

C*******************************************************************************
C*                                                                             *
C*          C U S T A L                                                        *
C*                                                                             *
C*  Customers all.                                                             *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	INTEGER DOLS (2), DOLSX (2)

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.
*DBMS
	FIND FIRST Customer-Rec RECORD OF Cust-Head SET.
	IF (ERSTAT .EQ. 0) GO TO 3
		TYPE 1
1		FORMAT (' ???No customers in Data Base ???',/,
	1	        '    Data Base probably corrupt.')
		GO TO 999
C CUSTOMER LOOP
2	CONTINUE
*DBMS
	FIND NEXT Customer-Rec RECORD OF Cust-Head SET.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
3	CONTINUE
*DBMS
	GET Customer-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
	DECODE (10, 11, CSBAL) DOLS, CNTS
11	FORMAT (1A5,1A3,1A2)
	TYPE 4,CSNUM,CSNAME,CSADDR,CSRTNG,CSRTE,CSSIZE,DOLS,CNTS
4	FORMAT (1X,18A5,1X,1A5,1A3,'.',1A2)
C LOOP ON ORDERS
5	CONTINUE
*DBMS
	FIND NEXT Order-Rec RECORD OF Cust-Ord SET.
	IF (ERSTAT .EQ. 0) GO TO 7
		TYPE 105
105		FORMAT ('+++No orders posted for this customer+++')
		GO TO 2
*DBMS
	GET Order-Rec.
	DECODE (10, 11, ORBILL) DOLS, CNTS
	DECODE (10, 11, OROUR) DOLSX, CNTSX
	IF (ERSTAT .NE. 0) GO TO 999
	TYPE 6,ORNUM,ORDATE,ORDUE,ORSHIP,DOLS,CNTS,DOLSX,CNTSX
6	FORMAT (1X,8A5,2(1X,1A5,1A3,'.',1A2))
C ITEM LOOP
7	CONTINUE
*DBMS
	FIND NEXT Item-Rec RECORD OF Ord-Item SET.
	IF (ERSTAT .EQ. 0) GO TO 9
		TYPE 8
8		FORMAT (' ???Data Base problems, orders recorded',/,
	1	        '    but there are no items on order')
		GO TO 2
9	CONTINUE
*DBMS
	GET Item-Rec.
	IF (ERSTAT .NE. 0) GO TO 999
	DECODE (10, 11, ITQTY) DOLS, CNTS
	DECODE (10, 11, ITPRIC) DOLSX, CNTSX
	TYPE 10,ITPART,DOLS,CNTS,ITSHIP,DOLSX,CNTSX
10	FORMAT (1X,1A5,1X,1A5,1A3,'.',1A2,1X,2A5,1X,1A5,1A3,'.',1A2)
	GO TO 7

999	RETURN
*DBMS
	END CUSTAL.
	SUBROUTINE CUSTAO

C*******************************************************************************
C*                                                                             *
C*          C U S T A O                                                        *
C*                                                                             *
C*  List all customers.                                                        *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	INTEGER DOLS (2)

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

*DBMS
	FIND FIRST Customer-Rec RECORD OF Cust-Head SET.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 998

1	CONTINUE
*DBMS
	GET Customer-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
	DECODE (10, 4, CSBAL) DOLS, CNTS
4	FORMAT (1A5,1A3,1A2)
	TYPE 2, CSNUM, CSNAME, CSADDR, CSRTNG, CSRTE, CSSIZE, DOLS, CNTS
2	FORMAT (1X,18A5,1X,1A5,1A3,'.',1A2)
*DBMS
	FIND NEXT Customer-Rec RECORD OF Cust-Head SET.
	IF (ERSTAT .NE. 0 .AND. ENDSET) GO TO 999
	IF (ERSTAT .EQ. 0) GO TO 1
	GO TO 999

998	TYPE 3
3	FORMAT (' ??? No cusatomers in data base ???',/,
	1       '     Data base probably corrupt.')

999	RETURN
*DBMS
	END CUSTAO.
	SUBROUTINE CUSTON

C*******************************************************************************
C*                                                                             *
C*          C U S T O N                                                        *
C*                                                                             *
C*  List one customer.                                                         *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	INTEGER DOLS (2), DOLSX (2)

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

	TYPE 1
1	FORMAT (' CUSTOMER--Type customer number: ',$)
	ACCEPT 2, CSNUM
2	FORMAT (1A5)
*DBMS
	FIND FIRST Customer-Rec RECORD OF Cust-Head SET.
	IF (ERSTAT .EQ. 0) GO TO 3
		TYPE 4
4		FORMAT (' ??? Customer not found ???')
		GO TO 999
3	CONTINUE
*DBMS
	GET Customer-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
	DECODE (10, 14, CSBAL) DOLS, CNTS
14	FORMAT (1A5,1A3,1A2)
	TYPE 5, CSNUM, CSNAME, CSADDR, CSRTNG, CSRTE, CSSIZE, DOLS, CNTS
5	FORMAT (1X,18A5,1X,1A5,1A3,'.',1A2)
C ORDERS LOOP
9	CONTINUE
*DBMS
	FIND NEXT Order-Rec RECORD OF Cust-Ord SET.
	IF (ERSTAT .EQ. 0 .OR. OK .OR. ENDSET) GO TO 7
		TYPE 8
8		FORMAT (' +++ No orders posted for this customer +++')
		GO TO 999
7	CONTINUE
	IF (ERSTAT .NE. 0 .AND. ENDSET) GO TO 999
*DBMS
	GET Order-Rec.
	IF (ERSTAT .NE. 0) GO TO 999
	DECODE (10, 14, ORBILL) DOLS, CNTS
	DECODE (10, 14, OROUT) DOLSX, CNTSX
	TYPE 15, ORNUM, ORDATE, ORDUE, ORSHIP, DOLS, CNTS, DOLSX, CNTSX
15	FORMAT (1X,8A5,2(1X,1A5,1A3,'.',1A2))
C ITEMS LOOP
10	CONTINUE
*DBMS
	FIND NEXT Item-Rec RECORD OF Ord-Item SET.
	IF (ERSTAT .EQ. 0) GO TO 12
		TYPE 11
11		FORMAT (' ???Data base problems, orders recorded???',/,
	1	        '    but there are not items on order')
		GO TO 999
12	CONTINUE
*DBMS
	GET Item-Rec.
	IF (ERSTAT .NE. 0) GO TO 9
	DECODE (10, 14, ITQTY) DOLS, CNTS
	DECODE (10, 14, ITPRIC) DOLSX, CNTSX
	TYPE 13,ITPART,DOLS,CNTS,ITSHIP,DOLSX,CNTSX
13	FORMAT (1X,1A5,1X,1A5,1A3,'.',1A2,1X,2A5,1X,1A5,1A3,'.',1A2)
	GO TO 10

999	RETURN
*DBMS
	END CUSTON.
	SUBROUTINE DEPT

C*******************************************************************************
C*                                                                             *
C*          D E P T                                                            *
C*                                                                             *
C*  Department.                                                                *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /UTIL/ FUNCTN


1	CALL HELPD
	TYPE 2
2	FORMAT (' DEPT-MENU>',$)
	ACCEPT 3, FUNCTN
3	FORMAT (1A2)
	IF (FUNCTN .NE. 'AD' .AND. FUNCTN .NE. 'ad') GO TO 4
		CALL ADEPT (.FALSE.)
		GO TO 999
4	IF (FUNCTN .NE. 'CH' .AND. FUNCTN .NE. 'ch') GO TO 5
		CALL CDEPT
		GO TO 999
5	IF (FUNCTN .NE. 'DE' .AND. FUNCTN .NE. 'de') GO TO 6
		CALL DDEPT
		GO TO 999
6	IF (FUNCTN .NE. 'LI' .AND. FUNCTN .NE. 'li') GO TO 7
		CALL LDEPT
		GO TO 999
7	IF (FUNCTN .EQ. '? ') GO TO 1
	IF (FUNCTN .EQ. 'HE' .OR. FUNCTN .EQ. 'he') GO TO 1
	IF (FUNCTN .EQ. '@ ') GO TO 999
	TYPE 8, FUNCTN
8	FORMAT (1X,1A2,' is not defined.')
	GO TO 1

999	RETURN
	END
	SUBROUTINE HELPD

C*******************************************************************************
C*                                                                             *
C*          H E L P D                                                          *
C*                                                                             *
C*  Department help.                                                           *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE


	TYPE 1
1	FORMAT (/,' AD	Add department',/,
	1         ' CH	Change department information',/,
	2         ' DE	Delete department',/,
	3         ' LI	List all departments',/,
	4         '  ?	Display this listing',/,
	5         ' HE	Display this listing',/,
	6         ' @	Abort and return to main menu',/)

999	RETURN
	END
	SUBROUTINE CDEPT

C*******************************************************************************
C*                                                                             *
C*          C D E P T                                                          *
C*                                                                             *
C*  Change department information.  Uses the code in ADEPT.                    *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE


	CALL ADEPT (.TRUE.)

999	RETURN
	END
	SUBROUTINE ADEPT (CHANGE)

C*******************************************************************************
C*                                                                             *
C*          A D E P T                                                          *
C*                                                                             *
C*  Add department.  This routine is also used by CHANGE DEPARTMENT, which     *
C*  is why it has a parameter.  If we are doing ADD DEPARTMENT, the            *
C*  parameter is false.  If we are doing CHANGE DEPARTMENT, the parameter      *
C*  is true.                                                                   *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, CHANGE, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	INTEGER WSDPNA (6), WSDPST (3), WSDPCT (3), WSDPZP (2), WSDPPH (3)

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

*DBMS
	OPEN TRANSACTION D-B-UPDATE.

5	TYPE 1
1	FORMAT (/,' DEPARTMENT -- Type dept-number>',$)
	ACCEPT 2, DPNUM
2	FORMAT (1A5)
	IF (DPNUM .EQ. '@    ') GO TO 998
	IF (DPNUM .NE. '?    ' .AND. DPNUM .NE. 'HE   '
	1	.AND. DPNUM .NE. 'he') GO TO 3
		TYPE 4
		GO TO 5
4	FORMAT (' HELP -- Type the 1 to 5 character department number')
3	CONTINUE
*DBMS
	FIND Department-Rec.
	IF (CHANGE) GO TO 6
	IF (ERSTAT .NE. 0) GO TO 7
		TYPE 8
8		FORMAT (' ??? Department already stored ???')
		GO TO 998
6	IF (ERSTAT .EQ. 0) GO TO 9
		TYPE 10
10		FORMAT (' ??? Department not stored ???')
		GO TO 998
9	CONTINUE
*DBMS
	GET Department-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 998
	TYPE 11, DPADDR, DPPHON
11	FORMAT (1X, 10A5, 1X, 2A5, 1A2)
7	WSDPNM = DPNUM

C REDO DEPARTMENT NAME
12	TYPE 13
13	FORMAT (' DEPARTMENT -- Type dept-name>',$)
	ACCEPT 14, WSDPNA
14	FORMAT (6A5)
	IF (WSDPNA (1) .EQ. '@    ') GO TO 998
	IF (WSDPNA (1) .NE. '     ' .OR. CHANGE) GO TO 15
		TYPE 16
16		FORMAT (' ??? You must type a department name ???')
		GO TO 12
15	IF (WSDPNA (1) .NE. '     ') GO TO 17
		DO 18 I = 1, 6
18		WSDPNA (I) = DPNAME (I)
17	TYPE 19
19	FORMAT (' DEPARTMENT -- Type dept-internal-no>',$)
	ACCEPT 20, WSDPI
20	FORMAT (1A5)
	IF (WSDPI .EQ. '@    ') GO TO 998
	IF (WSDPI .EQ. '     ' .AND. CHANGE) WSDPI = DPINO
C REDO DEPARTMENT STREET
21	TYPE 22
22	FORMAT (' DEPARTMENT -- Type dept-street>',$)
	ACCEPT 23, WSDPST
23	FORMAT (3A5)
	IF (WSDPST (1) .EQ. '@    ') GO TO 998
	IF (WSDPST (1) .NE. '     ' .OR. CHANGE) GO TO 24
		TYPE 25
25		FORMAT (' ??? You must type an address ???')
		GO TO 21
24	IF (WSDPST (1) .NE. '     ') GO TO 26
		DO 27 I = 1, 3
27		WSDPST (I) = DPSTRT (I)
C REDO DEPARTMENT CITY
26	TYPE 28
28	FORMAT (' DEPARTMENT -- Type dept-city>',$)
	ACCEPT 29, WSDPCT
29	FORMAT (3A5)
	IF (WSDPCT (1) .EQ. '@    ') GO TO 998
	IF (WSDPCT (1) .NE. '     ' .OR. CHANGE) GO TO 30
		TYPE 131
131		FORMAT (' ??? You must type a complete address ???')
		GO TO 26
30	IF (WSDPCT (1) .NE. '     ') GO TO 31
		DO 132 I = 1, 3
132		WSDPCT (I) = DPCITY (I)
C REDO DEPARTMENT STATE
31	TYPE 32
32	FORMAT (' DEPARTMENT -- Type dept-state>',$)
	ACCEPT 33, WSDPSA
33	FORMAT (1A5)
	IF (WSDPSA .EQ. '@    ') GO TO 998
	IF (WSDPSA .NE. '     ' .OR. CHANGE) GO TO 34
		TYPE 35
35		FORMAT (' ??? You must type a complete address ???')
		GO TO 31
34	IF (WSDPSA .EQ. '     ') WSDPSA = DPSTAT
C REDO DEPARTMENT ZIP
36	TYPE 37
37	FORMAT (' DEPARTMENT -- Type dept-zip>',$)
	ACCEPT 38, WSDPZP
38	FORMAT (2A5)
	IF (WSDPZP (1) .EQ. '@    ') GO TO 998
	IF (WSDPZP (1) .NE. '     ' .OR. CHANGE) GO TO 39
		TYPE 40
40		FORMAT (' ??? You must type a complete address ???')
		GO TO 36
39	IF (WSDPZP (1) .NE. '     ') GO TO 41
		WSDPZP (1) = DPZIP (1)
		WSDPZP (2) = DPZIP (2)
C REDO DEPARTMENT PHONE
41	TYPE 42
42	FORMAT (' DEPARTMENT -- Type dept-phone>',$)
	ACCEPT 43, WSDPPH
43	FORMAT (2A5, 1A2)
	IF (WSDPPH (1) .EQ. '@    ') GO TO 998
	IF (WSDPPH (1) .NE. '     ' .OR. CHANGE) GO TO 44
		TYPE 45
45		FORMAT (' ??? You must type a phone number ???')
		GO TO 41
44	IF (WSDPPH (1) .NE. '     ') GO TO 145
		DO 46 I = 1, 3
46		WSDPPH (I) = DPPHON (I)
145	DO 47 I = 1, 6
47	DPNAME (I) = WSDPNA (I)
	DPINO = WSDPI
	DO 48 I = 1, 3
48	DPSTRT (I) = WSDPST (I)
	DO 49 I = 1, 3
49	DPCITY (I) = WSDPCT (I)
	DPSTAT = WSDPSA
	DPZIP (1) = WSDPZP (1)
	DPZIP (2) = WSDPZP (2)
	DO 50 I = 1, 3
50	DPPHON (I) = WSDPPH (I)
	IF (CHANGE) GO TO 51
*DBMS
		STORE Department-Rec.
		IF (ERSTAT .NE. 0) GO TO 52
			TYPE 53
53			FORMAT (' Department record stored')
*DBMS
			CLOSE TRANSACTION D-B-UPDATE.
			GO TO 999
52		TYPE 54, DPNAME, DPADDR, DPPHON
54		FORMAT (' ??? Department record not stored ???',/,
	1	 ' Your input was: ',6A5,1X,10A5,1X,2A5,1A2)
		GO TO 998
51	CONTINUE
*DBMS
		MODIFY Department-Rec.
		IF (ERSTAT .EQ. 0) GO TO 55
			TYPE 56
56			FORMAT (' ??? Modification failed ???')
			GO TO 998
55		CONTINUE
*DBMS
		CLOSE TRANSACTION D-B-UPDATE.
		TYPE 57
57		FORMAT (' *** Department record modified ***')
		GO TO 999

998	CONTINUE
*DBMS
	DELETE TRANSACTION D-B-UPDATE.

999	RETURN
*DBMS
	END ADEPT.
	SUBROUTINE DDEPT

C*******************************************************************************
C*                                                                             *
C*          D D E P T                                                          *
C*                                                                             *
C*  Delete department.                                                         *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

5	TYPE 1
1	FORMAT (' DELETE DEPARTMENT -- Type dept-number',$)
	ACCEPT 2, DPNUM
2	FORMAT (1A5)
	IF (DPNUM .EQ. '@    ') GO TO 999
	IF (DPNUM .NE. 'HE   ' .AND. DPNUM .NE. '?    '
	1	.AND. DPNUM .NE. 'he') GO TO 3
		TYPE 4
		GO TO 5
4	FORMAT (' HELP -- Type the five character department number')
3	CONTINUE
*DBMS
	FIND Department-Rec.
	IF (ERSTAT .EQ. 0) GO TO 6
		IF (.NOT. INVKEY) GO TO 999
		TYPE 7
7		FORMAT (' Department not found')
		GO TO 999
6	CONTINUE
*DBMS
	FIND FIRST Customer-Rec RECORD OF Sales SET.
	IF (ERSTAT .NE. 0) GO TO 8
		TYPE 9
		GO TO 999
9	FORMAT (' Department has customers and may not be deleted')
8	CONTINUE
*DBMS
	FIND FIRST Truck-Rec RECORD OF Truck SET.
	IF (ERSTAT .NE. 0) GO TO 10
		TYPE 11
		GO TO 999
11	FORMAT (' Department has trucks and may not be deleted')
10	CONTINUE
*DBMS
	FIND FIRST Work-Item-Rec RECORD OF Dept-Work-Item SET.
	IF (ERSTAT .NE. 0) GO TO 12
		TYPE 13
		GO TO 999
13	FORMAT (' Department has work orders and may not be deleted')
12	CONTINUE
*DBMS
	FIND FIRST Employee-Rec RECORD OF Employees SET.
	IF (ERSTAT .NE. 0) GO TO 14
		TYPE 15
		GO TO 999
15	FORMAT (' Department has employees and may not be deleted')
14	CONTINUE
*DBMS
	DELETE Department-Rec.
	IF (ERSTAT .EQ. 0) GO TO 16
		TYPE 17
17		FORMAT (' Department not deleted')
		GO TO 999
16	TYPE 18
18	FORMAT (' Department deleted')

999	RETURN
*DBMS
	END DDEPT.
	SUBROUTINE LDEPT

C*******************************************************************************
C*                                                                             *
C*          L D E P T                                                          *
C*                                                                             *
C*  List departments.                                                          *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

*DBMS
	FIND FIRST Department-Rec RECORD OF Manufacturing-Area AREA.
	IF (ERSTAT .EQ. 0) GO TO 3
		TYPE 2
		GO TO 999
2	FORMAT (' ??? No Department Records Found, Data Base Corrupt ???')
3	TYPE 4
4	FORMAT (' DEPT-NUMBER DEPT-NAME',20X,'DEPT-ADDRESS & PHONE',/,
	1 1X,50('-'))
*DBMS
	GET Department-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
	TYPE 5, DPNUM, DPNAME, DPADDR, DPPHON
5	FORMAT (1X, 1A5, 1X, 6A5, 1X, 10A5, 1X, 2A5, 1A2)

6	CONTINUE
*DBMS
	FIND NEXT Department-Rec RECORD OF Manufacturing-Area AREA.
	IF (ERSTAT .NE. 0 .AND. ENDSET) GO TO 999
*DBMS
	GET Department-Rec.
	IF (ERSTAT .NE. 0) GO TO 999
	TYPE 5, DPNUM, DPNAME, DPADDR, DPPHON
	IF (ERSTAT .EQ. 0 .OR. .NOT. ENDSET) GO TO 6

999	RETURN
*DBMS
	END LDEPT.
	SUBROUTINE EMPLOY

C*******************************************************************************
C*                                                                             *
C*          E M P L O Y                                                        *
C*                                                                             *
C*  Employees.                                                                 *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /UTIL/ FUNCTN


1	CALL HELPE
	TYPE 2
2	FORMAT (' EMPLOYEE-MENU>',$)
	ACCEPT 3, FUNCTN
3	FORMAT (1A2)
	IF (FUNCTN .EQ. '? ') GO TO 1
	IF (FUNCTN .EQ. 'HE' .OR. FUNCTN .EQ. 'he') GO TO 1
	IF (FUNCTN .EQ. '@ ') GO TO 999
	IF (FUNCTN .NE. 'AC' .AND. FUNCTN .NE. 'ac') GO TO 4
		CALL ACEMP
		GO TO 999
4	IF (FUNCTN .NE. 'AD' .AND. FUNCTN .NE. 'ad') GO TO 5
		CALL ADEMP (.FALSE.)
		GO TO 999
5	IF (FUNCTN .NE. 'AS' .AND. FUNCTN .NE. 'as') GO TO 6
		CALL ASEMP
		GO TO 999
6	IF (FUNCTN .NE. 'CH' .AND. FUNCTN .NE. 'ch') GO TO 7
		CALL CHEMP
		GO TO 999
7	IF (FUNCTN .NE. 'DE' .AND. FUNCTN .NE. 'de') GO TO 8
		CALL DEEMP
		GO TO 999
8	IF (FUNCTN .NE. 'DI' .AND. FUNCTN .NE. 'di') GO TO 9
		CALL DIEMP
		GO TO 999
9	IF (FUNCTN .NE. 'LI' .AND. FUNCTN .NE. 'li') GO TO 10
		CALL LIEMP
		GO TO 999
10	TYPE 11, FUNCTN
11	FORMAT (1X,1A2,' is not defined.')
	GO TO 1

999	RETURN
	END
	SUBROUTINE HELPE

C*******************************************************************************
C*                                                                             *
C*          H E L P E                                                          *
C*                                                                             *
C*  Employee help.                                                             *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE


	TYPE 1
1	FORMAT (/,' AC	Add child',/,
	1         ' AD	Add employee',/,
	2         ' AS	Add spouse',/,
	3         ' CH	Change employee',/,
	4         ' DE	Delete employee',/,
	5         ' DI	Display information about one employee',/,
	6         ' LI	Display information about all employees',/,
	7         '  ?	Display this listing',/,
	8         ' HE	Display this listing',/,
	9         ' @	Abort and return to main menu',/)

999	RETURN
	END
	SUBROUTINE CHEMP

C*******************************************************************************
C*                                                                             *
C*          C H E M P                                                          *
C*                                                                             *
C*  Change employee.                                                           *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE


	CALL ADEMP (.TRUE.)

999	RETURN
	END
	SUBROUTINE ADEMP (CHANGE)

C*******************************************************************************
C*                                                                             *
C*          A D E M P                                                          *
C*                                                                             *
C*  Add employee.  This code is also used by CHANGE EMPLOYEE.                  *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, CHANGE, MODIFY, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

*DBMS
	OPEN TRANSACTION D-B-UPDATE.

	TYPE 1
1	FORMAT (' EMPLOYEE -- Type employee-number>',$)
	ACCEPT 2, EPNUM
2	FORMAT (1A5)
	IF (EPNUM .EQ. '@    ') GO TO 998
*DBMS
	FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
	IF (ERSTAT .EQ. 0) GO TO 3
		TYPE 4
4		FORMAT (' ??? Employee-Head not found ???',/,
	1	        ' ??? Data Base may be corrupt ???',/,
	2	        ' ??? *** Execution Aborted *** ???')
		DONE = .TRUE.
		GO TO 998
3	CONTINUE
*DBMS
	GET EMPLOYEE-HEAD-REC.
	IF (ERSTAT .NE. 0) GO TO 998
	IF (CHANGE) GO TO 5
	EHNUM = EHNUM + 1
*DBMS
	MODIFY Employee-Head-Rec Ehnum.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 998
5	CALL FINS6 ('Employee-Rec', 'Employee-Head')
	IF (CHANGE) GO TO 6
	IF (ERSTAT .NE. 0) GO TO 7
		TYPE 8
8		FORMAT (' ??? Employee already stored ???')
		GO TO 998
6	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 7
*DBMS
	GET Employee-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 998
	DECODE (5, 43, EPWAGE) DOLS, CNTS
43	FORMAT (1A3,1A2)
	TYPE 9, EPNAME, EPADDR, EPSICK, EPVAC, DOLS, CNTS
9	FORMAT (1X, 6A5, 1X, 10A5, 1X, 1A5, 1X, 1A5, 1X, 1A3,'.',1A2)
7	TYPE 10
10	FORMAT (' EMPLOYEE -- Type emp-last-name>',$)
	ACCEPT 11, EPLNAM
11	FORMAT (3A5)
	TYPE 12
12	FORMAT (' EMPLOYEE -- Type emp-first-name>',$)
	ACCEPT 13, EPFNAM
13	FORMAT (2A5)
	TYPE 14
14	FORMAT (' EMPLOYEE -- Type middle initial>',$)
	ACCEPT 15, EPMITL
15	FORMAT (1A5)
	TYPE 16
16	FORMAT (' EMPLOYEE -- Type emp-street>',$)
	ACCEPT 17, EPSTRT
17	FORMAT (3A5)
	TYPE 18
18	FORMAT (' EMPLOYEE -- Type apt number or RFD>',$)
	ACCEPT 19, EPAPT
19	FORMAT (1A5)
	TYPE 20
20	FORMAT (' EMPLOYEE -- Type emp-city>',$)
	ACCEPT 21, EPCITY
21	FORMAT (3A5)
	TYPE 22
22	FORMAT (' EMPLOYEE -- Type emp-state>',$)
	ACCEPT 23, EPSTAT
23	FORMAT (1A5)
	TYPE 24
24	FORMAT (' EMPLOYEE -- Type emp-zip>',$)
	ACCEPT 25, EPZIP
25	FORMAT (2A5)
	IF (CHANGE) GO TO 26
	EPSICK = '00000'
	EPVAC  = '00000'
26	TYPE 27
27	FORMAT (' EMPLOYEE -- Type wage>',$)
	ACCEPT 28, EPWAGE
28	FORMAT (1A5)
	TYPE 29
29	FORMAT (' EMPLOYEE -- Type employee''s dept num>',$)
	ACCEPT 30, DPNUM
30	FORMAT (1A5)
	TYPE 31
31	FORMAT (' EMPLOYEE -- Type employee''s job class>',$)
	ACCEPT 32, JBCLAS
32	FORMAT (1A5)
	MODIFY = .FALSE.
	IF (DPNUM .NE. '@     ' .AND. CHANGE) MODIFY = .TRUE.
	IF (CHANGE) GO TO 33
*DBMS
	FIND Department-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 998
*DBMS
	FIND Classification-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 998
*DBMS
	STORE Employee-Rec.
	IF (ERSTAT .NE. 0 .OR. OK) GO TO 34
		TYPE 35
35		FORMAT (' *** Employee record stored ***')
*DBMS
		CLOSE TRANSACTION D-B-UPDATE.
		GO TO 999
34	TYPE 37
37	FORMAT (' ??? Employee record not stored ???')
	GO TO 998
33	CONTINUE
*DBMS
	MODIFY Employee-Rec.
	IF (ERSTAT .EQ. 0) GO TO 38
		TYPE 39
39		FORMAT (' ??? Modification failed ???')
		GO TO 998
38	TYPE 139
139	FORMAT (' *** Employee record modified ***')
36	IF (.NOT. MODIFY) GO TO 999
*DBMS
	REMOVE Employee-Rec FROM Employees.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 998
*DBMS
	FIND Department-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 998
*DBMS
	FIND CURRENT OF Employee-Rec RECORD.
*DBMS
	INSERT Employee-Rec INTO Employees.
	IF (ERSTAT .EQ. 0) GO TO 40
		TYPE 41
41		FORMAT (' ??? Insertion into dept set failed ???')
		GO TO 999
40	CONTINUE
*DBMS
	CLOSE TRANSACTION D-B-UPDATE.
	TYPE 42
42	FORMAT (' *** Add employee routine concluded ***')
	GO TO 999

998	CONTINUE
*DBMS
	DELETE TRANSACTION D-B-UPDATE.


999	RETURN
*DBMS
	END ADEMP.
	SUBROUTINE DEEMP

C*******************************************************************************
C*                                                                             *
C*          D E E M P                                                          *
C*                                                                             *
C*  Delete employee.                                                           *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

	TYPE 1
1	FORMAT (' DELETE EMPLOYEE -- Type employee number>',$)
	ACCEPT 2, EPNUM
2	FORMAT (1A5)
	IF (EPNUM .EQ. '@    ') GO TO 999
*DBMS
	FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
	IF (ERSTAT .EQ. 0) GO TO 3
		TYPE 4
4		FORMAT (' ??? Employee-Head not found ???')
		DONE = .TRUE.
		GO TO 999
3	CALL FINS6 ('Employee-Rec', 'Employee-Head')
	IF (ERSTAT .EQ. 0) GO TO 5
		TYPE 6
6		FORMAT (' Employee not found')
		GO TO 999
5	CONTINUE
*DBMS
	GET Employee-Rec.
	DECODE (5, 11, EPWAGE) DOLS, CNTS
11	FORMAT (1A3,1A2)
	TYPE 7, EPNUM, EPNAME, EPADDR, EPSICK, EPVAC, DOLS,CNTS
7	FORMAT (1X,1A5,1X,6A5,1X,10A5,1X,1A5,1X,1A5,1X,1A3,'.',1A2)
*DBMS
	DELETE Employee-Rec ALL.
	IF (ERSTAT .NE. 0) GO TO 8
	TYPE 9
9	FORMAT (' Deleted')
*DBMS
	FIND CURRENT OF Employee-Head-Rec RECORD.
	EHNUM = EHNUM - 1
*DBMS
	MODIFY Employee-Head-Rec Ehnum.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
	GO TO 999
8	TYPE 10
10	FORMAT (' Deletion failed')

999	RETURN
*DBMS
	END DEEMP.
	SUBROUTINE DIEMP

C*******************************************************************************
C*                                                                             *
C*          D I E M P                                                          *
C*                                                                             *
C*  Display employee.                                                          *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

8	TYPE 1
1	FORMAT (' DISPLAY EMPLOYEE -- Type employee number>',$)
	ACCEPT 2, EPNUM
2	FORMAT (1A5)
	IF (EPNUM .EQ. '@    ') GO TO 999
*DBMS
	FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
	IF (ERSTAT .EQ. 0) GO TO 3
		TYPE 4
4		FORMAT (' ??? No employee-head ???')
		DONE = .TRUE.
		GO TO 999
3	CALL FINS6 ('Employee-Rec', 'Employee-Head')
	IF (ERSTAT .EQ. 0) GO TO 5
		TYPE 6, EPNUM
6		FORMAT (' ??? Employee ',1A5,' not found ???',/,
	1	        ' Type 'R' to retry',$)
		ACCEPT 7, FUNCTN
7		FORMAT (1A5)
		IF (FUNCTN .EQ. 'R    ') GO TO 8
		GO TO 999
5	CONTINUE
*DBMS
	GET Employee-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
	DECODE (5, 10, EPWAGE) DOLS, CNTS
10	FORMAT (1A3,1A2)
	TYPE 9, EPNUM, EPNAME, EPADDR, EPSICK, EPVAC, DOLS, CNTS
9	FORMAT (1X,1A5,1X,6A5,1X,10A5,1X,1A5,1X,1A5,1X,1A3,'.',1A2)

999	RETURN
*DBMS
	END DIEMP.
	SUBROUTINE LIEMP

C*******************************************************************************
C*                                                                             *
C*          L I E M P                                                          *
C*                                                                             *
C*  List employees.                                                            *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

*DBMS
	FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
	IF (ERSTAT .EQ. 0) GO TO 1
		TYPE 2
2		FORMAT (' ??? No employee-head ???')
		DONE = .TRUE.
		GO TO 999
1	CONTINUE
*DBMS
	FIND FIRST Employee-Rec RECORD OF Employee-Head SET.
	IF (ERSTAT .EQ. 0) GO TO 3
	IF (.NOT. ENDSET) GO TO 999
		TYPE 4
4		FORMAT (' --- No employees in data base ---')
		GO TO 999
3	CONTINUE
*DBMS
	GET Employee-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
	DECODE (5, 7, EPWAGE) DOLS, CNTS
7	FORMAT (1A3,1A2)
	TYPE 5, EPNUM, EPNAME, EPADDR, EPSICK, EPVAC, DOLS, CNTS
5	FORMAT (1X,1A5,1X,6A5,1X,10A5,1X,1A5,1X,1A5,1X,1A3,'.',1A2)

C LOOP ON EMPLOYEES
6	CONTINUE
*DBMS
	FIND NEXT Employee-Rec RECORD OF Employee-Head SET.
	IF (ERSTAT .NE. 0) GO TO 999
*DBMS
	GET Employee-Rec.
	IF (ERSTAT .NE. 0) GO TO 999
	DECODE (5, 7, EPWAGE) DOLS, CNTS
	TYPE 5, EPNUM, EPNAME, EPADDR, EPSICK, EPVAC, DOLS, CNTS
	GO TO 6

999	RETURN
*DBMS
	END LIEMP.
	SUBROUTINE ASEMP

C*******************************************************************************
C*                                                                             *
C*          A S E M P                                                          *
C*                                                                             *
C*  Add spouse.                                                                *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

	TYPE 1
1	FORMAT (' ADD SPOUSE -- Type employee number>',$)
	ACCEPT 2, EPNUM
2	FORMAT (1A5)
	IF (EPNUM .EQ. '@    ') GO TO 999
*DBMS
	FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
	IF (ERSTAT .EQ. 0) GO TO 4
		TYPE 3
3		FORMAT (' ??? No employee-head ???')
		DONE = .TRUE.
		GO TO 999
4	CALL FINS6 ('Employee-Rec', 'Employee-Head')
	IF (ERSTAT .EQ. 0) GO TO 6
		TYPE 5
5		FORMAT (' Employee not found')
		GO TO 999
6	TYPE 7
7	FORMAT (' Type spouse''s last name: ',$)
	ACCEPT 8, SRLNAM
8	FORMAT (3A5)
	TYPE 9
9	FORMAT (' Type spouse''s first name: ',$)
	ACCEPT 10, SRFNAM
10	FORMAT (2A5)
	TYPE 11
11	FORMAT (' Type spouse''s middle initial: ',$)
	ACCEPT 12, SRMITL
12	FORMAT (1A5)
	TYPE 13
13	FORMAT (' Type spouse''s date of birth: ',$)
	ACCEPT 14, SRDOB
14	FORMAT (2A5)
	TYPE 15
15	FORMAT (' Type spouse''s sex: ',$)
	ACCEPT 16, SRSEX
16	FORMAT (1A5)
*DBMS
	STORE Spouse-Rec.
	IF (ERSTAT .EQ. 0) GO TO 18
		TYPE 17
17		FORMAT (' Spouse not added')
		GO TO 999
18	TYPE 19
19	FORMAT (' Spouse added')

999	RETURN
*DBMS
	END ASEMP.
	SUBROUTINE ACEMP

C*******************************************************************************
C*                                                                             *
C*          A C E M P                                                          *
C*                                                                             *
C*  Add child.                                                                 *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

	TYPE 1
1	FORMAT (' ADD CHILD -- Type employee number>',$)
	ACCEPT 2, EPNUM
2	FORMAT (1A5)
	IF (EPNUM .EQ. '@    ') GO TO 999
*DBMS
	FIND FIRST Employee-Head-Rec RECORD OF Employee-Head-Sys SET.
	IF (ERSTAT .EQ. 0) GO TO 4
		TYPE 3
3		FORMAT (' ??? No employee-head ???')
		DONE = .TRUE.
		GO TO 999
4	CALL FINS6 ('Employee-Rec', 'Employee-Head')
	IF (ERSTAT .EQ. 0) GO TO 6
		TYPE 5
5		FORMAT (' Employee not found')
		GO TO 999
6	TYPE 7
7	FORMAT (' Type child''s last name: ',$)
	ACCEPT 8, CRLNAM
8	FORMAT (3A5)
	TYPE 9
9	FORMAT (' Type child''s first name: ',$)
	ACCEPT 10, CRFNAM
10	FORMAT (2A5)
	TYPE 11
11	FORMAT (' Type child''s middle initial: ',$)
	ACCEPT 12, CRMITL
12	FORMAT (1A5)
	TYPE 13
13	FORMAT (' Type child''s date of birth: ',$)
	ACCEPT 14, CRDOB
14	FORMAT (2A5)
	TYPE 15
15	FORMAT (' Type child''s sex: ',$)
	ACCEPT 16, CRSEX
16	FORMAT (1A5)
*DBMS
	STORE Child-Rec.
	IF (ERSTAT .EQ. 0) GO TO 18
		TYPE 17
17		FORMAT (' Child not added.')
		GO TO 999
18	TYPE 19
19	FORMAT (' Child added.')

999	RETURN
*DBMS
	END ACEMP.
	SUBROUTINE HELPM

C*******************************************************************************
C*                                                                             *
C*          H E L P M                                                          *
C*                                                                             *
C*  Help.                                                                      *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE


	TYPE 1
1	FORMAT (/,' The menus you may call are:',/,' CL	CLASSIFICATION',/,
	1' 	Add classification',/,' 	Delete classification',/,
	2' 	List all classifications',/,' CU	CUSTOMERS',/,
	3' 	List all customers and orders',/,
	4' 	List all customers',/,
	5' 	List one customer and his orders',/,
	6' DE	DEPARTMENT',/,
	7' 	Add department',/,' 	Change department',/,
	8' 	Delete department',/,' 	List departments',/,
	9' EM	EMPLOYEE',/,' 	Add employee',/,
	1' 	Delete employee',/,' 	Display employee',/,
	2' 	Change employee',/,' 	Add spouse',/,
	3' 	Add child',/,' OR	ORDER PROCESSING',/,
	4' ST	STATSITICS',/,
	5' 	Type statistics on your terminal',/,
	6' 	Write statistics to variable',/,' TR	TRUCKS',//,
	7' The non-menu functions are:',/,
	8' EX	Conclude session',/,
	9' HE	Type these messages',/,
	1' ME	Type abbreviated command list',/,
	2' MS	Set exception messages',/)

999	RETURN
	END
	SUBROUTINE MENU

C*******************************************************************************
C*                                                                             *
C*          M E N U                                                            *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, IMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE


	TYPE 1
1	FORMAT (' Available menus and fuctions are:',/,
	1 ' 	CL: AD, DE, HE, LI',/,
	2 ' 	CU: AL, HE, LA, LO',/,
	3 ' 	DE: AD, CH, DE, LI, HE',/,
	4 ' 	EM: AC, AD, AS, CH, DE, DI, HE, LI',/,
	5 ' 	EX',/,
	6 ' 	HE',/,
	7 ' 	ME',/,
	8 ' 	MS',/,
	9 ' 	OR',/,
	1 ' 	ST: TE, VA',/,
	2 ' 	TR',/)

999	RETURN
	END
	SUBROUTINE EXCMSG

C*******************************************************************************
C*                                                                             *
C*          E X C M S G                                                        *
C*                                                                             *
C*  Exception messages.                                                        *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, EXMS, DONE
	COMMON /EX/ EXMS
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /UTIL/ FUNCTN


	EXMS = .FALSE.
	TYPE 1
1	FORMAT (/,' Do you want to receive exception messages?',/,
	1         ' Type Y or N >',$)
	ACCEPT 2, FUNCTN
2	FORMAT (1A2)
	IF (FUNCTN .EQ. 'Y ' .OR. FUNCTN .EQ. 'y ') EXMS = .TRUE.

999	RETURN
	END
	SUBROUTINE ORDER

C*******************************************************************************
C*                                                                             *
C*          O R D E R                                                          *
C*                                                                             *
C*  Order processing.                                                          *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE, MORE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /UTIL/ FUNCTN
	REAL DOLAMT, DOLPRC

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

	MORE = 'TRUE'
3	TYPE 1
1	FORMAT (' ORDER-PROCESSING -- Type customer number >',$)
	ACCEPT 2, CSNUM
2	FORMAT (1A5)
	IF (CSNUM .EQ. '@    ') GO TO 999
	IF (CSNUM .NE. '?    ' .AND. CSNUM .NE. 'HE   '
	1	.AND. CSNUM .NE. 'he   ') GO TO 4
		TYPE 5
5		FORMAT (' HELP -- Type a five-digit customer number')
		GO TO 3
4	CALL FINS6 ('Customer-Rec', 'Cust-Head')
	IF (ERSTAT .EQ. 0 .OR. OK) GO TO 6
	IF (ERSTAT .EQ. 0 .OR. .NOT. INVKEY ) GO TO 999
	TYPE 7, CSNUM
7	FORMAT (' This is the firt time that the customer '
	1       'has placed an order',/,
	2       ' The customer-number that you typed is ', 1A5,//,
	3       ' Type Y if this is the right number.',/,
	4       ' Type R if you wish to reenter the number.',/,
	5       ' Anything else aborts >',$)
	ACCEPT 8, FUNCTN
8	FORMAT (1A2)
	IF (FUNCTN .EQ. 'R    ' .OR. FUNCTN .EQ. 'RE   ') GO TO 3
	IF (FUNCTN .EQ. 'r    ' .OR. FUNCTN .EQ. 're   ') GO TO 3
	IF (FUNCTN .NE. 'Y    ' .AND. FUNCTN .NE. 'YE   '
	1	.AND. FUNCTN .NE. 'ye   ') GO TO 999
	TYPE 9
9	FORMAT (' ORDER PROCESSOR -- Type customer''s name >',$)
	ACCEPT 10, CSNAME
10	FORMAT (4A5)
	IF (CSNAME (1) .EQ. '@    ') GO TO 999
	TYPE 11
11	FORMAT (' ORDER PROCESSOR -- Type customer''s street >',$)
	ACCEPT 12, CSSTRT
12	FORMAT (3A5)
	IF (CSSTRT (1) .EQ. '@    ') GO TO 999
	TYPE 13
13	FORMAT (' ORDER PROCESSOR -- Type customer''s city >',$)
	ACCEPT 14, CSCITY
14	FORMAT (3A5)
	IF (CSCITY (1) .EQ. '@    ') GO TO 999
	TYPE 15
15	FORMAT (' ORDER PROCESSOR -- Type customer''s state >',$)
	ACCEPT 16, CSSTAT
16	FORMAT (1A5)
	IF (CSSTAT .EQ. '@    ') GO TO 999
	TYPE 17
17	FORMAT (' ORDER PROCESSOR -- Type customer''s zip code >',$)
	ACCEPT 18, CSZIP
18	FORMAT (1A5, 1A4)
	IF (CSZIP (1) .EQ. '@    ') GO TO 999
	CSRTNG = '00999'
	CALL ZIP
	CSSIZE (1) = '00000'
	CSSIZE (2) = '00000'
	CSBAL (1) = '00000'
	CSBAL (2) = '00000'
*DBMS
	FIND FIRST CUST-HEAD-REC RECORD OF CUST-HEAD-SYS SET.
	IF (ERSTAT .NE. 0) GO TO 999
*DBMS
	GET CUST-HEAD-REC.
	IF (ERSTAT .NE. 0) GO TO 999
	CHNUM = CHNUM + 1
*DBMS
	MODIFY CUST-HEAD-REC CHNUM.
	IF (ERSTAT .NE. 0) GO TO 999
*DBMS
	STORE CUSTOMER-REC.
	IF (ERSTAT .NE. 0) GO TO 999
C PROCESS ORDER
C
C
*DBMS
	FIND FIRST NUMBER-OF-LAST-ORDER-REC RECORD OF HEAD-AREA AREA.
	IF (ERSTAT .NE. 0) GO TO 999
*DBMS
	GET NUMBER-OF-LAST-ORDER-REC.
	IF (ERSTAT .NE. 0) GO TO 999
	OHNUM = OHNUM + 1
*DBMS
	MODIFY NUMBER-OF-LAST-ORDER-REC OHNUM.
	IF (ERSTAT .NE. 0) GO TO 999
	TYPE 100
100	FORMAT (/,' ORDER PROCESSOR -- Type today s date>',$)
	ACCEPT 101, ORDATE
101	FORMAT (2A5)
6	TYPE 19
19	FORMAT (' ORDER PROCESSING -- Type date when customer '
	1       'expects shipment >',$)
	ACCEPT 20, ORDUE
20	FORMAT (2A5)
*DBMS
	STORE ORDER-REC.
	IF (ERSTAT .NE. 0) GO TO 999
*DBMS
	FIND FIRST Part-Head-Rec RECORD OF Part-Head-Sys SET.
	IF (ERSTAT .EQ. 0 .OR. OK) GO TO 22
		TYPE 21
21		FORMAT (' ??? No part head ???')
		GO TO 999
C REDO PART NUMBER
22	TYPE 23
23	FORMAT (' ORDER PROCESSOR -- Type part name >', $)
	ACCEPT 24, ITPART
24	FORMAT (1A5)
	IF (ITPART .EQ. '@    ') GO TO 999
	PTNUM = ITPART
	CALL FINS6 ('Part-Rec', 'Part-Head')
	IF (ERSTAT .EQ. 0 .OR. OK) GO TO 26
		TYPE 25
25		FORMAT (' ??? Illegal part number, please retype ???')
		GO TO 22
26	CONTINUE
*DBMS
	GET Part-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
	TYPE 27, PTNAME
27	FORMAT (' Is ', 2A5, ' correct?  Type Y or N >',$)
	ACCEPT 28, FUNCTN
28	FORMAT (1A2)
	IF (FUNCTN .NE. 'Y' .AND. FUNCTN .NE. 'YE') GO TO 22
	TYPE 29
29	FORMAT (' ORDER PROCESSOR -- Type quantity requested >',$)
	ACCEPT 30, ITQTY
30	FORMAT (2A5)
	IF (ITQTY (1) .LT. '00000') GO TO 999
C	ITPRIC = ITQTY * PTPRIC
	DECODE (10,37,ITQTY) DOLAMT
37	FORMAT (-2PF10.2)
	DECODE (10,37,PTPRIC) DOLPRC
	DOLPRC = DOLAMT * DOLPRC
	ENCODE (10, 37, ITPRIC) DOLPRC

	IF (MORE) GO TO 31
	CALL SHIP
*DBMS
	FIND Number-of-Last-Order-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
*DBMS
	GET Number-of-Last-Order-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
	OHDUM = OHDUM + 1
	ENCODE (10, 38, ORNUM) OHDUM
38	FORMAT (I10)
*DBMS
	STORE Number-of-Last-Order-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
*DBMS
	STORE Order-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
C
C  Initialization of this happened in ZIP.  This is necessary
C  to establich currency in the Shipping set.
C
	TRROUT = '00002'
*DBMS
	FIND Truck-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999
C
C  This establishes a currency in the Sales set so that the
C  customer can be linked into the Sales set.
C
	DPNUM = '00001'
*DBMS
	FIND department-Rec.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 999

31	CONTINUE
*DBMS
	STORE Item-Rec.
	IF (ERSTAT .NE. 0) GO TO 34
		TYPE 32
32		FORMAT (' Item record stored.')
34	TYPE 35
35	FORMAT (' ORDER PROCESSOR -- Are there additional items? '
	1       ' Type Y or N >',$)
	ACCEPT 36, FUNCTN
36	FORMAT (1A2)
	IF (FUNCTN .NE. 'Y' .AND. FUNCTN .NE. 'YE') MORE = .FALSE.
	GO TO 22

999	RETURN
*DBMS
	END ORDER.
	SUBROUTINE SHIP

C*******************************************************************************
C*                                                                             *
C*          S H I P                                                            *
C*                                                                             *
C*  Shipping date.                                                             *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

	TYPE 1
1	FORMAT (' Shipping date function not yet implemented')

999	RETURN
*DBMS
	END SHIP.
	SUBROUTINE ZIP

C*******************************************************************************
C*                                                                             *
C*          Z I P                                                              *
C*                                                                             *
C*  Convert zip code to route.                                                 *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

	TYPE 1
1	FORMAT (' Convert zip to route function not yet implemented.')

999	RETURN
*DBMS
	END ZIP.
	SUBROUTINE TRUCK

C*******************************************************************************
C*                                                                             *
C*          T R U C K                                                          *
C*                                                                             *
C*  Trucks.                                                                    *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

	TYPE 1
1	FORMAT (' This function is not yet implemented.')

999	RETURN
*DBMS
	END TRUCK.
	SUBROUTINE STATSP

C*******************************************************************************
C*                                                                             *
C*         S T A T S P                                                         *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /UTIL/ FUNCTN

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

7	TYPE 1
1	FORMAT (/, ' HE	Print this message',/,
	1 ' TE	Print statistics on terminal',/,
	2 ' VA	write statistics to variable',/,
	3 ' ?	Print this message',/,
	4 ' @	Abort',/)
	TYPE 2
2	FORMAT (' STATS-MENU>',$)
	ACCEPT 3, FUNCTN
3	FORMAT (1A5)
	IF (FUNCTN .EQ. '@    ') GO TO 999
	IF (FUNCTN .EQ. '?    ') GO TO 7
	IF (FUNCTN .EQ. 'HE   ' .OR. FUNCTN .EQ. 'he   ') GO TO 7
	IF (FUNCTN .NE. 'TE   ' .AND. FUNCTN .NE. 'te   ') GO TO 4
		CALL STATS
		GO TO 999
4	CONTINUE
C	IF (FUNCTN .NE. 'VA   ' .AND. FUNCTN .NE. 'va   ') GO TO 5
C		CALL STATS (XXX)
C		GO TO 999
5	TYPE 6, FUNCTN
6	FORMAT (1X, 1A5, ' is not defined, reenter command')
	GO TO 7

999	RETURN
*DBMS
	END STATSP.
	SUBROUTINE PART

C*******************************************************************************
C*                                                                             *
C*          P A R T                                                           *
C*                                                                             *
C* This routine accepts a response and calls the function called for.  The     *
C* functions follow this routine.                                              *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /UTIL/ FUNCTN


1	CALL HELPP
	TYPE 2
2	FORMAT (' PART-MENU>',$)
	ACCEPT 3,FUNCTN
3	FORMAT (1A2)
	IF (FUNCTN .NE. 'AD' .AND. FUNCTN .NE. 'ad') GO TO 4
		CALL APART (.FALSE.)
		GO TO 999
4	IF (FUNCTN .NE. 'DE' .AND. FUNCTN .NE. 'de') GO TO 5
		CALL DPART
		GO TO 999
5	IF (FUNCTN .NE. 'SH' .AND. FUNCTN .NE. 'sh') GO TO 55
		CALL SPART
		GO TO 999
55	IF (FUNCTN .EQ. 'HE' .OR. FUNCTN .EQ. 'he') GO TO 1
	IF (FUNCTN .EQ. '? ') GO TO 1
	IF (FUNCTN .NE. 'LI' .AND. FUNCTN .NE. 'li') GO TO 6
		CALL LPART
		GO TO 999
6	IF (FUNCTN .EQ. '@ ') GO TO 999
	TYPE 7, FUNCTN
7	FORMAT (1X,1A2,' is undefined.')
	GO TO 1

999	RETURN
	END
	SUBROUTINE HELPP

C*******************************************************************************
C*                                                                             *
C*          H E L P P                                                         *
C*                                                                             *
C* This routine accepts a response and calls the function called for.  The     *
C* functions follow this routine.                                              *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /UTIL/ FUNCTN

	TYPE 1
1	FORMAT (/,' @   Abort and return to THEME-MAIN-MENU',/,
	1         '  ?  Display this message',/,
	2         ' AD  Add part',/,
	3         ' DE  Delete part',/,
	4         ' HE  Display this message',/,
	5         ' LI  List parts',/,
	6         ' SH  Show one part',/)

999	RETURN
	END
	SUBROUTINE APART

C*******************************************************************************
C*                                                                             *
C*          A P A R T                                                         *
C*                                                                             *
C* This routine accepts a response and calls the function called for.  The     *
C* functions follow this routine.                                              *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /UTIL/ FUNCTN

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

*DBMS
	OPEN TRANSACTION D-B-UPDATE.

	TYPE 1
1	FORMAT (/,' Add part - - Type part number>',$)
	ACCEPT 2,PTNUM
2	FORMAT (1A5)

*DBMS
	FIND FIRST PART-HEAD-REC RECORD OF PART-HEAD-SYS SET.
	IF (ERSTAT .EQ. 0) GO TO 10
		TYPE 3
3		FORMAT (/,' ??? PART-HEAD NOT FOUND ???')
		GO TO 998
10	CONTINUE
*DBMS
	GET PART-HEAD-REC.
	IF (ERSTAT .NE. 0 .AND. .NOT. OK) GO TO 998
*DBMS
	FIND PART-REC VIA CURRENT OF PART-HEAD USING PTNUM.
	IF (ERSTAT .NE. 0) GO TO 20
		TYPE 4
4		FORMAT (/,' This part already exists')
		go to 998
20	continue
	PRNUM = PRNUM + 1

*DBMS
	MODIFY PART-HEAD-REC PRNUM.
	IF (ERSTAT .NE. 0) GO TO 998
	TYPE 5
5	FORMAT (/,' Add part - - Type part name>',$)
	ACCEPT 6,PTNAME
6	FORMAT (2A5)
	TYPE 7
7	FORMAT (/,' Add part - - Type quantity available>',$)
	ACCEPT 8,PTAVAL
8	FORMAT (1A5)
	TYPE 9
9	FORMAT (/,' Add part - - Type quantity reserved>',$)
	ACCEPT 100,PTRESD
100	FORMAT (1A5)
	TYPE 11
11 	FORMAT (/,' Add part - - Type quantity ordered>',$)
	ACCEPT 12,PTORDD
12	FORMAT (1A5)
	TYPE 13
13	FORMAT (/,' Add part - - Type lead time>',$)
	ACCEPT 14, PTLEAD
14	FORMAT (1A5)
	TYPE 15
15	FORMAT (/,' Add part - - Type cost>',$)
	ACCEPT 16, PTCOST
16	FORMAT (2A5)
C	PTPRIC = 1.5 * PTCOST
	TYPE 17, PTPRIC
17	FORMAT (/,' Price will be: ',2a5)

*DBMS
	STORE PART-REC.
	IF (ERSTAT .NE. 0) GO TO 19
		TYPE 18
18		FORMAT (/,' *** Part stored ***')
*DBMS
		CLOSE TRANSACTION D-B-UPDATE.
		go to 999
19	type 40
40	FORMAT (/,' ??? Part not stored ???')


998	CONTINUE
*DBMS
	DELETE TRANSACTION D-B-UPDATE.

999	RETURN

*DBMS
	END APART.
	SUBROUTINE DPART

C*******************************************************************************
C*                                                                             *
C*          D P A R T                                                         *
C*                                                                             *
C* This routine accepts a response and calls the function called for.  The     *
C* functions follow this routine.                                              *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /UTIL/ FUNCTN

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.
	TYPE 1
1	FORMAT (/,' Delete part - - Type part number>',$)
	ACCEPT 2, PTNUM
2	FORMAT (1A5)

*DBMS
	FIND FIRST PART-HEAD-REC RECORD OF PART-HEAD-SYS SET.
	IF (ERSTAT .EQ. 0) GO TO 4
		TYPE 3
3		FORMAT (/,' ??? NO PART-HEAD ???')
		GO TO 999
4	CONTINUE
*DBMS
	FIND PART-REC VIA CURRENT OF PART-HEAD USING PTNUM.
	IF (ERSTAT .EQ. 0) GO TO 6
		TYPE 5
5		FORMAT (/,' ??? PART NOT FOUND ???')
		GO TO 999
6	CONTINUE
*DBMS
	DELETE PART-REC ALL.
	IF (ERSTAT .EQ. 0) GO TO 8
		TYPE 7
7		FORMAT (/,' ??? DELETE FAILED ???')
		GO TO 999
8	TYPE 9
9	FORMAT (/,' Part deleted')
*DBMS
	FIND CURRENT OF PART-HEAD-REC RECORD.
	IF (ERSTAT .EQ. 0) GO TO 10
		GO TO 999
10	CONTINUE
*DBMS
	GET PART-HEAD-REC.
	IF (ERSTAT .EQ. 0) GO TO 11
		GO TO 999
11	PRNUM = PRNUM - 1
*DBMS
	MODIFY PART-HEAD-REC PRNUM.

999	RETURN
*DBMS
	END DPART.
	SUBROUTINE LPART

C*******************************************************************************
C*                                                                             *
C*          L P A R T                                                         *
C*                                                                             *
C* This routine accepts a response and calls the function called for.  The     *
C* functions follow this routine.                                              *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /UTIL/ FUNCTN

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

*DBMS
	FIND FIRST PART-HEAD-REC RECORD OF PART-HEAD-SYS SET.
*DBMS
	GET PART-HEAD-REC.
10	CONTINUE
*DBMS
	FIND NEXT PART-REC RECORD OF PART-HEAD SET.
	IF (ERSTAT .EQ. 0) GO TO 2
	IF (ERSTAT .NE. 307) GO TO 20
		GO TO 999
20	TYPE 1
1	FORMAT (/,' ??? NO PARTS IN DATA BASE ???')
	GO TO 999
2	CONTINUE
*DBMS
	GET PART-REC.
	IF (ERSTAT .EQ. 0) GO TO 3
		GO TO 999
3	TYPE 4, PTNUM, PTNAME
4	FORMAT (1X,1A5,5X,2A5)
	GO TO 10
999	RETURN
*DBMS
	END LPART.
	SUBROUTINE SPART

C*******************************************************************************
C*                                                                             *
C*          S P A R T                                                         *
C*                                                                             *
C* This routine accepts a response and calls the function called for.  The     *
C* functions follow this routine.                                              *
C*                                                                             *
C*******************************************************************************

	IMPLICIT INTEGER (A-Z)
	LOGICAL INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
	COMMON /UTIL/ FUNCTN

*DBMS
	ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
		PRIVACY KEY FOR COMPILE IS ACEDB.

10	TYPE 1
1	FORMAT (/,' Show part - - Type part number>',$)
	ACCEPT 2, PTNUM
2	FORMAT (1A5)
*DBMS
	FIND FIRST PART-HEAD-REC RECORD OF PART-HEAD-SYS SET.
	IF (ERSTAT .EQ. 0) GO TO 4
		TYPE 3
3		FORMAT (/,' ??? NO PART-HEAD ???')
		GO TO 999
4	CONTINUE
*DBMS
	FIND PART-REC VIA CURRENT OF PART-HEAD USING PTNUM.
	IF (ERSTAT .EQ. 0) GO TO 8
		TYPE 5
5		FORMAT (/,' PART NOT FOUND')
		TYPE 6
6		FORMAT (/,' Type R to retry>',$)
		ACCEPT 7,FUNCTN
7		FORMAT (1A5)
		IF (ERSTAT .NE. R) GO TO 999
			GO TO 10
8	CONTINUE
*DBMS
	GET PART-REC.
	IF (ERSTAT .NE. 0) GO TO 999
	TYPE 20,PTNUM
20	FORMAT (/,' PART NUMBER: ',1A5)
	TYPE 21,PTNAME
21	FORMAT (/,' NAME: ',2A5)
	TYPE 22,PTAVAL
22	FORMAT (/,' AVAILABLE: ',1A5)
	TYPE 23,PTRESD
23	FORMAT (/,' RESERVED: ',1A5)
	TYPE 24,PTORDD
24	FORMAT (/,' ORDERED: ',1A5)
	TYPE 25,PTLEAD
25	FORMAT (/,' LEAD TIME: ',1A5)
	TYPE 26,PTPRIC
26	FORMAT (/,' PRICE: ',2A5)

999	RETURN
*DBMS
	END SPART.