000100 IDENTIFICATION DIVISION.                                         00010001
000200 PROGRAM-ID.    IRCAL180.                                         00020001
000300*AUTHOR.        PBG/DDS.                                          00030001
000400*REMARKS.       CMS.                                              00040001
000500                                                                  00050001
000600 DATE-COMPILED.                                                   00060001
000610******************************************************************00061001
000620* CHANGES FOR 2018 - EFFECTIVE 10/01/2017                        *00062001
000630*----------------------------------------------------------------*00063001
000631* REMOVED 25% PAYMENT PENALTY.                                   *00063101
000632* REMOVED RURAL ADJUST FOR RURAL-TO-URBAN PROVIDERS.             *00063201
000634* UPDATED CMG-TABLE                                              *00063401
000638* UPDATED 0100-INITIAL-ROUTINE                                   *00063801
000639*                                                                *00063901
000640*   MOVE .70700 TO PPS-NAT-LABOR-PCT.                            *00064001
000641*   MOVE .29300 TO PPS-NAT-NONLABOR-PCT.                         *00064101
000642*   MOVE  8679  TO PPS-NAT-THRESHOLD-ADJ.                        *00064201
000643*   IF P-NEW-CBSA-HOSP-QUAL-IND IS EQUAL TO '1'                  *00064301
000644*      MOVE 15838  TO PPS-BDGT-NEUT-CONV-AMT                     *00064401
000645*   ELSE                                                         *00064501
000646*      MOVE 15524  TO PPS-BDGT-NEUT-CONV-AMT                     *00064601
000647*   END-IF.                                                      *00064701
000648*                                                                *00064801
000649* UPDATED 3000-CALC-PAYMENT                                      *00064901
000650*   NO CHANGE TO LOW INCOME PATIENT (LIP) ADJ = 0.3177           *00065001
000651*   NO CHANGE TO TEACHING ADJ = 1.10163                          *00065101
000652*                                                                *00065201
000660******************************************************************00066001
000670     EJECT                                                        00067001
000671 ENVIRONMENT DIVISION.                                            00067101
000672 CONFIGURATION SECTION.                                           00067201
000673 SOURCE-COMPUTER.            IBM-370.                             00067301
000674 OBJECT-COMPUTER.            IBM-370.                             00067401
000675 INPUT-OUTPUT  SECTION.                                           00067501
000676 FILE-CONTROL.                                                    00067601
000677                                                                  00067701
000678 DATA DIVISION.                                                   00067801
000679 FILE SECTION.                                                    00067901
000680                                                                  00068001
000690 WORKING-STORAGE SECTION.                                         00069001
000700 01  W-STORAGE-REF                  PIC X(46)  VALUE              00070001
000800     'IRCAL180      - W O R K I N G   S T O R A G E'.             00080001
000900 01  CAL-VERSION                    PIC X(05)  VALUE 'V18.0'.     00090001
001131     EJECT                                                        00113101
001132***************************************************************   00113201
001133*    LAYUP TABLE AREA FOR FY2018 CMGS                         *   00113301
001134***************************************************************   00113401
001135 01  CMG-TABLE.                                                   00113501
001136     05  CMG-TABLE-DATA.                                          00113601
001137         10                      PIC X(32)   VALUE                00113701
001138           '01010850507289067340643509090908'.                    00113801
001139         10                      PIC X(32)   VALUE                00113901
001140           '01021068009152084550808011121010'.                    00114001
001141         10                      PIC X(32)   VALUE                00114101
001142           '01031207610349095600913613131211'.                    00114201
001143         10                      PIC X(32)   VALUE                00114301
001144           '01041295411102102560980013131212'.                    00114401
001145         10                      PIC X(32)   VALUE                00114501
001146           '01051507312918119331140414141413'.                    00114601
001147         10                      PIC X(32)   VALUE                00114701
001148           '01061669514307132171263016161515'.                    00114801
001149         10                      PIC X(32)   VALUE                00114901
001150           '01071864015975147581410317171616'.                    00115001
001151         10                      PIC X(32)   VALUE                00115101
001152           '01082368920301187541792221232120'.                    00115201
001153         10                      PIC X(32)   VALUE                00115301
001154           '01092137318317169211617019191919'.                    00115401
001155         10                      PIC X(32)   VALUE                00115501
001156           '01102786723882220632108327262324'.                    00115601
001157         10                      PIC X(32)   VALUE                00115701
001158           '02010853706885062690574909090907'.                    00115801
001159         10                      PIC X(32)   VALUE                00115901
001160           '02021094408827080370736912111009'.                    00116001
001161         10                      PIC X(32)   VALUE                00116101
001162           '02031263810192092800851012131111'.                    00116201
001163         10                      PIC X(32)   VALUE                00116301
001164           '02041388311197101950934811121212'.                    00116401
001165         10                      PIC X(32)   VALUE                00116501
001166           '02051631713160119821098715151413'.                    00116601
001167         10                      PIC X(32)   VALUE                00116701
001168           '02061969115881144601325918181615'.                    00116801
001169         10                      PIC X(32)   VALUE                00116901
001170           '02072511420255184431691128231918'.                    00117001
001171         10                      PIC X(32)   VALUE                00117101
001172           '03011160809425085740810310111010'.                    00117201
001173         10                      PIC X(32)   VALUE                00117301
001174           '03021409911447104140984213131212'.                    00117401
001175         10                      PIC X(32)   VALUE                00117501
001176           '03031656513450122361156315151313'.                    00117601
001177         10                      PIC X(32)   VALUE                00117701
001178           '03042151717470158931502021191716'.                    00117801
001179         10                      PIC X(32)   VALUE                00117901
001180           '04010901608476075690684212121009'.                    00118001
001181         10                      PIC X(32)   VALUE                00118101
001182           '04021290312130108310979213141312'.                    00118201
001183         10                      PIC X(32)   VALUE                00118301
001184           '04032093819683175761588922221918'.                    00118401
001185         10                      PIC X(32)   VALUE                00118501
001186           '04043674434541308442788442363132'.                    00118601
001187         10                      PIC X(32)   VALUE                00118701
001188           '04053396531929285122577633353127'.                    00118801
001189         10                      PIC X(32)   VALUE                00118901
001190           '05010931307002066370609009090907'.                    00119001
001191         10                      PIC X(32)   VALUE                00119101
001192           '05021219209167086890797312101010'.                    00119201
001193         10                      PIC X(32)   VALUE                00119301
001194           '05031528811495108950999816131212'.                    00119401
001195         10                      PIC X(32)   VALUE                00119501
001196           '05041736213054123731135417151413'.                    00119601
001197         10                      PIC X(32)   VALUE                00119701
001198           '05051989714960141791301118171615'.                    00119801
001199         10                      PIC X(32)   VALUE                00119901
001200           '05062754920714196321801526232120'.                    00120001
001201         10                      PIC X(32)   VALUE                00120101
001202           '06011066108148075620687910090908'.                    00120201
001203         10                      PIC X(32)   VALUE                00120301
001204           '06021392210640098760898412121111'.                    00120401
001205         10                      PIC X(32)   VALUE                00120501
001206           '06031707313049121111101714141313'.                    00120601
001207         10                      PIC X(32)   VALUE                00120701
001208           '06042221316977157571433419181616'.                    00120801
001209         10                      PIC X(32)   VALUE                00120901
001210           '07011037208298078770717512111009'.                    00121001
001211         10                      PIC X(32)   VALUE                00121101
001212           '07021316810534100010910912121111'.                    00121201
001213         10                      PIC X(32)   VALUE                00121301
001214           '07031590312722120781100115141413'.                    00121401
001215         10                      PIC X(32)   VALUE                00121501
001216           '07042016016128153111394618181716'.                    00121601
001217         10                      PIC X(32)   VALUE                00121701
001218           '08010871006418061130564408080707'.                    00121801
001219         10                      PIC X(32)   VALUE                00121901
001220           '08021119708249078580725511100909'.                    00122001
001221         10                      PIC X(32)   VALUE                00122101
001222           '08031451510694101870940613131211'.                    00122201
001223         10                      PIC X(32)   VALUE                00122301
001224           '08041334209830093630864512111110'.                    00122401
001225         10                      PIC X(32)   VALUE                00122501
001226           '08051582111657111031025214131212'.                    00122601
001227         10                      PIC X(32)   VALUE                00122701
001228           '08061915914116134451241516161514'.                    00122801
001229         10                      PIC X(32)   VALUE                00122901
001230           '09011005308078072450673610100908'.                    00123001
001231         10                      PIC X(32)   VALUE                00123101
001232           '09021321910621095260885812121110'.                    00123201
001233         10                      PIC X(32)   VALUE                00123301
001234           '09031622313035116911087015141313'.                    00123401
001235         10                      PIC X(32)   VALUE                00123501
001236           '09042031916327146431361518181615'.                    00123601
001237         10                      PIC X(32)   VALUE                00123701
001238           '10011046109022079370724510111009'.                    00123801
001239         10                      PIC X(32)   VALUE                00123901
001240           '10021373411844104210951213131211'.                    00124001
001241         10                      PIC X(32)   VALUE                00124101
001242           '10032011517348152621393118181716'.                    00124201
001243         10                      PIC X(32)   VALUE                00124301
001244           '11011316011741101540871412141210'.                    00124401
001245         10                      PIC X(32)   VALUE                00124501
001246           '11021905216998147011261517231514'.                    00124601
001247         10                      PIC X(32)   VALUE                00124701
001248           '12011229609239086270793909111010'.                    00124801
001249         10                      PIC X(32)   VALUE                00124901
001250           '12021580711877110901020611131312'.                    00125001
001251         10                      PIC X(32)   VALUE                00125101
001252           '12031930614506135451246612151514'.                    00125201
001253         10                      PIC X(32)   VALUE                00125301
001254           '13011225309248083230798310101009'.                    00125401
001255         10                      PIC X(32)   VALUE                00125501
001256           '13021685212720114471098016141213'.                    00125601
001257         10                      PIC X(32)   VALUE                00125701
001258           '13032197216584149251431518181616'.                    00125801
001259         10                      PIC X(32)   VALUE                00125901
001260           '14010928907480068320620410080808'.                    00126001
001261         10                      PIC X(32)   VALUE                00126101
001262           '14021223109849089970816912111010'.                    00126201
001263         10                      PIC X(32)   VALUE                00126301
001264           '14031463511785107640977413131211'.                    00126401
001265         10                      PIC X(32)   VALUE                00126501
001266           '14041854014929136371238217161514'.                    00126601
001267         10                      PIC X(32)   VALUE                00126701
001268           '15011017108497077680744910090908'.                    00126801
001269         10                      PIC X(32)   VALUE                00126901
001270           '15021311910959100200960711121110'.                    00127001
001271         10                      PIC X(32)   VALUE                00127101
001272           '15031597113341121971169614141212'.                    00127201
001273         10                      PIC X(32)   VALUE                00127301
001274           '15041978316526151091448720161514'.                    00127401
001275         10                      PIC X(32)   VALUE                00127501
001276           '16011148809072082930760910111009'.                    00127601
001277         10                      PIC X(32)   VALUE                00127701
001278           '16021529412078110401013012141312'.                    00127801
001279         10                      PIC X(32)   VALUE                00127901
001280           '16031906215054137591262514161514'.                    00128001
001281         10                      PIC X(32)   VALUE                00128101
001282           '17011197209344084060771710101009'.                    00128201
001283         10                      PIC X(32)   VALUE                00128301
001284           '17021529411936107390985814141212'.                    00128401
001285         10                      PIC X(32)   VALUE                00128501
001286           '17031806614100126861164517151414'.                    00128601
001287         10                      PIC X(32)   VALUE                00128701
001288           '17042284217827160391472321191717'.                    00128801
001289         10                      PIC X(32)   VALUE                00128901
001290           '18011277209992088610812312111010'.                    00129001
001291         10                      PIC X(32)   VALUE                00129101
001292           '18021827514298126791162417161414'.                    00129201
001293         10                      PIC X(32)   VALUE                00129301
001294           '18032887222589200311836433262120'.                    00129401
001295         10                      PIC X(32)   VALUE                00129501
001296           '19011293010758099190947413121211'.                    00129601
001297         10                      PIC X(32)   VALUE                00129701
001298           '19022229718550171031633623202118'.                    00129801
001299         10                      PIC X(32)   VALUE                00129901
001300           '19033734331069286462736141322830'.                    00130001
001301         10                      PIC X(32)   VALUE                00130101
001302           '20010944407644069790633809090808'.                    00130201
001303         10                      PIC X(32)   VALUE                00130301
001304           '20021240310039091670832511111010'.                    00130401
001305         10                      PIC X(32)   VALUE                00130501
001306           '20031543112490114041035714141312'.                    00130601
001307         10                      PIC X(32)   VALUE                00130701
001308           '20041971615958145711323318171515'.                    00130801
001309         10                      PIC X(32)   VALUE                00130901
001310           '21011828918238138551288429171514'.                    00131001
001311         10                      PIC X(32)   VALUE                00131101
001312           '50010000000000000000156500000002'.                    00131201
001313         10                      PIC X(32)   VALUE                00131301
001314           '51010000000000000000658100000007'.                    00131401
001315         10                      PIC X(32)   VALUE                00131501
001316           '51020000000000000001639300000018'.                    00131601
001317         10                      PIC X(32)   VALUE                00131701
001318           '51030000000000000000813200000009'.                    00131801
001319         10                      PIC X(32)   VALUE                00131901
001320           '51040000000000000002033400000021'.                    00132001
001321         10                      PIC X(32)   VALUE                00132101
001322           '99990000000000000000000000000000'.                    00132201
001323     05  W-CMG-TABLE REDEFINES CMG-TABLE-DATA.                    00132301
001324         10  CMG-DATA            OCCURS 93 TIMES                  00132401
001325                                 ASCENDING KEY IS CMG-NUM         00132501
001326                                 INDEXED BY DX6.                  00132601
001327             15  CMG-NUM         PIC X(4).                        00132701
001328             15  CMG-NUM-REDEF REDEFINES CMG-NUM.                 00132801
001329                 20  CMG-RIC     PIC XX.                          00132901
001330                 20  FILLER      PIC XX.                          00133001
001331             15  B-REL-WGT       PIC 9(1)V9(4).                   00133101
001332             15  C-REL-WGT       PIC 9(1)V9(4).                   00133201
001333             15  D-REL-WGT       PIC 9(1)V9(4).                   00133301
001334             15  A-REL-WGT       PIC 9(1)V9(4).                   00133401
001335             15  B-LOS-TABLE     PIC 9(2).                        00133501
001336             15  C-LOS-TABLE     PIC 9(2).                        00133601
001337             15  D-LOS-TABLE     PIC 9(2).                        00133701
001338             15  A-LOS-TABLE     PIC 9(2).                        00133801
001736     EJECT                                                        00173601
001737 01  HOLD-PPS-COMPONENTS.                                         00173701
001738     05  H-LOS                        PIC 9(05).                  00173801
001739     05  H-WK-DSH                     PIC 9(01)V9(04).            00173901
001740     05  H-TEACH-PCT                  PIC 9(01)V9(04).            00174001
001750     05  H-LABOR-PORTION              PIC 9(07)V9(06).            00175001
001760     05  H-NONLABOR-PORTION           PIC 9(07)V9(06).            00176001
001770     05  H-OUTLIER-LABOR-PORTION      PIC 9(07)V9(06).            00177001
001780     05  H-OUTLIER-NONLABOR-PORTION   PIC 9(07)V9(06).            00178001
001790     05  H-FP-OUTLIER-THRESHOLD       PIC 9(07)V9(06).            00179001
001800     05  H-OUTLIER-THRESHOLD          PIC 9(07)V9(06).            00180001
001900     05  H-CHG-OUTLIER-THRESHOLD      PIC 9(07)V9(04).            00190001
002000     05  H-FY-BEGIN-DATE              PIC 9(08).                  00200001
002100     05  H-DISCHARGE-DATE             PIC 9(08).                  00210001
002200                                                                  00220001
002300 LINKAGE SECTION.                                                 00230001
002400**************************************************************    00240001
002500*      THIS IS THE BILL-RECORD THAT WILL BE PASSED FROM      *    00250001
002600*      THE IRCAL___ PROGRAM                                  *    00260001
002700**************************************************************    00270001
002800 01  BILL-NEW-DATA.                                               00280001
002900         10  B-NPI10.                                             00290001
003000             15  B-NPI8             PIC X(08).                    00300001
003100             15  B-NPI-FILLER       PIC X(02).                    00310001
003200         10  B-PROVIDER-NO          PIC X(06).                    00320001
003300         10  B-PATIENT-STATUS       PIC X(02).                    00330001
003400         10  B-CMG-CODE             PIC X(05).                    00340001
003500         10  B-LOS                  PIC 9(03).                    00350001
003600         10  B-COV-DAYS             PIC 9(03).                    00360001
003700         10  B-LTR-DAYS             PIC 9(02).                    00370001
003800         10  B-SPEC-PAY-IND         PIC X(01).                    00380001
003900         10  B-DISCHARGE-DATE.                                    00390001
004000             15  B-DISCHG-CC        PIC 9(02).                    00400001
004100             15  B-DISCHG-YY        PIC 9(02).                    00410001
004200             15  B-DISCHG-MM        PIC 9(02).                    00420001
004300             15  B-DISCHG-DD        PIC 9(02).                    00430001
004400         10  B-COV-CHARGES          PIC 9(07)V9(02).              00440001
004500         10  FILLER                 PIC X(11).                    00450001
004600                                                                  00460001
004700***************************************************************   00470001
004800*    THIS DATA IS CALCULATED BY THIS IRCAL SUBROUTINE         *   00480001
004900*    AND PASSED BACK TO THE CALLING PROGRAM                   *   00490001
005000*            RETURN CODE VALUES (PPS-RTC)                     *   00500001
005100*                                                             *   00510001
005200*     ****   PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   00520001
005300*              00 = PAID NORMAL CMG PAYMENT WITHOUT OUTLIER   *   00530001
005400*                                                             *   00540001
005500*              01 = PAID NORMAL CMG PAYMENT WITH OUTLIER      *   00550001
005600*                                                             *   00560001
005700*              02 = TRANSFER PAID ON A PERDIEM BASIS WITHOUT  *   00570001
005800*                   OUTLIER                                   *   00580001
005900*              03 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   00590001
006000*                   OUTLIER                                   *   00600001
006100*              04 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   00610001
006200*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   00620001
006300*                   WITHOUT OUTLIER                           *   00630001
006400*              05 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   00640001
006500*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   00650001
006600*                   WITH OUTLIER                              *   00660001
006700*              06 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   00670001
006800*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   00680001
006900*                   RATE -- WITHOUT OUTLIER                   *   00690001
007000*              07 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   00700001
007100*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   00710001
007200*                   RATE -- WITH OUTLIER                      *   00720001
007300*       **** NEW RT CODES FOR PAYMENT WITH PENALTIES          *   00730001
007400*              10 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   00740001
007500*                   WITHOUT OUTLIER                           *   00750001
007600*              11 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   00760001
007700*                   WITH OUTLIER                              *   00770001
007800*              12 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   00780001
007900*                   PENALTY WITHOUT OUTLIER                   *   00790001
008000*              13 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   00800001
008100*                   PENALTY WITH OUTLIER                      *   00810001
008200*              14 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   00820001
008300*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   00830001
008400*                   WITH PENALTY WITHOUT OUTLIER              *   00840001
008500*              15 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   00850001
008600*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   00860001
008700*                   WITH PENALTY WITH OUTLIER                 *   00870001
008800*              16 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   00880001
008900*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   00890001
009000*                   RATE -- WITH PENALTY WITHOUT OUTLIER      *   00900001
009100*              17 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   00910001
009200*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   00920001
009300*                   RATE -- WITH PENALTY WITH OUTLIER         *   00930001
009400*                                                             *   00940001
009500*      ****  PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   00950001
009600*              50 = PROVIDER SPECIFIC RATE NOT NUMERIC        *   00960001
009700*              51 = PROVIDER RECORD TERMINATED                *   00970001
009800*              52 = INVALID WAGE INDEX                        *   00980001
009900*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   00990001
010000*              54 = CMG ON CLAIM NOT FOUND IN TABLE           *   01000001
010100*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   01010001
010200*                                      OR                     *   01020001
010300*                   DISCHARGE DATE < MSA EFF START DATE       *   01030001
010400*                   FOR PPS                                   *   01040001
010500*              56 = INVALID LENGTH OF STAY                    *   01050001
010600*              57 = PROVIDER SPECIFIC RATE ZERO WHEN BLENDED  *   01060001
010700*                   PAYMENT REQUESTED                         *   01070001
010800*              58 = TOTAL COVERED CHARGES NOT NUMERIC         *   01080001
010900*              59 = PROVIDER SPECIFIC RECORD NOT FOUND        *   01090001
011000*              60 = MSA WAGE INDEX RECORD NOT FOUND           *   01100001
011100*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   01110001
011200*                   OR BILL-LTR-DAYS > 60                     *   01120001
011300*              62 = INVALID NUMBER OF COVERED DAYS            *   01130001
011400*              65 = OPERATING COST-TO-CHARGE RATIO NOT NUMERIC*   01140001
011500*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   01150001
011600*                   OR COST OUTLIER THRESHOLD CALCULATION     *   01160001
011700*              72 = INVALID BLEND INDICATOR (NOT 3 OR 4)      *   01170001
011800*              73 = DISCHARGED BEFORE PROVIDER FY BEGIN       *   01180001
011900*              74 = PROVIDER FY BEGIN DATE NOT IN 2002        *   01190001
012000***************************************************************   01200001
012100 01  PPS-DATA-ALL.                                                01210001
012200     05  PPS-RTC                      PIC 9(02).                  01220001
012300     05  PPS-DATA.                                                01230001
012400         10  PPS-MSA                  PIC X(04).                  01240001
012500         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).            01250001
012600         10  PPS-AVG-LOS              PIC 9(02).                  01260001
012700         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).            01270001
012800         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).            01280001
012900         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).            01290001
013000         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).            01300001
013100         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).            01310001
013200         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).            01320001
013300         10  PPS-LIP-PCT              PIC 9(01)V9(04).            01330001
013400         10  PPS-LOS                  PIC 9(03).                  01340001
013500         10  PPS-REG-DAYS-USED        PIC 9(03).                  01350001
013600         10  PPS-LTR-DAYS-USED        PIC 9(03).                  01360001
013700         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).            01370001
013800         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).            01380001
013900         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).            01390001
014000         10  PPS-FAC-COSTS            PIC 9(07)V9(02).            01400001
014100         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).            01410001
014200         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).           01420001
014300         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).            01430001
014400         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).            01440001
014500         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).            01450001
014600         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).            01460001
014700         10  PPS-SUBM-CMG-CODE        PIC X(05).                  01470001
014800         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.      01480001
014900            15  PPS-CMG-ALPHA         PIC X(01).                  01490001
015000            15  PPS-CMG-NUMERIC.                                  01500001
015100               20  PPS-CMG-RIC        PIC X(02).                  01510001
015200               20  FILLER             PIC X(02).                  01520001
015300         10  PPS-PRICED-CMG-CODE      PIC X(05).                  01530001
015400         10  PPS-CALC-VERS-CD         PIC X(05).                  01540001
015500         10  PPS-CBSA                 PIC X(05).                  01550001
015600         10  FILLER                   PIC X(08).                  01560001
015700     05  PPS-OTHER-DATA.                                          01570001
015800         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).            01580001
015900         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).            01590001
016000         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).            01600001
016100         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).            01610001
016200         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).            01620001
016300         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).            01630001
016400         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).            01640001
016500         10  PPS-TEACH-PAY-AMT        PIC 9(07)V9(02).            01650001
016600         10  PPS-TEACH-PENALTY-AMT    PIC 9(07)V9(02).            01660001
016700         10  FILLER                   PIC X(02).                  01670001
016800     05  PPS-PC-DATA.                                             01680001
016900         10  PPS-COT-IND              PIC X(01).                  01690001
017000         10  FILLER                   PIC X(20).                  01700001
017100                                                                  01710001
017200******************************************************************01720001
017300*            THESE ARE THE VERSIONS OF THE IRDRV___               01730001
017400*           PROGRAMS THAT WILL BE PASSED BACK----                 01740001
017500*          ASSOCIATED WITH THE BILL BEING PROCESSED               01750001
017600******************************************************************01760001
017700 01  PRICER-OPT-VERS-SW.                                          01770001
017800     05  PRICER-OPTION-SW          PIC X(01).                     01780001
017900         88  ALL-TABLES-PASSED          VALUE 'A'.                01790001
018000         88  PROV-RECORD-PASSED         VALUE 'P'.                01800001
018100     05  PPS-VERSIONS.                                            01810001
018200         10  PPDRV-VERSION         PIC X(05).                     01820001
018300                                                                  01830001
018400**************************************************************    01840001
018500*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BY        *    01850001
018600*      THE IRCAL___ PROGRAM                                  *    01860001
018700**************************************************************    01870001
018800 01  PROV-NEW-HOLD.                                               01880001
018900     02  PROV-NEWREC-HOLD1.                                       01890001
019000         05  P-NEW-NPI10.                                         01900001
019100             10  P-NEW-NPI8             PIC X(08).                01910001
019200             10  P-NEW-NPI-FILLER       PIC X(02).                01920001
019300         05  P-NEW-PROVIDER-NO.                                   01930001
019400             10  P-NEW-STATE            PIC 9(02).                01940001
019500             10  FILLER                 PIC X(04).                01950001
019600         05  P-NEW-DATE-DATA.                                     01960001
019700             10  P-NEW-EFF-DATE.                                  01970001
019800                 15  P-NEW-EFF-DT-CC    PIC 9(02).                01980001
019900                 15  P-NEW-EFF-DT-YY    PIC 9(02).                01990001
020000                 15  P-NEW-EFF-DT-MM    PIC 9(02).                02000001
020100                 15  P-NEW-EFF-DT-DD    PIC 9(02).                02010001
020200             10  P-NEW-FY-BEGIN-DATE.                             02020001
020300                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                02030001
020400                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                02040001
020500                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                02050001
020600                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                02060001
020700             10  P-NEW-REPORT-DATE.                               02070001
020800                 15  P-NEW-REPORT-DT-CC PIC 9(02).                02080001
020900                 15  P-NEW-REPORT-DT-YY PIC 9(02).                02090001
021000                 15  P-NEW-REPORT-DT-MM PIC 9(02).                02100001
021100                 15  P-NEW-REPORT-DT-DD PIC 9(02).                02110001
021200             10  P-NEW-TERMINATION-DATE.                          02120001
021300                 15  P-NEW-TERM-DT-CC   PIC 9(02).                02130001
021400                 15  P-NEW-TERM-DT-YY   PIC 9(02).                02140001
021500                 15  P-NEW-TERM-DT-MM   PIC 9(02).                02150001
021600                 15  P-NEW-TERM-DT-DD   PIC 9(02).                02160001
021700         05  P-NEW-WAIVER-CODE          PIC X(01).                02170001
021800             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              02180001
021900         05  P-NEW-INTER-NO             PIC 9(05).                02190001
022000         05  P-NEW-PROVIDER-TYPE        PIC X(02).                02200001
022100         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                02210001
022200         05  P-NEW-CURRENT-DIV   REDEFINES                        02220001
022300                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         02230001
022400         05  P-NEW-MSA-DATA.                                      02240001
022500             10  P-NEW-CHG-CODE-INDEX       PIC X.                02250001
022600             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 02260001
022700             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   02270001
022800                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       02280001
022900             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 02290001
023000             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 02300001
023100             10  P-NEW-STAND-AMT-LOC-MSA9                         02310001
023200                 REDEFINES P-NEW-STAND-AMT-LOC-MSA.               02320001
023300                 15  P-NEW-RURAL-1ST.                             02330001
023400                     20  P-NEW-STAND-RURAL  PIC XX.               02340001
023500                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    02350001
023600                 15  P-NEW-RURAL-2ND        PIC XX.               02360001
023700         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    02370001
023800         05  P-NEW-LUGAR                    PIC X.                02380001
023900         05  P-NEW-TEMP-RELIEF-IND          PIC X.                02390001
024000         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                02400001
024100         05  FILLER                         PIC X(05).            02410001
024200     02  PROV-NEWREC-HOLD2.                                       02420001
024300         05  P-NEW-VARIABLES.                                     02430001
024400             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        02440001
024500             10  P-NEW-COLA              PIC  9(01)V9(03).        02450001
024600             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        02460001
024700             10  P-NEW-BED-SIZE          PIC  9(05).              02470001
024800             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        02480001
024900             10  P-NEW-CMI               PIC  9(01)V9(04).        02490001
025000             10  P-NEW-SSI-RATIO         PIC  V9(04).             02500001
025100             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             02510001
025200             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              02520001
025300             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        02530001
025400             10  P-NEW-DSH-PERCENT       PIC  V9(04).             02540001
025500             10  P-NEW-FYE-DATE          PIC  X(08).              02550001
025600         05  P-NEW-CBSA-DATA.                                     02560001
025700             10  P-NEW-CBSA-SPEC-PAY-IND   PIC X.                 02570001
025800             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 02580001
025900             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  02590001
026000             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  02600001
026100             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  02610001
026200             10  P-NEW-CBSA-STAND-AMT-LOC9                        02620001
026300                 REDEFINES P-NEW-CBSA-STAND-AMT-LOC.              02630001
026400                 15  P-NEW-CBSA-RURAL-1ST.                        02640001
026500                     20  P-NEW-CBSA-STAND-RURAL PIC 999.          02650001
026600                 15  P-NEW-CBSA-RURAL-2ND       PIC 99.           02660001
026700             10  P-NEW-CBSA-SPEC-WAGE-INDEX     PIC 9(02)V9(04).  02670001
026800     02  PROV-NEWREC-HOLD3.                                       02680001
026900         05  P-NEW-PASS-AMT-DATA.                                 02690001
027000             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          02700001
027100             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          02710001
027200             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          02720001
027300             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          02730001
027400         05  P-NEW-CAPI-DATA.                                     02740001
027500             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 02750001
027600             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          02760001
027700             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          02770001
027800             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        02780001
027900             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             02790001
028000             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 02800001
028100             15  P-NEW-CAPI-IME            PIC 9V9999.            02810001
028200             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          02820001
028300             15  P-VAL-BASED-PURCH-SCORE   PIC 9V999.             02830001
028400         05  FILLER                        PIC X(18).             02840001
028500******************************************************************02850001
028600*                   THIS IS THE WAGE-INDEX                        02860001
028700*          ASSOCIATED WITH THE BILL BEING PROCESSED               02870001
028800*                                                                 02880001
028900******************************************************************02890001
029000 01  WAGE-NEW-INDEX-RECORD-CBSA.                                  02900001
029100     05  W-NEW-CBSA                    PIC X(5).                  02910001
029200*       88  VALID-RURAL-CBSA    VALUE                             02920001
029300*             '50001' '50007' '50016' '50020' '50031'             02930001
029400*             '50036' '50054' '50060' '50067' '50087'             02940001
029500*             '50089' '50091' '50092' '50100' '50104'             02950001
029600*             '50108' '50114' '50121' '50125' '50140'             02960001
029700*             '50145' '50152' '50164' '50170' '50192'             02970001
029800*             '50199' '50206' '50210' '50214' '50218'             02980001
029900*             '50222' '50225' '50226' '50231' '50234'             02990001
030000*             '50237' '50243' '50248' '50250' '50255'             03000001
030100*             '50256' '50257' '50260' '50261' '50262'             03010001
030200*             '50263' '50266' '50268' '50272' '50275'             03020001
030300*             '50281' '50286' '50293' '50313' '50314'             03030001
030400*             '50316' '50325' '50326' '50327' '50329'             03040001
030500*             '50336' '50344' '50352'.                            03050001
030600     05  W-NEW-EFF-DATE-C              PIC X(8).                  03060001
030700     05  W-NEW-WAGE-INDEX-C            PIC S9(02)V9(04).          03070001
030800                                                                  03080001
030900 PROCEDURE DIVISION  USING BILL-NEW-DATA                          03090001
031000                           PPS-DATA-ALL                           03100001
031100                           PRICER-OPT-VERS-SW                     03110001
031200                           PROV-NEW-HOLD                          03120001
031300                           WAGE-NEW-INDEX-RECORD-CBSA.            03130001
031400***************************************************************   03140001
031500*    PROCESSING:                                              *   03150001
031600*        A. WILL PROCESS CLAIMS BASED ON DISCHARGE DATE       *   03160001
031700*        B. INITIALIZE IRCAL HOLD VARIABLES.                  *   03170001
031800*        C. EDIT THE DATA PASSED FROM THE CLAIM BEFORE        *   03180001
031900*           ATTEMPTING TO CALCULATE PPS. IF THIS CLAIM        *   03190001
032000*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   03200001
032100*           GOBACK.                                           *   03210001
032200*        D. ASSEMBLE PRICING COMPONENTS.                      *   03220001
032300*        E. CALCULATE THE PRICE.                              *   03230001
032400*        F. CALCULATE OUTLIERS IF APPLICABLE.                 *   03240001
032500***************************************************************   03250001
032600                                                                  03260001
032700 0000-MAINLINE-CONTROL.                                           03270001
032800                                                                  03280001
032900     PERFORM 0100-INITIAL-ROUTINE                                 03290001
033000        THRU 0100-EXIT.                                           03300001
033100                                                                  03310001
033200     PERFORM 1000-EDIT-THE-BILL-INFO                              03320001
033300        THRU 1000-EXIT.                                           03330001
033400                                                                  03340001
033500     IF PPS-RTC = 00                                              03350001
033600        PERFORM 1700-EDIT-CMG-CODE                                03360001
033700           THRU 1700-EXIT.                                        03370001
033800                                                                  03380001
033900     IF PPS-RTC = 00                                              03390001
034000        PERFORM 2000-ASSEMBLE-PPS-VARIABLES                       03400001
034100           THRU 2000-EXIT.                                        03410001
034200                                                                  03420001
034300     IF PPS-RTC = 00                                              03430001
034400        PERFORM 3000-CALC-PAYMENT                                 03440001
034500           THRU 3000-EXIT                                         03450001
034600        PERFORM 3500-CONTINUE-CALC                                03460001
034700           THRU 3500-EXIT                                         03470001
034800        PERFORM 4000-CALC-OUTLIER                                 03480001
034900           THRU 4000-EXIT                                         03490001
035000        PERFORM 5000-FINAL-PAYMENTS                               03500001
035100           THRU 5000-EXIT.                                        03510001
035200                                                                  03520001
035300     PERFORM 9000-MOVE-RESULTS                                    03530001
035400        THRU 9000-EXIT.                                           03540001
035500                                                                  03550001
035600     GOBACK.                                                      03560001
035700                                                                  03570001
035800 0100-INITIAL-ROUTINE.                                            03580001
035900                                                                  03590001
036000     MOVE ZEROS TO PPS-RTC.                                       03600001
036100     INITIALIZE PPS-DATA.                                         03610001
036200     INITIALIZE PPS-OTHER-DATA.                                   03620001
036300     INITIALIZE HOLD-PPS-COMPONENTS.                              03630001
036400***************************************************************   03640001
036500*    UPDATE THE VALUES BELOW FOR EACH FY RELEASE              *   03650001
036600*     - VALUES PER POLICY                                     *   03660001
036700***************************************************************   03670001
036710*                                                                 03671001
036720**                                                                03672001
036730***                                                               03673001
036740**                                                                03674001
036750*                                                                 03675001
036900     MOVE .70700 TO PPS-NAT-LABOR-PCT.                            03690001
037000     MOVE .29300 TO PPS-NAT-NONLABOR-PCT.                         03700001
037100     MOVE  8679  TO PPS-NAT-THRESHOLD-ADJ.                        03710001
037200     IF P-NEW-CBSA-HOSP-QUAL-IND IS EQUAL TO '1'                  03720001
037300        MOVE 15838  TO PPS-BDGT-NEUT-CONV-AMT                     03730001
037400     ELSE                                                         03740001
037500        MOVE 15524  TO PPS-BDGT-NEUT-CONV-AMT                     03750001
037600     END-IF.                                                      03760001
037700                                                                  03770001
037800 0100-EXIT.                                                       03780001
037900      EXIT.                                                       03790001
038000                                                                  03800001
038100 1000-EDIT-THE-BILL-INFO.                                         03810001
038200***************************************************************   03820001
038300*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   03830001
038400*    AND DO NOT ATTEMPT TO PRICE.                             *   03840001
038500***************************************************************   03850001
038600                                                                  03860001
038700     MOVE B-CMG-CODE TO PPS-SUBM-CMG-CODE.                        03870001
038800                                                                  03880001
038900     IF (B-LOS NUMERIC) AND (B-LOS > 0)                           03890001
039000        MOVE B-LOS TO H-LOS                                       03900001
039100     ELSE                                                         03910001
039200        IF B-LOS = 0                                              03920001
039300           MOVE 1 TO H-LOS                                        03930001
039400        ELSE                                                      03940001
039500           MOVE 56 TO PPS-RTC.                                    03950001
039600                                                                  03960001
039700     MOVE P-NEW-FY-BEGIN-DATE TO H-FY-BEGIN-DATE.                 03970001
039800     IF H-FY-BEGIN-DATE (5:2) < 11                                03980001
039900       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 10200          03990001
040000     ELSE                                                         04000001
040100       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 19000.         04010001
040200     MOVE B-DISCHARGE-DATE TO H-DISCHARGE-DATE.                   04020001
040300     IF (H-DISCHARGE-DATE > H-FY-BEGIN-DATE)                      04030001
040400        OR (P-NEW-FY-BEGIN-DATE > 20020930 AND                    04040001
040500            P-NEW-FY-BEGIN-DATE < 20030101)                       04050001
040600        MOVE '4' TO P-NEW-FED-PPS-BLEND-IND.                      04060001
040700     IF P-NEW-FY-BEGIN-DATE > 20011231                            04070001
040800        IF (P-NEW-FY-BEGIN-DATE <= B-DISCHARGE-DATE)              04080001
040900           IF P-NEW-FED-PPS-BLEND-IND = '4'                       04090001
041000              MOVE 1.0000 TO PPS-FED-RATE-PCT                     04100001
041100              MOVE 0.0000 TO PPS-FAC-RATE-PCT                     04110001
041200           ELSE                                                   04120001
041300             IF P-NEW-FED-PPS-BLEND-IND = '3'                     04130001
041400                MOVE .6667 TO PPS-FED-RATE-PCT                    04140001
041500                MOVE .3333 TO PPS-FAC-RATE-PCT                    04150001
041600             ELSE                                                 04160001
041700               MOVE 72 TO PPS-RTC                                 04170001
041800        ELSE                                                      04180001
041900           MOVE 73 TO PPS-RTC                                     04190001
042000     ELSE                                                         04200001
042100        MOVE 74 TO PPS-RTC.                                       04210001
042200                                                                  04220001
042300     IF PPS-RTC = 00                                              04230001
042400       IF P-NEW-WAIVER-STATE                                      04240001
042500          MOVE 53 TO PPS-RTC.                                     04250001
042600                                                                  04260001
042700     IF PPS-RTC = 00                                              04270001
042800         IF ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR               04280001
042900            (B-DISCHARGE-DATE < W-NEW-EFF-DATE-C))                04290001
043000            MOVE 55 TO PPS-RTC.                                   04300001
043100                                                                  04310001
043200     IF PPS-RTC = 00                                              04320001
043300         IF P-NEW-TERMINATION-DATE > 00000000                     04330001
043400            IF B-DISCHARGE-DATE >= P-NEW-TERMINATION-DATE         04340001
043500               MOVE 51 TO PPS-RTC.                                04350001
043600                                                                  04360001
043700     IF PPS-RTC = 00                                              04370001
043800         IF B-COV-CHARGES NOT NUMERIC                             04380001
043900            MOVE 58 TO PPS-RTC.                                   04390001
044000                                                                  04400001
044100     IF PPS-RTC = 00                                              04410001
044200        IF B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60              04420001
044300           MOVE 61 TO PPS-RTC                                     04430001
044400        ELSE                                                      04440001
044500           MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.                  04450001
044600                                                                  04460001
044700     IF PPS-RTC = 00                                              04470001
044800        IF B-COV-DAYS NOT NUMERIC                                 04480001
044900             MOVE 62 TO PPS-RTC                                   04490001
045000        ELSE                                                      04500001
045100          IF B-COV-DAYS = 0 AND H-LOS > 0                         04510001
045200             MOVE 62 TO PPS-RTC.                                  04520001
045300                                                                  04530001
045400     IF PPS-RTC = 00                                              04540001
045500        IF B-LTR-DAYS  > B-COV-DAYS                               04550001
045600           MOVE 62 TO PPS-RTC                                     04560001
045700        ELSE                                                      04570001
045800           COMPUTE PPS-REG-DAYS-USED = B-COV-DAYS - B-LTR-DAYS.   04580001
045900                                                                  04590001
046000     IF PPS-RTC = 00                                              04600001
046100        IF PPS-REG-DAYS-USED > 0                                  04610001
046200           IF PPS-REG-DAYS-USED > H-LOS                           04620001
046300              MOVE H-LOS TO PPS-REG-DAYS-USED                     04630001
046400           ELSE                                                   04640001
046500              NEXT SENTENCE                                       04650001
046600        ELSE                                                      04660001
046700           IF B-LTR-DAYS > H-LOS                                  04670001
046800              MOVE H-LOS TO PPS-LTR-DAYS-USED                     04680001
046900           ELSE                                                   04690001
047000              MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.               04700001
047100                                                                  04710001
047200 1000-EXIT.                                                       04720001
047300      EXIT.                                                       04730001
047400                                                                  04740001
047500***************************************************************   04750001
047600*    FINDS THE CMG CODE IN THE TABLE                          *   04760001
047700***************************************************************   04770001
047800 1700-EDIT-CMG-CODE.                                              04780001
047900* 01/2010 - ADDED 5001 PER C.R. # 6699                            04790001
048000                                                                  04800001
048100     IF PPS-CMG-NUMERIC = '9999' OR '5001'                        04810001
048200        NEXT SENTENCE                                             04820001
048300     ELSE                                                         04830001
048400        IF PPS-CMG-NUMERIC < '2103'                               04840001
048500           NEXT SENTENCE                                          04850001
048600        ELSE                                                      04860001
048700           MOVE 54 TO PPS-RTC.                                    04870001
048800                                                                  04880001
048900     IF PPS-RTC = 00                                              04890001
049000        SEARCH ALL CMG-DATA                                       04900001
049100           AT END                                                 04910001
049200             MOVE 54 TO PPS-RTC                                   04920001
049300        WHEN CMG-NUM (DX6) = PPS-CMG-NUMERIC                      04930001
049400             PERFORM 1750-FIND-VALUE                              04940001
049500                THRU 1750-EXIT                                    04950001
049600        END-SEARCH.                                               04960001
049700                                                                  04970001
049800 1700-EXIT.                                                       04980001
049900      EXIT.                                                       04990001
050000                                                                  05000001
050100***************************************************************   05010001
050200*    FINDS THE VALUE IN THE CMG CODE IN THE TABLE             *   05020001
050300***************************************************************   05030001
050400 1750-FIND-VALUE.                                                 05040001
050500                                                                  05050001
050600      IF PPS-CMG-ALPHA = 'A'                                      05060001
050700         MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                 05070001
050800         MOVE A-LOS-TABLE (DX6) TO PPS-AVG-LOS                    05080001
050900      ELSE                                                        05090001
051000         IF PPS-CMG-ALPHA = 'B'                                   05100001
051100            MOVE B-REL-WGT (DX6) TO PPS-RELATIVE-WGT              05110001
051200            MOVE B-LOS-TABLE (DX6) TO PPS-AVG-LOS                 05120001
051300         ELSE                                                     05130001
051400            IF PPS-CMG-ALPHA = 'C'                                05140001
051500               MOVE C-REL-WGT (DX6) TO PPS-RELATIVE-WGT           05150001
051600               MOVE C-LOS-TABLE (DX6) TO PPS-AVG-LOS              05160001
051700            ELSE                                                  05170001
051800               IF PPS-CMG-ALPHA = 'D'                             05180001
051900                  MOVE D-REL-WGT (DX6) TO PPS-RELATIVE-WGT        05190001
052000                  MOVE D-LOS-TABLE (DX6) TO PPS-AVG-LOS           05200001
052100               ELSE                                               05210001
052200                  MOVE 54 TO PPS-RTC.                             05220001
052300                                                                  05230001
052400 1750-EXIT.                                                       05240001
052500      EXIT.                                                       05250001
052600                                                                  05260001
052700***************************************************************   05270001
052800*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   05280001
052900*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   05290001
053000*    OF THAT VARIABLE.                                        *   05300001
053100***************************************************************   05310001
053200***  GET THE PROVIDER SPECIFIC VARIABLE AND WAGE INDEX            05320001
053300***************************************************************   05330001
053400 2000-ASSEMBLE-PPS-VARIABLES.                                     05340001
053500                                                                  05350001
053600     IF P-NEW-FAC-SPEC-RATE NUMERIC                               05360001
053700        MOVE P-NEW-FAC-SPEC-RATE TO PPS-FAC-SPEC-RT-PREBLEND      05370001
053800     ELSE                                                         05380001
053900        MOVE 50 TO PPS-RTC                                        05390001
054000        GO TO 2000-EXIT.                                          05400001
054100                                                                  05410001
054200     IF P-NEW-FED-PPS-BLEND-IND = '3'                             05420001
054300        IF PPS-FAC-SPEC-RT-PREBLEND = 0                           05430001
054400          MOVE 57 TO PPS-RTC                                      05440001
054500          GO TO 2000-EXIT.                                        05450001
054600                                                                  05460001
054700     IF W-NEW-WAGE-INDEX-C NUMERIC                                05470001
054800            AND W-NEW-WAGE-INDEX-C > 0                            05480001
054900        MOVE W-NEW-WAGE-INDEX-C TO PPS-WAGE-INDEX                 05490001
055000     ELSE                                                         05500001
055100        MOVE 52 TO PPS-RTC                                        05510001
055200        GO TO 2000-EXIT.                                          05520001
055300                                                                  05530001
055400     IF P-NEW-OPER-CSTCHG-RATIO NOT NUMERIC                       05540001
055500        MOVE 65 TO PPS-RTC.                                       05550001
055600                                                                  05560001
055700 2000-EXIT.                                                       05570001
055800      EXIT.                                                       05580001
055900                                                                  05590001
056000***************************************************************   05600001
056100*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   05610001
056200*        CALCULATE THE FEDERAL PORTION.                       *   05620001
056300*        CALCULATE THE HOSPITAL PORTION.                      *   05630001
056400*        CALCULATE THE COST-OUTLIER PORTION.                  *   05640001
056500*        CALCULATE THE LIP ADJUSTMENT PERCENTAGE.             *   05650001
056600*-------------------------------------------------------------*   05660001
056700*    NO CHANGE TO LIP FROM 2014 AT  .3177                     *   05670001
056800*    NO CHANGE TO TCH FROM 2014 AT 1.0163                     *   05680001
056900***************************************************************   05690001
057000 3000-CALC-PAYMENT.                                               05700001
057100                                                                  05710001
057200***  LIP ( LOW INCOME PATIENT ) CALCULATION                   *   05720001
057300                                                                  05730001
057400      COMPUTE H-WK-DSH = (P-NEW-SSI-RATIO                         05740001
057500                           + P-NEW-MEDICAID-RATIO).               05750001
057600                                                                  05760001
057700      COMPUTE PPS-LIP-PCT ROUNDED =                               05770001
057800            ((1 + H-WK-DSH) ** .3177) - 1.                        05780001
057900                                                                  05790001
058000      COMPUTE H-TEACH-PCT ROUNDED =                               05800001
058100            ((1 + P-NEW-CAPI-IME) ** 1.0163) - 1.                 05810001
058200                                                                  05820001
058300***************************************************************   05830001
058400                                                                  05840001
058500     MOVE 1.0000 TO PPS-TRANSFER-PCT.                             05850001
058600                                                                  05860001
058700     IF B-PATIENT-STATUS =                                        05870001
058800          '02' OR '03' OR '61' OR '62' OR '63' OR '64' OR         05880001
058900          '82' OR '83' OR '89' OR '90' OR '91' OR '92'            05890001
059000        IF H-LOS < PPS-AVG-LOS                                    05900001
059100           COMPUTE PPS-TRANSFER-PCT =                             05910001
059200               ((H-LOS + .5) / PPS-AVG-LOS)                       05920001
059300           MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE          05930001
059400           GO TO 3000-EXIT.                                       05940001
059500                                                                  05950001
059600     IF H-LOS > 3                                                 05960001
059700        NEXT SENTENCE                                             05970001
059800     ELSE                                                         05980001
059900        MOVE 'A5001' TO PPS-PRICED-CMG-CODE                       05990001
060000        SET DX6 TO 88                                             06000001
060100        MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                  06010001
060200        GO TO 3000-EXIT.                                          06020001
060300                                                                  06030001
060400     IF B-PATIENT-STATUS = '20'                                   06040001
060500        NEXT SENTENCE                                             06050001
060600     ELSE                                                         06060001
060700        MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE             06070001
060800        GO TO 3000-EXIT.                                          06080001
060900                                                                  06090001
061000     IF PPS-CMG-RIC = ('07' OR '08' OR '09')                      06100001
061100        IF H-LOS < 14                                             06110001
061200           MOVE 'A5101' TO PPS-PRICED-CMG-CODE                    06120001
061300           SET DX6 TO 89                                          06130001
061400           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               06140001
061500        ELSE                                                      06150001
061600           MOVE 'A5102' TO PPS-PRICED-CMG-CODE                    06160001
061700           SET DX6 TO 90                                          06170001
061800           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               06180001
061900     ELSE                                                         06190001
062000        IF H-LOS < 16                                             06200001
062100           MOVE 'A5103' TO PPS-PRICED-CMG-CODE                    06210001
062200           SET DX6 TO 91                                          06220001
062300           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               06230001
062400        ELSE                                                      06240001
062500           MOVE 'A5104' TO PPS-PRICED-CMG-CODE                    06250001
062600           SET DX6 TO 92                                          06260001
062700           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT.              06270001
062800                                                                  06280001
062900 3000-EXIT.                                                       06290001
063000      EXIT.                                                       06300001
063100                                                                  06310001
063200 3500-CONTINUE-CALC.                                              06320001
063300                                                                  06330001
063400     COMPUTE PPS-STANDARD-PAY-AMT =                               06340001
063500            (PPS-TRANSFER-PCT * PPS-RELATIVE-WGT                  06350001
063600                      * PPS-BDGT-NEUT-CONV-AMT).                  06360001
063700                                                                  06370001
063800***************************************************************   06380001
063900*      CHANGE RURAL ADJUSTMENT AMOUNT IF NECESSARY            *   06390001
064000***************************************************************   06400001
064100     PERFORM 3510-CHECK-RURAL-ADJ         THRU 3510-EXIT.         06410001
064200                                                                  06420001
064300***************************************************************   06430001
064400*      CHANGE RURAL ADJUSTMENT BASED ON RELIEF INDICATOR      *   06440001
064500*       IF NECESSARY - PER CHANGE REQUEST                     *   06450001
064600***************************************************************   06460001
064700** REMOVED FOR 2008 RELEASE                                       06470001
064800**   IF P-NEW-TEMP-RELIEF-IND = 'Y'                               06480001
064900**      MOVE 1.0638 TO PPS-RURAL-ADJUSTMENT.                      06490001
065000                                                                  06500001
065100     COMPUTE H-LABOR-PORTION =                                    06510001
065200        (PPS-STANDARD-PAY-AMT * PPS-NAT-LABOR-PCT)                06520001
065300          * PPS-WAGE-INDEX.                                       06530001
065400                                                                  06540001
065500     COMPUTE H-NONLABOR-PORTION =                                 06550001
065600        (PPS-STANDARD-PAY-AMT * PPS-NAT-NONLABOR-PCT).            06560001
065700                                                                  06570001
065800     COMPUTE PPS-FED-PAY-AMT ROUNDED =                            06580001
065900        ((H-LABOR-PORTION + H-NONLABOR-PORTION) *                 06590001
066000         PPS-RURAL-ADJUSTMENT).                                   06600001
066100                                                                  06610001
066200     COMPUTE PPS-LIP-PAY-AMT ROUNDED =                            06620001
066300        (PPS-FED-PAY-AMT * PPS-LIP-PCT).                          06630001
066400                                                                  06640001
066500     COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                          06650001
066600        (PPS-FED-PAY-AMT * H-TEACH-PCT).                          06660001
066700                                                                  06670001
066800 3500-EXIT.                                                       06680001
066900      EXIT.                                                       06690001
067000                                                                  06700001
067100***************************************************************   06710001
067200* EFFECTIVE FY2018, REMOVED RURAL-TO-URBAN CODING             *   06720001
067300***************************************************************   06730001
067400 3510-CHECK-RURAL-ADJ.                                            06740001
067500                                                                  06750001
067600     MOVE 1.0000          TO PPS-RURAL-ADJUSTMENT                 06760001
068600                                                                  06860001
068700     IF W-NEW-CBSA (1:3) = '   '                                  06870001
068800        MOVE 1.1490 TO PPS-RURAL-ADJUSTMENT                       06880001
068810     ELSE                                                         06881001
068820        MOVE 1.0000 TO PPS-RURAL-ADJUSTMENT.                      06882001
068830                                                                  06883001
068840 3510-EXIT.                                                       06884001
068841      EXIT.                                                       06884101
068842                                                                  06884201
068843 4000-CALC-OUTLIER.                                               06884301
068844                                                                  06884401
068845     COMPUTE PPS-FAC-COSTS ROUNDED =                              06884501
068846         (B-COV-CHARGES * P-NEW-OPER-CSTCHG-RATIO).               06884601
068847                                                                  06884701
068848     COMPUTE H-OUTLIER-LABOR-PORTION =                            06884801
068849        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-LABOR-PCT)               06884901
068850              * PPS-WAGE-INDEX.                                   06885001
068860                                                                  06886001
068870     COMPUTE H-OUTLIER-NONLABOR-PORTION =                         06887001
068880        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-NONLABOR-PCT).           06888001
068890                                                                  06889001
068900     COMPUTE H-FP-OUTLIER-THRESHOLD ROUNDED =                     06890001
069000        ((H-OUTLIER-LABOR-PORTION + H-OUTLIER-NONLABOR-PORTION) * 06900001
069100         PPS-RURAL-ADJUSTMENT * (PPS-LIP-PCT + H-TEACH-PCT + 1)). 06910001
069200                                                                  06920001
069300     COMPUTE H-OUTLIER-THRESHOLD ROUNDED =                        06930001
069400        (PPS-FED-PAY-AMT + H-FP-OUTLIER-THRESHOLD +               06940001
069500         PPS-LIP-PAY-AMT + PPS-TEACH-PAY-AMT).                    06950001
069600                                                                  06960001
069700     IF PPS-FAC-COSTS > H-OUTLIER-THRESHOLD                       06970001
069800        COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                     06980001
069900           ((PPS-FAC-COSTS - H-OUTLIER-THRESHOLD) * .8).          06990001
070000                                                                  07000001
070100     COMPUTE H-CHG-OUTLIER-THRESHOLD ROUNDED =                    07010001
070200         H-OUTLIER-THRESHOLD / P-NEW-OPER-CSTCHG-RATIO.           07020001
070300                                                                  07030001
070400                                                                  07040001
070500 4000-EXIT.                                                       07050001
070600      EXIT.                                                       07060001
070700                                                                  07070001
070800 5000-FINAL-PAYMENTS.                                             07080001
070900                                                                  07090001
071000     IF B-SPEC-PAY-IND = '1' OR '3'                               07100001
071100         MOVE ZEROES TO PPS-OUTLIER-PAY-AMT.                      07110001
071200                                                                  07120001
071300     IF PPS-FED-RATE-PCT = 1.0000                                 07130001
071400         MOVE 0 TO PPS-FAC-SPEC-PAY-AMT                           07140001
071500     ELSE                                                         07150001
071600         COMPUTE PPS-FED-PAY-AMT ROUNDED =                        07160001
071700           (PPS-FED-RATE-PCT * PPS-FED-PAY-AMT)                   07170001
071800         COMPUTE PPS-FAC-SPEC-PAY-AMT ROUNDED =                   07180001
071900           (PPS-FAC-RATE-PCT * PPS-FAC-SPEC-RT-PREBLEND)          07190001
072000         COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                    07200001
072100           (PPS-FED-RATE-PCT * PPS-OUTLIER-PAY-AMT)               07210001
072200         COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                      07220001
072300           (PPS-FED-RATE-PCT * PPS-TEACH-PAY-AMT)                 07230001
072400         COMPUTE PPS-LIP-PAY-AMT ROUNDED =                        07240001
072500           (PPS-FED-RATE-PCT * PPS-LIP-PAY-AMT).                  07250001
072600                                                                  07260001
072700*    IF B-SPEC-PAY-IND = '2' OR '3'                               07270001
072800*       COMPUTE PPS-FED-PENALTY-AMT ROUNDED =                     07280001
072900*          (PPS-FED-PAY-AMT * .25)                                07290001
073000*       COMPUTE PPS-FED-PAY-AMT =                                 07300001
073100*          (PPS-FED-PAY-AMT - PPS-FED-PENALTY-AMT)                07310001
073200*       COMPUTE PPS-LIP-PENALTY-AMT ROUNDED =                     07320001
073300*          (PPS-LIP-PAY-AMT * .25)                                07330001
073400*       COMPUTE PPS-LIP-PAY-AMT =                                 07340001
073500*          (PPS-LIP-PAY-AMT - PPS-LIP-PENALTY-AMT)                07350001
073600*       COMPUTE PPS-OUT-PENALTY-AMT ROUNDED =                     07360001
073700*          (PPS-OUTLIER-PAY-AMT * .25)                            07370001
073800*       COMPUTE PPS-OUTLIER-PAY-AMT =                             07380001
073900*          (PPS-OUTLIER-PAY-AMT - PPS-OUT-PENALTY-AMT)            07390001
074000*       COMPUTE PPS-TEACH-PENALTY-AMT ROUNDED =                   07400001
074100*          (PPS-TEACH-PAY-AMT * .25)                              07410001
074200*       COMPUTE PPS-TEACH-PAY-AMT =                               07420001
074300*          (PPS-TEACH-PAY-AMT - PPS-TEACH-PENALTY-AMT)            07430001
074400*       COMPUTE PPS-TOTAL-PENALTY-AMT =                           07440001
074500*          (PPS-FED-PENALTY-AMT + PPS-LIP-PENALTY-AMT             07450001
074600*          + PPS-OUT-PENALTY-AMT + PPS-TEACH-PENALTY-AMT).        07460001
074700                                                                  07470001
074800     COMPUTE PPS-TOTAL-PAY-AMT ROUNDED =                          07480001
074900        (PPS-FED-PAY-AMT + PPS-FAC-SPEC-PAY-AMT                   07490001
075000         + PPS-OUTLIER-PAY-AMT + PPS-LIP-PAY-AMT +                07500001
075100         PPS-TEACH-PAY-AMT).                                      07510001
075200                                                                  07520001
075300     IF PPS-FED-RATE-PCT = 1.0000                                 07530001
075400        IF PPS-TRANSFER-PCT = 1.0000                              07540001
075500           IF PPS-OUTLIER-PAY-AMT > 0.0                           07550001
075600              MOVE 01 TO PPS-RTC                                  07560001
075700           ELSE                                                   07570001
075800              MOVE 00 TO PPS-RTC                                  07580001
075900        ELSE                                                      07590001
076000           IF PPS-OUTLIER-PAY-AMT > 0.0                           07600001
076100              MOVE 03 TO PPS-RTC                                  07610001
076200           ELSE                                                   07620001
076300              MOVE 02 TO PPS-RTC                                  07630001
076400     ELSE                                                         07640001
076500        IF PPS-TRANSFER-PCT = 1.0000                              07650001
076600           IF PPS-OUTLIER-PAY-AMT > 0.0                           07660001
076700              MOVE 05 TO PPS-RTC                                  07670001
076800           ELSE                                                   07680001
076900              MOVE 04 TO PPS-RTC                                  07690001
077000        ELSE                                                      07700001
077100           IF PPS-OUTLIER-PAY-AMT > 0.0                           07710001
077200              MOVE 07 TO PPS-RTC                                  07720001
077300           ELSE                                                   07730001
077400              MOVE 06 TO PPS-RTC.                                 07740001
077500                                                                  07750001
077600     IF B-SPEC-PAY-IND = '2' OR '3'                               07760001
077700        COMPUTE PPS-RTC = PPS-RTC + 10.                           07770001
077800     IF PPS-RTC = (01 OR 03 OR 05 OR 07                           07780001
077900                OR 11 OR 13 OR 15 OR 17)                          07790001
078000        IF ((PPS-REG-DAYS-USED + PPS-LTR-DAYS-USED) < H-LOS)      07800001
078100           OR PPS-COT-IND = 'Y'                                   07810001
078200            MOVE 67 TO PPS-RTC.                                   07820001
078300                                                                  07830001
078400 5000-EXIT.                                                       07840001
078500      EXIT.                                                       07850001
078600                                                                  07860001
078700 9000-MOVE-RESULTS.                                               07870001
078800                                                                  07880001
078900     IF PPS-RTC < 50                                              07890001
079000      MOVE H-LOS                   TO  PPS-LOS                    07900001
079100      MOVE H-OUTLIER-THRESHOLD     TO  PPS-OUTLIER-THRESHOLD      07910001
079200      MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD   07920001
079300      MOVE W-NEW-CBSA              TO  PPS-CBSA                   07930001
079400      MOVE 'V18.0'                 TO  PPS-CALC-VERS-CD           07940001
079500     ELSE                                                         07950001
079600       INITIALIZE PPS-DATA                                        07960001
079700       INITIALIZE PPS-OTHER-DATA                                  07970001
079800       MOVE 'V18.0'                TO  PPS-CALC-VERS-CD.          07980001
079900                                                                  07990001
080000     IF PPS-RTC = 67                                              08000001
080100       MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD. 08010001
080200                                                                  08020001
080300 9000-EXIT.                                                       08030001
080400      EXIT.                                                       08040001
080500***************************************************************   08050001
080600******        L A S T   S O U R C E   S T A T E M E N T   *****   08060001
080700***************************************************************   08070001
