000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPOPN210.
000300*AUTHOR.             DDS TEAM.
000400*                        CMS.
000500*REMARKS.
000600*    EFFECTIVE JAN 1,2006  CONVERTED SOFTWARE TO CICS FORMAT
000700*          - OPENS PROV,MSAX AND CBSA FILES
000800*          - FINDS PROV RECORD
000900*          - LOADS THE MSAX AND CBSA TABLES
001000*          - CALLS THE DRIVER MODULE
001100 DATE-COMPILED.
001200****************************************************************
001300* PPOPN210 VERSION FOR FY 2021 PRICER                        ***
001400****************************************************************
001500 ENVIRONMENT DIVISION.
001600 CONFIGURATION SECTION.
001700 SOURCE-COMPUTER.            IBM-370.
001800 OBJECT-COMPUTER.            IBM-370.
001900 INPUT-OUTPUT  SECTION.
002000 FILE-CONTROL.
002100
002200     SELECT PROV-FILE ASSIGN      TO  UT-S-PPSPROV
002300            FILE STATUS IS PROV-STAT.
002400     SELECT MSAX-FILE ASSIGN      TO  UT-S-PPSMSAX
002500            FILE STATUS IS MSAX-STAT.
002600     SELECT F-CBSA-FILE ASSIGN    TO  UT-S-PPSCBSA
002700            FILE STATUS IS CBSA-STAT.
002800 DATA DIVISION.
002900 FILE SECTION.
003000
003100 FD  PROV-FILE
003200     RECORDING MODE IS F
003300     LABEL RECORDS ARE STANDARD
003400     BLOCK CONTAINS 0 RECORDS.
003500 01  PROV-REC.
003600     05  PROV-PART1                 PIC X(80).
003700     05  PROV-PART2                 PIC X(80).
003800     05  PROV-PART3                 PIC X(150).
003900
004000 FD  MSAX-FILE
004100     RECORDING MODE IS F
004200     LABEL RECORDS ARE STANDARD
004300     BLOCK CONTAINS 0 RECORDS.
004400 01  MSAX-REC.
004500     05  X-MSA-X.
004600         10  M-BLANK                PIC X(02).
004700         10  M-STATE                PIC 9(02).
004800     05  X-MSA REDEFINES X-MSA-X    PIC 9(04).
004900     05  X-SIZE                     PIC X(01).
005000     05  XE-DATE.
005100         10  XE-CC                  PIC 9(02).
005200         10  XE-YY                  PIC 9(02).
005300         10  XE-MM                  PIC 9(02).
005400         10  XE-DD                  PIC 9(02).
005500     05  FILLER                     PIC X(01).
005600     05  X-WAGE-INDX1               PIC S9(02)V9(04).
005700     05  FILLER                     PIC X(01).
005800     05  X-WAGE-INDX2               PIC S9(02)V9(04).
005900     05  FILLER                     PIC X(01).
006000     05  X-STATE-MSA-NAME           PIC X(51).
006100     05  FILLER                     PIC X(01).
006200
006300 FD  F-CBSA-FILE
006400     RECORDING MODE IS F
006500     LABEL RECORDS ARE STANDARD
006600     BLOCK CONTAINS 0 RECORDS.
006700 01  F-CBSA-REC.
006800     05  F-CBSA.
006900         10  F-CBSA-BLANK                PIC X(03).
007000         10  F-CBSA-STATE                PIC 9(02).
007100     05  F-CBSA9  REDEFINES F-CBSA       PIC 9(05).
007200     05  F-CBSA-SIZE             PIC X(01).
007300     05  F-CBSA-EFF-DATE.
007400         10  F-CBSA-CC           PIC 9(02).
007500         10  F-CBSA-YY           PIC 9(02).
007600         10  F-CBSA-MM           PIC 9(02).
007700         10  F-CBSA-DD           PIC 9(02).
007800     05  FILLER                  PIC X(01).
007900     05  F-CBSA-WAGE-INDX1       PIC S9(02)V9(04).
008000     05  FILLER                  PIC X(01).
008100     05  F-CBSA-WAGE-INDX2       PIC S9(02)V9(04).
008200     05  FILLER                  PIC X(01).
008300     05  F-CBSA-WAGE-INDX3       PIC S9(02)V9(04).
008400     05  FILLER                  PIC X(01).
008500     05  F-CBSA-STATE-NAME       PIC X(43).
008600     05  FILLER                  PIC X(01).
008700
008800 WORKING-STORAGE SECTION.
008900 77  W-STORAGE-REF                  PIC X(48)  VALUE
009000     'I/O PRICER FILES- W O R K I N G   S T O R A G E'.
009100
009200 01  PPDRV210                       PIC X(08) VALUE 'PPDRV210'.
009300 01  TABLES-LOADED-SW               PIC 9(01)  VALUE 0.
009400 01  EOF-SW                         PIC 9(01)  VALUE 0.
009500
009600 01  PROV-STAT.
009700     02  PROV-STAT1     PIC X.
009800     02  PROV-STAT2     PIC X.
009900
010000 01  MSAX-STAT.
010100     02  MSAX-STAT1     PIC X.
010200     02  MSAX-STAT2     PIC X.
010300
010400 01  CBSA-STAT.
010500     02  CBSA-STAT1     PIC X.
010600     02  CBSA-STAT2     PIC X.
010700
010800 01  MSAX-WI-TABLE.
010900     05  M-MSAX-DATA                OCCURS 9000
011000                                    INDEXED BY MU1 MU2 MU3.
011100         10  M-MSAX-MSA             PIC X(4).
011200         10  M-MSAX-SIZE            PIC X(01).
011300         10  M-MSAX-EFF-DATE        PIC X(08).
011400         10  M-MSAX-WAGE-INDX1      PIC S9(02)V9(04).
011500         10  M-MSAX-WAGE-INDX2      PIC S9(02)V9(04).
011600
011700 01  CBSA-WI-TABLE.
011800     05  T-CBSA-DATA                  OCCURS 8000
011900                                    INDEXED BY MA1 MA2 MA3.
012000         10  T-CBSA                   PIC X(5).
012100         10  T-CBSA-SIZE              PIC X(01).
012200         10  T-CBSA-EFF-DATE          PIC X(08).
012300         10  T-CBSA-WAGE-INDX1        PIC S9(02)V9(04).
012400         10  T-CBSA-WAGE-INDX2        PIC S9(02)V9(04).
012500         10  T-CBSA-WAGE-INDX3        PIC S9(02)V9(04).
012600
012700******************************************************************
012800* THE PROVIDER SPECIFIC INFORMATION TABLE IS INITIALLY SET TO    *
012900* OCCUR 4000 TIMES. THIS NUMBER SHOULD BY ADJUSTED BY THE USER   *
013000* TO REFLECT THE NUMBER OF PROVIDER RECORDS PLUS EXPANSION. EACH *
013100* ENTRY COSTS 240 BYTES OF MEMORY. THIS FILE MUST BE IN PROVIDER *
013200* NUMBER, EFFECTIVE-DATE SEQUENCE.                               *
013300******************************************************************
013400 01  PROV-TABLE.
013500     05  PROV-ENTRIES               OCCURS 4000
013600                                    ASCENDING KEY IS PROV-NO
013700                                    INDEXED BY PX1 PX2 PX3.
013800         10  PROV-DATA1.
013900             15  PROV-NPI10.
014000                 20  PROV-NPI8       PIC X(08).
014100                 20  PROV-NPI-FILLER PIC X(02).
014200             15  PROV-NO             PIC X(06).
014300             15  PROV-EFF-DATE       PIC X(08).
014400             15  FILLER              PIC X(56).
014500 01  PROV-DATA-2.
014600     05  PROV-ENTRIES2               OCCURS 4000
014700                                     INDEXED BY PD2.
014800         10  PROV-DATA2              PIC X(80).
014900 01  PROV-DATA-3.
015000     05  PROV-ENTRIES3               OCCURS 4000
015100                                     INDEXED BY PD3.
015200         10  PROV-DATA3              PIC X(150).
015300
015400***************************************************************
015500*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
015600*      THE PPCAL001 PROGRAM THRU PPCAL046 FOR PROCESSING
015700***************************************************************
015800 01  WAGE-NEW-INDEX-RECORD.
015900     05  W-NEW-MSA               PIC 9(4).
016000     05  W-NEW-SIZE              PIC X(01).
016100         88  NEW-LARGE-URBAN       VALUE 'L'.
016200         88  NEW-OTHER-URBAN       VALUE 'O'.
016300         88  NEW-ALL-RURAL         VALUE 'R'.
016400     05  W-NEW-EFF-DATE.
016500          10  W-NEW-EFF-DATE-CC   PIC 9(2).
016600          10  W-NEW-EFF-DATE-YMD.
016700              15  W-NEW-EFF-DATE-YY   PIC 9(2).
016800              15  W-NEW-EFF-DATE-MM   PIC 9(2).
016900              15  W-NEW-EFF-DATE-DD   PIC 9(2).
017000     05  FILLER              PIC X.
017100     05  W-NEW-INDEX-RECORD      PIC S9(02)V9(04).
017200     05  W-NEW-PR-INDEX-RECORD   PIC S9(02)V9(04).
017300
017400***************************************************************
017500*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
017600*      THE PPCAL051 PROGRAM AND AFTER FOR PROCESSING
017700***************************************************************
017800 01  WAGE-NEW-CBSA-INDEX-RECORD.
017900     05  W-NEW-CBSA               PIC 9(5).
018000     05  W-NEW-CBSA-X  REDEFINES W-NEW-CBSA     PIC X(05).
018100     05  W-NEW-CBSA-SIZE              PIC X(01).
018200         88  NEW-CBSA-LARGE-URBAN       VALUE 'L'.
018300         88  NEW-CBSA-OTHER-URBAN       VALUE 'O'.
018400         88  NEW-CBSA-ALL-RURAL         VALUE 'R'.
018500     05  W-NEW-CBSA-EFF-DATE.
018600          10  W-NEW-CBSA-EFF-DATE-CC   PIC 9(2).
018700          10  W-NEW-CBSA-EFF-DATE-YMD.
018800              15  W-NEW-CBSA-EFF-DATE-YY   PIC 9(2).
018900              15  W-NEW-CBSA-EFF-DATE-MM   PIC 9(2).
019000              15  W-NEW-CBSA-EFF-DATE-DD   PIC 9(2).
019100     05  FILLER                      PIC X.
019200     05  W-NEW-CBSA-WI               PIC S9(02)V9(04).
019300     05  W-NEW-CBSA-PR-WI            PIC S9(02)V9(04).
019400
019500**************************************************************
019600*      THIS IS THE PROV-RECORD THAT WILL BE PASSED TO        *
019700*      THE PPDRV___ PROGRAM FOR PROCESSING                   *
019800**************************************************************
019900 01  PROV-NEW-HOLD.
020000     02  PROV-NEWREC-HOLD1.
020100         05  P-NEW-NPI10.
020200             10  P-NEW-NPI8             PIC X(08).
020300             10  P-NEW-NPI-FILLER       PIC X(02).
020400         05  P-NEW-PROVIDER-NO.
020500             10  P-NEW-STATE            PIC X(02).
020600             10  FILLER                 PIC X(04).
020700         05  P-NEW-DATE-DATA.
020800             10  P-NEW-EFF-DATE.
020900                 15  P-NEW-EFF-DT-CC    PIC 9(02).
021000                 15  P-NEW-EFF-DT-YY    PIC 9(02).
021100                 15  P-NEW-EFF-DT-MM    PIC 9(02).
021200                 15  P-NEW-EFF-DT-DD    PIC 9(02).
021300             10  P-NEW-FY-BEGIN-DATE.
021400                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
021500                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
021600                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
021700                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
021800             10  P-NEW-REPORT-DATE.
021900                 15  P-NEW-REPORT-DT-CC PIC 9(02).
022000                 15  P-NEW-REPORT-DT-YY PIC 9(02).
022100                 15  P-NEW-REPORT-DT-MM PIC 9(02).
022200                 15  P-NEW-REPORT-DT-DD PIC 9(02).
022300             10  P-NEW-TERMINATION-DATE.
022400                 15  P-NEW-TERM-DT-CC   PIC 9(02).
022500                 15  P-NEW-TERM-DT-YY   PIC 9(02).
022600                 15  P-NEW-TERM-DT-MM   PIC 9(02).
022700                 15  P-NEW-TERM-DT-DD   PIC 9(02).
022800         05  P-NEW-WAIVER-CODE          PIC X(01).
022900             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
023000         05  P-NEW-INTER-NO             PIC 9(05).
023100         05  P-NEW-PROVIDER-TYPE        PIC X(02).
023200             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
023300             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
023400                                                  '15' '17'
023500                                                  '22'.
023600             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
023700             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
023800             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
023900             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
024000             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
024100             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
024200             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
024300             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
024400             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
024500             88  P-N-EACH                   VALUE '21' '22'.
024600             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
024700             88  P-N-NHCMQ-II-SNF           VALUE '32'.
024800             88  P-N-NHCMQ-III-SNF          VALUE '33'.
024900         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
025000             88  P-N-NEW-ENGLAND            VALUE  1.
025100             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
025200             88  P-N-SOUTH-ATLANTIC         VALUE  3.
025300             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
025400             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
025500             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
025600             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
025700             88  P-N-MOUNTAIN               VALUE  8.
025800             88  P-N-PACIFIC                VALUE  9.
025900         05  P-NEW-CURRENT-DIV   REDEFINES
026000                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
026100             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
026200         05  P-NEW-MSA-DATA.
026300             10  P-NEW-CHG-CODE-INDEX       PIC X.
026400             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
026500             10  P-NEW-GEO-LOC-MSA9   REDEFINES
026600                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
026700             10  P-NEW-GEO-LOC-MSA-AST REDEFINES
026800                             P-NEW-GEO-LOC-MSA9.
026900                 15  P-NEW-GEO-MSA-1ST    PIC X.
027000                 15  P-NEW-GEO-MSA-2ND    PIC X.
027100                 15  P-NEW-GEO-MSA-3RD    PIC X.
027200                 15  P-NEW-GEO-MSA-4TH    PIC X.
027300             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
027400             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
027500             10  P-NEW-STAND-AMT-LOC-MSA9
027600       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
027700                 15  P-NEW-RURAL-1ST.
027800                     20  P-NEW-STAND-RURAL  PIC XX.
027900                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
028000                 15  P-NEW-RURAL-2ND        PIC XX.
028100         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
028200                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
028300                 88  P-NEW-SCH-YR82       VALUE   '82'.
028400                 88  P-NEW-SCH-YR87       VALUE   '87'.
028500         05  P-NEW-LUGAR                    PIC X.
028600         05  P-NEW-TEMP-RELIEF-IND          PIC X.
028700             88  P-NEW-LOW-VOL25PCT     VALUE 'Y'.
028800***          Y = LOW VOLUME PERCENTAGE  25 % ADD ON
028900         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
029000         05  P-NEW-STATE-CODE               PIC 9(02).
029100         05  P-NEW-STATE-CODE-X REDEFINES
029200             P-NEW-STATE-CODE               PIC X(02).
029300         05  FILLER                         PIC X(03).
029400     02  PROV-NEWREC-HOLD2.
029500         05  P-NEW-VARIABLES.
029600             10  P-NEW-CMI-ADJ-CPD       PIC  9(05)V9(02).
029700             10  P-NEW-COLA              PIC  9(01)V9(03).
029800             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
029900             10  P-NEW-BED-SIZE          PIC  9(05).
030000             10  P-NEW-CCR               PIC  9(01)V9(03).
030100             10  P-NEW-CMI               PIC  9(01)V9(04).
030200             10  P-NEW-SSI-RATIO         PIC  V9(04).
030300             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
030400             10  P-NEW-PPS-BLEND-YR-IND  PIC  X(01).
030500             10  P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).
030600             10  P-NEW-DSH-PERCENT       PIC  V9(04).
030700             10  P-NEW-FYE-DATE.
030800                 15  P-NEW-FYE-CC        PIC 99.
030900                 15  P-NEW-FYE-YY        PIC 99.
031000                 15  P-NEW-FYE-MM        PIC 99.
031100                 15  P-NEW-FYE-DD        PIC 99.
031200         05  P-NEW-CBSA-DATA.
031300             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.
031400                 88  P-NEW-CBSA-WI-GEO        VALUE 'N'.
031500                 88  P-NEW-CBSA-WI-RECLASS    VALUE 'Y'.
031600                 88  P-NEW-CBSA-WI-SPECIAL    VALUE '1' '2'.
031700***                  1 = ANYTHING OR HOLD HARMLESS WITH SPEC WI
031800***                  2 = RECLASS WITH SPEC WI
031900             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.
032000                 88  P-NEW-CBSA-HOSP-QUAL-MET   VALUE '1'.
032100                 88  P-NEW-CBSA-HOSP-QUAL-25PER VALUE '2'.
032200                 88  P-NEW-CBSA-HOSP-QUAL-BOTH  VALUE '3'.
032300             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.
032400             10  P-NEW-CBSA-GEO-LOC9  REDEFINES
032500                             P-NEW-CBSA-GEO-LOC  PIC 9(05).
032600             10  P-NEW-CBSA-GEO-LOC-AST REDEFINES
032700                             P-NEW-CBSA-GEO-LOC9.
032800                 15  P-NEW-CBSA-GEO-1ST    PIC X.
032900                 15  P-NEW-CBSA-GEO-2ND    PIC X.
033000                 15  P-NEW-CBSA-GEO-3RD    PIC X.
033100                 15  P-NEW-CBSA-GEO-4TH    PIC X.
033200                 15  P-NEW-CBSA-GEO-5TH    PIC X.
033300             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.
033400             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.
033500             10  P-NEW-CBSA-STAND-AMT-LOC-MSA9
033600       REDEFINES P-NEW-CBSA-STAND-AMT-LOC.
033700               15  P-NEW-CBSA-RURAL-1ST.
033800                   20  P-NEW-CBSA-STAND-RURAL  PIC XXX.
033900                      88  P-NEW-CBSA-STD-RURAL-CHECK VALUE '   '.
034000               15  P-NEW-CBSA-RURAL-2ND    PIC XX.
034100             10  P-NEW-CBSA-SPEC-WI          PIC 9(02)V9(04).
034200             10  P-NEW-CBSA-SPEC-WI-N  REDEFINES
034300                 P-NEW-CBSA-SPEC-WI          PIC 9(06).
034400     02  PROV-NEWREC-HOLD3.
034500         05  P-NEW-PASS-AMT-DATA.
034600             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
034700             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
034800             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
034900             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
035000         05  P-NEW-CAPI-DATA.
035100             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
035200             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
035300             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
035400             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
035500             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
035600             15  P-NEW-CAPI-NEW-HOSP       PIC X.
035700             15  P-NEW-CAPI-IME            PIC 9V9999.
035800             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
035900         05  P-HVBP-HRR-DATA.
036000             15  P-NEW-VAL-BASED-PURCH-PARTIPNT PIC X.
036100             15  P-NEW-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
036200             15  P-NEW-HOSP-READMISSION-REDU    PIC X.
036300             15  P-NEW-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
036400         05  P-MODEL1-BUNDLE-DATA.
036500             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
036600             15  P-HAC-REDUC-IND            PIC X.
036700             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
036800             15  P-EHR-REDUC-IND            PIC X.
036900             15  P-LV-ADJ-FACTOR            PIC 9V9(6).
037000         05  P-NEW-COUNTY-CODE              PIC 9(05).
037100         05  P-NEW-COUNTY-CODE-X REDEFINES
037200             P-NEW-COUNTY-CODE              PIC X(05).
037300         05  P-NEW-SUPPLEMENTAL-WI.
037400             10  P-NEW-SUPP-WI-IND          PIC X.
037500                 88  P-NEW-IND-PRIOR-YEAR   VALUE '1'.
037600             10  P-NEW-SUPP-WI              PIC 9(02)V9(04).
037700         05  P-PASS-THRU-ALLO-STEM-CELL     PIC 9(07)V9(02).
037800         05  FILLER                         PIC X(31).
037900
038000***************************************************************
038100 LINKAGE SECTION.
038200
038300 01  BILL-NEW-DATA.
038400         10  B-N-NPI10.
038500            15  B-N-NPI8              PIC X(08).
038600            15  B-N-NPI-FILLER        PIC X(02).
038700         10  B-N-PROVIDER-NO          PIC X(06).
038800         10  B-N-REVIEW-CODE          PIC 9(02).
038900             88  N-VALID-REVIEW-CODE    VALUE 00 THRU 09 11.
039000             88  N-PAY-WITH-OUTLIER     VALUE 00 07.
039100             88  N-PAY-DAYS-OUTLIER     VALUE 01.
039200             88  N-PAY-COST-OUTLIER     VALUE 02.
039300             88  N-PAY-PERDIEM-DAYS     VALUE 03.
039400             88  N-PAY-AVG-STAY-ONLY    VALUE 04.
039500             88  N-PAY-XFER-WITH-COST   VALUE 05.
039600             88  N-PAY-XFER-NO-COST     VALUE 06.
039700             88  N-PAY-WITHOUT-COST     VALUE 07.
039800             88  N-PAY-DRG-480          VALUE 08.
039900             88  N-PAY-XFER-SPEC-DRG    VALUE 09 11.
040000             88  N-PAY-XFER-SPEC-DRG-NO-COST VALUE 11.
040100         10  B-N-DRG                  PIC 9(03).
040200         10  B-N-LOS                  PIC 9(03).
040300         10  B-N-COVERED-DAYS         PIC 9(03).
040400         10  B-N-LTR-DAYS             PIC 9(02).
040500         10  B-N-DISCHARGE-DATE.
040600             15  B-N-DISCHG-CC        PIC 9(02).
040700             15  B-N-DISCHG-YY        PIC 9(02).
040800             15  B-N-DISCHG-MM        PIC 9(02).
040900             15  B-N-DISCHG-DD        PIC 9(02).
041000         10  B-N-CHARGES-CLAIMED      PIC 9(07)V9(02).
041100         10  B-N-PRIN-PROC-CODE       PIC X(07).
041200         10  B-N-OTHER-PROC-CODE1     PIC X(07).
041300         10  B-N-OTHER-PROC-CODE2     PIC X(07).
041400         10  B-N-OTHER-PROC-CODE3     PIC X(07).
041500         10  B-N-OTHER-PROC-CODE4     PIC X(07).
041600         10  B-N-OTHER-PROC-CODE5     PIC X(07).
041700         10  B-N-OTHER-PROC-CODE6     PIC X(07).
041800         10  B-N-OTHER-PROC-CODE7     PIC X(07).
041900         10  B-N-OTHER-PROC-CODE8     PIC X(07).
042000         10  B-N-OTHER-PROC-CODE9     PIC X(07).
042100         10  B-N-OTHER-PROC-CODE10    PIC X(07).
042200         10  B-N-OTHER-PROC-CODE11    PIC X(07).
042300         10  B-N-OTHER-PROC-CODE12    PIC X(07).
042400         10  B-N-OTHER-PROC-CODE13    PIC X(07).
042500         10  B-N-OTHER-PROC-CODE14    PIC X(07).
042600         10  B-N-OTHER-PROC-CODE15    PIC X(07).
042700         10  B-N-OTHER-PROC-CODE16    PIC X(07).
042800         10  B-N-OTHER-PROC-CODE17    PIC X(07).
042900         10  B-N-OTHER-PROC-CODE18    PIC X(07).
043000         10  B-N-OTHER-PROC-CODE19    PIC X(07).
043100         10  B-N-OTHER-PROC-CODE20    PIC X(07).
043200         10  B-N-OTHER-PROC-CODE21    PIC X(07).
043300         10  B-N-OTHER-PROC-CODE22    PIC X(07).
043400         10  B-N-OTHER-PROC-CODE23    PIC X(07).
043500         10  B-N-OTHER-PROC-CODE24    PIC X(07).
043600         10  B-N-OTHER-DIAG-CODE1   PIC X(07).
043700         10  B-N-OTHER-DIAG-CODE2   PIC X(07).
043800         10  B-N-OTHER-DIAG-CODE3   PIC X(07).
043900         10  B-N-OTHER-DIAG-CODE4   PIC X(07).
044000         10  B-N-OTHER-DIAG-CODE5   PIC X(07).
044100         10  B-N-OTHER-DIAG-CODE6   PIC X(07).
044200         10  B-N-OTHER-DIAG-CODE7   PIC X(07).
044300         10  B-N-OTHER-DIAG-CODE8   PIC X(07).
044400         10  B-N-OTHER-DIAG-CODE9   PIC X(07).
044500         10  B-N-OTHER-DIAG-CODE10  PIC X(07).
044600         10  B-N-OTHER-DIAG-CODE11  PIC X(07).
044700         10  B-N-OTHER-DIAG-CODE12  PIC X(07).
044800         10  B-N-OTHER-DIAG-CODE13  PIC X(07).
044900         10  B-N-OTHER-DIAG-CODE14  PIC X(07).
045000         10  B-N-OTHER-DIAG-CODE15  PIC X(07).
045100         10  B-N-OTHER-DIAG-CODE16  PIC X(07).
045200         10  B-N-OTHER-DIAG-CODE17  PIC X(07).
045300         10  B-N-OTHER-DIAG-CODE18  PIC X(07).
045400         10  B-N-OTHER-DIAG-CODE19  PIC X(07).
045500         10  B-N-OTHER-DIAG-CODE20  PIC X(07).
045600         10  B-N-OTHER-DIAG-CODE21  PIC X(07).
045700         10  B-N-OTHER-DIAG-CODE22  PIC X(07).
045800         10  B-N-OTHER-DIAG-CODE23  PIC X(07).
045900         10  B-N-OTHER-DIAG-CODE24  PIC X(07).
046000         10  B-N-OTHER-DIAG-CODE25  PIC X(07).
046100         10  B-N-DEMO-DATA.
046200             15  B-N-DEMO-CODE1        PIC X(02).
046300             15  B-N-DEMO-CODE2        PIC X(02).
046400             15  B-N-DEMO-CODE3        PIC X(02).
046500             15  B-N-DEMO-CODE4        PIC X(02).
046600         10  B-N-NDC-DATA.
046700             15  B-N-NDC-NUMBER        PIC X(11).
046800         10  B-N-COND-DATA.
046900             15  B-N-COND-CODE1        PIC X(02).
047000             15  B-N-COND-CODE2        PIC X(02).
047100             15  B-N-COND-CODE3        PIC X(02).
047200             15  B-N-COND-CODE4        PIC X(02).
047300             15  B-N-COND-CODE5        PIC X(02).
047400         10  FILLER                     PIC X(63).
047500
047600 01  PPS-DATA.
047700         10  PPS-RTC                PIC 9(02).
047800         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
047900         10  PPS-OUTLIER-DAYS       PIC 9(03).
048000         10  PPS-AVG-LOS            PIC 9(02)V9(01).
048100         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
048200         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
048300         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
048400         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
048500         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
048600         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
048700         10  PPS-REG-DAYS-USED      PIC 9(03).
048800         10  PPS-LTR-DAYS-USED      PIC 9(02).
048900         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
049000         10  PPS-CALC-VERS          PIC 9(05).
049100
049200 01  PRICER-OPT-VERS-SW.
049300     02  PRICER-OPTION-SW               PIC X(01).
049400         88  ALL-TABLES-PASSED          VALUE 'A'.
049500         88  PROV-RECORD-PASSED         VALUE 'P'.
049600         88  ADDITIONAL-VARIABLES       VALUE 'M'.
049700     02  PPS-VERSIONS.
049800         10  PPDRV-VERSION              PIC X(05).
049900
050000 01  PPS-ADDITIONAL-VARIABLES.
050100     02  PPS-OPERATION-VARIABLES.
050200         05  PPS-HSP-PCT                PIC 9(01)V9(02).
050300         05  PPS-FSP-PCT                PIC 9(01)V9(02).
050400         05  PPS-NAT-PCT                PIC 9(01)V9(02).
050500         05  PPS-REG-PCT                PIC 9(01)V9(02).
050600         05  PPS-CMI-ADJ-CPD            PIC 9(05)V9(02).
050700         05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
050800         05  PPS-DRG-WT                 PIC 9(02)V9(04).
050900         05  PPS-NAT-LABOR              PIC 9(05)V9(02).
051000         05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
051100         05  PPS-REG-LABOR              PIC 9(05)V9(02).
051200         05  PPS-REG-NLABOR             PIC 9(05)V9(02).
051300         05  PPS-OPER-COLA              PIC 9(01)V9(03).
051400         05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
051500         05  PPS-OPER-OUTLIER           PIC 9(07)V9(09).
051600         05  PPS-OPER-BILL-COSTS        PIC 9(07)V9(09).
051700         05  PPS-OPER-DOLLAR-THRESHOLD  PIC 9(07)V9(09).
051800         05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
051900         05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
052000         05  PPS-CAPITAL-VARIABLES.
052100             10  PPS-CAPI-TOTAL-PAY         PIC S9(07)V9(02).
052200             10  PPS-CAPI-HSP               PIC S9(07)V9(02).
052300             10  PPS-CAPI-FSP               PIC S9(07)V9(02).
052400             10  PPS-CAPI-OUTLIER           PIC S9(07)V9(02).
052500             10  PPS-CAPI-OLD-HARM          PIC S9(07)V9(02).
052600             10  PPS-CAPI-DSH-ADJ           PIC S9(07)V9(02).
052700             10  PPS-CAPI-IME-ADJ           PIC S9(07)V9(02).
052800             10  PPS-CAPI-EXCEPTIONS        PIC S9(07)V9(02).
052900         05  PPS-CAPITAL2-VARIABLES.
053000             10  PPS-CAPI2-PAY-CODE          PIC X(1).
053100             10  PPS-CAPI2-B-FSP             PIC S9(07)V9(02).
053200             10  PPS-CAPI2-B-OUTLIER         PIC S9(07)V9(02).
053300         05  PPS-OTHER-VARIABLES.
053400             10  PPS-NON-TEMP-RELIEF-PAYMENT PIC 9(07)V9(02).
053500             10  PPS-NEW-TECH-PAY-ADD-ON     PIC 9(07)V9(02).
053600             10  PPS-ISLET-ISOL-PAY-ADD-ON   PIC 9(07)V9(02).
053700             10  PPS-LOW-VOL-PAYMENT         PIC 9(07)V9(02).
053800         10  PPS-HVBP-HRR-DATA.
053900             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.
054000             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
054100             15  PPS-HOSP-READMISS-REDUCTN    PIC X.
054200             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
054300         10  PPS-OPERATNG-DATA.
054400             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
054500             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
054600             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
054700         10  PPS-PC-VARIABLES.
054800             15  PPS-OPER-DSH                PIC 9(01)V9(04).
054900             15  PPS-CAPI-DSH                PIC 9(01)V9(04).
055000             15  PPS-CAPI-HSP-PCT            PIC 9(01)V9(02).
055100             15  PPS-CAPI-FSP-PCT            PIC 9(01)V9(04).
055200             15  PPS-ARITH-ALOS              PIC 9(02)V9(01).
055300             15  PPS-PR-WAGE-INDEX           PIC 9(02)V9(04).
055400             15  PPS-TRANSFER-ADJ            PIC 9(01)V9(04).
055500             15  PPS-PC-HMO-FLAG             PIC X(01).
055600             15  PPS-PC-COT-FLAG             PIC X(01).
055700             15  PPS-OPER-HSP-PART2          PIC 9(07)V9(02).
055800             15  PPS-BUNDLE-ADJUST-AMT       PIC S9(07)V99.
055900         10  PPS-ADDITIONAL-PAY-INFO-DATA.
056000             15  PPS-UNCOMP-CARE-AMOUNT       PIC S9(07)V9(2).
056100             15  PPS-BUNDLE-ADJUST-AMT        PIC S9(07)V9(2).
056200             15  PPS-VAL-BASED-PURCH-ADJUST-AMT PIC S9(07)V9(2).
056300             15  PPS-READMIS-ADJUST-AMT       PIC S9(07)V9(2).
056400         10  PPS-ADDITIONAL-PAY-INFO-DATA2.
056500             15  PPS-HAC-PROG-REDUC-IND      PIC X.
056600             15  PPS-EHR-PROG-REDUC-IND      PIC X.
056700             15  PPS-EHR-ADJUST-AMT          PIC S9(07)V9(02).
056800             15  PPS-STNDRD-VALUE            PIC S9(07)V9(02).
056900             15  PPS-FLX6-PAYMENT            PIC S9(07)V9(02).
057000             15  PPS-FLX7-PAYMENT            PIC S9(07)V9(02).
057100         10  PPS-FILLER                      PIC X(0897).
057200*************************************************************
057300
057400 01  PROV-RECORD-FROM-USER.
057500     05  PROV-REC1                  PIC X(80).
057600     05  PROV-REC2                  PIC X(80).
057700     05  PROV-REC3                  PIC X(150).
057800
057900 01  MSAX-TABLE-FROM-USER.
058000     05  FILLER                     PIC X(32000).
058100     05  FILLER                     PIC X(30000).
058200     05  FILLER                     PIC X(30000).
058300
058400 01  CBSA-TABLE-FROM-USER.
058500     05  FILLER                     PIC X(32000).
058600     05  FILLER                     PIC X(30000).
058700     05  FILLER                     PIC X(30000).
058800
058900*******************************************************
059000*    HOLD VARIABLES POPULATED IN PPCAL___***          *
059100*******************************************************
059200 COPY PPHOLDAR.
059300
059400******************************************************************
059500 PROCEDURE DIVISION  USING BILL-NEW-DATA
059600                           PPS-DATA
059700                           PRICER-OPT-VERS-SW
059800                           PPS-ADDITIONAL-VARIABLES
059900                           PPHOLDAR-HOLD-AREA
060000                           PROV-RECORD-FROM-USER
060100                           MSAX-TABLE-FROM-USER
060200                           CBSA-TABLE-FROM-USER.
060300
060400******************************************************************
060500*    PROCESSING:
060600*        A. I/O THE PRICER FILES
060700*        B. THIS MODULE WILL LOAD ALL TABLES THE FIRST TIME THIS
060800*           SUBROUTINE IS CALLED.
060900*        C. ALL FILES WILL BE PASSED TO THE PPDRV___ PROGRAM.
061000******************************************************************
061100
061200     MOVE ALL '0' TO PPS-DATA.
061300
061400******************************************************************
061500
061600 0010-LOAD-TABLES.
061700     IF  PRICER-OPTION-SW  = 'A'
061800         PERFORM 1900-OPTION-SW-A THRU 1900-EXIT
061900     ELSE
062000     IF  PRICER-OPTION-SW  = 'P'
062100         PERFORM 2000-OPTION-SW-P THRU 2000-EXIT
062200     ELSE
062300         PERFORM 2100-OPTION-SW THRU 2100-EXIT.
062400
062500******************************************************************
062600***  GET THE PROVIDER RECORD TO BE PASSED TO PPDRV___
062700
062800 0020-GET-PROVIDER.
062900
063000     IF PROV-RECORD-PASSED OR ALL-TABLES-PASSED
063100*       PERFORM 1350-N-CHECK-MSA
063200        MOVE 00 TO PPS-RTC
063300     ELSE
063400        PERFORM 1200-GET-THIS-PROVIDER THRU 1200-EXIT.
063500
063600***     RTC = 51  --  PROVIDER NOT FOUND
063700     IF PPS-RTC = 51
063800          MOVE ALL '0' TO  PPS-ADDITIONAL-VARIABLES
063900          GOBACK.
064000
064100******************************************************************
064200
064300     CALL  PPDRV210 USING BILL-NEW-DATA
064400                          PPS-DATA
064500                          PRICER-OPT-VERS-SW
064600                          PPS-ADDITIONAL-VARIABLES
064700                          PROV-NEW-HOLD
064800                          MSAX-WI-TABLE
064900                          CBSA-WI-TABLE
065000                          PPHOLDAR-HOLD-AREA.
065100      GOBACK.
065200******************************************************************
065300
065400 1200-GET-THIS-PROVIDER.
065500***************************************************************
065600*    ON A PROVIDER BREAK:                                     *
065700*        FIND THE NEW PROVIDER SPECIFIC DATA ELEMENTS         *
065800*    NOTE: IF BILLS ARE BATCHED BY PROVIDER, FEWER TABLE      *
065900*             SEARCHES WILL BE NECESSARY.                     *
066000***************************************************************
066100     IF  B-N-PROVIDER-NO NOT = P-NEW-PROVIDER-NO
066200         SET PX2 TO 1
066300         SEARCH PROV-ENTRIES VARYING PX2
066400             AT END
066500                 MOVE 51 TO PPS-RTC
066600                 GO TO 1200-EXIT
066700             WHEN B-N-PROVIDER-NO = PROV-NO (PX2)
066800                 MOVE 00 TO PPS-RTC.
066900
067000     MOVE PROV-DATA1 (PX2) TO PROV-NEWREC-HOLD1.
067100     SET PD2 TO PX2.
067200     SET PD3 TO PX2.
067300     MOVE PROV-DATA2 (PD2) TO PROV-NEWREC-HOLD2.
067400     MOVE PROV-DATA3 (PD3) TO PROV-NEWREC-HOLD3.
067500
067600*    PERFORM 1350-N-CHECK-MSA.
067700
067800     PERFORM 1300-GET-CURR-PROV THRU 1300-EXIT VARYING PX3
067900         FROM PX2 BY 1 UNTIL PROV-NO (PX3) NOT =
068000         B-N-PROVIDER-NO OR PROV-NO (PX3) = '999999'.
068100
068200 1200-EXIT.  EXIT.
068300
068400 1300-GET-CURR-PROV.
068500     IF  B-N-DISCHARGE-DATE NOT < PROV-EFF-DATE (PX3)
068600         MOVE PROV-DATA1 (PX3) TO PROV-NEWREC-HOLD1
068700         SET PD2 TO PX3
068800         SET PD3 TO PX3
068900         MOVE PROV-DATA2 (PD2) TO PROV-NEWREC-HOLD2
069000         MOVE PROV-DATA3 (PD3) TO PROV-NEWREC-HOLD3.
069100*        PERFORM 1350-N-CHECK-MSA.
069200
069300 1300-EXIT.  EXIT.
069400
069500*1350-N-CHECK-MSA.
069600*
069700*    IF P-NEW-EFF-DATE < 20041001
069800*       IF (P-NEW-WAGE-INDEX-LOC-MSA = '    ' OR
069900*           P-NEW-WAGE-INDEX-LOC-MSA = '0000')
070000*           MOVE P-NEW-GEO-LOC-MSA9 TO P-NEW-WAGE-INDEX-LOC-MSA.
070100*    IF P-NEW-EFF-DATE < 20041001
070200*       IF (P-NEW-STAND-AMT-LOC-MSA = '    ' OR
070300*           P-NEW-STAND-AMT-LOC-MSA = '0000')
070400*           MOVE P-NEW-GEO-LOC-MSA9 TO P-NEW-STAND-AMT-LOC-MSA.
070500*
070600*    IF P-NEW-EFF-DATE > 20040930
070700*       IF (P-NEW-CBSA-RECLASS-LOC = '     ' OR
070800*           P-NEW-CBSA-RECLASS-LOC = '00000')
070900*           MOVE P-NEW-CBSA-GEO-LOC9 TO P-NEW-CBSA-RECLASS-LOC.
071000*    IF P-NEW-EFF-DATE > 20040930
071100*       IF (P-NEW-CBSA-STAND-AMT-LOC = '     ' OR
071200*           P-NEW-CBSA-STAND-AMT-LOC = '00000')
071300*           MOVE P-NEW-CBSA-GEO-LOC9 TO P-NEW-CBSA-STAND-AMT-LOC.
071400*
071500*1350-N-EXIT.  EXIT.
071600*
071700******************************************************************
071800 1500-LOAD-ALL-TABLES.
071900***************************************************************
072000*    THE FIRST TIME CALLED:                                   *
072100*        LOAD ALL TABLES SUPPLIED BY CMS                      *
072200*        LOAD THE PROVIDER SPECIFIC TABLE SUPPLIED BY         *
072300*             THE INTERMEDIARY.                               *
072400***************************************************************
072500     MOVE HIGH-VALUES TO MSAX-WI-TABLE.
072600     MOVE HIGH-VALUES TO CBSA-WI-TABLE.
072700     MOVE ALL '9' TO PROV-NEW-HOLD.
072800     MOVE ALL '9' TO PROV-TABLE.
072900     MOVE ALL '9' TO PROV-DATA-2.
073000     MOVE ALL '9' TO PROV-DATA-3.
073100     OPEN  INPUT  PROV-FILE.
073200     MOVE 0 TO EOF-SW.
073300     SET PX1 TO EOF-SW.
073400
073500     PERFORM 1600-READ-PROV-FILE THRU 1600-EXIT
073600                           UNTIL EOF-SW = 1.
073700
073800     CLOSE        PROV-FILE.
073900     PERFORM 1700-LOAD-MSAX-FILE THRU 1700-EXIT.
074000     PERFORM 1750-LOAD-CBSA-FILE THRU 1750-EXIT.
074100
074200 1500-EXIT.  EXIT.
074300
074400 1600-READ-PROV-FILE.
074500     READ PROV-FILE
074600         AT END
074700             SET PX1 UP BY 1
074800             MOVE ALL '9' TO PROV-DATA1 (PX1)
074900             SET PD2 TO PX1
075000             SET PD3 TO PX1
075100             MOVE ALL '9' TO PROV-DATA2 (PD2)
075200             MOVE ALL '9' TO PROV-DATA3 (PD3)
075300             MOVE '999999' TO P-NEW-PROVIDER-NO
075400             MOVE 1 TO EOF-SW.
075500
075600     IF  EOF-SW = 0
075700         SET PX1 UP BY 1
075800         MOVE PROV-PART1 TO PROV-DATA1 (PX1)
075900         SET PD2 TO PX1
076000         SET PD3 TO PX1
076100         MOVE PROV-PART2 TO PROV-DATA2 (PD2)
076200         MOVE PROV-PART3 TO PROV-DATA3 (PD3).
076300
076400 1600-EXIT.  EXIT.
076500
076600 1700-LOAD-MSAX-FILE.
076700     OPEN  INPUT  MSAX-FILE.
076800     MOVE 0 TO EOF-SW.
076900     SET MU3 TO EOF-SW.
077000
077100     PERFORM 1800-READ-MSAX-FILE THRU 1800-EXIT
077200                      UNTIL EOF-SW = 1.
077300     CLOSE        MSAX-FILE.
077400
077500 1700-EXIT.  EXIT.
077600
077700 1750-LOAD-CBSA-FILE.
077800     OPEN  INPUT  F-CBSA-FILE.
077900     MOVE 0 TO EOF-SW.
078000     SET MA3 TO EOF-SW.
078100
078200     PERFORM 1850-READ-CBSA-FILE THRU 1850-EXIT
078300                      UNTIL EOF-SW = 1.
078400     CLOSE  F-CBSA-FILE.
078500
078600 1750-EXIT.  EXIT.
078700
078800 1800-READ-MSAX-FILE.
078900     READ MSAX-FILE
079000         AT END
079100             MOVE 1 TO EOF-SW.
079200
079300     IF  EOF-SW = 0
079400             IF  XE-DATE > '19860930' OR
079500                (M-STATE = '98' OR '99')
079600                SET MU3 UP BY 1
079700                MOVE X-MSA-X      TO M-MSAX-MSA        (MU3)
079800                MOVE X-SIZE       TO M-MSAX-SIZE       (MU3)
079900                MOVE XE-DATE      TO M-MSAX-EFF-DATE   (MU3)
080000                MOVE X-WAGE-INDX1 TO M-MSAX-WAGE-INDX1 (MU3)
080100                MOVE X-WAGE-INDX2 TO M-MSAX-WAGE-INDX2 (MU3).
080200
080300 1800-EXIT.  EXIT.
080400
080500 1850-READ-CBSA-FILE.
080600     READ F-CBSA-FILE
080700         AT END
080800             MOVE 1 TO EOF-SW.
080900
081000     IF  EOF-SW = 0
081100             IF  F-CBSA-EFF-DATE > '20030930' OR
081200                (F-CBSA-STATE = '98' OR '99')
081300                SET MA3 UP BY 1
081400            MOVE F-CBSA            TO T-CBSA            (MA3)
081500            MOVE F-CBSA-SIZE       TO T-CBSA-SIZE       (MA3)
081600            MOVE F-CBSA-EFF-DATE   TO T-CBSA-EFF-DATE   (MA3)
081700            MOVE F-CBSA-WAGE-INDX1 TO T-CBSA-WAGE-INDX1 (MA3)
081800            MOVE F-CBSA-WAGE-INDX2 TO T-CBSA-WAGE-INDX2 (MA3).
081900            MOVE F-CBSA-WAGE-INDX3 TO T-CBSA-WAGE-INDX3 (MA3).
082000
082100 1850-EXIT.  EXIT.
082200
082300 1900-OPTION-SW-A.
082400     MOVE ALL '9'               TO PROV-NEW-HOLD.
082500     MOVE PROV-RECORD-FROM-USER TO PROV-NEW-HOLD.
082600     IF  TABLES-LOADED-SW = 0
082700         MOVE HIGH-VALUES           TO MSAX-WI-TABLE
082800         MOVE MSAX-TABLE-FROM-USER  TO MSAX-WI-TABLE
082900         MOVE HIGH-VALUES           TO CBSA-WI-TABLE
083000         MOVE CBSA-TABLE-FROM-USER  TO CBSA-WI-TABLE
083100         MOVE 1 TO TABLES-LOADED-SW.
083200
083300 1900-EXIT.  EXIT.
083400
083500 2000-OPTION-SW-P.
083600     MOVE ALL '9'               TO PROV-NEW-HOLD.
083700     MOVE PROV-RECORD-FROM-USER TO PROV-NEW-HOLD.
083800     IF  TABLES-LOADED-SW = 0
083900         MOVE HIGH-VALUES       TO MSAX-WI-TABLE
084000         MOVE HIGH-VALUES       TO CBSA-WI-TABLE
084100         PERFORM 1700-LOAD-MSAX-FILE THRU 1700-EXIT
084200         PERFORM 1750-LOAD-CBSA-FILE THRU 1750-EXIT
084300         MOVE 1 TO TABLES-LOADED-SW.
084400
084500 2000-EXIT.  EXIT.
084600
084700 2100-OPTION-SW.
084800     IF  TABLES-LOADED-SW = 0
084900         PERFORM 1500-LOAD-ALL-TABLES THRU 1500-EXIT
085000         MOVE 1 TO TABLES-LOADED-SW.
085100
085200 2100-EXIT.  EXIT.
085300
085400***************************************************************
085500******       L A S T   S O U R C E   S T A T E M E N T    *****
