000100 IDENTIFICATION DIVISION.                                         00010001
000200 PROGRAM-ID.           PPCAL944.                                  00020007
000300*AUTHOR.            DDS TEAM.                                     00030001
000400*REMARKS.                HCFA.                                    00040001
000500 DATE-COMPILED.                                                   00050001
000600 ENVIRONMENT DIVISION.                                            00060001
000700 CONFIGURATION SECTION.                                           00070001
000800 SOURCE-COMPUTER.            IBM-370.                             00080001
000900 OBJECT-COMPUTER.            IBM-370.                             00090001
001000 INPUT-OUTPUT  SECTION.                                           00100001
001100 FILE-CONTROL.                                                    00110001
001200                                                                  00120001
001300 DATA DIVISION.                                                   00130001
001400 FILE SECTION.                                                    00140001
001500                                                                  00150001
001600 WORKING-STORAGE SECTION.                                         00160001
001700 01  W-STORAGE-REF                  PIC X(46)  VALUE              00170001
001800     'PPCAL944 - WORKING   STORAGE'.                              00180007
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C94.4'.     00190007
002000 01  R1                             PIC S9(04) COMP SYNC.         00200001
002100 01  R2                             PIC S9(04) COMP SYNC.         00210001
002200 01  R3                             PIC S9(04) COMP SYNC.         00220001
002300 01  R4                             PIC S9(04) COMP SYNC.         00230001
002400 01  U1                             PIC S9(04) COMP SYNC.         00240001
002500 01  U2                             PIC S9(04) COMP SYNC.         00250001
002600 01  U3                             PIC S9(04) COMP SYNC.         00260001
002700 01  BLEND-RURAL-PCT                PIC V9(09) COMP SYNC.         00270001
002800 01  MO-DIFF                        PIC  9(03).                   00280001
002900 01  N-FACTOR                       PIC  9(02).                   00290001
003000                                                                  00300001
003100***************************************************************   00310001
003200*    LAYUP TABLE AREA                                         *   00320001
003300***************************************************************   00330001
003400 01  RATE-TABLE.                                                  00340001
003500     02  RATE-WORK.                                               00350001
003600*RATE 931001 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR       00360001
003700         05  FILLER PIC X(06) VALUE '931001'.                     00370001
003800         05  NE01   PIC X(45) VALUE                               00380001
003900            ' 0277892 113839 0273493 112037 0299146 103169'.      00390001
004000         05  MA02   PIC X(45) VALUE                               00400001
004100            ' 0249661 107850 0245709 106143 0286492  97530'.      00410001
004200         05  SA03   PIC X(45) VALUE                               00420001
004300            ' 0266505 099533 0262286 097958 0273874 084571'.      00430001
004400         05  ENS04  PIC X(45) VALUE                               00440001
004500            ' 0281097 117765 0276647 115900 0277333 093995'.      00450001
004600         05  ESC05  PIC X(45) VALUE                               00460001
004700            ' 0255771 090126 0251722 088699 0271437 078864'.      00470001
004800         05  WNC06  PIC X(45) VALUE                               00480001
004900            ' 0266581 107303 0262360 105605 0263817 084255'.      00490001
005000         05  WSC07  PIC X(45) VALUE                               00500001
005100            ' 0265047 098859 0260851 097295 0253011 077485'.      00510001
005200         05  MNT08  PIC X(45) VALUE                               00520001
005300            ' 0255676 105892 0251628 104216 0255862 089118'.      00530001
005400         05  PAC09  PIC X(45) VALUE                               00540001
005500            ' 0248702 120959 0244765 119044 0248847 100396'.      00550001
005600         05  NTL10  PIC X(45) VALUE                               00560001
005700            ' 0264619 109021 0260430 107295 0269819 086931'.      00570001
005800         05  PR11   PIC X(45) VALUE                               00580001
005900            ' 0237997 049498 0234229 048714 0183916 039647'.      00590001
006000         05  NPR12  PIC X(45) VALUE                               00600001
006100            ' 0264411 102804 0264411 102804 0264411 102804'.      00610001
006200     02  RATE-TAB REDEFINES RATE-WORK.                            00620001
006300         05  RATE-PERIOD            OCCURS 1.                     00630001
006400             10  RATE-EFF-DATE      PIC X(06).                    00640001
006500             10  REG-NAT            OCCURS 12.                    00650001
006600                 15  R-URBAN-RURAL  OCCURS 3.                     00660001
006700                     20  FILLER     PIC X(01).                    00670001
006800                     20  REG-LABOR  PIC 9(05)V9(02).              00680001
006900                     20  FILLER     PIC X(01).                    00690001
007000                     20  REG-NLABOR PIC 9(04)V9(02).              00700001
007100                                                                  00710001
007200                                                                  00720001
007300 01  DRG-TABLE.                                                   00730001
007400     05  D-TAB.                                                   00740001
007500      10  FILLER                  PIC X(06) VALUE                 00750001
007600     '931001'.                                                    00760001
007700      10  FILLER                  PIC X(56) VALUE                 00770001
007800     '03155610534147031381104331460301761273612702384708131120'.  00780001
007900      10  FILLER                  PIC X(56) VALUE                 00790001
008000     '01536104828061006271021250340251801073418800857602926046'.  00800001
008100      10  FILLER                  PIC X(56) VALUE                 00810001
008200     '01339706730105012819071301050076910422705900944906630094'.  00820001
008300      10  FILLER                  PIC X(56) VALUE                 00830001
008400     '00810806229078012056067300930067660402705101114106529088'.  00840001
008500      10  FILLER                  PIC X(56) VALUE                 00850001
008600     '00664804327056009202056290740059270382705102061308431121'.  00860001
008700      10  FILLER                  PIC X(56) VALUE                 00870001
008800     '01430406830091007286041270510084070412706000975905128070'.  00880001
008900      10  FILLER                  PIC X(56) VALUE                 00890001
009000     '00542603326043009878036270590133110402707501207805829089'.  00900001
009100      10  FILLER                  PIC X(56) VALUE                 00910001
009200     '00594103326048003660020170200073350422706000449402522034'.  00920001
009300      10  FILLER                  PIC X(56) VALUE                 00930001
009400     '00254001609016011103056290790056560362704900608701709021'.  00940001
009500      10  FILLER                  PIC X(56) VALUE                 00950001
009600     '00784302626039003716021150260047230150801900558602125032'.  00960001
009700      10  FILLER                  PIC X(56) VALUE                 00970001
009800     '00378201607016005777018130240038140342404300594905228063'.  00980001
009900      10  FILLER                  PIC X(56) VALUE                 00990001
010000     '00604703426043007288043270610040470282603800415502926029'.  01000001
010100      10  FILLER                  PIC X(56) VALUE                 01010001
010200     '01793705328076006732020120240065150201802800769702219030'.  01020001
010300      10  FILLER                  PIC X(56) VALUE                 01030001
010400     '00764502025032007124032220320057610171702600641201919028'.  01040001
010500      10  FILLER                  PIC X(56) VALUE                 01050001
010600     '00911603326052003203015040150041580160901900270401504015'.  01060001
010700      10  FILLER                  PIC X(56) VALUE                 01070001
010800     '01030702826053003194013050130105200362705401157105328089'.  01080001
010900      10  FILLER                  PIC X(56) VALUE                 01090001
011000     '00495203123039004909032250410084810392704800715804728057'.  01100001
011100      10  FILLER                  PIC X(56) VALUE                 01110001
011200     '00512603623044003978025250340068380382704700607903426049'.  01120001
011300      10  FILLER                  PIC X(56) VALUE                 01130001
011400     '00759104227057003545021200210303971063413002477010433144'.  01140001
011500      10  FILLER                  PIC X(56) VALUE                 01150001
011600     '01044304127064014292082310970173320873211300927806129075'.  01160001
011700      10  FILLER                  PIC X(56) VALUE                 01170001
011800     '01140806129061013105066300930094030572907500498603326043'.  01180001
011900      10  FILLER                  PIC X(56) VALUE                 01190001
012000     '01189106630087006691039270510134950562907801006705829071'.  01200001
012100      10  FILLER                  PIC X(56) VALUE                 01210001
012200     '01144706830084006990051270590077670382705201203906630084'.  01220001
012300      10  FILLER                  PIC X(56) VALUE                 01230001
012400     '00755004628059012433067300880060670412705100877605529066'.  01240001
012500      10  FILLER                  PIC X(56) VALUE                 01250001
012600     '00606704224049006840035270470071490342604500500402416029'.  01260001
012700      10  FILLER                  PIC X(56) VALUE                 01270001
012800     '00903504828065005282031260401402152594936607655916540194'.  01280001
012900      10  FILLER                  PIC X(56) VALUE                 01290001
013000     '05799011635137056791129361450420050983310905869011835151'.  01300001
013100      10  FILLER                  PIC X(56) VALUE                 01310001
013200     '00000000000000040494095331270232140693008001973604227057'.  01320001
013300      10  FILLER                  PIC X(56) VALUE                 01330001
013400     '02793113536183015631083311160358861093413302424805028068'.  01340001
013500      10  FILLER                  PIC X(56) VALUE                 01350001
013600     '01132803326048015419024250370098340352606001962606630114'.  01360001
013700      10  FILLER                  PIC X(56) VALUE                 01370001
013800     '01601707430091011325052280640141160292605201230704227056'.  01380001
013900      10  FILLER                  PIC X(56) VALUE                 01390001
014000     '00796002323031027299146381940102340572907400782507030080'.  01400001
014100      10  FILLER                  PIC X(56) VALUE                 01410001
014200     '01195902225041009042060290770058310462805800759403827052'.  01420001
014300      10  FILLER                  PIC X(56) VALUE                 01430001
014400     '00525702822036005614036270460086090452806200548903024039'.  01440001
014500      10  FILLER                  PIC X(56) VALUE                 01450001
014600     '00653003326033008038042270550049460282003500624103424042'.  01460001
014700      10  FILLER                  PIC X(56) VALUE                 01470001
014800     '00705304127053005150030210380051890261703201065904728067'.  01480001
014900      10  FILLER                  PIC X(56) VALUE                 01490001
015000     '00612203026039024955113341270153280803008903171912736152'.  01500001
015100      10  FILLER                  PIC X(56) VALUE                 01510001
015200     '01512708027087025505109341330117380572907101795508632102'.  01520001
015300      10  FILLER                  PIC X(56) VALUE                 01530001
015400     '01082106325069041338139371760138110653007900866806029060'.  01540001
015500      10  FILLER                  PIC X(56) VALUE                 01550001
015600     '01004804528063005100023170290109010452806000637802618033'.  01560001
015700      10  FILLER                  PIC X(56) VALUE                 01570001
015800     '00826003226046004823017110220067950322503902167909232106'.  01580001
015900      10  FILLER                  PIC X(56) VALUE                 01590001
016000     '01205505924066013413055280670078010341603901032103527055'.  01600001
016100      10  FILLER                  PIC X(56) VALUE                 01610001
016200     '00582402016026027524105341530108940462806201306306830101'.  01620001
016300      10  FILLER                  PIC X(56) VALUE                 01630001
016400     '00631803426050009657052280650053540352004101045305629073'.  01640001
016500      10  FILLER                  PIC X(56) VALUE                 01650001
016600     '00798604828059005804035200420110720683008800918005528071'.  01660001
016700      10  FILLER                  PIC X(56) VALUE                 01670001
016800     '00496903624044007617046280590052910322304000473502826038'.  01680001
016900      10  FILLER                  PIC X(56) VALUE                 01690001
017000     '00824804227058004251029230290058520262603701005005128071'.  01700001
017100      10  FILLER                  PIC X(56) VALUE                 01710001
017200     '00477502726037007577042270560433191433718801646007430093'.  01720001
017300      10  FILLER                  PIC X(56) VALUE                 01730001
017400     '03094013236157015991077310930240661023311901507306930081'.  01740001
017500      10  FILLER                  PIC X(56) VALUE                 01750001
017600     '02008208231100010432045270540235571033313702805408732134'.  01760001
017700      10  FILLER                  PIC X(56) VALUE                 01770001
017800     '03152612235175013176067300920121800653009401130205929077'.  01780001
017900      10  FILLER                  PIC X(56) VALUE                 01790001
018000     '01247006429090006181036270520098960512806700552102924037'.  01800001
018100      10  FILLER                  PIC X(56) VALUE                 01810001
018200     '02349108631096018702100331170130310763108601448604327060'.  01820001
018300      10  FILLER                  PIC X(56) VALUE                 01830001
018400     '01748508932123018857073300910109260442605302057009633138'.  01840001
018500      10  FILLER                  PIC X(56) VALUE                 01850001
018600     '03056313136204014195063290820090150392504800955605328053'.  01860001
018700      10  FILLER                  PIC X(56) VALUE                 01870001
018800     '01799207130101009846036270500081260282003500669802314028'.  01880001
018900      10  FILLER                  PIC X(56) VALUE                 01890001
019000     '00856803326051013096054280800068660262203400822502425036'.  01900001
019100      10  FILLER                  PIC X(56) VALUE                 01910001
019200     '00567901814024009353038270580111590372705901108203126055'.  01920001
019300      10  FILLER                  PIC X(56) VALUE                 01930001
019400     '01845407931111009321037270520097300642910200792205929081'.  01940001
019500      10  FILLER                  PIC X(56) VALUE                 01950001
019600     '00553604027053015082097331300103880723009501148806530088'.  01960001
019700      10  FILLER                  PIC X(56) VALUE                 01970001
019800     '00568204127053011356075301000070110502806600743705228070'.  01980001
019900      10  FILLER                  PIC X(56) VALUE                 01990001
020000     '00479803627048005962042270540055470352604700693904527060'.  02000001
020100      10  FILLER                  PIC X(56) VALUE                 02010001
020200     '00663803727055007174044270630044490272603700361501815018'.  02020001
020300      10  FILLER                  PIC X(56) VALUE                 02030001
020400     '00770605428076004272033260450047960292602900636603627049'.  02040001
020500      10  FILLER                  PIC X(56) VALUE                 02050001
020600     '00884503821046006959030130340083720312604700574302011025'.  02060001
020700      10  FILLER                  PIC X(56) VALUE                 02070001
020800     '00727202114026006071023250350244601353719001234607831107'.  02080001
020900      10  FILLER                  PIC X(56) VALUE                 02090001
021000     '01406505829090007108029260430065920262604300819802726043'.  02100001
021100      10  FILLER                  PIC X(56) VALUE                 02110001
021200     '01716607831116006456027260390117830813110801020606830088'.  02120001
021300      10  FILLER                  PIC X(56) VALUE                 02130001
021400     '00651404828064011183063290960050500272603900635104427058'.  02140001
021500      10  FILLER                  PIC X(56) VALUE                 02150001
021600     '00891706630080005828050280590076180422404200675504427061'.  02160001
021700      10  FILLER                  PIC X(56) VALUE                 02170001
021800     '00419503026040003540022190220072530502806600446903426045'.  02180001
021900      10  FILLER                  PIC X(56) VALUE                 02190001
022000     '02563713336182022821082311010219271243518102072506930105'.  02200001
022100      10  FILLER                  PIC X(56) VALUE                 02210001
022200     '00992003426049007637025160310050740170902002765811134161'.  02220001
022300      10  FILLER                  PIC X(56) VALUE                 02230001
022400     '01101004728071007466054280690075620422705600931305629078'.  02240001
022500      10  FILLER                  PIC X(56) VALUE                 02250001
022600     '00524403827048005627032260460082710442706401098206630087'.  02260001
022700      10  FILLER                  PIC X(56) VALUE                 02270001
022800     '00577703827051038871129361490259291033312402389709432127'.  02280001
022900      10  FILLER                  PIC X(56) VALUE                 02290001
023000     '01112704728059012474061290820066200331804001445205829085'.  02300001
023100      10  FILLER                  PIC X(56) VALUE                 02310001
023200     '00758002826037009006037270520052060201302500833403627054'.  02320001
023300      10  FILLER                  PIC X(56) VALUE                 02330001
023400     '00455102015026004470023250230203410652911601290306229089'.  02340001
023500      10  FILLER                  PIC X(56) VALUE                 02350001
023600     '00519402826040011215058290860052980252503400967706329079'.  02360001
023700      10  FILLER                  PIC X(56) VALUE                 02370001
023800     '00611204626054004952039210450072900302604100386402012024'.  02380001
023900      10  FILLER                  PIC X(56) VALUE                 02390001
024000     '00660704127056004024027210340071690312603100659703627050'.  02400001
024100      10  FILLER                  PIC X(56) VALUE                 02410001
024200     '00388101914024002882016090160098290522807200543002926041'.  02420001
024300      10  FILLER                  PIC X(56) VALUE                 02430001
024400     '00964105028072017535074250810136300622006600854004323052'.  02440001
024500      10  FILLER                  PIC X(56) VALUE                 02450001
024600     '00605003211036009395038270580080930312604600448302413024'.  02460001
024700      10  FILLER                  PIC X(56) VALUE                 02470001
024800     '00964603125040005848026260380039160170601701018303126043'.  02480001
024900      10  FILLER                  PIC X(56) VALUE                 02490001
025000     '00734403226046009338053280780049280252603800685603927055'.  02500001
025100      10  FILLER                  PIC X(56) VALUE                 02510001
025200     '00390402322033006668046270550034470130501300532603126044'.  02520001
025300      10  FILLER                  PIC X(56) VALUE                 02530001
025400     '01962408832107013794065290760087170441304700709603515040'.  02540001
025500      10  FILLER                  PIC X(56) VALUE                 02550001
025600     '02315309432115011042052210590078340391104100812603825047'.  02560001
025700      10  FILLER                  PIC X(56) VALUE                 02570001
025800     '01003703226050005151014050140063400292303900593002626038'.  02580001
025900      10  FILLER                  PIC X(56) VALUE                 02590001
026000     '01703406630096011948061290940047690262603600948905829075'.  02600001
026100      10  FILLER                  PIC X(56) VALUE                 02610001
026200     '00520103026044008699049240590062890381004000517403126043'.  02620001
026300      10  FILLER                  PIC X(56) VALUE                 02630001
026400     '00324702008022005859026150320070490442704400389402624035'.  02640001
026500      10  FILLER                  PIC X(56) VALUE                 02650001
026600     '00860003026044007580031160360033460242503400295801610021'.  02660001
026700      10  FILLER                  PIC X(56) VALUE                 02670001
026800     '00394301609020001240012040130040590312604300262002119028'.  02680001
026900      10  FILLER                  PIC X(56) VALUE                 02690001
027000     '01264801825018037722179411790188891333613301196508632086'.  02700001
027100      10  FILLER                  PIC X(56) VALUE                 02710001
027200     '01529505328107009165044270700022940311103103304310634143'.  02720001
027300      10  FILLER                  PIC X(56) VALUE                 02730001
027400     '01572309132091016781053280990080570452706200307901813023'.  02740001
027500      10  FILLER                  PIC X(56) VALUE                 02750001
027600     '01229205328073012431061290780068220402705102530908131124'.  02760001
027700      10  FILLER                  PIC X(56) VALUE                 02770001
027800     '02377810033146008850033260510167570783111300737703827054'.  02780001
027900      10  FILLER                  PIC X(56) VALUE                 02790001
028000     '01076104928049026133099331350112040452805901424104928084'.  02800001
028100      10  FILLER                  PIC X(56) VALUE                 02810001
028200     '00992205829085006679029200360041520222002900475802125032'.  02820001
028300      10  FILLER                  PIC X(56) VALUE                 02830001
028400     '01384907230106007091041270600357231423719801514107230100'.  02840001
028500      10  FILLER                  PIC X(56) VALUE                 02850001
028600     '00700204927057009665062290790095110552807000636504227051'.  02860001
028700      10  FILLER                  PIC X(56) VALUE                 02870001
028800     '00675804227053005888035270450162460773110702468413937232'.  02880001
028900      10  FILLER                  PIC X(56) VALUE                 02890001
029000     '00712704327060006128050280720061840492807300708405729092'.  02900001
029100      10  FILLER                  PIC X(56) VALUE                 02910001
029200     '00937907430110009153084311200069800582908700735704527074'.  02920001
029300      10  FILLER                  PIC X(56) VALUE                 02930001
029400     '00351202826042007321051280690045290422705800969115138179'.  02940001
029500      10  FILLER                  PIC X(56) VALUE                 02950001
029600     '00997012836152000000000000000138530612909901712507631119'.  02960001
029700      10  FILLER                  PIC X(56) VALUE                 02970001
029800     '00712202225036019292058290930073980242503400743104928065'.  02980001
029900      10  FILLER                  PIC X(56) VALUE                 02990001
030000     '00463503226041004959024220240048690252203300358802917029'.  03000001
030100      10  FILLER                  PIC X(56) VALUE                 03010001
030200     '00792903827054004224022190290102660422706000823204027058'.  03020001
030300      10  FILLER                  PIC X(56) VALUE                 03030001
030400     '00417702623035009107043270660041660232303202168805128104'.  03040001
030500      10  FILLER                  PIC X(56) VALUE                 03050001
030600     '01631202626053037459152382180210421073415401050806029087'.  03060001
030700      10  FILLER                  PIC X(56) VALUE                 03070001
030800     '00865602425050017205135361700072490472806400459102925038'.  03080001
030900      10  FILLER                  PIC X(56) VALUE                 03090001
031000     '00374001920029005516024250460041680252605103484212936185'.  03100001
031100      10  FILLER                  PIC X(56) VALUE                 03110001
031200     '00000000000000000000000000000386511063412411693317841310'.  03120001
031300      10  FILLER                  PIC X(56) VALUE                 03130001
031400     '03570209633169000000000000000371750983314202236113436167'.  03140001
031500      10  FILLER                  PIC X(56) VALUE                 03150001
031600     '01462806029099021897066301000130270402705319467927651372'.  03160001
031700      10  FILLER                  PIC X(56) VALUE                 03170001
031800     '14370936259397035756133361761698584396756705661213336206'.  03180001
031900      10  FILLER                  PIC X(56) VALUE                 03190001
032000     '03236112535158046756102331670193790733011104385915839221'.  03200001
032100      10  FILLER                  PIC X(56) VALUE                 03210001
032200     '01846808832134011174053280840160920502806003586110934172'.  03220001
032300      10  FILLER                  PIC X(56) VALUE                 03230001
032400     '01526804327062008233017130230000000000000000000000000000'.  03240001
032500     05  DRGX-TAB REDEFINES D-TAB.                                03250001
032600         10  DRGX-PERIOD               OCCURS 1                   03260001
032700                                        INDEXED BY DX5.           03270001
032800             15  DRGX-EFF-DATE         PIC X(06).                 03280001
032900             15  DRG-DATA              OCCURS 496                 03290001
033000                                        INDEXED BY DX6.           03300001
033100                 20  DRG-WT            PIC 9(02)V9(04).           03310001
033200                 20  DRG-ALOS          PIC 9(02)V9(01).           03320001
033300                 20  DRG-DAYS-TRIM     PIC 9(02).                 03330001
033400                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).           03340001
033500                                                                  03350001
033600 01  HOLD-AREA.                                                   03360001
033700     02  HOLD-DATES.                                              03370001
033800         05  HOLD-BILL-DATE.                                      03380001
033900             10  H-BILL-YY                PIC 9(02).              03390001
034000             10  H-BILL-MM                PIC 9(02).              03400001
034100             10  H-BILL-DD                PIC 9(02).              03410001
034200                                                                  03420001
034300         05  HOLD-FY-BEGIN-DATE.                                  03430001
034400             10  H-FY-BEGIN-YY            PIC 9(02).              03440001
034500             10  H-FY-BEGIN-MM            PIC 9(02).              03450001
034600             10  H-FY-BEGIN-DD            PIC 9(02).              03460001
034700                                                                  03470001
034800         05  HOLD-ADD-FY-BEGN-DATE.                               03480001
034900             10  H-ADD-FY-BEGN-YY            PIC 9(02).           03490001
035000             10  H-ADD-FY-BEGN-MM            PIC 9(02).           03500001
035100             10  H-ADD-FY-BEGN-DD            PIC 9(02).           03510001
035200                                                                  03520001
035300     02  HOLD-PPS-COMPONENTS.                                     03530001
035400         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).        03540001
035500         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).        03550001
035600                                                                  03560001
035700         05  H-OPER-HSP-PART              PIC 9(06)V9(09).        03570001
035800         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).        03580001
035900                                                                  03590001
036000         05  H-OPER-FSP-PART              PIC 9(06)V9(09).        03600001
036100         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).        03610001
036200         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).        03620001
036300                                                                  03630001
036400         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).        03640001
036500         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).        03650001
036600         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).        03660001
036700                                                                  03670001
036800         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).        03680001
036900         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).        03690001
037000                                                                  03700001
037100         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).        03710001
037200         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).        03720001
037300                                                                  03730001
037400         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).        03740001
037500         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).        03750001
037600                                                                  03760001
037700         05  H-OPER-DSH                   PIC 9(01)V9(04).        03770001
037800         05  H-CAPI-DSH                   PIC 9(01)V9(04).        03780001
037900                                                                  03790001
038000         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).        03800001
038100         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).        03810001
038200         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).        03820001
038300         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).        03830001
038400         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).        03840001
038500         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).        03850001
038600         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).        03860001
038700         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).        03870001
038800         05  H-CAPI-COLA                  PIC 9(01)V9(03).        03880001
038900         05  H-CAPI-SCH                   PIC 9(05)V9(02).        03890001
039000         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).        03900001
039100         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).        03910001
039200         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).        03920001
039300         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).        03930001
039400         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).        03940001
039500         05  H-CAPI-GAF                   PIC 9(05)V9(04).        03950001
039600         05  H-WAGE-INDEX                 PIC 9(02)V9(04).        03960001
039700         05  H-COV-DAYS                   PIC 9(3).               03970001
039800         05  H-REG-DAYS                   PIC 9(3).               03980001
039900         05  H-LTR-DAYS                   PIC 9(3).               03990001
040000         05  H-DSCHG-FRCTN                PIC 9(1)V9999.          04000001
040100         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.          04010001
040200         05  H-ALOS                       PIC 9(02)V9(01).        04020001
040300         05  H-ARITH-ALOS                 PIC 9(02)V9(01).        04030001
040400         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).        04040001
040500         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).        04050001
040600         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).        04060001
040700         05  H-CST-MULTIPLE               PIC 9(01)V9(03).        04070001
040800         05  H-CST-THRESH                 PIC 9(05)V9(02).        04080001
040900         05  H-LABOR-PCT                  PIC 9(01)V9(04).        04090001
041000         05  H-NLABOR-PCT                 PIC 9(01)V9(04).        04100001
041100         05  H-HSP-RATE                   PIC 9(06)V9(09).        04110001
041200         05  H-FSP-RATE                   PIC 9(06)V9(09).        04120001
041300         05  H-OUTLIER-FACT               PIC 9(01)V9(06).        04130001
041400         05  H-WK-OPER-DSH                PIC 9(01)V9(04).        04140001
041500         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).        04150001
041600                                                                  04160001
041700                                                                  04170001
041800     02  HOLD-ADDITIONAL-VARIABLES.                               04180001
041900         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).        04190001
042000         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).        04200001
042100         05  H-NAT-PCT                    PIC 9(01)V9(02).        04210001
042200         05  H-REG-PCT                    PIC 9(01)V9(02).        04220001
042300         05  H-CMI-ADJ-CPD                PIC 9(05)V9(02).        04230001
042400         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).        04240001
042500         05  H-DRG-WT                     PIC 9(02)V9(04).        04250001
042600         05  H-NAT-LABOR                  PIC 9(05)V9(02).        04260001
042700         05  H-NAT-NLABOR                 PIC 9(05)V9(02).        04270001
042800         05  H-REG-LABOR                  PIC 9(05)V9(02).        04280001
042900         05  H-REG-NLABOR                 PIC 9(05)V9(02).        04290001
043000         05  H-OPER-COLA                  PIC 9(01)V9(03).        04300001
043100         05  H-INTERN-RATIO               PIC 9(01)V9(04).        04310001
043200         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).        04320001
043300         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).        04330001
043400         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).        04340001
043500                                                                  04350001
043600     02  HOLD-CAPITAL-VARIABLES.                                  04360001
043700         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).        04370001
043800         05  H-CAPI-HSP                   PIC 9(07)V9(02).        04380001
043900         05  H-CAPI-FSP                   PIC 9(07)V9(02).        04390001
044000         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).        04400001
044100         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).        04410001
044200         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).        04420001
044300         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).        04430001
044400         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).        04440001
044500                                                                  04450001
044600     02  HOLD-CAPITAL2-VARIABLES.                                 04460001
044700         05  H-CAPI2-PAY-CODE             PIC X(1).               04470001
044800         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).        04480001
044900         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).        04490001
045000                                                                  04500001
045100 LINKAGE SECTION.                                                 04510001
045200***************************************************************   04520001
045300*                 * * * * * * * * *                           *   04530001
045400*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *   04540001
045500*    IN HOW TO PAY THE BILL.                                  *   04550001
045600*         REVIEW-CODE:                                        *   04560001
045700*            00 = PAY-WITH-OUTLIER.                           *   04570001
045800*                 WILL CALCULATE THE STANDARD PAYMENT.        *   04580001
045900*                 WILL ALSO ATTEMPT TO PAY DAY AND COST       *   04590001
046000*                 OUTLIERS.                                   *   04600001
046100*            03 = PAY-PERDIEM-DAYS.                           *   04610001
046200*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   04620001
046300*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *   04630001
046400*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   04640001
046500*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   04650001
046600*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   04660001
046700*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *   04670001
046800*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   04680001
046900*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *   04690001
047000*                 BILL EXCEED THE COST THRESHOLD.             *   04700001
047100*            06 = PAY-XFER-NO-COST                            *   04710001
047200*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   04720001
047300*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *   04730001
047400*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   04740001
047500*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *   04750001
047600*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   04760001
047700*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *   04770001
047800*                 CALCULATE ANY COST OUTLIER PORTION          *   04780001
047900*                 OF THE PAYMENT.                             *   04790001
048000*            07 = PAY-WITHOUT-COST.                           *   04800001
048100*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *   04810001
048200*                 ALSO CALCULATE THE DAY OUTLIER PORTION OF   *   04820001
048300*                 THE PAYMENT IF THE COVERED DAYS EXCEED THE  *   04830001
048400*                 OUTLIER CUTOFF FOR THE DRG.                 *   04840001
048500***************************************************************   04850001
048600 01  BILL-DATA.                                                   04860001
048700         10  B-PROVIDER-NO          PIC X(06).                    04870001
048800         10  B-REVIEW-CODE          PIC 9(02).                    04880001
048900             88  VALID-REVIEW-CODE  VALUE 00 03 06 07.            04890001
049000             88  PAY-WITH-OUTLIER   VALUE 00 07.                  04900001
049100             88  PAY-PERDIEM-DAYS   VALUE 03.                     04910001
049200             88  PAY-XFER-NO-COST   VALUE 06.                     04920001
049300             88  PAY-WITHOUT-COST   VALUE 07.                     04930001
049400         10  B-DRG                  PIC 9(03).                    04940001
049500         10  B-LOS                  PIC 9(03).                    04950001
049600         10  B-COVERED-DAYS         PIC 9(03).                    04960001
049700         10  B-LTR-DAYS             PIC 9(02).                    04970001
049800         10  B-DISCHARGE-DATE.                                    04980001
049900             15  B-DISCHG-MM        PIC 9(02).                    04990001
050000             15  B-DISCHG-DD        PIC 9(02).                    05000001
050100             15  B-DISCHG-YY        PIC 9(02).                    05010001
050200         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).              05020001
050300                                                                  05030001
050400***************************************************************   05040001
050500*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *   05050001
050600*    AND PASSED BACK TO THE CALLING PROGRAM                   *   05060001
050700*            RETURN CODE VALUES (PPS-RTC)                     *   05070001
050800*                                                             *   05080001
050900*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   05090001
051000*              00 = PAID NORMAL DRG PAYMENT                   *   05100001
051100*                                                             *   05110001
051200*              01 = PAID AS A DAY-OUTLIER.                    *   05120001
051300*                                                             *   05130001
051400*              02 = PAID AS A COST-OUTLIER.                   *   05140001
051500*                                                             *   05150001
051600*              03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   05160001
051700*                   AND INCLUDING THE FULL DRG.               *   05170001
051800*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   05180001
051900*                   AND INCLUDING THE FULL DRG WHICH ALSO     *   05190001
052000*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *   05200001
052100*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   05210001
052200*                   AND INCLUDING THE FULL DRG. PROVIDER      *   05220001
052300*                   REFUSED COST OUTLIER.                     *   05230001
052400*                                                             *   05240001
052500*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   05250001
052600*              51 = NO PROVIDER SPECIFIC INFO FOUND           *   05260001
052700*              52 = INVALID MSA # IN PROVIDER FILE            *   05270001
052800*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   05280001
052900*              54 = DRG < 001 OR > 494, OR = 109 OR = 438     *   05290001
053000*                                       OR = 469 OR = 470     *   05300001
053100*                                       OR = 474              *   05310001
053200*              55 = DISCHARGE DATE < PROVIDER PPS START DATE  *   05320001
053300*              56 = INVALID LENGTH OF STAY                    *   05330001
053400*              57 = REVIEW CODE INVALID (NOT 00 03 06 07)     *   05340001
053500*              58 = TOTAL CHARGES NOT NUMERIC                 *   05350001
053600*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   05360001
053700*              62 = INVALID NUMBER OF COVERED DAYS            *   05370001
053800*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *   05380001
053900*                   SPECIFIC FILE FOR CAPITAL                 *   05390001
054000*              66 = THERE ARE NOT AS MANY BENEFIT DAYS        *   05400001
054100*                   AVAILABLE ON THE BILL AS THERE ARE OUTLIER*   05410001
054200*                   DAYS COMPUTED BY PRICER --BENEFITS ARE    *   05420001
054300*                   EXHAUSTED ---                             *   05430001
054400*                   APPORTION THE CORRECT COVERED CHARGES     *   05440001
054500*                   FOR THE MAXIMUM NUMBER OF COVERED DAYS    *   05450001
054600*                   AVAILABLE BEFORE RESUBMITTING THE BILL    *   05460001
054700*                   FOR THE COST OUTLIER PAYMENT.             *   05470001
054800*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *   05480001
054900***************************************************************   05490001
055000 01  PPS-DATA.                                                    05500001
055100         10  PPS-RTC                PIC 9(02).                    05510001
055200         10  PPS-WAGE-INDX          PIC 9(02)V9(04).              05520001
055300         10  PPS-OUTLIER-DAYS       PIC 9(03).                    05530001
055400         10  PPS-AVG-LOS            PIC 9(02)V9(01).              05540001
055500         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).              05550001
055600         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).              05560001
055700         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).              05570001
055800         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).              05580001
055900         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).              05590001
056000         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).              05600001
056100         10  PPS-REG-DAYS-USED      PIC 9(03).                    05610001
056200         10  PPS-LTR-DAYS-USED      PIC 9(02).                    05620001
056300         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).              05630001
056400         10  PPS-CALC-VERS          PIC X(05).                    05640001
056500                                                                  05650001
056600******************************************************************05660001
056700*            THESE ARE THE VERSIONS OF THE PPCAL                  05670001
056800*           PROGRAMS THAT WILL BE PASSED BACK----                 05680001
056900*          ASSOCIATED WITH THE BILL BEING PROCESSED               05690001
057000******************************************************************05700001
057100 01  PRICER-OPT-VERS-SW.                                          05710001
057200     02  PRICER-OPTION-SW          PIC X(01).                     05720001
057300         88  ALL-TABLES-PASSED          VALUE 'A'.                05730001
057400         88  PROV-RECORD-PASSED         VALUE 'P'.                05740001
057500         88  ADDITIONAL-VARIABLES       VALUE 'M'.                05750001
057600     02  PPS-VERSIONS.                                            05760001
057700         10  PPDRV-VERSION         PIC X(05).                     05770001
057800                                                                  05780001
057900******************************************************************05790001
058000*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK           05800001
058100*          ASSOCIATED WITH THE BILL BEING PROCESSED               05810001
058200******************************************************************05820001
058300 01  PPS-ADDITIONAL-VARIABLES.                                    05830001
058400     05  PPS-HSP-PCT                PIC 9(01)V9(02).              05840001
058500     05  PPS-FSP-PCT                PIC 9(01)V9(02).              05850001
058600     05  PPS-NAT-PCT                PIC 9(01)V9(02).              05860001
058700     05  PPS-REG-PCT                PIC 9(01)V9(02).              05870001
058800     05  PPS-CMI-ADJ-CPD            PIC 9(05)V9(02).              05880001
058900     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).              05890001
059000     05  PPS-DRG-WT                 PIC 9(02)V9(04).              05900001
059100     05  PPS-NAT-LABOR              PIC 9(05)V9(02).              05910001
059200     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).              05920001
059300     05  PPS-REG-LABOR              PIC 9(05)V9(02).              05930001
059400     05  PPS-REG-NLABOR             PIC 9(05)V9(02).              05940001
059500     05  PPS-OPER-COLA              PIC 9(01)V9(03).              05950001
059600     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).              05960001
059700     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).              05970001
059800     05  PPS-BILL-COSTS             PIC 9(07)V9(09).              05980001
059900     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).              05990001
060000     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.                06000001
060100     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.                06010001
060200     05  PPS-CAPITAL-VARIABLES.                                   06020001
060300         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).        06030001
060400         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).        06040001
060500         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).        06050001
060600         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).        06060001
060700         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).        06070001
060800         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).        06080001
060900         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).        06090001
061000         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).        06100001
061100     05  PPS-CAPITAL2-VARIABLES.                                  06110001
061200         10  PPS-CAPI2-PAY-CODE             PIC X(1).             06120001
061300         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).      06130001
061400         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).      06140001
061500                                                                  06150001
061600                                                                  06160001
061700******************************************************************06170001
061800*               THIS IS THE PROVIDER RECORD                       06180001
061900*          ASSOCIATED WITH THE BILL BEING PROCESSED               06190001
062000******************************************************************06200001
062100 01  PROV-HOLD.                                                   06210001
062200     02  PROV-REC-HOLD.                                           06220001
062300         05  P-PROVIDER-NO.                                       06230001
062400             10  P-STATE                PIC 9(02).                06240001
062500             10  FILLER                 PIC X(04).                06250001
062600         05  P-EFF-DATE.                                          06260001
062700             10  P-EFF-YY               PIC 9(02).                06270001
062800             10  P-EFF-MM               PIC 9(02).                06280001
062900             10  P-EFF-DD               PIC 9(02).                06290001
063000         05  P-WAIVER-CODE              PIC X(01).                06300001
063100             88  WAIVER-STATE           VALUE 'Y'.                06310001
063200         05  P-PROVIDER-TYPE            PIC X(02).                06320001
063300             88  SOLE-COMMUNITY-PROV    VALUE '01' '11'.          06330001
063400             88  REFERRAL-CENTER        VALUE '07' '11' '15' '17'.06340001
063500             88  INDIAN-HEALTH-SERVICE  VALUE '08'.               06350001
063600             88  SOLE-COM-REF-CENT      VALUE '11'.               06360001
063700             88  MDH-REBASED-FY90       VALUE '14' '15'.          06370001
063800             88  MDH-RRC-REBASED-FY90   VALUE '15'.               06380001
063900             88  SCH-REBASED-FY90       VALUE '16' '17'.          06390001
064000             88  SCH-RRC-REBASED-FY90   VALUE '17'.               06400001
064100             88  MEDICAL-ASSIST-FACIL   VALUE '18'.               06410001
064200             88  OTHER-URB-TO-RURAL     VALUE '19'.               06420001
064300             88  LARGE-URB-TO-RURAL     VALUE '20'.               06430001
064400         05  P-CURRENT-CENSUS-DIV       PIC 9(01).                06440001
064500             88  NEW-ENGLAND            VALUE  1.                 06450001
064600             88  MIDDLE-ATLANTIC        VALUE  2.                 06460001
064700             88  SOUTH-ATLANTIC         VALUE  3.                 06470001
064800             88  EAST-NORTH-CENTRAL     VALUE  4.                 06480001
064900             88  EAST-SOUTH-CENTRAL     VALUE  5.                 06490001
065000             88  WEST-NORTH-CENTRAL     VALUE  6.                 06500001
065100             88  WEST-SOUTH-CENTRAL     VALUE  7.                 06510001
065200             88  MOUNTAIN               VALUE  8.                 06520001
065300             88  PACIFIC                VALUE  9.                 06530001
065400         05  P-CENSUS-DIV  REDEFINES                              06540001
065500                    P-CURRENT-CENSUS-DIV       PIC 9(01).         06550001
065600             88  VALID-CENSUS-DIV   VALUE 1 THRU 9.               06560001
065700         05  P-PPS-BLEND-YEAR           PIC 9(01).                06570001
065800             88  VALID-PPS-BLEND-YEAR   VALUE 1 THRU 8.           06580001
065900         05  P-MSA-X.                                             06590001
066000             10  P-MSA-9                PIC X(04).                06600001
066100         05  P-FISCAL-YEAR-END.                                   06610001
066200             10  P-MM                   PIC 9(02).                06620001
066300             10  P-DD                   PIC 9(02).                06630001
066400             10  P-YY                   PIC 9(02).                06640001
066500         05  P-VARIABLES.                                         06650001
066600             10  P-CMI-ADJ-CPD          PIC S9(05)V9(02).         06660001
066700             10  P-COLA                 PIC S9(01)V9(03).         06670001
066800             10  P-INTERN-RATIO         PIC S9(01)V9(04).         06680001
066900             10  PRUP-UPDT-FACTOR       PIC S9(01)V9(05).         06690001
067000             10  P-BED-SIZE             PIC  9(05).               06700001
067100             10  P-DSH-PERCENT          PIC V9(04).               06710001
067200             10  P-OPER-CSTCHG-RATIO    PIC  9(01)V9(03).         06720001
067300             10  P-CMI                  PIC  9(01)V9(04).         06730001
067400             10  FILLER                 PIC  9(01).               06740001
067500             10  P-REPORT-DATE          PIC  9(06).               06750001
067600             10  FILLER                 PIC  9(01).               06760001
067700             10  P-INTER-NO             PIC  9(05).               06770001
067800     02  PROV-REC-HOLD2.                                          06780001
067900         05  P-FY-BEGIN-DATE.                                     06790001
068000             10  P-FY-BEGIN-MM          PIC 9(2).                 06800001
068100             10  P-FY-BEGIN-DD          PIC 9(2).                 06810001
068200             10  P-FY-BEGIN-YY          PIC 9(2).                 06820001
068300         05  P-PASS-AMT-CAPITAL         PIC 9(4)V99.              06830001
068400         05  P-PASS-AMT-DIR-MED-ED      PIC 9(4)V99.              06840001
068500         05  P-PASS-AMT-ORGAN-ACQ       PIC 9(4)V99.              06850001
068600         05  P-PASS-AMT-INCL-MISC       PIC 9(4)V99.              06860001
068700         05  P-SSI-RATIO                PIC V9(4).                06870001
068800         05  P-MEDICAID-RATIO           PIC V9(4).                06880001
068900         05  P-TERMINATION-DATE         PIC X(6).                 06890001
069000         05  P-WAGE-INDEX-LOC-MSA       PIC X(4).                 06900001
069100         05  P-CHG-CODE-INDEX           PIC X.                    06910001
069200         05  P-STAND-AMT-LOC-MSA.                                 06920001
069300             10  P-RURAL-1ST            PIC XX.                   06930001
069400                 88  P-RURAL-CHECK        VALUE '  '.             06940001
069500             10  P-RURAL-2ND            PIC XX.                   06950001
069600         05  P-CAPI-SOL-HOSP-RATE       PIC XX.                   06960001
069700         05  FILLER                     PIC X.                    06970001
069800         05  FILLER                     PIC X(06).                06980001
069900         05  FILLER                     PIC X(18).                06990001
070000     02  PROV-REC-HOLD3.                                          07000001
070100         05  P-CAPI-PPS-PAY-CODE        PIC X.                    07010001
070200         05  P-CAPI-HOSP-SPEC-RATE      PIC 9(4)V99.              07020001
070300         05  P-CAPI-OLD-HARM-RATE       PIC 9(4)V99.              07030001
070400         05  P-CAPI-NEW-HARM-RATIO      PIC 9(1)V9999.            07040001
070500         05  P-CAPI-CSTCHG-RATIO        PIC 9V999.                07050001
070600         05  P-CAPI-NEW-HOSP            PIC X.                    07060001
070700         05  P-CAPI-IME                 PIC 9V9999.               07070001
070800         05  P-CAPI-EXCEPTIONS          PIC 9(4)V99.              07080001
070900         05  FILLER                     PIC X(46).                07090001
071000                                                                  07100001
071100******************************************************************07110001
071200*                   THIS IS THE WAGE-INDEX                        07120001
071300*          ASSOCIATED WITH THE BILL BEING PROCESSED               07130001
071400******************************************************************07140001
071500 01  WAGE-INDEX-RECORD.                                           07150001
071600     05  W-MSA                         PIC X(4).                  07160001
071700     05  W-SIZE                        PIC X.                     07170001
071800         88  LARGE-URBAN       VALUE 'L'.                         07180001
071900         88  OTHER-URBAN       VALUE 'O'.                         07190001
072000         88  ALL-RURAL         VALUE 'R'.                         07200001
072100     05  W-EFF-DATE                    PIC X(6).                  07210001
072200     05  FILLER                        PIC X.                     07220001
072300     05  W-INDEX-RECORD                PIC S9(02)V9(04).          07230001
072400                                                                  07240001
072500                                                                  07250001
072600 PROCEDURE DIVISION  USING BILL-DATA                              07260001
072700                           PPS-DATA                               07270001
072800                           PRICER-OPT-VERS-SW                     07280001
072900                           PPS-ADDITIONAL-VARIABLES               07290001
073000                           PROV-HOLD                              07300001
073100                           WAGE-INDEX-RECORD.                     07310001
073200                                                                  07320001
073300***************************************************************   07330001
073400*    PROCESSING:                                              *   07340001
073500*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE            07350001
073600*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *   07360001
073700*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *   07370001
073800*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *   07380001
073900*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   07390001
074000*           GOBACK.                                           *   07400001
074100*        D. ASSEMBLE PRICING COMPONENTS.                      *   07410001
074200*        E. CALCULATE THE BLENDED PRICE.                      *   07420001
074300***************************************************************   07430001
074400                                                                  07440001
074500     PERFORM 0200-MAINLINE-CONTROL.                               07450001
074600                                                                  07460001
074700     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES. 07470001
074800     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.          07480001
074900     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.         07490001
075000     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.    07500001
075100     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.   07510001
075200     MOVE CAL-VERSION               TO  PPS-CALC-VERS.            07520001
075300                                                                  07530001
075400     GOBACK.                                                      07540001
075500                                                                  07550001
075600 0200-MAINLINE-CONTROL.                                           07560001
075700     MOVE ALL '0' TO PPS-DATA                                     07570001
075800                     HOLD-PPS-COMPONENTS                          07580001
075900                     HOLD-ADDITIONAL-VARIABLES                    07590001
076000                     HOLD-CAPITAL-VARIABLES                       07600001
076100                     HOLD-CAPITAL2-VARIABLES.                     07610001
076200                                                                  07620001
076300     IF P-CAPI-HOSP-SPEC-RATE NOT NUMERIC                         07630001
076400        MOVE 0 TO P-CAPI-HOSP-SPEC-RATE.                          07640001
076500                                                                  07650001
076600     IF P-CAPI-OLD-HARM-RATE  NOT NUMERIC                         07660001
076700        MOVE 0 TO P-CAPI-OLD-HARM-RATE.                           07670001
076800                                                                  07680001
076900     IF P-CAPI-NEW-HARM-RATIO NOT NUMERIC                         07690001
077000        MOVE 0 TO P-CAPI-NEW-HARM-RATIO.                          07700001
077100                                                                  07710001
077200     IF P-CAPI-CSTCHG-RATIO NOT NUMERIC                           07720001
077300        MOVE 0 TO P-CAPI-CSTCHG-RATIO.                            07730001
077400                                                                  07740001
077500******************************************************************07750001
077600     PERFORM 1000-EDIT-THE-BILL-INFO.                             07760001
077700                                                                  07770001
077800     IF  PPS-RTC = 00                                             07780001
077900         PERFORM 2000-ASSEMBLE-PPS-VARIABLES                      07790001
078000         PERFORM 3000-CALC-BLENDED-PAYMENT.                       07800001
078100                                                                  07810001
078200 1000-EDIT-THE-BILL-INFO.                                         07820001
078300***************************************************************   07830001
078400*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   07840001
078500*    AND DO NOT ATTEMPT TO PRICE.                             *   07850001
078600***************************************************************   07860001
078700                                                                  07870001
078800     MOVE B-DISCHG-YY TO H-BILL-YY.                               07880001
078900     MOVE B-DISCHG-MM TO H-BILL-MM.                               07890001
079000     MOVE B-DISCHG-DD TO H-BILL-DD.                               07900001
079100                                                                  07910001
079200     MOVE P-FY-BEGIN-YY TO H-FY-BEGIN-YY.                         07920001
079300     MOVE P-FY-BEGIN-MM TO H-FY-BEGIN-MM.                         07930001
079400     MOVE P-FY-BEGIN-DD TO H-FY-BEGIN-DD.                         07940001
079500                                                                  07950001
079600     IF HOLD-FY-BEGIN-DATE < 931001                               07960001
079700        MOVE .20 TO H-CAPI-PAYCDE-PCT1                            07970001
079800        MOVE .80 TO H-CAPI-PAYCDE-PCT2                            07980001
079900     ELSE                                                         07990001
080000        IF (HOLD-FY-BEGIN-DATE < HOLD-BILL-DATE) OR               08000001
080100           (HOLD-FY-BEGIN-DATE = HOLD-BILL-DATE)                  08010001
080200              MOVE .30 TO H-CAPI-PAYCDE-PCT1                      08020001
080300              MOVE .70 TO H-CAPI-PAYCDE-PCT2                      08030001
080400        ELSE                                                      08040001
080500              MOVE .20 TO H-CAPI-PAYCDE-PCT1                      08050001
080600              MOVE .80 TO H-CAPI-PAYCDE-PCT2.                     08060001
080700                                                                  08070001
080800     IF  PPS-RTC = 00                                             08080001
080900         IF  WAIVER-STATE                                         08090001
081000             MOVE 53 TO PPS-RTC.                                  08100001
081100                                                                  08110001
081200     IF  PPS-RTC = 00                                             08120001
081300         IF  B-DRG < 001 OR > 494 OR = 109 OR = 438               08130001
081400                                  OR = 469 OR = 470               08140001
081500                                  OR = 474                        08150001
081600             MOVE 54 TO PPS-RTC.                                  08160001
081700                                                                  08170001
081800     IF  PPS-RTC = 00                                             08180001
081900         IF  HOLD-BILL-DATE < P-EFF-DATE                          08190001
082000             MOVE 55 TO PPS-RTC.                                  08200001
082100                                                                  08210001
082200     IF  PPS-RTC = 00                                             08211000
082300         IF  B-REVIEW-CODE NOT NUMERIC                            08212000
082400             MOVE 57 TO PPS-RTC.                                  08213000
082500     IF  PPS-RTC = 00                                             08220001
082600         IF  B-LOS NOT NUMERIC                                    08230001
082700             MOVE 56 TO PPS-RTC                                   08240001
082800         ELSE                                                     08250001
082900         IF  B-LOS = 0                                            08260001
083000             IF B-REVIEW-CODE NOT = 03 AND                        08270001
083100                              NOT = 06                            08280001
083200             MOVE 56 TO PPS-RTC.                                  08290001
083300                                                                  08300001
083400     IF  PPS-RTC = 00                                             08310001
083500         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60            08320001
083600             MOVE 61 TO PPS-RTC                                   08330001
083700         ELSE                                                     08340001
083800             MOVE B-LTR-DAYS TO H-LTR-DAYS.                       08350001
083900                                                                  08360001
084000     IF  PPS-RTC = 00                                             08370001
084100         IF  B-COVERED-DAYS NOT NUMERIC                           08380001
084200             MOVE 62 TO PPS-RTC                                   08390001
084300         ELSE                                                     08400001
084400         IF  B-COVERED-DAYS = 0 AND B-LOS > 0                     08410001
084500             MOVE 62 TO PPS-RTC                                   08420001
084600         ELSE                                                     08430001
084700             MOVE B-COVERED-DAYS TO H-COV-DAYS.                   08440001
084800                                                                  08450001
084900     IF  PPS-RTC = 00                                             08460001
085000         IF  H-LTR-DAYS  > H-COV-DAYS                             08470001
085100             MOVE 62 TO PPS-RTC                                   08480001
085200         ELSE                                                     08490001
085300             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.        08500001
085400                                                                  08510001
085500     IF  PPS-RTC = 00                                             08520001
085600         IF  NOT VALID-REVIEW-CODE                                08530001
085700             MOVE 57 TO PPS-RTC.                                  08540001
085800                                                                  08550001
085900     IF  PPS-RTC = 00                                             08560001
086000         IF  B-CHARGES-CLAIMED NOT NUMERIC                        08570001
086100             MOVE 58 TO PPS-RTC.                                  08580001
086200                                                                  08590001
086300     IF PPS-RTC = 00                                              08600001
086400        IF NOT INDIAN-HEALTH-SERVICE                              08610001
086500           IF P-CAPI-NEW-HOSP NOT = 'Y'                           08620001
086600                 IF P-CAPI-PPS-PAY-CODE NOT = 'A' AND             08630001
086700                                        NOT = 'B' AND             08640001
086800                                        NOT = 'C'                 08650001
086900                 MOVE 65 TO PPS-RTC.                              08660001
087000                                                                  08670001
087100 2000-ASSEMBLE-PPS-VARIABLES.                                     08680001
087200***************************************************************   08690001
087300*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   08700001
087400*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   08710001
087500*    OF THAT VARIABLE.                                        *   08720001
087600***************************************************************   08730001
087700***  GET THE PROVIDER SPECIFIC VARIABLES.                         08740001
087800                                                                  08750001
087900     MOVE P-CMI-ADJ-CPD  TO H-CMI-ADJ-CPD.                        08760001
088000     MOVE P-INTERN-RATIO TO H-INTERN-RATIO.                       08770001
088100                                                                  08780001
088200     IF  NOT (P-STATE = 02 OR 12)                                 08790001
088300         MOVE 1 TO H-OPER-COLA                                    08800001
088400     ELSE                                                         08810001
088500         MOVE P-COLA TO H-OPER-COLA.                              08820001
088600                                                                  08830001
088700***************************************************************   08840001
088800***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF              08850001
088900                                                                  08860001
089000     PERFORM 2600-GET-DRG-WEIGHT                                  08870001
089100             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.               08880001
089200                                                                  08890001
089300***************************************************************   08900001
089400***  GET THE WAGE-INDEX                                           08910001
089500                                                                  08920001
089600     MOVE W-INDEX-RECORD TO H-WAGE-INDEX.                         08930001
089700                                                                  08940001
089800***************************************************************   08950001
089900***  GET THE LABOR, NON-LABOR STANDARD RATES                      08960001
090000                                                                  08970001
090100     IF  VALID-CENSUS-DIV                                         08980001
090200         MOVE P-CURRENT-CENSUS-DIV TO R2                          08990001
090300     ELSE                                                         09000001
090400         MOVE 10 TO R2.                                           09010001
090500                                                                  09020001
090600     MOVE 10 TO R4.                                               09030001
090700                                                                  09040001
090800     IF  P-STATE = 40                                             09050001
090900         MOVE 11 TO R2                                            09060001
091000         MOVE 12 TO R4.                                           09070001
091100                                                                  09080001
091200     IF  LARGE-URBAN                                              09090001
091300         MOVE 1 TO R3                                             09100001
091400     ELSE                                                         09110001
091500     IF  OTHER-URBAN OR REFERRAL-CENTER                           09120001
091600         MOVE 2 TO R3                                             09130001
091700     ELSE                                                         09140001
091800         MOVE 3 TO R3.                                            09150001
091900                                                                  09160001
092000     PERFORM 2300-GET-LABOR-NLABOR-RATES                          09170001
092100             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 09180001
092200                                                                  09190001
092300***************************************************************   09200001
092400***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL               09210001
092500                                                                  09220001
092600     MOVE 0.00  TO H-OPER-HSP-PCT.                                09230001
092700     MOVE 1.00  TO H-OPER-FSP-PCT.                                09240001
092800                                                                  09250001
092900***************************************************************   09260001
093000***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL     09270001
093100                                                                  09280001
093200      MOVE 1.00 TO H-NAT-PCT.                                     09290001
093300      MOVE 0.00 TO H-REG-PCT.                                     09300001
093400                                                                  09310001
093500***************************************************************   09320001
093600*    REGIONAL FLOOR                                               09330001
093700                                                                  09340001
093800     IF  (H-REG-LABOR + H-REG-NLABOR) >                           09350001
093900         (H-NAT-LABOR + H-NAT-NLABOR)                             09360001
094000           MOVE 0.85 TO H-NAT-PCT                                 09370001
094100           MOVE 0.15 TO H-REG-PCT.                                09380001
094200                                                                  09390001
094300     IF  P-STATE = 40                                             09400001
094400         MOVE 0.25 TO H-NAT-PCT                                   09410001
094500         MOVE 0.75 TO H-REG-PCT.                                  09420001
094600                                                                  09430001
094700     IF  SCH-REBASED-FY90 OR MDH-REBASED-FY90                     09440001
094800         MOVE 1.00 TO H-OPER-HSP-PCT.                             09450001
094900                                                                  09460001
095000                                                                  09470001
095100 2300-GET-LABOR-NLABOR-RATES.                                     09480001
095200                                                                  09490001
095300     IF  HOLD-BILL-DATE NOT < RATE-EFF-DATE (R1)                  09500001
095400         MOVE REG-LABOR  (R1 R2 R3) TO H-REG-LABOR                09510001
095500         MOVE REG-NLABOR (R1 R2 R3) TO H-REG-NLABOR               09520001
095600         MOVE REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR                09530001
095700         MOVE REG-NLABOR (R1 R4 R3) TO H-NAT-NLABOR               09540001
095800         IF OTHER-URB-TO-RURAL OR LARGE-URB-TO-RURAL              09550001
095900            PERFORM 2350-BLEND-RURAL-RATES.                       09560001
096000                                                                  09570001
096100 2350-BLEND-RURAL-RATES.                                          09580001
096200      COMPUTE BLEND-RURAL-PCT ROUNDED = 2 / 3.                    09590001
096300                                                                  09600001
096400      IF OTHER-URB-TO-RURAL                                       09610001
096500         COMPUTE H-REG-LABOR  ROUNDED =                           09620001
096600             (REG-LABOR  (R1 R2 2) - REG-LABOR  (R1 R2 3))        09630001
096700               * BLEND-RURAL-PCT   +  REG-LABOR  (R1 R2 3)        09640001
096800                                                                  09650001
096900         COMPUTE H-REG-NLABOR ROUNDED =                           09660001
097000             (REG-NLABOR (R1 R2 2) - REG-NLABOR (R1 R2 3))        09670001
097100               * BLEND-RURAL-PCT   +  REG-NLABOR (R1 R2 3)        09680001
097200                                                                  09690001
097300         COMPUTE H-NAT-LABOR  ROUNDED =                           09700001
097400             (REG-LABOR  (R1 R4 2) - REG-LABOR  (R1 R4 3))        09710001
097500               * BLEND-RURAL-PCT   +  REG-LABOR  (R1 R4 3)        09720001
097600                                                                  09730001
097700         COMPUTE H-NAT-NLABOR ROUNDED =                           09740001
097800             (REG-NLABOR (R1 R4 2) - REG-NLABOR (R1 R4 3))        09750001
097900               * BLEND-RURAL-PCT   +  REG-NLABOR (R1 R4 3).       09760001
098000                                                                  09770001
098100                                                                  09780001
098200      IF LARGE-URB-TO-RURAL                                       09790001
098300         COMPUTE H-REG-LABOR  ROUNDED =                           09800001
098400             (REG-LABOR  (R1 R2 1) - REG-LABOR  (R1 R2 3))        09810001
098500               * BLEND-RURAL-PCT   +  REG-LABOR  (R1 R2 3)        09820001
098600                                                                  09830001
098700         COMPUTE H-REG-NLABOR ROUNDED =                           09840001
098800             (REG-NLABOR (R1 R2 1) - REG-NLABOR (R1 R2 3))        09850001
098900               * BLEND-RURAL-PCT   +  REG-NLABOR (R1 R2 3)        09860001
099000                                                                  09870001
099100         COMPUTE H-NAT-LABOR  ROUNDED =                           09880001
099200             (REG-LABOR  (R1 R4 1) - REG-LABOR  (R1 R4 3))        09890001
099300               * BLEND-RURAL-PCT   +  REG-LABOR  (R1 R4 3)        09900001
099400                                                                  09910001
099500         COMPUTE H-NAT-NLABOR ROUNDED =                           09920001
099600             (REG-NLABOR (R1 R4 1) - REG-NLABOR (R1 R4 3))        09930001
099700               * BLEND-RURAL-PCT   +  REG-NLABOR (R1 R4 3).       09940001
099800                                                                  09950001
099900 2600-GET-DRG-WEIGHT.                                             09960001
100000     IF  HOLD-BILL-DATE NOT < DRGX-EFF-DATE (DX5)                 09970001
100100         SET DX6 TO B-DRG                                         09980001
100200         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT                09990001
100300         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS                  10000001
100400         MOVE DRG-DAYS-TRIM (DX5 DX6)  TO H-DAYS-CUTOFF           10010001
100500         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.           10020001
100600                                                                  10030001
100700 3000-CALC-BLENDED-PAYMENT.                                       10040001
100800***************************************************************   10050001
100900*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   10060001
101000*        CALCULATE COVERED DAYS UTILIZATION.                  *   10070001
101100*        CALCULATE THE FEDERAL PORTION.                       *   10080001
101200*        CALCULATE THE HOSPITAL PORTION.                      *   10090001
101300*        CALCULATE THE DAYS-OUTLIER PORTION.                  *   10100001
101400*        CALCULATE THE COST-OUTLIER PORTION.                  *   10110001
101500*        CALCULATE THE TOTAL PAYMENT (BLENDED)                *   10120001
101600*        CALCULATE THE DSH ADJUSTMENT.                        *   10130001
101700***************************************************************   10140001
101800     PERFORM 3100-CALC-STAY-UTILIZATION.                          10150001
101900     PERFORM 3300-CALC-OPER-FSP-AMT.                              10160001
102000     PERFORM 3900-CALC-OPER-DSH.                                  10170001
102100***********************************************************       10180001
102200***  OPERATING IME CALCULATION                                    10190001
102300                                                                  10200001
102400         COMPUTE H-OPER-IME-TEACH =                               10210001
102500            1.89 * ((1 + H-INTERN-RATIO) ** .405  - 1).           10220001
102600                                                                  10230001
102700***********************************************************       10240001
102800                                                                  10250001
102900     IF  SCH-REBASED-FY90 OR MDH-REBASED-FY90                     10260001
103000         PERFORM 3450-CALC-ADDITIONAL-HSP.                        10270001
103100                                                                  10280001
103200     MOVE 00                 TO  PPS-RTC.                         10290001
103300     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.                   10300001
103400     MOVE H-ALOS             TO  PPS-AVG-LOS.                     10310001
103500     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.                 10320001
103600                                                                  10330001
103700     PERFORM 3600-CALC-OUTLIER.                                   10340001
103800                                                                  10350001
103900     IF PAY-PERDIEM-DAYS                                          10360001
104000         IF  B-LOS < H-ALOS                                       10370001
104100             IF  NOT (B-DRG = 385 OR 456)                         10380001
104200                 PERFORM 3500-CALC-PERDIEM-AMT                    10390001
104300                 MOVE 03 TO PPS-RTC.                              10400001
104400                                                                  10410001
104500     IF  PAY-PERDIEM-DAYS                                         10420001
104600         IF  H-OPER-OUTCST-PART > 0                               10430001
104700             MOVE H-OPER-OUTCST-PART TO                           10440001
104800                  H-OPER-OUTLIER-PART                             10450001
104900             MOVE 05 TO PPS-RTC                                   10460001
105000         ELSE                                                     10470001
105100         IF  PPS-RTC NOT = 03                                     10480001
105200             MOVE 00 TO PPS-RTC                                   10490001
105300             MOVE 0  TO H-OPER-OUTLIER-PART.                      10500001
105400                                                                  10510001
105500     IF  PAY-PERDIEM-DAYS                                         10520001
105600         IF  H-CAPI-OUTCST-PART > 0                               10530001
105700             MOVE H-CAPI-OUTCST-PART TO                           10540001
105800                  H-CAPI-OUTLIER-PART                             10550001
105900             MOVE 05 TO PPS-RTC                                   10560001
106000         ELSE                                                     10570001
106100         IF  PPS-RTC NOT = 03                                     10580001
106200             MOVE 0  TO H-CAPI-OUTLIER-PART.                      10590001
106300                                                                  10600001
106400     IF  PAY-XFER-NO-COST                                         10610001
106500         MOVE 0  TO H-OPER-OUTLIER-PART                           10620001
106600                    H-CAPI-OUTLIER-PART                           10630001
106700         MOVE 00 TO PPS-RTC                                       10640001
106800         IF B-LOS < H-ALOS                                        10650001
106900            IF  NOT (B-DRG = 385 OR 456)                          10660001
107000                PERFORM 3500-CALC-PERDIEM-AMT                     10670001
107100                MOVE 06 TO PPS-RTC.                               10680001
107200                                                                  10690001
107300     MOVE 1 TO H-DSCHG-FRCTN.                                     10700001
107400                                                                  10710001
107500     IF  (PAY-PERDIEM-DAYS OR                                     10720001
107600          PAY-XFER-NO-COST)                                       10730001
107700          COMPUTE H-DSCHG-FRCTN = H-COV-DAYS / H-ALOS             10740001
107800          IF H-DSCHG-FRCTN > 1                                    10750001
107900             MOVE 1 TO H-DSCHG-FRCTN.                             10760001
108000                                                                  10770001
108100     COMPUTE H-DRG-WT-FRCTN = H-DSCHG-FRCTN * H-DRG-WT.           10780001
108200                                                                  10790001
108300***********************************************************       10800001
108400***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF          10810001
108500***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE          10820001
108600                                                                  10830001
108700     COMPUTE H-CAPI2-B-FSP-PART = H-CAPI-FSP-PART.                10840001
108800                                                                  10850001
108900***********************************************************       10860001
109000     IF  PPS-RTC < 50                                             10870001
109100         PERFORM 3800-CALC-TOT-AMT                                10880001
109200     ELSE                                                         10890001
109300         MOVE 0 TO PPS-OPER-HSP-PART                              10900001
109400                   PPS-OPER-FSP-PART                              10910001
109500                   PPS-OPER-OUTLIER-PART                          10920001
109600                   PPS-OUTLIER-DAYS                               10930001
109700                   PPS-REG-DAYS-USED                              10940001
109800                   PPS-LTR-DAYS-USED                              10950001
109900                   PPS-TOTAL-PAYMENT                              10960001
110000                   PPS-OPER-DSH-ADJ                               10970001
110100                   PPS-OPER-IME-ADJ                               10980001
110200                   H-DSCHG-FRCTN                                  10990001
110300                   H-DRG-WT-FRCTN                                 11000001
110400                   HOLD-CAPITAL-VARIABLES                         11010001
110500                   HOLD-CAPITAL2-VARIABLES.                       11020001
110600                                                                  11030001
110700 3100-CALC-STAY-UTILIZATION.                                      11040001
110800     IF  H-REG-DAYS > 0                                           11050001
110900         IF  H-REG-DAYS < H-DAYS-CUTOFF                           11060001
111000             MOVE H-REG-DAYS TO PPS-REG-DAYS-USED                 11070001
111100             MOVE 0          TO H-REG-DAYS                        11080001
111200         ELSE                                                     11090001
111300             MOVE H-DAYS-CUTOFF TO PPS-REG-DAYS-USED              11100001
111400             SUBTRACT H-DAYS-CUTOFF FROM H-REG-DAYS               11110001
111500     ELSE                                                         11120001
111600     IF  H-LTR-DAYS < H-DAYS-CUTOFF                               11130001
111700         MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED                     11140001
111800         MOVE 0          TO H-LTR-DAYS                            11150001
111900     ELSE                                                         11160001
112000         MOVE H-DAYS-CUTOFF TO PPS-LTR-DAYS-USED                  11170001
112100         SUBTRACT H-DAYS-CUTOFF FROM H-LTR-DAYS.                  11180001
112200                                                                  11190001
112300     IF  B-LOS > H-DAYS-CUTOFF                                    11200001
112400         PERFORM 3200-CALC-OUTLIER-UTILIZATION.                   11210001
112500                                                                  11220001
112600 3200-CALC-OUTLIER-UTILIZATION.                                   11230001
112700     COMPUTE PPS-OUTLIER-DAYS =                                   11240001
112800         B-LOS - H-DAYS-CUTOFF.                                   11250001
112900                                                                  11260001
113000     IF  (H-REG-DAYS + H-LTR-DAYS) < PPS-OUTLIER-DAYS             11270001
113100         COMPUTE PPS-OUTLIER-DAYS =                               11280001
113200             H-REG-DAYS + H-LTR-DAYS                              11290001
113300         ADD H-REG-DAYS TO PPS-REG-DAYS-USED                      11300001
113400         ADD H-LTR-DAYS TO PPS-LTR-DAYS-USED                      11310001
113500     ELSE                                                         11320001
113600     IF  H-REG-DAYS < PPS-OUTLIER-DAYS                            11330001
113700         ADD H-REG-DAYS TO PPS-REG-DAYS-USED                      11340001
113800         COMPUTE PPS-LTR-DAYS-USED =                              11350001
113900             PPS-LTR-DAYS-USED + (PPS-OUTLIER-DAYS -              11360001
114000                                  H-REG-DAYS)                     11370001
114100     ELSE                                                         11380001
114200         ADD PPS-OUTLIER-DAYS TO PPS-REG-DAYS-USED.               11390001
114300                                                                  11400001
114400     IF  B-REVIEW-CODE = 03                                       11410001
114500         IF  PPS-REG-DAYS-USED > 0                                11420001
114600             MOVE 0 TO PPS-LTR-DAYS-USED.                         11430001
114700                                                                  11440001
114800 3300-CALC-OPER-FSP-AMT.                                          11450001
114900***********************************************************       11460001
115000***  OPERATING FSP CALCULATION                                    11470001
115100                                                                  11480001
115200     COMPUTE H-OPER-FSP-PART ROUNDED =                            11490001
115300         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +               11500001
115400         H-NAT-NLABOR * H-OPER-COLA) * H-DRG-WT)                  11510001
115500                           +                                      11520001
115600         (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDEX +               11530001
115700         H-REG-NLABOR * H-OPER-COLA) * H-DRG-WT).                 11540001
115800                                                                  11550001
115900 3450-CALC-ADDITIONAL-HSP.                                        11560001
116000***********************************************************       11570001
116100*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR                 11580001
116200*    SOLE COMMUNITY AND MEDICARE DEPENDENT HOSPITALS              11590001
116300*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES              11600001
116400***********************************************************       11610001
116500**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE       11620001
116600                                                                  11630001
116700         IF  P-RURAL-CHECK AND NOT REFERRAL-CENTER                11640001
116800             MOVE 1.023377 TO H-OUTLIER-FACT                      11650001
116900         ELSE                                                     11660001
117000             MOVE 1.057127 TO H-OUTLIER-FACT.                     11670001
117100                                                                  11680001
117200***************************************************************   11690001
117300***         GET THE UPDATING FACTOR                               11700001
117400                                                                  11710001
117500**** CHANGE HSP RATE BASED ON FYB DATE                            11720001
117600                                                                  11730001
117700     IF H-FY-BEGIN-MM < 10                                        11740001
117800        COMPUTE N-FACTOR = 10 - H-FY-BEGIN-MM.                    11750001
117900                                                                  11760001
118000     IF H-FY-BEGIN-MM = 10  MOVE 12 TO N-FACTOR.                  11770001
118100     IF H-FY-BEGIN-MM = 11  MOVE 11 TO N-FACTOR.                  11780001
118200     IF H-FY-BEGIN-MM = 12  MOVE 10 TO N-FACTOR.                  11790001
118300                                                                  11800001
118400     COMPUTE H-UPDATE-FACTOR ROUNDED =                            11810001
118500        (1.052 * 1.044 * (1.02 ** (N-FACTOR / 12))                11820001
118600               * 1.041 * .999003 * .999851).                      11830001
118700                                                                  11840001
118800     COMPUTE H-HSP-RATE ROUNDED =                                 11850001
118900         H-CMI-ADJ-CPD * H-UPDATE-FACTOR.                         11860001
119000                                                                  11870001
119100     COMPUTE H-FSP-RATE ROUNDED =                                 11880001
119200         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +              11890001
119300         H-NAT-NLABOR * H-OPER-COLA))                             11900001
119400                           +                                      11910001
119500          (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDEX +              11920001
119600         H-REG-NLABOR * H-OPER-COLA)))                            11930001
119700                           *                                      11940001
119800         H-OUTLIER-FACT * (1 + H-OPER-IME-TEACH +                 11950001
119900                         H-OPER-DSH).                             11960001
120000                                                                  11970001
120100     MOVE HOLD-FY-BEGIN-DATE TO HOLD-ADD-FY-BEGN-DATE.            11980001
120200                                                                  11990001
120300     IF H-ADD-FY-BEGN-MM = '11' OR '12'                           12000001
120400        MOVE 93 TO H-ADD-FY-BEGN-YY.                              12010001
120500                                                                  12020001
120600     IF H-ADD-FY-BEGN-MM = '01' OR '02' OR '03'                   12030001
120700        MOVE 94 TO H-ADD-FY-BEGN-YY.                              12040001
120800                                                                  12050001
120900     IF  H-HSP-RATE > H-FSP-RATE                                  12060001
121000         IF P-PROVIDER-TYPE = '14' OR '15'                        12070001
121100            IF H-ADD-FY-BEGN-MM = '11' OR '12' OR                 12080001
121200                               '01' OR '02' OR '03'               12090001
121300               IF HOLD-BILL-DATE < HOLD-ADD-FY-BEGN-DATE          12100001
121400                  COMPUTE H-OPER-HSP-PART =                       12110001
121500                      (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT        12120001
121600               ELSE                                               12130001
121700                  COMPUTE H-OPER-HSP-PART =                       12140001
121800                      (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .5   12150001
121900            ELSE                                                  12160001
122000               COMPUTE H-OPER-HSP-PART =                          12170001
122100                  (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .5       12180001
122200         ELSE                                                     12190001
122300           COMPUTE H-OPER-HSP-PART =                              12200001
122400             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT                 12210001
122500     ELSE                                                         12220001
122600         MOVE 0 TO H-OPER-HSP-PART.                               12230001
122700                                                                  12240001
122800 3500-CALC-PERDIEM-AMT.                                           12250001
122900     MOVE B-LOS TO H-COV-DAYS.                                    12260001
123000     IF  H-COV-DAYS = 0                                           12270001
123100         MOVE 1 TO H-COV-DAYS.                                    12280001
123200***********************************************************       12290001
123300***  OPERATING PERDIEM-AMT CALCULATION                            12300001
123400                                                                  12310001
123500     COMPUTE H-OPER-HSP-PART ROUNDED =                            12320001
123600        H-OPER-HSP-PART / H-ALOS * H-COV-DAYS                     12330001
123700        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.                  12340001
123800                                                                  12350001
123900     COMPUTE H-OPER-FSP-PART ROUNDED =                            12360001
124000        H-OPER-FSP-PART / H-ALOS * H-COV-DAYS                     12370001
124100        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  12380001
124200                                                                  12390001
124300***********************************************************       12400001
124400***  CAPITAL PERDIEM-AMT CALCULATION                              12410001
124500                                                                  12420001
124600     COMPUTE H-CAPI-HSP-PART ROUNDED =                            12430001
124700        H-CAPI-HSP-PART / H-ALOS * H-COV-DAYS                     12440001
124800        ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.                  12450001
124900                                                                  12460001
125000     COMPUTE H-CAPI-FSP-PART ROUNDED =                            12470001
125100        H-CAPI-FSP-PART / H-ALOS * H-COV-DAYS                     12480001
125200        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  12490001
125300                                                                  12500001
125400***********************************************************       12510001
125500***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                12520001
125600                                                                  12530001
125700     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                        12540001
125800        H-CAPI-OLD-HARMLESS / H-ALOS * H-COV-DAYS                 12550001
125900        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              12560001
126000                                                                  12570001
126100 3600-CALC-OUTLIER.                                               12580001
126200     MOVE 0.55 TO H-DAYOUT-PCT.                                   12590001
126300                                                                  12600001
126400     MOVE 0.75 TO H-CSTOUT-PCT.                                   12610001
126500                                                                  12620001
126600     IF  B-DRG = 456 OR 457 OR 458 OR 459 OR 460 OR 472           12630001
126700             MOVE 0.90 TO H-CSTOUT-PCT.                           12640001
126800                                                                  12650001
126900     MOVE 0.7140   TO H-LABOR-PCT.                                12660001
127000     MOVE 0.2860   TO H-NLABOR-PCT.                               12670001
127100                                                                  12680001
127200     IF  P-OPER-CSTCHG-RATIO NUMERIC                              12690001
127300             MOVE P-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO      12700001
127400     ELSE                                                         12710001
127500             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.                   12720001
127600                                                                  12730001
127700     IF P-CAPI-CSTCHG-RATIO NUMERIC                               12740001
127800             MOVE P-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO      12750001
127900     ELSE                                                         12760001
128000             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.                   12770001
128100                                                                  12780001
128200     MOVE 2.000    TO H-CST-MULTIPLE.                             12790001
128300     MOVE 36000.00 TO H-CST-THRESH.                               12800001
128400                                                                  12810001
128500***********************************************************       12820001
128600***  OPERATING DAY OUTLIER CALCULATION                            12830001
128700                                                                  12840001
128800     IF  PPS-OUTLIER-DAYS > 0                                     12850001
128900        COMPUTE H-OPER-OUTDAY-PART =                              12860001
129000            H-DAYOUT-PCT *  H-OPER-FSP-PART / H-ARITH-ALOS        12870001
129100                                       * PPS-OUTLIER-DAYS         12880001
129200            ON SIZE ERROR MOVE 0 TO H-OPER-OUTDAY-PART.           12890001
129300                                                                  12900001
129400***********************************************************       12910001
129500***********************************************************       12920001
129600***  CAPITAL PAYMENT METHOD B                                     12930001
129700                                                                  12940001
129800     IF W-SIZE = 'L'                                              12950001
129900        MOVE 1.03 TO H-CAPI-LARG-URBAN                            12960001
130000     ELSE                                                         12970001
130100        MOVE 1.00 TO H-CAPI-LARG-URBAN                            12980001
130200        IF LARGE-URB-TO-RURAL                                     12990001
130300           MOVE 1.02 TO H-CAPI-LARG-URBAN.                        13000001
130400                                                                  13010001
130500                                                                  13020001
130600     COMPUTE H-CAPI-GAF = (H-WAGE-INDEX ** .6848).                13030001
130700                                                                  13040001
130800     COMPUTE H-CAPI-COLA =                                        13050001
130900                     (.3152 * (H-OPER-COLA - 1) + 1).             13060001
131000                                                                  13070001
131100     IF P-STATE = 40                                              13080001
131200        COMPUTE  H-CAPI-FED-RATE = (.75 * 291.03) +               13090001
131300                                   (.25 * 378.34)                 13100001
131400     ELSE                                                         13110001
131500        MOVE 378.34 TO H-CAPI-FED-RATE.                           13120001
131600                                                                  13130001
131700***********************************************************       13140001
131800***  CAPITAL HSP CALCULATION                                      13150001
131900                                                                  13160001
132000     COMPUTE H-CAPI-HSP-PART = (H-DRG-WT *                        13170001
132100                   P-CAPI-HOSP-SPEC-RATE * 0.9784).               13180001
132200***********************************************************       13190001
132300***  CAPITAL FSP CALCULATION                                      13200001
132400                                                                  13210001
132500     COMPUTE H-CAPI-FSP-PART = H-DRG-WT * H-CAPI-FED-RATE *       13220001
132600                               H-CAPI-COLA * H-CAPI-GAF *         13230001
132700                               H-CAPI-LARG-URBAN.                 13240001
132800                                                                  13250001
132900***********************************************************       13260001
133000***  CAPITAL PAYMENT METHOD A                                     13270001
133100                                                                  13280001
133200     IF SOLE-COMMUNITY-PROV OR SCH-REBASED-FY90                   13290001
133300        MOVE 1.00 TO H-CAPI-SCH                                   13300001
133400     ELSE                                                         13310001
133500        MOVE 0.85 TO H-CAPI-SCH.                                  13320001
133600                                                                  13330001
133700***********  CAPITAL OLD-HARMLESS CALCULATION ***********         13340001
133800                                                                  13350001
133900     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                        13360001
134000                    (P-CAPI-OLD-HARM-RATE *                       13370001
134100                    H-CAPI-SCH).                                  13380001
134200                                                                  13390001
134300***********************************************************       13400001
134400***********************************************************       13410001
134500***  CAPITAL DAY OUTLIER CALCULATION                              13420001
134600                                                                  13430001
134700     IF  PPS-OUTLIER-DAYS > 0                                     13440001
134800         COMPUTE H-CAPI-OUTDAY-PART =                             13450001
134900            H-DAYOUT-PCT * H-CAPI-FSP-PART / H-ARITH-ALOS         13460001
135000                                       * PPS-OUTLIER-DAYS         13470001
135100            ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.           13480001
135200                                                                  13490001
135300     IF  H-CAPI-OUTDAY-PART  > 0                                  13500001
135400         IF P-CAPI-PPS-PAY-CODE = 'A'                             13510001
135500             COMPUTE H-CAPI-OUTDAY-PART =                         13520001
135600                 H-CAPI-OUTDAY-PART * P-CAPI-NEW-HARM-RATIO       13530001
135700             ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.          13540001
135800                                                                  13550001
135900     IF  H-CAPI-OUTDAY-PART  > 0                                  13560001
136000         IF P-CAPI-PPS-PAY-CODE = 'C'                             13570001
136100             COMPUTE H-CAPI-OUTDAY-PART =                         13580001
136200                    (H-CAPI-OUTDAY-PART * H-CAPI-PAYCDE-PCT1)     13590001
136300             ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.          13600001
136400                                                                  13610001
136500***********************************************************       13620001
136600***  COST OUTLIER OPERATING AND CAPITAL CALCULATION               13630001
136700                                                                  13640001
136800     IF H-CAPI-CSTCHG-RATIO > 0 OR                                13650001
136900       H-OPER-CSTCHG-RATIO > 0                                    13660001
137000        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD =                     13670001
137100                H-OPER-CSTCHG-RATIO /                             13680001
137200               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)        13690001
137300        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD =                     13700001
137400                H-CAPI-CSTCHG-RATIO /                             13710001
137500               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)        13720001
137600     ELSE                                                         13730001
137700         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD                    13740001
137800                   H-CAPI-SHARE-DOLL-THRESHOLD.                   13750001
137900                                                                  13760001
138000     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                    13770001
138100        ((H-CST-THRESH * H-LABOR-PCT  * H-WAGE-INDEX) +           13780001
138200         (H-CST-THRESH * H-NLABOR-PCT * H-OPER-COLA)) *           13790001
138300          H-OPER-SHARE-DOLL-THRESHOLD.                            13800001
138400                                                                  13810001
138500***********************************************************       13820001
138600***  DIFFERENT THRESHOLD   PRE-CAPITAL                            13830001
138700                                                                  13840001
138800     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE          13850001
138900        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                 13860001
139000                (33000 * H-LABOR-PCT * H-WAGE-INDEX) +            13870001
139100                (33000 * H-NLABOR-PCT * H-OPER-COLA).             13880001
139200***********************************************************       13890001
139300                                                                  13900001
139400     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =                    13910001
139500          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *         13920001
139600          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.              13930001
139700                                                                  13940001
139800     COMPUTE H-OPER-COST-OUTLIER ROUNDED =                        13950001
139900         H-CST-MULTIPLE * H-OPER-FSP-PART.                        13960001
140000                                                                  13970001
140100     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =                        13980001
140200         H-CST-MULTIPLE * H-CAPI-FSP-PART.                        13990001
140300                                                                  14000001
140400     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE          14010001
140500         MOVE 0 TO H-CAPI-DOLLAR-THRESHOLD                        14020001
140600                   H-CAPI-COST-OUTLIER.                           14030001
140700                                                                  14040001
140800     IF (H-OPER-DOLLAR-THRESHOLD + H-CAPI-DOLLAR-THRESHOLD)       14050001
140900        > (H-OPER-COST-OUTLIER + H-CAPI-COST-OUTLIER)             14060001
141000      MOVE H-OPER-DOLLAR-THRESHOLD TO H-OPER-COST-OUTLIER         14070001
141100      MOVE H-CAPI-DOLLAR-THRESHOLD TO H-CAPI-COST-OUTLIER.        14080001
141200                                                                  14090001
141300     IF B-REVIEW-CODE = '03'  AND H-COV-DAYS < H-ALOS             14100001
141400        COMPUTE H-OPER-COST-OUTLIER ROUNDED =                     14110001
141500                (H-OPER-COST-OUTLIER * H-COV-DAYS / H-ALOS)       14120001
141600                ON SIZE ERROR MOVE 0 TO H-OPER-COST-OUTLIER.      14130001
141700                                                                  14140001
141800     IF B-REVIEW-CODE = '03'  AND H-COV-DAYS < H-ALOS             14150001
141900        COMPUTE H-CAPI-COST-OUTLIER ROUNDED =                     14160001
142000                (H-CAPI-COST-OUTLIER * H-COV-DAYS / H-ALOS)       14170001
142100                ON SIZE ERROR MOVE 0 TO H-CAPI-COST-OUTLIER.      14180001
142200                                                                  14190001
142300***********************************************************       14200001
142400***  CAPITAL DSH CALCULATION                                      14210001
142500     MOVE 0 TO H-CAPI-DSH.                                        14220001
142600                                                                  14230001
142700     IF P-BED-SIZE NOT NUMERIC                                    14240001
142800         MOVE 0 TO P-BED-SIZE.                                    14250001
142900                                                                  14260001
143000     IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99                 14270001
143100         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **                   14280001
143200                  (.2025 * (P-SSI-RATIO                           14290001
143300                          + P-MEDICAID-RATIO)) - 1.               14300001
143400                                                                  14310001
143500     IF W-SIZE = 'R' AND P-BED-SIZE > 99                          14320001
143600                     AND (OTHER-URB-TO-RURAL OR                   14330001
143700                          LARGE-URB-TO-RURAL)                     14340001
143800         COMPUTE H-CAPI-DSH ROUNDED =                             14350001
143900                 2 / 3 * (2.7183 **                               14360001
144000                  (.2025 * (P-SSI-RATIO                           14370001
144100                          + P-MEDICAID-RATIO)) - 1).              14380001
144200                                                                  14390001
144300***********************************************************       14400001
144400***  OPERATING COST CALCULATION                                   14410001
144500                                                                  14420001
144600     COMPUTE H-OPER-BILL-COSTS ROUNDED =                          14430001
144700         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO /                14440001
144800         (1 + H-OPER-IME-TEACH + H-OPER-DSH)                      14450001
144900         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.               14460001
145000                                                                  14470001
145100     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER                  14480001
145200         COMPUTE H-OPER-OUTCST-PART =                             14490001
145300         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -                      14500001
145400                         H-OPER-COST-OUTLIER).                    14510001
145500                                                                  14520001
145600     IF PAY-WITHOUT-COST                                          14530001
145700         MOVE 0 TO H-OPER-OUTCST-PART.                            14540001
145800                                                                  14550001
145900***********************************************************       14560001
146000***  CAPITAL IME TEACH CALCULATION                                14570001
146100                                                                  14580001
146200     MOVE 0 TO H-WK-CAPI-IME-TEACH.                               14590001
146300                                                                  14600001
146400     IF P-CAPI-IME NUMERIC                                        14610001
146500        COMPUTE H-WK-CAPI-IME-TEACH =                             14620001
146600          (2.7183 ** (.2822 * P-CAPI-IME)) - 1.                   14630001
146700                                                                  14640001
146800***********************************************************       14650001
146900***  CAPITAL COST CALCULATION                                     14660001
147000                                                                  14670001
147100     COMPUTE H-CAPI-BILL-COSTS ROUNDED =                          14680001
147200             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO /            14690001
147300            (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH)                14700001
147400         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.               14710001
147500                                                                  14720001
147600     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER                  14730001
147700         COMPUTE H-CAPI-OUTCST-PART =                             14740001
147800         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -                      14750001
147900                         H-CAPI-COST-OUTLIER).                    14760001
148000                                                                  14770001
148100     IF P-CAPI-PPS-PAY-CODE = 'A'                                 14780001
148200       COMPUTE H-CAPI-OUTCST-PART =                               14790001
148300              (H-CAPI-OUTCST-PART * P-CAPI-NEW-HARM-RATIO).       14800001
148400                                                                  14810001
148500     IF P-CAPI-PPS-PAY-CODE = 'C'                                 14820001
148600        COMPUTE H-CAPI-OUTCST-PART =                              14830001
148700               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).         14840001
148800                                                                  14850001
148900     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <               14860001
149000        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)               14870001
149100        MOVE 0 TO H-CAPI-OUTCST-PART                              14880001
149200                  H-OPER-OUTCST-PART.                             14890001
149300                                                                  14900001
149400     IF PAY-WITHOUT-COST                                          14910001
149500         MOVE 0 TO H-CAPI-OUTCST-PART.                            14920001
149600                                                                  14930001
149700***********************************************************       14940001
149800***  DETERMINES THE BILL TO BE EITHER COST OR DAY OUTLIER         14950001
149900***     GREATER OF DAY OR COST OPERATING AND CAPITAL              14960001
150000                                                                  14970001
150100     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE          14980001
150200         MOVE 0 TO H-CAPI-OUTDAY-PART                             14990001
150300                   H-CAPI-OUTCST-PART.                            15000001
150400                                                                  15010001
150500      IF (H-OPER-OUTDAY-PART + H-CAPI-OUTDAY-PART) > 0 OR         15020001
150600         (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0            15030001
150700         IF (H-OPER-OUTDAY-PART + H-CAPI-OUTDAY-PART) >           15040001
150800            (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART)             15050001
150900                 MOVE H-OPER-OUTDAY-PART TO                       15060001
151000                      H-OPER-OUTLIER-PART                         15070001
151100                 MOVE H-CAPI-OUTDAY-PART TO                       15080001
151200                      H-CAPI-OUTLIER-PART                         15090001
151300                 MOVE 01 TO PPS-RTC                               15100001
151400             ELSE                                                 15110001
151500                 MOVE H-OPER-OUTCST-PART TO                       15120001
151600                      H-OPER-OUTLIER-PART                         15130001
151700                 MOVE H-CAPI-OUTCST-PART TO                       15140001
151800                      H-CAPI-OUTLIER-PART                         15150001
151900                 MOVE 02 TO PPS-RTC                               15160001
152000                 IF B-COVERED-DAYS > H-DAYS-CUTOFF                15170001
152100                    IF (H-REG-DAYS                                15180001
152200                            +                                     15190001
152300                        H-LTR-DAYS)   <                           15200001
152400                       (B-COVERED-DAYS - H-DAYS-CUTOFF)           15210001
152500                       MOVE 66 TO PPS-RTC.                        15220001
152600                                                                  15230001
152700***********************************************************       15240001
152800***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF          15250001
152900***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE          15260001
153000                                                                  15270001
153100     IF P-CAPI-PPS-PAY-CODE = 'A'                                 15280001
153200        COMPUTE H-CAPI2-B-OUTLIER-PART =                          15290001
153300                H-CAPI-OUTLIER-PART / P-CAPI-NEW-HARM-RATIO       15300001
153400         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.          15310001
153500                                                                  15320001
153600     IF P-CAPI-PPS-PAY-CODE = 'B'                                 15330001
153700        COMPUTE H-CAPI2-B-OUTLIER-PART =                          15340001
153800                H-CAPI-OUTLIER-PART.                              15350001
153900                                                                  15360001
154000     IF P-CAPI-PPS-PAY-CODE = 'C'                                 15370001
154100        COMPUTE H-CAPI2-B-OUTLIER-PART =                          15380001
154200                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1          15390001
154300         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.          15400001
154400***********************************************************       15410001
154500                                                                  15420001
154600 3800-CALC-TOT-AMT.                                               15430001
154700                                                                  15440001
154800***********************************************************       15450001
154900***  CALCULATE FINAL TOTALS FOR OPERATING                         15460001
155000                                                                  15470001
155100     COMPUTE PPS-OPER-HSP-PART ROUNDED =                          15480001
155200         H-OPER-HSP-PCT * H-OPER-HSP-PART.                        15490001
155300                                                                  15500001
155400     COMPUTE PPS-OPER-FSP-PART ROUNDED =                          15510001
155500         H-OPER-FSP-PCT * H-OPER-FSP-PART.                        15520001
155600                                                                  15530001
155700     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =                      15540001
155800             H-OPER-FSP-PCT * H-OPER-OUTLIER-PART.                15550001
155900                                                                  15560001
156000     MOVE ZERO TO PPS-OPER-DSH-ADJ.                               15570001
156100                                                                  15580001
156200     IF  H-OPER-DSH NUMERIC                                       15590001
156300             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =                   15600001
156400             (PPS-OPER-FSP-PART + PPS-OPER-OUTLIER-PART)          15610001
156500              * H-OPER-DSH.                                       15620001
156600                                                                  15630001
156700     COMPUTE PPS-OPER-IME-ADJ ROUNDED =                           15640001
156800         (PPS-OPER-FSP-PART + PPS-OPER-OUTLIER-PART) *            15650001
156900                 H-OPER-IME-TEACH.                                15660001
157000                                                                  15670001
157100***********************************************************       15680001
157200***  CALCULATE FINAL TOTALS FOR CAPITAL                           15690001
157300                                                                  15700001
157400     MOVE P-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.               15710001
157500                                                                  15720001
157600     IF P-CAPI-PPS-PAY-CODE = 'A'                                 15730001
157700        MOVE P-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT              15740001
157800        MOVE 0.00 TO H-CAPI-HSP-PCT.                              15750001
157900                                                                  15760001
158000     IF P-CAPI-PPS-PAY-CODE = 'B'                                 15770001
158100        MOVE 0    TO H-CAPI-OLD-HARMLESS                          15780001
158200        MOVE 1.00 TO H-CAPI-FSP-PCT                               15790001
158300        MOVE 0.00 TO H-CAPI-HSP-PCT.                              15800001
158400                                                                  15810001
158500     IF P-CAPI-PPS-PAY-CODE = 'C'                                 15820001
158600        MOVE 0    TO H-CAPI-OLD-HARMLESS                          15830001
158700        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT                 15840001
158800        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.                15850001
158900                                                                  15860001
159000     COMPUTE H-CAPI-HSP ROUNDED =                                 15870001
159100         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.                        15880001
159200                                                                  15890001
159300     COMPUTE H-CAPI-FSP ROUNDED =                                 15900001
159400         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.                        15910001
159500                                                                  15920001
159600     MOVE P-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.                 15930001
159700                                                                  15940001
159800     COMPUTE H-CAPI-OUTLIER ROUNDED =                             15950001
159900             1.00 * H-CAPI-OUTLIER-PART.                          15960001
160000                                                                  15970001
160100     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =                          15980001
160200             1.00 * H-CAPI2-B-OUTLIER-PART.                       15990001
160300                                                                  16000001
160400     COMPUTE H-CAPI2-B-FSP ROUNDED =                              16010001
160500             1.00 * H-CAPI2-B-FSP-PART.                           16020001
160600                                                                  16030001
160700     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.                 16040001
160800                                                                  16050001
160900     COMPUTE H-CAPI-DSH-ADJ ROUNDED =                             16060001
161000             (H-CAPI-FSP + H-CAPI-OUTLIER-PART)                   16070001
161100              * H-CAPI-DSH.                                       16080001
161200                                                                  16090001
161300     COMPUTE H-CAPI-IME-ADJ ROUNDED =                             16100001
161400         (H-CAPI-FSP + H-CAPI-OUTLIER-PART) *                     16110001
161500                 H-WK-CAPI-IME-TEACH.                             16120001
161600                                                                  16130001
161700***********************************************************       16140001
161800***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER               16150001
161900***        THIS ZEROES OUT ALL CAPITAL DATA                       16160001
162000                                                                  16170001
162100     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE          16180001
162200        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.                   16190001
162300                                                                  16200001
162400     COMPUTE H-CAPI-TOTAL-PAY =                                   16210001
162500             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +        16220001
162600             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +                    16230001
162700             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.                    16240001
162800                                                                  16250001
162900***********************************************************       16260001
163000***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING             16270001
163100                                                                  16280001
163200     COMPUTE PPS-TOTAL-PAYMENT =                                  16290001
163300             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +              16300001
163400             PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +           16310001
163500             PPS-OPER-IME-ADJ                                     16320001
163600                           +                                      16330001
163700                  H-CAPI-TOTAL-PAY.                               16340001
163800                                                                  16350001
163900 3900-CALC-OPER-DSH.                                              16360001
164000***********************************************************       16370001
164100***  OPERATING DSH CALCULATION                                    16380001
164200                                                                  16390001
164300      MOVE .00 TO H-OPER-DSH.                                     16400001
164400                                                                  16410001
164500      COMPUTE H-WK-OPER-DSH = (P-SSI-RATIO                        16420001
164600                                     + P-MEDICAID-RATIO).         16430001
164700                                                                  16440001
164800      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE < 100               16450001
164900                               AND H-WK-OPER-DSH > .3999          16460001
165000        MOVE .05 TO H-OPER-DSH.                                   16470001
165100                                                                  16480001
165200      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99                16490001
165300                               AND H-WK-OPER-DSH > .1499          16500001
165400                               AND H-WK-OPER-DSH < .2021          16510001
165500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        16520001
165600                                      * .65 + .025.               16530001
165700                                                                  16540001
165800      IF W-SIZE = 'R'          AND P-BED-SIZE > 499               16550001
165900                               AND H-WK-OPER-DSH > .1499          16560001
166000                               AND H-WK-OPER-DSH < .2021          16570001
166100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        16580001
166200                                 * .65 + .025.                    16590001
166300                                                                  16600001
166400      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99                16610001
166500                               AND H-WK-OPER-DSH > .202           16620001
166600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       16630001
166700                                 * .8 + .0588.                    16640001
166800                                                                  16650001
166900      IF W-SIZE = 'R'          AND P-BED-SIZE > 499               16660001
167000                               AND H-WK-OPER-DSH > .202           16670001
167100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       16680001
167200                                 * .8 + .0588.                    16690001
167300                                                                  16700001
167400      IF W-SIZE = 'R'          AND P-BED-SIZE < 101               16710001
167500                               AND H-WK-OPER-DSH > .4499          16720001
167600        MOVE .04 TO H-OPER-DSH.                                   16730001
167700                                                                  16740001
167800      IF W-SIZE = 'R'          AND P-BED-SIZE > 100               16750001
167900                               AND P-BED-SIZE < 500               16760001
168000                               AND H-WK-OPER-DSH > .2999          16770001
168100        MOVE .04 TO H-OPER-DSH.                                   16780001
168200                                                                  16790001
168300      IF W-SIZE = 'R'                                             16800001
168400         IF (P-PROVIDER-TYPE = '01' OR '16')                      16810001
168500                               AND H-WK-OPER-DSH > .2999          16820001
168600                               AND P-BED-SIZE < 500               16830001
168700            MOVE .10 TO H-OPER-DSH.                               16840001
168800                                                                  16850001
168900      IF W-SIZE = 'R'                                             16860001
169000         IF (P-PROVIDER-TYPE = '07')                              16870001
169100                               AND H-WK-OPER-DSH > .2999          16880001
169200                               AND P-BED-SIZE > 100               16890001
169300                               AND P-BED-SIZE < 500               16900001
169400            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)     16910001
169500                                 * .6 + .04.                      16920001
169600                                                                  16930001
169700      IF W-SIZE = 'R'                                             16940001
169800         IF (P-PROVIDER-TYPE = '11' OR '17')                      16950001
169900                               AND H-WK-OPER-DSH > .2999          16960001
170000                               AND P-BED-SIZE < 500               16970001
170100            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)     16980001
170200                                 * .6 + .04.                      16990001
170300                                                                  17000001
170400      IF W-SIZE = 'R'                                             17010001
170500         IF (P-PROVIDER-TYPE = '11' OR '17')                      17020001
170600                               AND H-WK-OPER-DSH > .2999          17030001
170700                               AND P-BED-SIZE < 500               17040001
170800                               AND H-OPER-DSH < .10               17050001
170900            MOVE .10 TO H-OPER-DSH.                               17060001
171000                                                                  17070001
171100      IF (P-PROVIDER-TYPE = '19' OR '20')                         17080001
171200          IF P-BED-SIZE < 100 AND H-WK-OPER-DSH > .3999           17090001
171300             COMPUTE H-OPER-DSH ROUNDED = (1 / 3 * H-OPER-DSH) +  17100001
171400                    (2 / 3 * .05).                                17110001
171500                                                                  17120001
171600      IF (P-PROVIDER-TYPE = '19' OR '20')                         17130001
171700          IF P-BED-SIZE > 99                                      17140001
171800                               AND H-WK-OPER-DSH > .1499          17150001
171900                               AND H-WK-OPER-DSH < .2021          17160001
172000             COMPUTE H-OPER-DSH ROUNDED = (1 / 3 * H-OPER-DSH) +  17170001
172100            (2 / 3 * ((H-WK-OPER-DSH - .15) * .65 + .025)).       17180001
172200                                                                  17190001
172300      IF (P-PROVIDER-TYPE = '19' OR '20')                         17200001
172400          IF P-BED-SIZE > 99                                      17210001
172500                               AND H-WK-OPER-DSH > .202           17220001
172600             COMPUTE H-OPER-DSH ROUNDED = (1 / 3 * H-OPER-DSH) +  17230001
172700            (2 / 3 * ((H-WK-OPER-DSH - .202) * .8 + .0588)).      17240001
172800                                                                  17250001
172900******        L A S T   S O U R C E   S T A T E M E N T   *****   17260001
