00001 IDENTIFICATION DIVISION. 08/28/02 00002 PROGRAM-ID. DESBR901. DESBR901 00003 AUTHOR. MT DEPT OF LABOR/UI PROGRAMMING SECTION LV001 00004 DATE-WRITTEN. JULY 1994. DESBR901 00005 DATE-COMPILED. DESBR901 00006 DESBR901 00007 ***** DESBR901 00008 * CALLING SEQUENCE: DTSBD311, DTSBD314, DTSBD315, DESBR901 00009 * DTSBD317 AND DTSBE761 CAN DESBR901 00010 * UPDATE DTSIR901 RECORD AND THE DESBR901 00011 * DTSBR901 READS DTSIR901 RECORDS DESBR901 00012 * DESBR901 00013 * TO PRINT THE EXTRACTED LABELS. DESBR901 00014 * FUNCTION: LABEL PRINTING. DESBR901 00015 * DESBR901 00016 * DESBR901 00017 * MODIFICATION HISTORY: DESBR901 00018 * DESBR901 00019 * 07-31-94 INITIAL DEVELOPMENT DESBR901 00020 * REFERENCE RFP #RAP AUTHOR OF CHANGE - SFW DESBR901 00021 * DESBR901 00022 * 03-15-95 DROP OP-ID FROM UI-272 LABELS. DESBR901 00023 * REFERENCE RFP #CR053 AUTHOR OF CHANGE - RHC DESBR901 00024 * DESBR901 00025 * 05-16-95 WORDS "UI ACCOUNT #" REMOVED PER C.R. 080 DESBR901 00026 * REFERENCE RFP #RAP AUTHOR OF CHANGE - SFW DESBR901 00027 * DESBR901 00028 * 06-13-96 RECOMPILED TO INCORPORATE CHANGES TO DTSIR901 FOR DESBR901 00029 * ELECTRONIC FILER LABELS FROM SCREEN 76. DESBR901 00030 * REFERENCE RFP #WARP II PROGRAMMER: MJA DESBR901 00031 * DESBR901 00032 * 10-29-98 DROP REFERENCE TO R901-UI-272-88 DESBR901 00033 * R901-GRP6-JS-OFFICE-ID FROM PROGRAM TO MEET DC DESBR901 00034 * EXTERNAL DESIGN EXPORT REQUIREMENTS. DESBR901 00035 * REFERENCE RFP #**** PROGRAMMER: DVS DESBR901 00036 * DESBR901 00037 * 10-13-99 ADDED S083-UPPERCSE-CHG ROUTINE TO CHANGE ALL LOWER DESBR901 00038 * CASE LETTERS TO UPPER CASE ON OPR NAME AND UNIT DESBR901 00039 * NAME LABEL. PROGRAMMER: FB DESBR901 00040 * DESBR901 00041 * 02-20-01 FIXED A BUG FOUND WHEN PRINTING SIC/NAIC EXTRACTS DESBR901 00042 * FOR JOB-SERVICE LABELS PROGRAMMER: JHP DESBR901 00043 * DESBR901 00044 * 05-24-01 CLONED FROM DTSBR901 DESBR901 00045 * PROGRAMMER: GD DESBR901 00046 * DESBR901 00047 * MM-DD-YY XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DESBR901 00048 * XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DESBR901 00049 * REFERENCE RFP #**** PROGRAMMER: XXX DESBR901 00050 * DESBR901 00051 * DESBR901 00052 * DESCRIPTION: DESBR901 00053 * DESBR901 00054 * THIS MODULE GENERATES LABELS FOR VARIOUS PROCESSES DESBR901 00055 * IN THE TAX SYSTEM. DESBR901 00056 * DESBR901 00057 * DESBR901 00058 * RECORDS READ: DESBR901 00059 * DESBR901 00060 * NONE. DESBR901 00061 * DESBR901 00062 * DESBR901 00063 * PRINTED OUTPUTS: DESBR901 00064 * DESBR901 00065 * 901R1 LABELS DESBR901 00066 * DESBR901 00067 * DESBR901 00068 * RECORDS WRITTEN: DESBR901 00069 * DESBR901 00070 * NONE. DESBR901 00071 * DESBR901 00072 * DESBR901 00073 * MODULES CALLED: DESBR901 00074 * DESBR901 00075 * DTSBU071 NAME EDIT/CONVERSION MODULE DESBR901 00076 * DTSBU082 OPERATOR ID EDIT/LOOKUP MODULE DESBR901 00077 * DTSBU132 JOB SERVICE OFFICE DESC. MODULE DESBR901 00078 * DESBR901 00079 ***** DESBR901 00080 EJECT DESBR901 00081 ENVIRONMENT DIVISION. DESBR901 00082 DESBR901 00083 CONFIGURATION SECTION. DESBR901 00084 SPECIAL-NAMES. C01 IS TOP-OF-PAGE. DESBR901 00085 DESBR901 00086 INPUT-OUTPUT SECTION. DESBR901 00087 DESBR901 00088 FILE-CONTROL. DESBR901 00089 SELECT PRT-FILE1 ASSIGN TO RPT901R1. DESBR901 00090 SELECT PRT-FILE2 ASSIGN TO RPT901R2. DESBR901 00091 DESBR901 00092 DATA DIVISION. DESBR901 00093 DESBR901 00094 FILE SECTION. DESBR901 00095 DESBR901 00096 FD PRT-FILE1 DESBR901 00097 RECORDING MODE IS F. DESBR901 00098 01 REPORT-LISTING1 PIC X(80). DESBR901 00099 DESBR901 00100 FD PRT-FILE2 DESBR901 00101 RECORDING MODE IS F. DESBR901 00102 01 REPORT-LISTING2 PIC X(80). DESBR901 00103 DESBR901 00104 EJECT DESBR901 00105 WORKING-STORAGE SECTION. DESBR901 001055 77 PAN-VALET PICTURE X(24) VALUE '001DESBR901 08/28/02'. DESBR901 00106 DESBR901 00107 01 WRK-AREA. DESBR901 00108 05 WRK-ABEND-CD PIC S9(04) COMP VALUE +901.DESBR901 00109 05 FIRST-TIME-IND PIC X(01) VALUE 'Y'. DESBR901 00110 DESBR901 00111 05 RPT1-OPEN-SW PIC X(01) VALUE 'N'. DESBR901 00112 DESBR901 00113 05 WRK-BREAK-GROUP. DESBR901 00114 10 WRK-LABEL-TYPE PIC X(27) VALUE SPACES. DESBR901 00115 10 WRK-OPR-NAME PIC X(32) VALUE SPACES. DESBR901 00116 05 WRK-OPR-UNIT-NAME PIC X(30) VALUE SPACES. DESBR901 00117 DESBR901 00118 05 WRK-HOLD-GROUP PIC X(01) VALUE SPACE. DESBR901 00119 05 WRK-HOLD-GROUP-9 REDEFINES WRK-HOLD-GROUP DESBR901 00120 PIC 9(01). DESBR901 00121 05 WRK-HOLD-OP-ID PIC X(08) VALUE SPACES. DESBR901 00122 DESBR901 00123 05 WRK-LOCAL-OFFICE-DESC. DESBR901 00124 10 WRK-FILLER PIC X(13) DESBR901 00125 VALUE 'LOCAL OFFICE '. DESBR901 00126 10 WRK-JS-OFFICE-ID PIC 9(02) VALUE ZEROS. DESBR901 00127 DESBR901 00128 05 WRK-LABEL-TYPE-TEXT. DESBR901 00129 10 FILLER PIC X(27) VALUE DESBR901 00130 ' ON REQUEST LABELS '. DESBR901 00131 10 FILLER PIC X(27) VALUE DESBR901 00132 'REGISTRATION CYCLE A LABELS'. DESBR901 00133 10 FILLER PIC X(27) VALUE DESBR901 00134 'LIAB DETERMINATION LABELS'. DESBR901 00135 10 FILLER PIC X(27) VALUE DESBR901 00136 ' JOB SERVICE LABELS '. DESBR901 00137 05 FILLER REDEFINES WRK-LABEL-TYPE-TEXT. DESBR901 00138 10 WRK-TEXT-LINE OCCURS 4 TIMES DESBR901 00139 INDEXED BY WRK-TEXT-LINE-IDX DESBR901 00140 PIC X(27). DESBR901 00141 05 WRK-GRP4-CD-1 PIC X(06) VALUE 'NAIC: '. DESBR901 00142 05 WRK-GRP4-CD-2 PIC X(06) VALUE ' SIC: '. DESBR901 00143 DESBR901 00144 01 LINEUP-LABEL1. DESBR901 00145 05 LLD1-LINE-1 PIC X(80) VALUE SPACES. DESBR901 00146 05 LLD1-LINE-2. DESBR901 00147 10 FILLER PIC X(03) VALUE SPACES. DESBR901 00148 10 FILLER PIC X(07) DESBR901 00149 VALUE '999 999'. DESBR901 00150 05 LLD1-LINE-3 PIC X(80) VALUE SPACES. DESBR901 00151 05 LLD1-LINE-4. DESBR901 00152 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00153 10 FILLER PIC X(40) DESBR901 00154 VALUE 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX'. DESBR901 00155 05 LLD1-LINE-5. DESBR901 00156 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00157 10 ILLER PIC X(40) DESBR901 00158 VALUE 'XXXXXXXXXXXXXXX DTSP901 XXXXXXXXXXXXXXX'. DESBR901 00159 05 LLD1-LINE-6. DESBR901 00160 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00161 10 FILLER PIC X(16) DESBR901 00162 VALUE 'XXXXXXXXXXXXXXX '. DESBR901 00163 10 LLD1-SYS-DATE PIC X(08) VALUE SPACES. DESBR901 00164 10 FILLER PIC X(16) DESBR901 00165 VALUE ' XXXXXXXXXXXXXXX'. DESBR901 00166 05 LLD1-LINE-7. DESBR901 00167 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00168 10 FILLER PIC X(40) DESBR901 00169 VALUE 'XXXXXXXXXXXXXXX DTSP901 XXXXXXXXXXXXXXX'. DESBR901 00170 05 LLD1-LINE-8. DESBR901 00171 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00172 10 FILLER PIC X(40) DESBR901 00173 VALUE 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX'. DESBR901 00174 EJECT DESBR901 00175 01 BREAK-LABEL1. DESBR901 00176 05 BLD1-LINE-1 PIC X(80) VALUE SPACES. DESBR901 00177 05 BLD1-LINE-3. DESBR901 00178 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00179 10 FILLER PIC X(40) DESBR901 00180 VALUE IS ALL '*'. DESBR901 00181 05 BLD1-LINE-4. DESBR901 00182 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00183 10 FILLER PIC X(01) DESBR901 00184 VALUE IS '*'. DESBR901 00185 10 FILLER PIC X(05) VALUE SPACE. DESBR901 00186 10 BLD1-LABEL-TYPE PIC X(27) VALUE SPACE. DESBR901 00187 10 FILLER PIC X(06) VALUE SPACE. DESBR901 00188 10 FILLER PIC X(01) DESBR901 00189 VALUE IS '*'. DESBR901 00190 05 BLD1-LINE-5. DESBR901 00191 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00192 10 FILLER PIC X(01) DESBR901 00193 VALUE IS '*'. DESBR901 00194 10 FILLER PIC X(05) VALUE SPACE. DESBR901 00195 10 BLD1-OPR-NAME PIC X(32) VALUE SPACE. DESBR901 00196 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00197 10 FILLER PIC X(01) DESBR901 00198 VALUE IS '*'. DESBR901 00199 05 BLD1-LINE-6. DESBR901 00200 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00201 10 FILLER PIC X(01) DESBR901 00202 VALUE IS '*'. DESBR901 00203 10 FILLER PIC X(05) VALUE SPACE. DESBR901 00204 10 BLD1-OPR-UNIT-NAME PIC X(30) VALUE SPACE. DESBR901 00205 10 FILLER PIC X(03) VALUE SPACE. DESBR901 00206 10 FILLER PIC X(01) DESBR901 00207 VALUE IS '*'. DESBR901 00208 05 BLD1-LINE-7. DESBR901 00209 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00210 10 FILLER PIC X(40) DESBR901 00211 VALUE IS ALL '*'. DESBR901 00212 DESBR901 00213 01 MAILING-LABEL1. DESBR901 00214 05 MLD1-LINE-1 PIC X(80) VALUE SPACES. DESBR901 00215 05 MLD1-LINE-2. DESBR901 00216 10 FILLER PIC X(03) VALUE SPACE. DESBR901 00217 10 MLD1-EMP-NO PIC 999B999. DESBR901 00218 05 MLD1-LINE-3 PIC X(80) VALUE SPACES. DESBR901 00219 05 MLD1-LINE-4. DESBR901 00220 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00221 10 MLD1-FMT-LINE-1 PIC X(40) VALUE SPACE. DESBR901 00222 05 MLD1-LINE-5. DESBR901 00223 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00224 10 MLD1-FMT-LINE-2 PIC X(40) VALUE SPACE. DESBR901 00225 05 MLD1-LINE-6. DESBR901 00226 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00227 10 MLD1-FMT-LINE-3 PIC X(40) VALUE SPACE. DESBR901 00228 05 MLD1-LINE-7. DESBR901 00229 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00230 10 MLD1-FMT-LINE-4 PIC X(40) VALUE SPACE. DESBR901 00231 05 MLD1-LINE-8. DESBR901 00232 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00233 10 MLD1-FMT-LINE-5 PIC X(40) VALUE SPACE. DESBR901 00234 DESBR901 00235 01 LINEUP-LABEL2. DESBR901 00236 05 LLD2-LINE-1 PIC X(80) VALUE SPACES. DESBR901 00237 05 LLD2-LINE-2. DESBR901 00238 10 FILLER PIC X(03) VALUE SPACES. DESBR901 00239 10 FILLER PIC X(07) DESBR901 00240 VALUE '999 999'. DESBR901 00241 05 LLD2-LINE-3 PIC X(80) VALUE SPACES. DESBR901 00242 05 LLD2-LINE-4. DESBR901 00243 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00244 10 FILLER PIC X(40) DESBR901 00245 VALUE 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX'. DESBR901 00246 05 LLD2-LINE-5. DESBR901 00247 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00248 10 FILLER PIC X(40) DESBR901 00249 VALUE 'XXXXXXXXXXXXXXX DTSP901 (OTHER) XXXXXXX'. DESBR901 00250 05 LLD2-LINE-6. DESBR901 00251 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00252 10 FILLER PIC X(16) DESBR901 00253 VALUE 'XXXXXXXXXXXXXXX '. DESBR901 00254 10 LLD2-SYS-DATE PIC X(08) VALUE SPACES. DESBR901 00255 10 FILLER PIC X(16) DESBR901 00256 VALUE ' (OTHER) XXXXXXX'. DESBR901 00257 05 LLD2-LINE-7. DESBR901 00258 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00259 10 FILLER PIC X(40) DESBR901 00260 VALUE 'XXXXXXXXXXXXXXX DTSP901 (OTHER) XXXXXXX'. DESBR901 00261 05 LLD2-LINE-8. DESBR901 00262 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00263 10 FILLER PIC X(40) DESBR901 00264 VALUE 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX'. DESBR901 00265 DESBR901 00266 01 BREAK-LABEL2. DESBR901 00267 05 BLD2-LINE-1 PIC X(80) VALUE SPACES. DESBR901 00268 05 BLD2-LINE-3. DESBR901 00269 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00270 10 FILLER PIC X(40) DESBR901 00271 VALUE IS ALL '*'. DESBR901 00272 05 BLD2-LINE-4. DESBR901 00273 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00274 10 FILLER PIC X(01) DESBR901 00275 VALUE IS '*'. DESBR901 00276 10 FILLER PIC X(05) VALUE SPACE. DESBR901 00277 10 BLD2-LABEL-TYPE PIC X(27) VALUE SPACE. DESBR901 00278 10 FILLER PIC X(06) VALUE SPACE. DESBR901 00279 10 FILLER PIC X(01) DESBR901 00280 VALUE IS '*'. DESBR901 00281 05 BLD2-LINE-5. DESBR901 00282 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00283 10 FILLER PIC X(01) DESBR901 00284 VALUE IS '*'. DESBR901 00285 10 FILLER PIC X(05) VALUE SPACE. DESBR901 00286 10 BLD2-OPR-NAME PIC X(32) VALUE SPACE. DESBR901 00287 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00288 10 FILLER PIC X(01) DESBR901 00289 VALUE IS '*'. DESBR901 00290 05 BLD2-LINE-6. DESBR901 00291 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00292 10 FILLER PIC X(01) DESBR901 00293 VALUE IS '*'. DESBR901 00294 10 FILLER PIC X(05) VALUE SPACE. DESBR901 00295 10 BLD2-OPR-UNIT-NAME PIC X(30) VALUE SPACE. DESBR901 00296 10 FILLER PIC X(03) VALUE SPACE. DESBR901 00297 10 FILLER PIC X(01) DESBR901 00298 VALUE IS '*'. DESBR901 00299 05 BLD2-LINE-7. DESBR901 00300 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00301 10 FILLER PIC X(40) DESBR901 00302 VALUE IS ALL '*'. DESBR901 00303 DESBR901 00304 01 MAILING-LABEL2. DESBR901 00305 05 MLD2-LINE-1 PIC X(80) VALUE SPACES. DESBR901 00306 05 MLD2-LINE-2. DESBR901 00307 10 FILLER PIC X(03) VALUE SPACES. DESBR901 00308 10 MLD2-EMP-NO PIC 999B999. DESBR901 00309 10 FILLER PIC X(15) VALUE SPACES. DESBR901 00310 10 WRK-GRP4-LBL-ID PIC X(06) VALUE SPACE. DESBR901 00311 10 WRK-GRP4-LBL-NBR PIC X(06) VALUE SPACE. DESBR901 00312 05 MLD2-LINE-3 PIC X(80) VALUE SPACES. DESBR901 00313 05 MLD2-LINE-4. DESBR901 00314 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00315 10 MLD2-FMT-LINE-1 PIC X(40) VALUE SPACE. DESBR901 00316 05 MLD2-LINE-5. DESBR901 00317 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00318 10 MLD2-FMT-LINE-2 PIC X(40) VALUE SPACE. DESBR901 00319 05 MLD2-LINE-6. DESBR901 00320 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00321 10 MLD2-FMT-LINE-3 PIC X(40) VALUE SPACE. DESBR901 00322 05 MLD2-LINE-7. DESBR901 00323 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00324 10 MLD2-FMT-LINE-4 PIC X(40) VALUE SPACE. DESBR901 00325 05 MLD2-LINE-8. DESBR901 00326 10 FILLER PIC X(01) VALUE SPACE. DESBR901 00327 10 MLD2-FMT-LINE-5 PIC X(40) VALUE SPACE. DESBR901 00328 EJECT DESBR901 00329 01 ILBL-LINK-AREA. DESBR901 00330 ++INCLUDE DOESILBL DESBR901 00331 DESBR901 00332 01 L071-LINK-AREA. DESBR901 00333 ++INCLUDE DTSIL071 DESBR901 00334 DESBR901 00335 01 L082-LINK-AREA. DESBR901 00336 ++INCLUDE DTSIL082 DESBR901 00337 DESBR901 00338 01 LINK-AREA. DESBR901 00339 ++INCLUDE DTSIL009 DESBR901 00340 EJECT DESBR901 00341 LINKAGE SECTION. DESBR901 00342 DESBR901 00343 01 LRCM-LINK-AREA. DESBR901 00344 ++INCLUDE DTSILRCM DESBR901 00345 EJECT DESBR901 00346 01 R901-REC. DESBR901 00347 ++INCLUDE DTSIR901 DESBR901 00348 EJECT DESBR901 00349 PROCEDURE DIVISION USING LRCM-LINK-AREA DESBR901 00350 R901-REC. DESBR901 00351 DESBR901 00352 IF FIRST-TIME-IND = 'Y' DESBR901 00353 PERFORM I1000-INITIATE DESBR901 00354 THRU I1000-EXIT DESBR901 00355 MOVE 'N' TO FIRST-TIME-IND. DESBR901 00356 DESBR901 00357 IF LRCM-EOR-88 DESBR901 00358 PERFORM T1000-TERMINATE DESBR901 00359 THRU T1000-EXIT DESBR901 00360 ELSE DESBR901 00361 PERFORM P1000-PROCESS DESBR901 00362 THRU P1000-EXIT. DESBR901 00363 DESBR901 00364 GOBACK. DESBR901 00365 EJECT DESBR901 00366 I1000-INITIATE. DESBR901 00367 MOVE LENGTH OF ILBL-LINK-AREA TO ILBL-LENGTH. DESBR901 00368 IF R901-JOB-SERVICE-88 DESBR901 00369 * OPEN OUTPUT PRT-FILE2 DESBR901 00370 * MOVE SPACES TO REPORT-LISTING2 DESBR901 00371 MOVE LRCM-SYS-DATE TO LLD2-SYS-DATE DESBR901 00372 PERFORM P3000-LINEUP-LABEL2 THRU P3000-EXIT 2 TIMES DESBR901 00373 MOVE 'N' TO RPT1-OPEN-SW DESBR901 00374 ELSE DESBR901 00375 * OPEN OUTPUT PRT-FILE1 DESBR901 00376 * MOVE SPACES TO REPORT-LISTING1 DESBR901 00377 MOVE LRCM-SYS-DATE TO LLD1-SYS-DATE DESBR901 00378 PERFORM P4000-LINEUP-LABEL1 THRU P4000-EXIT 2 TIMES DESBR901 00379 MOVE 'Y' TO RPT1-OPEN-SW. DESBR901 00380 DESBR901 00381 PERFORM P2000-SET-GROUP THRU P2000-EXIT. DESBR901 00382 DESBR901 00383 DESBR901 00384 I1000-EXIT. DESBR901 00385 EXIT. DESBR901 00386 EJECT DESBR901 00387 P1000-PROCESS. DESBR901 00388 DESBR901 00389 IF R901-GROUP = WRK-HOLD-GROUP DESBR901 00390 IF R901-EMP-REG-A-88 DESBR901 00391 OR R901-LIAB-DETER-88 DESBR901 00392 OR R901-ON-REQUEST-88 DESBR901 00393 PERFORM P1100-CHECK-FOR-NEW-OP-ID DESBR901 00394 THRU P1100-EXIT DESBR901 00395 ELSE DESBR901 00396 NEXT SENTENCE DESBR901 00397 END-IF DESBR901 00398 ELSE DESBR901 00399 **** DESBR901 00400 **** THE THREE TYPES OF LABELS ABOVE ARE *ABSOLUTELY* DESBR901 00401 **** MUTUALLY EXCLUSIVE WITH LABEL TYPE FOUR!!! DESBR901 00402 **** THE FIRST THREE ARE RELATED AND ARE ALL PRINTED DESBR901 00403 **** IN RPT901R1. THE FOURTH LABEL TYPE IS THE *ONLY* DESBR901 00404 **** ONE PRINTED IN RPT901R2. DESBR901 00405 **** THERE CAN NEVER BE A TYPE 4 IN THE SAME 'PER.RPT' DESBR901 00406 **** FILE WITH ANY OF THE OTHERS FROM THE *SAME* JOB. DESBR901 00407 **** DESBR901 00408 **** IF R901-JOB-SERVICE-88 DESBR901 00409 **** AND RPT1-OPEN-SW = 'Y' DESBR901 00410 **** PERFORM T1000-TERMINATE THRU T1000-EXIT DESBR901 00411 **** PERFORM I1000-INITIATE THRU I1000-EXIT DESBR901 00412 **** END-IF DESBR901 00413 DESBR901 00414 PERFORM P2000-SET-GROUP THRU P2000-EXIT DESBR901 00415 END-IF. DESBR901 00416 DESBR901 00417 IF RPT1-OPEN-SW = 'Y' DESBR901 00418 PERFORM R901-LABEL-CNT TIMES DESBR901 00419 PERFORM P5000-MAILING-LABEL1 THRU P5000-EXIT DESBR901 00420 END-PERFORM DESBR901 00421 ELSE DESBR901 00422 PERFORM R901-LABEL-CNT TIMES DESBR901 00423 PERFORM P1010-CHECK-JOB-SRVC THRU P1010-EXIT DESBR901 00424 PERFORM P6000-MAILING-LABEL2 THRU P6000-EXIT DESBR901 00425 MOVE SPACE TO WRK-GRP4-LBL-ID, DESBR901 00426 WRK-GRP4-LBL-NBR DESBR901 00427 END-PERFORM DESBR901 00428 END-IF. DESBR901 00429 DESBR901 00430 P1000-EXIT. DESBR901 00431 EXIT. DESBR901 00432 P1010-CHECK-JOB-SRVC. DESBR901 00433 IF R901-JOB-SERVICE-88 DESBR901 00434 IF R901-GRP4-NAICS-88 DESBR901 00435 MOVE WRK-GRP4-CD-1 TO WRK-GRP4-LBL-ID DESBR901 00436 ELSE DESBR901 00437 IF R901-GRP4-SIC-88 DESBR901 00438 MOVE WRK-GRP4-CD-2 TO WRK-GRP4-LBL-ID DESBR901 00439 END-IF DESBR901 00440 END-IF DESBR901 00441 DESBR901 00442 IF WRK-GRP4-LBL-ID NOT = SPACE DESBR901 00443 MOVE R901-GRP4-IND-CODE TO WRK-GRP4-LBL-NBR DESBR901 00444 END-IF DESBR901 00445 END-IF. DESBR901 00446 P1010-EXIT. DESBR901 00447 EXIT. DESBR901 00448 EJECT DESBR901 00449 P1100-CHECK-FOR-NEW-OP-ID. DESBR901 00450 DESBR901 00451 IF R901-GRP1-OP-ID NOT = WRK-HOLD-OP-ID DESBR901 00452 PERFORM P2100-SET-OPR-FIELDS DESBR901 00453 THRU P2100-EXIT. DESBR901 00454 DESBR901 00455 P1100-EXIT. DESBR901 00456 EXIT. DESBR901 00457 DESBR901 00458 EJECT DESBR901 00459 P2000-SET-GROUP. DESBR901 00460 DESBR901 00461 MOVE R901-GROUP TO WRK-HOLD-GROUP. DESBR901 00462 SET WRK-TEXT-LINE-IDX TO WRK-HOLD-GROUP-9. DESBR901 00463 MOVE WRK-TEXT-LINE (WRK-TEXT-LINE-IDX) TO WRK-LABEL-TYPE DESBR901 00464 BLD1-LABEL-TYPE DESBR901 00465 BLD2-LABEL-TYPE. DESBR901 00466 IF R901-JOB-SERVICE-88 DESBR901 00467 NEXT SENTENCE DESBR901 00468 ELSE DESBR901 00469 PERFORM P2100-SET-OPR-FIELDS DESBR901 00470 THRU P2100-EXIT. DESBR901 00471 DESBR901 00472 P2000-EXIT. DESBR901 00473 EXIT. DESBR901 00474 DESBR901 00475 P2100-SET-OPR-FIELDS. DESBR901 00476 DESBR901 00477 MOVE R901-GRP1-OP-ID TO WRK-HOLD-OP-ID DESBR901 00478 L082-OP-ID. DESBR901 00479 DESBR901 00480 PERFORM S082-OP-ID-NAME DESBR901 00481 THRU S082-EXIT. DESBR901 00482 DESBR901 00483 MOVE L082-NAME TO L071-NAM. DESBR901 00484 MOVE 2 TO L071-NAME-FORMAT. DESBR901 00485 DESBR901 00486 PERFORM S071-DESLASH-NAME DESBR901 00487 THRU S071-EXIT. DESBR901 00488 DESBR901 00489 ********** CONVERTING LOWER CASE TO UPPER CASE ***************** DESBR901 00490 ** MOVE L071-NAM TO WRK-OPR-NAME DESBR901 00491 MOVE L071-NAM TO L009-DATA. DESBR901 00492 PERFORM S083-UPPERCASE-CHG DESBR901 00493 THRU S083-EXIT. DESBR901 00494 MOVE L009-DATA TO WRK-OPR-NAME DESBR901 00495 BLD1-OPR-NAME DESBR901 00496 BLD2-OPR-NAME. DESBR901 00497 DESBR901 00498 ** MOVE L082-UNIT-NAME TO WRK-OPR-UNIT-NAME DESBR901 00499 MOVE L082-UNIT-NAME TO L009-DATA. DESBR901 00500 PERFORM S083-UPPERCASE-CHG DESBR901 00501 THRU S083-EXIT. DESBR901 00502 MOVE L009-DATA TO WRK-OPR-UNIT-NAME DESBR901 00503 BLD1-OPR-UNIT-NAME DESBR901 00504 BLD2-OPR-UNIT-NAME. DESBR901 00505 ************* ***********************DESBR901 00506 IF RPT1-OPEN-SW = 'Y' DESBR901 00507 IF R901-GRP1-OP-ID NOT = SPACES DESBR901 00508 PERFORM P7000-BREAK-LABEL1 THRU P7000-EXIT DESBR901 00509 END-IF DESBR901 00510 ELSE DESBR901 00511 PERFORM P8000-BREAK-LABEL2 THRU P8000-EXIT. DESBR901 00512 DESBR901 00513 P2100-EXIT. DESBR901 00514 EXIT. DESBR901 00515 DESBR901 00516 P3000-LINEUP-LABEL2. DESBR901 00517 MOVE LLD2-LINE-1 TO ILBL-FMT-LINE(1) DESBR901 00518 MOVE LLD2-LINE-2 TO ILBL-FMT-LINE(2) DESBR901 00519 MOVE LLD2-LINE-3 TO ILBL-FMT-LINE(3) DESBR901 00520 MOVE LLD2-LINE-4 TO ILBL-FMT-LINE(4) DESBR901 00521 MOVE LLD2-LINE-5 TO ILBL-FMT-LINE(5) DESBR901 00522 MOVE LLD2-LINE-6 TO ILBL-FMT-LINE(6) DESBR901 00523 MOVE LLD2-LINE-7 TO ILBL-FMT-LINE(7) DESBR901 00524 MOVE LLD2-LINE-8 TO ILBL-FMT-LINE(8) DESBR901 00525 PERFORM S946-WRITE THRU S946-EXIT. DESBR901 00526 P3000-EXIT. DESBR901 00527 EXIT. DESBR901 00528 DESBR901 00529 P4000-LINEUP-LABEL1. DESBR901 00530 DESBR901 00531 MOVE LLD1-LINE-1 TO ILBL-FMT-LINE(1) DESBR901 00532 MOVE LLD1-LINE-2 TO ILBL-FMT-LINE(2) DESBR901 00533 MOVE LLD1-LINE-3 TO ILBL-FMT-LINE(3) DESBR901 00534 MOVE LLD1-LINE-4 TO ILBL-FMT-LINE(4) DESBR901 00535 MOVE LLD1-LINE-5 TO ILBL-FMT-LINE(5) DESBR901 00536 MOVE LLD1-LINE-6 TO ILBL-FMT-LINE(6) DESBR901 00537 MOVE LLD1-LINE-7 TO ILBL-FMT-LINE(7) DESBR901 00538 MOVE LLD1-LINE-8 TO ILBL-FMT-LINE(8) DESBR901 00539 PERFORM S946-WRITE THRU S946-EXIT. DESBR901 00540 P4000-EXIT. DESBR901 00541 EXIT. DESBR901 00542 DESBR901 00543 P5000-MAILING-LABEL1. DESBR901 00544 DESBR901 00545 MOVE R901-EMP-NO TO MLD1-EMP-NO DESBR901 00546 MOVE R901-FMT-LINE (1) TO MLD1-FMT-LINE-1 DESBR901 00547 MOVE R901-FMT-LINE (2) TO MLD1-FMT-LINE-2 DESBR901 00548 MOVE R901-FMT-LINE (3) TO MLD1-FMT-LINE-3 DESBR901 00549 MOVE R901-FMT-LINE (4) TO MLD1-FMT-LINE-4 DESBR901 00550 MOVE R901-FMT-LINE (5) TO MLD1-FMT-LINE-5. DESBR901 00551 DESBR901 00552 MOVE MLD1-LINE-1 TO ILBL-FMT-LINE(1) DESBR901 00553 MOVE MLD1-LINE-2 TO ILBL-FMT-LINE(2) DESBR901 00554 MOVE MLD1-LINE-3 TO ILBL-FMT-LINE(3) DESBR901 00555 MOVE MLD1-LINE-4 TO ILBL-FMT-LINE(4) DESBR901 00556 MOVE MLD1-LINE-5 TO ILBL-FMT-LINE(5) DESBR901 00557 MOVE MLD1-LINE-6 TO ILBL-FMT-LINE(6) DESBR901 00558 MOVE MLD1-LINE-7 TO ILBL-FMT-LINE(7) DESBR901 00559 MOVE MLD1-LINE-8 TO ILBL-FMT-LINE(8) DESBR901 00560 PERFORM S946-WRITE THRU S946-EXIT. DESBR901 00561 P5000-EXIT. DESBR901 00562 EXIT. DESBR901 00563 DESBR901 00564 P6000-MAILING-LABEL2. DESBR901 00565 DESBR901 00566 MOVE R901-EMP-NO TO MLD2-EMP-NO DESBR901 00567 MOVE R901-FMT-LINE (1) TO MLD2-FMT-LINE-1 DESBR901 00568 MOVE R901-FMT-LINE (2) TO MLD2-FMT-LINE-2 DESBR901 00569 MOVE R901-FMT-LINE (3) TO MLD2-FMT-LINE-3 DESBR901 00570 MOVE R901-FMT-LINE (4) TO MLD2-FMT-LINE-4 DESBR901 00571 MOVE R901-FMT-LINE (5) TO MLD2-FMT-LINE-5. DESBR901 00572 DESBR901 00573 MOVE MLD2-LINE-1 TO ILBL-FMT-LINE(1) DESBR901 00574 MOVE MLD2-LINE-2 TO ILBL-FMT-LINE(2) DESBR901 00575 MOVE MLD2-LINE-3 TO ILBL-FMT-LINE(3) DESBR901 00576 MOVE MLD2-LINE-4 TO ILBL-FMT-LINE(4) DESBR901 00577 MOVE MLD2-LINE-5 TO ILBL-FMT-LINE(5) DESBR901 00578 MOVE MLD2-LINE-6 TO ILBL-FMT-LINE(6) DESBR901 00579 MOVE MLD2-LINE-7 TO ILBL-FMT-LINE(7) DESBR901 00580 MOVE MLD2-LINE-8 TO ILBL-FMT-LINE(8) DESBR901 00581 PERFORM S946-WRITE THRU S946-EXIT. DESBR901 00582 P6000-EXIT. DESBR901 00583 EXIT. DESBR901 00584 DESBR901 00585 P7000-BREAK-LABEL1. DESBR901 00586 DESBR901 00587 MOVE BLD1-LINE-1 TO ILBL-FMT-LINE(1) DESBR901 00588 MOVE SPACES TO ILBL-FMT-LINE(2) DESBR901 00589 MOVE BLD1-LINE-3 TO ILBL-FMT-LINE(3) DESBR901 00590 MOVE BLD1-LINE-4 TO ILBL-FMT-LINE(4) DESBR901 00591 MOVE BLD1-LINE-5 TO ILBL-FMT-LINE(5) DESBR901 00592 MOVE BLD1-LINE-6 TO ILBL-FMT-LINE(6) DESBR901 00593 MOVE BLD1-LINE-7 TO ILBL-FMT-LINE(7) DESBR901 00594 MOVE SPACES TO ILBL-FMT-LINE(8) DESBR901 00595 PERFORM S946-WRITE THRU S946-EXIT. DESBR901 00596 P7000-EXIT. DESBR901 00597 EXIT. DESBR901 00598 DESBR901 00599 P8000-BREAK-LABEL2. DESBR901 00600 DESBR901 00601 MOVE BLD2-LINE-1 TO ILBL-FMT-LINE(1) DESBR901 00602 MOVE SPACES TO ILBL-FMT-LINE(2) DESBR901 00603 MOVE BLD2-LINE-3 TO ILBL-FMT-LINE(3) DESBR901 00604 MOVE BLD2-LINE-4 TO ILBL-FMT-LINE(4) DESBR901 00605 MOVE BLD2-LINE-5 TO ILBL-FMT-LINE(5) DESBR901 00606 MOVE BLD2-LINE-6 TO ILBL-FMT-LINE(6) DESBR901 00607 MOVE BLD2-LINE-7 TO ILBL-FMT-LINE(7) DESBR901 00608 MOVE SPACES TO ILBL-FMT-LINE(8) DESBR901 00609 PERFORM S946-WRITE THRU S946-EXIT. DESBR901 00610 P8000-EXIT. DESBR901 00611 EXIT. DESBR901 00612 DESBR901 00613 T1000-TERMINATE. DESBR901 00614 DESBR901 00615 MOVE -1 TO ILBL-LENGTH. DESBR901 00616 PERFORM S946-WRITE THRU S946-EXIT. DESBR901 00617 * IF RPT1-OPEN-SW = 'Y' DESBR901 00618 * CLOSE PRT-FILE1 DESBR901 00619 * ELSE DESBR901 00620 * CLOSE PRT-FILE2. DESBR901 00621 DESBR901 00622 T1000-EXIT. DESBR901 00623 EXIT. DESBR901 00624 EJECT DESBR901 00625 S071-DESLASH-NAME. DESBR901 00626 DESBR901 00627 CALL 'DTSBU071' USING L071-LINK-AREA. DESBR901 00628 DESBR901 00629 S071-EXIT. DESBR901 00630 EXIT. DESBR901 00631 DESBR901 00632 S082-OP-ID-NAME. DESBR901 00633 DESBR901 00634 CALL 'DTSBU082' USING L082-LINK-AREA. DESBR901 00635 DESBR901 00636 S082-EXIT. DESBR901 00637 EXIT. DESBR901 00638 DESBR901 00639 S083-UPPERCASE-CHG. DESBR901 00640 DESBR901 00641 CALL 'DTSBU009' USING L009-DATA. DESBR901 00642 DESBR901 00643 S083-EXIT. DESBR901 00644 EXIT. DESBR901 00645 DESBR901 00646 DESBR901 00647 S946-WRITE. DESBR901 00648 DESBR901 00649 CALL 'DOESU946' USING ILBL-LINK-AREA. DESBR901 00650 DESBR901 00651 S946-EXIT. DESBR901 00652 EXIT. DESBR901 00653 DESBR901 00654 S999-ABEND. DESBR901 00655 DESBR901 00656 CALL 'DTSBU999' USING WRK-ABEND-CD. DESBR901 00657 DESBR901 00658 S999-EXIT. DESBR901 00659 EXIT. DESBR901