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
