000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. LTDRV141.
000300*AUTHOR.     CENTERS FOR MEDICARE AND MEDICAID SERVICES
000400*REMARKS.    - FINDS WAGE-INDEX RECORD(S) FOR GIVEN BILL TO
000500*              BE PASSED TO LTCALYYV MODULES
000600*            - LOADS THE PPS TABLES
000700*            - CALLS THE LTCALYYV MODULES
000800*            - YYV MEANS YEAR AND VERSION
000900 DATE-COMPILED.
001000****************************************************************
001100*   THIS SUBROUTINE IS FURNISHED BY THE CENTERS FOR MEDICARE   *
001200*   AND MEDICAID SERVICES.                                     *
001300*   IT IS TO BE USED AS AN AID IN IMPLEMENTING PROSPECTIVE     *
001400*   PAYMENT FOR LONG TERM CARE HOSPITALS.                      *
001500*   THE RESPONSIBILITY FOR INSTALLING, MODIFYING, TESTING,     *
001600*   MAINTAINING, AND VERIFYING THE ACCURACY OF THIS PROGRAM    *
001700*   IS THAT OF THE USER.                                       *
001800*                  *  *  *  *  *  *  *  *                      *
001900*   ONCE GROUPED THE PROSPECTIVE PAYMENT SUBROUTINE IS CALLED  *
002000*   TO CALCULATE THE TOTAL PAYMENT PRIOR TO DEDUCTIBLE,        *
002100*   CO-INSURANCE, AND CASES WHERE MEDICARE IS SECONDARY PAYOR. *
002200*   THE PROGRAM WILL:                                          *
002300*       1. EDIT THE BILL INFORMATION.                          *
002400*       2. PASS BACK RETURN CODES.                             *
002500*       3. CALCULATE WHEN APPLICABLE:                          *
002600*          A. THE HOSPITAL SPECIFIC PART OF PAYMENT.           *
002700*          B. THE FEDERAL SPECIFIC PART OF PAYMENT.            *
002800*          C. THE OUTLIER PORTION.                             *
002900*          D. TOTAL PAYMENT (B + C + D  ABOVE).                *
003000*                                                              *
003100*                  *  *  *  *  *  *  *  *                      *
003200*   THIS SUBROUTINE CALCULATES THE PROVIDER SPECIFIC           *
003300*   ELEMENTS ON A PROVIDER BREAK, THEREFORE IT WILL RUN FASTER *
003400*   WHEN BILLS ARE BATCHED BY PROVIDER.                        *
003500*                  *  *  *  *  *  *  *  *                      *
003600*                                                              *
003700*--------------------------------------------------------------*
003800*   CHANGE LOG.                                                *
003900*--------------------------------------------------------------*
004000*                                                              *
004100*   04/07/2005 - AT THE REQUEST OF FISS, LTSEL___ CREATED.     *
004200*                THIS PROGRAM IS CALLED BY LTDRV___ AND        *
004300*                RECEIVES THE PROVIDER RECORD, CBSA TABLE,     *
004400*                BILL RECORD, AND PPS DATA.  IT GETS THE       *
004500*                APPROPRIATE CBSA RECORD AND CALLS THE         *
004600*                APPROPRIATE LTCAL___ MODULE FOR THE BILL      *
004700*                                                              *
004800*--------------------------------------------------------------*
004900*                                                              *
005000*   04/21/2005 - EFFECTIVE JULY 1, 2005, CBSA (CORE-BASED      *
005100*                STATISTICAL AREA) IS USED IN PLACE OF MSA     *
005200*                (METROPOLITAN STATISTICAL AREA), THE PROGRAM  *
005300*                DETERMINES WHETHER TO USE THE CBSA WAGE INDEX *
005400*                FILE OR MSA WAGE INDEX FILE BASED ON THE BILL *
005500*                DISCHARGE DATE                                *
005600*                                                              *
005700*--------------------------------------------------------------*
005800*                                                              *
005900*   05/02/2005 - ADDED PSF FIELDS - SPECIAL PAY INDICATOR &    *
006000*                SPECIAL WAGE INDEX                            *
006100*                                                              *
006200*--------------------------------------------------------------*
006300*                                                              *
006400*   12/07/2005 - REMOVED TIME RESTRAINT FROM THE CALL TO THE   *
006500*                LATEST VERSION OF THE LTCAL PROGRAM           *
006600*                                                              *
006700*--------------------------------------------------------------*
006800*                                                              *
006900*   01/17/2006 - MODIFIED FOR 1ST CICS PACKAGE RELEASE;        *
007000*                FOR APRIL 1, 2006 RELEASE                     *
007100*                                                              *
007200*--------------------------------------------------------------*
007300*                                                              *
007400*   01/19/2006 - PROGRAM NAME CHANGED FROM LTSEL___ TO LTDRV___*
007500*                                                              *
007600*--------------------------------------------------------------*
007700*                                                              *
007800*   05/03/2006 - MODIFY PROGRAM FOR JULY 2006 RELEASE:         *
007900*                ADD LTCAL071 CALL, ADD IPPS CBSA WAGE INDEX   *
008000*                TABLE STORAGE & LOGIC.  DELETED LAYOUT FOR    *
008100*                W-PROV-NEW-HOLD - NOT NEEDED.                 *
008200*                IPPS WAGE INDEX LOGIC: ONLY THE IPPS CBSA     *
008300*                FLOOR POLICY IS APPLIED WHEN ASSIGNING THE    *
008400*                IPPS WAGE INDEX.  PUERTO RICO HOSPITALS ARE   *
008500*                GIVEN THE NATIONAL AND PUERTO RICO SPECIFIC   *
008600*                WAGE INDEX VALUES.                            *
008700*                                                              *
008800*--------------------------------------------------------------*
008900*                                                              *
009000*   06/15/2006 - CHANGE THE PLACEMENT OF THE MOVE OF THE PSF   *
009100*                CBSA TO THE IPPS CBSA HOLD AREA & REMOVE THAT *
009200*                MOVE FROM THE IPPS PR SEARCH LOGIC.           *
009300*                                                              *
009400*--------------------------------------------------------------*
009500*                                                              *
009600*   06/19/2006 - CHANGE THE VERSION FROM 07.0 TO 07.1          *
009700*                                                              *
009800*--------------------------------------------------------------*
009900*                                                              *
010000*   08/04/2006 - UPDATE PROGRAM FOR OCTOBER 2006 RELEASE 07.3  *
010100*                ADD FY 2007 FLOOR IF STATEMENT                *
010200*                STILL NEED TO ADD FLOOR CODE                  *
010300*                NEW VERSIONS OF LTCAL CALLED DUE TO THE SIZE  *
010400*                CHANGE OF THE FIELD: PPS-NEW-FAC-SPEC-RATE    *
010500*                FROM 9(5)V9(02) TO 9(7)V9(2).                 *
010600*                                                              *
010700*--------------------------------------------------------------*
010800*                                                              *
010900*   08/08/2006 - BECAUSE THE FY 2007 WAGE INDEX TABLE WILL NOT *
011000*                BE FINAL UNTIL LATE AUGUST, THE FOLLOWING     *
011100*                ITEMS ARE NOT INCLUDED IN VERSION 7.3 OF THE  *
011200*                LTCH PRICER:                                  *
011300*                                                              *
011400*                1) FY 2007 IPPS WAGE INDEX TABLE              *
011500*                2) FY 2007 IPPS WAGE INDEX FLOORS             *
011600*                3) FINAL FY 2007 IPPS DRG WEIGHTS             *
011700*                4) FY 2007 IPPS STANDARD RATES:               *
011800*                    H-IPPS-CAPI-STD-FED-RATE  (LTCAL073)      *
011900*                    H-IPPS-CAPI-STD-PR-RATE   (LTCAL073)      *
012000*                                                              *
012100*                FOR TESTING PURPOSES, THE FOLLOWING           *
012200*                SUBSTITUTES WERE MADE:                        *
012300*                                                              *
012400*                1) THE FY 2006 IPPS WAGE INDEX TABLE VERSION  *
012500*                   06.3 WILL BE USED IN PLACE OF THE FY 2007  *
012600*                   IPPS WAGE INDEX TABLE.                     *
012700*                2) THERE IS NO MODULE THAT ASSIGNS FY 2007    *
012800*                   IPPS WAGE INDEX FLOORS.  THE CODE THAT     *
012900*                   REFERENCES THIS FUTURE MODULE IS COMMENTED *
013000*                   OUT.                                       *
013100*                3) THE CURRENT FY 2007 DRG WEIGHTS ARE USED.  *
013200*                   THESE MAY OR MAY NOT CHANGE.               *
013300*                4) THE FY 2006 IPPS STANDARD RATES ARE USED.  *
013400*                                                              *
013500*--------------------------------------------------------------*
013600*                                                              *
013700*   08/09/2006 - DELETED RETURN CODES 02 & 03 AND ADDED CODES  *
013800*                20, 21, 22, 23, 24, & 25 FOR SHORT STAY       *
013900*                PAYMENT DESCRIPTIONS IN PROGRAM LTCAL073.     *
014000*                                                              *
014100*--------------------------------------------------------------*
014200*                                                              *
014300*   09/06/2006 - CREATE VERSION 07.4 OF THE LTCH PPS PRICER    *
014400*                UPDATED WITH THE FOLLOWING:                   *
014500*                1) FY 2007 IPPS WAGE INDEX TABLE              *
014600*                2) FY 2007 IPPS WAGE INDEX FLOORS             *
014700*                3) FINAL FY 2007 IPPS DRG WEIGHTS             *
014800*                4) FY 2007 IPPS STANDARD RATES (LTCAL074)     *
014900*                                                              *
015000*--------------------------------------------------------------*
015100*                                                              *
015200*   11/16/2006 - CREATE VERSION 07.5 OF THE LTCH PPS PRICER    *
015300*                UPDATED WITH THE FOLLOWING:                   *
015400*                1) IME MULTIPLIER IN PROGRAM LTCAL075 CHANGED *
015500*                   FROM 1.37 TO 1.32 (TO MATCH FY2007 IPPS)   *
015600*                2) PPS RETURN CODE 23 REMOVED FROM LTCAL075   *
015700*                   BECAUSE IT COULD NEVER BE REACHED          *
015800*                3) REMOVED CBSA 27860 FROM THE FY 2007 FLOOR  *
015900*                   CODE (DUE TO IPPS CN1 WAGE INDEX CHANGE)   *
016000*                                                              *
016100*--------------------------------------------------------------*
016200*                                                              *
016300*   12/28/2006 - CREATE VERSION 07.6 OF THE LTCH PPS PRICER    *
016400*                TO CORRECT THE CBSA SIZE LOGIC.  ALWAYS USE   *
016500*                THE GEOGRAPHIC CBSA'S SIZE; STOP USING THE    *
016600*                RURAL FLOOR CBSA'S SIZE.  ALSO, CBSA 27860    *
016700*                WAS REINSTATED INTO THE FLOOR LOGIC, IGNORED  *
016800*                11/03/2006 AND AFTER.                         *
016900*                *** THIS VERSION WAS NOT RELEASED ***         *
017000*                THE NEW LOGIC IS INTRODUCED IN VERSION 08.0.  *
017100*                                                              *
017200*--------------------------------------------------------------*
017300*                                                              *
017400*   05/03/2007 - CREATE VERSION 08.0 OF THE LTCH PPS PRICER    *
017500*                UPDATED WITH THE FOLLOWING:                   *
017600*                1) LTCH WAGE INDEX TABLE - 4/5 & 5/5 COLUMNS  *
017700*                2) LTCH RATES (LTCAL080)                      *
017800*                3) NEW SSO POLICY (IPPS COMPARABLE AMT)       *
017900*                4) 25% RULE (NOT APPLIED IN PRICER)           *
018000*                5) NEW RETURN CODES 26 & 27                   *
018100*                6) NEW IPPS COMPARABLE THRESHOLD COLUMN IN    *
018200*                   DRG TABLE                                  *
018300*                7) WAGE INDEX SELECTION CODE UPDATED          *
018400*                                                              *
018500*--------------------------------------------------------------*
018600*                                                              *
018700*   08/10/2007 - CREATE VERSION 08.1 OF THE LTCH PPS PRICER    *
018800*                UPDATED WITH THE FOLLOWING FY 2008 ITEMS:     *
018900*                1) LTCH DRG TBL (W/ NEW IPPS COMP THRESHOLDS) *
019000*                2) IPPS DRG TABLE                             *
019100*                3) IPPS WAGE INDEX TABLE                      *
019200*                4) IPPS RATES (IN LTCAL081)                   *
019300*                5) IPPS WAGE INDEX FLOORS                     *
019400*                6) NEW OPERATING IME FACTOR (1.35)            *
019500*                7) 3% LARGE URBAN ADD-ON ELIMINTATED          *
019600*                8) CHANGED MESSAGE FOR RETURN CODE 98         *
019700*                                                              *
019800*--------------------------------------------------------------*
019900*                                                              *
020000*   08/22/2007 - CREATE VERSION 08.2 OF THE LTCH PPS PRICER    *
020100*                UPDATED WITH THE FOLLOWING FY 2008 ITEMS:     *
020200*                1) REVISED IPPS WAGE INDEX TABLE              *
020300*                2) REVISED IPPS RATES (IN LTCAL082)           *
020400*                VERSION 08.2 REPLACES VERSION 08.1            *
020500*                                                              *
020600*--------------------------------------------------------------*
020700*                                                              *
020800*   09/14/2007 - CREATE VERSION 08.3 OF THE LTCH PPS PRICER    *
020900*                UPDATED WITH THE FOLLOWING FY 2008 ITEMS:     *
021000*                1) REVISED IPPS WAGE INDEX TABLE              *
021100*                2) REVISED IPPS RATES (IN LTCAL083)           *
021200*                VERSION 08.3 REPLACES VERSION 08.2            *
021300*                                                              *
021400*--------------------------------------------------------------*
021500*                                                              *
021600*   09/28/2007 - CREATE VERSION 08.4 OF THE LTCH PPS PRICER    *
021700*                UPDATED WITH CONGRESS MANDATED REVISION OF    *
021800*                IPPS RATES (IN LTCAL084)                      *
021900*                VERSION 08.4 REPLACES VERSION 08.3            *
022000*                                                              *
022100*--------------------------------------------------------------*
022200*                                                              *
022300*   12/27/2007 - CREATE VERSION 08.5 OF THE LTCH PPS PRICER    *
022400*                5TH SHORT STAY OUTLIER PROVISION NO LONGER    *
022500*                AVAILABLE TO BILLS DISCHARGED ON AND AFTER    *
022600*                12/29/2007 PER A CONGRESS MANDATE             *
022700*                UPDATED LTCAL085 TO REFLECT THIS CHANGE       *
022800*                                                              *
022900*--------------------------------------------------------------*
023000*                                                              *
023100*   02/06/2008 - CREATE VERSION 08.6 OF THE LTCH PPS PRICER    *
023200*                EFFECTIVE OCT 1, 2007 (REPLACES VERSION 08.5) *
023300*                CHANGES EFFECTIVE APRIL 1, 2008:              *
023400*                 1) CHANGED LTCH STANDARD FEDERAL RATE FROM   *
023500*                    $38,356.45 TO $38,086.04 IN PGM LTCAL086  *
023600*                 2) CHANGED FIXED LOSS AMOUNT FROM $20,738.00 *
023700*                    TO $20,707.00 IN PROGRAM LTCAL086         *
023800*                THESE CHANGES WERE MADE IN ACCORD WITH        *
023900*                SECTION 114(E)(2) AND (3) OF THE MEDICARE,    *
024000*                MEDICAID AND SCHIP EXTENSION ACT OF 2007,     *
024100*                ENACTED ON DECEMBER 29, 2007.                 *
024200*                                                              *
024300*--------------------------------------------------------------*
024400*                                                              *
024500*   05/08/2008 - CREATE VERSION 09.0 OF THE LTCH PPS PRICER    *
024600*                EFFECTIVE JULY 1, 2008 (FY 2008, RY 2009)     *
024700*                CHANGES EFFECTIVE JULY 1, 2008:               *
024800*                - NEW WAGE INDEX TABLE W/ 1 WAGE INDEX COLUMN *
024900*                - ALL CLAIMS RECEIVE THE FULL WAGE INDEX      *
025000*                  REGARDLESS OF ITS PROVIDER FY BEGIN DATE    *
025100*                - ALL SHORT STAY CLAIMS ELIGIBLE FOR THE      *
025200*                  BLENDED PAYMENT, NO CLAIMS ELIGIBLE FOR     *
025300*                  THE IPPS COMPARABLE PAYMENT                 *
025400*                - NEW LTCH RATES                              *
025500*                - DISABLE CALL TO LTCAL042 (5 YEAR RULE)      *
025600*                                                              *
025700*--------------------------------------------------------------*
025800*                                                              *
025900*   05/19/2008 - CREATE VERSION 09.1 OF THE LTCH PPS PRICER    *
026000*                EFFECTIVE JULY 1, 2008 (FY 2008, RY 2009)     *
026100*                CHANGED IPPS PUERTO RICO RATES EFFECTIVE      *
026200*                RETROACTIVE TO 10/01/2007.  CREATED TWO NEW   *
026300*                LTCAL MODULES FOR THIS CHANGE:                *
026400*                1) LTCAL087: FOR CLAIMS DISCHARGED            *
026500*                   10/01/2007 - 06/30/2008, REPLACED LTCAL086 *
026600*                2) LTCAL091: FOR CLAIMS DISCHARGED            *
026700*                   07/01/2008 & AFTER, REPLACED LTCAL090      *
026800*                                                              *
026900*--------------------------------------------------------------*
027000*                                                              *
027100*   08/04/2008 - CREATE VERSION 09.2 OF THE LTCH PPS PRICER    *
027200*                EFFECTIVE OCTOBER 1, 2008 (FY 2009, RY 2009)  *
027300*                UPDATED WITH THE FOLLOWING FY 2009 ITEMS:     *
027400*                1) LTCH DRG TBL (NO IPPS COMP THRESHOLDS)     *
027500*                2) IPPS DRG TABLE                             *
027600*                3) IPPS RATES (IN LTCAL092)                   *
027700*                4) OPERATING IME FACTOR (STILL 1.35)          *
027800*                5) FY 2009 FLOOR IF STATEMENT & PARAGRAPH     *
027900*                   USING FY 2008 FLOOR ASSIGNMENTS            *
028000*                                                              *
028100*                THE FOLLOWING FY 2009 UPDATES WERE NOT MADE   *
028200*                IN THIS VERSION BECAUSE THEY ARE NOT YET      *
028300*                AVAILABLE.  A NEW PRICER WILL BE RELEASED TO  *
028400*                INCLUDE THESE ITEMS.                          *
028500*                1) IPPS WAGE INDEX TABLE                      *
028600*                2) IPPS WAGE INDEX FLOORS                     *
028700*                                                              *
028800*                FOR TESTING PURPOSES, THE FOLLOWING           *
028900*                SUBSTITUTIONS WERE MADE:                      *
029000*                1) THE FY 2008 IPPS WAGE INDEX TABLE IS USED  *
029100*                   IN PLACE OF THE FY 2009 TABLE.             *
029200*                2) THE FY 2008 WAGE INDEX FLOORS ARE USED     *
029300*                   IN PLACE OF THE FY 2009 FLOORS.            *
029400*                                                              *
029500*--------------------------------------------------------------*
029600*                                                              *
029700*   08/11/2008 - COMMENTED OUT REFERENCES TO THE IPPS          *
029800*                COMPARABLE THRESHOLD IN LTCAL092 BECAUSE      *
029900*                SHORT STAY CLAIMS ARE NO LONGER ELIGIBLE      *
030000*                FOR THE IPPS COMPARABLE PER DIEM AND,         *
030100*                THEREFORE, THE IPPS THRESHOLD IS NOT INCLUDED *
030200*                IN THE LTCH DRG TABLE FOR FY 2009.  RETURN    *
030300*                CODES 26 & 27 WILL NO LONGER BE RETURNED.     *
030400*                ADDED FIELD P-VAL-BASED-PURCH-SCORE TO THE    *
030500*                PSF LAYOUT (TO BE USED IN IPPS 1/1/2008).     *
030600*                                                              *
030700*--------------------------------------------------------------*
030800*                                                              *
030900*   08/14/2008 - REDUCE H-CAPI-IME-TEACH ROUNDED BY 50%        *
031000*                IN LTCAL092.                                  *
031100*                                                              *
031200*                                                              *
031300*--------------------------------------------------------------*
031400*                                                              *
031500*   08/15/2008 - ADDED STATE SPECIFIC RURAL FLOOR BUDGET       *
031600*                NEUTRALITY (SSRFBN) TABLE AND LOGIC TO        *
031700*                LTCAL092 FOR FY 2009.                         *
031800*              - ADDED NEW RETURN CODE FOR SSRFBN LOGIC:       *
031900*                68 = PROVIDER SPECIFIC STATE CODE INVALID     *
032000*                                                              *
032100*--------------------------------------------------------------*
032200*                                                              *
032300*   09/09/2008 - CREATE VERSION 09.3 OF THE LTCH PPS PRICER    *
032400*                EFFECTIVE OCTOBER 1, 2008 (FY 2009, RY 2009)  *
032500*                REPLACES VERSION 09.2                         *
032600*                ADDED THE FOLLOWING ITEMS IN THIS VERSION:    *
032700*                - FY 2009 IPPS CBSA WAGE INDEX TABLE          *
032800*                  CHANGED NEW CBSA 14600 TO 42260 FOR LTCH    *
032900*                - FY 2009 IPPS RURAL FLOOR ASSIGNMENT CODE    *
033000*                - REVISED FY 2009 IPPS STANDARD RATES         *
033100*                - REVISED FY 2009 IPPS RFBN FACTOR TABLE      *
033200*                                                              *
033300*--------------------------------------------------------------*
033400*                                                              *
033500*   09/12/2008 - REVISED SSRFBN LOGIC IN LTCAL093 TO EXCLUDE   *
033600*                SPECIAL WAGE INDICES ENTERED INTO THE PSF     *
033700*                FROM THE SSRFBN ADJUSTMENT                    *
033800*                                                              *
033900*--------------------------------------------------------------*
034000*                                                              *
034100*   02/17/2009 - CREATE VERSION 09.4 OF THE LTCH PPS PRICER    *
034200*                EFFECTIVE RETROACTIVE BACK TO 10/01/2008      *
034300*                TO CONFORM TO ECONOMIC STIMULUS BILL SIGNED   *
034400*                02/17/2009, THE H-CAPI-IME-TEACH AMOUNT       *
034500*                CALCULATED IN PROGRAM LTCAL094 IS NO LONGER   *
034600*                REDUCED BY 50%.  NOW PAY 100% CAPITAL IME.    *
034700*                THIS VERSION REPLACES VERSION 09.3.           *
034800*                                                              *
034900*--------------------------------------------------------------*
035000*                                                              *
035100*   05/18/2009 - CREATE VERSION 09.5 OF THE LTCH PPS PRICER    *
035200*                EFFECTIVE 06/03/2009                          *
035300*                - ADDED NEW LTCH DRG WEIGHT TABLE (LTDRG095)  *
035400*                  AND CALCULATION PROGRAM (LTCAL095)          *
035500*                  NEW TABLE HAS CORRECTED WEIGHTS AND IS USED *
035600*                  TO PROCESS CLAIMS DISCHARGED ON AND AFTER   *
035700*                  JUNE 3, 2009 THROUGH SEPTEMBER 30, 2009     *
035800*                                                              *
035900*--------------------------------------------------------------*
036000*                                                              *
036100*   08/04/2009 - CREATE VERSION 10.0 OF THE LTCH PPS PRICER    *
036200*                EFFECTIVE 10/01/2009 (FY 2010, RY 2010)       *
036300*                - STARTING THIS YEAR, THE RATE YEAR AND       *
036400*                  FISCAL YEAR BOTH START ON OCTOBER 1ST       *
036500*                - THERE ARE NO POLICY OR FORMULA CHANGES      *
036600*                - RATE YEAR 2005 ITEMS REMOVED FROM PACKAGE   *
036700*                UPDATED WITH THE FOLLOWING FY 2010 ITEMS:     *
036800*                1) LTCH DRG TBL                               *
036900*                2) LTCH CBSA WAGE INDEX TABLE                 *
037000*                3) IPPS DRG TBL                               *
037100*                4) IPPS CBSA WAGE INDEX TABLE                 *
037200*                5) IPPS STATE SPECIFIC RURAL FLOOR BUDGET     *
037300*                   NEUTRALITY (SSRFBN) FACTOR TABLE           *
037400*                6) IPPS CBSA WAGE INDEX FLOOR ASSIGNMENT LOGIC*
037500*                7) LTCH STANDARD RATES IN PROGRAM LTCAL100    *
037600*                8) IPPS STANDARD RATES IN PROGRAM LTCAL100    *
037700*                                                              *
037800*--------------------------------------------------------------*
037900*                                                              *
038000*   09/03/2009 - CREATE VERSION 10.1 OF THE LTCH PPS PRICER    *
038100*                EFFECTIVE 10/01/2009 (FY 2010, RY 2010)       *
038200*                UPDATED W/ THE FOLLOWING REVISED FY2010 ITEMS:*
038300*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX101)      *
038400*                2) IPPS CAPITAL RATES IN PROGRAM LTCAL101     *
038500*                                                              *
038600*--------------------------------------------------------------*
038700*                                                              *
038800*   11/11/2009 - CREATE VERSION 10.2 OF THE LTCH PPS PRICER    *
038900*                EFFECTIVE 10/01/2009 (FY 2010, RY 2010)       *
039000*                REPLACES VERSION 10.1                         *
039100*                UPDATED W/ THE FOLLOWING REVISED FY2010 ITEMS:*
039200*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX103)      *
039300*                2) IPPS STATE SPECIFIC RURAL FLOOR BUDGET     *
039400*                   NEUTRALITY (SSRFBN) FACTOR TABLE (IRFBN102)*
039500*                   (KANSAS RFBN CORRECTED - CHANGED FROM      *
039600*                    0.99826 TO 0.99829)                       *
039700*                                                              *
039800*--------------------------------------------------------------*
039900*                                                              *
040000*   04/07/2010 - CREATE VERSION 10.3 OF THE LTCH PPS PRICER    *
040100*                EFFECTIVE 10/01/2010 (FY 2010, RY 2010)       *
040200*                REPLACES VERSION 10.2                         *
040300*                UPDATED W/ THE FOLLOWING REVISED FY2010 ITEMS:*
040400*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX104)      *
040500*                2) IPPS STATE SPECIFIC RURAL FLOOR BUDGET     *
040600*                   NEUTRALITY TABLE (IRFBN105)                *
040700*                3) IPPS DRG TABLE (IPDRG104)                  *
040800*                4) LTCH STANDARD RATES IN PROGRAM LTCAL104    *
040900*                5) IPPS STANDARD RATES IN PROGRAM LTCAL104    *
041000*                                                              *
041100*--------------------------------------------------------------*
041200*                                                              *
041300*   04/19/2010 - CREATE VERSION 10.4 OF THE LTCH PPS PRICER    *
041400*                EFFECTIVE 10/01/2010 (FY 2010, RY 2010)       *
041500*                REPLACES VERSION 10.3                         *
041600*                UPDATED W/ THE FOLLOWING REVISED FY2010 ITEMS:*
041700*                1) LTCH STANDARD RATES IN PROGRAM LTCAL105    *
041800*                2) IPPS STANDARD RATES IN PROGRAM LTCAL105    *
041900*                                                              *
042000*--------------------------------------------------------------*
042100*                                                              *
042200*   08/04/2010 - CREATE VERSION 11.0 OF THE LTCH PPS PRICER    *
042300*                EFFECTIVE 10/01/2010 (FY 2011, RY 2011)       *
042400*                REPLACES VERSION 10.4                         *
042500*                UPDATED W/ THE FOLLOWING REVISED FY2011 ITEMS:*
042600*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX110)      *
042700*                2) IPPS STATE SPECIFIC RURAL FLOOR BUDGET     *
042800*                   NEUTRALITY TABLE (IRFBN110)                *
042900*                3) IPPS DRG TABLE (IPDRG110)                  *
043000*                4) LTCH STANDARD RATES IN PROGRAM LTCAL110    *
043100*                5) IPPS STANDARD RATES IN PROGRAM LTCAL110    *
043200*                                                              *
043300*--------------------------------------------------------------*
043400*                                                              *
043500*   08/13/2010 - CORRECTED FY 2008 - FY 2011 FLOOR LOGIC TO    *
043600*                REFERENCE THE IPPS CBSA INSTEAD OF THE LTCH   *
043700*                CBSA (TAMARA HOWARD)                          *
043800*                                                              *
043900*--------------------------------------------------------------*
044000*                                                              *
044100*   10/19/2010 - CHANGED TO ALLOW ADJUSTMENTS TO CLAIMS WITH   *
044200*                DATES OF SERVICE OLDER THAN 5 YEARS           *
044300*--------------------------------------------------------------*
044400*                                                              *
044500*   08/01/2011 - CREATE VERSION 12.0 OF THE LTCH PPS PRICER    *
044600*                EFFECTIVE 10/01/2011 (FY 2012, RY 2012)       *
044700*                REPLACES VERSION 11.1                         *
044800*                UPDATED W/ THE FOLLOWING REVISED FY2012 ITEMS:*
044900*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX120)      *
045000*                2) IPPS DRG TABLE (IPDRG120)                  *
045100*                3) LTCH STANDARD RATES IN PROGRAM LTCAL120    *
045200*                4) IPPS STANDARD RATES IN PROGRAM LTCAL120    *
045300*                                                              *
045400*--------------------------------------------------------------*
045500*                                                              *
045600*   08/31/2011 - CREATE VERSION 12.1 OF THE LTCH PPS PRICER    *
045700*                EFFECTIVE 10/01/2011 (FY 2012, RY 2012)       *
045800*                REPLACES VERSION 12.0                         *
045900*                UPDATED W/ THE FOLLOWING REVISED FY2012 ITEMS:*
046000*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX121)      *
046100*                2) IPPS DRG TABLE (IPDRG121)                  *
046200*                3) LTCH CBSA WAGE INDEX TABLE (LTWIX121)      *
046300*--------------------------------------------------------------*
046400*                                                              *
046500*   10/28/2011 - CREATE VERSION 12.2 OF THE LTCH PPS PRICER    *
046600*                EFFECTIVE 10/01/2011 (FY 2012, RY 2012)       *
046700*                REPLACES VERSION 12.1                         *
046800*                UPDATED W/ THE FOLLOWING REVISED FY2012 ITEMS:*
046900*                1) LTCH DRG TABLE (IPDRG122)                  *
047000*                                                              *
047100*--------------------------------------------------------------*
047200*                                                              *
047300*   12/09/2011 - CREATE VERSION 12.3 OF THE LTCH PPS PRICER    *
047400*                EFFECTIVE 10/01/2011 (FY 2012, RY 2012)       *
047500*                REPLACES VERSION 12.2                         *
047600*                REVISED FY 2012 IPPS WAGE INDEX FLOOR         *
047700*                                                              *
047800*--------------------------------------------------------------*
047900*                                                              *
048000*   07/30/2012 - CREATE VERSION 13.0 OF THE LTCH PPS PRICER    *
048100*                EFFECTIVE 10/01/2012 (FY 2013, RY 2013)       *
048200*                REPLACES VERSION 12.3                         *
048300*                UPDATED W/ THE FOLLOWING REVISED FY2013 ITEMS:*
048400*                1) LTCH WAGE INDEX TABLE (LTWIX130)           *
048500*                2) LTCH DRG TABLE (LTDRG130)                  *
048600*                3) IPPS CBSA WAGE INDEX TABLE (IPWIX130)      *
048700*                4) IPPS DRG TABLE (IPDRG130)                  *
048800*                5) LTCH STANDARD RATES IN PROGRAM LTCAL130    *
048900*                6) IPPS STANDARD RATES IN PROGRAM LTCAL130    *
049000*                                                              *
049100*--------------------------------------------------------------*
049200*                                                              *
049300*   11/16/2012 - IN VERSION 13.0 OF THE LTCH PPS PRICER        *
049400*                CHANGED "T-CBSA-DATA  OCCURS 0 TO 4000 TIMES" *
049500*                     TO "T-CBSA-DATA  OCCURS 0 TO 7000 TIMES" *
049600*                FOR IPPS-CBSA-WI-TABLE IN RESPONSE TO         *
049700*                HPAR CR8041H2 (R41212).  NO VERSION NUMBERS   *
049800*                CHANGED AND ONLY MODULES LTDRV130 AND         *
049900*                LTOPN130 CHANGED AS DESCRIBED ABOVE.          *
050000*                                                              *
050100*--------------------------------------------------------------*
050200*                                                              *
050300*   08/08/2013 - CREATE VERSION 14.0 OF THE LTCH PPS PRICER    *
050400*                EFFECTIVE 10/01/2013 (FY 2014, RY 2014)       *
050500*                REPLACES VERSION 13.0                         *
050600*                UPDATED W/ THE FOLLOWING REVISED FY2014 ITEMS:*
050700*                1) LTCH WAGE INDEX TABLE (LTWIX140)           *
050800*                2) LTCH DRG TABLE (LTDRG140)                  *
050900*                3) IPPS CBSA WAGE INDEX TABLE (IPWIX140)      *
051000*                4) IPPS DRG TABLE (IPDRG140) - NEW TABLE      *
051100*                   LAYOUT & SEARCH LOGIC IN LTCAL140          *
051200*                5) LTCH STANDARD RATES IN PROGRAM LTCAL140    *
051300*                6) IPPS STANDARD RATES IN PROGRAM LTCAL140    *
051400*                7) ADDED HOSPITAL QUALITY INDICATOR TO PSF    *
051500*                8) ADDED OPERATING DSH PAYMENT REDUCTION FOR  *
051600*                   UNCOMPENSATED CARE PAYMENT IN LTCAL140     *
051700*                                                              *
051800*   09/03/2013 - CREATE VERION 141 TO INCORPORATE THE NEW LTCH *
051900*                AND PPS WAGE INDEX TABLES
052000*
052100****************************************************************
052200
052300
052400 ENVIRONMENT DIVISION.
052500 CONFIGURATION SECTION.
052600 SOURCE-COMPUTER.            IBM-370.
052700 OBJECT-COMPUTER.            IBM-370.
052800 INPUT-OUTPUT  SECTION.
052900 FILE-CONTROL.
053000
053100 DATA DIVISION.
053200 FILE SECTION.
053300
053400
053500 WORKING-STORAGE SECTION.
053600 77  W-STORAGE-REF                  PIC X(48) VALUE
053700     'L T D R V _ _ _ - W O R K I N G   S T O R A G E'.
053800 01  DRV-VERSION                    PIC X(05) VALUE 'D14.1'.
053900
054000*-------------------------------------------------------------*
054100* LTCAL MODULES OLDER THAN 5 YEARS                            *
054200*-------------------------------------------------------------*
054300 01  LTCAL032                       PIC X(08) VALUE 'LTCAL032'.
054400 01  LTCAL042                       PIC X(08) VALUE 'LTCAL042'.
054500 01  LTCAL043                       PIC X(08) VALUE 'LTCAL043'.
054600 01  LTCAL058                       PIC X(08) VALUE 'LTCAL058'.
054700 01  LTCAL059                       PIC X(08) VALUE 'LTCAL059'.
054800 01  LTCAL063                       PIC X(08) VALUE 'LTCAL063'.
054900 01  LTCAL064                       PIC X(08) VALUE 'LTCAL064'.
055000 01  LTCAL072                       PIC X(08) VALUE 'LTCAL072'.
055100 01  LTCAL075                       PIC X(08) VALUE 'LTCAL075'.
055200
055300*-------------------------------------------------------------*
055400* LTCAL MODULES CURRENTLY CALLED                              *
055500*-------------------------------------------------------------*
055600 01  LTCAL080                       PIC X(08) VALUE 'LTCAL080'.
055700 01  LTCAL087                       PIC X(08) VALUE 'LTCAL087'.
055800 01  LTCAL091                       PIC X(08) VALUE 'LTCAL091'.
055900 01  LTCAL094                       PIC X(08) VALUE 'LTCAL094'.
056000 01  LTCAL095                       PIC X(08) VALUE 'LTCAL095'.
056100 01  LTCAL103                       PIC X(08) VALUE 'LTCAL103'.
056200 01  LTCAL105                       PIC X(08) VALUE 'LTCAL105'.
056300 01  LTCAL111                       PIC X(08) VALUE 'LTCAL111'.
056400 01  LTCAL123                       PIC X(08) VALUE 'LTCAL123'.
056500 01  LTCAL130                       PIC X(08) VALUE 'LTCAL130'.
056600 01  LTCAL141                       PIC X(08) VALUE 'LTCAL141'.
056700
056800
056900***************************************************************
057000* MSA AND CBSA HOLD AREAS FOR SEARCH                          *
057100***************************************************************
057200 01  HOLD-PROV-MSA.
057300         10  H-PROV-BLANK             PIC X(2).
057400         10  H-PROV-STATE.
057500             15  FILLER               PIC X.
057600             15  H-MSA-LAST-POS       PIC X.
057700
057800 01  HOLD-PROV-CBSA.
057900         10  H-PROV-BLANK             PIC X(3).
058000         10  H-PROV-STATE.
058100             15  FILLER               PIC X.
058200             15  H-CBSA-LAST-POS      PIC X.
058300
058400 01  HOLD-PROV-IPPS-CBSA.
058500         10  H-PROV-BLANK             PIC X(3).
058600         10  H-PROV-STATE.
058700             15  FILLER               PIC X.
058800             15  H-IPPS-CBSA-LAST-POS PIC X.
058900
059000
059100***************************************************************
059200*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
059300*      THE LTCAL___ PROGRAM (MSA) - USED THROUGH 06/30/2005   *
059400***************************************************************
059500 01  WAGE-NEW-INDEX-RECORD-MSA.
059600     05  W-NEW-MSA                    PIC 9(4).
059700     05  W-NEW-EFF-DATE-M.
059800          10  W-NEW-EFF-DATE-M-CC     PIC 9(2).
059900          10  W-NEW-EFF-DATE-M-YMD.
060000              15  W-NEW-EFF-DATE-M-YY PIC 9(2).
060100              15  W-NEW-EFF-DATE-M-MM PIC 9(2).
060200              15  W-NEW-EFF-DATE-M-DD PIC 9(2).
060300     05  W-NEW-INDEX1-RECORD-M        PIC S9(02)V9(04).
060400     05  W-NEW-INDEX2-RECORD-M        PIC S9(02)V9(04).
060500     05  W-NEW-INDEX3-RECORD-M        PIC S9(02)V9(04).
060600
060700
060800***************************************************************
060900*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
061000*      THE LTCAL___ PROGRAM (CBSA) - USED SINCE 07/01/2005    *
061100***************************************************************
061200 01  WAGE-NEW-INDEX-RECORD-CBSA.
061300     05  W-NEW-CBSA                   PIC 9(5).
061400     05  W-NEW-EFF-DATE-C.
061500          10  W-NEW-EFF-DATE-C-CC     PIC 9(2).
061600          10  W-NEW-EFF-DATE-C-YMD.
061700              15  W-NEW-EFF-DATE-C-YY PIC 9(2).
061800              15  W-NEW-EFF-DATE-C-MM PIC 9(2).
061900              15  W-NEW-EFF-DATE-C-DD PIC 9(2).
062000     05  W-NEW-INDEX1-RECORD-C        PIC S9(02)V9(04).
062100     05  W-NEW-INDEX2-RECORD-C        PIC S9(02)V9(04).
062200     05  W-NEW-INDEX3-RECORD-C        PIC S9(02)V9(04).
062300
062400
062500***************************************************************
062600*      THIS IS THE IPPS WAGE-INDEX RECORD THAT WILL BE PASSED *
062700*      TO THE LTCAL___ PROGRAM (CBSA) - USED SINCE 07/01/2006 *
062800***************************************************************
062900 01  WAGE-IPPS-INDEX-RECORD-CBSA.
063000     05  W-CBSA-IPPS.
063100         10 CBSA-IPPS-123              PIC X(3).
063200         10 CBSA-IPPS-45               PIC X(2).
063300     05  W-CBSA-IPPS-SIZE              PIC X.
063400         88  LARGE-URBAN       VALUE 'L'.
063500         88  OTHER-URBAN       VALUE 'O'.
063600         88  ALL-RURAL         VALUE 'R'.
063700     05  W-CBSA-IPPS-EFF-DATE          PIC X(8).
063800     05  FILLER                        PIC X.
063900     05  W-IPPS-WAGE-INDEX             PIC S9(02)V9(04).
064000     05  W-IPPS-PR-WAGE-INDEX          PIC S9(02)V9(04).
064100
064200
064300**************************************************************
064400*      THIS IS THE PROV-RECORD THAT IS PASSED FROM THE       *
064500*      LTDRV___ PROGRAM TO THE LTCAL___ PROGRAM              *
064600**************************************************************
064700 01  PROV-NEW-HOLD.
064800     02  PROV-NEWREC-HOLD1.
064900         05  P-NEW-NPI10.
065000             10  P-NEW-NPI8             PIC X(08).
065100             10  P-NEW-NPI-FILLER       PIC X(02).
065200         05  P-NEW-PROVIDER-NO.
065300             10  P-NEW-STATE            PIC 9(02).
065400             10  FILLER                 PIC X(04).
065500         05  P-NEW-DATE-DATA.
065600             10  P-NEW-EFF-DATE.
065700                 15  P-NEW-EFF-DT-CC    PIC 9(02).
065800                 15  P-NEW-EFF-DT-YY    PIC 9(02).
065900                 15  P-NEW-EFF-DT-MM    PIC 9(02).
066000                 15  P-NEW-EFF-DT-DD    PIC 9(02).
066100             10  P-NEW-FY-BEGIN-DATE.
066200                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
066300                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
066400                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
066500                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
066600             10  P-NEW-REPORT-DATE.
066700                 15  P-NEW-REPORT-DT-CC PIC 9(02).
066800                 15  P-NEW-REPORT-DT-YY PIC 9(02).
066900                 15  P-NEW-REPORT-DT-MM PIC 9(02).
067000                 15  P-NEW-REPORT-DT-DD PIC 9(02).
067100             10  P-NEW-TERMINATION-DATE.
067200                 15  P-NEW-TERM-DT-CC   PIC 9(02).
067300                 15  P-NEW-TERM-DT-YY   PIC 9(02).
067400                 15  P-NEW-TERM-DT-MM   PIC 9(02).
067500                 15  P-NEW-TERM-DT-DD   PIC 9(02).
067600         05  P-NEW-WAIVER-CODE          PIC X(01).
067700             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
067800         05  P-NEW-INTER-NO             PIC 9(05).
067900         05  P-NEW-PROVIDER-TYPE        PIC X(02).
068000         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
068100         05  P-NEW-CURRENT-DIV   REDEFINES
068200                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
068300         05  P-NEW-MSA-DATA.
068400             10  P-NEW-CHG-CODE-INDEX       PIC X.
068500             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
068600             10  P-NEW-GEO-LOC-MSA9   REDEFINES
068700                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
068800             10  P-NEW-GEO-LOC-MSA-AST REDEFINES
068900                             P-NEW-GEO-LOC-MSA9.
069000                 15  P-NEW-GEO-MSA-1ST    PIC X.
069100                 15  P-NEW-GEO-MSA-2ND    PIC X.
069200                 15  P-NEW-GEO-MSA-3RD    PIC X.
069300                 15  P-NEW-GEO-MSA-4TH    PIC X.
069400             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
069500             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
069600             10  P-NEW-STAND-AMT-LOC-MSA9
069700                   REDEFINES P-NEW-STAND-AMT-LOC-MSA.
069800                 15  P-NEW-RURAL-1ST.
069900                     20  P-NEW-STAND-RURAL  PIC XX.
070000                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
070100                 15  P-NEW-RURAL-2ND        PIC XX.
070200         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
070300                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
070400                 88  P-NEW-SCH-YR82       VALUE   '82'.
070500                 88  P-NEW-SCH-YR87       VALUE   '87'.
070600         05  P-NEW-LUGAR                    PIC X.
070700         05  P-NEW-TEMP-RELIEF-IND          PIC X.
070800         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
070900         05  FILLER                         PIC X(05).
071000     02  PROV-NEWREC-HOLD2.
071100         05  P-NEW-VARIABLES.
071200             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
071300             10  P-NEW-COLA              PIC  9(01)V9(03).
071400             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
071500             10  P-NEW-BED-SIZE          PIC  9(05).
071600             10  P-NEW-CCR               PIC  9(01)V9(03).
071700             10  P-NEW-CMI               PIC  9(01)V9(04).
071800             10  P-NEW-SSI-RATIO         PIC  V9(04).
071900             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
072000             10  P-NEW-PPS-BLEND-YR-IND  PIC  X(01).
072100             10  P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).
072200             10  P-NEW-DSH-PERCENT       PIC  V9(04).
072300             10  P-NEW-FYE-DATE.
072400                 15  P-NEW-FYE-CC        PIC 99.
072500                 15  P-NEW-FYE-YY        PIC 99.
072600                 15  P-NEW-FYE-MM        PIC 99.
072700                 15  P-NEW-FYE-DD        PIC 99.
072800         05  P-NEW-CBSA-SPEC-PAY-IND       PIC X(01).
072900         05  P-NEW-HOSP-QUAL-IND           PIC X(01).
073000         05  P-NEW-GEO-LOC-CBSAX           PIC X(05) JUST RIGHT.
073100         05  P-NEW-GEO-LOC-CBSA9 REDEFINES
073200                          P-NEW-GEO-LOC-CBSAX PIC 9(05).
073300         05  P-NEW-GEO-LOC-CBSA-AST REDEFINES
073400                          P-NEW-GEO-LOC-CBSA9.
073500             10 P-NEW-GEO-LOC-CBSA-1ST     PIC X.
073600             10 P-NEW-GEO-LOC-CBSA-2ND     PIC X.
073700             10 P-NEW-GEO-LOC-CBSA-3RD     PIC X.
073800             10 P-NEW-GEO-LOC-CBSA-4TH     PIC X.
073900             10 P-NEW-GEO-LOC-CBSA-5TH     PIC X.
074000         05 P-NEW-GEO-LOC-CBSA-SIZE REDEFINES
074100                          P-NEW-GEO-LOC-CBSAX.
074200             10 P-NEW-GEO-LOC-CBSA-123     PIC X(03).
074300                88  P-NEW-RURAL-CBSA       VALUE '   '.
074400             10 P-NEW-GEO-LOC-CBSA-45      PIC X(02).
074500         05  FILLER                        PIC X(10).
074600         05  P-NEW-SPECIAL-WAGE-INDEX      PIC 9(02)V9(04).
074700     02  PROV-NEWREC-HOLD3.
074800         05  P-NEW-PASS-AMT-DATA.
074900             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
075000             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
075100             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
075200             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
075300         05  P-NEW-CAPI-DATA.
075400             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
075500             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
075600             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
075700             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
075800             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
075900             15  P-NEW-CAPI-NEW-HOSP       PIC X.
076000             15  P-NEW-CAPI-IME            PIC 9V9999.
076100             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
076200             15  P-VAL-BASED-PURCH-SCORE   PIC 9V999.
076300         05  FILLER                        PIC X(18).
076400
076500
076600***************************************************************
076700 LINKAGE SECTION.
076800***************************************************************
076900
077000**************************************************************
077100*      THIS IS THE BILL-RECORD THAT WILL BE PASSED TO        *
077200*      THE LTCAL___ PROGRAM                                  *
077300**************************************************************
077400 01  BILL-NEW-DATA.
077500     05  B-NPI10.
077600         10  B-NPI8                   PIC X(08).
077700         10  B-NPI-FILLER             PIC X(02).
077800     05  B-PROVIDER-NO                PIC X(06).
077900     05  B-PATIENT-STATUS             PIC X(02).
078000     05  B-DRG-CODE                   PIC X(03).
078100     05  B-LOS                        PIC 9(03).
078200     05  B-COV-DAYS                   PIC 9(03).
078300     05  B-LTR-DAYS                   PIC 9(02).
078400     05  B-DISCHARGE-DATE.
078500         10  B-DISCHG-CC              PIC 9(02).
078600         10  B-DISCHG-YY              PIC 9(02).
078700         10  B-DISCHG-MM              PIC 9(02).
078800         10  B-DISCHG-DD              PIC 9(02).
078900     05  B-COV-CHARGES                PIC 9(07)V9(02).
079000     05  B-SPEC-PAY-IND               PIC X(01).
079100     05  FILLER                       PIC X(13).
079200
079300
079400**************************************************************
079500*      THIS IS THE PPS DATA PASSED TO THE LTCAL___ PROGRAM   *
079600*      IT WILL BE PASSED BACK TO THE LTDRV___ PROGRAM        *
079700**************************************************************
079800 01  PPS-DATA-ALL.
079900     05  PPS-RTC                      PIC 9(02).
080000     05  PPS-CHRG-THRESHOLD           PIC 9(07)V9(02).
080100     05  PPS-DATA.
080200         10  PPS-MSA                  PIC X(04).
080300         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).
080400         10  PPS-AVG-LOS              PIC 9(02)V9(01).
080500         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).
080600         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).
080700         10  PPS-LOS                  PIC 9(03).
080800         10  PPS-DRG-ADJ-PAY-AMT      PIC 9(07)V9(02).
080900         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).
081000         10  PPS-FINAL-PAY-AMT        PIC 9(07)V9(02).
081100         10  PPS-FAC-COSTS            PIC 9(07)V9(02).
081200         10  PPS-NEW-FAC-SPEC-RATE    PIC 9(07)V9(02).
081300         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).
081400         10  PPS-SUBM-DRG-CODE        PIC X(03).
081500         10  PPS-CALC-VERS-CD         PIC X(05).
081600         10  PPS-REG-DAYS-USED        PIC 9(03).
081700         10  PPS-LTR-DAYS-USED        PIC 9(03).
081800         10  PPS-BLEND-YEAR           PIC 9(01).
081900         10  PPS-COLA                 PIC 9(01)V9(03).
082000         10  FILLER                   PIC X(04).
082100    05  PPS-OTHER-DATA.
082200         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).
082300         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).
082400         10  PPS-STD-FED-RATE         PIC 9(05)V9(02).
082500         10  PPS-BDGT-NEUT-RATE       PIC 9(01)V9(03).
082600         10  PPS-IPTHRESH             PIC 9(03)V9(01).
082700         10  FILLER                   PIC X(16).
082800    05  PPS-PC-DATA.
082900         10  PPS-COT-IND              PIC X(01).
083000         10  FILLER                   PIC X(20).
083100
083200 01  PPS-CBSA                         PIC X(05).
083300
083400
083500*****************************************************************
083600*            THESE ARE THE VERSIONS OF THE LTDRV___             *
083700*           PROGRAMS THAT WILL BE PASSED BACK----               *
083800*          ASSOCIATED WITH THE BILL BEING PROCESSED             *
083900*****************************************************************
084000 01  PRICER-OPT-VERS-SW.
084100     05  PRICER-OPTION-SW               PIC X(01).
084200         88  ALL-TABLES-PASSED          VALUE 'A'.
084300         88  PROV-RECORD-PASSED         VALUE 'P'.
084400     05  PPS-VERSIONS.
084500         10  PPDRV-VERSION              PIC X(05).
084600
084700
084800
084900**************************************************************
085000*      PROVIDER SPECIFIC RECORD                              *
085100**************************************************************
085200*      THIS IS THE PROV-RECORD THAT IS PASSED FROM THE       *
085300*      LTOPN___ PROGRAM                                      *
085400**************************************************************
085500 01  PROV-RECORD.
085600     05  PROV-REC1                  PIC X(80).
085700     05  PROV-REC2                  PIC X(80).
085800     05  PROV-REC3                  PIC X(80).
085900
086000
086100**************************************************************
086200*      LTCH CBSA WAGE INDEX TABLE                            *
086300**************************************************************
086400*      THIS IS THE CBSA WAGE INDEX TABLE THAT IS PASSED FROM *
086500*      THE LTOPN___ PROGRAM                                  *
086600**************************************************************
086700 01  CBSA-WI-TABLE.
086800     05  C-CBSA-DATA  OCCURS 0 TO 4000 TIMES
086900                      DEPENDING ON CBSA-CNT
087000                      ASCENDING KEY IS CBSAX-CBSA
087100                      INDEXED BY CU1 CU2.
087200         10  CBSAX-CBSA         PIC X(05).
087300         10  CBSAX-EFF-DATE     PIC X(08).
087400         10  CBSAX-WAGE-INDEX1  PIC S9(02)V9(04).
087500         10  CBSAX-WAGE-INDEX2  PIC S9(02)V9(04).
087600         10  CBSAX-WAGE-INDEX3  PIC S9(02)V9(04).
087700
087800
087900**************************************************************
088000*      IPPS CBSA WAGE INDEX TABLE                            *
088100**************************************************************
088200*      THIS IS THE IPPS CBSA WAGE INDEX TABLE THAT IS PASSED *
088300*      FROM THE LTOPN___ PROGRAM                             *
088400**************************************************************
088500 01  IPPS-CBSA-WI-TABLE.
088600     05  T-CBSA-DATA  OCCURS 0 TO 7000 TIMES
088700                      DEPENDING ON IPPS-CBSA-CNT
088800                      ASCENDING KEY IS T-CBSA
088900                      INDEXED BY MA1 MA2 MA3.
089000         10  T-CBSA             PIC X(5).
089100         10  T-CBSA-SIZE        PIC X(01).
089200         10  T-CBSA-EFF-DATE    PIC X(08).
089300         10  T-CBSA-WAGE-INDX1  PIC S9(02)V9(04).
089400         10  T-CBSA-WAGE-INDX2  PIC S9(02)V9(04).
089500
089600
089700**************************************************************
089800*      LTCH MSA WAGE INDEX TABLE                             *
089900**************************************************************
090000*      THIS IS THE MSA WAGE INDEX TABLE THAT IS PASSED FROM  *
090100*      THE LTOPN___ PROGRAM                                  *
090200**************************************************************
090300 01  MSA-WI-TABLE.
090400     05  M-MSA-DATA   OCCURS 0 TO 4000 TIMES
090500                      DEPENDING ON MSA-CNT
090600                      ASCENDING KEY IS MSAX-MSA
090700                      INDEXED BY MU1 MU2.
090800         10  MSAX-MSA          PIC X(4).
090900         10  MSAX-EFF-DATE     PIC X(08).
091000         10  MSAX-WAGE-INDEX1  PIC S9(02)V9(04).
091100         10  MSAX-WAGE-INDEX2  PIC S9(02)V9(04).
091200         10  MSAX-WAGE-INDEX3  PIC S9(02)V9(04).
091300
091400
091500**************************************************************
091600*  INPUT FILE RECORD COUNTS                                  *
091700**************************************************************
091800 01  WORK-COUNTERS.
091900     05  CBSA-CNT              PIC 9(5).
092000     05  MSA-CNT               PIC 9(5).
092100     05  PROV-CNT              PIC 9(5).
092200     05  IPPS-CBSA-CNT         PIC 9(5).
092300
092400
092500
092600
092700 PROCEDURE DIVISION  USING BILL-NEW-DATA
092800                           PPS-DATA-ALL
092900                           PPS-CBSA
093000                           PRICER-OPT-VERS-SW
093100                           PROV-RECORD
093200                           CBSA-WI-TABLE
093300                           IPPS-CBSA-WI-TABLE
093400                           MSA-WI-TABLE
093500                           WORK-COUNTERS.
093600
093700
093800******************************************************************
093900*                                                                *
094000*    PROCESSING:                                                 *
094100*      A. THIS MODULE WILL RETRIEVE THE WAGE INDEX RECORD(S)     *
094200*         NEEDED FOR EACH BILL.                                  *
094300*      B. THIS MODULE WILL CALL THE LTCAL MODULES.               *
094400*      C. THE PROV-RECORD AND WAGE-INDEX-RECORD(S) ASSOCIATED    *
094500*         WITH EACH BILL WILL BE PASSED TO THE LTCAL PROGRAMS.   *
094600*                                                                *
094700******************************************************************
094800
094900     MOVE DRV-VERSION TO PPDRV-VERSION.
095000
095100     INITIALIZE PPS-DATA-ALL.
095200     INITIALIZE PPS-CBSA.
095300     MOVE ZEROS TO W-IPPS-PR-WAGE-INDEX.
095400
095500     MOVE PROV-RECORD TO PROV-NEW-HOLD.
095600
095700
095800*----------------------------------------------------------*
095900* RTC = 98  --  BILL DISCHARGE DATE BEFORE 10/01/2002      *
096000*----------------------------------------------------------*
096100     IF B-DISCHARGE-DATE < 20021001
096200        MOVE 98 TO PPS-RTC
096300        GOBACK
096400     END-IF.
096500
096600
096700************************************************************
096800*    GET THE WAGE-INDEX RECORD                             *
096900************************************************************
097000
097100*------------------------------------------------*
097200* EDIT THE CBSA AND MSA FROM THE PROVIDER RECORD *
097300*------------------------------------------------*
097400     IF P-NEW-GEO-LOC-CBSAX = SPACES
097500        MOVE ZEROS TO P-NEW-GEO-LOC-CBSAX
097600     END-IF.
097700
097800     IF P-NEW-GEO-LOC-MSAX = SPACES
097900        MOVE ZEROS TO P-NEW-GEO-LOC-MSAX
098000     END-IF.
098100
098200     IF P-NEW-EFF-DATE > 20050701
098300        IF '*' = P-NEW-GEO-LOC-CBSA-1ST OR
098400                 P-NEW-GEO-LOC-CBSA-2ND OR
098500                 P-NEW-GEO-LOC-CBSA-3RD OR
098600                 P-NEW-GEO-LOC-CBSA-4TH OR
098700                 P-NEW-GEO-LOC-CBSA-5TH
098800           MOVE 60 TO PPS-RTC
098900           GOBACK
099000        END-IF
099100     END-IF.
099200
099300*----------------------------------------------------------*
099400* DETERMINE WHETHER TO GET THE LTCH MSA OR CBSA WAGE INDEX *
099500*----------------------------------------------------------*
099600     IF B-DISCHARGE-DATE < 20050701
099700       SET MU1 TO 1
099800       PERFORM 0500-GET-MSA THRU 0500-EXIT
099900     ELSE
100000       SET CU1 TO 1
100100       PERFORM 0550-GET-CBSA THRU 0550-EXIT
100200     END-IF.
100300
100400*----------------------------------------------------------*
100500* GET THE IPPS CBSA WAGE INDEX FOR CLAIMS DISCHARGED AFTER *
100600* JUNE 30, 2006 FOR USE IN THE 4TH SHORT STAY PROVISION    *
100700*----------------------------------------------------------*
100800     IF B-DISCHARGE-DATE > 20060630
100900       SET MA1 TO 1
101000       PERFORM 0575-GET-IPPS-CBSA THRU 0575-EXIT
101100       IF W-IPPS-WAGE-INDEX = 0
101200          MOVE 52 TO PPS-RTC
101300       END-IF
101400     END-IF.
101500
101600*--------------------------------------------------------------*
101700* RTC = 60  --  LTCH/IPPS CBSA/MSA WAGE INDEX RECORD NOT FOUND *
101800* RTC = 52  --  LTCH/IPPS CBSA/MSA WAGE INDEX INVALID          *
101900*--------------------------------------------------------------*
102000     IF PPS-RTC = 60 OR PPS-RTC = 52
102100        GOBACK
102200     END-IF.
102300
102400
102500
102600******************************************************************
102700******************************************************************
102800**                                                              **
102900**          THIS NEXT CALL WILL PROCESS BILLS WITH              **
103000**          A DISCHARGE DATE ON OR AFTER 20021001               **
103100**                                                              **
103200**--------------------------------------------------------------**
103300**                                                              **
103400** FOR BILLS WITH DISCHARGE DATES AFTER 20050630, INCLUDE FIELD **
103500** PPS-CBSA IN THE CALL USING STATEMENT, OMIT THIS FIELD FOR    **
103600** BILLS WITH DISCHARGE DATES BEFORE 20050701.                  **
103700**                                                              **
103800** FOR BILLS WITH DISCHARGE DATES AFTER 20060630, INCLUDE FIELD **
103900** WAGE-IPPS-INDEX-RECORD-CBSA.                                 **
104000**                                                              **
104100******************************************************************
104200******************************************************************
104300
104400*----------------------------------------------------------------*
104500*        FISCAL YEAR 2014, RATE YEAR 2014 (AFTER 10/1/2013)      *
104600*----------------------------------------------------------------*
104700         IF B-DISCHARGE-DATE > 20130930
104800            CALL LTCAL141 USING BILL-NEW-DATA
104900                                PPS-DATA-ALL
105000                                PPS-CBSA
105100                                PRICER-OPT-VERS-SW
105200                                PROV-NEW-HOLD
105300                                WAGE-NEW-INDEX-RECORD-CBSA
105400                                WAGE-IPPS-INDEX-RECORD-CBSA.
105500
105600*----------------------------------------------------------------*
105700*        FISCAL YEAR 2013, RATE YEAR 2013 (AFTER 10/1/2012)      *
105800*----------------------------------------------------------------*
105900         IF B-DISCHARGE-DATE > 20120930 AND
106000                             < 20131001
106100            CALL LTCAL130 USING BILL-NEW-DATA
106200                                PPS-DATA-ALL
106300                                PPS-CBSA
106400                                PRICER-OPT-VERS-SW
106500                                PROV-NEW-HOLD
106600                                WAGE-NEW-INDEX-RECORD-CBSA
106700                                WAGE-IPPS-INDEX-RECORD-CBSA.
106800
106900*----------------------------------------------------------------*
107000*        FISCAL YEAR 2012, RATE YEAR 2012 (AFTER 10/1/2011)      *
107100*----------------------------------------------------------------*
107200         IF B-DISCHARGE-DATE > 20110930 AND
107300                             < 20121001
107400            CALL LTCAL123 USING BILL-NEW-DATA
107500                                PPS-DATA-ALL
107600                                PPS-CBSA
107700                                PRICER-OPT-VERS-SW
107800                                PROV-NEW-HOLD
107900                                WAGE-NEW-INDEX-RECORD-CBSA
108000                                WAGE-IPPS-INDEX-RECORD-CBSA.
108100
108200*----------------------------------------------------------------*
108300*        FISCAL YEAR 2011, RATE YEAR 2011 (AFTER 10/1/2010)      *
108400*----------------------------------------------------------------*
108500         IF B-DISCHARGE-DATE > 20100930 AND
108600                             < 20111001
108700            CALL LTCAL111 USING BILL-NEW-DATA
108800                                PPS-DATA-ALL
108900                                PPS-CBSA
109000                                PRICER-OPT-VERS-SW
109100                                PROV-NEW-HOLD
109200                                WAGE-NEW-INDEX-RECORD-CBSA
109300                                WAGE-IPPS-INDEX-RECORD-CBSA.
109400
109500*----------------------------------------------------------------*
109600*        FISCAL YEAR 2010, RATE YEAR 2010 (AFTER 3/31/2010)      *
109700*----------------------------------------------------------------*
109800         IF B-DISCHARGE-DATE > 20100331 AND
109900                             < 20101001
110000            CALL LTCAL105 USING BILL-NEW-DATA
110100                                PPS-DATA-ALL
110200                                PPS-CBSA
110300                                PRICER-OPT-VERS-SW
110400                                PROV-NEW-HOLD
110500                                WAGE-NEW-INDEX-RECORD-CBSA
110600                                WAGE-IPPS-INDEX-RECORD-CBSA.
110700
110800*----------------------------------------------------------------*
110900*        FISCAL YEAR 2010, RATE YEAR 2010 (BEFORE 4/1/2010)      *
111000*----------------------------------------------------------------*
111100         IF B-DISCHARGE-DATE > 20090930 AND
111200                             < 20100401
111300            CALL LTCAL103 USING BILL-NEW-DATA
111400                                PPS-DATA-ALL
111500                                PPS-CBSA
111600                                PRICER-OPT-VERS-SW
111700                                PROV-NEW-HOLD
111800                                WAGE-NEW-INDEX-RECORD-CBSA
111900                                WAGE-IPPS-INDEX-RECORD-CBSA.
112000
112100*----------------------------------------------------------------*
112200*        FISCAL YEAR 2009, RATE YEAR 2009 (AFTER 6/2/2009)       *
112300*----------------------------------------------------------------*
112400         IF B-DISCHARGE-DATE > 20090602 AND
112500                             < 20091001
112600            CALL LTCAL095 USING BILL-NEW-DATA
112700                                PPS-DATA-ALL
112800                                PPS-CBSA
112900                                PRICER-OPT-VERS-SW
113000                                PROV-NEW-HOLD
113100                                WAGE-NEW-INDEX-RECORD-CBSA
113200                                WAGE-IPPS-INDEX-RECORD-CBSA.
113300
113400*----------------------------------------------------------------*
113500*        FISCAL YEAR 2009, RATE YEAR 2009 (BEFORE 6/3/2009)      *
113600*----------------------------------------------------------------*
113700         IF B-DISCHARGE-DATE > 20080930 AND
113800                             < 20090603
113900            CALL LTCAL094 USING BILL-NEW-DATA
114000                                PPS-DATA-ALL
114100                                PPS-CBSA
114200                                PRICER-OPT-VERS-SW
114300                                PROV-NEW-HOLD
114400                                WAGE-NEW-INDEX-RECORD-CBSA
114500                                WAGE-IPPS-INDEX-RECORD-CBSA.
114600
114700*----------------------------------------------------------------*
114800*        FISCAL YEAR 2008, RATE YEAR 2009                        *
114900*----------------------------------------------------------------*
115000         IF B-DISCHARGE-DATE > 20080630 AND
115100                             < 20081001
115200            CALL LTCAL091 USING BILL-NEW-DATA
115300                                PPS-DATA-ALL
115400                                PPS-CBSA
115500                                PRICER-OPT-VERS-SW
115600                                PROV-NEW-HOLD
115700                                WAGE-NEW-INDEX-RECORD-CBSA
115800                                WAGE-IPPS-INDEX-RECORD-CBSA.
115900
116000*----------------------------------------------------------------*
116100*        FISCAL YEAR 2008, RATE YEAR 2008                        *
116200*----------------------------------------------------------------*
116300         IF B-DISCHARGE-DATE > 20070930 AND
116400                             < 20080701
116500            CALL LTCAL087 USING BILL-NEW-DATA
116600                                PPS-DATA-ALL
116700                                PPS-CBSA
116800                                PRICER-OPT-VERS-SW
116900                                PROV-NEW-HOLD
117000                                WAGE-NEW-INDEX-RECORD-CBSA
117100                                WAGE-IPPS-INDEX-RECORD-CBSA.
117200
117300*----------------------------------------------------------------*
117400*        FISCAL YEAR 2007, RATE YEAR 2008                        *
117500*----------------------------------------------------------------*
117600         IF B-DISCHARGE-DATE > 20070630 AND
117700                             < 20071001
117800            CALL LTCAL080 USING BILL-NEW-DATA
117900                                PPS-DATA-ALL
118000                                PPS-CBSA
118100                                PRICER-OPT-VERS-SW
118200                                PROV-NEW-HOLD
118300                                WAGE-NEW-INDEX-RECORD-CBSA
118400                                WAGE-IPPS-INDEX-RECORD-CBSA.
118500
118600*----------------------------------------------------------------*
118700*        FISCAL YEAR 2007, RATE YEAR 2007                        *
118800*----------------------------------------------------------------*
118900         IF B-DISCHARGE-DATE > 20060930 AND
119000                             < 20070701
119100            CALL LTCAL075 USING BILL-NEW-DATA
119200                                PPS-DATA-ALL
119300                                PPS-CBSA
119400                                PRICER-OPT-VERS-SW
119500                                PROV-NEW-HOLD
119600                                WAGE-NEW-INDEX-RECORD-CBSA
119700                                WAGE-IPPS-INDEX-RECORD-CBSA.
119800
119900*----------------------------------------------------------------*
120000*        FISCAL YEAR 2006, RATE YEAR 2007                        *
120100*----------------------------------------------------------------*
120200         IF B-DISCHARGE-DATE > 20060630 AND
120300                             < 20061001
120400            CALL LTCAL072 USING BILL-NEW-DATA
120500                                PPS-DATA-ALL
120600                                PPS-CBSA
120700                                PRICER-OPT-VERS-SW
120800                                PROV-NEW-HOLD
120900                                WAGE-NEW-INDEX-RECORD-CBSA
121000                                WAGE-IPPS-INDEX-RECORD-CBSA.
121100
121200*----------------------------------------------------------------*
121300*        FISCAL YEAR 2006, RATE YEAR 2006                        *
121400*----------------------------------------------------------------*
121500         IF B-DISCHARGE-DATE > 20050930 AND
121600                             < 20060701
121700            CALL LTCAL064 USING BILL-NEW-DATA
121800                                PPS-DATA-ALL
121900                                PPS-CBSA
122000                                PRICER-OPT-VERS-SW
122100                                PROV-NEW-HOLD
122200                                WAGE-NEW-INDEX-RECORD-CBSA.
122300
122400*----------------------------------------------------------------*
122500*        FISCAL YEAR 2005, RATE YEAR 2006                        *
122600*----------------------------------------------------------------*
122700         IF B-DISCHARGE-DATE > 20050630 AND
122800                             < 20051001
122900            CALL LTCAL063 USING BILL-NEW-DATA
123000                                PPS-DATA-ALL
123100                                PPS-CBSA
123200                                PRICER-OPT-VERS-SW
123300                                PROV-NEW-HOLD
123400                                WAGE-NEW-INDEX-RECORD-CBSA.
123500
123600*----------------------------------------------------------------*
123700*        FISCAL YEAR 2005, RATE YEAR 2005                        *
123800*----------------------------------------------------------------*
123900         IF B-DISCHARGE-DATE > 20040930 AND
124000            B-DISCHARGE-DATE < 20050701
124100            CALL LTCAL059 USING BILL-NEW-DATA
124200                                PPS-DATA-ALL
124300                                PRICER-OPT-VERS-SW
124400                                PROV-NEW-HOLD
124500                                WAGE-NEW-INDEX-RECORD-MSA.
124600
124700**---------------------------------------------------------------*
124800**       FISCAL YEAR 2004, RATE YEAR 2005                        *
124900**---------------------------------------------------------------*
125000         IF B-DISCHARGE-DATE > 20040630 AND
125100            B-DISCHARGE-DATE < 20041001
125200            CALL LTCAL058 USING BILL-NEW-DATA
125300                                PPS-DATA-ALL
125400                                PRICER-OPT-VERS-SW
125500                                PROV-NEW-HOLD
125600                                WAGE-NEW-INDEX-RECORD-MSA.
125700
125800**---------------------------------------------------------------*
125900**       FISCAL YEAR 2004, RATE YEAR 2004 (NO LONGER CALLED)     *
126000**---------------------------------------------------------------*
126100         IF B-DISCHARGE-DATE > 20030930 AND
126200            B-DISCHARGE-DATE < 20040701
126300            CALL LTCAL043 USING BILL-NEW-DATA
126400                                PPS-DATA-ALL
126500                                PRICER-OPT-VERS-SW
126600                                PROV-NEW-HOLD
126700                                WAGE-NEW-INDEX-RECORD-MSA.
126800
126900**---------------------------------------------------------------*
127000**       FISCAL YEAR 2003, RATE YEAR 2004 (NO LONGER CALLED)     *
127100**---------------------------------------------------------------*
127200         IF B-DISCHARGE-DATE > 20030630 AND
127300            B-DISCHARGE-DATE < 20031001
127400            CALL LTCAL042 USING BILL-NEW-DATA
127500                                PPS-DATA-ALL
127600                                PRICER-OPT-VERS-SW
127700                                PROV-NEW-HOLD
127800                                WAGE-NEW-INDEX-RECORD-MSA.
127900
128000**---------------------------------------------------------------*
128100**       FISCAL YEAR 2003, RATE YEAR 2003 (NO LONGER CALLED)     *
128200**---------------------------------------------------------------*
128300         IF B-DISCHARGE-DATE < 20030701
128400            CALL LTCAL032 USING BILL-NEW-DATA
128500                                PPS-DATA-ALL
128600                                PRICER-OPT-VERS-SW
128700                                PROV-NEW-HOLD
128800                                WAGE-NEW-INDEX-RECORD-MSA.
128900
129000
129100         GOBACK.
129200
129300******************************************************************
129400******************************************************************
129500
129600
129700******************************************************************
129800 0500-GET-MSA.
129900******************************************************************
130000
130100     MOVE P-NEW-GEO-LOC-MSAX TO HOLD-PROV-MSA.
130200
130300     SEARCH M-MSA-DATA VARYING MU1
130400       AT END
130500          MOVE 60 TO PPS-RTC
130600       WHEN MSAX-MSA (MU1) = HOLD-PROV-MSA
130700          SET MU2 TO MU1
130800          PERFORM 0600-N-GET-WAGE-INDX
130900            THRU 0600-N-EXIT VARYING MU2
131000            FROM MU1 BY 1 UNTIL
131100              MSAX-MSA (MU2) NOT = HOLD-PROV-MSA.
131200
131300 0500-EXIT.
131400      EXIT.
131500
131600
131700******************************************************************
131800 0550-GET-CBSA.
131900******************************************************************
132000
132100     MOVE P-NEW-GEO-LOC-CBSAX TO HOLD-PROV-CBSA.
132200
132300     SEARCH C-CBSA-DATA VARYING CU1
132400        AT END
132500           MOVE 60 TO PPS-RTC
132600        WHEN CBSAX-CBSA (CU1) = HOLD-PROV-CBSA
132700           SET CU2 TO CU1
132800           PERFORM 0650-N-GET-WAGE-INDX
132900             THRU 0650-N-EXIT VARYING CU2
133000             FROM CU1 BY 1 UNTIL
133100               CBSAX-CBSA (CU2) NOT = HOLD-PROV-CBSA.
133200
133300 0550-EXIT.
133400      EXIT.
133500
133600
133700******************************************************************
133800 0575-GET-IPPS-CBSA.
133900******************************************************************
134000
134100     MOVE P-NEW-GEO-LOC-CBSAX TO HOLD-PROV-IPPS-CBSA.
134200
134300
134400*------------------------------------------------------------*
134500* ASSIGN FY 2006 IPPS WAGE INDEX FLOORS                      *
134600*------------------------------------------------------------*
134700     IF B-DISCHARGE-DATE > 20050930 AND < 20061001
134800        PERFORM 0580-FY2006-FLOOR-CBSA THRU 0580-FY2006-EXIT
134900     END-IF.
135000
135100
135200*------------------------------------------------------------*
135300* ASSIGN FY 2007 IPPS WAGE INDEX FLOORS                      *
135400*------------------------------------------------------------*
135500     IF B-DISCHARGE-DATE > 20060930 AND < 20071001
135600        PERFORM 0580-FY2007-FLOOR-CBSA THRU 0580-FY2007-EXIT
135700     END-IF.
135800
135900
136000*------------------------------------------------------------*
136100* ASSIGN FY 2008 IPPS WAGE INDEX FLOORS                      *
136200*------------------------------------------------------------*
136300     IF B-DISCHARGE-DATE > 20070930 AND < 20081001
136400        PERFORM 0580-FY2008-FLOOR-CBSA THRU 0580-FY2008-EXIT
136500     END-IF.
136600
136700
136800*------------------------------------------------------------*
136900* ASSIGN FY 2009 IPPS WAGE INDEX FLOORS                      *
137000*------------------------------------------------------------*
137100     IF B-DISCHARGE-DATE > 20080930 AND < 20091001
137200        PERFORM 0580-FY2009-FLOOR-CBSA THRU 0580-FY2009-EXIT
137300     END-IF.
137400
137500
137600*------------------------------------------------------------*
137700* ASSIGN FY 2010 IPPS WAGE INDEX FLOORS                      *
137800*------------------------------------------------------------*
137900     IF B-DISCHARGE-DATE > 20090930 AND < 20101001
138000        PERFORM 0580-FY2010-FLOOR-CBSA THRU 0580-FY2010-EXIT
138100     END-IF.
138200
138300*------------------------------------------------------------*
138400* ASSIGN FY 2011 IPPS WAGE INDEX FLOORS                      *
138500*------------------------------------------------------------*
138600     IF B-DISCHARGE-DATE > 20100930 AND < 20111001
138700        PERFORM 0580-FY2011-FLOOR-CBSA THRU 0580-FY2011-EXIT
138800     END-IF.
138900
139000*------------------------------------------------------------*
139100* ASSIGN FY 2012 IPPS WAGE INDEX FLOORS                      *
139200*------------------------------------------------------------*
139300     IF B-DISCHARGE-DATE > 20110930
139400        PERFORM 0580-FY2012-FLOOR-CBSA THRU 0580-FY2012-EXIT
139500     END-IF.
139600
139700*------------------------------------------------------------*
139800* ASSIGN FY 2013 IPPS WAGE INDEX FLOORS                      *
139900*------------------------------------------------------------*
140000     IF B-DISCHARGE-DATE > 20120930
140100        PERFORM 0580-FY2013-FLOOR-CBSA THRU 0580-FY2013-EXIT
140200     END-IF.
140300
140400*------------------------------------------------------------*
140500* ASSIGN FY 2014 IPPS WAGE INDEX FLOORS                      *
140600*------------------------------------------------------------*
140700     IF B-DISCHARGE-DATE > 20130930
140800        PERFORM 0580-FY2014-FLOOR-CBSA THRU 0580-FY2014-EXIT
140900     END-IF.
141000
141100
141200*------------------------------------------------------------*
141300* SEARCH TABLE FOR IPPS CBSA & GET WAGE INDEX                *
141400*------------------------------------------------------------*
141500     SEARCH T-CBSA-DATA VARYING MA1
141600        AT END
141700           MOVE 60 TO PPS-RTC
141800        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA
141900           SET MA2 TO MA1
142000           PERFORM 0675-N-GET-IPPS-WAGE-INDX
142100              THRU 0675-N-EXIT VARYING MA2
142200              FROM MA1 BY 1 UNTIL
142300                   T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA.
142400
142500
142600*------------------------------------------------------------*
142700* GET THE IPPS CBSA SIZE INDICATOR                           *
142800*------------------------------------------------------------*
142900* LOGIC REVISED 12/28/2006 FOR VERSION 08.0                  *
143000*------------------------------------------------------------*
143100     MOVE P-NEW-GEO-LOC-CBSAX TO HOLD-PROV-IPPS-CBSA.
143200
143300     SEARCH T-CBSA-DATA VARYING MA1
143400        AT END
143500           MOVE 60 TO PPS-RTC
143600        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA
143700           SET MA2 TO MA1.
143800
143900     IF PPS-RTC = 00
144000        PERFORM 0585-GET-IPPS-CBSA-SIZE
144100           THRU 0585-EXIT VARYING MA2
144200           FROM MA1 BY 1 UNTIL
144300                T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA.
144400
144500
144600*------------------------------------------------------------*
144700* GET THE PUERTO RICO SPECIFIC WAGE INDEX FOR PR HOSPITALS   *
144800*------------------------------------------------------------*
144900     IF P-NEW-STATE = 40
145000        PERFORM 0590-GET-IPPS-CBSA-PR THRU 0590-EXIT
145100        IF W-IPPS-PR-WAGE-INDEX = 0
145200           MOVE 52 TO PPS-RTC
145300        END-IF
145400     END-IF.
145500
145600
145700 0575-EXIT.
145800      EXIT.
145900
146000
146100******************************************************************
146200*                                                                *
146300* FLOOR ASSIGNMENTS FOR FY 2006 ONLY:                            *
146400*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
146500*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
146600*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
146700* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV063             *
146800*                                                                *
146900******************************************************************
147000 0580-FY2006-FLOOR-CBSA.
147100******************************************************************
147200
147300     IF HOLD-PROV-IPPS-CBSA = '   10'
147400        AND P-NEW-CBSA-SPEC-PAY-IND = 'Y'
147500        AND P-NEW-STATE = 10
147600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
147700            MOVE '   10' TO HOLD-PROV-IPPS-CBSA.
147800
147900     IF HOLD-PROV-IPPS-CBSA = '   50'
148000        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
148100        AND P-NEW-STATE = 50
148200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
148300            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
148400
148500     IF HOLD-PROV-IPPS-CBSA = '10900'
148600        AND P-NEW-STATE = 31
148700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
148800            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
148900
149000     IF HOLD-PROV-IPPS-CBSA = '15764'
149100        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
149200        AND P-NEW-STATE = 30
149300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
149400            MOVE '   30' TO HOLD-PROV-IPPS-CBSA.
149500
149600     IF HOLD-PROV-IPPS-CBSA = '16620'
149700        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
149800        AND P-NEW-STATE = 36
149900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
150000            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
150100
150200     IF HOLD-PROV-IPPS-CBSA = '19060'
150300        AND P-NEW-STATE = 21
150400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
150500            MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
150600
150700     IF HOLD-PROV-IPPS-CBSA = '22020'
150800        AND P-NEW-STATE = 24
150900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
151000            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
151100
151200     IF HOLD-PROV-IPPS-CBSA = '24220'
151300        AND P-NEW-STATE = 24
151400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
151500            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
151600
151700     IF HOLD-PROV-IPPS-CBSA = '24580'
151800        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
151900        AND P-NEW-STATE = 52
152000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
152100            MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
152200
152300     IF HOLD-PROV-IPPS-CBSA = '25540'
152400        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
152500        AND P-NEW-STATE = 07
152600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
152700            MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
152800
152900     IF HOLD-PROV-IPPS-CBSA = '30300'
153000        AND P-NEW-STATE = 50
153100            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
153200            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
153300
153400     IF HOLD-PROV-IPPS-CBSA = '37620'
153500        AND P-NEW-STATE = 36
153600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
153700            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
153800
153900     IF HOLD-PROV-IPPS-CBSA = '39900'
154000        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
154100        AND P-NEW-STATE = 05
154200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
154300            MOVE '   05' TO HOLD-PROV-IPPS-CBSA.
154400
154500     IF HOLD-PROV-IPPS-CBSA = '48260'
154600        AND P-NEW-STATE = 36
154700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
154800            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
154900
155000     IF HOLD-PROV-IPPS-CBSA = '48540'
155100        AND P-NEW-STATE = 36
155200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
155300            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
155400
155500     IF HOLD-PROV-IPPS-CBSA = '48540'
155600        AND P-NEW-STATE = 51
155700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
155800            MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
155900
156000     IF HOLD-PROV-IPPS-CBSA = '48864'
156100        AND P-NEW-STATE = 31
156200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
156300            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
156400
156500     IF HOLD-PROV-IPPS-CBSA = '49660'
156600        AND P-NEW-STATE = 36
156700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
156800            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
156900
157000
157100 0580-FY2006-EXIT.
157200      EXIT.
157300
157400
157500******************************************************************
157600*                                                                *
157700* FLOOR ASSIGNMENTS FOR FY 2007:                                 *
157800*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
157900*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
158000*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
158100* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV071             *
158200*                                                                *
158300******************************************************************
158400 0580-FY2007-FLOOR-CBSA.
158500******************************************************************
158600
158700     IF HOLD-PROV-IPPS-CBSA = '   10'
158800        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
158900        AND P-NEW-STATE = 10
159000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
159100            MOVE '   10' TO HOLD-PROV-IPPS-CBSA.
159200
159300     IF HOLD-PROV-IPPS-CBSA = '   14'
159400        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
159500        AND P-NEW-STATE = 14
159600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
159700            MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
159800
159900     IF HOLD-PROV-IPPS-CBSA = '   26'
160000        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
160100        AND P-NEW-STATE = 26
160200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
160300            MOVE '   26' TO HOLD-PROV-IPPS-CBSA.
160400
160500     IF HOLD-PROV-IPPS-CBSA = '   50'
160600        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
160700        AND P-NEW-STATE = 50
160800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
160900            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
161000
161100     IF HOLD-PROV-IPPS-CBSA = '10900'
161200        AND P-NEW-STATE = 31
161300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
161400            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
161500
161600     IF HOLD-PROV-IPPS-CBSA = '19060'
161700        AND P-NEW-STATE = 21
161800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
161900            MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
162000
162100     IF HOLD-PROV-IPPS-CBSA = '22020'
162200        AND P-NEW-STATE = 24
162300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
162400            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
162500
162600     IF HOLD-PROV-IPPS-CBSA = '24220'
162700        AND P-NEW-STATE = 24
162800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
162900            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
163000
163100     IF HOLD-PROV-IPPS-CBSA = '24580'
163200        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
163300        AND P-NEW-STATE = 52
163400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
163500            MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
163600
163700     IF HOLD-PROV-IPPS-CBSA = '25540'
163800        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
163900        AND P-NEW-STATE = 07
164000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
164100            MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
164200
164300     IF HOLD-PROV-IPPS-CBSA = '26580'
164400        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
164500        AND P-NEW-STATE = 36
164600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
164700            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
164800
164900
165000*----------------------------------------------------------*
165100*  ON AND AFTER 11/03/2006, NO HOSPITALS RECLASSIFYING TO  *
165200*  CBSA 27860 WILL RECEIVE ITS STATE FLOOR DUE TO THE WIX  *
165300*  CHANGE IN THE IPPS FINAL RULE 2007 CORRECTION NOTICE 1  *
165400*----------------------------------------------------------*
165500*  - LOGIC DISABLED 11-20-2006 FOR RELEASE 07.5            *
165600*  - REINSTATED & ALTERED 12-28-2006 FOR RELEASE 08.0 TO   *
165700*    MATCH THE IPPS PRICER (BECAUSE THIS CODE ONLY APPLIES *
165800*    RECLASS PROVIDERS AND THERE ARE NO LTCH RECLASS       *
165900*    PROVIDERS, THESE CHANGES DO NOT AFFECT BILL PAYMENT)  *
166000*----------------------------------------------------------*
166100     IF B-DISCHARGE-DATE < 20061103
166200        IF HOLD-PROV-IPPS-CBSA = '27860'
166300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
166400           AND P-NEW-STATE = 26
166500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
166600               MOVE '   26' TO HOLD-PROV-IPPS-CBSA.
166700*----------------------------------------------------------*
166800
166900
167000     IF HOLD-PROV-IPPS-CBSA = '29100'
167100        AND P-NEW-STATE = 52
167200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
167300            MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
167400
167500     IF HOLD-PROV-IPPS-CBSA = '30300'
167600        AND P-NEW-STATE = 50
167700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
167800            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
167900
168000     IF HOLD-PROV-IPPS-CBSA = '37620'
168100        AND P-NEW-STATE = 36
168200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
168300            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
168400
168500     IF HOLD-PROV-IPPS-CBSA = '37964'
168600        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
168700        AND P-NEW-STATE = 31
168800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
168900            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
169000
169100     IF HOLD-PROV-IPPS-CBSA = '38300'
169200        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
169300        AND P-NEW-STATE = 36
169400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
169500            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
169600
169700     IF HOLD-PROV-IPPS-CBSA = '39300'
169800        AND P-NEW-STATE = 22
169900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
170000            MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
170100
170200     IF HOLD-PROV-IPPS-CBSA = '39300'
170300        AND P-NEW-STATE = 41
170400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
170500            MOVE '   41' TO HOLD-PROV-IPPS-CBSA.
170600
170700     IF HOLD-PROV-IPPS-CBSA = '45500'
170800        AND P-NEW-STATE = 45
170900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
171000            MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
171100
171200     IF HOLD-PROV-IPPS-CBSA = '48260'
171300        AND P-NEW-STATE = 36
171400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
171500            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
171600
171700     IF HOLD-PROV-IPPS-CBSA = '48540'
171800        AND P-NEW-STATE = 36
171900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
172000            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
172100
172200     IF HOLD-PROV-IPPS-CBSA = '48540'
172300        AND P-NEW-STATE = 51
172400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
172500            MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
172600
172700     IF HOLD-PROV-IPPS-CBSA = '48864'
172800        AND P-NEW-STATE = 31
172900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
173000            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
173100
173200
173300 0580-FY2007-EXIT.
173400      EXIT.
173500
173600
173700******************************************************************
173800*                                                                *
173900* FLOOR ASSIGNMENTS FOR FY 2008:                                 *
174000*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
174100*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
174200*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
174300* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV080             *
174400*                                                                *
174500******************************************************************
174600 0580-FY2008-FLOOR-CBSA.
174700******************************************************************
174800
174900        IF HOLD-PROV-IPPS-CBSA = '   39'
175000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
175100           AND P-NEW-STATE = 33
175200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
175300               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
175400
175500        IF HOLD-PROV-IPPS-CBSA = '   39'
175600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
175700           AND P-NEW-STATE = 39
175800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
175900               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
176000
176100        IF HOLD-PROV-IPPS-CBSA = '10900'
176200           AND P-NEW-STATE = 31
176300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
176400               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
176500
176600        IF HOLD-PROV-IPPS-CBSA = '19060'
176700           AND P-NEW-STATE = 21
176800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
176900               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
177000
177100        IF HOLD-PROV-IPPS-CBSA = '21780'
177200           AND P-NEW-STATE = 15
177300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
177400               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
177500
177600        IF HOLD-PROV-IPPS-CBSA = '21780'
177700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
177800           AND P-NEW-STATE = 15
177900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
178000               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
178100
178200        IF HOLD-PROV-IPPS-CBSA = '22020'
178300           AND P-NEW-STATE = 24
178400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
178500               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
178600
178700        IF HOLD-PROV-IPPS-CBSA = '24220'
178800           AND P-NEW-STATE = 24
178900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
179000               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
179100
179200        IF HOLD-PROV-IPPS-CBSA = '24580'
179300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
179400           AND P-NEW-STATE = 52
179500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
179600               MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
179700
179800        IF HOLD-PROV-IPPS-CBSA = '25540'
179900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
180000           AND P-NEW-STATE = 07
180100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
180200               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
180300
180400        IF HOLD-PROV-IPPS-CBSA = '28420'
180500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
180600           AND P-NEW-STATE = 50
180700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
180800               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
180900
181000        IF HOLD-PROV-IPPS-CBSA = '28700'
181100           AND P-NEW-STATE = 44
181200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
181300               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
181400
181500        IF HOLD-PROV-IPPS-CBSA = '28700'
181600           AND P-NEW-STATE = 49
181700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
181800               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
181900
182000        IF HOLD-PROV-IPPS-CBSA = '30300'
182100           AND P-NEW-STATE = 50
182200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
182300               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
182400
182500        IF HOLD-PROV-IPPS-CBSA = '35084'
182600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
182700           AND P-NEW-STATE = 31
182800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
182900               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
183000
183100        IF HOLD-PROV-IPPS-CBSA = '37620'
183200           AND P-NEW-STATE = 36
183300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
183400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
183500
183600        IF HOLD-PROV-IPPS-CBSA = '37964'
183700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
183800           AND P-NEW-STATE = 31
183900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
184000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
184100
184200        IF HOLD-PROV-IPPS-CBSA = '38300'
184300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
184400           AND P-NEW-STATE = 36
184500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
184600               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
184700
184800        IF HOLD-PROV-IPPS-CBSA = '45500'
184900           AND P-NEW-STATE = 45
185000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
185100               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
185200
185300        IF HOLD-PROV-IPPS-CBSA = '48260'
185400           AND P-NEW-STATE = 36
185500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
185600               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
185700
185800        IF HOLD-PROV-IPPS-CBSA = '48540'
185900           AND P-NEW-STATE = 36
186000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
186100               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
186200
186300        IF HOLD-PROV-IPPS-CBSA = '48540'
186400           AND P-NEW-STATE = 51
186500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
186600               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
186700
186800        IF HOLD-PROV-IPPS-CBSA = '48864'
186900           AND P-NEW-STATE = 31
187000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
187100               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
187200
187300        IF HOLD-PROV-IPPS-CBSA = '48864'
187400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
187500           AND P-NEW-STATE = 31
187600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
187700               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
187800
187900
188000 0580-FY2008-EXIT.
188100      EXIT.
188200
188300
188400******************************************************************
188500*                                                                *
188600* FLOOR ASSIGNMENTS FOR FY 2009:                                 *
188700*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
188800*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
188900*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
189000* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV093             *
189100*                                                                *
189200******************************************************************
189300 0580-FY2009-FLOOR-CBSA.
189400******************************************************************
189500
189600        IF HOLD-PROV-IPPS-CBSA = '   04'
189700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
189800           AND P-NEW-STATE = 04
189900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
190000               MOVE '   04' TO HOLD-PROV-IPPS-CBSA.
190100
190200        IF HOLD-PROV-IPPS-CBSA = '   04'
190300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
190400           AND P-NEW-STATE = 19
190500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
190600               MOVE '   19' TO HOLD-PROV-IPPS-CBSA.
190700
190800        IF HOLD-PROV-IPPS-CBSA = '   14'
190900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
191000           AND P-NEW-STATE = 14
191100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
191200               MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
191300
191400        IF HOLD-PROV-IPPS-CBSA = '   14'
191500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
191600           AND P-NEW-STATE = 26
191700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
191800               MOVE '   26' TO HOLD-PROV-IPPS-CBSA.
191900
192000        IF HOLD-PROV-IPPS-CBSA = '10900'
192100           AND P-NEW-STATE = 31
192200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
192300               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
192400
192500        IF HOLD-PROV-IPPS-CBSA = '19340'
192600           AND P-NEW-STATE = 16
192700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
192800               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
192900
193000        IF HOLD-PROV-IPPS-CBSA = '21780'
193100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
193200           AND P-NEW-STATE = 15
193300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
193400               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
193500
193600        IF HOLD-PROV-IPPS-CBSA = '22020'
193700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
193800           AND P-NEW-STATE = 43
193900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
194000               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
194100
194200        IF HOLD-PROV-IPPS-CBSA = '22900'
194300           AND P-NEW-STATE = 37
194400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
194500               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
194600
194700        IF HOLD-PROV-IPPS-CBSA = '24580'
194800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
194900           AND P-NEW-STATE = 52
195000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
195100               MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
195200
195300        IF HOLD-PROV-IPPS-CBSA = '25540'
195400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
195500           AND P-NEW-STATE = 07
195600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
195700               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
195800
195900        IF HOLD-PROV-IPPS-CBSA = '28420'
196000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
196100           AND P-NEW-STATE = 50
196200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
196300               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
196400
196500        IF HOLD-PROV-IPPS-CBSA = '28700'
196600           AND P-NEW-STATE = 44
196700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
196800               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
196900
197000        IF HOLD-PROV-IPPS-CBSA = '28700'
197100           AND P-NEW-STATE = 49
197200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
197300               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
197400
197500        IF HOLD-PROV-IPPS-CBSA = '28700'
197600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
197700           AND P-NEW-STATE = 18
197800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
197900               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
198000
198100        IF HOLD-PROV-IPPS-CBSA = '28700'
198200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
198300           AND P-NEW-STATE = 44
198400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
198500               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
198600
198700        IF HOLD-PROV-IPPS-CBSA = '28940'
198800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
198900           AND P-NEW-STATE = 18
199000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
199100               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
199200
199300        IF HOLD-PROV-IPPS-CBSA = '28940'
199400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
199500           AND P-NEW-STATE = 44
199600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
199700               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
199800
199900        IF HOLD-PROV-IPPS-CBSA = '34820'
200000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
200100           AND P-NEW-STATE = 34
200200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
200300               MOVE '   34' TO HOLD-PROV-IPPS-CBSA.
200400
200500        IF HOLD-PROV-IPPS-CBSA = '34820'
200600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
200700           AND P-NEW-STATE = 42
200800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
200900               MOVE '   42' TO HOLD-PROV-IPPS-CBSA.
201000
201100        IF HOLD-PROV-IPPS-CBSA = '37620'
201200           AND P-NEW-STATE = 36
201300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
201400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
201500
201600        IF HOLD-PROV-IPPS-CBSA = '37964'
201700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
201800           AND P-NEW-STATE = 31
201900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
202000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
202100
202200        IF HOLD-PROV-IPPS-CBSA = '38340'
202300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
202400           AND P-NEW-STATE = 47
202500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
202600               MOVE '   47' TO HOLD-PROV-IPPS-CBSA.
202700
202800        IF HOLD-PROV-IPPS-CBSA = '41620'
202900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
203000           AND P-NEW-STATE = 29
203100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
203200               MOVE '   29' TO HOLD-PROV-IPPS-CBSA.
203300
203400        IF HOLD-PROV-IPPS-CBSA = '43580'
203500           AND P-NEW-STATE = 16
203600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
203700               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
203800
203900        IF HOLD-PROV-IPPS-CBSA = '48540'
204000           AND P-NEW-STATE = 36
204100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
204200               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
204300
204400        IF HOLD-PROV-IPPS-CBSA = '48540'
204500           AND P-NEW-STATE = 51
204600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
204700               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
204800
204900        IF HOLD-PROV-IPPS-CBSA = '48864'
205000           AND P-NEW-STATE = 31
205100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
205200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
205300
205400        IF HOLD-PROV-IPPS-CBSA = '48864'
205500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
205600           AND P-NEW-STATE = 31
205700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
205800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
205900
206000        IF HOLD-PROV-IPPS-CBSA = '19060'
206100           AND P-NEW-STATE = 21
206200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
206300               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
206400
206500        IF HOLD-PROV-IPPS-CBSA = '19060'
206600           AND P-NEW-STATE = 51
206700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
206800               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
206900
207000        IF HOLD-PROV-IPPS-CBSA = '22020'
207100           AND P-NEW-STATE = 24
207200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
207300               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
207400
207500        IF HOLD-PROV-IPPS-CBSA = '24220'
207600           AND P-NEW-STATE = 24
207700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
207800               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
207900
208000        IF HOLD-PROV-IPPS-CBSA = '30300'
208100           AND P-NEW-STATE = 50
208200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
208300               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
208400
208500        IF HOLD-PROV-IPPS-CBSA = '48260'
208600           AND P-NEW-STATE = 36
208700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
208800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
208900
209000
209100 0580-FY2009-EXIT.
209200      EXIT.
209300
209400
209500******************************************************************
209600*                                                                *
209700* FLOOR ASSIGNMENTS FOR FY 2010:                                 *
209800*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
209900*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
210000*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
210100* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV100             *
210200*                                                                *
210300******************************************************************
210400 0580-FY2010-FLOOR-CBSA.
210500******************************************************************
210600
210700        IF HOLD-PROV-IPPS-CBSA = '   33'
210800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
210900           AND P-NEW-STATE = 30
211000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
211100               MOVE '   30' TO HOLD-PROV-IPPS-CBSA.
211200
211300        IF HOLD-PROV-IPPS-CBSA = '   33'
211400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
211500           AND P-NEW-STATE = 33
211600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
211700               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
211800
211900        IF HOLD-PROV-IPPS-CBSA = '10900'
212000           AND P-NEW-STATE = 31
212100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
212200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
212300
212400        IF HOLD-PROV-IPPS-CBSA = '19340'
212500           AND P-NEW-STATE = 16
212600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
212700               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
212800
212900        IF HOLD-PROV-IPPS-CBSA = '19340'
213000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
213100           AND P-NEW-STATE = 16
213200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
213300               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
213400
213500        IF HOLD-PROV-IPPS-CBSA = '21780'
213600           AND P-NEW-STATE = 15
213700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
213800               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
213900
214000        IF HOLD-PROV-IPPS-CBSA = '21780'
214100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
214200           AND P-NEW-STATE = 15
214300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
214400               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
214500
214600        IF HOLD-PROV-IPPS-CBSA = '25180'
214700           AND P-NEW-STATE = 21
214800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
214900               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
215000
215100        IF HOLD-PROV-IPPS-CBSA = '25540'
215200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
215300           AND P-NEW-STATE = 07
215400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
215500               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
215600
215700        IF HOLD-PROV-IPPS-CBSA = '28420'
215800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
215900           AND P-NEW-STATE = 50
216000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
216100               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
216200
216300        IF HOLD-PROV-IPPS-CBSA = '28940'
216400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
216500           AND P-NEW-STATE = 18
216600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
216700               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
216800
216900        IF HOLD-PROV-IPPS-CBSA = '28940'
217000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
217100           AND P-NEW-STATE = 44
217200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
217300               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
217400
217500        IF HOLD-PROV-IPPS-CBSA = '35084'
217600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
217700           AND P-NEW-STATE = 31
217800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
217900               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
218000
218100        IF HOLD-PROV-IPPS-CBSA = '37620'
218200           AND P-NEW-STATE = 36
218300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
218400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
218500
218600        IF HOLD-PROV-IPPS-CBSA = '37964'
218700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
218800           AND P-NEW-STATE = 31
218900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
219000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
219100
219200        IF HOLD-PROV-IPPS-CBSA = '48540'
219300           AND P-NEW-STATE = 36
219400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
219500               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
219600
219700        IF HOLD-PROV-IPPS-CBSA = '48540'
219800           AND P-NEW-STATE = 51
219900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
220000               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
220100
220200        IF HOLD-PROV-IPPS-CBSA = '48864'
220300           AND P-NEW-STATE = 31
220400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
220500               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
220600
220700        IF HOLD-PROV-IPPS-CBSA = '48864'
220800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
220900           AND P-NEW-STATE = 31
221000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
221100               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
221200
221300        IF HOLD-PROV-IPPS-CBSA = '49660'
221400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
221500           AND P-NEW-STATE = 36
221600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
221700               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
221800
221900        IF HOLD-PROV-IPPS-CBSA = '19060'
222000           AND P-NEW-STATE = 21
222100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
222200               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
222300
222400        IF HOLD-PROV-IPPS-CBSA = '22020'
222500           AND P-NEW-STATE = 24
222600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
222700               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
222800
222900        IF HOLD-PROV-IPPS-CBSA = '24220'
223000           AND P-NEW-STATE = 24
223100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
223200               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
223300
223400        IF HOLD-PROV-IPPS-CBSA = '30300'
223500           AND P-NEW-STATE = 50
223600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
223700               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
223800
223900        IF HOLD-PROV-IPPS-CBSA = '35084'
224000           AND P-NEW-STATE = 31
224100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
224200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
224300
224400        IF HOLD-PROV-IPPS-CBSA = '48260'
224500           AND P-NEW-STATE = 36
224600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
224700               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
224800
224900        IF HOLD-PROV-IPPS-CBSA = '48260'
225000           AND P-NEW-STATE = 51
225100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
225200               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
225300
225400
225500 0580-FY2010-EXIT.
225600      EXIT.
225700
225800******************************************************************
225900*                                                                *
226000* FLOOR ASSIGNMENTS FOR FY 2011:                                 *
226100* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV110             *
226200*                                                                *
226300******************************************************************
226400
226500 0580-FY2011-FLOOR-CBSA.
226600
226700        IF HOLD-PROV-IPPS-CBSA = '   45'
226800          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
226900          AND P-NEW-STATE = 45
227000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
227100               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
227200
227300        IF HOLD-PROV-IPPS-CBSA = '   37'
227400          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
227500          AND P-NEW-STATE = 37
227600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
227700               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
227800
227900        IF HOLD-PROV-IPPS-CBSA = '10900'
228000           AND P-NEW-STATE = 31
228100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
228200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
228300
228400        IF HOLD-PROV-IPPS-CBSA = '21500'
228500          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
228600           AND P-NEW-STATE = 33
228700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
228800               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
228900
229000        IF HOLD-PROV-IPPS-CBSA = '21500'
229100          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
229200           AND P-NEW-STATE = 39
229300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
229400               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
229500
229600        IF HOLD-PROV-IPPS-CBSA = '21780'
229700           AND P-NEW-STATE = 15
229800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
229900               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
230000
230100        IF HOLD-PROV-IPPS-CBSA = '22900'
230200           AND P-NEW-STATE = 37
230300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
230400               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
230500
230600        IF HOLD-PROV-IPPS-CBSA = '24540'
230700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
230800           AND P-NEW-STATE = 53
230900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
231000               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.
231100
231200        IF HOLD-PROV-IPPS-CBSA = '25540'
231300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
231400           AND P-NEW-STATE = 07
231500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
231600               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
231700
231800        IF HOLD-PROV-IPPS-CBSA = '28700'
231900           AND P-NEW-STATE = 44
232000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
232100               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
232200
232300        IF HOLD-PROV-IPPS-CBSA = '28700'
232400           AND P-NEW-STATE = 49
232500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
232600               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
232700
232800        IF HOLD-PROV-IPPS-CBSA = '28940'
232900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
233000           AND P-NEW-STATE = 18
233100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
233200               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
233300
233400        IF HOLD-PROV-IPPS-CBSA = '28940'
233500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
233600           AND P-NEW-STATE = 44
233700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
233800               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
233900
234000        IF HOLD-PROV-IPPS-CBSA = '37620'
234100           AND P-NEW-STATE = 36
234200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
234300               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
234400
234500        IF HOLD-PROV-IPPS-CBSA = '37620'
234600           AND P-NEW-STATE = 51
234700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
234800               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
234900
235000        IF HOLD-PROV-IPPS-CBSA = '37964'
235100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
235200           AND P-NEW-STATE = 31
235300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
235400               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
235500
235600        IF HOLD-PROV-IPPS-CBSA = '38300'
235700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
235800           AND P-NEW-STATE = 36
235900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
236000               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
236100
236200        IF HOLD-PROV-IPPS-CBSA = '38300'
236300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
236400           AND P-NEW-STATE = 39
236500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
236600               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
236700
236800        IF HOLD-PROV-IPPS-CBSA = '43580'
236900           AND P-NEW-STATE = 43
237000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
237100               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
237200
237300        IF HOLD-PROV-IPPS-CBSA = '48540'
237400           AND P-NEW-STATE = 36
237500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
237600               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
237700
237800        IF HOLD-PROV-IPPS-CBSA = '48540'
237900           AND P-NEW-STATE = 51
238000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
238100               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
238200
238300        IF HOLD-PROV-IPPS-CBSA = '48864'
238400           AND P-NEW-STATE = 31
238500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
238600               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
238700
238800        IF HOLD-PROV-IPPS-CBSA = '17300'
238900           AND P-NEW-STATE = 18
239000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
239100               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
239200
239300        IF HOLD-PROV-IPPS-CBSA = '17300'
239400           AND P-NEW-STATE = 44
239500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
239600               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
239700
239800        IF HOLD-PROV-IPPS-CBSA = '19060'
239900           AND P-NEW-STATE = 21
240000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
240100               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
240200
240300        IF HOLD-PROV-IPPS-CBSA = '22020'
240400           AND P-NEW-STATE = 24
240500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
240600               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
240700
240800        IF HOLD-PROV-IPPS-CBSA = '22020'
240900           AND P-NEW-STATE = 35
241000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
241100               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
241200
241300        IF HOLD-PROV-IPPS-CBSA = '24220'
241400           AND P-NEW-STATE = 24
241500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
241600               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
241700
241800        IF HOLD-PROV-IPPS-CBSA = '24220'
241900           AND P-NEW-STATE = 35
242000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
242100               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
242200
242300        IF HOLD-PROV-IPPS-CBSA = '30300'
242400           AND P-NEW-STATE = 50
242500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
242600               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
242700
242800        IF HOLD-PROV-IPPS-CBSA = '44600'
242900           AND P-NEW-STATE = 36
243000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
243100               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
243200
243300        IF HOLD-PROV-IPPS-CBSA = '44600'
243400           AND P-NEW-STATE = 51
243500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
243600               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
243700
243800        IF HOLD-PROV-IPPS-CBSA = '45500'
243900           AND P-NEW-STATE = 45
244000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
244100               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
244200
244300
244400 0580-FY2011-EXIT.
244500      EXIT.
244600
244700******************************************************************
244800*                                                                *
244900* FLOOR ASSIGNMENTS FOR FY 2012:                                 *
245000* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV120             *
245100*                                                                *
245200* ******* CHANGE HOLD-PROV-CBSA TO HOLD-PROV-IPPS-CBSA ******    *
245300*                                                                *
245400******************************************************************
245500
245600 0580-FY2012-FLOOR-CBSA.
245700
245800**************YEARCHANGE 2012.0 ******************************
245900
246000        IF HOLD-PROV-IPPS-CBSA = '   30'
246100          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
246200          AND P-NEW-STATE = 30
246300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
246400               MOVE '   30' TO HOLD-PROV-IPPS-CBSA.
246500
246600        IF HOLD-PROV-IPPS-CBSA = '   39'
246700          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
246800          AND P-NEW-STATE = 39
246900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
247000               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
247100
247200        IF HOLD-PROV-IPPS-CBSA = '   39'
247300          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
247400          AND P-NEW-STATE = 33
247500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
247600               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
247700
247800        IF HOLD-PROV-IPPS-CBSA = '10900'
247900           AND P-NEW-STATE = 31
248000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
248100               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
248200
248300        IF HOLD-PROV-IPPS-CBSA = '14484'
248400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
248500           AND P-NEW-STATE = 22
248600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
248700               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
248800
248900        IF HOLD-PROV-IPPS-CBSA = '16020'
249000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
249100           AND P-NEW-STATE = 14
249200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
249300               MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
249400
249500        IF HOLD-PROV-IPPS-CBSA = '21500'
249600          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
249700           AND P-NEW-STATE = 33
249800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
249900               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
250000
250100        IF HOLD-PROV-IPPS-CBSA = '21500'
250200          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
250300           AND P-NEW-STATE = 39
250400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
250500               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
250600
250700        IF HOLD-PROV-IPPS-CBSA = '22900'
250800           AND P-NEW-STATE = 37
250900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
251000               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
251100
251200        IF HOLD-PROV-IPPS-CBSA = '25180'
251300           AND P-NEW-STATE = 21
251400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
251500               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
251600
251700        IF HOLD-PROV-IPPS-CBSA = '25540'
251800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
251900           AND P-NEW-STATE = 07
252000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
252100               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
252200
252300        IF HOLD-PROV-IPPS-CBSA = '25540'
252400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
252500           AND P-NEW-STATE = 22
252600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
252700               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
252800
252900        IF HOLD-PROV-IPPS-CBSA = '26820'
253000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
253100           AND P-NEW-STATE = 53
253200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
253300               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.
253400
253500        IF HOLD-PROV-IPPS-CBSA = '28700'
253600           AND P-NEW-STATE = 44
253700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
253800               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
253900
254000        IF HOLD-PROV-IPPS-CBSA = '28700'
254100           AND P-NEW-STATE = 49
254200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
254300               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
254400
254500        IF HOLD-PROV-IPPS-CBSA = '28700'
254600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
254700           AND P-NEW-STATE = 18
254800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
254900               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
255000
255100        IF HOLD-PROV-IPPS-CBSA = '28700'
255200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
255300           AND P-NEW-STATE = 44
255400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
255500               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
255600
255700        IF HOLD-PROV-IPPS-CBSA = '28940'
255800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
255900           AND P-NEW-STATE = 18
256000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
256100               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
256200
256300        IF HOLD-PROV-IPPS-CBSA = '35084'
256400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
256500           AND P-NEW-STATE = 31
256600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
256700               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
256800
256900        IF HOLD-PROV-IPPS-CBSA = '37620'
257000           AND P-NEW-STATE = 36
257100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
257200               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
257300
257400        IF HOLD-PROV-IPPS-CBSA = '37964'
257500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
257600           AND P-NEW-STATE = 31
257700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
257800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
257900
258000        IF HOLD-PROV-IPPS-CBSA = '43580'
258100           AND P-NEW-STATE = 43
258200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
258300               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
258400
258500        IF HOLD-PROV-IPPS-CBSA = '44600'
258600           AND P-NEW-STATE = 36
258700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
258800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
258900
259000        IF HOLD-PROV-IPPS-CBSA = '44600'
259100           AND P-NEW-STATE = 51
259200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
259300               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
259400
259500        IF HOLD-PROV-IPPS-CBSA = '48540'
259600           AND P-NEW-STATE = 36
259700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
259800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
259900
260000        IF HOLD-PROV-IPPS-CBSA = '48540'
260100           AND P-NEW-STATE = 51
260200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
260300               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
260400
260500        IF HOLD-PROV-IPPS-CBSA = '48864'
260600           AND P-NEW-STATE = 31
260700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
260800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
260900
261000        IF HOLD-PROV-IPPS-CBSA = '49660'
261100           AND P-NEW-STATE = 36
261200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
261300               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
261400
261500        IF HOLD-PROV-IPPS-CBSA = '49660'
261600           AND P-NEW-STATE = 39
261700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
261800               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
261900
262000        IF HOLD-PROV-IPPS-CBSA = '19060'
262100           AND P-NEW-STATE = 21
262200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
262300               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
262400
262500        IF HOLD-PROV-IPPS-CBSA = '22020'
262600           AND P-NEW-STATE = 24
262700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
262800               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
262900
263000        IF HOLD-PROV-IPPS-CBSA = '22020'
263100           AND P-NEW-STATE = 35
263200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
263300               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
263400
263500        IF HOLD-PROV-IPPS-CBSA = '24220'
263600           AND P-NEW-STATE = 24
263700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
263800               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
263900
264000        IF HOLD-PROV-IPPS-CBSA = '24220'
264100           AND P-NEW-STATE = 35
264200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
264300               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
264400
264500        IF HOLD-PROV-IPPS-CBSA = '30300'
264600           AND P-NEW-STATE = 50
264700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
264800               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
264900
265000        IF HOLD-PROV-IPPS-CBSA = '30860'
265100           AND P-NEW-STATE = 46
265200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
265300               MOVE '   46' TO HOLD-PROV-IPPS-CBSA.
265400
265500        IF HOLD-PROV-IPPS-CBSA = '35084'
265600           AND P-NEW-STATE = 31
265700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
265800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
265900
266000        IF HOLD-PROV-IPPS-CBSA = '39300'
266100           AND P-NEW-STATE = 22
266200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
266300               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
266400
266500        IF HOLD-PROV-IPPS-CBSA = '45500'
266600           AND P-NEW-STATE = 45
266700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
266800               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
266900
267000**************YEARCHANGE 2012.0 ******************************
267100
267200 0580-FY2012-EXIT.
267300      EXIT.
267400
267500 0580-FY2013-FLOOR-CBSA.
267600
267700**************YEARCHANGE 2013.0 ****************************
267800
267900        IF HOLD-PROV-IPPS-CBSA = '10900'
268000           AND P-NEW-STATE = 31
268100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
268200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
268300
268400        IF HOLD-PROV-IPPS-CBSA = '14484'
268500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
268600           AND P-NEW-STATE = 22
268700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
268800               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
268900
269000        IF HOLD-PROV-IPPS-CBSA = '16020'
269100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
269200           AND P-NEW-STATE = 14
269300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
269400               MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
269500
269600        IF HOLD-PROV-IPPS-CBSA = '21500'
269700          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
269800           AND P-NEW-STATE = 33
269900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
270000               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
270100
270200        IF HOLD-PROV-IPPS-CBSA = '21500'
270300          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
270400           AND P-NEW-STATE = 39
270500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
270600               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
270700
270800        IF HOLD-PROV-IPPS-CBSA = '21780'
270900          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
271000           AND P-NEW-STATE = 15
271100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
271200               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
271300
271400        IF HOLD-PROV-IPPS-CBSA = '24580'
271500          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
271600           AND P-NEW-STATE = 52
271700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
271800               MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
271900
272000        IF HOLD-PROV-IPPS-CBSA = '25540'
272100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
272200           AND P-NEW-STATE = 07
272300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
272400               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
272500
272600        IF HOLD-PROV-IPPS-CBSA = '25540'
272700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
272800           AND P-NEW-STATE = 22
272900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
273000               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
273100
273200        IF HOLD-PROV-IPPS-CBSA = '26820'
273300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
273400           AND P-NEW-STATE = 53
273500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
273600               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.
273700
273800        IF HOLD-PROV-IPPS-CBSA = '27900'
273900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
274000           AND P-NEW-STATE = 17
274100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
274200               MOVE '   17' TO HOLD-PROV-IPPS-CBSA.
274300
274400        IF HOLD-PROV-IPPS-CBSA = '28700'
274500           AND P-NEW-STATE = 44
274600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
274700               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
274800
274900        IF HOLD-PROV-IPPS-CBSA = '28700'
275000           AND P-NEW-STATE = 49
275100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
275200               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
275300
275400        IF HOLD-PROV-IPPS-CBSA = '28700'
275500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
275600           AND P-NEW-STATE = 18
275700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
275800               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
275900
276000        IF HOLD-PROV-IPPS-CBSA = '28700'
276100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
276200           AND P-NEW-STATE = 44
276300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
276400               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
276500
276600        IF HOLD-PROV-IPPS-CBSA = '28940'
276700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
276800           AND P-NEW-STATE = 18
276900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
277000               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
277100
277200        IF HOLD-PROV-IPPS-CBSA = '35084'
277300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
277400           AND P-NEW-STATE = 31
277500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
277600               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
277700
277800        IF HOLD-PROV-IPPS-CBSA = '37620'
277900           AND P-NEW-STATE = 36
278000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
278100               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
278200
278300        IF HOLD-PROV-IPPS-CBSA = '37964'
278400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
278500           AND P-NEW-STATE = 31
278600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
278700               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
278800
278900        IF HOLD-PROV-IPPS-CBSA = '38300'
279000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
279100           AND P-NEW-STATE = 36
279200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
279300               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
279400
279500        IF HOLD-PROV-IPPS-CBSA = '43580'
279600           AND P-NEW-STATE = 43
279700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
279800               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
279900
280000        IF HOLD-PROV-IPPS-CBSA = '48540'
280100           AND P-NEW-STATE = 36
280200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
280300               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
280400
280500        IF HOLD-PROV-IPPS-CBSA = '48540'
280600           AND P-NEW-STATE = 51
280700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
280800               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
280900
281000        IF HOLD-PROV-IPPS-CBSA = '48864'
281100           AND P-NEW-STATE = 31
281200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
281300               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
281400
281500        IF HOLD-PROV-IPPS-CBSA = '49660'
281600           AND P-NEW-STATE = 36
281700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
281800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
281900
282000        IF HOLD-PROV-IPPS-CBSA = '49660'
282100           AND P-NEW-STATE = 39
282200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
282300               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
282400
282500        IF HOLD-PROV-IPPS-CBSA = '22020'
282600           AND P-NEW-STATE = 24
282700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
282800               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
282900
283000        IF HOLD-PROV-IPPS-CBSA = '22020'
283100           AND P-NEW-STATE = 35
283200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
283300               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
283400
283500        IF HOLD-PROV-IPPS-CBSA = '24220'
283600           AND P-NEW-STATE = 24
283700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
283800               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
283900
284000        IF HOLD-PROV-IPPS-CBSA = '24220'
284100           AND P-NEW-STATE = 35
284200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
284300               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
284400
284500        IF HOLD-PROV-IPPS-CBSA = '30300'
284600           AND P-NEW-STATE = 50
284700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
284800               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
284900
285000        IF HOLD-PROV-IPPS-CBSA = '39300'
285100           AND P-NEW-STATE = 22
285200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
285300               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
285400
285500        IF HOLD-PROV-IPPS-CBSA = '39300'
285600           AND P-NEW-STATE = 41
285700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
285800               MOVE '   41' TO HOLD-PROV-IPPS-CBSA.
285900
286000        IF HOLD-PROV-IPPS-CBSA = '44600'
286100           AND P-NEW-STATE = 36
286200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
286300               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
286400
286500 0580-FY2013-EXIT.
286600      EXIT.
286700
286800 0580-FY2014-FLOOR-CBSA.
286900
287000**************YEARCHANGE 2014.0 ******************************
287100
287200        IF HOLD-PROV-IPPS-CBSA = '   07'
287300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
287400           AND P-NEW-STATE = 07
287500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
287600               MOVE '   07' TO HOLD-PROV-CBSA.
287700
287800        IF HOLD-PROV-IPPS-CBSA = '   36'
287900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
288000           AND P-NEW-STATE = 36
288100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
288200               MOVE '   36' TO HOLD-PROV-CBSA.
288300
288400        IF HOLD-PROV-IPPS-CBSA = '10900'
288500           AND P-NEW-STATE = 31
288600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
288700               MOVE '   31' TO HOLD-PROV-CBSA.
288800
288900        IF HOLD-PROV-IPPS-CBSA = '14484'
289000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
289100           AND P-NEW-STATE = 22
289200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
289300               MOVE '   22' TO HOLD-PROV-CBSA.
289400
289500        IF HOLD-PROV-IPPS-CBSA = '17300'
289600           AND P-NEW-STATE = 18
289700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
289800               MOVE '   18' TO HOLD-PROV-CBSA.
289900
290000        IF HOLD-PROV-IPPS-CBSA = '22900'
290100           AND P-NEW-STATE = 37
290200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
290300               MOVE '   37' TO HOLD-PROV-CBSA.
290400
290500        IF HOLD-PROV-IPPS-CBSA = '25540'
290600          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
290700           AND P-NEW-STATE = 07
290800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
290900               MOVE '   07' TO HOLD-PROV-CBSA.
291000
291100        IF HOLD-PROV-IPPS-CBSA = '25540'
291200          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
291300           AND P-NEW-STATE = 22
291400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
291500               MOVE '   22' TO HOLD-PROV-CBSA.
291600
291700        IF HOLD-PROV-IPPS-CBSA = '26820'
291800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
291900           AND P-NEW-STATE = 53
292000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
292100               MOVE '   53' TO HOLD-PROV-CBSA.
292200
292300        IF HOLD-PROV-IPPS-CBSA = '27180'
292400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
292500           AND P-NEW-STATE = 25
292600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
292700               MOVE '   25' TO HOLD-PROV-CBSA.
292800
292900        IF HOLD-PROV-IPPS-CBSA = '28700'
293000           AND P-NEW-STATE = 44
293100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
293200               MOVE '   44' TO HOLD-PROV-CBSA.
293300
293400        IF HOLD-PROV-IPPS-CBSA = '28700'
293500           AND P-NEW-STATE = 49
293600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
293700               MOVE '   49' TO HOLD-PROV-CBSA.
293800
293900        IF HOLD-PROV-IPPS-CBSA = '35644'
294000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
294100           AND P-NEW-STATE = 07
294200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
294300               MOVE '   07' TO HOLD-PROV-CBSA.
294400
294500        IF HOLD-PROV-IPPS-CBSA = '37620'
294600           AND P-NEW-STATE = 36
294700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
294800               MOVE '   36' TO HOLD-PROV-CBSA.
294900
295000        IF HOLD-PROV-IPPS-CBSA = '43580'
295100           AND P-NEW-STATE = 43
295200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
295300               MOVE '   43' TO HOLD-PROV-CBSA.
295400
295500        IF HOLD-PROV-IPPS-CBSA = '48540'
295600           AND P-NEW-STATE = 36
295700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
295800               MOVE '   36' TO HOLD-PROV-CBSA.
295900
296000        IF HOLD-PROV-IPPS-CBSA = '48540'
296100           AND P-NEW-STATE = 51
296200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
296300               MOVE '   51' TO HOLD-PROV-CBSA.
296400
296500        IF HOLD-PROV-IPPS-CBSA = '48864'
296600           AND P-NEW-STATE = 31
296700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
296800               MOVE '   31' TO HOLD-PROV-CBSA.
296900
297000        IF HOLD-PROV-IPPS-CBSA = '49660'
297100           AND P-NEW-STATE = 36
297200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
297300               MOVE '   36' TO HOLD-PROV-CBSA.
297400
297500        IF HOLD-PROV-IPPS-CBSA = '49660'
297600           AND P-NEW-STATE = 39
297700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
297800               MOVE '   39' TO HOLD-PROV-CBSA.
297900
298000        IF HOLD-PROV-IPPS-CBSA = '19060'
298100           AND P-NEW-STATE = 21
298200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
298300               MOVE '   21' TO HOLD-PROV-CBSA.
298400
298500        IF HOLD-PROV-IPPS-CBSA = '22020'
298600           AND P-NEW-STATE = 24
298700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
298800               MOVE '   24' TO HOLD-PROV-CBSA.
298900
299000        IF HOLD-PROV-IPPS-CBSA = '22020'
299100           AND P-NEW-STATE = 35
299200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
299300               MOVE '   35' TO HOLD-PROV-CBSA.
299400
299500        IF HOLD-PROV-IPPS-CBSA = '24220'
299600           AND P-NEW-STATE = 24
299700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
299800               MOVE '   24' TO HOLD-PROV-CBSA.
299900
300000        IF HOLD-PROV-IPPS-CBSA = '24220'
300100           AND P-NEW-STATE = 35
300200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
300300               MOVE '   35' TO HOLD-PROV-CBSA.
300400
300500        IF HOLD-PROV-IPPS-CBSA = '30300'
300600           AND P-NEW-STATE = 50
300700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
300800               MOVE '   50' TO HOLD-PROV-CBSA.
300900
301000        IF HOLD-PROV-IPPS-CBSA = '39300'
301100           AND P-NEW-STATE = 22
301200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
301300               MOVE '   22' TO HOLD-PROV-CBSA.
301400
301500        IF HOLD-PROV-IPPS-CBSA = '39300'
301600           AND P-NEW-STATE = 41
301700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
301800               MOVE '   41' TO HOLD-PROV-CBSA.
301900
302000        IF HOLD-PROV-IPPS-CBSA = '44600'
302100           AND P-NEW-STATE = 36
302200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
302300               MOVE '   36' TO HOLD-PROV-CBSA.
302400
302500        IF HOLD-PROV-IPPS-CBSA = '45500'
302600           AND P-NEW-STATE = 45
302700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
302800               MOVE '   45' TO HOLD-PROV-CBSA.
302900
303000 0580-FY2014-EXIT.
303100      EXIT.
303200
303300******************************************************************
303400 0585-GET-IPPS-CBSA-SIZE.
303500******************************************************************
303600
303700     IF B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2)
303800        IF P-NEW-RURAL-CBSA
303900           MOVE 'R' TO W-CBSA-IPPS-SIZE
304000        ELSE
304100          IF T-CBSA-SIZE (MA2) = 'L'
304200             MOVE 'L' TO W-CBSA-IPPS-SIZE
304300          ELSE
304400             MOVE 'O' TO W-CBSA-IPPS-SIZE
304500          END-IF
304600        END-IF
304700     END-IF.
304800
304900 0585-EXIT.
305000      EXIT.
305100
305200
305300******************************************************************
305400 0590-GET-IPPS-CBSA-PR.
305500******************************************************************
305600
305700*--------------------------------------*
305800* SET PUERTO RICO CBSA INDICATOR       *
305900*--------------------------------------*
306000     MOVE '*' TO H-IPPS-CBSA-LAST-POS.
306100
306200*------------------------------------------------------------*
306300* SEARCH TABLE FOR PR CBSA & GET PR SPECIFIC WAGE INDEX      *
306400*------------------------------------------------------------*
306500     SET MA1 TO 1.
306600     SEARCH T-CBSA-DATA VARYING MA1
306700        AT END
306800           MOVE 60 TO PPS-RTC
306900        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA
307000           SET MA2 TO MA1
307100               PERFORM 0680-N-GET-IPPS-PR-WAGE-INDX
307200                  THRU 0680-N-EXIT VARYING MA2
307300                  FROM MA1 BY 1 UNTIL
307400                       T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA.
307500
307600 0590-EXIT.
307700      EXIT.
307800
307900
308000******************************************************************
308100 0600-N-GET-WAGE-INDX.
308200******************************************************************
308300
308400     IF  B-DISCHARGE-DATE NOT < MSAX-EFF-DATE (MU2)
308500         MOVE MSAX-MSA (MU2)         TO W-NEW-MSA
308600         MOVE MSAX-EFF-DATE (MU2)    TO W-NEW-EFF-DATE-M
308700         MOVE MSAX-WAGE-INDEX1 (MU2) TO W-NEW-INDEX1-RECORD-M
308800         MOVE MSAX-WAGE-INDEX2 (MU2) TO W-NEW-INDEX2-RECORD-M
308900         MOVE MSAX-WAGE-INDEX3 (MU2) TO W-NEW-INDEX3-RECORD-M
309000     END-IF.
309100
309200 0600-N-EXIT.
309300     EXIT.
309400
309500
309600******************************************************************
309700 0650-N-GET-WAGE-INDX.
309800******************************************************************
309900
310000     IF  B-DISCHARGE-DATE NOT < CBSAX-EFF-DATE (CU2)
310100         MOVE CBSAX-CBSA (CU2)        TO W-NEW-CBSA
310200         MOVE CBSAX-EFF-DATE (CU2)    TO W-NEW-EFF-DATE-C
310300         MOVE CBSAX-WAGE-INDEX1 (CU2) TO W-NEW-INDEX1-RECORD-C
310400         MOVE CBSAX-WAGE-INDEX2 (CU2) TO W-NEW-INDEX2-RECORD-C
310500         MOVE CBSAX-WAGE-INDEX3 (CU2) TO W-NEW-INDEX3-RECORD-C
310600     END-IF.
310700
310800 0650-N-EXIT.
310900     EXIT.
311000
311100
311200******************************************************************
311300 0675-N-GET-IPPS-WAGE-INDX.
311400******************************************************************
311500
311600     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2)
311700         MOVE T-CBSA (MA2)            TO W-CBSA-IPPS
311800         MOVE T-CBSA-EFF-DATE (MA2)   TO W-CBSA-IPPS-EFF-DATE
311900         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-WAGE-INDEX
312000     END-IF.
312100
312200 0675-N-EXIT.
312300     EXIT.
312400
312500
312600******************************************************************
312700 0680-N-GET-IPPS-PR-WAGE-INDX.
312800******************************************************************
312900
313000     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2)
313100         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-PR-WAGE-INDEX
313200     END-IF.
313300
313400 0680-N-EXIT.
313500     EXIT.
313600
313700******************************************************************
313800********************   END OF PROGRAM   **************************
313900******************************************************************
