This appendix contains a sample batch COBOL program that accesses database records using navigational DML statements. The following figure shows the program as it appears in the various stages of the compilation process. You create a program using COBOL and DML statements. This program is input to the DML compiler, which produces a listing that contains diagnostics and, optionally, DML source statements. The expanded code is input to the COBOL compiler, which generates a listing of the fully expanded code and diagnostics.
Compilation Process
This section contains the following topics:
Sample Batch Program as Input to the DML Compiler
Sample Batch Program as Output from the DML Compiler
Sample Batch Program from the COBOL Precompiler
The sample program contains COBOL and DML source statements.
*RETRIEVAL
*DMLIST
*NO-ACTIVITY-LOG
*SCHEMA-COMMENTS
IDENTIFICATION DIVISION.
PROGRAM-ID. DEPTRPT.
AUTHOR. COMPUTER ASSOCIATES INTERNATIONAL.
DATE-WRITTEN. APRIL 1995.
REMARKS. THIS PROGRAM DEMONSTRATES
CA IDMS DATABASE ACCESS USING
COBOL DML STATEMENTS. IT READS
DEPARTMENT ID NUMBERS AND RETRIEVES
RELATED RECORD OCCURRENCES,
PRINTING A REPORT THAT INCLUDES
DEPARTMENT, EMPLOYEE, JOB, AND
OFFICE INFORMATION.
***************************************************************
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT DEPT-FILE-IN ASSIGN TO INFILE.
SELECT DEPT-FILE-OUT ASSIGN TO OUTFILE.
SELECT ERR-FILE-OUT ASSIGN TO ERRFILE.
***************************************************************
IDMS-CONTROL SECTION.
PROTOCOL. MODE IS BATCH DEBUG
IDMS-RECORDS MANUAL.
SKIP3
***************************************************************
DATA DIVISION.
SCHEMA SECTION.
DB EMPSS01 WITHIN EMPSCHM.
***************************************************************
FILE SECTION.
FD DEPT-FILE-IN
RECORD CONTAINS 80
BLOCK CONTAINS 80 CHARACTERS
RECORDING MODE IS F
LABEL RECORDS ARE OMITTED.
01 DEPT-REC-IN.
02 DEPT-ID-IN PIC 9(4).
02 DEPT-IN-FILLER PIC X(76).
FD DEPT-FILE-OUT
RECORD CONTAINS 133
BLOCK CONTAINS 133 CHARACTERS
RECORDING MODE IS F
LABEL RECORDS ARE OMITTED.
01 DEPT-REC-OUT.
02 CC PIC X.
02 PRINT-LINE PIC X(132).
FD ERR-FILE-OUT
RECORD CONTAINS 133
BLOCK CONTAINS 133 CHARACTERS
RECORDING MODE IS F
LABEL RECORDS ARE OMITTED.
01 ERR-REC-OUT.
02 ERR-CC PIC X.
02 ERR-LINE PIC X(132).
***************************************************************
WORKING-STORAGE SECTION.
01 EOF-SW PIC X VALUE 'N'.
88 END-OF-FILE VALUE 'Y'.
01 LINE-COUNT PIC 99 VALUE 0.
01 ERR-LINE-COUNT PIC 99 VALUE 0.
01 LINE-MAX PIC 99 VALUE 50.
***************************************************************
01 DEPT-HEADER.
05 FILLER PIC X(30) VALUE SPACES.
05 FILLER PIC X(13) VALUE 'DEPARTMENT ID'.
05 FILLER PIC X(10) VALUE SPACES.
05 FILLER PIC X(9) VALUE 'DEPT NAME'.
05 FILLER PIC X(70) VALUE SPACES.
01 DEPT-DETAIL-LINE.
05 FILLER PIC X(33) VALUE SPACES.
05 DEPT-ID-OUT PIC X(4).
05 FILLER PIC X(16) VALUE SPACES.
05 DEPT-NAME-OUT PIC X(45).
05 FILLER PIC X(34) VALUE SPACES.
01 EMP-HEADER.
05 FILLER PIC X(5) VALUE SPACES.
05 FILLER PIC X(6) VALUE 'EMP ID'.
05 FILLER PIC X(2) VALUE SPACES.
05 FILLER PIC X(9) VALUE 'LAST NAME'.
05 FILLER PIC X(8) VALUE SPACES.
05 FILLER PIC X(10) VALUE 'FIRST NAME'.
05 FILLER PIC X(3) VALUE SPACES.
05 FILLER PIC X(10) VALUE 'START DATE'.
05 FILLER PIC X(2) VALUE SPACES.
05 FILLER PIC X(9) VALUE 'JOB TITLE'.
05 FILLER PIC X(13) VALUE SPACES.
05 FILLER PIC X(14) VALUE 'OFFICE ADDRESS'.
05 FILLER PIC X(42) VALUE SPACES.
01 EMP-DETAIL-LINE.
05 FILLER PIC X(5) VALUE SPACES.
05 ID-OUT PIC X(4).
05 FILLER PIC X(4) VALUE SPACES.
05 LAST-OUT PIC X(15).
05 FILLER PIC X(2) VALUE SPACES.
05 FIRST-OUT PIC X(10).
05 FILLER PIC X(3) VALUE SPACES.
05 SD-OUT.
10 SD-MM PIC XX.
10 FILLER PIC X VALUE '/'.
10 SD-DD PIC XX.
10 FILLER PIC X VALUE '/'.
10 SD-YY PIC XX.
05 FILLER PIC X(4) VALUE SPACES.
05 TITLE-OUT PIC X(20).
05 FILLER PIC X(2) VALUE SPACES.
05 OFF-ADDRESS-OUT.
10 STREET-OUT PIC X(20).
10 FILLER PIC XX VALUE SPACES.
10 CITY-OUT PIC X(15).
10 FILLER PIC XX VALUE SPACES.
10 STATE-OUT PIC XX.
10 FILLER PIC XX VALUE SPACES.
10 ZIP-OUT PIC X(5).
05 FILLER PIC X(8) VALUE SPACES.
01 ERR-HEADER-1.
05 FILLER PIC X(40) VALUE SPACES.
05 FILLER PIC X(12) VALUE 'ERROR REPORT'.
05 FILLER PIC X(80) VALUE SPACES.
01 ERR-HEADER-2.
05 FILLER PIC X(10) VALUE SPACES.
05 FILLER PIC X(4) VALUE '*** '.
05 FILLER PIC X(51) VALUE
'THIS REPORT LISTS EMPTY AND NONEXISTENT DEPARTMENTS'.
05 FILLER PIC X(4) VALUE ' ***'.
05 FILLER PIC X(63) VALUE SPACES.
01 ERR-HEADER-3.
05 FILLER PIC X(20) VALUE SPACES.
05 FILLER PIC X(7) VALUE 'DEPT ID'.
05 FILLER PIC X(9) VALUE SPACES.
05 FILLER PIC X(7) VALUE 'MESSAGE'.
05 FILLER PIC X(89) VALUE SPACES.
01 ERR-DETAIL-LINE.
05 FILLER PIC X(20) VALUE SPACES.
05 ERR-ID-OUT PIC X(4).
05 FILLER PIC X(12) VALUE SPACES.
05 ERR-MESS-OUT PIC X(15).
05 FILLER PIC X(79) VALUE SPACES.
***************************************************************
01 MESSAGES.
05 NO-JOB-MESSAGE.
10 FILLER PIC X(20) VALUE 'NO JOB ASSIGNED'.
05 NO-OFFICE-MESSAGE.
10 FILLER PIC X(20)
VALUE 'NO OFFICE ASSIGNED'.
05 NO-DEPT-MESSAGE.
10 FILLER PIC X(15) VALUE 'DOES NOT EXIST'.
05 NO-EMP-MESSAGE.
10 FILLER PIC X(15) VALUE 'IS EMPTY'.
05 NO-INPUT-MESSAGE.
10 FILLER PIC XX VALUE SPACES.
10 FILLER PIC X(11) VALUE '========>> '.
10 FILLER PIC X(8) VALUE 'NO INPUT'.
10 FILLER PIC X(11) VALUE ' <<========'.
10 FILLER PIC X(100) VALUE SPACES.
01 COPY IDMS SUBSCHEMA-CTRL.
01 COPY IDMS SUBSCHEMA-SSNAME.
01 COPY IDMS SUBSCHEMA-RECNAMES.
01 COPY IDMS SUBSCHEMA-SETNAMES.
01 COPY IDMS RECORD EMPLOYEE.
01 COPY IDMS RECORD DEPARTMENT.
01 COPY IDMS RECORD JOB.
01 COPY IDMS RECORD EMPOSITION.
01 COPY IDMS RECORD OFFICE.
EJECT
PROCEDURE DIVISION.
* *********************************************************
* * PROCEDURE DIVISION GENERAL STRATEGY: *
* * 1) READ DEPT-ID-IN, WHICH CONTAINS THE *
* * DEPT-ID NUMBER *
* * 2) ACCESS THE DATABASE USING THE DEPT-ID NUMBER *
* * WITH AN OBTAIN CALC ON THE DEPARTMENT RECORD *
* * 3) ACCESS ALL EMPLOYEES IN THE DEPT-EMPLOYEE SET *
* * AND RETRIEVE RELATED JOB AND OFFICE DATA *
* * 4) PRINT A REPORT FOR EACH DEPARTMENT *
* * 5) PRINT AN ERROR REPORT FOR EMPTY DEPARTMENTS *
* * AND NONEXISTENT DEPARTMENTS (NO MATCHING *
* * DEPT-ID) *
* *********************************************************
MAIN-LINE.
PERFORM INIT-FILES.
IF END-OF-FILE
PERFORM EMPTY-INPUT-PROCESSING
ELSE
PERFORM INIT-BIND-READY
PERFORM U220-ERR-HEADER
PERFORM DEPT-PROCESSING THRU DEPT-PROCESSING-EXIT
UNTIL END-OF-FILE.
PERFORM END-PROCESSING.
GOBACK.
INIT-BIND-READY.
***************************************************************
* THE BIND STATEMENTS ARE PERFORMED INDIVIDUALLY (RATHER *
* THAN BY USING A COPY IDMS SUBSCHEMA-BINDS) IN ORDER TO *
* CHECK EACH ERROR-STATUS BY PERFORMING THE IDMS-STATUS *
* ROUTINE. *
***************************************************************
MOVE 'DEPTRPT' TO PROGRAM-NAME.
BIND RUN-UNIT.
PERFORM IDMS-STATUS.
BIND EMPLOYEE.
PERFORM IDMS-STATUS.
BIND DEPARTMENT.
PERFORM IDMS-STATUS.
BIND JOB.
PERFORM IDMS-STATUS.
BIND EMPOSITION.
PERFORM IDMS-STATUS.
BIND OFFICE.
PERFORM IDMS-STATUS.
READY.
PERFORM IDMS-STATUS.
INIT-FILES.
OPEN INPUT DEPT-FILE-IN.
OPEN OUTPUT DEPT-FILE-OUT.
OPEN OUTPUT ERR-FILE-OUT.
MOVE SPACES TO PRINT-LINE.
MOVE SPACES TO ERR-LINE.
READ DEPT-FILE-IN AT END MOVE 'Y' TO EOF-SW.
EMPTY-INPUT-PROCESSING.
MOVE NO-INPUT-MESSAGE TO PRINT-LINE.
MOVE '1' TO CC.
PERFORM U000-WRITE-LINE.
***************************************************************
* THIS PARAGRAPH ACCESSES THE DATABASE USING THE DEPT-ID-0415 *
* CALCKEY VALUE. *
***************************************************************
DEPT-PROCESSING.
MOVE DEPT-ID-IN TO DEPT-ID-0410.
OBTAIN CALC DEPARTMENT.
IF DB-REC-NOT-FOUND THEN
PERFORM NO-DEPT-PROCESSING
ELSE
PERFORM IDMS-STATUS
IF DEPT-EMPLOYEE IS NOT EMPTY THEN
PERFORM U020-VALID-HEADER
MOVE DEPT-ID-0410 TO DEPT-ID-OUT
MOVE DEPT-NAME-0410 TO DEPT-NAME-OUT
MOVE DEPT-DETAIL-LINE TO PRINT-LINE
PERFORM U000-WRITE-LINE
PERFORM U030-EMP-HEADERS
PERFORM SET-WALK THRU SET-WALK-EXIT
UNTIL DB-END-OF-SET
ELSE
PERFORM EMPTY-SET.
READ DEPT-FILE-IN AT END MOVE 'Y' TO EOF-SW.
DEPT-PROCESSING-EXIT.
EXIT.
***************************************************************
* THIS PARAGRAPH RETRIEVES EMPLOYEE, JOB, AND OFFICE DATA *
* FOR EACH EMPLOYEE IN THE DEPT-EMPLOYEE SET. *
***************************************************************
SET-WALK.
OBTAIN NEXT EMPLOYEE WITHIN DEPT-EMPLOYEE.
IF DB-END-OF-SET
GO TO SET-WALK-EXIT
ELSE
PERFORM IDMS-STATUS.
MOVE EMP-ID-0415 TO ID-OUT.
MOVE EMP-LAST-NAME-0415 TO LAST-OUT.
MOVE EMP-FIRST-NAME-0415 TO FIRST-OUT.
MOVE START-YEAR-0415 TO SD-YY.
MOVE START-MONTH-0415 TO SD-MM.
MOVE START-DAY-0415 TO SD-DD.
IF EMP-EMPOSITION IS EMPTY
MOVE NO-JOB-MESSAGE TO TITLE-OUT
ELSE
FIND FIRST WITHIN EMP-EMPOSITION
PERFORM IDMS-STATUS
IF NOT JOB-EMPOSITION MEMBER
MOVE NO-JOB-MESSAGE TO TITLE-OUT
ELSE
OBTAIN OWNER WITHIN JOB-EMPOSITION
PERFORM IDMS-STATUS
MOVE TITLE-0440 TO TITLE-OUT.
IF OFFICE-EMPLOYEE IS EMPTY
MOVE NO-OFFICE-MESSAGE TO STREET-OUT
MOVE SPACES TO CITY-OUT
MOVE SPACES TO STATE-OUT
MOVE SPACES TO ZIP-OUT
ELSE
OBTAIN OWNER WITHIN OFFICE-EMPLOYEE
PERFORM IDMS-STATUS
MOVE OFFICE-STREET-0450 TO STREET-OUT
MOVE OFFICE-CITY-0450 TO CITY-OUT
MOVE OFFICE-STATE-0450 TO STATE-OUT
MOVE OFFICE-ZIP-FIRST-FIVE-0450 TO ZIP-OUT
MOVE EMP-DETAIL-LINE TO PRINT-LINE.
PERFORM U000-WRITE-LINE.
SET-WALK-EXIT.
EXIT.
END-PROCESSING.
FINISH.
PERFORM IDMS-STATUS.
CLOSE DEPT-FILE-OUT.
CLOSE ERR-FILE-OUT.
CLOSE DEPT-FILE-IN.
EMPTY-SET.
MOVE SPACES TO ERR-LINE.
MOVE DEPT-ID-0410 TO ERR-ID-OUT.
MOVE NO-EMP-MESSAGE TO ERR-MESS-OUT.
MOVE ERR-DETAIL-LINE TO ERR-LINE.
PERFORM U200-WRITE-ERR-LINE.
NO-DEPT-PROCESSING.
MOVE DEPT-ID-IN TO ERR-ID-OUT.
MOVE NO-DEPT-MESSAGE TO ERR-MESS-OUT.
MOVE ERR-DETAIL-LINE TO ERR-LINE.
PERFORM U200-WRITE-ERR-LINE.
U000-WRITE-LINE.
WRITE DEPT-REC-OUT AFTER POSITIONING CC.
IF CC = '1' THEN MOVE 0 TO LINE-COUNT
ELSE IF CC = ' ' THEN ADD 1 TO LINE-COUNT
ELSE IF CC = '0' THEN ADD 2 TO LINE-COUNT.
IF LINE-COUNT > LINE-MAX
THEN PERFORM U010-NEW-PAGE-ROUTINE.
U010-NEW-PAGE-ROUTINE.
PERFORM U020-VALID-HEADER.
MOVE DEPT-DETAIL-LINE TO PRINT-LINE.
PERFORM U000-WRITE-LINE.
PERFORM U030-EMP-HEADERS.
U020-VALID-HEADER.
MOVE DEPT-HEADER TO PRINT-LINE.
MOVE '1' TO CC.
PERFORM U000-WRITE-LINE
MOVE ' ' TO CC.
U030-EMP-HEADERS.
MOVE '0' TO CC.
MOVE EMP-HEADER TO PRINT-LINE.
PERFORM U000-WRITE-LINE.
MOVE SPACES TO PRINT-LINE.
MOVE ' ' TO CC.
PERFORM U000-WRITE-LINE.
U200-WRITE-ERR-LINE.
WRITE ERR-REC-OUT AFTER POSITIONING ERR-CC.
IF ERR-CC = '1' THEN MOVE 0 TO ERR-LINE-COUNT
ELSE IF ERR-CC = ' ' THEN ADD 1 TO ERR-LINE-COUNT
ELSE IF ERR-CC = '0' THEN ADD 2 TO ERR-LINE-COUNT.
IF ERR-LINE-COUNT > LINE-MAX THEN
PERFORM U220-ERR-HEADER.
U220-ERR-HEADER.
MOVE ERR-HEADER-1 TO ERR-LINE.
MOVE '1' TO ERR-CC.
PERFORM U200-WRITE-ERR-LINE
MOVE '0' TO ERR-CC.
MOVE ERR-HEADER-2 TO ERR-LINE.
PERFORM U200-WRITE-ERR-LINE.
MOVE ERR-HEADER-3 TO ERR-LINE.
PERFORM U200-WRITE-ERR-LINE.
MOVE SPACES TO ERR-LINE.
MOVE ' ' TO ERR-CC.
PERFORM U200-WRITE-ERR-LINE.
IDMS-ABORT.
EXIT.
IDMS-ABORT-EXIT.
COPY IDMS IDMS-STATUS.
Since the *DMLIST option is specified in the program's IDENTIFICATION DIVISION, printed output consists of expanded code as well as diagnostics. This output is in the following format:
|
Column |
Explanation |
|---|---|
|
1 |
Sequence numbers generated by the DML compiler |
|
12 |
Line numbers generated by the DML compiler |
|
19 |
Line numbers generated by the user program |
|
26 |
Text of the COBOL source code including text generated by the DML compiler |
Note: For more information about the DML compiler status messages, see the CA IDMS Messages and Codes Guide.
This listing contains the sample batch program and partially expanded code generated by the DML compiler.
00001 *RETRIEVAL
00002 *DMLIST
00003 *NO-ACTIVITY-LOG
00004 *SCHEMA-COMMENTS
00005
00006 IDENTIFICATION DIVISION.
00007
00008 PROGRAM-ID. DEPTRPT.
00009
00010 AUTHOR. COMPUTER ASSOCIATES INTERNATIONAL.
00011
00012 DATE-WRITTEN. APRIL 1995.
00013
00014 REMARKS. THIS PROGRAM DEMONSTRATES
00015 CA IDMS DATABASE ACCESS USING
00016 COBOL DML STATEMENTS. IT READS
00017 DEPARTMENT ID NUMBERS AND RETRIEVES
00018 RELATED RECORD OCCURRENCES,
00019 PRINTING A REPORT THAT INCLUDES
00020 DEPARTMENT, EMPLOYEE, JOB, AND
00021 OFFICE INFORMATION.
00022 ***************************************************************
00023 ENVIRONMENT DIVISION.
00024 INPUT-OUTPUT SECTION.
00025 FILE-CONTROL.
00026 SELECT DEPT-FILE-IN ASSIGN TO INFILE.
00027 SELECT DEPT-FILE-OUT ASSIGN TO OUTFILE.
00028 SELECT ERR-FILE-OUT ASSIGN TO ERRFILE.
00029 ***************************************************************
DMLC 00030 IDMS-CONTROL SECTION.
00031
00032 PROTOCOL. MODE IS BATCH DEBUG
00033 IDMS-RECORDS MANUAL.
00034 SKIP3
00035 ***************************************************************
00036 DATA DIVISION.
00037
DMLC 00038 SCHEMA SECTION.
00039
00040 DB EMPSS01 WITHIN EMPSCHM.
00041
00042 ***************************************************************
00043 FILE SECTION.
00044
00045 FD DEPT-FILE-IN
00046 RECORD CONTAINS 80
00047 BLOCK CONTAINS 80 CHARACTERS
00048 RECORDING MODE IS F
00049 LABEL RECORDS ARE OMITTED.
00050
00051 01 DEPT-REC-IN.
00052 02 DEPT-ID-IN PIC 9(4).
00053 02 DEPT-IN-FILLER PIC X(76).
00054
00055 FD DEPT-FILE-OUT
00056 RECORD CONTAINS 133
00057 BLOCK CONTAINS 133 CHARACTERS
00058 RECORDING MODE IS F
00059 LABEL RECORDS ARE OMITTED.
00060
00061 01 DEPT-REC-OUT.
00062 02 CC PIC X.
00063 02 PRINT-LINE PIC X(132).
00064
00065 FD ERR-FILE-OUT
00066 RECORD CONTAINS 133
00067 BLOCK CONTAINS 133 CHARACTERS
00068 RECORDING MODE IS F
00069 LABEL RECORDS ARE OMITTED.
00070
00071 01 ERR-REC-OUT.
00072 02 ERR-CC PIC X.
00073 02 ERR-LINE PIC X(132).
00074
00075 ***************************************************************
00076 WORKING-STORAGE SECTION.
00077 01 EOF-SW PIC X VALUE 'N'.
00078 88 END-OF-FILE VALUE 'Y'.
00079 01 LINE-COUNT PIC 99 VALUE 0.
00080 01 ERR-LINE-COUNT PIC 99 VALUE 0.
00081 01 LINE-MAX PIC 99 VALUE 50.
00082 ***************************************************************
00083 01 DEPT-HEADER.
00084 05 FILLER PIC X(30) VALUE SPACES.
00085 05 FILLER PIC X(13) VALUE 'DEPARTMENT ID'.
00086 05 FILLER PIC X(10) VALUE SPACES.
00087 05 FILLER PIC X(9) VALUE 'DEPT NAME'.
00088 05 FILLER PIC X(70) VALUE SPACES.
00089 01 DEPT-DETAIL-LINE.
00090 05 FILLER PIC X(33) VALUE SPACES.
00091 05 DEPT-ID-OUT PIC X(4).
00092 05 FILLER PIC X(16) VALUE SPACES.
00093 05 DEPT-NAME-OUT PIC X(45).
00094 05 FILLER PIC X(34) VALUE SPACES.
00095 01 EMP-HEADER.
00096 05 FILLER PIC X(5) VALUE SPACES.
00097 05 FILLER PIC X(6) VALUE 'EMP ID'.
00098 05 FILLER PIC X(2) VALUE SPACES.
00099 05 FILLER PIC X(9) VALUE 'LAST NAME'.
00100 05 FILLER PIC X(8) VALUE SPACES.
00101 05 FILLER PIC X(10) VALUE 'FIRST NAME'.
00102 05 FILLER PIC X(3) VALUE SPACES.
00103 05 FILLER PIC X(10) VALUE 'START DATE'.
00104 05 FILLER PIC X(2) VALUE SPACES.
00105 05 FILLER PIC X(9) VALUE 'JOB TITLE'.
00106 05 FILLER PIC X(13) VALUE SPACES.
00107 05 FILLER PIC X(14) VALUE 'OFFICE ADDRESS'.
00108 05 FILLER PIC X(42) VALUE SPACES.
00109 01 EMP-DETAIL-LINE.
00110 05 FILLER PIC X(5) VALUE SPACES.
00111 05 ID-OUT PIC X(4).
00112 05 FILLER PIC X(4) VALUE SPACES.
00113 05 LAST-OUT PIC X(15).
00114 05 FILLER PIC X(2) VALUE SPACES.
00115 05 FIRST-OUT PIC X(10).
00116 05 FILLER PIC X(3) VALUE SPACES.
00117 05 SD-OUT.
00118 10 SD-MM PIC XX.
00119 10 FILLER PIC X VALUE '/'.
00120 10 SD-DD PIC XX.
00121 10 FILLER PIC X VALUE '/'.
00122 10 SD-YY PIC XX.
00123 05 FILLER PIC X(4) VALUE SPACES.
00124 05 TITLE-OUT PIC X(20).
00125 05 FILLER PIC X(2) VALUE SPACES.
00126 05 OFF-ADDRESS-OUT.
00127 10 STREET-OUT PIC X(20).
00128 10 FILLER PIC XX VALUE SPACES.
00129 10 CITY-OUT PIC X(15).
00130 10 FILLER PIC XX VALUE SPACES.
00131 10 STATE-OUT PIC XX.
00132 10 FILLER PIC XX VALUE SPACES.
00133 10 ZIP-OUT PIC X(5).
00134 05 FILLER PIC X(8) VALUE SPACES.
00135 01 ERR-HEADER-1.
00136 05 FILLER PIC X(40) VALUE SPACES.
00137 05 FILLER PIC X(12) VALUE 'ERROR REPORT'.
00138 05 FILLER PIC X(80) VALUE SPACES.
00139 01 ERR-HEADER-2.
00140 05 FILLER PIC X(10) VALUE SPACES.
00141 05 FILLER PIC X(4) VALUE '*** '.
00142 05 FILLER PIC X(51) VALUE
00143 'THIS REPORT LISTS EMPTY AND NONEXISTENT DEPARTMENTS'.
00144 05 FILLER PIC X(4) VALUE ' ***'.
00145 05 FILLER PIC X(63) VALUE SPACES.
00146 01 ERR-HEADER-3.
00147 05 FILLER PIC X(20) VALUE SPACES.
00148 05 FILLER PIC X(7) VALUE 'DEPT ID'.
00149 05 FILLER PIC X(9) VALUE SPACES.
00150 05 FILLER PIC X(7) VALUE 'MESSAGE'.
00151 05 FILLER PIC X(89) VALUE SPACES.
00152 01 ERR-DETAIL-LINE.
00153 05 FILLER PIC X(20) VALUE SPACES.
00154 05 ERR-ID-OUT PIC X(4).
00155 05 FILLER PIC X(12) VALUE SPACES.
00156 05 ERR-MESS-OUT PIC X(15).
00157 05 FILLER PIC X(79) VALUE SPACES.
00158 ***************************************************************
00159 01 MESSAGES.
00160 05 NO-JOB-MESSAGE.
00161 10 FILLER PIC X(20) VALUE 'NO JOB ASSIGNED'.
00162 05 NO-OFFICE-MESSAGE.
00163 10 FILLER PIC X(20)
00164 VALUE 'NO OFFICE ASSIGNED'.
00165 05 NO-DEPT-MESSAGE.
00166 10 FILLER PIC X(15) VALUE 'DOES NOT EXIST'.
00167 05 NO-EMP-MESSAGE.
00168 10 FILLER PIC X(15) VALUE 'IS EMPTY'.
00169 05 NO-INPUT-MESSAGE.
00170 10 FILLER PIC XX VALUE SPACES.
00171 10 FILLER PIC X(11) VALUE '========>> '.
00172 10 FILLER PIC X(8) VALUE 'NO INPUT'.
00173 10 FILLER PIC X(11) VALUE ' <<========'.
00174 10 FILLER PIC X(100) VALUE SPACES.
00175
DMLC 00176 01 COPY IDMS SUBSCHEMA-CTRL.
00177 01 SUBSCHEMA-CTRL.
00178 03 PROGRAM-NAME PIC X(8)
00179 VALUE SPACES .
00180 03 ERROR-STATUS PIC X(4)
00181 VALUE '1400' .
00182 88 DB-STATUS-OK
00183 VALUE '0000' .
00184 88 ANY-STATUS
00185 VALUE ' ' THRU '9999' .
00186 88 ANY-ERROR-STATUS
00187 VALUE '0001' THRU '9999' .
00188 88 DB-END-OF-SET
00189 VALUE '0307' .
00190 88 DB-REC-NOT-FOUND
00191 VALUE '0326' .
00192 03 DBKEY PIC S9(8) COMP SYNC.
00193 03 RECORD-NAME PIC X(16)
00194 VALUE SPACES .
00195 03 RRECORD-NAME REDEFINES RECORD-NAME.
00196 05 SSC-NODN PIC X(8).
00197 05 SSC-DBN PIC X(8).
00198 03 AREA-NAME PIC X(16)
00199 VALUE SPACES .
00200 03 AREA-RNAME REDEFINES AREA-NAME.
00201 05 SSC-DNO PIC X(8).
00202 05 SSC-DNA PIC X(8).
00203 03 ERROR-SET PIC X(16)
00204 VALUE SPACES .
00205 03 ERROR-RECORD PIC X(16)
00206 VALUE SPACES .
00207 03 ERROR-AREA PIC X(16)
00208 VALUE SPACES .
00209 03 IDBMSCOM-AREA PIC X(100)
00210 VALUE LOW-VALUE .
00211 03 IDBMSCOM REDEFINES IDBMSCOM-AREA
00212 PIC X
00213 OCCURS 100.
00214 03 RIDBMSCOM REDEFINES IDBMSCOM-AREA.
00215 05 DB-SUB-ADDR PIC X(4).
00216 05 FILLER PIC X(96).
00217 03 R1DBMSCOM REDEFINES IDBMSCOM-AREA.
00218 05 PAGE-INFO.
00219 07 PAGE-INFO-GROUP PIC S9(4) COMP.
00220 07 PAGE-INFO-DBK-FORMAT
00221 PIC 9(4) COMP.
00222 05 SSC-IDMS-STATUS-WRK.
00223 07 SSC-IN01-REQ-WK.
00224 09 SSC-IN01-REQ-CODE
00225 PIC S9(8) COMP.
00226 09 SSC-IN01-REQ-RETURN
00227 PIC S9(8) COMP.
00228 07 SSC-STATUS-LINE.
00229 09 SSC-STATUS-LABEL PIC X(16).
00230 09 SSC-STATUS-VALUE PIC X(12).
00231 05 FILLER PIC X(60).
00232 03 DIRECT-DBKEY PIC S9(8) COMP SYNC.
00233 03 DIRECT-DBK REDEFINES DIRECT-DBKEY
00234 PIC S9(8) COMP SYNC.
00235 03 DATABASE-STATUS.
00236 05 DBSTATMENT-CODE PIC X(2).
00237 05 DBSTATUS-CODE PIC X(5).
00238 03 FILLER PIC X.
00239 03 RECORD-OCCUR PIC S9(8) COMP SYNC.
00240 03 DML-SEQUENCE PIC S9(8) COMP SYNC.
00241
DMLC 00242 01 COPY IDMS SUBSCHEMA-SSNAME.
00243 01 SUBSCHEMA-SSNAME PIC X(8)
00244 VALUE 'EMPSS01 ' .
00245
DMLC 00246 01 COPY IDMS SUBSCHEMA-RECNAMES.
00247 01 SUBSCHEMA-RECNAMES.
00248 03 SR460 PIC X(16)
00249 VALUE 'STRUCTURE ' .
00250 03 SR455 PIC X(16)
00251 VALUE 'SKILL ' .
00252 03 SR450 PIC X(16)
00253 VALUE 'OFFICE ' .
00254 03 SR445 PIC X(16)
00255 VALUE 'NON-HOSP-CLAIM ' .
00256 03 SR440 PIC X(16)
00257 VALUE 'JOB ' .
00258 03 SR435 PIC X(16)
00259 VALUE 'INSURANCE-PLAN ' .
00260 03 SR430 PIC X(16)
00261 VALUE 'HOSPITAL-CLAIM ' .
00262 03 SR425 PIC X(16)
00263 VALUE 'EXPERTISE ' .
00264 03 SR420 PIC X(16)
00265 VALUE 'EMPOSITION ' .
00266 03 SR415 PIC X(16)
00267 VALUE 'EMPLOYEE ' .
00268 03 SR410 PIC X(16)
00269 VALUE 'DEPARTMENT ' .
00270 03 SR405 PIC X(16)
00271 VALUE 'DENTAL-CLAIM ' .
00272 03 SR400 PIC X(16)
00273 VALUE 'COVERAGE ' .
00274
DMLC 00275 01 COPY IDMS SUBSCHEMA-SETNAMES.
00276 01 SUBSCHEMA-SETNAMES.
00277 03 COVERAGE-CLAIMS PIC X(16)
00278 VALUE 'COVERAGE-CLAIMS ' .
00279 03 DEPT-EMPLOYEE PIC X(16)
00280 VALUE 'DEPT-EMPLOYEE ' .
00281 03 EMP-COVERAGE PIC X(16)
00282 VALUE 'EMP-COVERAGE ' .
00283 03 EMP-EXPERTISE PIC X(16)
00284 VALUE 'EMP-EXPERTISE ' .
00285 03 EMP-NAME-NDX PIC X(16)
00286 VALUE 'EMP-NAME-NDX ' .
00287 03 EMP-EMPOSITION PIC X(16)
00288 VALUE 'EMP-EMPOSITION ' .
00289 03 JOB-EMPOSITION PIC X(16)
00290 VALUE 'JOB-EMPOSITION ' .
00291 03 JOB-TITLE-NDX PIC X(16)
00292 VALUE 'JOB-TITLE-NDX ' .
00293 03 MANAGES PIC X(16)
00294 VALUE 'MANAGES ' .
00295 03 OFFICE-EMPLOYEE PIC X(16)
00296 VALUE 'OFFICE-EMPLOYEE ' .
00297 03 REPORTS-TO PIC X(16)
00298 VALUE 'REPORTS-TO ' .
00299 03 SKILL-EXPERTISE PIC X(16)
00300 VALUE 'SKILL-EXPERTISE ' .
00301 03 SKILL-NAME-NDX PIC X(16)
00302 VALUE 'SKILL-NAME-NDX ' .
00303 03 CALC PIC X(16)
00304 VALUE 'CALC ' .
00305
DMLC 00306 01 COPY IDMS RECORD EMPLOYEE.
00307 01 EMPLOYEE.
00308 02 EMP-ID-0415 PIC 9(4).
00309 02 EMP-NAME-0415.
00310 03 EMP-FIRST-NAME-0415 PIC X(10).
00311 03 EMP-LAST-NAME-0415 PIC X(15).
00312 02 EMP-ADDRESS-0415.
00313 03 EMP-STREET-0415 PIC X(20).
00314 03 EMP-CITY-0415 PIC X(15).
00315 03 EMP-STATE-0415 PIC X(2).
00316 03 EMP-ZIP-0415.
00317 04 EMP-ZIP-FIRST-FIVE-0415
00318 PIC X(5).
00319 04 EMP-ZIP-LAST-FOUR-0415
00320 PIC X(4).
00321 02 EMP-PHONE-0415 PIC 9(10).
00322 02 STATUS-0415 PIC X(2).
00323 88 ACTIVE-0415
00324 VALUE '01' .
00325 88 ST-DISABIL-0415
00326 VALUE '02' .
00327 88 LT-DISABIL-0415
00328 VALUE '03' .
00329 88 LEAVE-OF-ABSENCE-0415
00330 VALUE '04' .
00331 88 TERMINATED-0415
00332 VALUE '05' .
00333 02 SS-NUMBER-0415 PIC 9(9).
00334 02 START-DATE-0415.
00335 03 START-YEAR-0415 PIC 9(4).
00336 03 START-MONTH-0415 PIC 9(2).
00337 03 START-DAY-0415 PIC 9(2).
00338 02 TERMINATION-DATE-0415.
00339 03 TERMINATION-YEAR-0415 PIC 9(4).
00340 03 TERMINATION-MONTH-0415 PIC 9(2).
00341 03 TERMINATION-DAY-0415 PIC 9(2).
00342 02 BIRTH-DATE-0415.
00343 03 BIRTH-YEAR-0415 PIC 9(4).
00344 03 BIRTH-MONTH-0415 PIC 9(2).
00345 03 BIRTH-DAY-0415 PIC 9(2).
00346
DMLC 00347 01 COPY IDMS RECORD DEPARTMENT.
00348 01 DEPARTMENT.
00349 02 DEPT-ID-0410 PIC 9(4).
00350 02 DEPT-NAME-0410 PIC X(45).
00351 02 DEPT-HEAD-ID-0410 PIC 9(4).
00352 02 FILLER PIC XXX.
00353
DMLC 00354 01 COPY IDMS RECORD JOB.
00355 01 JOB.
00356 02 JOB-ID-0440 PIC 9(4).
00357 02 TITLE-0440 PIC X(20).
00358 02 DESCRIPTION-0440.
00359 03 DESCRIPTION-LINE-0440 PIC X(60)
00360 OCCURS 2.
00361 02 REQUIREMENTS-0440.
00362 03 REQUIREMENT-LINE-0440 PIC X(60)
00363 OCCURS 2.
00364 02 MINIMUM-SALARY-0440 PIC S9(6)V99.
00365 02 MAXIMUM-SALARY-0440 PIC S9(6)V99.
00366 02 SALARY-GRADES-0440 PIC 9(2)
00367 OCCURS 4.
00368 02 NUMBER-OF-POSITIONS-0440
00369 PIC 9(3).
00370 02 NUMBER-OPEN-0440 PIC 9(3).
00371 02 FILLER PIC XX.
00372
DMLC 00373 01 COPY IDMS RECORD EMPOSITION.
00374 01 EMPOSITION.
00375 02 START-DATE-0420.
00376 03 START-YEAR-0420 PIC 9(4).
00377 03 START-MONTH-0420 PIC 9(2).
00378 03 START-DAY-0420 PIC 9(2).
00379 02 FINISH-DATE-0420.
00380 03 FINISH-YEAR-0420 PIC 9(4).
00381 03 FINISH-MONTH-0420 PIC 9(2).
00382 03 FINISH-DAY-0420 PIC 9(2).
00383 02 SALARY-GRADE-0420 PIC 9(2).
00384 02 SALARY-AMOUNT-0420 PIC S9(7)V99 COMP-3.
00385 02 BONUS-PERCENT-0420 PIC SV999 COMP-3.
00386 02 COMMISSION-PERCENT-0420 PIC SV999 COMP-3.
00387 02 OVERTIME-RATE-0420 PIC S9V99 COMP-3.
00388 02 FILLER PIC XXX.
00389
DMLC 00390 01 COPY IDMS RECORD OFFICE.
00391 01 OFFICE.
00392 02 OFFICE-CODE-0450 PIC X(3).
00393 02 OFFICE-ADDRESS-0450.
00394 03 OFFICE-STREET-0450 PIC X(20).
00395 03 OFFICE-CITY-0450 PIC X(15).
00396 03 OFFICE-STATE-0450 PIC X(2).
00397 03 OFFICE-ZIP-0450.
00398 04 OFFICE-ZIP-FIRST-FIVE-0450
00399 PIC X(5).
00400 04 OFFICE-ZIP-LAST-FOUR-0450
00401 PIC X(4).
00402 02 OFFICE-PHONE-0450 PIC 9(7)
00403 OCCURS 3.
00404 02 OFFICE-AREA-CODE-0450 PIC X(3).
00405 02 SPEED-DIAL-0450 PIC X(3).
00406 02 FILLER PIC X(4).
00407 EJECT
00408 PROCEDURE DIVISION.
00409 * *********************************************************
00410 * * PROCEDURE DIVISION GENERAL STRATEGY: *
00411 * * 1) READ DEPT-ID-IN, WHICH CONTAINS THE *
00412 * * DEPT-ID NUMBER *
00413 * * 2) ACCESS THE DATABASE USING THE DEPT-ID NUMBER *
00414 * * WITH AN OBTAIN CALC ON THE DEPARTMENT RECORD *
00415 * * 3) ACCESS ALL EMPLOYEES IN THE DEPT-EMPLOYEE SET *
00416 * * AND RETRIEVE RELATED JOB AND OFFICE DATA *
00417 * * 4) PRINT A REPORT FOR EACH DEPARTMENT *
00418 * * 5) PRINT AN ERROR REPORT FOR EMPTY DEPARTMENTS *
00419 * * AND NONEXISTENT DEPARTMENTS (NO MATCHING *
00420 * * DEPT-ID) *
00421 * *********************************************************
00422
00423 MAIN-LINE.
00424 PERFORM INIT-FILES.
00425 IF END-OF-FILE
00426 PERFORM EMPTY-INPUT-PROCESSING
00427 ELSE
00428 PERFORM INIT-BIND-READY
00429 PERFORM U220-ERR-HEADER
00430 PERFORM DEPT-PROCESSING THRU DEPT-PROCESSING-EXIT
00431 UNTIL END-OF-FILE.
00432 PERFORM END-PROCESSING.
00433 GOBACK.
00434
00435 INIT-BIND-READY.
00436 ***************************************************************
00437 * THE BIND STATEMENTS ARE PERFORMED INDIVIDUALLY (RATHER *
00438 * THAN BY USING A COPY IDMS SUBSCHEMA-BINDS) IN ORDER TO *
00439 * CHECK EACH ERROR-STATUS BY PERFORMING THE IDMS-STATUS *
00440 * ROUTINE. *
00441
***************************************************************
00442 MOVE 'DEPTRPT' TO PROGRAM-NAME.
DMLC0001 00443 BIND RUN-UNIT.
00444 MOVE 1 TO DML-SEQUENCE
00445 CALL 'IDMS' USING SUBSCHEMA-CTRL
00446 IDBMSCOM (59)
00447 SUBSCHEMA-CTRL
00448 SUBSCHEMA-SSNAME.
00449 PERFORM IDMS-STATUS.
DMLC0002 00450 BIND EMPLOYEE.
00451 MOVE 2 TO DML-SEQUENCE
00452 CALL 'IDMS' USING SUBSCHEMA-CTRL
00453 IDBMSCOM (48)
00454 SR415
00455 EMPLOYEE.
00456 PERFORM IDMS-STATUS.
DMLC0003 00457 BIND DEPARTMENT.
00458 MOVE 3 TO DML-SEQUENCE
00459 CALL 'IDMS' USING SUBSCHEMA-CTRL
00460 IDBMSCOM (48)
00461 SR410
00462 DEPARTMENT.
00463 PERFORM IDMS-STATUS.
DMLC0004 00464 BIND JOB.
00465 MOVE 4 TO DML-SEQUENCE
00466 CALL 'IDMS' USING SUBSCHEMA-CTRL
00467 IDBMSCOM (48)
00468 SR440
00469 JOB.
00470 PERFORM IDMS-STATUS.
DMLC0005 00471 BIND EMPOSITION.
00472 MOVE 5 TO DML-SEQUENCE
00473 CALL 'IDMS' USING SUBSCHEMA-CTRL
00474 IDBMSCOM (48)
00475 SR420
00476 EMPOSITION.
00477 PERFORM IDMS-STATUS.
DMLC0006 00478 BIND OFFICE.
00479 MOVE 6 TO DML-SEQUENCE
00480 CALL 'IDMS' USING SUBSCHEMA-CTRL
00481 IDBMSCOM (48)
00482 SR450
00483 OFFICE.
00484 PERFORM IDMS-STATUS.
DMLC0007 00485 READY.
00486 MOVE 7 TO DML-SEQUENCE
00487 CALL 'IDMS' USING SUBSCHEMA-CTRL
00488 IDBMSCOM (37).
00489 PERFORM IDMS-STATUS.
00490
00491 INIT-FILES.
00492 OPEN INPUT DEPT-FILE-IN.
00493 OPEN OUTPUT DEPT-FILE-OUT.
00494 OPEN OUTPUT ERR-FILE-OUT.
00495 MOVE SPACES TO PRINT-LINE.
00496 MOVE SPACES TO ERR-LINE.
00497 READ DEPT-FILE-IN AT END MOVE 'Y' TO EOF-SW.
00498
00499 EMPTY-INPUT-PROCESSING.
00500 MOVE NO-INPUT-MESSAGE TO PRINT-LINE.
00501 MOVE '1' TO CC.
00502 PERFORM U000-WRITE-LINE.
00503
***************************************************************
00504 * THIS PARAGRAPH ACCESSES THE DATABASE USING THE DEPT-ID-0415 *
00505 * CALCKEY VALUE. *
00506 ***************************************************************
00507 DEPT-PROCESSING.
00508 MOVE DEPT-ID-IN TO DEPT-ID-0410.
DMLC0008 00509 OBTAIN CALC DEPARTMENT.
00510 MOVE 8 TO DML-SEQUENCE
00511 CALL 'IDMS' USING SUBSCHEMA-CTRL
00512 IDBMSCOM (32)
00513 SR410
00514 IDBMSCOM (43).
00515 IF DB-REC-NOT-FOUND THEN
00516 PERFORM NO-DEPT-PROCESSING
00517 ELSE
00518 PERFORM IDMS-STATUS
DMLC0009 00519 IF DEPT-EMPLOYEE IS NOT EMPTY
00520 MOVE 9 TO DML-SEQUENCE
00521 CALL 'IDMS' USING SUBSCHEMA-CTRL
00522 IDBMSCOM (65)
00523 DEPT-EMPLOYEE;
00524 IF ERROR-STATUS EQUAL TO '1601'
00525 THEN
00526 PERFORM U020-VALID-HEADER
00527 MOVE DEPT-ID-0410 TO DEPT-ID-OUT
00528 MOVE DEPT-NAME-0410 TO DEPT-NAME-OUT
00529 MOVE DEPT-DETAIL-LINE TO PRINT-LINE
00530 PERFORM U000-WRITE-LINE
00531 PERFORM U030-EMP-HEADERS
00532 PERFORM SET-WALK THRU SET-WALK-EXIT
00533 UNTIL DB-END-OF-SET
00534 ELSE
00535 PERFORM EMPTY-SET.
00536 READ DEPT-FILE-IN AT END MOVE 'Y' TO EOF-SW.
00537 DEPT-PROCESSING-EXIT.
00538 EXIT.
00539 ***************************************************************
00540 * THIS PARAGRAPH RETRIEVES EMPLOYEE, JOB, AND OFFICE DATA *
00541 * FOR EACH EMPLOYEE IN THE DEPT-EMPLOYEE SET. *
00542 ***************************************************************
00543 SET-WALK.
DMLC0010 00544 OBTAIN NEXT EMPLOYEE WITHIN DEPT-EMPLOYEE.
00545 MOVE 10 TO DML-SEQUENCE
00546 CALL 'IDMS' USING SUBSCHEMA-CTRL
00547 IDBMSCOM (10)
00548 SR415
00549 DEPT-EMPLOYEE
00550 IDBMSCOM (43).
00551 IF DB-END-OF-SET
00552 GO TO SET-WALK-EXIT
00553 ELSE
00554 PERFORM IDMS-STATUS.
00555 MOVE EMP-ID-0415 TO ID-OUT.
00556 MOVE EMP-LAST-NAME-0415 TO LAST-OUT.
00557 MOVE EMP-FIRST-NAME-0415 TO FIRST-OUT.
00558 MOVE START-YEAR-0415 TO SD-YY.
00559 MOVE START-MONTH-0415 TO SD-MM.
00560 MOVE START-DAY-0415 TO SD-DD.
DMLC0011 00561 IF EMP-EMPOSITION IS EMPTY
00562 MOVE 11 TO DML-SEQUENCE
00563 CALL 'IDMS' USING SUBSCHEMA-CTRL
00564 IDBMSCOM (64)
00565 EMP-EMPOSITION;
00566 IF ERROR-STATUS EQUAL TO '0000'
00567 MOVE NO-JOB-MESSAGE TO TITLE-OUT
00568 ELSE
DMLC0012 00569 FIND FIRST WITHIN EMP-EMPOSITION
00570 MOVE 12 TO DML-SEQUENCE
00571 CALL 'IDMS' USING SUBSCHEMA-CTRL
00572 IDBMSCOM (20)
00573 EMP-EMPOSITION;
00574 PERFORM IDMS-STATUS
DMLC0013 00575 IF NOT JOB-EMPOSITION MEMBER
00576 MOVE 13 TO DML-SEQUENCE
00577 CALL 'IDMS' USING SUBSCHEMA-CTRL
00578 IDBMSCOM (62)
00579 JOB-EMPOSITION;
00580 IF ERROR-STATUS EQUAL TO '1601'
00581 MOVE NO-JOB-MESSAGE TO TITLE-OUT
00582 ELSE
DMLC0014 00583 OBTAIN OWNER WITHIN JOB-EMPOSITION
00584 MOVE 14 TO DML-SEQUENCE
00585 CALL 'IDMS' USING SUBSCHEMA-CTRL
00586 IDBMSCOM (31)
00587 JOB-EMPOSITION
00588 IDBMSCOM (43);
00589 PERFORM IDMS-STATUS
00590 MOVE TITLE-0440 TO TITLE-OUT.
DMLC0015 00591 IF OFFICE-EMPLOYEE IS EMPTY
00592 MOVE 15 TO DML-SEQUENCE
00593 CALL 'IDMS' USING SUBSCHEMA-CTRL
00594 IDBMSCOM (64)
00595 OFFICE-EMPLOYEE;
00596 IF ERROR-STATUS EQUAL TO '0000'
00597 MOVE NO-OFFICE-MESSAGE TO STREET-OUT
00598 MOVE SPACES TO CITY-OUT
00599 MOVE SPACES TO STATE-OUT
00600 MOVE SPACES TO ZIP-OUT
00601 ELSE
DMLC0016 00602 OBTAIN OWNER WITHIN OFFICE-EMPLOYEE
00603 MOVE 16 TO DML-SEQUENCE
00604 CALL 'IDMS' USING SUBSCHEMA-CTRL
00605 IDBMSCOM (31)
00606 OFFICE-EMPLOYEE
00607 IDBMSCOM (43);
00608 PERFORM IDMS-STATUS
00609 MOVE OFFICE-STREET-0450 TO STREET-OUT
00610 MOVE OFFICE-CITY-0450 TO CITY-OUT
00611 MOVE OFFICE-STATE-0450 TO STATE-OUT
00612 MOVE OFFICE-ZIP-FIRST-FIVE-0450 TO ZIP-OUT
00613 MOVE EMP-DETAIL-LINE TO PRINT-LINE.
00614 PERFORM U000-WRITE-LINE.
00615 SET-WALK-EXIT.
00616 EXIT.
00617
00618 END-PROCESSING.
DMLC0017 00619 FINISH.
00620 MOVE 17 TO DML-SEQUENCE
00621 CALL 'IDMS' USING SUBSCHEMA-CTRL
00622 IDBMSCOM (2).
00623 PERFORM IDMS-STATUS.
00624 CLOSE DEPT-FILE-OUT.
00625 CLOSE ERR-FILE-OUT.
00626 CLOSE DEPT-FILE-IN.
00627
00628 EMPTY-SET.
00629 MOVE SPACES TO ERR-LINE.
00630 MOVE DEPT-ID-0410 TO ERR-ID-OUT.
00631 MOVE NO-EMP-MESSAGE TO ERR-MESS-OUT.
00632 MOVE ERR-DETAIL-LINE TO ERR-LINE.
00633 PERFORM U200-WRITE-ERR-LINE.
00634
00635 NO-DEPT-PROCESSING.
00636 MOVE DEPT-ID-IN TO ERR-ID-OUT.
00637 MOVE NO-DEPT-MESSAGE TO ERR-MESS-OUT.
00638 MOVE ERR-DETAIL-LINE TO ERR-LINE.
00639 PERFORM U200-WRITE-ERR-LINE.
00640
00641 U000-WRITE-LINE.
00642 WRITE DEPT-REC-OUT AFTER POSITIONING CC.
00643 IF CC = '1' THEN MOVE 0 TO LINE-COUNT
00644 ELSE IF CC = ' ' THEN ADD 1 TO LINE-COUNT
00645 ELSE IF CC = '0' THEN ADD 2 TO LINE-COUNT.
00646 IF LINE-COUNT > LINE-MAX
00647 THEN PERFORM U010-NEW-PAGE-ROUTINE.
00648 U010-NEW-PAGE-ROUTINE.
00649 PERFORM U020-VALID-HEADER.
00650 MOVE DEPT-DETAIL-LINE TO PRINT-LINE.
00651 PERFORM U000-WRITE-LINE.
00652 PERFORM U030-EMP-HEADERS.
00653 U020-VALID-HEADER.
00654 MOVE DEPT-HEADER TO PRINT-LINE.
00655 MOVE '1' TO CC.
00656 PERFORM U000-WRITE-LINE
00657 MOVE ' ' TO CC.
00658 U030-EMP-HEADERS.
00659 MOVE '0' TO CC.
00660 MOVE EMP-HEADER TO PRINT-LINE.
00661 PERFORM U000-WRITE-LINE.
00662 MOVE SPACES TO PRINT-LINE.
00663 MOVE ' ' TO CC.
00664 PERFORM U000-WRITE-LINE.
00665
00666 U200-WRITE-ERR-LINE.
00667 WRITE ERR-REC-OUT AFTER POSITIONING ERR-CC.
00668 IF ERR-CC = '1' THEN MOVE 0 TO ERR-LINE-COUNT
00669 ELSE IF ERR-CC = ' ' THEN ADD 1 TO ERR-LINE-COUNT
00670 ELSE IF ERR-CC = '0' THEN ADD 2 TO ERR-LINE-COUNT.
00671 IF ERR-LINE-COUNT > LINE-MAX THEN
00672 PERFORM U220-ERR-HEADER.
00673 U220-ERR-HEADER.
00674 MOVE ERR-HEADER-1 TO ERR-LINE.
00675 MOVE '1' TO ERR-CC.
00676 PERFORM U200-WRITE-ERR-LINE
00677 MOVE '0' TO ERR-CC.
00678 MOVE ERR-HEADER-2 TO ERR-LINE.
00679 PERFORM U200-WRITE-ERR-LINE.
00680 MOVE ERR-HEADER-3 TO ERR-LINE.
00681 PERFORM U200-WRITE-ERR-LINE.
00682 MOVE SPACES TO ERR-LINE.
00683 MOVE ' ' TO ERR-CC.
00684 PERFORM U200-WRITE-ERR-LINE.
00685 IDMS-ABORT.
00686 EXIT.
00687 IDMS-ABORT-EXIT.
DMLC 00688 COPY IDMS IDMS-STATUS.
00689
******************************************************************
00690 IDMS-STATUS SECTION.
00691 ******************************************************************
00692 IDMS-STATUS-PARAGRAPH.
00693 IF DB-STATUS-OK GO TO ISABEX.
00694 PERFORM IDMS-ABORT.
00695 DISPLAY '**************************'
00696 ' ABORTING - ' PROGRAM-NAME
00697 ', ' ERROR-STATUS
00698 ', ' ERROR-RECORD
00699 ' **** RECOVER IDMS ****'
00700 UPON CONSOLE.
00701 DISPLAY 'PROGRAM NAME ------ ' PROGRAM-NAME.
00702 DISPLAY 'ERROR STATUS ------ ' ERROR-STATUS.
00703 DISPLAY 'ERROR RECORD ------ ' ERROR-RECORD.
00704 DISPLAY 'ERROR SET --------- ' ERROR-SET.
00705 DISPLAY 'ERROR AREA -------- ' ERROR-AREA.
00706 DISPLAY 'LAST GOOD RECORD -- ' RECORD-NAME.
00707 DISPLAY 'LAST GOOD AREA ---- ' AREA-NAME.
00708 MOVE 39 TO SSC-IN01-REQ-CODE.
00709 MOVE 0 TO SSC-IN01-REQ-RETURN.
00710 MOVE ' ' TO SSC-STATUS-LABEL.
00711 PERFORM IDMS-STATUS-LOOP
00712 UNTIL SSC-IN01-REQ-RETURN > 0.
DMLC0018 00713 ROLLBACK.
00714 MOVE 18 TO DML-SEQUENCE
00715 CALL 'IDMS' USING SUBSCHEMA-CTRL
00716 IDBMSCOM (67).
00717 CALL 'ABORT'.
00718 GO TO ISABEX.
00719 IDMS-STATUS-LOOP.
00720 CALL 'IDMSIN1' USING IDBMSCOM(41)
00721 SSC-IN01-REQ-WK
00722 SUBSCHEMA-CTRL
00723 IDBMSCOM(1)
00724 DML-SEQUENCE
00725 SSC-STATUS-LINE.
00726 IF SSC-IN01-REQ-RETURN GREATER THAN 4
00727 DISPLAY 'DML SEQUENCE ------ ' DML-SEQUENCE
00728 ELSE
00729 DISPLAY SSC-STATUS-LABEL '--- ' SSC-STATUS-VALUE.
00730 ISABEX. EXIT.
NO MESSAGES FOR PROGRAM DEPTRPT
The following listing illustrates the sample batch program after precompilation by the COBOL precompiler. The original code is further expanded and includes the following:
Note: For more information about expanded code generated by the DML compiler, see CA IDMS Call Formats.
This listing contains the sample program output from the COBOL compiler with the fully expanded code (including the calls to CA IDMS) generated by the DML compiler.
00001 *DMLIST 00002 *NO-ACTIVITY-LOG 00003 *SCHEMA-COMMENTS 00004 00005 IDENTIFICATION DIVISION. 00006 00007 PROGRAM-ID. DEPTRPT. 00008 00009 AUTHOR. COMPUTER ASSOCIATES INTERNATIONAL. 00010 00011 DATE-WRITTEN. APRIL 1995. 00012 00013 REMARKS. THIS PROGRAM DEMONSTRATES 00014 CA IDMS DATABASE ACCESS USING 00015 COBOL DML STATEMENTS. IT READS 00016 DEPARTMENT ID NUMBERS AND RETRIEVES 00017 RELATED RECORD OCCURRENCES, 00018 PRINTING A REPORT THAT INCLUDES 00019 DEPARTMENT, EMPLOYEE, JOB, AND 00020 OFFICE INFORMATION. 00021 *************************************************************** 00022 ENVIRONMENT DIVISION. 00023 INPUT-OUTPUT SECTION. 00024 FILE-CONTROL. 00025 SELECT DEPT-FILE-IN ASSIGN TO INFILE. 00026 SELECT DEPT-FILE-OUT ASSIGN TO OUTFILE. 00027 SELECT ERR-FILE-OUT ASSIGN TO ERRFILE. 00028 *************************************************************** 00029 *IDMS-CONTROL SECTION. 00030 * 00031 *PROTOCOL. MODE IS BATCH DEBUG 00032 * IDMS-RECORDS MANUAL. 00034 *************************************************************** 00035 DATA DIVISION. 00036 00037 *SCHEMA SECTION. 00038 * 00039 *DB EMPSS01 WITHIN EMPSCHM. 00040 00041 *************************************************************** 00042 FILE SECTION. 00043 00044 FD DEPT-FILE-IN 00045 RECORD CONTAINS 80 00046 BLOCK CONTAINS 80 CHARACTERS 00047 RECORDING MODE IS F 00048 LABEL RECORDS ARE OMITTED. 00049 00050 01 DEPT-REC-IN. 00051 02 DEPT-ID-IN PIC 9(4). 00052 02 DEPT-IN-FILLER PIC X(76). 00053 00054 FD DEPT-FILE-OUT 00055 RECORD CONTAINS 133 00056 BLOCK CONTAINS 133 CHARACTERS 00057 RECORDING MODE IS F 00058 LABEL RECORDS ARE OMITTED. 00059 00060 01 DEPT-REC-OUT. 00061 02 CC PIC X. 00062 02 PRINT-LINE PIC X(132). 00063 00064 FD ERR-FILE-OUT 00065 RECORD CONTAINS 133 00066 BLOCK CONTAINS 133 CHARACTERS 00067 RECORDING MODE IS F 00068 LABEL RECORDS ARE OMITTED. 00069 00070 01 ERR-REC-OUT. 00071 02 ERR-CC PIC X. 00072 02 ERR-LINE PIC X(132). 00073 00074 *************************************************************** 00075 WORKING-STORAGE SECTION. 00076 01 EOF-SW PIC X VALUE 'N'. 00077 88 END-OF-FILE VALUE 'Y'. 00078 01 LINE-COUNT PIC 99 VALUE 0. 00079 01 ERR-LINE-COUNT PIC 99 VALUE 0. 00080 01 LINE-MAX PIC 99 VALUE 50. 00081 *************************************************************** 00082 01 DEPT-HEADER. 00083 05 FILLER PIC X(30) VALUE SPACES. 00084 05 FILLER PIC X(13) VALUE 'DEPARTMENT ID'. 00085 05 FILLER PIC X(10) VALUE SPACES. 00086 05 FILLER PIC X(9) VALUE 'DEPT NAME'. 00087 05 FILLER PIC X(70) VALUE SPACES. 00088 01 DEPT-DETAIL-LINE. 00089 05 FILLER PIC X(33) VALUE SPACES. 00090 05 DEPT-ID-OUT PIC X(4). 00091 05 FILLER PIC X(16) VALUE SPACES. 00092 05 DEPT-NAME-OUT PIC X(45). 00093 05 FILLER PIC X(34) VALUE SPACES. 00094 01 EMP-HEADER. 00095 05 FILLER PIC X(5) VALUE SPACES. 00096 05 FILLER PIC X(6) VALUE 'EMP ID'. 00097 05 FILLER PIC X(2) VALUE SPACES. 00098 05 FILLER PIC X(9) VALUE 'LAST NAME'. 00099 05 FILLER PIC X(8) VALUE SPACES. 00100 05 FILLER PIC X(10) VALUE 'FIRST NAME'. 00101 05 FILLER PIC X(3) VALUE SPACES. 00102 05 FILLER PIC X(10) VALUE 'START DATE'. 00103 05 FILLER PIC X(2) VALUE SPACES. 00104 05 FILLER PIC X(9) VALUE 'JOB TITLE'. 00105 05 FILLER PIC X(13) VALUE SPACES. 00106 05 FILLER PIC X(14) VALUE 'OFFICE ADDRESS'. 00107 05 FILLER PIC X(42) VALUE SPACES. 00108 01 EMP-DETAIL-LINE. 00109 05 FILLER PIC X(5) VALUE SPACES. 00110 05 ID-OUT PIC X(4). 00111 05 FILLER PIC X(4) VALUE SPACES. 00112 05 LAST-OUT PIC X(15). 00113 05 FILLER PIC X(2) VALUE SPACES. 00114 05 FIRST-OUT PIC X(10). 00115 05 FILLER PIC X(3) VALUE SPACES. 00116 05 SD-OUT. 00117 10 SD-MM PIC XX. 00118 10 FILLER PIC X VALUE '/'. 00119 10 SD-DD PIC XX. 00120 10 FILLER PIC X VALUE '/'. 00121 10 SD-YY PIC XX. 00122 05 FILLER PIC X(4) VALUE SPACES. 00123 05 TITLE-OUT PIC X(20). 00124 05 FILLER PIC X(2) VALUE SPACES. 00125 05 OFF-ADDRESS-OUT. 00126 10 STREET-OUT PIC X(20). 00127 10 FILLER PIC XX VALUE SPACES. 00128 10 CITY-OUT PIC X(15). 00129 10 FILLER PIC XX VALUE SPACES. 00130 10 STATE-OUT PIC XX. 00131 10 FILLER PIC XX VALUE SPACES. 00132 10 ZIP-OUT PIC X(5). 00133 05 FILLER PIC X(8) VALUE SPACES. 00134 01 ERR-HEADER-1. 00135 05 FILLER PIC X(40) VALUE SPACES. 00136 05 FILLER PIC X(12) VALUE 'ERROR REPORT'. 00137 05 FILLER PIC X(80) VALUE SPACES. 00138 01 ERR-HEADER-2. 00139 05 FILLER PIC X(10) VALUE SPACES. 00140 05 FILLER PIC X(4) VALUE '*** '. 00141 05 FILLER PIC X(51) VALUE 00142 'THIS REPORT LISTS EMPTY AND NONEXISTENT DEPARTMENTS'. 00143 05 FILLER PIC X(4) VALUE ' ***'. 00144 05 FILLER PIC X(63) VALUE SPACES. 00145 01 ERR-HEADER-3. 00146 05 FILLER PIC X(20) VALUE SPACES. 00147 05 FILLER PIC X(7) VALUE 'DEPT ID'. 00148 05 FILLER PIC X(9) VALUE SPACES. 00149 05 FILLER PIC X(7) VALUE 'MESSAGE'. 00150 05 FILLER PIC X(89) VALUE SPACES. 00151 01 ERR-DETAIL-LINE. 00152 05 FILLER PIC X(20) VALUE SPACES. 00153 05 ERR-ID-OUT PIC X(4). 00154 05 FILLER PIC X(12) VALUE SPACES. 00155 05 ERR-MESS-OUT PIC X(15). 00156 05 FILLER PIC X(79) VALUE SPACES. 00157 *************************************************************** 00158 01 MESSAGES. 00159 05 NO-JOB-MESSAGE. 00160 10 FILLER PIC X(20) VALUE 'NO JOB ASSIGNED'. 00161 05 NO-OFFICE-MESSAGE. 00162 10 FILLER PIC X(20) 00163 VALUE 'NO OFFICE ASSIGNED'. 00164 05 NO-DEPT-MESSAGE. 00165 10 FILLER PIC X(15) VALUE 'DOES NOT EXIST'. 00166 05 NO-EMP-MESSAGE. 00167 10 FILLER PIC X(15) VALUE 'IS EMPTY'. 00168 05 NO-INPUT-MESSAGE. 00169 10 FILLER PIC XX VALUE SPACES. 00170 10 FILLER PIC X(11) VALUE '========>> '. 00171 10 FILLER PIC X(8) VALUE 'NO INPUT'. 00172 10 FILLER PIC X(11) VALUE ' <<========'. 00173 10 FILLER PIC X(100) VALUE SPACES. 00174 00175 *01 COPY IDMS SUBSCHEMA-CTRL. 00176 01 SUBSCHEMA-CTRL. 00177 03 PROGRAM-NAME PIC X(8) 00178 VALUE SPACES . 00179 03 ERROR-STATUS PIC X(4) 00180 VALUE '1400' . 00181 88 DB-STATUS-OK 00182 VALUE '0000' . 00183 88 ANY-STATUS 00184 VALUE ' ' THRU '9999' . 00185 88 ANY-ERROR-STATUS 00186 VALUE '0001' THRU '9999' . 00187 88 DB-END-OF-SET 00188 VALUE '0307' . 00189 88 DB-REC-NOT-FOUND 00190 VALUE '0326' . 00191 03 DBKEY PIC S9(8) COMP SYNC. 00192 03 RECORD-NAME PIC X(16) 00193 VALUE SPACES . 00194 03 RRECORD-NAME REDEFINES RECORD-NAME. 00195 05 SSC-NODN PIC X(8). 00196 05 SSC-DBN PIC X(8). 00197 03 AREA-NAME PIC X(16) 00198 VALUE SPACES . 00199 03 AREA-RNAME REDEFINES AREA-NAME. 00200 05 SSC-DNO PIC X(8). 00201 05 SSC-DNA PIC X(8). 00202 03 ERROR-SET PIC X(16) 00203 VALUE SPACES . 00204 03 ERROR-RECORD PIC X(16) 00205 VALUE SPACES . 00206 03 ERROR-AREA PIC X(16) 00207 VALUE SPACES . 00208 03 IDBMSCOM-AREA PIC X(100) 00209 VALUE LOW-VALUE . 00210 03 IDBMSCOM REDEFINES IDBMSCOM-AREA 00211 PIC X 00212 OCCURS 100. 00213 03 RIDBMSCOM REDEFINES IDBMSCOM-AREA. 00214 05 DB-SUB-ADDR PIC X(4). 00215 05 FILLER PIC X(96). 00216 03 R1DBMSCOM REDEFINES IDBMSCOM-AREA. 00217 05 PAGE-INFO. 00218 07 PAGE-INFO-GROUP PIC S9(4) COMP. 00219 07 PAGE-INFO-DBK-FORMAT 00220 PIC 9(4) COMP. 00221 05 SSC-IDMS-STATUS-WRK. 00222 07 SSC-IN01-REQ-WK. 00223 09 SSC-IN01-REQ-CODE 00224 PIC S9(8) COMP. 00225 09 SSC-IN01-REQ-RETURN 00226 PIC S9(8) COMP. 00227 07 SSC-STATUS-LINE. 00228 09 SSC-STATUS-LABEL PIC X(16). 00229 09 SSC-STATUS-VALUE PIC X(12). 00300 05 FILLER PIC X(60). 00301 03 DIRECT-DBKEY PIC S9(8) COMP SYNC. 00302 03 DIRECT-DBK REDEFINES DIRECT-DBKEY 00303 PIC S9(8) COMP SYNC. 00234 03 DATABASE-STATUS. 00235 05 DBSTATMENT-CODE PIC X(2). 00236 05 DBSTATUS-CODE PIC X(5). 00237 03 FILLER PIC X. 00238 03 RECORD-OCCUR PIC S9(8) COMP SYNC. 00239 03 DML-SEQUENCE PIC S9(8) COMP SYNC. 00240 00241 *01 COPY IDMS SUBSCHEMA-SSNAME. 00242 01 SUBSCHEMA-SSNAME PIC X(8) 00243 VALUE 'EMPSS01 ' . 00244 00245 *01 COPY IDMS SUBSCHEMA-RECNAMES. 00246 01 SUBSCHEMA-RECNAMES. 00247 03 SR460 PIC X(16) 00248 VALUE 'STRUCTURE ' . 00249 03 SR455 PIC X(16) 00250 VALUE 'SKILL ' . 00251 03 SR450 PIC X(16) 00252 VALUE 'OFFICE ' . 00253 03 SR445 PIC X(16) 00254 VALUE 'NON-HOSP-CLAIM ' . 00255 03 SR440 PIC X(16) 00256 VALUE 'JOB ' . 00257 03 SR435 PIC X(16) 00258 VALUE 'INSURANCE-PLAN ' . 00259 03 SR430 PIC X(16) 00260 VALUE 'HOSPITAL-CLAIM ' . 00261 03 SR425 PIC X(16) 00262 VALUE 'EXPERTISE ' . 00263 03 SR420 PIC X(16) 00264 VALUE 'EMPOSITION ' . 00265 03 SR415 PIC X(16) 00266 VALUE 'EMPLOYEE ' . 00267 03 SR410 PIC X(16) 00268 VALUE 'DEPARTMENT ' . 00269 03 SR405 PIC X(16) 00270 VALUE 'DENTAL-CLAIM ' . 00271 03 SR400 PIC X(16) 00272 VALUE 'COVERAGE ' . 00273 00274 *01 COPY IDMS SUBSCHEMA-SETNAMES. 00275 01 SUBSCHEMA-SETNAMES. 00276 03 COVERAGE-CLAIMS PIC X(16) 00277 VALUE 'COVERAGE-CLAIMS ' . 00278 03 DEPT-EMPLOYEE PIC X(16) 00279 VALUE 'DEPT-EMPLOYEE ' . 00280 03 EMP-COVERAGE PIC X(16) 00281 VALUE 'EMP-COVERAGE ' . 00282 03 EMP-EXPERTISE PIC X(16) 00283 VALUE 'EMP-EXPERTISE ' . 00284 03 EMP-NAME-NDX PIC X(16) 00285 VALUE 'EMP-NAME-NDX ' . 00286 03 EMP-EMPOSITION PIC X(16) 00287 VALUE 'EMP-EMPOSITION ' . 00288 03 JOB-EMPOSITION PIC X(16) 00289 VALUE 'JOB-EMPOSITION ' . 00290 03 JOB-TITLE-NDX PIC X(16) 00291 VALUE 'JOB-TITLE-NDX ' . 00292 03 MANAGES PIC X(16) 00293 VALUE 'MANAGES ' . 00294 03 OFFICE-EMPLOYEE PIC X(16) 00295 VALUE 'OFFICE-EMPLOYEE ' . 00296 03 REPORTS-TO PIC X(16) 00297 VALUE 'REPORTS-TO ' . 00298 03 SKILL-EXPERTISE PIC X(16) 00299 VALUE 'SKILL-EXPERTISE ' . 00300 03 SKILL-NAME-NDX PIC X(16) 00301 VALUE 'SKILL-NAME-NDX ' . 00302 03 CALC PIC X(16) 00303 VALUE 'CALC ' . 00304 00305 *01 COPY IDMS RECORD EMPLOYEE. 00306 01 EMPLOYEE. 00307 02 EMP-ID-0415 PIC 9(4). 00308 02 EMP-NAME-0415. 00309 03 EMP-FIRST-NAME-0415 PIC X(10). 00310 03 EMP-LAST-NAME-0415 PIC X(15). 00311 02 EMP-ADDRESS-0415. 00312 03 EMP-STREET-0415 PIC X(20). 00313 03 EMP-CITY-0415 PIC X(15). 00314 03 EMP-STATE-0415 PIC X(2). 00315 03 EMP-ZIP-0415. 00316 04 EMP-ZIP-FIRST-FIVE-0415 00317 PIC X(5). 00318 04 EMP-ZIP-LAST-FOUR-0415 00319 PIC X(4). 00320 02 EMP-PHONE-0415 PIC 9(10). 00321 02 STATUS-0415 PIC X(2). 00322 88 ACTIVE-0415 00323 VALUE '01' . 00324 88 ST-DISABIL-0415 00325 VALUE '02' . 00326 88 LT-DISABIL-0415 00327 VALUE '03' . 00328 88 LEAVE-OF-ABSENCE-0415 00329 VALUE '04' . 00330 88 TERMINATED-0415 00331 VALUE '05' . 00332 02 SS-NUMBER-0415 PIC 9(9). 00333 02 START-DATE-0415. 00334 03 START-YEAR-0415 PIC 9(4). 00335 03 START-MONTH-0415 PIC 9(2). 00336 03 START-DAY-0415 PIC 9(2). 00337 02 TERMINATION-DATE-0415. 00338 03 TERMINATION-YEAR-0415 PIC 9(4). 00339 03 TERMINATION-MONTH-0415 PIC 9(2). 00340 03 TERMINATION-DAY-0415 PIC 9(2). 00341 02 BIRTH-DATE-0415. 00342 03 BIRTH-YEAR-0415 PIC 9(4). 00343 03 BIRTH-MONTH-0415 PIC 9(2). 00344 03 BIRTH-DAY-0415 PIC 9(2). 00345 00346 *01 COPY IDMS RECORD DEPARTMENT. 00347 01 DEPARTMENT. 00348 02 DEPT-ID-0410 PIC 9(4). 00349 02 DEPT-NAME-0410 PIC X(45). 00350 02 DEPT-HEAD-ID-0410 PIC 9(4). 00351 02 FILLER PIC XXX. 00352 00353 *01 COPY IDMS RECORD JOB. 00354 01 JOB. 00355 02 JOB-ID-0440 PIC 9(4). 00356 02 TITLE-0440 PIC X(20). 00357 02 DESCRIPTION-0440. 00358 03 DESCRIPTION-LINE-0440 PIC X(60) 00359 OCCURS 2. 00360 02 REQUIREMENTS-0440. 00361 03 REQUIREMENT-LINE-0440 PIC X(60) 00362 OCCURS 2. 00363 02 MINIMUM-SALARY-0440 PIC S9(6)V99. 00364 02 MAXIMUM-SALARY-0440 PIC S9(6)V99. 00365 02 SALARY-GRADES-0440 PIC 9(2) 00366 OCCURS 4. 00367 02 NUMBER-OF-POSITIONS-0440 00368 PIC 9(3). 00369 02 NUMBER-OPEN-0440 PIC 9(3). 00370 02 FILLER PIC XX. 00371 00372 *01 COPY IDMS RECORD EMPOSITION. 00373 01 EMPOSITION. 00374 02 START-DATE-0420. 00375 03 START-YEAR-0420 PIC 9(4). 00376 03 START-MONTH-0420 PIC 9(2). 00377 03 START-DAY-0420 PIC 9(2). 00378 02 FINISH-DATE-0420. 00379 03 FINISH-YEAR-0420 PIC 9(4). 00380 03 FINISH-MONTH-0420 PIC 9(2). 00381 03 FINISH-DAY-0420 PIC 9(2). 00382 02 SALARY-GRADE-0420 PIC 9(2). 00383 02 SALARY-AMOUNT-0420 PIC S9(7)V99 COMP-3. 00384 02 BONUS-PERCENT-0420 PIC SV999 COMP-3. 00385 02 COMMISSION-PERCENT-0420 PIC SV999 COMP-3. 00386 02 OVERTIME-RATE-0420 PIC S9V99 COMP-3. 00387 02 FILLER PIC XXX. 00388 00389 *01 COPY IDMS RECORD OFFICE. 00390 01 OFFICE. 00391 02 OFFICE-CODE-0450 PIC X(3). 00392 02 OFFICE-ADDRESS-0450. 00393 03 OFFICE-STREET-0450 PIC X(20). 00394 03 OFFICE-CITY-0450 PIC X(15). 00395 03 OFFICE-STATE-0450 PIC X(2). 00396 03 OFFICE-ZIP-0450. 00397 04 OFFICE-ZIP-FIRST-FIVE-0450 00398 PIC X(5). 00399 04 OFFICE-ZIP-LAST-FOUR-0450 00400 PIC X(4). 00401 02 OFFICE-PHONE-0450 PIC 9(7) 00402 OCCURS 3. 00403 02 OFFICE-AREA-CODE-0450 PIC X(3). 00404 02 SPEED-DIAL-0450 PIC X(3). 00405 02 FILLER PIC X(4). 00406 PROCEDURE DIVISION. 00407 00408 * ********************************************************* 00409 * * PROCEDURE DIVISION GENERAL STRATEGY: * 00410 * * 1) READ DEPT-ID-IN, WHICH CONTAINS THE * 00411 * * DEPT-ID NUMBER * 00412 * * 2) ACCESS THE DATABASE USING THE DEPT-ID NUMBER * 00413 * * WITH AN OBTAIN CALC ON THE DEPARTMENT RECORD * 00414 * * 3) ACCESS ALL EMPLOYEES IN THE DEPT-EMPLOYEE SET * 00415 * * AND RETRIEVE RELATED JOB AND OFFICE DATA * 00416 * * 4) PRINT A REPORT FOR EACH DEPARTMENT * 00417 * * 5) PRINT AN ERROR REPORT FOR EMPTY DEPARTMENTS * 00418 * * AND NONEXISTENT DEPARTMENTS (NO MATCHING * 00419 * * DEPT-ID) * 00420 * ********************************************************* 00421 00422 MAIN-LINE. 00423 PERFORM INIT-FILES. 00424 IF END-OF-FILE 00425 PERFORM EMPTY-INPUT-PROCESSING 00426 ELSE 00427 PERFORM INIT-BIND-READY 00428 PERFORM U220-ERR-HEADER 00429 PERFORM DEPT-PROCESSING THRU DEPT-PROCESSING-EXIT 00430 UNTIL END-OF-FILE. 00431 PERFORM END-PROCESSING. 00432 GOBACK. 00433 00434 INIT-BIND-READY. 00435 *************************************************************** 00436 * THE BIND STATEMENTS ARE PERFORMED INDIVIDUALLY (RATHER * 00437 * THAN BY USING A COPY IDMS SUBSCHEMA-BINDS) IN ORDER TO * 00438 * CHECK EACH ERROR-STATUS BY PERFORMING THE IDMS-STATUS * 00439 * ROUTINE. * 00440 *************************************************************** 00441 MOVE 'DEPTRPT' TO PROGRAM-NAME. 00442 * BIND RUN-UNIT. DMLC0001 00443 MOVE 1 TO DML-SEQUENCE 00444 CALL 'IDMS' USING SUBSCHEMA-CTRL 00445 IDBMSCOM (59) 00446 SUBSCHEMA-CTRL 00447 SUBSCHEMA-SSNAME. 00448 PERFORM IDMS-STATUS. 00449 * BIND EMPLOYEE. DMLC0002 00450 MOVE 2 TO DML-SEQUENCE 00451 CALL 'IDMS' USING SUBSCHEMA-CTRL 00452 IDBMSCOM (48) 00453 SR415 00454 EMPLOYEE. 00455 PERFORM IDMS-STATUS. 00456 * BIND DEPARTMENT. DMLC0003 00457 MOVE 3 TO DML-SEQUENCE 00458 CALL 'IDMS' USING SUBSCHEMA-CTRL 00459 IDBMSCOM (48) 00460 SR410 00461 DEPARTMENT. 00462 PERFORM IDMS-STATUS. 00463 * BIND JOB. DMLC0004 00464 MOVE 4 TO DML-SEQUENCE 00465 CALL 'IDMS' USING SUBSCHEMA-CTRL 00466 IDBMSCOM (48) 00467 SR440 00468 JOB. 00469 PERFORM IDMS-STATUS. 00470 * BIND EMPOSITION. DMLC0005 00471 MOVE 5 TO DML-SEQUENCE 00472 CALL 'IDMS' USING SUBSCHEMA-CTRL 00473 IDBMSCOM (48) 00474 SR420 00475 EMPOSITION. 00476 PERFORM IDMS-STATUS. 00477 * BIND OFFICE. DMLC0006 00478 MOVE 6 TO DML-SEQUENCE 00479 CALL 'IDMS' USING SUBSCHEMA-CTRL 00480 IDBMSCOM (48) 00481 SR450 00482 OFFICE. 00483 PERFORM IDMS-STATUS. 00484 * READY. DMLC0007 00485 MOVE 7 TO DML-SEQUENCE 00486 CALL 'IDMS' USING SUBSCHEMA-CTRL 00487 IDBMSCOM (37). 00488 PERFORM IDMS-STATUS. 00489 00490 INIT-FILES. 00491 OPEN INPUT DEPT-FILE-IN. 00492 OPEN OUTPUT DEPT-FILE-OUT. 00493 OPEN OUTPUT ERR-FILE-OUT. 00494 MOVE SPACES TO PRINT-LINE. 00495 MOVE SPACES TO ERR-LINE. 00496 READ DEPT-FILE-IN AT END MOVE 'Y' TO EOF-SW. 00497 00498 EMPTY-INPUT-PROCESSING. 00499 MOVE NO-INPUT-MESSAGE TO PRINT-LINE. 00500 MOVE '1' TO CC. 00501 PERFORM U000-WRITE-LINE. 00502 00503 *************************************************************** 00504 * THIS PARAGRAPH ACCESSES THE DATABASE USING THE DEPT-ID-0415 * 00505 * CALCKEY VALUE. * 00506 *************************************************************** 00507 DEPT-PROCESSING. 00508 MOVE DEPT-ID-IN TO DEPT-ID-0410. 00509 * OBTAIN CALC DEPARTMENT. DMLC0008 00510 MOVE 8 TO DML-SEQUENCE 00511 CALL 'IDMS' USING SUBSCHEMA-CTRL 00512 IDBMSCOM (32) 00513 SR410 00514 IDBMSCOM (43). 00515 IF DB-REC-NOT-FOUND THEN 00516 PERFORM NO-DEPT-PROCESSING 00517 ELSE 00518 PERFORM IDMS-STATUS 00519 * IF DEPT-EMPLOYEE IS NOT EMPTY DMLC0009 00520 MOVE 9 TO DML-SEQUENCE 00521 CALL 'IDMS' USING SUBSCHEMA-CTRL 00522 IDBMSCOM (65) 00523 DEPT-EMPLOYEE; 00524 IF ERROR-STATUS EQUAL TO '1601' 00525 THEN 00526 PERFORM U020-VALID-HEADER 00527 MOVE DEPT-ID-0410 TO DEPT-ID-OUT 00528 MOVE DEPT-NAME-0410 TO DEPT-NAME-OUT 00529 MOVE DEPT-DETAIL-LINE TO PRINT-LINE 00530 PERFORM U000-WRITE-LINE 00531 PERFORM U030-EMP-HEADERS 00532 PERFORM SET-WALK THRU SET-WALK-EXIT 00533 UNTIL DB-END-OF-SET 00534 ELSE 00535 PERFORM EMPTY-SET. 00536 READ DEPT-FILE-IN AT END MOVE 'Y' TO EOF-SW. 00537 DEPT-PROCESSING-EXIT. 00538 EXIT. 00539 00540 *************************************************************** 00541 * THIS PARAGRAPH RETRIEVES EMPLOYEE, JOB, AND OFFICE DATA * 00542 * FOR EACH EMPLOYEE IN THE DEPT-EMPLOYEE SET. * 00543 *************************************************************** 00544 SET-WALK. 00545 * OBTAIN NEXT EMPLOYEE WITHIN DEPT-EMPLOYEE. DMLC0010 00546 MOVE 10 TO DML-SEQUENCE 00547 CALL 'IDMS' USING SUBSCHEMA-CTRL 00548 IDBMSCOM (10) 00549 SR415 00550 DEPT-EMPLOYEE 00551 IDBMSCOM (43). 00552 IF DB-END-OF-SET 00553 GO TO SET-WALK-EXIT 00554 ELSE 00555 PERFORM IDMS-STATUS. 00556 MOVE EMP-ID-0415 TO ID-OUT. 00557 MOVE EMP-LAST-NAME-0415 TO LAST-OUT. 00558 MOVE EMP-FIRST-NAME-0415 TO FIRST-OUT. 00559 MOVE START-YEAR-0415 TO SD-YY. 00560 MOVE START-MONTH-0415 TO SD-MM. 00561 MOVE START-DAY-0415 TO SD-DD. 00562 * IF EMP-EMPOSITION IS EMPTY DMLC0011 00563 MOVE 11 TO DML-SEQUENCE 00564 CALL 'IDMS' USING SUBSCHEMA-CTRL 00565 IDBMSCOM (64) 00566 EMP-EMPOSITION; 00567 IF ERROR-STATUS EQUAL TO '0000' 00568 MOVE NO-JOB-MESSAGE TO TITLE-OUT 00569 ELSE 00570 * FIND FIRST WITHIN EMP-EMPOSITION DMLC0012 00571 MOVE 12 TO DML-SEQUENCE 00572 CALL 'IDMS' USING SUBSCHEMA-CTRL 00573 IDBMSCOM (20) 00574 EMP-EMPOSITION; 00575 PERFORM IDMS-STATUS 00576 * IF NOT JOB-EMPOSITION MEMBER DMLC0013 00577 MOVE 13 TO DML-SEQUENCE 00578 CALL 'IDMS' USING SUBSCHEMA-CTRL 00579 IDBMSCOM (62) 00580 JOB-EMPOSITION; 00581 IF ERROR-STATUS EQUAL TO '1601' 00582 MOVE NO-JOB-MESSAGE TO TITLE-OUT 00583 ELSE 00584 * OBTAIN OWNER WITHIN JOB-EMPOSITION DMLC0014 00585 MOVE 14 TO DML-SEQUENCE 00586 CALL 'IDMS' USING SUBSCHEMA-CTRL 00587 IDBMSCOM (31) 00588 JOB-EMPOSITION 00589 IDBMSCOM (43); 00590 PERFORM IDMS-STATUS 00591 MOVE TITLE-0440 TO TITLE-OUT. 00592 * IF OFFICE-EMPLOYEE IS EMPTY DMLC0015 00593 MOVE 15 TO DML-SEQUENCE 00594 CALL 'IDMS' USING SUBSCHEMA-CTRL 00595 IDBMSCOM (64) 00596 OFFICE-EMPLOYEE; 00597 IF ERROR-STATUS EQUAL TO '0000' 00598 MOVE NO-OFFICE-MESSAGE TO STREET-OUT 00599 MOVE SPACES TO CITY-OUT 00600 MOVE SPACES TO STATE-OUT 00601 MOVE SPACES TO ZIP-OUT 00602 ELSE 00603 * OBTAIN OWNER WITHIN OFFICE-EMPLOYEE DMLC0016 00604 MOVE 16 TO DML-SEQUENCE 00605 CALL 'IDMS' USING SUBSCHEMA-CTRL 00609 IDBMSCOM (31) 00607 OFFICE-EMPLOYEE 00608 IDBMSCOM (43); 00609 PERFORM IDMS-STATUS 00610 MOVE OFFICE-STREET-0450 TO STREET-OUT 00611 MOVE OFFICE-CITY-0450 TO CITY-OUT 00612 MOVE OFFICE-STATE-0450 TO STATE-OUT 00613 MOVE OFFICE-ZIP-FIRST-FIVE-0450 TO ZIP-OUT 00614 MOVE EMP-DETAIL-LINE TO PRINT-LINE. 00615 PERFORM U000-WRITE-LINE. 00616 SET-WALK-EXIT. 00617 EXIT. 00618 00619 END-PROCESSING. 00620 * FINISH. DMLC0017 00621 MOVE 17 TO DML-SEQUENCE 00622 CALL 'IDMS' USING SUBSCHEMA-CTRL 00623 IDBMSCOM (2). 00624 PERFORM IDMS-STATUS. 00625 CLOSE DEPT-FILE-OUT. 00626 CLOSE ERR-FILE-OUT. 00627 CLOSE DEPT-FILE-IN. 00628 00629 EMPTY-SET. 00630 MOVE SPACES TO ERR-LINE. 00631 MOVE DEPT-ID-0410 TO ERR-ID-OUT. 00632 MOVE NO-EMP-MESSAGE TO ERR-MESS-OUT. 00633 MOVE ERR-DETAIL-LINE TO ERR-LINE. 00634 PERFORM U200-WRITE-ERR-LINE. 00635 00636 NO-DEPT-PROCESSING. 00637 MOVE DEPT-ID-IN TO ERR-ID-OUT. 00638 MOVE NO-DEPT-MESSAGE TO ERR-MESS-OUT. 00639 MOVE ERR-DETAIL-LINE TO ERR-LINE. 00640 PERFORM U200-WRITE-ERR-LINE. 00641 00642 U000-WRITE-LINE. 00643 WRITE DEPT-REC-OUT AFTER POSITIONING CC. 00644 IF CC = '1' THEN MOVE 0 TO LINE-COUNT 00645 ELSE IF CC = ' ' THEN ADD 1 TO LINE-COUNT 00646 ELSE IF CC = '0' THEN ADD 2 TO LINE-COUNT. 00647 IF LINE-COUNT > LINE-MAX 00648 THEN PERFORM U010-NEW-PAGE-ROUTINE. 00649 U010-NEW-PAGE-ROUTINE. 00650 PERFORM U020-VALID-HEADER. 00651 MOVE DEPT-DETAIL-LINE TO PRINT-LINE. 00652 PERFORM U000-WRITE-LINE. 00653 PERFORM U030-EMP-HEADERS. 00654 U020-VALID-HEADER. 00655 MOVE DEPT-HEADER TO PRINT-LINE. 00656 MOVE '1' TO CC. 00657 PERFORM U000-WRITE-LINE 00658 MOVE ' ' TO CC. 00659 U030-EMP-HEADERS. 00660 MOVE '0' TO CC. 00661 MOVE EMP-HEADER TO PRINT-LINE. 00662 PERFORM U000-WRITE-LINE. 00663 MOVE SPACES TO PRINT-LINE. 00664 MOVE ' ' TO CC. 00665 PERFORM U000-WRITE-LINE. 00666 00667 U200-WRITE-ERR-LINE. 00668 WRITE ERR-REC-OUT AFTER POSITIONING ERR-CC. 00669 IF ERR-CC = '1' THEN MOVE 0 TO ERR-LINE-COUNT 00670 ELSE IF ERR-CC = ' ' THEN ADD 1 TO ERR-LINE-COUNT 00671 ELSE IF ERR-CC = '0' THEN ADD 2 TO ERR-LINE-COUNT. 00672 IF ERR-LINE-COUNT > LINE-MAX THEN 00673 PERFORM U220-ERR-HEADER. 00674 U220-ERR-HEADER. 00675 MOVE ERR-HEADER-1 TO ERR-LINE. 00676 MOVE '1' TO ERR-CC. 00677 PERFORM U200-WRITE-ERR-LINE 00678 MOVE '0' TO ERR-CC. 00679 MOVE ERR-HEADER-2 TO ERR-LINE. 00680 PERFORM U200-WRITE-ERR-LINE. 00681 MOVE ERR-HEADER-3 TO ERR-LINE. 00682 PERFORM U200-WRITE-ERR-LINE. 00683 MOVE SPACES TO ERR-LINE. 00684 MOVE ' ' TO ERR-CC. 00685 PERFORM U200-WRITE-ERR-LINE. 00686 IDMS-ABORT. 00687 EXIT. 00688 IDMS-ABORT-EXIT. 00689 * COPY IDMS IDMS-STATUS. 00690 ****************************************************************** 00691 IDMS-STATUS SECTION. 00692 ****************************************************************** 00693 IDMS-STATUS-PARAGRAPH. 00694 IF DB-STATUS-OK GO TO ISABEX. 00695 PERFORM IDMS-ABORT. 00696 DISPLAY '**************************' 00697 ' ABORTING - ' PROGRAM-NAME 00698 ', ' ERROR-STATUS 00699 ', ' ERROR-RECORD 00700 ' **** RECOVER IDMS ****' 00701 UPON CONSOLE. 00702 DISPLAY 'PROGRAM NAME ------ ' PROGRAM-NAME. 00703 DISPLAY 'ERROR STATUS ------ ' ERROR-STATUS. 00704 DISPLAY 'ERROR RECORD ------ ' ERROR-RECORD. 00705 DISPLAY 'ERROR SET --------- ' ERROR-SET. 00706 DISPLAY 'ERROR AREA -------- ' ERROR-AREA. 00707 DISPLAY 'LAST GOOD RECORD -- ' RECORD-NAME. 00708 DISPLAY 'LAST GOOD AREA ---- ' AREA-NAME. 00709 MOVE 39 TO SSC-IN01-REQ-CODE. 00710 MOVE 0 TO SSC-IN01-REQ-RETURN. 00711 MOVE ' ' TO SSC-STATUS-LABEL. 00712 PERFORM IDMS-STATUS-LOOP 00713 UNTIL SSC-IN01-REQ-RETURN > 0. 00714 * ROLLBACK. DMLC0018 00715 MOVE 18 TO DML-SEQUENCE 00716 CALL 'IDMS' USING SUBSCHEMA-CTRL 00717 IDBMSCOM (67). 00718 CALL 'ABORT'. 00719 GO TO ISABEX. 00720 IDMS-STATUS-LOOP. 00721 CALL 'IDMSIN1' USING IDBMSCOM(41) 00722 SSC-IN01-REQ-WK 00723 SUBSCHEMA-CTRL 00724 IDBMSCOM(1) 00725 DML-SEQUENCE 00726 SSC-STATUS-LINE. 00727 IF SSC-IN01-REQ-RETURN GREATER THAN 4 00728 DISPLAY 'DML SEQUENCE ------ ' DML-SEQUENCE 00729 ELSE 00730 DISPLAY SSC-STATUS-LABEL '--- ' SSC-STATUS-VALUE. 00731 ISABEX. EXIT.
|
Copyright © 2014 CA.
All rights reserved.
|
|