000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID. LTDRV130.                                            00020000
000400*AUTHOR.     CENTERS FOR MEDICARE AND MEDICAID SERVICES           00030000
000500*REMARKS.    - FINDS WAGE-INDEX RECORD(S) FOR GIVEN BILL TO       00040000
000600*              BE PASSED TO LTCAL___ MODULES                      00050000
000700*            - LOADS THE PPS TABLES                               00060000
000800*            - CALLS THE LTCAL___ MODULES                         00070000
000900 DATE-COMPILED.                                                   00080000
001000****************************************************************  00090000
001100*   THIS SUBROUTINE IS FURNISHED BY THE CENTERS FOR MEDICARE   *  00100000
001200*   AND MEDICAID SERVICES.                                     *  00110000
001300*   IT IS TO BE USED AS AN AID IN IMPLEMENTING PROSPECTIVE     *  00120000
001400*   PAYMENT FOR LONG TERM CARE HOSPITALS.                      *  00130000
001500*   THE RESPONSIBILITY FOR INSTALLING, MODIFYING, TESTING,     *  00140000
001600*   MAINTAINING, AND VERIFYING THE ACCURACY OF THIS PROGRAM    *  00150000
001700*   IS THAT OF THE USER.                                       *  00160000
001800*                  *  *  *  *  *  *  *  *                      *  00170000
001900*   ONCE GROUPED THE PROSPECTIVE PAYMENT SUBROUTINE IS CALLED  *  00180000
002000*   TO CALCULATE THE TOTAL PAYMENT PRIOR TO DEDUCTIBLE,        *  00190000
002100*   CO-INSURANCE, AND CASES WHERE MEDICARE IS SECONDARY PAYOR. *  00200000
002200*   THE PROGRAM WILL:                                          *  00210000
002300*       1. EDIT THE BILL INFORMATION.                          *  00220000
002400*       2. PASS BACK RETURN CODES.                             *  00230000
002500*       3. CALCULATE WHEN APPLICABLE:                          *  00240000
002600*          A. THE HOSPITAL SPECIFIC PART OF PAYMENT.           *  00250000
002700*          B. THE FEDERAL SPECIFIC PART OF PAYMENT.            *  00260000
002800*          C. THE OUTLIER PORTION.                             *  00270000
002900*          D. TOTAL PAYMENT (B + C + D  ABOVE).                *  00280000
003000*                                                              *  00290000
003100*                  *  *  *  *  *  *  *  *                      *  00300000
003200*   THIS SUBROUTINE CALCULATES THE PROVIDER SPECIFIC           *  00310000
003300*   ELEMENTS ON A PROVIDER BREAK, THEREFORE IT WILL RUN FASTER *  00320000
003400*   WHEN BILLS ARE BATCHED BY PROVIDER.                        *  00330000
003500*                  *  *  *  *  *  *  *  *                      *  00340000
003600*                                                              *  00350000
003700*--------------------------------------------------------------*  00360000
003800*   CHANGE LOG.                                                *  00370000
003900*--------------------------------------------------------------*  00380000
004000*                                                              *  00390000
004100*   04/07/2005 - AT THE REQUEST OF FISS, LTSEL___ CREATED.     *  00400000
004200*                THIS PROGRAM IS CALLED BY LTDRV___ AND        *  00410000
004300*                RECEIVES THE PROVIDER RECORD, CBSA TABLE,     *  00420000
004400*                BILL RECORD, AND PPS DATA.  IT GETS THE       *  00430000
004500*                APPROPRIATE CBSA RECORD AND CALLS THE         *  00440000
004600*                APPROPRIATE LTCAL___ MODULE FOR THE BILL      *  00450000
004700*                                                              *  00460000
004800*--------------------------------------------------------------*  00470000
004900*                                                              *  00480000
005000*   04/21/2005 - EFFECTIVE JULY 1, 2005, CBSA (CORE-BASED      *  00490000
005100*                STATISTICAL AREA) IS USED IN PLACE OF MSA     *  00500000
005200*                (METROPOLITAN STATISTICAL AREA), THE PROGRAM  *  00510000
005300*                DETERMINES WHETHER TO USE THE CBSA WAGE INDEX *  00520000
005400*                FILE OR MSA WAGE INDEX FILE BASED ON THE BILL *  00530000
005500*                DISCHARGE DATE                                *  00540000
005600*                                                              *  00550000
005700*--------------------------------------------------------------*  00560000
005800*                                                              *  00570000
005900*   05/02/2005 - ADDED PSF FIELDS - SPECIAL PAY INDICATOR &    *  00580000
006000*                SPECIAL WAGE INDEX                            *  00590000
006100*                                                              *  00600000
006200*--------------------------------------------------------------*  00610000
006300*                                                              *  00620000
006400*   12/07/2005 - REMOVED TIME RESTRAINT FROM THE CALL TO THE   *  00630000
006500*                LATEST VERSION OF THE LTCAL PROGRAM           *  00640000
006600*                                                              *  00650000
006700*--------------------------------------------------------------*  00660000
006800*                                                              *  00670000
006900*   01/17/2006 - MODIFIED FOR 1ST CICS PACKAGE RELEASE;        *  00680000
007000*                FOR APRIL 1, 2006 RELEASE                     *  00690000
007100*                                                              *  00700000
007200*--------------------------------------------------------------*  00710000
007300*                                                              *  00720000
007400*   01/19/2006 - PROGRAM NAME CHANGED FROM LTSEL___ TO LTDRV___*  00730000
007500*                                                              *  00740000
007600*--------------------------------------------------------------*  00750000
007700*                                                              *  00760000
007800*   05/03/2006 - MODIFY PROGRAM FOR JULY 2006 RELEASE:         *  00770000
007900*                ADD LTCAL071 CALL, ADD IPPS CBSA WAGE INDEX   *  00780000
008000*                TABLE STORAGE & LOGIC.  DELETED LAYOUT FOR    *  00790000
008100*                W-PROV-NEW-HOLD - NOT NEEDED.                 *  00800000
008200*                IPPS WAGE INDEX LOGIC: ONLY THE IPPS CBSA     *  00810000
008300*                FLOOR POLICY IS APPLIED WHEN ASSIGNING THE    *  00820000
008400*                IPPS WAGE INDEX.  PUERTO RICO HOSPITALS ARE   *  00830000
008500*                GIVEN THE NATIONAL AND PUERTO RICO SPECIFIC   *  00840000
008600*                WAGE INDEX VALUES.                            *  00850000
008700*                                                              *  00860000
008800*--------------------------------------------------------------*  00870000
008900*                                                              *  00880000
009000*   06/15/2006 - CHANGE THE PLACEMENT OF THE MOVE OF THE PSF   *  00890000
009100*                CBSA TO THE IPPS CBSA HOLD AREA & REMOVE THAT *  00900000
009200*                MOVE FROM THE IPPS PR SEARCH LOGIC.           *  00910000
009300*                                                              *  00920000
009400*--------------------------------------------------------------*  00930000
009500*                                                              *  00940000
009600*   06/19/2006 - CHANGE THE VERSION FROM 07.0 TO 07.1          *  00950000
009700*                                                              *  00960000
009800*--------------------------------------------------------------*  00970000
009900*                                                              *  00980000
010000*   08/04/2006 - UPDATE PROGRAM FOR OCTOBER 2006 RELEASE 07.3  *  00990000
010100*                ADD FY 2007 FLOOR IF STATEMENT                *  01000000
010200*                STILL NEED TO ADD FLOOR CODE                  *  01010000
010300*                NEW VERSIONS OF LTCAL CALLED DUE TO THE SIZE  *  01020000
010400*                CHANGE OF THE FIELD: PPS-NEW-FAC-SPEC-RATE    *  01030000
010500*                FROM 9(5)V9(02) TO 9(7)V9(2).                 *  01040000
010600*                                                              *  01050000
010700*--------------------------------------------------------------*  01060000
010800*                                                              *  01070000
010900*   08/08/2006 - BECAUSE THE FY 2007 WAGE INDEX TABLE WILL NOT *  01080000
011000*                BE FINAL UNTIL LATE AUGUST, THE FOLLOWING     *  01090000
011100*                ITEMS ARE NOT INCLUDED IN VERSION 7.3 OF THE  *  01100000
011200*                LTCH PRICER:                                  *  01110000
011300*                                                              *  01120000
011400*                1) FY 2007 IPPS WAGE INDEX TABLE              *  01130000
011500*                2) FY 2007 IPPS WAGE INDEX FLOORS             *  01140000
011600*                3) FINAL FY 2007 IPPS DRG WEIGHTS             *  01150000
011700*                4) FY 2007 IPPS STANDARD RATES:               *  01160000
011800*                    H-IPPS-CAPI-STD-FED-RATE  (LTCAL073)      *  01170000
011900*                    H-IPPS-CAPI-STD-PR-RATE   (LTCAL073)      *  01180000
012000*                                                              *  01190000
012100*                FOR TESTING PURPOSES, THE FOLLOWING           *  01200000
012200*                SUBSTITUTES WERE MADE:                        *  01210000
012300*                                                              *  01220000
012400*                1) THE FY 2006 IPPS WAGE INDEX TABLE VERSION  *  01230000
012500*                   06.3 WILL BE USED IN PLACE OF THE FY 2007  *  01240000
012600*                   IPPS WAGE INDEX TABLE.                     *  01250000
012700*                2) THERE IS NO MODULE THAT ASSIGNS FY 2007    *  01260000
012800*                   IPPS WAGE INDEX FLOORS.  THE CODE THAT     *  01270000
012900*                   REFERENCES THIS FUTURE MODULE IS COMMENTED *  01280000
013000*                   OUT.                                       *  01290000
013100*                3) THE CURRENT FY 2007 DRG WEIGHTS ARE USED.  *  01300000
013200*                   THESE MAY OR MAY NOT CHANGE.               *  01310000
013300*                4) THE FY 2006 IPPS STANDARD RATES ARE USED.  *  01320000
013400*                                                              *  01330000
013500*--------------------------------------------------------------*  01340000
013600*                                                              *  01350000
013700*   08/09/2006 - DELETED RETURN CODES 02 & 03 AND ADDED CODES  *  01360000
013800*                20, 21, 22, 23, 24, & 25 FOR SHORT STAY       *  01370000
013900*                PAYMENT DESCRIPTIONS IN PROGRAM LTCAL073.     *  01380000
014000*                                                              *  01390000
014100*--------------------------------------------------------------*  01400000
014200*                                                              *  01410000
014300*   09/06/2006 - CREATE VERSION 07.4 OF THE LTCH PPS PRICER    *  01420000
014400*                UPDATED WITH THE FOLLOWING:                   *  01430000
014500*                1) FY 2007 IPPS WAGE INDEX TABLE              *  01440000
014600*                2) FY 2007 IPPS WAGE INDEX FLOORS             *  01450000
014700*                3) FINAL FY 2007 IPPS DRG WEIGHTS             *  01460000
014800*                4) FY 2007 IPPS STANDARD RATES (LTCAL074)     *  01470000
014900*                                                              *  01480000
015000*--------------------------------------------------------------*  01490000
015100*                                                              *  01500000
015200*   11/16/2006 - CREATE VERSION 07.5 OF THE LTCH PPS PRICER    *  01510000
015300*                UPDATED WITH THE FOLLOWING:                   *  01520000
015400*                1) IME MULTIPLIER IN PROGRAM LTCAL075 CHANGED *  01530000
015500*                   FROM 1.37 TO 1.32 (TO MATCH FY2007 IPPS)   *  01540000
015600*                2) PPS RETURN CODE 23 REMOVED FROM LTCAL075   *  01550000
015700*                   BECAUSE IT COULD NEVER BE REACHED          *  01560000
015800*                3) REMOVED CBSA 27860 FROM THE FY 2007 FLOOR  *  01570000
015900*                   CODE (DUE TO IPPS CN1 WAGE INDEX CHANGE)   *  01580000
016000*                                                              *  01590000
016100*--------------------------------------------------------------*  01600000
016200*                                                              *  01610000
016300*   12/28/2006 - CREATE VERSION 07.6 OF THE LTCH PPS PRICER    *  01620000
016400*                TO CORRECT THE CBSA SIZE LOGIC.  ALWAYS USE   *  01630000
016500*                THE GEOGRAPHIC CBSA'S SIZE; STOP USING THE    *  01640000
016600*                RURAL FLOOR CBSA'S SIZE.  ALSO, CBSA 27860    *  01650000
016700*                WAS REINSTATED INTO THE FLOOR LOGIC, IGNORED  *  01660000
016800*                11/03/2006 AND AFTER.                         *  01670000
016900*                *** THIS VERSION WAS NOT RELEASED ***         *  01680000
017000*                THE NEW LOGIC IS INTRODUCED IN VERSION 08.0.  *  01690000
017100*                                                              *  01700000
017200*--------------------------------------------------------------*  01710000
017300*                                                              *  01720000
017400*   05/03/2007 - CREATE VERSION 08.0 OF THE LTCH PPS PRICER    *  01730000
017500*                UPDATED WITH THE FOLLOWING:                   *  01740000
017600*                1) LTCH WAGE INDEX TABLE - 4/5 & 5/5 COLUMNS  *  01750000
017700*                2) LTCH RATES (LTCAL080)                      *  01760000
017800*                3) NEW SSO POLICY (IPPS COMPARABLE AMT)       *  01770000
017900*                4) 25% RULE (NOT APPLIED IN PRICER)           *  01780000
018000*                5) NEW RETURN CODES 26 & 27                   *  01790000
018100*                6) NEW IPPS COMPARABLE THRESHOLD COLUMN IN    *  01800000
018200*                   DRG TABLE                                  *  01810000
018300*                7) WAGE INDEX SELECTION CODE UPDATED          *  01820000
018400*                                                              *  01830000
018500*--------------------------------------------------------------*  01840000
018600*                                                              *  01850000
018700*   08/10/2007 - CREATE VERSION 08.1 OF THE LTCH PPS PRICER    *  01860000
018800*                UPDATED WITH THE FOLLOWING FY 2008 ITEMS:     *  01870000
018900*                1) LTCH DRG TBL (W/ NEW IPPS COMP THRESHOLDS) *  01880000
019000*                2) IPPS DRG TABLE                             *  01890000
019100*                3) IPPS WAGE INDEX TABLE                      *  01900000
019200*                4) IPPS RATES (IN LTCAL081)                   *  01910000
019300*                5) IPPS WAGE INDEX FLOORS                     *  01920000
019400*                6) NEW OPERATING IME FACTOR (1.35)            *  01930000
019500*                7) 3% LARGE URBAN ADD-ON ELIMINTATED          *  01940000
019600*                8) CHANGED MESSAGE FOR RETURN CODE 98         *  01950000
019700*                                                              *  01960000
019800*--------------------------------------------------------------*  01970000
019900*                                                              *  01980000
020000*   08/22/2007 - CREATE VERSION 08.2 OF THE LTCH PPS PRICER    *  01990000
020100*                UPDATED WITH THE FOLLOWING FY 2008 ITEMS:     *  02000000
020200*                1) REVISED IPPS WAGE INDEX TABLE              *  02010000
020300*                2) REVISED IPPS RATES (IN LTCAL082)           *  02020000
020400*                VERSION 08.2 REPLACES VERSION 08.1            *  02030000
020500*                                                              *  02040000
020600*--------------------------------------------------------------*  02050000
020700*                                                              *  02060000
020800*   09/14/2007 - CREATE VERSION 08.3 OF THE LTCH PPS PRICER    *  02070000
020900*                UPDATED WITH THE FOLLOWING FY 2008 ITEMS:     *  02080000
021000*                1) REVISED IPPS WAGE INDEX TABLE              *  02090000
021100*                2) REVISED IPPS RATES (IN LTCAL083)           *  02100000
021200*                VERSION 08.3 REPLACES VERSION 08.2            *  02110000
021300*                                                              *  02120000
021400*--------------------------------------------------------------*  02130000
021500*                                                              *  02140000
021600*   09/28/2007 - CREATE VERSION 08.4 OF THE LTCH PPS PRICER    *  02150000
021700*                UPDATED WITH CONGRESS MANDATED REVISION OF    *  02160000
021800*                IPPS RATES (IN LTCAL084)                      *  02170000
021900*                VERSION 08.4 REPLACES VERSION 08.3            *  02180000
022000*                                                              *  02190000
022100*--------------------------------------------------------------*  02200000
022200*                                                              *  02210000
022300*   12/27/2007 - CREATE VERSION 08.5 OF THE LTCH PPS PRICER    *  02220000
022400*                5TH SHORT STAY OUTLIER PROVISION NO LONGER    *  02230000
022500*                AVAILABLE TO BILLS DISCHARGED ON AND AFTER    *  02240000
022600*                12/29/2007 PER A CONGRESS MANDATE             *  02250000
022700*                UPDATED LTCAL085 TO REFLECT THIS CHANGE       *  02260000
022800*                                                              *  02270000
022900*--------------------------------------------------------------*  02280000
023000*                                                              *  02290000
023100*   02/06/2008 - CREATE VERSION 08.6 OF THE LTCH PPS PRICER    *  02300000
023200*                EFFECTIVE OCT 1, 2007 (REPLACES VERSION 08.5) *  02310000
023300*                CHANGES EFFECTIVE APRIL 1, 2008:              *  02320000
023400*                 1) CHANGED LTCH STANDARD FEDERAL RATE FROM   *  02330000
023500*                    $38,356.45 TO $38,086.04 IN PGM LTCAL086  *  02340000
023600*                 2) CHANGED FIXED LOSS AMOUNT FROM $20,738.00 *  02350000
023700*                    TO $20,707.00 IN PROGRAM LTCAL086         *  02360000
023800*                THESE CHANGES WERE MADE IN ACCORD WITH        *  02370000
023900*                SECTION 114(E)(2) AND (3) OF THE MEDICARE,    *  02380000
024000*                MEDICAID AND SCHIP EXTENSION ACT OF 2007,     *  02390000
024100*                ENACTED ON DECEMBER 29, 2007.                 *  02400000
024200*                                                              *  02410000
024300*--------------------------------------------------------------*  02420000
024400*                                                              *  02430000
024500*   05/08/2008 - CREATE VERSION 09.0 OF THE LTCH PPS PRICER    *  02440000
024600*                EFFECTIVE JULY 1, 2008 (FY 2008, RY 2009)     *  02450000
024700*                CHANGES EFFECTIVE JULY 1, 2008:               *  02460000
024800*                - NEW WAGE INDEX TABLE W/ 1 WAGE INDEX COLUMN *  02470000
024900*                - ALL CLAIMS RECEIVE THE FULL WAGE INDEX      *  02480000
025000*                  REGARDLESS OF ITS PROVIDER FY BEGIN DATE    *  02490000
025100*                - ALL SHORT STAY CLAIMS ELIGIBLE FOR THE      *  02500000
025200*                  BLENDED PAYMENT, NO CLAIMS ELIGIBLE FOR     *  02510000
025300*                  THE IPPS COMPARABLE PAYMENT                 *  02520000
025400*                - NEW LTCH RATES                              *  02530000
025500*                - DISABLE CALL TO LTCAL042 (5 YEAR RULE)      *  02540000
025600*                                                              *  02550000
025700*--------------------------------------------------------------*  02560000
025800*                                                              *  02570000
025900*   05/19/2008 - CREATE VERSION 09.1 OF THE LTCH PPS PRICER    *  02580000
026000*                EFFECTIVE JULY 1, 2008 (FY 2008, RY 2009)     *  02590000
026100*                CHANGED IPPS PUERTO RICO RATES EFFECTIVE      *  02600000
026200*                RETROACTIVE TO 10/01/2007.  CREATED TWO NEW   *  02610000
026300*                LTCAL MODULES FOR THIS CHANGE:                *  02620000
026400*                1) LTCAL087: FOR CLAIMS DISCHARGED            *  02630000
026500*                   10/01/2007 - 06/30/2008, REPLACED LTCAL086 *  02640000
026600*                2) LTCAL091: FOR CLAIMS DISCHARGED            *  02650000
026700*                   07/01/2008 & AFTER, REPLACED LTCAL090      *  02660000
026800*                                                              *  02670000
026900*--------------------------------------------------------------*  02680000
027000*                                                              *  02690000
027100*   08/04/2008 - CREATE VERSION 09.2 OF THE LTCH PPS PRICER    *  02700000
027200*                EFFECTIVE OCTOBER 1, 2008 (FY 2009, RY 2009)  *  02710000
027300*                UPDATED WITH THE FOLLOWING FY 2009 ITEMS:     *  02720000
027400*                1) LTCH DRG TBL (NO IPPS COMP THRESHOLDS)     *  02730000
027500*                2) IPPS DRG TABLE                             *  02740000
027600*                3) IPPS RATES (IN LTCAL092)                   *  02750000
027700*                4) OPERATING IME FACTOR (STILL 1.35)          *  02760000
027800*                5) FY 2009 FLOOR IF STATEMENT & PARAGRAPH     *  02770000
027900*                   USING FY 2008 FLOOR ASSIGNMENTS            *  02780000
028000*                                                              *  02790000
028100*                THE FOLLOWING FY 2009 UPDATES WERE NOT MADE   *  02800000
028200*                IN THIS VERSION BECAUSE THEY ARE NOT YET      *  02810000
028300*                AVAILABLE.  A NEW PRICER WILL BE RELEASED TO  *  02820000
028400*                INCLUDE THESE ITEMS.                          *  02830000
028500*                1) IPPS WAGE INDEX TABLE                      *  02840000
028600*                2) IPPS WAGE INDEX FLOORS                     *  02850000
028700*                                                              *  02860000
028800*                FOR TESTING PURPOSES, THE FOLLOWING           *  02870000
028900*                SUBSTITUTIONS WERE MADE:                      *  02880000
029000*                1) THE FY 2008 IPPS WAGE INDEX TABLE IS USED  *  02890000
029100*                   IN PLACE OF THE FY 2009 TABLE.             *  02900000
029200*                2) THE FY 2008 WAGE INDEX FLOORS ARE USED     *  02910000
029300*                   IN PLACE OF THE FY 2009 FLOORS.            *  02920000
029400*                                                              *  02930000
029500*--------------------------------------------------------------*  02940000
029600*                                                              *  02950000
029700*   08/11/2008 - COMMENTED OUT REFERENCES TO THE IPPS          *  02960000
029800*                COMPARABLE THRESHOLD IN LTCAL092 BECAUSE      *  02970000
029900*                SHORT STAY CLAIMS ARE NO LONGER ELIGIBLE      *  02980000
030000*                FOR THE IPPS COMPARABLE PER DIEM AND,         *  02990000
030100*                THEREFORE, THE IPPS THRESHOLD IS NOT INCLUDED *  03000000
030200*                IN THE LTCH DRG TABLE FOR FY 2009.  RETURN    *  03010000
030300*                CODES 26 & 27 WILL NO LONGER BE RETURNED.     *  03020000
030400*                ADDED FIELD P-VAL-BASED-PURCH-SCORE TO THE    *  03030000
030500*                PSF LAYOUT (TO BE USED IN IPPS 1/1/2008).     *  03040000
030600*                                                              *  03050000
030700*--------------------------------------------------------------*  03060000
030800*                                                              *  03070000
030900*   08/14/2008 - REDUCE H-CAPI-IME-TEACH ROUNDED BY 50%        *  03080000
031000*                IN LTCAL092.                                  *  03090000
031100*                                                              *  03100000
031200*                                                              *  03110000
031300*--------------------------------------------------------------*  03120000
031400*                                                              *  03130000
031500*   08/15/2008 - ADDED STATE SPECIFIC RURAL FLOOR BUDGET       *  03140000
031600*                NEUTRALITY (SSRFBN) TABLE AND LOGIC TO        *  03150000
031700*                LTCAL092 FOR FY 2009.                         *  03160000
031800*              - ADDED NEW RETURN CODE FOR SSRFBN LOGIC:       *  03170000
031900*                68 = PROVIDER SPECIFIC STATE CODE INVALID     *  03180000
032000*                                                              *  03190000
032100*--------------------------------------------------------------*  03200000
032200*                                                              *  03210000
032300*   09/09/2008 - CREATE VERSION 09.3 OF THE LTCH PPS PRICER    *  03220000
032400*                EFFECTIVE OCTOBER 1, 2008 (FY 2009, RY 2009)  *  03230000
032500*                REPLACES VERSION 09.2                         *  03240000
032600*                ADDED THE FOLLOWING ITEMS IN THIS VERSION:    *  03250000
032700*                - FY 2009 IPPS CBSA WAGE INDEX TABLE          *  03260000
032800*                  CHANGED NEW CBSA 14600 TO 42260 FOR LTCH    *  03270000
032900*                - FY 2009 IPPS RURAL FLOOR ASSIGNMENT CODE    *  03280000
033000*                - REVISED FY 2009 IPPS STANDARD RATES         *  03290000
033100*                - REVISED FY 2009 IPPS RFBN FACTOR TABLE      *  03300000
033200*                                                              *  03310000
033300*--------------------------------------------------------------*  03320000
033400*                                                              *  03330000
033500*   09/12/2008 - REVISED SSRFBN LOGIC IN LTCAL093 TO EXCLUDE   *  03340000
033600*                SPECIAL WAGE INDICES ENTERED INTO THE PSF     *  03350000
033700*                FROM THE SSRFBN ADJUSTMENT                    *  03360000
033800*                                                              *  03370000
033900*--------------------------------------------------------------*  03380000
034000*                                                              *  03390000
034100*   02/17/2009 - CREATE VERSION 09.4 OF THE LTCH PPS PRICER    *  03400000
034200*                EFFECTIVE RETROACTIVE BACK TO 10/01/2008      *  03410000
034300*                TO CONFORM TO ECONOMIC STIMULUS BILL SIGNED   *  03420000
034400*                02/17/2009, THE H-CAPI-IME-TEACH AMOUNT       *  03430000
034500*                CALCULATED IN PROGRAM LTCAL094 IS NO LONGER   *  03440000
034600*                REDUCED BY 50%.  NOW PAY 100% CAPITAL IME.    *  03450000
034700*                THIS VERSION REPLACES VERSION 09.3.           *  03460000
034800*                                                              *  03470000
034900*--------------------------------------------------------------*  03480000
035000*                                                              *  03490000
035100*   05/18/2009 - CREATE VERSION 09.5 OF THE LTCH PPS PRICER    *  03500000
035200*                EFFECTIVE 06/03/2009                          *  03510000
035300*                - ADDED NEW LTCH DRG WEIGHT TABLE (LTDRG095)  *  03520000
035400*                  AND CALCULATION PROGRAM (LTCAL095)          *  03530000
035500*                  NEW TABLE HAS CORRECTED WEIGHTS AND IS USED *  03540000
035600*                  TO PROCESS CLAIMS DISCHARGED ON AND AFTER   *  03550000
035700*                  JUNE 3, 2009 THROUGH SEPTEMBER 30, 2009     *  03560000
035800*                                                              *  03570000
035900*--------------------------------------------------------------*  03580000
036000*                                                              *  03590000
036100*   08/04/2009 - CREATE VERSION 10.0 OF THE LTCH PPS PRICER    *  03600000
036200*                EFFECTIVE 10/01/2009 (FY 2010, RY 2010)       *  03610000
036300*                - STARTING THIS YEAR, THE RATE YEAR AND       *  03620000
036400*                  FISCAL YEAR BOTH START ON OCTOBER 1ST       *  03630000
036500*                - THERE ARE NO POLICY OR FORMULA CHANGES      *  03640000
036600*                - RATE YEAR 2005 ITEMS REMOVED FROM PACKAGE   *  03650000
036700*                UPDATED WITH THE FOLLOWING FY 2010 ITEMS:     *  03660000
036800*                1) LTCH DRG TBL                               *  03670000
036900*                2) LTCH CBSA WAGE INDEX TABLE                 *  03680000
037000*                3) IPPS DRG TBL                               *  03690000
037100*                4) IPPS CBSA WAGE INDEX TABLE                 *  03700000
037200*                5) IPPS STATE SPECIFIC RURAL FLOOR BUDGET     *  03710000
037300*                   NEUTRALITY (SSRFBN) FACTOR TABLE           *  03720000
037400*                6) IPPS CBSA WAGE INDEX FLOOR ASSIGNMENT LOGIC*  03730000
037500*                7) LTCH STANDARD RATES IN PROGRAM LTCAL100    *  03740000
037600*                8) IPPS STANDARD RATES IN PROGRAM LTCAL100    *  03750000
037700*                                                              *  03760000
037800*--------------------------------------------------------------*  03770000
037900*                                                              *  03780000
038000*   09/03/2009 - CREATE VERSION 10.1 OF THE LTCH PPS PRICER    *  03790000
038100*                EFFECTIVE 10/01/2009 (FY 2010, RY 2010)       *  03800000
038200*                UPDATED W/ THE FOLLOWING REVISED FY2010 ITEMS:*  03810000
038300*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX101)      *  03820000
038400*                2) IPPS CAPITAL RATES IN PROGRAM LTCAL101     *  03830000
038500*                                                              *  03840000
038600*--------------------------------------------------------------*  03850000
038700*                                                              *  03860000
038800*   11/11/2009 - CREATE VERSION 10.2 OF THE LTCH PPS PRICER    *  03870000
038900*                EFFECTIVE 10/01/2009 (FY 2010, RY 2010)       *  03880000
039000*                REPLACES VERSION 10.1                         *  03890000
039100*                UPDATED W/ THE FOLLOWING REVISED FY2010 ITEMS:*  03900000
039200*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX103)      *  03910000
039300*                2) IPPS STATE SPECIFIC RURAL FLOOR BUDGET     *  03920000
039400*                   NEUTRALITY (SSRFBN) FACTOR TABLE (IRFBN102)*  03930000
039500*                   (KANSAS RFBN CORRECTED - CHANGED FROM      *  03940000
039600*                    0.99826 TO 0.99829)                       *  03950000
039700*                                                              *  03960000
039800*--------------------------------------------------------------*  03970000
039900*                                                              *  03980000
040000*   04/07/2010 - CREATE VERSION 10.3 OF THE LTCH PPS PRICER    *  03990000
040100*                EFFECTIVE 10/01/2010 (FY 2010, RY 2010)       *  04000000
040200*                REPLACES VERSION 10.2                         *  04010000
040300*                UPDATED W/ THE FOLLOWING REVISED FY2010 ITEMS:*  04020000
040400*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX104)      *  04030000
040500*                2) IPPS STATE SPECIFIC RURAL FLOOR BUDGET     *  04040000
040600*                   NEUTRALITY TABLE (IRFBN105)                *  04050000
040700*                3) IPPS DRG TABLE (IPDRG104)                  *  04060000
040800*                4) LTCH STANDARD RATES IN PROGRAM LTCAL104    *  04070000
040900*                5) IPPS STANDARD RATES IN PROGRAM LTCAL104    *  04080000
041000*                                                              *  04090000
041100*--------------------------------------------------------------*  04100000
041200*                                                              *  04110000
041300*   04/19/2010 - CREATE VERSION 10.4 OF THE LTCH PPS PRICER    *  04120000
041400*                EFFECTIVE 10/01/2010 (FY 2010, RY 2010)       *  04130000
041500*                REPLACES VERSION 10.3                         *  04140000
041600*                UPDATED W/ THE FOLLOWING REVISED FY2010 ITEMS:*  04150000
041700*                1) LTCH STANDARD RATES IN PROGRAM LTCAL105    *  04160000
041800*                2) IPPS STANDARD RATES IN PROGRAM LTCAL105    *  04170000
041900*                                                              *  04180000
042000*--------------------------------------------------------------*  04190000
042100*                                                              *  04200000
042200*   08/04/2010 - CREATE VERSION 11.0 OF THE LTCH PPS PRICER    *  04210000
042300*                EFFECTIVE 10/01/2010 (FY 2011, RY 2011)       *  04220000
042400*                REPLACES VERSION 10.4                         *  04230000
042500*                UPDATED W/ THE FOLLOWING REVISED FY2011 ITEMS:*  04240000
042600*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX110)      *  04250000
042700*                2) IPPS STATE SPECIFIC RURAL FLOOR BUDGET     *  04260000
042800*                   NEUTRALITY TABLE (IRFBN110)                *  04270000
042900*                3) IPPS DRG TABLE (IPDRG110)                  *  04280000
043000*                4) LTCH STANDARD RATES IN PROGRAM LTCAL110    *  04290000
043100*                5) IPPS STANDARD RATES IN PROGRAM LTCAL110    *  04300000
041900*                                                              *  04310000
042000*--------------------------------------------------------------*  04311000
042100*                                                              *  04312000
042200*   08/13/2010 - CORRECTED FY 2008 - FY 2011 FLOOR LOGIC TO    *  04313000
042300*                REFERENCE THE IPPS CBSA INSTEAD OF THE LTCH   *  04314000
043200*                CBSA (TAMARA HOWARD)                          *  04315000
043200*                                                              *  04316000
042000*--------------------------------------------------------------*  04317000
042100*                                                              *  04318000
042200*   10/19/2010 - CHANGED TO ALLOW ADJUSTMENTS TO CLAIMS WITH   *  04319000
042300*                DATES OF SERVICE OLDER THAN 5 YEARS           *  04320000
042000*--------------------------------------------------------------*  04330000
042100*                                                              *  04331000
042200*   08/01/2011 - CREATE VERSION 12.0 OF THE LTCH PPS PRICER    *  04332000
042300*                EFFECTIVE 10/01/2011 (FY 2012, RY 2012)       *  04332100
042400*                REPLACES VERSION 11.1                         *  04332200
042500*                UPDATED W/ THE FOLLOWING REVISED FY2012 ITEMS:*  04332300
042600*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX120)      *  04332400
042900*                2) IPPS DRG TABLE (IPDRG120)                  *  04332500
043000*                3) LTCH STANDARD RATES IN PROGRAM LTCAL120    *  04332600
043100*                4) IPPS STANDARD RATES IN PROGRAM LTCAL120    *  04332700
041900*                                                              *  04332800
042000*--------------------------------------------------------------*  04332900
042100*                                                              *  04333000
042200*   08/31/2011 - CREATE VERSION 12.1 OF THE LTCH PPS PRICER    *  04333100
042300*                EFFECTIVE 10/01/2011 (FY 2012, RY 2012)       *  04333200
042400*                REPLACES VERSION 12.0                         *  04333300
042500*                UPDATED W/ THE FOLLOWING REVISED FY2012 ITEMS:*  04333400
042600*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX121)      *  04333500
042900*                2) IPPS DRG TABLE (IPDRG121)                  *  04333600
043000*                3) LTCH CBSA WAGE INDEX TABLE (LTWIX121)      *  04333700
042000*--------------------------------------------------------------*  04333800
042100*                                                              *  04333900
042200*   10/28/2011 - CREATE VERSION 12.2 OF THE LTCH PPS PRICER    *  04334000
042300*                EFFECTIVE 10/01/2011 (FY 2012, RY 2012)       *  04334100
042400*                REPLACES VERSION 12.1                         *  04334200
042500*                UPDATED W/ THE FOLLOWING REVISED FY2012 ITEMS:*  04334300
042600*                1) LTCH DRG TABLE (IPDRG122)                  *  04334400
041900*                                                              *  04334500
042000*--------------------------------------------------------------*  04334600
042100*                                                              *  04334700
042200*   12/09/2011 - CREATE VERSION 12.3 OF THE LTCH PPS PRICER    *  04334800
042300*                EFFECTIVE 10/01/2011 (FY 2012, RY 2012)       *  04334900
042400*                REPLACES VERSION 12.2                         *  04335000
042500*                REVISED FY 2012 IPPS WAGE INDEX FLOOR         *  04335100
041900*                                                              *  04335200
042000*--------------------------------------------------------------*  04335300
042100*                                                              *  04335400
042200*   07/30/2012 - CREATE VERSION 13.0 OF THE LTCH PPS PRICER    *  04335500
042300*                EFFECTIVE 10/01/2012 (FY 2013, RY 2013)       *  04335600
042400*                REPLACES VERSION 12.3                         *  04335700
042500*                UPDATED W/ THE FOLLOWING REVISED FY2013 ITEMS:*  04335800
042600*                1) LTCH WAGE INDEX TABLE (LTWIX130)           *  04335900
042600*                2) LTCH DRG TABLE (LTDRG130)                  *  04336000
042600*                3) IPPS CBSA WAGE INDEX TABLE (IPWIX130)      *  04336100
042900*                4) IPPS DRG TABLE (IPDRG130)                  *  04336200
043000*                5) LTCH STANDARD RATES IN PROGRAM LTCAL130    *  04336300
043100*                6) IPPS STANDARD RATES IN PROGRAM LTCAL130    *  04336400
041900*                                                              *  04336507
042000*--------------------------------------------------------------*  04336607
042100*                                                              *  04336707
042200*   11/16/2012 - IN VERSION 13.0 OF THE LTCH PPS PRICER        *  04336807
042300*                CHANGED "T-CBSA-DATA  OCCURS 0 TO 4000 TIMES" *  04336907
042400*                     TO "T-CBSA-DATA  OCCURS 0 TO 7000 TIMES" *  04337007
042500*                FOR IPPS-CBSA-WI-TABLE IN RESPONSE TO         *  04337107
041900*                HPAR CR8041H2 (R41212).  NO VERSION NUMBERS   *  04337207
041900*                CHANGED AND ONLY MODULES LTDRV130 AND         *  04337307
041900*                LTOPN130 CHANGED AS DESCRIBED ABOVE.          *  04337407
041900*                                                              *  04337507
043300****************************************************************  04337607
043400                                                                  04337707
043500                                                                  04337807
043600 ENVIRONMENT DIVISION.                                            04337907
043700 CONFIGURATION SECTION.                                           04338007
043800 SOURCE-COMPUTER.            IBM-370.                             04338107
043900 OBJECT-COMPUTER.            IBM-370.                             04338207
044000 INPUT-OUTPUT  SECTION.                                           04338307
044100 FILE-CONTROL.                                                    04338407
044200                                                                  04338507
044300 DATA DIVISION.                                                   04338607
044400 FILE SECTION.                                                    04338707
044500                                                                  04338807
044600                                                                  04338907
044700 WORKING-STORAGE SECTION.                                         04339007
044800 77  W-STORAGE-REF                  PIC X(48) VALUE               04339107
044900     'L T D R V _ _ _ - W O R K I N G   S T O R A G E'.           04339207
045000 01  DRV-VERSION                    PIC X(05) VALUE 'D13.0'.      04339307
045100                                                                  04339407
045200*-------------------------------------------------------------*   04339507
045300* LTCAL MODULES OLDER THAN 5 YEARS                            *   04340000
045400*-------------------------------------------------------------*   04350000
045500 01  LTCAL032                       PIC X(08) VALUE 'LTCAL032'.   04360000
045600 01  LTCAL042                       PIC X(08) VALUE 'LTCAL042'.   04370000
045700 01  LTCAL043                       PIC X(08) VALUE 'LTCAL043'.   04380000
045800 01  LTCAL058                       PIC X(08) VALUE 'LTCAL058'.   04390000
045900 01  LTCAL059                       PIC X(08) VALUE 'LTCAL059'.   04400000
046000 01  LTCAL063                       PIC X(08) VALUE 'LTCAL063'.   04410000
046100 01  LTCAL064                       PIC X(08) VALUE 'LTCAL064'.   04420000
046600 01  LTCAL072                       PIC X(08) VALUE 'LTCAL072'.   04430000
046700 01  LTCAL075                       PIC X(08) VALUE 'LTCAL075'.   04440000
046200                                                                  04450000
046300*-------------------------------------------------------------*   04460000
046400* LTCAL MODULES CURRENTLY CALLED                              *   04470000
046500*-------------------------------------------------------------*   04480000
046800 01  LTCAL080                       PIC X(08) VALUE 'LTCAL080'.   04490000
046900 01  LTCAL087                       PIC X(08) VALUE 'LTCAL087'.   04500000
047000 01  LTCAL091                       PIC X(08) VALUE 'LTCAL091'.   04510000
047100 01  LTCAL094                       PIC X(08) VALUE 'LTCAL094'.   04520000
047200 01  LTCAL095                       PIC X(08) VALUE 'LTCAL095'.   04530000
047400 01  LTCAL103                       PIC X(08) VALUE 'LTCAL103'.   04540000
047400 01  LTCAL105                       PIC X(08) VALUE 'LTCAL105'.   04550000
047700 01  LTCAL111                       PIC X(08) VALUE 'LTCAL111'.   04560000
047700 01  LTCAL123                       PIC X(08) VALUE 'LTCAL123'.   04564000
047700 01  LTCAL130                       PIC X(08) VALUE 'LTCAL130'.   04564100
047800                                                                  04565000
047900                                                                  04566000
048000***************************************************************   04567000
048100* MSA AND CBSA HOLD AREAS FOR SEARCH                          *   04568000
048200***************************************************************   04569000
048300 01  HOLD-PROV-MSA.                                               04570000
048400         10  H-PROV-BLANK             PIC X(2).                   04580000
048500         10  H-PROV-STATE.                                        04590000
048600             15  FILLER               PIC X.                      04600000
048700             15  H-MSA-LAST-POS       PIC X.                      04610000
048800                                                                  04620000
048900 01  HOLD-PROV-CBSA.                                              04630000
049000         10  H-PROV-BLANK             PIC X(3).                   04640000
049100         10  H-PROV-STATE.                                        04650000
049200             15  FILLER               PIC X.                      04660000
049300             15  H-CBSA-LAST-POS      PIC X.                      04670000
049400                                                                  04680000
049500 01  HOLD-PROV-IPPS-CBSA.                                         04690000
049600         10  H-PROV-BLANK             PIC X(3).                   04700000
049700         10  H-PROV-STATE.                                        04710000
049800             15  FILLER               PIC X.                      04720000
049900             15  H-IPPS-CBSA-LAST-POS PIC X.                      04730000
050000                                                                  04740000
050100                                                                  04750000
050200***************************************************************   04760000
050300*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *   04770000
050400*      THE LTCAL___ PROGRAM (MSA) - USED THROUGH 06/30/2005   *   04780000
050500***************************************************************   04790000
050600 01  WAGE-NEW-INDEX-RECORD-MSA.                                   04800000
050700     05  W-NEW-MSA                    PIC 9(4).                   04810000
050800     05  W-NEW-EFF-DATE-M.                                        04820000
050900          10  W-NEW-EFF-DATE-M-CC     PIC 9(2).                   04830000
051000          10  W-NEW-EFF-DATE-M-YMD.                               04840000
051100              15  W-NEW-EFF-DATE-M-YY PIC 9(2).                   04850000
051200              15  W-NEW-EFF-DATE-M-MM PIC 9(2).                   04860000
051300              15  W-NEW-EFF-DATE-M-DD PIC 9(2).                   04870000
051400     05  W-NEW-INDEX1-RECORD-M        PIC S9(02)V9(04).           04880000
051500     05  W-NEW-INDEX2-RECORD-M        PIC S9(02)V9(04).           04890000
051600     05  W-NEW-INDEX3-RECORD-M        PIC S9(02)V9(04).           04900000
051700                                                                  04910000
051800                                                                  04920000
051900***************************************************************   04930000
052000*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *   04940000
052100*      THE LTCAL___ PROGRAM (CBSA) - USED SINCE 07/01/2005    *   04950000
052200***************************************************************   04960000
052300 01  WAGE-NEW-INDEX-RECORD-CBSA.                                  04970000
052400     05  W-NEW-CBSA                   PIC 9(5).                   04980000
052500     05  W-NEW-EFF-DATE-C.                                        04990000
052600          10  W-NEW-EFF-DATE-C-CC     PIC 9(2).                   05000000
052700          10  W-NEW-EFF-DATE-C-YMD.                               05010000
052800              15  W-NEW-EFF-DATE-C-YY PIC 9(2).                   05020000
052900              15  W-NEW-EFF-DATE-C-MM PIC 9(2).                   05030000
053000              15  W-NEW-EFF-DATE-C-DD PIC 9(2).                   05040000
053100     05  W-NEW-INDEX1-RECORD-C        PIC S9(02)V9(04).           05050000
053200     05  W-NEW-INDEX2-RECORD-C        PIC S9(02)V9(04).           05060000
053300     05  W-NEW-INDEX3-RECORD-C        PIC S9(02)V9(04).           05070000
053400                                                                  05080000
053500                                                                  05090000
053600***************************************************************   05100000
053700*      THIS IS THE IPPS WAGE-INDEX RECORD THAT WILL BE PASSED *   05110000
053800*      TO THE LTCAL___ PROGRAM (CBSA) - USED SINCE 07/01/2006 *   05120000
053900***************************************************************   05130000
054000 01  WAGE-IPPS-INDEX-RECORD-CBSA.                                 05140000
054100     05  W-CBSA-IPPS.                                             05150000
054200         10 CBSA-IPPS-123              PIC X(3).                  05160000
054300         10 CBSA-IPPS-45               PIC X(2).                  05170000
054400     05  W-CBSA-IPPS-SIZE              PIC X.                     05180000
054500         88  LARGE-URBAN       VALUE 'L'.                         05190000
054600         88  OTHER-URBAN       VALUE 'O'.                         05200000
054700         88  ALL-RURAL         VALUE 'R'.                         05210000
054800     05  W-CBSA-IPPS-EFF-DATE          PIC X(8).                  05220000
054900     05  FILLER                        PIC X.                     05230000
055000     05  W-IPPS-WAGE-INDEX             PIC S9(02)V9(04).          05240000
055100     05  W-IPPS-PR-WAGE-INDEX          PIC S9(02)V9(04).          05250000
055200                                                                  05260000
055300                                                                  05270000
055400**************************************************************    05280000
055500*      THIS IS THE PROV-RECORD THAT IS PASSED FROM THE       *    05290000
055600*      LTDRV___ PROGRAM TO THE LTCAL___ PROGRAM              *    05300000
055700**************************************************************    05310000
055800 01  PROV-NEW-HOLD.                                               05320000
055900     02  PROV-NEWREC-HOLD1.                                       05330000
056000         05  P-NEW-NPI10.                                         05340000
056100             10  P-NEW-NPI8             PIC X(08).                05350000
056200             10  P-NEW-NPI-FILLER       PIC X(02).                05360000
056300         05  P-NEW-PROVIDER-NO.                                   05370000
056400             10  P-NEW-STATE            PIC 9(02).                05380000
056500             10  FILLER                 PIC X(04).                05390000
056600         05  P-NEW-DATE-DATA.                                     05400000
056700             10  P-NEW-EFF-DATE.                                  05410000
056800                 15  P-NEW-EFF-DT-CC    PIC 9(02).                05420000
056900                 15  P-NEW-EFF-DT-YY    PIC 9(02).                05430000
057000                 15  P-NEW-EFF-DT-MM    PIC 9(02).                05440000
057100                 15  P-NEW-EFF-DT-DD    PIC 9(02).                05450000
057200             10  P-NEW-FY-BEGIN-DATE.                             05460000
057300                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                05470000
057400                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                05480000
057500                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                05490000
057600                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                05500000
057700             10  P-NEW-REPORT-DATE.                               05510000
057800                 15  P-NEW-REPORT-DT-CC PIC 9(02).                05520000
057900                 15  P-NEW-REPORT-DT-YY PIC 9(02).                05530000
058000                 15  P-NEW-REPORT-DT-MM PIC 9(02).                05540000
058100                 15  P-NEW-REPORT-DT-DD PIC 9(02).                05550000
058200             10  P-NEW-TERMINATION-DATE.                          05560000
058300                 15  P-NEW-TERM-DT-CC   PIC 9(02).                05570000
058400                 15  P-NEW-TERM-DT-YY   PIC 9(02).                05580000
058500                 15  P-NEW-TERM-DT-MM   PIC 9(02).                05590000
058600                 15  P-NEW-TERM-DT-DD   PIC 9(02).                05600000
058700         05  P-NEW-WAIVER-CODE          PIC X(01).                05610000
058800             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              05620000
058900         05  P-NEW-INTER-NO             PIC 9(05).                05630000
059000         05  P-NEW-PROVIDER-TYPE        PIC X(02).                05640000
059100         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                05650000
059200         05  P-NEW-CURRENT-DIV   REDEFINES                        05660000
059300                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         05670000
059400         05  P-NEW-MSA-DATA.                                      05680000
059500             10  P-NEW-CHG-CODE-INDEX       PIC X.                05690000
059600             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 05700000
059700             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   05710000
059800                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       05720000
059900             10  P-NEW-GEO-LOC-MSA-AST REDEFINES                  05730000
060000                             P-NEW-GEO-LOC-MSA9.                  05740000
060100                 15  P-NEW-GEO-MSA-1ST    PIC X.                  05750000
060200                 15  P-NEW-GEO-MSA-2ND    PIC X.                  05760000
060300                 15  P-NEW-GEO-MSA-3RD    PIC X.                  05770000
060400                 15  P-NEW-GEO-MSA-4TH    PIC X.                  05780000
060500             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 05790000
060600             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 05800000
060700             10  P-NEW-STAND-AMT-LOC-MSA9                         05810000
060800                   REDEFINES P-NEW-STAND-AMT-LOC-MSA.             05820000
060900                 15  P-NEW-RURAL-1ST.                             05830000
061000                     20  P-NEW-STAND-RURAL  PIC XX.               05840000
061100                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    05850000
061200                 15  P-NEW-RURAL-2ND        PIC XX.               05860000
061300         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    05870000
061400                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           05880000
061500                 88  P-NEW-SCH-YR82       VALUE   '82'.           05890000
061600                 88  P-NEW-SCH-YR87       VALUE   '87'.           05900000
061700         05  P-NEW-LUGAR                    PIC X.                05910000
061800         05  P-NEW-TEMP-RELIEF-IND          PIC X.                05920000
061900         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                05930000
062000         05  FILLER                         PIC X(05).            05940000
062100     02  PROV-NEWREC-HOLD2.                                       05950000
062200         05  P-NEW-VARIABLES.                                     05960000
062300             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        05970000
062400             10  P-NEW-COLA              PIC  9(01)V9(03).        05980000
062500             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        05990000
062600             10  P-NEW-BED-SIZE          PIC  9(05).              06000000
062700             10  P-NEW-CCR               PIC  9(01)V9(03).        06010000
062800             10  P-NEW-CMI               PIC  9(01)V9(04).        06020000
062900             10  P-NEW-SSI-RATIO         PIC  V9(04).             06030000
063000             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             06040000
063100             10  P-NEW-PPS-BLEND-YR-IND  PIC  X(01).              06050000
063200             10  P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).        06060000
063300             10  P-NEW-DSH-PERCENT       PIC  V9(04).             06070000
063400             10  P-NEW-FYE-DATE.                                  06080000
063500                 15  P-NEW-FYE-CC        PIC 99.                  06090000
063600                 15  P-NEW-FYE-YY        PIC 99.                  06100000
063700                 15  P-NEW-FYE-MM        PIC 99.                  06110000
063800                 15  P-NEW-FYE-DD        PIC 99.                  06120000
063900         05  P-NEW-CBSA-SPEC-PAY-IND       PIC X(01).             06130000
064000         05  FILLER                        PIC X(01).             06140000
064100         05  P-NEW-GEO-LOC-CBSAX           PIC X(05) JUST RIGHT.  06150000
064200         05  P-NEW-GEO-LOC-CBSA9 REDEFINES                        06160000
064300                          P-NEW-GEO-LOC-CBSAX PIC 9(05).          06170000
064400         05  P-NEW-GEO-LOC-CBSA-AST REDEFINES                     06180000
064500                          P-NEW-GEO-LOC-CBSA9.                    06190000
064600             10 P-NEW-GEO-LOC-CBSA-1ST     PIC X.                 06200000
064700             10 P-NEW-GEO-LOC-CBSA-2ND     PIC X.                 06210000
064800             10 P-NEW-GEO-LOC-CBSA-3RD     PIC X.                 06220000
064900             10 P-NEW-GEO-LOC-CBSA-4TH     PIC X.                 06230000
065000             10 P-NEW-GEO-LOC-CBSA-5TH     PIC X.                 06240000
065100         05 P-NEW-GEO-LOC-CBSA-SIZE REDEFINES                     06250000
065200                          P-NEW-GEO-LOC-CBSAX.                    06260000
065300             10 P-NEW-GEO-LOC-CBSA-123     PIC X(03).             06270000
065400                88  P-NEW-RURAL-CBSA       VALUE '   '.           06280000
065500             10 P-NEW-GEO-LOC-CBSA-45      PIC X(02).             06290000
065600         05  FILLER                        PIC X(10).             06300000
065700         05  P-NEW-SPECIAL-WAGE-INDEX      PIC 9(02)V9(04).       06310000
065800     02  PROV-NEWREC-HOLD3.                                       06320000
065900         05  P-NEW-PASS-AMT-DATA.                                 06330000
066000             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          06340000
066100             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          06350000
066200             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          06360000
066300             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          06370000
066400         05  P-NEW-CAPI-DATA.                                     06380000
066500             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 06390000
066600             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          06400000
066700             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          06410000
066800             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        06420000
066900             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             06430000
067000             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 06440000
067100             15  P-NEW-CAPI-IME            PIC 9V9999.            06450000
067200             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          06460000
067300             15  P-VAL-BASED-PURCH-SCORE   PIC 9V999.             06470000
067400         05  FILLER                        PIC X(18).             06480000
067500                                                                  06490000
067600                                                                  06500000
067700***************************************************************   06510000
067800 LINKAGE SECTION.                                                 06520000
067900***************************************************************   06530000
068000                                                                  06540000
068100**************************************************************    06550000
068200*      THIS IS THE BILL-RECORD THAT WILL BE PASSED TO        *    06560000
068300*      THE LTCAL___ PROGRAM                                  *    06570000
068400**************************************************************    06580000
068500 01  BILL-NEW-DATA.                                               06590000
068600     05  B-NPI10.                                                 06600000
068700         10  B-NPI8                   PIC X(08).                  06610000
068800         10  B-NPI-FILLER             PIC X(02).                  06620000
068900     05  B-PROVIDER-NO                PIC X(06).                  06630000
069000     05  B-PATIENT-STATUS             PIC X(02).                  06640000
069100     05  B-DRG-CODE                   PIC X(03).                  06650000
069200     05  B-LOS                        PIC 9(03).                  06660000
069300     05  B-COV-DAYS                   PIC 9(03).                  06670000
069400     05  B-LTR-DAYS                   PIC 9(02).                  06680000
069500     05  B-DISCHARGE-DATE.                                        06690000
069600         10  B-DISCHG-CC              PIC 9(02).                  06700000
069700         10  B-DISCHG-YY              PIC 9(02).                  06710000
069800         10  B-DISCHG-MM              PIC 9(02).                  06720000
069900         10  B-DISCHG-DD              PIC 9(02).                  06730000
070000     05  B-COV-CHARGES                PIC 9(07)V9(02).            06740000
070100     05  B-SPEC-PAY-IND               PIC X(01).                  06750000
070200     05  FILLER                       PIC X(13).                  06760000
070300                                                                  06770000
070400                                                                  06780000
070500**************************************************************    06790000
070600*      THIS IS THE PPS DATA PASSED TO THE LTCAL___ PROGRAM   *    06800000
070700*      IT WILL BE PASSED BACK TO THE LTDRV___ PROGRAM        *    06810000
070800**************************************************************    06820000
070900 01  PPS-DATA-ALL.                                                06830000
071000     05  PPS-RTC                      PIC 9(02).                  06840000
071100     05  PPS-CHRG-THRESHOLD           PIC 9(07)V9(02).            06850000
071200     05  PPS-DATA.                                                06860000
071300         10  PPS-MSA                  PIC X(04).                  06870000
071400         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).            06880000
071500         10  PPS-AVG-LOS              PIC 9(02)V9(01).            06890000
071600         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).            06900000
071700         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).            06910000
071800         10  PPS-LOS                  PIC 9(03).                  06920000
071900         10  PPS-DRG-ADJ-PAY-AMT      PIC 9(07)V9(02).            06930000
072000         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).            06940000
072100         10  PPS-FINAL-PAY-AMT        PIC 9(07)V9(02).            06950000
072200         10  PPS-FAC-COSTS            PIC 9(07)V9(02).            06960000
072300         10  PPS-NEW-FAC-SPEC-RATE    PIC 9(07)V9(02).            06970000
072400         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).            06980000
072500         10  PPS-SUBM-DRG-CODE        PIC X(03).                  06990000
072600         10  PPS-CALC-VERS-CD         PIC X(05).                  07000000
072700         10  PPS-REG-DAYS-USED        PIC 9(03).                  07010000
072800         10  PPS-LTR-DAYS-USED        PIC 9(03).                  07020000
072900         10  PPS-BLEND-YEAR           PIC 9(01).                  07030000
073000         10  PPS-COLA                 PIC 9(01)V9(03).            07040000
073100         10  FILLER                   PIC X(04).                  07050000
073200    05  PPS-OTHER-DATA.                                           07060000
073300         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).            07070000
073400         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).            07080000
073500         10  PPS-STD-FED-RATE         PIC 9(05)V9(02).            07090000
073600         10  PPS-BDGT-NEUT-RATE       PIC 9(01)V9(03).            07100000
073700         10  PPS-IPTHRESH             PIC 9(03)V9(01).            07110000
073800         10  FILLER                   PIC X(16).                  07120000
073900    05  PPS-PC-DATA.                                              07130000
074000         10  PPS-COT-IND              PIC X(01).                  07140000
074100         10  FILLER                   PIC X(20).                  07150000
074200                                                                  07160000
074300 01  PPS-CBSA                         PIC X(05).                  07170000
074400                                                                  07180000
074500                                                                  07190000
074600***************************************************************** 07200000
074700*            THESE ARE THE VERSIONS OF THE LTDRV___             * 07210000
074800*           PROGRAMS THAT WILL BE PASSED BACK----               * 07220000
074900*          ASSOCIATED WITH THE BILL BEING PROCESSED             * 07230000
075000***************************************************************** 07240000
075100 01  PRICER-OPT-VERS-SW.                                          07250000
075200     05  PRICER-OPTION-SW               PIC X(01).                07260000
075300         88  ALL-TABLES-PASSED          VALUE 'A'.                07270000
075400         88  PROV-RECORD-PASSED         VALUE 'P'.                07280000
075500     05  PPS-VERSIONS.                                            07290000
075600         10  PPDRV-VERSION              PIC X(05).                07300000
075700                                                                  07310000
075800                                                                  07320000
075900                                                                  07330000
076000**************************************************************    07340000
076100*      PROVIDER SPECIFIC RECORD                              *    07350000
076200**************************************************************    07360000
076300*      THIS IS THE PROV-RECORD THAT IS PASSED FROM THE       *    07370000
076400*      LTOPN___ PROGRAM                                      *    07380000
076500**************************************************************    07390000
076600 01  PROV-RECORD.                                                 07400000
076700     05  PROV-REC1                  PIC X(80).                    07410000
076800     05  PROV-REC2                  PIC X(80).                    07420000
076900     05  PROV-REC3                  PIC X(80).                    07430000
077000                                                                  07440000
077100                                                                  07450000
077200**************************************************************    07460000
077300*      LTCH CBSA WAGE INDEX TABLE                            *    07470000
077400**************************************************************    07480000
077500*      THIS IS THE CBSA WAGE INDEX TABLE THAT IS PASSED FROM *    07490000
077600*      THE LTOPN___ PROGRAM                                  *    07500000
077700**************************************************************    07510000
077800 01  CBSA-WI-TABLE.                                               07520000
077900     05  C-CBSA-DATA  OCCURS 0 TO 4000 TIMES                      07530000
078000                      DEPENDING ON CBSA-CNT                       07540000
078100                      ASCENDING KEY IS CBSAX-CBSA                 07550000
078200                      INDEXED BY CU1 CU2.                         07560000
078300         10  CBSAX-CBSA         PIC X(05).                        07570000
078400         10  CBSAX-EFF-DATE     PIC X(08).                        07580000
078500         10  CBSAX-WAGE-INDEX1  PIC S9(02)V9(04).                 07590000
078600         10  CBSAX-WAGE-INDEX2  PIC S9(02)V9(04).                 07600000
078700         10  CBSAX-WAGE-INDEX3  PIC S9(02)V9(04).                 07610000
078800                                                                  07620000
078900                                                                  07630000
079000**************************************************************    07640000
079100*      IPPS CBSA WAGE INDEX TABLE                            *    07650000
079200**************************************************************    07660000
079300*      THIS IS THE IPPS CBSA WAGE INDEX TABLE THAT IS PASSED *    07670000
079400*      FROM THE LTOPN___ PROGRAM                             *    07680000
079500**************************************************************    07690000
079600 01  IPPS-CBSA-WI-TABLE.                                          07700000
079700     05  T-CBSA-DATA  OCCURS 0 TO 7000 TIMES                      07710006
079800                      DEPENDING ON IPPS-CBSA-CNT                  07720000
079900                      ASCENDING KEY IS T-CBSA                     07730000
080000                      INDEXED BY MA1 MA2 MA3.                     07740000
080100         10  T-CBSA             PIC X(5).                         07750000
080200         10  T-CBSA-SIZE        PIC X(01).                        07760000
080300         10  T-CBSA-EFF-DATE    PIC X(08).                        07770000
080400         10  T-CBSA-WAGE-INDX1  PIC S9(02)V9(04).                 07780000
080500         10  T-CBSA-WAGE-INDX2  PIC S9(02)V9(04).                 07790000
080600                                                                  07800000
080700                                                                  07810000
080800**************************************************************    07820000
080900*      LTCH MSA WAGE INDEX TABLE                             *    07830000
081000**************************************************************    07840000
081100*      THIS IS THE MSA WAGE INDEX TABLE THAT IS PASSED FROM  *    07850000
081200*      THE LTOPN___ PROGRAM                                  *    07860000
081300**************************************************************    07870000
081400 01  MSA-WI-TABLE.                                                07880000
081500     05  M-MSA-DATA   OCCURS 0 TO 4000 TIMES                      07890000
081600                      DEPENDING ON MSA-CNT                        07900000
081700                      ASCENDING KEY IS MSAX-MSA                   07910000
081800                      INDEXED BY MU1 MU2.                         07920000
081900         10  MSAX-MSA          PIC X(4).                          07930000
082000         10  MSAX-EFF-DATE     PIC X(08).                         07940000
082100         10  MSAX-WAGE-INDEX1  PIC S9(02)V9(04).                  07950000
082200         10  MSAX-WAGE-INDEX2  PIC S9(02)V9(04).                  07960000
082300         10  MSAX-WAGE-INDEX3  PIC S9(02)V9(04).                  07970000
082400                                                                  07980000
082500                                                                  07990000
082600**************************************************************    08000000
082700*  INPUT FILE RECORD COUNTS                                  *    08010000
082800**************************************************************    08020000
082900 01  WORK-COUNTERS.                                               08030000
083000     05  CBSA-CNT              PIC 9(5).                          08040000
083100     05  MSA-CNT               PIC 9(5).                          08050000
083200     05  PROV-CNT              PIC 9(5).                          08060000
083300     05  IPPS-CBSA-CNT         PIC 9(5).                          08070000
083400                                                                  08080000
083500                                                                  08090000
083600                                                                  08100000
083700                                                                  08110000
083800 PROCEDURE DIVISION  USING BILL-NEW-DATA                          08120000
083900                           PPS-DATA-ALL                           08130000
084000                           PPS-CBSA                               08140000
084100                           PRICER-OPT-VERS-SW                     08150000
084200                           PROV-RECORD                            08160000
084300                           CBSA-WI-TABLE                          08170000
084400                           IPPS-CBSA-WI-TABLE                     08180000
084500                           MSA-WI-TABLE                           08190000
084600                           WORK-COUNTERS.                         08200000
084700                                                                  08210000
084800                                                                  08220000
084900******************************************************************08230000
085000*                                                                *08240000
085100*    PROCESSING:                                                 *08250000
085200*      A. THIS MODULE WILL RETRIEVE THE WAGE INDEX RECORD(S)     *08260000
085300*         NEEDED FOR EACH BILL.                                  *08270000
085400*      B. THIS MODULE WILL CALL THE LTCAL MODULES.               *08280000
085500*      C. THE PROV-RECORD AND WAGE-INDEX-RECORD(S) ASSOCIATED    *08290000
085600*         WITH EACH BILL WILL BE PASSED TO THE LTCAL PROGRAMS.   *08300000
085700*                                                                *08310000
085800******************************************************************08320000
085900                                                                  08330000
086000     MOVE DRV-VERSION TO PPDRV-VERSION.                           08340000
086100                                                                  08350000
086200     INITIALIZE PPS-DATA-ALL.                                     08360000
086300     INITIALIZE PPS-CBSA.                                         08370000
086400     MOVE ZEROS TO W-IPPS-PR-WAGE-INDEX.                          08380000
086500                                                                  08390000
086600     MOVE PROV-RECORD TO PROV-NEW-HOLD.                           08400000
086700                                                                  08410000
086800                                                                  08420000
086900*----------------------------------------------------------*      08430000
087000* RTC = 98  --  BILL DISCHARGE DATE BEFORE 10/01/2002      *      08440000
087200*----------------------------------------------------------*      08450000
087300     IF B-DISCHARGE-DATE < 20021001                               08460000
087400        MOVE 98 TO PPS-RTC                                        08470000
087500        GOBACK                                                    08480000
087600     END-IF.                                                      08490000
087700                                                                  08500000
087800                                                                  08510000
087900************************************************************      08520000
088000*    GET THE WAGE-INDEX RECORD                             *      08530000
088100************************************************************      08540000
088200                                                                  08550000
088300*------------------------------------------------*                08560000
088400* EDIT THE CBSA AND MSA FROM THE PROVIDER RECORD *                08570000
088500*------------------------------------------------*                08580000
088600     IF P-NEW-GEO-LOC-CBSAX = SPACES                              08590000
088700        MOVE ZEROS TO P-NEW-GEO-LOC-CBSAX                         08600000
088800     END-IF.                                                      08610000
088900                                                                  08620000
089000     IF P-NEW-GEO-LOC-MSAX = SPACES                               08630000
089100        MOVE ZEROS TO P-NEW-GEO-LOC-MSAX                          08640000
089200     END-IF.                                                      08650000
089300                                                                  08660000
089400     IF P-NEW-EFF-DATE > 20050701                                 08670000
089500        IF '*' = P-NEW-GEO-LOC-CBSA-1ST OR                        08680000
089600                 P-NEW-GEO-LOC-CBSA-2ND OR                        08690000
089700                 P-NEW-GEO-LOC-CBSA-3RD OR                        08700000
089800                 P-NEW-GEO-LOC-CBSA-4TH OR                        08710000
089900                 P-NEW-GEO-LOC-CBSA-5TH                           08720000
090000           MOVE 60 TO PPS-RTC                                     08730000
090100           GOBACK                                                 08740000
090200        END-IF                                                    08750000
090300     END-IF.                                                      08760000
090400                                                                  08770000
090500*----------------------------------------------------------*      08780000
090600* DETERMINE WHETHER TO GET THE LTCH MSA OR CBSA WAGE INDEX *      08790000
090700*----------------------------------------------------------*      08800000
090800     IF B-DISCHARGE-DATE < 20050701                               08810000
090900       SET MU1 TO 1                                               08820000
091000       PERFORM 0500-GET-MSA THRU 0500-EXIT                        08830000
091100     ELSE                                                         08840000
091200       SET CU1 TO 1                                               08850000
091300       PERFORM 0550-GET-CBSA THRU 0550-EXIT                       08860000
091400     END-IF.                                                      08870000
091500                                                                  08880000
091600*----------------------------------------------------------*      08890000
091700* GET THE IPPS CBSA WAGE INDEX FOR CLAIMS DISCHARGED AFTER *      08900000
091800* JUNE 30, 2006 FOR USE IN THE 4TH SHORT STAY PROVISION    *      08910000
091900*----------------------------------------------------------*      08920000
092000     IF B-DISCHARGE-DATE > 20060630                               08930000
092100       SET MA1 TO 1                                               08940000
092200       PERFORM 0575-GET-IPPS-CBSA THRU 0575-EXIT                  08950000
092300       IF W-IPPS-WAGE-INDEX = 0                                   08960000
092400          MOVE 52 TO PPS-RTC                                      08970000
092500       END-IF                                                     08980000
092600     END-IF.                                                      08990000
092700                                                                  09000000
092800*--------------------------------------------------------------*  09010000
092900* RTC = 60  --  LTCH/IPPS CBSA/MSA WAGE INDEX RECORD NOT FOUND *  09020000
093000* RTC = 52  --  LTCH/IPPS CBSA/MSA WAGE INDEX INVALID          *  09030000
093100*--------------------------------------------------------------*  09040000
093200     IF PPS-RTC = 60 OR PPS-RTC = 52                              09050000
093300        GOBACK                                                    09060000
093400     END-IF.                                                      09070000
093500                                                                  09080000
093600                                                                  09090000
093700                                                                  09100000
093800******************************************************************09110000
093900******************************************************************09120000
094000**                                                              **09130000
094100**          THIS NEXT CALL WILL PROCESS BILLS WITH              **09140000
094200**          A DISCHARGE DATE ON OR AFTER 20021001               **09150000
094300**                                                              **09160000
094400**--------------------------------------------------------------**09170000
094500**                                                              **09180000
094600** FOR BILLS WITH DISCHARGE DATES AFTER 20050630, INCLUDE FIELD **09190000
094700** PPS-CBSA IN THE CALL USING STATEMENT, OMIT THIS FIELD FOR    **09200000
094800** BILLS WITH DISCHARGE DATES BEFORE 20050701.                  **09210000
094900**                                                              **09220000
095000** FOR BILLS WITH DISCHARGE DATES AFTER 20060630, INCLUDE FIELD **09230000
095100** WAGE-IPPS-INDEX-RECORD-CBSA.                                 **09240000
095200**                                                              **09250000
095300******************************************************************09260000
095400******************************************************************09270000
095500                                                                  09280000
095600*----------------------------------------------------------------*09290000
095700*        FISCAL YEAR 2013, RATE YEAR 2013 (AFTER 10/1/2012)      *09300000
095800*----------------------------------------------------------------*09310000
095900         IF B-DISCHARGE-DATE > 20120930                           09320000
096000            CALL LTCAL130 USING BILL-NEW-DATA                     09330000
096100                                PPS-DATA-ALL                      09340000
096200                                PPS-CBSA                          09350000
096300                                PRICER-OPT-VERS-SW                09360000
096400                                PROV-NEW-HOLD                     09370000
096500                                WAGE-NEW-INDEX-RECORD-CBSA        09380000
096600                                WAGE-IPPS-INDEX-RECORD-CBSA.      09390000
096700                                                                  09400000
095600*----------------------------------------------------------------*09401000
095700*        FISCAL YEAR 2012, RATE YEAR 2012 (AFTER 10/1/2011)      *09402000
095800*----------------------------------------------------------------*09403000
095900         IF B-DISCHARGE-DATE > 20110930 AND                       09404000
095910                             < 20121001                           09404100
096000            CALL LTCAL123 USING BILL-NEW-DATA                     09405000
096100                                PPS-DATA-ALL                      09406000
096200                                PPS-CBSA                          09407000
096300                                PRICER-OPT-VERS-SW                09408000
096400                                PROV-NEW-HOLD                     09409000
096500                                WAGE-NEW-INDEX-RECORD-CBSA        09409100
096600                                WAGE-IPPS-INDEX-RECORD-CBSA.      09409200
096700                                                                  09409300
095600*----------------------------------------------------------------*09410000
095700*        FISCAL YEAR 2011, RATE YEAR 2011 (AFTER 10/1/2010)      *09420000
095800*----------------------------------------------------------------*09430000
095900         IF B-DISCHARGE-DATE > 20100930 AND                       09440000
095910                             < 20111001                           09450000
096000            CALL LTCAL111 USING BILL-NEW-DATA                     09460000
096100                                PPS-DATA-ALL                      09470000
096200                                PPS-CBSA                          09480000
096300                                PRICER-OPT-VERS-SW                09490000
096400                                PROV-NEW-HOLD                     09500000
096500                                WAGE-NEW-INDEX-RECORD-CBSA        09510000
096600                                WAGE-IPPS-INDEX-RECORD-CBSA.      09520000
096700                                                                  09530000
096800*----------------------------------------------------------------*09540000
096900*        FISCAL YEAR 2010, RATE YEAR 2010 (AFTER 3/31/2010)      *09550000
097000*----------------------------------------------------------------*09560000
097100         IF B-DISCHARGE-DATE > 20100331 AND                       09570000
098400                             < 20101001                           09580000
097200            CALL LTCAL105 USING BILL-NEW-DATA                     09590000
097300                                PPS-DATA-ALL                      09591000
097400                                PPS-CBSA                          09592000
097500                                PRICER-OPT-VERS-SW                09593000
097600                                PROV-NEW-HOLD                     09594000
097700                                WAGE-NEW-INDEX-RECORD-CBSA        09595000
097800                                WAGE-IPPS-INDEX-RECORD-CBSA.      09596000
097900                                                                  09597000
098000*----------------------------------------------------------------*09598000
098100*        FISCAL YEAR 2010, RATE YEAR 2010 (BEFORE 4/1/2010)      *09599000
098200*----------------------------------------------------------------*09600000
098300         IF B-DISCHARGE-DATE > 20090930 AND                       09610000
098400                             < 20100401                           09620000
098500            CALL LTCAL103 USING BILL-NEW-DATA                     09630000
098600                                PPS-DATA-ALL                      09640000
098700                                PPS-CBSA                          09650000
098800                                PRICER-OPT-VERS-SW                09660000
098900                                PROV-NEW-HOLD                     09670000
099000                                WAGE-NEW-INDEX-RECORD-CBSA        09680000
099100                                WAGE-IPPS-INDEX-RECORD-CBSA.      09690000
099200                                                                  09700000
099300*----------------------------------------------------------------*09710000
099400*        FISCAL YEAR 2009, RATE YEAR 2009 (AFTER 6/2/2009)       *09720000
099500*----------------------------------------------------------------*09730000
099600         IF B-DISCHARGE-DATE > 20090602 AND                       09740000
099700                             < 20091001                           09750000
099800            CALL LTCAL095 USING BILL-NEW-DATA                     09760000
099900                                PPS-DATA-ALL                      09770000
100000                                PPS-CBSA                          09780000
100100                                PRICER-OPT-VERS-SW                09790000
100200                                PROV-NEW-HOLD                     09800000
100300                                WAGE-NEW-INDEX-RECORD-CBSA        09810000
100400                                WAGE-IPPS-INDEX-RECORD-CBSA.      09820000
100500                                                                  09830000
100600*----------------------------------------------------------------*09840000
100700*        FISCAL YEAR 2009, RATE YEAR 2009 (BEFORE 6/3/2009)      *09850000
100800*----------------------------------------------------------------*09860000
100900         IF B-DISCHARGE-DATE > 20080930 AND                       09870000
101000                             < 20090603                           09880000
101100            CALL LTCAL094 USING BILL-NEW-DATA                     09890000
101200                                PPS-DATA-ALL                      09900000
101300                                PPS-CBSA                          09910000
101400                                PRICER-OPT-VERS-SW                09920000
101500                                PROV-NEW-HOLD                     09930000
101600                                WAGE-NEW-INDEX-RECORD-CBSA        09940000
101700                                WAGE-IPPS-INDEX-RECORD-CBSA.      09950000
101800                                                                  09960000
101900*----------------------------------------------------------------*09970000
102000*        FISCAL YEAR 2008, RATE YEAR 2009                        *09980000
102100*----------------------------------------------------------------*09990000
102200         IF B-DISCHARGE-DATE > 20080630 AND                       10000000
102300                             < 20081001                           10010000
102400            CALL LTCAL091 USING BILL-NEW-DATA                     10020000
102500                                PPS-DATA-ALL                      10030000
102600                                PPS-CBSA                          10040000
102700                                PRICER-OPT-VERS-SW                10050000
102800                                PROV-NEW-HOLD                     10060000
102900                                WAGE-NEW-INDEX-RECORD-CBSA        10070000
103000                                WAGE-IPPS-INDEX-RECORD-CBSA.      10080000
103100                                                                  10090000
103200*----------------------------------------------------------------*10100000
103300*        FISCAL YEAR 2008, RATE YEAR 2008                        *10110000
103400*----------------------------------------------------------------*10120000
103500         IF B-DISCHARGE-DATE > 20070930 AND                       10130000
103600                             < 20080701                           10140000
103700            CALL LTCAL087 USING BILL-NEW-DATA                     10150000
103800                                PPS-DATA-ALL                      10160000
103900                                PPS-CBSA                          10170000
104000                                PRICER-OPT-VERS-SW                10180000
104100                                PROV-NEW-HOLD                     10190000
104200                                WAGE-NEW-INDEX-RECORD-CBSA        10200000
104300                                WAGE-IPPS-INDEX-RECORD-CBSA.      10210000
104400                                                                  10220000
104500*----------------------------------------------------------------*10230000
104600*        FISCAL YEAR 2007, RATE YEAR 2008                        *10240000
104700*----------------------------------------------------------------*10250000
104800         IF B-DISCHARGE-DATE > 20070630 AND                       10260000
104900                             < 20071001                           10270000
105000            CALL LTCAL080 USING BILL-NEW-DATA                     10280000
105100                                PPS-DATA-ALL                      10290000
105200                                PPS-CBSA                          10300000
105300                                PRICER-OPT-VERS-SW                10310000
105400                                PROV-NEW-HOLD                     10320000
105500                                WAGE-NEW-INDEX-RECORD-CBSA        10330000
105600                                WAGE-IPPS-INDEX-RECORD-CBSA.      10340000
105700                                                                  10350000
105800*----------------------------------------------------------------*10360000
105900*        FISCAL YEAR 2007, RATE YEAR 2007                        *10370000
106000*----------------------------------------------------------------*10380000
106100         IF B-DISCHARGE-DATE > 20060930 AND                       10390000
106200                             < 20070701                           10400000
106300            CALL LTCAL075 USING BILL-NEW-DATA                     10410000
106400                                PPS-DATA-ALL                      10420000
106500                                PPS-CBSA                          10430000
106600                                PRICER-OPT-VERS-SW                10440000
106700                                PROV-NEW-HOLD                     10450000
106800                                WAGE-NEW-INDEX-RECORD-CBSA        10460000
106900                                WAGE-IPPS-INDEX-RECORD-CBSA.      10470000
107000                                                                  10480000
107100*----------------------------------------------------------------*10490000
107200*        FISCAL YEAR 2006, RATE YEAR 2007                        *10500000
107300*----------------------------------------------------------------*10510000
107400         IF B-DISCHARGE-DATE > 20060630 AND                       10520000
107500                             < 20061001                           10530000
107600            CALL LTCAL072 USING BILL-NEW-DATA                     10540000
107700                                PPS-DATA-ALL                      10550000
107800                                PPS-CBSA                          10560000
107900                                PRICER-OPT-VERS-SW                10570000
108000                                PROV-NEW-HOLD                     10580000
108100                                WAGE-NEW-INDEX-RECORD-CBSA        10590000
108200                                WAGE-IPPS-INDEX-RECORD-CBSA.      10600000
108300                                                                  10610000
108400*----------------------------------------------------------------*10620000
108500*        FISCAL YEAR 2006, RATE YEAR 2006                        *10630000
108600*----------------------------------------------------------------*10640000
108700         IF B-DISCHARGE-DATE > 20050930 AND                       10650000
108800                             < 20060701                           10660000
108900            CALL LTCAL064 USING BILL-NEW-DATA                     10670000
109000                                PPS-DATA-ALL                      10680000
109100                                PPS-CBSA                          10690000
109200                                PRICER-OPT-VERS-SW                10700000
109300                                PROV-NEW-HOLD                     10710000
109400                                WAGE-NEW-INDEX-RECORD-CBSA.       10720000
109500                                                                  10730000
109600*----------------------------------------------------------------*10740000
109700*        FISCAL YEAR 2005, RATE YEAR 2006                        *10750000
109800*----------------------------------------------------------------*10760000
109900         IF B-DISCHARGE-DATE > 20050630 AND                       10770000
110000                             < 20051001                           10780000
110100            CALL LTCAL063 USING BILL-NEW-DATA                     10790000
110200                                PPS-DATA-ALL                      10800000
110300                                PPS-CBSA                          10810000
110400                                PRICER-OPT-VERS-SW                10820000
110500                                PROV-NEW-HOLD                     10830000
110600                                WAGE-NEW-INDEX-RECORD-CBSA.       10840000
110700                                                                  10850000
110800*----------------------------------------------------------------*10860000
110900*        FISCAL YEAR 2005, RATE YEAR 2005                        *10870000
111000*----------------------------------------------------------------*10880000
111100         IF B-DISCHARGE-DATE > 20040930 AND                       10890000
111200            B-DISCHARGE-DATE < 20050701                           10900000
111300            CALL LTCAL059 USING BILL-NEW-DATA                     10910000
111400                                PPS-DATA-ALL                      10920000
111500                                PRICER-OPT-VERS-SW                10930000
111600                                PROV-NEW-HOLD                     10940000
111700                                WAGE-NEW-INDEX-RECORD-MSA.        10950000
111800                                                                  10960000
111900**---------------------------------------------------------------*10970000
112000**       FISCAL YEAR 2004, RATE YEAR 2005                        *10980000
112100**---------------------------------------------------------------*10990000
112200         IF B-DISCHARGE-DATE > 20040630 AND                       11000000
112300            B-DISCHARGE-DATE < 20041001                           11010000
112400            CALL LTCAL058 USING BILL-NEW-DATA                     11020000
112500                                PPS-DATA-ALL                      11030000
112600                                PRICER-OPT-VERS-SW                11040000
112700                                PROV-NEW-HOLD                     11050000
112800                                WAGE-NEW-INDEX-RECORD-MSA.        11060000
112900                                                                  11070000
113000**---------------------------------------------------------------*11080000
113100**       FISCAL YEAR 2004, RATE YEAR 2004 (NO LONGER CALLED)     *11090000
113200**---------------------------------------------------------------*11100000
113300         IF B-DISCHARGE-DATE > 20030930 AND                       11110000
113400            B-DISCHARGE-DATE < 20040701                           11120000
113500            CALL LTCAL043 USING BILL-NEW-DATA                     11130000
113600                                PPS-DATA-ALL                      11140000
113700                                PRICER-OPT-VERS-SW                11150000
113800                                PROV-NEW-HOLD                     11160000
113900                                WAGE-NEW-INDEX-RECORD-MSA.        11170000
114000                                                                  11180000
114100**---------------------------------------------------------------*11190000
114200**       FISCAL YEAR 2003, RATE YEAR 2004 (NO LONGER CALLED)     *11200000
114300**---------------------------------------------------------------*11210000
114400         IF B-DISCHARGE-DATE > 20030630 AND                       11220000
114500            B-DISCHARGE-DATE < 20031001                           11230000
114600            CALL LTCAL042 USING BILL-NEW-DATA                     11240000
114700                                PPS-DATA-ALL                      11250000
114800                                PRICER-OPT-VERS-SW                11260000
114900                                PROV-NEW-HOLD                     11270000
115000                                WAGE-NEW-INDEX-RECORD-MSA.        11280000
115100                                                                  11290000
115200**---------------------------------------------------------------*11300000
115300**       FISCAL YEAR 2003, RATE YEAR 2003 (NO LONGER CALLED)     *11310000
115400**---------------------------------------------------------------*11320000
115500         IF B-DISCHARGE-DATE < 20030701                           11330000
115600            CALL LTCAL032 USING BILL-NEW-DATA                     11340000
115700                                PPS-DATA-ALL                      11350000
115800                                PRICER-OPT-VERS-SW                11360000
115900                                PROV-NEW-HOLD                     11370000
116000                                WAGE-NEW-INDEX-RECORD-MSA.        11380000
116100                                                                  11390000
116200                                                                  11400000
116300         GOBACK.                                                  11410000
116400                                                                  11420000
116500******************************************************************11430000
116600******************************************************************11440000
116700                                                                  11450000
116800                                                                  11460000
116900******************************************************************11470000
117000 0500-GET-MSA.                                                    11480000
117100******************************************************************11490000
117200                                                                  11500000
117300     MOVE P-NEW-GEO-LOC-MSAX TO HOLD-PROV-MSA.                    11510000
117400                                                                  11520000
117500     SEARCH M-MSA-DATA VARYING MU1                                11530000
117600       AT END                                                     11540000
117700          MOVE 60 TO PPS-RTC                                      11550000
117800       WHEN MSAX-MSA (MU1) = HOLD-PROV-MSA                        11560000
117900          SET MU2 TO MU1                                          11570000
118000          PERFORM 0600-N-GET-WAGE-INDX                            11580000
118100            THRU 0600-N-EXIT VARYING MU2                          11590000
118200            FROM MU1 BY 1 UNTIL                                   11600000
118300              MSAX-MSA (MU2) NOT = HOLD-PROV-MSA.                 11610000
118400                                                                  11620000
118500 0500-EXIT.                                                       11630000
118600      EXIT.                                                       11640000
118700                                                                  11650000
118800                                                                  11660000
118900******************************************************************11670000
119000 0550-GET-CBSA.                                                   11680000
119100******************************************************************11690000
119200                                                                  11700000
119300     MOVE P-NEW-GEO-LOC-CBSAX TO HOLD-PROV-CBSA.                  11710000
119400                                                                  11720000
119500     SEARCH C-CBSA-DATA VARYING CU1                               11730000
119600        AT END                                                    11740000
119700           MOVE 60 TO PPS-RTC                                     11750000
119800        WHEN CBSAX-CBSA (CU1) = HOLD-PROV-CBSA                    11760000
119900           SET CU2 TO CU1                                         11770000
120000           PERFORM 0650-N-GET-WAGE-INDX                           11780000
120100             THRU 0650-N-EXIT VARYING CU2                         11790000
120200             FROM CU1 BY 1 UNTIL                                  11800000
120300               CBSAX-CBSA (CU2) NOT = HOLD-PROV-CBSA.             11810000
120400                                                                  11820000
120500 0550-EXIT.                                                       11830000
120600      EXIT.                                                       11840000
120700                                                                  11850000
120800                                                                  11860000
120900******************************************************************11870000
121000 0575-GET-IPPS-CBSA.                                              11880000
121100******************************************************************11890000
121200                                                                  11900000
121300     MOVE P-NEW-GEO-LOC-CBSAX TO HOLD-PROV-IPPS-CBSA.             11910000
121400                                                                  11920000
121500                                                                  11930000
121600*------------------------------------------------------------*    11940000
121700* ASSIGN FY 2006 IPPS WAGE INDEX FLOORS                      *    11950000
121800*------------------------------------------------------------*    11960000
121900     IF B-DISCHARGE-DATE > 20050930 AND < 20061001                11970000
122000        PERFORM 0580-FY2006-FLOOR-CBSA THRU 0580-FY2006-EXIT      11980000
122100     END-IF.                                                      11990000
122200                                                                  12000000
122300                                                                  12010000
122400*------------------------------------------------------------*    12020000
122500* ASSIGN FY 2007 IPPS WAGE INDEX FLOORS                      *    12030000
122600*------------------------------------------------------------*    12040000
122700     IF B-DISCHARGE-DATE > 20060930 AND < 20071001                12050000
122800        PERFORM 0580-FY2007-FLOOR-CBSA THRU 0580-FY2007-EXIT      12060000
122900     END-IF.                                                      12070000
123000                                                                  12080000
123100                                                                  12090000
123200*------------------------------------------------------------*    12100000
123300* ASSIGN FY 2008 IPPS WAGE INDEX FLOORS                      *    12110000
123400*------------------------------------------------------------*    12120000
123500     IF B-DISCHARGE-DATE > 20070930 AND < 20081001                12130000
123600        PERFORM 0580-FY2008-FLOOR-CBSA THRU 0580-FY2008-EXIT      12140000
123700     END-IF.                                                      12150000
123800                                                                  12160000
123900                                                                  12170000
124000*------------------------------------------------------------*    12180000
124100* ASSIGN FY 2009 IPPS WAGE INDEX FLOORS                      *    12190000
124200*------------------------------------------------------------*    12200000
124300     IF B-DISCHARGE-DATE > 20080930 AND < 20091001                12210000
124400        PERFORM 0580-FY2009-FLOOR-CBSA THRU 0580-FY2009-EXIT      12220000
124500     END-IF.                                                      12230000
124600                                                                  12240000
124700                                                                  12250000
124800*------------------------------------------------------------*    12260000
124900* ASSIGN FY 2010 IPPS WAGE INDEX FLOORS                      *    12270000
125000*------------------------------------------------------------*    12280000
125100     IF B-DISCHARGE-DATE > 20090930 AND < 20101001                12290000
125200        PERFORM 0580-FY2010-FLOOR-CBSA THRU 0580-FY2010-EXIT      12300000
125300     END-IF.                                                      12310000
125400                                                                  12320000
125500*------------------------------------------------------------*    12330000
125600* ASSIGN FY 2011 IPPS WAGE INDEX FLOORS                      *    12340000
125700*------------------------------------------------------------*    12350000
125800     IF B-DISCHARGE-DATE > 20100930 AND < 20111001                12360000
125900        PERFORM 0580-FY2011-FLOOR-CBSA THRU 0580-FY2011-EXIT      12370000
126000     END-IF.                                                      12380000
126100                                                                  12390000
125500*------------------------------------------------------------*    12400000
125600* ASSIGN FY 2012 IPPS WAGE INDEX FLOORS                      *    12410000
125700*------------------------------------------------------------*    12420000
125800     IF B-DISCHARGE-DATE > 20110930                               12430000
125900        PERFORM 0580-FY2012-FLOOR-CBSA THRU 0580-FY2012-EXIT      12440000
126000     END-IF.                                                      12450000
126100                                                                  12460000
125500*------------------------------------------------------------*    12461001
125600* ASSIGN FY 2013 IPPS WAGE INDEX FLOORS                      *    12462001
125700*------------------------------------------------------------*    12463001
125800     IF B-DISCHARGE-DATE > 20120930                               12464001
125900        PERFORM 0580-FY2013-FLOOR-CBSA THRU 0580-FY2013-EXIT      12465001
126000     END-IF.                                                      12466001
126100                                                                  12467001
126200                                                                  12470000
126300*------------------------------------------------------------*    12480000
126400* SEARCH TABLE FOR IPPS CBSA & GET WAGE INDEX                *    12490000
126500*------------------------------------------------------------*    12500000
126600     SEARCH T-CBSA-DATA VARYING MA1                               12510000
126700        AT END                                                    12520000
126800           MOVE 60 TO PPS-RTC                                     12530000
126900        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA                   12540000
127000           SET MA2 TO MA1                                         12550000
127100           PERFORM 0675-N-GET-IPPS-WAGE-INDX                      12551000
127200              THRU 0675-N-EXIT VARYING MA2                        12552000
127300              FROM MA1 BY 1 UNTIL                                 12553000
127400                   T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA.        12554000
127500                                                                  12555000
127600                                                                  12556000
127700*------------------------------------------------------------*    12557000
127800* GET THE IPPS CBSA SIZE INDICATOR                           *    12558000
127900*------------------------------------------------------------*    12559000
128000* LOGIC REVISED 12/28/2006 FOR VERSION 08.0                  *    12560000
128100*------------------------------------------------------------*    12570000
128200     MOVE P-NEW-GEO-LOC-CBSAX TO HOLD-PROV-IPPS-CBSA.             12580000
128300                                                                  12590000
128400     SEARCH T-CBSA-DATA VARYING MA1                               12600000
128500        AT END                                                    12610000
128600           MOVE 60 TO PPS-RTC                                     12620000
128700        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA                   12630000
128800           SET MA2 TO MA1.                                        12640000
128900                                                                  12650000
129000     IF PPS-RTC = 00                                              12660000
129100        PERFORM 0585-GET-IPPS-CBSA-SIZE                           12670000
129200           THRU 0585-EXIT VARYING MA2                             12680000
129300           FROM MA1 BY 1 UNTIL                                    12690000
129400                T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA.           12700000
129500                                                                  12710000
129600                                                                  12720000
129700*------------------------------------------------------------*    12730000
129800* GET THE PUERTO RICO SPECIFIC WAGE INDEX FOR PR HOSPITALS   *    12740000
129900*------------------------------------------------------------*    12750000
130000     IF P-NEW-STATE = 40                                          12760000
130100        PERFORM 0590-GET-IPPS-CBSA-PR THRU 0590-EXIT              12770000
130200        IF W-IPPS-PR-WAGE-INDEX = 0                               12780000
130300           MOVE 52 TO PPS-RTC                                     12790000
130400        END-IF                                                    12800000
130500     END-IF.                                                      12810000
130600                                                                  12820000
130700                                                                  12830000
130800 0575-EXIT.                                                       12840000
130900      EXIT.                                                       12850000
131000                                                                  12860000
131100                                                                  12870000
131200******************************************************************12880000
131300*                                                                *12890000
131400* FLOOR ASSIGNMENTS FOR FY 2006 ONLY:                            *12900000
131500*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *12910000
131600*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *12920000
131700*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *12930000
131800* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV063             *12940000
131900*                                                                *12950000
132000******************************************************************12960000
132100 0580-FY2006-FLOOR-CBSA.                                          12970000
132200******************************************************************12980000
132300                                                                  12990000
132400     IF HOLD-PROV-IPPS-CBSA = '   10'                             13000000
132500        AND P-NEW-CBSA-SPEC-PAY-IND = 'Y'                         13010000
132600        AND P-NEW-STATE = 10                                      13020000
132700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13030000
132800            MOVE '   10' TO HOLD-PROV-IPPS-CBSA.                  13040000
132900                                                                  13050000
133000     IF HOLD-PROV-IPPS-CBSA = '   50'                             13060000
133100        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                        13070000
133200        AND P-NEW-STATE = 50                                      13080000
133300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13090000
133400            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.                  13100000
133500                                                                  13110000
133600     IF HOLD-PROV-IPPS-CBSA = '10900'                             13120000
133700        AND P-NEW-STATE = 31                                      13130000
133800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13140000
133900            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.                  13150000
134000                                                                  13160000
134100     IF HOLD-PROV-IPPS-CBSA = '15764'                             13170000
134200        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                        13180000
134300        AND P-NEW-STATE = 30                                      13190000
134400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13200000
134500            MOVE '   30' TO HOLD-PROV-IPPS-CBSA.                  13210000
134600                                                                  13220000
134700     IF HOLD-PROV-IPPS-CBSA = '16620'                             13230000
134800        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                        13240000
134900        AND P-NEW-STATE = 36                                      13250000
135000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13260000
135100            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.                  13270000
135200                                                                  13280000
135300     IF HOLD-PROV-IPPS-CBSA = '19060'                             13290000
135400        AND P-NEW-STATE = 21                                      13300000
135500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13310000
135600            MOVE '   21' TO HOLD-PROV-IPPS-CBSA.                  13320000
135700                                                                  13330000
135800     IF HOLD-PROV-IPPS-CBSA = '22020'                             13340000
135900        AND P-NEW-STATE = 24                                      13350000
136000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13360000
136100            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.                  13370000
136200                                                                  13380000
136300     IF HOLD-PROV-IPPS-CBSA = '24220'                             13390000
136400        AND P-NEW-STATE = 24                                      13400000
136500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13410000
136600            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.                  13420000
136700                                                                  13430000
136800     IF HOLD-PROV-IPPS-CBSA = '24580'                             13440000
136900        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                        13450000
137000        AND P-NEW-STATE = 52                                      13460000
137100            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13470000
137200            MOVE '   52' TO HOLD-PROV-IPPS-CBSA.                  13480000
137300                                                                  13490000
137400     IF HOLD-PROV-IPPS-CBSA = '25540'                             13500000
137500        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                        13510000
137600        AND P-NEW-STATE = 07                                      13520000
137700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13530000
137800            MOVE '   07' TO HOLD-PROV-IPPS-CBSA.                  13540000
137900                                                                  13550000
138000     IF HOLD-PROV-IPPS-CBSA = '30300'                             13560000
138100        AND P-NEW-STATE = 50                                      13570000
138200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13580000
138300            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.                  13590000
138400                                                                  13600000
138500     IF HOLD-PROV-IPPS-CBSA = '37620'                             13610000
138600        AND P-NEW-STATE = 36                                      13620000
138700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13630000
138800            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.                  13640000
138900                                                                  13650000
139000     IF HOLD-PROV-IPPS-CBSA = '39900'                             13660000
139100        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                        13670000
139200        AND P-NEW-STATE = 05                                      13680000
139300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13690000
139400            MOVE '   05' TO HOLD-PROV-IPPS-CBSA.                  13700000
139500                                                                  13710000
139600     IF HOLD-PROV-IPPS-CBSA = '48260'                             13720000
139700        AND P-NEW-STATE = 36                                      13730000
139800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13740000
139900            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.                  13750000
140000                                                                  13760000
140100     IF HOLD-PROV-IPPS-CBSA = '48540'                             13770000
140200        AND P-NEW-STATE = 36                                      13780000
140300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13790000
140400            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.                  13800000
140500                                                                  13810000
140600     IF HOLD-PROV-IPPS-CBSA = '48540'                             13820000
140700        AND P-NEW-STATE = 51                                      13830000
140800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13840000
140900            MOVE '   51' TO HOLD-PROV-IPPS-CBSA.                  13850000
141000                                                                  13860000
141100     IF HOLD-PROV-IPPS-CBSA = '48864'                             13870000
141200        AND P-NEW-STATE = 31                                      13880000
141300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13890000
141400            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.                  13900000
141500                                                                  13910000
141600     IF HOLD-PROV-IPPS-CBSA = '49660'                             13920000
141700        AND P-NEW-STATE = 36                                      13930000
141800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   13940000
141900            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.                  13950000
142000                                                                  13960000
142100                                                                  13970000
142200 0580-FY2006-EXIT.                                                13980000
142300      EXIT.                                                       13990000
142400                                                                  14000000
142500                                                                  14010000
142600******************************************************************14020000
142700*                                                                *14030000
142800* FLOOR ASSIGNMENTS FOR FY 2007:                                 *14040000
142900*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *14050000
143000*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *14060000
143100*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *14070000
143200* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV071             *14080000
143300*                                                                *14090000
143400******************************************************************14100000
143500 0580-FY2007-FLOOR-CBSA.                                          14110000
143600******************************************************************14120000
143700                                                                  14130000
143800     IF HOLD-PROV-IPPS-CBSA = '   10'                             14140000
143900        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                        14150000
144000        AND P-NEW-STATE = 10                                      14160000
144100            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   14170000
144200            MOVE '   10' TO HOLD-PROV-IPPS-CBSA.                  14180000
144300                                                                  14190000
144400     IF HOLD-PROV-IPPS-CBSA = '   14'                             14200000
144500        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                        14210000
144600        AND P-NEW-STATE = 14                                      14220000
144700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   14230000
144800            MOVE '   14' TO HOLD-PROV-IPPS-CBSA.                  14240000
144900                                                                  14250000
145000     IF HOLD-PROV-IPPS-CBSA = '   26'                             14260000
145100        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                        14270000
145200        AND P-NEW-STATE = 26                                      14280000
145300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   14290000
145400            MOVE '   26' TO HOLD-PROV-IPPS-CBSA.                  14300000
145500                                                                  14310000
145600     IF HOLD-PROV-IPPS-CBSA = '   50'                             14320000
145700        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                        14330000
145800        AND P-NEW-STATE = 50                                      14340000
145900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   14350000
146000            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.                  14360000
146100                                                                  14370000
146200     IF HOLD-PROV-IPPS-CBSA = '10900'                             14380000
146300        AND P-NEW-STATE = 31                                      14390000
146400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   14400000
146500            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.                  14410000
146600                                                                  14420000
146700     IF HOLD-PROV-IPPS-CBSA = '19060'                             14430000
146800        AND P-NEW-STATE = 21                                      14440000
146900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   14450000
147000            MOVE '   21' TO HOLD-PROV-IPPS-CBSA.                  14460000
147100                                                                  14470000
147200     IF HOLD-PROV-IPPS-CBSA = '22020'                             14480000
147300        AND P-NEW-STATE = 24                                      14490000
147400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   14500000
147500            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.                  14510000
147600                                                                  14520000
147700     IF HOLD-PROV-IPPS-CBSA = '24220'                             14530000
147800        AND P-NEW-STATE = 24                                      14540000
147900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   14550000
148000            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.                  14560000
148100                                                                  14570000
148200     IF HOLD-PROV-IPPS-CBSA = '24580'                             14580000
148300        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                        14590000
148400        AND P-NEW-STATE = 52                                      14600000
148500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   14610000
148600            MOVE '   52' TO HOLD-PROV-IPPS-CBSA.                  14620000
148700                                                                  14630000
148800     IF HOLD-PROV-IPPS-CBSA = '25540'                             14640000
148900        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                        14650000
149000        AND P-NEW-STATE = 07                                      14660000
149100            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   14670000
149200            MOVE '   07' TO HOLD-PROV-IPPS-CBSA.                  14680000
149300                                                                  14690000
149400     IF HOLD-PROV-IPPS-CBSA = '26580'                             14700000
149500        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                        14710000
149600        AND P-NEW-STATE = 36                                      14720000
149700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   14730000
149800            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.                  14740000
149900                                                                  14750000
150000                                                                  14760000
150100*----------------------------------------------------------*      14770000
150200*  ON AND AFTER 11/03/2006, NO HOSPITALS RECLASSIFYING TO  *      14780000
150300*  CBSA 27860 WILL RECEIVE ITS STATE FLOOR DUE TO THE WIX  *      14790000
150400*  CHANGE IN THE IPPS FINAL RULE 2007 CORRECTION NOTICE 1  *      14800000
150500*----------------------------------------------------------*      14810000
150600*  - LOGIC DISABLED 11-20-2006 FOR RELEASE 07.5            *      14820000
150700*  - REINSTATED & ALTERED 12-28-2006 FOR RELEASE 08.0 TO   *      14830000
150800*    MATCH THE IPPS PRICER (BECAUSE THIS CODE ONLY APPLIES *      14840000
150900*    RECLASS PROVIDERS AND THERE ARE NO LTCH RECLASS       *      14850000
151000*    PROVIDERS, THESE CHANGES DO NOT AFFECT BILL PAYMENT)  *      14860000
151100*----------------------------------------------------------*      14870000
151200     IF B-DISCHARGE-DATE < 20061103                               14880000
151300        IF HOLD-PROV-IPPS-CBSA = '27860'                          14890000
151400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     14900000
151500           AND P-NEW-STATE = 26                                   14910000
151600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                14920000
151700               MOVE '   26' TO HOLD-PROV-IPPS-CBSA.               14930000
151800*----------------------------------------------------------*      14940000
151900                                                                  14950000
152000                                                                  14960000
152100     IF HOLD-PROV-IPPS-CBSA = '29100'                             14970000
152200        AND P-NEW-STATE = 52                                      14980000
152300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   14990000
152400            MOVE '   52' TO HOLD-PROV-IPPS-CBSA.                  15000000
152500                                                                  15010000
152600     IF HOLD-PROV-IPPS-CBSA = '30300'                             15020000
152700        AND P-NEW-STATE = 50                                      15030000
152800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   15040000
152900            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.                  15050000
153000                                                                  15060000
153100     IF HOLD-PROV-IPPS-CBSA = '37620'                             15070000
153200        AND P-NEW-STATE = 36                                      15080000
153300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   15090000
153400            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.                  15100000
153500                                                                  15110000
153600     IF HOLD-PROV-IPPS-CBSA = '37964'                             15120000
153700        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                        15130000
153800        AND P-NEW-STATE = 31                                      15140000
153900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   15150000
154000            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.                  15160000
154100                                                                  15170000
154200     IF HOLD-PROV-IPPS-CBSA = '38300'                             15180000
154300        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                        15190000
154400        AND P-NEW-STATE = 36                                      15200000
154500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   15210000
154600            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.                  15220000
154700                                                                  15230000
154800     IF HOLD-PROV-IPPS-CBSA = '39300'                             15240000
154900        AND P-NEW-STATE = 22                                      15250000
155000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   15260000
155100            MOVE '   22' TO HOLD-PROV-IPPS-CBSA.                  15270000
155200                                                                  15280000
155300     IF HOLD-PROV-IPPS-CBSA = '39300'                             15290000
155400        AND P-NEW-STATE = 41                                      15300000
155500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   15310000
155600            MOVE '   41' TO HOLD-PROV-IPPS-CBSA.                  15320000
155700                                                                  15330000
155800     IF HOLD-PROV-IPPS-CBSA = '45500'                             15340000
155900        AND P-NEW-STATE = 45                                      15350000
156000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   15360000
156100            MOVE '   45' TO HOLD-PROV-IPPS-CBSA.                  15370000
156200                                                                  15380000
156300     IF HOLD-PROV-IPPS-CBSA = '48260'                             15390000
156400        AND P-NEW-STATE = 36                                      15400000
156500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   15410000
156600            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.                  15420000
156700                                                                  15430000
156800     IF HOLD-PROV-IPPS-CBSA = '48540'                             15440000
156900        AND P-NEW-STATE = 36                                      15450000
157000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   15460000
157100            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.                  15470000
157200                                                                  15480000
157300     IF HOLD-PROV-IPPS-CBSA = '48540'                             15490000
157400        AND P-NEW-STATE = 51                                      15500000
157500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   15510000
157600            MOVE '   51' TO HOLD-PROV-IPPS-CBSA.                  15520000
157700                                                                  15530000
157800     IF HOLD-PROV-IPPS-CBSA = '48864'                             15540000
157900        AND P-NEW-STATE = 31                                      15550000
158000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                   15560000
158100            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.                  15570000
158200                                                                  15580000
158300                                                                  15590000
158400 0580-FY2007-EXIT.                                                15600000
158500      EXIT.                                                       15610000
158600                                                                  15620000
158700                                                                  15630000
158800******************************************************************15640000
158900*                                                                *15650000
159000* FLOOR ASSIGNMENTS FOR FY 2008:                                 *15660000
159100*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *15670000
159200*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *15680000
159300*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *15690000
159400* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV080             *15700000
159500*                                                                *15710000
159600******************************************************************15720000
159700 0580-FY2008-FLOOR-CBSA.                                          15730000
159800******************************************************************15740000
159900                                                                  15750000
160000        IF HOLD-PROV-IPPS-CBSA = '   39'                          15760000
160100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     15770000
160200           AND P-NEW-STATE = 33                                   15780000
160300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                15790000
160400               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.               15800000
160500                                                                  15810000
160600        IF HOLD-PROV-IPPS-CBSA = '   39'                          15820000
160700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     15830000
160800           AND P-NEW-STATE = 39                                   15840000
160900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                15850000
161000               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.               15860000
161100                                                                  15870000
161200        IF HOLD-PROV-IPPS-CBSA = '10900'                          15880000
161300           AND P-NEW-STATE = 31                                   15890000
161400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                15900000
161500               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               15910000
161600                                                                  15920000
161700        IF HOLD-PROV-IPPS-CBSA = '19060'                          15930000
161800           AND P-NEW-STATE = 21                                   15940000
161900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                15950000
162000               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.               15960000
162100                                                                  15970000
162200        IF HOLD-PROV-IPPS-CBSA = '21780'                          15980000
162300           AND P-NEW-STATE = 15                                   15990000
162400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16000000
162500               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.               16010000
162600                                                                  16020000
162700        IF HOLD-PROV-IPPS-CBSA = '21780'                          16030000
162800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     16040000
162900           AND P-NEW-STATE = 15                                   16050000
163000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16060000
163100               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.               16070000
163200                                                                  16080000
163300        IF HOLD-PROV-IPPS-CBSA = '22020'                          16090000
163400           AND P-NEW-STATE = 24                                   16100000
163500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16110000
163600               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.               16120000
163700                                                                  16130000
163800        IF HOLD-PROV-IPPS-CBSA = '24220'                          16140000
163900           AND P-NEW-STATE = 24                                   16150000
164000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16160000
164100               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.               16170000
164200                                                                  16180000
164300        IF HOLD-PROV-IPPS-CBSA = '24580'                          16190000
164400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     16200000
164500           AND P-NEW-STATE = 52                                   16210000
164600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16220000
164700               MOVE '   52' TO HOLD-PROV-IPPS-CBSA.               16230000
164800                                                                  16240000
164900        IF HOLD-PROV-IPPS-CBSA = '25540'                          16250000
165000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     16260000
165100           AND P-NEW-STATE = 07                                   16270000
165200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16280000
165300               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.               16290000
165400                                                                  16300000
165500        IF HOLD-PROV-IPPS-CBSA = '28420'                          16310000
165600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     16320000
165700           AND P-NEW-STATE = 50                                   16330000
165800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16340000
165900               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.               16350000
166000                                                                  16360000
166100        IF HOLD-PROV-IPPS-CBSA = '28700'                          16370000
166200           AND P-NEW-STATE = 44                                   16380000
166300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16390000
166400               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.               16400000
166500                                                                  16410000
166600        IF HOLD-PROV-IPPS-CBSA = '28700'                          16420000
166700           AND P-NEW-STATE = 49                                   16430000
166800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16440000
166900               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.               16450000
167000                                                                  16460000
167100        IF HOLD-PROV-IPPS-CBSA = '30300'                          16470000
167200           AND P-NEW-STATE = 50                                   16480000
167300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16490000
167400               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.               16500000
167500                                                                  16510000
167600        IF HOLD-PROV-IPPS-CBSA = '35084'                          16520000
167700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     16530000
167800           AND P-NEW-STATE = 31                                   16540000
167900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16550000
168000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               16560000
168100                                                                  16570000
168200        IF HOLD-PROV-IPPS-CBSA = '37620'                          16580000
168300           AND P-NEW-STATE = 36                                   16590000
168400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16600000
168500               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               16610000
168600                                                                  16620000
168700        IF HOLD-PROV-IPPS-CBSA = '37964'                          16630000
168800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     16640000
168900           AND P-NEW-STATE = 31                                   16650000
169000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16660000
169100               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               16670000
169200                                                                  16680000
169300        IF HOLD-PROV-IPPS-CBSA = '38300'                          16690000
169400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     16700000
169500           AND P-NEW-STATE = 36                                   16710000
169600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16720000
169700               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               16730000
169800                                                                  16740000
169900        IF HOLD-PROV-IPPS-CBSA = '45500'                          16750000
170000           AND P-NEW-STATE = 45                                   16760000
170100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16770000
170200               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.               16780000
170300                                                                  16790000
170400        IF HOLD-PROV-IPPS-CBSA = '48260'                          16800000
170500           AND P-NEW-STATE = 36                                   16810000
170600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16820000
170700               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               16830000
170800                                                                  16840000
170900        IF HOLD-PROV-IPPS-CBSA = '48540'                          16850000
171000           AND P-NEW-STATE = 36                                   16860000
171100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16870000
171200               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               16880000
171300                                                                  16890000
171400        IF HOLD-PROV-IPPS-CBSA = '48540'                          16900000
171500           AND P-NEW-STATE = 51                                   16910000
171600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16920000
171700               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.               16930000
171800                                                                  16940000
171900        IF HOLD-PROV-IPPS-CBSA = '48864'                          16950000
172000           AND P-NEW-STATE = 31                                   16960000
172100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                16970000
172200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               16980000
172300                                                                  16990000
172400        IF HOLD-PROV-IPPS-CBSA = '48864'                          17000000
172500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     17010000
172600           AND P-NEW-STATE = 31                                   17020000
172700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                17030000
172800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               17040000
172900                                                                  17050000
173000                                                                  17060000
173100 0580-FY2008-EXIT.                                                17070000
173200      EXIT.                                                       17080000
173300                                                                  17090000
173400                                                                  17100000
173500******************************************************************17110000
173600*                                                                *17120000
173700* FLOOR ASSIGNMENTS FOR FY 2009:                                 *17130000
173800*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *17140000
173900*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *17150000
174000*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *17160000
174100* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV093             *17170000
174200*                                                                *17180000
174300******************************************************************17190000
174400 0580-FY2009-FLOOR-CBSA.                                          17200000
174500******************************************************************17210000
174600                                                                  17220000
174700        IF HOLD-PROV-IPPS-CBSA = '   04'                          17230000
174800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     17240000
174900           AND P-NEW-STATE = 04                                   17250000
175000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                17260000
175100               MOVE '   04' TO HOLD-PROV-IPPS-CBSA.               17270000
175200                                                                  17280000
175300        IF HOLD-PROV-IPPS-CBSA = '   04'                          17290000
175400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     17300000
175500           AND P-NEW-STATE = 19                                   17310000
175600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                17320000
175700               MOVE '   19' TO HOLD-PROV-IPPS-CBSA.               17330000
175800                                                                  17340000
175900        IF HOLD-PROV-IPPS-CBSA = '   14'                          17350000
176000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     17360000
176100           AND P-NEW-STATE = 14                                   17370000
176200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                17380000
176300               MOVE '   14' TO HOLD-PROV-IPPS-CBSA.               17390000
176400                                                                  17400000
176500        IF HOLD-PROV-IPPS-CBSA = '   14'                          17410000
176600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     17420000
176700           AND P-NEW-STATE = 26                                   17430000
176800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                17440000
176900               MOVE '   26' TO HOLD-PROV-IPPS-CBSA.               17450000
177000                                                                  17460000
177100        IF HOLD-PROV-IPPS-CBSA = '10900'                          17470000
177200           AND P-NEW-STATE = 31                                   17480000
177300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                17490000
177400               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               17500000
177500                                                                  17510000
177600        IF HOLD-PROV-IPPS-CBSA = '19340'                          17520000
177700           AND P-NEW-STATE = 16                                   17530000
177800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                17540000
177900               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.               17550000
178000                                                                  17560000
178100        IF HOLD-PROV-IPPS-CBSA = '21780'                          17570000
178200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     17580000
178300           AND P-NEW-STATE = 15                                   17590000
178400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                17600000
178500               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.               17610000
178600                                                                  17620000
178700        IF HOLD-PROV-IPPS-CBSA = '22020'                          17630000
178800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     17640000
178900           AND P-NEW-STATE = 43                                   17650000
179000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                17660000
179100               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.               17670000
179200                                                                  17680000
179300        IF HOLD-PROV-IPPS-CBSA = '22900'                          17690000
179400           AND P-NEW-STATE = 37                                   17700000
179500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                17710000
179600               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.               17720000
179700                                                                  17730000
179800        IF HOLD-PROV-IPPS-CBSA = '24580'                          17740000
179900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     17750000
180000           AND P-NEW-STATE = 52                                   17760000
180100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                17770000
180200               MOVE '   52' TO HOLD-PROV-IPPS-CBSA.               17780000
180300                                                                  17790000
180400        IF HOLD-PROV-IPPS-CBSA = '25540'                          17800000
180500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     17810000
180600           AND P-NEW-STATE = 07                                   17820000
180700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                17830000
180800               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.               17840000
180900                                                                  17850000
181000        IF HOLD-PROV-IPPS-CBSA = '28420'                          17860000
181100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     17870000
181200           AND P-NEW-STATE = 50                                   17880000
181300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                17890000
181400               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.               17900000
181500                                                                  17910000
181600        IF HOLD-PROV-IPPS-CBSA = '28700'                          17920000
181700           AND P-NEW-STATE = 44                                   17930000
181800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                17940000
181900               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.               17950000
182000                                                                  17960000
182100        IF HOLD-PROV-IPPS-CBSA = '28700'                          17970000
182200           AND P-NEW-STATE = 49                                   17980000
182300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                17990000
182400               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.               18000000
182500                                                                  18010000
182600        IF HOLD-PROV-IPPS-CBSA = '28700'                          18020000
182700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     18030000
182800           AND P-NEW-STATE = 18                                   18040000
182900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18050000
183000               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.               18060000
183100                                                                  18070000
183200        IF HOLD-PROV-IPPS-CBSA = '28700'                          18080000
183300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     18090000
183400           AND P-NEW-STATE = 44                                   18100000
183500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18110000
183600               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.               18120000
183700                                                                  18130000
183800        IF HOLD-PROV-IPPS-CBSA = '28940'                          18140000
183900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     18150000
184000           AND P-NEW-STATE = 18                                   18160000
184100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18170000
184200               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.               18180000
184300                                                                  18190000
184400        IF HOLD-PROV-IPPS-CBSA = '28940'                          18200000
184500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     18210000
184600           AND P-NEW-STATE = 44                                   18220000
184700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18230000
184800               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.               18240000
184900                                                                  18250000
185000        IF HOLD-PROV-IPPS-CBSA = '34820'                          18260000
185100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     18270000
185200           AND P-NEW-STATE = 34                                   18280000
185300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18290000
185400               MOVE '   34' TO HOLD-PROV-IPPS-CBSA.               18300000
185500                                                                  18310000
185600        IF HOLD-PROV-IPPS-CBSA = '34820'                          18320000
185700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     18330000
185800           AND P-NEW-STATE = 42                                   18340000
185900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18350000
186000               MOVE '   42' TO HOLD-PROV-IPPS-CBSA.               18360000
186100                                                                  18370000
186200        IF HOLD-PROV-IPPS-CBSA = '37620'                          18380000
186300           AND P-NEW-STATE = 36                                   18390000
186400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18400000
186500               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               18410000
186600                                                                  18420000
186700        IF HOLD-PROV-IPPS-CBSA = '37964'                          18430000
186800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     18440000
186900           AND P-NEW-STATE = 31                                   18450000
187000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18460000
187100               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               18470000
187200                                                                  18480000
187300        IF HOLD-PROV-IPPS-CBSA = '38340'                          18490000
187400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     18500000
187500           AND P-NEW-STATE = 47                                   18510000
187600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18520000
187700               MOVE '   47' TO HOLD-PROV-IPPS-CBSA.               18530000
187800                                                                  18540000
187900        IF HOLD-PROV-IPPS-CBSA = '41620'                          18550000
188000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     18560000
188100           AND P-NEW-STATE = 29                                   18570000
188200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18580000
188300               MOVE '   29' TO HOLD-PROV-IPPS-CBSA.               18590000
188400                                                                  18600000
188500        IF HOLD-PROV-IPPS-CBSA = '43580'                          18610000
188600           AND P-NEW-STATE = 16                                   18620000
188700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18630000
188800               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.               18640000
188900                                                                  18650000
189000        IF HOLD-PROV-IPPS-CBSA = '48540'                          18660000
189100           AND P-NEW-STATE = 36                                   18670000
189200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18680000
189300               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               18690000
189400                                                                  18700000
189500        IF HOLD-PROV-IPPS-CBSA = '48540'                          18710000
189600           AND P-NEW-STATE = 51                                   18720000
189700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18730000
189800               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.               18740000
189900                                                                  18750000
190000        IF HOLD-PROV-IPPS-CBSA = '48864'                          18760000
190100           AND P-NEW-STATE = 31                                   18770000
190200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18780000
190300               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               18790000
190400                                                                  18800000
190500        IF HOLD-PROV-IPPS-CBSA = '48864'                          18810000
190600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     18820000
190700           AND P-NEW-STATE = 31                                   18830000
190800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18840000
190900               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               18850000
191000                                                                  18860000
191100        IF HOLD-PROV-IPPS-CBSA = '19060'                          18870000
191200           AND P-NEW-STATE = 21                                   18880000
191300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18890000
191400               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.               18900000
191500                                                                  18910000
191600        IF HOLD-PROV-IPPS-CBSA = '19060'                          18920000
191700           AND P-NEW-STATE = 51                                   18930000
191800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18940000
191900               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.               18950000
192000                                                                  18960000
192100        IF HOLD-PROV-IPPS-CBSA = '22020'                          18970000
192200           AND P-NEW-STATE = 24                                   18980000
192300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                18990000
192400               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.               19000000
192500                                                                  19010000
192600        IF HOLD-PROV-IPPS-CBSA = '24220'                          19020000
192700           AND P-NEW-STATE = 24                                   19030000
192800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                19040000
192900               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.               19050000
193000                                                                  19060000
193100        IF HOLD-PROV-IPPS-CBSA = '30300'                          19070000
193200           AND P-NEW-STATE = 50                                   19080000
193300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                19090000
193400               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.               19100000
193500                                                                  19110000
193600        IF HOLD-PROV-IPPS-CBSA = '48260'                          19120000
193700           AND P-NEW-STATE = 36                                   19130000
193800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                19140000
193900               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               19150000
194000                                                                  19160000
194100                                                                  19170000
194200 0580-FY2009-EXIT.                                                19180000
194300      EXIT.                                                       19190000
194400                                                                  19200000
194500                                                                  19210000
194600******************************************************************19220000
194700*                                                                *19230000
194800* FLOOR ASSIGNMENTS FOR FY 2010:                                 *19240000
194900*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *19250000
195000*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *19260000
195100*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *19270000
195200* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV100             *19280000
195300*                                                                *19290000
195400******************************************************************19300000
195500 0580-FY2010-FLOOR-CBSA.                                          19310000
195600******************************************************************19320000
195700                                                                  19330000
195800        IF HOLD-PROV-IPPS-CBSA = '   33'                          19340000
195900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     19350000
196000           AND P-NEW-STATE = 30                                   19360000
196100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                19370000
196200               MOVE '   30' TO HOLD-PROV-IPPS-CBSA.               19380000
196300                                                                  19390000
196400        IF HOLD-PROV-IPPS-CBSA = '   33'                          19400000
196500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     19410000
196600           AND P-NEW-STATE = 33                                   19420000
196700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                19430000
196800               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.               19440000
196900                                                                  19450000
197000        IF HOLD-PROV-IPPS-CBSA = '10900'                          19460000
197100           AND P-NEW-STATE = 31                                   19470000
197200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                19480000
197300               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               19490000
197400                                                                  19500000
197500        IF HOLD-PROV-IPPS-CBSA = '19340'                          19510000
197600           AND P-NEW-STATE = 16                                   19520000
197700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                19530000
197800               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.               19540000
197900                                                                  19550000
198000        IF HOLD-PROV-IPPS-CBSA = '19340'                          19560000
198100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     19570000
198200           AND P-NEW-STATE = 16                                   19580000
198300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                19590000
198400               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.               19600000
198500                                                                  19610000
198600        IF HOLD-PROV-IPPS-CBSA = '21780'                          19620000
198700           AND P-NEW-STATE = 15                                   19630000
198800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                19640000
198900               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.               19650000
199000                                                                  19660000
199100        IF HOLD-PROV-IPPS-CBSA = '21780'                          19670000
199200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     19680000
199300           AND P-NEW-STATE = 15                                   19690000
199400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                19700000
199500               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.               19710000
199600                                                                  19720000
199700        IF HOLD-PROV-IPPS-CBSA = '25180'                          19730000
199800           AND P-NEW-STATE = 21                                   19740000
199900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                19750000
200000               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.               19760000
200100                                                                  19770000
200200        IF HOLD-PROV-IPPS-CBSA = '25540'                          19780000
200300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     19790000
200400           AND P-NEW-STATE = 07                                   19800000
200500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                19810000
200600               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.               19820000
200700                                                                  19830000
200800        IF HOLD-PROV-IPPS-CBSA = '28420'                          19840000
200900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     19850000
201000           AND P-NEW-STATE = 50                                   19860000
201100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                19870000
201200               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.               19880000
201300                                                                  19890000
201400        IF HOLD-PROV-IPPS-CBSA = '28940'                          19900000
201500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     19910000
201600           AND P-NEW-STATE = 18                                   19920000
201700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                19930000
201800               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.               19940000
201900                                                                  19950000
202000        IF HOLD-PROV-IPPS-CBSA = '28940'                          19960000
202100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     19970000
202200           AND P-NEW-STATE = 44                                   19980000
202300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                19990000
202400               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.               20000000
202500                                                                  20010000
202600        IF HOLD-PROV-IPPS-CBSA = '35084'                          20020000
202700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     20030000
202800           AND P-NEW-STATE = 31                                   20040000
202900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20050000
203000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               20060000
203100                                                                  20070000
203200        IF HOLD-PROV-IPPS-CBSA = '37620'                          20080000
203300           AND P-NEW-STATE = 36                                   20090000
203400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20100000
203500               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               20110000
203600                                                                  20120000
203700        IF HOLD-PROV-IPPS-CBSA = '37964'                          20130000
203800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     20140000
203900           AND P-NEW-STATE = 31                                   20150000
204000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20160000
204100               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               20170000
204200                                                                  20180000
204300        IF HOLD-PROV-IPPS-CBSA = '48540'                          20190000
204400           AND P-NEW-STATE = 36                                   20200000
204500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20210000
204600               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               20220000
204700                                                                  20230000
204800        IF HOLD-PROV-IPPS-CBSA = '48540'                          20240000
204900           AND P-NEW-STATE = 51                                   20250000
205000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20260000
205100               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.               20270000
205200                                                                  20280000
205300        IF HOLD-PROV-IPPS-CBSA = '48864'                          20290000
205400           AND P-NEW-STATE = 31                                   20300000
205500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20310000
205600               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               20320000
205700                                                                  20330000
205800        IF HOLD-PROV-IPPS-CBSA = '48864'                          20340000
205900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     20350000
206000           AND P-NEW-STATE = 31                                   20360000
206100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20370000
206200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               20380000
206300                                                                  20390000
206400        IF HOLD-PROV-IPPS-CBSA = '49660'                          20400000
206500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     20410000
206600           AND P-NEW-STATE = 36                                   20420000
206700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20430000
206800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               20440000
206900                                                                  20450000
207000        IF HOLD-PROV-IPPS-CBSA = '19060'                          20460000
207100           AND P-NEW-STATE = 21                                   20470000
207200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20480000
207300               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.               20490000
207400                                                                  20500000
207500        IF HOLD-PROV-IPPS-CBSA = '22020'                          20510000
207600           AND P-NEW-STATE = 24                                   20520000
207700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20530000
207800               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.               20540000
207900                                                                  20550000
208000        IF HOLD-PROV-IPPS-CBSA = '24220'                          20560000
208100           AND P-NEW-STATE = 24                                   20570000
208200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20580000
208300               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.               20590000
208400                                                                  20600000
208500        IF HOLD-PROV-IPPS-CBSA = '30300'                          20610000
208600           AND P-NEW-STATE = 50                                   20620000
208700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20630000
208800               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.               20640000
208900                                                                  20650000
209000        IF HOLD-PROV-IPPS-CBSA = '35084'                          20660000
209100           AND P-NEW-STATE = 31                                   20670000
209200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20680000
209300               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               20690000
209400                                                                  20700000
209500        IF HOLD-PROV-IPPS-CBSA = '48260'                          20710000
209600           AND P-NEW-STATE = 36                                   20720000
209700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20730000
209800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               20740000
209900                                                                  20750000
210000        IF HOLD-PROV-IPPS-CBSA = '48260'                          20760000
210100           AND P-NEW-STATE = 51                                   20770000
210200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20780000
210300               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.               20790000
210400                                                                  20800000
210500                                                                  20810000
210600 0580-FY2010-EXIT.                                                20820000
210700      EXIT.                                                       20830000
210800                                                                  20840000
210900******************************************************************20850000
211000*                                                                *20860000
211100* FLOOR ASSIGNMENTS FOR FY 2011:                                 *20870000
211200* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV110             *20880000
211300*                                                                *20890000
211400******************************************************************20900000
211500                                                                  20910000
211600 0580-FY2011-FLOOR-CBSA.                                          20920000
211700                                                                  20930000
211800        IF HOLD-PROV-IPPS-CBSA = '   45'                          20940000
211900          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                      20950000
212000          AND P-NEW-STATE = 45                                    20960000
212100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                20970000
212200               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.               20980000
212300                                                                  20990000
212400        IF HOLD-PROV-IPPS-CBSA = '   37'                          21000000
212500          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                      21010000
212600          AND P-NEW-STATE = 37                                    21020000
212700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21030000
212800               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.               21040000
212900                                                                  21050000
213000        IF HOLD-PROV-IPPS-CBSA = '10900'                          21060000
213100           AND P-NEW-STATE = 31                                   21070000
213200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21080000
213300               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               21090000
213400                                                                  21100000
213500        IF HOLD-PROV-IPPS-CBSA = '21500'                          21110000
213600          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                      21120000
213700           AND P-NEW-STATE = 33                                   21130000
213800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21140000
213900               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.               21150000
214000                                                                  21160000
214100        IF HOLD-PROV-IPPS-CBSA = '21500'                          21170000
214200          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                      21180000
214300           AND P-NEW-STATE = 39                                   21190000
214400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21200000
214500               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.               21210000
214600                                                                  21220000
214700        IF HOLD-PROV-IPPS-CBSA = '21780'                          21230000
214800           AND P-NEW-STATE = 15                                   21240000
214900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21250000
215000               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.               21260000
215100                                                                  21270000
215200        IF HOLD-PROV-IPPS-CBSA = '22900'                          21280000
215300           AND P-NEW-STATE = 37                                   21290000
215400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21300000
215500               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.               21310000
215600                                                                  21320000
215700        IF HOLD-PROV-IPPS-CBSA = '24540'                          21330000
215800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     21340000
215900           AND P-NEW-STATE = 53                                   21350000
216000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21360000
216100               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.               21370000
216200                                                                  21380000
216300        IF HOLD-PROV-IPPS-CBSA = '25540'                          21390000
216400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     21400000
216500           AND P-NEW-STATE = 07                                   21410000
216600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21420000
216700               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.               21430000
216800                                                                  21440000
216900        IF HOLD-PROV-IPPS-CBSA = '28700'                          21450000
217000           AND P-NEW-STATE = 44                                   21460000
217100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21470000
217200               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.               21480000
217300                                                                  21490000
217400        IF HOLD-PROV-IPPS-CBSA = '28700'                          21500000
217500           AND P-NEW-STATE = 49                                   21510000
217600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21520000
217700               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.               21530000
217800                                                                  21540000
217900        IF HOLD-PROV-IPPS-CBSA = '28940'                          21550000
218000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     21560000
218100           AND P-NEW-STATE = 18                                   21570000
218200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21580000
218300               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.               21590000
218400                                                                  21600000
218500        IF HOLD-PROV-IPPS-CBSA = '28940'                          21610000
218600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     21620000
218700           AND P-NEW-STATE = 44                                   21630000
218800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21640000
218900               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.               21650000
219000                                                                  21660000
219100        IF HOLD-PROV-IPPS-CBSA = '37620'                          21670000
219200           AND P-NEW-STATE = 36                                   21680000
219300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21690000
219400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               21700000
219500                                                                  21710000
219600        IF HOLD-PROV-IPPS-CBSA = '37620'                          21720000
219700           AND P-NEW-STATE = 51                                   21730000
219800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21740000
219900               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.               21750000
220000                                                                  21760000
220100        IF HOLD-PROV-IPPS-CBSA = '37964'                          21770000
220200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     21780000
220300           AND P-NEW-STATE = 31                                   21790000
220400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21800000
220500               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               21810000
220600                                                                  21820000
220700        IF HOLD-PROV-IPPS-CBSA = '38300'                          21830000
220800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     21840000
220900           AND P-NEW-STATE = 36                                   21850000
221000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21860000
221100               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               21870000
221200                                                                  21880000
221300        IF HOLD-PROV-IPPS-CBSA = '38300'                          21890000
221400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     21900000
221500           AND P-NEW-STATE = 39                                   21910000
221600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21920000
221700               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.               21930000
221800                                                                  21940000
221900        IF HOLD-PROV-IPPS-CBSA = '43580'                          21950000
222000           AND P-NEW-STATE = 43                                   21960000
222100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                21970000
222200               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.               21980000
222300                                                                  21990000
222400        IF HOLD-PROV-IPPS-CBSA = '48540'                          22000000
222500           AND P-NEW-STATE = 36                                   22010000
222600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22020000
222700               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               22030000
222800                                                                  22040000
222900        IF HOLD-PROV-IPPS-CBSA = '48540'                          22050000
223000           AND P-NEW-STATE = 51                                   22060000
223100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22070000
223200               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.               22080000
223300                                                                  22090000
223400        IF HOLD-PROV-IPPS-CBSA = '48864'                          22100000
223500           AND P-NEW-STATE = 31                                   22110000
223600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22120000
223700               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               22130000
223800                                                                  22140000
223900        IF HOLD-PROV-IPPS-CBSA = '17300'                          22150000
224000           AND P-NEW-STATE = 18                                   22160000
224100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22170000
224200               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.               22180000
224300                                                                  22190000
224400        IF HOLD-PROV-IPPS-CBSA = '17300'                          22200000
224500           AND P-NEW-STATE = 44                                   22210000
224600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22220000
224700               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.               22230000
224800                                                                  22240000
224900        IF HOLD-PROV-IPPS-CBSA = '19060'                          22250000
225000           AND P-NEW-STATE = 21                                   22260000
225100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22270000
225200               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.               22280000
225300                                                                  22290000
225400        IF HOLD-PROV-IPPS-CBSA = '22020'                          22300000
225500           AND P-NEW-STATE = 24                                   22310000
225600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22320000
225700               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.               22330000
225800                                                                  22340000
225900        IF HOLD-PROV-IPPS-CBSA = '22020'                          22350000
226000           AND P-NEW-STATE = 35                                   22360000
226100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22370000
226200               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.               22380000
226300                                                                  22390000
226400        IF HOLD-PROV-IPPS-CBSA = '24220'                          22400000
226500           AND P-NEW-STATE = 24                                   22410000
226600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22420000
226700               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.               22430000
226800                                                                  22440000
226900        IF HOLD-PROV-IPPS-CBSA = '24220'                          22450000
227000           AND P-NEW-STATE = 35                                   22460000
227100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22470000
227200               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.               22480000
227300                                                                  22490000
227400        IF HOLD-PROV-IPPS-CBSA = '30300'                          22500000
227500           AND P-NEW-STATE = 50                                   22510000
227600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22520000
227700               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.               22530000
227800                                                                  22540000
227900        IF HOLD-PROV-IPPS-CBSA = '44600'                          22550000
228000           AND P-NEW-STATE = 36                                   22560000
228100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22570000
228200               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               22580000
228300                                                                  22590000
228400        IF HOLD-PROV-IPPS-CBSA = '44600'                          22600000
228500           AND P-NEW-STATE = 51                                   22610000
228600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22620000
228700               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.               22630000
228800                                                                  22640000
228900        IF HOLD-PROV-IPPS-CBSA = '45500'                          22650000
229000           AND P-NEW-STATE = 45                                   22660000
229100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22670000
229200               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.               22680000
229300                                                                  22690000
229400                                                                  22700000
229500 0580-FY2011-EXIT.                                                22710000
229600      EXIT.                                                       22720000
229700                                                                  22730000
210900******************************************************************22740000
211000*                                                                *22750000
211100* FLOOR ASSIGNMENTS FOR FY 2012:                                 *22760000
211200* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV120             *22770000
211000*                                                                *22780000
211300* ******* CHANGE HOLD-PROV-CBSA TO HOLD-PROV-IPPS-CBSA ******    *22790000
211000*                                                                *22800000
211400******************************************************************22810000
211500                                                                  22820000
211600 0580-FY2012-FLOOR-CBSA.                                          22830000
377900                                                                  22840000
378000**************YEARCHANGE 2012.0 ******************************    22850000
378100                                                                  22860000
378200        IF HOLD-PROV-IPPS-CBSA = '   30'                          22870000
378300          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                      22880000
378400          AND P-NEW-STATE = 30                                    22890000
378500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22900000
378600               MOVE '   30' TO HOLD-PROV-IPPS-CBSA.               22901000
378700                                                                  22902000
378800        IF HOLD-PROV-IPPS-CBSA = '   39'                          22903000
378900          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                      22904000
379000          AND P-NEW-STATE = 39                                    22905000
379100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22906000
379200               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.               22907000
379300                                                                  22908000
379400        IF HOLD-PROV-IPPS-CBSA = '   39'                          22908100
379500          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                      22908200
379600          AND P-NEW-STATE = 33                                    22908300
379700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22908400
379800               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.               22908500
379900                                                                  22908600
380000        IF HOLD-PROV-IPPS-CBSA = '10900'                          22908700
380100           AND P-NEW-STATE = 31                                   22908800
380200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22908900
380300               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               22909000
380400                                                                  22909100
380500        IF HOLD-PROV-IPPS-CBSA = '14484'                          22909200
380600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22909300
380700           AND P-NEW-STATE = 22                                   22909400
380800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22909500
380900               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.               22909600
381000                                                                  22909700
381100        IF HOLD-PROV-IPPS-CBSA = '16020'                          22909800
381200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22909900
381300           AND P-NEW-STATE = 14                                   22910000
381400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22911000
381500               MOVE '   14' TO HOLD-PROV-IPPS-CBSA.               22912000
381600                                                                  22913000
381700        IF HOLD-PROV-IPPS-CBSA = '21500'                          22914000
381800          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                      22915000
381900           AND P-NEW-STATE = 33                                   22916000
382000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22917000
382100               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.               22918000
382200                                                                  22919000
382300        IF HOLD-PROV-IPPS-CBSA = '21500'                          22919100
382400          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                      22919200
382500           AND P-NEW-STATE = 39                                   22919300
382600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22919400
382700               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.               22919500
382800                                                                  22919600
382900        IF HOLD-PROV-IPPS-CBSA = '22900'                          22919700
383000           AND P-NEW-STATE = 37                                   22919800
383100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22919900
383200               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.               22920000
383300                                                                  22920100
383400        IF HOLD-PROV-IPPS-CBSA = '25180'                          22920200
383500           AND P-NEW-STATE = 21                                   22920300
383600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22920400
383700               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.               22920500
383800                                                                  22920600
383900        IF HOLD-PROV-IPPS-CBSA = '25540'                          22920700
384000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22920800
384100           AND P-NEW-STATE = 07                                   22920900
384200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22921000
384300               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.               22921100
384400                                                                  22921200
384500        IF HOLD-PROV-IPPS-CBSA = '25540'                          22921300
384600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22921400
384700           AND P-NEW-STATE = 22                                   22921500
384800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22921600
384900               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.               22921700
385000                                                                  22921800
385100        IF HOLD-PROV-IPPS-CBSA = '26820'                          22921900
385200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22922000
385300           AND P-NEW-STATE = 53                                   22922100
385400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22922200
385500               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.               22922300
385600                                                                  22922400
385700        IF HOLD-PROV-IPPS-CBSA = '28700'                          22922500
385800           AND P-NEW-STATE = 44                                   22922600
385900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22922700
386000               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.               22922800
386100                                                                  22922900
386200        IF HOLD-PROV-IPPS-CBSA = '28700'                          22923000
386300           AND P-NEW-STATE = 49                                   22923100
386400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22923200
386500               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.               22923300
386600                                                                  22923400
386700        IF HOLD-PROV-IPPS-CBSA = '28700'                          22923500
386800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22923600
386900           AND P-NEW-STATE = 18                                   22923700
387000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22923800
387100               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.               22923900
387200                                                                  22924000
387300        IF HOLD-PROV-IPPS-CBSA = '28700'                          22924100
387400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22924200
387500           AND P-NEW-STATE = 44                                   22924300
387600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22924400
387700               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.               22924500
387800                                                                  22924600
387900        IF HOLD-PROV-IPPS-CBSA = '28940'                          22924700
388000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22924800
388100           AND P-NEW-STATE = 18                                   22924900
388200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22925000
388300               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.               22925100
388400                                                                  22925200
388500        IF HOLD-PROV-IPPS-CBSA = '35084'                          22925300
388600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22925400
388700           AND P-NEW-STATE = 31                                   22925500
388800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22925600
388900               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               22925700
389000                                                                  22925800
389100        IF HOLD-PROV-IPPS-CBSA = '37620'                          22925900
389200           AND P-NEW-STATE = 36                                   22926000
389300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22926100
389400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               22926200
389500                                                                  22926300
389600        IF HOLD-PROV-IPPS-CBSA = '37964'                          22926400
389700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22926500
389800           AND P-NEW-STATE = 31                                   22926600
389900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22926700
390000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               22926800
390100                                                                  22926900
390200        IF HOLD-PROV-IPPS-CBSA = '43580'                          22927000
390300           AND P-NEW-STATE = 43                                   22927100
390400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22927200
390500               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.               22927300
390600                                                                  22927400
390700        IF HOLD-PROV-IPPS-CBSA = '44600'                          22927500
390800           AND P-NEW-STATE = 36                                   22927600
390900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22927700
391000               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               22927800
391100                                                                  22927900
391200        IF HOLD-PROV-IPPS-CBSA = '44600'                          22928000
391300           AND P-NEW-STATE = 51                                   22928100
391400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22928200
391500               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.               22928300
391600                                                                  22928400
391700        IF HOLD-PROV-IPPS-CBSA = '48540'                          22928500
391800           AND P-NEW-STATE = 36                                   22928600
391900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22928700
392000               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               22928800
392100                                                                  22928900
392200        IF HOLD-PROV-IPPS-CBSA = '48540'                          22929000
392300           AND P-NEW-STATE = 51                                   22929100
392400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22929200
392500               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.               22929300
392600                                                                  22929400
392700        IF HOLD-PROV-IPPS-CBSA = '48864'                          22929500
392800           AND P-NEW-STATE = 31                                   22929600
392900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22929700
393000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               22929800
393100                                                                  22929900
393200        IF HOLD-PROV-IPPS-CBSA = '49660'                          22930000
393300           AND P-NEW-STATE = 36                                   22930100
393400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22930200
393500               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               22930300
393600                                                                  22930400
393700        IF HOLD-PROV-IPPS-CBSA = '49660'                          22930500
393800           AND P-NEW-STATE = 39                                   22930600
393900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22930700
394000               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.               22930800
394100                                                                  22930900
394200        IF HOLD-PROV-IPPS-CBSA = '19060'                          22931000
394300           AND P-NEW-STATE = 21                                   22931100
394400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22931200
394500               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.               22931300
394600                                                                  22931400
394700        IF HOLD-PROV-IPPS-CBSA = '22020'                          22931500
394800           AND P-NEW-STATE = 24                                   22931600
394900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22931700
395000               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.               22931800
395100                                                                  22931900
395200        IF HOLD-PROV-IPPS-CBSA = '22020'                          22932000
395300           AND P-NEW-STATE = 35                                   22932100
395400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22932200
395500               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.               22932300
395600                                                                  22932400
395700        IF HOLD-PROV-IPPS-CBSA = '24220'                          22932500
395800           AND P-NEW-STATE = 24                                   22932600
395900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22932700
396000               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.               22932800
396100                                                                  22932900
396200        IF HOLD-PROV-IPPS-CBSA = '24220'                          22933000
396300           AND P-NEW-STATE = 35                                   22933100
396400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22933200
396500               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.               22933300
396600                                                                  22933400
396700        IF HOLD-PROV-IPPS-CBSA = '30300'                          22933500
396800           AND P-NEW-STATE = 50                                   22933600
396900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22933700
397000               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.               22933800
397100                                                                  22933900
397200        IF HOLD-PROV-IPPS-CBSA = '30860'                          22934000
397300           AND P-NEW-STATE = 46                                   22934100
397400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22934200
397500               MOVE '   46' TO HOLD-PROV-IPPS-CBSA.               22934300
397600                                                                  22934400
397700        IF HOLD-PROV-IPPS-CBSA = '35084'                          22934500
397800           AND P-NEW-STATE = 31                                   22934600
397900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22934700
398000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               22934800
398100                                                                  22934900
398200        IF HOLD-PROV-IPPS-CBSA = '39300'                          22935000
398300           AND P-NEW-STATE = 22                                   22935100
398400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22935200
398500               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.               22935300
398600                                                                  22935400
398700        IF HOLD-PROV-IPPS-CBSA = '45500'                          22935500
398800           AND P-NEW-STATE = 45                                   22935600
398900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22935700
399000               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.               22935800
399100                                                                  22935900
399200**************YEARCHANGE 2012.0 ******************************    22936000
399300                                                                  22936100
229500 0580-FY2012-EXIT.                                                22936200
229600      EXIT.                                                       22936300
229700                                                                  22936400
211600 0580-FY2013-FLOOR-CBSA.                                          22936501
229700                                                                  22936601
405000**************YEARCHANGE 2013.0 ****************************      22936701
405500                                                                  22937101
407900        IF HOLD-PROV-IPPS-CBSA = '10900'                          22937203
408100           AND P-NEW-STATE = 31                                   22937301
408200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22937401
408300               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               22937503
408400                                                                  22937601
407900        IF HOLD-PROV-IPPS-CBSA = '14484'                          22937703
408000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22937801
408100           AND P-NEW-STATE = 22                                   22937901
408200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22938001
408300               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.               22938103
408400                                                                  22938201
408500        IF HOLD-PROV-IPPS-CBSA = '16020'                          22938303
408600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22938401
408700           AND P-NEW-STATE = 14                                   22938501
408800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22938601
408900               MOVE '   14' TO HOLD-PROV-IPPS-CBSA.               22938703
409000                                                                  22938801
409100        IF HOLD-PROV-IPPS-CBSA = '21500'                          22938903
409200          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                      22939001
409300           AND P-NEW-STATE = 33                                   22939101
409400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22939201
409500               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.               22939303
409600                                                                  22939401
409700        IF HOLD-PROV-IPPS-CBSA = '21500'                          22939503
409800          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                      22939601
409900           AND P-NEW-STATE = 39                                   22939701
410000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22939801
410100               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.               22939903
410200                                                                  22940001
410300        IF HOLD-PROV-IPPS-CBSA = '21780'                          22940103
409800          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                      22940201
410400           AND P-NEW-STATE = 15                                   22940301
410500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22940401
410600               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.               22940503
410700                                                                  22940601
410800        IF HOLD-PROV-IPPS-CBSA = '24580'                          22940703
409800          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                      22940801
410900           AND P-NEW-STATE = 52                                   22940901
411000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22941001
411100               MOVE '   52' TO HOLD-PROV-IPPS-CBSA.               22941103
411200                                                                  22941201
411300        IF HOLD-PROV-IPPS-CBSA = '25540'                          22941303
411400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22941401
411500           AND P-NEW-STATE = 07                                   22941501
411600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22941601
411700               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.               22941703
411800                                                                  22941801
411900        IF HOLD-PROV-IPPS-CBSA = '25540'                          22941903
412000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22942001
412100           AND P-NEW-STATE = 22                                   22942101
412200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22942201
412300               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.               22942303
412400                                                                  22942401
412500        IF HOLD-PROV-IPPS-CBSA = '26820'                          22942503
412600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22942601
412700           AND P-NEW-STATE = 53                                   22942701
412800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22942801
412900               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.               22942903
413000                                                                  22943001
413100        IF HOLD-PROV-IPPS-CBSA = '27900'                          22943103
412600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22943201
413200           AND P-NEW-STATE = 17                                   22943301
413300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22943401
413400               MOVE '   17' TO HOLD-PROV-IPPS-CBSA.               22943503
413000                                                                  22943601
413100        IF HOLD-PROV-IPPS-CBSA = '28700'                          22943703
413200           AND P-NEW-STATE = 44                                   22943801
413300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22943901
413400               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.               22944003
413500                                                                  22944101
413600        IF HOLD-PROV-IPPS-CBSA = '28700'                          22944203
413700           AND P-NEW-STATE = 49                                   22944301
413800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22944401
413900               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.               22944503
414000                                                                  22944601
414100        IF HOLD-PROV-IPPS-CBSA = '28700'                          22944703
414200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22944801
414300           AND P-NEW-STATE = 18                                   22944901
414400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22945001
414500               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.               22945103
414600                                                                  22945201
414700        IF HOLD-PROV-IPPS-CBSA = '28700'                          22945303
414800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22945401
414900           AND P-NEW-STATE = 44                                   22945501
415000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22945601
415100               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.               22945703
415200                                                                  22945801
415300        IF HOLD-PROV-IPPS-CBSA = '28940'                          22945903
415400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22946001
415500           AND P-NEW-STATE = 18                                   22946101
415600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22946201
415700               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.               22946303
415800                                                                  22946401
415900        IF HOLD-PROV-IPPS-CBSA = '35084'                          22946503
416000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22946601
416100           AND P-NEW-STATE = 31                                   22946701
416200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22946801
416300               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               22946903
416400                                                                  22947001
416500        IF HOLD-PROV-IPPS-CBSA = '37620'                          22947103
416600           AND P-NEW-STATE = 36                                   22947201
416700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22947301
416800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               22947403
416900                                                                  22947501
417000        IF HOLD-PROV-IPPS-CBSA = '37964'                          22947603
417100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22947701
417200           AND P-NEW-STATE = 31                                   22947801
417300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22947901
417400               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               22948003
417500                                                                  22948101
417000        IF HOLD-PROV-IPPS-CBSA = '38300'                          22948203
417100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'                     22948301
417200           AND P-NEW-STATE = 36                                   22948401
417300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22948501
417400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               22948603
417500                                                                  22948701
417600        IF HOLD-PROV-IPPS-CBSA = '43580'                          22948803
417700           AND P-NEW-STATE = 43                                   22948901
417800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22949001
417900               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.               22949103
418000                                                                  22949201
419100        IF HOLD-PROV-IPPS-CBSA = '48540'                          22949303
419200           AND P-NEW-STATE = 36                                   22949401
419300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22949501
419400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               22949603
419500                                                                  22949701
419600        IF HOLD-PROV-IPPS-CBSA = '48540'                          22949803
419700           AND P-NEW-STATE = 51                                   22949901
419800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22950001
419900               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.               22950103
420000                                                                  22950201
420100        IF HOLD-PROV-IPPS-CBSA = '48864'                          22950303
420200           AND P-NEW-STATE = 31                                   22950401
420300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22950501
420400               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.               22950603
420500                                                                  22950701
420600        IF HOLD-PROV-IPPS-CBSA = '49660'                          22950803
420700           AND P-NEW-STATE = 36                                   22950901
420800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22951001
420900               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               22951103
421000                                                                  22951201
421100        IF HOLD-PROV-IPPS-CBSA = '49660'                          22951303
421200           AND P-NEW-STATE = 39                                   22951401
421300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22951501
421400               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.               22951603
421500                                                                  22951701
421100        IF HOLD-PROV-IPPS-CBSA = '22020'                          22951803
421200           AND P-NEW-STATE = 24                                   22951901
421300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22952001
421400               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.               22952103
421500                                                                  22952201
421100        IF HOLD-PROV-IPPS-CBSA = '22020'                          22952303
421200           AND P-NEW-STATE = 35                                   22952401
421300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22952501
421400               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.               22952603
421500                                                                  22952701
421100        IF HOLD-PROV-IPPS-CBSA = '24220'                          22952803
421200           AND P-NEW-STATE = 24                                   22952901
421300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22953001
421400               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.               22953103
421500                                                                  22953201
421100        IF HOLD-PROV-IPPS-CBSA = '24220'                          22953303
421200           AND P-NEW-STATE = 35                                   22953401
421300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22953501
421400               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.               22953603
421500                                                                  22953701
421100        IF HOLD-PROV-IPPS-CBSA = '30300'                          22953803
421200           AND P-NEW-STATE = 50                                   22953901
421300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22954001
421400               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.               22954103
421500                                                                  22954201
421100        IF HOLD-PROV-IPPS-CBSA = '39300'                          22954303
421200           AND P-NEW-STATE = 22                                   22954401
421300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22954501
421400               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.               22954603
421500                                                                  22954701
421100        IF HOLD-PROV-IPPS-CBSA = '39300'                          22954803
421200           AND P-NEW-STATE = 41                                   22954901
421300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22955001
421400               MOVE '   41' TO HOLD-PROV-IPPS-CBSA.               22955103
421500                                                                  22955201
421100        IF HOLD-PROV-IPPS-CBSA = '44600'                          22955303
421200           AND P-NEW-STATE = 36                                   22955401
421300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND                22955501
421400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.               22955603
421500                                                                  22955701
229500 0580-FY2013-EXIT.                                                22957601
229600      EXIT.                                                       22957701
229800                                                                  22957800
229900******************************************************************22957900
230000 0585-GET-IPPS-CBSA-SIZE.                                         22958000
230100******************************************************************22958100
230200                                                                  22958200
230300     IF B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2)              22958300
230400        IF P-NEW-RURAL-CBSA                                       22958400
230500           MOVE 'R' TO W-CBSA-IPPS-SIZE                           22958500
230600        ELSE                                                      22958600
230700          IF T-CBSA-SIZE (MA2) = 'L'                              22958700
230800             MOVE 'L' TO W-CBSA-IPPS-SIZE                         22958800
230900          ELSE                                                    22958900
231000             MOVE 'O' TO W-CBSA-IPPS-SIZE                         22959000
231100          END-IF                                                  22959100
231200        END-IF                                                    22959200
231300     END-IF.                                                      22959300
231400                                                                  22959400
231500 0585-EXIT.                                                       22959500
231600      EXIT.                                                       22959600
231700                                                                  22960000
231800                                                                  22970000
231900******************************************************************22980000
232000 0590-GET-IPPS-CBSA-PR.                                           22990000
232100******************************************************************23000000
232200                                                                  23010000
232300*--------------------------------------*                          23020000
232400* SET PUERTO RICO CBSA INDICATOR       *                          23030000
232500*--------------------------------------*                          23040000
232600     MOVE '*' TO H-IPPS-CBSA-LAST-POS.                            23050000
232700                                                                  23060000
232800*------------------------------------------------------------*    23070000
232900* SEARCH TABLE FOR PR CBSA & GET PR SPECIFIC WAGE INDEX      *    23080000
233000*------------------------------------------------------------*    23090000
233100     SET MA1 TO 1.                                                23100000
233200     SEARCH T-CBSA-DATA VARYING MA1                               23110000
233300        AT END                                                    23120000
233400           MOVE 60 TO PPS-RTC                                     23130000
233500        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA                   23140000
233600           SET MA2 TO MA1                                         23150000
233700               PERFORM 0680-N-GET-IPPS-PR-WAGE-INDX               23160000
233800                  THRU 0680-N-EXIT VARYING MA2                    23170000
233900                  FROM MA1 BY 1 UNTIL                             23180000
234000                       T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA.    23190000
234100                                                                  23200000
234200 0590-EXIT.                                                       23210000
234300      EXIT.                                                       23220000
234400                                                                  23230000
234500                                                                  23240000
234600******************************************************************23250000
234700 0600-N-GET-WAGE-INDX.                                            23260000
234800******************************************************************23270000
234900                                                                  23280000
235000     IF  B-DISCHARGE-DATE NOT < MSAX-EFF-DATE (MU2)               23290000
235100         MOVE MSAX-MSA (MU2)         TO W-NEW-MSA                 23300000
235200         MOVE MSAX-EFF-DATE (MU2)    TO W-NEW-EFF-DATE-M          23310000
235300         MOVE MSAX-WAGE-INDEX1 (MU2) TO W-NEW-INDEX1-RECORD-M     23320000
235400         MOVE MSAX-WAGE-INDEX2 (MU2) TO W-NEW-INDEX2-RECORD-M     23330000
235500         MOVE MSAX-WAGE-INDEX3 (MU2) TO W-NEW-INDEX3-RECORD-M     23340000
235600     END-IF.                                                      23350000
235700                                                                  23360000
235800 0600-N-EXIT.                                                     23370000
235900     EXIT.                                                        23380000
236000                                                                  23390000
236100                                                                  23400000
236200******************************************************************23410000
236300 0650-N-GET-WAGE-INDX.                                            23420000
236400******************************************************************23430000
236500                                                                  23440000
236600     IF  B-DISCHARGE-DATE NOT < CBSAX-EFF-DATE (CU2)              23450000
236700         MOVE CBSAX-CBSA (CU2)        TO W-NEW-CBSA               23460000
236800         MOVE CBSAX-EFF-DATE (CU2)    TO W-NEW-EFF-DATE-C         23470000
236900         MOVE CBSAX-WAGE-INDEX1 (CU2) TO W-NEW-INDEX1-RECORD-C    23480000
237000         MOVE CBSAX-WAGE-INDEX2 (CU2) TO W-NEW-INDEX2-RECORD-C    23490000
237100         MOVE CBSAX-WAGE-INDEX3 (CU2) TO W-NEW-INDEX3-RECORD-C    23500000
237200     END-IF.                                                      23510000
237300                                                                  23520000
237400 0650-N-EXIT.                                                     23530000
237500     EXIT.                                                        23540000
237600                                                                  23550000
237700                                                                  23560000
237800******************************************************************23570000
237900 0675-N-GET-IPPS-WAGE-INDX.                                       23580000
238000******************************************************************23590000
238100                                                                  23600000
238200     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2)             23610000
238300         MOVE T-CBSA (MA2)            TO W-CBSA-IPPS              23620000
238400         MOVE T-CBSA-EFF-DATE (MA2)   TO W-CBSA-IPPS-EFF-DATE     23630000
238500         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-WAGE-INDEX        23640000
238600     END-IF.                                                      23650000
238700                                                                  23660000
238800 0675-N-EXIT.                                                     23670000
238900     EXIT.                                                        23680000
239000                                                                  23690000
239100                                                                  23700000
239200******************************************************************23710000
239300 0680-N-GET-IPPS-PR-WAGE-INDX.                                    23720000
239400******************************************************************23730000
239500                                                                  23740000
239600     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2)             23750000
239700         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-PR-WAGE-INDEX     23760000
239800     END-IF.                                                      23770000
239900                                                                  23780000
240000 0680-N-EXIT.                                                     23790000
240100     EXIT.                                                        23800000
240200                                                                  23810000
240300******************************************************************23820000
240400********************   END OF PROGRAM   **************************23830000
240500******************************************************************23840000
