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