000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.    IRCAL201.                                         00020000
000300*AUTHOR.        PBG/DDS.                                          00030000
000400*REMARKS.       CMS.                                              00040000
000500                                                                  00050000
000600 DATE-COMPILED.                                                   00060000
000610******************************************************************00061000
000620* CHANGES FOR FY2020 - EFFECTIVE 10/01/2019                      *00062000
000630*----------------------------------------------------------------*00063000
000631* IRCAL201 - A CORRECTION WAS MADE REGARDING RETURN CODES        *00063100
000632* RELATED TO TRANSFER CASES.  PPS-TRANSFER-PCT WAS REPLACE WITH  *00063200
000633* SW-XFER-CASE 'N' IN PARAGRAPH 5000-FINAL-PAYMENTS.             *00063300
000634*----------------------------------------------------------------*00063400
000635* UPDATED CMG-TABLE - ADDED 8 ADDITIONAL CMG'S                   *00063500
000636* UPDATED 0100-INITIAL-ROUTINE                                   *00063601
000637*                                                                *00063701
000638*   MOVE .72700 TO PPS-NAT-LABOR-PCT.                            *00063801
000639*   MOVE .27300 TO PPS-NAT-NONLABOR-PCT.                         *00063901
000640*   MOVE  9300  TO PPS-NAT-THRESHOLD-ADJ.                        *00064001
000641*   IF P-NEW-CBSA-HOSP-QUAL-IND IS EQUAL TO '1'                  *00064101
000642*      MOVE 16489  TO PPS-BDGT-NEUT-CONV-AMT                     *00064201
000643*   ELSE                                                         *00064301
000644*      MOVE 16167  TO PPS-BDGT-NEUT-CONV-AMT                     *00064401
000645*   END-IF.                                                      *00064501
000646*                                                                *00064601
000647*   NO CHANGE TO LOW INCOME PATIENT (LIP) ADJ = 0.3177           *00064701
000648*   NO CHANGE TO TEACHING ADJ = 1.0163                           *00064801
000649*   NO CHANGE TO RURAL-ADJUSTMENT                                *00064901
000650*   IF W-NEW-CBSA (1:3) = '   '                                  *00065001
000651*     MOVE 1.1490 TO PPS-RURAL-ADJUSTMENT                        *00065101
000652*   ELSE                                                         *00065201
000653*     MOVE 1.0000 TO PPS-RURAL-ADJUSTMENT.                       *00065301
000654*                                                                *00065401
000655*   FOR TRANSFER CASES, THE STANDARD PAYMENT IS NOW COMPUTED     *00065501
000656*   USING THE PER DIEM - 3000-CALC-PAYMENT                       *00065601
000657*                                                                *00065701
000658******************************************************************00065801
000659     EJECT                                                        00065901
000660 ENVIRONMENT DIVISION.                                            00066001
000670 CONFIGURATION SECTION.                                           00067001
000671 SOURCE-COMPUTER.            IBM-370.                             00067101
000672 OBJECT-COMPUTER.            IBM-370.                             00067201
000673 INPUT-OUTPUT  SECTION.                                           00067301
000674 FILE-CONTROL.                                                    00067401
000675                                                                  00067501
000676 DATA DIVISION.                                                   00067601
000677 FILE SECTION.                                                    00067701
000678                                                                  00067801
000679 WORKING-STORAGE SECTION.                                         00067901
000680 01  W-STORAGE-REF                  PIC X(46)  VALUE              00068001
000690     'IRCAL201      - W O R K I N G   S T O R A G E'.             00069001
000700 01  CAL-VERSION                    PIC X(05)  VALUE 'V20.1'.     00070001
000800 01  SW-XFER-CASE                   PIC X(01)  VALUE 'N'.         00080001
000900     EJECT                                                        00090001
001000***************************************************************   00100001
001100*    FY2020 CMG TABLE                                         *   00110001
001110***************************************************************   00111001
001120 01  CMG-TABLE.                                                   00112001
001130     05  CMG-TABLE-DATA.                                          00113001
001131         10                      PIC X(32)   VALUE                00113101
001132           '01011035108965083000790611111009'.                    00113201
001133         10                      PIC X(32)   VALUE                00113301
001134           '01021315011389105451004513131212'.                    00113401
001135         10                      PIC X(32)   VALUE                00113501
001136           '01031679014541134641282515161515'.                    00113601
001137         10                      PIC X(32)   VALUE                00113701
001138           '01042195819017176081677219201919'.                    00113801
001139         10                      PIC X(32)   VALUE                00113901
001140           '01052430021046194871856222222120'.                    00114001
001141         10                      PIC X(32)   VALUE                00114101
001142           '01062836024562227422166327262424'.                    00114201
001143         10                      PIC X(32)   VALUE                00114301
001144           '02011159309500085680799211111010'.                    00114401
001145         10                      PIC X(32)   VALUE                00114501
001146           '02021436611772106180990313131212'.                    00114601
001147         10                      PIC X(32)   VALUE                00114701
001148           '02031748714330129241205515161414'.                    00114801
001149         10                      PIC X(32)   VALUE                00114901
001150           '02042133917487157721471021191716'.                    00115001
001151         10                      PIC X(32)   VALUE                00115101
001152           '02052663121823196831835831242119'.                    00115201
001153         10                      PIC X(32)   VALUE                00115301
001154           '03011228009995092180861811111010'.                    00115401
001155         10                      PIC X(32)   VALUE                00115501
001156           '03021560312700117121095014141313'.                    00115601
001157         10                      PIC X(32)   VALUE                00115701
001158           '03031881415313141231320317161515'.                    00115801
001159         10                      PIC X(32)   VALUE                00115901
001160           '03042109717171158361480520181716'.                    00116001
001161         10                      PIC X(32)   VALUE                00116101
001162           '03052288918630171821606321201817'.                    00116201
001163         10                      PIC X(32)   VALUE                00116301
001164           '04011370211748107530986014131212'.                    00116401
001165         10                      PIC X(32)   VALUE                00116501
001166           '04021798715423141171294415181615'.                    00116601
001167         10                      PIC X(32)   VALUE                00116701
001168           '04032174918649170701565220201918'.                    00116801
001169         10                      PIC X(32)   VALUE                00116901
001170           '04043194427390250702298836312723'.                    00117001
001171         10                      PIC X(32)   VALUE                00117101
001172           '04052720623328213521957827272321'.                    00117201
001173         10                      PIC X(32)   VALUE                00117301
001174           '04063326628523261082393939322726'.                    00117401
001175         10                      PIC X(32)   VALUE                00117501
001176           '04074120335330323372965149373236'.                    00117601
001177         10                      PIC X(32)   VALUE                00117701
001178           '05011269610371096140879813121110'.                    00117801
001179         10                      PIC X(32)   VALUE                00117901
001180           '05021585912954120091099015141313'.                    00118001
001181         10                      PIC X(32)   VALUE                00118101
001182           '05031827314926138371266317151514'.                    00118201
001183         10                      PIC X(32)   VALUE                00118301
001184           '05042220918141168171539020191817'.                    00118401
001185         10                      PIC X(32)   VALUE                00118501
001186           '05052836223166214771965430242321'.                    00118601
001187         10                      PIC X(32)   VALUE                00118701
001188           '06011343110441097480886412111110'.                    00118801
001189         10                      PIC X(32)   VALUE                00118901
001190           '06021664112937120781098314141312'.                    00119001
001191         10                      PIC X(32)   VALUE                00119101
001192           '06031960615242142301294016161514'.                    00119201
001193         10                      PIC X(32)   VALUE                00119301
001194           '06042253517519163561487320181716'.                    00119401
001195         10                      PIC X(32)   VALUE                00119501
001196           '07011251110096096440877112121110'.                    00119601
001197         10                      PIC X(32)   VALUE                00119701
001198           '07021566012636120721097814141313'.                    00119801
001199         10                      PIC X(32)   VALUE                00119901
001200           '07031896015299146151329117171615'.                    00120001
001201         10                      PIC X(32)   VALUE                00120101
001202           '07042144317303165291503218181817'.                    00120201
001203         10                      PIC X(32)   VALUE                00120301
001204           '08011061108826079920743410100909'.                    00120401
001205         10                      PIC X(32)   VALUE                00120501
001206           '08021250610402094190876211121110'.                    00120601
001207         10                      PIC X(32)   VALUE                00120701
001208           '08031402811669105660982913131211'.                    00120801
001209         10                      PIC X(32)   VALUE                00120901
001210           '08041613313419121511130415151313'.                    00121001
001211         10                      PIC X(32)   VALUE                00121101
001212           '08051920215973144631345416171515'.                    00121201
001213         10                      PIC X(32)   VALUE                00121301
001214           '09011206609641089500824311111010'.                    00121401
001215         10                      PIC X(32)   VALUE                00121501
001216           '09021526212196113211042713141312'.                    00121601
001217         10                      PIC X(32)   VALUE                00121701
001218           '09031793714333133051225415151414'.                    00121801
001219         10                      PIC X(32)   VALUE                00121901
001220           '09042035816268151011390818171615'.                    00122001
001221         10                      PIC X(32)   VALUE                00122101
001222           '10011285410952099150911012131111'.                    00122201
001223         10                      PIC X(32)   VALUE                00122301
001224           '10021601913648123571135315151313'.                    00122401
001225         10                      PIC X(32)   VALUE                00122501
001226           '10031848315748142581310016171615'.                    00122601
001227         10                      PIC X(32)   VALUE                00122701
001228           '10042148018301165701522418191816'.                    00122801
001229         10                      PIC X(32)   VALUE                00122901
001230           '11011420211802106830894313131210'.                    00123001
001231         10                      PIC X(32)   VALUE                00123101
001232           '11021763314653132641110315141413'.                    00123201
001233         10                      PIC X(32)   VALUE                00123301
001234           '11032022316806152121273417191514'.                    00123401
001235         10                      PIC X(32)   VALUE                00123501
001236           '12011237809532092560860011111010'.                    00123601
001237         10                      PIC X(32)   VALUE                00123701
001238           '12021575312131117801094414141313'.                    00123801
001239         10                      PIC X(32)   VALUE                00123901
001240           '12031799813860134591250515161514'.                    00124001
001241         10                      PIC X(32)   VALUE                00124101
001242           '12041914814746143181330315151615'.                    00124201
001243         10                      PIC X(32)   VALUE                00124301
001244           '13011166709831093150857911111010'.                    00124401
001245         10                      PIC X(32)   VALUE                00124501
001246           '13021426912023113921049212141212'.                    00124601
001247         10                      PIC X(32)   VALUE                00124701
001248           '13031681614169134251236513151414'.                    00124801
001249         10                      PIC X(32)   VALUE                00124901
001250           '13041903616040151981399716171615'.                    00125001
001251         10                      PIC X(32)   VALUE                00125101
001252           '13051876815814149841380014171614'.                    00125201
001253         10                      PIC X(32)   VALUE                00125301
001254           '14011142509303085760770711111009'.                    00125401
001255         10                      PIC X(32)   VALUE                00125501
001256           '14021437611706107920969813131211'.                    00125601
001257         10                      PIC X(32)   VALUE                00125701
001258           '14031734614125130211170215151413'.                    00125801
001259         10                      PIC X(32)   VALUE                00125901
001260           '14042020116450151651362818171615'.                    00126001
001261         10                      PIC X(32)   VALUE                00126101
001262           '15011244610612097690928011111010'.                    00126201
001263         10                      PIC X(32)   VALUE                00126301
001264           '15021508212859118381124513131212'.                    00126401
001265         10                      PIC X(32)   VALUE                00126501
001266           '15031776115143139401324215141413'.                    00126601
001267         10                      PIC X(32)   VALUE                00126701
001268           '15042039117385160051520320171515'.                    00126801
001269         10                      PIC X(32)   VALUE                00126901
001270           '16011131208992084920783610111009'.                    00127001
001271         10                      PIC X(32)   VALUE                00127101
001272           '16021396311099104820967211111211'.                    00127201
001273         10                      PIC X(32)   VALUE                00127301
001274           '16031623412904121871124513141313'.                    00127401
001275         10                      PIC X(32)   VALUE                00127501
001276           '16041891015031141961309814151514'.                    00127601
001277         10                      PIC X(32)   VALUE                00127701
001278           '17011409811015103100940412121211'.                    00127801
001279         10                      PIC X(32)   VALUE                00127901
001280           '17021729313512126471153615141413'.                    00128001
001281         10                      PIC X(32)   VALUE                00128101
001282           '17032009215699146941340317171615'.                    00128201
001283         10                      PIC X(32)   VALUE                00128301
001284           '17042223117369162581482920181717'.                    00128401
001285         10                      PIC X(32)   VALUE                00128501
001286           '17052414018861176541610321201917'.                    00128601
001287         10                      PIC X(32)   VALUE                00128701
001288           '18011178809975089080815113111010'.                    00128801
001289         10                      PIC X(32)   VALUE                00128901
001290           '18021525812911115301055115151312'.                    00129001
001291         10                      PIC X(32)   VALUE                00129101
001292           '18031889115984142751306319181515'.                    00129201
001293         10                      PIC X(32)   VALUE                00129301
001294           '18042188818521165411513626211816'.                    00129401
001295         10                      PIC X(32)   VALUE                00129501
001296           '18052576021797194671781327222020'.                    00129601
001297         10                      PIC X(32)   VALUE                00129701
001298           '18063440129109259962378840312825'.                    00129801
001299         10                      PIC X(32)   VALUE                00129901
001300           '19011229709638092580902613111111'.                    00130001
001301         10                      PIC X(32)   VALUE                00130101
001302           '19021729913558130241269717171415'.                    00130201
001303         10                      PIC X(32)   VALUE                00130301
001304           '19032627020589197781928226232221'.                    00130401
001305         10                      PIC X(32)   VALUE                00130501
001306           '19043727429213280632735944302930'.                    00130601
001307         10                      PIC X(32)   VALUE                00130701
001308           '20011212709812091070826811111010'.                    00130801
001309         10                      PIC X(32)   VALUE                00130901
001310           '20021494812094112251019213131212'.                    00131001
001311         10                      PIC X(32)   VALUE                00131101
001312           '20031751514171131521194215151413'.                    00131201
001313         10                      PIC X(32)   VALUE                00131301
001314           '20041967915922147781341718171615'.                    00131401
001315         10                      PIC X(32)   VALUE                00131501
001316           '20052102017007157851433219181616'.                    00131601
001317         10                      PIC X(32)   VALUE                00131701
001318           '21011542312723118091061415131312'.                    00131801
001319         10                      PIC X(32)   VALUE                00131901
001320           '21022203618179168731516522191617'.                    00132001
001321         10                      PIC X(32)   VALUE                00132101
001322           '50010000000000000000181600000003'.                    00132201
001323         10                      PIC X(32)   VALUE                00132301
001324           '51010000000000000000570300000006'.                    00132401
001325         10                      PIC X(32)   VALUE                00132501
001326           '51020000000000000001793900000018'.                    00132601
001327         10                      PIC X(32)   VALUE                00132701
001328           '51030000000000000000674000000007'.                    00132801
001329         10                      PIC X(32)   VALUE                00132901
001330           '51040000000000000002195600000022'.                    00133001
001331         10                      PIC X(32)   VALUE                00133101
001332           '99990000000000000000000000000000'.                    00133201
001333     05  W-CMG-TABLE REDEFINES CMG-TABLE-DATA.                    00133301
001334         10  CMG-DATA            OCCURS 101 TIMES                 00133401
001335                                 ASCENDING KEY IS CMG-NUM         00133501
001336                                 INDEXED BY DX6.                  00133601
001337             15  CMG-NUM         PIC X(4).                        00133701
001338             15  CMG-NUM-REDEF REDEFINES CMG-NUM.                 00133801
001339                 20  CMG-RIC     PIC XX.                          00133901
001340                 20  FILLER      PIC XX.                          00134001
001341             15  B-REL-WGT       PIC 9(1)V9(4).                   00134101
001342             15  C-REL-WGT       PIC 9(1)V9(4).                   00134201
001343             15  D-REL-WGT       PIC 9(1)V9(4).                   00134301
001344             15  A-REL-WGT       PIC 9(1)V9(4).                   00134401
001345             15  B-LOS-TABLE     PIC 9(2).                        00134501
001346             15  C-LOS-TABLE     PIC 9(2).                        00134601
001347             15  D-LOS-TABLE     PIC 9(2).                        00134701
001348             15  A-LOS-TABLE     PIC 9(2).                        00134801
001349     EJECT                                                        00134901
001350 01  HOLD-PPS-COMPONENTS.                                         00135001
001360     05  H-LOS                        PIC 9(05).                  00136001
001370     05  H-WK-DSH                     PIC 9(01)V9(04).            00137001
001380     05  H-TEACH-PCT                  PIC 9(01)V9(04).            00138001
001390     05  H-LABOR-PORTION              PIC 9(07)V9(06).            00139001
001400     05  H-NONLABOR-PORTION           PIC 9(07)V9(06).            00140001
001500     05  H-OUTLIER-LABOR-PORTION      PIC 9(07)V9(06).            00150001
001600     05  H-OUTLIER-NONLABOR-PORTION   PIC 9(07)V9(06).            00160001
001700     05  H-FP-OUTLIER-THRESHOLD       PIC 9(07)V9(06).            00170001
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).                  00200000
002100     05  H-DISCHARGE-DATE             PIC 9(08).                  00210000
002200                                                                  00220000
002300 LINKAGE SECTION.                                                 00230000
002400**************************************************************    00240000
002500*      THIS IS THE BILL-RECORD THAT WILL BE PASSED FROM      *    00250000
002600*      THE IRCAL___ PROGRAM                                  *    00260000
002700**************************************************************    00270000
002800 01  BILL-NEW-DATA.                                               00280000
002900         10  B-NPI10.                                             00290000
003000             15  B-NPI8             PIC X(08).                    00300000
003100             15  B-NPI-FILLER       PIC X(02).                    00310000
003200         10  B-PROVIDER-NO          PIC X(06).                    00320000
003300         10  B-PATIENT-STATUS       PIC X(02).                    00330000
003400         10  B-CMG-CODE             PIC X(05).                    00340000
003500         10  B-LOS                  PIC 9(03).                    00350000
003600         10  B-COV-DAYS             PIC 9(03).                    00360000
003700         10  B-LTR-DAYS             PIC 9(02).                    00370000
003800         10  B-SPEC-PAY-IND         PIC X(01).                    00380000
003900         10  B-DISCHARGE-DATE.                                    00390000
004000             15  B-DISCHG-CC        PIC 9(02).                    00400000
004100             15  B-DISCHG-YY        PIC 9(02).                    00410000
004200             15  B-DISCHG-MM        PIC 9(02).                    00420000
004300             15  B-DISCHG-DD        PIC 9(02).                    00430000
004400         10  B-COV-CHARGES          PIC 9(07)V9(02).              00440000
004500         10  FILLER                 PIC X(11).                    00450000
004600                                                                  00460000
004700***************************************************************   00470000
004800*    THIS DATA IS CALCULATED BY THIS IRCAL SUBROUTINE         *   00480000
004900*    AND PASSED BACK TO THE CALLING PROGRAM                   *   00490000
005000*            RETURN CODE VALUES (PPS-RTC)                     *   00500000
005100*                                                             *   00510000
005200*     ****   PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   00520000
005300*              00 = PAID NORMAL CMG PAYMENT WITHOUT OUTLIER   *   00530000
005400*                                                             *   00540000
005500*              01 = PAID NORMAL CMG PAYMENT WITH OUTLIER      *   00550000
005600*                                                             *   00560000
005700*              02 = TRANSFER PAID ON A PERDIEM BASIS WITHOUT  *   00570000
005800*                   OUTLIER                                   *   00580000
005900*              03 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   00590000
006000*                   OUTLIER                                   *   00600000
006100*              04 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   00610000
006200*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   00620000
006300*                   WITHOUT OUTLIER                           *   00630000
006400*              05 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   00640000
006500*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   00650000
006600*                   WITH OUTLIER                              *   00660000
006700*              06 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   00670000
006800*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   00680000
006900*                   RATE -- WITHOUT OUTLIER                   *   00690000
007000*              07 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   00700000
007100*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   00710000
007200*                   RATE -- WITH OUTLIER                      *   00720000
007300*       **** NEW RT CODES FOR PAYMENT WITH PENALTIES          *   00730000
007400*              10 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   00740000
007500*                   WITHOUT OUTLIER                           *   00750000
007600*              11 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   00760000
007700*                   WITH OUTLIER                              *   00770000
007800*              12 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   00780000
007900*                   PENALTY WITHOUT OUTLIER                   *   00790000
008000*              13 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   00800000
008100*                   PENALTY WITH OUTLIER                      *   00810000
008200*              14 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   00820000
008300*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   00830000
008400*                   WITH PENALTY WITHOUT OUTLIER              *   00840000
008500*              15 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   00850000
008600*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   00860000
008700*                   WITH PENALTY WITH OUTLIER                 *   00870000
008800*              16 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   00880000
008900*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   00890000
009000*                   RATE -- WITH PENALTY WITHOUT OUTLIER      *   00900000
009100*              17 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   00910000
009200*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   00920000
009300*                   RATE -- WITH PENALTY WITH OUTLIER         *   00930000
009400*                                                             *   00940000
009500*      ****  PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   00950000
009600*              50 = PROVIDER SPECIFIC RATE NOT NUMERIC        *   00960000
009700*              51 = PROVIDER RECORD TERMINATED                *   00970000
009800*              52 = INVALID WAGE INDEX                        *   00980000
009900*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   00990000
010000*              54 = CMG ON CLAIM NOT FOUND IN TABLE           *   01000000
010100*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   01010000
010200*                                      OR                     *   01020000
010300*                   DISCHARGE DATE < MSA EFF START DATE       *   01030000
010400*                   FOR PPS                                   *   01040000
010500*              56 = INVALID LENGTH OF STAY                    *   01050000
010600*              57 = PROVIDER SPECIFIC RATE ZERO WHEN BLENDED  *   01060000
010700*                   PAYMENT REQUESTED                         *   01070000
010800*              58 = TOTAL COVERED CHARGES NOT NUMERIC         *   01080000
010900*              59 = PROVIDER SPECIFIC RECORD NOT FOUND        *   01090000
011000*              60 = MSA WAGE INDEX RECORD NOT FOUND           *   01100000
011100*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   01110000
011200*                   OR BILL-LTR-DAYS > 60                     *   01120000
011300*              62 = INVALID NUMBER OF COVERED DAYS            *   01130000
011400*              65 = OPERATING COST-TO-CHARGE RATIO NOT NUMERIC*   01140000
011500*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   01150000
011600*                   OR COST OUTLIER THRESHOLD CALCULATION     *   01160000
011700*              72 = INVALID BLEND INDICATOR (NOT 3 OR 4)      *   01170000
011800*              73 = DISCHARGED BEFORE PROVIDER FY BEGIN       *   01180000
011900*              74 = PROVIDER FY BEGIN DATE NOT IN 2002        *   01190000
012000***************************************************************   01200000
012100 01  PPS-DATA-ALL.                                                01210000
012200     05  PPS-RTC                      PIC 9(02).                  01220000
012300     05  PPS-DATA.                                                01230000
012400         10  PPS-MSA                  PIC X(04).                  01240000
012500         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).            01250000
012600         10  PPS-AVG-LOS              PIC 9(02).                  01260000
012700         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).            01270000
012800         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).            01280000
012900         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).            01290000
013000         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).            01300000
013100         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).            01310000
013200         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).            01320000
013300         10  PPS-LIP-PCT              PIC 9(01)V9(04).            01330000
013400         10  PPS-LOS                  PIC 9(03).                  01340000
013500         10  PPS-REG-DAYS-USED        PIC 9(03).                  01350000
013600         10  PPS-LTR-DAYS-USED        PIC 9(03).                  01360000
013700         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).            01370000
013800         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).            01380000
013900         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).            01390000
014000         10  PPS-FAC-COSTS            PIC 9(07)V9(02).            01400000
014100         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).            01410000
014200         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).           01420000
014300         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).            01430000
014400         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).            01440000
014500         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).            01450000
014600         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).            01460000
014700         10  PPS-SUBM-CMG-CODE        PIC X(05).                  01470000
014800         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.      01480000
014900            15  PPS-CMG-ALPHA         PIC X(01).                  01490000
015000            15  PPS-CMG-NUMERIC.                                  01500000
015100               20  PPS-CMG-RIC        PIC X(02).                  01510000
015200               20  FILLER             PIC X(02).                  01520000
015300         10  PPS-PRICED-CMG-CODE      PIC X(05).                  01530000
015400         10  PPS-CALC-VERS-CD         PIC X(05).                  01540000
015500         10  PPS-CBSA                 PIC X(05).                  01550000
015600         10  FILLER                   PIC X(08).                  01560000
015700     05  PPS-OTHER-DATA.                                          01570000
015800         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).            01580000
015900         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).            01590000
016000         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).            01600000
016100         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).            01610000
016200         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).            01620000
016300         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).            01630000
016400         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).            01640000
016500         10  PPS-TEACH-PAY-AMT        PIC 9(07)V9(02).            01650000
016600         10  PPS-TEACH-PENALTY-AMT    PIC 9(07)V9(02).            01660000
016700         10  FILLER                   PIC X(02).                  01670000
016800     05  PPS-PC-DATA.                                             01680000
016900         10  PPS-COT-IND              PIC X(01).                  01690000
017000         10  FILLER                   PIC X(20).                  01700000
017100                                                                  01710000
017200******************************************************************01720000
017300*            THESE ARE THE VERSIONS OF THE IRDRV___               01730000
017400*           PROGRAMS THAT WILL BE PASSED BACK----                 01740000
017500*          ASSOCIATED WITH THE BILL BEING PROCESSED               01750000
017600******************************************************************01760000
017700 01  PRICER-OPT-VERS-SW.                                          01770000
017800     05  PRICER-OPTION-SW          PIC X(01).                     01780000
017900         88  ALL-TABLES-PASSED          VALUE 'A'.                01790000
018000         88  PROV-RECORD-PASSED         VALUE 'P'.                01800000
018100     05  PPS-VERSIONS.                                            01810000
018200         10  PPDRV-VERSION         PIC X(05).                     01820000
018300                                                                  01830000
018400**************************************************************    01840000
018500*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BY        *    01850000
018600*      THE IRCAL___ PROGRAM                                  *    01860000
018700**************************************************************    01870000
018800 01  PROV-NEW-HOLD.                                               01880000
018900     02  PROV-NEWREC-HOLD1.                                       01890000
019000         05  P-NEW-NPI10.                                         01900000
019100             10  P-NEW-NPI8             PIC X(08).                01910000
019200             10  P-NEW-NPI-FILLER       PIC X(02).                01920000
019300         05  P-NEW-PROVIDER-NO.                                   01930000
019400             10  P-NEW-STATE            PIC 9(02).                01940000
019500             10  FILLER                 PIC X(04).                01950000
019600         05  P-NEW-DATE-DATA.                                     01960000
019700             10  P-NEW-EFF-DATE.                                  01970000
019800                 15  P-NEW-EFF-DT-CC    PIC 9(02).                01980000
019900                 15  P-NEW-EFF-DT-YY    PIC 9(02).                01990000
020000                 15  P-NEW-EFF-DT-MM    PIC 9(02).                02000000
020100                 15  P-NEW-EFF-DT-DD    PIC 9(02).                02010000
020200             10  P-NEW-FY-BEGIN-DATE.                             02020000
020300                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                02030000
020400                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                02040000
020500                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                02050000
020600                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                02060000
020700             10  P-NEW-REPORT-DATE.                               02070000
020800                 15  P-NEW-REPORT-DT-CC PIC 9(02).                02080000
020900                 15  P-NEW-REPORT-DT-YY PIC 9(02).                02090000
021000                 15  P-NEW-REPORT-DT-MM PIC 9(02).                02100000
021100                 15  P-NEW-REPORT-DT-DD PIC 9(02).                02110000
021200             10  P-NEW-TERMINATION-DATE.                          02120000
021300                 15  P-NEW-TERM-DT-CC   PIC 9(02).                02130000
021400                 15  P-NEW-TERM-DT-YY   PIC 9(02).                02140000
021500                 15  P-NEW-TERM-DT-MM   PIC 9(02).                02150000
021600                 15  P-NEW-TERM-DT-DD   PIC 9(02).                02160000
021700         05  P-NEW-WAIVER-CODE          PIC X(01).                02170000
021800             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              02180000
021900         05  P-NEW-INTER-NO             PIC 9(05).                02190000
022000         05  P-NEW-PROVIDER-TYPE        PIC X(02).                02200000
022100         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                02210000
022200         05  P-NEW-CURRENT-DIV   REDEFINES                        02220000
022300                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         02230000
022400         05  P-NEW-MSA-DATA.                                      02240000
022500             10  P-NEW-CHG-CODE-INDEX       PIC X.                02250000
022600             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 02260000
022700             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   02270000
022800                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       02280000
022900             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 02290000
023000             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 02300000
023100             10  P-NEW-STAND-AMT-LOC-MSA9                         02310000
023200                 REDEFINES P-NEW-STAND-AMT-LOC-MSA.               02320000
023300                 15  P-NEW-RURAL-1ST.                             02330000
023400                     20  P-NEW-STAND-RURAL  PIC XX.               02340000
023500                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    02350000
023600                 15  P-NEW-RURAL-2ND        PIC XX.               02360000
023700         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    02370000
023800         05  P-NEW-LUGAR                    PIC X.                02380000
023900         05  P-NEW-TEMP-RELIEF-IND          PIC X.                02390000
024000         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                02400000
024100         05  FILLER                         PIC X(05).            02410000
024200     02  PROV-NEWREC-HOLD2.                                       02420000
024300         05  P-NEW-VARIABLES.                                     02430000
024400             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        02440000
024500             10  P-NEW-COLA              PIC  9(01)V9(03).        02450000
024600             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        02460000
024700             10  P-NEW-BED-SIZE          PIC  9(05).              02470000
024800             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        02480000
024900             10  P-NEW-CMI               PIC  9(01)V9(04).        02490000
025000             10  P-NEW-SSI-RATIO         PIC  V9(04).             02500000
025100             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             02510000
025200             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              02520000
025300             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        02530000
025400             10  P-NEW-DSH-PERCENT       PIC  V9(04).             02540000
025500             10  P-NEW-FYE-DATE          PIC  X(08).              02550000
025600         05  P-NEW-CBSA-DATA.                                     02560000
025700             10  P-NEW-CBSA-SPEC-PAY-IND   PIC X.                 02570000
025800             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 02580000
025900             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  02590000
026000             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  02600000
026100             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  02610000
026200             10  P-NEW-CBSA-STAND-AMT-LOC9                        02620000
026300                 REDEFINES P-NEW-CBSA-STAND-AMT-LOC.              02630000
026400                 15  P-NEW-CBSA-RURAL-1ST.                        02640000
026500                     20  P-NEW-CBSA-STAND-RURAL PIC 999.          02650000
026600                 15  P-NEW-CBSA-RURAL-2ND       PIC 99.           02660000
026700             10  P-NEW-CBSA-SPEC-WAGE-INDEX     PIC 9(02)V9(04).  02670000
026800     02  PROV-NEWREC-HOLD3.                                       02680000
026900         05  P-NEW-PASS-AMT-DATA.                                 02690000
027000             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          02700000
027100             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          02710000
027200             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          02720000
027300             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          02730000
027400         05  P-NEW-CAPI-DATA.                                     02740000
027500             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 02750000
027600             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          02760000
027700             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          02770000
027800             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        02780000
027900             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             02790000
028000             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 02800000
028100             15  P-NEW-CAPI-IME            PIC 9V9999.            02810000
028200             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          02820000
028300             15  P-VAL-BASED-PURCH-SCORE   PIC 9V999.             02830000
028400         05  FILLER                        PIC X(18).             02840000
028500******************************************************************02850000
028600*                   THIS IS THE WAGE-INDEX                        02860000
028700*          ASSOCIATED WITH THE BILL BEING PROCESSED               02870000
028800*                                                                 02880000
028900******************************************************************02890000
029000 01  WAGE-NEW-INDEX-RECORD-CBSA.                                  02900000
029100     05  W-NEW-CBSA                    PIC X(5).                  02910000
029200*       88  VALID-RURAL-CBSA    VALUE                             02920000
029300*             '50001' '50007' '50016' '50020' '50031'             02930000
029400*             '50036' '50054' '50060' '50067' '50087'             02940000
029500*             '50089' '50091' '50092' '50100' '50104'             02950000
029600*             '50108' '50114' '50121' '50125' '50140'             02960000
029700*             '50145' '50152' '50164' '50170' '50192'             02970000
029800*             '50199' '50206' '50210' '50214' '50218'             02980000
029900*             '50222' '50225' '50226' '50231' '50234'             02990000
030000*             '50237' '50243' '50248' '50250' '50255'             03000000
030100*             '50256' '50257' '50260' '50261' '50262'             03010000
030200*             '50263' '50266' '50268' '50272' '50275'             03020000
030300*             '50281' '50286' '50293' '50313' '50314'             03030000
030400*             '50316' '50325' '50326' '50327' '50329'             03040000
030500*             '50336' '50344' '50352'.                            03050000
030600     05  W-NEW-EFF-DATE-C              PIC X(8).                  03060000
030700     05  W-NEW-WAGE-INDEX-C            PIC S9(02)V9(04).          03070000
030800                                                                  03080000
030900 PROCEDURE DIVISION  USING BILL-NEW-DATA                          03090000
031000                           PPS-DATA-ALL                           03100000
031100                           PRICER-OPT-VERS-SW                     03110000
031200                           PROV-NEW-HOLD                          03120000
031300                           WAGE-NEW-INDEX-RECORD-CBSA.            03130000
031400***************************************************************   03140000
031500*    PROCESSING:                                              *   03150000
031600*        A. WILL PROCESS CLAIMS BASED ON DISCHARGE DATE       *   03160000
031700*        B. INITIALIZE IRCAL HOLD VARIABLES.                  *   03170000
031800*        C. EDIT THE DATA PASSED FROM THE CLAIM BEFORE        *   03180000
031900*           ATTEMPTING TO CALCULATE PPS. IF THIS CLAIM        *   03190000
032000*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   03200000
032100*           GOBACK.                                           *   03210000
032200*        D. ASSEMBLE PRICING COMPONENTS.                      *   03220000
032300*        E. CALCULATE THE PRICE.                              *   03230000
032400*        F. CALCULATE OUTLIERS IF APPLICABLE.                 *   03240000
032500***************************************************************   03250000
032600                                                                  03260000
032700 0000-MAINLINE-CONTROL.                                           03270000
032800                                                                  03280001
032900     PERFORM 0100-INITIAL-ROUTINE                                 03290000
033000        THRU 0100-EXIT.                                           03300000
033100                                                                  03310000
033200     PERFORM 1000-EDIT-THE-BILL-INFO                              03320000
033300        THRU 1000-EXIT.                                           03330000
033400                                                                  03340000
033500     IF PPS-RTC = 00                                              03350000
033600        PERFORM 1700-EDIT-CMG-CODE                                03360000
033700           THRU 1700-EXIT.                                        03370000
033800                                                                  03380000
033900     IF PPS-RTC = 00                                              03390000
034000        PERFORM 2000-ASSEMBLE-PPS-VARIABLES                       03400000
034100           THRU 2000-EXIT.                                        03410000
034200                                                                  03420000
034300     IF PPS-RTC = 00                                              03430000
034400        PERFORM 3000-CALC-PAYMENT                                 03440000
034500           THRU 3000-EXIT                                         03450000
034600        PERFORM 3500-CONTINUE-CALC                                03460000
034700           THRU 3500-EXIT                                         03470000
034800        PERFORM 4000-CALC-OUTLIER                                 03480000
034900           THRU 4000-EXIT                                         03490000
035000        PERFORM 5000-FINAL-PAYMENTS                               03500000
035100           THRU 5000-EXIT.                                        03510000
035200                                                                  03520000
035300     PERFORM 9000-MOVE-RESULTS                                    03530000
035400        THRU 9000-EXIT.                                           03540000
035500                                                                  03550000
035600     GOBACK.                                                      03560000
035700                                                                  03570000
035800 0100-INITIAL-ROUTINE.                                            03580000
035900                                                                  03590000
036000     MOVE ZEROS TO PPS-RTC.                                       03600000
036100     INITIALIZE PPS-DATA.                                         03610000
036200     INITIALIZE PPS-OTHER-DATA.                                   03620000
036300     INITIALIZE HOLD-PPS-COMPONENTS.                              03630000
036310     MOVE 'N'   TO SW-XFER-CASE.                                  03631000
036320***************************************************************   03632001
036330*    UPDATE THE VALUES BELOW FOR EACH FY RELEASE              *   03633001
036340*     - VALUES PER POLICY                                     *   03634001
036350***************************************************************   03635001
036360     MOVE .72700 TO PPS-NAT-LABOR-PCT.                            03636001
036370     MOVE .27300 TO PPS-NAT-NONLABOR-PCT.                         03637001
036380     MOVE  9300  TO PPS-NAT-THRESHOLD-ADJ.                        03638001
036390     IF P-NEW-CBSA-HOSP-QUAL-IND IS EQUAL TO '1'                  03639001
036400        MOVE 16489  TO PPS-BDGT-NEUT-CONV-AMT                     03640001
036500     ELSE                                                         03650001
036600        MOVE 16167  TO PPS-BDGT-NEUT-CONV-AMT                     03660001
036700     END-IF.                                                      03670001
036800                                                                  03680001
036900 0100-EXIT.                                                       03690001
037000      EXIT.                                                       03700001
037100                                                                  03710001
037200 1000-EDIT-THE-BILL-INFO.                                         03720001
037300***************************************************************   03730001
037400*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   03740001
037500*    AND DO NOT ATTEMPT TO PRICE.                             *   03750001
037600***************************************************************   03760001
037700                                                                  03770001
037800     MOVE B-CMG-CODE TO PPS-SUBM-CMG-CODE.                        03780001
037900                                                                  03790001
038000     IF (B-LOS NUMERIC) AND (B-LOS > 0)                           03800001
038100        MOVE B-LOS TO H-LOS                                       03810001
038200     ELSE                                                         03820001
038300        IF B-LOS = 0                                              03830001
038400           MOVE 1 TO H-LOS                                        03840001
038500        ELSE                                                      03850001
038600           MOVE 56 TO PPS-RTC.                                    03860001
038700                                                                  03870001
038800     MOVE P-NEW-FY-BEGIN-DATE TO H-FY-BEGIN-DATE.                 03880001
038900     IF H-FY-BEGIN-DATE (5:2) < 11                                03890001
039000       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 10200          03900001
039100     ELSE                                                         03910001
039200       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 19000.         03920001
039300     MOVE B-DISCHARGE-DATE TO H-DISCHARGE-DATE.                   03930001
039400     IF (H-DISCHARGE-DATE > H-FY-BEGIN-DATE)                      03940001
039500        OR (P-NEW-FY-BEGIN-DATE > 20020930 AND                    03950001
039600            P-NEW-FY-BEGIN-DATE < 20030101)                       03960001
039700        MOVE '4' TO P-NEW-FED-PPS-BLEND-IND.                      03970001
039800     IF P-NEW-FY-BEGIN-DATE > 20011231                            03980001
039900        IF (P-NEW-FY-BEGIN-DATE <= B-DISCHARGE-DATE)              03990001
040000           IF P-NEW-FED-PPS-BLEND-IND = '4'                       04000001
040100              MOVE 1.0000 TO PPS-FED-RATE-PCT                     04010001
040200              MOVE 0.0000 TO PPS-FAC-RATE-PCT                     04020001
040300           ELSE                                                   04030001
040400             IF P-NEW-FED-PPS-BLEND-IND = '3'                     04040001
040500                MOVE .6667 TO PPS-FED-RATE-PCT                    04050001
040600                MOVE .3333 TO PPS-FAC-RATE-PCT                    04060001
040700             ELSE                                                 04070001
040800               MOVE 72 TO PPS-RTC                                 04080001
040900        ELSE                                                      04090001
041000           MOVE 73 TO PPS-RTC                                     04100001
041100     ELSE                                                         04110001
041200        MOVE 74 TO PPS-RTC.                                       04120001
041300                                                                  04130001
041400     IF PPS-RTC = 00                                              04140001
041500       IF P-NEW-WAIVER-STATE                                      04150001
041600          MOVE 53 TO PPS-RTC.                                     04160001
041700                                                                  04170001
041800     IF PPS-RTC = 00                                              04180001
041900         IF ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR               04190001
042000            (B-DISCHARGE-DATE < W-NEW-EFF-DATE-C))                04200001
042100            MOVE 55 TO PPS-RTC.                                   04210001
042200                                                                  04220001
042300     IF PPS-RTC = 00                                              04230001
042400         IF P-NEW-TERMINATION-DATE > 00000000                     04240001
042500            IF B-DISCHARGE-DATE >= P-NEW-TERMINATION-DATE         04250001
042600               MOVE 51 TO PPS-RTC.                                04260001
042700                                                                  04270001
042800     IF PPS-RTC = 00                                              04280001
042900         IF B-COV-CHARGES NOT NUMERIC                             04290001
043000            MOVE 58 TO PPS-RTC.                                   04300001
043100                                                                  04310001
043200     IF PPS-RTC = 00                                              04320001
043300        IF B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60              04330001
043400           MOVE 61 TO PPS-RTC                                     04340001
043500        ELSE                                                      04350001
043600           MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.                  04360001
043700                                                                  04370001
043800     IF PPS-RTC = 00                                              04380001
043900        IF B-COV-DAYS NOT NUMERIC                                 04390001
044000             MOVE 62 TO PPS-RTC                                   04400001
044100        ELSE                                                      04410001
044200          IF B-COV-DAYS = 0 AND H-LOS > 0                         04420001
044300             MOVE 62 TO PPS-RTC.                                  04430001
044400                                                                  04440001
044500     IF PPS-RTC = 00                                              04450001
044600        IF B-LTR-DAYS  > B-COV-DAYS                               04460001
044700           MOVE 62 TO PPS-RTC                                     04470001
044800        ELSE                                                      04480001
044900           COMPUTE PPS-REG-DAYS-USED = B-COV-DAYS - B-LTR-DAYS.   04490001
045000                                                                  04500001
045100     IF PPS-RTC = 00                                              04510001
045200        IF PPS-REG-DAYS-USED > 0                                  04520001
045300           IF PPS-REG-DAYS-USED > H-LOS                           04530001
045400              MOVE H-LOS TO PPS-REG-DAYS-USED                     04540001
045500           ELSE                                                   04550001
045600              NEXT SENTENCE                                       04560001
045700        ELSE                                                      04570001
045800           IF B-LTR-DAYS > H-LOS                                  04580001
045900              MOVE H-LOS TO PPS-LTR-DAYS-USED                     04590001
046000           ELSE                                                   04600001
046100              MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.               04610001
046200                                                                  04620001
046300 1000-EXIT.                                                       04630001
046400      EXIT.                                                       04640001
046500                                                                  04650001
046600***************************************************************   04660001
046700*    FINDS THE CMG CODE IN THE TABLE                          *   04670001
046800***************************************************************   04680001
046900 1700-EDIT-CMG-CODE.                                              04690001
047000* 01/2010 - ADDED 5001 PER C.R. # 6699                            04700001
047100                                                                  04710001
047200     IF PPS-CMG-NUMERIC = '9999' OR '5001'                        04720001
047300        NEXT SENTENCE                                             04730001
047400     ELSE                                                         04740001
047500        IF PPS-CMG-NUMERIC < '2103'                               04750001
047600           NEXT SENTENCE                                          04760001
047700        ELSE                                                      04770001
047800           MOVE 54 TO PPS-RTC.                                    04780001
047900                                                                  04790001
048000     IF PPS-RTC = 00                                              04800001
048100        SEARCH ALL CMG-DATA                                       04810001
048200           AT END                                                 04820001
048300             MOVE 54 TO PPS-RTC                                   04830001
048400        WHEN CMG-NUM (DX6) = PPS-CMG-NUMERIC                      04840001
048500             PERFORM 1750-FIND-VALUE                              04850001
048600                THRU 1750-EXIT                                    04860001
048700        END-SEARCH.                                               04870001
048800                                                                  04880001
048900 1700-EXIT.                                                       04890001
049000      EXIT.                                                       04900001
049100                                                                  04910001
049200***************************************************************   04920001
049300*    FINDS THE VALUE IN THE CMG CODE IN THE TABLE             *   04930001
049400***************************************************************   04940001
049500 1750-FIND-VALUE.                                                 04950001
049600                                                                  04960001
049700      IF PPS-CMG-ALPHA = 'A'                                      04970001
049800         MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                 04980001
049900         MOVE A-LOS-TABLE (DX6) TO PPS-AVG-LOS                    04990001
050000      ELSE                                                        05000001
050100         IF PPS-CMG-ALPHA = 'B'                                   05010001
050200            MOVE B-REL-WGT (DX6) TO PPS-RELATIVE-WGT              05020001
050300            MOVE B-LOS-TABLE (DX6) TO PPS-AVG-LOS                 05030001
050400         ELSE                                                     05040001
050500            IF PPS-CMG-ALPHA = 'C'                                05050001
050600               MOVE C-REL-WGT (DX6) TO PPS-RELATIVE-WGT           05060001
050700               MOVE C-LOS-TABLE (DX6) TO PPS-AVG-LOS              05070001
050800            ELSE                                                  05080001
050900               IF PPS-CMG-ALPHA = 'D'                             05090001
051000                  MOVE D-REL-WGT (DX6) TO PPS-RELATIVE-WGT        05100001
051100                  MOVE D-LOS-TABLE (DX6) TO PPS-AVG-LOS           05110001
051200               ELSE                                               05120001
051300                  MOVE 54 TO PPS-RTC.                             05130001
051400                                                                  05140001
051500 1750-EXIT.                                                       05150001
051600      EXIT.                                                       05160001
051700                                                                  05170001
051800***************************************************************   05180001
051900*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   05190001
052000*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   05200001
052100*    OF THAT VARIABLE.                                        *   05210001
052200***************************************************************   05220001
052300***  GET THE PROVIDER SPECIFIC VARIABLE AND WAGE INDEX            05230001
052400***************************************************************   05240001
052500 2000-ASSEMBLE-PPS-VARIABLES.                                     05250001
052600                                                                  05260001
052700     IF P-NEW-FAC-SPEC-RATE NUMERIC                               05270001
052800        MOVE P-NEW-FAC-SPEC-RATE TO PPS-FAC-SPEC-RT-PREBLEND      05280001
052900     ELSE                                                         05290001
053000        MOVE 50 TO PPS-RTC                                        05300001
053100        GO TO 2000-EXIT.                                          05310001
053200                                                                  05320001
053300     IF P-NEW-FED-PPS-BLEND-IND = '3'                             05330001
053400        IF PPS-FAC-SPEC-RT-PREBLEND = 0                           05340001
053500          MOVE 57 TO PPS-RTC                                      05350001
053600          GO TO 2000-EXIT.                                        05360001
053700                                                                  05370001
053800     IF W-NEW-WAGE-INDEX-C NUMERIC                                05380001
053900            AND W-NEW-WAGE-INDEX-C > 0                            05390001
054000        MOVE W-NEW-WAGE-INDEX-C TO PPS-WAGE-INDEX                 05400001
054100     ELSE                                                         05410001
054200        MOVE 52 TO PPS-RTC                                        05420001
054300        GO TO 2000-EXIT.                                          05430001
054400                                                                  05440001
054500     IF P-NEW-OPER-CSTCHG-RATIO NOT NUMERIC                       05450001
054600        MOVE 65 TO PPS-RTC.                                       05460001
054700                                                                  05470001
054800 2000-EXIT.                                                       05480001
054900      EXIT.                                                       05490001
055000                                                                  05500001
055100***************************************************************   05510001
055200*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   05520001
055300*        CALCULATE THE FEDERAL PORTION.                       *   05530001
055400*        CALCULATE THE HOSPITAL PORTION.                      *   05540001
055500*        CALCULATE THE COST-OUTLIER PORTION.                  *   05550001
055600*        CALCULATE THE LIP ADJUSTMENT PERCENTAGE.             *   05560001
055700*-------------------------------------------------------------*   05570001
055800*    NO CHANGE TO LIP FROM 2014 AT  .3177                     *   05580001
055900*    NO CHANGE TO TCH FROM 2014 AT 1.0163                     *   05590001
056000***************************************************************   05600001
056100 3000-CALC-PAYMENT.                                               05610001
056200                                                                  05620001
056300***  LIP ( LOW INCOME PATIENT ) CALCULATION                   *   05630001
056400                                                                  05640001
056500      COMPUTE H-WK-DSH = (P-NEW-SSI-RATIO                         05650001
056600                           + P-NEW-MEDICAID-RATIO).               05660001
056700                                                                  05670001
056800      COMPUTE PPS-LIP-PCT ROUNDED =                               05680001
056900            ((1 + H-WK-DSH) ** .3177) - 1.                        05690001
057000                                                                  05700001
057100      COMPUTE H-TEACH-PCT ROUNDED =                               05710001
057200            ((1 + P-NEW-CAPI-IME) ** 1.0163) - 1.                 05720001
057300                                                                  05730001
057400****************************************************************  05740001
057500*  IF A TRANSFER CASE, CALCULATE THE STANDARD PAYMENT USING    *  05750001
057600*  THE PER DIEM IN THE CALCULATION.                            *  05760001
057700****************************************************************  05770001
057800     MOVE 'N'   TO SW-XFER-CASE.                                  05780001
057900     IF B-PATIENT-STATUS =                                        05790001
058000        '02' OR '03' OR '61' OR '62' OR '63' OR '64' OR           05800001
058100        '82' OR '83' OR '89' OR '90' OR '91' OR '92'              05810001
058200                                                                  05820001
058300        IF H-LOS < PPS-AVG-LOS                                    05830001
058310           COMPUTE PPS-STANDARD-PAY-AMT =                         05831001
058320              (PPS-BDGT-NEUT-CONV-AMT / PPS-AVG-LOS)              05832001
058330              * (H-LOS + .5)                                      05833001
058340              * PPS-RELATIVE-WGT                                  05834001
058350                                                                  05835001
058360           MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE          05836001
058370           MOVE 'Y'               TO SW-XFER-CASE                 05837001
058380           GO   TO 3000-EXIT                                      05838001
058390         END-IF                                                   05839001
058400     END-IF.                                                      05840001
058500                                                                  05850001
058600     IF H-LOS > 3                                                 05860001
058700        NEXT SENTENCE                                             05870001
058800     ELSE                                                         05880001
058900        MOVE 'A5001' TO PPS-PRICED-CMG-CODE                       05890001
059000        SET DX6 TO 96                                             05900001
059100        MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                  05910001
059200        GO TO 3000-EXIT.                                          05920001
059300                                                                  05930001
059400     IF B-PATIENT-STATUS = '20'                                   05940001
059500        NEXT SENTENCE                                             05950001
059600     ELSE                                                         05960001
059700        MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE             05970001
059800        GO TO 3000-EXIT.                                          05980001
059900                                                                  05990001
060000     IF PPS-CMG-RIC = ('07' OR '08' OR '09')                      06000001
060100        IF H-LOS < 14                                             06010001
060200           MOVE 'A5101' TO PPS-PRICED-CMG-CODE                    06020001
060300           SET DX6 TO 97                                          06030001
060400           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               06040001
060500        ELSE                                                      06050001
060600           MOVE 'A5102' TO PPS-PRICED-CMG-CODE                    06060001
060700           SET DX6 TO 98                                          06070001
060800           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               06080001
060900     ELSE                                                         06090001
061000        IF H-LOS < 16                                             06100001
061100           MOVE 'A5103' TO PPS-PRICED-CMG-CODE                    06110001
061200           SET DX6 TO 99                                          06120001
061300           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               06130001
061400        ELSE                                                      06140001
061500           MOVE 'A5104' TO PPS-PRICED-CMG-CODE                    06150001
061600           SET DX6 TO 100                                         06160001
061700           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT.              06170001
061800                                                                  06180001
061900 3000-EXIT.                                                       06190001
062000      EXIT.                                                       06200001
062100                                                                  06210001
062200 3500-CONTINUE-CALC.                                              06220001
062300****************************************************************  06230001
062400*  IF A NON-TRANSFER CASE, CALCULATE THE STANDARD PAYMENT      *  06240001
062500*  AS DONE NORMALLY.                                           *  06250001
062600****************************************************************  06260001
062700     IF SW-XFER-CASE = 'Y'                                        06270001
062800        CONTINUE                                                  06280001
062900     ELSE                                                         06290001
063000        COMPUTE PPS-STANDARD-PAY-AMT =                            06300001
063100                PPS-RELATIVE-WGT *                                06310001
063200                PPS-BDGT-NEUT-CONV-AMT                            06320001
063300     END-IF.                                                      06330001
063400                                                                  06340001
063500***************************************************************   06350001
063600*      CHANGE RURAL ADJUSTMENT AMOUNT IF NECESSARY            *   06360001
063700***************************************************************   06370001
063800     PERFORM 3510-CHECK-RURAL-ADJ         THRU 3510-EXIT.         06380001
063900                                                                  06390001
064000***************************************************************   06400001
064100*      CHANGE RURAL ADJUSTMENT BASED ON RELIEF INDICATOR      *   06410001
064200*       IF NECESSARY - PER CHANGE REQUEST                     *   06420001
064300***************************************************************   06430001
064400                                                                  06440001
064500     COMPUTE H-LABOR-PORTION =                                    06450001
064600        (PPS-STANDARD-PAY-AMT * PPS-NAT-LABOR-PCT)                06460001
064700          * PPS-WAGE-INDEX.                                       06470001
064800                                                                  06480001
064900     COMPUTE H-NONLABOR-PORTION =                                 06490001
065000        (PPS-STANDARD-PAY-AMT * PPS-NAT-NONLABOR-PCT).            06500001
065100                                                                  06510001
065200     COMPUTE PPS-FED-PAY-AMT ROUNDED =                            06520001
065300        ((H-LABOR-PORTION + H-NONLABOR-PORTION) *                 06530001
065400         PPS-RURAL-ADJUSTMENT).                                   06540001
065500                                                                  06550001
065600     COMPUTE PPS-LIP-PAY-AMT ROUNDED =                            06560001
065700        (PPS-FED-PAY-AMT * PPS-LIP-PCT).                          06570001
065800                                                                  06580001
065900     COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                          06590001
066000        (PPS-FED-PAY-AMT * H-TEACH-PCT).                          06600001
066100                                                                  06610001
066200 3500-EXIT.                                                       06620001
066300      EXIT.                                                       06630001
066400                                                                  06640001
066500***************************************************************   06650001
066600* EFFECTIVE FY2018, REMOVED RURAL-TO-URBAN CODING             *   06660001
066700***************************************************************   06670001
066800 3510-CHECK-RURAL-ADJ.                                            06680001
066900                                                                  06690001
067000     MOVE 1.0000          TO PPS-RURAL-ADJUSTMENT                 06700001
067100                                                                  06710001
067200     IF W-NEW-CBSA (1:3) = '   '                                  06720001
067300        MOVE 1.1490 TO PPS-RURAL-ADJUSTMENT                       06730001
067400     ELSE                                                         06740001
067500        MOVE 1.0000 TO PPS-RURAL-ADJUSTMENT.                      06750001
067600                                                                  06760001
067700 3510-EXIT.                                                       06770001
067800      EXIT.                                                       06780001
067900                                                                  06790001
068000 4000-CALC-OUTLIER.                                               06800001
068100                                                                  06810001
068200     COMPUTE PPS-FAC-COSTS ROUNDED =                              06820001
068300         (B-COV-CHARGES * P-NEW-OPER-CSTCHG-RATIO).               06830001
068400                                                                  06840001
068500     COMPUTE H-OUTLIER-LABOR-PORTION =                            06850001
068600        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-LABOR-PCT)               06860001
068700              * PPS-WAGE-INDEX.                                   06870001
068800                                                                  06880001
068810     COMPUTE H-OUTLIER-NONLABOR-PORTION =                         06881001
068820        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-NONLABOR-PCT).           06882001
068830                                                                  06883001
068840     COMPUTE H-FP-OUTLIER-THRESHOLD ROUNDED =                     06884001
068850        ((H-OUTLIER-LABOR-PORTION + H-OUTLIER-NONLABOR-PORTION) * 06885001
068860         PPS-RURAL-ADJUSTMENT * (PPS-LIP-PCT + H-TEACH-PCT + 1)). 06886001
068870                                                                  06887001
068880     COMPUTE H-OUTLIER-THRESHOLD ROUNDED =                        06888001
068890        (PPS-FED-PAY-AMT + H-FP-OUTLIER-THRESHOLD +               06889001
068900         PPS-LIP-PAY-AMT + PPS-TEACH-PAY-AMT).                    06890001
069000                                                                  06900001
069100     IF PPS-FAC-COSTS > H-OUTLIER-THRESHOLD                       06910001
069200        COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                     06920001
069300           ((PPS-FAC-COSTS - H-OUTLIER-THRESHOLD) * .8).          06930001
069400                                                                  06940001
069500     COMPUTE H-CHG-OUTLIER-THRESHOLD ROUNDED =                    06950001
069600         H-OUTLIER-THRESHOLD / P-NEW-OPER-CSTCHG-RATIO.           06960001
069700                                                                  06970001
069800                                                                  06980001
069900 4000-EXIT.                                                       06990001
070000      EXIT.                                                       07000001
070100                                                                  07010001
070200 5000-FINAL-PAYMENTS.                                             07020001
070300                                                                  07030001
070400     IF B-SPEC-PAY-IND = '1' OR '3'                               07040001
070500         MOVE ZEROES TO PPS-OUTLIER-PAY-AMT.                      07050001
070600                                                                  07060001
070700     IF PPS-FED-RATE-PCT = 1.0000                                 07070001
070800         MOVE 0 TO PPS-FAC-SPEC-PAY-AMT                           07080001
070900     ELSE                                                         07090001
071000         COMPUTE PPS-FED-PAY-AMT ROUNDED =                        07100001
071100           (PPS-FED-RATE-PCT * PPS-FED-PAY-AMT)                   07110001
071200         COMPUTE PPS-FAC-SPEC-PAY-AMT ROUNDED =                   07120001
071300           (PPS-FAC-RATE-PCT * PPS-FAC-SPEC-RT-PREBLEND)          07130001
071400         COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                    07140001
071500           (PPS-FED-RATE-PCT * PPS-OUTLIER-PAY-AMT)               07150001
071600         COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                      07160001
071700           (PPS-FED-RATE-PCT * PPS-TEACH-PAY-AMT)                 07170001
071800         COMPUTE PPS-LIP-PAY-AMT ROUNDED =                        07180001
071900           (PPS-FED-RATE-PCT * PPS-LIP-PAY-AMT).                  07190001
072000                                                                  07200001
072100     COMPUTE PPS-TOTAL-PAY-AMT ROUNDED =                          07210001
072200        (PPS-FED-PAY-AMT + PPS-FAC-SPEC-PAY-AMT                   07220001
072300         + PPS-OUTLIER-PAY-AMT + PPS-LIP-PAY-AMT +                07230001
072400         PPS-TEACH-PAY-AMT).                                      07240001
072500                                                                  07250001
072600     IF PPS-FED-RATE-PCT = 1.0000                                 07260001
072700        IF SW-XFER-CASE = 'N'                                     07270001
072800           IF PPS-OUTLIER-PAY-AMT > 0.0                           07280001
072900              MOVE 01 TO PPS-RTC                                  07290001
073000           ELSE                                                   07300001
073100              MOVE 00 TO PPS-RTC                                  07310001
073200        ELSE                                                      07320001
073300           IF PPS-OUTLIER-PAY-AMT > 0.0                           07330001
073400              MOVE 03 TO PPS-RTC                                  07340001
073500           ELSE                                                   07350001
073600              MOVE 02 TO PPS-RTC                                  07360001
073700     ELSE                                                         07370001
073800        IF SW-XFER-CASE = 'N'                                     07380001
073900           IF PPS-OUTLIER-PAY-AMT > 0.0                           07390001
074000              MOVE 05 TO PPS-RTC                                  07400001
074100           ELSE                                                   07410001
074200              MOVE 04 TO PPS-RTC                                  07420001
074300        ELSE                                                      07430001
074400           IF PPS-OUTLIER-PAY-AMT > 0.0                           07440001
074500              MOVE 07 TO PPS-RTC                                  07450001
074600           ELSE                                                   07460001
074700              MOVE 06 TO PPS-RTC.                                 07470001
074800                                                                  07480001
074900     IF B-SPEC-PAY-IND = '2' OR '3'                               07490001
075000        COMPUTE PPS-RTC = PPS-RTC + 10.                           07500001
075100     IF PPS-RTC = (01 OR 03 OR 05 OR 07                           07510001
075200                OR 11 OR 13 OR 15 OR 17)                          07520001
075300        IF ((PPS-REG-DAYS-USED + PPS-LTR-DAYS-USED) < H-LOS)      07530001
075400           OR PPS-COT-IND = 'Y'                                   07540001
075500            MOVE 67 TO PPS-RTC.                                   07550001
075600                                                                  07560001
075700 5000-EXIT.                                                       07570001
075800      EXIT.                                                       07580001
075900                                                                  07590001
076000 9000-MOVE-RESULTS.                                               07600001
076100                                                                  07610001
076200     IF PPS-RTC < 50                                              07620001
076300      MOVE H-LOS                   TO  PPS-LOS                    07630001
076400      MOVE H-OUTLIER-THRESHOLD     TO  PPS-OUTLIER-THRESHOLD      07640001
076500      MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD   07650001
076600      MOVE W-NEW-CBSA              TO  PPS-CBSA                   07660001
076700      MOVE 'V20.1'                 TO  PPS-CALC-VERS-CD           07670001
076800     ELSE                                                         07680001
076900       INITIALIZE PPS-DATA                                        07690001
077000       INITIALIZE PPS-OTHER-DATA                                  07700001
077100       MOVE 'V20.1'                TO  PPS-CALC-VERS-CD.          07710001
077200                                                                  07720001
077300     IF PPS-RTC = 67                                              07730001
077400       MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD. 07740001
077500                                                                  07750001
077600 9000-EXIT.                                                       07760001
077700      EXIT.                                                       07770001
077800***************************************************************   07780001
077900******        L A S T   S O U R C E   S T A T E M E N T   *****   07790001
078000***************************************************************   07800001
