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