000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.           PPCAL974.                                  00020012
000300*AUTHOR.            DDS TEAM.                                     00030000
000400*REMARKS.                HCFA.                                    00040000
000500 DATE-COMPILED.                                                   00050000
000600 ENVIRONMENT DIVISION.                                            00060000
000700 CONFIGURATION SECTION.                                           00070000
000800 SOURCE-COMPUTER.            IBM-370.                             00080000
000900 OBJECT-COMPUTER.            IBM-370.                             00090000
001000 INPUT-OUTPUT  SECTION.                                           00100000
001100 FILE-CONTROL.                                                    00110000
001200                                                                  00120000
001300 DATA DIVISION.                                                   00130000
001400 FILE SECTION.                                                    00140000
001500                                                                  00150000
001600 WORKING-STORAGE SECTION.                                         00160000
001700 01  W-STORAGE-REF                  PIC X(46)  VALUE              00170000
001800     'PPCAL974      - W O R K I N G   S T O R A G E'.             00180012
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C97.4'.     00190012
002000 01  R1                             PIC S9(04) COMP SYNC.         00200000
002100 01  R2                             PIC S9(04) COMP SYNC.         00210000
002200 01  R3                             PIC S9(04) COMP SYNC.         00220000
002300 01  R4                             PIC S9(04) COMP SYNC.         00230000
002400                                                                  00240000
002500***************************************************************   00250000
002600*    LAYUP TABLE AREA FOR FY97 RATES                          *   00260000
002700***************************************************************   00270000
002800***************************************************************   00280000
002900***************************************************************   00290000
003000***************************************************************   00300000
003100 01  RATE-TABLE.                                                  00310000
003200     02  RATE-WORK.                                               00320000
003300         05  FILLER PIC X(06) VALUE '961001'.                     00330000
003400*RATE   961001 REGION  LABOR AND NON-LABOR RATES                  00340000
003500*                  R3=1     /     R3=2     /     R3=3             00350000
003600*               LARGE URBAN /OTHER URBAN & / ALL RURAL            00360000
003700*                           /REFERRAL CTR  /                      00370000
003800*              LABOR / NON  / LABOR / NON  / LABOR / NON          00380000
003900*                    /LABOR /       /LABOR /       /LABOR         00390000
004000*             --------------------------------------------        00400000
004100         05  NE01   PIC X(45) VALUE                               00410000
004200            ' 0278284 112564 0273879 110783 0273879 110783'.      00420000
004300         05  MA02   PIC X(45) VALUE                               00430000
004400            ' 0278284 112564 0273879 110783 0273879 110783'.      00440000
004500         05  SA03   PIC X(45) VALUE                               00450000
004600            ' 0278284 112564 0273879 110783 0273879 110783'.      00460000
004700         05  ENC04  PIC X(45) VALUE                               00470000
004800            ' 0278284 112564 0273879 110783 0273879 110783'.      00480000
004900         05  ESC05  PIC X(45) VALUE                               00490000
005000            ' 0278284 112564 0273879 110783 0273879 110783'.      00500000
005100         05  WNC06  PIC X(45) VALUE                               00510000
005200            ' 0278284 112564 0273879 110783 0273879 110783'.      00520000
005300         05  WSC07  PIC X(45) VALUE                               00530000
005400            ' 0278284 112564 0273879 110783 0273879 110783'.      00540000
005500         05  MNT08  PIC X(45) VALUE                               00550000
005600            ' 0278284 112564 0273879 110783 0273879 110783'.      00560000
005700         05  PAC09  PIC X(45) VALUE                               00570000
005800            ' 0278284 112564 0273879 110783 0273879 110783'.      00580000
005900         05  NTL10  PIC X(45) VALUE                               00590000
006000            ' 0278284 112564 0273879 110783 0273879 110783'.      00600000
006100         05  PR11   PIC X(45) VALUE                               00610000
006200            ' 0248870 051865 0244931 051044 0244931 051044'.      00620000
006300         05  NPR12  PIC X(45) VALUE                               00630000
006400            ' 0275922 111609 0275922 111609 0275922 111609'.      00640000
006500     02  RATE-TAB REDEFINES RATE-WORK.                            00650000
006600         05  RATE-PERIOD            OCCURS 1.                     00660000
006700             10  RATE-EFF-DATE      PIC X(06).                    00670000
006800             10  REG-NAT            OCCURS 12.                    00680000
006900                 15  R-URBAN-RURAL  OCCURS 3.                     00690000
007000                     20  FILLER     PIC X(01).                    00700000
007100                     20  REG-LABOR  PIC 9(05)V9(02).              00710000
007200                     20  FILLER     PIC X(01).                    00720000
007300                     20  REG-NLABOR PIC 9(04)V9(02).              00730000
007400                                                                  00740000
007500                                                                  00750000
007600***************************************************************   00760000
007700*    LAYUP TABLE AREA FOR FY97 DRGS                           *   00770000
007800***************************************************************   00780000
007900 01  DRG-TABLE.                                                   00790000
008000     05  D-TAB.                                                   00800000
008100      10  FILLER                  PIC X(06) VALUE                 00810000
008200     '961001'.                                                    00820000
008300      10  FILLER                  PIC X(56) VALUE                 00830000
008400     '03048607732111030134084321160191671273712702339905930091'.  00840000
008500       10  FILLER                  PIC X(56) VALUE                00850000
008600     '01514303426044007419024260340248860813212601096202627039'.  00860000
008700       10  FILLER                  PIC X(56) VALUE                00870000
008800     '01267705429078012196057300810080000352805000945705429077'.  00880000
008900       10  FILLER                  PIC X(56) VALUE                00890000
009000     '00777005029062011999055300750072310352704501037104929066'.  00900000
009100       10  FILLER                  PIC X(56) VALUE                00910000
009200     '00633103026040009319048290640062300342704502485408633116'.  00920000
009300       10  FILLER                  PIC X(56) VALUE                00930000
009400     '01491005830078008353038280490080890362805100969404228058'.  00940000
009500       10  FILLER                  PIC X(56) VALUE                00950000
009600     '00579303024039007387033270460130600362806301203304829071'.  00960000
009700       10  FILLER                  PIC X(56) VALUE                00970000
009800     '00637103027041003241020170200084120372805400486102320031'.  00980000
009900       10  FILLER                  PIC X(56) VALUE                00990000
010000     '00203701609016010673046290650061490322704300613401306016'.  01000000
010100       10  FILLER                  PIC X(56) VALUE                01010000
010200     '00932302727040004282019170260051840151002000707202226034'.  01020000
010300       10  FILLER                  PIC X(56) VALUE                01030000
010400     '00329901607016005816016130220045200332704200623704729057'.  01040000
010500       10  FILLER                  PIC X(56) VALUE                01050000
010600     '00652503122038007656040280560046640282703800290702927029'.  01060000
010700       10  FILLER                  PIC X(56) VALUE                01070000
010800     '01724504128057007686017090210073450192002901027102124034'.  01080000
010900       10  FILLER                  PIC X(56) VALUE                01090000
011000     '01012802226036004712032220320078800202203000828302118027'.  01100000
011100       10  FILLER                  PIC X(56) VALUE                01110000
011200     '00932502827041002676015040150074390232603600203801504015'.  01120000
011300       10  FILLER                  PIC X(56) VALUE                01130000
011400     '01196002727051002885013050130121680322704701173704829076'.  01140000
011500       10  FILLER                  PIC X(56) VALUE                01150000
011600     '00519502720034005366029210360083970342404200709803927048'.  01160000
011700       10  FILLER                  PIC X(56) VALUE                01170000
011800     '00523903120038003727024150290077020312704000653203127044'.  01180000
011900       10  FILLER                  PIC X(56) VALUE                01190000
012000     '00750503728050003278021200210319510883311202603609133125'.  01200000
012100       10  FILLER                  PIC X(56) VALUE                01210000
012200     '01159303828055014292070310830163000723109300943605329066'.  01220000
012300       10  FILLER                  PIC X(56) VALUE                01230000
012400     '01484506330078013319057300790097820492906400531902923037'.  01240000
012500       10  FILLER                  PIC X(56) VALUE                01250000
012600     '01220005630074007117034270450136150512906900984604929061'.  01260000
012700       10  FILLER                  PIC X(56) VALUE                01270000
012800     '01115605830071006978043240510075240352704501202905630073'.  01280000
012900       10  FILLER                  PIC X(56) VALUE                01290000
013000     '00749804028049011780053290710059960332504100827204529055'.  01300000
013100       10  FILLER                  PIC X(56) VALUE                01310000
013200     '00603503622043007807029270430068690272203500511302012024'.  01320000
013300       10  FILLER                  PIC X(56) VALUE                01330000
013400     '00874803928052005335024200311533582845240007319912036146'.  01340000
013500       10  FILLER                  PIC X(56) VALUE                01350000
013600     '05599809033110055564103341170406850783208805913509834126'.  01360000
013700       10  FILLER                  PIC X(56) VALUE                01370000
013800     '00000000000000041589082321090228750593006702094603527047'.  01380000
013900       10  FILLER                  PIC X(56) VALUE                01390000
014000     '02693510635144015152068310950368270913311502415003928054'.  01400000
014100       10  FILLER                  PIC X(56) VALUE                01410000
014200     '01176402727041015825021250320114350332705501931805429092'.  01420000
014300       10  FILLER                  PIC X(56) VALUE                01430000
014400     '01648206430078011617044280530145550272704701325803828050'.  01440000
014500       10  FILLER                  PIC X(56) VALUE                01450000
014600     '00924602320031025379110351430102650482906200786105927067'.  01460000
014700       10  FILLER                  PIC X(56) VALUE                01470000
014800     '01131602026035009352053290670060380432805200684002920036'.  01480000
014900       10  FILLER                  PIC X(56) VALUE                01490000
015000     '00553702316029005787030230390088380372805000562902618033'.  01500000
015100       10  FILLER                  PIC X(56) VALUE                01510000
015200     '00799903327033008008035270460049710241602900620502820035'.  01520000
015300       10  FILLER                  PIC X(56) VALUE                01530000
015400     '00712803427045005288025180320052230211402601085704128057'.  01540000
015500       10  FILLER                  PIC X(56) VALUE                01550000
015600     '00620802520032026363098341120160180672707303371011235135'.  01560000
015700       10  FILLER                  PIC X(56) VALUE                01570000
015800     '01599907025077026828095341170129100522906501931107632090'.  01580000
015900       10  FILLER                  PIC X(56) VALUE                01590000
016000     '01156805624062041817116361500140590452905900823806030060'.  01600000
016100       10  FILLER                  PIC X(56) VALUE                01610000
016200     '01135204228058006077023180290122680402805300702602416030'.  01620000
016300       10  FILLER                  PIC X(56) VALUE                01630000
016400     '01006603027044005707017110220077060211102102338608032094'.  01640000
016500       10  FILLER                  PIC X(56) VALUE                01650000
016600     '01258205124058014497045290570084310281503201092903227050'.  01660000
016700       10  FILLER                  PIC X(56) VALUE                01670000
016800     '00671702015025027453085331250112020402805401292005730082'.  01680000
016900       10  FILLER                  PIC X(56) VALUE                01690000
017000     '00676903027044009952044280560054850291703501085604729062'.  01700000
017100       10  FILLER                  PIC X(56) VALUE                01710000
017200     '00833504028050006091030190360111880553007200919404729061'.  01720000
017300       10  FILLER                  PIC X(56) VALUE                01730000
017400     '00533803322040007789038280500055530282003400541402827039'.  01740000
017500       10  FILLER                  PIC X(56) VALUE                01750000
017600     '00842403728052003140029230290071040312704201059104528061'.  01760000
017700       10  FILLER                  PIC X(56) VALUE                01770000
017800     '00564002727037008769039280510445431213616301788906230079'.  01780000
017900       10  FILLER                  PIC X(56) VALUE                01790000
018000     '03287811435139017549068310850268940883310501612705830067'.  01800000
018100       10  FILLER                  PIC X(56) VALUE                01810000
018200     '02267907531092011738043230490237280843211203177207932124'.  01820000
018300       10  FILLER                  PIC X(56) VALUE                01830000
018400     '03766912136168013675057300780124860553007701200405129068'.  01840000
018500       10  FILLER                  PIC X(56) VALUE                01850000
018600     '01219405329073007159036280470105080442805800604502621035'.  01860000
018700       10  FILLER                  PIC X(56) VALUE                01870000
018800     '02260605923067018460072310860127400562306301148711135111'.  01880000
018900       10  FILLER                  PIC X(56) VALUE                01890000
019000     '01704907031097019255049290650111190302003702078407932111'.  01900000
019100       10  FILLER                  PIC X(56) VALUE                01910000
019200     '02881210234154014574048290620095530311903800570605329053'.  01920000
019300       10  FILLER                  PIC X(56) VALUE                01930000
019400     '01834005830081010177031270400087200221602900741701910023'.  01940000
019500       10  FILLER                  PIC X(56) VALUE                01950000
019600     '01002003327050013831044280670074490231803000934902326035'.  01960000
019700       10  FILLER                  PIC X(56) VALUE                01970000
019800     '00651201813024010567033270520122630332705101088402627045'.  01980000
019900       10  FILLER                  PIC X(56) VALUE                01990000
020000     '02017006430091010675031270410083950472906900762004729064'.  02000000
020100       10  FILLER                  PIC X(56) VALUE                02010000
020200     '00563703327044013796076321010101150583007601211205530075'.  02020000
020300       10  FILLER                  PIC X(56) VALUE                02030000
020400     '00602903528046010492058300770072410432805600727904328058'.  02040000
020500       10  FILLER                  PIC X(56) VALUE                02050000
020600     '00495403227043005887036280460055230292704000732503928053'.  02060000
020700       10  FILLER                  PIC X(56) VALUE                02070000
020800     '00652202927043006915036280510046400252203300247901815018'.  02080000
020900       10  FILLER                  PIC X(56) VALUE                02090000
021000     '00743804328058004451029250390028860292702900765104028057'.  02100000
021100       10  FILLER                  PIC X(56) VALUE                02110000
021200     '00901502817034007087022100250086400232603500608301608019'.  02120000
021300       10  FILLER                  PIC X(56) VALUE                02130000
021400     '00828601912023007695027270390212260993413901127006030083'.  02140000
021500       10  FILLER                  PIC X(56) VALUE                02150000
021600     '01499304829077007629027270370083300282704300991602527041'.  02160000
021700       10  FILLER                  PIC X(56) VALUE                02170000
021800     '01641606330093007003024260340108160663108501015805630075'.  02180000
021900       10  FILLER                  PIC X(56) VALUE                02190000
022000     '00634604128055010760053290790050850252703700637403928050'.  02200000
022100       10  FILLER                  PIC X(56) VALUE                02210000
022200     '00852605529067005774043250520071900422404200675003728051'.  02220000
022300       10  FILLER                  PIC X(56) VALUE                02230000
022400     '00456002724036002509022190220069900412805500434002926038'.  02240000
022500       10  FILLER                  PIC X(56) VALUE                02250000
022600     '02201509534137023775066310870197650943313402010405229069'.  02260000
022700       10  FILLER                  PIC X(56) VALUE                02270000
022800     '01019802727040008798021150280051890140801802645008432128'.  02280000
022900       10  FILLER                  PIC X(56) VALUE                02290000
023000     '01267104629068007594043280570071590332704300892904729064'.  02300000
023100       10  FILLER                  PIC X(56) VALUE                02310000
023200     '00536403326043005221025230340083300392805401095005530073'.  02320000
023300       10  FILLER                  PIC X(56) VALUE                02330000
023400     '00618203427044039047104341230264090843210202371607531103'.  02340000
023500       10  FILLER                  PIC X(56) VALUE                02350000
023600     '01177603928049012258043280620067080241503001525204729070'.  02360000
023700       10  FILLER                  PIC X(56) VALUE                02370000
023800     '00886002318030010015032270460056700181102200912403227048'.  02380000
023900       10  FILLER                  PIC X(56) VALUE                02390000
024000     '00522301813023004836023260230205740532909301303405429076'.  02400000
024100       10  FILLER                  PIC X(56) VALUE                02410000
024200     '00484501920029011296050290720057720232403200904805129064'.  02420000
024300       10  FILLER                  PIC X(56) VALUE                02430000
024400     '00607703924047005133036230440074960272403600415901710021'.  02440000
024500       10  FILLER                  PIC X(56) VALUE                02450000
024600     '00637703427046004320024190340023410312703100688603127043'.  02460000
024700       10  FILLER                  PIC X(56) VALUE                02470000
024800     '00456702117028003115016090160099140462906200607002827039'.  02480000
024900       10  FILLER                  PIC X(56) VALUE                02490000
025000     '00856204328058016653053230610126100421704600884803224041'.  02500000
025100       10  FILLER                  PIC X(56) VALUE                02510000
025200     '00614702311027010499035270530101940312705300276902413024'.  02520000
025300       10  FILLER                  PIC X(56) VALUE                02530000
025400     '01074502321033007578027270400015040170601701008302325035'.  02540000
025500       10  FILLER                  PIC X(56) VALUE                02550000
025600     '00842202827040009559048290680050960242503300710703628049'.  02560000
025700       10  FILLER                  PIC X(56) VALUE                02570000
025800     '00397402220030006611039240480023090130501300587702827039'.  02580000
025900       10  FILLER                  PIC X(56) VALUE                02590000
026000     '01917406731083014643052280630090560361103900737602612030'.  02600000
026100       10  FILLER                  PIC X(56) VALUE                02610000
026200     '02382408032098011713041190480082850301003300845902917035'.  02620000
026300       10  FILLER                  PIC X(56) VALUE                02630000
026400     '01114802523035002951014050140069110262103500673902627036'.  02640000
026500       10  FILLER                  PIC X(56) VALUE                02650000
026600     '01723705329081011941053290780052160232403201023005329069'.  02660000
026700       10  FILLER                  PIC X(56) VALUE                02670000
026800     '00545402627037010401043260560068380321103600543902420034'.  02680000
026900       10  FILLER                  PIC X(56) VALUE                02690000
027000     '00360201707019006775020110260066980442804400563802325034'.  02700000
027100       10  FILLER                  PIC X(56) VALUE                02710000
027200     '00818802126033008054024150290035910202103000477501712023'.  02720000
027300       10  FILLER                  PIC X(56) VALUE                02730000
027400     '00515101714023002013013060160046550282704100392101822031'.  02740000
027500       10  FILLER                  PIC X(56) VALUE                02750000
027600     '01344301826018044329179421790302761333713301826808633086'.  02760000
027700       10  FILLER                  PIC X(56) VALUE                02770000
027800     '02245107932107012845036280470014900311103103244308933117'.  02780000
027900       10  FILLER                  PIC X(56) VALUE                02790000
028000     '01316809133091015994045280800083620392805400696602727038'.  02800000
028100       10  FILLER                  PIC X(56) VALUE                02810000
028200     '01261204428061012106052290660070300352704402557206731104'.  02820000
028300       10  FILLER                  PIC X(56) VALUE                02830000
028400     '02483408532124010255031270470169250653009300805903728051'.  02840000
028500       10  FILLER                  PIC X(56) VALUE                02850000
028600     '01866904929049026841081321130117870382804901739305029082'.  02860000
028700       10  FILLER                  PIC X(56) VALUE                02870000
028800     '00976304729067007514026200340038370211602700408002123030'.  02880000
028900       10  FILLER                  PIC X(56) VALUE                02890000
029000     '01325706030084007337037280520344301143515801483806230083'.  02900000
029100       10  FILLER                  PIC X(56) VALUE                02910000
029200     '00808903728046009697054290680089910442805700626403524043'.  02920000
029300       10  FILLER                  PIC X(56) VALUE                02930000
029400     '00715303628047005347029250380159470633008802363710935180'.  02940000
029500       10  FILLER                  PIC X(56) VALUE                02950000
029600     '00705103527049005680039280550054950372805200730305229084'.  02960000
029700       10  FILLER                  PIC X(56) VALUE                02970000
029800     '00907505930090008391069310980065560492907200736303928065'.  02980000
029900       10  FILLER                  PIC X(56) VALUE                02990000
030000     '00298602525034007141043280580041640382804800818312136148'.  03000000
030100       10  FILLER                  PIC X(56) VALUE                03010000
030200     '00765709233109000000000000000161440593008901772506330099'.  03020000
030300       10  FILLER                  PIC X(56) VALUE                03030000
030400     '00929402426044021653056300870088490252603600731204028053'.  03040000
030500       10  FILLER                  PIC X(56) VALUE                03050000
030600     '00484502925039002894024220240049180211702800077701001010'.  03060000
030700       10  FILLER                  PIC X(56) VALUE                03070000
030800     '00790203027045004274018130230025700211702100947303828054'.  03080000
030900       10  FILLER                  PIC X(56) VALUE                03090000
031000     '00482202420032008575034270510044670211802801832704128084'.  03100000
031100       10  FILLER                  PIC X(56) VALUE                03110000
031200     '01465702426048034991119361690165380673110300954704629066'.  03120000
031300       10  FILLER                  PIC X(56) VALUE                03130000
031400     '00996302527049014298110351390071010382805200502802824038'.  03140000
031500       10  FILLER                  PIC X(56) VALUE                03150000
031600     '00557102326039005905025270480045880242604103602810635153'.  03160000
031700       10  FILLER                  PIC X(56) VALUE                03170000
031800     '00000000000000000000000000000359800683108110998917041302'.  03180000
031900       10  FILLER                  PIC X(56) VALUE                03190000
032000     '03574008533147000000000000000367650863312302247910334139'.  03200000
032100       10  FILLER                  PIC X(56) VALUE                03210000
032200     '01726605930093022883056300830140800352704613942426450326'.  03220000
032300       10  FILLER                  PIC X(56) VALUE                03230000
032400     '11229929754326036578114351491604133606046405682110635159'.  03240000
032500       10  FILLER                  PIC X(56) VALUE                03250000
032600     '03205809233117047915090331360203050623009104790514338205'.  03260000
032700       10  FILLER                  PIC X(56) VALUE                03270000
032800     '01814107231107010116044280660163080361904304029911235174'.  03280000
032900       10  FILLER                  PIC X(56) VALUE                03290000
033000     '01710004228059009169018150240928701804222700000000000000'.  03300000
033100     05  DRGX-TAB REDEFINES D-TAB.                                03310000
033200         10  DRGX-PERIOD               OCCURS 1                   03320000
033300                                        INDEXED BY DX5.           03330000
033400             15  DRGX-EFF-DATE         PIC X(06).                 03340000
033500             15  DRG-DATA              OCCURS 496                 03350000
033600                                        INDEXED BY DX6.           03360000
033700                 20  DRG-WT            PIC 9(02)V9(04).           03370000
033800                 20  DRG-ALOS          PIC 9(02)V9(01).           03380000
033900                 20  DRG-DAYS-TRIM     PIC 9(02).                 03390000
034000                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).           03400000
034100                                                                  03410000
034200 01  HOLD-AREA.                                                   03420000
034300     02  HOLD-DATES.                                              03430000
034400         05  HOLD-BILL-DATE.                                      03440000
034500             10  H-BILL-YY                PIC 9(02).              03450000
034600             10  H-BILL-MM                PIC 9(02).              03460000
034700             10  H-BILL-DD                PIC 9(02).              03470000
034800                                                                  03480000
034900         05  HOLD-FY-BEGIN-DATE.                                  03490000
035000             10  H-FY-BEGIN-YY            PIC 9(02).              03500000
035100             10  H-FY-BEGIN-MM            PIC 9(02).              03510000
035200             10  H-FY-BEGIN-DD            PIC 9(02).              03520000
035300                                                                  03530000
035400         05  HOLD-ADD-FY-BEGN-DATE.                               03540000
035500             10  H-ADD-FY-BEGN-YY            PIC 9(02).           03550000
035600             10  H-ADD-FY-BEGN-MM            PIC 9(02).           03560000
035700             10  H-ADD-FY-BEGN-DD            PIC 9(02).           03570000
035800                                                                  03580000
035900     02  HOLD-PPS-COMPONENTS.                                     03590000
036000         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).        03600000
036100         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).        03610000
036200                                                                  03620000
036300         05  H-OPER-HSP-PART              PIC 9(06)V9(09).        03630000
036400         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).        03640000
036500                                                                  03650000
036600         05  H-OPER-FSP-PART              PIC 9(06)V9(09).        03660000
036700         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).        03670000
036800         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).        03680000
036900                                                                  03690000
037000         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).        03700000
037100         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).        03710000
037200         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).        03720000
037300                                                                  03730000
037400         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).        03740000
037500         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).        03750000
037600                                                                  03760000
037700         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).        03770000
037800         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).        03780000
037900                                                                  03790000
038000         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).        03800000
038100         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).        03810000
038200                                                                  03820000
038300         05  H-OPER-DSH                   PIC 9(01)V9(04).        03830000
038400         05  H-CAPI-DSH                   PIC 9(01)V9(04).        03840000
038500                                                                  03850000
038600         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).        03860000
038700         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).        03870000
038800         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).        03880000
038900         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).        03890000
039000         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).        03900000
039100         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).        03910000
039200         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).        03920000
039300         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).        03930000
039400         05  H-CAPI-COLA                  PIC 9(01)V9(03).        03940000
039500         05  H-CAPI-SCH                   PIC 9(05)V9(02).        03950000
039600         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).        03960000
039700         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).        03970000
039800         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).        03980000
039900         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).        03990000
040000         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).        04000000
040100         05  H-CAPI-GAF                   PIC 9(05)V9(04).        04010000
040200         05  H-WAGE-INDEX                 PIC 9(02)V9(04).        04020000
040300         05  H-COV-DAYS                   PIC 9(3).               04030000
040400         05  H-PERDIEM-DAYS               PIC 9(3).               04040000
040500         05  H-REG-DAYS                   PIC 9(3).               04050000
040600         05  H-LTR-DAYS                   PIC 9(3).               04060000
040700         05  H-DSCHG-FRCTN                PIC 9(1)V9999.          04070000
040800         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.          04080000
040900         05  H-ALOS                       PIC 9(02)V9(01).        04090000
041000         05  H-ARITH-ALOS                 PIC 9(02)V9(01).        04100000
041100         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).        04110000
041200         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).        04120000
041300         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).        04130000
041400         05  H-CST-THRESH                 PIC 9(05)V9(02).        04140000
041500         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).        04150000
041600         05  H-BUDG-NUTR93                PIC 9(01)V9(06).        04160000
041700         05  H-BUDG-NUTR94                PIC 9(01)V9(06).        04170000
041800         05  H-BUDG-NUTR95                PIC 9(01)V9(06).        04180000
041900         05  H-BUDG-NUTR96                PIC 9(01)V9(06).        04190000
042000         05  H-BUDG-NUTR97                PIC 9(01)V9(06).        04200000
042100         05  H-UPDATE-95                  PIC 9(01)V9(03).        04210000
042200         05  H-UPDATE-96                  PIC 9(01)V9(03).        04220000
042300         05  H-UPDATE-97                  PIC 9(01)V9(03).        04230000
042400         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).        04240000
042500         05  H-HSP-UPDATE94               PIC 9(01)V9(04).        04250000
042600         05  H-HSP-UPDATE95               PIC 9(01)V9(04).        04260000
042700         05  H-HSP-UPDATE96               PIC 9(01)V9(04).        04270000
042800         05  H-HSP-UPDATE97               PIC 9(01)V9(04).        04280000
042900         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).        04290000
043000         05  H-FEDERAL-RATE               PIC 9(04)V9(02).        04300000
043100         05  H-LABOR-PCT                  PIC 9(01)V9(04).        04310000
043200         05  H-NLABOR-PCT                 PIC 9(01)V9(04).        04320000
043300         05  H-HSP-RATE                   PIC 9(06)V9(09).        04330000
043400         05  H-FSP-RATE                   PIC 9(06)V9(09).        04340000
043500         05  H-OUTLIER-FACT               PIC 9(01)V9(06).        04350000
043600         05  H-WK-OPER-DSH                PIC 9(01)V9(04).        04360000
043700         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).        04370000
043800                                                                  04380000
043900                                                                  04390000
044000     02  HOLD-ADDITIONAL-VARIABLES.                               04400000
044100         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).        04410000
044200         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).        04420000
044300         05  H-NAT-PCT                    PIC 9(01)V9(02).        04430000
044400         05  H-REG-PCT                    PIC 9(01)V9(02).        04440000
044500         05  H-CMI-ADJ-CPD                PIC 9(05)V9(02).        04450000
044600         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).        04460000
044700         05  H-DRG-WT                     PIC 9(02)V9(04).        04470000
044800         05  H-NAT-LABOR                  PIC 9(05)V9(02).        04480000
044900         05  H-NAT-NLABOR                 PIC 9(05)V9(02).        04490000
045000         05  H-REG-LABOR                  PIC 9(05)V9(02).        04500000
045100         05  H-REG-NLABOR                 PIC 9(05)V9(02).        04510000
045200         05  H-OPER-COLA                  PIC 9(01)V9(03).        04520000
045300         05  H-INTERN-RATIO               PIC 9(01)V9(04).        04530000
045400         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).        04540000
045500         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).        04550000
045600         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).        04560000
045700                                                                  04570000
045800     02  HOLD-CAPITAL-VARIABLES.                                  04580000
045900         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).        04590000
046000         05  H-CAPI-HSP                   PIC 9(07)V9(02).        04600000
046100         05  H-CAPI-FSP                   PIC 9(07)V9(02).        04610000
046200         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).        04620000
046300         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).        04630000
046400         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).        04640000
046500         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).        04650000
046600         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).        04660000
046700                                                                  04670000
046800     02  HOLD-CAPITAL2-VARIABLES.                                 04680000
046900         05  H-CAPI2-PAY-CODE             PIC X(1).               04690000
047000         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).        04700000
047100         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).        04710000
047200                                                                  04720000
047300 LINKAGE SECTION.                                                 04730000
047400***************************************************************   04740000
047500*                 * * * * * * * * *                           *   04750000
047600*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *   04760000
047700*    IN HOW TO PAY THE BILL.                                  *   04770000
047800*         REVIEW-CODE:                                        *   04780000
047900*            00 = PAY-WITH-OUTLIER.                           *   04790000
048000*                 WILL CALCULATE THE STANDARD PAYMENT.        *   04800000
048100*                 WILL ALSO ATTEMPT TO PAY DAY AND COST       *   04810000
048200*                 OUTLIERS.                                   *   04820000
048300*            03 = PAY-PERDIEM-DAYS.                           *   04830000
048400*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   04840000
048500*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *   04850000
048600*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   04860000
048700*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   04870000
048800*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   04880000
048900*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *   04890000
049000*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   04900000
049100*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *   04910000
049200*                 BILL EXCEED THE COST THRESHOLD.             *   04920000
049300*            06 = PAY-XFER-NO-COST                            *   04930000
049400*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   04940000
049500*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *   04950000
049600*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   04960000
049700*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *   04970000
049800*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   04980000
049900*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *   04990000
050000*                 CALCULATE ANY COST OUTLIER PORTION          *   05000000
050100*                 OF THE PAYMENT.                             *   05010000
050200*            07 = PAY-WITHOUT-COST.                           *   05020000
050300*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *   05030000
050400*                 ALSO CALCULATE THE DAY OUTLIER PORTION OF   *   05040000
050500*                 THE PAYMENT IF THE COVERED DAYS EXCEED THE  *   05050000
050600*                 OUTLIER CUTOFF FOR THE DRG.                 *   05060000
050700***************************************************************   05070000
050800 01  BILL-DATA.                                                   05080000
050900         10  B-PROVIDER-NO          PIC X(06).                    05090000
051000         10  B-REVIEW-CODE          PIC 9(02).                    05100000
051100             88  VALID-REVIEW-CODE  VALUE 00 03 06 07.            05110000
051200             88  PAY-WITH-OUTLIER   VALUE 00 07.                  05120000
051300             88  PAY-PERDIEM-DAYS   VALUE 03.                     05130000
051400             88  PAY-XFER-NO-COST   VALUE 06.                     05140000
051500             88  PAY-WITHOUT-COST   VALUE 07.                     05150000
051600         10  B-DRG                  PIC 9(03).                    05160000
051700         10  B-LOS                  PIC 9(03).                    05170000
051800         10  B-COVERED-DAYS         PIC 9(03).                    05180000
051900         10  B-LTR-DAYS             PIC 9(02).                    05190000
052000         10  B-DISCHARGE-DATE.                                    05200000
052100             15  B-DISCHG-MM        PIC 9(02).                    05210000
052200             15  B-DISCHG-DD        PIC 9(02).                    05220000
052300             15  B-DISCHG-YY        PIC 9(02).                    05230000
052400         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).              05240000
052500                                                                  05250000
052600***************************************************************   05260000
052700*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *   05270000
052800*    AND PASSED BACK TO THE CALLING PROGRAM                   *   05280000
052900*            RETURN CODE VALUES (PPS-RTC)                     *   05290000
053000*                                                             *   05300000
053100*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   05310000
053200*              00 = PAID NORMAL DRG PAYMENT                   *   05320000
053300*                                                             *   05330000
053400*              01 = PAID AS A DAY-OUTLIER.                    *   05340000
053500*                                                             *   05350000
053600*              02 = PAID AS A COST-OUTLIER.                   *   05360000
053700*                                                             *   05370000
053800*              03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   05380000
053900*                   AND INCLUDING THE FULL DRG.               *   05390000
054000*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   05400000
054100*                   AND INCLUDING THE FULL DRG WHICH ALSO     *   05410000
054200*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *   05420000
054300*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   05430000
054400*                   AND INCLUDING THE FULL DRG. PROVIDER      *   05440000
054500*                   REFUSED COST OUTLIER.                     *   05450000
054600*                                                             *   05460000
054700*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   05470000
054800*              51 = NO PROVIDER SPECIFIC INFO FOUND           *   05480000
054900*              52 = INVALID MSA # IN PROVIDER FILE            *   05490000
055000*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   05500000
055100*              54 = DRG < 001 OR > 495, OR = 109 OR = 438     *   05510000
055200*                                       OR = 469 OR = 470     *   05520000
055300*                                       OR = 474              *   05530000
055400*              55 = DISCHARGE DATE < PROVIDER PPS START DATE  *   05540000
055500*              56 = INVALID LENGTH OF STAY                    *   05550000
055600*              57 = REVIEW CODE INVALID (NOT 00 03 06 07)     *   05560000
055700*              58 = TOTAL CHARGES NOT NUMERIC                 *   05570000
055800*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   05580000
055900*              62 = INVALID NUMBER OF COVERED DAYS            *   05590000
056000*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *   05600000
056100*                   SPECIFIC FILE FOR CAPITAL                 *   05610000
056200*              66 = THERE ARE NOT AS MANY BENEFIT DAYS        *   05620000
056300*                   AVAILABLE ON THE BILL AS THERE ARE OUTLIER*   05630000
056400*                   DAYS COMPUTED BY PRICER --BENEFITS ARE    *   05640000
056500*                   EXHAUSTED ---                             *   05650000
056600*                   APPORTION THE CORRECT COVERED CHARGES     *   05660000
056700*                   FOR THE MAXIMUM NUMBER OF COVERED DAYS    *   05670000
056800*                   AVAILABLE BEFORE RESUBMITTING THE BILL    *   05680000
056900*                   FOR THE COST OUTLIER PAYMENT.             *   05690000
057000*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *   05700000
057100***************************************************************   05710000
057200 01  PPS-DATA.                                                    05720000
057300         10  PPS-RTC                PIC 9(02).                    05730000
057400         10  PPS-WAGE-INDX          PIC 9(02)V9(04).              05740000
057500         10  PPS-OUTLIER-DAYS       PIC 9(03).                    05750000
057600         10  PPS-AVG-LOS            PIC 9(02)V9(01).              05760000
057700         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).              05770000
057800         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).              05780000
057900         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).              05790000
058000         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).              05800000
058100         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).              05810000
058200         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).              05820000
058300         10  PPS-REG-DAYS-USED      PIC 9(03).                    05830000
058400         10  PPS-LTR-DAYS-USED      PIC 9(02).                    05840000
058500         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).              05850000
058600         10  PPS-CALC-VERS          PIC X(05).                    05860000
058700                                                                  05870000
058800******************************************************************05880000
058900*            THESE ARE THE VERSIONS OF THE PPCAL                  05890000
059000*           PROGRAMS THAT WILL BE PASSED BACK----                 05900000
059100*          ASSOCIATED WITH THE BILL BEING PROCESSED               05910000
059200******************************************************************05920000
059300 01  PRICER-OPT-VERS-SW.                                          05930000
059400     02  PRICER-OPTION-SW          PIC X(01).                     05940000
059500         88  ALL-TABLES-PASSED          VALUE 'A'.                05950000
059600         88  PROV-RECORD-PASSED         VALUE 'P'.                05960000
059700         88  ADDITIONAL-VARIABLES       VALUE 'M'.                05970000
059800     02  PPS-VERSIONS.                                            05980000
059900         10  PPDRV-VERSION         PIC X(05).                     05990000
060000                                                                  06000000
060100******************************************************************06010000
060200*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK           06020000
060300*          ASSOCIATED WITH THE BILL BEING PROCESSED               06030000
060400******************************************************************06040000
060500 01  PPS-ADDITIONAL-VARIABLES.                                    06050000
060600     05  PPS-HSP-PCT                PIC 9(01)V9(02).              06060000
060700     05  PPS-FSP-PCT                PIC 9(01)V9(02).              06070000
060800     05  PPS-NAT-PCT                PIC 9(01)V9(02).              06080000
060900     05  PPS-REG-PCT                PIC 9(01)V9(02).              06090000
061000     05  PPS-CMI-ADJ-CPD            PIC 9(05)V9(02).              06100000
061100     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).              06110000
061200     05  PPS-DRG-WT                 PIC 9(02)V9(04).              06120000
061300     05  PPS-NAT-LABOR              PIC 9(05)V9(02).              06130000
061400     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).              06140000
061500     05  PPS-REG-LABOR              PIC 9(05)V9(02).              06150000
061600     05  PPS-REG-NLABOR             PIC 9(05)V9(02).              06160000
061700     05  PPS-OPER-COLA              PIC 9(01)V9(03).              06170000
061800     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).              06180000
061900     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).              06190000
062000     05  PPS-BILL-COSTS             PIC 9(07)V9(09).              06200000
062100     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).              06210000
062200     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.                06220000
062300     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.                06230000
062400     05  PPS-CAPITAL-VARIABLES.                                   06240000
062500         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).        06250000
062600         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).        06260000
062700         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).        06270000
062800         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).        06280000
062900         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).        06290000
063000         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).        06300000
063100         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).        06310000
063200         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).        06320000
063300     05  PPS-CAPITAL2-VARIABLES.                                  06330000
063400         10  PPS-CAPI2-PAY-CODE             PIC X(1).             06340000
063500         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).      06350000
063600         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).      06360000
063610         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).      06361005
063620         10  PPS-HVBP-HRR-DATA.                                   06362005
063630             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.              06363005
063640             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).        06364005
063650             15  PPS-HOSP-READMISS-REDUCTN    PIC X.              06365005
063660             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).         06366010
063670         10  PPS-OPERATNG-DATA.                                   06367005
063680             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.            06368011
063690             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.        06369005
063691             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.        06369105
063692         10  PPS-FILLER                      PIC X(0998).         06369211
063700                                                                  06370000
063800                                                                  06380000
063900******************************************************************06390000
064000*               THIS IS THE PROVIDER RECORD                       06400000
064100*          ASSOCIATED WITH THE BILL BEING PROCESSED               06410000
064200******************************************************************06420000
064300 01  PROV-HOLD.                                                   06430000
064400     02  PROV-REC-HOLD.                                           06440000
064500         05  P-PROVIDER-NO.                                       06450000
064600             10  P-STATE                PIC 9(02).                06460000
064700             10  FILLER                 PIC X(04).                06470000
064800         05  P-EFF-DATE.                                          06480000
064900             10  P-EFF-YY               PIC 9(02).                06490000
065000             10  P-EFF-MM               PIC 9(02).                06500000
065100             10  P-EFF-DD               PIC 9(02).                06510000
065200         05  P-WAIVER-CODE              PIC X(01).                06520000
065300             88  WAIVER-STATE           VALUE 'Y'.                06530000
065400         05  P-PROVIDER-TYPE            PIC X(02).                06540000
065500             88  REFERRAL-CENTER        VALUE '07' '15' '17' '22'.06550000
065600             88  INDIAN-HEALTH-SERVICE  VALUE '08'.               06560000
065700             88  MDH-REBASED-FY90       VALUE '14' '15'.          06570000
065800             88  MDH-RRC-REBASED-FY90   VALUE '15'.               06580000
065900             88  SCH-REBASED-FY90       VALUE '16' '17'.          06590000
066000             88  SCH-RRC-REBASED-FY90   VALUE '17'.               06600000
066100             88  MEDICAL-ASSIST-FACIL   VALUE '18'.               06610000
066200             88  EACH                   VALUE '21' '22'.          06620000
066300             88  EACH-REFERRAL-CENTER   VALUE '22'.               06630000
066400         05  P-CURRENT-CENSUS-DIV       PIC 9(01).                06640000
066500             88  NEW-ENGLAND            VALUE  1.                 06650000
066600             88  MIDDLE-ATLANTIC        VALUE  2.                 06660000
066700             88  SOUTH-ATLANTIC         VALUE  3.                 06670000
066800             88  EAST-NORTH-CENTRAL     VALUE  4.                 06680000
066900             88  EAST-SOUTH-CENTRAL     VALUE  5.                 06690000
067000             88  WEST-NORTH-CENTRAL     VALUE  6.                 06700000
067100             88  WEST-SOUTH-CENTRAL     VALUE  7.                 06710000
067200             88  MOUNTAIN               VALUE  8.                 06720000
067300             88  PACIFIC                VALUE  9.                 06730000
067400         05  P-CENSUS-DIV  REDEFINES                              06740000
067500                    P-CURRENT-CENSUS-DIV       PIC 9(01).         06750000
067600             88  VALID-CENSUS-DIV   VALUE 1 THRU 9.               06760000
067700         05  P-PPS-BLEND-YEAR           PIC 9(01).                06770000
067800             88  VALID-PPS-BLEND-YEAR   VALUE 1 THRU 8.           06780000
067900         05  P-MSA-X.                                             06790000
068000             10  P-MSA-9                PIC X(04).                06800000
068100         05  P-FISCAL-YEAR-END.                                   06810000
068200             10  P-MM                   PIC 9(02).                06820000
068300             10  P-DD                   PIC 9(02).                06830000
068400             10  P-YY                   PIC 9(02).                06840000
068500         05  P-VARIABLES.                                         06850000
068600             10  P-CMI-ADJ-CPD          PIC S9(05)V9(02).         06860000
068700             10  P-COLA                 PIC S9(01)V9(03).         06870000
068800             10  P-INTERN-RATIO         PIC S9(01)V9(04).         06880000
068900             10  PRUP-UPDT-FACTOR       PIC S9(01)V9(05).         06890000
069000             10  P-BED-SIZE             PIC  9(05).               06900000
069100             10  P-DSH-PERCENT          PIC V9(04).               06910000
069200             10  P-OPER-CSTCHG-RATIO    PIC  9(01)V9(03).         06920000
069300             10  P-CMI                  PIC  9(01)V9(04).         06930000
069400             10  FILLER                 PIC  9(01).               06940000
069500             10  P-REPORT-DATE          PIC  9(06).               06950000
069600             10  FILLER                 PIC  9(01).               06960000
069700             10  P-INTER-NO             PIC  9(05).               06970000
069800     02  PROV-REC-HOLD2.                                          06980000
069900         05  P-FY-BEGIN-DATE.                                     06990000
070000             10  P-FY-BEGIN-MM          PIC 9(2).                 07000000
070100             10  P-FY-BEGIN-DD          PIC 9(2).                 07010000
070200             10  P-FY-BEGIN-YY          PIC 9(2).                 07020000
070300         05  P-PASS-AMT-CAPITAL         PIC 9(4)V99.              07030000
070400         05  P-PASS-AMT-DIR-MED-ED      PIC 9(4)V99.              07040000
070500         05  P-PASS-AMT-ORGAN-ACQ       PIC 9(4)V99.              07050000
070600         05  P-PASS-AMT-INCL-MISC       PIC 9(4)V99.              07060000
070700         05  P-SSI-RATIO                PIC V9(4).                07070000
070800         05  P-MEDICAID-RATIO           PIC V9(4).                07080000
070900         05  P-TERMINATION-DATE         PIC X(6).                 07090000
071000         05  P-WAGE-INDEX-LOC-MSA       PIC X(4).                 07100000
071100         05  P-CHG-CODE-INDEX           PIC X.                    07110000
071200         05  P-STAND-AMT-LOC-MSA.                                 07120000
071300             10  P-RURAL-1ST            PIC XX.                   07130000
071400                 88  P-RURAL-CHECK        VALUE '  '.             07140000
071500             10  P-RURAL-2ND            PIC XX.                   07150000
071600         05  P-CAPI-SOL-HOSP-RATE       PIC XX.                   07160000
071700         05  FILLER                     PIC X.                    07170000
071800         05  FILLER                     PIC X(06).                07180000
071900         05  FILLER                     PIC X(18).                07190000
072000     02  PROV-REC-HOLD3.                                          07200000
072100         05  P-CAPI-PPS-PAY-CODE        PIC X.                    07210000
072200         05  P-CAPI-HOSP-SPEC-RATE      PIC 9(4)V99.              07220000
072300         05  P-CAPI-OLD-HARM-RATE       PIC 9(4)V99.              07230000
072400         05  P-CAPI-NEW-HARM-RATIO      PIC 9(1)V9999.            07240000
072500         05  P-CAPI-CSTCHG-RATIO        PIC 9V999.                07250000
072600         05  P-CAPI-NEW-HOSP            PIC X.                    07260000
072700         05  P-CAPI-IME                 PIC 9V9999.               07270000
072800         05  P-CAPI-EXCEPTIONS          PIC 9(4)V99.              07280000
072810         05  P-HVBP-HRR-DATA.                                     07281005
072820             10  P-VAL-BASED-PURCH-PARTIPNT PIC X.                07282005
072830             10  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).          07283005
072840             10  P-HOSP-READMISSION-REDUCTN PIC X.                07284005
072850             10  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).           07285010
072860         05  P-MODEL1-BUNDLE-DATA.                                07286005
072870             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.             07287014
072871             15  P-HAC-REDUC-IND            PIC X.                07287113
072872             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.         07287213
072873             15  P-EHR-REDUC-IND            PIC X.                07287313
072874         05  FILLER                         PIC X(09).            07287413
072875                                                                  07287513
072890************************************************************      07289005
073000                                                                  07300000
073100******************************************************************07310000
073200*                   THIS IS THE WAGE-INDEX                        07320000
073300*          ASSOCIATED WITH THE BILL BEING PROCESSED               07330000
073400******************************************************************07340000
073500 01  WAGE-INDEX-RECORD.                                           07350000
073600     05  W-MSA                         PIC X(4).                  07360000
073700     05  W-SIZE                        PIC X.                     07370000
073800         88  LARGE-URBAN       VALUE 'L'.                         07380000
073900         88  OTHER-URBAN       VALUE 'O'.                         07390000
074000         88  ALL-RURAL         VALUE 'R'.                         07400000
074100     05  W-EFF-DATE                    PIC X(6).                  07410000
074200     05  FILLER                        PIC X.                     07420000
074300     05  W-INDEX-RECORD                PIC S9(02)V9(04).          07430000
074400                                                                  07440000
074500                                                                  07450000
074600 PROCEDURE DIVISION  USING BILL-DATA                              07460000
074700                           PPS-DATA                               07470000
074800                           PRICER-OPT-VERS-SW                     07480000
074900                           PPS-ADDITIONAL-VARIABLES               07490000
075000                           PROV-HOLD                              07500000
075100                           WAGE-INDEX-RECORD.                     07510000
075200                                                                  07520000
075300***************************************************************   07530000
075400*    PROCESSING:                                              *   07540000
075500*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE            07550000
075600*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *   07560000
075700*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *   07570000
075800*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *   07580000
075900*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   07590000
076000*           GOBACK.                                           *   07600000
076100*        D. ASSEMBLE PRICING COMPONENTS.                      *   07610000
076200*        E. CALCULATE THE PRICE.                              *   07620000
076300***************************************************************   07630000
076400                                                                  07640000
076500     PERFORM 0200-MAINLINE-CONTROL.                               07650000
076600                                                                  07660000
076700     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES. 07670000
076800     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.          07680000
076900     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.         07690000
077000     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.    07700000
077100     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.   07710000
077200     MOVE CAL-VERSION               TO  PPS-CALC-VERS.            07720000
077300                                                                  07730000
077400     GOBACK.                                                      07740000
077500                                                                  07750000
077600 0200-MAINLINE-CONTROL.                                           07760000
077700     MOVE ALL '0' TO PPS-DATA                                     07770000
077800                     HOLD-PPS-COMPONENTS                          07780000
077900                     HOLD-ADDITIONAL-VARIABLES                    07790000
078000                     HOLD-CAPITAL-VARIABLES                       07800000
078100                     HOLD-CAPITAL2-VARIABLES.                     07810000
078200                                                                  07820000
078300     IF P-CAPI-HOSP-SPEC-RATE NOT NUMERIC                         07830000
078400        MOVE 0 TO P-CAPI-HOSP-SPEC-RATE.                          07840000
078500                                                                  07850000
078600     IF P-CAPI-OLD-HARM-RATE  NOT NUMERIC                         07860000
078700        MOVE 0 TO P-CAPI-OLD-HARM-RATE.                           07870000
078800                                                                  07880000
078900     IF P-CAPI-NEW-HARM-RATIO NOT NUMERIC                         07890000
079000        MOVE 0 TO P-CAPI-NEW-HARM-RATIO.                          07900000
079100                                                                  07910000
079200     IF P-CAPI-CSTCHG-RATIO NOT NUMERIC                           07920000
079300        MOVE 0 TO P-CAPI-CSTCHG-RATIO.                            07930000
079400                                                                  07940000
079500******************************************************************07950000
079600     PERFORM 1000-EDIT-THE-BILL-INFO.                             07960000
079700                                                                  07970000
079800     IF  PPS-RTC = 00                                             07980000
079900         PERFORM 2000-ASSEMBLE-PPS-VARIABLES                      07990000
080000         PERFORM 3000-CALC-PAYMENT.                               08000000
080100                                                                  08010000
080200 1000-EDIT-THE-BILL-INFO.                                         08020000
080300***************************************************************   08030000
080400*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   08040000
080500*    AND DO NOT ATTEMPT TO PRICE.                             *   08050000
080600***************************************************************   08060000
080700                                                                  08070000
080800     MOVE B-DISCHG-YY TO H-BILL-YY.                               08080000
080900     MOVE B-DISCHG-MM TO H-BILL-MM.                               08090000
081000     MOVE B-DISCHG-DD TO H-BILL-DD.                               08100000
081100                                                                  08110000
081200     MOVE P-FY-BEGIN-YY TO H-FY-BEGIN-YY.                         08120000
081300     MOVE P-FY-BEGIN-MM TO H-FY-BEGIN-MM.                         08130000
081400     MOVE P-FY-BEGIN-DD TO H-FY-BEGIN-DD.                         08140000
081500                                                                  08150000
081600     IF HOLD-FY-BEGIN-DATE < 961001                               08160000
081700        MOVE .50 TO H-CAPI-PAYCDE-PCT1                            08170000
081800        MOVE .50 TO H-CAPI-PAYCDE-PCT2                            08180000
081900     ELSE                                                         08190000
082000        IF (HOLD-FY-BEGIN-DATE < HOLD-BILL-DATE) OR               08200000
082100           (HOLD-FY-BEGIN-DATE = HOLD-BILL-DATE)                  08210000
082200              MOVE .60 TO H-CAPI-PAYCDE-PCT1                      08220000
082300              MOVE .40 TO H-CAPI-PAYCDE-PCT2                      08230000
082400        ELSE                                                      08240000
082500              MOVE .50 TO H-CAPI-PAYCDE-PCT1                      08250000
082600              MOVE .50 TO H-CAPI-PAYCDE-PCT2.                     08260000
082700                                                                  08270000
082800     IF  PPS-RTC = 00                                             08280000
082900         IF  WAIVER-STATE                                         08290000
083000             MOVE 53 TO PPS-RTC.                                  08300000
083100                                                                  08310000
083200     IF  PPS-RTC = 00                                             08320000
083300         IF  B-DRG < 001 OR > 495 OR = 109 OR = 438               08330000
083400                                  OR = 469 OR = 470               08340000
083500                                  OR = 474                        08350000
083600             MOVE 54 TO PPS-RTC.                                  08360000
083700                                                                  08370000
083800     IF  PPS-RTC = 00                                             08380000
083900         IF  HOLD-BILL-DATE < P-EFF-DATE                          08390000
084000             MOVE 55 TO PPS-RTC.                                  08400000
084100                                                                  08410000
084200     IF  PPS-RTC = 00                                             08411000
084300         IF  B-REVIEW-CODE NOT NUMERIC                            08412000
084400             MOVE 57 TO PPS-RTC.                                  08413000
084500     IF  PPS-RTC = 00                                             08420000
084600         IF  B-LOS NOT NUMERIC                                    08430000
084700             MOVE 56 TO PPS-RTC                                   08440000
084800         ELSE                                                     08450000
084900         IF  B-LOS = 0                                            08460000
085000             IF B-REVIEW-CODE NOT = 03 AND                        08470000
085100                              NOT = 06                            08480000
085200             MOVE 56 TO PPS-RTC.                                  08490000
085300                                                                  08500000
085400     IF  PPS-RTC = 00                                             08510000
085500         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60            08520000
085600             MOVE 61 TO PPS-RTC                                   08530000
085700         ELSE                                                     08540000
085800             MOVE B-LTR-DAYS TO H-LTR-DAYS.                       08550000
085900                                                                  08560000
086000     IF  PPS-RTC = 00                                             08570000
086100         IF  B-COVERED-DAYS NOT NUMERIC                           08580000
086200             MOVE 62 TO PPS-RTC                                   08590000
086300         ELSE                                                     08600000
086400         IF  B-COVERED-DAYS = 0 AND B-LOS > 0                     08610000
086500             MOVE 62 TO PPS-RTC                                   08620000
086600         ELSE                                                     08630000
086700             MOVE B-COVERED-DAYS TO H-COV-DAYS.                   08640000
086800                                                                  08650000
086900     IF  PPS-RTC = 00                                             08660000
087000         IF  H-LTR-DAYS  > H-COV-DAYS                             08670000
087100             MOVE 62 TO PPS-RTC                                   08680000
087200         ELSE                                                     08690000
087300             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.        08700000
087400                                                                  08710000
087500     IF  PPS-RTC = 00                                             08720000
087600         IF  NOT VALID-REVIEW-CODE                                08730000
087700             MOVE 57 TO PPS-RTC.                                  08740000
087800                                                                  08750000
087900     IF  PPS-RTC = 00                                             08760000
088000         IF  B-CHARGES-CLAIMED NOT NUMERIC                        08770000
088100             MOVE 58 TO PPS-RTC.                                  08780000
088200                                                                  08790000
088300     IF PPS-RTC = 00                                              08800000
088400        IF NOT INDIAN-HEALTH-SERVICE                              08810000
088500           IF P-CAPI-NEW-HOSP NOT = 'Y'                           08820000
088600                 IF P-CAPI-PPS-PAY-CODE NOT = 'A' AND             08830000
088700                                        NOT = 'B' AND             08840000
088800                                        NOT = 'C'                 08850000
088900                 MOVE 65 TO PPS-RTC.                              08860000
089000                                                                  08870000
089100 2000-ASSEMBLE-PPS-VARIABLES.                                     08880000
089200***************************************************************   08890000
089300*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   08900000
089400*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   08910000
089500*    OF THAT VARIABLE.                                        *   08920000
089600***************************************************************   08930000
089700***  GET THE PROVIDER SPECIFIC VARIABLES.                         08940000
089800***  GET THE PROVIDER SPECIFIC VARIABLES.                         08950000
089900                                                                  08960000
090000     MOVE P-CMI-ADJ-CPD  TO H-CMI-ADJ-CPD.                        08970000
090100     MOVE P-INTERN-RATIO TO H-INTERN-RATIO.                       08980000
090200                                                                  08990000
090300     IF  (P-STATE = 02 OR 12)                                     09000000
090400         MOVE P-COLA TO H-OPER-COLA                               09010000
090500     ELSE                                                         09020000
090600         MOVE 1.000  TO H-OPER-COLA.                              09030000
090700                                                                  09040000
090800***************************************************************   09050000
090900***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF              09060000
091000***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF              09070000
091100                                                                  09080000
091200     PERFORM 2600-GET-DRG-WEIGHT                                  09090000
091300             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.               09100000
091400                                                                  09110000
091500***************************************************************   09120000
091600***  GET THE WAGE-INDEX                                           09130000
091700***  GET THE WAGE-INDEX                                           09140000
091800                                                                  09150000
091900     MOVE W-INDEX-RECORD TO H-WAGE-INDEX.                         09160000
092000                                                                  09170000
092100***************************************************************   09180000
092200***  GET THE LABOR, NON-LABOR STANDARD RATES                      09190000
092300                                                                  09200000
092400     IF  VALID-CENSUS-DIV                                         09210000
092500         MOVE P-CURRENT-CENSUS-DIV TO R2                          09220000
092600     ELSE                                                         09230000
092700         MOVE 10 TO R2.                                           09240000
092800                                                                  09250000
092900     MOVE 10 TO R4.                                               09260000
093000                                                                  09270000
093100     IF  P-STATE = 40                                             09280000
093200         MOVE 11 TO R2                                            09290000
093300         MOVE 12 TO R4.                                           09300000
093400                                                                  09310000
093500     IF  LARGE-URBAN                                              09320000
093600         MOVE 1 TO R3                                             09330000
093700     ELSE                                                         09340000
093800     IF  OTHER-URBAN OR REFERRAL-CENTER                           09350000
093900         MOVE 2 TO R3                                             09360000
094000     ELSE                                                         09370000
094100         MOVE 3 TO R3.                                            09380000
094200                                                                  09390000
094300     PERFORM 2300-GET-LABOR-NLABOR-RATES                          09400000
094400             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 09410000
094500                                                                  09420000
094600***************************************************************   09430000
094700***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL               09440000
094800***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL               09450000
094900                                                                  09460000
095000     MOVE 0.00  TO H-OPER-HSP-PCT.                                09470000
095100     MOVE 1.00  TO H-OPER-FSP-PCT.                                09480000
095200                                                                  09490000
095300***************************************************************   09500000
095400***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL     09510000
095500***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL     09520000
095600                                                                  09530000
095700      MOVE 1.00 TO H-NAT-PCT.                                     09540000
095800      MOVE 0.00 TO H-REG-PCT.                                     09550000
095900                                                                  09560000
096000***************************************************************   09570000
096100*    REGIONAL FLOOR EXPIRED 10/01/96                              09580000
096200*    REGIONAL FLOOR EXPIRED 10/01/96                              09590000
096300                                                                  09600000
096400*    IF  (H-REG-LABOR + H-REG-NLABOR) >                           09610000
096500*        (H-NAT-LABOR + H-NAT-NLABOR)                             09620000
096600*          MOVE 0.85 TO H-NAT-PCT                                 09630000
096700*          MOVE 0.15 TO H-REG-PCT.                                09640000
096800***************************************************************   09650000
096900                                                                  09660000
097000     IF  P-STATE = 40                                             09670000
097100         MOVE 0.25 TO H-NAT-PCT                                   09680000
097200         MOVE 0.75 TO H-REG-PCT.                                  09690000
097300                                                                  09700000
097400     IF  SCH-REBASED-FY90 OR EACH                                 09710000
097500         MOVE 1.00 TO H-OPER-HSP-PCT.                             09720000
097600                                                                  09730000
097700 2300-GET-LABOR-NLABOR-RATES.                                     09740000
097800                                                                  09750000
097900     IF  HOLD-BILL-DATE NOT < RATE-EFF-DATE (R1)                  09760000
098000         MOVE REG-LABOR  (R1 R2 R3) TO H-REG-LABOR                09770000
098100         MOVE REG-NLABOR (R1 R2 R3) TO H-REG-NLABOR               09780000
098200         MOVE REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR                09790000
098300         MOVE REG-NLABOR (R1 R4 R3) TO H-NAT-NLABOR.              09800000
098400                                                                  09810000
098500 2600-GET-DRG-WEIGHT.                                             09820000
098600     IF  HOLD-BILL-DATE NOT < DRGX-EFF-DATE (DX5)                 09830000
098700         SET DX6 TO B-DRG                                         09840000
098800         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT                09850000
098900         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS                  09860000
099000         MOVE DRG-DAYS-TRIM (DX5 DX6)  TO H-DAYS-CUTOFF           09870000
099100         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.           09880000
099200                                                                  09890000
099300 3000-CALC-PAYMENT.                                               09900000
099400***************************************************************   09910000
099500*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   09920000
099600*        CALCULATE COVERED DAYS UTILIZATION.                  *   09930000
099700*        CALCULATE THE FEDERAL PORTION.                       *   09940000
099800*        CALCULATE THE HOSPITAL PORTION.                      *   09950000
099900*        CALCULATE THE DAYS-OUTLIER PORTION.                  *   09960000
100000*        CALCULATE THE COST-OUTLIER PORTION.                  *   09970000
100100*        CALCULATE THE TOTAL PAYMENT OPERATING AND CAPITAL    *   09980000
100200*        CALCULATE THE DSH ADJUSTMENT.                        *   09990000
100300*        CALCULATE THE IME TEACHING.                          *   10000000
100400***************************************************************   10010000
100500     PERFORM 3100-CALC-STAY-UTILIZATION.                          10020000
100600     PERFORM 3300-CALC-OPER-FSP-AMT.                              10030000
100700     PERFORM 3900-CALC-OPER-DSH.                                  10040000
100800***********************************************************       10050000
100900***  OPERATING IME CALCULATION                                    10060000
101000***  OPERATING IME CALCULATION                                    10070000
101100                                                                  10080000
101200         COMPUTE H-OPER-IME-TEACH =                               10090000
101300            1.89 * ((1 + H-INTERN-RATIO) ** .405  - 1).           10100000
101400                                                                  10110000
101500***********************************************************       10120000
101600                                                                  10130000
101700     IF  SCH-REBASED-FY90 OR EACH                                 10140000
101800         PERFORM 3450-CALC-ADDITIONAL-HSP.                        10150000
101900                                                                  10160000
102000     MOVE 00                 TO  PPS-RTC.                         10170000
102100     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.                   10180000
102200     MOVE H-ALOS             TO  PPS-AVG-LOS.                     10190000
102300     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.                 10200000
102400                                                                  10210000
102500     MOVE B-LOS TO H-PERDIEM-DAYS.                                10220000
102600     IF H-PERDIEM-DAYS < 1                                        10230000
102700         MOVE 1 TO H-PERDIEM-DAYS.                                10240000
102800     ADD 1 TO H-PERDIEM-DAYS.                                     10250000
102900                                                                  10260000
103000     PERFORM 3600-CALC-OUTLIER.                                   10270000
103100                                                                  10280000
103200     IF PAY-PERDIEM-DAYS                                          10290000
103300         IF  H-PERDIEM-DAYS < H-ALOS                              10300000
103400             IF  NOT (B-DRG = 385 OR 456)                         10310000
103500                 PERFORM 3500-CALC-PERDIEM-AMT                    10320000
103600                 MOVE 03 TO PPS-RTC.                              10330000
103700                                                                  10340000
103800     IF  PAY-PERDIEM-DAYS                                         10350000
103900         IF  H-OPER-OUTCST-PART > 0                               10360000
104000             MOVE H-OPER-OUTCST-PART TO                           10370000
104100                  H-OPER-OUTLIER-PART                             10380000
104200             MOVE 05 TO PPS-RTC                                   10390000
104300         ELSE                                                     10400000
104400         IF  PPS-RTC NOT = 03                                     10410000
104500             MOVE 00 TO PPS-RTC                                   10420000
104600             MOVE 0  TO H-OPER-OUTLIER-PART.                      10430000
104700                                                                  10440000
104800     IF  PAY-PERDIEM-DAYS                                         10450000
104900         IF  H-CAPI-OUTCST-PART > 0                               10460000
105000             MOVE H-CAPI-OUTCST-PART TO                           10470000
105100                  H-CAPI-OUTLIER-PART                             10480000
105200             MOVE 05 TO PPS-RTC                                   10490000
105300         ELSE                                                     10500000
105400         IF  PPS-RTC NOT = 03                                     10510000
105500             MOVE 0  TO H-CAPI-OUTLIER-PART.                      10520000
105600                                                                  10530000
105700     IF  PAY-XFER-NO-COST                                         10540000
105800         MOVE 0  TO H-OPER-OUTLIER-PART                           10550000
105900                    H-CAPI-OUTLIER-PART                           10560000
106000         MOVE 00 TO PPS-RTC                                       10570000
106100         IF H-PERDIEM-DAYS < H-ALOS                               10580000
106200            IF  NOT (B-DRG = 385 OR 456)                          10590000
106300                PERFORM 3500-CALC-PERDIEM-AMT                     10600000
106400                MOVE 06 TO PPS-RTC.                               10610000
106500                                                                  10620000
106600     MOVE 1 TO H-DSCHG-FRCTN.                                     10630000
106700                                                                  10640000
106800     IF  (PAY-PERDIEM-DAYS OR                                     10650000
106900          PAY-XFER-NO-COST)                                       10660000
107000          COMPUTE H-DSCHG-FRCTN = H-PERDIEM-DAYS / H-ALOS         10670000
107100          IF H-DSCHG-FRCTN > 1                                    10680000
107200             MOVE 1 TO H-DSCHG-FRCTN.                             10690000
107300                                                                  10700000
107400     COMPUTE H-DRG-WT-FRCTN = H-DSCHG-FRCTN * H-DRG-WT.           10710000
107500                                                                  10720000
107600***********************************************************       10730000
107700***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF          10740000
107800***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE          10750000
107900                                                                  10760000
108000     COMPUTE H-CAPI2-B-FSP-PART = H-CAPI-FSP-PART.                10770000
108100                                                                  10780000
108200***********************************************************       10790000
108300     IF  PPS-RTC < 50                                             10800000
108400         PERFORM 3800-CALC-TOT-AMT                                10810000
108500     ELSE                                                         10820000
108600         MOVE 0 TO PPS-OPER-HSP-PART                              10830000
108700                   PPS-OPER-FSP-PART                              10840000
108800                   PPS-OPER-OUTLIER-PART                          10850000
108900                   PPS-OUTLIER-DAYS                               10860000
109000                   PPS-REG-DAYS-USED                              10870000
109100                   PPS-LTR-DAYS-USED                              10880000
109200                   PPS-TOTAL-PAYMENT                              10890000
109300                   PPS-OPER-DSH-ADJ                               10900000
109400                   PPS-OPER-IME-ADJ                               10910000
109500                   H-DSCHG-FRCTN                                  10920000
109600                   H-DRG-WT-FRCTN                                 10930000
109700                   HOLD-CAPITAL-VARIABLES                         10940000
109800                   HOLD-CAPITAL2-VARIABLES.                       10950000
109900                                                                  10960000
110000 3100-CALC-STAY-UTILIZATION.                                      10970000
110100                                                                  10980000
110200     IF  H-REG-DAYS > 0                                           10990000
110300         IF  H-REG-DAYS < H-DAYS-CUTOFF                           11000000
110400             MOVE H-REG-DAYS TO PPS-REG-DAYS-USED                 11010000
110500             MOVE 0          TO H-REG-DAYS                        11020000
110600         ELSE                                                     11030000
110700             MOVE H-DAYS-CUTOFF TO PPS-REG-DAYS-USED              11040000
110800             SUBTRACT H-DAYS-CUTOFF FROM H-REG-DAYS               11050000
110900     ELSE                                                         11060000
111000     IF  H-LTR-DAYS < H-DAYS-CUTOFF                               11070000
111100         MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED                     11080000
111200         MOVE 0          TO H-LTR-DAYS                            11090000
111300     ELSE                                                         11100000
111400         MOVE H-DAYS-CUTOFF TO PPS-LTR-DAYS-USED                  11110000
111500         SUBTRACT H-DAYS-CUTOFF FROM H-LTR-DAYS.                  11120000
111600                                                                  11130000
111700     IF  B-LOS > H-DAYS-CUTOFF                                    11140000
111800         PERFORM 3200-CALC-OUTLIER-UTILIZATION.                   11150000
111900                                                                  11160000
112000 3200-CALC-OUTLIER-UTILIZATION.                                   11170000
112100                                                                  11180000
112200     COMPUTE PPS-OUTLIER-DAYS =                                   11190000
112300         B-LOS - H-DAYS-CUTOFF.                                   11200000
112400                                                                  11210000
112500     IF  (H-REG-DAYS + H-LTR-DAYS) < PPS-OUTLIER-DAYS             11220000
112600         COMPUTE PPS-OUTLIER-DAYS =                               11230000
112700             H-REG-DAYS + H-LTR-DAYS                              11240000
112800         ADD H-REG-DAYS TO PPS-REG-DAYS-USED                      11250000
112900         ADD H-LTR-DAYS TO PPS-LTR-DAYS-USED                      11260000
113000     ELSE                                                         11270000
113100     IF  H-REG-DAYS < PPS-OUTLIER-DAYS                            11280000
113200         ADD H-REG-DAYS TO PPS-REG-DAYS-USED                      11290000
113300         COMPUTE PPS-LTR-DAYS-USED =                              11300000
113400             PPS-LTR-DAYS-USED + (PPS-OUTLIER-DAYS -              11310000
113500                                  H-REG-DAYS)                     11320000
113600     ELSE                                                         11330000
113700         ADD PPS-OUTLIER-DAYS TO PPS-REG-DAYS-USED.               11340000
113800                                                                  11350000
113900     IF  B-REVIEW-CODE = 03                                       11360000
114000         IF  PPS-REG-DAYS-USED > 0                                11370000
114100             MOVE 0 TO PPS-LTR-DAYS-USED.                         11380000
114200                                                                  11390000
114300 3300-CALC-OPER-FSP-AMT.                                          11400000
114400***********************************************************       11410000
114500***  OPERATING FSP CALCULATION                                    11420000
114600***  OPERATING FSP CALCULATION                                    11430000
114700                                                                  11440000
114800     COMPUTE H-OPER-FSP-PART ROUNDED =                            11450000
114900         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +               11460000
115000         H-NAT-NLABOR * H-OPER-COLA) * H-DRG-WT)                  11470000
115100                           +                                      11480000
115200         (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDEX +               11490000
115300         H-REG-NLABOR * H-OPER-COLA) * H-DRG-WT).                 11500000
115400                                                                  11510000
115500                                                                  11520000
115600 3450-CALC-ADDITIONAL-HSP.                                        11530000
115700***********************************************************       11540000
115800*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR                 11550000
115900*    SOLE COMMUNITY                                               11560000
116000*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)              11570000
116100*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES              11580000
116200***********************************************************       11590000
116300**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE       11600000
116400****    USE ACTUAL FEDERAL REGISTER NUMBER                        11610000
116500                                                                  11620000
116600     MOVE 0.949001 TO H-OUTLIER-FACT.                             11630000
116700***************************************************************   11640000
116800***         GET THE UPDATING FACTOR                               11650000
116900***         GET THE UPDATING FACTOR                               11660000
117000                                                                  11670000
117100     MOVE 0.999851 TO H-BUDG-NUTR93.                              11680000
117200     MOVE 0.999003 TO H-BUDG-NUTR94.                              11690000
117300     MOVE 0.998050 TO H-BUDG-NUTR95.                              11700000
117400     MOVE 0.999306 TO H-BUDG-NUTR96.                              11710000
117500     MOVE 0.998703 TO H-BUDG-NUTR97.                              11720000
117600                                                                  11730000
117700     MOVE 1.014 TO H-UPDATE-95.                                   11740000
117800     MOVE 1.015 TO H-UPDATE-96.                                   11750000
117900     MOVE 1.020 TO H-UPDATE-97.                                   11760000
118000                                                                  11770000
118100     COMPUTE H-UPDATE-FACTOR ROUNDED =                            11780000
118200        (H-UPDATE-95 * H-UPDATE-96 *                              11790000
118300         H-UPDATE-97 *                                            11800000
118400         H-BUDG-NUTR93 * H-BUDG-NUTR94 *                          11810000
118500         H-BUDG-NUTR95 * H-BUDG-NUTR96 *                          11820000
118600         H-BUDG-NUTR97).                                          11830000
118700                                                                  11840000
118800     COMPUTE H-HSP-RATE ROUNDED =                                 11850000
118900         H-CMI-ADJ-CPD * H-UPDATE-FACTOR.                         11860000
119000                                                                  11870000
119100     COMPUTE H-FSP-RATE ROUNDED =                                 11880000
119200         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +              11890000
119300         H-NAT-NLABOR * H-OPER-COLA))                             11900000
119400                           +                                      11910000
119500          (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDEX +              11920000
119600         H-REG-NLABOR * H-OPER-COLA)))                            11930000
119700                           *                                      11940000
119800       ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-FACT).    11950000
119900                                                                  11960000
120000     IF  H-HSP-RATE > H-FSP-RATE                                  11970000
120100           COMPUTE H-OPER-HSP-PART =                              11980000
120200             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT                 11990000
120300     ELSE                                                         12000000
120400         MOVE 0 TO H-OPER-HSP-PART.                               12010000
120500                                                                  12020000
120600 3500-CALC-PERDIEM-AMT.                                           12030000
120700***********************************************************       12040000
120800***  OPERATING PERDIEM-AMT CALCULATION                            12050000
120900***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS              12060000
121000                                                                  12070000
121100     COMPUTE H-OPER-HSP-PART ROUNDED =                            12080000
121200        H-OPER-HSP-PART / H-ALOS * H-PERDIEM-DAYS                 12090000
121300        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.                  12100000
121400                                                                  12110000
121500     COMPUTE H-OPER-FSP-PART ROUNDED =                            12120000
121600        H-OPER-FSP-PART / H-ALOS * H-PERDIEM-DAYS                 12130000
121700        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  12140000
121800                                                                  12150000
121900***********************************************************       12160000
122000***  CAPITAL PERDIEM-AMT CALCULATION                              12170000
122100***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS                12180000
122200                                                                  12190000
122300     COMPUTE H-CAPI-HSP-PART ROUNDED =                            12200000
122400        H-CAPI-HSP-PART / H-ALOS * H-PERDIEM-DAYS                 12210000
122500        ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.                  12220000
122600                                                                  12230000
122700     COMPUTE H-CAPI-FSP-PART ROUNDED =                            12240000
122800        H-CAPI-FSP-PART / H-ALOS * H-PERDIEM-DAYS                 12250000
122900        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  12260000
123000                                                                  12270000
123100***********************************************************       12280000
123200***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                12290000
123300***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                12300000
123400                                                                  12310000
123500     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                        12320000
123600        H-CAPI-OLD-HARMLESS / H-ALOS * H-PERDIEM-DAYS             12330000
123700        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              12340000
123800                                                                  12350000
123900 3600-CALC-OUTLIER.                                               12360000
124000     MOVE 0.33 TO H-DAYOUT-PCT.                                   12370000
124100                                                                  12380000
124200     MOVE 0.80 TO H-CSTOUT-PCT.                                   12390000
124300                                                                  12400000
124400     IF  B-DRG = 456 OR 457 OR 458 OR 459 OR 460 OR 472           12410000
124500             MOVE 0.90 TO H-CSTOUT-PCT.                           12420000
124600                                                                  12430000
124700     MOVE 0.7120   TO H-LABOR-PCT.                                12440000
124800     MOVE 0.2880   TO H-NLABOR-PCT.                               12450000
124900                                                                  12460000
125000     IF  P-OPER-CSTCHG-RATIO NUMERIC                              12470000
125100             MOVE P-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO      12480000
125200     ELSE                                                         12490000
125300             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.                   12500000
125400                                                                  12510000
125500     IF P-CAPI-CSTCHG-RATIO NUMERIC                               12520000
125600             MOVE P-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO      12530000
125700     ELSE                                                         12540000
125800             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.                   12550000
125900                                                                  12560000
126000***********************************************************       12570000
126100***  OPERATING DAY OUTLIER CALCULATION                            12580000
126200***  OPERATING DAY OUTLIER CALCULATION                            12590000
126300                                                                  12600000
126400     IF  PPS-OUTLIER-DAYS > 0                                     12610000
126500        COMPUTE H-OPER-OUTDAY-PART =                              12620000
126600            H-DAYOUT-PCT *  H-OPER-FSP-PART / H-ARITH-ALOS        12630000
126700                                       * PPS-OUTLIER-DAYS         12640000
126800            ON SIZE ERROR MOVE 0 TO H-OPER-OUTDAY-PART.           12650000
126900                                                                  12660000
127000***********************************************************       12670000
127100***********************************************************       12680000
127200***  CAPITAL PAYMENT METHOD B                                     12690000
127300***  CAPITAL PAYMENT METHOD B                                     12700000
127400                                                                  12710000
127500     IF W-SIZE = 'L'                                              12720000
127600        MOVE 1.03 TO H-CAPI-LARG-URBAN                            12730000
127700     ELSE                                                         12740000
127800        MOVE 1.00 TO H-CAPI-LARG-URBAN.                           12750000
127900                                                                  12760000
128000     COMPUTE H-CAPI-GAF = (H-WAGE-INDEX ** .6848).                12770000
128100                                                                  12780000
128200     COMPUTE H-CAPI-COLA =                                        12790000
128300                     (.3152 * (H-OPER-COLA - 1) + 1).             12800000
128400                                                                  12810000
128500     MOVE 0337.63 TO H-PUERTO-RICO-RATE.                          12820000
128600     MOVE 0438.92 TO H-FEDERAL-RATE.                              12830000
128700                                                                  12840000
128800     IF P-STATE = 40                                              12850000
128900        COMPUTE  H-CAPI-FED-RATE =                                12860000
129000                      (.75 * H-PUERTO-RICO-RATE) +                12870000
129100                      (.25 * H-FEDERAL-RATE)                      12880000
129200     ELSE                                                         12890000
129300        MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.                   12900000
129400                                                                  12910000
129500***********************************************************       12920000
129600***  CAPITAL HSP CALCULATION                                      12930000
129700***  CAPITAL HSP CALCULATION                                      12940000
129800                                                                  12950000
129900     MOVE 0.9784 TO H-HSP-UPDATE94.                               12960000
130000     MOVE 1.0005 TO H-HSP-UPDATE95.                               12970000
130100     MOVE 1.2110 TO H-HSP-UPDATE96.                               12980000
130200     MOVE 0.9568 TO H-HSP-UPDATE97.                               12990000
130300                                                                  13000000
130400     COMPUTE H-ACCUM-TO-HSP = (H-HSP-UPDATE94 *                   13010000
130500                               H-HSP-UPDATE95 *                   13020000
130600                               H-HSP-UPDATE96 *                   13030000
130700                               H-HSP-UPDATE97).                   13040000
130800                                                                  13050000
130900     COMPUTE H-CAPI-HSP-PART = (H-DRG-WT *                        13060000
131000                   P-CAPI-HOSP-SPEC-RATE * H-ACCUM-TO-HSP).       13070000
131100***********************************************************       13080000
131200***  CAPITAL FSP CALCULATION                                      13090000
131300***  CAPITAL FSP CALCULATION                                      13100000
131400                                                                  13110000
131500     COMPUTE H-CAPI-FSP-PART = H-DRG-WT * H-CAPI-FED-RATE *       13120000
131600                               H-CAPI-COLA * H-CAPI-GAF *         13130000
131700                               H-CAPI-LARG-URBAN.                 13140000
131800                                                                  13150000
131900***********************************************************       13160000
132000***  CAPITAL PAYMENT METHOD A                                     13170000
132100***  CAPITAL PAYMENT METHOD A                                     13180000
132200                                                                  13190000
132300     IF SCH-REBASED-FY90 OR EACH                                  13200000
132400        MOVE 1.00 TO H-CAPI-SCH                                   13210000
132500     ELSE                                                         13220000
132600        MOVE 0.85 TO H-CAPI-SCH.                                  13230000
132700                                                                  13240000
132800***********************************************************       13250000
132900***********  CAPITAL OLD-HARMLESS CALCULATION ***********         13260000
133000***********  CAPITAL OLD-HARMLESS CALCULATION ***********         13270000
133100                                                                  13280000
133200     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                        13290000
133300                    (P-CAPI-OLD-HARM-RATE *                       13300000
133400                    H-CAPI-SCH).                                  13310000
133500                                                                  13320000
133600***********************************************************       13330000
133700***********************************************************       13340000
133800***  CAPITAL DAY OUTLIER CALCULATION                              13350000
133900***  CAPITAL DAY OUTLIER CALCULATION                              13360000
134000                                                                  13370000
134100     IF  PPS-OUTLIER-DAYS > 0                                     13380000
134200         COMPUTE H-CAPI-OUTDAY-PART =                             13390000
134300            H-DAYOUT-PCT * H-CAPI-FSP-PART / H-ARITH-ALOS         13400000
134400                                       * PPS-OUTLIER-DAYS         13410000
134500            ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.           13420000
134600                                                                  13430000
134700     IF  H-CAPI-OUTDAY-PART  > 0                                  13440000
134800         IF P-CAPI-PPS-PAY-CODE = 'A'                             13450000
134900             COMPUTE H-CAPI-OUTDAY-PART =                         13460000
135000                 H-CAPI-OUTDAY-PART * P-CAPI-NEW-HARM-RATIO       13470000
135100             ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.          13480000
135200                                                                  13490000
135300     IF  H-CAPI-OUTDAY-PART  > 0                                  13500000
135400         IF P-CAPI-PPS-PAY-CODE = 'C'                             13510000
135500             COMPUTE H-CAPI-OUTDAY-PART =                         13520000
135600                    (H-CAPI-OUTDAY-PART * H-CAPI-PAYCDE-PCT1)     13530000
135700             ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.          13540000
135800                                                                  13550000
135900***********************************************************       13560000
136000***  COST OUTLIER OPERATING AND CAPITAL CALCULATION               13570000
136100***  COST OUTLIER OPERATING AND CAPITAL CALCULATION               13580000
136200                                                                  13590000
136300     IF H-CAPI-CSTCHG-RATIO > 0 OR                                13600000
136400       H-OPER-CSTCHG-RATIO > 0                                    13610000
136500        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD =                     13620000
136600                H-OPER-CSTCHG-RATIO /                             13630000
136700               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)        13640000
136800        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD =                     13650000
136900                H-CAPI-CSTCHG-RATIO /                             13660000
137000               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)        13670000
137100     ELSE                                                         13680000
137200         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD                    13690000
137300                   H-CAPI-SHARE-DOLL-THRESHOLD.                   13700000
137400                                                                  13710000
137500     MOVE 09700.00 TO H-CST-THRESH.                               13720000
137600     MOVE 08850.00 TO H-PRE-CAPI-THRESH.                          13730000
137700                                                                  13740000
137800     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                    13750000
137900        ((H-CST-THRESH * H-LABOR-PCT  * H-WAGE-INDEX) +           13760000
138000         (H-CST-THRESH * H-NLABOR-PCT * H-OPER-COLA)) *           13770000
138100          H-OPER-SHARE-DOLL-THRESHOLD.                            13780000
138200                                                                  13790000
138300***********************************************************       13800000
138400***  DIFFERENT THRESHOLD   PRE-CAPITAL                            13810000
138500***  DIFFERENT THRESHOLD   PRE-CAPITAL                            13820000
138600                                                                  13830000
138700     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE          13840000
138800        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                 13850000
138900        (H-PRE-CAPI-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +        13860000
139000        (H-PRE-CAPI-THRESH * H-NLABOR-PCT * H-OPER-COLA).         13870000
139100***********************************************************       13880000
139200                                                                  13890000
139300     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =                    13900000
139400          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *         13910000
139500          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.              13920000
139600                                                                  13930000
139700     COMPUTE H-OPER-COST-OUTLIER ROUNDED =                        13940000
139800          H-OPER-FSP-PART + H-OPER-DOLLAR-THRESHOLD.              13950000
139900                                                                  13960000
140000     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =                        13970000
140100          H-CAPI-FSP-PART + H-CAPI-DOLLAR-THRESHOLD.              13980000
140200                                                                  13990000
140300     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE          14000000
140400         MOVE 0 TO H-CAPI-COST-OUTLIER.                           14010000
140500                                                                  14020000
140600     IF B-REVIEW-CODE = '03'  AND H-PERDIEM-DAYS < H-ALOS         14030000
140700        COMPUTE H-OPER-COST-OUTLIER ROUNDED =                     14040000
140800                (H-OPER-COST-OUTLIER * H-PERDIEM-DAYS / H-ALOS)   14050000
140900                ON SIZE ERROR MOVE 0 TO H-OPER-COST-OUTLIER.      14060000
141000                                                                  14070000
141100     IF B-REVIEW-CODE = '03'  AND H-PERDIEM-DAYS < H-ALOS         14080000
141200        COMPUTE H-CAPI-COST-OUTLIER ROUNDED =                     14090000
141300                (H-CAPI-COST-OUTLIER * H-PERDIEM-DAYS / H-ALOS)   14100000
141400                ON SIZE ERROR MOVE 0 TO H-CAPI-COST-OUTLIER.      14110000
141500                                                                  14120000
141600***********************************************************       14130000
141700***  CAPITAL DSH CALCULATION                                      14140000
141800***  CAPITAL DSH CALCULATION                                      14150000
141900                                                                  14160000
142000     MOVE 0 TO H-CAPI-DSH.                                        14170000
142100                                                                  14180000
142200     IF P-BED-SIZE NOT NUMERIC                                    14190000
142300         MOVE 0 TO P-BED-SIZE.                                    14200000
142400                                                                  14210000
142500     IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99                 14220000
142600         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **                   14230000
142700                  (.2025 * (P-SSI-RATIO                           14240000
142800                          + P-MEDICAID-RATIO)) - 1.               14250000
142900                                                                  14260000
143000***********************************************************       14270000
143100***  OPERATING COST CALCULATION                                   14280000
143200***  OPERATING COST CALCULATION                                   14290000
143300                                                                  14300000
143400     COMPUTE H-OPER-BILL-COSTS ROUNDED =                          14310000
143500         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO /                14320000
143600         (1 + H-OPER-IME-TEACH + H-OPER-DSH)                      14330000
143700         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.               14340000
143800                                                                  14350000
143900     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER                  14360000
144000         COMPUTE H-OPER-OUTCST-PART =                             14370000
144100         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -                      14380000
144200                         H-OPER-COST-OUTLIER).                    14390000
144300                                                                  14400000
144400     IF PAY-WITHOUT-COST                                          14410000
144500         MOVE 0 TO H-OPER-OUTCST-PART.                            14420000
144600                                                                  14430000
144700***********************************************************       14440000
144800***  CAPITAL IME TEACH CALCULATION                                14450000
144900***  CAPITAL IME TEACH CALCULATION                                14460000
145000                                                                  14470000
145100     MOVE 0 TO H-WK-CAPI-IME-TEACH.                               14480000
145200                                                                  14490000
145300     IF P-CAPI-IME NUMERIC                                        14500000
145400        COMPUTE H-WK-CAPI-IME-TEACH =                             14510000
145500          (2.7183 ** (.2822 * P-CAPI-IME)) - 1.                   14520000
145600                                                                  14530000
145700***********************************************************       14540000
145800***  CAPITAL COST CALCULATION                                     14550000
145900***  CAPITAL COST CALCULATION                                     14560000
146000                                                                  14570000
146100     COMPUTE H-CAPI-BILL-COSTS ROUNDED =                          14580000
146200             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO /            14590000
146300            (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH)                14600000
146400         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.               14610000
146500                                                                  14620000
146600     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER                  14630000
146700         COMPUTE H-CAPI-OUTCST-PART =                             14640000
146800         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -                      14650000
146900                         H-CAPI-COST-OUTLIER).                    14660000
147000                                                                  14670000
147100     IF P-CAPI-PPS-PAY-CODE = 'A'                                 14680000
147200       COMPUTE H-CAPI-OUTCST-PART =                               14690000
147300              (H-CAPI-OUTCST-PART * P-CAPI-NEW-HARM-RATIO).       14700000
147400                                                                  14710000
147500     IF P-CAPI-PPS-PAY-CODE = 'C'                                 14720000
147600        COMPUTE H-CAPI-OUTCST-PART =                              14730000
147700               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).         14740000
147800                                                                  14750000
147900     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <               14760000
148000        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)               14770000
148100        MOVE 0 TO H-CAPI-OUTCST-PART                              14780000
148200                  H-OPER-OUTCST-PART.                             14790000
148300                                                                  14800000
148400     IF PAY-WITHOUT-COST                                          14810000
148500         MOVE 0 TO H-CAPI-OUTCST-PART.                            14820000
148600                                                                  14830000
148700***********************************************************       14840000
148800***  DETERMINES THE BILL TO BE EITHER COST OR DAY OUTLIER         14850000
148900***     GREATER OF DAY OR COST OPERATING AND CAPITAL              14860000
149000                                                                  14870000
149100     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE          14880000
149200         MOVE 0 TO H-CAPI-OUTDAY-PART                             14890000
149300                   H-CAPI-OUTCST-PART.                            14900000
149400                                                                  14910000
149500      IF (H-OPER-OUTDAY-PART + H-CAPI-OUTDAY-PART) > 0 OR         14920000
149600         (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0            14930000
149700         IF (H-OPER-OUTDAY-PART + H-CAPI-OUTDAY-PART) >           14940000
149800            (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART)             14950000
149900                 MOVE H-OPER-OUTDAY-PART TO                       14960000
150000                      H-OPER-OUTLIER-PART                         14970000
150100                 MOVE H-CAPI-OUTDAY-PART TO                       14980000
150200                      H-CAPI-OUTLIER-PART                         14990000
150300                 MOVE 01 TO PPS-RTC                               15000000
150400             ELSE                                                 15010000
150500                 MOVE H-OPER-OUTCST-PART TO                       15020000
150600                      H-OPER-OUTLIER-PART                         15030000
150700                 MOVE H-CAPI-OUTCST-PART TO                       15040000
150800                      H-CAPI-OUTLIER-PART                         15050000
150900                 MOVE 02 TO PPS-RTC                               15060000
151000                 IF B-COVERED-DAYS > H-DAYS-CUTOFF                15070000
151100                    IF (H-REG-DAYS                                15080000
151200                            +                                     15090000
151300                        H-LTR-DAYS)   <                           15100000
151400                       (B-COVERED-DAYS - H-DAYS-CUTOFF)           15110000
151500                       MOVE 66 TO PPS-RTC.                        15120000
151600                                                                  15130000
151700***********************************************************       15140000
151800***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF          15150000
151900***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE          15160000
152000                                                                  15170000
152100     IF P-CAPI-PPS-PAY-CODE = 'A'                                 15180000
152200        COMPUTE H-CAPI2-B-OUTLIER-PART =                          15190000
152300                H-CAPI-OUTLIER-PART / P-CAPI-NEW-HARM-RATIO       15200000
152400         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.          15210000
152500                                                                  15220000
152600     IF P-CAPI-PPS-PAY-CODE = 'B'                                 15230000
152700        COMPUTE H-CAPI2-B-OUTLIER-PART =                          15240000
152800                H-CAPI-OUTLIER-PART.                              15250000
152900                                                                  15260000
153000     IF P-CAPI-PPS-PAY-CODE = 'C'                                 15270000
153100        COMPUTE H-CAPI2-B-OUTLIER-PART =                          15280000
153200                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1          15290000
153300         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.          15300000
153400***********************************************************       15310000
153500                                                                  15320000
153600 3800-CALC-TOT-AMT.                                               15330000
153700                                                                  15340000
153800***********************************************************       15350000
153900***  CALCULATE FINAL TOTALS FOR OPERATING                         15360000
154000***  CALCULATE FINAL TOTALS FOR OPERATING                         15370000
154100                                                                  15380000
154200     COMPUTE PPS-OPER-HSP-PART ROUNDED =                          15390000
154300         H-OPER-HSP-PCT * H-OPER-HSP-PART.                        15400000
154400                                                                  15410000
154500     COMPUTE PPS-OPER-FSP-PART ROUNDED =                          15420000
154600         H-OPER-FSP-PCT * H-OPER-FSP-PART.                        15430000
154700                                                                  15440000
154800     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =                      15450000
154900             H-OPER-FSP-PCT * H-OPER-OUTLIER-PART.                15460000
155000                                                                  15470000
155100     MOVE ZERO TO PPS-OPER-DSH-ADJ.                               15480000
155200                                                                  15490000
155300     IF  H-OPER-DSH NUMERIC                                       15500000
155400             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =                   15510000
155500             (PPS-OPER-FSP-PART + PPS-OPER-OUTLIER-PART)          15520000
155600              * H-OPER-DSH.                                       15530000
155700                                                                  15540000
155800     COMPUTE PPS-OPER-IME-ADJ ROUNDED =                           15550000
155900         (PPS-OPER-FSP-PART + PPS-OPER-OUTLIER-PART) *            15560000
156000                 H-OPER-IME-TEACH.                                15570000
156100                                                                  15580000
156200***********************************************************       15590000
156300***  CALCULATE FINAL TOTALS FOR CAPITAL                           15600000
156400***  CALCULATE FINAL TOTALS FOR CAPITAL                           15610000
156500                                                                  15620000
156600     MOVE P-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.               15630000
156700                                                                  15640000
156800     IF P-CAPI-PPS-PAY-CODE = 'A'                                 15650000
156900        MOVE P-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT              15660000
157000        MOVE 0.00 TO H-CAPI-HSP-PCT.                              15670000
157100                                                                  15680000
157200     IF P-CAPI-PPS-PAY-CODE = 'B'                                 15690000
157300        MOVE 0    TO H-CAPI-OLD-HARMLESS                          15700000
157400        MOVE 1.00 TO H-CAPI-FSP-PCT                               15710000
157500        MOVE 0.00 TO H-CAPI-HSP-PCT.                              15720000
157600                                                                  15730000
157700     IF P-CAPI-PPS-PAY-CODE = 'C'                                 15740000
157800        MOVE 0    TO H-CAPI-OLD-HARMLESS                          15750000
157900        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT                 15760000
158000        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.                15770000
158100                                                                  15780000
158200     COMPUTE H-CAPI-HSP ROUNDED =                                 15790000
158300         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.                        15800000
158400                                                                  15810000
158500     COMPUTE H-CAPI-FSP ROUNDED =                                 15820000
158600         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.                        15830000
158700                                                                  15840000
158800     MOVE P-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.                 15850000
158900                                                                  15860000
159000     COMPUTE H-CAPI-OUTLIER ROUNDED =                             15870000
159100             1.00 * H-CAPI-OUTLIER-PART.                          15880000
159200                                                                  15890000
159300     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =                          15900000
159400             1.00 * H-CAPI2-B-OUTLIER-PART.                       15910000
159500                                                                  15920000
159600     COMPUTE H-CAPI2-B-FSP ROUNDED =                              15930000
159700             1.00 * H-CAPI2-B-FSP-PART.                           15940000
159800                                                                  15950000
159900     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.                 15960000
160000                                                                  15970000
160100     COMPUTE H-CAPI-DSH-ADJ ROUNDED =                             15980000
160200             (H-CAPI-FSP + H-CAPI-OUTLIER-PART)                   15990000
160300              * H-CAPI-DSH.                                       16000000
160400                                                                  16010000
160500     COMPUTE H-CAPI-IME-ADJ ROUNDED =                             16020000
160600         (H-CAPI-FSP + H-CAPI-OUTLIER-PART) *                     16030000
160700                 H-WK-CAPI-IME-TEACH.                             16040000
160800                                                                  16050000
160900***********************************************************       16060000
161000***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER               16070000
161100***        THIS ZEROES OUT ALL CAPITAL DATA                       16080000
161200                                                                  16090000
161300     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE          16100000
161400        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.                   16110000
161500                                                                  16120000
161600     COMPUTE H-CAPI-TOTAL-PAY =                                   16130000
161700             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +        16140000
161800             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +                    16150000
161900             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.                    16160000
162000                                                                  16170000
162100***********************************************************       16180000
162200***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING             16190000
162300***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING             16200000
162400                                                                  16210000
162500     COMPUTE PPS-TOTAL-PAYMENT =                                  16220000
162600             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +              16230000
162700             PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +           16240000
162800             PPS-OPER-IME-ADJ                                     16250000
162900                           +                                      16260000
163000                  H-CAPI-TOTAL-PAY.                               16270000
163100                                                                  16280000
163200 3900-CALC-OPER-DSH.                                              16290000
163300***********************************************************       16300000
163400***  OPERATING DSH CALCULATION                                    16310000
163500***  OPERATING DSH CALCULATION                                    16320000
163600                                                                  16330000
163700      MOVE .00 TO H-OPER-DSH.                                     16340000
163800                                                                  16350000
163900      COMPUTE H-WK-OPER-DSH = (P-SSI-RATIO                        16360000
164000                                     + P-MEDICAID-RATIO).         16370000
164100                                                                  16380000
164200      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE < 100               16390000
164300                               AND H-WK-OPER-DSH > .3999          16400000
164400        MOVE .05 TO H-OPER-DSH.                                   16410000
164500                                                                  16420000
164600      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99                16430000
164700                               AND H-WK-OPER-DSH > .1499          16440000
164800                               AND H-WK-OPER-DSH < .2021          16450000
164900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        16460000
165000                                      * .65 + .025.               16470000
165100                                                                  16480000
165200      IF W-SIZE = 'R'          AND P-BED-SIZE > 499               16490000
165300                               AND H-WK-OPER-DSH > .1499          16500000
165400                               AND H-WK-OPER-DSH < .2021          16510000
165500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        16520000
165600                                 * .65 + .025.                    16530000
165700                                                                  16540000
165800      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99                16550000
165900                               AND H-WK-OPER-DSH > .202           16560000
166000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       16570000
166100                                 * .825 + .0588.                  16580000
166200                                                                  16590000
166300      IF W-SIZE = 'R'          AND P-BED-SIZE > 499               16600000
166400                               AND H-WK-OPER-DSH > .202           16610000
166500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       16620000
166600                                 * .825 + .0588.                  16630000
166700                                                                  16640000
166800      IF W-SIZE = 'R'          AND P-BED-SIZE < 101               16650000
166900                               AND H-WK-OPER-DSH > .4499          16660000
167000        MOVE .04 TO H-OPER-DSH.                                   16670000
167100                                                                  16680000
167200      IF W-SIZE = 'R'          AND P-BED-SIZE > 100               16690000
167300                               AND P-BED-SIZE < 500               16700000
167400                               AND H-WK-OPER-DSH > .2999          16710000
167500        MOVE .04 TO H-OPER-DSH.                                   16720000
167600                                                                  16730000
167700      IF W-SIZE = 'R'                                             16740000
167800         IF (P-PROVIDER-TYPE = '16' OR '21')                      16750000
167900                               AND H-WK-OPER-DSH > .2999          16760000
168000                               AND P-BED-SIZE < 500               16770000
168100            MOVE .10 TO H-OPER-DSH.                               16780000
168200                                                                  16790000
168300      IF W-SIZE = 'R'                                             16800000
168400         IF (P-PROVIDER-TYPE = '07')                              16810000
168500                               AND H-WK-OPER-DSH > .2999          16820000
168600                               AND P-BED-SIZE > 100               16830000
168700                               AND P-BED-SIZE < 500               16840000
168800            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)     16850000
168900                                 * .6 + .04.                      16860000
169000                                                                  16870000
169100      IF W-SIZE = 'R'                                             16880000
169200         IF (P-PROVIDER-TYPE = '17' OR '22')                      16890000
169300                               AND H-WK-OPER-DSH > .2999          16900000
169400                               AND P-BED-SIZE < 500               16910000
169500            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)     16920000
169600                                 * .6 + .04.                      16930000
169700                                                                  16940000
169800      IF W-SIZE = 'R'                                             16950000
169900         IF (P-PROVIDER-TYPE = '17' OR '22')                      16960000
170000                               AND H-WK-OPER-DSH > .2999          16970000
170100                               AND P-BED-SIZE < 500               16980000
170200                               AND H-OPER-DSH < .10               16990000
170300            MOVE .10 TO H-OPER-DSH.                               17000000
170400                                                                  17010000
170500******        L A S T   S O U R C E   S T A T E M E N T   *****   17020000
