Trailing-Edge
-
PDP-10 Archives
-
DBMS-20_V6.0_bin_9-25-81
-
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.