00001 IDENTIFICATION DIVISION. 07/10/00 00002 PROGRAM-ID. DTSBE761. DTSBE761 00003 AUTHOR. TRICOASTAL CONSULTING LTD. LV160 00004 DATE-WRITTEN. AUGUST 1994. DTSBE761 00005 DATE-COMPILED. DTSBE761 00006 DTSBE761 00007 ***** DTSBE761 00008 * DTSBE761 00009 * CALLING SEQUENCE: DTSBD400 CALLS DTSBE761 00010 * DTSBE761 WHICH UPDATES DTSIR901 DTSBE761 00011 * DTSBR901 PRODUCES THE REQUESTED DTSBE761 00012 * LABELS. DTSBE761 00013 * DTSBE761 00014 * FUNCTION: JOB SERVICE LABELS EXTRACT. DTSBE761 00015 * DTSBE761 00016 * DTSBE761 00017 * MODIFICATION LOG: DTSBE761 00018 * DTSBE761 00019 * 06/13/96 RECOMPILED TO INCORPORATE CHANGES TO DTSIR901. DTSBE761 00020 * REFERENCE RFP: #WARP II PROGRAMMER: MJA DTSBE761 00021 * DTSBE761 00022 * 03/02/99 MODIFIED TO MEET DUTAS PROGRAMMING SPECIFICATIONS DTSBE761 00023 * REFERENCE RFP: #XXX PROGRAMMER: DVS DTSBE761 00024 * DTSBE761 00025 * XX/XX/XX XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSBE761 00026 * XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSBE761 00027 * REFERENCE RFP: #XXX PROGRAMMER: XXX DTSBE761 00028 * DTSBE761 00029 * DTSBE761 00030 * DESCRIPTION: DTSBE761 00031 * DTSBE761 00032 * DTSBE761 00033 * INITIATION: DTSBE761 00034 * DTSBE761 00035 * SET LECM-MST-OPEN-READ-88 TO TRUE. DTSBE761 00036 * SET LECM-REF-OPEN-READ-88 TO TRUE. DTSBE761 00037 * DTSBE761 00038 * EDIT PARAMTERS (SEE 901R1). DTSBE761 00039 * DTSBE761 00040 * DTSBE761 00041 * PROCESSING: DTSBE761 00042 * DTSBE761 00043 * SEE PRINTED OUTPUTS DESCRIPTION AND LAYOUTS (901R1). DTSBE761 00044 * DTSBE761 00045 * DTSBE761 00046 * TERMINATION: DTSBE761 00047 * DTSBE761 00048 * NONE. DTSBE761 00049 * DTSBE761 00050 * DTSBE761 00051 * RECORDS READ: DTSBE761 00052 * DTSBE761 00053 * MASTER: DTSBE761 00054 * DTSBE761 00055 * NONE. DTSBE761 00056 * DTSBE761 00057 * DTSBE761 00058 * ALTERNATE INDEX: DTSBE761 00059 * DTSBE761 00060 * NONE. DTSBE761 00061 * DTSBE761 00062 * DTSBE761 00063 * REFERENCE: DTSBE761 00064 * DTSBE761 00065 * NONE. DTSBE761 00066 * DTSBE761 00067 * DTSBE761 00068 * RECORDS UPDATED: DTSBE761 00069 * DTSBE761 00070 * NONE. DTSBE761 00071 * DTSBE761 00072 * DTSBE761 00073 * REPORT RECORDS WRITTEN: DTSBE761 00074 * DTSBE761 00075 * R901 LABELS. DTSBE761 00076 * DTSBE761 00077 * DTSBE761 00078 * BATCH TRANSACTION COLLECTION RECORDS WRITTEN: DTSBE761 00079 * DTSBE761 00080 * NONE. DTSBE761 00081 * DTSBE761 00082 * DTSBE761 00083 * MODULES CALLED: DTSBE761 00084 * DTSBE761 00085 * DTSBU001 DATE CONVERSION/EDIT. DTSBE761 00086 * DTSBU111 ADDRESS LOOKUP. DTSBE761 00087 * DTSBU112 ADDRESS FORMATTING. DTSBE761 00088 * DTSBU910 MASTER FILE I/O. DTSBE761 00089 * DTSBU946 VARIABLE LENGTH RECORDS SEQUENTIAL OUTPUT 1. DTSBE761 00090 * DTSBE761 00091 * DTSBE761 00092 * VERMONT REFERENCE: DTSBE761 00093 * DTSBE761 00094 * NONE. DTSBE761 00095 * DTSBE761 00096 ***** DTSBE761 00097 DTSBE761 00098 ENVIRONMENT DIVISION. DTSBE761 00099 DTSBE761 00100 DATA DIVISION. DTSBE761 00101 DTSBE761 00102 WORKING-STORAGE SECTION. DTSBE761 001025 77 PAN-VALET PICTURE X(24) VALUE '160DTSBE761 07/10/00'. DTSBE761 00103 DTSBE761 00104 01 WRK-AREA. DTSBE761 00105 05 WRK-ABEND-CD PIC S9(04) COMP VALUE +761.DTSBE761 00106 DTSBE761 00107 05 WRK-MOD-NAME PIC X(08) VALUE 'DTSBE761'.DTSBE761 00108 DTSBE761 00109 05 ABEND-MSG PIC X(60). DTSBE761 00110 05 WRK-MQTR-CNT PIC 9(03) VALUE ZERO. DTSBE761 00111 DTSBE761 00112 05 WRK-EMP-NO PIC S9(07) COMP-3. DTSBE761 00113 05 WRK-EMP-NO1 PIC 9(07) VALUE ZEROES. DTSBE761 00114 05 WRK-EMPL-CNT PIC S9(04) COMP VALUE ZERO.DTSBE761 00115 05 WRK-MIN-EMP-CNT PIC S9(04) COMP VALUE +40. DTSBE761 00116 05 WRK-YRQ PIC X(04) VALUE ZERO. DTSBE761 00117 DTSBE761 00118 05 WRK-PARM-OCC-CNT PIC S9(04) COMP. DTSBE761 00119 05 WRK-EMPLOYER-CLASS PIC X(01) VALUE SPACES.DTSBE761 00120 88 WRK-CLASS-CHG-ONLY-88 VALUE 'C'. DTSBE761 00121 88 WRK-CLASS-RATED-88 VALUE 'R'. DTSBE761 00122 88 WRK-CLASS-SELF-INS-88 VALUE 'S'. DTSBE761 00123 88 WRK-CLASS-UNK-88 VALUE 'U'. DTSBE761 00124 88 WRK-CLASS-SUB-88 VALUE 'R' 'S'. DTSBE761 00125 05 WRK-GRP-REPORT-IND PIC X. DTSBE761 00126 88 WRK-ON-REQUEST-88 VALUE '1'. DTSBE761 00127 * 88 WRK-EMP-REG-A-88 VALUE '2'. DTSBE761 00128 * 88 WRK-LIAB-DETER-88 VALUE '3'. DTSBE761 00129 88 WRK-JOB-SERVICE-88 VALUE '4'. DTSBE761 00130 05 WRK-GRP-IND-CODE-IND PIC X. DTSBE761 00131 88 WRK-GRP-IND-CODE-OFF VALUE '0'. DTSBE761 00132 88 WRK-GRP-IND-CODE-NAICS-88 VALUE '1'. DTSBE761 00133 88 WRK-GRP-IND-CODE-SIC-88 VALUE '2'. DTSBE761 00134 88 WRK-GRP-IND-CODE-BOTH-88 VALUE '3'. DTSBE761 00135 05 WRK-VALID-IND-CODE-VALUE PIC X. DTSBE761 00136 88 WRK-PROCESS-DEFAULT-88 VALUE '0'. DTSBE761 00137 88 WRK-NAICS-ALL-NINES-88 VALUE '1'. DTSBE761 00138 88 WRK-SIC-ALL-NINES-88 VALUE '2'. DTSBE761 00139 05 WRK-JS-MIN-EMPL-IND PIC X. DTSBE761 00140 88 WRK-JS-EMPLOYER-MIN-88 VALUE 'Y'. DTSBE761 00141 05 WRK-PARM-NAICS-CODE. DTSBE761 00142 10 WRK-NAICS-CODE-S PIC X(06). DTSBE761 00143 10 WRK-NAICS-CODE-E PIC X(06). DTSBE761 00144 05 WRK-PARM-SIC-CODE. DTSBE761 00145 10 WRK-SIC-CODE-S PIC X(04). DTSBE761 00146 10 WRK-SIC-CODE-E PIC X(04). DTSBE761 00147 05 WRK-NAICS-JOB-CODE PIC X(06) VALUE SPACES. DTSBE761 00148 05 WRK-SIC-JOB-CODE. DTSBE761 00149 10 WRK-SIC-JOB-CODE-H PIC X(02) VALUE '00'. DTSBE761 00150 10 WRK-SIC-JOB-CODE-L PIC X(04) VALUE SPACES. DTSBE761 00151 05 WRK-R901-ADDRESS. DTSBE761 00152 10 WRK-ATTN-LINE PIC X(40). DTSBE761 00153 10 WRK-DELIV-LINE-1 PIC X(40). DTSBE761 00154 10 WRK-DELIV-LINE-2 PIC X(40). DTSBE761 00155 10 WRK-CITY PIC X(25). DTSBE761 00156 10 WRK-ST PIC X(02). DTSBE761 00157 10 WRK-ZIP PIC X(10). DTSBE761 00158 10 WRK-ADVANCED-BARCODE DTSBE761 00159 PIC X(14). DTSBE761 00160 DTSBE761 00161 05 WRK-LABEL-IND PIC X(01). DTSBE761 00162 EJECT DTSBE761 00163 01 L001-LINK-AREA. DTSBE761 00164 ++INCLUDE DTSIL001 DTSBE761 00165 EJECT DTSBE761 00166 01 L111-LINK-AREA. DTSBE761 00167 ++INCLUDE DTSIL111 DTSBE761 00168 EJECT DTSBE761 00169 01 L112-LINK-AREA. DTSBE761 00170 ++INCLUDE DTSIL112 DTSBE761 00171 EJECT DTSBE761 00172 01 L910-LINK-AREA. DTSBE761 00173 ++INCLUDE DTSIL910 DTSBE761 00174 DTSBE761 00175 01 MSKL-REC. DTSBE761 00176 ++INCLUDE DTSIMSKL DTSBE761 00177 EJECT DTSBE761 00178 01 MQTR-REC. DTSBE761 00179 ++INCLUDE DTSIMQTR DTSBE761 00180 EJECT DTSBE761 00181 01 MTAA-REC. DTSBE761 00182 ++INCLUDE DTSIMTAA DTSBE761 00183 EJECT DTSBE761 00184 01 MTAD-REC. DTSBE761 00185 ++INCLUDE DTSIMTAD DTSBE761 00186 EJECT DTSBE761 00187 01 R901-REC. DTSBE761 00188 ++INCLUDE DTSIR901 DTSBE761 00189 EJECT DTSBE761 00190 LINKAGE SECTION. DTSBE761 00191 DTSBE761 00192 01 LECM-LINK-AREA. DTSBE761 00193 ++INCLUDE DTSILECM DTSBE761 00194 DTSBE761 00195 10 FILLER REDEFINES LECM-EXTRACT-PARMS. DTSBE761 00196 15 LECM-PARM-JS-EXTRACT-TYPE PIC X. DTSBE761 00197 15 FILLER PIC X. DTSBE761 00198 15 LECM-PARM-EMPLR-CLASS PIC X. DTSBE761 00199 15 FILLER PIC X. DTSBE761 00200 15 LECM-PARM-INDUSTRY-SIC-CODE PIC X(08). DTSBE761 00201 15 FILLER PIC X. DTSBE761 00202 15 LECM-PARM-INDUSTRY-NAICS-CODE PIC X(12). DTSBE761 00203 15 FILLER PIC X. DTSBE761 00204 15 LECM-PARM-EMPLOYEE-MINIMUM PIC X(02). DTSBE761 00205 15 LECM-PARM-EMPLOYEE-MIN-N REDEFINES DTSBE761 00206 LECM-PARM-EMPLOYEE-MINIMUM PIC 9(02). DTSBE761 00207 15 FILLER PIC X(40). DTSBE761 00208 EJECT DTSBE761 00209 01 MPRF-LINK-REC. DTSBE761 00210 ++INCLUDE DTSIMPRF DTSBE761 00211 EJECT DTSBE761 00212 ************************************************************** DTSBE761 00213 * PROCEDURE DIVISION FOR DTSBE761 - JOB SERVICE LABELS DTSBE761 00214 * EXTRACT STARTS HERE. DTSBE761 00215 ************************************************************** DTSBE761 00216 DTSBE761 00217 PROCEDURE DIVISION USING LECM-LINK-AREA DTSBE761 00218 MPRF-LINK-REC. DTSBE761 00219 DTSBE761 00220 EVALUATE LECM-CALL-TYPE-IND DTSBE761 00221 WHEN 'P' DTSBE761 00222 PERFORM P0000-PROCESS DTSBE761 00223 THRU P0000-EXIT DTSBE761 00224 WHEN 'I' DTSBE761 00225 PERFORM I0000-INITIALIZE DTSBE761 00226 THRU I0000-EXIT DTSBE761 00227 WHEN 'T' DTSBE761 00228 PERFORM T0000-TERMINATE DTSBE761 00229 THRU T0000-EXIT DTSBE761 00230 WHEN OTHER DTSBE761 00231 MOVE 'INVALID LECM-CALL-TYPE-IND ENCOUNTERED' DTSBE761 00232 TO ABEND-MSG DTSBE761 00233 PERFORM S999-ABEND DTSBE761 00234 THRU S999-EXIT DTSBE761 00235 END-EVALUATE. DTSBE761 00236 DTSBE761 00237 GOBACK. DTSBE761 00238 EJECT DTSBE761 00239 ************************************************************** DTSBE761 00240 * THIS IS THE INITIALIZATION PARAGRAPH FOR DTSBE761. DTSBE761 00241 ************************************************************** DTSBE761 00242 DTSBE761 00243 I0000-INITIALIZE. DTSBE761 00244 DTSBE761 00245 MOVE LENGTH OF R901-REC TO R901-LENGTH. DTSBE761 00246 MOVE '901' TO R901-REC-TYPE. DTSBE761 00247 MOVE +0 TO R901-LABEL-CNT. DTSBE761 00248 PERFORM I1000-EDIT-AND-DEFAULT-PARMS DTSBE761 00249 THRU I1000-EXIT. DTSBE761 00250 MOVE LECM-TRACE-IND TO L910-TRACE-IND. DTSBE761 00251 MOVE WRK-MOD-NAME TO L910-MOD-NAME. DTSBE761 00252 SET LECM-MST-OPEN-READ-88 TO TRUE. DTSBE761 00253 SET LECM-REF-OPEN-READ-88 TO TRUE. DTSBE761 00254 DTSBE761 00255 I0000-EXIT. DTSBE761 00256 EXIT. DTSBE761 00257 DTSBE761 00258 DTSBE761 00259 I1000-EDIT-AND-DEFAULT-PARMS. DTSBE761 00260 DTSBE761 00261 PERFORM I1100-EXTRACT-TYPE DTSBE761 00262 THRU I1100-EXIT. DTSBE761 00263 DTSBE761 00264 PERFORM I1400-EMPLOYER-CLS DTSBE761 00265 THRU I1400-EXIT. DTSBE761 00266 DTSBE761 00267 I1000-EXIT. DTSBE761 00268 EXIT. DTSBE761 00269 DTSBE761 00270 DTSBE761 00271 I1100-EXTRACT-TYPE. DTSBE761 00272 IF LECM-PARM-JS-EXTRACT-TYPE = SPACES DTSBE761 00273 MOVE 'LECM-PARM-JS-EXTRACT-TYPE IS MISSING' DTSBE761 00274 TO ABEND-MSG DTSBE761 00275 PERFORM S999-ABEND DTSBE761 00276 THRU S999-EXIT DTSBE761 00277 ELSE DTSBE761 00278 IF LECM-PARM-JS-EXTRACT-TYPE NOT = '1' AND '4' DTSBE761 00279 MOVE 'LECM-PARM-JS-EXTRACT-TYPE IS NOT VALID ' DTSBE761 00280 TO ABEND-MSG DTSBE761 00281 PERFORM S999-ABEND DTSBE761 00282 THRU S999-EXIT. DTSBE761 00283 DTSBE761 00284 IF LECM-PARM-JS-EXTRACT-TYPE = '4' DTSBE761 00285 SET WRK-JOB-SERVICE-88 TO TRUE DTSBE761 00286 PERFORM I1200-INDUSTRY-CDE DTSBE761 00287 THRU I1200-EXIT DTSBE761 00288 PERFORM I1300-EMPLOYEE-MIN DTSBE761 00289 THRU I1300-EXIT DTSBE761 00290 ELSE DTSBE761 00291 SET WRK-ON-REQUEST-88 TO TRUE. DTSBE761 00292 DTSBE761 00293 DISPLAY 'J IND ' WRK-GRP-REPORT-IND. DTSBE761 00294 I1100-EXIT. DTSBE761 00295 EXIT. DTSBE761 00296 DTSBE761 00297 DTSBE761 00298 I1200-INDUSTRY-CDE. DTSBE761 00299 SET WRK-GRP-IND-CODE-OFF TO TRUE. DTSBE761 00300 DTSBE761 00301 IF LECM-PARM-INDUSTRY-NAICS-CODE > SPACES DTSBE761 00302 AND LECM-PARM-INDUSTRY-SIC-CODE > SPACES DTSBE761 00303 MOVE LECM-PARM-INDUSTRY-NAICS-CODE TO WRK-PARM-NAICS-CODEDTSBE761 00304 MOVE LECM-PARM-INDUSTRY-SIC-CODE TO WRK-PARM-SIC-CODE DTSBE761 00305 SET WRK-GRP-IND-CODE-BOTH-88 TO TRUE DTSBE761 00306 ELSE DTSBE761 00307 IF LECM-PARM-INDUSTRY-NAICS-CODE > SPACES DTSBE761 00308 MOVE LECM-PARM-INDUSTRY-NAICS-CODE DTSBE761 00309 TO WRK-PARM-NAICS-CODE DTSBE761 00310 SET WRK-GRP-IND-CODE-NAICS-88 TO TRUE DTSBE761 00311 ELSE DTSBE761 00312 IF LECM-PARM-INDUSTRY-SIC-CODE > SPACES DTSBE761 00313 MOVE LECM-PARM-INDUSTRY-SIC-CODE DTSBE761 00314 TO WRK-PARM-SIC-CODE DTSBE761 00315 SET WRK-GRP-IND-CODE-SIC-88 TO TRUE. DTSBE761 00316 DTSBE761 00317 PERFORM I1210-VALIDATE-CDE DTSBE761 00318 THRU I1210-EXIT. DTSBE761 00319 DTSBE761 00320 DISPLAY ' GROUP CODE ' WRK-GRP-IND-CODE-IND. DTSBE761 00321 I1200-EXIT. DTSBE761 00322 EXIT. DTSBE761 00323 DTSBE761 00324 I1210-VALIDATE-CDE. DTSBE761 00325 DTSBE761 00326 IF WRK-NAICS-CODE-S > SPACES DTSBE761 00327 AND WRK-NAICS-CODE-E > SPACES DTSBE761 00328 IF WRK-NAICS-CODE-S > WRK-NAICS-CODE-E DTSBE761 00329 MOVE 'LECM-PARM-INDUSTRY-NAICS-CODE RANGE INVALID ' DTSBE761 00330 TO ABEND-MSG DTSBE761 00331 PERFORM S999-ABEND DTSBE761 00332 THRU S999-EXIT DTSBE761 00333 ELSE DTSBE761 00334 NEXT SENTENCE DTSBE761 00335 ELSE DTSBE761 00336 MOVE WRK-NAICS-CODE-S TO WRK-NAICS-CODE-E. DTSBE761 00337 DTSBE761 00338 IF WRK-SIC-CODE-S > SPACES DTSBE761 00339 AND WRK-SIC-CODE-E > SPACES DTSBE761 00340 IF WRK-SIC-CODE-S > WRK-SIC-CODE-E DTSBE761 00341 MOVE 'LECM-PARM-INDUSTRY-SIC-CODE RANGE INVALID ' DTSBE761 00342 TO ABEND-MSG DTSBE761 00343 PERFORM S999-ABEND DTSBE761 00344 THRU S999-EXIT DTSBE761 00345 ELSE DTSBE761 00346 NEXT SENTENCE DTSBE761 00347 ELSE DTSBE761 00348 MOVE WRK-SIC-CODE-S TO WRK-SIC-CODE-E. DTSBE761 00349 DTSBE761 00350 I1210-EXIT. DTSBE761 00351 EXIT. DTSBE761 00352 DTSBE761 00353 DTSBE761 00354 I1300-EMPLOYEE-MIN. DTSBE761 00355 IF LECM-PARM-EMPLOYEE-MIN-N NOT NUMERIC DTSBE761 00356 MOVE 40 TO LECM-PARM-EMPLOYEE-MINIMUM. DTSBE761 00357 DTSBE761 00358 MOVE LECM-PARM-EMPLOYEE-MIN-N TO WRK-MIN-EMP-CNT. DTSBE761 00359 DTSBE761 00360 I1300-EXIT. DTSBE761 00361 EXIT. DTSBE761 00362 DTSBE761 00363 DTSBE761 00364 I1400-EMPLOYER-CLS. DTSBE761 00365 IF LECM-PARM-EMPLR-CLASS > SPACES DTSBE761 00366 EVALUATE LECM-PARM-EMPLR-CLASS DTSBE761 00367 WHEN 'C' DTSBE761 00368 SET WRK-CLASS-CHG-ONLY-88 TO TRUE DTSBE761 00369 WHEN 'R' DTSBE761 00370 SET WRK-CLASS-RATED-88 TO TRUE DTSBE761 00371 WHEN 'S' DTSBE761 00372 SET WRK-CLASS-SELF-INS-88 TO TRUE DTSBE761 00373 WHEN 'U' DTSBE761 00374 SET WRK-CLASS-UNK-88 TO TRUE DTSBE761 00375 WHEN OTHER DTSBE761 00376 SET WRK-CLASS-SUB-88 TO TRUE DTSBE761 00377 DISPLAY DTSBE761 00378 'LECM-PARM-EMPLR-CLASS INVALID - DEFAULT VALUE SET'DTSBE761 00379 END-EVALUATE DTSBE761 00380 ELSE DTSBE761 00381 SET WRK-CLASS-SUB-88 TO TRUE. DTSBE761 00382 DTSBE761 00383 I1400-EXIT. DTSBE761 00384 EXIT. DTSBE761 00385 EJECT DTSBE761 00386 ************************************************************** DTSBE761 00387 * THIS IS THE PROCESS PARAGRAPH FOR DTSBE761. DTSBE761 00388 ************************************************************** DTSBE761 00389 DTSBE761 00390 P0000-PROCESS. DTSBE761 00391 DTSBE761 00392 IF MPRF-STATUS-ACT-88 DTSBE761 00393 NEXT SENTENCE DTSBE761 00394 ELSE DTSBE761 00395 GO TO P0000-EXIT. DTSBE761 00396 DTSBE761 00397 IF MPRF-EMP-CLASS = WRK-EMPLOYER-CLASS DTSBE761 00398 NEXT SENTENCE DTSBE761 00399 ELSE DTSBE761 00400 GO TO P0000-EXIT. DTSBE761 00401 DTSBE761 00402 DTSBE761 00403 IF WRK-JOB-SERVICE-88 DTSBE761 00404 PERFORM P1000-JOB-SERVICE-PROCESSING DTSBE761 00405 THRU P1000-EXIT DTSBE761 00406 ELSE DTSBE761 00407 PERFORM P1100-DEFAULT-LABEL-PROCESS DTSBE761 00408 THRU P1100-EXIT. DTSBE761 00409 DTSBE761 00410 P0000-EXIT. DTSBE761 00411 EXIT. DTSBE761 00412 EJECT DTSBE761 00413 ************************************************************** DTSBE761 00414 * THIS PARAGRAPH SETS UP THE KEY FOR THE R901 EXTRACT RECORD. DTSBE761 00415 ************************************************************** DTSBE761 00416 P1000-JOB-SERVICE-PROCESSING. DTSBE761 00417 DTSBE761 00418 IF MPRF-NAICS-PRIV-HOUSEHOLDS-88 DTSBE761 00419 OR MPRF-SIC-PRIV-HOUSEHOLDS-88 DTSBE761 00420 GO TO P1000-EXIT. DTSBE761 00421 DTSBE761 00422 MOVE LOW-VALUES TO MSKL-KEY-AREA. DTSBE761 00423 DTSBE761 00424 MOVE MPRF-EMP-NO TO MSKL-EMP-NO. DTSBE761 00425 DTSBE761 00426 SET MSKL-QTR-88 TO TRUE. DTSBE761 00427 DTSBE761 00428 PERFORM S910-START-BROWSE DTSBE761 00429 THRU S910-EXIT. DTSBE761 00430 DTSBE761 00431 IF L910-NO-REC-88 DTSBE761 00432 GO TO P1000-EXIT DTSBE761 00433 ELSE DTSBE761 00434 ADD +1 TO WRK-MQTR-CNT DTSBE761 00435 MOVE ZERO TO WRK-EMPL-CNT DTSBE761 00436 PERFORM P1400-SCAN-MQTR DTSBE761 00437 THRU P1400-EXIT DTSBE761 00438 UNTIL L910-NO-REC-88. DTSBE761 00439 DTSBE761 00440 IF WRK-EMPL-CNT > WRK-MIN-EMP-CNT DTSBE761 00441 PERFORM P1010-VALIDATE-INDUSTRY-CDS DTSBE761 00442 THRU P1010-EXIT. DTSBE761 00443 P1000-EXIT. DTSBE761 00444 EXIT. DTSBE761 00445 ************************************************************** DTSBE761 00446 * THIS PARAGRAPH SETS UP THE NAICS OR SIC CODE VALUES DTSBE761 00447 ************************************************************** DTSBE761 00448 DTSBE761 00449 P1010-VALIDATE-INDUSTRY-CDS. DTSBE761 00450 MOVE SPACES TO WRK-VALID-IND-CODE-VALUE. DTSBE761 00451 DTSBE761 00452 IF WRK-GRP-IND-CODE-OFF DTSBE761 00453 PERFORM P1040-DEFAULT-CHECK DTSBE761 00454 THRU P1040-EXIT, DTSBE761 00455 DTSBE761 00456 IF WRK-GRP-IND-CODE-BOTH-88 DTSBE761 00457 OR WRK-GRP-IND-CODE-NAICS-88 DTSBE761 00458 PERFORM P1020-VALIDATE-NAICS-VALUE DTSBE761 00459 THRU P1020-EXIT. DTSBE761 00460 DTSBE761 00461 IF WRK-GRP-IND-CODE-SIC-88 DTSBE761 00462 PERFORM P1030-VALIDATE-SIC-VALUE DTSBE761 00463 THRU P1030-EXIT. DTSBE761 00464 DTSBE761 00465 IF WRK-PROCESS-DEFAULT-88 DTSBE761 00466 PERFORM P1100-DEFAULT-LABEL-PROCESS DTSBE761 00467 THRU P1100-EXIT. DTSBE761 00468 P1010-EXIT. DTSBE761 00469 EXIT. DTSBE761 00470 DTSBE761 00471 DTSBE761 00472 P1020-VALIDATE-NAICS-VALUE. DTSBE761 00473 DTSBE761 00474 IF MPRF-NAICS-CD-NONCLASSIF-88 DTSBE761 00475 SET WRK-NAICS-ALL-NINES-88 TO TRUE DTSBE761 00476 IF WRK-GRP-IND-CODE-BOTH-88 DTSBE761 00477 PERFORM P1030-VALIDATE-SIC-VALUE DTSBE761 00478 THRU P1030-EXIT DTSBE761 00479 ELSE DTSBE761 00480 GO TO P1020-EXIT. DTSBE761 00481 DTSBE761 00482 IF MPRF-NAICS-CD >= WRK-NAICS-CODE-S DTSBE761 00483 AND MPRF-NAICS-CD <= WRK-NAICS-CODE-E DTSBE761 00484 MOVE MPRF-NAICS-CD TO WRK-NAICS-JOB-CODE DTSBE761 00485 SET R901-GRP4-NAICS-88 TO TRUE DTSBE761 00486 SET WRK-PROCESS-DEFAULT-88 TO TRUE DTSBE761 00487 ELSE DTSBE761 00488 IF WRK-GRP-IND-CODE-BOTH-88 DTSBE761 00489 PERFORM P1030-VALIDATE-SIC-VALUE DTSBE761 00490 THRU P1030-EXIT. DTSBE761 00491 P1020-EXIT. DTSBE761 00492 EXIT. DTSBE761 00493 DTSBE761 00494 DTSBE761 00495 P1030-VALIDATE-SIC-VALUE. DTSBE761 00496 DTSBE761 00497 IF MPRF-SIC-CD-NONCLASSIF-88 DTSBE761 00498 SET WRK-SIC-ALL-NINES-88 TO TRUE DTSBE761 00499 GO TO P1030-EXIT. DTSBE761 00500 DTSBE761 00501 * DISPLAY 'EMP SIC ' MPRF-SIC-CD DTSBE761 00502 * DISPLAY 'WRK SIC ' WRK-SIC-CODE-S ' ' WRK-SIC-CODE-E DTSBE761 00503 * DISPLAY SPACE DTSBE761 00504 DTSBE761 00505 IF MPRF-SIC-CD >= WRK-SIC-CODE-S DTSBE761 00506 AND MPRF-SIC-CD <= WRK-SIC-CODE-E DTSBE761 00507 MOVE MPRF-SIC-CD TO WRK-SIC-JOB-CODE-L DTSBE761 00508 SET R901-GRP4-SIC-88 TO TRUE DTSBE761 00509 SET WRK-PROCESS-DEFAULT-88 TO TRUE. DTSBE761 00510 DTSBE761 00511 P1030-EXIT. DTSBE761 00512 EXIT. DTSBE761 00513 ************************************************************** DTSBE761 00514 * THIS PARAGRAPH WILL DEFAULT TO A NAICS CODE OR SIC CODE DTSBE761 00515 ************************************************************** DTSBE761 00516 P1040-DEFAULT-CHECK. DTSBE761 00517 DTSBE761 00518 SET WRK-PROCESS-DEFAULT-88 TO TRUE. DTSBE761 00519 DTSBE761 00520 IF MPRF-NAICS-CD-NONCLASSIF-88 DTSBE761 00521 NEXT SENTENCE DTSBE761 00522 ELSE DTSBE761 00523 MOVE MPRF-NAICS-CD TO WRK-NAICS-JOB-CODE DTSBE761 00524 SET R901-GRP4-NAICS-88 TO TRUE DTSBE761 00525 GO TO P1040-EXIT. DTSBE761 00526 DTSBE761 00527 MOVE MPRF-SIC-CD TO WRK-SIC-JOB-CODE-L. DTSBE761 00528 SET R901-GRP4-SIC-88 TO TRUE. DTSBE761 00529 DTSBE761 00530 P1040-EXIT. DTSBE761 00531 EXIT. DTSBE761 00532 EJECT DTSBE761 00533 P1100-DEFAULT-LABEL-PROCESS. DTSBE761 00534 DTSBE761 00535 PERFORM P2000-SETUP-R901-KEY DTSBE761 00536 THRU P2000-EXIT. DTSBE761 00537 PERFORM P3000-LOOKUP-ADDR DTSBE761 00538 THRU P3000-EXIT. DTSBE761 00539 DTSBE761 00540 IF WRK-ON-REQUEST-88 DTSBE761 00541 PERFORM S946-WRITE-R901 DTSBE761 00542 THRU S946-EXIT DTSBE761 00543 MOVE LOW-VALUES TO R901-SORT-VAR-AREA DTSBE761 00544 GO TO P1100-EXIT. DTSBE761 00545 DTSBE761 00546 IF L111-ADDR-FOUND-88 DTSBE761 00547 PERFORM P1200-VALIDATE-MAIL-CRITERIA DTSBE761 00548 THRU P1200-EXIT. DTSBE761 00549 DTSBE761 00550 P1100-EXIT. DTSBE761 00551 EXIT. DTSBE761 00552 ******************************************************************DTSBE761 00553 * THIS PARAGRAPH CHECKS THE MTAD RECD FOR A DISTRICT OF COLUMBIA DTSBE761 00554 * ADDRESS. IF ONE EXIST, WRITE THE MTAD LABEL OTHERWISE USE THE DTSBE761 00555 * TAX MAILING ADDRESS. DTSBE761 00556 ******************************************************************DTSBE761 00557 DTSBE761 00558 P1200-VALIDATE-MAIL-CRITERIA. DTSBE761 00559 DTSBE761 00560 SET R901-JOB-SERVICE-88 TO TRUE. DTSBE761 00561 DTSBE761 00562 IF L112-ST EQUAL 'DC' DTSBE761 00563 PERFORM S946-WRITE-R901 DTSBE761 00564 THRU S946-EXIT DTSBE761 00565 ELSE DTSBE761 00566 PERFORM P3110-LOOKUP-PHYS-ADDR DTSBE761 00567 THRU P3110-EXIT DTSBE761 00568 IF L111-ADDR-FOUND-88 DTSBE761 00569 PERFORM S946-WRITE-R901 DTSBE761 00570 THRU S946-EXIT. DTSBE761 00571 DTSBE761 00572 MOVE LOW-VALUES TO R901-SORT-VAR-AREA. DTSBE761 00573 DTSBE761 00574 P1200-EXIT. DTSBE761 00575 EXIT. DTSBE761 00576 ************************************************************** DTSBE761 00577 * THIS PARAGRAPH SETS UP THE KEY FOR THE MQTR EXTRACT DTSBE761 00578 * TO DETERMINE IF THE EMPLOYER HAS A MINIMUN NUMBER OF DTSBE761 00579 * EMPLOYEES WITHIN THE MOST RECENT QUARTER. DTSBE761 00580 ************************************************************** DTSBE761 00581 P1400-SCAN-MQTR. DTSBE761 00582 MOVE MSKL-REC TO MQTR-REC. DTSBE761 00583 DTSBE761 00584 IF MQTR-CURR-RCVD-88 DTSBE761 00585 MOVE MQTR-YRQ TO WRK-YRQ DTSBE761 00586 PERFORM P1500-EMPL-CNT DTSBE761 00587 THRU P1500-EXIT. DTSBE761 00588 DTSBE761 00589 PERFORM S910-READ-NEXT DTSBE761 00590 THRU S910-EXIT. DTSBE761 00591 DTSBE761 00592 P1400-EXIT. DTSBE761 00593 EXIT. DTSBE761 00594 P1500-EMPL-CNT. DTSBE761 00595 *** DISPLAY MQTR-YRQ ' ' MQTR-CURR-RPT-TYPE. DTSBE761 00596 *** DISPLAY MQTR-1ST-MTH-EMPL-CNT ' ' DTSBE761 00597 *** MQTR-2ND-MTH-EMPL-CNT ' ' DTSBE761 00598 *** MQTR-3RD-MTH-EMPL-CNT. DTSBE761 00599 DTSBE761 00600 IF MQTR-1ST-MTH-NO-ENTRY-88 DTSBE761 00601 NEXT SENTENCE DTSBE761 00602 ELSE DTSBE761 00603 MOVE MQTR-1ST-MTH-EMPL-CNT TO WRK-EMPL-CNT. DTSBE761 00604 DTSBE761 00605 IF MQTR-2ND-MTH-NO-ENTRY-88 DTSBE761 00606 NEXT SENTENCE DTSBE761 00607 ELSE DTSBE761 00608 IF MQTR-2ND-MTH-EMPL-CNT > WRK-EMPL-CNT DTSBE761 00609 MOVE MQTR-2ND-MTH-EMPL-CNT TO WRK-EMPL-CNT. DTSBE761 00610 DTSBE761 00611 IF MQTR-3RD-MTH-NO-ENTRY-88 DTSBE761 00612 NEXT SENTENCE DTSBE761 00613 ELSE DTSBE761 00614 IF MQTR-3RD-MTH-EMPL-CNT > WRK-EMPL-CNT DTSBE761 00615 MOVE MQTR-3RD-MTH-EMPL-CNT TO WRK-EMPL-CNT. DTSBE761 00616 P1500-EXIT. DTSBE761 00617 EXIT. DTSBE761 00618 DTSBE761 00619 ************************************************************** DTSBE761 00620 * THIS PARAGRAPH SETS UP THE KEY FOR THE R901 EXTRACT RECORD. DTSBE761 00621 ************************************************************** DTSBE761 00622 DTSBE761 00623 P2000-SETUP-R901-KEY. DTSBE761 00624 ADD +1 TO R901-LABEL-CNT. DTSBE761 00625 DTSBE761 00626 IF WRK-JOB-SERVICE-88 DTSBE761 00627 MOVE MPRF-PRIMARY-NAME TO R901-GRP4-PRIMARY-NAME DTSBE761 00628 MOVE MPRF-EMP-NO TO R901-GRP4-EMP-NO DTSBE761 00629 PERFORM P2100-SETUP-IND-CD DTSBE761 00630 THRU P2100-EXIT DTSBE761 00631 ELSE DTSBE761 00632 SET R901-ON-REQUEST-88 TO TRUE DTSBE761 00633 MOVE MPRF-EMP-NO TO R901-GRP1-EMP-NO. DTSBE761 00634 DTSBE761 00635 P2000-EXIT. DTSBE761 00636 EXIT. DTSBE761 00637 ************************************************************** DTSBE761 00638 * THIS PARAGRAPH SETS UP THE INDUSTRY CODE VALUE. IF BOTH DTSBE761 00639 * SIC AND NAICS CODE APPEAR THEN USE ONLY NAICS CODE VALUE. DTSBE761 00640 ************************************************************** DTSBE761 00641 DTSBE761 00642 P2100-SETUP-IND-CD. DTSBE761 00643 IF R901-GRP4-NAICS-88 DTSBE761 00644 MOVE WRK-NAICS-JOB-CODE TO R901-GRP4-IND-CODE. DTSBE761 00645 DTSBE761 00646 IF R901-GRP4-SIC-88 DTSBE761 00647 MOVE WRK-SIC-JOB-CODE TO R901-GRP4-IND-CODE. DTSBE761 00648 DTSBE761 00649 P2100-EXIT. DTSBE761 00650 EXIT. DTSBE761 00651 EJECT DTSBE761 00652 ************************************************************** DTSBE761 00653 * THIS PARAGRAPH LOOKS UP THE ADDRESS (MTAD). DTSBE761 00654 ************************************************************** DTSBE761 00655 DTSBE761 00656 P3000-LOOKUP-ADDR. DTSBE761 00657 DTSBE761 00658 SET L111-LOOKUP-TAD-88 TO TRUE. DTSBE761 00659 SET L111-ID-NO-TAD-MAIL-88 TO TRUE. DTSBE761 00660 DTSBE761 00661 MOVE MPRF-EMP-NO TO L111-EMP-NO. DTSBE761 00662 MOVE MPRF-EMP-NO TO R901-EMP-NO. DTSBE761 00663 DTSBE761 00664 PERFORM S111-LOOKUP-ADDR DTSBE761 00665 THRU S111-EXIT. DTSBE761 00666 DTSBE761 00667 IF L111-ADDR-FOUND-88 DTSBE761 00668 SET L112-TAD-ADDR-88 TO TRUE DTSBE761 00669 PERFORM P3100-FORMAT-ADDR DTSBE761 00670 THRU P3100-EXIT DTSBE761 00671 ELSE DTSBE761 00672 MOVE +1 TO R901-LABEL-CNT DTSBE761 00673 MOVE ALL '?' TO R901-FMT-ADDR DTSBE761 00674 R901-ZIP DTSBE761 00675 R901-ADVANCED-BARCODE. DTSBE761 00676 DTSBE761 00677 P3000-EXIT. DTSBE761 00678 EXIT. DTSBE761 00679 DTSBE761 00680 P3110-LOOKUP-PHYS-ADDR. DTSBE761 00681 DTSBE761 00682 ** DISPLAY 'LOOK UP TAX ADDR ' DTSBE761 00683 ** DISPLAY 'EMP NO ' WRK-EMP-NO1 DTSBE761 00684 ** DISPLAY SPACE. DTSBE761 00685 DTSBE761 00686 SET L111-LOOKUP-TAD-88 TO TRUE. DTSBE761 00687 SET L111-ID-NO-TAD-PHYS-88 TO TRUE. DTSBE761 00688 DTSBE761 00689 MOVE MPRF-EMP-NO TO L111-EMP-NO. DTSBE761 00690 MOVE MPRF-EMP-NO TO R901-EMP-NO. DTSBE761 00691 DTSBE761 00692 PERFORM S111-LOOKUP-ADDR DTSBE761 00693 THRU S111-EXIT. DTSBE761 00694 DTSBE761 00695 IF L111-ADDR-FOUND-88 DTSBE761 00696 SET L112-TAD-ADDR-88 TO TRUE DTSBE761 00697 PERFORM P3100-FORMAT-ADDR DTSBE761 00698 THRU P3100-EXIT DTSBE761 00699 ELSE DTSBE761 00700 MOVE +1 TO R901-LABEL-CNT DTSBE761 00701 MOVE ALL '?' TO R901-FMT-ADDR DTSBE761 00702 R901-ZIP DTSBE761 00703 R901-ADVANCED-BARCODE. DTSBE761 00704 DTSBE761 00705 P3110-EXIT. DTSBE761 00706 EXIT. DTSBE761 00707 DTSBE761 00708 DTSBE761 00709 ************************************************************** DTSBE761 00710 * THIS PARAGRAPH FORMATS THE ADDRESS (MTAD). DTSBE761 00711 ************************************************************** DTSBE761 00712 P3100-FORMAT-ADDR. DTSBE761 00713 DTSBE761 00714 SET L112-ANCHOR-LAST-88 TO TRUE. DTSBE761 00715 MOVE MPRF-PRIMARY-NAME TO L112-PRIMARY-NAME. DTSBE761 00716 MOVE L111-RETURN-AREA TO L112-NAME-ADDRESS-AREA. DTSBE761 00717 DTSBE761 00718 PERFORM S112-FORMAT-ADDR DTSBE761 00719 THRU S112-EXIT. DTSBE761 00720 DTSBE761 00721 MOVE L112-MAILING-ADDRESS TO R901-FMT-ADDR. DTSBE761 00722 MOVE L112-ZIP TO R901-ZIP. DTSBE761 00723 MOVE L112-ADVANCED-BARCODE TO R901-ADVANCED-BARCODE. DTSBE761 00724 MOVE +1 TO R901-LABEL-CNT. DTSBE761 00725 DTSBE761 00726 P3100-EXIT. DTSBE761 00727 EXIT. DTSBE761 00728 EJECT DTSBE761 00729 T0000-TERMINATE. DTSBE761 00730 DTSBE761 00731 DTSBE761 00732 T0000-EXIT. DTSBE761 00733 EXIT. DTSBE761 00734 EJECT DTSBE761 00735 S001-FROM-FED-8. DTSBE761 00736 SET L001-FROM-FED-8 TO TRUE. DTSBE761 00737 GO TO S001-DATE. DTSBE761 00738 DTSBE761 00739 S001-FROM-CAL-6. DTSBE761 00740 SET L001-FROM-CAL-6 TO TRUE. DTSBE761 00741 GO TO S001-DATE. DTSBE761 00742 DTSBE761 00743 S001-FROM-ABS-DAY. DTSBE761 00744 SET L001-FROM-ABS-DAY TO TRUE. DTSBE761 00745 GO TO S001-DATE. DTSBE761 00746 DTSBE761 00747 S001-DATE. DTSBE761 00748 CALL 'DTSBU001' USING L001-LINK-AREA. DTSBE761 00749 S001-EXIT. DTSBE761 00750 EXIT. DTSBE761 00751 DTSBE761 00752 S111-LOOKUP-ADDR. DTSBE761 00753 DTSBE761 00754 CALL 'DTSBU111' USING L111-LINK-AREA. DTSBE761 00755 S111-EXIT. DTSBE761 00756 EXIT. DTSBE761 00757 DTSBE761 00758 S112-FORMAT-ADDR. DTSBE761 00759 CALL 'DTSBU112' USING L112-LINK-AREA. DTSBE761 00760 S112-EXIT. DTSBE761 00761 EXIT. DTSBE761 00762 DTSBE761 00763 S910-READ. DTSBE761 00764 SET L910-READ-88 TO TRUE. DTSBE761 00765 GO TO S910-MSTR-IO. DTSBE761 00766 DTSBE761 00767 S910-START-BROWSE. DTSBE761 00768 SET L910-START-BROWSE-88 TO TRUE. DTSBE761 00769 GO TO S910-MSTR-IO. DTSBE761 00770 DTSBE761 00771 S910-READ-NEXT. DTSBE761 00772 SET L910-READ-NEXT-88 TO TRUE. DTSBE761 00773 GO TO S910-MSTR-IO. DTSBE761 00774 DTSBE761 00775 S910-COUNT. DTSBE761 00776 SET L910-COUNT-88 TO TRUE. DTSBE761 00777 GO TO S910-MSTR-IO. DTSBE761 00778 DTSBE761 00779 S910-MSTR-IO. DTSBE761 00780 CALL 'DTSBU910' USING L910-LINK-AREA DTSBE761 00781 MSKL-REC. DTSBE761 00782 S910-EXIT. DTSBE761 00783 EXIT. DTSBE761 00784 DTSBE761 00785 S946-WRITE-R901. DTSBE761 00786 CALL 'DTSBU946' USING R901-REC. DTSBE761 00787 GO TO S946-EXIT. DTSBE761 00788 DTSBE761 00789 S946-EXIT. DTSBE761 00790 EXIT. DTSBE761 00791 DTSBE761 00792 S999-ABEND. DTSBE761 00793 DISPLAY '*** DTSBE761 ABENDING. ' DTSBE761 00794 ABEND-MSG. DTSBE761 00795 DTSBE761 00796 CALL 'DTSBU999' USING WRK-ABEND-CD. DTSBE761 00797 S999-EXIT. DTSBE761 00798 EXIT. DTSBE761