000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.           HOSOP140.                                  00020001
000300*AUTHOR.  DDS TEAM                                                00030008
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*     HOSPR140   REVISIONS FOR OCT 1, 2013                        00120005
001300*                2014 RATE REVISIONS                              00130005
000900*                REVISED BILL & RATE RECORD LENGTH FROM 135 TO 21500130113
000900*                NEW LOGIC FOR QIP INDICATOR                      00130206
001400*     HOSDR140   NEW PROCESSES OCT 1, 2013                        00140002
000900*                REVISED BILL & RATE RECORD LENGTH FROM 135 TO 21500141013
001500*                CBSA FILE PROCESSING DRIVER CALL TO HOSPR140     00150002
001600*     HOSOP140   NEW PROCESSES OCT 1, 2013                        00160002
000900*                REVISED BILL & RATE RECORD LENGTH FROM 135 TO 21500160113
000900*                MODIFY CBSA TABLE SIZE & ADD ERROR DISPLAY LOGIC 00160213
001700*                CICS VERSION OPENS FILES CALL TO HOSDR140        00161002
001900*                                                                 00161200
001200*     HOSPR130   REVISIONS FOR OCT 1, 2012                        00161301
001300*                2013 RATE REVISIONS 3                            00161401
001400*     HOSDR130   NEW PROCESSES OCT 1, 2012                        00161501
001500*                CBSA FILE PROCESSING DRIVER CALL TO HOSPR130     00161601
001600*     HOSOP130   NEW PROCESSES OCT 1, 2012                        00161701
001700*                CICS VERSION OPENS FILES CALL TO HOSDR130        00161801
001900*                                                                 00161901
001200*     HOSPR120   REVISIONS FOR OCT 1, 2011                        00162001
001300*                2012 RATE REVISIONS                              00162101
001400*     HOSDR120   NEW PROCESSES OCT 1, 2011                        00162201
001500*                CBSA FILE PROCESSING DRIVER CALL TO HOSPR120     00162301
001600*     HOSOP120   NEW PROCESSES OCT 1, 2011                        00162401
001700*                CICS VERSION OPENS FILES CALL TO HOSDR120        00162501
001900*                                                                 00162601
001200*     HOSPR110   REVISIONS FOR OCT 1, 2010                        00162701
001300*                2011 RATE REVISIONS                              00162801
001400*     HOSDR110   NEW PROCESSES OCT 1, 2010                        00162901
001500*                CBSA FILE PROCESSING DRIVER CALL TO HOSPR110     00163001
001600*     HOSOP110   NEW PROCESSES OCT 1, 2010                        00163101
001700*                CICS VERSION OPENS FILES CALL TO HOSDR110        00163201
001900*                                                                 00163301
001200*     HOSPR100   REVISIONS FOR OCT 1, 2009                        00163401
001300*                2010 RATE REVISIONS                              00163501
001400*     HOSDR100   NEW PROCESSES OCT 1, 2009                        00163601
001500*                CBSA FILE PROCESSING DRIVER CALL TO HOSPR100     00163701
001600*     HOSOP100   NEW PROCESSES OCT 1, 2009                        00163801
001700*                CICS VERSION OPENS FILES CALL TO HOSDR100        00163901
001900*                                                                 00164001
002000*     HOSPR091   REVISIONS FOR OCT 1, 2008                        00164101
002100*                2009 RATE REVISIONS                              00164201
002200*     HOSDR091   NEW PROCESSES OCT 1, 2008                        00164301
002300*                CBSA FILE PROCESSING DRIVER CALL TO HOSPR091     00164401
002400*     HOSOP091   NEW PROCESSES OCT 1, 2008                        00164501
002500*                CICS VERSION OPENS FILES CALL TO HOSDR091        00164601
002600*                STIMULUS PKG RECOMPILE                           00164701
002700*                                                                 00164801
002800*     HOSPR090   REVISIONS FOR OCT 1, 2008                        00164901
002900*                2009 RATE REVISIONS                              00165001
003000*     HOSDR090   NEW PROCESSES OCT 1, 2008                        00165101
003100*                CBSA FILE PROCESSING DRIVER CALL TO HOSPR090     00165201
003200*     HOSOP090   NEW PROCESSES OCT 1, 2008                        00165301
003300*                CICS VERSION OPENS FILES CALL TO HOSDR090        00165401
003400*                                                                 00165501
003500*     HOSPR081   REVISIONS FOR OCT 1, 2007                        00165601
003600*                2008 RATE REVISIONS                              00165701
003700*     HOSDR081   NEW PROCESSES OCT 1, 2007                        00165801
003800*                CBSA FILE PROCESSING DRIVER CALL TO HOSPR081     00165901
003900*     HOSOP081   NEW PROCESSES OCT 1, 2007                        00166001
004000*                CICS VERSION OPENS FILES CALL TO HOSDR081        00166101
004100*                                                                 00166201
004200*     HOSPR071   REVISIONS FOR OCT 1, 2006                        00166301
004300*                2007.1-PROCESS-DATA 1UNIT = 15 MIN CODE 652      00166401
004400*                2007 CALCULATE HOME RATE BY REVENUE CODE FACTORS 00166501
004500*     HOSDR071   NEW PROCESSES OCT 1, 2006                        00166601
004600*                CBSA FILE PROCESSING DRIVER CALL TO HOSPR071     00166701
004700*     HOSOP071   NEW PROCESSES OCT 1, 2006                        00166801
004800*                CICS VERSION OPENS FILES CALL TO HOSDR071        00166901
004900*                                                                 00167001
005000*     HOSPR070   REVISIONS FOR OCT 1, 2006                        00167101
005100*                2007-PROCESS-DATA                                00167201
005200*                2007 CALCULATE HOME RATE BY REVENUE CODE FACTORS 00167301
005300*     HOSDR070   NEW PROCESSES OCT 1, 2006                        00167401
005400*                CBSA FILE PROCESSING DRIVER                      00167501
005500*     HOSOP070   NEW PROCESSES OCT 1, 2006                        00167601
005600*                CICS VERSION OPENS FILES                         00167701
005700*                                                                 00167801
005800***************************************************************   00167901
005900 DATE-COMPILED.                                                   00168001
006000 ENVIRONMENT DIVISION.                                            00168101
006100 CONFIGURATION SECTION.                                           00168201
006200 SOURCE-COMPUTER.            IBM-370.                             00168301
006300 OBJECT-COMPUTER.            IBM-370.                             00168401
006400 INPUT-OUTPUT  SECTION.                                           00168501
006500 FILE-CONTROL.                                                    00168601
006600                                                                  00168701
006700     SELECT BILLFILE ASSIGN TO UT-S-BILLFILE                      00168801
006800           FILE STATUS IS UT1-STAT.                               00168901
006900     SELECT RATEFILE  ASSIGN TO UT-S-RATEFILE                     00169000
007000           FILE STATUS IS UT2-STAT.                               00170000
007100     SELECT MSAFILE  ASSIGN TO UT-S-MSAFILE                       00180000
007200           FILE STATUS IS UT3-STAT.                               00190000
007300     SELECT PROVFILE  ASSIGN TO UT-S-PROVFILE                     00200000
007400           FILE STATUS IS UT4-STAT.                               00210000
007500     SELECT CBSAFILE  ASSIGN TO UT-S-CBSAFILE                     00220000
007600           FILE STATUS IS UT5-STAT.                               00230000
007700                                                                  00240000
007800                                                                  00250000
007900 DATA DIVISION.                                                   00260000
008000 FILE SECTION.                                                    00270000
008100                                                                  00280000
008200 FD  BILLFILE                                                     00290000
008300     LABEL RECORDS ARE STANDARD                                   00300000
008400     RECORDING MODE IS F                                          00310000
008500     BLOCK CONTAINS 0 RECORDS.                                    00320000
008600 01  BILL-REC              PIC X(215).                            00330007
008700                                                                  00340000
008800 FD  RATEFILE                                                     00350000
008900     LABEL RECORDS ARE STANDARD                                   00360000
009000     RECORDING MODE IS F                                          00370000
009100     BLOCK CONTAINS 0 RECORDS.                                    00380000
009200 01  RATE-REC              PIC X(215).                            00390007
009300                                                                  00400000
009400 FD  MSAFILE                                                      00410000
009500     LABEL RECORDS ARE STANDARD                                   00420000
009600     RECORDING MODE IS F                                          00430000
009700     BLOCK CONTAINS 0 RECORDS.                                    00440000
009800 01  MSA-REC.                                                     00450000
009900     05  IN-MSA          PIC 9(04).                               00460000
010000     05  IN-LUGAR        PIC X(01).                               00470000
010100     05  FILLER          PIC X.                                   00480000
010200     05  IN-EFFDTE       PIC X(08).                               00490000
010300     05  FILLER          PIC X.                                   00500000
010400     05  IN-WAGE-IND     PIC 9(02)V9(04).                         00510000
010500     05  FILLER          PIC X.                                   00520000
010600     05  IN-STCNTY       PIC X(05).                               00530000
010700     05  FILLER          PIC X.                                   00540000
010800     05  IN-MSANAME      PIC X(22).                               00550000
010900                                                                  00560000
011000 FD  CBSAFILE                                                     00570000
011100     LABEL RECORDS ARE STANDARD                                   00580000
011200     RECORDING MODE IS F                                          00590000
011300     BLOCK CONTAINS 0 RECORDS.                                    00600000
011400 01  F-CBSA-REC.                                                  00610000
011500     05  F-CBSA           PIC X(05).                              00620000
011600     05  FILLER           PIC X.                                  00630000
011700     05  F-CBSA-EFFDTE    PIC X(08).                              00640000
011800     05  FILLER           PIC X.                                  00650000
011900     05  F-CBSA-WAGE-IND  PIC 9(02)V9(04).                        00660000
012000     05  FILLER           PIC X.                                  00670000
012100     05  F-CBSA-STCNTY    PIC X(06).                              00680000
012200     05  FILLER           PIC X.                                  00690000
012300     05  F-CBSANAME       PIC X(39).                              00700000
012400     05  FILLER           PIC X(12).                              00710000
012500                                                                  00720000
012600 FD  PROVFILE                                                     00730000
012700     LABEL RECORDS ARE STANDARD                                   00740000
012800     RECORDING MODE IS F                                          00750000
012900     BLOCK CONTAINS 0 RECORDS.                                    00760000
013000 01  PROV-REC.                                                    00770000
013100     05  PROV-PART1            PIC X(80).                         00780000
013200     05  PROV-PART2            PIC X(80).                         00790000
013300     05  PROV-PART3            PIC X(80).                         00800000
013400                                                                  00810000
013500 WORKING-STORAGE SECTION.                                         00820000
013600 01  W-STORAGE-REF                  PIC X(46)  VALUE              00830000
013700     'HOSOP140      - W O R K I N G   S T O R A G E'.             00840002
013800 01  HOS-VERSION                    PIC X(09)  VALUE 'HOSOP14.0'. 00850002
013900 01  HOSPR140                       PIC X(08)  VALUE 'HOSPR140'.  00860002
014000 01  HOSDR140                       PIC X(08)  VALUE 'HOSDR140'.  00870002
014100 01  EOF-MSA-SW                     PIC 9(01) VALUE 0.            00880000
014200 01  EOF-CBSA-SW                    PIC 9(01) VALUE 0.            00890000
014300 01  EOF-BILL-SW                    PIC 9(01) VALUE 0.            00900000
014400 01  EOF-PROV-SW                    PIC 9(01) VALUE 0.            00910000
014500 01  BILL-CTR                       PIC 9(09) VALUE 0.            00920000
014500 01  CBSA-CTR                       PIC 9(09) VALUE 0.            00921011
014600 01  RATE-CTR                       PIC 9(09) VALUE 0.            00930000
014700 01  PROV-CTR                       PIC 9(09) VALUE 0.            00940000
014800                                                                  00950000
014900 01  SEARCH-MSA-LUGAR.                                            00960000
015000     05  SEARCH-MSA.                                              00970000
015100         10  SEARCH-MSA-POS12     PIC 9(02).                      00980000
015200         10  SEARCH-MSA-POS34     PIC 9(02).                      00990000
015300     05  SEARCH-LUGAR    PIC X.                                   01000000
015400                                                                  01010000
015500 01  SEARCH-CBSA.                                                 01020000
015600     05  SEARCH-CBSA-POS123    PIC 9(03).                         01030000
015700     05  SEARCH-CBSA-POS45     PIC 9(02).                         01040000
015800                                                                  01050000
015900 01  UT1-STAT.                                                    01060000
016000     05  UT1-STAT1       PIC X.                                   01070000
016100     05  UT1-STAT2       PIC X.                                   01080000
016200 01  UT2-STAT.                                                    01090000
016300     05  UT2-STAT1       PIC X.                                   01100000
016400     05  UT2-STAT2       PIC X.                                   01110000
016500 01  UT3-STAT.                                                    01120000
016600     05  UT3-STAT1       PIC X.                                   01130000
016700     05  UT3-STAT2       PIC X.                                   01140000
016800 01  UT4-STAT.                                                    01150000
016900     05  UT4-STAT1       PIC X.                                   01160000
017000     05  UT4-STAT2       PIC X.                                   01170000
017100 01  UT5-STAT.                                                    01180000
017200     05  UT5-STAT1       PIC X.                                   01190000
017300     05  UT5-STAT2       PIC X.                                   01200000
017400                                                                  01210000
017500******************************************************************01220000
017600*                                                                 01230000
017700*    FILE MUST BE PROV-NO EFF-DATE SEQUENCE                       01240000
017800*                                                                 01250000
017900******************************************************************01260000
018000                                                                  01270000
018100 01  PROV-TABLE.                                                  01280000
018200     02  PROV-ENTRIES               OCCURS 2400                   01290000
018300                                    ASCENDING KEY IS PROV-NO      01300000
018400                                    INDEXED BY PX1 PX2 PX3.       01310000
018500         10  PROV-DATA1.                                          01320000
018600             15  PROV-NPI10.                                      01330000
018700                 20  PROV-NPI8     PIC X(08).                     01340000
018800                 20  PROV-NPI-FIL  PIC X(02).                     01350000
018900             15  PROV-NO           PIC X(06).                     01360000
019000             15  PROV-EFF-DATE     PIC X(08).                     01370000
019100             15  FILLER            PIC X(56).                     01380000
019200                                                                  01390000
019300 01  PROV-DATA-2.                                                 01400000
019400     02  PROV-ENTRIES2              OCCURS 2400                   01410000
019500                                    INDEXED BY PD2.               01420000
019600         10  PROV-DATA2            PIC X(80).                     01430000
019700                                                                  01440000
019800 01  PROV-DATA-3.                                                 01450000
019900     02  PROV-ENTRIES3              OCCURS 2400                   01460000
020000                                    INDEXED BY PD3.               01470000
020100         10  PROV-DATA3            PIC X(80).                     01480000
020200                                                                  01490000
020300***************************************************************   01500000
020400**************************************************************    01510000
020500*      MILLINNIUM COMPATIBLE                                 *    01520000
020600**************************************************************    01530000
020700 01  PROV-NEW-HOLD.                                               01540000
020800     02  PROV-NEWREC-HOLD1.                                       01550000
020900         05  P-NEW-NPI10.                                         01560000
021000             10  P-NEW-NPI8             PIC X(08).                01570000
021100             10  P-NEW-NPI-FILLER       PIC X(02).                01580000
021200         05  P-NEW-PROVIDER-NO.                                   01590000
021300             10  P-NEW-STATE            PIC 9(02).                01600000
021400             10  FILLER                 PIC X(04).                01610000
021500         05  P-NEW-DATE-DATA.                                     01620000
021600             10  P-NEW-EFF-DATE.                                  01630000
021700                 15  P-NEW-EFF-DT-CC    PIC 9(02).                01640000
021800                 15  P-NEW-EFF-DT-YY    PIC 9(02).                01650000
021900                 15  P-NEW-EFF-DT-MM    PIC 9(02).                01660000
022000                 15  P-NEW-EFF-DT-DD    PIC 9(02).                01670000
022100             10  P-NEW-FY-BEGIN-DATE.                             01680000
022200                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                01690000
022300                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                01700000
022400                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                01710000
022500                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                01720000
022600             10  P-NEW-REPORT-DATE.                               01730000
022700                 15  P-NEW-REPORT-DT-CC PIC 9(02).                01740000
022800                 15  P-NEW-REPORT-DT-YY PIC 9(02).                01750000
022900                 15  P-NEW-REPORT-DT-MM PIC 9(02).                01760000
023000                 15  P-NEW-REPORT-DT-DD PIC 9(02).                01770000
023100             10  P-NEW-TERMINATION-DATE.                          01780000
023200                 15  P-NEW-TERM-DT-CC   PIC 9(02).                01790000
023300                 15  P-NEW-TERM-DT-YY   PIC 9(02).                01800000
023400                 15  P-NEW-TERM-DT-MM   PIC 9(02).                01810000
023500                 15  P-NEW-TERM-DT-DD   PIC 9(02).                01820000
023600         05  P-NEW-WAIVER-CODE          PIC X(01).                01830000
023700             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              01840000
023800         05  P-NEW-INTER-NO             PIC 9(05).                01850000
023900         05  P-NEW-PROVIDER-TYPE        PIC X(02).                01860000
024000             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.      01870000
024100             88  P-N-REFERRAL-CENTER        VALUE '07' '11'       01880000
024200                                                  '15' '17'       01890000
024300                                                  '22'.           01900000
024400             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.           01910000
024500             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.           01920000
024600             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.           01930000
024700             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.           01940000
024800             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.      01950000
024900             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.           01960000
025000             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.      01970000
025100             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.           01980000
025200             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.           01990000
025300             88  P-N-EACH                   VALUE '21' '22'.      02000000
025400             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.           02010000
025500             88  P-N-NHCMQ-II-SNF           VALUE '32'.           02020000
025600             88  P-N-NHCMQ-III-SNF          VALUE '33'.           02030000
025700         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                02040000
025800             88  P-N-NEW-ENGLAND            VALUE  1.             02050000
025900             88  P-N-MIDDLE-ATLANTIC        VALUE  2.             02060000
026000             88  P-N-SOUTH-ATLANTIC         VALUE  3.             02070000
026100             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.             02080000
026200             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.             02090000
026300             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.             02100000
026400             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.             02110000
026500             88  P-N-MOUNTAIN               VALUE  8.             02120000
026600             88  P-N-PACIFIC                VALUE  9.             02130000
026700         05  P-NEW-CURRENT-DIV   REDEFINES                        02140000
026800                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         02150000
026900             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.          02160000
027000         05  P-NEW-MSA-DATA.                                      02170000
027100             10  P-NEW-CHG-CODE-INDEX       PIC X.                02180000
027200             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 02190000
027300             10  P-NEW-GEO-LOC-MSAX-RUR REDEFINES                 02200000
027400                                     P-NEW-GEO-LOC-MSAX.          02210000
027500                 15  P-NEW-RURAL1    PIC X(02).                   02220000
027600                     88  P-NEW-GEO-RURAL1   VALUE '  '.           02230000
027700                 15  P-NEW-GEO-RURAL2    PIC X(02).               02240000
027800             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   02250000
027900                             P-NEW-GEO-LOC-MSAX-RUR PIC 9(04).    02260000
028000             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 02270000
028100             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 02280000
028200             10  P-NEW-STAND-AMT-LOC-MSA9                         02290000
028300       REDEFINES P-NEW-STAND-AMT-LOC-MSA.                         02300000
028400                 15  P-NEW-RURAL-1ST.                             02310000
028500                     20  P-NEW-STAND-RURAL  PIC XX.               02320000
028600                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    02330000
028700                 15  P-NEW-RURAL-2ND        PIC XX.               02340000
028800         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    02350000
028900                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           02360000
029000                 88  P-NEW-SCH-YR82       VALUE   '82'.           02370000
029100                 88  P-NEW-SCH-YR87       VALUE   '87'.           02380000
029200         05  P-NEW-LUGAR                    PIC X.                02390000
029300         05  P-NEW-TEMP-RELIEF-IND          PIC X.                02400000
029400         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                02410000
029500         05  FILLER                         PIC X(05).            02420000
029600     02  PROV-NEWREC-HOLD2.                                       02430000
029700         05  P-NEW-VARIABLES.                                     02440000
029800             10  P-NEW-FAC-SPEC-RATE       PIC 9(05)V9(02).       02450000
029900             10  P-NEW-COLA                PIC 9(01)V9(03).       02460000
030000             10  P-NEW-INTERN-RATIO        PIC 9(01)V9(04).       02470000
030100             10  P-NEW-BED-SIZE            PIC 9(05).             02480000
030200             10  P-NEW-OPER-CSTCHG-RATIO   PIC 9(01)V9(03).       02490000
030300             10  P-NEW-CMI                 PIC 9(01)V9(04).       02500000
030400             10  P-NEW-SSI-RATIO           PIC V9(04).            02510000
030500             10  P-NEW-MEDICAID-RATIO      PIC V9(04).            02520000
030600             10  P-NEW-PPS-BLEND-YR-IND    PIC X(01).             02530000
030700             10  P-NEW-PRUP-UPDATE-FACTOR  PIC 9(01)V9(05).       02540000
030800             10  P-NEW-DSH-PERCENT         PIC V9(04).            02550000
030900             10  P-NEW-FYE-DATE            PIC 9(08).             02560000
031000         05  P-NEW-CBSA-DATA.                                     02570000
031100             10  W-P-NEW-CBSA-SPEC-PAY-IND     PIC X.             02580000
035200                 88  P-NEW-CBSA-WI-GEO        VALUE 'N'.          02590000
031300                 88  P-NEW-CBSA-WI-RECLASS    VALUE 'Y'.          02600000
031400                 88  P-NEW-CBSA-WI-SPECIAL    VALUE '1' '2'.      02610000
031500***                  1 = ANYTHING OR HOLD HARMLESS WITH SPEC WI   02620000
031600***                  2 = RECLASS WITH SPEC WI                     02630000
031700             10  W-P-NEW-CBSA-HOSP-QUAL-IND    PIC X.             02640000
031800                                                                  02650000
031900             10  W-P-NEW-CBSA-GEO-LOC       PIC X(05) JUST RIGHT. 02660000
032000             10  W-P-NEW-CBSA-GEO-RURAL REDEFINES                 02670000
032100                 W-P-NEW-CBSA-GEO-LOC.                            02680000
032200                 15  W-P-NEW-CBSA-GEO-RURAL1ST PIC XXX.           02690000
032300                     88  W-P-NEW-CBSA-GEO-RURAL1  VALUE '   '.    02700000
032400                 15  W-P-NEW-CBSA-GEO-RURAL2ND PIC XX.            02710000
032500                                                                  02711000
032600             10  W-P-NEW-CBSA-RECLASS-LOC   PIC X(05) JUST RIGHT. 02712000
032700             10  W-P-NEW-CBSA-STAND-AMT-LOC PIC X(05) JUST RIGHT. 02713000
032800             10  W-P-NEW-CBSA-SPEC-WAGE-INDEX  PIC 9(02)V9(04).   02714000
032900     02  PROV-NEWREC-HOLD3.                                       02715000
033000         05  P-NEW-PASS-AMT-DATA.                                 02716000
033100             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          02717000
033200             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          02718000
033300             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          02719000
033400             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          02720000
033500         05  P-NEW-CAPI-DATA.                                     02730000
033600             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 02740000
033700             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          02750000
033800             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          02760000
033900             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        02770000
034000             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             02780000
034100             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 02790000
034200             15  P-NEW-CAPI-IME            PIC 9V9999.            02800000
034300             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          02810000
034400             15  P-VAL-BASED-PURCH-SCORE   PIC 9V999.             02820000
034500         05  FILLER                        PIC X(18).             02830000
034600******************************************************************02840000
034700***************************************************************   02850000
034800 01  MSA-WI-TABLE.                                                02860000
034900     05  M-MSA-DATA              OCCURS 4000                      02870013
035000                                 INDEXED BY MU1 MU2 MU3.          02880000
035100         10  MSA-MSA-LUGAR.                                       02890000
035200             15  MSA-MSA       PIC 9(04).                         02900000
035300             15  MSA-LUGAR     PIC X.                             02910000
035400         10  MSA-EFFDTE        PIC X(08).                         02920000
035500         10  MSA-WAGE-IND      PIC S9(02)V9(04).                  02930000
035600                                                                  02940000
035700***************************************************************   02950000
035800***************************************************************   02960000
035900 01  CBSA-WI-TABLE.                                               02970000
036000     05  M-CBSA-DATA              OCCURS 6000                     02980013
036100                                 INDEXED BY CU1 CU2 CU3.          02990000
036200         10  M-CBSA              PIC 9(05).                       03000000
036300         10  M-CBSA-EFFDTE       PIC X(08).                       03010000
036400         10  M-CBSA-WAGE-IND     PIC S9(02)V9(04).                03020000
036500                                                                  03030000
036600***************************************************************   03040000
036700*                 * * * * * * * * *                           *   03050000
036800***************************************************************   03060000
036900***************************************************************   03070000
037000*    THIS DATA IS CALCULATED BY THIS HOSPRICER PROGRAM        *   03080000
037100*    AND PASSED BACK                                          *   03090000
037200*            RETURN CODE VALUES (HLD-RTC)                     *   03100000
037300*                                                             *   03110000
037400*            HLD-RTC                                          *   03120000
037500*              00 = HOME RATE RETURNED                        *   03130000
037600*                                                             *   03140000
037700*            HLD-RTC   NO RATE RETURNED                       *   03150000
037800*              10 = BAD UNITS                                 *   03160000
037900*                                                             *   03170000
038000*              20 = BAD UNITS2 < 8                            *   03180000
038100*                                                             *   03190000
038200*              30 = BAD MSA CODE OR CBSA CODE                 *   03200000
038300*                                                             *   03210000
038400*              40 = BAD HOSPICE WAGE INDEX FROM MSAFILE       *   03220000
038500*                                                             *   03230000
038600*              50 = BAD BENE    WAGE INDEX FROM MSAFILE       *   03240000
038700*                                                             *   03250000
038800*              51 = BAD PROV NUMBER                           *   03260000
038900*                                                             *   03270000
039000***************************************************************   03280000
039100 01  HOLD-BILL-DATA.                                              03290000
039200     10  HLD-NPI                  PIC X(10).                      03300000
039300     10  HLD-PROV-NO              PIC X(06).                      03310000
039400     10  HLD-FROM-DATE-ALL.                                       03320000
039500         15  HLD-FROM-CC          PIC 99.                         03330000
039600         15  HLD-FROM-DATE.                                       03340000
039700             20  HLD-FROM-YY      PIC 99.                         03350000
039800             20  HLD-FROM-MM      PIC 99.                         03360000
039900             20  HLD-FROM-DD      PIC 99.                         03370000
040000*                                                                 03370107
035700     10  FILLER-1                 PIC X(08).                      03371009
040000*                                                                 03380000
040100     10  HLD-PROV-MSA-LUGAR.                                      03390000
040200         15  HLD-PROV-MSA         PIC X(04).                      03400000
040300         15  HLD-PROV-LUGAR       PIC X.                          03410000
040400     10  HLD-PROV-CBSA REDEFINES                                  03420000
040500                       HLD-PROV-MSA-LUGAR PIC X(05).              03430000
040600*                                                                 03440000
040700     10  HLD-BENE-MSA-LUGAR.                                      03450000
040800         15  HLD-BENE-MSA         PIC X(04).                      03460000
040900         15  HLD-BENE-LUGAR       PIC X.                          03470000
041000     10  HLD-BENE-CBSA REDEFINES                                  03480000
041100                       HLD-BENE-MSA-LUGAR PIC X(05).              03490000
035500*                                                                 03491002
035700     10  FILLER-2                 PIC X(10).                      03492009
041200*                                                                 03500000
041300     10  HLD-PROV-WAGE-IND        PIC 9(02)V9(04).                03510000
041400     10  HLD-BENE-WAGE-IND        PIC 9(02)V9(04).                03520000
035500*                                                                 03521002
035700     10  FILLER-3                 PIC X(20).                      03522009
035500*                                                                 03523002
035700     10  HLD-QIP-REDUCTION-IND    PIC X.                          03524003
035500*                                                                 03525002
041500     10  HLD-GROUP1.                                              03530000
041600         15  HLD-REV1             PIC XXXX.                       03540000
036000         15  HLD-HCPC1            PIC X(05).                      03541002
041700         15  HLD-UNITS1           PIC 9(07).                      03550000
041800         15  HLD-THEIR-PAY-CHG1   PIC 9(06)V99.                   03560000
041900     10  HLD-GROUP2.                                              03570000
042000         15  HLD-REV2             PIC XXXX.                       03580000
036000         15  HLD-HCPC2            PIC X(05).                      03581002
042100         15  HLD-UNITS2           PIC 9(07).                      03590000
042200         15  HLD-THEIR-PAY-CHG2   PIC 9(06)V99.                   03600000
042300     10  HLD-GROUP3.                                              03610000
042400         15  HLD-REV3             PIC XXXX.                       03620000
036000         15  HLD-HCPC3            PIC X(05).                      03621002
042500         15  HLD-UNITS3           PIC 9(07).                      03630000
042600         15  HLD-THEIR-PAY-CHG3   PIC 9(06)V99.                   03640000
042700     10  HLD-GROUP4.                                              03650000
042800         15  HLD-REV4             PIC XXXX.                       03660000
036000         15  HLD-HCPC4            PIC X(05).                      03661002
042900         15  HLD-UNITS4           PIC 9(07).                      03670000
043000         15  HLD-THEIR-PAY-CHG4   PIC 9(06)V99.                   03680000
043100     10  HLD-RETURNED-DATA.                                       03690000
043200         15  HLD-PAY-AMT          PIC 9(06)V99.                   03700000
043300         15  HLD-RTC              PIC XX.                         03710000
043400     10  FILLER-4                 PIC X(24).                      03720009
043500                                                                  03730000
043600***************************************************************   03740000
043600***************************************************************   03741002
043700                                                                  03750000
043800 PROCEDURE DIVISION.                                              03760000
043900 0100-OPEN-FILES.                                                 03770000
044000     OPEN INPUT MSAFILE                                           03780000
044100                PROVFILE                                          03790000
044200                BILLFILE                                          03800000
044300                CBSAFILE.                                         03810000
043700                                                                  03811000
044400     OPEN OUTPUT RATEFILE.                                        03820000
044500***************************************************************   03830000
044600***************************************************************   03840000
044800                                                                  03841000
044700     PERFORM 2000-LOAD-FILES                                      03850000
044700        THRU 2000-EXIT.                                           03851000
044800                                                                  03860000
044900     CLOSE MSAFILE.                                               03870000
045000     CLOSE PROVFILE.                                              03880000
045100     CLOSE CBSAFILE.                                              03890000
045200                                                                  03900000
045300     IF PROV-CTR > 2399                                           03910012
045300        GO TO 0150-EOJ.                                           03910112
045200                                                                  03910212
045300     IF CBSA-CTR > 5999                                           03911014
045300        GO TO 0150-EOJ.                                           03912012
045400                                                                  03920000
045500     PERFORM 0200-PROCESS-RECORDS                                 03930000
045500        THRU 0200-EXIT                                            03931000
045600                 UNTIL EOF-BILL-SW = 1.                           03940000
045700 0150-EOJ.                                                        03950000
045800     DISPLAY ' '.                                                 03960000
045900     DISPLAY '-- HOSPICE PROGRAM  VERSION ==> ' HOS-VERSION.      03970000
046000     DISPLAY '-- HOSPICE PROGRAM  VERSION ==> HOSDR14.0'.         03980002
046100     DISPLAY '-- HOSPICE PROGRAM  VERSION ==> HOSPR14.0'.         03990002
046200     DISPLAY ' '.                                                 04000000
046300     DISPLAY '-- INPUT  COUNT FOR CBSA          ===> ' CBSA-CTR.  04010012
046300     DISPLAY '-- INPUT  COUNT FOR PROVIDER FILE ===> ' PROV-CTR.  04011012
046400     DISPLAY '-- INPUT  COUNT FOR BILL FILE     ===> ' BILL-CTR.  04020000
046500     DISPLAY '-- OUTPUT COUNT FOR RATE FILE     ===> ' RATE-CTR.  04030000
046600     CLOSE BILLFILE.                                              04040000
046700     CLOSE RATEFILE.                                              04050000
046800     STOP RUN.                                                    04060000
046900                                                                  04070000
047000 0200-PROCESS-RECORDS.                                            04080000
047100     READ BILLFILE                                                04090000
047200             AT END                                               04100006
047200                MOVE 1         TO EOF-BILL-SW.                    04101006
047300     MOVE BILL-REC             TO HOLD-BILL-DATA.                 04110002
047400     MOVE ALL '0'              TO HLD-RETURNED-DATA.              04120000
047500     IF EOF-BILL-SW = 0                                           04130000
047600           ADD 1               TO BILL-CTR                        04140000
047700           PERFORM 0300-PROCESS-DATA                              04150000
047700              THRU 0300-EXIT.                                     04151000
047800                                                                  04160000
047900 0200-EXIT.  EXIT.                                                04170000
048000                                                                  04180000
048100 0300-PROCESS-DATA.                                               04190000
048200****    GET PROV RECORD FOR HOSPICE MSA OR CBSA                   04200000
048300****    GET PROV RECORD FOR HOSPICE MSA OR CBSA                   04210000
048400                                                                  04220000
048500                                                                  04230000
048600     IF HLD-RTC NOT = 00                                          04240000
048700        PERFORM 0600-WRT-REC                                      04250000
048700           THRU 0600-EXIT                                         04251000
048800        GO TO 0300-EXIT.                                          04260000
048900                                                                  04270000
049000     IF P-NEW-EFF-DATE < 20051001 AND                             04280000
049100        HLD-FROM-DATE-ALL > 20050930                              04290000
049200        MOVE 30                TO HLD-RTC                         04300000
049800                                                                  04301000
049800                                                                  04331000
049600        PERFORM 0600-WRT-REC                                      04340000
049600           THRU 0600-EXIT                                         04341000
049700        GO TO 0300-EXIT.                                          04350000
049800                                                                  04360000
049900     PERFORM 1000-CALL                                            04370000
049900        THRU 1000-EXIT.                                           04371000
050000                                                                  04380000
050100                                                                  04390000
050200 0300-EXIT.   EXIT.                                               04400000
050300                                                                  04410000
050400                                                                  04420000
050500 0600-WRT-REC.                                                    04430000
050600      ADD 1                    TO RATE-CTR.                       04440000
050800      WRITE RATE-REC           FROM HOLD-BILL-DATA.               04460000
050900                                                                  04470000
051000 0600-EXIT.   EXIT.                                               04480000
051100                                                                  04490000
051200                                                                  04500000
051300 1000-CALL.                                                       04510000
051400                                                                  04520000
051500     CALL HOSDR140 USING HOLD-BILL-DATA                           04530005
051600                         PROV-TABLE                               04540000
051700                         PROV-DATA-2                              04550000
051800                         PROV-DATA-3                              04560000
051900                         MSA-WI-TABLE                             04570000
052000                         CBSA-WI-TABLE.                           04580000
052100                                                                  04590000
052200                                                                  04600000
052300                                                                  04610000
052400     PERFORM 0600-WRT-REC                                         04620000
052400        THRU 0600-EXIT.                                           04621000
052500                                                                  04630000
052600 1000-EXIT.   EXIT.                                               04640000
052700                                                                  04650000
052800 2000-LOAD-FILES.                                                 04660000
052500                                                                  04661000
052900     MOVE HIGH-VALUES          TO MSA-WI-TABLE.                   04670000
053000     MOVE ALL '9'              TO PROV-NEW-HOLD                   04680000
053100                                  PROV-TABLE                      04690000
053200                                  PROV-DATA-2                     04700000
053300                                  PROV-DATA-3.                    04710000
053400                                                                  04720000
053500     MOVE 0                    TO EOF-PROV-SW.                    04730000
053600     SET PX1                   TO EOF-PROV-SW.                    04740000
053700     PERFORM 2100-LOAD-PROV-FILE                                  04750000
053700        THRU 2100-EXIT                                            04751000
053800              UNTIL EOF-PROV-SW = 1.                              04760000
053900                                                                  04770000
054000     MOVE 0                    TO EOF-MSA-SW.                     04780000
054100     SET MU3                   TO EOF-MSA-SW.                     04790000
054400                                                                  04791013
054200     PERFORM 2200-LOAD-MSA-FILE                                   04800000
054200        THRU 2200-EXIT                                            04801000
054300              UNTIL EOF-MSA-SW = 1.                               04810000
054400                                                                  04820000
054500     MOVE 0                    TO EOF-CBSA-SW.                    04830002
054600     SET CU3                   TO EOF-CBSA-SW.                    04840000
054700     PERFORM 2300-LOAD-CBSA-FILE                                  04850000
054700        THRU 2300-EXIT                                            04851000
054800              UNTIL EOF-CBSA-SW = 1.                              04860000
054900                                                                  04870000
055000 2000-EXIT.  EXIT.                                                04880000
055100 2100-LOAD-PROV-FILE.                                             04890000
000000                                                                  04891002
055200     READ PROVFILE                                                04900000
055300          AT END                                                  04910000
055400             SET PX1 UP BY 1                                      04920000
055500             MOVE ALL '9'      TO PROV-DATA1 (PX1)                04930000
055600             SET PD2           TO PX1                             04940000
055700             SET PD3           TO PX1                             04950000
055800             MOVE ALL '9'      TO PROV-DATA2 (PD2)                04960000
055900             MOVE ALL '9'      TO PROV-DATA3 (PD3)                04970000
056000             MOVE '999999'     TO P-NEW-PROVIDER-NO               04980000
056100             MOVE 1            TO EOF-PROV-SW                     04990000
056200             GO TO 2100-EXIT.                                     05000000
056300                                                                  05010000
056400     ADD 1                     TO PROV-CTR.                       05020000
056500                                                                  05030000
056600     IF PROV-CTR > 2399                                           05040000
045800        DISPLAY ' '                                               05041013
045900        DISPLAY '-- HOSPICE PROGRAM  VERSION ==> ' HOS-VERSION    05042013
045800        DISPLAY ' '                                               05043013
056700        DISPLAY  ' CAN NOT PROCESS MORE THAN 2400 PROV RECORDS'   05050000
056800        DISPLAY  ' CAN NOT PROCESS MORE THAN 2400 PROV RECORDS'   05060000
056900        DISPLAY  ' CAN NOT PROCESS MORE THAN 2400 PROV RECORDS'   05070000
057000        DISPLAY  ' CAN NOT PROCESS MORE THAN 2400 PROV RECORDS'   05080000
057100        DISPLAY  ' PROVIDER FILE TO LARGE '                       05090000
057200        MOVE 1                 TO EOF-PROV-SW.                    05100000
057300                                                                  05110000
057400                                                                  05120000
057500     IF  EOF-PROV-SW = 0                                          05130000
057600         SET PX1 UP            BY 1                               05140000
057700         MOVE PROV-PART1       TO PROV-DATA1 (PX1)                05150000
057800         SET PD2               TO PX1                             05160000
057900         SET PD3               TO PX1                             05170000
058000         MOVE PROV-PART2       TO PROV-DATA2 (PD2)                05180000
058100         MOVE PROV-PART3       TO PROV-DATA3 (PD3).               05190000
058200                                                                  05200000
058300 2100-EXIT.   EXIT.                                               05210000
058400 2200-LOAD-MSA-FILE.                                              05220000
058200                                                                  05221013
058500     READ MSAFILE                                                 05230000
058600          AT END                                                  05240000
058700             MOVE 1            TO EOF-MSA-SW.                     05250000
059400                                                                  05251013
058800     IF EOF-MSA-SW = 0                                            05260000
058900        SET MU3 UP             BY 1                               05270000
059000        MOVE IN-MSA            TO MSA-MSA         (MU3)           05280000
059100        MOVE IN-LUGAR          TO MSA-LUGAR       (MU3)           05290000
059200        MOVE IN-EFFDTE         TO MSA-EFFDTE      (MU3)           05300000
059300        MOVE IN-WAGE-IND       TO MSA-WAGE-IND    (MU3).          05310000
059400                                                                  05320000
059500 2200-EXIT.  EXIT.                                                05330000
059600                                                                  05340000
059700 2300-LOAD-CBSA-FILE.                                             05350000
059800     READ CBSAFILE                                                05360000
059900          AT END                                                  05370000
060000             MOVE 1            TO EOF-CBSA-SW.                    05380000
056300                                                                  05381011
056400     ADD 1                     TO CBSA-CTR.                       05382011
056500                                                                  05383011
056600     IF CBSA-CTR > 5999                                           05384013
045800        DISPLAY ' '                                               05384113
045900        DISPLAY '-- HOSPICE PROGRAM  VERSION ==> ' HOS-VERSION    05384213
045800        DISPLAY ' '                                               05384313
056700        DISPLAY  ' CAN NOT PROCESS MORE THAN 6000 CBSA RECORDS'   05385013
056800        DISPLAY  ' CAN NOT PROCESS MORE THAN 6000 CBSA RECORDS'   05386013
056900        DISPLAY  ' CAN NOT PROCESS MORE THAN 6000 CBSA RECORDS'   05387013
057000        DISPLAY  ' CAN NOT PROCESS MORE THAN 6000 CBSA RECORDS'   05388013
057100        DISPLAY  ' CBSA FILE TO LARGE '                           05389011
057200        MOVE 1                 TO EOF-CBSA-SW.                    05389111
057300                                                                  05389211
060100     IF EOF-CBSA-SW = 0                                           05390000
060200        SET CU3 UP             BY 1                               05400000
060300        MOVE F-CBSA            TO M-CBSA          (CU3)           05410000
060400        MOVE F-CBSA-EFFDTE     TO M-CBSA-EFFDTE   (CU3)           05420000
060500        MOVE F-CBSA-WAGE-IND   TO M-CBSA-WAGE-IND (CU3).          05430000
060600                                                                  05440000
060700 2300-EXIT.  EXIT.                                                05450000
060800******        L A S T   S O U R C E   S T A T E M E N T   *****   05460000
060900***************************************************************   05470000
