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