00001 IDENTIFICATION DIVISION. 02/13/04 00002 PROGRAM-ID. PICKNMBR. PICKNMBR 00003 AUTHOR YU-SHING(ELSA) CHEN. LV001 00004 DATE-WRITTEN. NOV. 24, 1992. PICKNMBR 00005 ** PICKNMBR 00006 *************************************************************** PICKNMBR 00007 ** -----------------PROGRAM DESCRIPTION--------------------- ** PICKNMBR 00008 ** VS COBOL VERSION ** PICKNMBR 00009 *************************************************************** PICKNMBR 00010 ** THIS PROGRAM CALCULATES WHICH RECORDS ARE TO BE SELECTED ** PICKNMBR 00011 ** FOR THE SAMPLE. TO EXECUTE THE PICKNMBR PROGRAM THE ** PICKNMBR 00012 ** FOLLOWING FIELDS ARE REQUIRED, A RANDOM NUMBER, THE ** PICKNMBR 00013 ** NUMBER OF RECORDS TO BE SELECTED, AND THE TOTAL NUMBER OF ** PICKNMBR 00014 ** RECORDS ON THE TRANSACTION FILE. ** PICKNMBR 00015 ** ** PICKNMBR 00016 ** (THIS INFO COMES IN ON A PARM CARD - JHP) ** PICKNMBR 00017 *************************************************************** PICKNMBR 00018 ** MAINTENANCE HISTORY: ** PICKNMBR 00019 ** ** PICKNMBR 00020 ** 06-15-00 CHANGED TO ENSURE THAT THE 'SKIP INTERVAL' FIELD ** PICKNMBR 00021 ** HAS A MINIMUM VALUE OF ONE (1) ** PICKNMBR 00022 ** PROGRAMMER - JHP ** PICKNMBR 00023 ** ** PICKNMBR 00024 *************************************************************** PICKNMBR 00025 * PICKNMBR 00026 ENVIRONMENT DIVISION. PICKNMBR 00027 CONFIGURATION SECTION. PICKNMBR 00028 INPUT-OUTPUT SECTION. PICKNMBR 00029 FILE-CONTROL. PICKNMBR 00030 SELECT CNTRL-DATA ASSIGN TO UT-S-CNTRLDTA. PICKNMBR 00031 SELECT SELECT-NUMBERS ASSIGN TO UT-S-SELNMBR. PICKNMBR 00032 SELECT PICKNUM-LIST ASSIGN TO UT-S-PICKLST. PICKNMBR 00033 ** PICKNMBR 00034 DATA DIVISION. PICKNMBR 00035 FILE SECTION. PICKNMBR 00036 *************************************************************** PICKNMBR 00037 ** CNTRL-DATA CONTAINS SOME OF THE PROCESSING INFORMATION ** PICKNMBR 00038 ** NEEDED FOR SAMPLING. IT CONTAINS THE RANDOM NUMBER ** PICKNMBR 00039 ** (CNTRL-RANDOM), THE NUMBER OF RECORDS TO BE SELECTED FOR ** PICKNMBR 00040 ** THE SAMPLE (SAMPLED-NMBR), AND THE RECORD COUNT OF THE ** PICKNMBR 00041 ** NUMBER OF RECORDS (TRANS-REC-CNTR) CONTAINED ON THE ** PICKNMBR 00042 ** TRANS-FILE. ** PICKNMBR 00043 *************************************************************** PICKNMBR 00044 ** PICKNMBR 00045 FD CNTRL-DATA PICKNMBR 00046 RECORDING MODE IS F PICKNMBR 00047 LABEL RECORD IS OMITTED PICKNMBR 00048 BLOCK CONTAINS 1 RECORDS. PICKNMBR 00049 01 CNTRL-DATA-REC. PICKNMBR 00050 05 CNTRL-TYPE PIC X(5). PICKNMBR 00051 05 CNTRL-TRANS-TYPE PIC X. PICKNMBR 00052 05 CNTRL-SESA-ID PIC XX. PICKNMBR 00053 05 CNTRL-RANDOM PIC V999. PICKNMBR 00054 05 CNTRL-RANDOM-ALF REDEFINES CNTRL-RANDOM PIC X(3). PICKNMBR 00055 05 SAMPLED-NMBR PIC 9(4). PICKNMBR 00056 05 SAMPLED-NMBR-ALF REDEFINES SAMPLED-NMBR PIC X(4). PICKNMBR 00057 05 TRANS-REC-CNTR PIC 9(8). PICKNMBR 00058 05 TRANS-REC-CNTR-ALF REDEFINES TRANS-REC-CNTR PIC X(8). PICKNMBR 00059 05 SAMPLE-TYPE PIC XX. PICKNMBR 00060 05 CNTRL-YEAR-QTR PIC X(8). PICKNMBR 00061 ** PICKNMBR 00062 FD SELECT-NUMBERS PICKNMBR 00063 RECORDING MODE IS F PICKNMBR 00064 LABEL RECORD IS STANDARD PICKNMBR 00065 BLOCK CONTAINS 0 RECORDS. PICKNMBR 00066 01 SELECTED-REC. PICKNMBR 00067 05 SEL-REC-NO PIC 9(8). PICKNMBR 00068 ** PICKNMBR 00069 *************************************************************** PICKNMBR 00070 ** PICKNUM-LIST IS AN OUTPUT LISTING WHICH CONTAINS THE ** PICKNMBR 00071 ** CALCULATED NUMBERS OF THE RECORDS WHICH WILL BE PULLED ** PICKNMBR 00072 ** FOR SAMPLING AND THE CORRESPONDING CASE NUMBERS. ** PICKNMBR 00073 *************************************************************** PICKNMBR 00074 * PICKNMBR 00075 FD PICKNUM-LIST PICKNMBR 00076 RECORDING MODE IS F PICKNMBR 00077 LABEL RECORD IS STANDARD PICKNMBR 00078 BLOCK CONTAINS 0 RECORDS. PICKNMBR 00079 01 PICKNUM-REC PIC X(132). PICKNMBR 00080 ** PICKNMBR 00081 WORKING-STORAGE SECTION. PICKNMBR 000815 77 PAN-VALET PICTURE X(24) VALUE '001PICKNMBR 02/13/04'. PICKNMBR 00082 77 SKIP-INTERVAL PIC 9(8) VALUE 0. PICKNMBR 00083 77 SKIP-INTERVAL-B PIC 9(8)V999 VALUE 0.000. PICKNMBR 00084 77 SELECT-CNTR PIC 9(5) VALUE 0. PICKNMBR 00085 77 INITIAL-CASE PIC 9(5) VALUE 0. PICKNMBR 00086 77 ODD-EVEN-CNTL PIC 9 VALUE 0. PICKNMBR 00087 77 TEMP-LOOP-NBR PIC 9(8) VALUE 0. PICKNMBR 00088 77 LOOP-NBR PIC S9(8) VALUE +0. PICKNMBR 00089 77 ONE-MORE-REC PIC 9(8) VALUE 0. PICKNMBR 00090 77 MATCH-CNTR PIC 9(5) VALUE 0. PICKNMBR 00091 77 CNTRL-FLAG PIC X VALUE 'N'. PICKNMBR 00092 77 ODD-LOOP-NBR PIC 9(8) VALUE 0. PICKNMBR 00093 77 SEL-1 PIC 9(8) VALUE 0. PICKNMBR 00094 77 SEL-2 PIC 9(8) VALUE 0. PICKNMBR 00095 77 SEL-NMBR PIC 9(8) VALUE 0. PICKNMBR 00096 77 SEL-ACCU PIC 9(8)V999 VALUE 0.000. PICKNMBR 00097 77 STOP-FLAG PIC 9 VALUE 0. PICKNMBR 00098 77 EOF PIC 9 VALUE 0. PICKNMBR 00099 77 LIST-PAGE PIC 9(6) VALUE 0. PICKNMBR 00100 77 LIST-COUNTER PIC 999 VALUE 0. PICKNMBR 00101 77 FIPS-FLAG PIC 9 VALUE 0. PICKNMBR 00102 ** PICKNMBR 00103 01 CASE-NUM PIC 9(8) VALUE 0. PICKNMBR 00104 ** PICKNMBR 00105 01 WS-CURRENT-DATE. PICKNMBR 00106 05 WS-DATE PIC 9(06) VALUE ZEROES. PICKNMBR 00107 05 WS-DATE-R REDEFINES WS-DATE. PICKNMBR 00108 10 WS-YY PIC 9(02). PICKNMBR 00109 10 WS-MM PIC 9(02). PICKNMBR 00110 10 WS-DD PIC 9(02). PICKNMBR 00111 PICKNMBR 00112 05 WRK-DATE-AREA. PICKNMBR 00113 10 WRK-MM PIC X(02). PICKNMBR 00114 10 FILLER PIC X(01) VALUE '/'. PICKNMBR 00115 10 WRK-DD PIC X(02). PICKNMBR 00116 10 FILLER PIC X(01) VALUE '/'. PICKNMBR 00117 10 WRK-YY PIC X(02). PICKNMBR 00118 ** PICKNMBR 00119 01 RUN-DATE PIC 9(6). PICKNMBR 00120 01 FILLER REDEFINES RUN-DATE. PICKNMBR 00121 05 RUN-DATE-MM PIC 99. PICKNMBR 00122 05 RUN-DATE-DD PIC 99. PICKNMBR 00123 05 RUN-DATE-YY PIC 99. PICKNMBR 00124 ** PICKNMBR 00125 01 O-PICKNUM-REC. PICKNMBR 00126 05 FILLER PIC X(10) VALUE SPACES. PICKNMBR 00127 05 O-CASE-NUM PIC ZZZZZZZ9. PICKNMBR 00128 05 FILLER PIC X(7) VALUE SPACES. PICKNMBR 00129 05 O-PICK-NUM PIC ZZZZZZZ9. PICKNMBR 00130 05 FILLER PIC X(99) VALUE SPACES. PICKNMBR 00131 ** PICKNMBR 00132 01 O-LIST-1-REC. PICKNMBR 00133 05 FILLER PIC X(10) VALUE SPACES. PICKNMBR 00134 05 FILLER PIC X(30) PICKNMBR 00135 VALUE '******************************'. PICKNMBR 00136 05 FILLER PIC X(30) PICKNMBR 00137 VALUE '******************************'. PICKNMBR 00138 05 FILLER PIC X(62) VALUE SPACES. PICKNMBR 00139 ** PICKNMBR 00140 01 O-LIST-2-REC. PICKNMBR 00141 05 FILLER PIC X(10) VALUE SPACES. PICKNMBR 00142 05 FILLER PIC X(27) PICKNMBR 00143 VALUE '* INFORMATION USED'. PICKNMBR 00144 05 FILLER PIC X(33) PICKNMBR 00145 VALUE ' IN THE CALCULATIONS *'. PICKNMBR 00146 05 FILLER PIC X(62) VALUE SPACES. PICKNMBR 00147 ** PICKNMBR 00148 01 O-LIST-3-REC. PICKNMBR 00149 05 FILLER PIC X(10) VALUE SPACES. PICKNMBR 00150 05 FILLER PIC X VALUE '*'. PICKNMBR 00151 05 CNTL-ITEM PIC X(40) VALUE SPACES. PICKNMBR 00152 05 FILLER PIC X(09) VALUE SPACES. PICKNMBR 00153 05 CNTL-VALUE PIC ZZZZZZZ9. PICKNMBR 00154 05 CNTL-VALUE-X REDEFINES CNTL-VALUE PICKNMBR 00155 PIC X(8). PICKNMBR 00156 05 FILLER PIC X(2) VALUE ' *'. PICKNMBR 00157 05 FILLER PIC X(52) VALUE SPACES. PICKNMBR 00158 ** PICKNMBR 00159 01 O-LIST-4-REC. PICKNMBR 00160 05 FILLER PIC X(10) VALUE SPACES. PICKNMBR 00161 05 FILLER PIC X VALUE '*'. PICKNMBR 00162 05 CNTL-ITEM-2 PIC X(39) VALUE SPACES. PICKNMBR 00163 05 FILLER PIC X(6) VALUE SPACES. PICKNMBR 00164 05 CNTL-VALUE-2 PIC ZZZZZZZ9.999. PICKNMBR 00165 05 FILLER PIC X(2) VALUE ' *'. PICKNMBR 00166 05 FILLER PIC X(52) VALUE SPACES. PICKNMBR 00167 ** PICKNMBR 00168 01 O-LIST-5-REC. PICKNMBR 00169 05 FILLER PIC X(10) VALUE SPACES. PICKNMBR 00170 05 FILLER PIC X VALUE '*'. PICKNMBR 00171 05 FILLER PIC X(58) VALUE SPACES. PICKNMBR 00172 05 FILLER PIC X VALUE '*'. PICKNMBR 00173 05 FILLER PIC X(62) VALUE SPACES. PICKNMBR 00174 ** PICKNMBR 00175 01 DIGIT-8 PIC X(8) VALUE SPACES. PICKNMBR 00176 01 FILLER REDEFINES DIGIT-8. PICKNMBR 00177 05 DIGIT-8-4-A PIC X(4). PICKNMBR 00178 05 DIGIT-8-MM-A PIC X(2). PICKNMBR 00179 05 DIGIT-8-DD-A PIC X(2). PICKNMBR 00180 ** PICKNMBR 00181 01 DIGIT-8-2-2. PICKNMBR 00182 05 DIGIT-8-4-B PIC X(4) VALUE SPACES. PICKNMBR 00183 05 FILLER PIC X VALUE '/'. PICKNMBR 00184 05 DIGIT-8-MM-B PIC X(2) VALUE SPACES. PICKNMBR 00185 05 FILLER PIC X VALUE '/'. PICKNMBR 00186 05 DIGIT-8-DD-B PIC X(2) VALUE SPACES. PICKNMBR 00187 ** PICKNMBR 00188 01 DIGIT-5 PIC X(8) VALUE SPACES. PICKNMBR 00189 01 FILLER REDEFINES DIGIT-5. PICKNMBR 00190 05 DIGIT-5-4-A PIC X(4). PICKNMBR 00191 05 DIGIT-5-1-A PIC X(1). PICKNMBR 00192 05 DIGIT-5-3-A PIC X(3). PICKNMBR 00193 ** PICKNMBR 00194 01 DIGIT-5-3. PICKNMBR 00195 05 DIGIT-5-4-B PIC X(4) VALUE SPACES. PICKNMBR 00196 05 FILLER PIC X VALUE '/'. PICKNMBR 00197 05 DIGIT-5-1-B PIC X(1) VALUE SPACES. PICKNMBR 00198 05 FILLER PIC X(2) VALUE SPACES. PICKNMBR 00199 ** PICKNMBR 00200 01 DIGIT-4-4. PICKNMBR 00201 05 DIGIT-4 PIC X(4) VALUE SPACES. PICKNMBR 00202 05 DIGIT-2-4 PIC X(4) VALUE SPACES. PICKNMBR 00203 ** PICKNMBR 00204 01 PERIOD-Y PIC X(12) VALUE ' (YYYY): '. PICKNMBR 00205 01 PERIOD-YQ PIC X(12) VALUE ' (YYYYQ): '. PICKNMBR 00206 01 PERIOD-YMD PIC X(12) VALUE '(YYYYMMDD): '. PICKNMBR 00207 * PICKNMBR 00208 *************************************************************** PICKNMBR 00209 ** STATE-TABLE: ** PICKNMBR 00210 ** CONTAINS THE STATE NAME. ** PICKNMBR 00211 *************************************************************** PICKNMBR 00212 * PICKNMBR 00213 01 STATE-TABLE. PICKNMBR 00214 03 STATE-NAME-TABLE. PICKNMBR 00215 05 FILLER PIC X(20) VALUE 'ALABAMA'. PICKNMBR 00216 05 FILLER PIC X(20) VALUE 'ALASKA'. PICKNMBR 00217 05 FILLER PIC X(20) VALUE 'ARIZONA'. PICKNMBR 00218 05 FILLER PIC X(20) VALUE 'ARKANSAS'. PICKNMBR 00219 05 FILLER PIC X(20) VALUE 'CALIFORNIA'. PICKNMBR 00220 05 FILLER PIC X(20) VALUE 'COLORADO'. PICKNMBR 00221 05 FILLER PIC X(20) VALUE 'CONNECTICUT'. PICKNMBR 00222 05 FILLER PIC X(20) VALUE 'DELAWARE'. PICKNMBR 00223 05 FILLER PIC X(20) VALUE 'DISTRICT OF COLUMBIA'. PICKNMBR 00224 05 FILLER PIC X(20) VALUE 'FLORIDA'. PICKNMBR 00225 05 FILLER PIC X(20) VALUE 'GEORGIA'. PICKNMBR 00226 05 FILLER PIC X(20) VALUE 'HAWAII'. PICKNMBR 00227 05 FILLER PIC X(20) VALUE 'IDAHO'. PICKNMBR 00228 05 FILLER PIC X(20) VALUE 'ILLINOIS'. PICKNMBR 00229 05 FILLER PIC X(20) VALUE 'INDIANA'. PICKNMBR 00230 05 FILLER PIC X(20) VALUE 'IOWA'. PICKNMBR 00231 05 FILLER PIC X(20) VALUE 'KANSAS'. PICKNMBR 00232 05 FILLER PIC X(20) VALUE 'KENTUCKY'. PICKNMBR 00233 05 FILLER PIC X(20) VALUE 'LOUISIANA'. PICKNMBR 00234 05 FILLER PIC X(20) VALUE 'MAINE'. PICKNMBR 00235 05 FILLER PIC X(20) VALUE 'MARYLAND'. PICKNMBR 00236 05 FILLER PIC X(20) VALUE 'MASSACHUSETTS'. PICKNMBR 00237 05 FILLER PIC X(20) VALUE 'MICHIGAN'. PICKNMBR 00238 05 FILLER PIC X(20) VALUE 'MINNESOTA'. PICKNMBR 00239 05 FILLER PIC X(20) VALUE 'MISSISSIPPI'. PICKNMBR 00240 05 FILLER PIC X(20) VALUE 'MISSOURI'. PICKNMBR 00241 05 FILLER PIC X(20) VALUE 'MONTANA'. PICKNMBR 00242 05 FILLER PIC X(20) VALUE 'NEBRASKA'. PICKNMBR 00243 05 FILLER PIC X(20) VALUE 'NEVADA'. PICKNMBR 00244 05 FILLER PIC X(20) VALUE 'NEW HAMPSHIRE'. PICKNMBR 00245 05 FILLER PIC X(20) VALUE 'NEW JERSEY'. PICKNMBR 00246 05 FILLER PIC X(20) VALUE 'NEW MEXICO'. PICKNMBR 00247 05 FILLER PIC X(20) VALUE 'NEW YORK'. PICKNMBR 00248 05 FILLER PIC X(20) VALUE 'NORTH CAROLINA'. PICKNMBR 00249 05 FILLER PIC X(20) VALUE 'NORTH DAKOTA'. PICKNMBR 00250 05 FILLER PIC X(20) VALUE 'OHIO'. PICKNMBR 00251 05 FILLER PIC X(20) VALUE 'OKLAHOMA'. PICKNMBR 00252 05 FILLER PIC X(20) VALUE 'OREGON'. PICKNMBR 00253 05 FILLER PIC X(20) VALUE 'PENNSYLVANIA'. PICKNMBR 00254 05 FILLER PIC X(20) VALUE 'PUERTO RICO'. PICKNMBR 00255 05 FILLER PIC X(20) VALUE 'RHODE ISLAND'. PICKNMBR 00256 05 FILLER PIC X(20) VALUE 'SOUTH CAROLINA'. PICKNMBR 00257 05 FILLER PIC X(20) VALUE 'SOUTH DAKOTA'. PICKNMBR 00258 05 FILLER PIC X(20) VALUE 'TENNESSEE'. PICKNMBR 00259 05 FILLER PIC X(20) VALUE 'TEXAS'. PICKNMBR 00260 05 FILLER PIC X(20) VALUE 'UTAH'. PICKNMBR 00261 05 FILLER PIC X(20) VALUE 'VERMONT'. PICKNMBR 00262 05 FILLER PIC X(20) VALUE 'VIRGINIA'. PICKNMBR 00263 05 FILLER PIC X(20) VALUE 'VIRGIN ISLANDS'. PICKNMBR 00264 05 FILLER PIC X(20) VALUE 'WASHINGTON'. PICKNMBR 00265 05 FILLER PIC X(20) VALUE 'WEST VIRGINIA'. PICKNMBR 00266 05 FILLER PIC X(20) VALUE 'WISCONSIN'. PICKNMBR 00267 05 FILLER PIC X(20) VALUE 'WYOMING'. PICKNMBR 00268 03 STATE-NAME REDEFINES STATE-NAME-TABLE OCCURS 53 TIMES INPICKNMBR 00269 - DEXED BY STATE-NAME-INDEX PIC X(20). PICKNMBR 00270 * PICKNMBR 00271 *************************************************************** PICKNMBR 00272 ** STATE-ID-TABLE: ** PICKNMBR 00273 ** CONTAINS THE FIPS CODE. ** PICKNMBR 00274 *************************************************************** PICKNMBR 00275 * PICKNMBR 00276 03 STATE-ID-TABLE. PICKNMBR 00277 05 FILLER PIC X(2) VALUE 'AL'. PICKNMBR 00278 05 FILLER PIC X(2) VALUE 'AK'. PICKNMBR 00279 05 FILLER PIC X(2) VALUE 'AZ'. PICKNMBR 00280 05 FILLER PIC X(2) VALUE 'AR'. PICKNMBR 00281 05 FILLER PIC X(2) VALUE 'CA'. PICKNMBR 00282 05 FILLER PIC X(2) VALUE 'CO'. PICKNMBR 00283 05 FILLER PIC X(2) VALUE 'CT'. PICKNMBR 00284 05 FILLER PIC X(2) VALUE 'DE'. PICKNMBR 00285 05 FILLER PIC X(2) VALUE 'DC'. PICKNMBR 00286 05 FILLER PIC X(2) VALUE 'FL'. PICKNMBR 00287 05 FILLER PIC X(2) VALUE 'GA'. PICKNMBR 00288 05 FILLER PIC X(2) VALUE 'HI'. PICKNMBR 00289 05 FILLER PIC X(2) VALUE 'ID'. PICKNMBR 00290 05 FILLER PIC X(2) VALUE 'IL'. PICKNMBR 00291 05 FILLER PIC X(2) VALUE 'IN'. PICKNMBR 00292 05 FILLER PIC X(2) VALUE 'IA'. PICKNMBR 00293 05 FILLER PIC X(2) VALUE 'KS'. PICKNMBR 00294 05 FILLER PIC X(2) VALUE 'KY'. PICKNMBR 00295 05 FILLER PIC X(2) VALUE 'LA'. PICKNMBR 00296 05 FILLER PIC X(2) VALUE 'ME'. PICKNMBR 00297 05 FILLER PIC X(2) VALUE 'MD'. PICKNMBR 00298 05 FILLER PIC X(2) VALUE 'MA'. PICKNMBR 00299 05 FILLER PIC X(2) VALUE 'MI'. PICKNMBR 00300 05 FILLER PIC X(2) VALUE 'MN'. PICKNMBR 00301 05 FILLER PIC X(2) VALUE 'MS'. PICKNMBR 00302 05 FILLER PIC X(2) VALUE 'MO'. PICKNMBR 00303 05 FILLER PIC X(2) VALUE 'MT'. PICKNMBR 00304 05 FILLER PIC X(2) VALUE 'NE'. PICKNMBR 00305 05 FILLER PIC X(2) VALUE 'NV'. PICKNMBR 00306 05 FILLER PIC X(2) VALUE 'NH'. PICKNMBR 00307 05 FILLER PIC X(2) VALUE 'NJ'. PICKNMBR 00308 05 FILLER PIC X(2) VALUE 'NM'. PICKNMBR 00309 05 FILLER PIC X(2) VALUE 'NY'. PICKNMBR 00310 05 FILLER PIC X(2) VALUE 'NC'. PICKNMBR 00311 05 FILLER PIC X(2) VALUE 'ND'. PICKNMBR 00312 05 FILLER PIC X(2) VALUE 'OH'. PICKNMBR 00313 05 FILLER PIC X(2) VALUE 'OK'. PICKNMBR 00314 05 FILLER PIC X(2) VALUE 'OR'. PICKNMBR 00315 05 FILLER PIC X(2) VALUE 'PA'. PICKNMBR 00316 05 FILLER PIC X(2) VALUE 'PR'. PICKNMBR 00317 05 FILLER PIC X(2) VALUE 'RI'. PICKNMBR 00318 05 FILLER PIC X(2) VALUE 'SC'. PICKNMBR 00319 05 FILLER PIC X(2) VALUE 'SD'. PICKNMBR 00320 05 FILLER PIC X(2) VALUE 'TN'. PICKNMBR 00321 05 FILLER PIC X(2) VALUE 'TX'. PICKNMBR 00322 05 FILLER PIC X(2) VALUE 'UT'. PICKNMBR 00323 05 FILLER PIC X(2) VALUE 'VT'. PICKNMBR 00324 05 FILLER PIC X(2) VALUE 'VA'. PICKNMBR 00325 05 FILLER PIC X(2) VALUE 'VI'. PICKNMBR 00326 05 FILLER PIC X(2) VALUE 'WA'. PICKNMBR 00327 05 FILLER PIC X(2) VALUE 'WV'. PICKNMBR 00328 05 FILLER PIC X(2) VALUE 'WI'. PICKNMBR 00329 05 FILLER PIC X(2) VALUE 'WY'. PICKNMBR 00330 03 STATE-ID REDEFINES STATE-ID-TABLE OCCURS 53 TIMES INPICKNMBR 00331 - DEXED BY STATE-ID-INDEX PIC X(2). PICKNMBR 00332 ****** PICKNMBR 00333 01 SPL-TABLE-CONTROLS. PICKNMBR 00334 05 SPL-ENTRY-FOUND-SWITCH PIC X(03). PICKNMBR 00335 88 SPL-ENTRY-FOUND VALUE 'YES'. PICKNMBR 00336 88 SPL-END-OF-TABLE VALUE 'END'. PICKNMBR 00337 * PICKNMBR 00338 *************************************************************** PICKNMBR 00339 ** SPL-TYPE-DATA. ** PICKNMBR 00340 ** CONTAINS THE RQC SAMPLE TYPES, A 2 CHARACTER CODE AND A ** PICKNMBR 00341 ** 25 CHARACTER DEFINITION. ** PICKNMBR 00342 *************************************************************** PICKNMBR 00343 * PICKNMBR 00344 01 SPL-TYPE-DATA. PICKNMBR 00345 05 FILLER PIC X(27) VALUE 'A11ST ACCEPTANCE SAMPLE '. PICKNMBR 00346 05 FILLER PIC X(27) VALUE 'A22ND ACCEPTANCE SAMPLE '. PICKNMBR 00347 05 FILLER PIC X(27) VALUE 'E1EXPANDED SAMPLE '. PICKNMBR 00348 05 FILLER PIC X(27) VALUE 'O11ST SESA OPTIONAL SAMPLE '. PICKNMBR 00349 05 FILLER PIC X(27) VALUE 'O22ND SESA OPTIONAL SAMPLE '. PICKNMBR 00350 01 SPL-TYPE-TABLE REDEFINES SPL-TYPE-DATA. PICKNMBR 00351 05 SPL-TABLE-ENTRY OCCURS 5 TIMES PICKNMBR 00352 INDEXED BY SPL-INDEX. PICKNMBR 00353 10 SPL-ID PIC X(2). PICKNMBR 00354 10 SPL-NAME PIC X(25). PICKNMBR 00355 ** PICKNMBR 00356 *************************************************************** PICKNMBR 00357 ** (OUTPUT-TITLES) DESCRIBES THE LINES FOR EACH LINE OF THE ** PICKNMBR 00358 ** REPORT TITLE. ** PICKNMBR 00359 *************************************************************** PICKNMBR 00360 01 LIST-HEADING-1. PICKNMBR 00361 10 FILLER PIC X(1) VALUE SPACES. PICKNMBR 00362 10 FILLER PIC X(9) VALUE 'RUN DATE:'. PICKNMBR 00363 10 FILLER PIC X(1) VALUE SPACES. PICKNMBR 00364 10 O-RUN-DATE PIC X(8) VALUE SPACES. PICKNMBR 00365 10 FILLER PIC X(14) VALUE SPACES. PICKNMBR 00366 10 O-TITLE PIC X(35) VALUE SPACES. PICKNMBR 00367 10 FILLER PIC X(33) VALUE SPACES. PICKNMBR 00368 10 FILLER PIC X(5) VALUE 'PAGE:'. PICKNMBR 00369 10 FILLER PIC X(1) VALUE SPACES. PICKNMBR 00370 10 O-LIST-PAGE PIC ZZZZZ9 VALUE ZEROS. PICKNMBR 00371 10 FILLER PIC X(19) VALUE SPACES. PICKNMBR 00372 ** PICKNMBR 00373 01 LIST-HEADING-2. PICKNMBR 00374 10 FILLER PIC X(37) VALUE SPACES. PICKNMBR 00375 10 FILLER PIC X(20) PICKNMBR 00376 VALUE 'RECORDS FOR SAMPLING'. PICKNMBR 00377 10 FILLER PIC X(75) VALUE SPACES. PICKNMBR 00378 ** PICKNMBR 00379 01 LIST-HEADING-3. PICKNMBR 00380 10 FILLER PIC X(1) VALUE SPACES. PICKNMBR 00381 10 FILLER PIC X(6) VALUE 'PERIOD'. PICKNMBR 00382 10 O-PERIOD-MARK PIC X(12) VALUE SPACES. PICKNMBR 00383 10 O-PERIOD PIC X(12) VALUE SPACES. PICKNMBR 00384 10 FILLER PIC X(9) VALUE SPACES. PICKNMBR 00385 10 FILLER PIC X(9) VALUE 'STATE OF '. PICKNMBR 00386 10 O-SESA-NAME PIC X(20) VALUE SPACES. PICKNMBR 00387 10 FILLER PIC X(3) VALUE SPACES. PICKNMBR 00388 10 FILLER PIC X(13) VALUE 'SAMPLE TYPE: '. PICKNMBR 00389 10 O-SAMPLE-TYPE PIC X(27) VALUE SPACES. PICKNMBR 00390 10 FILLER PIC X(20) VALUE SPACES. PICKNMBR 00391 ** PICKNMBR 00392 01 LIST-HEADING-4. PICKNMBR 00393 10 FILLER PIC X(10) VALUE SPACES. PICKNMBR 00394 10 FILLER PIC X(11) VALUE 'CASE NUMBER'. PICKNMBR 00395 10 FILLER PIC X(4) VALUE SPACES. PICKNMBR 00396 10 FILLER PIC X(15) VALUE 'SEQUENCE NUMBER'. PICKNMBR 00397 10 FILLER PIC X(82) VALUE SPACES. PICKNMBR 00398 01 BLANK-LINE. PICKNMBR 00399 10 FILLER PIC X(132) VALUE SPACES. PICKNMBR 00400 *** PICKNMBR 00401 PROCEDURE DIVISION. PICKNMBR 00402 *************************************************************** PICKNMBR 00403 ** 0000-DRIVER-ROUTINE. ** PICKNMBR 00404 ** THIS SECTION PERFORMS THE MAIN PROCESSING OF THE PROGRAM. ** PICKNMBR 00405 *************************************************************** PICKNMBR 00406 0000-DRIVER-ROUTINE. PICKNMBR 00407 ACCEPT WS-DATE FROM DATE. PICKNMBR 00408 MOVE WS-YY TO WRK-YY. PICKNMBR 00409 MOVE WS-MM TO WRK-MM. PICKNMBR 00410 MOVE WS-DD TO WRK-DD. PICKNMBR 00411 MOVE WRK-DATE-AREA TO O-RUN-DATE. PICKNMBR 00412 PERFORM 0100-OPEN-ROUTINE THRU 0100-OPEN-ROUTINE-EXIT. PICKNMBR 00413 PERFORM 0110-CNTL-OPTION THRU 0110-CNTL-OPTION-EXIT. PICKNMBR 00414 PERFORM 0120-CNTL-ERROR THRU 0120-CNTL-ERROR-EXIT. PICKNMBR 00415 PERFORM 0130-FIPS-TABLE THRU 0130-FIPS-TABLE-EXIT. PICKNMBR 00416 PERFORM 0140-SPL-TABLE THRU 0140-SPL-TABLE-EXIT. PICKNMBR 00417 PERFORM 0001-LIST-HEADING THRU 0001-LIST-EXIT. PICKNMBR 00418 IF (TRANS-REC-CNTR > 200 ) PICKNMBR 00419 PERFORM 0200-CALC-SKIP-INTERVAL PICKNMBR 00420 PERFORM 0300-CALC-INITIAL-CASE PICKNMBR 00421 PERFORM 0400-REMAINING-NUMBERS PICKNMBR 00422 THRU 0400-REMAINING-NUMBERS-EXIT PICKNMBR 00423 UNTIL LOOP-NBR < 0 PICKNMBR 00424 ELSE PICKNMBR 00425 PERFORM 0500-CALC-SKIPINTERVAL PICKNMBR 00426 PERFORM 0600-CALC-INITIAL-CASE PICKNMBR 00427 PERFORM 0700-SELECTED-NUMBERS PICKNMBR 00428 THRU 0700-SELECTED-NUMBERS-EXIT PICKNMBR 00429 UNTIL CASE-NUM = SAMPLED-NMBR. PICKNMBR 00430 PERFORM 0900-TRAILER-LIST THRU 0900-TRAILER-EXIT. PICKNMBR 00431 PERFORM 9999-CLOSE-FILES. PICKNMBR 00432 STOP RUN. PICKNMBR 00433 ** PICKNMBR 00434 ********************************************************* PICKNMBR 00435 ** 0001-LIST-HEADING. ** PICKNMBR 00436 ** 0002-LIST-HEADING. ** PICKNMBR 00437 ** THESE SECTIONS CONTROL PRINTING OF REPORT PAGE AND ** PICKNMBR 00438 ** COLUMN HEADER INFORMATION, LINE COUNT, AND PAGE ** PICKNMBR 00439 ** ADVANCEMENT. ** PICKNMBR 00440 ********************************************************* PICKNMBR 00441 ** PICKNMBR 00442 0001-LIST-HEADING. PICKNMBR 00443 ADD 1 TO LIST-PAGE. PICKNMBR 00444 MOVE LIST-PAGE TO O-LIST-PAGE. PICKNMBR 00445 WRITE PICKNUM-REC FROM LIST-HEADING-1 PICKNMBR 00446 AFTER ADVANCING PAGE. PICKNMBR 00447 WRITE PICKNUM-REC FROM LIST-HEADING-2 AFTER 1 LINES. PICKNMBR 00448 WRITE PICKNUM-REC FROM LIST-HEADING-3 AFTER 1 LINES. PICKNMBR 00449 WRITE PICKNUM-REC FROM LIST-HEADING-4 AFTER 3 LINES. PICKNMBR 00450 WRITE PICKNUM-REC FROM BLANK-LINE AFTER 1 LINES. PICKNMBR 00451 0001-LIST-EXIT. PICKNMBR 00452 EXIT. PICKNMBR 00453 ** PICKNMBR 00454 0002-LIST-HEADING. PICKNMBR 00455 ADD 1 TO LIST-PAGE. PICKNMBR 00456 MOVE LIST-PAGE TO O-LIST-PAGE. PICKNMBR 00457 WRITE PICKNUM-REC FROM LIST-HEADING-1 PICKNMBR 00458 AFTER ADVANCING PAGE. PICKNMBR 00459 WRITE PICKNUM-REC FROM LIST-HEADING-2 AFTER 1 LINES. PICKNMBR 00460 WRITE PICKNUM-REC FROM LIST-HEADING-3 AFTER 1 LINES. PICKNMBR 00461 0002-LIST-EXIT. PICKNMBR 00462 EXIT. PICKNMBR 00463 ** PICKNMBR 00464 ********************************************************* PICKNMBR 00465 ** 0011-CS011, 0031-CS031, 0041-CS041, 0042-CS042, ** PICKNMBR 00466 ** 0043-CS043, 0051-CS051, 0061-CS061. ** PICKNMBR 00467 ** THIS SECTIONS IDENTIFY EACH OF THE TAX FUNCTIONS ** PICKNMBR 00468 ** AND CORRESPONDING YEAR/QUARTER FIELDS FOR THE ** PICKNMBR 00469 ** INDIVIDUAL TAX FUNCTION BEING PROCESSED. ** PICKNMBR 00470 ********************************************************* PICKNMBR 00471 ** PICKNMBR 00472 0011-CS011. PICKNMBR 00473 IF CNTRL-TRANS-TYPE = '1' THEN PICKNMBR 00474 MOVE ' STATUS DETERMINATION - NEW ' TO O-TITLE PICKNMBR 00475 ELSE IF CNTRL-TRANS-TYPE = '2' THEN PICKNMBR 00476 MOVE ' STATUS DETERMINATION - SUCCESSOR ' TO O-TITLE PICKNMBR 00477 ELSE IF CNTRL-TRANS-TYPE = '3' THEN PICKNMBR 00478 MOVE ' STATUS DETERMINATION - INACTIVE ' TO O-TITLE. PICKNMBR 00479 PERFORM 0071-Y-FORMATE THRU 0071-Y-FORMATE-EXIT. PICKNMBR 00480 0011-CS011-EXIT. PICKNMBR 00481 EXIT. PICKNMBR 00482 ** PICKNMBR 00483 0021-CS021. PICKNMBR 00484 IF CNTRL-TRANS-TYPE = '1' THEN PICKNMBR 00485 MOVE ' CASHIERING - ACCURACY ' TO O-TITLE PICKNMBR 00486 ELSE IF CNTRL-TRANS-TYPE = '2' THEN PICKNMBR 00487 MOVE ' CASHIERING - TIMELINESS ' TO O-TITLE. PICKNMBR 00488 PERFORM 0071-Y-FORMATE THRU 0071-Y-FORMATE-EXIT. PICKNMBR 00489 0021-CS021-EXIT. PICKNMBR 00490 EXIT. PICKNMBR 00491 ** PICKNMBR 00492 0031-CS031. PICKNMBR 00493 IF CNTRL-TRANS-TYPE = '1' THEN PICKNMBR 00494 MOVE ' FIELD AUDIT - RANDOM ' TO O-TITLE PICKNMBR 00495 ELSE IF CNTRL-TRANS-TYPE = '2' THEN PICKNMBR 00496 MOVE ' FIELD AUDIT - OTHER ' TO O-TITLE. PICKNMBR 00497 PERFORM 0071-Y-FORMATE THRU 0071-Y-FORMATE-EXIT. PICKNMBR 00498 0031-CS031-EXIT. PICKNMBR 00499 EXIT. PICKNMBR 00500 ** PICKNMBR 00501 0041-CS041. PICKNMBR 00502 MOVE ' CONTRIBUTION REPORT ' TO O-TITLE. PICKNMBR 00503 PERFORM 0072-YQ-FORMATE THRU 0072-YQ-FORMATE-EXIT. PICKNMBR 00504 0041-CS041-EXIT. PICKNMBR 00505 EXIT. PICKNMBR 00506 ** PICKNMBR 00507 0042-CS042. PICKNMBR 00508 IF CNTRL-TRANS-TYPE = '1' THEN PICKNMBR 00509 MOVE 'EMPLOYER BILLINGS - CONTRIBUTORY ' TO O-TITLE PICKNMBR 00510 ELSE IF CNTRL-TRANS-TYPE = '2' THEN PICKNMBR 00511 MOVE 'EMPLOYER BILLINGS - REIMBURSING ' TO O-TITLE. PICKNMBR 00512 PERFORM 0072-YQ-FORMATE THRU 0072-YQ-FORMATE-EXIT. PICKNMBR 00513 0042-CS042-EXIT. PICKNMBR 00514 EXIT. PICKNMBR 00515 ** PICKNMBR 00516 0043-CS043. PICKNMBR 00517 MOVE ' CREDITS/REFUNDS ' TO O-TITLE. PICKNMBR 00518 PERFORM 0072-YQ-FORMATE THRU 0072-YQ-FORMATE-EXIT. PICKNMBR 00519 0043-CS043-EXIT. PICKNMBR 00520 EXIT. PICKNMBR 00521 ** PICKNMBR 00522 0044-CS044. PICKNMBR 00523 MOVE ' EMPLOYER BENEFIT CHARGING ' TO O-TITLE. PICKNMBR 00524 PERFORM 0072-YQ-FORMATE THRU 0072-YQ-FORMATE-EXIT. PICKNMBR 00525 0044-CS044-EXIT. PICKNMBR 00526 EXIT. PICKNMBR 00527 ** PICKNMBR 00528 0045-CS045. PICKNMBR 00529 MOVE ' EXPERIENCE RATING ' TO O-TITLE. PICKNMBR 00530 PERFORM 0071-Y-FORMATE THRU 0071-Y-FORMATE-EXIT. PICKNMBR 00531 0045-CS045-EXIT. PICKNMBR 00532 EXIT. PICKNMBR 00533 ** PICKNMBR 00534 0051-CS051. PICKNMBR 00535 MOVE ' COLLECTIONS ' TO O-TITLE. PICKNMBR 00536 PERFORM 0073-YMD-FORMATE THRU 0073-YMD-FORMATE-EXIT. PICKNMBR 00537 0051-CS051-EXIT. PICKNMBR 00538 EXIT. PICKNMBR 00539 ** PICKNMBR 00540 0061-CS061. PICKNMBR 00541 MOVE ' REPORT DELINQUENCY ' TO O-TITLE. PICKNMBR 00542 PERFORM 0072-YQ-FORMATE THRU 0072-YQ-FORMATE-EXIT. PICKNMBR 00543 0061-CS061-EXIT. PICKNMBR 00544 EXIT. PICKNMBR 00545 ** PICKNMBR 00546 0071-Y-FORMATE. PICKNMBR 00547 MOVE CNTRL-YEAR-QTR TO DIGIT-4-4. PICKNMBR 00548 MOVE SPACES TO DIGIT-2-4. PICKNMBR 00549 MOVE DIGIT-4-4 TO O-PERIOD. PICKNMBR 00550 MOVE PERIOD-Y TO O-PERIOD-MARK. PICKNMBR 00551 0071-Y-FORMATE-EXIT. PICKNMBR 00552 EXIT. PICKNMBR 00553 ** PICKNMBR 00554 0072-YQ-FORMATE. PICKNMBR 00555 MOVE CNTRL-YEAR-QTR TO DIGIT-5. PICKNMBR 00556 MOVE DIGIT-5-4-A TO DIGIT-5-4-B. PICKNMBR 00557 MOVE DIGIT-5-1-A TO DIGIT-5-1-B. PICKNMBR 00558 MOVE DIGIT-5-3 TO O-PERIOD. PICKNMBR 00559 MOVE PERIOD-YQ TO O-PERIOD-MARK. PICKNMBR 00560 0072-YQ-FORMATE-EXIT. PICKNMBR 00561 EXIT. PICKNMBR 00562 ** PICKNMBR 00563 0073-YMD-FORMATE. PICKNMBR 00564 MOVE CNTRL-YEAR-QTR TO DIGIT-8. PICKNMBR 00565 MOVE DIGIT-8-4-A TO DIGIT-8-4-B. PICKNMBR 00566 MOVE DIGIT-8-MM-A TO DIGIT-8-MM-B. PICKNMBR 00567 MOVE DIGIT-8-DD-A TO DIGIT-8-DD-B. PICKNMBR 00568 MOVE DIGIT-8-2-2 TO O-PERIOD. PICKNMBR 00569 MOVE PERIOD-YMD TO O-PERIOD-MARK. PICKNMBR 00570 0073-YMD-FORMATE-EXIT. PICKNMBR 00571 EXIT. PICKNMBR 00572 ** PICKNMBR 00573 *************************************************************** PICKNMBR 00574 ** 0100-OPEN-ROUTINE. ** PICKNMBR 00575 ** THIS SECTION OPENS THE INPUT CNTRL-DATA FILE, OUTPUT ** PICKNMBR 00576 ** SELECT-NUMBERS FILE AND PICKNUM-LIST. ** PICKNMBR 00577 *************************************************************** PICKNMBR 00578 0100-OPEN-ROUTINE. PICKNMBR 00579 OPEN INPUT CNTRL-DATA. PICKNMBR 00580 OPEN OUTPUT SELECT-NUMBERS. PICKNMBR 00581 OPEN OUTPUT PICKNUM-LIST. PICKNMBR 00582 MOVE 1 TO O-CASE-NUM, O-PICK-NUM. PICKNMBR 00583 READ CNTRL-DATA AT END MOVE 'Y' TO CNTRL-FLAG. PICKNMBR 00584 0100-OPEN-ROUTINE-EXIT. PICKNMBR 00585 EXIT. PICKNMBR 00586 *************************************************************** PICKNMBR 00587 ** 0110-CNTL-OPTION. ** PICKNMBR 00588 ** THIS SECTION DETERMINES WHICH TAX FUNCTION IS BEING ** PICKNMBR 00589 ** PROCESSED. ** PICKNMBR 00590 *************************************************************** PICKNMBR 00591 0110-CNTL-OPTION. PICKNMBR 00592 IF CNTRL-TYPE = 'CS011' THEN PICKNMBR 00593 PERFORM 0011-CS011 THRU 0011-CS011-EXIT PICKNMBR 00594 ELSE IF CNTRL-TYPE = 'CS021' THEN PICKNMBR 00595 PERFORM 0021-CS021 THRU 0021-CS021-EXIT PICKNMBR 00596 ELSE IF CNTRL-TYPE = 'CS031' THEN PICKNMBR 00597 PERFORM 0031-CS031 THRU 0031-CS031-EXIT PICKNMBR 00598 ELSE IF CNTRL-TYPE = 'CS041' THEN PICKNMBR 00599 PERFORM 0041-CS041 THRU 0041-CS041-EXIT PICKNMBR 00600 ELSE IF CNTRL-TYPE = 'CS042' THEN PICKNMBR 00601 PERFORM 0042-CS042 THRU 0042-CS042-EXIT PICKNMBR 00602 ELSE IF CNTRL-TYPE = 'CS043' THEN PICKNMBR 00603 PERFORM 0043-CS043 THRU 0043-CS043-EXIT PICKNMBR 00604 ELSE IF CNTRL-TYPE = 'CS044' THEN PICKNMBR 00605 PERFORM 0044-CS044 THRU 0044-CS044-EXIT PICKNMBR 00606 ELSE IF CNTRL-TYPE = 'CS045' THEN PICKNMBR 00607 PERFORM 0045-CS045 THRU 0045-CS045-EXIT PICKNMBR 00608 ELSE IF CNTRL-TYPE = 'CS051' THEN PICKNMBR 00609 PERFORM 0051-CS051 THRU 0051-CS051-EXIT PICKNMBR 00610 ELSE IF CNTRL-TYPE = 'CS061' THEN PICKNMBR 00611 PERFORM 0061-CS061 THRU 0061-CS061-EXIT PICKNMBR 00612 ELSE DISPLAY 'INVALID RECORD TYPE IN CONTROL RECORD.' PICKNMBR 00613 STOP RUN. PICKNMBR 00614 0110-CNTL-OPTION-EXIT. PICKNMBR 00615 EXIT. PICKNMBR 00616 *************************************************************** PICKNMBR 00617 ** 0120-CNTL-ERROR. ** PICKNMBR 00618 ** THIS SECTION VALIDATES THE THREE CNTRL-DATA FILE FIELDS ** PICKNMBR 00619 ** CNTRL-RANDOM-ALF, TRANS-REC-CNTRL-ALF, AND SAMPLED-NMBR ** PICKNMBR 00620 ** FOR NON-NUMERIC VALUES. THESE FIELDS MUST BE NUMERIC FOR ** PICKNMBR 00621 ** THE PROGRAM TO EXECUTE. TO ASSIST IN THE VALIDATION, A ** PICKNMBR 00622 ** STOP-FLAG FIELD IS INCREMENTED BY A CERTAIN AMOUNT. AS A ** PICKNMBR 00623 ** RESULT, A COMPARISON IS MADE BETWEEN THE INCREMENTED ** PICKNMBR 00624 ** STOP-FLAG AND A VALUE IN THE RANGE 0 THROUGH 7. WITHIN ** PICKNMBR 00625 ** THIS RANGE, DIFFERENT ERROR MESSAGES WILL BE DISPLAYED ** PICKNMBR 00626 ** DEPENDING UPON THE ERROR DETECTED, THEN THE PROGRAM IS ** PICKNMBR 00627 ** TERMINATED. ** PICKNMBR 00628 *************************************************************** PICKNMBR 00629 0120-CNTL-ERROR. PICKNMBR 00630 IF CNTRL-RANDOM-ALF NOT NUMERIC PICKNMBR 00631 ADD 1 TO STOP-FLAG. PICKNMBR 00632 IF TRANS-REC-CNTR-ALF NOT NUMERIC PICKNMBR 00633 ADD 2 TO STOP-FLAG. PICKNMBR 00634 IF SAMPLED-NMBR-ALF NOT NUMERIC PICKNMBR 00635 ADD 4 TO STOP-FLAG. PICKNMBR 00636 PICKNMBR 00637 IF STOP-FLAG = 7 THEN PICKNMBR 00638 DISPLAY 'CNTRL-RANDOM, TRANS-REC-CNTR, AND ', PICKNMBR 00639 'SAMPLED-NMBR FIELDS IN ERROR.' PICKNMBR 00640 ELSE IF STOP-FLAG = 6 THEN PICKNMBR 00641 DISPLAY 'TRANS-REC-CNTR, AND ', PICKNMBR 00642 'SAMPLED-NMBR FIELDS IN ERROR.' PICKNMBR 00643 ELSE IF STOP-FLAG = 5 THEN PICKNMBR 00644 DISPLAY 'CNTRL-RANDOM AND TRANS-REC-CNTR ', PICKNMBR 00645 'FIELDS IN ERROR.' PICKNMBR 00646 ELSE IF STOP-FLAG = 4 THEN PICKNMBR 00647 DISPLAY 'SAMPLED-NMBR FIELD IN ERROR.' PICKNMBR 00648 ELSE IF STOP-FLAG = 3 THEN PICKNMBR 00649 DISPLAY 'CNTRL-RANDOM AND TRANS-REC-CNTR ', PICKNMBR 00650 'FIELDS IN ERROR.' PICKNMBR 00651 ELSE IF STOP-FLAG = 2 THEN PICKNMBR 00652 DISPLAY 'TRANS-REC-CNTR FIELD IN ERROR.' PICKNMBR 00653 ELSE IF STOP-FLAG = 1 THEN PICKNMBR 00654 DISPLAY 'CNTRL-RANDOM FIELD IN ERROR.'. PICKNMBR 00655 PICKNMBR 00656 IF STOP-FLAG > 0 THEN PICKNMBR 00657 DISPLAY 'NON-NUMERIC DATA IN CONTROL CARD.' PICKNMBR 00658 DISPLAY 'CNTRL-RANDOM-ALF', CNTRL-RANDOM-ALF PICKNMBR 00659 DISPLAY 'SAMPLED-NMBR ALF', SAMPLED-NMBR-ALF PICKNMBR 00660 DISPLAY 'TRANS-REC-CNTR ALF', TRANS-REC-CNTR-ALF PICKNMBR 00661 PERFORM 9999-CLOSE-FILES PICKNMBR 00662 STOP RUN. PICKNMBR 00663 0120-CNTL-ERROR-EXIT. PICKNMBR 00664 EXIT. PICKNMBR 00665 *************************************************************** PICKNMBR 00666 ** 0130-FIPS-TABLE. ** PICKNMBR 00667 ** THIS SECTION SEARCHES SESA-ID IN THE FIPS TABLE TO FIND ** PICKNMBR 00668 ** THE EXACT STATE NAME ASSOCIATED WITH ITS ABBREVIATION. ** PICKNMBR 00669 *************************************************************** PICKNMBR 00670 0130-FIPS-TABLE. PICKNMBR 00671 SET STATE-NAME-INDEX, STATE-ID-INDEX TO 1. PICKNMBR 00672 SEARCH STATE-ID VARYING STATE-NAME-INDEX, PICKNMBR 00673 AT END MOVE 0 TO FIPS-FLAG, PICKNMBR 00674 WHEN CNTRL-SESA-ID = STATE-ID (STATE-ID-INDEX) PICKNMBR 00675 MOVE STATE-NAME (STATE-NAME-INDEX) TO O-SESA-NAME PICKNMBR 00676 MOVE 1 TO FIPS-FLAG. PICKNMBR 00677 IF FIPS-FLAG = 0 PICKNMBR 00678 DISPLAY 'SESA ID NOT FOUND ON FIPS TABLE'. PICKNMBR 00679 0130-FIPS-TABLE-EXIT. PICKNMBR 00680 EXIT. PICKNMBR 00681 *************************************************************** PICKNMBR 00682 ** 0140-SPL-TABLE. ** PICKNMBR 00683 ** THIS SECTION SEARCHES THE SAMPLE-TYPE FIELD OF THE ** PICKNMBR 00684 ** CNTRL-DATA FILE FOR A CORRESPONDING MATCH IN THE SAMPLE ** PICKNMBR 00685 ** TABLE(SPL-TYPE-DATA). IF A MATCH OCCURS, THE SAMPLE TYPE ** PICKNMBR 00686 ** ABBREVIATION IS REPLACED BY THE EXACT SAMPLE TYPE ** PICKNMBR 00687 ** DESCRIPTION TO BE UTILIZED IN THE OUTPUT REPORT FORMATS. ** PICKNMBR 00688 *************************************************************** PICKNMBR 00689 0140-SPL-TABLE. PICKNMBR 00690 SEARCH SPL-TABLE-ENTRY PICKNMBR 00691 AT END MOVE 'END' TO SPL-ENTRY-FOUND-SWITCH PICKNMBR 00692 WHEN SAMPLE-TYPE PICKNMBR 00693 IS EQUAL TO SPL-ID (SPL-INDEX) PICKNMBR 00694 MOVE 'YES' TO SPL-ENTRY-FOUND-SWITCH. PICKNMBR 00695 IF SPL-ENTRY-FOUND PICKNMBR 00696 MOVE SPL-NAME (SPL-INDEX) PICKNMBR 00697 TO O-SAMPLE-TYPE PICKNMBR 00698 ELSE PICKNMBR 00699 DISPLAY SAMPLE-TYPE ' IS INCORRECT SAMPLE TYPE.'. PICKNMBR 00700 0140-SPL-TABLE-EXIT. PICKNMBR 00701 EXIT. PICKNMBR 00702 *************************************************************** PICKNMBR 00703 ** TO ENSURE A BALANCED SYSTEMATIC SAMPLE, THE FOLLOWING ** PICKNMBR 00704 ** CALCULATIONS ARE USED TO DETERMINE THE NUMBERS SELECTED ** PICKNMBR 00705 ** FOR THE SAMPLE. ** PICKNMBR 00706 ** P = THE TOTAL NUMBER OF RECORDS ON THE VSAM FILE ** PICKNMBR 00707 ** (TRANS-REC-CNTR) FROM THE CNTRL-DATA FILE. ** PICKNMBR 00708 ** N = SAMPLE SIZE (SAMPLED-NMBR) FROM THE CNTRL-DATA FILE. ** PICKNMBR 00709 ** R = RANDOM NUMBER (CNTRL-RANDOM) FROM CNTRL-DATA FILE. ** PICKNMBR 00710 ** K = SKIP INTERVAL (CALCULATED IN THIS PROGRAM). ** PICKNMBR 00711 ** I = INITIAL SAMPLE CASE (CALCULATED IN THIS PROGRAM). ** PICKNMBR 00712 ** THE FOLLOWING FORMULAS ARE USED: ** PICKNMBR 00713 ** K = P/N, I = (R*K) + .5, J = 0, 1, 2, ... (1/2N - 1) ** PICKNMBR 00714 ** IF N IS EVEN, N/2 PAIRS OF RECORDS ARE SELECTED ACCORDING ** PICKNMBR 00715 ** TO THE FORMULA: I + JK AND (P - JK) - I + 1 ** PICKNMBR 00716 ** IF N IS ODD, J = 0, 1, 2, ... 1/2(N-1) - 1 ** PICKNMBR 00717 ** I + JK AND (P - JK) - I + 1 AND THE REMAINING CASE ** PICKNMBR 00718 ** IS CALCULATED BY: I + 1/2(N - 1)K ** PICKNMBR 00719 ** EXAMPLE: P = 43 N = 5 R = .261 K = 43/5 = 8.6 => 9 ** PICKNMBR 00720 ** I = (.261 * 9) +.5 =2.849 => 2 (TRUNCATED) ** PICKNMBR 00721 ** THE FOLLOWING RECORDS WOULD BE SELECTED - ** PICKNMBR 00722 ** 2, 11, 33, 42 AND 20. ** PICKNMBR 00723 *************************************************************** PICKNMBR 00724 ** PICKNMBR 00725 *************************************************************** PICKNMBR 00726 ** 0200-CALC-SKIP-INTERVAL. ** PICKNMBR 00727 ** THIS SECTION WILL CALCULATE THE SKIP-INTERVAL(K) BASED ON ** PICKNMBR 00728 ** THE FOLLOWING EQUATION K=P/N AS DEFINED ABOVE(COMMENT BOX)** PICKNMBR 00729 *************************************************************** PICKNMBR 00730 0200-CALC-SKIP-INTERVAL. PICKNMBR 00731 DIVIDE TRANS-REC-CNTR BY SAMPLED-NMBR PICKNMBR 00732 GIVING SKIP-INTERVAL ROUNDED. PICKNMBR 00733 ** PICKNMBR 00734 ** GIVEN A LARGE ENOUGH SAMPLE REQUESTED (E.G., INADVERTENTLY) PICKNMBR 00735 ** IN RELATION TO THE POPULATION SIZE FROM WHICH THE SAMPLE IS PICKNMBR 00736 ** TO BE TAKEN, THE 'SKIP-INTERVAL' COULD BE CALCULATED TO BE: PICKNMBR 00737 ** PICKNMBR 00738 ** FROM .99 TO .50 - WHICH LEADS TO THE SAME EMPLOYER NUMBER PICKNMBR 00739 ** BE CHOSEN FOR MORE THAN ONE CASE -OR- PICKNMBR 00740 ** FROM .49 TO .00 - WHICH ALSO LEADS TO AN 'INITIAL-CASE' OF PICKNMBR 00741 ** ZERO (WHICH CAN NEVER EXIST). PICKNMBR 00742 ** ERGO; PICKNMBR 00743 ** PICKNMBR 00744 IF SKIP-INTERVAL < 1 PICKNMBR 00745 MOVE 1 TO SKIP-INTERVAL. PICKNMBR 00746 *************************************************************** PICKNMBR 00747 ** 0300-CALC-INITIAL-CASE. ** PICKNMBR 00748 ** THIS SECTION CALCULATES THE INITIAL CASE (I). IT IS ** PICKNMBR 00749 ** DETERMINED BY TRUNCATING THE RESULT OF I = R * K + .5. ** PICKNMBR 00750 ** THE INITIAL-CASE FIELD (I) IS DEFINED AS A 5-POSITION ** PICKNMBR 00751 ** NUMERIC INTEGER. THE RIGHT SIDE OF EQUATION I= R*K + .5 ** PICKNMBR 00752 ** YIELD A REAL NUMBER, THUS ALLOWING(I) TO TRUNCATE THE ** PICKNMBR 00753 ** RESULT OF THE CALCULATION. R:CNTRL-RANDOM-ALF, AND ** PICKNMBR 00754 ** K:SKIP-INTERVAL. ** PICKNMBR 00755 *************************************************************** PICKNMBR 00756 0300-CALC-INITIAL-CASE. PICKNMBR 00757 COMPUTE INITIAL-CASE = (SKIP-INTERVAL * CNTRL-RANDOM) + 0.5.PICKNMBR 00758 ** ERGO; (JUST TO REAL SURE) PICKNMBR 00759 IF INITIAL-CASE < 1 PICKNMBR 00760 MOVE SKIP-INTERVAL TO INITIAL-CASE. PICKNMBR 00761 PERFORM 0310-CHECK-ODD-EVEN. PICKNMBR 00762 *************************************************************** PICKNMBR 00763 ** 0310-CHECK-ODD-EVEN. ** PICKNMBR 00764 ** THIS SECTION DETERMINES WHETHER THE NUMBER OF RECORDS (N) ** PICKNMBR 00765 ** TO BE SELECTED (SAMPLED-NUMBER) IS EITHER ODD OR EVEN,IF N** PICKNMBR 00766 ** IS ODD, 0320-ODD-ROUTINE IS PERFORMED. ** PICKNMBR 00767 *************************************************************** PICKNMBR 00768 0310-CHECK-ODD-EVEN. PICKNMBR 00769 DIVIDE SAMPLED-NMBR BY 2 GIVING TEMP-LOOP-NBR PICKNMBR 00770 REMAINDER ODD-EVEN-CNTL. PICKNMBR 00771 SUBTRACT 1 FROM TEMP-LOOP-NBR GIVING LOOP-NBR. PICKNMBR 00772 IF ODD-EVEN-CNTL = 1 THEN PICKNMBR 00773 PERFORM 0320-ODD-RTN. PICKNMBR 00774 *************************************************************** PICKNMBR 00775 ** 0320-ODD-RTN. ** PICKNMBR 00776 ** THIS ROUTINE CALCULATES THE ADDITIONAL NUMBER FOR THE ** PICKNMBR 00777 ** SAMPLE UTILIZING THE FOLLOWING FORMULA:I+ 1/2(N-1)*K. ** PICKNMBR 00778 ** THIS NUMBER(ONE-MORE-REC) IS WRITTEN TO THE ** PICKNMBR 00779 ** (SELECT-NUMBERS) FILE. ** PICKNMBR 00780 *************************************************************** PICKNMBR 00781 0320-ODD-RTN. PICKNMBR 00782 COMPUTE ODD-LOOP-NBR = (SAMPLED-NMBR - 1) / 2. PICKNMBR 00783 COMPUTE ONE-MORE-REC = INITIAL-CASE + PICKNMBR 00784 (ODD-LOOP-NBR * SKIP-INTERVAL). PICKNMBR 00785 MOVE ONE-MORE-REC TO O-PICK-NUM, SELECTED-REC. PICKNMBR 00786 PERFORM 0330-CREATE-REC THRU 0330-CREATE-REC-EXIT. PICKNMBR 00787 *************************************************************** PICKNMBR 00788 ** 0330-CREATE-REC. ** PICKNMBR 00789 ** THIS ROUTINE WRITES THE CALCULATED NUMBERS TO AN OUTPUT ** PICKNMBR 00790 ** DATA FILE(SELECT-NUMBERS) AND AN OUTPUT PRINT FILE ** PICKNMBR 00791 ** (PICKNUM-LIST). A RECORD COUNTER(MATCH-CNTR) IS ** PICKNMBR 00792 ** INCREMENTED BY ONE EACH TIME A RECORD IS ADDED TO THE ** PICKNMBR 00793 ** FILES. ** PICKNMBR 00794 *************************************************************** PICKNMBR 00795 ** LET'S JUST MAKE SURE THAT WE DON'T CREATE A CASE PICKNMBR 00796 ** NUMBER BEYOND THE SIZE OF THE POPULATION. PICKNMBR 00797 0330-CREATE-REC. PICKNMBR 00798 IF (CASE-NUM + 1) < TRANS-REC-CNTR OR PICKNMBR 00799 (CASE-NUM + 1) = TRANS-REC-CNTR PICKNMBR 00800 PERFORM 0331-OK-2-CREATE THRU 0331-EXIT PICKNMBR 00801 ELSE PICKNMBR 00802 ADD 1 TO CASE-NUM. PICKNMBR 00803 0330-CREATE-REC-EXIT. PICKNMBR 00804 EXIT. PICKNMBR 00805 0331-OK-2-CREATE. PICKNMBR 00806 ADD 1 TO CASE-NUM. PICKNMBR 00807 MOVE CASE-NUM TO O-CASE-NUM. PICKNMBR 00808 ADD 1 TO LIST-COUNTER. PICKNMBR 00809 PICKNMBR 00810 IF LIST-COUNTER > 50 PICKNMBR 00811 MOVE 1 TO LIST-COUNTER PICKNMBR 00812 PERFORM 0001-LIST-HEADING THRU 0001-LIST-EXIT. PICKNMBR 00813 PICKNMBR 00814 WRITE PICKNUM-REC FROM O-PICKNUM-REC PICKNMBR 00815 AFTER ADVANCING 1 LINE. PICKNMBR 00816 ADD 1 TO SELECT-CNTR. PICKNMBR 00817 WRITE SELECTED-REC. PICKNMBR 00818 0331-EXIT. PICKNMBR 00819 EXIT. PICKNMBR 00820 *************************************************************** PICKNMBR 00821 ** 0400-REMAINING-NUMBERS. ** PICKNMBR 00822 ** THIS SECTION PERFORMS THE CALCULATIONS TO DETERMINE THE ** PICKNMBR 00823 ** REMAINING NUMBERS FOR THE SAMPLE. AS STATED ABOVE, IF ** PICKNMBR 00824 ** N IS EVEN, N/2 PAIRS OF RECORDS ARE SELECTED. IF N IS ** PICKNMBR 00825 ** ODD, J = 0, 1, 2, .... 1/2(N - 1) - 1. ** PICKNMBR 00826 ** THIS ROUTINE IS PERFORMED UNTIL J < 0. ** PICKNMBR 00827 *************************************************************** PICKNMBR 00828 0400-REMAINING-NUMBERS. PICKNMBR 00829 COMPUTE SEL-1 = PICKNMBR 00830 INITIAL-CASE + PICKNMBR 00831 (LOOP-NBR * SKIP-INTERVAL). PICKNMBR 00832 COMPUTE SEL-2 = PICKNMBR 00833 TRANS-REC-CNTR - PICKNMBR 00834 (LOOP-NBR * SKIP-INTERVAL) - PICKNMBR 00835 INITIAL-CASE + 1. PICKNMBR 00836 MOVE SEL-1 TO O-PICK-NUM, SELECTED-REC. PICKNMBR 00837 PERFORM 0330-CREATE-REC THRU 0330-CREATE-REC-EXIT. PICKNMBR 00838 MOVE SEL-2 TO O-PICK-NUM, SELECTED-REC. PICKNMBR 00839 PERFORM 0330-CREATE-REC THRU 0330-CREATE-REC-EXIT. PICKNMBR 00840 SUBTRACT 1 FROM LOOP-NBR. PICKNMBR 00841 MOVE ZEROS TO SEL-1 SEL-2. PICKNMBR 00842 0400-REMAINING-NUMBERS-EXIT. PICKNMBR 00843 EXIT. PICKNMBR 00844 *************************************************************** PICKNMBR 00845 ** 0500-CALC-SKIPINTERVAL. ** PICKNMBR 00846 ** THIS SECTION WILL CALCULATE THE SKIP-INTERVAL FOR A ** PICKNMBR 00847 ** TRANSACTION SAMPLE SIZE LESS THAN 200. ** PICKNMBR 00848 *************************************************************** PICKNMBR 00849 0500-CALC-SKIPINTERVAL. PICKNMBR 00850 DIVIDE TRANS-REC-CNTR BY SAMPLED-NMBR PICKNMBR 00851 GIVING SKIP-INTERVAL-B. PICKNMBR 00852 ** PICKNMBR 00853 ** GIVEN A LARGE ENOUGH SAMPLE REQUESTED (E.G., INADVERTENTLY) PICKNMBR 00854 ** IN RELATION TO THE POPULATION SIZE FROM WHICH THE SAMPLE IS PICKNMBR 00855 ** TO BE TAKEN, THE 'SKIP-INTERVAL' COULD BE CALCULATED TO BE: PICKNMBR 00856 ** PICKNMBR 00857 ** FROM .99 TO .50 - WHICH LEADS TO THE SAME EMPLOYER NUMBER PICKNMBR 00858 ** BE CHOSEN FOR MORE THAN ONE CASE -OR- PICKNMBR 00859 ** FROM .49 TO .00 - WHICH ALSO LEADS TO AN 'INITIAL-CASE' OF PICKNMBR 00860 ** ZERO (WHICH CAN NEVER EXIST). PICKNMBR 00861 ** ERGO; PICKNMBR 00862 ** PICKNMBR 00863 IF SKIP-INTERVAL-B < 1 PICKNMBR 00864 MOVE 1 TO SKIP-INTERVAL-B. PICKNMBR 00865 **************************************************************** PICKNMBR 00866 ** 0600-CALC-INITIAL-CASE. ** PICKNMBR 00867 ** THIS SECTION CALCULATES THE INITIAL CASE (I) NUMBER. ** PICKNMBR 00868 ** IT IS DETERMINED BY TRUNCATING THE RESULT OF I = R * K + .5** PICKNMBR 00869 **************************************************************** PICKNMBR 00870 0600-CALC-INITIAL-CASE. PICKNMBR 00871 COMPUTE INITIAL-CASE = (SKIP-INTERVAL-B * CNTRL-RANDOM) PICKNMBR 00872 + 0.5. PICKNMBR 00873 ** ERGO; (JUST TO REAL SURE) PICKNMBR 00874 IF INITIAL-CASE < 1 PICKNMBR 00875 MOVE SKIP-INTERVAL-B TO INITIAL-CASE. PICKNMBR 00876 MOVE INITIAL-CASE TO SEL-NMBR. PICKNMBR 00877 MOVE SEL-NMBR TO O-PICK-NUM, SELECTED-REC, SEL-ACCU. PICKNMBR 00878 PERFORM 0330-CREATE-REC THRU 0330-CREATE-REC-EXIT. PICKNMBR 00879 ** PICKNMBR 00880 *************************************************************** PICKNMBR 00881 ** 0700-SELECTED-NUMBERS. ** PICKNMBR 00882 ** THIS SECTION PERFORMS THE CALCULATIONS TO DETERMINE THE ** PICKNMBR 00883 ** NUMBERS TO SELECT FOR THE SAMPLE. THE 2ND RECORD IS ** PICKNMBR 00884 ** CALCULATED BY ADDING THE SKIP INTERVAL(NOT ROUNDED) TO THE** PICKNMBR 00885 ** INITIAL CASE(TRUNCATED) AND ROUNDING THE RESULT. THE ** PICKNMBR 00886 ** REMAINING NUMBERS ARE CALCULATED BY ADDING THE SKIP ** PICKNMBR 00887 ** INTERVAL TO THE PREVIOUS (NOT ROUNDED) NUMBER AND THEN ** PICKNMBR 00888 ** ROUNDING THE RESULT. THIS PROCESS IS CONTINUED UNTIL ALL ** PICKNMBR 00889 ** OF THE RECORDS HAVE BEEN CALCULATED. ** PICKNMBR 00890 *************************************************************** PICKNMBR 00891 0700-SELECTED-NUMBERS. PICKNMBR 00892 IF (SEL-NMBR > TRANS-REC-CNTR ) PICKNMBR 00893 COMPUTE SEL-NMBR = SEL-NMBR - TRANS-REC-CNTR PICKNMBR 00894 MOVE SEL-NMBR TO SEL-ACCU PICKNMBR 00895 ELSE PICKNMBR 00896 COMPUTE SEL-NMBR ROUNDED = SEL-ACCU + SKIP-INTERVAL-B PICKNMBR 00897 COMPUTE SEL-ACCU = SEL-ACCU + SKIP-INTERVAL-B. PICKNMBR 00898 MOVE SEL-NMBR TO O-PICK-NUM, SELECTED-REC. PICKNMBR 00899 PERFORM 0330-CREATE-REC THRU 0330-CREATE-REC-EXIT. PICKNMBR 00900 0700-SELECTED-NUMBERS-EXIT. PICKNMBR 00901 EXIT. PICKNMBR 00902 ** PICKNMBR 00903 *************************************************************** PICKNMBR 00904 ** 0800-CHK-SPL-NBR. ** PICKNMBR 00905 ** THIS SECTION VERIFIES THAT THE NUMBER OF RECORDS WRITTEN ** PICKNMBR 00906 ** TO THE (SELECT-NUMBERS) FILE IS EQUAL TO THE NUMBER OF ** PICKNMBR 00907 ** RECORDS TO BE SAMPLED (SAMPLED-NMBR) IN THE CNTRL-DATA ** PICKNMBR 00908 ** FILE. IF THESE FIELDS ARE NOT EQUAL, AN ERROR MESSAGE ** PICKNMBR 00909 ** IS DISPLAYED. ** PICKNMBR 00910 *************************************************************** PICKNMBR 00911 0800-CHK-SPL-NBR. PICKNMBR 00912 ** THROW A SYSOUT & AND A RPT LINE PICKNMBR 00913 DISPLAY 'RECORDS SELECTED NE TO RECORDS DESIRED'. PICKNMBR 00914 ** PICKNMBR 00915 MOVE ' DID NOT FILL DESIRED NUMBER OF RECORDS' PICKNMBR 00916 TO CNTL-ITEM. PICKNMBR 00917 MOVE SPACE TO CNTL-VALUE-X. PICKNMBR 00918 WRITE PICKNUM-REC FROM O-LIST-3-REC. PICKNMBR 00919 0800-CHK-SPL-NBR-EXIT. PICKNMBR 00920 EXIT. PICKNMBR 00921 ** PICKNMBR 00922 *************************************************************** PICKNMBR 00923 ** 0900-TRAILER-LIST. ** PICKNMBR 00924 ** THIS SECTION PRINTS THE INFORMATION THAT WAS USED TO ** PICKNMBR 00925 ** CALCULATE THE RECORD NUMBERS FOR SAMPLING ** PICKNMBR 00926 *************************************************************** PICKNMBR 00927 0900-TRAILER-LIST. PICKNMBR 00928 PERFORM 0002-LIST-HEADING THRU 0002-LIST-EXIT. PICKNMBR 00929 WRITE PICKNUM-REC FROM O-LIST-1-REC AFTER 10 LINES. PICKNMBR 00930 WRITE PICKNUM-REC FROM O-LIST-5-REC. PICKNMBR 00931 WRITE PICKNUM-REC FROM O-LIST-2-REC. PICKNMBR 00932 WRITE PICKNUM-REC FROM O-LIST-5-REC. PICKNMBR 00933 WRITE PICKNUM-REC FROM O-LIST-5-REC. PICKNMBR 00934 MOVE ' TOTAL TRANSACTION FILE RECORDS(P) ' PICKNMBR 00935 TO CNTL-ITEM. PICKNMBR 00936 MOVE TRANS-REC-CNTR TO CNTL-VALUE. PICKNMBR 00937 WRITE PICKNUM-REC FROM O-LIST-3-REC. PICKNMBR 00938 MOVE ' NUMBER OF RECORDS TO BE SELECTED(N) ' PICKNMBR 00939 TO CNTL-ITEM. PICKNMBR 00940 MOVE SAMPLED-NMBR TO CNTL-VALUE. PICKNMBR 00941 WRITE PICKNUM-REC FROM O-LIST-3-REC. PICKNMBR 00942 MOVE ' RANDOM NUMBER(R) ' PICKNMBR 00943 TO CNTL-ITEM-2. PICKNMBR 00944 MOVE CNTRL-RANDOM TO CNTL-VALUE-2. PICKNMBR 00945 WRITE PICKNUM-REC FROM O-LIST-4-REC. PICKNMBR 00946 PICKNMBR 00947 IF (TRANS-REC-CNTR > 200 ) PICKNMBR 00948 MOVE ' SKIP INTERVAL(K) ' PICKNMBR 00949 TO CNTL-ITEM PICKNMBR 00950 MOVE SKIP-INTERVAL TO CNTL-VALUE PICKNMBR 00951 WRITE PICKNUM-REC FROM O-LIST-3-REC PICKNMBR 00952 ELSE PICKNMBR 00953 MOVE ' SKIP INTERVAL(K) ' PICKNMBR 00954 TO CNTL-ITEM-2 PICKNMBR 00955 MOVE SKIP-INTERVAL-B TO CNTL-VALUE-2 PICKNMBR 00956 WRITE PICKNUM-REC FROM O-LIST-4-REC. PICKNMBR 00957 PICKNMBR 00958 MOVE ' INITIAL SAMPLE CASE(I) ' PICKNMBR 00959 TO CNTL-ITEM. PICKNMBR 00960 MOVE INITIAL-CASE TO CNTL-VALUE. PICKNMBR 00961 WRITE PICKNUM-REC FROM O-LIST-3-REC. PICKNMBR 00962 PICKNMBR 00963 IF SELECT-CNTR NOT EQUAL SAMPLED-NMBR PICKNMBR 00964 PERFORM 0800-CHK-SPL-NBR THRU 0800-CHK-SPL-NBR-EXIT. PICKNMBR 00965 PICKNMBR 00966 WRITE PICKNUM-REC FROM O-LIST-5-REC. PICKNMBR 00967 WRITE PICKNUM-REC FROM O-LIST-5-REC. PICKNMBR 00968 WRITE PICKNUM-REC FROM O-LIST-1-REC. PICKNMBR 00969 0900-TRAILER-EXIT. PICKNMBR 00970 EXIT. PICKNMBR 00971 ** PICKNMBR 00972 *************************************************************** PICKNMBR 00973 ** 9999-CLOSE-FILES. ** PICKNMBR 00974 ** THIS SECTION CLOSES THE FILES: CNTRL-DATA, PICKNUM-LIST ** PICKNMBR 00975 ** SELECT-NUMBERS. ** PICKNMBR 00976 *************************************************************** PICKNMBR 00977 9999-CLOSE-FILES. PICKNMBR 00978 CLOSE SELECT-NUMBERS. PICKNMBR 00979 CLOSE CNTRL-DATA. PICKNMBR 00980 CLOSE PICKNUM-LIST. PICKNMBR