DATA IGNORED - IN CONTROL MODE @PL1,EBS ,$R SWAPSIZE=80,TEXTSIZE=2044,INFOSIZE=896 PL1 10R1-1 S75R3H 06/08/99 10:48:44 1. 0 1 %INCLUDE(PP.COPY/DRIVER); 1I PP_TARGET: 2I PROC OPTIONS(MAIN); 3I 1 2 DCL LV$ BIT INIT('0'B); 4I 1 3 DCL HV$ BIT INIT('1'B); 5I 1 4 DCL RFT_SW BIT INIT('0'B); 6I 1 5 DCL SELECT_SW BIT ALIGNED; 7I 1 6 DCL EOP_SW BIT; 8I 1 7 DCL PAGE_SW BIT; 9I 1 8 DCL CSF_STATUS BIT(36); 10I 1 9 DCL OLD_# INIT(0); 11I 1 10 DCL CALL_SW INIT(0); 12I 1 11 DCL CALL_SWW DEF(CALL_SW); 13I 1 12 DCL SELECT_# INIT(0); 14I 1 13 DCL I_G_T INIT(0); 15I 1 14 DCL # INIT(0); 16I 1 15 DCL PRINT_# INIT(0); 17I 1 16 DCL LINE_# INIT(0); 18I 1 17 DCL PAGE_# INIT(0); 19I 1 18 DCL OUTPUT_# INIT(0); 20I 1 19 DCL (SORT_TIC,SORT_TOC) INIT(0); 21I 1 20 DCL RF_# INIT(0) ALIGNED STATIC; 22I 1 21 DCL #_RLS ; 23I 1 22 DCL (CPU_IN,CPU_OUT); 24I 1 23 DCL AS_RANK(0:0) INIT(0); 25I 1 24 DCL PRINT_LINE CHAR(132); 26I 1 25 DCL $W INPUT RECORD; 27I 1 26 DCL $W_REC CHAR(132) VAR; 28I 1 27 DCL SKIPS$ BIT(1000); 29I 1 28 DCL O_11 CHAR INIT(SUBSTR(COLLATE(),10,1)); 30I 1 29 DCL PL1ACSF$ ENTRY(CHAR(*),BIT(36)); 31I 1 30 DCL PP_DATE CHAR(08); 32I 1 31 DCL PP_TIME CHAR(08); 33I 1 32 PP_DATE=SUBSTR(DATE(),3,2)!!'/'!! 34I SUBSTR(DATE(),5,2)!!'/'!! 35I SUBSTR(DATE(),1,2); 36I 1 33 PP_TIME=SUBSTR(TIME(),1,2)!!':'!! 37I SUBSTR(TIME(),3,2)!!':'!! 38I SUBSTR(TIME(),5,2); 39I 1 34 DCL WRITETABLE FILE OUTPUT RECORD ENV(RECSIZE(40)); 40I 1 35 DCL WT_L CHAR(160) INIT((160)' '); 41I 1 36 DCL CHAR4$ CHAR(4); 42I 1 37 DCL PCT_0 CHAR(1280); 43I 1 38 DCL UREC CHAR(112); 44I 1 39 DCL OLDCRD_X CHAR(42) INIT(' '); 45I 1 40 DCL USERID_X CHAR(12), 46I DATEIN_X CHAR(06), 47I TIMEIN_X CHAR(06), 48I TIMEOU_X CHAR(06), 49I CPUTOT_X PIC'9999999999', 50I CPUSRT_X PIC'9999999999', 51I READSM_X PIC'9999999999', 52I SELTSM_X PIC'9999999999'; 53I 1 41 BEGIN_PP: 54I IF (^RUN_SW) 55I THEN DO; 56I 1 1 43 PUT EDIT('** PL1TAX ERROR DETECTED IN PREPROCESSOR PHASE **', 57I '** PL1TAX EXECUTION SUPPRESSED **') 58I (SKIP,A); 59I 1 1 44 PUT SKIP; 60I 1 1 45 STOP; 61I 1 1 46 END; 62I 1 47 /* 63I ON ERROR BEGIN; 64I PUT PAGE; 65I PUT DATA; 66I STOP; 67I RETURN; 68I END; 69I */ 70I CPU_IN=CPUTIC(); 71I 1 48 DATEIN_X=DATE(); 72I 1 49 TIMEIN_X=TIME(); 73I 1 50 CALL PCT_SNAP(1); 74I 1 51 CALL LIST_SOURCE; 75I 1 52 CALL LOAD_TITLES; 76I 1 53 CALL LOAD_FUNCTIONS; 77I 1 54 CALL LOAD_SUBTITLES; 78I 1 55 CALL PP_OUTPUTS; 79I 1 56 CALL OPEN_OUTPUT_FILES; 80I 1 57 I_G_T=1; 81I 1 58 IF (PRINT_SW) 82I THEN DO; 83I 1 1 60 CALL PP_PAGING; 84I 1 1 61 CALL PP_SUBTITLES; 85I 1 1 62 END; 86I 1 63 CALL PP_INITIALIZATION; 87I 1 64 CALL PP_PROGRAM; 88I 1 65 CALL PP_TERMINATION; 89I 1 66 I_G_T=2; 90I 1 67 CALL CLOSE_OUTPUT_FILES; 91I 1 68 CALL PP_OUTPUTS; 92I 1 69 LINE_#=0; 93I 1 70 CALL PP_PAGING; 94I 1 71 CALL PP_PROGRAM; 95I 1 72 CPU_OUT=CPUTIC(); 96I 1 73 TIMEOU_X=TIME(); 97I 1 74 CALL WRAP_UP; 98I 1 75 CALL PCT_SNAP(2); 99I 1 76 LIST_SOURCE: 100I PROC; 101I 2 77 DCL $SW RECORD INPUT; 102I 2 78 DCL $SW_REC CHAR(80) VAR; 103I 2 79 DCL $SW_# INIT(0); 104I 2 80 PUT EDIT('$PL1TAX VER 2 '!!PP_DATE!!' '!!PP_TIME,' ') (COL(1),A); 105I 2 81 DCL EOF_$SW BIT INIT('0'B); 106I 2 82 ON ENDFILE($SW) EOF_$SW=HV$; 107I 2 83 OPEN FILE($SW); 108I 2 84 READ FILE($SW) INTO($SW_REC); 109I 2 85 DO WHILE(^EOF_$SW); 110I 2 1 86 CALL GETOLDCARD($SW_REC); 111I 2 1 87 $SW_#=$SW_#+1; 112I 2 1 88 IF (MOD($SW_#-1,50)=0) 113I THEN PUT EDIT('** PL1TAX SOURCE LISTING **', 114I ' # STATEMENT',' ') 115I (PAGE,A,SKIP(2),A,SKIP,A); 116I 2 1 90 PUT EDIT($SW_#,'. ',$SW_REC) (SKIP,F(6),A,A); 117I 2 1 91 READ FILE($SW) INTO($SW_REC); 118I 2 1 92 END; 119I 2 93 CLOSE FILE($SW); 120I 2 94 PUT EDIT('** $PL1TAX SOURCE LISTING **') (SKIP(2),A); 121I 2 95 END LIST_SOURCE; 122I 1 96 WRAP_UP: 123I PROC; 124I 2 97 DCL I; 125I 2 98 DCL (F,FOLD,FSEL,TCPU) FLOAT; 126I 2 99 PUT EDIT('** PL1TAX OUTPUT FILE COUNTS **') (SKIP(2),A); 127I 2 100 DO I=1 TO #_OFILES; 128I 2 1 101 PUT EDIT('** '!!O_FILES(I),OFILE_#S(I),' WRITTEN') 129I (SKIP(2),A(16),F(10),A); 130I 2 1 102 END; 131I 2 103 IF (PRINT_#>0) 132I THEN PUT EDIT('** LINES',PRINT_#,' PRINTED') 133I (SKIP(2),A(16),F(10),A); 134I 2 105 IF (RF_#>0) 135I THEN PUT EDIT('** RECORDS',RF_#,' SORTED') 136I (SKIP(2),A(16),F(10),A); 137I 2 107 CPUTOT_X=CPU_OUT-CPU_IN; 138I 2 108 F=200*(CPU_OUT-CPU_IN); 139I 2 109 F=F/1000000.; 140I 2 110 TCPU=F; 141I 2 111 PUT EDIT('** CPU TIME',F,' SECONDS') 142I (SKIP(2),A(14),F(12,4),A); 143I 2 112 FOLD=OLD_#; 144I 2 113 FSEL=SELECT_#; 145I 2 114 IF (FOLD>0.) 146I THEN FOLD=1000.*F/FOLD; 147I 2 116 IF (FSEL>0.) 148I THEN FSEL=1000.*F/FSEL; 149I 2 118 PUT EDIT('** CPU/RECORD',FOLD,' MILLISECONDS') 150I (SKIP(1),A(16),F(10,4),A); 151I 2 119 PUT EDIT('** CPU/SELECT',FSEL,' MILLISECONDS') 152I (SKIP(1),A(16),F(10,4),A); 153I 2 120 CPUSRT_X=SORT_TOC-SORT_TOC; 154I 2 121 F=200*(SORT_TOC-SORT_TIC); 155I 2 122 F=F/1000000.; 156I 2 123 IF (F>0.) 157I THEN PUT EDIT('** CPU SORT TIME',F,' SECONDS') 158I (SKIP,A(17),F(9,4),A); 159I 2 125 IF (RF_#=0) 160I THEN F=0.; 161I 2 127 ELSE DO; 162I 2 1 128 FOLD=RF_#; 163I 2 1 129 F=(F*1000.)/FOLD; 164I 2 1 130 END; 165I 2 131 IF (F>0.) 166I THEN PUT EDIT('** CPU SORT/REC',F,' MILLISECONDS') 167I (SKIP,A(16),F(10,4),A); 168I 2 133 PUT EDIT('** PL1TAX START '!!PP_DATE!!' '!!PP_TIME!!' **') 169I (SKIP(2),A); 170I 2 134 PUT EDIT('** PL1TAX END '!!SUBSTR(DATE(),3,2)!!'/'!! 171I SUBSTR(DATE(),5,2)!!'/'!! 172I SUBSTR(DATE(),1,2)!!' '!! 173I SUBSTR(TIME(),1,2)!!':'!! 174I SUBSTR(TIME(),3,2)!!':'!! 175I SUBSTR(TIME(),5,2)!!' **') 176I (SKIP(2),A); 177I 2 135 DCL (SHH,SMM,SSS, 178I EHH,EMM,ESS, 179I THH,TMM,TSS,SC,MC) PIC'99'; 180I 2 136 SHH=SUBSTR(PP_TIME,1,2); 181I 2 137 SMM=SUBSTR(PP_TIME,4,2); 182I 2 138 SSS=SUBSTR(PP_TIME,7,2); 183I 2 139 EHH=SUBSTR(TIME(),1,2); 184I 2 140 EMM=SUBSTR(TIME(),3,2); 185I 2 141 ESS=SUBSTR(TIME(),5,2); 186I 2 142 SC=0; 187I 2 143 IF (ESS < SSS) 188I THEN DO; 189I 2 1 145 TSS=(60-SSS)+ESS; 190I 2 1 146 SC=1; 191I 2 1 147 END; 192I 2 148 ELSE TSS=ESS-SSS; 193I 2 149 MC=0; 194I 2 150 IF (EMM + SC < SMM) 195I THEN DO; 196I 2 1 152 TMM=(60-SMM)+EMM-SC; 197I 2 1 153 MC=1; 198I 2 1 154 END; 199I 2 155 ELSE TMM=EMM-SMM-SC; 200I 2 156 IF (EHH + MC < SHH) 201I THEN THH=24+EHH-SHH-MC; 202I 2 158 ELSE THH=EHH-SHH-MC; 203I 2 159 PUT EDIT('** PL1TAX TOTAL '!!SUBSTR(DATE(),3,2)!!'/'!! 204I SUBSTR(DATE(),5,2)!!'/'!! 205I SUBSTR(DATE(),1,2)!!' '!! 206I THH!!':'!!TMM!!':'!!TSS!!' **') 207I (SKIP(2),A); 208I 2 160 F=TSS+60*TMM+3600*THH; 209I 2 161 IF (F>0.) THEN F=100.*TCPU/F; 210I 2 163 PUT EDIT('** CPU/TOTAL',F,' PERCENT') 211I (SKIP(2),A(16),F(10,7),A); 212I 2 164 CALL PUT_LOG; 213I 2 165 END WRAP_UP; 214I 1 166 CPUTIC: 215I PROC RETURNS(BIN); 216I 2 167 DCL ERPCT2 ENTRY(BIN,CHAR(4),BIN); 217I 2 168 DCL X STATIC CHAR(4); 218I 2 169 CALL ERPCT2(1,X,22); 219I 2 170 RETURN(UNSPEC(X)); 220I 2 171 END CPUTIC; 221I 1 172 PP_PAGING: 222I PROC; 223I 2 173 IF (MOD(LINE_#,#LINE_#)=0) 224I THEN DO; 225I 2 1 175 PUT PAGE; 226I 2 1 176 PAGE_SW=HV$; 227I 2 1 177 LINE_#=1; 228I 2 1 178 CALL PP_TITLES; 229I 2 1 179 RETURN; 230I 2 1 180 END; 231I 2 181 PUT SKIP; 232I 2 182 PAGE_SW=LV$; 233I 2 183 LINE_#=LINE_#+1; 234I 2 184 END PP_PAGING; 235I 1 185 LOAD_TITLES: 236I PROC; 237I 2 186 CALL READ_$W(TITLES$,#_TITLES); 238I 2 187 END LOAD_TITLES; 239I 1 188 LOAD_SUBTITLES: 240I PROC; 241I 2 189 CALL READ_$W(SUBTITLES,#_SUBTITLES); 242I 2 190 END LOAD_SUBTITLES; 243I 1 191 PP_TITLES: 244I PROC; 245I 2 192 CALL PP_PAGE; 246I 2 193 DO #=1 TO #_TITLES; 247I 2 1 194 PUT EDIT(TITLES$(#)) (A); 248I 2 1 195 PUT SKIP; 249I 2 1 196 END; 250I 2 197 LINE_#=LINE_#+#_TITLES; 251I 2 198 END PP_TITLES; 252I 1 199 PP_SUBTITLES: 253I PROC; 254I 2 200 DO #=1 TO #_SUBTITLES; 255I 2 1 201 PUT EDIT(SUBTITLES(#)) (A); 256I 2 1 202 PUT SKIP; 257I 2 1 203 END; 258I 2 204 LINE_#=LINE_#+#_SUBTITLES; 259I 2 205 END PP_SUBTITLES; 260I 1 206 READ_$W: 261I PROC(ARRAY,I); 262I 2 207 DCL ARRAY(*) CHAR(*); 263I 2 208 DCL I ; 264I 2 209 DO #=1 TO I; 265I 2 1 210 READ FILE($W) INTO($W_REC); 266I 2 1 211 ARRAY(#)=$W_REC; 267I 2 1 212 END; 268I 2 213 END READ_$W; 269I 1 214 READV_$W: 270I PROC(ARRAY,I); 271I 2 215 DCL ARRAY(*) CHAR(*) VAR; 272I 2 216 DCL I ; 273I 2 217 DO #=1 TO I; 274I 2 1 218 READ FILE($W) INTO($W_REC); 275I 2 1 219 ARRAY(#)=$W_REC; 276I 2 1 220 END; 277I 2 221 END READV_$W; 278I 1 222 RANK_AS: 279I PROC(ARRAY,I); 280I 2 223 DCL ARRAY(*) ; 281I 2 224 DCL I ; 282I 2 225 DO #=0 TO I; 283I 2 1 226 ARRAY(#)=#; 284I 2 1 227 END; 285I 2 228 END RANK_AS; 286I 1 229 NUMERIC$: 287I PROC(I) RETURNS(CHAR(200) VARYING); 288I 2 230 DCL I ; 289I 2 231 DCL J STATIC; 290I 2 232 DCL STRING STATIC CHAR(200); 291I 2 233 STRING=''; 292I 2 234 DO J=1 TO I; 293I 2 1 235 SUBSTR(STRING,J,1)=SUBSTR('0123456789',RND_#(10),1); 294I 2 1 236 END; 295I 2 237 RETURN(SUBSTR(STRING,1,I)); 296I 2 238 END NUMERIC$; 297I 1 239 ANUMERIC$: 298I PROC(I) RETURNS(CHAR(200) VARYING); 299I 2 240 DCL I ; 300I 2 241 DCL J STATIC; 301I 2 242 DCL STRING STATIC CHAR(200); 302I 2 243 STRING=''; 303I 2 244 DO J=1 TO I; 304I 2 1 245 SUBSTR(STRING,J,1)=SUBSTR('ABCDEFGHIJKLMNOPQRSTUVWXYZ'!! 305I '0123456789',RND_#(36),1); 306I 2 1 246 END; 307I 2 247 RETURN(SUBSTR(STRING,1,I)); 308I 2 248 END ANUMERIC$; 309I 1 249 ALPHA$: 310I PROC(I) RETURNS(CHAR(200) VARYING); 311I 2 250 DCL I ; 312I 2 251 DCL J STATIC; 313I 2 252 DCL STRING STATIC CHAR(200); 314I 2 253 STRING=''; 315I 2 254 DO J=1 TO I; 316I 2 1 255 SUBSTR(STRING,J,1)=SUBSTR('ABCDEFGHIJKLMNOPQRSTUVWXYZ',RND_#(26),1); 317I 2 1 256 END; 318I 2 257 RETURN(SUBSTR(STRING,1,I)); 319I 2 258 END ALPHA$; 320I 1 259 RND_#: 321I PROC(I) RETURNS(); 322I 2 260 DCL I ; 323I 2 261 DCL $SEED STATIC FLOAT INIT(1.13); 324I 2 262 $SEED=$SEED+.317; 325I 2 263 RETURN(MOD(ABS(100000000.*SIN($SEED)),I)+1.); 326I 2 264 END RND_#; 327I 1 265 PP_TRACE: 328I PROC(ST$); 329I 2 266 DCL ST$ CHAR(80) VAR; 330I 2 267 PUT EDIT(ST$) (COL(1),A); 331I 2 268 PUT SKIP; 332I 2 269 END PP_TRACE; 333I 1 270 GET_PCTSTR: 334I PROC(PCTSTR); 335I 2 271 ENTRYS: 336I DCL PCTSTR CHAR(640); 337I 2 272 DCL PL1PCT$ ENTRY(CHAR(*),BIN) OPTIONS(ASM); 338I 2 273 BEGIN_GETPCTSTR: 339I CALL PL1PCT$(PCTSTR,160); 340I 2 274 END GET_PCTSTR; 341I 1 275 PCT_SNAP: 342I PROC(N); 343I 2 276 DCL N ; 344I 2 277 FILES: 345I DCL OUT FILE RECORD OUTPUT; 346I 2 278 DCL OUTREC CHAR(1280); 347I 2 279 DECLARES: 348I DCL PCT_1 CHAR(640); 349I 2 280 DCL STATUS BIT(36); 350I 2 281 BEGIN_PCT_SNAP: 351I RETURN; 352I 2 282 CALL GET_PCTSTR(PCT_1); 353I 2 283 IF (N=1) THEN 354I DO; 355I 2 1 285 PCT_0=PCT_1; 356I 2 1 286 RETURN; 357I 2 1 287 END; 358I 2 288 SUBSTR(PCT_0,641,640)=PCT_1; 359I 2 289 CALL PL1ACSF$('@ASG,AX SS*PL1TAXPCTLOG.',STATUS); 360I 2 290 361I OPEN FILE(OUT) TITLE('SS*PL1TAXPCTLOG.') ENV(RECSIZE(320),EXTEND); 362I 2 291 /* 363I OPEN FILE(OUT) TITLE('SS*PL1TAXPCTLOG.') ENV(RECSIZE(320)); 364I */ 365I WRITE FILE(OUT) FROM(PCT_0); 366I 2 292 CLOSE FILE(OUT); 367I 2 293 CALL PL1ACSF$('@FREE SS*PL1TAXPCTLOG.',STATUS); 368I 2 294 END PCT_SNAP; 369I 1 295 GETOLDCARD: 370I PROC(S$); 371I 2 296 DCL S$ CHAR(80) VAR; 372I 2 297 DCL IM ; 373I 2 298 IF (OLDCRD_X^='') THEN RETURN; 374I 2 300 IM=MAX(INDEX(S$,'OLD '),INDEX(S$,'INPUT ')); 375I 2 301 IF (IM>0)& 376I (IM<9) 377I THEN OLDCRD_X=S$; 378I 2 303 END GETOLDCARD; 379I 1 304 PUT_LOG: 380I PROC; 381I 2 305 DCL PL1$FD2ASC ENTRY(PTR,CHAR(12)); 382I 2 306 DCL PL1PCT$ ENTRY(CHAR(*),BIN) OPTIONS(ASM); 383I 2 307 DCL OUT FILE RECORD OUTPUT; 384I 2 308 DCL STATUS BIT(36); 385I 2 309 DCL P12 BIT(72) ALIGNED; 386I 2 310 DCL C8 CHAR(8); 387I 2 311 CALL PL1PCT$(C8,2); 388I 2 312 P12=UNSPEC(C8); 389I 2 313 CALL PL1$FD2ASC(ADDR(P12),USERID_X); 390I 2 314 READSM_X=OLD_#; 391I 2 315 SELTSM_X=SELECT_#; 392I 2 316 CALL PL1ACSF$('@ASG,AX SS*PL1TAXLOG.',STATUS); 393I 2 317 OPEN FILE(OUT) TITLE('SS*PL1TAXLOG.') ENV(RECSIZE(28),EXTEND); 394I 2 318 UREC= USERID_X!!DATEIN_X!!TIMEIN_X!!TIMEOU_X!! 395I CPUTOT_X!!CPUSRT_X!!READSM_X!!SELTSM_X!! 396I OLDCRD_X; 397I 2 319 WRITE FILE(OUT) FROM(UREC); 398I 2 320 CLOSE FILE(OUT); 399I 2 321 CALL PL1ACSF$('@FREE SS*PL1TAXLOG.',STATUS); 400I 2 322 END PUT_LOG; 401I 1 323 %PAGE; 2. PP_FILES: 3. DCL OLD FILE INPUT RECORD ENV(RECSIZE(20),BLKSIZE(3584)); 4. 1 324 OPEN_OLD: 5. PROC; 6. 2 325 OPEN FILE(OLD) TITLE(OLD_TITLE); 7. 2 326 END OPEN_OLD; 8. 1 327 DCL OLDV_SW BIT INIT('0'B); 9. 1 328 DCL OLD_TITLE CHAR(13) INIT('PL1TAXDATA.'); 10. 1 329 DCL OLD_BUF CHAR(80) DEF(OLDREC) ALIGNED; 11. 1 330 DCL OLDREC CHAR(80) ALIGNED; 12. 1 331 DCL DATA CHAR(80) DEF(OLDREC) ALIGNED; 13. 1 332 DCL O_FILES(1) CHAR(12) INIT(''); 14. 1 333 DCL OFILE_#S(1) INIT(0); 15. 1 334 DCL #_OFILES INIT(0); 16. 1 335 OPEN_OUTPUT_FILES: 17. PROC; 18. 2 336 END OPEN_OUTPUT_FILES; 19. 1 337 CLOSE_OUTPUT_FILES: 20. PROC; 21. 2 338 END CLOSE_OUTPUT_FILES; 22. 1 339 DCL LIMIT_# INIT(99999999); 23. 1 340 DCL OLDNULL_SW BIT INIT('0'B); 24. 1 341 PP_PAGE: 25. PROC; 26. 2 342 PAGE_#=PAGE_#+1; 27. 2 343 END PP_PAGE; 28. 1 344 DCL TITLES$(1) CHAR(132); 29. 1 345 DCL #_TITLES INIT(0); 30. 1 346 DCL PAGE_## INIT(132); 31. 1 347 DCL #LINE_# INIT(57); 32. 1 348 DCL CT CHAR(8) INIT(''); 33. 1 349 DCL LSSN CHAR(11) INIT(''); 34. 1 350 DCL LASTNAME DEF(OLDREC) POS(1) CHAR(12); 35. 1 351 DCL FLLNAME DEF(OLDREC) POS(1) CHAR(1); 36. 1 352 DCL FIRSTNAME DEF(OLDREC) POS(13) CHAR(8); 37. 1 353 DCL AGE DEF(OLDREC) POS(21) CHAR(2); 38. 1 354 DCL RACE DEF(OLDREC) POS(23) CHAR(1); 39. 1 355 DCL SEX DEF(OLDREC) POS(24) CHAR(1); 40. 1 356 DCL COUNTY DEF(OLDREC) POS(25) CHAR(2); 41. 1 357 DCL COMPANY DEF(OLDREC) POS(27) CHAR(10); 42. 1 358 DCL PHONE DEF(OLDREC) POS(37) CHAR(10); 43. 1 359 DCL AREACODE DEF(OLDREC) POS(37) CHAR(3); 44. 1 360 DCL SSN DEF(OLDREC) POS(47) CHAR(9); 45. 1 361 DCL SALARY DEF(OLDREC) POS(56) PIC'99999'; 46. 1 362 PP_VARIABLES: 47. PROC; 48. 2 363 SUBSTR(LPHONE,1,1)='('; 49. 2 364 SUBSTR(LPHONE,2,3)=SUBSTR(OLDREC,37,3); 50. 2 365 SUBSTR(LPHONE,5,2)=') '; 51. 2 366 SUBSTR(LPHONE,7,3)=SUBSTR(OLDREC,40,3); 52. 2 367 SUBSTR(LPHONE,10,1)='-'; 53. 2 368 SUBSTR(LPHONE,11,4)=SUBSTR(OLDREC,43,4); 54. 2 369 END PP_VARIABLES; 55. 1 370 DCL VAR_SW BIT INIT('1'); 56. 1 371 DCL LPHONE CHAR(14); 57. 1 372 PP_INITIALIZATION: 58. PROC; 59. 2 373 END PP_INITIALIZATION; 60. 1 374 %PAGE; 61. %INCLUDE(PP.COPY/READ); 1I PP_PROGRAM: 2I PROC; 3I 2 375 DCL EOF_OLD BIT INIT('0'B); 4I 2 376 ON ENDFILE(OLD) EOF_OLD='1'B; 5I 2 377 IF (I_G_T=2) 6I THEN DO; 7I 2 1 379 PUT EDIT('** PL1TAX INSTRUCTIONS/READ COUNTS **') (SKIP(2),A) 8I ('** OLD',OLD_#,' READ') (SKIP(2),A(16),F(10),A) 9I ('** OLD',SELECT_#,' SELECTED') (SKIP(2),A(16),F(10),A); 10I 2 1 380 RETURN; 11I 2 1 381 END; 12I 2 382 OLD_#,SELECT_#=0; 13I 2 383 CALL OPEN_OLD; 14I 2 384 READ FILE(OLD) INTO(OLD_BUF); 15I 2 385 DO WHILE(^EOF_OLD); 16I 2 1 386 IF (OLDV_SW) THEN OLDREC=OLD_BUF; 17I 2 1 388 OLD_#=OLD_#+1; 18I 2 1 389 SELECT_SW=HV$; 19I 2 1 390 IF (VAR_SW) THEN CALL PP_VARIABLES; 20I 2 1 392 IF (SELECT_SW) THEN CALL READ_PROCESS; 21I 2 1 394 IF (SELECT_SW) 22I THEN DO; 23I 2 2 396 SELECT_#=SELECT_#+1; 24I 2 2 397 IF (OUT_SW) THEN CALL PP_OUTPUTS; 25I 2 2 399 END; 26I 2 1 400 READ FILE(OLD) INTO(OLD_BUF); 27I 2 1 401 IF (OLD_#=LIMIT_#) THEN EOF_OLD='1'B; 28I 2 1 403 END; 29I 2 404 CLOSE FILE(OLD); 30I 2 405 RETURN; 31I 2 406 READ_PROCESS: 32I PROC; 62. 3 407 IF (((COUNTY>='00')& 63. (COUNTY<='24'))) 64. THEN DO; 65. 3 1 409 CT='COSTAL'; 66. 3 1 410 END; 67. 3 411 ELSE 68. IF (((COUNTY>='25')& 69. (COUNTY<='40'))) 70. THEN DO; 71. 3 1 413 CT='VALLEY'; 72. 3 1 414 END; 73. 3 415 ELSE 74. IF (((COUNTY>='41')& 75. (COUNTY<='57'))) 76. THEN DO; 77. 3 1 417 CT='MOUNTAIN'; 78. 3 1 418 END; 79. 3 419 ELSE DO; 80. 3 1 420 CT='LAST'; 81. 3 1 421 END; 82. 3 422 IF ((COMPANY='IBM')) 83. THEN DO; 84. 3 1 424 CALL_SW=1; 85. 3 1 425 CALL TABLE_IBMTABLE; 86. 3 1 426 CALL_SWW=0; 87. 3 1 427 END; 88. 3 428 END READ_PROCESS; 89. 2 429 END PP_PROGRAM; 90. 1 430 PP_TERMINATION: 91. PROC; 92. 2 431 END PP_TERMINATION; 93. 1 432 DCL PRINT_SW BIT INIT('0'B); 94. 1 433 %PAGE; 95. TABLE_001: 96. PROC; 97. 2 434 %INCLUDE(PP.COPY/TABLEGEN); 1I DCL (I,J,K,L,S1#,S2#,S3#,SP#) STATIC; 2I 2 435 DCL (#HV,#LV,#MID,#MIDSV) STATIC; 3I 2 436 IF (I_G_T=1) THEN GOTO GENERATE; 4I 2 438 IF (I_G_T=2) THEN GOTO TERMINATE; 5I 2 440 IF (I_G_T=3) 6I THEN DO; 7I 2 1 442 TABLE=0; 8I 2 1 443 RETURN; 9I 2 1 444 END; 10I 2 445 ALLOC TABLE; 11I 2 446 TABLE=0; 12I 2 447 CALL INIT; 13I 2 448 RETURN; 14I 2 449 GENERATE: 15I S1#,S2#,S3#,SP#=0; 98. 2 450 IF (COUNTY>='01')& 99. (COUNTY<='24') THEN S1#=1; 100. 2 452 ELSE IF (COUNTY>='25')& 101. (COUNTY<='40') THEN S1#=2; 102. 2 454 ELSE IF (COUNTY>='41')& 103. (COUNTY<='57') THEN S1#=3; 104. 2 456 ELSE IF (COUNTY ='58') THEN S1#=4; 105. 2 458 ELSE RETURN; 106. 2 459 #MIDSV,SP#=0; 107. 2 460 #HV=SP_FOUND; 108. 2 461 IF (#HV>10) THEN #HV=10; 109. 2 463 #LV=1; 110. 2 464 DO WHILE(SP#=0); 111. 2 1 465 #MID=(#HV+#LV)/2; 112. 2 1 466 IF (#MID=#MIDSV) 113. THEN DO; 114. 2 2 468 IF (SP_FOUND=11) 115. THEN DO; 116. 2 3 470 SP#=11; 117. 2 3 471 GOTO SP_END; 118. 2 3 472 END; 119. 2 2 473 IF (SP_FOUND=10) 120. THEN DO; 121. 2 3 475 SP_FOUND,SP#=11; 122. 2 3 476 SP_RANK(SP_FOUND)=11; 123. 2 3 477 GOTO SP_END; 124. 2 3 478 END; 125. 2 2 479 SP_FOUND=SP_FOUND+1; 126. 2 2 480 SP_FROMS(SP_FOUND)=COMPANY; 127. 2 2 481 SP#,SP_RANK(SP_FOUND)=SP_FOUND; 128. 2 2 482 DO I=1 TO SP_FOUND-1; 129. 2 3 483 IF (COMPANY<SP_FROMS(SP_RANK(I))) 130. THEN DO; 131. 2 4 485 DO J=SP_FOUND-1 TO I BY -1; 132. 2 5 486 SP_RANK(J+1)=SP_RANK(J); 133. 2 5 487 END; 134. 2 4 488 SP_RANK(I),I=SP_FOUND; 135. 2 4 489 GOTO SP_END; 136. 2 4 490 END; 137. 2 3 491 END; 138. 2 2 492 GOTO SP_END; 139. 2 2 493 END; 140. 2 1 494 #MIDSV=#MID; 141. 2 1 495 IF (COMPANY=SP_FROMS(SP_RANK(#MID))) 142. THEN DO; 143. 2 2 497 SP#=SP_RANK(#MID); 144. 2 2 498 GOTO SP_END; 145. 2 2 499 END; 146. 2 1 500 IF (COMPANY<SP_FROMS(SP_RANK(#MID))) 147. THEN #HV=#MID-1; 148. 2 1 502 ELSE #LV=#MID+1; 149. 2 1 503 END; 150. 2 504 SP_END: 151. TABLE(S1#,SP#)=TABLE(S1#,SP#)+1; 152. 2 505 RETURN; 153. 2 506 INIT: 154. PROC; 155. 3 507 CALL READ_$W(TABLEHEADS,2); 156. 3 508 CALL READ_$W(TABLEFOOTS,0); 157. 3 509 CALL READV_$W(S1_LABS,4); 158. 3 510 CALL READ_$W(S1_FROMS,4); 159. 3 511 CALL RANK(S1_FROMS,4,S1_RANK); 160. 3 512 CALL READ_$W(S1_TOS,4); 161. 3 513 END INIT; 162. 2 514 TERMINATE: 163. DCL TABLEHEADS(2) STATIC CHAR(132); 164. 2 515 DCL TABLEFOOTS(0:0) STATIC CHAR(132); 165. 2 516 DCL S1_RANK(0:4) STATIC; 166. 2 517 DCL S1_LABS(0:4) STATIC CHAR(56) VAR; 167. 2 518 CALL RANK_AS(S1_RANK,4); 168. 2 519 DCL S1_FROMS(4) STATIC CHAR(2); 169. 2 520 DCL S1_TOS(4) STATIC CHAR(2); 170. 2 521 DCL SP_RANK(0:11) STATIC; 171. 2 522 DCL SP_LABS(0:11) STATIC CHAR(56) VAR; 172. 2 523 DCL SP_FROMS(11) STATIC CHAR(10); 173. 2 524 DCL SP_FOUND STATIC INIT(0); 174. 2 525 SP#=SP_FOUND; 175. 2 526 DO I=1 TO SP#; 176. 2 1 527 SP_LABS(I)=SP_FROMS(I); 177. 2 1 528 END; 178. 2 529 SP_LABS(11)=COPY('/',10); 179. 2 530 DCL TABLE(0:4,0:11) CTL; 180. 2 531 DCL OPTIONS STATIC BIT(36) 181. INIT('0000000000'B); 182. 2 532 SKIPS$=LV$; 183. 2 533 CALL PRINT_TABLE1(TABLE,TABLEHEADS,TABLEFOOTS, 184. 'COUNTY',S1_LABS,S1_RANK,4,0, 185. 'COMPANY',SP_LABS,SP_RANK,SP#,0,SP#, 186. OPTIONS); 187. 2 534 END TABLE_001; 188. 1 535 %PAGE; 189. TABLE_002: 190. PROC; 191. 2 536 %INCLUDE(PP.COPY/TABLEGEN); 1I DCL (I,J,K,L,S1#,S2#,S3#,SP#) STATIC; 2I 2 537 DCL (#HV,#LV,#MID,#MIDSV) STATIC; 3I 2 538 IF (I_G_T=1) THEN GOTO GENERATE; 4I 2 540 IF (I_G_T=2) THEN GOTO TERMINATE; 5I 2 542 IF (I_G_T=3) 6I THEN DO; 7I 2 1 544 TABLE=0; 8I 2 1 545 RETURN; 9I 2 1 546 END; 10I 2 547 ALLOC TABLE; 11I 2 548 TABLE=0; 12I 2 549 CALL INIT; 13I 2 550 RETURN; 14I 2 551 GENERATE: 15I S1#,S2#,S3#,SP#=0; 192. 2 552 #MIDSV,S1#=0; 193. 2 553 #HV=4; 194. 2 554 #LV=1; 195. 2 555 DO WHILE(S1#=0); 196. 2 1 556 #MID=(#HV+#LV)/2; 197. 2 1 557 IF (#MID=#MIDSV) THEN GOTO S1_END; 198. 2 1 559 #MIDSV=#MID; 199. 2 1 560 IF (CT=S1_FROMS(S1_RANK(#MID))) 200. THEN DO; 201. 2 2 562 S1#=S1_RANK(#MID); 202. 2 2 563 GOTO S1_END; 203. 2 2 564 END; 204. 2 1 565 IF (CT<S1_FROMS(S1_RANK(#MID))) 205. THEN #HV=#MID-1; 206. 2 1 567 ELSE #LV=#MID+1; 207. 2 1 568 END; 208. 2 569 S1_END: 209. IF (S1#=0) THEN RETURN; 210. 2 571 #MIDSV,SP#=0; 211. 2 572 #HV=SP_FOUND; 212. 2 573 IF (#HV>10) THEN #HV=10; 213. 2 575 #LV=1; 214. 2 576 DO WHILE(SP#=0); 215. 2 1 577 #MID=(#HV+#LV)/2; 216. 2 1 578 IF (#MID=#MIDSV) 217. THEN DO; 218. 2 2 580 IF (SP_FOUND=11) 219. THEN DO; 220. 2 3 582 SP#=11; 221. 2 3 583 GOTO SP_END; 222. 2 3 584 END; 223. 2 2 585 IF (SP_FOUND=10) 224. THEN DO; 225. 2 3 587 SP_FOUND,SP#=11; 226. 2 3 588 SP_RANK(SP_FOUND)=11; 227. 2 3 589 GOTO SP_END; 228. 2 3 590 END; 229. 2 2 591 SP_FOUND=SP_FOUND+1; 230. 2 2 592 SP_FROMS(SP_FOUND)=COMPANY; 231. 2 2 593 SP#,SP_RANK(SP_FOUND)=SP_FOUND; 232. 2 2 594 DO I=1 TO SP_FOUND-1; 233. 2 3 595 IF (COMPANY<SP_FROMS(SP_RANK(I))) 234. THEN DO; 235. 2 4 597 DO J=SP_FOUND-1 TO I BY -1; 236. 2 5 598 SP_RANK(J+1)=SP_RANK(J); 237. 2 5 599 END; 238. 2 4 600 SP_RANK(I),I=SP_FOUND; 239. 2 4 601 GOTO SP_END; 240. 2 4 602 END; 241. 2 3 603 END; 242. 2 2 604 GOTO SP_END; 243. 2 2 605 END; 244. 2 1 606 #MIDSV=#MID; 245. 2 1 607 IF (COMPANY=SP_FROMS(SP_RANK(#MID))) 246. THEN DO; 247. 2 2 609 SP#=SP_RANK(#MID); 248. 2 2 610 GOTO SP_END; 249. 2 2 611 END; 250. 2 1 612 IF (COMPANY<SP_FROMS(SP_RANK(#MID))) 251. THEN #HV=#MID-1; 252. 2 1 614 ELSE #LV=#MID+1; 253. 2 1 615 END; 254. 2 616 SP_END: 255. TABLE(S1#,SP#)=TABLE(S1#,SP#)+1; 256. 2 617 RETURN; 257. 2 618 INIT: 258. PROC; 259. 3 619 CALL READ_$W(TABLEHEADS,2); 260. 3 620 CALL READ_$W(TABLEFOOTS,0); 261. 3 621 CALL READV_$W(S1_LABS,4); 262. 3 622 CALL READ_$W(S1_FROMS,4); 263. 3 623 CALL RANK(S1_FROMS,4,S1_RANK); 264. 3 624 END INIT; 265. 2 625 TERMINATE: 266. DCL TABLEHEADS(2) STATIC CHAR(132); 267. 2 626 DCL TABLEFOOTS(0:0) STATIC CHAR(132); 268. 2 627 DCL S1_RANK(0:4) STATIC; 269. 2 628 DCL S1_LABS(0:4) STATIC CHAR(56) VAR; 270. 2 629 CALL RANK_AS(S1_RANK,4); 271. 2 630 DCL S1_FROMS(4) STATIC CHAR(8); 272. 2 631 DCL SP_RANK(0:11) STATIC; 273. 2 632 DCL SP_LABS(0:11) STATIC CHAR(56) VAR; 274. 2 633 DCL SP_FROMS(11) STATIC CHAR(10); 275. 2 634 DCL SP_FOUND STATIC INIT(0); 276. 2 635 SP#=SP_FOUND; 277. 2 636 DO I=1 TO SP#; 278. 2 1 637 SP_LABS(I)=SP_FROMS(I); 279. 2 1 638 END; 280. 2 639 SP_LABS(11)=COPY('/',10); 281. 2 640 DCL TABLE(0:4,0:11) CTL; 282. 2 641 DCL OPTIONS STATIC BIT(36) 283. INIT('0000000000'B); 284. 2 642 SKIPS$=LV$; 285. 2 643 CALL PRINT_TABLE1(TABLE,TABLEHEADS,TABLEFOOTS, 286. 'COUNTY TYPE',S1_LABS,S1_RANK,4,0, 287. 'COMPANY',SP_LABS,SP_RANK,SP#,0,SP#, 288. OPTIONS); 289. 2 644 END TABLE_002; 290. 1 645 %PAGE; 291. TABLE_003: 292. PROC; 293. 2 646 %INCLUDE(PP.COPY/TABLEGEN); 1I DCL (I,J,K,L,S1#,S2#,S3#,SP#) STATIC; 2I 2 647 DCL (#HV,#LV,#MID,#MIDSV) STATIC; 3I 2 648 IF (I_G_T=1) THEN GOTO GENERATE; 4I 2 650 IF (I_G_T=2) THEN GOTO TERMINATE; 5I 2 652 IF (I_G_T=3) 6I THEN DO; 7I 2 1 654 TABLE=0; 8I 2 1 655 RETURN; 9I 2 1 656 END; 10I 2 657 ALLOC TABLE; 11I 2 658 TABLE=0; 12I 2 659 CALL INIT; 13I 2 660 RETURN; 14I 2 661 GENERATE: 15I S1#,S2#,S3#,SP#=0; 294. 2 662 #MIDSV,S1#=0; 295. 2 663 #HV=S1_FOUND; 296. 2 664 IF (#HV>5) THEN #HV=5; 297. 2 666 #LV=1; 298. 2 667 DO WHILE(S1#=0); 299. 2 1 668 #MID=(#HV+#LV)/2; 300. 2 1 669 IF (#MID=#MIDSV) 301. THEN DO; 302. 2 2 671 IF (S1_FOUND=6) 303. THEN DO; 304. 2 3 673 S1#=6; 305. 2 3 674 GOTO S1_END; 306. 2 3 675 END; 307. 2 2 676 IF (S1_FOUND=5) 308. THEN DO; 309. 2 3 678 S1_FOUND,S1#=6; 310. 2 3 679 S1_RANK(S1_FOUND)=6; 311. 2 3 680 GOTO S1_END; 312. 2 3 681 END; 313. 2 2 682 S1_FOUND=S1_FOUND+1; 314. 2 2 683 S1_FROMS(S1_FOUND)=CT; 315. 2 2 684 S1#,S1_RANK(S1_FOUND)=S1_FOUND; 316. 2 2 685 DO I=1 TO S1_FOUND-1; 317. 2 3 686 IF (CT<S1_FROMS(S1_RANK(I))) 318. THEN DO; 319. 2 4 688 DO J=S1_FOUND-1 TO I BY -1; 320. 2 5 689 S1_RANK(J+1)=S1_RANK(J); 321. 2 5 690 END; 322. 2 4 691 S1_RANK(I),I=S1_FOUND; 323. 2 4 692 GOTO S1_END; 324. 2 4 693 END; 325. 2 3 694 END; 326. 2 2 695 GOTO S1_END; 327. 2 2 696 END; 328. 2 1 697 #MIDSV=#MID; 329. 2 1 698 IF (CT=S1_FROMS(S1_RANK(#MID))) 330. THEN DO; 331. 2 2 700 S1#=S1_RANK(#MID); 332. 2 2 701 GOTO S1_END; 333. 2 2 702 END; 334. 2 1 703 IF (CT<S1_FROMS(S1_RANK(#MID))) 335. THEN #HV=#MID-1; 336. 2 1 705 ELSE #LV=#MID+1; 337. 2 1 706 END; 338. 2 707 S1_END: 339. #MIDSV,SP#=0; 340. 2 708 #HV=SP_FOUND; 341. 2 709 IF (#HV>10) THEN #HV=10; 342. 2 711 #LV=1; 343. 2 712 DO WHILE(SP#=0); 344. 2 1 713 #MID=(#HV+#LV)/2; 345. 2 1 714 IF (#MID=#MIDSV) 346. THEN DO; 347. 2 2 716 IF (SP_FOUND=11) 348. THEN DO; 349. 2 3 718 SP#=11; 350. 2 3 719 GOTO SP_END; 351. 2 3 720 END; 352. 2 2 721 IF (SP_FOUND=10) 353. THEN DO; 354. 2 3 723 SP_FOUND,SP#=11; 355. 2 3 724 SP_RANK(SP_FOUND)=11; 356. 2 3 725 GOTO SP_END; 357. 2 3 726 END; 358. 2 2 727 SP_FOUND=SP_FOUND+1; 359. 2 2 728 SP_FROMS(SP_FOUND)=COMPANY; 360. 2 2 729 SP#,SP_RANK(SP_FOUND)=SP_FOUND; 361. 2 2 730 DO I=1 TO SP_FOUND-1; 362. 2 3 731 IF (COMPANY<SP_FROMS(SP_RANK(I))) 363. THEN DO; 364. 2 4 733 DO J=SP_FOUND-1 TO I BY -1; 365. 2 5 734 SP_RANK(J+1)=SP_RANK(J); 366. 2 5 735 END; 367. 2 4 736 SP_RANK(I),I=SP_FOUND; 368. 2 4 737 GOTO SP_END; 369. 2 4 738 END; 370. 2 3 739 END; 371. 2 2 740 GOTO SP_END; 372. 2 2 741 END; 373. 2 1 742 #MIDSV=#MID; 374. 2 1 743 IF (COMPANY=SP_FROMS(SP_RANK(#MID))) 375. THEN DO; 376. 2 2 745 SP#=SP_RANK(#MID); 377. 2 2 746 GOTO SP_END; 378. 2 2 747 END; 379. 2 1 748 IF (COMPANY<SP_FROMS(SP_RANK(#MID))) 380. THEN #HV=#MID-1; 381. 2 1 750 ELSE #LV=#MID+1; 382. 2 1 751 END; 383. 2 752 SP_END: 384. TABLE(S1#,SP#)=TABLE(S1#,SP#)+1; 385. 2 753 RETURN; 386. 2 754 INIT: 387. PROC; 388. 3 755 CALL READ_$W(TABLEHEADS,2); 389. 3 756 CALL READ_$W(TABLEFOOTS,0); 390. 3 757 END INIT; 391. 2 758 TERMINATE: 392. DCL TABLEHEADS(2) STATIC CHAR(132); 393. 2 759 DCL TABLEFOOTS(0:0) STATIC CHAR(132); 394. 2 760 DCL S1_RANK(0:6) STATIC; 395. 2 761 DCL S1_LABS(0:6) STATIC CHAR(56) VAR; 396. 2 762 DCL S1_FROMS(6) STATIC CHAR(8); 397. 2 763 DCL S1_FOUND STATIC INIT(0); 398. 2 764 S1#=S1_FOUND; 399. 2 765 DO I=1 TO S1#; 400. 2 1 766 S1_LABS(I)=S1_FROMS(I); 401. 2 1 767 END; 402. 2 768 S1_LABS(6)=COPY('/',8); 403. 2 769 DCL SP_RANK(0:11) STATIC; 404. 2 770 DCL SP_LABS(0:11) STATIC CHAR(56) VAR; 405. 2 771 DCL SP_FROMS(11) STATIC CHAR(10); 406. 2 772 DCL SP_FOUND STATIC INIT(0); 407. 2 773 SP#=SP_FOUND; 408. 2 774 DO I=1 TO SP#; 409. 2 1 775 SP_LABS(I)=SP_FROMS(I); 410. 2 1 776 END; 411. 2 777 SP_LABS(11)=COPY('/',10); 412. 2 778 DCL TABLE(0:6,0:11) CTL; 413. 2 779 DCL OPTIONS STATIC BIT(36) 414. INIT('0000000000'B); 415. 2 780 SKIPS$=LV$; 416. 2 781 CALL PRINT_TABLE1(TABLE,TABLEHEADS,TABLEFOOTS, 417. 'COUNTY TYPE',S1_LABS,S1_RANK,S1_FOUND,0, 418. 'COMPANY',SP_LABS,SP_RANK,SP#,0,SP#, 419. OPTIONS); 420. 2 782 END TABLE_003; 421. 1 783 %PAGE; 422. TABLE_004: 423. PROC; 424. 2 784 %INCLUDE(PP.COPY/TABLEGEN); 1I DCL (I,J,K,L,S1#,S2#,S3#,SP#) STATIC; 2I 2 785 DCL (#HV,#LV,#MID,#MIDSV) STATIC; 3I 2 786 IF (I_G_T=1) THEN GOTO GENERATE; 4I 2 788 IF (I_G_T=2) THEN GOTO TERMINATE; 5I 2 790 IF (I_G_T=3) 6I THEN DO; 7I 2 1 792 TABLE=0; 8I 2 1 793 RETURN; 9I 2 1 794 END; 10I 2 795 ALLOC TABLE; 11I 2 796 TABLE=0; 12I 2 797 CALL INIT; 13I 2 798 RETURN; 14I 2 799 GENERATE: 15I S1#,S2#,S3#,SP#=0; 425. 2 800 #MIDSV,S1#=0; 426. 2 801 #HV=S1_FOUND; 427. 2 802 IF (#HV>10) THEN #HV=10; 428. 2 804 #LV=1; 429. 2 805 DO WHILE(S1#=0); 430. 2 1 806 #MID=(#HV+#LV)/2; 431. 2 1 807 IF (#MID=#MIDSV) 432. THEN DO; 433. 2 2 809 IF (S1_FOUND=11) 434. THEN DO; 435. 2 3 811 S1#=11; 436. 2 3 812 GOTO S1_END; 437. 2 3 813 END; 438. 2 2 814 IF (S1_FOUND=10) 439. THEN DO; 440. 2 3 816 S1_FOUND,S1#=11; 441. 2 3 817 S1_RANK(S1_FOUND)=11; 442. 2 3 818 GOTO S1_END; 443. 2 3 819 END; 444. 2 2 820 S1_FOUND=S1_FOUND+1; 445. 2 2 821 S1_FROMS(S1_FOUND)=COMPANY; 446. 2 2 822 S1#,S1_RANK(S1_FOUND)=S1_FOUND; 447. 2 2 823 DO I=1 TO S1_FOUND-1; 448. 2 3 824 IF (COMPANY<S1_FROMS(S1_RANK(I))) 449. THEN DO; 450. 2 4 826 DO J=S1_FOUND-1 TO I BY -1; 451. 2 5 827 S1_RANK(J+1)=S1_RANK(J); 452. 2 5 828 END; 453. 2 4 829 S1_RANK(I),I=S1_FOUND; 454. 2 4 830 GOTO S1_END; 455. 2 4 831 END; 456. 2 3 832 END; 457. 2 2 833 GOTO S1_END; 458. 2 2 834 END; 459. 2 1 835 #MIDSV=#MID; 460. 2 1 836 IF (COMPANY=S1_FROMS(S1_RANK(#MID))) 461. THEN DO; 462. 2 2 838 S1#=S1_RANK(#MID); 463. 2 2 839 GOTO S1_END; 464. 2 2 840 END; 465. 2 1 841 IF (COMPANY<S1_FROMS(S1_RANK(#MID))) 466. THEN #HV=#MID-1; 467. 2 1 843 ELSE #LV=#MID+1; 468. 2 1 844 END; 469. 2 845 S1_END: IF SEX='M' THEN SP#=1; 470. 2 847 ELSE IF SEX='F' THEN SP#=2; 471. 2 849 ELSE RETURN; 472. 2 850 TABLE(S1#,SP#)=TABLE(S1#,SP#)+1; 473. 2 851 RETURN; 474. 2 852 INIT: 475. PROC; 476. 3 853 CALL READ_$W(TABLEHEADS,2); 477. 3 854 CALL READ_$W(TABLEFOOTS,0); 478. 3 855 CALL READV_$W(SP_LABS,2); 479. 3 856 CALL READ_$W(SP_FROMS,2); 480. 3 857 CALL RANK(SP_FROMS,2,SP_RANK); 481. 3 858 END INIT; 482. 2 859 TERMINATE: 483. DCL TABLEHEADS(2) STATIC CHAR(132); 484. 2 860 DCL TABLEFOOTS(0:0) STATIC CHAR(132); 485. 2 861 DCL S1_RANK(0:11) STATIC; 486. 2 862 DCL S1_LABS(0:11) STATIC CHAR(56) VAR; 487. 2 863 DCL S1_FROMS(11) STATIC CHAR(10); 488. 2 864 DCL S1_FOUND STATIC INIT(0); 489. 2 865 S1#=S1_FOUND; 490. 2 866 DO I=1 TO S1#; 491. 2 1 867 S1_LABS(I)=S1_FROMS(I); 492. 2 1 868 END; 493. 2 869 S1_LABS(11)=COPY('/',10); 494. 2 870 DCL SP_RANK(0:2) STATIC; 495. 2 871 DCL SP_LABS(0:2) STATIC CHAR(56) VAR; 496. 2 872 CALL RANK_AS(SP_RANK,2); 497. 2 873 DCL SP_FROMS(2) STATIC CHAR(1); 498. 2 874 DCL TABLE(0:11,0:2) CTL; 499. 2 875 DCL OPTIONS STATIC BIT(36) 500. INIT('0000000000'B); 501. 2 876 SKIPS$=LV$; 502. 2 877 CALL PRINT_TABLE1(TABLE,TABLEHEADS,TABLEFOOTS, 503. 'COMPANY',S1_LABS,S1_RANK,S1_FOUND,0, 504. 'SEX',SP_LABS,SP_RANK,2,0,2, 505. OPTIONS); 506. 2 878 END TABLE_004; 507. 1 879 %PAGE; 508. TABLE_005: 509. PROC; 510. 2 880 %INCLUDE(PP.COPY/TABLEGEN); 1I DCL (I,J,K,L,S1#,S2#,S3#,SP#) STATIC; 2I 2 881 DCL (#HV,#LV,#MID,#MIDSV) STATIC; 3I 2 882 IF (I_G_T=1) THEN GOTO GENERATE; 4I 2 884 IF (I_G_T=2) THEN GOTO TERMINATE; 5I 2 886 IF (I_G_T=3) 6I THEN DO; 7I 2 1 888 TABLE=0; 8I 2 1 889 RETURN; 9I 2 1 890 END; 10I 2 891 ALLOC TABLE; 11I 2 892 TABLE=0; 12I 2 893 CALL INIT; 13I 2 894 RETURN; 14I 2 895 GENERATE: 15I S1#,S2#,S3#,SP#=0; 511. 2 896 #MIDSV,S1#=0; 512. 2 897 #HV=S1_FOUND; 513. 2 898 IF (#HV>10) THEN #HV=10; 514. 2 900 #LV=1; 515. 2 901 DO WHILE(S1#=0); 516. 2 1 902 #MID=(#HV+#LV)/2; 517. 2 1 903 IF (#MID=#MIDSV) 518. THEN DO; 519. 2 2 905 IF (S1_FOUND=11) 520. THEN DO; 521. 2 3 907 S1#=11; 522. 2 3 908 GOTO S1_END; 523. 2 3 909 END; 524. 2 2 910 IF (S1_FOUND=10) 525. THEN DO; 526. 2 3 912 S1_FOUND,S1#=11; 527. 2 3 913 S1_RANK(S1_FOUND)=11; 528. 2 3 914 GOTO S1_END; 529. 2 3 915 END; 530. 2 2 916 S1_FOUND=S1_FOUND+1; 531. 2 2 917 S1_FROMS(S1_FOUND)=COMPANY; 532. 2 2 918 S1#,S1_RANK(S1_FOUND)=S1_FOUND; 533. 2 2 919 DO I=1 TO S1_FOUND-1; 534. 2 3 920 IF (COMPANY<S1_FROMS(S1_RANK(I))) 535. THEN DO; 536. 2 4 922 DO J=S1_FOUND-1 TO I BY -1; 537. 2 5 923 S1_RANK(J+1)=S1_RANK(J); 538. 2 5 924 END; 539. 2 4 925 S1_RANK(I),I=S1_FOUND; 540. 2 4 926 GOTO S1_END; 541. 2 4 927 END; 542. 2 3 928 END; 543. 2 2 929 GOTO S1_END; 544. 2 2 930 END; 545. 2 1 931 #MIDSV=#MID; 546. 2 1 932 IF (COMPANY=S1_FROMS(S1_RANK(#MID))) 547. THEN DO; 548. 2 2 934 S1#=S1_RANK(#MID); 549. 2 2 935 GOTO S1_END; 550. 2 2 936 END; 551. 2 1 937 IF (COMPANY<S1_FROMS(S1_RANK(#MID))) 552. THEN #HV=#MID-1; 553. 2 1 939 ELSE #LV=#MID+1; 554. 2 1 940 END; 555. 2 941 S1_END: IF SEX='M' THEN SP#=1; 556. 2 943 ELSE IF SEX='F' THEN SP#=2; 557. 2 945 ELSE RETURN; 558. 2 946 TABLE(S1#,SP#)=TABLE(S1#,SP#)+1; 559. 2 947 RETURN; 560. 2 948 INIT: 561. PROC; 562. 3 949 CALL READ_$W(TABLEHEADS,2); 563. 3 950 CALL READ_$W(TABLEFOOTS,0); 564. 3 951 CALL READV_$W(SP_LABS,2); 565. 3 952 CALL READ_$W(SP_FROMS,2); 566. 3 953 CALL RANK(SP_FROMS,2,SP_RANK); 567. 3 954 END INIT; 568. 2 955 TERMINATE: 569. DCL TABLEHEADS(2) STATIC CHAR(132); 570. 2 956 DCL TABLEFOOTS(0:0) STATIC CHAR(132); 571. 2 957 DCL S1_RANK(0:11) STATIC; 572. 2 958 DCL S1_LABS(0:11) STATIC CHAR(56) VAR; 573. 2 959 DCL S1_FROMS(11) STATIC CHAR(10); 574. 2 960 DCL S1_FOUND STATIC INIT(0); 575. 2 961 S1#=S1_FOUND; 576. 2 962 DO I=1 TO S1#; 577. 2 1 963 S1_LABS(I)=S1_FROMS(I); 578. 2 1 964 END; 579. 2 965 S1_LABS(11)=COPY('/',10); 580. 2 966 DCL SP_RANK(0:2) STATIC; 581. 2 967 DCL SP_LABS(0:2) STATIC CHAR(56) VAR; 582. 2 968 CALL RANK_AS(SP_RANK,2); 583. 2 969 DCL SP_FROMS(2) STATIC CHAR(1); 584. 2 970 DCL TABLE(0:11,0:2) CTL; 585. 2 971 DCL OPTIONS STATIC BIT(36) 586. INIT('0000000000'B); 587. 2 972 SKIPS$=LV$; 588. 2 973 CALL PRINT_TABLE1(TABLE,TABLEHEADS,TABLEFOOTS, 589. 'COMPANY',S1_LABS,S1_RANK,S1_FOUND,0, 590. 'SEX',SP_LABS,SP_RANK,2,0,2, 591. OPTIONS); 592. 2 974 END TABLE_005; 593. 1 975 %PAGE; 594. TABLE_006: 595. PROC; 596. 2 976 %INCLUDE(PP.COPY/TABLEGEN); 1I DCL (I,J,K,L,S1#,S2#,S3#,SP#) STATIC; 2I 2 977 DCL (#HV,#LV,#MID,#MIDSV) STATIC; 3I 2 978 IF (I_G_T=1) THEN GOTO GENERATE; 4I 2 980 IF (I_G_T=2) THEN GOTO TERMINATE; 5I 2 982 IF (I_G_T=3) 6I THEN DO; 7I 2 1 984 TABLE=0; 8I 2 1 985 RETURN; 9I 2 1 986 END; 10I 2 987 ALLOC TABLE; 11I 2 988 TABLE=0; 12I 2 989 CALL INIT; 13I 2 990 RETURN; 14I 2 991 GENERATE: 15I S1#,S2#,S3#,SP#=0; 597. 2 992 #MIDSV,S1#=0; 598. 2 993 #HV=S1_FOUND; 599. 2 994 IF (#HV>10) THEN #HV=10; 600. 2 996 #LV=1; 601. 2 997 DO WHILE(S1#=0); 602. 2 1 998 #MID=(#HV+#LV)/2; 603. 2 1 999 IF (#MID=#MIDSV) 604. THEN DO; 605. 2 2 1001 IF (S1_FOUND=11) 606. THEN DO; 607. 2 3 1003 S1#=11; 608. 2 3 1004 GOTO S1_END; 609. 2 3 1005 END; 610. 2 2 1006 IF (S1_FOUND=10) 611. THEN DO; 612. 2 3 1008 S1_FOUND,S1#=11; 613. 2 3 1009 S1_RANK(S1_FOUND)=11; 614. 2 3 1010 GOTO S1_END; 615. 2 3 1011 END; 616. 2 2 1012 S1_FOUND=S1_FOUND+1; 617. 2 2 1013 S1_FROMS(S1_FOUND)=COMPANY; 618. 2 2 1014 S1#,S1_RANK(S1_FOUND)=S1_FOUND; 619. 2 2 1015 DO I=1 TO S1_FOUND-1; 620. 2 3 1016 IF (COMPANY<S1_FROMS(S1_RANK(I))) 621. THEN DO; 622. 2 4 1018 DO J=S1_FOUND-1 TO I BY -1; 623. 2 5 1019 S1_RANK(J+1)=S1_RANK(J); 624. 2 5 1020 END; 625. 2 4 1021 S1_RANK(I),I=S1_FOUND; 626. 2 4 1022 GOTO S1_END; 627. 2 4 1023 END; 628. 2 3 1024 END; 629. 2 2 1025 GOTO S1_END; 630. 2 2 1026 END; 631. 2 1 1027 #MIDSV=#MID; 632. 2 1 1028 IF (COMPANY=S1_FROMS(S1_RANK(#MID))) 633. THEN DO; 634. 2 2 1030 S1#=S1_RANK(#MID); 635. 2 2 1031 GOTO S1_END; 636. 2 2 1032 END; 637. 2 1 1033 IF (COMPANY<S1_FROMS(S1_RANK(#MID))) 638. THEN #HV=#MID-1; 639. 2 1 1035 ELSE #LV=#MID+1; 640. 2 1 1036 END; 641. 2 1037 S1_END: IF SEX='M' THEN SP#=1; 642. 2 1039 ELSE IF SEX='F' THEN SP#=2; 643. 2 1041 ELSE RETURN; 644. 2 1042 TABLE(S1#,SP#)=TABLE(S1#,SP#)+1; 645. 2 1043 RETURN; 646. 2 1044 INIT: 647. PROC; 648. 3 1045 CALL READ_$W(TABLEHEADS,2); 649. 3 1046 CALL READ_$W(TABLEFOOTS,0); 650. 3 1047 CALL READV_$W(SP_LABS,2); 651. 3 1048 CALL READ_$W(SP_FROMS,2); 652. 3 1049 CALL RANK(SP_FROMS,2,SP_RANK); 653. 3 1050 END INIT; 654. 2 1051 TERMINATE: 655. DCL TABLEHEADS(2) STATIC CHAR(132); 656. 2 1052 DCL TABLEFOOTS(0:0) STATIC CHAR(132); 657. 2 1053 DCL S1_RANK(0:11) STATIC; 658. 2 1054 DCL S1_LABS(0:11) STATIC CHAR(56) VAR; 659. 2 1055 DCL S1_FROMS(11) STATIC CHAR(10); 660. 2 1056 DCL S1_FOUND STATIC INIT(0); 661. 2 1057 S1#=S1_FOUND; 662. 2 1058 DO I=1 TO S1#; 663. 2 1 1059 S1_LABS(I)=S1_FROMS(I); 664. 2 1 1060 END; 665. 2 1061 S1_LABS(11)=COPY('/',10); 666. 2 1062 DCL SP_RANK(0:2) STATIC; 667. 2 1063 DCL SP_LABS(0:2) STATIC CHAR(56) VAR; 668. 2 1064 CALL RANK_AS(SP_RANK,2); 669. 2 1065 DCL SP_FROMS(2) STATIC CHAR(1); 670. 2 1066 DCL TABLE(0:11,0:2) CTL; 671. 2 1067 DCL OPTIONS STATIC BIT(36) 672. INIT('0000000000'B); 673. 2 1068 SKIPS$=LV$; 674. 2 1069 CALL PRINT_TABLE1(TABLE,TABLEHEADS,TABLEFOOTS, 675. 'COMPANY',S1_LABS,S1_RANK,S1_FOUND,0, 676. 'SEX',SP_LABS,SP_RANK,2,0,2, 677. OPTIONS); 678. 2 1070 END TABLE_006; 679. 1 1071 %PAGE; 680. TABLE_007: 681. PROC; 682. 2 1072 TABLE_IBMTABLE: 683. ENTRY; 684. 2 1073 %INCLUDE(PP.COPY/TABLEGEN); 1I DCL (I,J,K,L,S1#,S2#,S3#,SP#) STATIC; 2I 2 1074 DCL (#HV,#LV,#MID,#MIDSV) STATIC; 3I 2 1075 IF (I_G_T=1) THEN GOTO GENERATE; 4I 2 1077 IF (I_G_T=2) THEN GOTO TERMINATE; 5I 2 1079 IF (I_G_T=3) 6I THEN DO; 7I 2 1 1081 TABLE=0; 8I 2 1 1082 RETURN; 9I 2 1 1083 END; 10I 2 1084 ALLOC TABLE; 11I 2 1085 TABLE=0; 12I 2 1086 CALL INIT; 13I 2 1087 RETURN; 14I 2 1088 GENERATE: 15I S1#,S2#,S3#,SP#=0; 685. 2 1089 IF (CALL_SW=0) THEN RETURN; 686. 2 1091 IF SEX='M' THEN S1#=1; 687. 2 1093 ELSE IF SEX='F' THEN S1#=2; 688. 2 1095 ELSE RETURN; 689. 2 1096 IF RACE='W' THEN SP#=1; 690. 2 1098 ELSE IF RACE='B' THEN SP#=2; 691. 2 1100 ELSE SP#=3; 692. 2 1101 TABLE(S1#,SP#)=TABLE(S1#,SP#)+1; 693. 2 1102 RETURN; 694. 2 1103 INIT: 695. PROC; 696. 3 1104 CALL READ_$W(TABLEHEADS,1); 697. 3 1105 CALL READ_$W(TABLEFOOTS,0); 698. 3 1106 CALL READV_$W(S1_LABS,2); 699. 3 1107 CALL READ_$W(S1_FROMS,2); 700. 3 1108 CALL RANK(S1_FROMS,2,S1_RANK); 701. 3 1109 CALL READV_$W(SP_LABS,3); 702. 3 1110 CALL READ_$W(SP_FROMS,2); 703. 3 1111 CALL RANK(SP_FROMS,2,SP_RANK); 704. 3 1112 END INIT; 705. 2 1113 TERMINATE: 706. DCL TABLEHEADS(1) STATIC CHAR(132); 707. 2 1114 DCL TABLEFOOTS(0:0) STATIC CHAR(132); 708. 2 1115 DCL S1_RANK(0:2) STATIC; 709. 2 1116 DCL S1_LABS(0:2) STATIC CHAR(56) VAR; 710. 2 1117 CALL RANK_AS(S1_RANK,2); 711. 2 1118 DCL S1_FROMS(2) STATIC CHAR(1); 712. 2 1119 DCL SP_RANK(0:3) STATIC; 713. 2 1120 DCL SP_LABS(0:3) STATIC CHAR(56) VAR; 714. 2 1121 CALL RANK_AS(SP_RANK,3); 715. 2 1122 DCL SP_FROMS(3) STATIC CHAR(1); 716. 2 1123 DCL TABLE(0:2,0:3) CTL; 717. 2 1124 DCL OPTIONS STATIC BIT(36) 718. INIT('0000000000'B); 719. 2 1125 SKIPS$=LV$; 720. 2 1126 CALL PRINT_TABLE1(TABLE,TABLEHEADS,TABLEFOOTS, 721. 'SEX',S1_LABS,S1_RANK,2,0, 722. 'RACE',SP_LABS,SP_RANK,3,0,3, 723. OPTIONS); 724. 2 1127 END TABLE_007; 725. 1 1128 %PAGE; 726. REPORT_0001: 727. PROC; 728. 2 1129 %INCLUDE(PP.COPY/REPORTGEN); 1I IF (I_G_T=1) THEN GOTO GENERATE; 2I 2 1131 IF (I_G_T=2) THEN GOTO TERMINATE; 3I 2 1133 CALL READ_$W(HEADS,#_HEADS); 4I 2 1134 CALL READ_$W(IMHEADS,#_IMHEADS); 5I 2 1135 CALL READ_$W(AHHEADS,#_AHHEADS); 6I 2 1136 RETURN; 7I 2 1137 RPAGE: 8I PROC; 9I 3 1138 LINE_#=0; 10I 3 1139 CALL PP_PAGING; 11I 3 1140 CALL PUT_HEADS; 12I 3 1141 END RPAGE; 13I 2 1142 PUT_HEADS: 14I PROC; 15I 3 1143 DO #=1 TO #_HEADS; 16I 3 1 1144 PUT EDIT(HEADS(#)) (COL(1),A); 17I 3 1 1145 END; 18I 3 1146 DO #=1 TO #_IMHEADS; 19I 3 1 1147 CALL NCHEAD(IMHEADS(#)); 20I 3 1 1148 END; 21I 3 1149 DO #=1 TO #_AHHEADS; 22I 3 1 1150 CALL NCHEAD(AHHEADS(#)); 23I 3 1 1151 END; 24I 3 1152 END PUT_HEADS; 729. 2 1153 DCL #_HEADS STATIC INIT(1); 730. 2 1154 DCL HEADS(1) STATIC CHAR(132); 731. 2 1155 GENERATE: 732. IF ((COMPANY='IBM')) 733. THEN; 734. 2 1157 ELSE RETURN; 735. 2 1158 DCL #_IMHEADS STATIC INIT(0); 736. 2 1159 SUBSTR(R$,1,1)=SEX; 737. 2 1160 SUBSTR(R$,4,12)=LASTNAME; 738. 2 1161 SUBSTR(R$,18,8)=FIRSTNAME; 739. 2 1162 SUBSTR(R$,28,11)=LSSN; 740. 2 1163 DCL #_AHHEADS STATIC INIT(0); 741. 2 1164 DCL IMHEADS(1) STATIC CHAR(44); 742. 2 1165 DCL AHHEADS(1) STATIC CHAR(44); 743. 2 1166 SUBSTR(RS$,5,1)=SEX; 744. 2 1167 SUBSTR(RS$,6,12)=LASTNAME; 745. 2 1168 SUBSTR(RS$,18,8)=FIRSTNAME; 746. 2 1169 RLS$=RS$; 747. 2 1170 RLL$=R$; 748. 2 1171 RLCB$=RCB$; 749. 2 1172 RF_#=RF_#+1; 750. 2 1173 IF (^RFT_SW) 751. THEN IF (RF_#>RF_#MAX) 752. THEN CALL SORTDISKTAPE; 753. 2 1176 IF (RFT_SW) 754. THEN WRITE FILE($RFT) FROM(RL$); 755. 2 1178 ELSE WRITE FILE($RF ) FROM(RL$); 756. 2 1179 RETURN; 757. 2 1180 TERMINATE: 758. #_RLS=0; 759. 2 1181 RS$=RLS$; 760. 2 1182 R$=RLL$; 761. 2 1183 RCB$=RLCB$; 762. 2 1184 PAGE_#=0; 763. 2 1185 CALL NCPAGE(1,44,0,56,3); 764. 2 1186 CALL RPAGE; 765. 2 1187 DO WHILE(RL_#=0001); 766. 2 1 1188 CALL PUT_LINES; 767. 2 1 1189 #_RLS=#_RLS+1; 768. 2 1 1190 IF (RFT_SW) 769. THEN READ FILE($RFT) INTO(RL$); 770. 2 1 1192 ELSE READ FILE($RF ) INTO(RL$); 771. 2 1 1193 RS$=RLS$; 772. 2 1 1194 R$=RLL$; 773. 2 1 1195 RCB$=RLCB$; 774. 2 1 1196 END; 775. 2 1197 CALL NCDATA('/*',EOP_SW); 776. 2 1198 IF (#_RLS>0) 777. THEN CALL RPAGE; 778. 2 1200 PUT EDIT('** TOTAL RECORDS PRINTED: ',#_RLS) (SKIP,A,F(8)); 779. 2 1201 RETURN; 780. 2 1202 PUT_LINES: 781. PROC; 782. 3 1203 CALL NCDATA(R$,EOP_SW); 783. 3 1204 IF (EOP_SW) THEN CALL RPAGE; 784. 3 1206 END PUT_LINES; 785. 2 1207 DCL RS$ STATIC CHAR(28) INIT('0001'); 786. 2 1208 DCL R$ STATIC CHAR(44) INIT(''); 787. 2 1209 DCL RCB$ STATIC CHAR(4) INIT(''); 788. 2 1210 DCL RL_# PIC'9999' DEF(RS$) POS(1); 789. 2 1211 END REPORT_0001; 790. 1 1212 %PAGE; 791. REPORT_0002: 792. PROC; 793. 2 1213 %INCLUDE(PP.COPY/REPORTGEN); 1I IF (I_G_T=1) THEN GOTO GENERATE; 2I 2 1215 IF (I_G_T=2) THEN GOTO TERMINATE; 3I 2 1217 CALL READ_$W(HEADS,#_HEADS); 4I 2 1218 CALL READ_$W(IMHEADS,#_IMHEADS); 5I 2 1219 CALL READ_$W(AHHEADS,#_AHHEADS); 6I 2 1220 RETURN; 7I 2 1221 RPAGE: 8I PROC; 9I 3 1222 LINE_#=0; 10I 3 1223 CALL PP_PAGING; 11I 3 1224 CALL PUT_HEADS; 12I 3 1225 END RPAGE; 13I 2 1226 PUT_HEADS: 14I PROC; 15I 3 1227 DO #=1 TO #_HEADS; 16I 3 1 1228 PUT EDIT(HEADS(#)) (COL(1),A); 17I 3 1 1229 END; 18I 3 1230 DO #=1 TO #_IMHEADS; 19I 3 1 1231 CALL NCHEAD(IMHEADS(#)); 20I 3 1 1232 END; 21I 3 1233 DO #=1 TO #_AHHEADS; 22I 3 1 1234 CALL NCHEAD(AHHEADS(#)); 23I 3 1 1235 END; 24I 3 1236 END PUT_HEADS; 794. 2 1237 DCL #_HEADS STATIC INIT(1); 795. 2 1238 DCL HEADS(1) STATIC CHAR(132); 796. 2 1239 GENERATE: 797. IF ((COMPANY='CDC')) 798. THEN; 799. 2 1241 ELSE RETURN; 800. 2 1242 DCL #_IMHEADS STATIC INIT(0); 801. 2 1243 SUBSTR(R$,1,12)=LASTNAME; 802. 2 1244 SUBSTR(R$,16,8)=FIRSTNAME; 803. 2 1245 SUBSTR(R$,27,14)=LPHONE; 804. 2 1246 DCL #_AHHEADS STATIC INIT(5); 805. 2 1247 DCL IMHEADS(1) STATIC CHAR(44); 806. 2 1248 DCL AHHEADS(5) STATIC CHAR(44); 807. 2 1249 SUBSTR(RS$,5,12)=LASTNAME; 808. 2 1250 SUBSTR(RS$,17,8)=FIRSTNAME; 809. 2 1251 DOUBLE$=FLLNAME; 810. 2 1252 DCL DOUBLE$ CHAR(1) DEF(RCB$) POS(1); 811. 2 1253 DCL DSV$ CHAR(1) STATIC; 812. 2 1254 RLS$=RS$; 813. 2 1255 RLL$=R$; 814. 2 1256 RLCB$=RCB$; 815. 2 1257 RF_#=RF_#+1; 816. 2 1258 IF (^RFT_SW) 817. THEN IF (RF_#>RF_#MAX) 818. THEN CALL SORTDISKTAPE; 819. 2 1261 IF (RFT_SW) 820. THEN WRITE FILE($RFT) FROM(RL$); 821. 2 1263 ELSE WRITE FILE($RF ) FROM(RL$); 822. 2 1264 RETURN; 823. 2 1265 TERMINATE: 824. #_RLS=0; 825. 2 1266 RS$=RLS$; 826. 2 1267 R$=RLL$; 827. 2 1268 RCB$=RLCB$; 828. 2 1269 PAGE_#=0; 829. 2 1270 DSV$=DOUBLE$; 830. 2 1271 CALL NCPAGE(4,40,3,51,3); 831. 2 1272 CALL RPAGE; 832. 2 1273 DO WHILE(RL_#=0002); 833. 2 1 1274 CALL PUT_LINES; 834. 2 1 1275 #_RLS=#_RLS+1; 835. 2 1 1276 IF (RFT_SW) 836. THEN READ FILE($RFT) INTO(RL$); 837. 2 1 1278 ELSE READ FILE($RF ) INTO(RL$); 838. 2 1 1279 RS$=RLS$; 839. 2 1 1280 R$=RLL$; 840. 2 1 1281 RCB$=RLCB$; 841. 2 1 1282 END; 842. 2 1283 CALL NCDATA('/*',EOP_SW); 843. 2 1284 IF (#_RLS>0) 844. THEN CALL RPAGE; 845. 2 1286 PUT EDIT('** TOTAL RECORDS PRINTED: ',#_RLS) (SKIP,A,F(8)); 846. 2 1287 RETURN; 847. 2 1288 PUT_LINES: 848. PROC; 849. 3 1289 IF (DOUBLE$^=DSV$) 850. THEN DO; 851. 3 1 1291 CALL NCDATA(' ',EOP_SW); 852. 3 1 1292 IF (EOP_SW) THEN CALL RPAGE; 853. 3 1 1294 DSV$=DOUBLE$; 854. 3 1 1295 END; 855. 3 1296 CALL NCDATA(R$,EOP_SW); 856. 3 1297 IF (EOP_SW) THEN CALL RPAGE; 857. 3 1299 END PUT_LINES; 858. 2 1300 DCL RS$ STATIC CHAR(28) INIT('0002'); 859. 2 1301 DCL R$ STATIC CHAR(44) INIT(''); 860. 2 1302 DCL RCB$ STATIC CHAR(4) INIT(''); 861. 2 1303 DCL RL_# PIC'9999' DEF(RS$) POS(1); 862. 2 1304 END REPORT_0002; 863. 1 1305 %PAGE; 864. REPORT_0003: 865. PROC; 866. 2 1306 %INCLUDE(PP.COPY/REPORTGEN); 1I IF (I_G_T=1) THEN GOTO GENERATE; 2I 2 1308 IF (I_G_T=2) THEN GOTO TERMINATE; 3I 2 1310 CALL READ_$W(HEADS,#_HEADS); 4I 2 1311 CALL READ_$W(IMHEADS,#_IMHEADS); 5I 2 1312 CALL READ_$W(AHHEADS,#_AHHEADS); 6I 2 1313 RETURN; 7I 2 1314 RPAGE: 8I PROC; 9I 3 1315 LINE_#=0; 10I 3 1316 CALL PP_PAGING; 11I 3 1317 CALL PUT_HEADS; 12I 3 1318 END RPAGE; 13I 2 1319 PUT_HEADS: 14I PROC; 15I 3 1320 DO #=1 TO #_HEADS; 16I 3 1 1321 PUT EDIT(HEADS(#)) (COL(1),A); 17I 3 1 1322 END; 18I 3 1323 DO #=1 TO #_IMHEADS; 19I 3 1 1324 CALL NCHEAD(IMHEADS(#)); 20I 3 1 1325 END; 21I 3 1326 DO #=1 TO #_AHHEADS; 22I 3 1 1327 CALL NCHEAD(AHHEADS(#)); 23I 3 1 1328 END; 24I 3 1329 END PUT_HEADS; 867. 2 1330 DCL #_HEADS STATIC INIT(1); 868. 2 1331 DCL HEADS(1) STATIC CHAR(132); 869. 2 1332 GENERATE: 870. IF (SALARY>90000) 871. THEN; 872. 2 1334 ELSE RETURN; 873. 2 1335 DCL #_IMHEADS STATIC INIT(0); 874. 2 1336 SUBSTR(R$,1,10)=COMPANY; 875. 2 1337 SUBSTR(R$,13,12)=LASTNAME; 876. 2 1338 SUBSTR(R$,28,8)=FIRSTNAME; 877. 2 1339 SUBSTR(R$,39,5)=SALARY; 878. 2 1340 DCL #_AHHEADS STATIC INIT(5); 879. 2 1341 DCL IMHEADS(1) STATIC CHAR(66); 880. 2 1342 DCL AHHEADS(5) STATIC CHAR(66); 881. 2 1343 SUBSTR(RS$,5,5)=TRANSLATE(SALARY,REVERSE(COLLATE())); 882. 2 1344 SUBSTR(RS$,10,12)=LASTNAME; 883. 2 1345 RLS$=RS$; 884. 2 1346 RLL$=R$; 885. 2 1347 RLCB$=RCB$; 886. 2 1348 RF_#=RF_#+1; 887. 2 1349 IF (^RFT_SW) 888. THEN IF (RF_#>RF_#MAX) 889. THEN CALL SORTDISKTAPE; 890. 2 1352 IF (RFT_SW) 891. THEN WRITE FILE($RFT) FROM(RL$); 892. 2 1354 ELSE WRITE FILE($RF ) FROM(RL$); 893. 2 1355 RETURN; 894. 2 1356 TERMINATE: 895. #_RLS=0; 896. 2 1357 RS$=RLS$; 897. 2 1358 R$=RLL$; 898. 2 1359 RCB$=RLCB$; 899. 2 1360 PAGE_#=0; 900. 2 1361 CALL NCPAGE(16,44,14,51,2); 901. 2 1362 CALL RPAGE; 902. 2 1363 DO WHILE(RL_#=0003); 903. 2 1 1364 CALL PUT_LINES; 904. 2 1 1365 #_RLS=#_RLS+1; 905. 2 1 1366 IF (RFT_SW) 906. THEN READ FILE($RFT) INTO(RL$); 907. 2 1 1368 ELSE READ FILE($RF ) INTO(RL$); 908. 2 1 1369 RS$=RLS$; 909. 2 1 1370 R$=RLL$; 910. 2 1 1371 RCB$=RLCB$; 911. 2 1 1372 END; 912. 2 1373 CALL NCDATA('/*',EOP_SW); 913. 2 1374 IF (#_RLS>0) 914. THEN CALL RPAGE; 915. 2 1376 PUT EDIT('** TOTAL RECORDS PRINTED: ',#_RLS) (SKIP,A,F(8)); 916. 2 1377 RETURN; 917. 2 1378 PUT_LINES: 918. PROC; 919. 3 1379 CALL NCDATA(R$,EOP_SW); 920. 3 1380 IF (EOP_SW) THEN CALL RPAGE; 921. 3 1382 END PUT_LINES; 922. 2 1383 DCL RS$ STATIC CHAR(28) INIT('0003'); 923. 2 1384 DCL R$ STATIC CHAR(68) INIT(''); 924. 2 1385 DCL RCB$ STATIC CHAR(4) INIT(''); 925. 2 1386 DCL RL_# PIC'9999' DEF(RS$) POS(1); 926. 2 1387 END REPORT_0003; 927. 1 1388 %PAGE; 928. REPORT_0004: 929. PROC; 930. 2 1389 %INCLUDE(PP.COPY/REPORTGEN); 1I IF (I_G_T=1) THEN GOTO GENERATE; 2I 2 1391 IF (I_G_T=2) THEN GOTO TERMINATE; 3I 2 1393 CALL READ_$W(HEADS,#_HEADS); 4I 2 1394 CALL READ_$W(IMHEADS,#_IMHEADS); 5I 2 1395 CALL READ_$W(AHHEADS,#_AHHEADS); 6I 2 1396 RETURN; 7I 2 1397 RPAGE: 8I PROC; 9I 3 1398 LINE_#=0; 10I 3 1399 CALL PP_PAGING; 11I 3 1400 CALL PUT_HEADS; 12I 3 1401 END RPAGE; 13I 2 1402 PUT_HEADS: 14I PROC; 15I 3 1403 DO #=1 TO #_HEADS; 16I 3 1 1404 PUT EDIT(HEADS(#)) (COL(1),A); 17I 3 1 1405 END; 18I 3 1406 DO #=1 TO #_IMHEADS; 19I 3 1 1407 CALL NCHEAD(IMHEADS(#)); 20I 3 1 1408 END; 21I 3 1409 DO #=1 TO #_AHHEADS; 22I 3 1 1410 CALL NCHEAD(AHHEADS(#)); 23I 3 1 1411 END; 24I 3 1412 END PUT_HEADS; 931. 2 1413 DCL #_HEADS STATIC INIT(1); 932. 2 1414 DCL HEADS(1) STATIC CHAR(132); 933. 2 1415 GENERATE: 934. IF (SALARY>90000) 935. THEN; 936. 2 1417 ELSE RETURN; 937. 2 1418 DCL #_IMHEADS STATIC INIT(0); 938. 2 1419 SUBSTR(R$,1,10)=COMPANY; 939. 2 1420 SUBSTR(R$,13,5)=SALARY; 940. 2 1421 DCL #_AHHEADS STATIC INIT(5); 941. 2 1422 DCL IMHEADS(1) STATIC CHAR(33); 942. 2 1423 DCL AHHEADS(5) STATIC CHAR(33); 943. 2 1424 SUBSTR(RS$,5,10)=COMPANY; 944. 2 1425 SUBSTR(RS$,15,5)=TRANSLATE(SALARY,REVERSE(COLLATE())); 945. 2 1426 COLUMN$=COMPANY; 946. 2 1427 DCL COLUMN$ CHAR(10) DEF(RCB$) POS(1); 947. 2 1428 DCL CSV$ CHAR(10) STATIC; 948. 2 1429 RLS$=RS$; 949. 2 1430 RLL$=R$; 950. 2 1431 RLCB$=RCB$; 951. 2 1432 RF_#=RF_#+1; 952. 2 1433 IF (^RFT_SW) 953. THEN IF (RF_#>RF_#MAX) 954. THEN CALL SORTDISKTAPE; 955. 2 1436 IF (RFT_SW) 956. THEN WRITE FILE($RFT) FROM(RL$); 957. 2 1438 ELSE WRITE FILE($RF ) FROM(RL$); 958. 2 1439 RETURN; 959. 2 1440 TERMINATE: 960. #_RLS=0; 961. 2 1441 RS$=RLS$; 962. 2 1442 R$=RLL$; 963. 2 1443 RCB$=RLCB$; 964. 2 1444 PAGE_#=0; 965. 2 1445 CSV$=COLUMN$; 966. 2 1446 CALL NCPAGE(13,18,12,51,4); 967. 2 1447 CALL RPAGE; 968. 2 1448 DO WHILE(RL_#=0004); 969. 2 1 1449 CALL PUT_LINES; 970. 2 1 1450 #_RLS=#_RLS+1; 971. 2 1 1451 IF (RFT_SW) 972. THEN READ FILE($RFT) INTO(RL$); 973. 2 1 1453 ELSE READ FILE($RF ) INTO(RL$); 974. 2 1 1454 RS$=RLS$; 975. 2 1 1455 R$=RLL$; 976. 2 1 1456 RCB$=RLCB$; 977. 2 1 1457 END; 978. 2 1458 CALL NCDATA('/*',EOP_SW); 979. 2 1459 IF (#_RLS>0) 980. THEN CALL RPAGE; 981. 2 1461 PUT EDIT('** TOTAL RECORDS PRINTED: ',#_RLS) (SKIP,A,F(8)); 982. 2 1462 RETURN; 983. 2 1463 PUT_LINES: 984. PROC; 985. 3 1464 IF (COLUMN$^=CSV$) 986. THEN DO; 987. 3 1 1466 CALL NCDATA('//',EOP_SW); 988. 3 1 1467 IF (EOP_SW) THEN CALL RPAGE; 989. 3 1 1469 CSV$=COLUMN$; 990. 3 1 1470 END; 991. 3 1471 CALL NCDATA(R$,EOP_SW); 992. 3 1472 IF (EOP_SW) THEN CALL RPAGE; 993. 3 1474 END PUT_LINES; 994. 2 1475 DCL RS$ STATIC CHAR(28) INIT('0004'); 995. 2 1476 DCL R$ STATIC CHAR(36) INIT(''); 996. 2 1477 DCL RCB$ STATIC CHAR(12) INIT(''); 997. 2 1478 DCL RL_# PIC'9999' DEF(RS$) POS(1); 998. 2 1479 END REPORT_0004; 999. 1 1480 %PAGE; 1000. %INCLUDE(PP.COPY/PPREPORTS); 1I DCL SP$ STATIC CHAR(56) VAR; 2I 1 1481 DCL RL_MAX$ STATIC PIC'9999'; 3I 1 1482 DCL SORT_MAX$ STATIC PIC'99'; 4I 1 1483 DCL VOL# STATIC; 5I 1 1484 DCL F$ CHAR(4) INIT('V ') ALIGNED STATIC; 6I 1 1485 PP_REPORTS: 7I PROC; 8I 2 1486 IF (I_G_T=1) 9I THEN; 10I 2 1488 ELSE 11I IF (I_G_T=0) 12I THEN DO; 13I 2 1 1490 CALL PL1ACSF$('@ASG,T $RF.,//TRK/2560',CSF_STATUS); 14I 2 1 1491 IF ((CSF_STATUS='0'B)! 15I (CSF_STATUS='001'B)) 16I THEN; 17I 2 1 1493 ELSE PUT EDIT('$RF. STATUS: ',CSF_STATUS) (SKIP,A,B(36)); 18I 2 1 1494 OPEN OUTPUT FILE($RF); 19I 2 1 1495 END; 20I 2 1496 ELSE DO; 21I 2 1 1497 RL$='9999'; 22I 2 1 1498 SORT_MAX$=SORT_MAX; 23I 2 1 1499 RL_MAX$=RL_MAX; 24I 2 1 1500 SP$='KEY=1/'!!SORT_MAX$!!',RSZ='!!RL_MAX$; 25I 2 1 1501 VOL#=RF_#*RF_##; 26I 2 1 1502 /* 27I VOL#=VOL#+VOL#/10; 28I IF (VOL#<8800000) 29I THEN SP$=SP$!!',FILES=(XA,XB)'; 30I ELSE SP$=SP$!!',FILES=(XC,XD,XE,XF,XG,XH)'; 31I PUT SKIP; 32I PUT DATA(RF_#); 33I PUT SKIP; 34I PUT DATA(RF_##); 35I PUT SKIP; 36I PUT DATA(F$); 37I PUT SKIP; 38I */ 39I SORT_TIC=CPUTIC(); 40I 2 1 1503 IF (RFT_SW) 41I THEN DO; 42I 2 2 1505 WRITE FILE($RFT) FROM(RL$); 43I 2 2 1506 CLOSE FILE($RFT); 44I 2 2 1507 CALL PL1SRTASG(RF_#,RF_##,F$); 45I 2 2 1508 IF (RF_##=1) 46I THEN SP$=SP$!!',FILES=(XA,XB)'; 47I 2 2 1510 ELSE SP$=SP$!!',FILES=(XC,XD,XE,XF,XG,XH)'; 48I 2 2 1511 CALL PL1SORT(SP$,$RFT,$RFT); 49I 2 2 1512 OPEN INPUT FILE($RFT); 50I 2 2 1513 END; 51I 2 1 1514 ELSE DO; 52I 2 2 1515 WRITE FILE($RF) FROM(RL$); 53I 2 2 1516 CLOSE FILE($RF); 54I 2 2 1517 CALL PL1SRTASG(RF_#,RF_##,F$); 55I 2 2 1518 IF (RF_##=1) 56I THEN SP$=SP$!!',FILES=(XA,XB)'; 57I 2 2 1520 ELSE SP$=SP$!!',FILES=(XC,XD,XE,XF,XG,XH)'; 58I 2 2 1521 CALL PL1SORT(SP$,$RF,$RF); 59I 2 2 1522 OPEN INPUT FILE($RF); 60I 2 2 1523 END; 61I 2 1 1524 SORT_TOC=CPUTIC(); 62I 2 1 1525 IF (RFT_SW) 63I THEN READ FILE($RFT) INTO(RL$); 64I 2 1 1527 ELSE READ FILE($RF ) INTO(RL$); 65I 2 1 1528 END; 1001. 2 1529 CALL REPORT_0001; 1002. 2 1530 CALL REPORT_0002; 1003. 2 1531 CALL REPORT_0003; 1004. 2 1532 CALL REPORT_0004; 1005. 2 1533 IF (I_G_T=2) 1006. THEN IF (RFT_SW) 1007. THEN CLOSE FILE($RFT); 1008. 2 1536 ELSE CLOSE FILE($RF); 1009. 2 1537 END PP_REPORTS; 1010. 1 1538 %PAGE; 1011. %INCLUDE(PP.COPY/RSORTINOUT); 1I SORTDISKTAPE: 2I PROC; 3I 2 1539 RFT_SW=HV$; 4I 2 1540 CLOSE FILE($RF); 5I 2 1541 CALL PL1ACSF$('@ASG,T $RFT.,CT//////Q',CSF_STATUS); 6I 2 1542 IF ((CSF_STATUS='0'B)! 7I (CSF_STATUS='001'B)) 8I THEN; 9I 2 1544 ELSE PUT EDIT('$RFT. STATUS: ',CSF_STATUS) 10I (SKIP,A,B(36)); 11I 2 1545 OPEN INPUT FILE($RF); 12I 2 1546 OPEN OUTPUT FILE($RFT); 13I 2 1547 DO #=1 TO RF_#-1; 14I 2 1 1548 READ FILE($RF) INTO(RL$); 15I 2 1 1549 WRITE FILE($RFT) FROM(RL$); 16I 2 1 1550 END; 17I 2 1551 CLOSE FILE($RF); 18I 2 1552 END SORTDISKTAPE; 1012. 1 1553 DCL $RF FILE RECORD ENV(RECSIZE(27),BLKSIZE(3584)); 1013. 1 1554 DCL $RFT FILE RECORD ENV(FB,REWIND,ANSI,RECSIZE(108),BLKSIZE(1080)); 1014. 1 1555 DCL RF_## INIT(108) ALIGNED STATIC; 1015. 1 1556 DCL RF_#MAX INIT(159259); 1016. 1 1557 DCL SORT_MAX INIT(28); 1017. 1 1558 DCL RL_MAX INIT(108); 1018. 1 1559 DCL PL1SORT ENTRY(CHAR(*),FILE,FILE); 1019. 1 1560 DCL PL1SRTASG ENTRY(BIN,BIN,CHAR(4)); 1020. 1 1561 DCL RL$ CHAR(108); 1021. 1 1562 DCL RLS$ CHAR(28) DEF(RL$); 1022. 1 1563 DCL RLL$ CHAR(68) DEF(RL$) POS(29); 1023. 1 1564 DCL RLCB$ CHAR(12) DEF(RL$) POS(97); 1024. 1 1565 %INCLUDE(PP.COPY/NCOLS); 1I NCOLS: 2I PROC; 3I 2 1566 DECLARES: 4I DCL (START_COL,DATUM_##,GAP_##,#_ROWS,#_COLS, 5I COL_LIMIT,DATUM_#,DATUM_MAX,II,JJ) 6I STATIC; 7I 2 1567 DCL DATUM_ARRAY(DATUM_MAX) CHAR(DATUM_##) CTL; 8I 2 1568 DCL (I,J,K,L,M) ; 9I 2 1569 NCPAGE: 10I ENTRY(I,J,K,L,M); 11I 2 1570 START_COL=I; 12I 2 1571 DATUM_## =J; 13I 2 1572 GAP_## =K; 14I 2 1573 #_ROWS =L; 15I 2 1574 #_COLS =M; 16I 2 1575 DO WHILE(ALLOCN(DATUM_ARRAY)>0); 17I 2 1 1576 FREE DATUM_ARRAY; 18I 2 1 1577 END; 19I 2 1578 DATUM_MAX =#_ROWS*#_COLS; 20I 2 1579 ALLOC DATUM_ARRAY; 21I 2 1580 COL_LIMIT =(#_COLS-1)*#_ROWS; 22I 2 1581 DATUM_ARRAY=''; 23I 2 1582 DATUM_# =1; 24I 2 1583 RETURN; 25I 2 1584 NCHEAD: 26I ENTRY(ST); 27I 2 1585 DCL ST CHAR(*); 28I 2 1586 PUT EDIT(((ST)DO II=1 TO #_COLS)) 29I (COL(START_COL),(#_COLS)(A(DATUM_##),X(GAP_##))); 30I 2 1587 RETURN; 31I 2 1588 NCDATA: 32I ENTRY(DATUM,END_OF_PAGE); 33I 2 1589 DCL DATUM CHAR(*); 34I 2 1590 DCL END_OF_PAGE BIT; 35I 2 1591 END_OF_PAGE='0'B; 36I 2 1592 IF (DATUM='/*') 37I THEN CALL PUT_PAGE; 38I 2 1594 ELSE 39I IF (DATUM='//') 40I THEN DO; 41I 2 1 1596 DATUM_#=((DATUM_#+1)/#_ROWS+1)*#_ROWS+1; 42I 2 1 1597 IF (DATUM_#>DATUM_MAX) 43I THEN CALL PUT_PAGE; 44I 2 1 1599 END; 45I 2 1600 ELSE DO; 46I 2 1 1601 DATUM_ARRAY(DATUM_#)=DATUM; 47I 2 1 1602 DATUM_# =DATUM_#+1; 48I 2 1 1603 IF (DATUM_#>DATUM_MAX) 49I THEN CALL PUT_PAGE; 50I 2 1 1605 END; 51I 2 1606 RETURN; 52I 2 1607 PUT_PAGE: 53I PROC; 54I 3 1608 DO II=1 TO #_ROWS; 55I 3 1 1609 PUT EDIT((DATUM_ARRAY(II+JJ)DO JJ=0 TO COL_LIMIT BY #_ROWS)) 56I (COL(START_COL),(#_COLS)(A(DATUM_##),X(GAP_##))); 57I 3 1 1610 END; 58I 3 1611 END_OF_PAGE='1'B; 59I 3 1612 DATUM_# =1; 60I 3 1613 DATUM_ARRAY=''; 61I 3 1614 END PUT_PAGE; 62I 2 1615 END NCOLS; 1025. 1 1616 %PAGE; 1026. %INCLUDE(PP.COPY/RANK); 1I RANK: 2I PROC(ARRAY,#,RANKING); 3I 2 1617 DCL ARRAY(*) CHAR(*); 4I 2 1618 DCL RANKING(*) ; 5I 2 1619 DCL # ; 6I 2 1620 DCL WARRAY(1000) CHAR(28) VAR; 7I 2 1621 DCL MIN CHAR(28) VAR; 8I 2 1622 DCL (I,J,JS) STATIC; 9I 2 1623 DO I=1 TO #; 10I 2 1 1624 WARRAY(I)=ARRAY(I); 11I 2 1 1625 RANKING(I)=I; 12I 2 1 1626 END; 13I 2 1627 RANKING(0)=0; 14I 2 1628 DO I=2 TO #; 15I 2 1 1629 IF (ARRAY(I)<ARRAY(I-1)) THEN RANKING(0)=1; 16I 2 1 1631 END; 17I 2 1632 IF (RANKING(0)=0) THEN RETURN; 18I 2 1634 DO I=1 TO #; 19I 2 1 1635 MIN=WARRAY(I); 20I 2 1 1636 JS=I; 21I 2 1 1637 DO J=1 TO #; 22I 2 2 1638 IF (MIN > WARRAY(J)) 23I THEN DO; 24I 2 3 1640 MIN=WARRAY(J); 25I 2 3 1641 JS=J; 26I 2 3 1642 END; 27I 2 2 1643 END; 28I 2 1 1644 WARRAY(JS)=COPY('Z',28); 29I 2 1 1645 RANKING(I)=JS; 30I 2 1 1646 END; 31I 2 1647 END RANK; 1027. 1 1648 %PAGE; 1028. %INCLUDE(PP.COPY/PTABLE1); 1I PRINT_TABLE1: 2I PROC(TABLE,TABLE_HEADING,TABLE_FOOTING, 3I S1_LAB,S1_LABS,S1_RANK,S1_#,S1_LV, 4I SP_LAB,SP_LABS,SP_RANK,SP_#,SP_L,SP_H, 5I OPTIONS); 6I 2 1649 DCL TABLE(*,*) ; 7I 2 1650 DCL TABLE_HEADING(*) CHAR(132); 8I 2 1651 DCL TABLE_FOOTING(*) CHAR(132); 9I 2 1652 DCL S1_LAB CHAR(28) VAR; 10I 2 1653 DCL S1_LABS(*) CHAR(56) VAR; 11I 2 1654 DCL S1_RANK(*) ; 12I 2 1655 DCL S1_# ; 13I 2 1656 DCL S1_LV ; 14I 2 1657 DCL SP_LAB CHAR(28) VAR; 15I 2 1658 DCL SP_LABS(*) CHAR(56) VAR; 16I 2 1659 DCL SP_RANK(*) ; 17I 2 1660 DCL SP_# ; 18I 2 1661 DCL (SP_L,SP_H) ; 19I 2 1662 DCL OPTIONS BIT(36); 20I 2 1663 DCL #_SPS STATIC; 21I 2 1664 DCL SPT_LABS(24) STATIC CHAR(56) VAR; 22I 2 1665 DCL (I,II,J,K,L) ; 23I 2 1666 DCL T_LABS(4) CHAR(132); 24I 2 1667 DCL T_LAB# ; 25I 2 1668 DCL FTABLE(0:S1_#,0:SP_H) FLOAT CTL; 26I 2 1669 DCL FM STATIC FLOAT; 27I 2 1670 DCL (O_R,O_C,O_RS,O_CS,O_GT,O_ZL) 28I STATIC BIT; 29I 2 1671 O_R =SUBSTR(OPTIONS,1,1); 30I 2 1672 O_C =SUBSTR(OPTIONS,2,1); 31I 2 1673 O_GT=SUBSTR(OPTIONS,5,1); 32I 2 1674 O_ZL=SUBSTR(OPTIONS,6,1); 33I 2 1675 DCL (#_HEADS,#_FOOTS,GRID_##,CELL_##,GRID_COL); 34I 2 1676 #_HEADS=HBOUND(TABLE_HEADING,1); 35I 2 1677 #_FOOTS=HBOUND(TABLE_FOOTING,1); 36I 2 1678 DO I=1 TO S1_#; 37I 2 1 1679 DO J=1 TO SP_#; 38I 2 2 1680 TABLE(0,J)=TABLE(0,J)+TABLE(I,J); 39I 2 2 1681 TABLE(I,0)=TABLE(I,0)+TABLE(I,J); 40I 2 2 1682 END; 41I 2 1 1683 END; 42I 2 1684 IF (SP_H>SP_#) 43I THEN DO; 44I 2 1 1686 DO I=1 TO S1_#; 45I 2 2 1687 DO J=SP_#+1 TO SP_H; 46I 2 3 1688 TABLE(0,J)=TABLE(0,J)+TABLE(I,J); 47I 2 3 1689 END; 48I 2 2 1690 END; 49I 2 1 1691 END; 50I 2 1692 DO I=1 TO S1_#; 51I 2 1 1693 TABLE(0,0)=TABLE(0,0)+TABLE(I,0); 52I 2 1 1694 END; 53I 2 1695 S1_LABS(0),SP_LABS(0)='TOTAL'; 54I 2 1696 S1_RANK(0),SP_RANK(0)=0; 55I 2 1697 GRID_COL=0; 56I 2 1698 DO I=0 TO S1_#; 57I 2 1 1699 GRID_COL=MAX(GRID_COL,LENGTH(S1_LABS(I))); 58I 2 1 1700 END; 59I 2 1701 GRID_COL=GRID_COL+2; 60I 2 1702 #_SPS=SP_H-SP_L+1; 61I 2 1703 CELL_##=(PAGE_##-GRID_COL)/(#_SPS); 62I 2 1704 CELL_##=MIN(12,CELL_##); 63I 2 1705 GRID_##=CELL_##*(#_SPS); 64I 2 1706 IF (GRID_COL+#_SPS*CELL_##>(PAGE_##*70)/132) 65I THEN DO; 66I 2 1 1708 CELL_##=(PAGE_##-GRID_COL)/#_SPS; 67I 2 1 1709 GRID_COL=PAGE_##-CELL_##*#_SPS+1; 68I 2 1 1710 GRID_##=CELL_##*#_SPS; 69I 2 1 1711 END; 70I 2 1712 J=0; 71I 2 1713 DO I=SP_L TO SP_H; 72I 2 1 1714 J=J+1; 73I 2 1 1715 SPT_LABS(J)=SP_LABS(SP_RANK(I)); 74I 2 1 1716 END; 75I 2 1717 CALL TABLELABS(S1_LAB,'','',SP_LAB, 76I SPT_LABS,#_SPS,CELL_##,GRID_##,GRID_COL, 77I T_LABS,T_LAB#); 78I 2 1718 LINE_#=0; 79I 2 1719 CALL TABLE_PAGING; 80I 2 1720 CALL PUT_HEADINGS; 81I 2 1721 DO I=S1_LV TO S1_#; 82I 2 1 1722 II=S1_RANK(I); 83I 2 1 1723 IF ((O_ZL)!(TABLE(II,0)>0)!(II=0)) 84I THEN DO; 85I 2 2 1725 PUT EDIT(S1_LABS(II),(TABLE(II,SP_RANK(J))DO J=SP_L TO SP_H)) 86I (A(GRID_COL-1),(#_SPS)F(CELL_##)); 87I 2 2 1726 CALL TABLE_PAGING; 88I 2 2 1727 IF (PAGE_SW) THEN CALL PUT_HEADINGS; 89I 2 2 1729 END; 90I 2 1 1730 IF (SUBSTR(SKIPS$,I,1)=HV$) 91I THEN DO; 92I 2 2 1732 CALL TABLE_PAGING; 93I 2 2 1733 IF (PAGE_SW) THEN CALL PUT_HEADINGS; 94I 2 2 1735 END; 95I 2 1 1736 IF (I=0) 96I THEN DO; 97I 2 2 1738 PUT SKIP; 98I 2 2 1739 LINE_#=LINE_#+1; 99I 2 2 1740 END; 100I 2 1 1741 END; 101I 2 1742 CALL PUT_FOOTINGS; 102I 2 1743 103I IF (((O_R)!(O_C)!(O_GT))&(TABLE(0,0)>0)) 104I THEN ALLOC FTABLE; 105I 2 1745 ELSE RETURN; 106I 2 1746 107I IF (O_R) 108I THEN DO; 109I 2 1 1748 FTABLE=TABLE; 110I 2 1 1749 DO I=0 TO S1_#; 111I 2 2 1750 IF (TABLE(I,0)>0.) 112I THEN FM=100./FTABLE(I,0); 113I 2 2 1752 ELSE FM=0.; 114I 2 2 1753 DO J=0 TO SP_H; 115I 2 3 1754 FTABLE(I,J)=FTABLE(I,J)*FM; 116I 2 3 1755 END; 117I 2 2 1756 END; 118I 2 1 1757 CALL PUT_FTABLE; 119I 2 1 1758 END; 120I 2 1759 121I IF (O_C) 122I THEN DO; 123I 2 1 1761 FTABLE=TABLE; 124I 2 1 1762 DO J=0 TO SP_H; 125I 2 2 1763 IF (TABLE(0,J)>0.) 126I THEN FM=100./FTABLE(0,J); 127I 2 2 1765 ELSE FM=0.; 128I 2 2 1766 DO I=0 TO S1_#; 129I 2 3 1767 FTABLE(I,J)=FTABLE(I,J)*FM; 130I 2 3 1768 END; 131I 2 2 1769 END; 132I 2 1 1770 CALL PUT_FTABLE; 133I 2 1 1771 END; 134I 2 1772 135I IF (O_GT) 136I THEN DO; 137I 2 1 1774 FTABLE=TABLE; 138I 2 1 1775 FM=100./FTABLE(0,0); 139I 2 1 1776 DO I=0 TO S1_#; 140I 2 2 1777 DO J=0 TO SP_H; 141I 2 3 1778 FTABLE(I,J)=FTABLE(I,J)*FM; 142I 2 3 1779 END; 143I 2 2 1780 END; 144I 2 1 1781 CALL PUT_FTABLE; 145I 2 1 1782 END; 146I 2 1783 FREE FTABLE; 147I 2 1784 PUT_FTABLE: 148I PROC; 149I 3 1785 LINE_#=0; 150I 3 1786 CALL TABLE_PAGING; 151I 3 1787 CALL PUT_HEADINGS; 152I 3 1788 DO I=S1_LV TO S1_#; 153I 3 1 1789 II=S1_RANK(I); 154I 3 1 1790 IF ((O_ZL)!(FTABLE(II,0)>0.)) 155I THEN DO; 156I 3 2 1792 PUT EDIT(S1_LABS(II),(FTABLE(II,SP_RANK(J))DO J=SP_L TO SP_H)) 157I (A(GRID_COL-1),(#_SPS)F(CELL_##,2)); 158I 3 2 1793 CALL TABLE_PAGING; 159I 3 2 1794 IF (PAGE_SW) THEN CALL PUT_HEADINGS; 160I 3 2 1796 END; 161I 3 1 1797 IF (SUBSTR(SKIPS$,I,1)=HV$) 162I THEN DO; 163I 3 2 1799 CALL TABLE_PAGING; 164I 3 2 1800 IF (PAGE_SW) THEN CALL PUT_HEADINGS; 165I 3 2 1802 END; 166I 3 1 1803 IF (I=0) 167I THEN DO; 168I 3 2 1805 PUT SKIP; 169I 3 2 1806 LINE_#=LINE_#+1; 170I 3 2 1807 END; 171I 3 1 1808 END; 172I 3 1809 CALL PUT_FOOTINGS; 173I 3 1810 END PUT_FTABLE; 174I 2 1811 PUT_HEADINGS: 175I PROC; 176I 3 1812 DCL I STATIC; 177I 3 1813 DO I=1 TO #_HEADS; 178I 3 1 1814 PUT EDIT(TABLE_HEADING(I)) (A); 179I 3 1 1815 PUT SKIP; 180I 3 1 1816 END; 181I 3 1817 PUT EDIT(T_LABS(1)) (A); 182I 3 1818 PUT SKIP(2); 183I 3 1819 DO I=2 TO T_LAB#; 184I 3 1 1820 PUT EDIT(T_LABS(I)) (A); 185I 3 1 1821 PUT SKIP; 186I 3 1 1822 END; 187I 3 1823 PUT SKIP; 188I 3 1824 LINE_#=LINE_#+#_HEADS+T_LAB#+2; 189I 3 1825 END PUT_HEADINGS; 190I 2 1826 TABLE_PAGING: 191I PROC; 192I 3 1827 IF (#_FOOTS=0) 193I THEN DO; 194I 3 1 1829 CALL PP_PAGING; 195I 3 1 1830 RETURN; 196I 3 1 1831 END; 197I 3 1832 IF (LINE_#=#LINE_#-#_FOOTS-1) 198I THEN CALL PUT_FOOTINGS; 199I 3 1834 CALL PP_PAGING; 200I 3 1835 END TABLE_PAGING; 201I 2 1836 PUT_FOOTINGS: 202I PROC; 203I 3 1837 PUT SKIP; 204I 3 1838 DO #=1 TO #_FOOTS; 205I 3 1 1839 PUT EDIT(TABLE_FOOTING(#)) (SKIP,A); 206I 3 1 1840 END; 207I 3 1841 LINE_#=0; 208I 3 1842 END PUT_FOOTINGS; 209I 2 1843 END PRINT_TABLE1; 1029. 1 1844 %PAGE; 1030. %INCLUDE(PP.COPY/TABLELABS); 1I TABLELABS: 2I PROC(S1_LAB,S2_LAB,S3_LAB,SP_LAB, 3I SP_LABS,SP_#,CELL_##,GRID_##,GRID_COL, 4I T_LABS,T_LAB#); 5I 2 1845 DCL (S1_LAB,S2_LAB,S3_LAB,SP_LAB) 6I CHAR(28) VAR; 7I 2 1846 DCL SP_LABS(*) CHAR(56) VAR; 8I 2 1847 DCL (SP_#,CELL_##,GRID_##,GRID_COL); 9I 2 1848 DCL T_LABS(4) CHAR(132); 10I 2 1849 DCL T_LAB# ; 11I 2 1850 DCL (I,J,JS,K,L,##) STATIC; 12I 2 1851 T_LABS=COPY(' ',132); 13I 2 1852 SUBSTR(T_LABS(1),1,LENGTH(S1_LAB))=S1_LAB; 14I 2 1853 I=GRID_COL+(GRID_##-LENGTH(SP_LAB))/2; 15I 2 1854 IF (LENGTH(S1_LAB)+4>I) THEN I=LENGTH(S1_LAB)+4; 16I 2 1856 SUBSTR(T_LABS(1),I)=SP_LAB; 17I 2 1857 SUBSTR(T_LABS(2),5)=S2_LAB; 18I 2 1858 SUBSTR(T_LABS(4),9)=S3_LAB; 19I 2 1859 ##=0; 20I 2 1860 DO I=1 TO SP_#; 21I 2 1 1861 ##=MAX(##,LENGTH(SP_LABS(I))); 22I 2 1 1862 END; 23I 2 1863 T_LAB#=2; 24I 2 1864 IF (##<CELL_##) 25I THEN DO; 26I 2 1 1866 DO I=1 TO SP_#; 27I 2 2 1867 SUBSTR(T_LABS(2),GRID_COL+(I-1)*CELL_##,CELL_##)= 28I RJ(SP_LABS(I),CELL_##); 29I 2 2 1868 END; 30I 2 1 1869 GOTO EXIT; 31I 2 1 1870 END; 32I 2 1871 DO I=1 TO SP_#; 33I 2 1 1872 ##=LENGTH(SP_LABS(I)); 34I 2 1 1873 J=1; 35I 2 1 1874 DO K=2 TO 4; 36I 2 2 1875 DO WHILE((SUBSTR(SP_LABS(I),J,1)=' ')& 37I (J<=##)); 38I 2 3 1876 J=J+1; 39I 2 3 1877 END; 40I 2 2 1878 JS=J; 41I 2 2 1879 L=0; 42I 2 2 1880 DO WHILE((SUBSTR(SP_LABS(I),J,1)^=' ')& 43I (J<=##)); 44I 2 3 1881 J=J+1; 45I 2 3 1882 L=L+1; 46I 2 3 1883 END; 47I 2 2 1884 SUBSTR(T_LABS(K),GRID_COL+(I-1)*CELL_##,CELL_##)= 48I RJ(SUBSTR(SP_LABS(I),JS,L),CELL_##); 49I 2 2 1885 END; 50I 2 1 1886 END; 51I 2 1887 EXIT: 52I IF (T_LABS(4)^=COPY(' ',132)) 53I THEN T_LAB#=4; 54I 2 1889 ELSE 55I IF (T_LABS(3)^=COPY(' ',132)) 56I THEN T_LAB#=3; 57I 2 1891 RJ: 58I PROC(STRING,##) RETURNS(CHAR(80) VAR); 59I 3 1892 DCL STRING CHAR(*); 60I 3 1893 DCL ## ; 61I 3 1894 DCL I STATIC; 62I 3 1895 DO I=LENGTH(STRING) TO 1 BY -1; 63I 3 1 1896 IF (SUBSTR(STRING,I,1)^=' ') THEN GO TO RJ_TAG1; 64I 3 1 1898 END; 65I 3 1899 RJ_TAG1: 66I IF (##<=I) THEN I=##-1; 67I 3 1901 RETURN(COPY(' ',##-I)!!SUBSTR(STRING,1,I)); 68I 3 1902 END RJ; 69I 2 1903 END TABLELABS; 1031. 1 1904 DCL OUT_SW BIT INIT('1'B); 1032. 1 1905 PP_OUTPUTS: 1033. PROC; 1034. 2 1906 OUTPUT_#=OUTPUT_#+1; 1035. 2 1907 CALL TABLE_001; 1036. 2 1908 CALL TABLE_002; 1037. 2 1909 CALL TABLE_003; 1038. 2 1910 CALL TABLE_004; 1039. 2 1911 CALL TABLE_005; 1040. 2 1912 CALL TABLE_006; 1041. 2 1913 CALL TABLE_007; 1042. 2 1914 CALL PP_REPORTS; 1043. 2 1915 END PP_OUTPUTS; 1044. 1 1916 LOAD_FUNCTIONS: 1045. PROC; 1046. 2 1917 END LOAD_FUNCTIONS; 1047. 1 1918 DCL SUBTITLES(1) CHAR(132); 1048. 1 1919 DCL #_SUBTITLES INIT(0); 1049. 1 1920 DCL RUN_SW BIT INIT('1'B); 1050. 1 1921 END PP_TARGET; **** NO ERRORS OR WARNINGS IN ABOVE PROGRAM END PL1 0 ERRORS 0 WARNINGS 17521 IBANK 6437 DBANK @BK2,E