982 lines
78 KiB
COBOL
982 lines
78 KiB
COBOL
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
|