000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           HOSDR162.
000300*AUTHOR.  DDS TEAM
000400*         (CENTERS FOR MEDICARE AND MEDICAID SERVICES)
000500*REMARKS. A). HOSPICE DRIVER WILL CALL HOSPR___ MODULE.
000600*             CALLS THE HOSPR___ MODULE.
000700*             LOADS THE PROV FILE MSA FILEAND CBSA FILE.
000800*             FINDS THE PROV RECORD AND WAGE-INDEX RECORD FOR
000900*             GIVEN HOSPICE DATA TO BE PASSED TO HOSPR___ MODULE.
001000******************************************************************
001100*REMARKS.
001200*     HOSPR162   UPDATES TO REVISIONS FOR JAN 1, 2016
001200*                CORRECTED A CALCULATION FOR EOL6
001300*                SERVICE INTENSITY ADD-ON PAYMENTS
001400*                MODIFIED  '> 0 ' NOTATIONS TO USE '> ZEROES '
001600*     HOSDR162   UPDATES TO REVISIONS FOR JAN 1, 2016
001700*                CALL TO HOSPR162
001900*     HOSOP162   UPDATES TO REVISIONS FOR JAN 1, 2016
002000*                CICS VERSION TO OPEN FILES CALL HOSDR162
002100*
001200*     HOSPR161   REVISIONS FOR JAN 1, 2016
001300*                2016 RATE REVISIONS
001500*         ==>>>> 2016 LOGIC CHANGES
001600*     HOSDR161   NEW PROCESSES JAN 1, 2016
001700*                CALL TO HOSPR161
001800*         ==>>>> REVISED BILL RECORD LENGTH FROM 215 TO 315
001900*     HOSOP161   NEW PROCESSES JAN 1, 2016
002000*                CICS VERSION TO OPEN FILES CALL HOSDR161
002100*
002200*     HOSPR160   REVISIONS FOR OCT 1, 2015
002300*                2016 RATE REVISIONS
002400*     HOSDR160   NEW PROCESSES OCT 1, 2015
002500*                CALL TO HOSPR160
002600*     HOSOP160   NEW PROCESSES OCT 1, 2015
002700*                CICS VERSION TO OPEN FILES CALL HOSDR160
002800*
002900*     HOSPR150   REVISIONS FOR OCT 1, 2014
003000*                2015 RATE REVISIONS
003100*     HOSDR150   NEW PROCESSES OCT 1, 2014
003200*                CALL TO HOSPR150
003300*     HOSOP150   NEW PROCESSES OCT 1, 2014
003400*                CICS VERSION TO OPEN FILES CALL HOSDR150
003500*
003600*     HOSPR140   REVISIONS FOR OCT 1, 2013
003700*                2014 RATE REVISIONS
003800*         ==>>>> REVISED BILL & RATE RECORD LENGTH FROM 135 TO 215
003900*         ==>>>> NEW LOGIC FOR QIP INDICATOR
004000*     HOSDR140   NEW PROCESSES OCT 1, 2013
004100*                CALL TO HOSPR140
004200*     HOSOP140   NEW PROCESSES OCT 1, 2013
004300*                CICS VERSION TO OPEN FILES CALL HOSDR140
004400*
004500*     HOSPR130   REVISIONS FOR OCT 1, 2012
004600*                2013 RATE REVISIONS
004700*     HOSDR130   NEW PROCESSES OCT 1, 2012
004800*                CALL TO HOSPR130
004900*     HOSOP130   NEW PROCESSES OCT 1, 2012
005000*                CICS VERSION TO OPEN FILES CALL HOSDR130
005100*
005200*     HOSPR120   REVISIONS FOR OCT 1, 2011
005300*                2012 RATE REVISIONS
005400*     HOSDR120   NEW PROCESSES OCT 1, 2011
005500*                CALL TO HOSPR120
005600*     HOSOP120   NEW PROCESSES OCT 1, 2011
005700*                CICS VERSION TO OPEN FILES CALL HOSDR120
005800*
005900*     HOSPR110   REVISIONS FOR OCT 1, 2010
006000*                2011 RATE REVISIONS
006100*     HOSDR110   NEW PROCESSES OCT 1, 2010
006200*                CALL TO HOSPR110
006300*     HOSOP110   NEW PROCESSES OCT 1, 2010
006400*                CICS VERSION TO OPEN FILES CALL HOSDR110
006500*
006600*     HOSPR100   REVISIONS FOR OCT 1, 2009
006700*                2010 RATE REVISIONS
006800*     HOSDR100   NEW PROCESSES OCT 1, 2009
006900*                CALL TO HOSPR100
007000*     HOSOP100   NEW PROCESSES OCT 1, 2009
007100*                CICS VERSION TO OPEN FILES CALL HOSDR100
007200*
007300*     HOSPR091   REVISIONS FOR JAN 1, 2008
007400*                2009 RATE REVISIONS
007500*     HOSDR091   NEW PROCESSES JAN 1, 2008
007600*                CALL TO HOSPR091
007700*                STIMULUS PKG RECOMPILE
007800*     HOSOP091   NEW PROCESSES JAN 1, 2008
007900*                CICS VERSION TO OPEN FILES CALL HOSDR091
008000*
008100*     HOSPR090   REVISIONS FOR OCT 1, 2008
008200*                2008 RATE REVISIONS
008300*     HOSDR090   NEW PROCESSES OCT 1, 2008
008400*                CALL TO HOSPR090
008500*     HOSOP090   NEW PROCESSES OCT 1, 2008
008600*                CICS VERSION TO OPEN FILES CALL HOSDR090
008700*
008800*     HOSPR081   REVISIONS FOR OCT 1, 2007
008900*                2008 RATE REVISIONS
009000*     HOSDR081   NEW PROCESSES OCT 1, 2007
009100*                CALL TO HOSPR081
009200*     HOSOP081   NEW PROCESSES OCT 1, 2007
009300*                CICS VERSION TO OPEN FILES CALL HOSDR081
009400*
009500*     HOSPR071   REVISIONS FOR JAN 1, 2007
009600*                2007.1-PROCESS-DATA 1 UNIT = 15 MIN CODE 652
009700*                2007 CALCULATE HOME RATE BY REVENUE CODE FACTORS
009800*     HOSDR071   NEW PROCESSES JAN 1, 2007
009900*                CALL TO HOSPR071
010000*     HOSOP071   NEW PROCESSES JAN 1, 2007
010100*                CICS VERSION TO OPEN FILES CALL HOSDR071
010200*
010300*     HOSPR070   REVISIONS FOR OCT 1, 2006
010400*                2007-PROCESS-DATA
010500*                2007 CALCULATE HOME RATE BY REVENUE CODE FACTORS
010600*     HOSDR070   NEW PROCESSES OCT 1, 2006
010700*                CBSA FILE PROCESSING
010800*     HOSOP070   NEW PROCESSES OCT 1, 2006
010900*                CICS VERSION TO OPEN FILES
011000*
011100***************************************************************
011200 DATE-COMPILED.
011300 ENVIRONMENT DIVISION.
011400 CONFIGURATION SECTION.
011500 SOURCE-COMPUTER.            IBM-370.
011600 OBJECT-COMPUTER.            IBM-370.
011700 INPUT-OUTPUT  SECTION.
011800 FILE-CONTROL.
011900
012000 DATA DIVISION.
012100 FILE SECTION.
012200
012300 WORKING-STORAGE SECTION.
012400 01  W-STORAGE-REF                  PIC X(46)  VALUE
012500     'HOSDR162      - W O R K I N G   S T O R A G E'.
012600 01  HOS-VERSION                    PIC X(09)  VALUE 'HOSDR16.2'.
012700 01  HOSOP162                       PIC X(08)  VALUE 'HOSOP162'.
012800 01  HOSPR162                       PIC X(08)  VALUE 'HOSPR162'.
012900 01  EOF-MSA-SW                     PIC 9(01)  VALUE 0.
013000 01  EOF-CBSA-SW                    PIC 9(01)  VALUE 0.
013100 01  EOF-BILL-SW                    PIC 9(01)  VALUE 0.
013200 01  EOF-PROV-SW                    PIC 9(01)  VALUE 0.
013300 01  BILL-CTR                       PIC 9(09)  VALUE 0.
013400 01  RATE-CTR                       PIC 9(09)  VALUE 0.
013500 01  PROV-CTR                       PIC 9(09)  VALUE 0.
013600
013700 01  SEARCH-MSA-LUGAR.
013800     05  SEARCH-MSA.
013900         10  SEARCH-MSA-POS12  PIC 9(02).
014000         10  SEARCH-MSA-POS34  PIC 9(02).
014100     05  SEARCH-LUGAR          PIC X.
014200
014300 01  SEARCH-CBSA.
014400     05  SEARCH-CBSA-POS123    PIC 9(03).
014500     05  SEARCH-CBSA-POS45     PIC 9(02).
014600
014700 01  UT1-STAT.
014800     05  UT1-STAT1             PIC X.
014900     05  UT1-STAT2             PIC X.
015000 01  UT2-STAT.
015100     05  UT2-STAT1             PIC X.
015200     05  UT2-STAT2             PIC X.
015300 01  UT3-STAT.
015400     05  UT3-STAT1             PIC X.
015500     05  UT3-STAT2             PIC X.
015600 01  UT4-STAT.
015700     05  UT4-STAT1             PIC X.
015800     05  UT4-STAT2             PIC X.
015900 01  UT5-STAT.
016000     05  UT5-STAT1             PIC X.
016100     05  UT5-STAT2             PIC X.
016200
016300***************************************************************
016400**************************************************************
016500*      MILLINNIUM COMPATIBLE                                 *
016600**************************************************************
016700 01  PROV-NEW-HOLD.
016800     02  PROV-NEWREC-HOLD1.
016900         05  P-NEW-NPI10.
017000             10  P-NEW-NPI8             PIC X(08).
017100             10  P-NEW-NPI-FILLER       PIC X(02).
017200         05  P-NEW-PROVIDER-NO.
017300             10  P-NEW-STATE            PIC 9(02).
017400             10  FILLER                 PIC X(04).
017500         05  P-NEW-DATE-DATA.
017600             10  P-NEW-EFF-DATE.
017700                 15  P-NEW-EFF-DT-CC    PIC 9(02).
017800                 15  P-NEW-EFF-DT-YY    PIC 9(02).
017900                 15  P-NEW-EFF-DT-MM    PIC 9(02).
018000                 15  P-NEW-EFF-DT-DD    PIC 9(02).
018100             10  P-NEW-FY-BEGIN-DATE.
018200                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
018300                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
018400                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
018500                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
018600             10  P-NEW-REPORT-DATE.
018700                 15  P-NEW-REPORT-DT-CC PIC 9(02).
018800                 15  P-NEW-REPORT-DT-YY PIC 9(02).
018900                 15  P-NEW-REPORT-DT-MM PIC 9(02).
019000                 15  P-NEW-REPORT-DT-DD PIC 9(02).
019100             10  P-NEW-TERMINATION-DATE.
019200                 15  P-NEW-TERM-DT-CC   PIC 9(02).
019300                 15  P-NEW-TERM-DT-YY   PIC 9(02).
019400                 15  P-NEW-TERM-DT-MM   PIC 9(02).
019500                 15  P-NEW-TERM-DT-DD   PIC 9(02).
019600         05  P-NEW-WAIVER-CODE          PIC X(01).
019700             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
019800         05  P-NEW-INTER-NO             PIC 9(05).
019900         05  P-NEW-PROVIDER-TYPE        PIC X(02).
020000             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
020100             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
020200                                                  '15' '17'
020300                                                  '22'.
020400             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
020500             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
020600             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
020700             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
020800             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
020900             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
021000             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
021100             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
021200             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
021300             88  P-N-EACH                   VALUE '21' '22'.
021400             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
021500             88  P-N-NHCMQ-II-SNF           VALUE '32'.
021600             88  P-N-NHCMQ-III-SNF          VALUE '33'.
021700         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
021800             88  P-N-NEW-ENGLAND            VALUE  1.
021900             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
022000             88  P-N-SOUTH-ATLANTIC         VALUE  3.
022100             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
022200             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
022300             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
022400             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
022500             88  P-N-MOUNTAIN               VALUE  8.
022600             88  P-N-PACIFIC                VALUE  9.
022700         05  P-NEW-CURRENT-DIV   REDEFINES
022800                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
022900             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
023000         05  P-NEW-MSA-DATA.
023100             10  P-NEW-CHG-CODE-INDEX       PIC X.
023200             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
023300             10  P-NEW-GEO-LOC-MSAX-RUR REDEFINES
023400                                     P-NEW-GEO-LOC-MSAX.
023500                 15  P-NEW-RURAL1    PIC X(02).
023600                     88  P-NEW-GEO-RURAL1   VALUE '  '.
023700                 15  P-NEW-GEO-RURAL2    PIC X(02).
023800             10  P-NEW-GEO-LOC-MSA9   REDEFINES
023900                             P-NEW-GEO-LOC-MSAX-RUR PIC 9(04).
024000             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
024100             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
024200             10  P-NEW-STAND-AMT-LOC-MSA9
024300       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
024400                 15  P-NEW-RURAL-1ST.
024500                     20  P-NEW-STAND-RURAL  PIC XX.
024600                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
024700                 15  P-NEW-RURAL-2ND        PIC XX.
024800         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
024900                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
025000                 88  P-NEW-SCH-YR82       VALUE   '82'.
025100                 88  P-NEW-SCH-YR87       VALUE   '87'.
025200         05  P-NEW-LUGAR                    PIC X.
025300         05  P-NEW-TEMP-RELIEF-IND          PIC X.
025400         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
025500         05  FILLER                         PIC X(05).
025600     02  PROV-NEWREC-HOLD2.
025700         05  P-NEW-VARIABLES.
025800             10  P-NEW-FAC-SPEC-RATE       PIC 9(05)V9(02).
025900             10  P-NEW-COLA                PIC 9(01)V9(03).
026000             10  P-NEW-INTERN-RATIO        PIC 9(01)V9(04).
026100             10  P-NEW-BED-SIZE            PIC 9(05).
026200             10  P-NEW-OPER-CSTCHG-RATIO   PIC 9(01)V9(03).
026300             10  P-NEW-CMI                 PIC 9(01)V9(04).
026400             10  P-NEW-SSI-RATIO           PIC V9(04).
026500             10  P-NEW-MEDICAID-RATIO      PIC V9(04).
026600             10  P-NEW-PPS-BLEND-YR-IND    PIC X(01).
026700             10  P-NEW-PRUP-UPDATE-FACTOR  PIC 9(01)V9(05).
026800             10  P-NEW-DSH-PERCENT         PIC V9(04).
026900             10  P-NEW-FYE-DATE            PIC 9(08).
027000         05  P-NEW-CBSA-DATA.
027100             10  W-P-NEW-CBSA-SPEC-PAY-IND     PIC X.
027200                 88  P-NEW-CBSA-WI-GEO        VALUE 'N'.
027300                 88  P-NEW-CBSA-WI-RECLASS    VALUE 'Y'.
027400                 88  P-NEW-CBSA-WI-SPECIAL    VALUE '1' '2'.
027500***                  1 = ANYTHING OR HOLD HARMLESS WITH SPEC WI
027600***                  2 = RECLASS WITH SPEC WI
027700             10  W-P-NEW-CBSA-HOSP-QUAL-IND    PIC X.
027800
027900             10  W-P-NEW-CBSA-GEO-LOC       PIC X(05) JUST RIGHT.
028000             10  W-P-NEW-CBSA-GEO-RURAL REDEFINES
028100                 W-P-NEW-CBSA-GEO-LOC.
028200                 15  W-P-NEW-CBSA-GEO-RURAL1ST PIC XXX.
028300                     88  W-P-NEW-CBSA-GEO-RURAL1  VALUE '   '.
028400                 15  W-P-NEW-CBSA-GEO-RURAL2ND PIC XX.
028500
028600             10  W-P-NEW-CBSA-RECLASS-LOC   PIC X(05) JUST RIGHT.
028700             10  W-P-NEW-CBSA-STAND-AMT-LOC PIC X(05) JUST RIGHT.
028800             10  W-P-NEW-CBSA-SPEC-WAGE-INDEX  PIC 9(02)V9(04).
028900     02  PROV-NEWREC-HOLD3.
029000         05  P-NEW-PASS-AMT-DATA.
029100             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
029200             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
029300             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
029400             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
029500         05  P-NEW-CAPI-DATA.
029600             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
029700             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
029800             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
029900             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
030000             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
030100             15  P-NEW-CAPI-NEW-HOSP       PIC X.
030200             15  P-NEW-CAPI-IME            PIC 9V9999.
030300             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
030400             15  P-VAL-BASED-PURCH-SCORE   PIC 9V999.
030500         05  FILLER                        PIC X(18).
030600
030700
030800*-------------------------------------------------------------*
030900* VARIABLES TO HOLD THE BILL'S FY BEGIN AND END DATES         *
031000*-------------------------------------------------------------*
031100 01  W-FY-BEGIN-DATE.
031200     05  W-FY-BEGIN-CC              PIC 9(02).
031300     05  W-FY-BEGIN-YY              PIC 9(02).
031400     05  W-FY-BEGIN-MM              PIC 9(02) VALUE 10.
031500     05  W-FY-BEGIN-DD              PIC 9(02) VALUE 01.
031600
031700 01  W-FY-END-DATE.
031800     05  W-FY-END-CC                PIC 9(02).
031900     05  W-FY-END-YY                PIC 9(02).
032000     05  W-FY-END-MM                PIC 9(02) VALUE 09.
032100     05  W-FY-END-DD                PIC 9(02) VALUE 30.
032200
032300
032400
032500******************************************************************
032600 LINKAGE SECTION.
032700***************************************************************
032800*                 * * * * * * * * *                           *
032900***************************************************************
033000***************************************************************
033100*    THIS DATA IS CALCULATED BY THIS HOSPRICER PROGRAM        *
033200*    AND PASSED BACK                                          *
033300*            RETURN CODE VALUES (BILL-RTC)                    *
033400*                                                             *
033500*            BILL-RTC                                         *
033600*              00 = HOME RATE RETURNED                        *
033700*                                                             *
033800*              73 = LOW RHC RATE APPLIES TO ALL RHC           *
033900*                                                             *
034000*              74 = LOW RHC RATE WITH EOL SIA                 *
034100*                                                             *
034200*              75 = HIGH RHC RATE APPLIES TO SOME OR ALL RHC  *
034300*                                                             *
034400*              77 = HIGH RHC WITH EOL SIA                     *
034500*                                                             *
034600*            BILL-RTC  NO RATE RETURNED                       *
034700*              10 = BAD UNITS                                 *
034800*                                                             *
034900*              20 = BAD UNITS2 < 8                            *
035000*                                                             *
035100*              30 = BAD MSA CODE OR CBSA CODE                 *
035200*                                                             *
035300*              40 = BAD PROV WAGE INDEX CBSA OR MSAFILE       *
035400*                                                             *
035500*              50 = BAD BENE WAGE INDEX CBSA OR MSAFILE       *
035600*                                                             *
035700*              51 = BAD PROV NUMBER                           *
035800*                                                             *
035900***************************************************************
036000
036100*-------------------------------------------------------------*
036200*  BILL RECORD - 315 RECORD LENGTH LAYOUT                     *
036300*  CONTAINS INPUT AND OUTPUT VALUES                           *
036400*-------------------------------------------------------------*
036500 01  BILL-315-DATA.
036600     10  BILL-NPI                PIC X(10).
036700     10  BILL-PROV-NO            PIC X(06).
036800*
036900     10  BILL-FROM-DATE.
037000         15  BILL-FROM-CC        PIC 99.
037100         15  BILL-FROM-YY        PIC 99.
037200         15  BILL-FROM-MM        PIC 99.
037300         15  BILL-FROM-DD        PIC 99.
037400*
037500     10  BILL-ADMISSION-DATE.
037600         15  BILL-ADM-CC         PIC 99.
037700         15  BILL-ADM-YY         PIC 99.
037800         15  BILL-ADM-MM         PIC 99.
037900         15  BILL-ADM-DD         PIC 99.
038000*
038100     10  FILLER                  PIC X(10).
038200*
038300     10  BILL-PROV-MSA-LUGAR.
038400         15  BILL-PROV-MSA       PIC X(04).
038500         15  BILL-PROV-LUGAR     PIC X.
038600     10  BILL-PROV-CBSA          REDEFINES
038700             BILL-PROV-MSA-LUGAR         PIC X(05).
038800*
038900     10  BILL-BENE-MSA-LUGAR.
039000         15 BILL-BENE-MSA        PIC X(04).
039100         15 BILL-BENE-LUGAR      PIC X.
039200     10  BILL-BENE-CBSA          REDEFINES
039300              BILL-BENE-MSA-LUGAR         PIC X(05).
039400*
039500     10  BILL-PROV-WAGE-INDEX    PIC 9(02)V9(04).
039600     10  BILL-BENE-WAGE-INDEX    PIC 9(02)V9(04).
039700*
039800     10  BILL-SIA-ADD-ON-UNITS.
039900         15  BILL-NA-ADD-ON-DAY1-UNITS   PIC X(02).
040000         15  BILL-NA-ADD-ON-DAY2-UNITS   PIC X(02).
040100         15  BILL-EOL-ADD-ON-DAY1-UNITS  PIC X(02).
040200         15  BILL-EOL-ADD-ON-DAY2-UNITS  PIC X(02).
040300         15  BILL-EOL-ADD-ON-DAY3-UNITS  PIC X(02).
040400         15  BILL-EOL-ADD-ON-DAY4-UNITS  PIC X(02).
040500         15  BILL-EOL-ADD-ON-DAY5-UNITS  PIC X(02).
040600         15  BILL-EOL-ADD-ON-DAY6-UNITS  PIC X(02).
040700         15  BILL-EOL-ADD-ON-DAY7-UNITS  PIC X(02).
040800*
040900     10  FILLER                       PIC X(10).
041000     10  BILL-QIP-IND                 PIC X.
041100*
041200     10  BILL-GROUP1.
041300         15  BILL-REV1                PIC XXXX.
041400         15  BILL-HCPC1               PIC X(05).
041500         15  BILL-LINE-ITEM-DOS1.
041600             20  BILL-LIDOS1-CC       PIC 99.
041700             20  BILL-LIDOS1-YY       PIC 99.
041800             20  BILL-LIDOS1-MM       PIC 99.
041900             20  BILL-LIDOS1-DD       PIC 99.
042000         15  BILL-UNITS1              PIC 9(07).
042100         15  BILL-PAY-AMT1            PIC 9(06)V99.
042200*
042300     10  BILL-GROUP2.
042400         15  BILL-REV2                PIC XXXX.
042500         15  BILL-HCPC2               PIC X(05).
042600         15  BILL-LINE-ITEM-DOS2.
042700             20  BILL-LIDOS2-CC       PIC 99.
042800             20  BILL-LIDOS2-YY       PIC 99.
042900             20  BILL-LIDOS2-MM       PIC 99.
043000             20  BILL-LIDOS2-DD       PIC 99.
043100         15  BILL-UNITS2              PIC 9(07).
043200         15  BILL-PAY-AMT2            PIC 9(06)V99.
043300*
043400     10  BILL-GROUP3.
043500         15  BILL-REV3                PIC XXXX.
043600         15  BILL-HCPC3               PIC X(05).
043700         15  BILL-LINE-ITEM-DOS3.
043800             20  BILL-LIDOS3-CC       PIC 99.
043900             20  BILL-LIDOS3-YY       PIC 99.
044000             20  BILL-LIDOS3-MM       PIC 99.
044100             20  BILL-LIDOS3-DD       PIC 99.
044200         15  BILL-UNITS3              PIC 9(07).
044300         15  BILL-PAY-AMT3            PIC 9(06)V99.
044400*
044500     10  BILL-GROUP4.
044600         15  BILL-REV4                PIC XXXX.
044700         15  BILL-HCPC4               PIC X(05).
044800         15  BILL-LINE-ITEM-DOS4.
044900             20  BILL-LIDOS4-CC       PIC 99.
045000             20  BILL-LIDOS4-YY       PIC 99.
045100             20  BILL-LIDOS4-MM       PIC 99.
045200             20  BILL-LIDOS4-DD       PIC 99.
045300         15  BILL-UNITS4              PIC 9(07).
045400         15  BILL-PAY-AMT4            PIC 9(06)V99.
045500*
045600     10  BILL-SIA-ADD-ON-PYMTS.
045700         15  BILL-NA-ADD-ON-DAY1-PAY   PIC 9(06)V99.
045800         15  BILL-NA-ADD-ON-DAY2-PAY   PIC 9(06)V99.
045900         15  BILL-EOL-ADD-ON-DAY1-PAY  PIC 9(06)V99.
046000         15  BILL-EOL-ADD-ON-DAY2-PAY  PIC 9(06)V99.
046100         15  BILL-EOL-ADD-ON-DAY3-PAY  PIC 9(06)V99.
046200         15  BILL-EOL-ADD-ON-DAY4-PAY  PIC 9(06)V99.
046300         15  BILL-EOL-ADD-ON-DAY5-PAY  PIC 9(06)V99.
046400         15  BILL-EOL-ADD-ON-DAY6-PAY  PIC 9(06)V99.
046500         15  BILL-EOL-ADD-ON-DAY7-PAY  PIC 9(06)V99.
046600*
046700     10  BILL-RETURNED-DATA.
046800         15  BILL-PAY-AMT-TOTAL       PIC 9(06)V99.
046900         15  BILL-RTC                 PIC XX.
047000     10  FILLER                       PIC X(12).
047100
047200
047300***************************************************************
047400
047500***************************************************************
047600*----------------------------------------------------------****
047700******************************************************************
047800*
047900*    FILE MUST BE PROV-NO EFF-DATE SEQUENCE
048000*
048100******************************************************************
048200
048300 01  PROV-TABLE.
048400     02  PROV-ENTRIES               OCCURS 2400
048500                                    ASCENDING KEY IS PROV-NO
048600                                    INDEXED BY PX1 PX2 PX3.
048700         10  PROV-DATA1.
048800             15  PROV-NPI10.
048900                 20  PROV-NPI8     PIC X(08).
049000                 20  PROV-NPI-FIL  PIC X(02).
049100             15  PROV-NO           PIC X(06).
049200             15  PROV-EFF-DATE     PIC X(08).
049300             15  FILLER            PIC X(56).
049400
049500 01  PROV-DATA-2.
049600     02  PROV-ENTRIES2              OCCURS 2400
049700                                    INDEXED BY PD2.
049800         10  PROV-DATA2            PIC X(80).
049900
050000 01  PROV-DATA-3.
050100     02  PROV-ENTRIES3              OCCURS 2400
050200                                    INDEXED BY PD3.
050300         10  PROV-DATA3            PIC X(80).
050400
050500***************************************************************
050600***************************************************************
050700 01  MSA-WI-TABLE.
050800     05  M-MSA-DATA              OCCURS 4000
050900                                 INDEXED BY MU1 MU2 MU3.
051000         10  MSA-MSA-LUGAR.
051100             15  MSA-MSA       PIC 9(04).
051200             15  MSA-LUGAR     PIC X.
051300         10  MSA-EFFDTE        PIC X(08).
051400         10  MSA-WAGE-IND      PIC S9(02)V9(04).
051500
051600***************************************************************
051700***************************************************************
051800 01  CBSA-WI-TABLE.
051900     05  M-CBSA-DATA             OCCURS 6000
052000                                 INDEXED BY CU1 CU2 CU3.
052100         10  M-CBSA              PIC 9(05).
052200         10  M-CBSA-EFFDTE       PIC X(08).
052300         10  M-CBSA-WAGE-IND     PIC S9(02)V9(04).
052400
052500***************************************************************
052600**-----------------------------------------------------------**
052700
052800**-----------------------------------------------------------**
052900**-----------------------------------------------------------**
053000**-----------------------------------------------------------**
053100
053200 PROCEDURE DIVISION USING  BILL-315-DATA
053300                           PROV-TABLE
053400                           PROV-DATA-2
053500                           PROV-DATA-3
053600                           MSA-WI-TABLE
053700                           CBSA-WI-TABLE.
053800**-----------------------------------------------------------**
053900**-----------------------------------------------------------**
054000
054100     PERFORM 0200-PROCESS-RECORDS
054200        THRU 0200-EXIT.
054300
054400     GOBACK.
054500
054600
054700 0200-PROCESS-RECORDS.
054800**
054900*----------------------------------------------------------*
055000* INITIALIZE VARIABLES                                     *
055100*----------------------------------------------------------*
055200     MOVE ALL '0' TO BILL-RETURNED-DATA
055300                     BILL-PAY-AMT1
055400                     BILL-PAY-AMT2
055500                     BILL-PAY-AMT3
055600                     BILL-PAY-AMT4
055700                     BILL-SIA-ADD-ON-PYMTS.
055800
055900     INITIALIZE W-FY-BEGIN-CC
056000                W-FY-BEGIN-YY
056100                W-FY-END-CC
056200                W-FY-END-YY.
056300
056400*----------------------------------------------------------*
056500* SET FY BEGIN AND END DATES USING BILL DISCHARGE DATE     *
056600*----------------------------------------------------------*
056700     MOVE BILL-FROM-CC TO W-FY-BEGIN-CC.
056800     MOVE BILL-FROM-CC TO W-FY-END-CC.
056900
057000*----------------------------------*
057100* FOR CLAIMS DISCHARGED JAN - SEPT *
057200*----------------------------------*
057300     IF BILL-FROM-MM >= 01 AND
057400        BILL-FROM-MM <= 09
057500        COMPUTE W-FY-BEGIN-YY = BILL-FROM-YY - 1
057600        MOVE BILL-FROM-YY TO W-FY-END-YY
057700
057800*----------------------------------*
057900* FOR CLAIMS DISCHARGED OCT - DEC  *
058000*----------------------------------*
058100     ELSE
058200        MOVE BILL-FROM-YY TO W-FY-BEGIN-YY
058300        COMPUTE W-FY-END-YY = BILL-FROM-YY + 1
058400     END-IF.
058500
058600     IF EOF-BILL-SW = 0
058700           ADD 1               TO BILL-CTR
058800           PERFORM 0300-PROCESS-DATA
058900              THRU 0300-EXIT.
059000
059100 0200-EXIT.  EXIT.
059200
059300 0300-PROCESS-DATA.
059400****    GET PROV RECORD FOR HOSPICE MSA OR CBSA
059500****    GET PROV RECORD FOR HOSPICE MSA OR CBSA
059600
059700     PERFORM 0700-GET-PROVIDER
059800        THRU 0700-EXIT.
059900
060000     IF BILL-RTC NOT = 00
060100        GO TO 0300-EXIT.
060200
060300     IF P-NEW-EFF-DATE < 20051001 AND
060400        BILL-FROM-DATE > 20050930
060500        MOVE 51                TO BILL-RTC
060600
060700
060800        GO TO 0300-EXIT.
060900
061000
061100     IF BILL-FROM-DATE > 20050930
061200        PERFORM 0375-GET-CBSA
061300           THRU 0375-EXIT
061400     ELSE
061500        PERFORM 0350-GET-MSA
061600           THRU 0350-EXIT.
061700
061800 0300-EXIT.   EXIT.
061900
062000 0350-GET-MSA.
062100
062200****    GET PROV-HOSP WAGE INDEX
062300****    GET PROV-HOSP WAGE INDEX
062400
062500     IF P-NEW-GEO-RURAL1
062600        MOVE '99'              TO SEARCH-MSA-POS12
062700        MOVE P-NEW-GEO-RURAL2  TO SEARCH-MSA-POS34
062800     ELSE
062900        MOVE P-NEW-GEO-LOC-MSA9
063000                               TO SEARCH-MSA.
063100
063200     IF BILL-FROM-DATE < 19991001
063300        MOVE P-NEW-LUGAR       TO SEARCH-LUGAR
063400     ELSE
063500        MOVE SPACE             TO SEARCH-LUGAR.
063600
063700     MOVE P-NEW-GEO-LOC-MSAX   TO BILL-PROV-MSA.
063800
063900     IF BILL-FROM-DATE < 19991001
064000        MOVE P-NEW-LUGAR       TO BILL-PROV-LUGAR
064100     ELSE
064200        MOVE SPACE             TO BILL-PROV-LUGAR.
064300
064400        IF BILL-FROM-DATE < 19991001
064500           MOVE P-NEW-LUGAR       TO SEARCH-LUGAR
064600        ELSE
064700           MOVE SPACE             TO SEARCH-LUGAR.
064800
064900        MOVE P-NEW-GEO-LOC-MSAX   TO BILL-PROV-MSA.
065000
065100        IF BILL-FROM-DATE < 19991001
065200           MOVE P-NEW-LUGAR       TO BILL-PROV-LUGAR
065300        ELSE
065400           MOVE SPACE             TO BILL-PROV-LUGAR.
065500
065600     PERFORM 0400-SEARCH-4-MSA
065700        THRU 0400-SEARCH-EXIT.
065800
065900     IF BILL-RTC = 00
066000        PERFORM 0500-GET-HOSP-WAGE-INDEX
066100                THRU 0500-EXIT  VARYING MU2
066200                FROM MU1 BY 1 UNTIL
066300                MSA-MSA-LUGAR (MU2) NOT = SEARCH-MSA-LUGAR
066400     ELSE
066500        MOVE 0                 TO BILL-PROV-WAGE-INDEX
066600                                  BILL-BENE-WAGE-INDEX
066700        GO TO 0350-EXIT.
066800
066900     IF (BILL-PROV-WAGE-INDEX  NOT NUMERIC) OR
067000        (BILL-PROV-WAGE-INDEX  = ZERO)
067100        MOVE '40'              TO BILL-RTC
067200        GO TO 0350-EXIT.
067300
067400
067500****    GET BENE WAGE INDEX
067600****    GET BENE WAGE INDEX
067700
067800     MOVE BILL-BENE-MSA        TO SEARCH-MSA.
067900
068000     IF BILL-FROM-DATE  < 19991001
068100        MOVE BILL-BENE-LUGAR   TO SEARCH-LUGAR
068200     ELSE
068300        MOVE SPACE             TO SEARCH-LUGAR.
068400
068500     PERFORM 0400-SEARCH-4-MSA
068600        THRU 0400-SEARCH-EXIT.
068700
068800     IF BILL-RTC = 00
068900        PERFORM 0550-GET-BENE-WAGE-INDEX
069000                THRU 0550-EXIT  VARYING MU2
069100                FROM MU1 BY 1 UNTIL
069200                MSA-MSA-LUGAR (MU2) NOT = SEARCH-MSA-LUGAR
069300     ELSE
069400        MOVE 0                   TO BILL-PROV-WAGE-INDEX
069500                                    BILL-BENE-WAGE-INDEX
069600        GO TO 0350-EXIT.
069700
069800     IF (BILL-BENE-WAGE-INDEX NOT NUMERIC) OR
069900        (BILL-BENE-WAGE-INDEX = ZERO)
070000        MOVE '50'                TO BILL-RTC
070100        GO TO 0350-EXIT.
070200
070300
070400 0350-EXIT.  EXIT.
070500
070600 0375-GET-CBSA.
070700
070800****    GET PROV-HOSP WAGE INDEX
070900****    GET PROV-HOSP WAGE INDEX
071000****    AS OF 01/01/2008 PROV CBSA ONLY COMES FROM CLAIM
071100
071200     IF BILL-FROM-DATE < 20080101
071300       IF W-P-NEW-CBSA-GEO-RURAL1
071400          MOVE '999'           TO SEARCH-CBSA-POS123
071500          MOVE W-P-NEW-CBSA-GEO-RURAL2ND
071600                               TO SEARCH-CBSA-POS45
071700       ELSE
071800          MOVE W-P-NEW-CBSA-GEO-LOC
071900                               TO SEARCH-CBSA
072000          MOVE W-P-NEW-CBSA-GEO-LOC
072100                               TO BILL-PROV-CBSA
072200     ELSE
072300          MOVE BILL-PROV-CBSA  TO SEARCH-CBSA.
072400
072500
072600****    CBSA BETWEEN 50000 AND 59999 NOT VALID FOR 2007
072700****    CBSA BETWEEN 50000 AND 59999 NOT VALID FOR 2007
072800
072900*    IF BILL-FROM-DATE > 20060930 AND
073000*       BILL-PROV-CBSA > 49999 AND
073100*       BILL-PROV-CBSA < 99900
073200*       MOVE '30'              TO BILL-RTC
073300*       GO TO 0375-EXIT.
073400
073500
073600     PERFORM 0450-SEARCH-4-CBSA
073700        THRU 0450-SEARCH-EXIT.
073800
073900     IF BILL-RTC = 00
074000        PERFORM 0525-GET-HOSP-WAGE-INDEX
074100                THRU 0525-EXIT  VARYING CU2
074200                FROM CU1 BY 1 UNTIL
074300                M-CBSA (CU2) NOT = SEARCH-CBSA
074400     ELSE
074500        MOVE 0                 TO BILL-PROV-WAGE-INDEX
074600                                  BILL-BENE-WAGE-INDEX
074700        GO TO 0375-EXIT.
074800
074900     IF (BILL-PROV-WAGE-INDEX NOT NUMERIC) OR
075000        (BILL-PROV-WAGE-INDEX = ZERO)
075100        MOVE '40'          TO BILL-RTC
075200        GO TO 0375-EXIT.
075300
075400
075500****    GET BENE WAGE INDEX
075600**%%    GET BENE WAGE INDEX
075700
075800     MOVE BILL-BENE-CBSA   TO SEARCH-CBSA.
075900
076000     PERFORM 0450-SEARCH-4-CBSA
076100        THRU 0450-SEARCH-EXIT.
076200
076300     IF BILL-RTC = 00
076400        PERFORM 0575-GET-BENE-WAGE-INDEX
076500           THRU 0575-EXIT
076600               VARYING CU2
076700                  FROM CU1 BY 1 UNTIL
076800                       M-CBSA (CU2) NOT = SEARCH-CBSA
076900     ELSE
077000        MOVE 0             TO BILL-PROV-WAGE-INDEX
077100                              BILL-BENE-WAGE-INDEX
077200        GO TO 0375-EXIT.
077300
077400     IF (BILL-BENE-WAGE-INDEX NOT NUMERIC) OR
077500        (BILL-BENE-WAGE-INDEX = ZERO)
077600        MOVE '50'          TO BILL-RTC
077700        GO TO 0375-EXIT.
077800
077900     PERFORM 1000-CALL
078000        THRU 1000-EXIT.
078100
078200 0375-EXIT.  EXIT.
078300
078400 0400-SEARCH-4-MSA.
078500****   SEARCH FOR MSA
078600     SET MU1               TO 1.
078700     SEARCH M-MSA-DATA VARYING MU1
078800            AT END
078900                MOVE 30    TO BILL-RTC
079000
079100
079200     WHEN MSA-MSA-LUGAR (MU1) = SEARCH-MSA-LUGAR
079300          SET MU2          TO MU1.
079400
079500 0400-SEARCH-EXIT.  EXIT.
079600
079700 0450-SEARCH-4-CBSA.
079800****   SEARCH FOR CBSA
079900
080000     SET CU1               TO 1.
080100
080200
080300     SEARCH M-CBSA-DATA VARYING CU1
080400            AT END
080500                MOVE 30    TO BILL-RTC
080600
080700
080800     WHEN M-CBSA (CU1) = SEARCH-CBSA
080900          SET CU2          TO CU1.
081000
081100 0450-SEARCH-EXIT.  EXIT.
081200
081300 0500-GET-HOSP-WAGE-INDEX.
081400
081500****   LOOKUP FOR MSA
081600     IF BILL-FROM-DATE NOT < MSA-EFFDTE (MU2)
081700        MOVE MSA-WAGE-IND (MU2)
081800                           TO BILL-PROV-WAGE-INDEX.
081900
082000 0500-EXIT.   EXIT.
082100
082200 0525-GET-HOSP-WAGE-INDEX.
082300
082400****   LOOKUP FOR CBSA
082500****   MUST BE EFFECTIVE WITHIN THE CLAIM'S FY
082600     IF BILL-FROM-DATE NOT < M-CBSA-EFFDTE (CU2) AND
082700
082800        (M-CBSA-EFFDTE (CU2)  >= W-FY-BEGIN-DATE AND
082900         M-CBSA-EFFDTE (CU2)  <= W-FY-END-DATE)
083000
083100        MOVE M-CBSA-WAGE-IND (CU2)
083200                           TO BILL-PROV-WAGE-INDEX.
083300
083400 0525-EXIT.   EXIT.
083500
083600 0550-GET-BENE-WAGE-INDEX.
083700
083800****   LOOKUP FOR MSA
083900     IF BILL-FROM-DATE NOT < MSA-EFFDTE (MU2)
084000        MOVE MSA-WAGE-IND (MU2)
084100                           TO BILL-BENE-WAGE-INDEX.
084200
084300 0550-EXIT.   EXIT.
084400
084500 0575-GET-BENE-WAGE-INDEX.
084600
084700****   LOOKUP FOR CBSA
084800****   MUST BE EFFECTIVE WITHIN THE CLAIM'S FY
084900     IF BILL-FROM-DATE NOT < M-CBSA-EFFDTE (CU2) AND
085000
085100        (M-CBSA-EFFDTE(CU2)  >= W-FY-BEGIN-DATE AND
085200         M-CBSA-EFFDTE(CU2)  <= W-FY-END-DATE)
085300
085400        MOVE M-CBSA-WAGE-IND (CU2)
085500                           TO BILL-BENE-WAGE-INDEX.
085600
085700 0575-EXIT.   EXIT.
085800
085900 0700-GET-PROVIDER.
086000***************************************************************
086100*    ON A PROVIDER BREAK:                                     *
086200*    FIND THE PROVIDER MSA AND LUGAR ELEMENTS                 *
086300*    FILE MUST BE PROV-NO EFF-DATE SEQUENCE                   *
086400***************************************************************
086500
086600     IF  BILL-PROV-NO NOT = P-NEW-PROVIDER-NO
086700         SET PX2               TO 1
086800         SEARCH PROV-ENTRIES VARYING PX2
086900             AT END
087000                 MOVE 51       TO BILL-RTC
087100                 GO TO 0700-EXIT
087200             WHEN BILL-PROV-NO = PROV-NO (PX2)
087300                 MOVE 00       TO BILL-RTC.
087400
087500     MOVE PROV-DATA1 (PX2)     TO PROV-NEWREC-HOLD1.
087600     SET PD2                   TO PX2.
087700     SET PD3                   TO PX2.
087800     MOVE PROV-DATA2 (PD2)     TO PROV-NEWREC-HOLD2.
087900     MOVE PROV-DATA3 (PD3)     TO PROV-NEWREC-HOLD3.
088000
088100     PERFORM 0800-GET-CURR-PROV
088200        THRU 0800-EXIT
088300             VARYING PX3
088400             FROM PX2 BY 1 UNTIL PROV-NO (PX3) NOT =
088500                  BILL-PROV-NO OR PROV-NO (PX3) = '999999'.
088600
088700 0700-EXIT.  EXIT.
088800
088900 0800-GET-CURR-PROV.
089000
089100     IF BILL-FROM-DATE NOT < PROV-EFF-DATE (PX3)
089200         MOVE PROV-DATA1 (PX3) TO PROV-NEWREC-HOLD1
089300         SET PD2               TO PX3
089400         SET PD3               TO PX3
089500         MOVE PROV-DATA2 (PD2) TO PROV-NEWREC-HOLD2
089600         MOVE PROV-DATA3 (PD3) TO PROV-NEWREC-HOLD3.
089700
089800
089900 0800-EXIT.  EXIT.
090000
090100
090200 1000-CALL.
090300*
090400*    DISPLAY '========================='
090500*    DISPLAY '======HOSDR162==========='
090600*    DISPLAY 'BENE WAGE INDEX = '  BILL-BENE-WAGE-INDEX.
090700*    DISPLAY 'PROV WAGE INDEX = '  BILL-PROV-WAGE-INDEX.
090800*    DISPLAY '========================='
090900*
091000     CALL HOSPR162            USING BILL-315-DATA.
091100
091200
091300 1000-EXIT.   EXIT.
091400
091500******        L A S T   S O U R C E   S T A T E M E N T   *****
091600***************************************************************
