000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. LTDRV170.
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*--------------------------------------------------------------*
051900*                                                              *
052000*   09/03/2013 - CREATE VERION 141 TO INCORPORATE THE NEW LTCH *
052100*                AND PPS WAGE INDEX TABLES                     *
052200*                                                              *
052300*--------------------------------------------------------------*
052400*                                                              *
052500*   08/06/2014 - CREATE VERSION 15.0 OF THE LTCH PPS PRICER    *
052600*                EFFECTIVE 10/01/2014 (FY 2015)                *
052700*                REPLACES VERSION 14.1                         *
052800*                UPDATED W/ THE FOLLOWING REVISED FY2015 ITEMS:*
052900*                1) LTCH WAGE INDEX TABLE (LTWIX150)           *
053000*                2) LTCH DRG TABLE (LTDRG150)                  *
053100*                3) IPPS CBSA WAGE INDEX TABLE (IPWIX150)      *
053200*                4) IPPS DRG TABLE (IPDRG150)                  *
053300*                5) LTCH STANDARD RATES IN PROGRAM LTCAL150    *
053400*                6) IPPS STANDARD RATES IN PROGRAM LTCAL150    *
053500*                7) IPPS BLENDED WAGE INDEX TABLE              *
053600*                   (BLEND150) - NEW FOR FY 2015               *
053700*                8) NEW LOGIC IN LTCAL150 TO USE THE IPPS CBSA *
053800*                   BLENDED WAGE INDEX IN TABLE BLEND150       *
053900*                   FOR ALL PROVIDERS IN THAT TABLE            *
054000*                9) NEW LOGIC TO ASSIGN IPPS CBSA WAGE INDEX   *
054100*                   FLOORS IN LTDRV150                         *
054200*               10) CORRECTED DATE RANGES FOR FYS 2011 - 2014  *
054300*                   RURAL FLOOR ASSIGNMENT LOGIC IN LTDRV150   *
054400*               11) CORRECTED FY 2014 RURAL FLOOR LOGIC TO     *
054500*                   CHANGE THE IPPS CBSA INSTEAD OF THE LTCH   *
054600*                   CBSA IN LTDRV150                           *
054700*               12) INCREASE SIZE OF LTCH CBSA TABLE FROM      *
054800*                   4,000 TO 7,000                             *
054900*                                                              *
055000*--------------------------------------------------------------*
055100*                                                              *
055200*   08/28/2014 - CREATE VERSION 15.1 OF THE LTCH PPS PRICER    *
055300*                EFFECTIVE 10/01/2014 (FY 2015)                *
055400*                REPLACES VERSION 15.0                         *
055500*              - ADDED CONDITIONS TO THE CBSA WAGE INDEX       *
055600*                SEARCH TO ONLY SELECT THE WAGE INDEX IF ITS   *
055700*                EFFECTIVE DATE IS WITHIN THE SAME FY AS THE   *
055800*                THE CLAIM'S DISCHARGE DATE. CODE WAS CHANGED  *
055900*                IN THE FOLLOWING THREE PLACES:                *
056000*                - NATIONAL LTCH WAGE INDEX SEARCH,            *
056100*                - NATIONAL IPPS WAGE INDEX SEARCH, AND        *
056200*                - PUERTO RICO IPPS WAGE INDEX SEARCH.         *
056300*              - MOVED LOGIC THAT ASSIGNS THE SPECIAL WAGE     *
056400*                INDEX WHEN APPLICABLE FROM LTCAL151 TO        *
056500*                LTDRV151 (0550-GET-CBSA).                     *
056600*              - MODIFIED SPECIAL WAGE INDEX ASSIGNMENT LOGIC  *
056700*                TO ONLY SELECT THE WAGE INDEX IF THE PSF      *
056800*                RECORD'S EFFECTIVE DATE FALLS WITHIN THE      *
056900*                CLAIM'S FISCAL YEAR (0550-GET-CBSA).          *
057000*              - ADDED LOGIC TO INITIALIZE LTCH AND IPPS WAGE  *
057100*                INDEX TABLES AND HOLD CBSA FIELDS             *
057200*              - ADDED LOGIC TO SET RTC TO 52 IF THE THIRD     *
057300*                COLUMN OF THE LTCH CBSA WAGE INDEX IS ZERO    *
057400*                                   *
057500*--------------------------------------------------------------*
057600*                                                              *
057700* 11/20/14 - VERSION 15.2 CREATED TO ADDRESS A PROBLEM         *
057800*   REPORTED BY FISS WHERE A CLAIM DATED 12/31/2007 RECEIVES   *
057900*   UNEXPECTED WAGE INDEX ERROR (RTC 52).                      *
058000*                                                              *
058100* ADDED CONDITION TO PROCEDURE 0650-N-GET-WAGE-INDX SO THAT TO *
058200* SELECT THE WAGE INDEX, IT MUST BE A CBSA WITH AN EFFECTIVE   *
058300* DATE ON OR BEFORE THE CLAIM DISCHARGE DATE AND A CLAIM       *
058400* DISCHARGE DATE ON OR BEFORE 09/30/2009                       *
058500*                                                              *
058600* THE CODE ADDED IS AS FOLLOWS:                                *
058700*   (B-DISCHARGE-DATE <= 20090930) OR                          *
058800*                                                              *
058900*--------------------------------------------------------------*
059000*                                                              *
059100* 03/16/15 - VERSION 15.3 CREATED TO ADD NEW DATA NAMES.       *
059200* THE FIRST STAGE OF BUILDING THE FY 2016 LTCH PRICER.         *
059300* WAS BUILT TO TEST THE CHANGES IN THE DATA LAYOUT, AND        *
059400* ONLY MADE CHANGES TO THE DRIVER MODULE (LTDRV153)            *
059500*                                                              *
059600*--------------------------------------------------------------*
059700* 06/11/15 - VERSION 16.B CREATED TO ADD NEW LOGIC.            *
059800* THE SECOND STAGE OF BUILDING THE FY 2016 LTCH PRICER.        *
059900* DONE IN ORDER TO GIVE THE PROGRAMMERS MORE TIME              *
060000* TO BE ABLE TO CREATE THE LOGIC AND TEST IT WITHOUT HAVING TO *
060100* FIRST GET THE FY 2016 RATES.                                 *
060200*                                                              *
060300*--------------------------------------------------------------*
060400*                                                              *
060500*   08/04/2015 - CREATE VERSION 16.0 OF THE LTCH PPS PRICER    *
060600*                EFFECTIVE 10/01/2015 (FY 2016)                *
060700*                REPLACES VERSION 15.3                         *
060800*              - ADDED NEW STATE CODES FOR RURAL FLOOR WAGE    *
060900*                INDEX LOGIC (TO BE USED STARTING APRIL 2016)  *
061000*              - CORRECTED CRITERIA TO SEARCH FOR CBSA SIZE    *
061100*              - ROUTINE FISCAL YEAR UPDATES TO VERSION AND    *
061200*                NEW CALL TO LTCAL160                          *
061300*                                                              *
061400*--------------------------------------------------------------*
061500*                                                              *
061600*   11/25/2015 - CREATE VERSION 16.C OF THE LTCH PPS PRICER    *
061700*                EFFECTIVE 04/01/2016 (FY 2016)                *
061800*                ** BETA VERSION FOR APRIL 2016 TESTING **     *
061900*              - ADDED NEW STATE CODES FOR RURAL FLOOR WAGE    *
062000*                INDEX LOGIC (TO BE USED STARTING APRIL 2016)  *
062100*                (ADDITIONAL CODES 95, 96, & 97)               *
062200*              - CREATED LTCAL15C TO PROCESS CLAIMS DISCHARGED *
062300*                01/01/2015 - 09/30/2015.                      *
062400*              - CREATED LTCAL16C TO PROCESS CLAIMS DISCHARGED *
062500*                10/01/2015 - 09/30/2016.                      *
062600*              - ADDED NEW COST REPORT DAYS VARIABLE TO INPUT  *
062700*                RECORD TO PRICE SUBCLAUSE (II) LTCH PAYMENTS  *
062800*                (LTDRV16C, LTCAL15C, LTCAL16C)                *
062900*              - NEW CALLS TO LTCAL15C & LTCAL16C              *
063000*              - ALTERED CALL TO LTCAL152 TO PROCESS CLAIMS    *
063100*                DISCHARGED 10/01/2014 - 12/31/2014.           *
063200*                                                              *
063300*--------------------------------------------------------------*
063400*                                                              *
063500*   12/11/2015 - VERSION 16.1 EFFECTIVE APRIL 1, 2016          *
063600*                DUE TO CR 9401                                *
063700*                                                              *
063800*--------------------------------------------------------------*
063900*                                                              *
064000*   01/28/2016 - VERSION 16.2 EFFECTIVE APRIL 1, 2016          *
064100*              - CHANGE TO CALL LTCAL162                       *
064200*              - LTCAL162 UPDATED DUE TO CR 9300 AND CR 9527   *
064300*                                                              *
064400*--------------------------------------------------------------*
064500*                                                              *
064600* JUNE 20, 2016 - FOR VERSION 17.B CHANGED THE FOLLOWING:      *
064700*                                                              *
064800*   1.THE LAYOUT OF THE PROVIDER RECORD TO INCLUDE A           *
064900*        STATE CODE.                                           *
065000*      - REPLACE 05 FILLER PIC X(05). ON LINE 76 OF            *
065100*        PROV-NEW-HOLD WITH THE FOLLOWING:                     *
065200*             05  P-NEW-STATE-CODE           PIC 9(02).        *
065300*             05  P-NEW-STATE-CODE-X REDEFINES                 *
065400*                   P-NEW-STATE-CODE         PIC X(02).        *
065500*             05  FILLER                     PIC X(03).        *
065600*   2.THE LOGIC OF THE DRIVER MODULE TO MOVE THE NEW           *
065700*     STATE CODE INTO THE SEARCH VARIABLE AND TO               *
065800*     COMMENT-OUT THE LINES OF CODE THAT DO THE                *
065900*     FLOOR ASSIGNMENTS.                                       *
066000*   3.ADDED COBOL CODE TO ALLOW THE LTCH PRICER TO WORK WITH   *
066100*     THE NEW ARIZONA STATE CODE OF '00'                       *
066200*                                                              *
066300* 8-9-16 - VERSION 17.0                                        *
066400*  - MADE ANNUAL UPDATE                                        *
066500*  - ADDED CALL TO LTCAL170                                    *
066600*  - CHANGED TO NO LONGER GET THE PUERTO RICO SPECIFIC WAGE    *
066700*    INDEX FOR PR HOSPITALS BEGINNING FY 2016                  *
066800*                                                              *
066900****************************************************************
067000
067100
067200 ENVIRONMENT DIVISION.
067300 CONFIGURATION SECTION.
067400 SOURCE-COMPUTER.            IBM-370.
067500 OBJECT-COMPUTER.            IBM-370.
067600 INPUT-OUTPUT  SECTION.
067700 FILE-CONTROL.
067800
067900 DATA DIVISION.
068000 FILE SECTION.
068100
068200
068300 WORKING-STORAGE SECTION.
068400 77  W-STORAGE-REF                  PIC X(48) VALUE
068500     'L T D R V _ _ _ - W O R K I N G   S T O R A G E'.
068600 01  DRV-VERSION                    PIC X(05) VALUE 'D17.0'.
068700
068800*-------------------------------------------------------------*
068900* LTCAL MODULES OLDER THAN 5 YEARS                            *
069000*-------------------------------------------------------------*
069100 01  LTCAL032                       PIC X(08) VALUE 'LTCAL032'.
069200 01  LTCAL042                       PIC X(08) VALUE 'LTCAL042'.
069300 01  LTCAL043                       PIC X(08) VALUE 'LTCAL043'.
069400 01  LTCAL058                       PIC X(08) VALUE 'LTCAL058'.
069500 01  LTCAL059                       PIC X(08) VALUE 'LTCAL059'.
069600 01  LTCAL063                       PIC X(08) VALUE 'LTCAL063'.
069700 01  LTCAL064                       PIC X(08) VALUE 'LTCAL064'.
069800 01  LTCAL072                       PIC X(08) VALUE 'LTCAL072'.
069900 01  LTCAL075                       PIC X(08) VALUE 'LTCAL075'.
070000
070100*-------------------------------------------------------------*
070200* LTCAL MODULES CURRENTLY CALLED                              *
070300*-------------------------------------------------------------*
070400 01  LTCAL080                       PIC X(08) VALUE 'LTCAL080'.
070500 01  LTCAL087                       PIC X(08) VALUE 'LTCAL087'.
070600 01  LTCAL091                       PIC X(08) VALUE 'LTCAL091'.
070700 01  LTCAL094                       PIC X(08) VALUE 'LTCAL094'.
070800 01  LTCAL095                       PIC X(08) VALUE 'LTCAL095'.
070900 01  LTCAL103                       PIC X(08) VALUE 'LTCAL103'.
071000 01  LTCAL105                       PIC X(08) VALUE 'LTCAL105'.
071100 01  LTCAL111                       PIC X(08) VALUE 'LTCAL111'.
071200 01  LTCAL123                       PIC X(08) VALUE 'LTCAL123'.
071300 01  LTCAL130                       PIC X(08) VALUE 'LTCAL130'.
071400 01  LTCAL141                       PIC X(08) VALUE 'LTCAL141'.
071500 01  LTCAL152                       PIC X(08) VALUE 'LTCAL152'.
071600 01  LTCAL154                       PIC X(08) VALUE 'LTCAL154'.
071700 01  LTCAL162                       PIC X(08) VALUE 'LTCAL162'.
071800 01  LTCAL170                       PIC X(08) VALUE 'LTCAL170'.
071900
072000*-------------------------------------------------------------*
072100* VARIABLES TO HOLD THE BILL'S FY BEGIN AND END DATES         *
072200*-------------------------------------------------------------*
072300 01  W-FY-BEGIN-DATE.
072400     05  W-FY-BEGIN-CC              PIC 9(02).
072500     05  W-FY-BEGIN-YY              PIC 9(02).
072600     05  W-FY-BEGIN-MM              PIC 9(02) VALUE 10.
072700     05  W-FY-BEGIN-DD              PIC 9(02) VALUE 01.
072800
072900 01  W-FY-END-DATE.
073000     05  W-FY-END-CC                PIC 9(02).
073100     05  W-FY-END-YY                PIC 9(02).
073200     05  W-FY-END-MM                PIC 9(02) VALUE 09.
073300     05  W-FY-END-DD                PIC 9(02) VALUE 30.
073400
073500
073600***************************************************************
073700* MSA AND CBSA HOLD AREAS FOR SEARCH                          *
073800***************************************************************
073900 01  HOLD-PROV-MSA.
074000         10  H-PROV-BLANK             PIC X(2).
074100         10  H-PROV-STATE.
074200             15  FILLER               PIC X.
074300             15  H-MSA-LAST-POS       PIC X.
074400
074500 01  HOLD-PROV-CBSA.
074600         10  H-PROV-BLANK             PIC X(3).
074700         10  H-PROV-STATE.
074800             15  FILLER               PIC X.
074900             15  H-CBSA-LAST-POS      PIC X.
075000
075100 01  HOLD-PROV-IPPS-CBSA.
075200         10  H-PROV-BLANK             PIC X(3).
075300         10  H-PROV-STATE.
075400             15  FILLER               PIC X.
075500             15  H-IPPS-CBSA-LAST-POS PIC X.
075600
075700 01  HOLD-PROV-IPPS-CBSA-RURAL.
075800         10  H-PROV-BLANK-R              PIC X(3).
075900         10  H-PROV-STATE-R.
076000             15  FILLER                  PIC X.
076100             15  H-IPPS-CBSA-LAST-POS-R  PIC X.
076200
076300
076400***************************************************************
076500*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
076600*      THE LTCAL___ PROGRAM (MSA) - USED THROUGH 06/30/2005   *
076700***************************************************************
076800 01  WAGE-NEW-INDEX-RECORD-MSA.
076900     05  W-NEW-MSA                    PIC 9(4).
077000     05  W-NEW-EFF-DATE-M.
077100          10  W-NEW-EFF-DATE-M-CC     PIC 9(2).
077200          10  W-NEW-EFF-DATE-M-YMD.
077300              15  W-NEW-EFF-DATE-M-YY PIC 9(2).
077400              15  W-NEW-EFF-DATE-M-MM PIC 9(2).
077500              15  W-NEW-EFF-DATE-M-DD PIC 9(2).
077600     05  W-NEW-INDEX1-RECORD-M        PIC S9(02)V9(04).
077700     05  W-NEW-INDEX2-RECORD-M        PIC S9(02)V9(04).
077800     05  W-NEW-INDEX3-RECORD-M        PIC S9(02)V9(04).
077900
078000
078100***************************************************************
078200*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
078300*      THE LTCAL___ PROGRAM (CBSA) - USED SINCE 07/01/2005    *
078400***************************************************************
078500 01  WAGE-NEW-INDEX-RECORD-CBSA.
078600     05  W-NEW-CBSA                   PIC 9(5).
078700     05  W-NEW-EFF-DATE-C.
078800          10  W-NEW-EFF-DATE-C-CC     PIC 9(2).
078900          10  W-NEW-EFF-DATE-C-YMD.
079000              15  W-NEW-EFF-DATE-C-YY PIC 9(2).
079100              15  W-NEW-EFF-DATE-C-MM PIC 9(2).
079200              15  W-NEW-EFF-DATE-C-DD PIC 9(2).
079300     05  W-NEW-INDEX1-RECORD-C        PIC S9(02)V9(04).
079400     05  W-NEW-INDEX2-RECORD-C        PIC S9(02)V9(04).
079500     05  W-NEW-INDEX3-RECORD-C        PIC S9(02)V9(04).
079600
079700
079800***************************************************************
079900*      THIS IS THE IPPS WAGE-INDEX RECORD THAT WILL BE PASSED *
080000*      TO THE LTCAL___ PROGRAM (CBSA) - USED SINCE 07/01/2006 *
080100***************************************************************
080200 01  WAGE-IPPS-INDEX-RECORD-CBSA.
080300     05  W-CBSA-IPPS.
080400         10 CBSA-IPPS-123              PIC X(3).
080500         10 CBSA-IPPS-45               PIC X(2).
080600     05  W-CBSA-IPPS-SIZE              PIC X.
080700         88  LARGE-URBAN       VALUE 'L'.
080800         88  OTHER-URBAN       VALUE 'O'.
080900         88  ALL-RURAL         VALUE 'R'.
081000     05  W-CBSA-IPPS-EFF-DATE          PIC X(8).
081100     05  FILLER                        PIC X.
081200     05  W-IPPS-WAGE-INDEX             PIC S9(02)V9(04).
081300     05  W-IPPS-PR-WAGE-INDEX          PIC S9(02)V9(04).
081400
081500
081600***************************************************************
081700*      THIS IS THE IPPS RURAL WAGE INDEX INFO THAT WILL BE    *
081800*      HELD                                                   *
081900***************************************************************
082000 01  WAGE-IPPS-INDEX-RURAL-CBSA.
082100     05  W-CBSA-IPPS-RURAL.
082200         10 CBSA-IPPS-RURAL-123        PIC X(3).
082300         10 CBSA-IPPS-RURAL-45         PIC X(2).
082400     05  W-CBSA-IPPS-RUR-EFF-DATE      PIC X(8).
082500     05  W-IPPS-WAGE-INDEX-RURAL       PIC S9(02)V9(04).
082600
082700
082800***************************************************************
082900*      THIS IS THE IPPS RURAL WAGE INDEX INFO THAT WILL BE    *
083000*      HELD - PUERTO RICO SPECIFIC                            *
083100***************************************************************
083200 01  W-IPPS-PR-WAGE-INDEX-RUR          PIC S9(02)V9(04).
083300
083400
083500**************************************************************
083600*      THIS IS THE PROV-RECORD THAT IS PASSED FROM THE       *
083700*      LTDRV___ PROGRAM TO THE LTCAL___ PROGRAM              *
083800**************************************************************
083900 01  PROV-NEW-HOLD.
084000     02  PROV-NEWREC-HOLD1.
084100         05  P-NEW-NPI10.
084200             10  P-NEW-NPI8             PIC X(08).
084300             10  P-NEW-NPI-FILLER       PIC X(02).
084400         05  P-NEW-PROVIDER-NO.
084500             10  P-NEW-STATE            PIC 9(02).
084600             10  FILLER                 PIC X(04).
084700         05  P-NEW-DATE-DATA.
084800             10  P-NEW-EFF-DATE.
084900                 15  P-NEW-EFF-DT-CC    PIC 9(02).
085000                 15  P-NEW-EFF-DT-YY    PIC 9(02).
085100                 15  P-NEW-EFF-DT-MM    PIC 9(02).
085200                 15  P-NEW-EFF-DT-DD    PIC 9(02).
085300             10  P-NEW-FY-BEGIN-DATE.
085400                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
085500                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
085600                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
085700                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
085800             10  P-NEW-REPORT-DATE.
085900                 15  P-NEW-REPORT-DT-CC PIC 9(02).
086000                 15  P-NEW-REPORT-DT-YY PIC 9(02).
086100                 15  P-NEW-REPORT-DT-MM PIC 9(02).
086200                 15  P-NEW-REPORT-DT-DD PIC 9(02).
086300             10  P-NEW-TERMINATION-DATE.
086400                 15  P-NEW-TERM-DT-CC   PIC 9(02).
086500                 15  P-NEW-TERM-DT-YY   PIC 9(02).
086600                 15  P-NEW-TERM-DT-MM   PIC 9(02).
086700                 15  P-NEW-TERM-DT-DD   PIC 9(02).
086800         05  P-NEW-WAIVER-CODE          PIC X(01).
086900             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
087000         05  P-NEW-INTER-NO             PIC 9(05).
087100         05  P-NEW-PROVIDER-TYPE        PIC X(02).
087200         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
087300         05  P-NEW-CURRENT-DIV   REDEFINES
087400                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
087500         05  P-NEW-MSA-DATA.
087600             10  P-NEW-CHG-CODE-INDEX       PIC X.
087700             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
087800             10  P-NEW-GEO-LOC-MSA9   REDEFINES
087900                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
088000             10  P-NEW-GEO-LOC-MSA-AST REDEFINES
088100                             P-NEW-GEO-LOC-MSA9.
088200                 15  P-NEW-GEO-MSA-1ST    PIC X.
088300                 15  P-NEW-GEO-MSA-2ND    PIC X.
088400                 15  P-NEW-GEO-MSA-3RD    PIC X.
088500                 15  P-NEW-GEO-MSA-4TH    PIC X.
088600             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
088700             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
088800             10  P-NEW-STAND-AMT-LOC-MSA9
088900                   REDEFINES P-NEW-STAND-AMT-LOC-MSA.
089000                 15  P-NEW-RURAL-1ST.
089100                     20  P-NEW-STAND-RURAL  PIC XX.
089200                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
089300                 15  P-NEW-RURAL-2ND        PIC XX.
089400         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
089500                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
089600                 88  P-NEW-SCH-YR82       VALUE   '82'.
089700                 88  P-NEW-SCH-YR87       VALUE   '87'.
089800         05  P-NEW-LUGAR                    PIC X.
089900         05  P-NEW-TEMP-RELIEF-IND          PIC X.
090000         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
090100         05  P-NEW-STATE-CODE               PIC 9(02).
090200         05  P-NEW-STATE-CODE-X REDEFINES
090300               P-NEW-STATE-CODE             PIC X(02).
090400         05  FILLER                         PIC X(03).
090500     02  PROV-NEWREC-HOLD2.
090600         05  P-NEW-VARIABLES.
090700             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
090800             10  P-NEW-COLA              PIC  9(01)V9(03).
090900             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
091000             10  P-NEW-BED-SIZE          PIC  9(05).
091100             10  P-NEW-CCR               PIC  9(01)V9(03).
091200             10  P-NEW-CMI               PIC  9(01)V9(04).
091300             10  P-NEW-SSI-RATIO         PIC  V9(04).
091400             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
091500             10  P-NEW-PPS-BLEND-YR-IND  PIC  X(01).
091600             10  P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).
091700             10  P-NEW-DSH-PERCENT       PIC  V9(04).
091800             10  P-NEW-FYE-DATE.
091900                 15  P-NEW-FYE-CC        PIC 99.
092000                 15  P-NEW-FYE-YY        PIC 99.
092100                 15  P-NEW-FYE-MM        PIC 99.
092200                 15  P-NEW-FYE-DD        PIC 99.
092300         05  P-NEW-CBSA-SPEC-PAY-IND       PIC X(01).
092400         05  P-NEW-HOSP-QUAL-IND           PIC X(01).
092500         05  P-NEW-GEO-LOC-CBSAX           PIC X(05) JUST RIGHT.
092600         05  P-NEW-GEO-LOC-CBSA9 REDEFINES
092700                          P-NEW-GEO-LOC-CBSAX PIC 9(05).
092800         05  P-NEW-GEO-LOC-CBSA-AST REDEFINES
092900                          P-NEW-GEO-LOC-CBSA9.
093000             10 P-NEW-GEO-LOC-CBSA-1ST     PIC X.
093100             10 P-NEW-GEO-LOC-CBSA-2ND     PIC X.
093200             10 P-NEW-GEO-LOC-CBSA-3RD     PIC X.
093300             10 P-NEW-GEO-LOC-CBSA-4TH     PIC X.
093400             10 P-NEW-GEO-LOC-CBSA-5TH     PIC X.
093500         05 P-NEW-GEO-LOC-CBSA-SIZE REDEFINES
093600                          P-NEW-GEO-LOC-CBSAX.
093700             10 P-NEW-GEO-LOC-CBSA-123     PIC X(03).
093800                88  P-NEW-RURAL-CBSA       VALUE '   '.
093900             10 P-NEW-GEO-LOC-CBSA-45      PIC X(02).
094000         05  FILLER                        PIC X(10).
094100         05  P-NEW-SPECIAL-WAGE-INDEX      PIC 9(02)V9(04).
094200     02  PROV-NEWREC-HOLD3.
094300         05  P-NEW-PASS-AMT-DATA.
094400             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
094500             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
094600             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
094700             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
094800         05  P-NEW-CAPI-DATA.
094900             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
095000             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
095100             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
095200             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
095300             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
095400             15  P-NEW-CAPI-NEW-HOSP       PIC X.
095500             15  P-NEW-CAPI-IME            PIC 9V9999.
095600             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
095700             15  P-VAL-BASED-PURCH-SCORE   PIC 9V999.
095800         05  FILLER                        PIC X(18).
095900
096000
096100**************************************************************
096200*      THIS IS THE BILL-RECORD THAT WILL BE PASSED TO        *
096300*      THE LTCAL___ PROGRAM FOR FYS 2003 - 2015 OCT - DEC    *
096400**************************************************************
096500 01  BILL-DATA-FY03-FY15.
096600     05  B-03TO15-NPI10.
096700         10  B-03TO15-NPI8            PIC X(08).
096800         10  B-03TO15-NPI-FILLER      PIC X(02).
096900     05  B-03TO15-PROVIDER-NO         PIC X(06).
097000     05  B-03TO15-PATIENT-STATUS      PIC X(02).
097100     05  B-03TO15-DRG-CODE            PIC X(03).
097200     05  B-03TO15-LOS                 PIC 9(03).
097300     05  B-03TO15-COV-DAYS            PIC 9(03).
097400     05  B-03TO15-LTR-DAYS            PIC 9(02).
097500     05  B-03TO15-DISCHARGE-DATE.
097600         10  B-03TO15-DISCHG-CC       PIC 9(02).
097700         10  B-03TO15-DISCHG-YY       PIC 9(02).
097800         10  B-03TO15-DISCHG-MM       PIC 9(02).
097900         10  B-03TO15-DISCHG-DD       PIC 9(02).
098000     05  B-03TO15-COV-CHARGES         PIC 9(07)V9(02).
098100     05  B-03TO15-SPEC-PAY-IND        PIC X(01).
098200     05  FILLER                       PIC X(13).
098300
098400
098500***************************************************************
098600 LINKAGE SECTION.
098700***************************************************************
098800
098900**************************************************************
099000*      THIS IS THE BILL-RECORD THAT WILL BE PASSED TO        *
099100*      THE LTCAL___ PROGRAM FOR FYS 2015 (JANUARY) & LATER   *
099200**************************************************************
099300 01  BILL-NEW-DATA.
099400     05  B-NPI10.
099500         10  B-NPI8                   PIC X(08).
099600         10  B-NPI-FILLER             PIC X(02).
099700     05  B-PROVIDER-NO                PIC X(06).
099800     05  B-PATIENT-STATUS             PIC X(02).
099900     05  B-DRG-CODE                   PIC X(03).
100000     05  B-LOS                        PIC 9(03).
100100     05  B-COV-DAYS                   PIC 9(03).
100200     05  B-LTR-DAYS                   PIC 9(02).
100300     05  B-CST-RPT-DAYS               PIC 9(03).
100400     05  B-DISCHARGE-DATE.
100500         10  B-DISCHG-CC              PIC 9(02).
100600         10  B-DISCHG-YY              PIC 9(02).
100700         10  B-DISCHG-MM              PIC 9(02).
100800         10  B-DISCHG-DD              PIC 9(02).
100900     05  B-COV-CHARGES                PIC 9(07)V9(02).
101000     05  B-SPEC-PAY-IND               PIC X(01).
101100     05  B-REVIEW-CODE                PIC 9(02).
101200     05  B-DIAGNOSIS-CODE-TABLE.
101300         10  B-DIAGNOSIS-CODE         PIC X(07) OCCURS 25 TIMES
101400                                      INDEXED BY IDX-DIAG.
101500     05  B-PROCEDURE-CODE-TABLE.
101600         10 B-PROCEDURE-CODE          PIC X(07) OCCURS 25 TIMES
101700                                      INDEXED BY IDX-PROC.
101800     05  FILLER                       PIC X(20).
101900
102000
102100**************************************************************
102200*      THIS IS THE PPS DATA PASSED TO THE LTCAL___ PROGRAM   *
102300*      IT WILL BE PASSED BACK TO THE LTDRV___ PROGRAM        *
102400**************************************************************
102500 01  PPS-DATA-ALL.
102600     05  PPS-RTC                      PIC X(02).
102700     05  PPS-CHRG-THRESHOLD           PIC 9(07)V9(02).
102800     05  PPS-DATA.
102900         10  PPS-MSA                  PIC X(04).
103000         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).
103100         10  PPS-AVG-LOS              PIC 9(02)V9(01).
103200         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).
103300         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).
103400         10  PPS-LOS                  PIC 9(03).
103500         10  PPS-DRG-ADJ-PAY-AMT      PIC 9(07)V9(02).
103600         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).
103700         10  PPS-FINAL-PAY-AMT        PIC 9(07)V9(02).
103800         10  PPS-FAC-COSTS            PIC 9(07)V9(02).
103900         10  PPS-NEW-FAC-SPEC-RATE    PIC 9(07)V9(02).
104000         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).
104100         10  PPS-SUBM-DRG-CODE        PIC X(03).
104200         10  PPS-CALC-VERS-CD         PIC X(05).
104300         10  PPS-REG-DAYS-USED        PIC 9(03).
104400         10  PPS-LTR-DAYS-USED        PIC 9(03).
104500         10  PPS-BLEND-YEAR           PIC 9(01).
104600         10  PPS-COLA                 PIC 9(01)V9(03).
104700         10  FILLER                   PIC X(04).
104800    05  PPS-OTHER-DATA.
104900         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).
105000         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).
105100         10  PPS-STD-FED-RATE         PIC 9(05)V9(02).
105200         10  PPS-BDGT-NEUT-RATE       PIC 9(01)V9(03).
105300         10  PPS-IPTHRESH             PIC 9(03)V9(01).
105400         10  FILLER                   PIC X(16).
105500    05  PPS-PC-DATA.
105600         10  PPS-COT-IND              PIC X(01).
105700         10  FILLER                   PIC X(20).
105800
105900 01  PPS-CBSA                         PIC X(05).
106000
106100 01  PPS-PAYMENT-DATA.
106200     05  PPS-SITE-NEUTRAL-COST-PMT    PIC 9(07)V99.
106300     05  PPS-SITE-NEUTRAL-IPPS-PMT    PIC 9(07)V99.
106400     05  PPS-STANDARD-FULL-PMT        PIC 9(07)V99.
106500     05  PPS-STANDARD-SSO-PMT         PIC 9(07)V99.
106600
106700*****************************************************************
106800*            THESE ARE THE VERSIONS OF THE LTDRV___             *
106900*           PROGRAMS THAT WILL BE PASSED BACK----               *
107000*          ASSOCIATED WITH THE BILL BEING PROCESSED             *
107100*****************************************************************
107200 01  PRICER-OPT-VERS-SW.
107300     05  PRICER-OPTION-SW               PIC X(01).
107400         88  ALL-TABLES-PASSED          VALUE 'A'.
107500         88  PROV-RECORD-PASSED         VALUE 'P'.
107600     05  PPS-VERSIONS.
107700         10  PPDRV-VERSION              PIC X(05).
107800
107900
108000
108100**************************************************************
108200*      PROVIDER SPECIFIC RECORD                              *
108300**************************************************************
108400*      THIS IS THE PROV-RECORD THAT IS PASSED FROM THE       *
108500*      LTOPN___ PROGRAM                                      *
108600**************************************************************
108700 01  PROV-RECORD.
108800     05  PROV-REC1                  PIC X(80).
108900     05  PROV-REC2                  PIC X(80).
109000     05  PROV-REC3                  PIC X(80).
109100
109200
109300**************************************************************
109400*      LTCH CBSA WAGE INDEX TABLE                            *
109500**************************************************************
109600*      THIS IS THE CBSA WAGE INDEX TABLE THAT IS PASSED FROM *
109700*      THE LTOPN___ PROGRAM                                  *
109800**************************************************************
109900 01  CBSA-WI-TABLE.
110000     05  C-CBSA-DATA  OCCURS 0 TO 7000 TIMES
110100                      DEPENDING ON CBSA-CNT
110200                      ASCENDING KEY IS CBSAX-CBSA
110300                      INDEXED BY CU1 CU2.
110400         10  CBSAX-CBSA         PIC X(05).
110500         10  CBSAX-EFF-DATE     PIC X(08).
110600         10  CBSAX-WAGE-INDEX1  PIC S9(02)V9(04).
110700         10  CBSAX-WAGE-INDEX2  PIC S9(02)V9(04).
110800         10  CBSAX-WAGE-INDEX3  PIC S9(02)V9(04).
110900
111000
111100**************************************************************
111200*      IPPS CBSA WAGE INDEX TABLE                            *
111300**************************************************************
111400*      THIS IS THE IPPS CBSA WAGE INDEX TABLE THAT IS PASSED *
111500*      FROM THE LTOPN___ PROGRAM                             *
111600**************************************************************
111700 01  IPPS-CBSA-WI-TABLE.
111800     05  T-CBSA-DATA  OCCURS 0 TO 7000 TIMES
111900                      DEPENDING ON IPPS-CBSA-CNT
112000                      ASCENDING KEY IS T-CBSA
112100                      INDEXED BY MA1 MA2 MA3.
112200         10  T-CBSA             PIC X(5).
112300         10  T-CBSA-SIZE        PIC X(01).
112400         10  T-CBSA-EFF-DATE    PIC X(08).
112500         10  T-CBSA-WAGE-INDX1  PIC S9(02)V9(04).
112600         10  T-CBSA-WAGE-INDX2  PIC S9(02)V9(04).
112700
112800
112900**************************************************************
113000*      LTCH MSA WAGE INDEX TABLE                             *
113100**************************************************************
113200*      THIS IS THE MSA WAGE INDEX TABLE THAT IS PASSED FROM  *
113300*      THE LTOPN___ PROGRAM                                  *
113400**************************************************************
113500 01  MSA-WI-TABLE.
113600     05  M-MSA-DATA   OCCURS 0 TO 4000 TIMES
113700                      DEPENDING ON MSA-CNT
113800                      ASCENDING KEY IS MSAX-MSA
113900                      INDEXED BY MU1 MU2.
114000         10  MSAX-MSA          PIC X(4).
114100         10  MSAX-EFF-DATE     PIC X(08).
114200         10  MSAX-WAGE-INDEX1  PIC S9(02)V9(04).
114300         10  MSAX-WAGE-INDEX2  PIC S9(02)V9(04).
114400         10  MSAX-WAGE-INDEX3  PIC S9(02)V9(04).
114500
114600
114700**************************************************************
114800*  INPUT FILE RECORD COUNTS                                  *
114900**************************************************************
115000 01  WORK-COUNTERS.
115100     05  CBSA-CNT              PIC 9(5).
115200     05  MSA-CNT               PIC 9(5).
115300     05  PROV-CNT              PIC 9(5).
115400     05  IPPS-CBSA-CNT         PIC 9(5).
115500
115600
115700
115800
115900 PROCEDURE DIVISION  USING BILL-NEW-DATA
116000                           PPS-DATA-ALL
116100                           PPS-CBSA
116200                           PPS-PAYMENT-DATA
116300                           PRICER-OPT-VERS-SW
116400                           PROV-RECORD
116500                           CBSA-WI-TABLE
116600                           IPPS-CBSA-WI-TABLE
116700                           MSA-WI-TABLE
116800                           WORK-COUNTERS.
116900
117000
117100******************************************************************
117200*                                                                *
117300*    PROCESSING:                                                 *
117400*      A. THIS MODULE WILL RETRIEVE THE WAGE INDEX RECORD(S)     *
117500*         NEEDED FOR EACH BILL.                                  *
117600*      B. THIS MODULE WILL CALL THE LTCAL MODULES.               *
117700*      C. THE PROV-RECORD AND WAGE-INDEX-RECORD(S) ASSOCIATED    *
117800*         WITH EACH BILL WILL BE PASSED TO THE LTCAL PROGRAMS.   *
117900*                                                                *
118000******************************************************************
118100
118200     MOVE DRV-VERSION TO PPDRV-VERSION.
118300
118400*----------------------------------------------------------*
118500* INITIALIZE VARIABLES                                     *
118600*----------------------------------------------------------*
118700     INITIALIZE PPS-DATA-ALL
118800                PPS-CBSA
118900                HOLD-PROV-MSA
119000                HOLD-PROV-CBSA
119100                HOLD-PROV-IPPS-CBSA
119200                HOLD-PROV-IPPS-CBSA-RURAL
119300                WAGE-NEW-INDEX-RECORD-MSA
119400                WAGE-NEW-INDEX-RECORD-CBSA
119500                WAGE-IPPS-INDEX-RECORD-CBSA
119600                W-IPPS-PR-WAGE-INDEX-RUR
119700                WAGE-IPPS-INDEX-RURAL-CBSA
119800                W-FY-BEGIN-CC
119900                W-FY-BEGIN-YY
120000                W-FY-END-CC
120100                W-FY-END-YY
120200                BILL-DATA-FY03-FY15
120300                PPS-PAYMENT-DATA.
120400
120500     MOVE PROV-RECORD TO PROV-NEW-HOLD.
120600
120700
120800*----------------------------------------------------------*
120900* RTC = 98  --  BILL DISCHARGE DATE BEFORE 10/01/2002      *
121000*----------------------------------------------------------*
121100     IF B-DISCHARGE-DATE < 20021001
121200        MOVE 98 TO PPS-RTC
121300        GOBACK
121400     END-IF.
121500
121600
121700*-----------------------------------------------------------*
121800* IF CLAIM DISCHARGED BEFORE JAN 2015, MOVE INPUT BILL DATA *
121900* TO OLD BILL RECORD LAYOUT TO PASS TO PRE-JAN 2015 VERSIONS*
122000* OF PROGRAM LTCAL***                                       *
122100*-----------------------------------------------------------*
122200     IF B-DISCHARGE-DATE < 20150101
122300        MOVE B-NPI8           TO B-03TO15-NPI8
122400        MOVE B-PROVIDER-NO    TO B-03TO15-PROVIDER-NO
122500        MOVE B-PATIENT-STATUS TO B-03TO15-PATIENT-STATUS
122600        MOVE B-DRG-CODE       TO B-03TO15-DRG-CODE
122700        MOVE B-LOS            TO B-03TO15-LOS
122800        MOVE B-COV-DAYS       TO B-03TO15-COV-DAYS
122900        MOVE B-LTR-DAYS       TO B-03TO15-LTR-DAYS
123000        MOVE B-DISCHG-CC      TO B-03TO15-DISCHG-CC
123100        MOVE B-DISCHG-YY      TO B-03TO15-DISCHG-YY
123200        MOVE B-DISCHG-MM      TO B-03TO15-DISCHG-MM
123300        MOVE B-DISCHG-DD      TO B-03TO15-DISCHG-DD
123400        MOVE B-COV-CHARGES    TO B-03TO15-COV-CHARGES
123500        MOVE B-SPEC-PAY-IND   TO B-03TO15-SPEC-PAY-IND
123600     END-IF.
123700
123800
123900*----------------------------------------------------------*
124000* SET FY BEGIN AND END DATES USING BILL DISCHARGE DATE     *
124100*----------------------------------------------------------*
124200     MOVE B-DISCHG-CC TO W-FY-BEGIN-CC.
124300     MOVE B-DISCHG-CC TO W-FY-END-CC.
124400
124500*----------------------------------*
124600* FOR CLAIMS DISCHARGED JAN - SEPT *
124700*----------------------------------*
124800     IF B-DISCHG-MM >= 01 AND
124900        B-DISCHG-MM <= 09
125000        COMPUTE W-FY-BEGIN-YY = B-DISCHG-YY - 1
125100        MOVE B-DISCHG-YY TO W-FY-END-YY
125200
125300*----------------------------------*
125400* FOR CLAIMS DISCHARGED OCT - DEC  *
125500*----------------------------------*
125600     ELSE
125700        MOVE B-DISCHG-YY TO W-FY-BEGIN-YY
125800        COMPUTE W-FY-END-YY = B-DISCHG-YY + 1
125900     END-IF.
126000
126100
126200
126300************************************************************
126400*    GET THE WAGE-INDEX RECORD                             *
126500************************************************************
126600
126700*------------------------------------------------*
126800* EDIT THE CBSA AND MSA FROM THE PROVIDER RECORD *
126900*------------------------------------------------*
127000     IF P-NEW-GEO-LOC-CBSAX = SPACES
127100        MOVE ZEROS TO P-NEW-GEO-LOC-CBSAX
127200     END-IF.
127300
127400     IF P-NEW-GEO-LOC-MSAX = SPACES
127500        MOVE ZEROS TO P-NEW-GEO-LOC-MSAX
127600     END-IF.
127700
127800     IF P-NEW-EFF-DATE > 20050701
127900        IF '*' = P-NEW-GEO-LOC-CBSA-1ST OR
128000                 P-NEW-GEO-LOC-CBSA-2ND OR
128100                 P-NEW-GEO-LOC-CBSA-3RD OR
128200                 P-NEW-GEO-LOC-CBSA-4TH OR
128300                 P-NEW-GEO-LOC-CBSA-5TH
128400           MOVE 60 TO PPS-RTC
128500           GOBACK
128600        END-IF
128700     END-IF.
128800
128900*----------------------------------------------------------*
129000* DETERMINE WHETHER TO GET THE LTCH MSA OR CBSA WAGE INDEX *
129100*----------------------------------------------------------*
129200     IF B-DISCHARGE-DATE < 20050701
129300       SET MU1 TO 1
129400       PERFORM 0500-GET-MSA THRU 0500-EXIT
129500     ELSE
129600       SET CU1 TO 1
129700       PERFORM 0550-GET-CBSA THRU 0550-EXIT
129800       IF W-NEW-INDEX3-RECORD-C = 0
129900          MOVE 52 TO PPS-RTC
130000     END-IF.
130100
130200*----------------------------------------------------------*
130300* GET THE IPPS CBSA WAGE INDEX FOR CLAIMS DISCHARGED AFTER *
130400* JUNE 30, 2006 FOR USE IN THE 4TH SHORT STAY PROVISION    *
130500*----------------------------------------------------------*
130600     IF B-DISCHARGE-DATE > 20060630
130700       SET MA1 TO 1
130800       PERFORM 0575-GET-IPPS-CBSA THRU 0575-EXIT
130900       IF W-IPPS-WAGE-INDEX = 0
131000          MOVE 52 TO PPS-RTC
131100       END-IF
131200     END-IF.
131300
131400*--------------------------------------------------------------*
131500* RTC = 60  --  LTCH/IPPS CBSA/MSA WAGE INDEX RECORD NOT FOUND *
131600* RTC = 52  --  LTCH/IPPS CBSA/MSA WAGE INDEX INVALID          *
131700*--------------------------------------------------------------*
131800     IF PPS-RTC = 60 OR PPS-RTC = 52
131900        GOBACK
132000     END-IF.
132100
132200
132300
132400******************************************************************
132500******************************************************************
132600**                                                              **
132700**          THIS NEXT CALL WILL PROCESS BILLS WITH              **
132800**          A DISCHARGE DATE ON OR AFTER 20021001               **
132900**                                                              **
133000**--------------------------------------------------------------**
133100**                                                              **
133200** FOR BILLS WITH DISCHARGE DATES AFTER 20050630, INCLUDE FIELD **
133300** PPS-CBSA IN THE CALL USING STATEMENT, OMIT THIS FIELD FOR    **
133400** BILLS WITH DISCHARGE DATES BEFORE 20050701.                  **
133500**                                                              **
133600** FOR BILLS WITH DISCHARGE DATES AFTER 20060630, INCLUDE FIELD **
133700** WAGE-IPPS-INDEX-RECORD-CBSA.                                 **
133800**                                                              **
133900******************************************************************
134000******************************************************************
134100
134200
134300*----------------------------------------------------------------*
134400*        FISCAL YEAR 2017
134500*----------------------------------------------------------------*
134600         IF B-DISCHARGE-DATE > 20160930
134700            CALL LTCAL170 USING BILL-NEW-DATA
134800                                PPS-DATA-ALL
134900                                PPS-CBSA
135000                                PPS-PAYMENT-DATA
135100                                PRICER-OPT-VERS-SW
135200                                PROV-NEW-HOLD
135300                                WAGE-NEW-INDEX-RECORD-CBSA
135400                                WAGE-IPPS-INDEX-RECORD-CBSA.
135500
135600
135700*----------------------------------------------------------------*
135800*        FISCAL YEAR 2016
135900*----------------------------------------------------------------*
136000         IF B-DISCHARGE-DATE > 20150930 AND
136100                             < 20161001
136200            CALL LTCAL162 USING BILL-NEW-DATA
136300                                PPS-DATA-ALL
136400                                PPS-CBSA
136500                                PPS-PAYMENT-DATA
136600                                PRICER-OPT-VERS-SW
136700                                PROV-NEW-HOLD
136800                                WAGE-NEW-INDEX-RECORD-CBSA
136900                                WAGE-IPPS-INDEX-RECORD-CBSA.
137000
137100*----------------------------------------------------------------*
137200*        FISCAL YEAR 2015, 01/01/2015 - 09/30/2015               *
137300*----------------------------------------------------------------*
137400         IF B-DISCHARGE-DATE > 20141231 AND
137500                             < 20151001
137600            CALL LTCAL154 USING BILL-NEW-DATA
137700                                PPS-DATA-ALL
137800                                PPS-CBSA
137900                                PRICER-OPT-VERS-SW
138000                                PROV-NEW-HOLD
138100                                WAGE-NEW-INDEX-RECORD-CBSA
138200                                WAGE-IPPS-INDEX-RECORD-CBSA.
138300
138400*----------------------------------------------------------------*
138500*        FISCAL YEAR 2015, 10/01/2014 - 12/31/2014               *
138600*----------------------------------------------------------------*
138700         IF B-DISCHARGE-DATE > 20140930 AND
138800                             < 20150101
138900            CALL LTCAL152 USING BILL-DATA-FY03-FY15
139000                                PPS-DATA-ALL
139100                                PPS-CBSA
139200                                PRICER-OPT-VERS-SW
139300                                PROV-NEW-HOLD
139400                                WAGE-NEW-INDEX-RECORD-CBSA
139500                                WAGE-IPPS-INDEX-RECORD-CBSA.
139600
139700*----------------------------------------------------------------*
139800*        FISCAL YEAR 2014, RATE YEAR 2014 (AFTER 10/1/2013)      *
139900*----------------------------------------------------------------*
140000         IF B-DISCHARGE-DATE > 20130930 AND
140100                             < 20141001
140200            CALL LTCAL141 USING BILL-DATA-FY03-FY15
140300                                PPS-DATA-ALL
140400                                PPS-CBSA
140500                                PRICER-OPT-VERS-SW
140600                                PROV-NEW-HOLD
140700                                WAGE-NEW-INDEX-RECORD-CBSA
140800                                WAGE-IPPS-INDEX-RECORD-CBSA.
140900
141000*----------------------------------------------------------------*
141100*        FISCAL YEAR 2013, RATE YEAR 2013 (AFTER 10/1/2012)      *
141200*----------------------------------------------------------------*
141300         IF B-DISCHARGE-DATE > 20120930 AND
141400                             < 20131001
141500            CALL LTCAL130 USING BILL-DATA-FY03-FY15
141600                                PPS-DATA-ALL
141700                                PPS-CBSA
141800                                PRICER-OPT-VERS-SW
141900                                PROV-NEW-HOLD
142000                                WAGE-NEW-INDEX-RECORD-CBSA
142100                                WAGE-IPPS-INDEX-RECORD-CBSA.
142200
142300*----------------------------------------------------------------*
142400*        FISCAL YEAR 2012, RATE YEAR 2012 (AFTER 10/1/2011)      *
142500*----------------------------------------------------------------*
142600         IF B-DISCHARGE-DATE > 20110930 AND
142700                             < 20121001
142800            CALL LTCAL123 USING BILL-DATA-FY03-FY15
142900                                PPS-DATA-ALL
143000                                PPS-CBSA
143100                                PRICER-OPT-VERS-SW
143200                                PROV-NEW-HOLD
143300                                WAGE-NEW-INDEX-RECORD-CBSA
143400                                WAGE-IPPS-INDEX-RECORD-CBSA.
143500
143600*----------------------------------------------------------------*
143700*        FISCAL YEAR 2011, RATE YEAR 2011 (AFTER 10/1/2010)      *
143800*----------------------------------------------------------------*
143900         IF B-DISCHARGE-DATE > 20100930 AND
144000                             < 20111001
144100            CALL LTCAL111 USING BILL-DATA-FY03-FY15
144200                                PPS-DATA-ALL
144300                                PPS-CBSA
144400                                PRICER-OPT-VERS-SW
144500                                PROV-NEW-HOLD
144600                                WAGE-NEW-INDEX-RECORD-CBSA
144700                                WAGE-IPPS-INDEX-RECORD-CBSA.
144800
144900*----------------------------------------------------------------*
145000*        FISCAL YEAR 2010, RATE YEAR 2010 (AFTER 3/31/2010)      *
145100*----------------------------------------------------------------*
145200         IF B-DISCHARGE-DATE > 20100331 AND
145300                             < 20101001
145400            CALL LTCAL105 USING BILL-DATA-FY03-FY15
145500                                PPS-DATA-ALL
145600                                PPS-CBSA
145700                                PRICER-OPT-VERS-SW
145800                                PROV-NEW-HOLD
145900                                WAGE-NEW-INDEX-RECORD-CBSA
146000                                WAGE-IPPS-INDEX-RECORD-CBSA.
146100
146200*----------------------------------------------------------------*
146300*        FISCAL YEAR 2010, RATE YEAR 2010 (BEFORE 4/1/2010)      *
146400*----------------------------------------------------------------*
146500         IF B-DISCHARGE-DATE > 20090930 AND
146600                             < 20100401
146700            CALL LTCAL103 USING BILL-DATA-FY03-FY15
146800                                PPS-DATA-ALL
146900                                PPS-CBSA
147000                                PRICER-OPT-VERS-SW
147100                                PROV-NEW-HOLD
147200                                WAGE-NEW-INDEX-RECORD-CBSA
147300                                WAGE-IPPS-INDEX-RECORD-CBSA.
147400
147500*----------------------------------------------------------------*
147600*        FISCAL YEAR 2009, RATE YEAR 2009 (AFTER 6/2/2009)       *
147700*----------------------------------------------------------------*
147800         IF B-DISCHARGE-DATE > 20090602 AND
147900                             < 20091001
148000            CALL LTCAL095 USING BILL-DATA-FY03-FY15
148100                                PPS-DATA-ALL
148200                                PPS-CBSA
148300                                PRICER-OPT-VERS-SW
148400                                PROV-NEW-HOLD
148500                                WAGE-NEW-INDEX-RECORD-CBSA
148600                                WAGE-IPPS-INDEX-RECORD-CBSA.
148700
148800*----------------------------------------------------------------*
148900*        FISCAL YEAR 2009, RATE YEAR 2009 (BEFORE 6/3/2009)      *
149000*----------------------------------------------------------------*
149100         IF B-DISCHARGE-DATE > 20080930 AND
149200                             < 20090603
149300            CALL LTCAL094 USING BILL-DATA-FY03-FY15
149400                                PPS-DATA-ALL
149500                                PPS-CBSA
149600                                PRICER-OPT-VERS-SW
149700                                PROV-NEW-HOLD
149800                                WAGE-NEW-INDEX-RECORD-CBSA
149900                                WAGE-IPPS-INDEX-RECORD-CBSA.
150000
150100*----------------------------------------------------------------*
150200*        FISCAL YEAR 2008, RATE YEAR 2009                        *
150300*----------------------------------------------------------------*
150400         IF B-DISCHARGE-DATE > 20080630 AND
150500                             < 20081001
150600            CALL LTCAL091 USING BILL-DATA-FY03-FY15
150700                                PPS-DATA-ALL
150800                                PPS-CBSA
150900                                PRICER-OPT-VERS-SW
151000                                PROV-NEW-HOLD
151100                                WAGE-NEW-INDEX-RECORD-CBSA
151200                                WAGE-IPPS-INDEX-RECORD-CBSA.
151300
151400*----------------------------------------------------------------*
151500*        FISCAL YEAR 2008, RATE YEAR 2008                        *
151600*----------------------------------------------------------------*
151700         IF B-DISCHARGE-DATE > 20070930 AND
151800                             < 20080701
151900            CALL LTCAL087 USING BILL-DATA-FY03-FY15
152000                                PPS-DATA-ALL
152100                                PPS-CBSA
152200                                PRICER-OPT-VERS-SW
152300                                PROV-NEW-HOLD
152400                                WAGE-NEW-INDEX-RECORD-CBSA
152500                                WAGE-IPPS-INDEX-RECORD-CBSA.
152600
152700*----------------------------------------------------------------*
152800*        FISCAL YEAR 2007, RATE YEAR 2008                        *
152900*----------------------------------------------------------------*
153000         IF B-DISCHARGE-DATE > 20070630 AND
153100                             < 20071001
153200            CALL LTCAL080 USING BILL-DATA-FY03-FY15
153300                                PPS-DATA-ALL
153400                                PPS-CBSA
153500                                PRICER-OPT-VERS-SW
153600                                PROV-NEW-HOLD
153700                                WAGE-NEW-INDEX-RECORD-CBSA
153800                                WAGE-IPPS-INDEX-RECORD-CBSA.
153900
154000*----------------------------------------------------------------*
154100*        FISCAL YEAR 2007, RATE YEAR 2007                        *
154200*----------------------------------------------------------------*
154300         IF B-DISCHARGE-DATE > 20060930 AND
154400                             < 20070701
154500            CALL LTCAL075 USING BILL-DATA-FY03-FY15
154600                                PPS-DATA-ALL
154700                                PPS-CBSA
154800                                PRICER-OPT-VERS-SW
154900                                PROV-NEW-HOLD
155000                                WAGE-NEW-INDEX-RECORD-CBSA
155100                                WAGE-IPPS-INDEX-RECORD-CBSA.
155200
155300*----------------------------------------------------------------*
155400*        FISCAL YEAR 2006, RATE YEAR 2007                        *
155500*----------------------------------------------------------------*
155600         IF B-DISCHARGE-DATE > 20060630 AND
155700                             < 20061001
155800            CALL LTCAL072 USING BILL-DATA-FY03-FY15
155900                                PPS-DATA-ALL
156000                                PPS-CBSA
156100                                PRICER-OPT-VERS-SW
156200                                PROV-NEW-HOLD
156300                                WAGE-NEW-INDEX-RECORD-CBSA
156400                                WAGE-IPPS-INDEX-RECORD-CBSA.
156500
156600*----------------------------------------------------------------*
156700*        FISCAL YEAR 2006, RATE YEAR 2006                        *
156800*----------------------------------------------------------------*
156900         IF B-DISCHARGE-DATE > 20050930 AND
157000                             < 20060701
157100            CALL LTCAL064 USING BILL-DATA-FY03-FY15
157200                                PPS-DATA-ALL
157300                                PPS-CBSA
157400                                PRICER-OPT-VERS-SW
157500                                PROV-NEW-HOLD
157600                                WAGE-NEW-INDEX-RECORD-CBSA.
157700
157800*----------------------------------------------------------------*
157900*        FISCAL YEAR 2005, RATE YEAR 2006                        *
158000*----------------------------------------------------------------*
158100         IF B-DISCHARGE-DATE > 20050630 AND
158200                             < 20051001
158300            CALL LTCAL063 USING BILL-DATA-FY03-FY15
158400                                PPS-DATA-ALL
158500                                PPS-CBSA
158600                                PRICER-OPT-VERS-SW
158700                                PROV-NEW-HOLD
158800                                WAGE-NEW-INDEX-RECORD-CBSA.
158900
159000*----------------------------------------------------------------*
159100*        FISCAL YEAR 2005, RATE YEAR 2005                        *
159200*----------------------------------------------------------------*
159300         IF B-DISCHARGE-DATE > 20040930 AND
159400            B-DISCHARGE-DATE < 20050701
159500            CALL LTCAL059 USING BILL-DATA-FY03-FY15
159600                                PPS-DATA-ALL
159700                                PRICER-OPT-VERS-SW
159800                                PROV-NEW-HOLD
159900                                WAGE-NEW-INDEX-RECORD-MSA.
160000
160100*----------------------------------------------------------------*
160200*        FISCAL YEAR 2004, RATE YEAR 2005                        *
160300*----------------------------------------------------------------*
160400         IF B-DISCHARGE-DATE > 20040630 AND
160500            B-DISCHARGE-DATE < 20041001
160600            CALL LTCAL058 USING BILL-DATA-FY03-FY15
160700                                PPS-DATA-ALL
160800                                PRICER-OPT-VERS-SW
160900                                PROV-NEW-HOLD
161000                                WAGE-NEW-INDEX-RECORD-MSA.
161100
161200*----------------------------------------------------------------*
161300*        FISCAL YEAR 2004, RATE YEAR 2004 (NO LONGER CALLED)     *
161400*----------------------------------------------------------------*
161500         IF B-DISCHARGE-DATE > 20030930 AND
161600            B-DISCHARGE-DATE < 20040701
161700            CALL LTCAL043 USING BILL-DATA-FY03-FY15
161800                                PPS-DATA-ALL
161900                                PRICER-OPT-VERS-SW
162000                                PROV-NEW-HOLD
162100                                WAGE-NEW-INDEX-RECORD-MSA.
162200
162300*----------------------------------------------------------------*
162400*        FISCAL YEAR 2003, RATE YEAR 2004 (NO LONGER CALLED)     *
162500*----------------------------------------------------------------*
162600         IF B-DISCHARGE-DATE > 20030630 AND
162700            B-DISCHARGE-DATE < 20031001
162800            CALL LTCAL042 USING BILL-DATA-FY03-FY15
162900                                PPS-DATA-ALL
163000                                PRICER-OPT-VERS-SW
163100                                PROV-NEW-HOLD
163200                                WAGE-NEW-INDEX-RECORD-MSA.
163300
163400*----------------------------------------------------------------*
163500*        FISCAL YEAR 2003, RATE YEAR 2003 (NO LONGER CALLED)     *
163600*----------------------------------------------------------------*
163700         IF B-DISCHARGE-DATE < 20030701
163800            CALL LTCAL032 USING BILL-DATA-FY03-FY15
163900                                PPS-DATA-ALL
164000                                PRICER-OPT-VERS-SW
164100                                PROV-NEW-HOLD
164200                                WAGE-NEW-INDEX-RECORD-MSA.
164300
164400
164500         GOBACK.
164600
164700******************************************************************
164800******************************************************************
164900
165000
165100******************************************************************
165200 0500-GET-MSA.
165300******************************************************************
165400
165500     MOVE P-NEW-GEO-LOC-MSAX TO HOLD-PROV-MSA.
165600
165700     SEARCH M-MSA-DATA VARYING MU1
165800       AT END
165900          MOVE 60 TO PPS-RTC
166000       WHEN MSAX-MSA (MU1) = HOLD-PROV-MSA
166100          SET MU2 TO MU1
166200          PERFORM 0600-N-GET-WAGE-INDX
166300            THRU 0600-N-EXIT VARYING MU2
166400            FROM MU1 BY 1 UNTIL
166500              MSAX-MSA (MU2) NOT = HOLD-PROV-MSA.
166600
166700 0500-EXIT.
166800      EXIT.
166900
167000
167100******************************************************************
167200 0550-GET-CBSA.
167300******************************************************************
167400
167500*----------------------------------------------------------------*
167600* USE SPECIAL WAGE INDEX WHEN INDICATED - FOR LTCH WAGE INDEX    *
167700* TO USE THE SPECIAL WAGE INDEX IT MUST:                         *
167800*   1) BE FOR A CLAIM DISCHARGED ON OR AFTER 07/01/2005          *
167900*      (WHEN SPECIAL WAGE INDEX WAS FIRST USED FOR LTCH)         *
168000*   2) BE NUMERIC,                                               *
168100*   3) BE GREATER THAN 0, AND                                    *
168200*   4) BE IN A PSF RECORD WITH AN EFFECTIVE DATE WITHIN THE      *
168300*      CLAIM'S FISCAL YEAR.                                      *
168400*----------------------------------------------------------------*
168500     IF B-DISCHARGE-DATE > 20050630
168600     IF P-NEW-CBSA-SPEC-PAY-IND = '1'
168700        IF P-NEW-SPECIAL-WAGE-INDEX NUMERIC AND
168800           P-NEW-SPECIAL-WAGE-INDEX > 0 AND
168900           (P-NEW-EFF-DATE >= W-FY-BEGIN-DATE AND
169000            P-NEW-EFF-DATE <= W-FY-END-DATE)
169100            MOVE ZEROS                    TO W-NEW-CBSA
169200            MOVE P-NEW-EFF-DATE           TO W-NEW-EFF-DATE-C
169300            MOVE P-NEW-SPECIAL-WAGE-INDEX TO W-NEW-INDEX1-RECORD-C
169400            MOVE P-NEW-SPECIAL-WAGE-INDEX TO W-NEW-INDEX2-RECORD-C
169500            MOVE P-NEW-SPECIAL-WAGE-INDEX TO W-NEW-INDEX3-RECORD-C
169600            GO TO 0550-EXIT
169700        ELSE
169800            MOVE 52 TO PPS-RTC
169900            GO TO 0550-EXIT
170000        END-IF
170100     END-IF
170200     END-IF.
170300
170400
170500     MOVE P-NEW-GEO-LOC-CBSAX TO HOLD-PROV-CBSA.
170600
170700*6-20-16
170800*ADDED FOLLOWING LINE TO ALLOW LTCH PRICER TO WORK
170900*WITH THE NEW ARIZONA STATE CODE OF 00 -->
171000
171100     IF HOLD-PROV-CBSA = '   00' MOVE '   03' TO HOLD-PROV-CBSA.
171200
171300     SEARCH C-CBSA-DATA VARYING CU1
171400        AT END
171500           MOVE 60 TO PPS-RTC
171600        WHEN CBSAX-CBSA (CU1) = HOLD-PROV-CBSA
171700           SET CU2 TO CU1
171800           PERFORM 0650-N-GET-WAGE-INDX
171900             THRU 0650-N-EXIT VARYING CU2
172000             FROM CU1 BY 1 UNTIL
172100               CBSAX-CBSA (CU2) NOT = HOLD-PROV-CBSA.
172200
172300 0550-EXIT.
172400      EXIT.
172500
172600
172700******************************************************************
172800 0575-GET-IPPS-CBSA.
172900******************************************************************
173000
173100*------------------------------------------------------------*
173200* SET IPPS CBSA TO GEOGRAPHIC LOCATION CBSA IN PSF           *
173300*------------------------------------------------------------*
173400     MOVE P-NEW-GEO-LOC-CBSAX TO HOLD-PROV-IPPS-CBSA.
173500
173600
173700*6-20-16
173800*ADDED FOLLOWING LINE TO ALLOW LTCH PRICER TO WORK
173900*WITH THE NEW ARIZONA STATE CODE OF 00 -->
174000
174100     IF HOLD-PROV-IPPS-CBSA = '   00'
174200        MOVE '   03' TO HOLD-PROV-IPPS-CBSA.
174300
174400*------------------------------------------------------------*
174500* ASSIGN FY 2006 IPPS WAGE INDEX FLOORS                      *
174600*------------------------------------------------------------*
174700     IF B-DISCHARGE-DATE > 20050930 AND < 20061001
174800        PERFORM 0580-FY2006-FLOOR-CBSA THRU 0580-FY2006-EXIT
174900     END-IF.
175000
175100
175200*------------------------------------------------------------*
175300* ASSIGN FY 2007 IPPS WAGE INDEX FLOORS                      *
175400*------------------------------------------------------------*
175500     IF B-DISCHARGE-DATE > 20060930 AND < 20071001
175600        PERFORM 0580-FY2007-FLOOR-CBSA THRU 0580-FY2007-EXIT
175700     END-IF.
175800
175900
176000*------------------------------------------------------------*
176100* ASSIGN FY 2008 IPPS WAGE INDEX FLOORS                      *
176200*------------------------------------------------------------*
176300     IF B-DISCHARGE-DATE > 20070930 AND < 20081001
176400        PERFORM 0580-FY2008-FLOOR-CBSA THRU 0580-FY2008-EXIT
176500     END-IF.
176600
176700
176800*------------------------------------------------------------*
176900* ASSIGN FY 2009 IPPS WAGE INDEX FLOORS                      *
177000*------------------------------------------------------------*
177100     IF B-DISCHARGE-DATE > 20080930 AND < 20091001
177200        PERFORM 0580-FY2009-FLOOR-CBSA THRU 0580-FY2009-EXIT
177300     END-IF.
177400
177500
177600*------------------------------------------------------------*
177700* ASSIGN FY 2010 IPPS WAGE INDEX FLOORS                      *
177800*------------------------------------------------------------*
177900     IF B-DISCHARGE-DATE > 20090930 AND < 20101001
178000        PERFORM 0580-FY2010-FLOOR-CBSA THRU 0580-FY2010-EXIT
178100     END-IF.
178200
178300*------------------------------------------------------------*
178400* ASSIGN FY 2011 IPPS WAGE INDEX FLOORS                      *
178500*------------------------------------------------------------*
178600     IF B-DISCHARGE-DATE > 20100930 AND < 20111001
178700        PERFORM 0580-FY2011-FLOOR-CBSA THRU 0580-FY2011-EXIT
178800     END-IF.
178900
179000*------------------------------------------------------------*
179100* ASSIGN FY 2012 IPPS WAGE INDEX FLOORS                      *
179200*------------------------------------------------------------*
179300     IF B-DISCHARGE-DATE > 20110930 AND < 20121001
179400        PERFORM 0580-FY2012-FLOOR-CBSA THRU 0580-FY2012-EXIT
179500     END-IF.
179600
179700*------------------------------------------------------------*
179800* ASSIGN FY 2013 IPPS WAGE INDEX FLOORS                      *
179900*------------------------------------------------------------*
180000     IF B-DISCHARGE-DATE > 20120930 AND < 20131001
180100        PERFORM 0580-FY2013-FLOOR-CBSA THRU 0580-FY2013-EXIT
180200     END-IF.
180300
180400*------------------------------------------------------------*
180500* ASSIGN FY 2014 IPPS WAGE INDEX FLOORS                      *
180600*------------------------------------------------------------*
180700     IF B-DISCHARGE-DATE > 20130930 AND < 20141001
180800        PERFORM 0580-FY2014-FLOOR-CBSA THRU 0580-FY2014-EXIT
180900     END-IF.
181000
181100*------------------------------------------------------------*
181200* SEARCH TABLE FOR IPPS CBSA & GET WAGE INDEX                *
181300*------------------------------------------------------------*
181400     SEARCH T-CBSA-DATA VARYING MA1
181500        AT END
181600           MOVE 60 TO PPS-RTC
181700        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA
181800           SET MA2 TO MA1
181900           PERFORM 0675-N-GET-IPPS-WAGE-INDX
182000              THRU 0675-N-EXIT VARYING MA2
182100              FROM MA1 BY 1 UNTIL
182200                   T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA.
182300
182400
182500*------------------------------------------------------------*
182600* ASSIGN IPPS WAGE INDEX FLOORS FOR FY 2015 AND LATER        *
182700*------------------------------------------------------------*
182800     IF B-DISCHARGE-DATE > 20140930
182900        PERFORM 0580-FY2015-LATER-FLOOR-CBSA
183000           THRU 0580-FY2015-LATER-EXIT
183100     END-IF.
183200
183300
183400*------------------------------------------------------------*
183500* GET THE IPPS CBSA SIZE INDICATOR                           *
183600*------------------------------------------------------------*
183700* LOGIC REVISED 12/28/2006 FOR VERSION 08.0                  *
183800*------------------------------------------------------------*
183900     MOVE P-NEW-GEO-LOC-CBSAX TO HOLD-PROV-IPPS-CBSA.
184000
184100*6-20-16
184200*ADDED FOLLOWING LINE TO ALLOW LTCH PRICER TO WORK
184300*WITH THE NEW ARIZONA STATE CODE OF 00 -->
184400
184500     IF HOLD-PROV-IPPS-CBSA = '   00'
184600        MOVE '   03' TO HOLD-PROV-IPPS-CBSA.
184700
184800
184900     SET MA1 TO 1.
185000     SEARCH T-CBSA-DATA VARYING MA1
185100        AT END
185200           MOVE 60 TO PPS-RTC
185300        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA
185400           SET MA2 TO MA1.
185500
185600     IF PPS-RTC NOT = 60
185700        PERFORM 0585-GET-IPPS-CBSA-SIZE
185800           THRU 0585-EXIT VARYING MA2
185900           FROM MA1 BY 1 UNTIL
186000                T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA.
186100
186200
186300*------------------------------------------------------------*
186400* GET THE PUERTO RICO SPECIFIC WAGE INDEX FOR PR HOSPITALS   *
186500*------------------------------------------------------------*
186600     IF (B-DISCHARGE-DATE < 20161001) AND
186700        (P-NEW-STATE = 40 OR 84)
186800        PERFORM 0590-GET-IPPS-CBSA-PR THRU 0590-EXIT
186900        IF W-IPPS-PR-WAGE-INDEX = 0
187000           MOVE 52 TO PPS-RTC
187100        END-IF
187200     END-IF.
187300
187400
187500 0575-EXIT.
187600      EXIT.
187700
187800
187900******************************************************************
188000*                                                                *
188100* FLOOR ASSIGNMENTS FOR FY 2006 ONLY:                            *
188200*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
188300*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
188400*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
188500* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV063             *
188600*                                                                *
188700******************************************************************
188800 0580-FY2006-FLOOR-CBSA.
188900******************************************************************
189000
189100     IF HOLD-PROV-IPPS-CBSA = '   10'
189200        AND P-NEW-CBSA-SPEC-PAY-IND = 'Y'
189300        AND P-NEW-STATE = 10
189400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
189500            MOVE '   10' TO HOLD-PROV-IPPS-CBSA.
189600
189700     IF HOLD-PROV-IPPS-CBSA = '   50'
189800        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
189900        AND P-NEW-STATE = 50
190000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
190100            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
190200
190300     IF HOLD-PROV-IPPS-CBSA = '10900'
190400        AND P-NEW-STATE = 31
190500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
190600            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
190700
190800     IF HOLD-PROV-IPPS-CBSA = '15764'
190900        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
191000        AND P-NEW-STATE = 30
191100            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
191200            MOVE '   30' TO HOLD-PROV-IPPS-CBSA.
191300
191400     IF HOLD-PROV-IPPS-CBSA = '16620'
191500        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
191600        AND P-NEW-STATE = 36
191700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
191800            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
191900
192000     IF HOLD-PROV-IPPS-CBSA = '19060'
192100        AND P-NEW-STATE = 21
192200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
192300            MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
192400
192500     IF HOLD-PROV-IPPS-CBSA = '22020'
192600        AND P-NEW-STATE = 24
192700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
192800            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
192900
193000     IF HOLD-PROV-IPPS-CBSA = '24220'
193100        AND P-NEW-STATE = 24
193200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
193300            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
193400
193500     IF HOLD-PROV-IPPS-CBSA = '24580'
193600        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
193700        AND P-NEW-STATE = 52
193800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
193900            MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
194000
194100     IF HOLD-PROV-IPPS-CBSA = '25540'
194200        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
194300        AND P-NEW-STATE = 07
194400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
194500            MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
194600
194700     IF HOLD-PROV-IPPS-CBSA = '30300'
194800        AND P-NEW-STATE = 50
194900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
195000            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
195100
195200     IF HOLD-PROV-IPPS-CBSA = '37620'
195300        AND P-NEW-STATE = 36
195400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
195500            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
195600
195700     IF HOLD-PROV-IPPS-CBSA = '39900'
195800        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
195900        AND P-NEW-STATE = 05
196000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
196100            MOVE '   05' TO HOLD-PROV-IPPS-CBSA.
196200
196300     IF HOLD-PROV-IPPS-CBSA = '48260'
196400        AND P-NEW-STATE = 36
196500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
196600            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
196700
196800     IF HOLD-PROV-IPPS-CBSA = '48540'
196900        AND P-NEW-STATE = 36
197000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
197100            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
197200
197300     IF HOLD-PROV-IPPS-CBSA = '48540'
197400        AND P-NEW-STATE = 51
197500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
197600            MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
197700
197800     IF HOLD-PROV-IPPS-CBSA = '48864'
197900        AND P-NEW-STATE = 31
198000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
198100            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
198200
198300     IF HOLD-PROV-IPPS-CBSA = '49660'
198400        AND P-NEW-STATE = 36
198500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
198600            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
198700
198800
198900 0580-FY2006-EXIT.
199000      EXIT.
199100
199200
199300******************************************************************
199400*                                                                *
199500* FLOOR ASSIGNMENTS FOR FY 2007:                                 *
199600*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
199700*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
199800*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
199900* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV071             *
200000*                                                                *
200100******************************************************************
200200 0580-FY2007-FLOOR-CBSA.
200300******************************************************************
200400
200500     IF HOLD-PROV-IPPS-CBSA = '   10'
200600        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
200700        AND P-NEW-STATE = 10
200800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
200900            MOVE '   10' TO HOLD-PROV-IPPS-CBSA.
201000
201100     IF HOLD-PROV-IPPS-CBSA = '   14'
201200        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
201300        AND P-NEW-STATE = 14
201400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
201500            MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
201600
201700     IF HOLD-PROV-IPPS-CBSA = '   26'
201800        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
201900        AND P-NEW-STATE = 26
202000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
202100            MOVE '   26' TO HOLD-PROV-IPPS-CBSA.
202200
202300     IF HOLD-PROV-IPPS-CBSA = '   50'
202400        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
202500        AND P-NEW-STATE = 50
202600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
202700            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
202800
202900     IF HOLD-PROV-IPPS-CBSA = '10900'
203000        AND P-NEW-STATE = 31
203100            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
203200            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
203300
203400     IF HOLD-PROV-IPPS-CBSA = '19060'
203500        AND P-NEW-STATE = 21
203600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
203700            MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
203800
203900     IF HOLD-PROV-IPPS-CBSA = '22020'
204000        AND P-NEW-STATE = 24
204100            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
204200            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
204300
204400     IF HOLD-PROV-IPPS-CBSA = '24220'
204500        AND P-NEW-STATE = 24
204600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
204700            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
204800
204900     IF HOLD-PROV-IPPS-CBSA = '24580'
205000        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
205100        AND P-NEW-STATE = 52
205200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
205300            MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
205400
205500     IF HOLD-PROV-IPPS-CBSA = '25540'
205600        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
205700        AND P-NEW-STATE = 07
205800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
205900            MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
206000
206100     IF HOLD-PROV-IPPS-CBSA = '26580'
206200        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
206300        AND P-NEW-STATE = 36
206400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
206500            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
206600
206700
206800*----------------------------------------------------------*
206900*  ON AND AFTER 11/03/2006, NO HOSPITALS RECLASSIFYING TO  *
207000*  CBSA 27860 WILL RECEIVE ITS STATE FLOOR DUE TO THE WIX  *
207100*  CHANGE IN THE IPPS FINAL RULE 2007 CORRECTION NOTICE 1  *
207200*----------------------------------------------------------*
207300*  - LOGIC DISABLED 11-20-2006 FOR RELEASE 07.5            *
207400*  - REINSTATED & ALTERED 12-28-2006 FOR RELEASE 08.0 TO   *
207500*    MATCH THE IPPS PRICER (BECAUSE THIS CODE ONLY APPLIES *
207600*    RECLASS PROVIDERS AND THERE ARE NO LTCH RECLASS       *
207700*    PROVIDERS, THESE CHANGES DO NOT AFFECT BILL PAYMENT)  *
207800*----------------------------------------------------------*
207900     IF B-DISCHARGE-DATE < 20061103
208000        IF HOLD-PROV-IPPS-CBSA = '27860'
208100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
208200           AND P-NEW-STATE = 26
208300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
208400               MOVE '   26' TO HOLD-PROV-IPPS-CBSA.
208500*----------------------------------------------------------*
208600
208700
208800     IF HOLD-PROV-IPPS-CBSA = '29100'
208900        AND P-NEW-STATE = 52
209000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
209100            MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
209200
209300     IF HOLD-PROV-IPPS-CBSA = '30300'
209400        AND P-NEW-STATE = 50
209500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
209600            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
209700
209800     IF HOLD-PROV-IPPS-CBSA = '37620'
209900        AND P-NEW-STATE = 36
210000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
210100            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
210200
210300     IF HOLD-PROV-IPPS-CBSA = '37964'
210400        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
210500        AND P-NEW-STATE = 31
210600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
210700            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
210800
210900     IF HOLD-PROV-IPPS-CBSA = '38300'
211000        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
211100        AND P-NEW-STATE = 36
211200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
211300            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
211400
211500     IF HOLD-PROV-IPPS-CBSA = '39300'
211600        AND P-NEW-STATE = 22
211700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
211800            MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
211900
212000     IF HOLD-PROV-IPPS-CBSA = '39300'
212100        AND P-NEW-STATE = 41
212200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
212300            MOVE '   41' TO HOLD-PROV-IPPS-CBSA.
212400
212500     IF HOLD-PROV-IPPS-CBSA = '45500'
212600        AND P-NEW-STATE = 45
212700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
212800            MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
212900
213000     IF HOLD-PROV-IPPS-CBSA = '48260'
213100        AND P-NEW-STATE = 36
213200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
213300            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
213400
213500     IF HOLD-PROV-IPPS-CBSA = '48540'
213600        AND P-NEW-STATE = 36
213700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
213800            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
213900
214000     IF HOLD-PROV-IPPS-CBSA = '48540'
214100        AND P-NEW-STATE = 51
214200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
214300            MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
214400
214500     IF HOLD-PROV-IPPS-CBSA = '48864'
214600        AND P-NEW-STATE = 31
214700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
214800            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
214900
215000
215100 0580-FY2007-EXIT.
215200      EXIT.
215300
215400
215500******************************************************************
215600*                                                                *
215700* FLOOR ASSIGNMENTS FOR FY 2008:                                 *
215800*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
215900*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
216000*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
216100* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV080             *
216200*                                                                *
216300******************************************************************
216400 0580-FY2008-FLOOR-CBSA.
216500******************************************************************
216600
216700        IF HOLD-PROV-IPPS-CBSA = '   39'
216800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
216900           AND P-NEW-STATE = 33
217000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
217100               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
217200
217300        IF HOLD-PROV-IPPS-CBSA = '   39'
217400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
217500           AND P-NEW-STATE = 39
217600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
217700               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
217800
217900        IF HOLD-PROV-IPPS-CBSA = '10900'
218000           AND P-NEW-STATE = 31
218100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
218200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
218300
218400        IF HOLD-PROV-IPPS-CBSA = '19060'
218500           AND P-NEW-STATE = 21
218600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
218700               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
218800
218900        IF HOLD-PROV-IPPS-CBSA = '21780'
219000           AND P-NEW-STATE = 15
219100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
219200               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
219300
219400        IF HOLD-PROV-IPPS-CBSA = '21780'
219500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
219600           AND P-NEW-STATE = 15
219700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
219800               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
219900
220000        IF HOLD-PROV-IPPS-CBSA = '22020'
220100           AND P-NEW-STATE = 24
220200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
220300               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
220400
220500        IF HOLD-PROV-IPPS-CBSA = '24220'
220600           AND P-NEW-STATE = 24
220700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
220800               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
220900
221000        IF HOLD-PROV-IPPS-CBSA = '24580'
221100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
221200           AND P-NEW-STATE = 52
221300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
221400               MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
221500
221600        IF HOLD-PROV-IPPS-CBSA = '25540'
221700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
221800           AND P-NEW-STATE = 07
221900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
222000               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
222100
222200        IF HOLD-PROV-IPPS-CBSA = '28420'
222300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
222400           AND P-NEW-STATE = 50
222500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
222600               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
222700
222800        IF HOLD-PROV-IPPS-CBSA = '28700'
222900           AND P-NEW-STATE = 44
223000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
223100               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
223200
223300        IF HOLD-PROV-IPPS-CBSA = '28700'
223400           AND P-NEW-STATE = 49
223500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
223600               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
223700
223800        IF HOLD-PROV-IPPS-CBSA = '30300'
223900           AND P-NEW-STATE = 50
224000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
224100               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
224200
224300        IF HOLD-PROV-IPPS-CBSA = '35084'
224400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
224500           AND P-NEW-STATE = 31
224600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
224700               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
224800
224900        IF HOLD-PROV-IPPS-CBSA = '37620'
225000           AND P-NEW-STATE = 36
225100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
225200               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
225300
225400        IF HOLD-PROV-IPPS-CBSA = '37964'
225500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
225600           AND P-NEW-STATE = 31
225700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
225800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
225900
226000        IF HOLD-PROV-IPPS-CBSA = '38300'
226100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
226200           AND P-NEW-STATE = 36
226300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
226400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
226500
226600        IF HOLD-PROV-IPPS-CBSA = '45500'
226700           AND P-NEW-STATE = 45
226800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
226900               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
227000
227100        IF HOLD-PROV-IPPS-CBSA = '48260'
227200           AND P-NEW-STATE = 36
227300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
227400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
227500
227600        IF HOLD-PROV-IPPS-CBSA = '48540'
227700           AND P-NEW-STATE = 36
227800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
227900               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
228000
228100        IF HOLD-PROV-IPPS-CBSA = '48540'
228200           AND P-NEW-STATE = 51
228300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
228400               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
228500
228600        IF HOLD-PROV-IPPS-CBSA = '48864'
228700           AND P-NEW-STATE = 31
228800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
228900               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
229000
229100        IF HOLD-PROV-IPPS-CBSA = '48864'
229200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
229300           AND P-NEW-STATE = 31
229400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
229500               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
229600
229700
229800 0580-FY2008-EXIT.
229900      EXIT.
230000
230100
230200******************************************************************
230300*                                                                *
230400* FLOOR ASSIGNMENTS FOR FY 2009:                                 *
230500*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
230600*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
230700*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
230800* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV093             *
230900*                                                                *
231000******************************************************************
231100 0580-FY2009-FLOOR-CBSA.
231200******************************************************************
231300
231400        IF HOLD-PROV-IPPS-CBSA = '   04'
231500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
231600           AND P-NEW-STATE = 04
231700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
231800               MOVE '   04' TO HOLD-PROV-IPPS-CBSA.
231900
232000        IF HOLD-PROV-IPPS-CBSA = '   04'
232100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
232200           AND P-NEW-STATE = 19
232300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
232400               MOVE '   19' TO HOLD-PROV-IPPS-CBSA.
232500
232600        IF HOLD-PROV-IPPS-CBSA = '   14'
232700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
232800           AND P-NEW-STATE = 14
232900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
233000               MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
233100
233200        IF HOLD-PROV-IPPS-CBSA = '   14'
233300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
233400           AND P-NEW-STATE = 26
233500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
233600               MOVE '   26' TO HOLD-PROV-IPPS-CBSA.
233700
233800        IF HOLD-PROV-IPPS-CBSA = '10900'
233900           AND P-NEW-STATE = 31
234000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
234100               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
234200
234300        IF HOLD-PROV-IPPS-CBSA = '19340'
234400           AND P-NEW-STATE = 16
234500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
234600               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
234700
234800        IF HOLD-PROV-IPPS-CBSA = '21780'
234900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
235000           AND P-NEW-STATE = 15
235100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
235200               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
235300
235400        IF HOLD-PROV-IPPS-CBSA = '22020'
235500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
235600           AND P-NEW-STATE = 43
235700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
235800               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
235900
236000        IF HOLD-PROV-IPPS-CBSA = '22900'
236100           AND P-NEW-STATE = 37
236200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
236300               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
236400
236500        IF HOLD-PROV-IPPS-CBSA = '24580'
236600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
236700           AND P-NEW-STATE = 52
236800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
236900               MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
237000
237100        IF HOLD-PROV-IPPS-CBSA = '25540'
237200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
237300           AND P-NEW-STATE = 07
237400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
237500               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
237600
237700        IF HOLD-PROV-IPPS-CBSA = '28420'
237800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
237900           AND P-NEW-STATE = 50
238000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
238100               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
238200
238300        IF HOLD-PROV-IPPS-CBSA = '28700'
238400           AND P-NEW-STATE = 44
238500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
238600               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
238700
238800        IF HOLD-PROV-IPPS-CBSA = '28700'
238900           AND P-NEW-STATE = 49
239000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
239100               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
239200
239300        IF HOLD-PROV-IPPS-CBSA = '28700'
239400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
239500           AND P-NEW-STATE = 18
239600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
239700               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
239800
239900        IF HOLD-PROV-IPPS-CBSA = '28700'
240000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
240100           AND P-NEW-STATE = 44
240200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
240300               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
240400
240500        IF HOLD-PROV-IPPS-CBSA = '28940'
240600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
240700           AND P-NEW-STATE = 18
240800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
240900               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
241000
241100        IF HOLD-PROV-IPPS-CBSA = '28940'
241200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
241300           AND P-NEW-STATE = 44
241400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
241500               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
241600
241700        IF HOLD-PROV-IPPS-CBSA = '34820'
241800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
241900           AND P-NEW-STATE = 34
242000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
242100               MOVE '   34' TO HOLD-PROV-IPPS-CBSA.
242200
242300        IF HOLD-PROV-IPPS-CBSA = '34820'
242400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
242500           AND P-NEW-STATE = 42
242600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
242700               MOVE '   42' TO HOLD-PROV-IPPS-CBSA.
242800
242900        IF HOLD-PROV-IPPS-CBSA = '37620'
243000           AND P-NEW-STATE = 36
243100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
243200               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
243300
243400        IF HOLD-PROV-IPPS-CBSA = '37964'
243500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
243600           AND P-NEW-STATE = 31
243700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
243800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
243900
244000        IF HOLD-PROV-IPPS-CBSA = '38340'
244100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
244200           AND P-NEW-STATE = 47
244300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
244400               MOVE '   47' TO HOLD-PROV-IPPS-CBSA.
244500
244600        IF HOLD-PROV-IPPS-CBSA = '41620'
244700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
244800           AND P-NEW-STATE = 29
244900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
245000               MOVE '   29' TO HOLD-PROV-IPPS-CBSA.
245100
245200        IF HOLD-PROV-IPPS-CBSA = '43580'
245300           AND P-NEW-STATE = 16
245400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
245500               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
245600
245700        IF HOLD-PROV-IPPS-CBSA = '48540'
245800           AND P-NEW-STATE = 36
245900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
246000               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
246100
246200        IF HOLD-PROV-IPPS-CBSA = '48540'
246300           AND P-NEW-STATE = 51
246400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
246500               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
246600
246700        IF HOLD-PROV-IPPS-CBSA = '48864'
246800           AND P-NEW-STATE = 31
246900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
247000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
247100
247200        IF HOLD-PROV-IPPS-CBSA = '48864'
247300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
247400           AND P-NEW-STATE = 31
247500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
247600               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
247700
247800        IF HOLD-PROV-IPPS-CBSA = '19060'
247900           AND P-NEW-STATE = 21
248000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
248100               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
248200
248300        IF HOLD-PROV-IPPS-CBSA = '19060'
248400           AND P-NEW-STATE = 51
248500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
248600               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
248700
248800        IF HOLD-PROV-IPPS-CBSA = '22020'
248900           AND P-NEW-STATE = 24
249000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
249100               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
249200
249300        IF HOLD-PROV-IPPS-CBSA = '24220'
249400           AND P-NEW-STATE = 24
249500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
249600               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
249700
249800        IF HOLD-PROV-IPPS-CBSA = '30300'
249900           AND P-NEW-STATE = 50
250000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
250100               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
250200
250300        IF HOLD-PROV-IPPS-CBSA = '48260'
250400           AND P-NEW-STATE = 36
250500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
250600               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
250700
250800
250900 0580-FY2009-EXIT.
251000      EXIT.
251100
251200
251300******************************************************************
251400*                                                                *
251500* FLOOR ASSIGNMENTS FOR FY 2010:                                 *
251600*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
251700*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
251800*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
251900* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV100             *
252000*                                                                *
252100******************************************************************
252200 0580-FY2010-FLOOR-CBSA.
252300******************************************************************
252400
252500        IF HOLD-PROV-IPPS-CBSA = '   33'
252600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
252700           AND P-NEW-STATE = 30
252800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
252900               MOVE '   30' TO HOLD-PROV-IPPS-CBSA.
253000
253100        IF HOLD-PROV-IPPS-CBSA = '   33'
253200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
253300           AND P-NEW-STATE = 33
253400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
253500               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
253600
253700        IF HOLD-PROV-IPPS-CBSA = '10900'
253800           AND P-NEW-STATE = 31
253900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
254000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
254100
254200        IF HOLD-PROV-IPPS-CBSA = '19340'
254300           AND P-NEW-STATE = 16
254400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
254500               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
254600
254700        IF HOLD-PROV-IPPS-CBSA = '19340'
254800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
254900           AND P-NEW-STATE = 16
255000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
255100               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
255200
255300        IF HOLD-PROV-IPPS-CBSA = '21780'
255400           AND P-NEW-STATE = 15
255500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
255600               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
255700
255800        IF HOLD-PROV-IPPS-CBSA = '21780'
255900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
256000           AND P-NEW-STATE = 15
256100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
256200               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
256300
256400        IF HOLD-PROV-IPPS-CBSA = '25180'
256500           AND P-NEW-STATE = 21
256600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
256700               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
256800
256900        IF HOLD-PROV-IPPS-CBSA = '25540'
257000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
257100           AND P-NEW-STATE = 07
257200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
257300               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
257400
257500        IF HOLD-PROV-IPPS-CBSA = '28420'
257600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
257700           AND P-NEW-STATE = 50
257800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
257900               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
258000
258100        IF HOLD-PROV-IPPS-CBSA = '28940'
258200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
258300           AND P-NEW-STATE = 18
258400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
258500               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
258600
258700        IF HOLD-PROV-IPPS-CBSA = '28940'
258800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
258900           AND P-NEW-STATE = 44
259000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
259100               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
259200
259300        IF HOLD-PROV-IPPS-CBSA = '35084'
259400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
259500           AND P-NEW-STATE = 31
259600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
259700               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
259800
259900        IF HOLD-PROV-IPPS-CBSA = '37620'
260000           AND P-NEW-STATE = 36
260100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
260200               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
260300
260400        IF HOLD-PROV-IPPS-CBSA = '37964'
260500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
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 = '48540'
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 = '48540'
261600           AND P-NEW-STATE = 51
261700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
261800               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
261900
262000        IF HOLD-PROV-IPPS-CBSA = '48864'
262100           AND P-NEW-STATE = 31
262200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
262300               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
262400
262500        IF HOLD-PROV-IPPS-CBSA = '48864'
262600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
262700           AND P-NEW-STATE = 31
262800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
262900               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
263000
263100        IF HOLD-PROV-IPPS-CBSA = '49660'
263200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
263300           AND P-NEW-STATE = 36
263400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
263500               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
263600
263700        IF HOLD-PROV-IPPS-CBSA = '19060'
263800           AND P-NEW-STATE = 21
263900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
264000               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
264100
264200        IF HOLD-PROV-IPPS-CBSA = '22020'
264300           AND P-NEW-STATE = 24
264400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
264500               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
264600
264700        IF HOLD-PROV-IPPS-CBSA = '24220'
264800           AND P-NEW-STATE = 24
264900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
265000               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
265100
265200        IF HOLD-PROV-IPPS-CBSA = '30300'
265300           AND P-NEW-STATE = 50
265400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
265500               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
265600
265700        IF HOLD-PROV-IPPS-CBSA = '35084'
265800           AND P-NEW-STATE = 31
265900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
266000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
266100
266200        IF HOLD-PROV-IPPS-CBSA = '48260'
266300           AND P-NEW-STATE = 36
266400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
266500               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
266600
266700        IF HOLD-PROV-IPPS-CBSA = '48260'
266800           AND P-NEW-STATE = 51
266900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
267000               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
267100
267200
267300 0580-FY2010-EXIT.
267400      EXIT.
267500
267600******************************************************************
267700*                                                                *
267800* FLOOR ASSIGNMENTS FOR FY 2011:                                 *
267900* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV110             *
268000*                                                                *
268100******************************************************************
268200
268300 0580-FY2011-FLOOR-CBSA.
268400
268500        IF HOLD-PROV-IPPS-CBSA = '   45'
268600          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
268700          AND P-NEW-STATE = 45
268800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
268900               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
269000
269100        IF HOLD-PROV-IPPS-CBSA = '   37'
269200          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
269300          AND P-NEW-STATE = 37
269400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
269500               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
269600
269700        IF HOLD-PROV-IPPS-CBSA = '10900'
269800           AND P-NEW-STATE = 31
269900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
270000               MOVE '   31' 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 = 33
270500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
270600               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
270700
270800        IF HOLD-PROV-IPPS-CBSA = '21500'
270900          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
271000           AND P-NEW-STATE = 39
271100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
271200               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
271300
271400        IF HOLD-PROV-IPPS-CBSA = '21780'
271500           AND P-NEW-STATE = 15
271600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
271700               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
271800
271900        IF HOLD-PROV-IPPS-CBSA = '22900'
272000           AND P-NEW-STATE = 37
272100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
272200               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
272300
272400        IF HOLD-PROV-IPPS-CBSA = '24540'
272500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
272600           AND P-NEW-STATE = 53
272700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
272800               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.
272900
273000        IF HOLD-PROV-IPPS-CBSA = '25540'
273100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
273200           AND P-NEW-STATE = 07
273300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
273400               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
273500
273600        IF HOLD-PROV-IPPS-CBSA = '28700'
273700           AND P-NEW-STATE = 44
273800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
273900               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
274000
274100        IF HOLD-PROV-IPPS-CBSA = '28700'
274200           AND P-NEW-STATE = 49
274300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
274400               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
274500
274600        IF HOLD-PROV-IPPS-CBSA = '28940'
274700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
274800           AND P-NEW-STATE = 18
274900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
275000               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
275100
275200        IF HOLD-PROV-IPPS-CBSA = '28940'
275300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
275400           AND P-NEW-STATE = 44
275500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
275600               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
275700
275800        IF HOLD-PROV-IPPS-CBSA = '37620'
275900           AND P-NEW-STATE = 36
276000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
276100               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
276200
276300        IF HOLD-PROV-IPPS-CBSA = '37620'
276400           AND P-NEW-STATE = 51
276500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
276600               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
276700
276800        IF HOLD-PROV-IPPS-CBSA = '37964'
276900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
277000           AND P-NEW-STATE = 31
277100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
277200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
277300
277400        IF HOLD-PROV-IPPS-CBSA = '38300'
277500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
277600           AND P-NEW-STATE = 36
277700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
277800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
277900
278000        IF HOLD-PROV-IPPS-CBSA = '38300'
278100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
278200           AND P-NEW-STATE = 39
278300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
278400               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
278500
278600        IF HOLD-PROV-IPPS-CBSA = '43580'
278700           AND P-NEW-STATE = 43
278800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
278900               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
279000
279100        IF HOLD-PROV-IPPS-CBSA = '48540'
279200           AND P-NEW-STATE = 36
279300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
279400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
279500
279600        IF HOLD-PROV-IPPS-CBSA = '48540'
279700           AND P-NEW-STATE = 51
279800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
279900               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
280000
280100        IF HOLD-PROV-IPPS-CBSA = '48864'
280200           AND P-NEW-STATE = 31
280300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
280400               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
280500
280600        IF HOLD-PROV-IPPS-CBSA = '17300'
280700           AND P-NEW-STATE = 18
280800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
280900               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
281000
281100        IF HOLD-PROV-IPPS-CBSA = '17300'
281200           AND P-NEW-STATE = 44
281300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
281400               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
281500
281600        IF HOLD-PROV-IPPS-CBSA = '19060'
281700           AND P-NEW-STATE = 21
281800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
281900               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
282000
282100        IF HOLD-PROV-IPPS-CBSA = '22020'
282200           AND P-NEW-STATE = 24
282300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
282400               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
282500
282600        IF HOLD-PROV-IPPS-CBSA = '22020'
282700           AND P-NEW-STATE = 35
282800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
282900               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
283000
283100        IF HOLD-PROV-IPPS-CBSA = '24220'
283200           AND P-NEW-STATE = 24
283300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
283400               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
283500
283600        IF HOLD-PROV-IPPS-CBSA = '24220'
283700           AND P-NEW-STATE = 35
283800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
283900               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
284000
284100        IF HOLD-PROV-IPPS-CBSA = '30300'
284200           AND P-NEW-STATE = 50
284300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
284400               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
284500
284600        IF HOLD-PROV-IPPS-CBSA = '44600'
284700           AND P-NEW-STATE = 36
284800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
284900               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
285000
285100        IF HOLD-PROV-IPPS-CBSA = '44600'
285200           AND P-NEW-STATE = 51
285300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
285400               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
285500
285600        IF HOLD-PROV-IPPS-CBSA = '45500'
285700           AND P-NEW-STATE = 45
285800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
285900               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
286000
286100
286200 0580-FY2011-EXIT.
286300      EXIT.
286400
286500******************************************************************
286600*                                                                *
286700* FLOOR ASSIGNMENTS FOR FY 2012:                                 *
286800* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV120             *
286900*                                                                *
287000* ******* CHANGE HOLD-PROV-CBSA TO HOLD-PROV-IPPS-CBSA ******    *
287100*                                                                *
287200******************************************************************
287300
287400 0580-FY2012-FLOOR-CBSA.
287500
287600**************YEARCHANGE 2012.0 ******************************
287700
287800        IF HOLD-PROV-IPPS-CBSA = '   30'
287900          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
288000          AND P-NEW-STATE = 30
288100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
288200               MOVE '   30' TO HOLD-PROV-IPPS-CBSA.
288300
288400        IF HOLD-PROV-IPPS-CBSA = '   39'
288500          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
288600          AND P-NEW-STATE = 39
288700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
288800               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
288900
289000        IF HOLD-PROV-IPPS-CBSA = '   39'
289100          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
289200          AND P-NEW-STATE = 33
289300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
289400               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
289500
289600        IF HOLD-PROV-IPPS-CBSA = '10900'
289700           AND P-NEW-STATE = 31
289800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
289900               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
290000
290100        IF HOLD-PROV-IPPS-CBSA = '14484'
290200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
290300           AND P-NEW-STATE = 22
290400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
290500               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
290600
290700        IF HOLD-PROV-IPPS-CBSA = '16020'
290800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
290900           AND P-NEW-STATE = 14
291000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
291100               MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
291200
291300        IF HOLD-PROV-IPPS-CBSA = '21500'
291400          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
291500           AND P-NEW-STATE = 33
291600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
291700               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
291800
291900        IF HOLD-PROV-IPPS-CBSA = '21500'
292000          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
292100           AND P-NEW-STATE = 39
292200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
292300               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
292400
292500        IF HOLD-PROV-IPPS-CBSA = '22900'
292600           AND P-NEW-STATE = 37
292700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
292800               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
292900
293000        IF HOLD-PROV-IPPS-CBSA = '25180'
293100           AND P-NEW-STATE = 21
293200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
293300               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
293400
293500        IF HOLD-PROV-IPPS-CBSA = '25540'
293600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
293700           AND P-NEW-STATE = 07
293800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
293900               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
294000
294100        IF HOLD-PROV-IPPS-CBSA = '25540'
294200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
294300           AND P-NEW-STATE = 22
294400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
294500               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
294600
294700        IF HOLD-PROV-IPPS-CBSA = '26820'
294800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
294900           AND P-NEW-STATE = 53
295000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
295100               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.
295200
295300        IF HOLD-PROV-IPPS-CBSA = '28700'
295400           AND P-NEW-STATE = 44
295500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
295600               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
295700
295800        IF HOLD-PROV-IPPS-CBSA = '28700'
295900           AND P-NEW-STATE = 49
296000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
296100               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
296200
296300        IF HOLD-PROV-IPPS-CBSA = '28700'
296400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
296500           AND P-NEW-STATE = 18
296600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
296700               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
296800
296900        IF HOLD-PROV-IPPS-CBSA = '28700'
297000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
297100           AND P-NEW-STATE = 44
297200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
297300               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
297400
297500        IF HOLD-PROV-IPPS-CBSA = '28940'
297600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
297700           AND P-NEW-STATE = 18
297800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
297900               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
298000
298100        IF HOLD-PROV-IPPS-CBSA = '35084'
298200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
298300           AND P-NEW-STATE = 31
298400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
298500               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
298600
298700        IF HOLD-PROV-IPPS-CBSA = '37620'
298800           AND P-NEW-STATE = 36
298900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
299000               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
299100
299200        IF HOLD-PROV-IPPS-CBSA = '37964'
299300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
299400           AND P-NEW-STATE = 31
299500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
299600               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
299700
299800        IF HOLD-PROV-IPPS-CBSA = '43580'
299900           AND P-NEW-STATE = 43
300000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
300100               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
300200
300300        IF HOLD-PROV-IPPS-CBSA = '44600'
300400           AND P-NEW-STATE = 36
300500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
300600               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
300700
300800        IF HOLD-PROV-IPPS-CBSA = '44600'
300900           AND P-NEW-STATE = 51
301000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
301100               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
301200
301300        IF HOLD-PROV-IPPS-CBSA = '48540'
301400           AND P-NEW-STATE = 36
301500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
301600               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
301700
301800        IF HOLD-PROV-IPPS-CBSA = '48540'
301900           AND P-NEW-STATE = 51
302000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
302100               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
302200
302300        IF HOLD-PROV-IPPS-CBSA = '48864'
302400           AND P-NEW-STATE = 31
302500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
302600               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
302700
302800        IF HOLD-PROV-IPPS-CBSA = '49660'
302900           AND P-NEW-STATE = 36
303000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
303100               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
303200
303300        IF HOLD-PROV-IPPS-CBSA = '49660'
303400           AND P-NEW-STATE = 39
303500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
303600               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
303700
303800        IF HOLD-PROV-IPPS-CBSA = '19060'
303900           AND P-NEW-STATE = 21
304000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
304100               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
304200
304300        IF HOLD-PROV-IPPS-CBSA = '22020'
304400           AND P-NEW-STATE = 24
304500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
304600               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
304700
304800        IF HOLD-PROV-IPPS-CBSA = '22020'
304900           AND P-NEW-STATE = 35
305000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
305100               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
305200
305300        IF HOLD-PROV-IPPS-CBSA = '24220'
305400           AND P-NEW-STATE = 24
305500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
305600               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
305700
305800        IF HOLD-PROV-IPPS-CBSA = '24220'
305900           AND P-NEW-STATE = 35
306000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
306100               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
306200
306300        IF HOLD-PROV-IPPS-CBSA = '30300'
306400           AND P-NEW-STATE = 50
306500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
306600               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
306700
306800        IF HOLD-PROV-IPPS-CBSA = '30860'
306900           AND P-NEW-STATE = 46
307000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
307100               MOVE '   46' TO HOLD-PROV-IPPS-CBSA.
307200
307300        IF HOLD-PROV-IPPS-CBSA = '35084'
307400           AND P-NEW-STATE = 31
307500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
307600               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
307700
307800        IF HOLD-PROV-IPPS-CBSA = '39300'
307900           AND P-NEW-STATE = 22
308000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
308100               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
308200
308300        IF HOLD-PROV-IPPS-CBSA = '45500'
308400           AND P-NEW-STATE = 45
308500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
308600               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
308700
308800**************YEARCHANGE 2012.0 ******************************
308900
309000 0580-FY2012-EXIT.
309100      EXIT.
309200
309300 0580-FY2013-FLOOR-CBSA.
309400
309500**************YEARCHANGE 2013.0 ****************************
309600
309700        IF HOLD-PROV-IPPS-CBSA = '10900'
309800           AND P-NEW-STATE = 31
309900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
310000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
310100
310200        IF HOLD-PROV-IPPS-CBSA = '14484'
310300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
310400           AND P-NEW-STATE = 22
310500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
310600               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
310700
310800        IF HOLD-PROV-IPPS-CBSA = '16020'
310900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
311000           AND P-NEW-STATE = 14
311100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
311200               MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
311300
311400        IF HOLD-PROV-IPPS-CBSA = '21500'
311500          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
311600           AND P-NEW-STATE = 33
311700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
311800               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
311900
312000        IF HOLD-PROV-IPPS-CBSA = '21500'
312100          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
312200           AND P-NEW-STATE = 39
312300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
312400               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
312500
312600        IF HOLD-PROV-IPPS-CBSA = '21780'
312700          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
312800           AND P-NEW-STATE = 15
312900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
313000               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
313100
313200        IF HOLD-PROV-IPPS-CBSA = '24580'
313300          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
313400           AND P-NEW-STATE = 52
313500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
313600               MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
313700
313800        IF HOLD-PROV-IPPS-CBSA = '25540'
313900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
314000           AND P-NEW-STATE = 07
314100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
314200               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
314300
314400        IF HOLD-PROV-IPPS-CBSA = '25540'
314500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
314600           AND P-NEW-STATE = 22
314700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
314800               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
314900
315000        IF HOLD-PROV-IPPS-CBSA = '26820'
315100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
315200           AND P-NEW-STATE = 53
315300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
315400               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.
315500
315600        IF HOLD-PROV-IPPS-CBSA = '27900'
315700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
315800           AND P-NEW-STATE = 17
315900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
316000               MOVE '   17' TO HOLD-PROV-IPPS-CBSA.
316100
316200        IF HOLD-PROV-IPPS-CBSA = '28700'
316300           AND P-NEW-STATE = 44
316400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
316500               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
316600
316700        IF HOLD-PROV-IPPS-CBSA = '28700'
316800           AND P-NEW-STATE = 49
316900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
317000               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
317100
317200        IF HOLD-PROV-IPPS-CBSA = '28700'
317300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
317400           AND P-NEW-STATE = 18
317500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
317600               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
317700
317800        IF HOLD-PROV-IPPS-CBSA = '28700'
317900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
318000           AND P-NEW-STATE = 44
318100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
318200               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
318300
318400        IF HOLD-PROV-IPPS-CBSA = '28940'
318500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
318600           AND P-NEW-STATE = 18
318700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
318800               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
318900
319000        IF HOLD-PROV-IPPS-CBSA = '35084'
319100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
319200           AND P-NEW-STATE = 31
319300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
319400               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
319500
319600        IF HOLD-PROV-IPPS-CBSA = '37620'
319700           AND P-NEW-STATE = 36
319800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
319900               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
320000
320100        IF HOLD-PROV-IPPS-CBSA = '37964'
320200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
320300           AND P-NEW-STATE = 31
320400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
320500               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
320600
320700        IF HOLD-PROV-IPPS-CBSA = '38300'
320800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
320900           AND P-NEW-STATE = 36
321000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
321100               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
321200
321300        IF HOLD-PROV-IPPS-CBSA = '43580'
321400           AND P-NEW-STATE = 43
321500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
321600               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
321700
321800        IF HOLD-PROV-IPPS-CBSA = '48540'
321900           AND P-NEW-STATE = 36
322000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
322100               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
322200
322300        IF HOLD-PROV-IPPS-CBSA = '48540'
322400           AND P-NEW-STATE = 51
322500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
322600               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
322700
322800        IF HOLD-PROV-IPPS-CBSA = '48864'
322900           AND P-NEW-STATE = 31
323000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
323100               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
323200
323300        IF HOLD-PROV-IPPS-CBSA = '49660'
323400           AND P-NEW-STATE = 36
323500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
323600               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
323700
323800        IF HOLD-PROV-IPPS-CBSA = '49660'
323900           AND P-NEW-STATE = 39
324000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
324100               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
324200
324300        IF HOLD-PROV-IPPS-CBSA = '22020'
324400           AND P-NEW-STATE = 24
324500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
324600               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
324700
324800        IF HOLD-PROV-IPPS-CBSA = '22020'
324900           AND P-NEW-STATE = 35
325000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
325100               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
325200
325300        IF HOLD-PROV-IPPS-CBSA = '24220'
325400           AND P-NEW-STATE = 24
325500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
325600               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
325700
325800        IF HOLD-PROV-IPPS-CBSA = '24220'
325900           AND P-NEW-STATE = 35
326000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
326100               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
326200
326300        IF HOLD-PROV-IPPS-CBSA = '30300'
326400           AND P-NEW-STATE = 50
326500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
326600               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
326700
326800        IF HOLD-PROV-IPPS-CBSA = '39300'
326900           AND P-NEW-STATE = 22
327000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
327100               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
327200
327300        IF HOLD-PROV-IPPS-CBSA = '39300'
327400           AND P-NEW-STATE = 41
327500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
327600               MOVE '   41' TO HOLD-PROV-IPPS-CBSA.
327700
327800        IF HOLD-PROV-IPPS-CBSA = '44600'
327900           AND P-NEW-STATE = 36
328000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
328100               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
328200
328300 0580-FY2013-EXIT.
328400      EXIT.
328500
328600 0580-FY2014-FLOOR-CBSA.
328700
328800**************YEARCHANGE 2014.0 ******************************
328900
329000        IF HOLD-PROV-IPPS-CBSA = '   07'
329100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
329200           AND P-NEW-STATE = 07
329300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
329400               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
329500
329600        IF HOLD-PROV-IPPS-CBSA = '   36'
329700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
329800           AND P-NEW-STATE = 36
329900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
330000               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
330100
330200        IF HOLD-PROV-IPPS-CBSA = '10900'
330300           AND P-NEW-STATE = 31
330400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
330500               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
330600
330700        IF HOLD-PROV-IPPS-CBSA = '14484'
330800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
330900           AND P-NEW-STATE = 22
331000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
331100               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
331200
331300        IF HOLD-PROV-IPPS-CBSA = '17300'
331400           AND P-NEW-STATE = 18
331500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
331600               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
331700
331800        IF HOLD-PROV-IPPS-CBSA = '22900'
331900           AND P-NEW-STATE = 37
332000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
332100               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
332200
332300        IF HOLD-PROV-IPPS-CBSA = '25540'
332400          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
332500           AND P-NEW-STATE = 07
332600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
332700               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
332800
332900        IF HOLD-PROV-IPPS-CBSA = '25540'
333000          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
333100           AND P-NEW-STATE = 22
333200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
333300               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
333400
333500        IF HOLD-PROV-IPPS-CBSA = '26820'
333600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
333700           AND P-NEW-STATE = 53
333800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
333900               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.
334000
334100        IF HOLD-PROV-IPPS-CBSA = '27180'
334200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
334300           AND P-NEW-STATE = 25
334400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
334500               MOVE '   25' TO HOLD-PROV-IPPS-CBSA.
334600
334700        IF HOLD-PROV-IPPS-CBSA = '28700'
334800           AND P-NEW-STATE = 44
334900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
335000               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
335100
335200        IF HOLD-PROV-IPPS-CBSA = '28700'
335300           AND P-NEW-STATE = 49
335400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
335500               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
335600
335700        IF HOLD-PROV-IPPS-CBSA = '35644'
335800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
335900           AND P-NEW-STATE = 07
336000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
336100               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
336200
336300        IF HOLD-PROV-IPPS-CBSA = '37620'
336400           AND P-NEW-STATE = 36
336500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
336600               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
336700
336800        IF HOLD-PROV-IPPS-CBSA = '43580'
336900           AND P-NEW-STATE = 43
337000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
337100               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
337200
337300        IF HOLD-PROV-IPPS-CBSA = '48540'
337400           AND P-NEW-STATE = 36
337500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
337600               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
337700
337800        IF HOLD-PROV-IPPS-CBSA = '48540'
337900           AND P-NEW-STATE = 51
338000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
338100               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
338200
338300        IF HOLD-PROV-IPPS-CBSA = '48864'
338400           AND P-NEW-STATE = 31
338500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
338600               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
338700
338800        IF HOLD-PROV-IPPS-CBSA = '49660'
338900           AND P-NEW-STATE = 36
339000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
339100               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
339200
339300        IF HOLD-PROV-IPPS-CBSA = '49660'
339400           AND P-NEW-STATE = 39
339500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
339600               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
339700
339800        IF HOLD-PROV-IPPS-CBSA = '19060'
339900           AND P-NEW-STATE = 21
340000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
340100               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
340200
340300        IF HOLD-PROV-IPPS-CBSA = '22020'
340400           AND P-NEW-STATE = 24
340500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
340600               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
340700
340800        IF HOLD-PROV-IPPS-CBSA = '22020'
340900           AND P-NEW-STATE = 35
341000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
341100               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
341200
341300        IF HOLD-PROV-IPPS-CBSA = '24220'
341400           AND P-NEW-STATE = 24
341500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
341600               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
341700
341800        IF HOLD-PROV-IPPS-CBSA = '24220'
341900           AND P-NEW-STATE = 35
342000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
342100               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
342200
342300        IF HOLD-PROV-IPPS-CBSA = '30300'
342400           AND P-NEW-STATE = 50
342500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
342600               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
342700
342800        IF HOLD-PROV-IPPS-CBSA = '39300'
342900           AND P-NEW-STATE = 22
343000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
343100               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
343200
343300        IF HOLD-PROV-IPPS-CBSA = '39300'
343400           AND P-NEW-STATE = 41
343500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
343600               MOVE '   41' TO HOLD-PROV-IPPS-CBSA.
343700
343800        IF HOLD-PROV-IPPS-CBSA = '44600'
343900           AND P-NEW-STATE = 36
344000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
344100               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
344200
344300        IF HOLD-PROV-IPPS-CBSA = '45500'
344400           AND P-NEW-STATE = 45
344500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
344600               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
344700
344800 0580-FY2014-EXIT.
344900      EXIT.
345000
345100
345200******************************************************************
345300*                                                                *
345400* IPPS WAGE INDEX FLOOR ASSIGNMENT LOGIC FOR FY 2015 AND LATER   *
345500* ** LOGIC ADDED 08/06/2014 **                                   *
345600*                                                                *
345700******************************************************************
345800
345900 0580-FY2015-LATER-FLOOR-CBSA.
346000
346100*------------------------------------------------------------*
346200* SET RURAL IPPS CBSA TO PROVIDER'S STATE CODE               *
346300* (HOLD-PROV-IPPS-CBSA-RURAL)                                *
346400*------------------------------------------------------------*
346500     MOVE SPACES              TO H-PROV-BLANK-R.
346600*    MOVE P-NEW-STATE         TO H-PROV-STATE-R.
346700     MOVE P-NEW-STATE-CODE-X  TO H-PROV-STATE-R.
346800
346900*6-20-16
347000*ADDED FOLLOWING LINE TO ALLOW LTCH PRICER TO WORK
347100*WITH THE NEW ARIZONA STATE CODE OF 00 -->
347200
347300     IF H-PROV-STATE-R = '00' MOVE '03' TO H-PROV-STATE-R.
347400
347500*------------------------------------------------------------*
347600* SEARCH TABLE FOR RURAL IPPS CBSA & GET RURAL WAGE INDEX    *
347700*------------------------------------------------------------*
347800     SET MA1 TO 1.
347900     SEARCH T-CBSA-DATA VARYING MA1
348000        AT END
348100           MOVE SPACES TO W-CBSA-IPPS-RURAL
348200           MOVE ZEROS TO W-CBSA-IPPS-RUR-EFF-DATE
348300           MOVE ZEROS TO W-IPPS-WAGE-INDEX-RURAL
348400        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA-RURAL
348500           SET MA2 TO MA1
348600           PERFORM 0675-N-GET-IPPS-WAGE-INDX-RUR
348700              THRU 0675-N-RUR-EXIT VARYING MA2
348800              FROM MA1 BY 1 UNTIL
348900                   T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA-RURAL.
349000
349100
349200*------------------------------------------------------------*
349300* REPLACE CBSA WAGE INDEX & CBSA WITH RURAL FLOOR WAGE INDEX *
349400* & CBSA IF RURAL FLOOR WAGE INDEX IS HIGHER                 *
349500*------------------------------------------------------------*
349600     IF W-IPPS-WAGE-INDEX-RURAL > W-IPPS-WAGE-INDEX
349700        MOVE W-CBSA-IPPS-RURAL        TO W-CBSA-IPPS
349800        MOVE W-CBSA-IPPS-RUR-EFF-DATE TO W-CBSA-IPPS-EFF-DATE
349900        MOVE W-IPPS-WAGE-INDEX-RURAL  TO W-IPPS-WAGE-INDEX
350000     END-IF.
350100
350200 0580-FY2015-LATER-EXIT.
350300      EXIT.
350400
350500
350600******************************************************************
350700 0585-GET-IPPS-CBSA-SIZE.
350800******************************************************************
350900
351000     IF B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2)
351100        IF P-NEW-RURAL-CBSA
351200           MOVE 'R' TO W-CBSA-IPPS-SIZE
351300        ELSE
351400          IF T-CBSA-SIZE (MA2) = 'L'
351500             MOVE 'L' TO W-CBSA-IPPS-SIZE
351600          ELSE
351700             MOVE 'O' TO W-CBSA-IPPS-SIZE
351800          END-IF
351900        END-IF
352000     END-IF.
352100
352200 0585-EXIT.
352300      EXIT.
352400
352500
352600******************************************************************
352700 0590-GET-IPPS-CBSA-PR.
352800******************************************************************
352900
353000*--------------------------------------*
353100* SET PUERTO RICO CBSA INDICATOR       *
353200*--------------------------------------*
353300     MOVE '*' TO H-IPPS-CBSA-LAST-POS.
353400
353500*------------------------------------------------------------*
353600* SEARCH TABLE FOR PR CBSA & GET PR SPECIFIC WAGE INDEX      *
353700*------------------------------------------------------------*
353800     SET MA1 TO 1.
353900     SEARCH T-CBSA-DATA VARYING MA1
354000        AT END
354100           MOVE 60 TO PPS-RTC
354200        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA
354300           SET MA2 TO MA1
354400               PERFORM 0680-N-GET-IPPS-PR-WAGE-INDX
354500                  THRU 0680-N-EXIT VARYING MA2
354600                  FROM MA1 BY 1 UNTIL
354700                       T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA.
354800
354900
355000*------------------------------------------------------------*
355100* ASSIGN PR IPPS WAGE INDEX FLOOR FOR FY 2015 AND LATER      *
355200*------------------------------------------------------------*
355300     IF B-DISCHARGE-DATE > 20140930
355400        PERFORM 0590-FY2015-LATER-PR-FLOOR
355500           THRU 0590-FY2015-LATER-PR-EXIT
355600     END-IF.
355700
355800 0590-EXIT.
355900      EXIT.
356000
356100
356200******************************************************************
356300*                                                                *
356400* PUERTO RICO SPECIFIC WAGE INDEX:                               *
356500* IPPS WAGE INDEX FLOOR ASSIGNMENT LOGIC FOR FY 2015 AND LATER   *
356600* ** LOGIC ADDED 08/06/2014 **                                   *
356700*                                                                *
356800******************************************************************
356900
357000 0590-FY2015-LATER-PR-FLOOR.
357100
357200*------------------------------------------------------------*
357300* SET RURAL IPPS CBSA TO PROVIDER'S STATE CODE               *
357400* (HOLD-PROV-IPPS-CBSA-RURAL)                                *
357500*------------------------------------------------------------*
357600     MOVE SPACES              TO H-PROV-BLANK-R.
357700*    MOVE P-NEW-STATE         TO H-PROV-STATE-R.
357800     MOVE P-NEW-STATE-CODE-X  TO H-PROV-STATE-R.
357900     MOVE '*'                 TO H-IPPS-CBSA-LAST-POS-R.
358000
358100
358200*------------------------------------------------------------*
358300* SEARCH TABLE FOR RURAL PR IPPS CBSA & GET WAGE INDEX       *
358400*------------------------------------------------------------*
358500     SET MA1 TO 1.
358600     SEARCH T-CBSA-DATA VARYING MA1
358700        AT END
358800           MOVE ZEROS TO W-IPPS-PR-WAGE-INDEX-RUR
358900        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA-RURAL
359000           SET MA2 TO MA1
359100           PERFORM 0680-N-GET-IPPS-PR-WAGE-IDX-RU
359200              THRU 0680-N-RU-EXIT VARYING MA2
359300              FROM MA1 BY 1 UNTIL
359400                   T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA-RURAL.
359500
359600
359700*------------------------------------------------------------*
359800* REPLACE CBSA WAGE INDEX & CBSA WITH RURAL FLOOR WAGE INDEX *
359900* & CBSA IF RURAL FLOOR WAGE INDEX IS HIGHER                 *
360000*------------------------------------------------------------*
360100     IF W-IPPS-PR-WAGE-INDEX-RUR > W-IPPS-PR-WAGE-INDEX
360200        MOVE W-IPPS-PR-WAGE-INDEX-RUR TO W-IPPS-PR-WAGE-INDEX
360300     END-IF.
360400
360500
360600 0590-FY2015-LATER-PR-EXIT.
360700      EXIT.
360800
360900
361000******************************************************************
361100 0600-N-GET-WAGE-INDX.
361200******************************************************************
361300
361400     IF  B-DISCHARGE-DATE NOT < MSAX-EFF-DATE (MU2)
361500         MOVE MSAX-MSA (MU2)         TO W-NEW-MSA
361600         MOVE MSAX-EFF-DATE (MU2)    TO W-NEW-EFF-DATE-M
361700         MOVE MSAX-WAGE-INDEX1 (MU2) TO W-NEW-INDEX1-RECORD-M
361800         MOVE MSAX-WAGE-INDEX2 (MU2) TO W-NEW-INDEX2-RECORD-M
361900         MOVE MSAX-WAGE-INDEX3 (MU2) TO W-NEW-INDEX3-RECORD-M
362000     END-IF.
362100
362200 0600-N-EXIT.
362300     EXIT.
362400
362500
362600******************************************************************
362700 0650-N-GET-WAGE-INDX.
362800******************************************************************
362900
363000*----------------------------------------------------------------*
363100* TO SELECT THE WAGE INDEX, IT MUST BE EITHER:                   *
363200* 1) AN INDIAN HEALTH CBSA (98 OR 99) WITH AN EFFECTIVE DATE ON  *
363300*    OR BEFORE THE CLAIM DISCHARGE DATE, OR                      *
363400* 2) A CBSA WITH AN EFFECTIVE DATE ON OR BEFORE THE CLAIM
363500*    DISCHARGE DATE AND A CLAIM DISCHARGE DATE ON OR BEFORE
363600*    09/30/2009 OR
363700* 3) A NON-INDIAN HEATLH CBSA WITH AN EFFECTIVE DATE ON OR BEFORE*
363800*    THE CLAIM DISHARGE DATE AND WITHIN THE CLAIM'S FISCAL YEAR  *
363900*----------------------------------------------------------------*
364000     IF  B-DISCHARGE-DATE NOT < CBSAX-EFF-DATE (CU2)
364100
364200         IF (HOLD-PROV-CBSA = '   98' OR
364300             HOLD-PROV-CBSA = '   99') OR
364400
364500*THE FOLLOWING LINE ADDED WITH VERSION 15.2 TO FIX A PROBLEM
364600*FOUND BY FISS THAT CAUSED AN UNEXPECTED WAGE INDEX ERROR CODE
364700*TO BE REPORTED
364800
364900            (B-DISCHARGE-DATE <= 20090930) OR
365000
365100            (CBSAX-EFF-DATE (CU2)  >= W-FY-BEGIN-DATE AND
365200             CBSAX-EFF-DATE (CU2)  <= W-FY-END-DATE)
365300
365400             MOVE CBSAX-CBSA (CU2)        TO W-NEW-CBSA
365500             MOVE CBSAX-EFF-DATE (CU2)    TO W-NEW-EFF-DATE-C
365600             MOVE CBSAX-WAGE-INDEX1 (CU2) TO W-NEW-INDEX1-RECORD-C
365700             MOVE CBSAX-WAGE-INDEX2 (CU2) TO W-NEW-INDEX2-RECORD-C
365800             MOVE CBSAX-WAGE-INDEX3 (CU2) TO W-NEW-INDEX3-RECORD-C
365900         END-IF
366000     END-IF.
366100
366200 0650-N-EXIT.
366300     EXIT.
366400
366500
366600******************************************************************
366700 0675-N-GET-IPPS-WAGE-INDX.
366800******************************************************************
366900
367000*----------------------------------------------------------------*
367100* TO SELECT THE WAGE INDEX, IT MUST BE EITHER:                   *
367200* 1) AN INDIAN HEALTH CBSA (98 OR 99) WITH AN EFFECTIVE DATE ON  *
367300*    OR BEFORE THE CLAIM DISCHARGE DATE, -OR-                    *
367400* 2) A NON-INDIAN HEATLH CBSA WITH AN EFFECTIVE DATE ON OR BEFORE*
367500*    THE CLAIM DISHARGE DATE AND WITHIN THE CLAIM'S FISCAL YEAR  *
367600*----------------------------------------------------------------*
367700     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2)
367800
367900         IF (HOLD-PROV-IPPS-CBSA = '   98' OR
368000             HOLD-PROV-IPPS-CBSA = '   99') OR
368100
368200            (T-CBSA-EFF-DATE (MA2) >= W-FY-BEGIN-DATE AND
368300             T-CBSA-EFF-DATE (MA2) <= W-FY-END-DATE)
368400
368500         MOVE T-CBSA (MA2)            TO W-CBSA-IPPS
368600         MOVE T-CBSA-EFF-DATE (MA2)   TO W-CBSA-IPPS-EFF-DATE
368700         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-WAGE-INDEX
368800     END-IF.
368900
369000 0675-N-EXIT.
369100     EXIT.
369200
369300
369400******************************************************************
369500 0675-N-GET-IPPS-WAGE-INDX-RUR.
369600******************************************************************
369700
369800*----------------------------------------------------------------*
369900* TO SELECT THE WAGE INDEX, ITS EFFECTIVE DATE MUST BE ON OR     *
370000* BEFORE THE CLAIM DISCHARGE DATE AND WITHIN THE CLAIM'S FISCAL  *
370100* YEAR.                                                          *
370200*----------------------------------------------------------------*
370300     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2) AND
370400         T-CBSA-EFF-DATE (MA2) >= W-FY-BEGIN-DATE AND
370500         T-CBSA-EFF-DATE (MA2) <= W-FY-END-DATE
370600         MOVE T-CBSA (MA2)            TO W-CBSA-IPPS-RURAL
370700         MOVE T-CBSA-EFF-DATE (MA2)   TO W-CBSA-IPPS-RUR-EFF-DATE
370800         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-WAGE-INDEX-RURAL
370900     END-IF.
371000
371100 0675-N-RUR-EXIT.
371200     EXIT.
371300
371400
371500******************************************************************
371600 0680-N-GET-IPPS-PR-WAGE-INDX.
371700******************************************************************
371800
371900*----------------------------------------------------------------*
372000* TO SELECT THE WAGE INDEX, ITS EFFECTIVE DATE MUST BE ON OR     *
372100* BEFORE THE CLAIM DISCHARGE DATE AND WITHIN THE CLAIM'S FISCAL  *
372200* YEAR.                                                          *
372300*----------------------------------------------------------------*
372400     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2) AND
372500         T-CBSA-EFF-DATE (MA2) >= W-FY-BEGIN-DATE AND
372600         T-CBSA-EFF-DATE (MA2) <= W-FY-END-DATE
372700         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-PR-WAGE-INDEX
372800     END-IF.
372900
373000 0680-N-EXIT.
373100     EXIT.
373200
373300
373400******************************************************************
373500 0680-N-GET-IPPS-PR-WAGE-IDX-RU.
373600******************************************************************
373700
373800*----------------------------------------------------------------*
373900* TO SELECT THE WAGE INDEX, ITS EFFECTIVE DATE MUST BE ON OR     *
374000* BEFORE THE CLAIM DISCHARGE DATE AND WITHIN THE CLAIM'S FISCAL  *
374100* YEAR.                                                          *
374200*----------------------------------------------------------------*
374300     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2) AND
374400         T-CBSA-EFF-DATE (MA2) >= W-FY-BEGIN-DATE AND
374500         T-CBSA-EFF-DATE (MA2) <= W-FY-END-DATE
374600         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-PR-WAGE-INDEX-RUR
374700     END-IF.
374800
374900 0680-N-RU-EXIT.
375000     EXIT.
375100
375200******************************************************************
375300********************   END OF PROGRAM   **************************
375400******************************************************************
