000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.           HOSDR150.                                  00020001
000300*AUTHOR.  DDS TEAM                                                00030000
000400*         (CENTERS FOR MEDICARE AND MEDICAID SERVICES)            00040000
000500*REMARKS. A). HOSPICE DRIVER WILL CALL HOSPR___ MODULE.           00050000
000600*             CALLS THE HOSPR___ MODULE.                          00060000
000700*             LOADS THE PROV FILE MSA FILEAND CBSA FILE.          00070000
000800*             FINDS THE PROV RECORD AND WAGE-INDEX RECORD FOR     00080000
000900*             GIVEN HOSPICE DATA TO BE PASSED TO HOSPR___ MODULE. 00090000
001000******************************************************************00100000
001100*REMARKS.                                                         00110000
000800*     HOSPR150   REVISIONS FOR OCT 1, 2013                        00120002
001300*                2014 RATE REVISIONS                              00130000
000900*                REVISED BILL & RATE RECORD LENGTH FROM 135 TO 21500140002
000900*                NEW LOGIC FOR QIP INDICATOR                      00150000
001400*     HOSDR150   NEW PROCESSES OCT 1, 2013                        00160002
001500*                CALL TO HOSPR150                                 00170002
001700*     HOSOP150   NEW PROCESSES OCT 1, 2013                        00180002
001800*                CICS VERSION TO OPEN FILES CALL HOSDR150         00190002
001900*                                                                 00200000
000800*     HOSPR140   REVISIONS FOR OCT 1, 2013                        00210002
001300*                2014 RATE REVISIONS                              00220002
000900*         ==>>>> REVISED BILL & RATE RECORD LENGTH FROM 135 TO 21500230002
000900*         ==>>>> NEW LOGIC FOR QIP INDICATOR                      00240002
001400*     HOSDR140   NEW PROCESSES OCT 1, 2013                        00250002
001500*                CALL TO HOSPR140                                 00260002
001700*     HOSOP140   NEW PROCESSES OCT 1, 2013                        00270002
001800*                CICS VERSION TO OPEN FILES CALL HOSDR140         00280002
001900*                                                                 00290002
001200*     HOSPR130   REVISIONS FOR OCT 1, 2012                        00300000
001300*                2013 RATE REVISIONS                              00310000
001400*     HOSDR130   NEW PROCESSES OCT 1, 2012                        00320000
001500*                CALL TO HOSPR130                                 00330000
001700*     HOSOP130   NEW PROCESSES OCT 1, 2012                        00340000
001800*                CICS VERSION TO OPEN FILES CALL HOSDR130         00350000
001900*                                                                 00360000
001200*     HOSPR120   REVISIONS FOR OCT 1, 2011                        00370000
001300*                2012 RATE REVISIONS                              00380000
001400*     HOSDR120   NEW PROCESSES OCT 1, 2011                        00390000
001500*                CALL TO HOSPR120                                 00400000
001700*     HOSOP120   NEW PROCESSES OCT 1, 2011                        00410000
001800*                CICS VERSION TO OPEN FILES CALL HOSDR120         00420000
001900*                                                                 00430000
001200*     HOSPR110   REVISIONS FOR OCT 1, 2010                        00440000
001300*                2011 RATE REVISIONS                              00450000
001400*     HOSDR110   NEW PROCESSES OCT 1, 2010                        00460000
001500*                CALL TO HOSPR110                                 00470000
001700*     HOSOP110   NEW PROCESSES OCT 1, 2010                        00480000
001800*                CICS VERSION TO OPEN FILES CALL HOSDR110         00490000
001900*                                                                 00500000
001200*     HOSPR100   REVISIONS FOR OCT 1, 2009                        00510000
001300*                2010 RATE REVISIONS                              00520000
001400*     HOSDR100   NEW PROCESSES OCT 1, 2009                        00530000
001500*                CALL TO HOSPR100                                 00540000
001700*     HOSOP100   NEW PROCESSES OCT 1, 2009                        00550000
001800*                CICS VERSION TO OPEN FILES CALL HOSDR100         00560000
001900*                                                                 00570000
002000*     HOSPR091   REVISIONS FOR JAN 1, 2008                        00580000
002100*                2009 RATE REVISIONS                              00590000
002200*     HOSDR091   NEW PROCESSES JAN 1, 2008                        00600000
002300*                CALL TO HOSPR091                                 00610000
002400*                STIMULUS PKG RECOMPILE                           00620000
002500*     HOSOP091   NEW PROCESSES JAN 1, 2008                        00630000
002600*                CICS VERSION TO OPEN FILES CALL HOSDR091         00640000
002700*                                                                 00650000
002800*     HOSPR090   REVISIONS FOR OCT 1, 2008                        00660000
002900*                2008 RATE REVISIONS                              00670000
003000*     HOSDR090   NEW PROCESSES OCT 1, 2008                        00680000
003100*                CALL TO HOSPR090                                 00690000
003200*     HOSOP090   NEW PROCESSES OCT 1, 2008                        00700000
003300*                CICS VERSION TO OPEN FILES CALL HOSDR090         00710000
003400*                                                                 00720000
003500*     HOSPR081   REVISIONS FOR OCT 1, 2007                        00730000
003600*                2008 RATE REVISIONS                              00740000
003700*     HOSDR081   NEW PROCESSES OCT 1, 2007                        00750000
003800*                CALL TO HOSPR081                                 00760000
003900*     HOSOP081   NEW PROCESSES OCT 1, 2007                        00770000
004000*                CICS VERSION TO OPEN FILES CALL HOSDR081         00780000
004100*                                                                 00790000
004200*     HOSPR071   REVISIONS FOR JAN 1, 2007                        00800000
004300*                2007.1-PROCESS-DATA 1 UNIT = 15 MIN CODE 652     00810000
004400*                2007 CALCULATE HOME RATE BY REVENUE CODE FACTORS 00820000
004500*     HOSDR071   NEW PROCESSES JAN 1, 2007                        00830000
004600*                CALL TO HOSPR071                                 00840000
004700*     HOSOP071   NEW PROCESSES JAN 1, 2007                        00850000
004800*                CICS VERSION TO OPEN FILES CALL HOSDR071         00860000
004900*                                                                 00870000
005000*     HOSPR070   REVISIONS FOR OCT 1, 2006                        00880000
005100*                2007-PROCESS-DATA                                00890000
005200*                2007 CALCULATE HOME RATE BY REVENUE CODE FACTORS 00900000
005300*     HOSDR070   NEW PROCESSES OCT 1, 2006                        00910000
005400*                CBSA FILE PROCESSING                             00920000
005500*     HOSOP070   NEW PROCESSES OCT 1, 2006                        00930000
005600*                CICS VERSION TO OPEN FILES                       00940000
005700*                                                                 00950000
005800***************************************************************   00960000
005900 DATE-COMPILED.                                                   00970000
006000 ENVIRONMENT DIVISION.                                            00980000
006100 CONFIGURATION SECTION.                                           00990000
006200 SOURCE-COMPUTER.            IBM-370.                             01000000
006300 OBJECT-COMPUTER.            IBM-370.                             01010000
006400 INPUT-OUTPUT  SECTION.                                           01020000
006500 FILE-CONTROL.                                                    01030000
006600                                                                  01040000
006700 DATA DIVISION.                                                   01050000
006800 FILE SECTION.                                                    01060000
006900                                                                  01070000
007000 WORKING-STORAGE SECTION.                                         01080000
007100 01  W-STORAGE-REF                  PIC X(46)  VALUE              01090000
007200     'HOSDR150      - W O R K I N G   S T O R A G E'.             01100002
007300 01  HOS-VERSION                    PIC X(09)  VALUE 'HOSDR15.0'. 01110002
007400 01  HOSOP150                       PIC X(08)  VALUE 'HOSOP150'.  01120002
007500 01  HOSPR150                       PIC X(08)  VALUE 'HOSPR150'.  01130002
007600 01  EOF-MSA-SW                     PIC 9(01)  VALUE 0.           01140000
007700 01  EOF-CBSA-SW                    PIC 9(01)  VALUE 0.           01150000
007800 01  EOF-BILL-SW                    PIC 9(01)  VALUE 0.           01160000
007900 01  EOF-PROV-SW                    PIC 9(01)  VALUE 0.           01170000
008000 01  BILL-CTR                       PIC 9(09)  VALUE 0.           01180000
008100 01  RATE-CTR                       PIC 9(09)  VALUE 0.           01190000
008200 01  PROV-CTR                       PIC 9(09)  VALUE 0.           01200000
008300                                                                  01210000
008400 01  SEARCH-MSA-LUGAR.                                            01220000
008500     05  SEARCH-MSA.                                              01230000
008600         10  SEARCH-MSA-POS12  PIC 9(02).                         01240000
008700         10  SEARCH-MSA-POS34  PIC 9(02).                         01250000
008800     05  SEARCH-LUGAR          PIC X.                             01260000
008900                                                                  01270000
009000 01  SEARCH-CBSA.                                                 01280000
009100     05  SEARCH-CBSA-POS123    PIC 9(03).                         01290000
009200     05  SEARCH-CBSA-POS45     PIC 9(02).                         01300000
009300                                                                  01310000
009400 01  UT1-STAT.                                                    01320000
009500     05  UT1-STAT1             PIC X.                             01330000
009600     05  UT1-STAT2             PIC X.                             01340000
009700 01  UT2-STAT.                                                    01350000
009800     05  UT2-STAT1             PIC X.                             01360000
009900     05  UT2-STAT2             PIC X.                             01370000
010000 01  UT3-STAT.                                                    01380000
010100     05  UT3-STAT1             PIC X.                             01390000
010200     05  UT3-STAT2             PIC X.                             01400000
010300 01  UT4-STAT.                                                    01410000
010400     05  UT4-STAT1             PIC X.                             01420000
010500     05  UT4-STAT2             PIC X.                             01430000
010600 01  UT5-STAT.                                                    01440000
010700     05  UT5-STAT1             PIC X.                             01450000
010800     05  UT5-STAT2             PIC X.                             01460000
010900                                                                  01470000
011000***************************************************************   01480000
011100**************************************************************    01490000
011200*      MILLINNIUM COMPATIBLE                                 *    01500000
011300**************************************************************    01510000
011400 01  PROV-NEW-HOLD.                                               01520000
011500     02  PROV-NEWREC-HOLD1.                                       01530000
011600         05  P-NEW-NPI10.                                         01540000
011700             10  P-NEW-NPI8             PIC X(08).                01550000
011800             10  P-NEW-NPI-FILLER       PIC X(02).                01560000
011900         05  P-NEW-PROVIDER-NO.                                   01570000
012000             10  P-NEW-STATE            PIC 9(02).                01580000
012100             10  FILLER                 PIC X(04).                01590000
012200         05  P-NEW-DATE-DATA.                                     01600000
012300             10  P-NEW-EFF-DATE.                                  01610000
012400                 15  P-NEW-EFF-DT-CC    PIC 9(02).                01620000
012500                 15  P-NEW-EFF-DT-YY    PIC 9(02).                01630000
012600                 15  P-NEW-EFF-DT-MM    PIC 9(02).                01640000
012700                 15  P-NEW-EFF-DT-DD    PIC 9(02).                01650000
012800             10  P-NEW-FY-BEGIN-DATE.                             01660000
012900                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                01670000
013000                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                01680000
013100                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                01690000
013200                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                01700000
013300             10  P-NEW-REPORT-DATE.                               01710000
013400                 15  P-NEW-REPORT-DT-CC PIC 9(02).                01720000
013500                 15  P-NEW-REPORT-DT-YY PIC 9(02).                01730000
013600                 15  P-NEW-REPORT-DT-MM PIC 9(02).                01740000
013700                 15  P-NEW-REPORT-DT-DD PIC 9(02).                01750000
013800             10  P-NEW-TERMINATION-DATE.                          01760000
013900                 15  P-NEW-TERM-DT-CC   PIC 9(02).                01770000
014000                 15  P-NEW-TERM-DT-YY   PIC 9(02).                01780000
014100                 15  P-NEW-TERM-DT-MM   PIC 9(02).                01790000
014200                 15  P-NEW-TERM-DT-DD   PIC 9(02).                01800000
014300         05  P-NEW-WAIVER-CODE          PIC X(01).                01810000
014400             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              01820000
014500         05  P-NEW-INTER-NO             PIC 9(05).                01830000
014600         05  P-NEW-PROVIDER-TYPE        PIC X(02).                01840000
014700             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.      01850000
014800             88  P-N-REFERRAL-CENTER        VALUE '07' '11'       01860000
014900                                                  '15' '17'       01870000
015000                                                  '22'.           01880000
015100             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.           01890000
015200             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.           01900000
015300             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.           01910000
015400             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.           01920000
015500             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.      01930000
015600             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.           01940000
015700             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.      01950000
015800             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.           01960000
015900             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.           01970000
016000             88  P-N-EACH                   VALUE '21' '22'.      01980000
016100             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.           01990000
016200             88  P-N-NHCMQ-II-SNF           VALUE '32'.           02000000
016300             88  P-N-NHCMQ-III-SNF          VALUE '33'.           02010000
016400         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                02020000
016500             88  P-N-NEW-ENGLAND            VALUE  1.             02030000
016600             88  P-N-MIDDLE-ATLANTIC        VALUE  2.             02040000
016700             88  P-N-SOUTH-ATLANTIC         VALUE  3.             02050000
016800             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.             02060000
016900             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.             02070000
017000             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.             02080000
017100             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.             02090000
017200             88  P-N-MOUNTAIN               VALUE  8.             02100000
017300             88  P-N-PACIFIC                VALUE  9.             02110000
017400         05  P-NEW-CURRENT-DIV   REDEFINES                        02120000
017500                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         02130000
017600             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.          02140000
017700         05  P-NEW-MSA-DATA.                                      02150000
017800             10  P-NEW-CHG-CODE-INDEX       PIC X.                02160000
017900             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 02170000
018000             10  P-NEW-GEO-LOC-MSAX-RUR REDEFINES                 02180000
018100                                     P-NEW-GEO-LOC-MSAX.          02190000
018200                 15  P-NEW-RURAL1    PIC X(02).                   02200000
018300                     88  P-NEW-GEO-RURAL1   VALUE '  '.           02210000
018400                 15  P-NEW-GEO-RURAL2    PIC X(02).               02220000
018500             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   02230000
018600                             P-NEW-GEO-LOC-MSAX-RUR PIC 9(04).    02240000
018700             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 02250000
018800             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 02260000
018900             10  P-NEW-STAND-AMT-LOC-MSA9                         02270000
019000       REDEFINES P-NEW-STAND-AMT-LOC-MSA.                         02280000
019100                 15  P-NEW-RURAL-1ST.                             02290000
019200                     20  P-NEW-STAND-RURAL  PIC XX.               02300000
019300                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    02310000
019400                 15  P-NEW-RURAL-2ND        PIC XX.               02320000
019500         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    02330000
019600                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           02340000
019700                 88  P-NEW-SCH-YR82       VALUE   '82'.           02350000
019800                 88  P-NEW-SCH-YR87       VALUE   '87'.           02360000
019900         05  P-NEW-LUGAR                    PIC X.                02370000
020000         05  P-NEW-TEMP-RELIEF-IND          PIC X.                02380000
020100         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                02390000
020200         05  FILLER                         PIC X(05).            02400000
020300     02  PROV-NEWREC-HOLD2.                                       02410000
020400         05  P-NEW-VARIABLES.                                     02420000
020500             10  P-NEW-FAC-SPEC-RATE       PIC 9(05)V9(02).       02430000
020600             10  P-NEW-COLA                PIC 9(01)V9(03).       02440000
020700             10  P-NEW-INTERN-RATIO        PIC 9(01)V9(04).       02450000
020800             10  P-NEW-BED-SIZE            PIC 9(05).             02460000
020900             10  P-NEW-OPER-CSTCHG-RATIO   PIC 9(01)V9(03).       02470000
021000             10  P-NEW-CMI                 PIC 9(01)V9(04).       02480000
021100             10  P-NEW-SSI-RATIO           PIC V9(04).            02490000
021200             10  P-NEW-MEDICAID-RATIO      PIC V9(04).            02500000
021300             10  P-NEW-PPS-BLEND-YR-IND    PIC X(01).             02510000
021400             10  P-NEW-PRUP-UPDATE-FACTOR  PIC 9(01)V9(05).       02520000
021500             10  P-NEW-DSH-PERCENT         PIC V9(04).            02530000
021600             10  P-NEW-FYE-DATE            PIC 9(08).             02540000
021700         05  P-NEW-CBSA-DATA.                                     02550000
021800             10  W-P-NEW-CBSA-SPEC-PAY-IND     PIC X.             02560000
021900                 88  P-NEW-CBSA-WI-GEO        VALUE 'N'.          02570000
022000                 88  P-NEW-CBSA-WI-RECLASS    VALUE 'Y'.          02580000
022100                 88  P-NEW-CBSA-WI-SPECIAL    VALUE '1' '2'.      02590000
022200***                  1 = ANYTHING OR HOLD HARMLESS WITH SPEC WI   02600000
022300***                  2 = RECLASS WITH SPEC WI                     02610000
022400             10  W-P-NEW-CBSA-HOSP-QUAL-IND    PIC X.             02620000
022500                                                                  02630000
022600             10  W-P-NEW-CBSA-GEO-LOC       PIC X(05) JUST RIGHT. 02640000
022700             10  W-P-NEW-CBSA-GEO-RURAL REDEFINES                 02650000
022800                 W-P-NEW-CBSA-GEO-LOC.                            02660000
022900                 15  W-P-NEW-CBSA-GEO-RURAL1ST PIC XXX.           02670000
023000                     88  W-P-NEW-CBSA-GEO-RURAL1  VALUE '   '.    02680000
023100                 15  W-P-NEW-CBSA-GEO-RURAL2ND PIC XX.            02690000
023200                                                                  02700000
023300             10  W-P-NEW-CBSA-RECLASS-LOC   PIC X(05) JUST RIGHT. 02710000
023400             10  W-P-NEW-CBSA-STAND-AMT-LOC PIC X(05) JUST RIGHT. 02720000
023500             10  W-P-NEW-CBSA-SPEC-WAGE-INDEX  PIC 9(02)V9(04).   02730000
023600     02  PROV-NEWREC-HOLD3.                                       02740000
023700         05  P-NEW-PASS-AMT-DATA.                                 02750000
023800             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          02760000
023900             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          02770000
024000             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          02780000
024100             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          02790000
024200         05  P-NEW-CAPI-DATA.                                     02800000
024300             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 02810000
024400             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          02820000
024500             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          02830000
024600             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        02840000
024700             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             02850000
024800             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 02860000
024900             15  P-NEW-CAPI-IME            PIC 9V9999.            02870000
025000             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          02880000
025100             15  P-VAL-BASED-PURCH-SCORE   PIC 9V999.             02890000
025200         05  FILLER                        PIC X(18).             02900000
025300******************************************************************02910000
025400**-----------------------------------------------------------**   02920000
025500 LINKAGE SECTION.                                                 02930000
025600***************************************************************   02940000
025700*                 * * * * * * * * *                           *   02950000
025800***************************************************************   02960000
025900***************************************************************   02970000
026000*    THIS DATA IS CALCULATED BY THIS HOSPRICER PROGRAM        *   02980000
026100*    AND PASSED BACK                                          *   02990000
026200*            RETURN CODE VALUES (HLD-RTC)                     *   03000000
026300*                                                             *   03010000
026400*            HLD-RTC                                          *   03020000
026500*              00 = HOME RATE RETURNED                        *   03030000
026600*                                                             *   03040000
026700*            HLD-RTC   NO RATE RETURNED                       *   03050000
026800*              10 = BAD UNITS                                 *   03060000
026900*                                                             *   03070000
027000*              20 = BAD UNITS2 < 8                            *   03080000
027100*                                                             *   03090000
027200*              30 = BAD MSA CODE OR CBSA CODE                 *   03100000
027300*                                                             *   03110000
027400*              40 = BAD HOSPICE WAGE INDEX FROM MSAFILE       *   03120000
027500*                                                             *   03130000
027600*              50 = BAD BENE    WAGE INDEX FROM MSAFILE       *   03140000
027700*                                                             *   03150000
027800*              51 = BAD PROV NUMBER                           *   03160000
027900*                                                             *   03170000
028000***************************************************************   03180000
032500                                                                  03190000
014800***************************************************************   03200000
039100 01  HOLD-BILL-DATA.                                              03210000
039200     10  HLD-NPI                  PIC X(10).                      03220000
039300     10  HLD-PROV-NO              PIC X(06).                      03230000
039400     10  HLD-FROM-DATE-ALL.                                       03240000
039500         15  HLD-FROM-CC          PIC 99.                         03250000
039600         15  HLD-FROM-DATE.                                       03260000
039700             20  HLD-FROM-YY      PIC 99.                         03270000
039800             20  HLD-FROM-MM      PIC 99.                         03280000
039900             20  HLD-FROM-DD      PIC 99.                         03290000
040000*                                                                 03300000
035700     10  FILLER                   PIC X(08).                      03310000
040000*                                                                 03320000
040100     10  HLD-PROV-MSA-LUGAR.                                      03330000
040200         15  HLD-PROV-MSA         PIC X(04).                      03340000
040300         15  HLD-PROV-LUGAR       PIC X.                          03350000
040400     10  HLD-PROV-CBSA REDEFINES                                  03360000
040500                       HLD-PROV-MSA-LUGAR PIC X(05).              03370000
040600*                                                                 03380000
040700     10  HLD-BENE-MSA-LUGAR.                                      03390000
040800         15  HLD-BENE-MSA         PIC X(04).                      03400000
040900         15  HLD-BENE-LUGAR       PIC X.                          03410000
041000     10  HLD-BENE-CBSA REDEFINES                                  03420000
041100                       HLD-BENE-MSA-LUGAR PIC X(05).              03430000
035500*                                                                 03440000
035700     10  FILLER                   PIC X(10).                      03450000
041200*                                                                 03460000
041300     10  HLD-PROV-WAGE-IND        PIC 9(02)V9(04).                03470000
041400     10  HLD-BENE-WAGE-IND        PIC 9(02)V9(04).                03480000
035500*                                                                 03490000
035700     10  FILLER                   PIC X(20).                      03500000
035500*                                                                 03510000
035700     10  HLD-QIP-REDUCTION-IND    PIC X.                          03520000
035500*                                                                 03530000
041500     10  HLD-GROUP1.                                              03540000
041600         15  HLD-REV1             PIC XXXX.                       03550000
036000         15  HLD-HCPC1            PIC X(05).                      03560000
041700         15  HLD-UNITS1           PIC 9(07).                      03570000
041800         15  HLD-THEIR-PAY-CHG1   PIC 9(06)V99.                   03580000
041900     10  HLD-GROUP2.                                              03590000
042000         15  HLD-REV2             PIC XXXX.                       03600000
036000         15  HLD-HCPC2            PIC X(05).                      03610000
042100         15  HLD-UNITS2           PIC 9(07).                      03620000
042200         15  HLD-THEIR-PAY-CHG2   PIC 9(06)V99.                   03630000
042300     10  HLD-GROUP3.                                              03640000
042400         15  HLD-REV3             PIC XXXX.                       03650000
036000         15  HLD-HCPC3            PIC X(05).                      03660000
042500         15  HLD-UNITS3           PIC 9(07).                      03670000
042600         15  HLD-THEIR-PAY-CHG3   PIC 9(06)V99.                   03680000
042700     10  HLD-GROUP4.                                              03690000
042800         15  HLD-REV4             PIC XXXX.                       03700000
036000         15  HLD-HCPC4            PIC X(05).                      03710000
042900         15  HLD-UNITS4           PIC 9(07).                      03720000
043000         15  HLD-THEIR-PAY-CHG4   PIC 9(06)V99.                   03730000
043100     10  HLD-RETURNED-DATA.                                       03740000
043200         15  HLD-PAY-AMT          PIC 9(06)V99.                   03750000
043300         15  HLD-RTC              PIC XX.                         03760000
043400     10  FILLER                   PIC X(24).                      03770000
043500                                                                  03780000
043600***************************************************************   03790000
014900*----------------------------------------------------------****   03800000
032600******************************************************************03810000
032700*                                                                 03820000
032800*    FILE MUST BE PROV-NO EFF-DATE SEQUENCE                       03830000
032900*                                                                 03840000
033000******************************************************************03850000
033100                                                                  03860000
033200 01  PROV-TABLE.                                                  03870000
033300     02  PROV-ENTRIES               OCCURS 2400                   03880000
033400                                    ASCENDING KEY IS PROV-NO      03890000
033500                                    INDEXED BY PX1 PX2 PX3.       03900000
033600         10  PROV-DATA1.                                          03910000
033700             15  PROV-NPI10.                                      03920000
033800                 20  PROV-NPI8     PIC X(08).                     03930000
033900                 20  PROV-NPI-FIL  PIC X(02).                     03940000
034000             15  PROV-NO           PIC X(06).                     03950000
034100             15  PROV-EFF-DATE     PIC X(08).                     03960000
034200             15  FILLER            PIC X(56).                     03970000
034300                                                                  03980000
034400 01  PROV-DATA-2.                                                 03990000
034500     02  PROV-ENTRIES2              OCCURS 2400                   04000000
034600                                    INDEXED BY PD2.               04010000
034700         10  PROV-DATA2            PIC X(80).                     04020000
034800                                                                  04030000
034900 01  PROV-DATA-3.                                                 04040000
035000     02  PROV-ENTRIES3              OCCURS 2400                   04050000
035100                                    INDEXED BY PD3.               04060000
035200         10  PROV-DATA3            PIC X(80).                     04070000
035300                                                                  04080000
035400***************************************************************   04090000
035500***************************************************************   04100000
035600 01  MSA-WI-TABLE.                                                04110000
035700     05  M-MSA-DATA              OCCURS 4000                      04120000
035800                                 INDEXED BY MU1 MU2 MU3.          04130000
035900         10  MSA-MSA-LUGAR.                                       04140000
036000             15  MSA-MSA       PIC 9(04).                         04150000
036100             15  MSA-LUGAR     PIC X.                             04160000
036200         10  MSA-EFFDTE        PIC X(08).                         04170000
036300         10  MSA-WAGE-IND      PIC S9(02)V9(04).                  04180000
036400                                                                  04190000
036500***************************************************************   04200000
036600***************************************************************   04210000
036700 01  CBSA-WI-TABLE.                                               04220000
036800     05  M-CBSA-DATA             OCCURS 6000                      04230000
036900                                 INDEXED BY CU1 CU2 CU3.          04240000
037000         10  M-CBSA              PIC 9(05).                       04250000
037100         10  M-CBSA-EFFDTE       PIC X(08).                       04260000
037200         10  M-CBSA-WAGE-IND     PIC S9(02)V9(04).                04270000
037300                                                                  04280000
037400***************************************************************   04290000
037500**-----------------------------------------------------------**   04300000
037600                                                                  04310000
037700 PROCEDURE DIVISION USING HOLD-BILL-DATA                          04320000
037800                          PROV-TABLE                              04330000
037900                          PROV-DATA-2                             04340000
038000                          PROV-DATA-3                             04350000
038100                          MSA-WI-TABLE                            04360000
038200                          CBSA-WI-TABLE.                          04370000
038300**-----------------------------------------------------------**   04380000
038400**-----------------------------------------------------------**   04390000
038500                                                                  04400000
038600     PERFORM 0200-PROCESS-RECORDS                                 04410000
038600        THRU 0200-EXIT.                                           04420000
038700                                                                  04430000
038800     GOBACK.                                                      04440000
038900                                                                  04450000
039000                                                                  04460000
039100 0200-PROCESS-RECORDS.                                            04470000
039200**                                                                04480000
039300     MOVE ALL '0'              TO HLD-RETURNED-DATA.              04490000
039400     IF EOF-BILL-SW = 0                                           04500000
039500           ADD 1               TO BILL-CTR                        04510000
039600           PERFORM 0300-PROCESS-DATA                              04520000
039600              THRU 0300-EXIT.                                     04530000
039700                                                                  04540000
039800 0200-EXIT.  EXIT.                                                04550000
039900                                                                  04560000
040000 0300-PROCESS-DATA.                                               04570000
040100****    GET PROV RECORD FOR HOSPICE MSA OR CBSA                   04580000
040200****    GET PROV RECORD FOR HOSPICE MSA OR CBSA                   04590000
040300                                                                  04600000
040400     PERFORM 0700-GET-PROVIDER                                    04610000
040400        THRU 0700-EXIT.                                           04620000
040500                                                                  04630000
040600     IF HLD-RTC NOT = 00                                          04640000
040700        GO TO 0300-EXIT.                                          04650000
040800                                                                  04660000
040900     IF P-NEW-EFF-DATE < 20051001 AND                             04670000
041000        HLD-FROM-DATE-ALL > 20050930                              04680000
041100        MOVE 51                TO HLD-RTC                         04690000
041600                                                                  04700000
041600                                                                  04710000
041500        GO TO 0300-EXIT.                                          04720000
041600                                                                  04730000
041700                                                                  04740000
041800     IF HLD-FROM-DATE-ALL > 20050930                              04750000
041900        PERFORM 0375-GET-CBSA                                     04760000
041900           THRU 0375-EXIT                                         04770000
042000     ELSE                                                         04780000
042100        PERFORM 0350-GET-MSA                                      04790000
042100           THRU 0350-EXIT.                                        04800000
042200                                                                  04810000
042300 0300-EXIT.   EXIT.                                               04820000
042400                                                                  04830000
042500 0350-GET-MSA.                                                    04840000
042600                                                                  04850000
042700****    GET PROV-HOSP WAGE INDEX                                  04860000
042800****    GET PROV-HOSP WAGE INDEX                                  04870000
042900                                                                  04880000
043000     IF P-NEW-GEO-RURAL1                                          04890000
043100        MOVE '99'              TO SEARCH-MSA-POS12                04900000
043200        MOVE P-NEW-GEO-RURAL2  TO SEARCH-MSA-POS34                04910000
043300     ELSE                                                         04920000
043400        MOVE P-NEW-GEO-LOC-MSA9                                   04930000
043400                               TO SEARCH-MSA.                     04940000
043500                                                                  04950000
043600     IF HLD-FROM-DATE-ALL < 19991001                              04960000
043700        MOVE P-NEW-LUGAR       TO SEARCH-LUGAR                    04970000
043800     ELSE                                                         04980000
043900        MOVE SPACE             TO SEARCH-LUGAR.                   04990000
044000                                                                  05000000
044100     MOVE P-NEW-GEO-LOC-MSAX   TO HLD-PROV-MSA.                   05010000
044200                                                                  05020000
044300     IF HLD-FROM-DATE-ALL < 19991001                              05030000
044400        MOVE P-NEW-LUGAR       TO HLD-PROV-LUGAR                  05040000
044500     ELSE                                                         05050000
044600        MOVE SPACE             TO HLD-PROV-LUGAR.                 05060000
044700                                                                  05070000
044800     PERFORM 0400-SEARCH-4-MSA                                    05080000
044800        THRU 0400-SEARCH-EXIT.                                    05090000
044900                                                                  05100000
045000     IF HLD-RTC = 00                                              05110000
045100        PERFORM 0500-GET-HOSP-WAGE-INDEX                          05120000
045200                THRU 0500-EXIT  VARYING MU2                       05130000
045300                FROM MU1 BY 1 UNTIL                               05140000
045400                MSA-MSA-LUGAR (MU2) NOT = SEARCH-MSA-LUGAR        05150000
045500     ELSE                                                         05160000
045600        MOVE 0                 TO HLD-PROV-WAGE-IND               05170000
045700                                  HLD-BENE-WAGE-IND               05180000
045800        GO TO 0350-EXIT.                                          05190000
045900                                                                  05200000
046000     IF HLD-PROV-WAGE-IND NOT NUMERIC                             05210000
046100        MOVE '40'              TO HLD-RTC                         05220000
046200        GO TO 0350-EXIT.                                          05230000
046300                                                                  05240000
046400                                                                  05250000
046500****    GET BENE WAGE INDEX                                       05260000
046600****    GET BENE WAGE INDEX                                       05270000
046700                                                                  05280000
046800     MOVE HLD-BENE-MSA         TO SEARCH-MSA.                     05290000
046900                                                                  05300000
047000     IF HLD-FROM-DATE-ALL < 19991001                              05310000
047100        MOVE HLD-BENE-LUGAR    TO SEARCH-LUGAR                    05320000
047200     ELSE                                                         05330000
047300        MOVE SPACE             TO SEARCH-LUGAR.                   05340000
047400                                                                  05350000
047500     PERFORM 0400-SEARCH-4-MSA                                    05360000
047500        THRU 0400-SEARCH-EXIT.                                    05370000
047600                                                                  05380000
047700     IF HLD-RTC = 00                                              05390000
047800        PERFORM 0550-GET-BENE-WAGE-INDEX                          05400000
047900                THRU 0550-EXIT  VARYING MU2                       05410000
048000                FROM MU1 BY 1 UNTIL                               05420000
048100                MSA-MSA-LUGAR (MU2) NOT = SEARCH-MSA-LUGAR        05430000
048200     ELSE                                                         05440000
048300        MOVE 0                   TO HLD-PROV-WAGE-IND             05450000
048400                                    HLD-BENE-WAGE-IND             05460000
048500        GO TO 0350-EXIT.                                          05470000
048600                                                                  05480000
048700     IF HLD-BENE-WAGE-IND NOT NUMERIC                             05490000
048800        MOVE '50'                TO HLD-RTC                       05500000
048900        GO TO 0350-EXIT.                                          05510000
049000                                                                  05520000
049100                                                                  05530000
049200 0350-EXIT.  EXIT.                                                05540000
049300                                                                  05550000
049400 0375-GET-CBSA.                                                   05560000
049500                                                                  05570000
049600****    GET PROV-HOSP WAGE INDEX                                  05580000
049700****    GET PROV-HOSP WAGE INDEX                                  05590000
049800****    AS OF 01/01/2008 PROV CBSA ONLY COMES FROM CLAIM          05600000
049900     IF HLD-FROM-DATE-ALL < 20080101                              05610000
050000       IF W-P-NEW-CBSA-GEO-RURAL1                                 05620000
050100          MOVE '999'           TO SEARCH-CBSA-POS123              05630000
050200          MOVE W-P-NEW-CBSA-GEO-RURAL2ND                          05640000
050200                               TO SEARCH-CBSA-POS45               05650000
050300       ELSE                                                       05660000
050400          MOVE W-P-NEW-CBSA-GEO-LOC                               05670000
050400                               TO SEARCH-CBSA                     05680000
050500          MOVE W-P-NEW-CBSA-GEO-LOC                               05690000
050500                               TO HLD-PROV-CBSA                   05700000
050600     ELSE                                                         05710000
050700          MOVE HLD-PROV-CBSA   TO SEARCH-CBSA.                    05720000
050800                                                                  05730000
050900                                                                  05740000
051000****    CBSA BETWEEN 50000 AND 59999 NOT VALID FOR 2007           05750000
051100****    CBSA BETWEEN 50000 AND 59999 NOT VALID FOR 2007           05760000
051200                                                                  05770000
051300     IF HLD-FROM-DATE-ALL > 20060930 AND                          05780000
051400        HLD-PROV-CBSA > 49999 AND                                 05790000
051500        HLD-PROV-CBSA < 99900                                     05800000
051600        MOVE '30'              TO HLD-RTC                         05810000
051700        GO TO 0375-EXIT.                                          05820000
051800                                                                  05830000
051900                                                                  05840000
052000     PERFORM 0450-SEARCH-4-CBSA                                   05850000
052000        THRU 0450-SEARCH-EXIT.                                    05860000
052100                                                                  05870000
052200     IF HLD-RTC = 00                                              05880000
052300        PERFORM 0525-GET-HOSP-WAGE-INDEX                          05890000
052400                THRU 0525-EXIT  VARYING CU2                       05900000
052500                FROM CU1 BY 1 UNTIL                               05910000
052600                M-CBSA (CU2) NOT = SEARCH-CBSA                    05920000
052700     ELSE                                                         05930000
052800        MOVE 0                 TO HLD-PROV-WAGE-IND               05940000
052900                                  HLD-BENE-WAGE-IND               05950000
053000        GO TO 0375-EXIT.                                          05960000
053100                                                                  05970000
053200     IF HLD-PROV-WAGE-IND NOT NUMERIC                             05980000
053300        MOVE '40'          TO HLD-RTC                             05990000
053400        GO TO 0375-EXIT.                                          06000000
053500                                                                  06010000
053600                                                                  06020000
053700****    GET BENE WAGE INDEX                                       06030000
053800****    GET BENE WAGE INDEX                                       06040000
053900                                                                  06050000
054000     MOVE HLD-BENE-CBSA    TO SEARCH-CBSA.                        06060000
054100                                                                  06070000
054200****    CBSA BETWEEN 50000 AND 59999 NOT VALID FOR 2007           06080000
054300****    CBSA BETWEEN 50000 AND 59999 NOT VALID FOR 2007           06090000
054400                                                                  06100000
054500     IF HLD-FROM-DATE-ALL > 20060930 AND                          06110000
054600        HLD-BENE-CBSA > 49999 AND                                 06120000
054700        HLD-BENE-CBSA < 99900                                     06130000
054800        MOVE '30'          TO HLD-RTC                             06140000
054900        GO                 TO 0375-EXIT.                          06150000
055000                                                                  06160000
055100     PERFORM 0450-SEARCH-4-CBSA                                   06170000
055100        THRU 0450-SEARCH-EXIT.                                    06180000
055200                                                                  06190000
055300     IF HLD-RTC = 00                                              06200000
055400        PERFORM 0575-GET-BENE-WAGE-INDEX                          06210000
055500           THRU 0575-EXIT                                         06220000
055500               VARYING CU2                                        06230000
055600                  FROM CU1 BY 1 UNTIL                             06240000
055700                       M-CBSA (CU2) NOT = SEARCH-CBSA             06250000
055800     ELSE                                                         06260000
055900        MOVE 0             TO HLD-PROV-WAGE-IND                   06270000
056000                              HLD-BENE-WAGE-IND                   06280000
056100        GO TO 0375-EXIT.                                          06290000
056200                                                                  06300000
056300     IF HLD-BENE-WAGE-IND NOT NUMERIC                             06310000
056400        MOVE '50'          TO HLD-RTC                             06320000
056500        GO TO 0375-EXIT.                                          06330000
056600                                                                  06340000
056700     PERFORM 1000-CALL                                            06350000
056700        THRU 1000-EXIT.                                           06360000
056800                                                                  06370000
056900 0375-EXIT.  EXIT.                                                06380000
057000                                                                  06390000
057100 0400-SEARCH-4-MSA.                                               06400000
057200****   SEARCH FOR MSA                                             06410000
057300     SET MU1               TO 1.                                  06420000
057400     SEARCH M-MSA-DATA VARYING MU1                                06430000
057500            AT END                                                06440000
057600                MOVE 30    TO HLD-RTC                             06450000
058100                                                                  06460000
058100                                                                  06470000
057900     WHEN MSA-MSA-LUGAR (MU1) = SEARCH-MSA-LUGAR                  06480000
058000          SET MU2          TO MU1.                                06490000
058100                                                                  06500000
058200 0400-SEARCH-EXIT.  EXIT.                                         06510000
058300                                                                  06520000
058400 0450-SEARCH-4-CBSA.                                              06530000
058500****   SEARCH FOR CBSA                                            06540000
059700                                                                  06550000
058600     SET CU1               TO 1.                                  06560000
059700                                                                  06570000
059700                                                                  06580000
059000     SEARCH M-CBSA-DATA VARYING CU1                               06590000
059100            AT END                                                06600000
059200                MOVE 30    TO HLD-RTC                             06610000
059700                                                                  06620000
059700                                                                  06630000
059500     WHEN M-CBSA (CU1) = SEARCH-CBSA                              06640000
059600          SET CU2          TO CU1.                                06650000
059700                                                                  06660000
059800 0450-SEARCH-EXIT.  EXIT.                                         06670000
059900                                                                  06680000
060000 0500-GET-HOSP-WAGE-INDEX.                                        06690000
060400                                                                  06700000
060100****   LOOKUP FOR MSA                                             06710000
060200     IF HLD-FROM-DATE-ALL NOT < MSA-EFFDTE (MU2)                  06720000
060300        MOVE MSA-WAGE-IND (MU2)                                   06730000
060300                           TO HLD-PROV-WAGE-IND.                  06740000
060400                                                                  06750000
060500 0500-EXIT.   EXIT.                                               06760000
060600                                                                  06770000
060700 0525-GET-HOSP-WAGE-INDEX.                                        06780000
061100                                                                  06790000
060800****   LOOKUP FOR CBSA                                            06800000
060900     IF HLD-FROM-DATE-ALL NOT < M-CBSA-EFFDTE (CU2)               06810000
061000        MOVE M-CBSA-WAGE-IND (CU2)                                06820000
061000                           TO HLD-PROV-WAGE-IND.                  06830000
061100                                                                  06840000
061200 0525-EXIT.   EXIT.                                               06850000
061300                                                                  06860000
061400 0550-GET-BENE-WAGE-INDEX.                                        06870000
061800                                                                  06880000
061500****   LOOKUP FOR MSA                                             06890000
061600     IF HLD-FROM-DATE-ALL NOT < MSA-EFFDTE (MU2)                  06900000
061700        MOVE MSA-WAGE-IND (MU2)                                   06910000
061700                           TO HLD-BENE-WAGE-IND.                  06920000
061800                                                                  06930000
061900 0550-EXIT.   EXIT.                                               06940000
062000                                                                  06950000
062100 0575-GET-BENE-WAGE-INDEX.                                        06960000
062500                                                                  06970000
062200****   LOOKUP FOR CBSA                                            06980000
062300     IF HLD-FROM-DATE-ALL NOT < M-CBSA-EFFDTE (CU2)               06990000
062400        MOVE M-CBSA-WAGE-IND (CU2)                                07000000
062400                           TO HLD-BENE-WAGE-IND.                  07010000
062500                                                                  07020000
062600 0575-EXIT.   EXIT.                                               07030000
062700                                                                  07040000
062800 0700-GET-PROVIDER.                                               07050000
062900***************************************************************   07060000
063000*    ON A PROVIDER BREAK:                                     *   07070000
063100*    FIND THE PROVIDER MSA AND LUGAR ELEMENTS                 *   07080000
063200*    FILE MUST BE PROV-NO EFF-DATE SEQUENCE                   *   07090000
063300***************************************************************   07100000
064700                                                                  07110000
063400     IF  HLD-PROV-NO NOT = P-NEW-PROVIDER-NO                      07120000
063500         SET PX2               TO 1                               07130000
063600         SEARCH PROV-ENTRIES VARYING PX2                          07140000
063700             AT END                                               07150000
063800                 MOVE 51       TO HLD-RTC                         07160000
063900                 GO TO 0700-EXIT                                  07170000
064000             WHEN HLD-PROV-NO = PROV-NO (PX2)                     07180000
064100                 MOVE 00       TO HLD-RTC.                        07190000
064700                                                                  07200000
064200     MOVE PROV-DATA1 (PX2)     TO PROV-NEWREC-HOLD1.              07210000
064300     SET PD2                   TO PX2.                            07220000
064400     SET PD3                   TO PX2.                            07230000
064500     MOVE PROV-DATA2 (PD2)     TO PROV-NEWREC-HOLD2.              07240000
064600     MOVE PROV-DATA3 (PD3)     TO PROV-NEWREC-HOLD3.              07250000
064700                                                                  07260000
064800     PERFORM 0800-GET-CURR-PROV                                   07270000
064800        THRU 0800-EXIT                                            07280000
064800             VARYING PX3                                          07290000
064900             FROM PX2 BY 1 UNTIL PROV-NO (PX3) NOT =              07300000
065000                  HLD-PROV-NO OR PROV-NO (PX3) = '999999'.        07310000
065100                                                                  07320000
065200 0700-EXIT.  EXIT.                                                07330000
065300                                                                  07340000
065400 0800-GET-CURR-PROV.                                              07350000
065300                                                                  07360000
065500     IF HLD-FROM-DATE-ALL NOT < PROV-EFF-DATE (PX3)               07370000
065600         MOVE PROV-DATA1 (PX3) TO PROV-NEWREC-HOLD1               07380000
065700         SET PD2               TO PX3                             07390000
065800         SET PD3               TO PX3                             07400000
065900         MOVE PROV-DATA2 (PD2) TO PROV-NEWREC-HOLD2               07410000
066000         MOVE PROV-DATA3 (PD3) TO PROV-NEWREC-HOLD3.              07420000
066100                                                                  07430000
066200                                                                  07440000
066300 0800-EXIT.  EXIT.                                                07450000
066400                                                                  07460000
066500                                                                  07470000
066600 1000-CALL.                                                       07480000
066700*                                                                 07490004
066700*    DISPLAY '========================='                          07500004
066700*    DISPLAY '======HOSDR150==========='                          07510004
066700*    DISPLAY 'BENE WAGE INDEX = '  HLD-BENE-WAGE-IND.             07520004
066700*    DISPLAY 'PROV WAGE INDEX = '  HLD-PROV-WAGE-IND.             07530004
066700*    DISPLAY '========================='                          07540004
066700*                                                                 07550004
066800     CALL HOSPR150             USING HOLD-BILL-DATA.              07560002
066900                                                                  07570000
067000                                                                  07580000
067100 1000-EXIT.   EXIT.                                               07590000
067200                                                                  07600000
067300******        L A S T   S O U R C E   S T A T E M E N T   *****   07610000
067400***************************************************************   07620000
