This is the output of a "great coder" rather than a "great programmer". When this was written (~1978), the shop paid for computer usage by the byte-second. Features such as hex literals, "SELECT OPTIONAL", four dimensional tables, and "EVALUATE" were not then part of the language. I have replaced the multipunched, five digit, COMP-3 zero with a hex literal since the x'0c' in the final byte might cause a form feed. This program was written in-house for a state agency and as such is a matter of public record. 00001 ID DIVISION. 00002 PROGRAM-ID. HDPER882. 00003 AUTHOR. WARREN PORTER, CDP. 00004 *REMARKS. 00005 * PRINTS THE MINORITY REPORT EITHER STATEWIDE OR BROKEN DOWN 00006 * BY DISTRICT. A PARM OF "STATE" PRINTS THE STATEWIDE 00007 * SUMMARY ONLY. INPUT TAPE MUST BE SORTED BY DISTRICT, BUT 00008 * NO OTHER SORT IS NECESSARY. MULTIPUNCHED PACKED ZEROS ARE 00009 * USED TO INTITLIZE TOTALING TABLES. 00010 * TOTALS ARE BROKEN DOWN BY SEX, MINORITY STATUS,SALARY, 00011 * AND TYPE JOB. 00012 * A RUN-TIME HEAD MAY BE READ IN UNDER THE //READER DD * 00013 * STATEMENT. READER IS AN OPTIONAL DD STATEMENT AND NEED 00014 * NOT BE DUMMIED IF NOT USED. 00015 ENVIRONMENT DIVISION. 00016 CONFIGURATION SECTION. 00017 OBJECT-COMPUTER. IBM-370-155. 00018 INPUT-OUTPUT SECTION. 00019 FILE-CONTROL. 00020 SELECT IN-FLE 00021 ASSIGN TO UT-S-TAPEI. 00022 SELECT OT-FLE 00023 ASSIGN TO UT-S-PRINTER. 00024 SELECT CI-FLE 00025 ASSIGN TO UT-S-READER. 00026 DATA DIVISION. 00027 FILE SECTION. 00028 FD IN-FLE 00029 RECORDING MODE F 00030 LABEL RECORDS OMITTED 00031 BLOCK CONTAINS 0 RECORDS. 00032 01 IN-REC. 00033 02 FILLER PIC X(09). 00034 02 F-DIST PIC XX. 00035 02 EMP PIC 9(6). 00036 02 EMP-NAME PIC X(22). 00037 02 FILLER PIC X(43). 00038 02 STAT PIC X. 00039 02 SAL PIC 9999V99. 00040 02 FILLER PIC X(116). 00041 02 FILLER PIC X. 00042 88 RESIGND VALUE '9'. 00043 02 FILLER PIC X(206). 00044 02 JOB-CD PIC 9(4). 00045 02 MINR PIC 9. 00046 02 FILLER PIC X(8). 00047 02 SEX PIC 9. 00048 02 FILLER PIC X(8). 00049 02 HIRE-DTE PIC 9(6). 00050 02 FILLER PIC X(233). 00051 02 JOB-TITLE PIC X(19). 00052 02 FILLER PIC X(8). 00053 02 FIL PIC X(800). 00054 FD OT-FLE 00055 RECORDING MODE F 00056 LABEL RECORDS OMITTED. 00057 01 PRINT-REC PIC X(133). 00058 FD CI-FLE 00059 RECORDING MODE F 00060 LABEL RECORDS ARE OMITTED. 00061 01 CI-REC PIC X(80). 00062 WORKING-STORAGE SECTION. 00063 77 J PIC S999 COMP-3. 00064 77 T-TYPE PIC S9 COMP-3. 00065 77 T-PAY PIC S9 COMP-3. 00066 77 SAL-1 PIC S9(5) COMP-3. 00067 77 W-M PIC S9(5) COMP-3 VALUE ZERO. 00068 77 W-F PIC S9(5) COMP-3 VALUE ZERO. 00069 77 B-M PIC S9(5) COMP-3 VALUE ZERO. 00070 77 B-F PIC S9(5) COMP-3 VALUE ZERO. 00071 77 L-TOT PIC S9(5) COMP-3 VALUE ZERO. 00072 77 FW-M PIC S9(5) COMP-3 VALUE ZERO. 00073 77 FW-F PIC S9(5) COMP-3 VALUE ZERO. 00074 77 FB-M PIC S9(5) COMP-3 VALUE ZERO. 00075 77 FB-F PIC S9(5) COMP-3 VALUE ZERO. 00076 77 K SYNC PIC S9(4) COMP. 00077 77 L SYNC PIC S9(4) COMP. 00078 77 CAR-CON PIC X. 00079 77 RUN-CNT PIC 9 VALUE ZERO. 00080 77 KEEP-DIST PIC XX. 00081 01 DUMMY-1 PIC X(864) VALUE ALL X'00000C'. 00082 01 FILLER REDEFINES DUMMY-1. 00083 02 CNT-1 OCCURS 288 INDEXED BY 00084 X1 PIC S9(5) COMP-3. 00085 01 DUMMY-2 PIC X(108) VALUE ALL X'00000C'. 00086 01 FILLER REDEFINES DUMMY-2. 00087 02 CNT-2 OCCURS 36 INDEXED BY 00088 X2 PIC S9(5) COMP-3. 00089 01 HEAD-0. 00090 02 FILLER PIC X. 00091 02 FILLER PIC X(20) VALUE SPACE. 00092 02 PR-TYPE PIC X(4). 00093 02 FILLER PIC X(5) VALUE ' TIME'. 00094 02 FILLER PIC X(9) VALUE SPACE. 00095 02 FILLER PIC X(8) VALUE 'HDPER882'. 00096 02 FILLER PIC X(13) VALUE SPACE. 00097 02 H0-WHERE-AT. 00098 03 D-HEAD PIC X(9) VALUE 'STATEWIDE'. 00099 03 H-DIST PIC XX VALUE SPACE. 00100 02 FILLER PIC X(24) VALUE SPACE. 00101 02 H-DATE PIC X(8). 00102 01 HEAD-0A. 00103 02 FILLER PIC X(26) VALUE SPACE. 00104 02 HEAD-MESS. 00105 03 FILLER PIC X(6) VALUE SPACE. 00106 88 ACTONLY VALUE 'ACTIVE'. 00107 03 FILLER PIC X(74) VALUE SPACE. 00108 01 HEAD-1. 00109 02 FILLER PIC X(69) VALUE SPACE. 00110 02 FILLER PIC X(33) VALUE 'MALE FEMALE'. 00111 02 FILLER PIC X(18) VALUE ' TOTAL'. 00112 01 HEAD-2. 00113 02 FILLER PIC X(63) VALUE SPACE. 00114 02 FILLER PIC X(56) VALUE ALL 'WHITE MINORITY '. 00115 01 TYPE-TAB. 00116 02 FILLER PIC X(24) VALUE 'OFFICIALS/ADMINISTRATION'. 00117 02 FILLER PIC X(24) VALUE ' PROFESSIONALS'. 00118 02 FILLER PIC X(24) VALUE ' TECHNICIANS'. 00119 02 FILLER PIC X(24) VALUE ' PROTECTIVE SERVICE'. 00120 02 FILLER PIC X(24) VALUE ' PARA-PROFESSIONAL'. 00121 02 FILLER PIC X(24) VALUE ' OFFICE/CLERICAL'. 00122 02 FILLER PIC X(24) VALUE ' SKILLED CRAFT'. 00123 02 FILLER PIC X(24) VALUE ' SERVICE/MAINTENANCE'. 00124 02 FILLER PIC X(24) VALUE ' NON FULLTIME'. 00125 01 FILLER REDEFINES TYPE-TAB. 00126 02 TYPE-ENT OCCURS 9 PIC X(24). 00127 01 SAL-TAB PIC X(120) VALUE 00128 ' 100 - 7,999 8,000 - 11,99912,000 - 15,99916,000 - 19,9 00129 - '9920,000 - 24,99925,000 - 32,99933,000 - 42,99943,000 - 00130 - 'OVER'. 00131 01 FILLER REDEFINES SAL-TAB. 00132 02 SAL-ENT OCCURS 8 PIC X(15). 00133 01 DETAIL-1. 00134 02 TYPE-HEAD PIC X(40) JUST RIGHT. 00135 02 DET-1 PIC X VALUE SPACE. 00136 02 SAL-HEAD PIC X(15). 00137 02 FILLER PIC X(6) VALUE SPACE. 00138 02 PR-W-M PIC ZZZZ9. 00139 02 FILLER PIC X(5) VALUE SPACE. 00140 02 PR-B-M PIC ZZZZ9. 00141 02 FILLER PIC X(13) VALUE SPACE. 00142 02 PR-W-F PIC ZZZZ9. 00143 02 FILLER PIC X(5) VALUE SPACE. 00144 02 PR-B-F PIC ZZZZ9. 00145 02 FILLER PIC X(9) VALUE SPACE. 00146 02 PR-L-TOT PIC ZZZZ9. 00147 01 GRAND-TOTALS. 00148 02 FILLER PIC X(35) VALUE SPACE. 00149 02 FILLER PIC XX VALUE '**'. 00150 02 GT-HEAD PIC X(11). 00151 02 FILLER PIC X(10) VALUE ' SUMMARY**'. 00152 01 TOTAL-1. 00153 02 FILLER PIC X(58) VALUE '**TOTALS**' JUST RIGHT. 00154 01 SUBAREA. 00155 02 SUBNAME PIC X(8) VALUE 'HDGTJ19 '. 00156 02 LNKTIT PIC X(19). 00157 02 LNKBEG PIC 999. 00158 02 LNKEND PIC 999. 00159 02 LNKCLS PIC X. 00160 02 REDLNK REDEFINES LNKCLS PIC 9. 00161 LINKAGE SECTION. 00162 01 PARM. 00163 02 FILLER PIC XX. 00164 02 FILLER PIC X(5). 00165 88 STATE VALUE 'STATE'. 00166 PROCEDURE DIVISION USING PARM. 00167 OPEN INPUT IN-FLE OUTPUT OT-FLE. 00168 CALL 'CHECKADD' USING CI-FLE. 00169 IF RETURN-CODE > ZERO 00170 MOVE ZERO TO RETURN-CODE 00171 GO TO FIN-CI-FLE. 00172 OPEN INPUT CI-FLE. 00173 READ CI-FLE AT END 00174 GO TO END-CARD. 00175 MOVE CI-REC TO HEAD-MESS. 00176 END-CARD. 00177 CLOSE CI-FLE. 00178 FIN-CI-FLE. 00179 MOVE CURRENT-DATE TO H-DATE. 00180 IF STATE 00181 GO TO T-TOP. 00182 MOVE 'DISTRICT ' TO D-HEAD. 00183 READ IN-FLE AT END 00184 GO TO E-O-J. 00185 IF RESIGND AND ACTONLY GO TO FIN-CI-FLE. 00186 MOVE F-DIST TO H-DIST. 00187 GO TO AFT-READ. 00188 T-TOP. 00189 READ IN-FLE AT END 00190 GO TO GEN-REPORT. 00191 IF RESIGND AND ACTONLY GO TO T-TOP. 00192 IF NOT STATE 00193 IF H-DIST < F-DIST 00194 PERFORM GEN-REPORT 00195 MOVE F-DIST TO H-DIST 00196 MOVE ALL X'00000C' TO DUMMY-1 DUMMY-2. 00197 AFT-READ. 00198 CALL SUBNAME USING JOB-CD LNKTIT LNKBEG LNKEND LNKCLS. 00199 TRANSFORM LNKCLS CHARACTERS FROM 'ABCDEFGH' TO '12345678'. 00200 IF LNKCLS GREATER THAN '8' OR LESS THAN '1' 00201 DISPLAY F-DIST SPACE EMP SPACE EMP-NAME SPACE JOB-CD 00202 GO TO T-TOP. 00203 MOVE REDLNK TO T-TYPE. 00204 IF STAT = '3' 00205 GO TO ADD-PART. 00206 IF STAT = '1' 00207 COMPUTE SAL-1 = SAL * 12 00208 ELSE 00209 COMPUTE SAL-1 = SAL * 2087.143. 00210 IF SAL-1 < 8000 00211 MOVE 0 TO T-PAY 00212 GO TO SAL-CASE. 00213 IF SAL-1 < 12000 00214 MOVE 1 TO T-PAY 00215 GO TO SAL-CASE. 00216 IF SAL-1 < 16000 00217 MOVE 2 TO T-PAY 00218 GO TO SAL-CASE. 00219 IF SAL-1 < 20000 00220 MOVE 3 TO T-PAY 00221 GO TO SAL-CASE. 00222 IF SAL-1 < 25000 00223 MOVE 4 TO T-PAY 00224 GO TO SAL-CASE. 00225 IF SAL-1 < 33000 00226 MOVE 5 TO T-PAY 00227 GO TO SAL-CASE. 00228 IF SAL-1 < 43000 00229 MOVE 6 TO T-PAY 00230 GO TO SAL-CASE. 00231 MOVE 7 TO T-PAY. 00232 SAL-CASE. 00233 COMPUTE J = T-TYPE * 32 + T-PAY * 4 + SEX * 2 + 00234 MINR - 33. 00235 ADD 1 TO CNT-1 (J) 00236 GO TO T-TOP. 00237 ADD-PART. 00238 IF JOB-CD = '7123' 00239 MOVE 9 TO T-TYPE. 00240 COMPUTE J = T-TYPE * 4 + SEX * 2 + MINR - 5. 00241 ADD 1 TO CNT-2 (J). 00242 GO TO T-TOP. 00243 GEN-REPORT. 00244 SET X1 X2 TO 1. 00245 PERFORM FULL-TIME THRU F-T-X VARYING K FROM 1 00246 BY 1 UNTIL K > 8 AFTER L FROM 1 BY 1 UNTIL L 00247 > 8. 00248 MOVE TOTAL-1 TO DETAIL-1. 00249 PERFORM WRITE-TOTALS. 00250 MOVE W-M TO FW-M. 00251 MOVE W-F TO FW-F. 00252 MOVE B-M TO FB-M. 00253 MOVE B-F TO FB-F. 00254 MOVE ZERO TO W-M W-F B-M B-F. 00255 MOVE 'PART' TO PR-TYPE. 00256 MOVE '-' TO CAR-CON. 00257 MOVE SPACE TO SAL-HEAD. 00258 PERFORM HEADERS. 00259 PERFORM PART-TIME THRU P-T-X VARYING K FROM 1 00260 BY 1 UNTIL K > 9. 00261 MOVE TOTAL-1 TO DETAIL-1. 00262 PERFORM WRITE-TOTALS. 00263 ADD FW-M TO W-M. 00264 ADD FW-F TO W-F. 00265 ADD FB-M TO B-M. 00266 ADD FB-F TO B-F. 00267 MOVE H0-WHERE-AT TO GT-HEAD. 00268 MOVE GRAND-TOTALS TO DETAIL-1. 00269 PERFORM WRITE-TOTALS. 00270 MOVE ZERO TO W-M W-F B-M B-F. 00271 E-O-J. 00272 CLOSE IN-FLE OT-FLE. 00273 STOP RUN. 00274 FULL-TIME. 00275 IF L = 1 00276 MOVE '-' TO CAR-CON 00277 IF K = 1 OR 5 00278 MOVE 'FULL' TO PR-TYPE 00279 PERFORM HEADERS 00280 ELSE 00281 NEXT SENTENCE 00282 ELSE 00283 MOVE SPACE TO CAR-CON. 00284 MOVE SAL-ENT (L) TO SAL-HEAD. 00285 IF L = 4 00286 MOVE TYPE-ENT (K) TO TYPE-HEAD 00287 ELSE 00288 MOVE SPACE TO TYPE-HEAD. 00289 MOVE CNT-1 (X1) TO PR-W-M L-TOT 00290 ADD CNT-1 (X1) TO W-M. 00291 MOVE CNT-1 (X1 + 1) TO PR-B-M 00292 ADD CNT-1 (X1 + 1) TO B-M L-TOT. 00293 MOVE CNT-1 (X1 + 2) TO PR-W-F 00294 ADD CNT-1 (X1 + 2) TO W-F L-TOT. 00295 MOVE CNT-1 (X1 + 3) TO PR-B-F 00296 ADD CNT-1 (X1 + 3) TO B-F L-TOT. 00297 MOVE L-TOT TO PR-L-TOT. 00298 WRITE PRINT-REC FROM DETAIL-1 AFTER POSITIONING 00299 CAR-CON. 00300 SET X1 UP BY 4. 00301 F-T-X. 00302 EXIT. 00303 HEADERS. 00304 WRITE PRINT-REC FROM HEAD-0 AFTER POSITIONING 0. 00305 WRITE PRINT-REC FROM HEAD-0A AFTER POSITIONING 2. 00306 WRITE PRINT-REC FROM HEAD-1 AFTER POSITIONING 2. 00307 WRITE PRINT-REC FROM HEAD-2 AFTER POSITIONING 1. 00308 PART-TIME. 00309 MOVE TYPE-ENT (K) TO TYPE-HEAD. 00310 MOVE CNT-2 (X2) TO PR-W-M L-TOT 00311 ADD CNT-2 (X2) TO W-M. 00312 MOVE CNT-2 (X2 + 1) TO PR-B-M 00313 ADD CNT-2 (X2 + 1) TO B-M L-TOT. 00314 MOVE CNT-2 (X2 + 2) TO PR-W-F 00315 ADD CNT-2 (X2 + 2) TO W-F L-TOT. 00316 MOVE CNT-2 (X2 + 3) TO PR-B-F 00317 ADD CNT-2 (X2 + 3) TO B-F L-TOT. 00318 MOVE L-TOT TO PR-L-TOT. 00319 WRITE PRINT-REC FROM DETAIL-1 AFTER POSITIONING 00320 CAR-CON. 00321 MOVE SPACE TO CAR-CON. 00322 SET X2 UP BY 4. 00323 P-T-X. 00324 EXIT. 00325 WRITE-TOTALS. 00326 ADD W-M W-F B-M B-F GIVING PR-L-TOT. 00327 MOVE W-M TO PR-W-M 00328 MOVE W-F TO PR-W-F 00329 MOVE B-M TO PR-B-M 00330 MOVE B-F TO PR-B-F. 00331 WRITE PRINT-REC FROM DETAIL-1 AFTER POSITIONING 00332 3. 00333 IF RUN-CNT = ZERO MOVE H-DIST TO KEEP-DIST MOVE SPACE TO 00334 H-DIST EXHIBIT HEAD-0 MOVE KEEP-DIST TO H-DIST EXHIBIT 00335 SPACE EXHIBIT HEAD-0A EXHIBIT HEAD-1 EXHIBIT HEAD-2 00336 EXHIBIT SPACE MOVE 1 TO RUN-CNT. 00337 IF DET-1 = SPACE NEXT SENTENCE ELSE EXHIBIT DETAIL-1. 00338 MOVE SPACE TO DETAIL-1.