000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.    IPDRV201.
000300*================================================================*
000400*REMARKS.  - CALLS THE IPCAL__ MODULES
000500*          - CBSA FILE REPLACES THE MSA FILE ON JULY1, 2006
000600*          - LOADS THE IPF TABLES
000700*          - LOADS THE SNF MSA TABLES UNTIL JULY 1, 2006
000800*          - LOADS THE SNF CBSA TABLES STARTING JULY 1, 2006
000900*          - FINDS PROV RECORD AND WAGE-INDEX RECORD FOR
001000*             GIVEN BILL TO BE PASSED TO IPCAL__ MODULES.
001010*================================================================*
001021* REPLACED CALL FROM IPCAL200 TO IPCAL201 FOR U071 COVID-19 CODE *
001030*================================================================*
001200 DATE-COMPILED.
001300 ENVIRONMENT DIVISION.
001400 CONFIGURATION SECTION.
001500 SOURCE-COMPUTER.            IBM-370.
001600 OBJECT-COMPUTER.            IBM-370.
001700 INPUT-OUTPUT  SECTION.
001800 FILE-CONTROL.
001900 DATA DIVISION.
002000 FILE SECTION.
002100
002200 WORKING-STORAGE SECTION.
002300 77  W-STORAGE-REF         PIC X(40)  VALUE
002400     'IPDRV201 - W O R K I N G   S T O R A G E'.
002500 01  DRV-VERSION           PIC X(05) VALUE 'D20.1'.
002600 01  IPCAL201              PIC X(08) VALUE 'IPCAL201'.
002601 01  IPCAL191              PIC X(08) VALUE 'IPCAL191'.
002602 01  IPCAL180              PIC X(08) VALUE 'IPCAL180'.
002603 01  IPCAL170              PIC X(08) VALUE 'IPCAL170'.
002604 01  IPCAL161              PIC X(08) VALUE 'IPCAL161'.
002610 01  IPCAL150              PIC X(08) VALUE 'IPCAL150'.
002700 01  IPCAL140              PIC X(08) VALUE 'IPCAL140'.
002800 01  IPCAL130              PIC X(08) VALUE 'IPCAL130'.
002900 01  IPCAL121              PIC X(08) VALUE 'IPCAL121'.
002901 01  IPCAL120              PIC X(08) VALUE 'IPCAL120'.
002902 01  IPCAL112              PIC X(08) VALUE 'IPCAL112'.
002903 01  IPCAL111              PIC X(08) VALUE 'IPCAL111'.
002904 01  IPCAL110              PIC X(08) VALUE 'IPCAL110'.
002905 01  IPCAL102              PIC X(08) VALUE 'IPCAL102'.
002906 01  IPCAL100              PIC X(08) VALUE 'IPCAL100'.
002907 01  IPCAL094              PIC X(08) VALUE 'IPCAL094'.
002908 01  IPCAL09A              PIC X(08) VALUE 'IPCAL09A'.
002909 01  IPCAL08A              PIC X(08) VALUE 'IPCAL08A'.
002910 01  IPCAL086              PIC X(08) VALUE 'IPCAL086'.
002911 01  IPCAL076              PIC X(08) VALUE 'IPCAL076'.
002912 01  IPCAL057              PIC X(08) VALUE 'IPCAL057'.
002913 01  TABLES-LOADED-SW      PIC 9(01)  VALUE 0.
002914 01  EOF-SW                PIC 9(01)  VALUE 0.
002915 01  PROV-STAT.
002916     02  PROV-STAT1     PIC X.
002917     02  PROV-STAT2     PIC X.
002918
002919 01  MSAX-STAT.
002920     02  MSAX-STAT1     PIC X.
002930     02  MSAX-STAT2     PIC X.
002940
002950 01  CBSA-STAT.
002960     02  CBSA-STAT1     PIC X.
002970     02  CBSA-STAT2     PIC X.
002980
002990 01  HOLD-PROV-MSAX.
003000         10  H-MSAX-PROV-BLANK   PIC X(2).
003100         10  H-MSAX-PROV-STATE.
003200             15  FILLER          PIC X.
003300             15  H-MSAX-LAST-POS PIC X.
003400
003500 01  HOLD-PROV-CBSA.
003600         10  H-CBSA-PROV-BLANK   PIC X(3).
003700         10  H-CBSA-PROV-STATE.
003800             15  FILLER          PIC X.
003900             15  H-CBSA-LAST-POS PIC X.
004000
004100**================================================================
004200*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
004300*      THE IPCAL056 PROGRAM FOR PROCESSING
004400**================================================================
004500 01  WAGE-NEW-INDEX-RECORD.
004600     05  W-NEW-MSA               PIC 9(4).
004700     05  W-NEW-SIZE              PIC X(01).
004800         88  NEW-LARGE-URBAN       VALUE 'L'.
004900         88  NEW-OTHER-URBAN       VALUE 'O'.
005000         88  NEW-ALL-RURAL         VALUE 'R'.
005100     05  W-NEW-EFF-DATE.
005200          10  W-NEW-EFF-DATE-CC   PIC 9(2).
005300          10  W-NEW-EFF-DATE-YMD.
005400              15  W-NEW-EFF-DATE-YY   PIC 9(2).
005500              15  W-NEW-EFF-DATE-MM   PIC 9(2).
005600              15  W-NEW-EFF-DATE-DD   PIC 9(2).
005700     05  FILLER              PIC X.
005800     05  W-NEW-INDEX-RECORD      PIC S9(02)V9(04).
005900     05  FILLER                  PIC S9(02)V9(04).
006000
006100**================================================================
006200*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
006300*      THE IPCAL    PROGRAM FOR PROCESSING
006400**================================================================
006500 01  CBSA-WAGE-INDEX-RECORD.
006600     05  W-CBSA               PIC 9(5).
006700     05  W-CBSA-X  REDEFINES W-CBSA PIC X(05).
006800     05  W-CBSA-SIZE             PIC X(01).
006900         88  W-CBSA-LARGE-URBAN       VALUE 'L'.
007000         88  W-CBSA-OTHER-URBAN       VALUE 'O'.
007100         88  W-CBSA-ALL-RURAL         VALUE 'R'.
007200     05  W-CBSA-EFF-DATE.
007300          10  W-CBSA-EFF-DATE-CC       PIC 9(2).
007400          10  W-CBSA-EFF-DATE-YMD.
007500              15  W-CBSA-EFF-DATE-YY   PIC 9(2).
007600              15  W-CBSA-EFF-DATE-MM   PIC 9(2).
007700              15  W-CBSA-EFF-DATE-DD   PIC 9(2).
007800     05  FILLER             PIC X.
007900     05  W-CBSA-INDEX       PIC S9(02)V9(04).
008000     05  FILLER             PIC S9(02)V9(04).
008100
008200
008300**==============================================================**
008400*   MSAX RECORD PASSED OPTION B
008500**==============================================================**
008600 01  MSAX-TABLE-FROM-USER.
008700     05  FILLER                     PIC X(32000).
008800     05  FILLER                     PIC X(30000).
008900     05  FILLER                     PIC X(30000).
009000
009100**==============================================================**
009200*   CBSA RECORD PASSED OPTION B
009300**==============================================================**
009400 01  CBSA-TABLE-FROM-USER.
009500     05  FILLER                     PIC X(32000).
009600     05  FILLER                     PIC X(30000).
009700     05  FILLER                     PIC X(30000).
009800
009900**==============================================================**
010000*   PROV RECORD PASSED OPTION P
010100**==============================================================**
010200 01  PROV-NEW-HOLD.
010300     02  PROV-NEWREC-HOLD1.
010400         05  P-NEW-NPI10.
010500             10  P-NEW-NPI8             PIC X(08).
010600             10  P-NEW-NPI-FILLER       PIC X(02).
010700         05  P-NEW-PROVIDER-NO.
010800             10  P-NEW-STATE            PIC 9(02).
010900             10  FILLER                 PIC X(04).
011000         05  P-NEW-DATE-DATA.
011100             10  P-NEW-EFF-DATE.
011200                 15  P-NEW-EFF-DT-CC    PIC 9(02).
011300                 15  P-NEW-EFF-DT-YY    PIC 9(02).
011400                 15  P-NEW-EFF-DT-MM    PIC 9(02).
011500                 15  P-NEW-EFF-DT-DD    PIC 9(02).
011600             10  P-NEW-FY-BEGIN-DATE.
011700                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
011800                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
011900                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
012000                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
012100             10  P-NEW-REPORT-DATE.
012200                 15  P-NEW-REPORT-DT-CC PIC 9(02).
012300                 15  P-NEW-REPORT-DT-YY PIC 9(02).
012400                 15  P-NEW-REPORT-DT-MM PIC 9(02).
012500                 15  P-NEW-REPORT-DT-DD PIC 9(02).
012600             10  P-NEW-TERMINATION-DATE.
012700                 15  P-NEW-TERM-DT-CC   PIC 9(02).
012800                 15  P-NEW-TERM-DT-YY   PIC 9(02).
012900                 15  P-NEW-TERM-DT-MM   PIC 9(02).
013000                 15  P-NEW-TERM-DT-DD   PIC 9(02).
013100         05  P-NEW-WAIVER-CODE          PIC X(01).
013200             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
013300         05  P-NEW-INTER-NO             PIC 9(05).
013400         05  P-NEW-PROVIDER-TYPE        PIC X(02).
013500             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
013600             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
013700                                                  '15' '17'
013800                                                  '22'.
013900             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
014000             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
014100             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
014200             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
014300             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
014400             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
014500             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
014600             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
014700             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
014800             88  P-N-EACH                   VALUE '21' '22'.
014900             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
015000             88  P-N-NHCMQ-II-SNF           VALUE '32'.
015100             88  P-N-NHCMQ-III-SNF          VALUE '33'.
015200         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
015300             88  P-N-NEW-ENGLAND            VALUE  1.
015400             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
015500             88  P-N-SOUTH-ATLANTIC         VALUE  3.
015600             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
015700             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
015800             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
015900             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
016000             88  P-N-MOUNTAIN               VALUE  8.
016100             88  P-N-PACIFIC                VALUE  9.
016200         05  P-NEW-CURRENT-DIV   REDEFINES
016300                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
016400             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
016500         05  P-NEW-MSA-DATA.
016600             10  P-NEW-CHG-CODE-INDEX       PIC X.
016700             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
016800             10  P-NEW-GEO-LOC-MSA9   REDEFINES
016900                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
017000             10  P-NEW-GEO-LOC-MSA-AST REDEFINES
017100                             P-NEW-GEO-LOC-MSA9.
017200                 15  P-NEW-GEO-MSA-1ST    PIC X.
017300                 15  P-NEW-GEO-MSA-2ND    PIC X.
017400                 15  P-NEW-GEO-MSA-3RD    PIC X.
017500                 15  P-NEW-GEO-MSA-4TH    PIC X.
017600             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
017700             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
017800             10  P-NEW-STAND-AMT-LOC-MSA9
017900       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
018000                 15  P-NEW-RURAL-1ST.
018100                     20  P-NEW-STAND-RURAL  PIC XX.
018200                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
018300                 15  P-NEW-RURAL-2ND        PIC XX.
018400         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
018500                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
018600                 88  P-NEW-SCH-YR82       VALUE   '82'.
018700                 88  P-NEW-SCH-YR87       VALUE   '87'.
018800         05  P-NEW-LUGAR                    PIC X.
018900         05  P-NEW-TEMP-RELIEF-IND          PIC X.
019000             88  P-NEW-LOW-VOL25PCT     VALUE 'Y'.
019100***          Y = LOW VOLUME PERCENTAGE  25 % ADD ON
019200         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
019300         05  FILLER                         PIC X(05).
019400     02  PROV-NEWREC-HOLD2.
019500         05  P-NEW-VARIABLES.
019600             10  P-NEW-CMI-ADJ-CPD       PIC  9(05)V9(02).
019700             10  P-NEW-COLA              PIC  9(01)V9(03).
019800             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
019900             10  P-NEW-BED-SIZE          PIC  9(05).
020000             10  P-NEW-CCR               PIC  9(01)V9(03).
020100             10  P-NEW-CMI               PIC  9(01)V9(04).
020200             10  P-NEW-SSI-RATIO         PIC  V9(04).
020300             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
020400             10  P-NEW-PPS-BLEND-YR-IND  PIC  X(01).
020500             10  P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).
020600             10  P-NEW-DSH-PERCENT       PIC  V9(04).
020700             10  P-NEW-FYE-DATE.
020800                 15  P-NEW-FYE-CC        PIC 99.
020900                 15  P-NEW-FYE-YY        PIC 99.
021000                 15  P-NEW-FYE-MM        PIC 99.
021100                 15  P-NEW-FYE-DD        PIC 99.
021200         05  P-NEW-CBSA-DATA.
021300             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.
021400                 88  P-NEW-CBSA-WI-GEO        VALUE 'N'.
021500                 88  P-NEW-CBSA-WI-RECLASS    VALUE 'Y'.
021600                 88  P-NEW-CBSA-WI-SPECIAL    VALUE '1' '2'.
021700***                  1 = ANYTHING OR HOLD HARMLESS WITH SPEC WI
021800***                  2 = RECLASS WITH SPEC WI
021900             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.
022000                 88  P-NEW-CBSA-HOSP-QUAL-MET   VALUE '1'.
022100                 88  P-NEW-CBSA-HOSP-QUAL-25PER VALUE '2'.
022200                 88  P-NEW-CBSA-HOSP-QUAL-BOTH  VALUE '3'.
022300             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.
022400             10  P-NEW-CBSA-GEO-LOC9  REDEFINES
022500                             P-NEW-CBSA-GEO-LOC  PIC 9(05).
022600             10  P-NEW-CBSA-GEO-LOC-AST REDEFINES
022700                             P-NEW-CBSA-GEO-LOC9.
022800                 15  P-NEW-CBSA-GEO-1ST    PIC X.
022900                 15  P-NEW-CBSA-GEO-2ND    PIC X.
023000                 15  P-NEW-CBSA-GEO-3RD    PIC X.
023100                 15  P-NEW-CBSA-GEO-4TH    PIC X.
023200                 15  P-NEW-CBSA-GEO-5TH    PIC X.
023300             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.
023400             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.
023500             10  P-NEW-CBSA-STAND-AMT-LOC-MSA9
023600       REDEFINES P-NEW-CBSA-STAND-AMT-LOC.
023700               15  P-NEW-CBSA-RURAL-1ST.
023800                   20  P-NEW-CBSA-STAND-RURAL  PIC XXX.
023900                      88  P-NEW-CBSA-STD-RURAL-CHECK VALUE '   '.
024000               15  P-NEW-CBSA-RURAL-2ND    PIC XX.
024100             10  P-NEW-CBSA-SPEC-WI          PIC 9(02)V9(04).
024200             10  P-NEW-CBSA-SPEC-WI-N  REDEFINES
024300                 P-NEW-CBSA-SPEC-WI          PIC 9(06).
024400     02  PROV-NEWREC-HOLD3.
024500         05  P-NEW-PASS-AMT-DATA.
024600             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
024700             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
024800             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
024900             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
025000         05  P-NEW-CAPI-DATA.
025100             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
025200             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
025300             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
025400             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
025500             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
025600             15  P-NEW-CAPI-NEW-HOSP       PIC X.
025700             15  P-NEW-CAPI-IME            PIC 9V9999.
025800             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
025900             15  P-VAL-BASED-PURCH-SCORE    PIC 9V999.
026000         05  FILLER                         PIC X(18).
026100
026200**================================================================
026300 LINKAGE SECTION.
026400
026500**========================================================
026600*    PASSED AND RETURNED BY IPCAL                     *
026700**==============================*========================*
026800 01  BILL-INPUT-DATA.
026900     05  BILL-IN-DATA.
027000         10  BILL-NPI-NUMBER.
027100             15  BILL-NPI            PIC X(08).
027200             15  BILL-NPI-FILLER     PIC X(02).
027300         10  BILL-PROVIDER-NO        PIC X(06).
027400         10  BILL-HIC-NO             PIC X(12).
027500         10  BILL-DISCHARGE-DATE.
027600             15  BILL-D-CC           PIC 9(02).
027700             15  BILL-D-YY           PIC 9(02).
027800             15  BILL-D-MM           PIC 9(02).
027900             15  BILL-D-DD           PIC 9(02).
028000         10  BILL-PATIENT-STATUS     PIC X(02).
028100         10  BILL-AGE                PIC 9(03).
028200         10  BILL-DRG                PIC 9(03).
028300         10  BILL-LOS                PIC 9(05).
028400         10  BILL-OUTL-OCCUR-IND     PIC X(01).
028500         10  BILL-SRC-OF-ADMISSION   PIC X(01).
028600         10  BILL-ECT-NO-OF-UNITS    PIC 9(03).
028700         10  BILL-CHARGES-CLAIMED    PIC 9(07)V9(02).
028800         10  BILL-OTHER-DIAG-DATA    PIC X(175).
028900         10  BILL-OTHER-PROC-DATA    PIC X(175).
029000         10  BILL-PRIOR-DAYS         PIC 9(03).
029100**========================================================
029200*    PASSED AND RETURNED BY IPCAL                     *
029300**======================================================**
029400 01  IPF-DATA-VARIABLES.
029500         10  IPF-RTC                 PIC 9(02).
029600         10  IPF-MSA-CBSA            PIC X(05).
029700         10  IPF-MSA-CODE REDEFINES IPF-MSA-CBSA.
029800             15  IPF-MSA             PIC X(04).
029900             15  FILLER              PIC X.
030000         10  IPF-CBSA-CODE REDEFINES IPF-MSA-CBSA.
030100             15  IPF-CBSA            PIC X(05).
030200         10  IPF-WAGE-INDX           PIC 9(02)V9(04).
030300         10  IPF-LABOR-SHARE         PIC 9(01)V9(05).
030400         10  IPF-NLABOR-SHARE        PIC 9(01)V9(05).
030500         10  IPF-COLA                PIC 9(01)V9(03).
030600         10  IPF-STD-FACTOR          PIC 9(01)V9(05).
030700         10  IPF-COMORB-FACTOR       PIC 9(01)V9(05).
030800         10  IPF-AGE-ADJ             PIC 9(01)V9(02).
030900         10  IPF-DRG-FACTOR          PIC 9(01)V9(02).
031000         10  IPF-GEO-RURAL-ADJ       PIC 9(01)V9(02).
031100         10  IPF-EMERG-ADJ           PIC 9(01)V9(02).
031200         10  IPF-TEACH-ADJ           PIC 9(01)V9(02).
031300         10  IPF-FED-PPS-BLEND-IND   PIC X.
031400         10  IPF-CAL-VERSION         PIC X(05).
031500         10  IPF-CSTCHG-RATIO        PIC 9(01)V9(03).
031600         10  FILLER                  PIC X(08).
031700
031800**======================================================**
031900*    PASSED AND RETURNED BY IPCAL                     *
032000**======================================================**
032100 01  IPF-ADDITIONAL-VARIABLES.
032200     02  IPF-MF-VARIABLES.
032300         10  IPF-100PCT-STOPLOS-AMT     PIC 9(07)V9(02).
032400         10  IPF-TOT-PAYMENT            PIC 9(07)V9(02).
032500         10  IPF-FED-PAYMENT            PIC 9(07)V9(02).
032600         10  IPF-FAC-PAYMENT            PIC 9(07)V9(02).
032700         10  IPF-ECT-PAYMENT            PIC 9(07)V9(02).
032800         10  IPF-OUTLIER-PAYMENT        PIC 9(07)V9(02).
032900         10  IPF-OUTL-COST              PIC 9(07)V9(02).
033000         10  IPF-OUTL-ADJ-COST          PIC 9(07)V9(02).
033100         10  IPF-OUTL-PER-DIEM-AMT      PIC 9(07)V9(02).
033200         10  IPF-OUTL-THRES-AMT         PIC 9(07)V9(02).
033300         10  IPF-OUTL-THRES-ADJ-AMT     PIC 9(07)V9(02).
033400         10  IPF-ADJUSTED-PER-DIEM-AMT  PIC 9(07)V9(02).
033500         10  IPF-WAGE-ADJ-AMT           PIC 9(07)V9(02).
033600         10  IPF-LABOR-BASE-AMT         PIC 9(07)V9(05).
033700         10  IPF-NLABOR-BASE-AMT        PIC 9(07)V9(05).
033800         10  IPF-OUTL-LABOR-BASE-AMT    PIC 9(07)V9(05).
033900         10  IPF-OUTL-NLABOR-BASE-AMT   PIC 9(07)V9(05).
034000         10  IPF-BUDGNUT-RATE-AMT       PIC 9(05)V9(02).
034100         10  IPF-ECT-RATE-AMT           PIC 9(05)V9(02).
034200         10  IPF-TEACH-PAYMENT          PIC 9(07)V9(02).
034300         10  FILLER                     PIC X(01).
034400      02 IPF-PC-VARIABLES.
034500         10  IPF-PC-DATA                PIC X(44).
034600
034700 01  PRICER-OPT-VERS-SW.
034800     02  PRICER-OPTION-SW               PIC X(01).
034900         88  VARIABLES                  VALUE 'S'.
035000         88  PROV-RECORD-PASSED         VALUE 'P'.
035100         88  ALL-TABLES-PASSED          VALUE 'B'.
035200     02  IPF-VERSIONS.
035300         10  IPDRV-VERSION              PIC X(05).
035400
035500**===============================================================*
035600* THE PROVIDER SPECIFIC PASSED FROM CALLING PROGRAM              *
035700**===============================================================*
035800 01  PROV-RECORD-FROM-USER.
035900     02  PROV-FROM-USER-HOLD1           PIC X(80).
036000     02  PROV-FROM-USER-HOLD2           PIC X(80).
036100     02  PROV-FROM-USER-HOLD3           PIC X(80).
036200
036300 01  MSAX-WI-TABLE.
036400     05  M-MSAX-DATA                OCCURS 4000
036500                                    INDEXED BY MU1 MU2 MU3.
036600         10  M-MSAX-MSA             PIC X(4).
036700         10  M-MSAX-SIZE            PIC X(01).
036800         10  M-MSAX-EFF-DATE        PIC X(08).
036900         10  M-MSAX-WAGE-INDX1      PIC S9(02)V9(04).
037000         10  M-MSAX-WAGE-INDX2      PIC S9(02)V9(04).
037100
037200 01  CBSA-WI-TABLE.
037300     05  TB-CBSA-DATA                OCCURS 7000
037400                                    INDEXED BY MA1 MA2 MA3.
037500         10  TB-CBSA                PIC X(5).
037600         10  TB-CBSA-SIZE           PIC X(01).
037700         10  TB-CBSA-EFF-DATE       PIC X(08).
037800         10  TB-CBSA-WAGE-INDX1     PIC S9(02)V9(04).
037900         10  TB-CBSA-WAGE-INDX2     PIC S9(02)V9(04).
038000
038100**============================================================
038200 PROCEDURE DIVISION  USING BILL-INPUT-DATA
038300                           IPF-DATA-VARIABLES
038400                           IPF-ADDITIONAL-VARIABLES
038500                           PRICER-OPT-VERS-SW
038600                           PROV-RECORD-FROM-USER
038700                           MSAX-WI-TABLE
038800                           CBSA-WI-TABLE.
038900
039000**==============================================================**
039100*    PROCESSING:
039200*        A. THIS MODULE WILL CALL THE IPCAL MODULES.
039300*        B. THIS MODULE WILL LOAD ALL TABLES THE FIRST TIME THIS
039400*           SUBROUTINE IS CALLED.
039500*        C. THE PROV-RECORD AND WAGE-INDEX-RECORD ASSOCIATED WITH*
039600*           EACH BILL WILL BE PASSED TO THE IPCAL PROGRAMS.
039700*        D. CALL COMORBIDITY GROUPER AND RETURN A
039800*           APPLIED COMORBIDITY ADJUSTER
039900**==============================================================**
040000
040100     MOVE DRV-VERSION TO IPDRV-VERSION.
040200
040300     MOVE ALL '0' TO IPF-ADDITIONAL-VARIABLES
040400                     IPF-DATA-VARIABLES.
040500
040600**==============================================================**
040700***     RTC = 98 >> A BILL LESS THEN 20050101
040800
040900     IF BILL-DISCHARGE-DATE < 20050101
041000             MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES
041100                              IPF-DATA-VARIABLES
041200             MOVE 98 TO IPF-RTC
041300             GOBACK.
041400**==============================================================**
041500
041600 0010-PROCESS-RECORDS.
041700**==============================================================**
041800***  GET THE PROVIDER RECORD
041900
042000     MOVE PROV-RECORD-FROM-USER TO PROV-NEW-HOLD.
042100     IF PROV-RECORD-FROM-USER <= SPACES
042200        MOVE 51 TO IPF-RTC
042300        MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES
042400        GOBACK
042500     END-IF.
042600
042700     PERFORM 1350-N-CHECK-MSA THRU 1350-N-EXIT.
042800
042900     IF BILL-DISCHARGE-DATE < P-NEW-EFF-DATE
043000        MOVE 55 TO IPF-RTC
043100        GOBACK.
043200
043300     IF BILL-DISCHARGE-DATE > 20060630 AND
043400        P-NEW-EFF-DATE < 20060701
043500        MOVE 55 TO IPF-RTC
043600        GOBACK.
043700
043800     IF P-NEW-EFF-DATE < 20060701
043900        PERFORM 0500-GET-MSA THRU 0500-EXIT
044000     ELSE
044100        PERFORM 0550-GET-CBSA THRU 0550-EXIT.
044200
044300***     RTC = 52  --  WAGE-INDEX NOT FOUND
044400
044500     IF IPF-RTC = 52
044600          MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES
044700          GOBACK.
044800
044900**==============================================================**
045000** MAKE SURE DATE IS CODED THE DAY BEFORE THE EFFECTIVE DATE    **
045100**==============================================================**
045200**          THIS NEXT CALL WILL PROCESS 2020 BILLS WITH
045300**              A DISCHARGE DATE ON OR AFTER 20191001
045400**==============================================================**
045500     IF BILL-DISCHARGE-DATE
045600              > 20190930
045700         CALL  IPCAL201 USING BILL-INPUT-DATA
045800                              IPF-DATA-VARIABLES
045900                              IPF-ADDITIONAL-VARIABLES
046000                              PRICER-OPT-VERS-SW
046100                              PROV-NEW-HOLD
046200                              CBSA-WAGE-INDEX-RECORD
046300         GOBACK.
046301**==============================================================**
046302**          THIS NEXT CALL WILL PROCESS 2019 BILLS WITH
046303**              A DISCHARGE DATE ON OR AFTER 20181001
046304**==============================================================**
046305     IF BILL-DISCHARGE-DATE
046306              > 20180930
046307         CALL  IPCAL191 USING BILL-INPUT-DATA
046308                              IPF-DATA-VARIABLES
046309                              IPF-ADDITIONAL-VARIABLES
046310                              PRICER-OPT-VERS-SW
046311                              PROV-NEW-HOLD
046312                              CBSA-WAGE-INDEX-RECORD
046313         GOBACK.
046314**==============================================================**
046315**          THIS NEXT CALL WILL PROCESS 2018 BILLS WITH
046316**              A DISCHARGE DATE ON OR AFTER 20171001
046317**==============================================================**
046318     IF BILL-DISCHARGE-DATE
046319              > 20170930
046320         CALL  IPCAL180 USING BILL-INPUT-DATA
046321                              IPF-DATA-VARIABLES
046322                              IPF-ADDITIONAL-VARIABLES
046323                              PRICER-OPT-VERS-SW
046324                              PROV-NEW-HOLD
046325                              CBSA-WAGE-INDEX-RECORD
046326         GOBACK.
046327**==============================================================**
046328**          THIS NEXT CALL WILL PROCESS 2017 BILLS WITH
046329**              A DISCHARGE DATE ON OR AFTER 20161001
046330**==============================================================**
046331     IF BILL-DISCHARGE-DATE
046332              > 20160930
046333         CALL  IPCAL170 USING BILL-INPUT-DATA
046334                              IPF-DATA-VARIABLES
046335                              IPF-ADDITIONAL-VARIABLES
046336                              PRICER-OPT-VERS-SW
046337                              PROV-NEW-HOLD
046338                              CBSA-WAGE-INDEX-RECORD
046339         GOBACK.
046340**==============================================================**
046341**          THIS NEXT CALL WILL PROCESS 2016 BILLS WITH
046342**              A DISCHARGE DATE ON OR AFTER 20151001
046343**==============================================================**
046344     IF BILL-DISCHARGE-DATE
046345              > 20150930
046346         CALL  IPCAL161 USING BILL-INPUT-DATA
046347                              IPF-DATA-VARIABLES
046348                              IPF-ADDITIONAL-VARIABLES
046349                              PRICER-OPT-VERS-SW
046350                              PROV-NEW-HOLD
046351                              CBSA-WAGE-INDEX-RECORD
046352         GOBACK.
046353**==============================================================**
046354**          THIS NEXT CALL WILL PROCESS 2015 BILLS WITH
046355**              A DISCHARGE DATE ON OR AFTER 20141001
046356**==============================================================**
046357     IF BILL-DISCHARGE-DATE
046360              > 20140930
046370         CALL  IPCAL150 USING BILL-INPUT-DATA
046380                              IPF-DATA-VARIABLES
046390                              IPF-ADDITIONAL-VARIABLES
046391                              PRICER-OPT-VERS-SW
046392                              PROV-NEW-HOLD
046393                              CBSA-WAGE-INDEX-RECORD
046394         GOBACK.
046400**==============================================================**
046500**          THIS NEXT CALL WILL PROCESS 2014 BILLS WITH
046600**              A DISCHARGE DATE ON OR AFTER 20131001
046700**==============================================================**
046800     IF BILL-DISCHARGE-DATE
046900              > 20130930
047000         CALL  IPCAL140 USING BILL-INPUT-DATA
047100                              IPF-DATA-VARIABLES
047200                              IPF-ADDITIONAL-VARIABLES
047300                              PRICER-OPT-VERS-SW
047400                              PROV-NEW-HOLD
047500                              CBSA-WAGE-INDEX-RECORD
047600         GOBACK.
047700**==============================================================**
047800**          THIS NEXT CALL WILL PROCESS 2013 BILLS WITH
047900**              A DISCHARGE DATE ON OR AFTER 20121001
048000**==============================================================**
048100     IF BILL-DISCHARGE-DATE
048200              > 20120930
048300         CALL  IPCAL130 USING BILL-INPUT-DATA
048400                              IPF-DATA-VARIABLES
048500                              IPF-ADDITIONAL-VARIABLES
048600                              PRICER-OPT-VERS-SW
048700                              PROV-NEW-HOLD
048800                              CBSA-WAGE-INDEX-RECORD
048900         GOBACK.
049000**==============================================================**
049100**          THIS NEXT CALL WILL PROCESS 2012 BILLS WITH
049200**              A DISCHARGE DATE ON OR AFTER 20111001
049300**==============================================================**
049400     IF BILL-DISCHARGE-DATE
049500              > 20110930
049600         CALL  IPCAL121 USING BILL-INPUT-DATA
049700                              IPF-DATA-VARIABLES
049800                              IPF-ADDITIONAL-VARIABLES
049900                              PRICER-OPT-VERS-SW
050000                              PROV-NEW-HOLD
050100                              CBSA-WAGE-INDEX-RECORD
050200         GOBACK.
050300**==============================================================**
050400**          THIS NEXT CALL WILL PROCESS 2011 BILLS WITH
050500**              A DISCHARGE DATE ON OR AFTER 20110701
050600**==============================================================**
050700     IF BILL-DISCHARGE-DATE
050800              > 20110630
050900         CALL  IPCAL120 USING BILL-INPUT-DATA
051000                              IPF-DATA-VARIABLES
051100                              IPF-ADDITIONAL-VARIABLES
051200                              PRICER-OPT-VERS-SW
051300                              PROV-NEW-HOLD
051400                              CBSA-WAGE-INDEX-RECORD
051500         GOBACK.
051600**==============================================================**
051700**          THIS NEXT CALL WILL PROCESS 2011 BILLS WITH
051800**              A DISCHARGE DATE ON OR AFTER 20110101
051900**==============================================================**
052000     IF BILL-DISCHARGE-DATE
052100              > 20101231
052200         CALL  IPCAL112 USING BILL-INPUT-DATA
052300                              IPF-DATA-VARIABLES
052400                              IPF-ADDITIONAL-VARIABLES
052500                              PRICER-OPT-VERS-SW
052600                              PROV-NEW-HOLD
052700                              CBSA-WAGE-INDEX-RECORD
052800         GOBACK.
052900**==============================================================**
053000**          THIS NEXT CALL WILL PROCESS 2010 BILLS  WITH
053100**              A DISCHARGE DATE ON OR AFTER 20101001
053200**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE
053300**              USES THE CBSA FOR WAGE INDEXES
053400**      FOR RY 2011 10/01/2010 TO 06/30/2011
053500**==============================================================**
053600     IF BILL-DISCHARGE-DATE
053700              > 20100930
053800         CALL  IPCAL111 USING BILL-INPUT-DATA
053900                              IPF-DATA-VARIABLES
054000                              IPF-ADDITIONAL-VARIABLES
054100                              PRICER-OPT-VERS-SW
054200                              PROV-NEW-HOLD
054300                              CBSA-WAGE-INDEX-RECORD
054400         GOBACK.
054500
054600**==============================================================**
054700**          THIS NEXT CALL WILL PROCESS 2010 BILLS  WITH
054800**              A DISCHARGE DATE ON OR AFTER 20101001
054900**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE
055000**              USES THE CBSA FOR WAGE INDEXES
055100**      FOR RY 2011 07/01/2010 TO 06/30/2011
055200**==============================================================**
055300     IF BILL-DISCHARGE-DATE
055400              > 20100630
055500         CALL  IPCAL110 USING BILL-INPUT-DATA
055600                              IPF-DATA-VARIABLES
055700                              IPF-ADDITIONAL-VARIABLES
055800                              PRICER-OPT-VERS-SW
055900                              PROV-NEW-HOLD
056000                              CBSA-WAGE-INDEX-RECORD
056100         GOBACK.
056200**==============================================================**
056300**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH
056400**              A DISCHARGE DATE ON OR AFTER 20091001
056500**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE
056600**              USES THE CBSA FOR WAGE INDEXES
056700**      FOR RY 2010 10/01/2010 TO 06/30/2010
056800**==============================================================**
056900     IF BILL-DISCHARGE-DATE
057000              > 20090930
057100         CALL  IPCAL102 USING BILL-INPUT-DATA
057200                              IPF-DATA-VARIABLES
057300                              IPF-ADDITIONAL-VARIABLES
057400                              PRICER-OPT-VERS-SW
057500                              PROV-NEW-HOLD
057600                              CBSA-WAGE-INDEX-RECORD
057700         GOBACK.
057800**==============================================================**
057900**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH
058000**              A DISCHARGE DATE ON OR AFTER 20090701
058100**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE
058200**              USES THE CBSA FOR WAGE INDEXES
058300**      FOR RY 2010 07/01/2009 TO 06/30/2010
058400**==============================================================**
058500     IF BILL-DISCHARGE-DATE
058600              > 20090630
058700         CALL  IPCAL100 USING BILL-INPUT-DATA
058800                              IPF-DATA-VARIABLES
058900                              IPF-ADDITIONAL-VARIABLES
059000                              PRICER-OPT-VERS-SW
059100                              PROV-NEW-HOLD
059200                              CBSA-WAGE-INDEX-RECORD
059300         GOBACK.
059400**==============================================================**
059500**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH
059600**              A DISCHARGE DATE ON OR AFTER 20080930
059700**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE
059800**              USES THE CBSA FOR WAGE INDEXES
059900**      FOR RY 2009 10/01/2008 TO 06/30/2009
060000**==============================================================**
060100     IF BILL-DISCHARGE-DATE
060200              > 20080930
060300         CALL  IPCAL094 USING BILL-INPUT-DATA
060400                              IPF-DATA-VARIABLES
060500                              IPF-ADDITIONAL-VARIABLES
060600                              PRICER-OPT-VERS-SW
060700                              PROV-NEW-HOLD
060800                              CBSA-WAGE-INDEX-RECORD
060900         GOBACK.
061000**==============================================================**
061100**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH
061200**              A DISCHARGE DATE ON OR AFTER 20080630
061300**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE
061400**              USES THE CBSA FOR WAGE INDEXES
061500**      FOR RY 2009 07/01/2008 TO 09/30/2009
061600**==============================================================**
061700     IF BILL-DISCHARGE-DATE
061800              > 20080630
061900         CALL  IPCAL09A USING BILL-INPUT-DATA
062000                              IPF-DATA-VARIABLES
062100                              IPF-ADDITIONAL-VARIABLES
062200                              PRICER-OPT-VERS-SW
062300                              PROV-NEW-HOLD
062400                              CBSA-WAGE-INDEX-RECORD
062500         GOBACK.
062600**==============================================================**
062700**          THIS NEXT CALL WILL PROCESS 2008 BILLS  WITH
062800**              A DISCHARGE DATE ON OR AFTER 20070630
062900**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE
063000**              USES THE CBSA FOR WAGE INDEXES
063100**      FOR RY 2008 10/01/2007 TO 07/01/2008
063200**==============================================================**
063300     IF BILL-DISCHARGE-DATE
063400              > 20070930
063500         CALL  IPCAL086 USING BILL-INPUT-DATA
063600                              IPF-DATA-VARIABLES
063700                              IPF-ADDITIONAL-VARIABLES
063800                              PRICER-OPT-VERS-SW
063900                              PROV-NEW-HOLD
064000                              CBSA-WAGE-INDEX-RECORD
064100         GOBACK.
064200**==============================================================**
064300**          THIS NEXT CALL WILL PROCESS 2008 BILLS  WITH
064400**              A DISCHARGE DATE ON OR AFTER 20070630
064500**              BUT BEFORE 20071001 WHEN DRG'S ARE REVISED
064600**              USES THE CBSA FOR WAGE INDEXES
064700**      FOR RY 2008 07/01/2007 TO 10/01/2007
064800**==============================================================**
064900     IF BILL-DISCHARGE-DATE
065000              > 20070630
065100         CALL  IPCAL08A USING BILL-INPUT-DATA
065200                              IPF-DATA-VARIABLES
065300                              IPF-ADDITIONAL-VARIABLES
065400                              PRICER-OPT-VERS-SW
065500                              PROV-NEW-HOLD
065600                              CBSA-WAGE-INDEX-RECORD
065700         GOBACK.
065800**==============================================================**
065900**          THIS NEXT CALL WILL PROCESS 2007 BILLS  WITH
066000**              A DISCHARGE DATE ON OR AFTER 20060630
066100**              USES THE CBSA FOR WAGE INDEXES
066200**      FOR RY 2007
066300**==============================================================**
066400     IF BILL-DISCHARGE-DATE
066500              > 20060630
066600         CALL  IPCAL076 USING BILL-INPUT-DATA
066700                              IPF-DATA-VARIABLES
066800                              IPF-ADDITIONAL-VARIABLES
066900                              PRICER-OPT-VERS-SW
067000                              PROV-NEW-HOLD
067100                              CBSA-WAGE-INDEX-RECORD
067200         GOBACK.
067300**==============================================================**
067400**          THIS NEXT CALL WILL PROCESS 2005 BILLS  WITH
067500**              A DISCHARGE DATE ON OR AFTER 20050101
067600**              USES MSA FILE FOR WAGE INDEX
067700**==============================================================**
067800     IF BILL-DISCHARGE-DATE
067900              > 20041231
068000         CALL  IPCAL057 USING BILL-INPUT-DATA
068100                              IPF-DATA-VARIABLES
068200                              IPF-ADDITIONAL-VARIABLES
068300                              PRICER-OPT-VERS-SW
068400                              PROV-NEW-HOLD
068500                              WAGE-NEW-INDEX-RECORD
068600         GOBACK.
068700**==============================================================**
068800     MOVE 98 TO IPF-RTC.
068900     GOBACK.
069000
069100 0100-GET-MSA.
069200     SET MU1 TO 1.
069300
069400     SEARCH M-MSAX-DATA VARYING MU1
069500     AT END
069600          MOVE 999999 TO P-NEW-PROVIDER-NO
069700          MOVE 52     TO IPF-RTC
069800          GO TO 0100-EXIT
069900     WHEN M-MSAX-MSA (MU1) = HOLD-PROV-MSAX
070000          SET MU2 TO MU1.
070100
070200 0100-EXIT.  EXIT.
070300
070400 0150-GET-CBSA.
070500     SET MA1 TO 1.
070600
070700     SEARCH TB-CBSA-DATA VARYING MA1
070800     AT END
070900          MOVE 999999 TO P-NEW-PROVIDER-NO
071000          MOVE 52     TO IPF-RTC
071100          GO TO 0150-EXIT
071200     WHEN TB-CBSA (MA1) = HOLD-PROV-CBSA
071300          SET MA2 TO MA1.
071400
071500 0150-EXIT.  EXIT.
071600
071700 0500-GET-MSA.
071800     IF P-NEW-CHG-CODE-INDEX = 'Y'
071900        MOVE P-NEW-WAGE-INDEX-LOC-MSA TO HOLD-PROV-MSAX
072000                                         IPF-MSA
072100     ELSE
072200        MOVE P-NEW-GEO-LOC-MSA9 TO HOLD-PROV-MSAX
072300                                   IPF-MSA.
072400
072500     PERFORM 0100-GET-MSA THRU 0100-EXIT.
072600
072700***     RTC = 52  --  MSA NOT FOUND
072800     IF IPF-RTC = 52    GOBACK.
072900
073000     IF IPF-RTC = 00
073100        PERFORM 0600-N-GET-WAGE-INDX
073200           THRU 0600-N-EXIT VARYING MU2
073300           FROM MU1 BY 1 UNTIL
073400           M-MSAX-MSA (MU2) NOT = HOLD-PROV-MSAX.
073500
073600***     RTC = 52  --  WAGE-INDEX NOT FOUND
073700     IF IPF-RTC = 52    GOBACK.
073800
073900     IF W-NEW-INDEX-RECORD = 00.0000
074000        MOVE 52 TO IPF-RTC.
074100
074200***  GET THE WAGE-SIZE
074300
074400     MOVE P-NEW-STAND-AMT-LOC-MSA TO HOLD-PROV-MSAX.
074500
074600     PERFORM 0100-GET-MSA THRU 0100-EXIT.
074700
074800     IF IPF-RTC = 00
074900         PERFORM 0700-N-GET-WAGE-SIZE
075000           THRU 0700-N-EXIT VARYING MU2
075100           FROM MU1 BY 1 UNTIL
075200           M-MSAX-MSA (MU2) NOT = HOLD-PROV-MSAX.
075300
075400***     RTC = 52  --  PR-WAGE-INDEX NOT FOUND
075500     IF IPF-RTC = 52
075600          MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES
075700          GOBACK.
075800
075900 0500-EXIT.  EXIT.
076000
076100 0550-GET-CBSA.
076200
076600     MOVE P-NEW-CBSA-GEO-LOC TO HOLD-PROV-CBSA
076700                                IPF-CBSA.
076800
076900     IF (P-NEW-CBSA-WI-SPECIAL AND
077000         P-NEW-CBSA-SPEC-WI-N NOT NUMERIC)
077100         MOVE 52 TO IPF-RTC
077200         GOBACK.
077300
077400     IF (P-NEW-CBSA-WI-SPECIAL AND
077500         P-NEW-CBSA-SPEC-WI-N = ZEROES)
077600         MOVE 52 TO IPF-RTC
077700         GOBACK.
077800
077900     IF P-NEW-CBSA-WI-SPECIAL
078000        MOVE 'SPEC*'  TO W-CBSA-X
078100        MOVE P-NEW-EFF-DATE TO W-CBSA-EFF-DATE
078200        MOVE P-NEW-CBSA-SPEC-WI TO W-CBSA-INDEX
078300        GO TO 0550-EXIT.
078400
078500     PERFORM 0150-GET-CBSA THRU 0150-EXIT.
078600
078700***     RTC = 52  --  CBSA NOT FOUND
078800     IF IPF-RTC = 52    GOBACK.
078900
079000     IF IPF-RTC = 00
079100        PERFORM 0650-N-GET-WAGE-INDX
079200           THRU 0650-N-EXIT VARYING MA2
079300           FROM MA1 BY 1 UNTIL
079400           TB-CBSA (MA2) NOT = HOLD-PROV-CBSA.
079500
079600***     RTC = 52  --  WAGE-INDEX NOT FOUND
079700     IF IPF-RTC = 52    GOBACK.
079800
079900     IF W-CBSA-INDEX       = 00.0000
080000        MOVE 52 TO IPF-RTC.
080100
080200 0550-EXIT.  EXIT.
080300
080400
080500 0600-N-GET-WAGE-INDX.
080600
080700     IF  BILL-DISCHARGE-DATE NOT < M-MSAX-EFF-DATE (MU2)
080800         MOVE M-MSAX-MSA        (MU2) TO W-NEW-MSA
080900         MOVE M-MSAX-EFF-DATE   (MU2) TO W-NEW-EFF-DATE
081000         MOVE M-MSAX-WAGE-INDX1 (MU2) TO W-NEW-INDEX-RECORD
081100         IF P-NEW-CHG-CODE-INDEX  = 'Y'
081200            MOVE M-MSAX-WAGE-INDX2 (MU2) TO W-NEW-INDEX-RECORD.
081300
081400 0600-N-EXIT.  EXIT.
081500
081600 0650-N-GET-WAGE-INDX.
081700
081800     IF  BILL-DISCHARGE-DATE NOT < TB-CBSA-EFF-DATE (MA2)
081900         MOVE TB-CBSA            (MA2) TO W-CBSA
082000         MOVE TB-CBSA-EFF-DATE   (MA2) TO W-CBSA-EFF-DATE
082100         MOVE TB-CBSA-WAGE-INDX1 (MA2) TO W-CBSA-INDEX.
082400
082500 0650-N-EXIT.  EXIT.
082600
082700
082800 0700-N-GET-WAGE-SIZE.
082900
083000     IF  BILL-DISCHARGE-DATE NOT < M-MSAX-EFF-DATE (MU2)
083100         IF  P-NEW-STD-RURAL-CHECK
083200             MOVE 'R' TO W-NEW-SIZE
083300         ELSE
083400         IF  M-MSAX-SIZE (MU2) = 'L'
083500             MOVE 'L' TO W-NEW-SIZE
083600         ELSE
083700             MOVE 'O' TO W-NEW-SIZE.
083800
083900 0700-N-EXIT.  EXIT.
084000
084100 1350-N-CHECK-MSA.
084200     IF P-NEW-EFF-DATE < 20050701
084300        IF (P-NEW-WAGE-INDEX-LOC-MSA = '    ' OR
084400            P-NEW-WAGE-INDEX-LOC-MSA = '0000')
084500            MOVE P-NEW-GEO-LOC-MSA9 TO P-NEW-WAGE-INDEX-LOC-MSA.
084600     IF P-NEW-EFF-DATE < 20050701
084700        IF (P-NEW-STAND-AMT-LOC-MSA = '    ' OR
084800            P-NEW-STAND-AMT-LOC-MSA = '0000')
084900            MOVE P-NEW-GEO-LOC-MSA9 TO P-NEW-STAND-AMT-LOC-MSA.
085000
085100     IF P-NEW-EFF-DATE < 20050701
085200        IF (P-NEW-CBSA-RECLASS-LOC = '     ' OR
085300            P-NEW-CBSA-RECLASS-LOC = '00000')
085400            MOVE P-NEW-CBSA-GEO-LOC9 TO P-NEW-CBSA-RECLASS-LOC.
085500     IF P-NEW-EFF-DATE < 20050701
085600        IF (P-NEW-CBSA-STAND-AMT-LOC = '     ' OR
085700            P-NEW-CBSA-STAND-AMT-LOC = '00000')
085800            MOVE P-NEW-CBSA-GEO-LOC9 TO P-NEW-CBSA-STAND-AMT-LOC.
085900
086000 1350-N-EXIT.  EXIT.
086100
086200**==============================================================**
086300**           L A S T   S O U R C E   S T A T E M E N T          **
086400**==============================================================**
