000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.           PPCAL998.                                  00020030
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     'PPCAL998      - W O R K I N G   S T O R A G E'.             00180030
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C99.8'.     00190030
002000***************************************************************   00200000
002100*    IF YOU ARE A HMO, YOU WANT TO PAY CLAIMS AS A HMO         *  00210000
002200*     - CHANGE THE HMO-FLAG 01 TO THE VALUE OF 'Y'                00220000
002300*     - CHANGE ALL PPCAL___ PROGRAMS BACK TO PPCAL983             00230005
002400*        BEFORE YOU COMPILE AND LINK THIS PROGRAM                 00240000
002500*     - THIS WILL ALLOW YOU TO PAY ALL YOUR CLAIMS WITH           00250000
002600*        AN 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  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.         00300000
003100 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES. 00310000
003200 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES. 00320000
003300 01  R1                             PIC S9(04) COMP SYNC.         00330000
003400 01  R2                             PIC S9(04) COMP SYNC.         00340000
003500 01  R3                             PIC S9(04) COMP SYNC.         00350000
003600 01  R4                             PIC S9(04) COMP SYNC.         00360000
003700                                                                  00370000
003800***************************************************************   00380000
003900*    LAYUP TABLE AREA FOR FY99 RATES                          *   00390000
004000***************************************************************   00400000
004100***************************************************************   00410000
004200 01  RATE-TABLE.                                                  00420000
004300     02  RATE-WORK.                                               00430000
004400*RATE 19981001 REGION  LABOR AND NON-LABOR RATES                  00440000
004500*                  R3=1     /     R3=2     /     R3=3             00450000
004600*               LARGE URBAN /OTHER URBAN & / ALL RURAL            00460000
004700*                           /REFERRAL CTR  /                      00470000
004800*              LABOR / NON  / LABOR / NON  / LABOR / NON          00480000
004900*                    /LABOR /       /LABOR /       /LABOR         00490000
005000*             --------------------------------------------        00500000
005100         05  FILLER PIC X(08) VALUE '19981001'.                   00510000
005200         05  NE01   PIC X(45) VALUE                               00520000
005300            ' 0278342 113138 0273936 111347 0273936 111347'.      00530000
005400         05  MA02   PIC X(45) VALUE                               00540000
005500            ' 0278342 113138 0273936 111347 0273936 111347'.      00550000
005600         05  SA03   PIC X(45) VALUE                               00560000
005700            ' 0278342 113138 0273936 111347 0273936 111347'.      00570000
005800         05  ENC04  PIC X(45) VALUE                               00580000
005900            ' 0278342 113138 0273936 111347 0273936 111347'.      00590000
006000         05  ESC05  PIC X(45) VALUE                               00600000
006100            ' 0278342 113138 0273936 111347 0273936 111347'.      00610000
006200         05  WNC06  PIC X(45) VALUE                               00620000
006300            ' 0278342 113138 0273936 111347 0273936 111347'.      00630000
006400         05  WSC07  PIC X(45) VALUE                               00640000
006500            ' 0278342 113138 0273936 111347 0273936 111347'.      00650000
006600         05  MNT08  PIC X(45) VALUE                               00660000
006700            ' 0278342 113138 0273936 111347 0273936 111347'.      00670000
006800         05  PAC09  PIC X(45) VALUE                               00680000
006900            ' 0278342 113138 0273936 111347 0273936 111347'.      00690000
007000         05  NTL10  PIC X(45) VALUE                               00700000
007100            ' 0278342 113138 0273936 111347 0273936 111347'.      00710000
007200         05  PR11   PIC X(45) VALUE                               00720000
007300            ' 0132781 053448 0130679 052601 0130679 052601'.      00730000
007400         05  NPR12  PIC X(45) VALUE                               00740000
007500            ' 0276001 112187 0276001 112187 0276001 112187'.      00750000
007600*************************************************************     00760000
007700*RATE 19990301 REGION  LABOR AND NON-LABOR RATES                  00770000
007800*                  R3=1     /     R3=2     /     R3=3             00780000
007900*               LARGE URBAN /OTHER URBAN & / ALL RURAL            00790000
008000*                           /REFERRAL CTR  /                      00800000
008100*              LABOR / NON  / LABOR / NON  / LABOR / NON          00810000
008200*                    /LABOR /       /LABOR /       /LABOR         00820000
008300*             --------------------------------------------        00830000
008400         05  FILLER PIC X(08) VALUE '19990301'.                   00840000
008500         05  NE01   PIC X(45) VALUE                               00850000
008600            ' 0278334 113134 0273928 111344 0273928 111344'.      00860000
008700         05  MA02   PIC X(45) VALUE                               00870000
008800            ' 0278334 113134 0273928 111344 0273928 111344'.      00880000
008900         05  SA03   PIC X(45) VALUE                               00890000
009000            ' 0278334 113134 0273928 111344 0273928 111344'.      00900000
009100         05  ENC04  PIC X(45) VALUE                               00910000
009200            ' 0278334 113134 0273928 111344 0273928 111344'.      00920000
009300         05  ESC05  PIC X(45) VALUE                               00930000
009400            ' 0278334 113134 0273928 111344 0273928 111344'.      00940000
009500         05  WNC06  PIC X(45) VALUE                               00950000
009600            ' 0278334 113134 0273928 111344 0273928 111344'.      00960000
009700         05  WSC07  PIC X(45) VALUE                               00970000
009800            ' 0278334 113134 0273928 111344 0273928 111344'.      00980000
009900         05  MNT08  PIC X(45) VALUE                               00990000
010000            ' 0278334 113134 0273928 111344 0273928 111344'.      01000000
010100         05  PAC09  PIC X(45) VALUE                               01010000
010200            ' 0278334 113134 0273928 111344 0273928 111344'.      01020000
010300         05  NTL10  PIC X(45) VALUE                               01030000
010400            ' 0278334 113134 0273928 111344 0273928 111344'.      01040000
010500         05  PR11   PIC X(45) VALUE                               01050000
010600            ' 0132781 053448 0130679 052602 0130679 052602'.      01060000
010700         05  NPR12  PIC X(45) VALUE                               01070000
010800            ' 0275994 112183 0275994 112183 0275994 112183'.      01080000
010900     02  RATE-TAB REDEFINES RATE-WORK.                            01090000
011000         05  RATE-PERIOD            OCCURS 2.                     01100000
011100             10  RATE-EFF-DATE      PIC X(08).                    01110000
011200             10  REG-NAT            OCCURS 12.                    01120000
011300                 15  R-URBAN-RURAL  OCCURS 3.                     01130000
011400                     20  FILLER     PIC X(01).                    01140000
011500                     20  REG-LABOR  PIC 9(05)V9(02).              01150000
011600                     20  FILLER     PIC X(01).                    01160000
011700                     20  REG-NLABOR PIC 9(04)V9(02).              01170000
011800                                                                  01180000
011900                                                                  01190000
012000***************************************************************   01200000
012100*    LAYUP TABLE AREA FOR FY99 DRGS                           *   01210000
012200***************************************************************   01220000
012300 01  DRG-TABLE.                                                   01230000
012400     05  D-TAB.                                                   01240000
012500      10  FILLER                  PIC X(08) VALUE                 01250000
012600     '19981001'.                                                  01260000
012700      10  FILLER                  PIC X(56) VALUE                 01270000
012800     '03069406831096031113075321010194931273712702327805129077'.  01280000
012900       10  FILLER                  PIC X(56) VALUE                01290000
013000     '01485102724036007712021230300239380683110101290102225032'.  01300000
013100       10  FILLER                  PIC X(56) VALUE                01310000
013200     '01287304829067012107050290690082450312704200903004829067'.  01320000
013300       10  FILLER                  PIC X(56) VALUE                01330000
013400     '00781004428055011955049290640073140312303901069304529059'.  01340000
013500       10  FILLER                  PIC X(56) VALUE                01350000
013600     '00617802721034009269043280560064550302503802610207932105'.  01360000
013700       10  FILLER                  PIC X(56) VALUE                01370000
013800     '01475305129068008985036280470077640322704300957703828051'.  01380000
013900       10  FILLER                  PIC X(56) VALUE                01390000
014000     '00589302721034007277025240330131300342705401170004228060'.  01400000
014100       10  FILLER                  PIC X(56) VALUE                01410000
014200     '00637702624035003297020170200081050322704400515802218030'.  01420000
014300       10  FILLER                  PIC X(56) VALUE                01430000
014400     '00207201609016010091041280550059070272303600689101305015'.  01440000
014500       10  FILLER                  PIC X(56) VALUE                01450000
014600     '00963702527037004841019160260056970151102000789502126032'.  01460000
014700       10  FILLER                  PIC X(56) VALUE                01470000
014800     '00335601607016006030016110210043710272203400609004227051'.  01480000
014900       10  FILLER                  PIC X(56) VALUE                01490000
015000     '00681402820035007521036280470046170252203300295602927029'.  01500000
015100       10  FILLER                  PIC X(56) VALUE                01510000
015200     '01756703728050008283016090200086010182002800861401914024'.  01520000
015300       10  FILLER                  PIC X(56) VALUE                01530000
015400     '01143202326037004792032220320089520202203000900802119028'.  01540000
015500       10  FILLER                  PIC X(56) VALUE                01550000
015600     '00887602625035002721015040150067000181402400207301504015'.  01560000
015700       10  FILLER                  PIC X(56) VALUE                01570000
015800     '01158602727046002934013050130132830302704401217704428067'.  01580000
015900       10  FILLER                  PIC X(56) VALUE                01590000
016000     '00516202416030005402026190330082300302203800669903423042'.  01600000
016100       10  FILLER                  PIC X(56) VALUE                01610000
016200     '00505302817033003841021130250076300322403900652402826038'.  01620000
016300       10  FILLER                  PIC X(56) VALUE                01630000
016400     '00750403327044003334021200210318110813210202687608432113'.  01640000
016500       10  FILLER                  PIC X(56) VALUE                01650000
016600     '01156503427049014047063300740163090673108400914704729059'.  01660000
016700       10  FILLER                  PIC X(56) VALUE                01670000
016800     '01509806130061013606053290710095440442805600506802620033'.  01680000
016900       10  FILLER                  PIC X(56) VALUE                01690000
017000     '01235105129067006835030260390136500482906400953004428054'.  01700000
017100       10  FILLER                  PIC X(56) VALUE                01710000
017200     '01083805229063006644038210450072090332204001204205129064'.  01720000
017300       10  FILLER                  PIC X(56) VALUE                01730000
017400     '00771103526044011879049290650060420312303900789104026049'.  01740000
017500       10  FILLER                  PIC X(56) VALUE                01750000
017600     '00591903220038006953036280490067380231803000515001710021'.  01760000
017700       10  FILLER                  PIC X(56) VALUE                01770000
017800     '00829203327044005395022160281779023165650507282409934125'.  01780000
017900       10  FILLER                  PIC X(56) VALUE                01790000
018000     '05709907932098073690091331090550300953310705976408633113'.  01800000
018100       10  FILLER                  PIC X(56) VALUE                01810000
018200     '04071807029080041500074310970221990512905901989302827039'.  01820000
018300       10  FILLER                  PIC X(56) VALUE                01830000
018400     '02738909834130015077060300840355580633008802483303027042'.  01840000
018500       10  FILLER                  PIC X(56) VALUE                01850000
018600     '01237202727040015716020210290130760322705401963004929082'.  01860000
018700       10  FILLER                  PIC X(56) VALUE                01870000
018800     '01633405730070011286036240440148480262704401379303427045'.  01880000
018900       10  FILLER                  PIC X(56) VALUE                01890000
019000     '01013402217029025837097341270101310432805500764105325060'.  01900000
019100       10  FILLER                  PIC X(56) VALUE                01910000
019200     '01089801823030009427049290600060670392704700669802518032'.  01920000
019300       10  FILLER                  PIC X(56) VALUE                01930000
019400     '00555602013025005823027200350085430332704400573502418030'.  01940000
019500       10  FILLER                  PIC X(56) VALUE                01950000
019600     '00813503327033007999031260410049770211402600595702417030'.  01960000
019700       10  FILLER                  PIC X(56) VALUE                01970000
019800     '00702203024039005312022150280052630181102301112203828053'.  01980000
019900       10  FILLER                  PIC X(56) VALUE                01990000
020000     '00631602217029027175090331030158900612506703423110334123'.  02000000
020100       10  FILLER                  PIC X(56) VALUE                02010000
020200     '01569206322069027419089331090128080482905901940607031083'.  02020000
020300       10  FILLER                  PIC X(56) VALUE                02030000
020400     '01192505121056041847103341340135410362804700837806030060'.  02040000
020500       10  FILLER                  PIC X(56) VALUE                02050000
020600     '01208203928054006416021150260128780372805000741102214027'.  02060000
020700       10  FILLER                  PIC X(56) VALUE                02070000
020800     '01071002927041006108017100200086640211102102321207331085'.  02080000
020900       10  FILLER                  PIC X(56) VALUE                02090000
021000     '01226904322050014446040280510085220241302801164203127046'.  02100000
021100       10  FILLER                  PIC X(56) VALUE                02110000
021200     '00721901916026028030079321130116580362804801314305229071'.  02120000
021300       10  FILLER                  PIC X(56) VALUE                02130000
021400     '00732002827040009933040280490052980251503001105304328055'.  02140000
021500       10  FILLER                  PIC X(56) VALUE                02150000
021600     '00861403726046006317027170320110540502906400917404228054'.  02160000
021700       10  FILLER                  PIC X(56) VALUE                02170000
021800     '00525902919035007690034270440055770241703000545702521033'.  02180000
021900       10  FILLER                  PIC X(56) VALUE                02190000
022000     '00829203327045003193029230290073850302704001075804128056'.  02200000
022100       10  FILLER                  PIC X(56) VALUE                02210000
022200     '00559302421032007519039280540443451083514601725305429067'.  02220000
022300       10  FILLER                  PIC X(56) VALUE                02230000
022400     '03327610334125016646058300690278880833209801635704929057'.  02240000
022500       10  FILLER                  PIC X(56) VALUE                02250000
022600     '02384507131086011996040210460238650773210203280007431116'.  02260000
022700       10  FILLER                  PIC X(56) VALUE                02270000
022800     '03605310434144013158051290680130000512906901212204729061'.  02280000
022900       10  FILLER                  PIC X(56) VALUE                02290000
023000     '01212704929066006947031270410106950402805200616902317029'.  02300000
023100       10  FILLER                  PIC X(56) VALUE                02310000
023200     '02180304918055018128061280710125050471705200841303222038'.  02320000
023300       10  FILLER                  PIC X(56) VALUE                02330000
023400     '01638306230084000000000000000000000000000002127507031099'.  02340000
023500       10  FILLER                  PIC X(56) VALUE                02350000
023600     '02794408733130014641042280530099240281603300580305329053'.  02360000
023700       10  FILLER                  PIC X(56) VALUE                02370000
023800     '00000000000000000000000000000092550201502600787101709021'.  02380000
023900       10  FILLER                  PIC X(56) VALUE                02390000
024000     '01012203027044014081040280590079220211602701003802326034'.  02400000
024100       10  FILLER                  PIC X(56) VALUE                02410000
024200     '00705801814024011072031270450129230302704601089202326038'.  02420000
024300       10  FILLER                  PIC X(56) VALUE                02430000
024400     '02062805329076011731028240360075240392805400724304128053'.  02440000
024500       10  FILLER                  PIC X(56) VALUE                02450000
024600     '00538402923037013409067310890096530502906401225205029067'.  02460000
024700       10  FILLER                  PIC X(56) VALUE                02470000
024800     '00590303124040010371052290680071420382804900704803928050'.  02480000
024900       10  FILLER                  PIC X(56) VALUE                02490000
025000     '00493902924037005647031240390055340262303500744503628047'.  02500000
025100       10  FILLER                  PIC X(56) VALUE                02510000
025200     '00652002627036006752032270420046210231803000252101815018'.  02520000
025300       10  FILLER                  PIC X(56) VALUE                02530000
025400     '00718103728049004309027190340029350292702900758303828051'.  02540000
025500       10  FILLER                  PIC X(56) VALUE                02550000
025600     '00919802415030007228019080210088370202303100624101405015'.  02560000
025700       10  FILLER                  PIC X(56) VALUE                02570000
025800     '00913101712022008729029270420200640883311901109005429072'.  02580000
025900       10  FILLER                  PIC X(56) VALUE                02590000
026000     '01479604228065008262025250340092930292704601066902326036'.  02600000
026100       10  FILLER                  PIC X(56) VALUE                02610000
026200     '01579805630079007206022230310100070573007201042104929064'.  02620000
026300       10  FILLER                  PIC X(56) VALUE                02630000
026400     '00626003628048011119048290680053050262703600640703627045'.  02640000
026500       10  FILLER                  PIC X(56) VALUE                02650000
026600     '00834204829059005548038220450066570432505000662803327043'.  02660000
026700       10  FILLER                  PIC X(56) VALUE                02670000
026800     '00453502419031002552022190220069380362804800439902621033'.  02680000
026900       10  FILLER                  PIC X(56) VALUE                02690000
027000     '02042508132110022199055290700185910803211202022704729059'.  02700000
027100       10  FILLER                  PIC X(56) VALUE                02710000
027200     '01011702222032009166019130250057720150701802598007531108'.  02720000
027300       10  FILLER                  PIC X(56) VALUE                02730000
027400     '01279403828055007478038280490072420302504000849704128054'.  02740000
027500       10  FILLER                  PIC X(56) VALUE                02750000
027600     '00520202921037005262024260370088000392805401080104829063'.  02760000
027700       10  FILLER                  PIC X(56) VALUE                02770000
027800     '00602002923038036406086331010265970753209202336106530090'.  02780000
027900       10  FILLER                  PIC X(56) VALUE                02790000
028000     '01134103223039012401038280550064100201102401516604128060'.  02800000
028100       10  FILLER                  PIC X(56) VALUE                02810000
028200     '00907602114026010629030270430060730160902000987702927043'.  02820000
028300       10  FILLER                  PIC X(56) VALUE                02830000
028400     '00628601814024004918023260230207030462908001331505029069'.  02840000
028500       10  FILLER                  PIC X(56) VALUE                02850000
028600     '00614002020029010921044280610061500222003000866504528056'.  02860000
028700       10  FILLER                  PIC X(56) VALUE                02870000
028800     '00580803420040005406033210410076580242103200434601609019'.  02880000
028900       10  FILLER                  PIC X(56) VALUE                02890000
029000     '00623603026040004200021150280035180312703100717602826037'.  02900000
029100       10  FILLER                  PIC X(56) VALUE                02910000
029200     '00491801713023003168016090160099520422805600623502725036'.  02920020
029300       10  FILLER                  PIC X(56) VALUE                02930000
029400     '00775703528049015975044180500120560341203700885602821036'.  02940000
029500       10  FILLER                  PIC X(56) VALUE                02950000
029600     '00617602009023010867032270480098220292704200281602413024'.  02960000
029700       10  FILLER                  PIC X(56) VALUE                02970000
029800     '01119402119030008555026210340015300170601701041401817026'.  02980000
029900       10  FILLER                  PIC X(56) VALUE                02990000
030000     '00864602527036009494043280580056200232303100689203227043'.  03000000
030100       10  FILLER                  PIC X(56) VALUE                03010000
030200     '00409002117028006918036230440023480130501300625102725036'.  03020000
030300       10  FILLER                  PIC X(56) VALUE                03030000
030400     '01923505630069014953048250580093220321003500786302311026'.  03040000
030500       10  FILLER                  PIC X(56) VALUE                03050000
030600     '02442907331090012111037180440086630280903000890202614032'.  03060000
030700       10  FILLER                  PIC X(56) VALUE                03070000
030800     '01205102322033003001014050140074980251903300728002627036'.  03080000
030900       10  FILLER                  PIC X(56) VALUE                03090000
031000     '01742104629069011912048290690056400221902901054405029064'.  03100000
031100       10  FILLER                  PIC X(56) VALUE                03110000
031200     '00525702321031010501043250550071610320903500571602416031'.  03120000
031300       10  FILLER                  PIC X(56) VALUE                03130000
031400     '00400001808021007120022140310068120442804400487702316029'.  03140000
031500       10  FILLER                  PIC X(56) VALUE                03150000
031600     '01426303427045008441022120260043900222603600416801711022'.  03160000
031700       10  FILLER                  PIC X(56) VALUE                03170000
031800     '00554001611021001965011040130047180272703700357801818027'.  03180000
031900       10  FILLER                  PIC X(56) VALUE                03190000
032000     '01367101826018045084179421790307911333713301857808633086'.  03200000
032100       10  FILLER                  PIC X(56) VALUE                03210000
032200     '01827907632102015908042280600015160311103103292707932104'.  03220000
032300       10  FILLER                  PIC X(56) VALUE                03230000
032400     '01339209133091016195041280700081960342704702197805229180'.  03240000
032500       10  FILLER                  PIC X(56) VALUE                03250000
032600     '01253604028055012463048290600069080302303702654606130094'.  03260000
032700       10  FILLER                  PIC X(56) VALUE                03270000
032800     '02574907732110010114027270390168430583008200830203227045'.  03280000
032900       10  FILLER                  PIC X(56) VALUE                03290000
033000     '01898704929049025688069310950117880352604301820404629075'.  03300000
033100       10  FILLER                  PIC X(56) VALUE                03310000
033200     '01011704328058008402027210340038970222603500504201912023'.  03320000
033300       10  FILLER                  PIC X(56) VALUE                03330000
033400     '01347305429075007146031270420357471053514401488305730074'.  03340000
033500       10  FILLER                  PIC X(56) VALUE                03350000
033600     '01327604529059009894049290620087640402805000633103222040'.  03360000
033700       10  FILLER                  PIC X(56) VALUE                03370000
033800     '00674803123040005668026190330160280583007802348309033143'.  03380000
033900       10  FILLER                  PIC X(56) VALUE                03390000
034000     '00678203027041005525035280490055880342704800711404529073'.  03400000
034100       10  FILLER                  PIC X(56) VALUE                03410000
034200     '00871005229074008079062300880074680462907300708503427053'.  03420000
034300       10  FILLER                  PIC X(56) VALUE                03430000
034400     '00302502323032007007039280520041510352704400814511435141'.  03440000
034500       10  FILLER                  PIC X(56) VALUE                03450000
034600     '00702307732092000000000000000158000502907701799305730090'.  03460000
034700       10  FILLER                  PIC X(56) VALUE                03470000
034800     '01010602326035022652052290810092920252303300711503527045'.  03480000
034900       10  FILLER                  PIC X(56) VALUE                03490000
035000     '00481202621034002943024220240049380191502500096802917029'.  03500000
035100       10  FILLER                  PIC X(56) VALUE                03510000
035200     '00785002727038004321016100210026140211702100979903628051'.  03520000
035300       10  FILLER                  PIC X(56) VALUE                03530000
035400     '00485902218029008448032270470046750191702700000000000000'.  03540000
035500       10  FILLER                  PIC X(56) VALUE                03550000
035600     '00000000000000000000000000000000000000000000000000000000'.  03560000
035700       10  FILLER                  PIC X(56) VALUE                03570000
035800     '01068402426044014071101341270067380332704400499602621034'.  03580000
035900       10  FILLER                  PIC X(56) VALUE                03590000
036000     '00524701920029006121023260400049410232604403658209533135'.  03600000
036100       10  FILLER                  PIC X(56) VALUE                03610000
036200     '00000000000000000000000000000332460532306100000000000000'.  03620000
036300       10  FILLER                  PIC X(56) VALUE                03630000
036400     '03474107632130000000000000000374290813211302218208933119'.  03640000
036500       10  FILLER                  PIC X(56) VALUE                03650000
036600     '01754505329082023355051290750142300302603810645519343268'.  03660000
036700       10  FILLER                  PIC X(56) VALUE                03670000
036800     '10213824949279036031100341281633953405842305338009533148'.  03680000
036900       10  FILLER                  PIC X(56) VALUE                03690000
037000     '03078807732097049966084321250191830552907504576611936172'.  03700000
037100       10  FILLER                  PIC X(56) VALUE                03710000
037200     '01769006230089009705039280540166550311603704542711435172'.  03720000
037300       10  FILLER                  PIC X(56) VALUE                03730000
037400     '01791404228056009973019140240895001353816805427508633106'.  03740000
037500       10  FILLER                  PIC X(56) VALUE                03750000
037600     '02759405029063016863029200350146770382805000971402415029'.  03760000
037700       10  FILLER                  PIC X(56) VALUE                03770000
037800     '02554408432105015539054290660122970322704214115323748318'.  03780000
037900       10  FILLER                  PIC X(56) VALUE                03790000
038000     '01787502326058042478122361680170780663109001417805329079'.  03800000
038100       10  FILLER                  PIC X(56) VALUE                03810000
038200     '00782403427050011630049290700060420352704900000000000000'.  03820000
038300     05  DRGX-TAB REDEFINES D-TAB.                                03830000
038400         10  DRGX-PERIOD               OCCURS 1                   03840000
038500                                        INDEXED BY DX5.           03850000
038600             15  DRGX-EFF-DATE         PIC X(08).                 03860000
038700             15  DRG-DATA              OCCURS 512                 03870000
038800                                        INDEXED BY DX6.           03880000
038900                 20  DRG-WT            PIC 9(02)V9(04).           03890000
039000                 20  DRG-ALOS          PIC 9(02)V9(01).           03900000
039100                 20  DRG-DAYS-TRIM     PIC 9(02).                 03910000
039200                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).           03920000
039300                                                                  03930000
039400 01  HOLD-AREA.                                                   03940000
039500     02  HOLD-PPS-COMPONENTS.                                     03950000
039600         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).        03960000
039700         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).        03970000
039800                                                                  03980000
039900         05  H-OPER-HSP-PART              PIC 9(06)V9(09).        03990000
040000         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).        04000000
040100                                                                  04010000
040200         05  H-OPER-FSP-PART              PIC 9(06)V9(09).        04020000
040300         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).        04030000
040400         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).        04040000
040500                                                                  04050000
040600         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).        04060000
040700         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).        04070000
040800         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).        04080000
040900                                                                  04090000
041000         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).        04100000
041100         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).        04110000
041200                                                                  04120000
041300         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).        04130000
041400         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).        04140000
041500                                                                  04150000
041600         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).        04160000
041700         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).        04170000
041800                                                                  04180000
041900                                                                  04190000
042000         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).        04200000
042100         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).        04210000
042200         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).        04220000
042300         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).        04230000
042400         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).        04240000
042500         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).        04250000
042600         05  H-CAPI-COLA                  PIC 9(01)V9(03).        04260000
042700         05  H-CAPI-SCH                   PIC 9(05)V9(02).        04270000
042800         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).        04280000
042900         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).        04290000
043000         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).        04300000
043100         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).        04310000
043200         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).        04320000
043300         05  H-CAPI-GAF                   PIC 9(05)V9(04).        04330000
043400         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).        04340000
043500         05  H-BLEND-GAF                  PIC 9(05)V9(04).        04350000
043600         05  H-WAGE-INDEX                 PIC 9(02)V9(04).        04360000
043700         05  H-COV-DAYS                   PIC 9(3).               04370000
043800         05  H-PERDIEM-DAYS               PIC 9(3).               04380000
043900         05  H-REG-DAYS                   PIC 9(3).               04390000
044000         05  H-LTR-DAYS                   PIC 9(3).               04400000
044100         05  H-DSCHG-FRCTN                PIC 9(1)V9999.          04410000
044200         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.          04420000
044300         05  H-ALOS                       PIC 9(02)V9(01).        04430000
044400         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).        04440000
044500         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).        04450000
044600         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).        04460000
044700         05  H-CST-THRESH                 PIC 9(05)V9(02).        04470000
044800         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).        04480000
044900         05  H-BUDG-NUTR93                PIC 9(01)V9(06).        04490000
045000         05  H-BUDG-NUTR94                PIC 9(01)V9(06).        04500000
045100         05  H-BUDG-NUTR95                PIC 9(01)V9(06).        04510000
045200         05  H-BUDG-NUTR96                PIC 9(01)V9(06).        04520000
045300         05  H-BUDG-NUTR97                PIC 9(01)V9(06).        04530000
045400         05  H-BUDG-NUTR98                PIC 9(01)V9(06).        04540000
045500         05  H-BUDG-NUTR99                PIC 9(01)V9(06).        04550000
045600         05  H-UPDATE-95                  PIC 9(01)V9(03).        04560000
045700         05  H-UPDATE-96                  PIC 9(01)V9(03).        04570000
045800         05  H-UPDATE-97                  PIC 9(01)V9(03).        04580000
045900         05  H-UPDATE-98                  PIC 9(01)V9(03).        04590000
046000         05  H-UPDATE-99                  PIC 9(01)V9(03).        04600000
046100         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).        04610000
046200         05  H-HSP-UPDATE94               PIC 9(01)V9(04).        04620000
046300         05  H-HSP-UPDATE95               PIC 9(01)V9(04).        04630000
046400         05  H-HSP-UPDATE96               PIC 9(01)V9(04).        04640000
046500         05  H-HSP-UPDATE97               PIC 9(01)V9(04).        04650000
046600         05  H-HSP-UPDATE98               PIC 9(01)V9(04).        04660000
046700         05  H-HSP-UPDATE99               PIC 9(01)V9(04).        04670000
046800         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).        04680000
046900         05  H-FEDERAL-RATE               PIC 9(04)V9(02).        04690000
047000         05  H-LABOR-PCT                  PIC 9(01)V9(04).        04700000
047100         05  H-NONLABOR-PCT               PIC 9(01)V9(04).        04710000
047200         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).        04720000
047300         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).        04730000
047400         05  H-HSP-RATE                   PIC 9(06)V9(09).        04740000
047500         05  H-FSP-RATE                   PIC 9(06)V9(09).        04750000
047600         05  H-OUTLIER-FACT               PIC 9(01)V9(06).        04760000
047700         05  H-WK-OPER-DSH                PIC 9(01)V9(04).        04770000
047800         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).        04780000
047900         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).        04790000
048000         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).        04800000
048100         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).        04810000
048200         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.           04820000
048300                                                                  04830000
048400                                                                  04840000
048500     02  HOLD-ADDITIONAL-VARIABLES.                               04850000
048600         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).        04860000
048700         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).        04870000
048800         05  H-NAT-PCT                    PIC 9(01)V9(02).        04880000
048900         05  H-REG-PCT                    PIC 9(01)V9(02).        04890000
049000         05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).        04900000
049100         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).        04910000
049200         05  H-DRG-WT                     PIC 9(02)V9(04).        04920000
049300         05  H-NAT-LABOR                  PIC 9(05)V9(02).        04930000
049400         05  H-NAT-NONLABOR               PIC 9(05)V9(02).        04940000
049500         05  H-REG-LABOR                  PIC 9(05)V9(02).        04950000
049600         05  H-REG-NONLABOR               PIC 9(05)V9(02).        04960000
049700         05  H-OPER-COLA                  PIC 9(01)V9(03).        04970000
049800         05  H-INTERN-RATIO               PIC 9(01)V9(04).        04980000
049900         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).        04990000
050000         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).        05000000
050100         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).        05010000
050200                                                                  05020000
050300     02  HOLD-CAPITAL-VARIABLES.                                  05030000
050400         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).        05040000
050500         05  H-CAPI-HSP                   PIC 9(07)V9(02).        05050000
050600         05  H-CAPI-FSP                   PIC 9(07)V9(02).        05060000
050700         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).        05070000
050800         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).        05080000
050900         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).        05090000
051000         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).        05100000
051100         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).        05110000
051200                                                                  05120000
051300     02  HOLD-CAPITAL2-VARIABLES.                                 05130000
051400         05  H-CAPI2-PAY-CODE             PIC X(1).               05140000
051500         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).        05150000
051600         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).        05160000
051700                                                                  05170000
051800     02  HOLD-OTHER-VARIABLES.                                    05180000
051900         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).        05190000
052000         05  FILLER                       PIC X(30).              05200000
052100                                                                  05210000
052200     02  HOLD-PC-OTH-VARIABLES.                                   05220000
052300         05  H-OPER-DSH                   PIC 9(01)V9(04).        05230000
052400         05  H-CAPI-DSH                   PIC 9(01)V9(04).        05240000
052500         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).        05250000
052600         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).        05260000
052700         05  H-ARITH-ALOS                 PIC 9(02)V9(01).        05270000
052800         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).        05280000
052900         05  H-TRANSFER-ADJ               PIC 9(01)V9(05).        05290000
053000         05  H-PC-HMO-FLAG                PIC X(01).              05300000
053100         05  H-PC-COT-FLAG                PIC X(01).              05310000
053200         05  H-FILLER                     PIC X(09).              05320000
053300                                                                  05330000
053400 LINKAGE SECTION.                                                 05340000
053500***************************************************************   05350000
053600*                 * * * * * * * * *                           *   05360000
053700*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *   05370000
053800*    IN HOW TO PAY THE BILL.                                  *   05380000
053900*                         *****                               *   05390000
054000*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *   05400000
054100*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *   05410000
054200*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *   05420000
054300*                 OUTLIER COMPUTATION.                        *   05430000
054400*                         *****                               *   05440000
054500*         REVIEW-CODE:                                        *   05450000
054600*            00 = PAY-WITH-OUTLIER.                           *   05460000
054700*                 WILL CALCULATE THE STANDARD PAYMENT.        *   05470000
054800*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *   05480000
054900*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *   05490000
055000*            03 = PAY-PERDIEM-DAYS.                           *   05500000
055100*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   05510000
055200*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *   05520000
055300*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   05530000
055400*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   05540000
055500*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   05550000
055600*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *   05560000
055700*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   05570000
055800*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *   05580000
055900*                 BILL EXCEED THE COST THRESHOLD.             *   05590000
056000*            06 = PAY-XFER-NO-COST                            *   05600000
056100*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   05610000
056200*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *   05620000
056300*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   05630000
056400*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *   05640000
056500*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   05650000
056600*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *   05660000
056700*                 CALCULATE ANY COST OUTLIER PORTION          *   05670000
056800*                 OF THE PAYMENT.                             *   05680000
056900*            07 = PAY-WITHOUT-COST.                           *   05690000
057000*                 WILL CALCULATE THE STANDARD PAYMENT         *   05700000
057100*                 WITHOUT COST PORTION.                       *   05710000
057200*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *   05720000
057300*                 FOR DRG'S 209,210,211,014,113,236,263,264,  *   05730000
057400*                 429,483.      POST-ACUTE TRANSFERS          *   05740000
057500*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   05750000
057600*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*   05760000
057700*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   05770000
057800*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   05780000
057900*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   05790000
058000*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *   05800000
058100*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   05810000
058200*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *   05820000
058300*                 BILL EXCEED THE COST THRESHOLD.             *   05830000
058400*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *   05840000
058500*                 POST-ACUTE TRANSFERS                        *   05850000
058600*                 FOR DRG'S 209,210,211,014,113,236,263,264,  *   05860000
058700*                 429,483.      POST-ACUTE TRANSFERS          *   05870000
058800*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   05880000
058900*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*   05890000
059000*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   05900000
059100*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   05910000
059200*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   05920000
059300*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *   05930000
059400*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   05940000
059500*                 PAYMENT.                                    *   05950000
059600***************************************************************   05960000
059700                                                                  05970000
059800**************************************************************    05980000
059900*      MILLINNIUM COMPATIBLE                                 *    05990000
060000*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *    06000000
060100*      THE PPCAL994 PROGRAM AND AFTER FOR PROCESSING         *    06010015
060200*      IN THE NEW FORMAT                                     *    06020000
060300**************************************************************    06030000
060400 01  BILL-NEW-DATA.                                               06040000
060500         10  B-NPI10.                                             06050000
060600             15  B-NPI8             PIC X(08).                    06060000
060700             15  B-NPI-FILLER       PIC X(02).                    06070000
060800         10  B-PROVIDER-NO          PIC X(06).                    06080000
060900         10  B-REVIEW-CODE          PIC 9(02).                    06090000
061000             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.    06100000
061100             88  PAY-WITH-OUTLIER     VALUE 00 07.                06110000
061200             88  PAY-PERDIEM-DAYS     VALUE 03.                   06120000
061300             88  PAY-XFER-NO-COST     VALUE 06.                   06130000
061400             88  PAY-WITHOUT-COST     VALUE 07.                   06140000
061500             88  PAY-XFER-SPEC-DRG    VALUE 09 11.                06150000
061600             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.              06160000
061700         10  B-DRG                  PIC 9(03).                    06170000
061800         10  B-LOS                  PIC 9(03).                    06180000
061900         10  B-COVERED-DAYS         PIC 9(03).                    06190000
062000         10  B-LTR-DAYS             PIC 9(02).                    06200000
062100         10  B-DISCHARGE-DATE.                                    06210000
062200             15  B-DISCHG-CC        PIC 9(02).                    06220000
062300             15  B-DISCHG-YY        PIC 9(02).                    06230000
062400             15  B-DISCHG-MM        PIC 9(02).                    06240000
062500             15  B-DISCHG-DD        PIC 9(02).                    06250000
062600         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).              06260000
062610         10  B-PRIN-PROC-CODE       PIC X(07).                    06261015
062620         10  B-OTHER-PROC-CODE1     PIC X(07).                    06262015
062630         10  B-OTHER-PROC-CODE2     PIC X(07).                    06263015
062640         10  B-OTHER-PROC-CODE3     PIC X(07).                    06264015
062650         10  B-OTHER-PROC-CODE4     PIC X(07).                    06265015
062660         10  B-OTHER-PROC-CODE5     PIC X(07).                    06266015
062670         10  B-OTHER-PROC-CODE6     PIC X(07).                    06267015
062680         10  B-OTHER-PROC-CODE7     PIC X(07).                    06268015
062690         10  B-OTHER-PROC-CODE8     PIC X(07).                    06269015
062691         10  B-OTHER-PROC-CODE9     PIC X(07).                    06269115
062692         10  B-OTHER-PROC-CODE10    PIC X(07).                    06269215
062693         10  B-OTHER-PROC-CODE11    PIC X(07).                    06269315
062694         10  B-OTHER-PROC-CODE12    PIC X(07).                    06269415
062695         10  B-OTHER-PROC-CODE13    PIC X(07).                    06269515
062696         10  B-OTHER-PROC-CODE14    PIC X(07).                    06269615
062697         10  B-OTHER-PROC-CODE15    PIC X(07).                    06269715
062698         10  B-OTHER-PROC-CODE16    PIC X(07).                    06269815
062699         10  B-OTHER-PROC-CODE17    PIC X(07).                    06269915
062700         10  B-OTHER-PROC-CODE18    PIC X(07).                    06270015
062701         10  B-OTHER-PROC-CODE19    PIC X(07).                    06270115
062702         10  B-OTHER-PROC-CODE20    PIC X(07).                    06270215
062703         10  B-OTHER-PROC-CODE21    PIC X(07).                    06270315
062704         10  B-OTHER-PROC-CODE22    PIC X(07).                    06270415
062705         10  B-OTHER-PROC-CODE23    PIC X(07).                    06270515
062706         10  B-OTHER-PROC-CODE24    PIC X(07).                    06270615
062707         10  B-OTHER-DIAG-CODE1     PIC X(07).                    06270716
062708         10  B-OTHER-DIAG-CODE2     PIC X(07).                    06270816
062709         10  B-OTHER-DIAG-CODE3     PIC X(07).                    06270916
062710         10  B-OTHER-DIAG-CODE4     PIC X(07).                    06271016
062711         10  B-OTHER-DIAG-CODE5     PIC X(07).                    06271116
062712         10  B-OTHER-DIAG-CODE6     PIC X(07).                    06271216
062713         10  B-OTHER-DIAG-CODE7     PIC X(07).                    06271316
062714         10  B-OTHER-DIAG-CODE8     PIC X(07).                    06271416
062715         10  B-OTHER-DIAG-CODE9     PIC X(07).                    06271516
062716         10  B-OTHER-DIAG-CODE10    PIC X(07).                    06271616
062717         10  B-OTHER-DIAG-CODE11    PIC X(07).                    06271716
062718         10  B-OTHER-DIAG-CODE12    PIC X(07).                    06271816
062719         10  B-OTHER-DIAG-CODE13    PIC X(07).                    06271916
062720         10  B-OTHER-DIAG-CODE14    PIC X(07).                    06272016
062721         10  B-OTHER-DIAG-CODE15    PIC X(07).                    06272116
062722         10  B-OTHER-DIAG-CODE16    PIC X(07).                    06272216
062723         10  B-OTHER-DIAG-CODE17    PIC X(07).                    06272316
062724         10  B-OTHER-DIAG-CODE18    PIC X(07).                    06272416
062725         10  B-OTHER-DIAG-CODE19    PIC X(07).                    06272516
062726         10  B-OTHER-DIAG-CODE20    PIC X(07).                    06272616
062727         10  B-OTHER-DIAG-CODE21    PIC X(07).                    06272716
062728         10  B-OTHER-DIAG-CODE22    PIC X(07).                    06272816
062729         10  B-OTHER-DIAG-CODE23    PIC X(07).                    06272916
062730         10  B-OTHER-DIAG-CODE24    PIC X(07).                    06273016
062731         10  B-OTHER-DIAG-CODE25    PIC X(07).                    06273116
062732         10  BILL-DEMO-DATA.                                      06273222
062733             15  BILL-DEMO-CODE1        PIC X(02).                06273322
062734             15  BILL-DEMO-CODE2        PIC X(02).                06273422
062735             15  BILL-DEMO-CODE3        PIC X(02).                06273522
062736             15  BILL-DEMO-CODE4        PIC X(02).                06273622
062737         10  BILL-NDC-DATA.                                       06273722
062738             15  BILL-NDC-NUMBER        PIC X(11).                06273822
062739         10  FILLER                     PIC X(73).                06273922
062740                                                                  06274022
062741                                                                  06274116
062750                                                                  06275000
062800***************************************************************   06280000
062900*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *   06290000
063000*    AND PASSED BACK TO THE CALLING PROGRAM                   *   06300000
063100*            RETURN CODE VALUES (PPS-RTC)                     *   06310000
063200*                                                             *   06320000
063300*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   06330000
063400*              00 = PAID NORMAL DRG PAYMENT                   *   06340000
063500*                                                             *   06350000
063600*              01 = PAID AS A DAY-OUTLIER.                    *   06360000
063700*                   NOTE:                                     *   06370000
063800*                     DAY-OUTLIER NO LONGER BEING PAID        *   06380000
063900*                         AS OF 10/01/97                      *   06390000
064000*                                                             *   06400000
064100*              02 = PAID AS A COST-OUTLIER.                   *   06410000
064200*                                                             *   06420000
064300*              03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   06430000
064400*                   AND INCLUDING THE FULL DRG.               *   06440000
064500*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   06450000
064600*                   AND INCLUDING THE FULL DRG WHICH ALSO     *   06460000
064700*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *   06470000
064800*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   06480000
064900*                   AND INCLUDING THE FULL DRG. PROVIDER      *   06490000
065000*                   REFUSED COST OUTLIER.                     *   06500000
065100*              10 = DRG IS 209, 210 OR 211 AND                *   06510000
065200*                   POST-ACUTE TRANSFER                       *   06520000
065300*              12 = POST-CAUTE TRANSFER WITH SPECIFIC DRGS    *   06530000
065400*                       THE FOLLOWING DRG'S                   *   06540000
065500*                   14,113,236,263,264,429,483                *   06550000
065600*              14 = PAID NORMAL DRG PAYMENT WITH              *   06560000
065700*                    PERDIEM DAYS = OR > GM  ALOS             *   06570000
065800*              16 = PAID AS A COST-OUTLIER WITH               *   06580000
065900*                    PERDIEM DAYS = OR > GM  ALOS             *   06590000
066000*                                                             *   06600000
066100*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   06610000
066200*              51 = NO PROVIDER SPECIFIC INFO FOUND           *   06620000
066300*              52 = INVALID MSA # IN PROVIDER FILE            *   06630000
066400*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   06640000
066500*              54 = DRG < 001 OR > 511, OR = 214 OR = 215     *   06650000
066600*                                       OR = 221 OR = 222     *   06660000
066700*                                       OR = 438 OR = 456     *   06670000
066800*                                       OR = 457 OR = 458     *   06680000
066900*                                       OR = 459 OR = 460     *   06690000
067000*                                       OR = 469 OR = 470     *   06700000
067100*                                       OR = 472 OR = 474     *   06710000
067200*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   06720000
067300*                                      OR                     *   06730000
067400*                   DISCHARGE DATE < MSA EFF START DATE       *   06740000
067500*                   FOR PPS                                   *   06750000
067600*              56 = INVALID LENGTH OF STAY                    *   06760000
067700*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09)  *   06770000
067800*              58 = TOTAL CHARGES NOT NUMERIC                 *   06780000
067900*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   06790000
068000*                   OR BILL-LTR-DAYS > 60                     *   06800000
068100*              62 = INVALID NUMBER OF COVERED DAYS            *   06810000
068200*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *   06820000
068300*                   SPECIFIC FILE FOR CAPITAL                 *   06830000
068400*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   06840000
068500*                   OR COST OUTLIER THRESHOLD CALUCULATION    *   06850000
068600*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *   06860000
068700***************************************************************   06870000
068800 01  PPS-DATA.                                                    06880000
068900         10  PPS-RTC                PIC 9(02).                    06890000
069000         10  PPS-WAGE-INDX          PIC 9(02)V9(04).              06900000
069100         10  PPS-OUTLIER-DAYS       PIC 9(03).                    06910000
069200         10  PPS-AVG-LOS            PIC 9(02)V9(01).              06920000
069300         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).              06930000
069400         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).              06940000
069500         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).              06950000
069600         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).              06960000
069700         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).              06970000
069800         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).              06980000
069900         10  PPS-REG-DAYS-USED      PIC 9(03).                    06990000
070000         10  PPS-LTR-DAYS-USED      PIC 9(02).                    07000000
070100         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).              07010000
070200         10  PPS-CALC-VERS          PIC X(05).                    07020000
070300                                                                  07030000
070400******************************************************************07040000
070500*            THESE ARE THE VERSIONS OF THE PPCAL                  07050000
070600*           PROGRAMS THAT WILL BE PASSED BACK----                 07060000
070700*          ASSOCIATED WITH THE BILL BEING PROCESSED               07070000
070800******************************************************************07080000
070900 01  PRICER-OPT-VERS-SW.                                          07090000
071000     02  PRICER-OPTION-SW          PIC X(01).                     07100000
071100         88  ALL-TABLES-PASSED          VALUE 'A'.                07110000
071200         88  PROV-RECORD-PASSED         VALUE 'P'.                07120000
071300         88  ADDITIONAL-VARIABLES       VALUE 'M'.                07130000
071400         88  PC-PRICER                  VALUE 'C'.                07140000
071500     02  PPS-VERSIONS.                                            07150000
071600         10  PPDRV-VERSION         PIC X(05).                     07160000
071700                                                                  07170000
071800******************************************************************07180000
071900*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK           07190000
072000*          ASSOCIATED WITH THE BILL BEING PROCESSED               07200000
072100******************************************************************07210000
072200 01  PPS-ADDITIONAL-VARIABLES.                                    07220000
072300     05  PPS-HSP-PCT                PIC 9(01)V9(02).              07230000
072400     05  PPS-FSP-PCT                PIC 9(01)V9(02).              07240000
072500     05  PPS-NAT-PCT                PIC 9(01)V9(02).              07250000
072600     05  PPS-REG-PCT                PIC 9(01)V9(02).              07260000
072700     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).              07270000
072800     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).              07280000
072900     05  PPS-DRG-WT                 PIC 9(02)V9(04).              07290000
073000     05  PPS-NAT-LABOR              PIC 9(05)V9(02).              07300000
073100     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).              07310000
073200     05  PPS-REG-LABOR              PIC 9(05)V9(02).              07320000
073300     05  PPS-REG-NLABOR             PIC 9(05)V9(02).              07330000
073400     05  PPS-OPER-COLA              PIC 9(01)V9(03).              07340000
073500     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).              07350000
073600     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).              07360000
073700     05  PPS-BILL-COSTS             PIC 9(07)V9(09).              07370000
073800     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).              07380000
073900     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.                07390000
074000     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.                07400000
074100     05  PPS-CAPITAL-VARIABLES.                                   07410000
074200         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).        07420000
074300         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).        07430000
074400         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).        07440000
074500         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).        07450000
074600         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).        07460000
074700         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).        07470000
074800         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).        07480000
074900         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).        07490000
075000     05  PPS-CAPITAL2-VARIABLES.                                  07500000
075100         10  PPS-CAPI2-PAY-CODE             PIC X(1).             07510000
075200         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).      07520000
075300         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).      07530000
075400                                                                  07540000
075500     05  PPS-OTHER-VARIABLES.                                     07550000
075600         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).      07560000
075610         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).      07561015
075621         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).      07562122
075622         10  PPS-HVBP-HRR-DATA.                                   07562222
075623             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.              07562322
075624             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).        07562422
075625             15  PPS-HOSP-READMISS-REDUCTN    PIC X.              07562522
075626             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).         07562628
075627         10  PPS-OPERATNG-DATA.                                   07562722
075628             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.            07562829
075629             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.        07562922
075630             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.        07563022
075800                                                                  07580000
075900     05  PPS-PC-OTH-VARIABLES.                                    07590000
076000         10  PPS-OPER-DSH                   PIC 9(01)V9(04).      07600000
076100         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).      07610000
076200         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).      07620000
076300         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).      07630000
076400         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).      07640000
076500         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).      07650000
076600         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(05).      07660000
076700         10  PPS-PC-HMO-FLAG                PIC X(01).            07670000
076800         10  PPS-PC-COT-FLAG                PIC X(01).            07680000
076810         10  PPS-FILLER                     PIC X(0998).          07681029
077000                                                                  07700000
077100**************************************************************    07710000
077200*      MILLINNIUM COMPATIBLE                                 *    07720000
077300*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BACK FROM *    07730000
077400*      THE PPCAL994 PROGRAM AND AFTER FOR PROCESSING         *    07740015
077500*      IN THE NEW FORMAT                                     *    07750000
077600**************************************************************    07760000
077700 01  PROV-NEW-HOLD.                                               07770000
077800     02  PROV-NEWREC-HOLD1.                                       07780000
077900         05  P-NEW-NPI10.                                         07790000
078000             10  P-NEW-NPI8             PIC X(08).                07800000
078100             10  P-NEW-NPI-FILLER       PIC X(02).                07810000
078200         05  P-NEW-PROVIDER-NO.                                   07820000
078300             10  P-NEW-STATE            PIC 9(02).                07830000
078400             10  FILLER                 PIC X(04).                07840000
078500         05  P-NEW-DATE-DATA.                                     07850000
078600             10  P-NEW-EFF-DATE.                                  07860000
078700                 15  P-NEW-EFF-DT-CC    PIC 9(02).                07870000
078800                 15  P-NEW-EFF-DT-YY    PIC 9(02).                07880000
078900                 15  P-NEW-EFF-DT-MM    PIC 9(02).                07890000
079000                 15  P-NEW-EFF-DT-DD    PIC 9(02).                07900000
079100             10  P-NEW-FY-BEGIN-DATE.                             07910000
079200                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                07920000
079300                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                07930000
079400                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                07940000
079500                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                07950000
079600             10  P-NEW-REPORT-DATE.                               07960000
079700                 15  P-NEW-REPORT-DT-CC PIC 9(02).                07970000
079800                 15  P-NEW-REPORT-DT-YY PIC 9(02).                07980000
079900                 15  P-NEW-REPORT-DT-MM PIC 9(02).                07990000
080000                 15  P-NEW-REPORT-DT-DD PIC 9(02).                08000000
080100             10  P-NEW-TERMINATION-DATE.                          08010000
080200                 15  P-NEW-TERM-DT-CC   PIC 9(02).                08020000
080300                 15  P-NEW-TERM-DT-YY   PIC 9(02).                08030000
080400                 15  P-NEW-TERM-DT-MM   PIC 9(02).                08040000
080500                 15  P-NEW-TERM-DT-DD   PIC 9(02).                08050000
080600         05  P-NEW-WAIVER-CODE          PIC X(01).                08060000
080700             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              08070000
080800         05  P-NEW-INTER-NO             PIC 9(05).                08080000
080900         05  P-NEW-PROVIDER-TYPE        PIC X(02).                08090000
081000             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.      08100000
081100             88  P-N-REFERRAL-CENTER        VALUE '07' '11'       08110000
081200                                                  '15' '17'       08120000
081300                                                  '22'.           08130000
081400             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.           08140000
081500             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.           08150000
081600             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.           08160000
081700             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.           08170000
081800             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.      08180000
081900             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.           08190000
082000             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.      08200000
082100             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.           08210000
082200             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.           08220000
082300             88  P-N-EACH                   VALUE '21' '22'.      08230000
082400             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.           08240000
082500             88  P-N-NHCMQ-II-SNF           VALUE '32'.           08250000
082600             88  P-N-NHCMQ-III-SNF          VALUE '33'.           08260000
082700         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                08270000
082800             88  P-N-NEW-ENGLAND            VALUE  1.             08280000
082900             88  P-N-MIDDLE-ATLANTIC        VALUE  2.             08290000
083000             88  P-N-SOUTH-ATLANTIC         VALUE  3.             08300000
083100             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.             08310000
083200             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.             08320000
083300             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.             08330000
083400             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.             08340000
083500             88  P-N-MOUNTAIN               VALUE  8.             08350000
083600             88  P-N-PACIFIC                VALUE  9.             08360000
083700         05  P-NEW-CURRENT-DIV   REDEFINES                        08370000
083800                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         08380000
083900             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.          08390000
084000         05  P-NEW-MSA-DATA.                                      08400000
084100             10  P-NEW-CHG-CODE-INDEX       PIC X.                08410000
084200             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 08420000
084300             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   08430000
084400                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       08440000
084500             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 08450000
084600             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 08460000
084700             10  P-NEW-STAND-AMT-LOC-MSA9                         08470000
084800       REDEFINES P-NEW-STAND-AMT-LOC-MSA.                         08480000
084900                 15  P-NEW-RURAL-1ST.                             08490000
085000                     20  P-NEW-STAND-RURAL  PIC XX.               08500000
085100                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    08510000
085200                 15  P-NEW-RURAL-2ND        PIC XX.               08520000
085300         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    08530000
085400                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           08540000
085500                 88  P-NEW-SCH-YR82       VALUE   '82'.           08550000
085600                 88  P-NEW-SCH-YR87       VALUE   '87'.           08560000
085700         05  P-NEW-LUGAR                    PIC X.                08570000
085800         05  P-NEW-TEMP-RELIEF-IND          PIC X.                08580000
085900         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                08590000
086000         05  FILLER                         PIC X(05).            08600000
086100     02  PROV-NEWREC-HOLD2.                                       08610000
086200         05  P-NEW-VARIABLES.                                     08620000
086300             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        08630000
086400             10  P-NEW-COLA              PIC  9(01)V9(03).        08640000
086500             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        08650000
086600             10  P-NEW-BED-SIZE          PIC  9(05).              08660000
086700             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        08670000
086800             10  P-NEW-CMI               PIC  9(01)V9(04).        08680000
086900             10  P-NEW-SSI-RATIO         PIC  V9(04).             08690000
087000             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             08700000
087100             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              08710000
087200             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        08720000
087300             10  P-NEW-DSH-PERCENT       PIC  V9(04).             08730000
087400             10  P-NEW-FYE-DATE          PIC  X(08).              08740000
087500         05  FILLER                      PIC  X(23).              08750000
087600     02  PROV-NEWREC-HOLD3.                                       08760000
087700         05  P-NEW-PASS-AMT-DATA.                                 08770000
087800             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          08780000
087900             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          08790000
088000             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          08800000
088100             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          08810000
088200         05  P-NEW-CAPI-DATA.                                     08820000
088300             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 08830000
088400             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          08840000
088500             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          08850000
088600             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        08860000
088700             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             08870000
088800             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 08880000
088900             15  P-NEW-CAPI-IME            PIC 9V9999.            08890000
089000             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          08900000
089001         05  P-HVBP-HRR-DATA.                                     08900122
089002             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.                08900222
089003             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).          08900322
089004             15  P-HOSP-READMISSION-REDUCTN PIC X.                08900422
089005             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).           08900528
089006         05  P-MODEL1-BUNDLE-DATA.                                08900622
089007             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.             08900729
089008             15  P-HAC-REDUC-IND            PIC X.                08900831
089009             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.         08900931
089010             15  P-EHR-REDUC-IND            PIC X.                08901031
089011         05  FILLER                         PIC X(09).            08901131
089012                                                                  08901231
089020************************************************************      08902022
089200******************************************************************08920000
089300*      MILLINNIUM COMPATIBLE                                      08930000
089400*                   THIS IS THE WAGE-INDEX                        08940000
089500*          ASSOCIATED WITH THE BILL BEING PROCESSED               08950000
089600******************************************************************08960000
089700 01  WAGE-NEW-INDEX-RECORD.                                       08970000
089800     05  W-MSA                         PIC X(4).                  08980000
089900     05  W-SIZE                        PIC X.                     08990000
090000         88  LARGE-URBAN       VALUE 'L'.                         09000000
090100         88  OTHER-URBAN       VALUE 'O'.                         09010000
090200         88  ALL-RURAL         VALUE 'R'.                         09020000
090300     05  W-EFF-DATE                    PIC X(8).                  09030000
090400     05  FILLER                        PIC X.                     09040000
090500     05  W-INDEX-RECORD                PIC S9(02)V9(04).          09050000
090600     05  W-PR-INDEX-RECORD             PIC S9(02)V9(04).          09060000
090700                                                                  09070000
090800                                                                  09080000
090900 PROCEDURE DIVISION  USING BILL-NEW-DATA                          09090000
091000                           PPS-DATA                               09100000
091100                           PRICER-OPT-VERS-SW                     09110000
091200                           PPS-ADDITIONAL-VARIABLES               09120000
091300                           PROV-NEW-HOLD                          09130000
091400                           WAGE-NEW-INDEX-RECORD.                 09140000
091500                                                                  09150000
091600***************************************************************   09160000
091700*    PROCESSING:                                              *   09170000
091800*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE            09180000
091900*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *   09190000
092000*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *   09200000
092100*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *   09210000
092200*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   09220000
092300*           GOBACK.                                           *   09230000
092400*        D. ASSEMBLE PRICING COMPONENTS.                      *   09240000
092500*        E. CALCULATE THE PRICE.                              *   09250000
092600***************************************************************   09260000
092700                                                                  09270000
092800     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.                      09280000
092900     MOVE 'N' TO TEMP-RELIEF-FLAG.                                09290000
093000                                                                  09300000
093100     PERFORM 0200-MAINLINE-CONTROL.                               09310000
093200                                                                  09320000
093300     IF P-NEW-TEMP-RELIEF-IND  = 'Y'                              09330000
093400        MOVE PPS-TOTAL-PAYMENT TO NON-TEMP-RELIEF-PAYMENT         09340000
093500        MOVE 'Y' TO TEMP-RELIEF-FLAG                              09350000
093600        PERFORM 0200-MAINLINE-CONTROL                             09360000
093700        MOVE NON-TEMP-RELIEF-PAYMENT TO                           09370000
093800                      H-NON-TEMP-RELIEF-PAYMENT.                  09380000
093900                                                                  09390000
094000     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES. 09400000
094100     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.          09410000
094200     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.         09420000
094300     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.    09430000
094400     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.   09440000
094500     MOVE CAL-VERSION               TO  PPS-CALC-VERS.            09450000
094600     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.      09460000
094700     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.     09470000
094800                                                                  09480000
094900     GOBACK.                                                      09490000
095000                                                                  09500000
095100 0200-MAINLINE-CONTROL.                                           09510000
095200                                                                  09520000
095300     MOVE 'N' TO HMO-TAG.                                         09530000
095400                                                                  09540000
095500     IF PPS-PC-HMO-FLAG = 'Y' OR                                  09550000
095600               HMO-FLAG = 'Y'                                     09560000
095700        MOVE 'Y' TO HMO-TAG.                                      09570000
095800                                                                  09580000
095900     IF P-NEW-STATE NOT = 40                                      09590000
096000        MOVE ZEROES TO W-PR-INDEX-RECORD.                         09600000
096100                                                                  09610000
096200     MOVE ALL '0' TO PPS-DATA                                     09620000
096300                     HOLD-PPS-COMPONENTS                          09630000
096400                     HOLD-ADDITIONAL-VARIABLES                    09640000
096500                     HOLD-CAPITAL-VARIABLES                       09650000
096600                     HOLD-CAPITAL2-VARIABLES                      09660000
096700                     HOLD-OTHER-VARIABLES                         09670000
096800                     HOLD-PC-OTH-VARIABLES.                       09680000
096900                                                                  09690000
097000     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC                     09700000
097100        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.                      09710000
097200                                                                  09720000
097300     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC                     09730000
097400        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.                       09740000
097500                                                                  09750000
097600     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC                     09760000
097700        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.                      09770000
097800                                                                  09780000
097900     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC                       09790000
098000        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.                        09800000
098100                                                                  09810000
098200     PERFORM 1000-EDIT-THE-BILL-INFO.                             09820000
098300                                                                  09830000
098400     IF  PPS-RTC = 00                                             09840000
098500         PERFORM 2000-ASSEMBLE-PPS-VARIABLES                      09850000
098600         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.                09860000
098700                                                                  09870000
098800     IF PPS-RTC = 00                                              09880000
098900        IF H-PERDIEM-DAYS = H-ALOS OR                             09890000
099000           H-PERDIEM-DAYS > H-ALOS                                09900000
099100           MOVE 14 TO PPS-RTC.                                    09910000
099200                                                                  09920000
099300     IF PPS-RTC = 02                                              09930000
099400        IF H-PERDIEM-DAYS = H-ALOS OR                             09940000
099500           H-PERDIEM-DAYS > H-ALOS                                09950000
099600           MOVE 16 TO PPS-RTC.                                    09960000
099700                                                                  09970000
099800 1000-EDIT-THE-BILL-INFO.                                         09980000
099900***************************************************************   09990000
100000*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   10000000
100100*    AND DO NOT ATTEMPT TO PRICE.                             *   10010000
100200***************************************************************   10020000
100300                                                                  10030000
100400     IF P-NEW-FY-BEGIN-DATE < 19981001                            10040000
100500        MOVE .70 TO H-CAPI-PAYCDE-PCT1                            10050000
100600        MOVE .30 TO H-CAPI-PAYCDE-PCT2                            10060000
100700     ELSE                                                         10070000
100800        IF (P-NEW-FY-BEGIN-DATE < B-DISCHARGE-DATE) OR            10080000
100900           (P-NEW-FY-BEGIN-DATE = B-DISCHARGE-DATE)               10090000
101000              MOVE .80 TO H-CAPI-PAYCDE-PCT1                      10100000
101100              MOVE .20 TO H-CAPI-PAYCDE-PCT2                      10110000
101200        ELSE                                                      10120000
101300              MOVE .70 TO H-CAPI-PAYCDE-PCT1                      10130000
101400              MOVE .30 TO H-CAPI-PAYCDE-PCT2.                     10140000
101500                                                                  10150000
101600     IF  PPS-RTC = 00                                             10160000
101700         IF  P-NEW-WAIVER-STATE                                   10170000
101800             MOVE 53 TO PPS-RTC.                                  10180000
101900                                                                  10190000
102000     IF  PPS-RTC = 00                                             10200000
102100         IF  B-DRG < 001 OR > 511 OR = 214 OR = 215               10210000
102200                                  OR = 221 OR = 222               10220000
102300                                  OR = 438 OR = 456               10230000
102400                                  OR = 457 OR = 458               10240000
102500                                  OR = 459 OR = 460               10250000
102600                                  OR = 469 OR = 470               10260000
102700                                  OR = 472 OR = 474               10270000
102800             MOVE 54 TO PPS-RTC.                                  10280000
102900                                                                  10290000
103000     IF  PPS-RTC = 00                                             10300000
103100            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR           10310000
103200                 (B-DISCHARGE-DATE < W-EFF-DATE))                 10320000
103300                MOVE 55 TO PPS-RTC.                               10330000
103400                                                                  10340000
103500     IF  PPS-RTC = 00                                             10350000
103600         IF  B-LOS NOT NUMERIC                                    10360000
103700             MOVE 56 TO PPS-RTC                                   10370000
103800         ELSE                                                     10380000
103900         IF  B-LOS = 0                                            10390000
104000             IF B-REVIEW-CODE NOT = 03 AND                        10400000
104100                              NOT = 06 AND                        10410000
104200                              NOT = 09 AND                        10420000
104300                              NOT = 11                            10430000
104400             MOVE 56 TO PPS-RTC.                                  10440000
104500                                                                  10450000
104600     IF  PPS-RTC = 00                                             10460000
104700         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60            10470000
104800             MOVE 61 TO PPS-RTC                                   10480000
104900         ELSE                                                     10490000
105000             MOVE B-LTR-DAYS TO H-LTR-DAYS.                       10500000
105100                                                                  10510000
105200     IF  PPS-RTC = 00                                             10520000
105300         IF  B-COVERED-DAYS NOT NUMERIC                           10530000
105400             MOVE 62 TO PPS-RTC                                   10540000
105500         ELSE                                                     10550000
105600         IF  B-COVERED-DAYS = 0 AND B-LOS > 0                     10560000
105700             MOVE 62 TO PPS-RTC                                   10570000
105800         ELSE                                                     10580000
105900             MOVE B-COVERED-DAYS TO H-COV-DAYS.                   10590000
106000                                                                  10600000
106100     IF  PPS-RTC = 00                                             10610000
106200         IF  H-LTR-DAYS  > H-COV-DAYS                             10620000
106300             MOVE 62 TO PPS-RTC                                   10630000
106400         ELSE                                                     10640000
106500             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.        10650000
106600                                                                  10660000
106700     IF  PPS-RTC = 00                                             10670000
106800         IF  NOT VALID-REVIEW-CODE                                10680000
106900             MOVE 57 TO PPS-RTC.                                  10690000
107000                                                                  10700000
107100     IF  PPS-RTC = 00                                             10710000
107200         IF  B-CHARGES-CLAIMED NOT NUMERIC                        10720000
107300             MOVE 58 TO PPS-RTC.                                  10730000
107400                                                                  10740000
107500     IF PPS-RTC = 00                                              10750000
107600           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'                       10760000
107700                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND         10770000
107800                                            NOT = 'B' AND         10780000
107900                                            NOT = 'C'             10790000
108000                 MOVE 65 TO PPS-RTC.                              10800000
108100                                                                  10810000
108200 2000-ASSEMBLE-PPS-VARIABLES.                                     10820000
108300***************************************************************   10830000
108400*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   10840000
108500*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   10850000
108600*    OF THAT VARIABLE.                                        *   10860000
108700***************************************************************   10870000
108800***  GET THE PROVIDER SPECIFIC VARIABLES.                         10880000
108900***  GET THE PROVIDER SPECIFIC VARIABLES.                         10890000
109000                                                                  10900000
109100     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.                 10910000
109200     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.                   10920000
109300                                                                  10930000
109400     IF  (P-NEW-STATE = 02 OR 12)                                 10940000
109500         MOVE P-NEW-COLA TO H-OPER-COLA                           10950000
109600     ELSE                                                         10960000
109700         MOVE 1.000  TO H-OPER-COLA.                              10970000
109800                                                                  10980000
109900***************************************************************   10990000
110000***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF              11000000
110100***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF              11010000
110200                                                                  11020000
110300     PERFORM 2600-GET-DRG-WEIGHT                                  11030000
110400             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.               11040000
110500                                                                  11050000
110600***************************************************************   11060000
110700***  GET THE WAGE-INDEX                                           11070000
110800***  GET THE WAGE-INDEX                                           11080000
110900                                                                  11090000
111000     MOVE W-INDEX-RECORD TO H-WAGE-INDEX.                         11100000
111100     MOVE W-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.                   11110000
111200                                                                  11120000
111300***************************************************************   11130000
111400***  GET THE LABOR, NON-LABOR STANDARD RATES                      11140000
111500                                                                  11150000
111600     IF  P-N-VALID-CENSUS-DIV                                     11160000
111700         MOVE P-NEW-CURRENT-CENSUS-DIV TO R2                      11170000
111800     ELSE                                                         11180000
111900         MOVE 10 TO R2.                                           11190000
112000                                                                  11200000
112100     MOVE 10 TO R4.                                               11210000
112200                                                                  11220000
112300     IF  P-NEW-STATE = 40                                         11230000
112400         MOVE 11 TO R2                                            11240000
112500         MOVE 12 TO R4.                                           11250000
112600                                                                  11260000
112700     IF  LARGE-URBAN                                              11270000
112800         MOVE 1 TO R3                                             11280000
112900     ELSE                                                         11290000
113000     IF  OTHER-URBAN OR P-N-REFERRAL-CENTER                       11300000
113100         MOVE 2 TO R3                                             11310000
113200     ELSE                                                         11320000
113300         MOVE 3 TO R3.                                            11330000
113400                                                                  11340000
113500     PERFORM 2300-GET-LABOR-NLABOR-RATES                          11350000
113600             VARYING R1 FROM 1 BY 1 UNTIL R1 > 2.                 11360000
113700                                                                  11370000
113800     IF TEMP-RELIEF-FLAG = 'Y'                                    11380000
113900        COMPUTE H-REG-LABOR ROUNDED =                             11390000
114000                H-REG-LABOR * 1.008 / 1.005                       11400000
114100        COMPUTE H-REG-NONLABOR ROUNDED =                          11410000
114200                H-REG-NONLABOR * 1.008 / 1.005                    11420000
114300        COMPUTE H-NAT-LABOR ROUNDED =                             11430000
114400                H-NAT-LABOR * 1.008 / 1.005                       11440000
114500        COMPUTE H-NAT-NONLABOR ROUNDED =                          11450000
114600                H-NAT-NONLABOR * 1.008 / 1.005.                   11460000
114700                                                                  11470000
114800***************************************************************   11480000
114900***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL               11490000
115000***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL               11500000
115100                                                                  11510000
115200     MOVE 0.00  TO H-OPER-HSP-PCT.                                11520000
115300     MOVE 1.00  TO H-OPER-FSP-PCT.                                11530000
115400                                                                  11540000
115500***************************************************************   11550000
115600***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL     11560000
115700***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL     11570000
115800                                                                  11580000
115900      MOVE 1.00 TO H-NAT-PCT.                                     11590000
116000      MOVE 0.00 TO H-REG-PCT.                                     11600000
116100                                                                  11610000
116200     IF  P-NEW-STATE = 40                                         11620000
116300         MOVE 0.50 TO H-NAT-PCT                                   11630000
116400         MOVE 0.50 TO H-REG-PCT.                                  11640000
116500                                                                  11650000
116600     IF  P-N-SCH-REBASED-FY90 OR                                  11660000
116700         P-N-EACH OR                                              11670000
116800         P-N-MDH-REBASED-FY90                                     11680000
116900         MOVE 1.00 TO H-OPER-HSP-PCT.                             11690000
117000                                                                  11700000
117100 2300-GET-LABOR-NLABOR-RATES.                                     11710000
117200                                                                  11720000
117300     IF  B-DISCHARGE-DATE NOT < RATE-EFF-DATE (R1)                11730000
117400         MOVE REG-LABOR  (R1 R2 R3) TO H-REG-LABOR                11740000
117500         MOVE REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR             11750000
117600         MOVE REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR                11760000
117700         MOVE REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.            11770000
117800                                                                  11780000
117900 2600-GET-DRG-WEIGHT.                                             11790000
118000     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)               11800000
118100         SET DX6 TO B-DRG                                         11810000
118200         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT                11820000
118300         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS                  11830000
118400*****    MOVE DRG-DAYS-TRIM (DX5 DX6)  TO H-DAYS-CUTOFF           11840000
118500         MOVE ZEROES                   TO H-DAYS-CUTOFF           11850000
118600         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.           11860000
118700                                                                  11870000
118800 3000-CALC-PAYMENT.                                               11880000
118900***************************************************************   11890000
119000*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   11900000
119100*        CALCULATE THE STAY UTILIZATION.                      *   11910000
119200*        CALCULATE THE FEDERAL PORTION.                       *   11920000
119300*        CALCULATE THE HOSPITAL PORTION.                      *   11930000
119400*        CALCULATE THE COST-OUTLIER PORTION.                  *   11940000
119500*        CALCULATE THE TOTAL PAYMENT OPERATING AND CAPITAL    *   11950000
119600*        CALCULATE THE DSH ADJUSTMENT.                        *   11960000
119700*        CALCULATE THE IME TEACHING.                          *   11970000
119800***************************************************************   11980000
119900     PERFORM 3100-CALC-STAY-UTILIZATION.                          11990000
120000     PERFORM 3300-CALC-OPER-FSP-AMT.                              12000000
120100     PERFORM 3900-CALC-OPER-DSH.                                  12010000
120200***********************************************************       12020000
120300***  OPERATING IME CALCULATION                                    12030000
120400***  OPERATING IME CALCULATION                                    12040000
120500                                                                  12050000
120600         COMPUTE H-OPER-IME-TEACH ROUNDED =                       12060000
120700            1.60 * ((1 + H-INTERN-RATIO) ** .405  - 1).           12070000
120800                                                                  12080000
120900***********************************************************       12090000
121000                                                                  12100000
121100     IF P-N-SCH-REBASED-FY90 OR                                   12110000
121200        P-N-EACH OR                                               12120000
121300        P-N-MDH-REBASED-FY90                                      12130000
121400         PERFORM 3450-CALC-ADDITIONAL-HSP.                        12140000
121500                                                                  12150000
121600     MOVE 00                 TO  PPS-RTC.                         12160000
121700     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.                   12170000
121800     MOVE H-ALOS             TO  PPS-AVG-LOS.                     12180000
121900     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.                 12190000
122000                                                                  12200000
122100     MOVE B-LOS TO H-PERDIEM-DAYS.                                12210000
122200     IF H-PERDIEM-DAYS < 1                                        12220000
122300         MOVE 1 TO H-PERDIEM-DAYS.                                12230000
122400     ADD 1 TO H-PERDIEM-DAYS.                                     12240000
122500                                                                  12250000
122600     MOVE 1 TO H-DSCHG-FRCTN.                                     12260000
122700                                                                  12270000
122800     IF  (PAY-PERDIEM-DAYS OR                                     12280000
122900          PAY-XFER-NO-COST) OR                                    12290006
123000        (PAY-XFER-SPEC-DRG AND                                    12300006
123100               (B-DRG = 014 OR 113 OR 236 OR                      12310006
123200                        263 OR 264 OR 429 OR 483))                12320006
123300         COMPUTE H-DSCHG-FRCTN ROUNDED = H-PERDIEM-DAYS / H-ALOS  12330000
123400         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS.12340006
123500                                                                  12350006
123600     IF (PAY-XFER-SPEC-DRG AND                                    12360006
123700               (B-DRG = 209 OR 210 OR 211))                       12370014
123800         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS 12380006
123900         COMPUTE H-DSCHG-FRCTN ROUNDED =                          12390006
124000                      .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS).      12400013
124100                                                                  12410006
124200     IF H-DSCHG-FRCTN > 1                                         12420006
124300              MOVE 1 TO H-DSCHG-FRCTN                             12430000
124400              MOVE 1 TO H-TRANSFER-ADJ.                           12440000
124500                                                                  12450000
124600     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.   12460000
124700                                                                  12470000
124800     PERFORM 3600-CALC-OUTLIER.                                   12480000
124900                                                                  12490000
125000     IF PPS-RTC = 67  GO TO 3000-CONTINUE.                        12500000
125100                                                                  12510000
125200        IF PAY-PERDIEM-DAYS                                       12520000
125300            IF  H-PERDIEM-DAYS < H-ALOS                           12530000
125400                IF  NOT (B-DRG = 385)                             12540000
125500                    PERFORM 3500-CALC-PERDIEM-AMT                 12550000
125600                    MOVE 03 TO PPS-RTC.                           12560000
125700                                                                  12570000
125800        IF PAY-XFER-SPEC-DRG                                      12580000
125900            IF  H-PERDIEM-DAYS < H-ALOS                           12590000
126000                IF  NOT (B-DRG = 385)                             12600000
126100                    PERFORM 3550-CALC-PERDIEM-AMT.                12610000
126200                                                                  12620000
126300        IF  PAY-PERDIEM-DAYS                                      12630000
126400            IF  H-OPER-OUTCST-PART > 0                            12640000
126500                MOVE H-OPER-OUTCST-PART TO                        12650000
126600                     H-OPER-OUTLIER-PART                          12660000
126700                MOVE 05 TO PPS-RTC                                12670000
126800            ELSE                                                  12680000
126900            IF  PPS-RTC NOT = 03                                  12690000
127000                MOVE 00 TO PPS-RTC                                12700000
127100                MOVE 0  TO H-OPER-OUTLIER-PART.                   12710000
127200                                                                  12720000
127300        IF  PAY-PERDIEM-DAYS                                      12730000
127400            IF  H-CAPI-OUTCST-PART > 0                            12740000
127500                MOVE H-CAPI-OUTCST-PART TO                        12750000
127600                     H-CAPI-OUTLIER-PART                          12760000
127700                MOVE 05 TO PPS-RTC                                12770000
127800            ELSE                                                  12780000
127900            IF  PPS-RTC NOT = 03                                  12790000
128000                MOVE 0  TO H-CAPI-OUTLIER-PART.                   12800000
128100                                                                  12810000
128200        IF  PAY-XFER-NO-COST                                      12820000
128300            MOVE 0  TO H-OPER-OUTLIER-PART                        12830000
128400                       H-CAPI-OUTLIER-PART                        12840000
128500            MOVE 00 TO PPS-RTC                                    12850000
128600            IF H-PERDIEM-DAYS < H-ALOS                            12860000
128700               IF  NOT (B-DRG = 385)                              12870000
128800                   PERFORM 3500-CALC-PERDIEM-AMT                  12880000
128900                   MOVE 06 TO PPS-RTC.                            12890000
129000                                                                  12900000
129100 3000-CONTINUE.                                                   12910000
129200                                                                  12920000
129300***********************************************************       12930000
129400***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF          12940000
129500***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE          12950000
129600                                                                  12960000
129700     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.        12970000
129800                                                                  12980000
129900***********************************************************       12990000
130000                                                                  13000000
130100     IF  PPS-RTC = 67                                             13010000
130200         MOVE H-OPER-DOLLAR-THRESHOLD TO                          13020000
130300              WK-H-OPER-DOLLAR-THRESHOLD.                         13030000
130400                                                                  13040000
130500     IF  PPS-RTC < 50                                             13050000
130600         PERFORM 3800-CALC-TOT-AMT                                13060000
130700     ELSE                                                         13070000
130800         MOVE ALL '0' TO PPS-OPER-HSP-PART                        13080000
130900                         PPS-OPER-FSP-PART                        13090000
131000                         PPS-OPER-OUTLIER-PART                    13100000
131100                         PPS-OUTLIER-DAYS                         13110000
131200                         PPS-REG-DAYS-USED                        13120000
131300                         PPS-LTR-DAYS-USED                        13130000
131400                         PPS-TOTAL-PAYMENT                        13140000
131500                         PPS-OPER-DSH-ADJ                         13150000
131600                         PPS-OPER-IME-ADJ                         13160000
131700                         H-DSCHG-FRCTN                            13170000
131800                         H-DRG-WT-FRCTN                           13180000
131900                         HOLD-ADDITIONAL-VARIABLES                13190000
132000                         HOLD-CAPITAL-VARIABLES                   13200000
132100                         HOLD-CAPITAL2-VARIABLES                  13210000
132200                         HOLD-OTHER-VARIABLES                     13220000
132300                         HOLD-PC-OTH-VARIABLES.                   13230000
132400                                                                  13240000
132500     IF  PPS-RTC = 67                                             13250000
132600         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO                       13260000
132700                 H-OPER-DOLLAR-THRESHOLD.                         13270000
132800                                                                  13280000
132900 3000-EXIT.  EXIT.                                                13290000
133000                                                                  13300000
133100 3100-CALC-STAY-UTILIZATION.                                      13310000
133200                                                                  13320000
133300     MOVE 0 TO PPS-REG-DAYS-USED.                                 13330000
133400     MOVE 0 TO PPS-LTR-DAYS-USED.                                 13340000
133500                                                                  13350000
133600     IF H-REG-DAYS > 0                                            13360000
133700        IF H-REG-DAYS > B-LOS                                     13370000
133800           MOVE B-LOS TO PPS-REG-DAYS-USED                        13380000
133900        ELSE                                                      13390000
134000           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED                   13400000
134100     ELSE                                                         13410000
134200        IF H-LTR-DAYS > B-LOS                                     13420000
134300           MOVE B-LOS TO PPS-LTR-DAYS-USED                        13430000
134400        ELSE                                                      13440000
134500           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.                  13450000
134600                                                                  13460000
134700                                                                  13470000
134800                                                                  13480000
134900 3300-CALC-OPER-FSP-AMT.                                          13490000
135000***********************************************************       13500000
135100***  OPERATING FSP CALCULATION                                    13510000
135200***  OPERATING FSP CALCULATION                                    13520000
135300                                                                  13530000
135400     IF P-NEW-STATE = 40                                          13540000
135500       COMPUTE H-OPER-FSP-PART ROUNDED =                          13550000
135600           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +             13560000
135700            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)             13570000
135800                           +                                      13580000
135900           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +          13590000
136000            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)             13600000
136100                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART        13610000
136200     ELSE                                                         13620000
136300        COMPUTE H-OPER-FSP-PART ROUNDED =                         13630000
136400           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +             13640000
136500            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)             13650000
136600                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.       13660000
136700                                                                  13670000
136800                                                                  13680000
136900 3450-CALC-ADDITIONAL-HSP.                                        13690000
137000***********************************************************       13700000
137100*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR                 13710000
137200*    SOLE COMMUNITY                                               13720000
137300*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)              13730000
137400*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES              13740000
137500***********************************************************       13750000
137600**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE       13760000
137700****    USE ACTUAL FEDERAL REGISTER NUMBER                        13770000
137800                                                                  13780000
137900     MOVE 0.948740 TO H-OUTLIER-FACT.                             13790000
138000***************************************************************   13800000
138100***         GET THE UPDATING FACTOR                               13810000
138200***         GET THE UPDATING FACTOR                               13820000
138300                                                                  13830000
138400     MOVE 0.999851 TO H-BUDG-NUTR93.                              13840000
138500     MOVE 0.999003 TO H-BUDG-NUTR94.                              13850000
138600     MOVE 0.998050 TO H-BUDG-NUTR95.                              13860000
138700     MOVE 0.999306 TO H-BUDG-NUTR96.                              13870000
138800     MOVE 0.998703 TO H-BUDG-NUTR97.                              13880000
138900     MOVE 0.997731 TO H-BUDG-NUTR98.                              13890000
139000                                                                  13900000
139100     IF B-DISCHARGE-DATE < 19990301                               13910000
139200        MOVE 0.999006 TO H-BUDG-NUTR99                            13920000
139300     ELSE                                                         13930000
139400        MOVE 0.998978 TO H-BUDG-NUTR99.                           13940000
139500                                                                  13950000
139600     MOVE 1.014 TO H-UPDATE-95.                                   13960000
139700     MOVE 1.015 TO H-UPDATE-96.                                   13970000
139800     MOVE 1.020 TO H-UPDATE-97.                                   13980000
139900     MOVE 1.000 TO H-UPDATE-98.                                   13990000
140000     MOVE 1.005 TO H-UPDATE-99.                                   14000000
140100                                                                  14010000
140200     COMPUTE H-UPDATE-FACTOR ROUNDED =                            14020000
140300        (H-UPDATE-95 * H-UPDATE-96 *                              14030000
140400         H-UPDATE-97 * H-UPDATE-98 *                              14040000
140500         H-UPDATE-99 *                                            14050000
140600         H-BUDG-NUTR93 * H-BUDG-NUTR94 *                          14060000
140700         H-BUDG-NUTR95 * H-BUDG-NUTR96 *                          14070000
140800         H-BUDG-NUTR97 * H-BUDG-NUTR98 *                          14080000
140900         H-BUDG-NUTR99).                                          14090000
141000                                                                  14100000
141100     COMPUTE H-HSP-RATE ROUNDED =                                 14110000
141200         H-FAC-SPEC-RATE * H-UPDATE-FACTOR.                       14120000
141300                                                                  14130000
141400     IF P-NEW-STATE = 40                                          14140000
141500       COMPUTE H-FSP-RATE ROUNDED =                               14150000
141600         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +              14160000
141700         H-NAT-NONLABOR * H-OPER-COLA))                           14170000
141800                           +                                      14180000
141900          (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +           14190000
142000         H-REG-NONLABOR * H-OPER-COLA)))                          14200000
142100                           *                                      14210000
142200       ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-FACT)     14220000
142300                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE             14230000
142400     ELSE                                                         14240000
142500       COMPUTE H-FSP-RATE ROUNDED =                               14250000
142600         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +               14260000
142700         H-NAT-NONLABOR * H-OPER-COLA))                           14270000
142800                           *                                      14280000
142900       ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-FACT)     14290000
143000                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.            14300000
143100                                                                  14310000
143200     IF  H-HSP-RATE > H-FSP-RATE                                  14320000
143300           COMPUTE H-OPER-HSP-PART ROUNDED =                      14330000
143400             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT                 14340000
143500                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART        14350000
143600     ELSE                                                         14360000
143700         MOVE 0 TO H-OPER-HSP-PART.                               14370000
143800                                                                  14380000
143900***************************************************************   14390000
144000***         GET THE MDH REBASE                                    14400000
144100***     HAS BEEN REVIVED FOR 10/01/97                             14410000
144200                                                                  14420000
144300     IF  H-HSP-RATE > H-FSP-RATE                                  14430000
144400         IF P-NEW-PROVIDER-TYPE = '14' OR '15'                    14440000
144500           COMPUTE H-OPER-HSP-PART ROUNDED =                      14450000
144600             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .5            14460000
144700                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.       14470000
144800                                                                  14480000
144900 3500-CALC-PERDIEM-AMT.                                           14490000
145000***********************************************************       14500000
145100***  REVIEW CODE = 03 OR 06                                       14510000
145200***  OPERATING PERDIEM-AMT CALCULATION                            14520000
145300***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS              14530000
145400                                                                  14540000
145500        COMPUTE H-OPER-HSP-PART ROUNDED =                         14550000
145600        H-OPER-HSP-PART * H-TRANSFER-ADJ                          14560000
145700        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.                  14570000
145800                                                                  14580000
145900        COMPUTE H-OPER-FSP-PART ROUNDED =                         14590000
146000        H-OPER-FSP-PART * H-TRANSFER-ADJ                          14600000
146100        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  14610000
146200                                                                  14620000
146300***********************************************************       14630000
146400***  REVIEW CODE = 03 OR 06                                       14640000
146500***  CAPITAL   PERDIEM-AMT CALCULATION                            14650000
146600***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS              14660000
146700                                                                  14670000
146800        COMPUTE H-CAPI-HSP-PART ROUNDED =                         14680000
146900        H-CAPI-HSP-PART * H-TRANSFER-ADJ                          14690000
147000        ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.                  14700000
147100                                                                  14710000
147200        COMPUTE H-CAPI-FSP-PART ROUNDED =                         14720000
147300        H-CAPI-FSP-PART * H-TRANSFER-ADJ                          14730000
147400        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  14740000
147500                                                                  14750000
147600***********************************************************       14760000
147700***  REVIEW CODE = 03 OR 06                                       14770000
147800***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                14780000
147900***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                14790000
148000                                                                  14800000
148100        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                     14810000
148200        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ                      14820000
148300        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              14830000
148400                                                                  14840000
148500 3550-CALC-PERDIEM-AMT.                                           14850000
148600***********************************************************       14860000
148700***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG            14870000
148800***  OPERATING PERDIEM-AMT CALCULATION                            14880000
148900***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS              14890000
149000                                                                  14900000
149100     IF (B-DRG = 209 OR 210 OR 211)                               14910000
149200        MOVE 10 TO PPS-RTC                                        14920000
149300        COMPUTE H-OPER-HSP-PART ROUNDED =                         14930000
149400        H-OPER-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             14940000
149500        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.                  14950000
149600                                                                  14960000
149700     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR                      14970000
149800                 264 OR 429 OR 483)                               14980000
149900        MOVE 12 TO PPS-RTC                                        14990000
150000        COMPUTE H-OPER-HSP-PART ROUNDED =                         15000000
150100        H-OPER-HSP-PART *  H-TRANSFER-ADJ                         15010000
150200        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.                  15020000
150300                                                                  15030000
150400     IF (B-DRG = 209 OR 210 OR 211)                               15040000
150500        MOVE 10 TO PPS-RTC                                        15050000
150600        COMPUTE H-OPER-FSP-PART ROUNDED =                         15060000
150700        H-OPER-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             15070000
150800        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  15080000
150900                                                                  15090000
151000     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR                      15100000
151100                 264 OR 429 OR 483)                               15110000
151200        MOVE 12 TO PPS-RTC                                        15120000
151300        COMPUTE H-OPER-FSP-PART ROUNDED =                         15130000
151400        H-OPER-FSP-PART *  H-TRANSFER-ADJ                         15140000
151500        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  15150000
151600                                                                  15160000
151700***********************************************************       15170000
151800***  CAPITAL PERDIEM-AMT CALCULATION                              15180000
151900***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS                15190000
152000                                                                  15200000
152100     IF (B-DRG = 209 OR 210 OR 211)                               15210000
152200        MOVE 10 TO PPS-RTC                                        15220000
152300        COMPUTE H-CAPI-HSP-PART ROUNDED =                         15230000
152400        H-CAPI-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             15240000
152500        ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.                  15250000
152600                                                                  15260000
152700     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR                      15270000
152800                 264 OR 429 OR 483)                               15280000
152900        MOVE 12 TO PPS-RTC                                        15290000
153000        COMPUTE H-CAPI-HSP-PART ROUNDED =                         15300000
153100        H-CAPI-HSP-PART *  H-TRANSFER-ADJ                         15310000
153200        ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.                  15320000
153300                                                                  15330000
153400     IF (B-DRG = 209 OR 210 OR 211)                               15340000
153500        MOVE 10 TO PPS-RTC                                        15350000
153600        COMPUTE H-CAPI-FSP-PART ROUNDED =                         15360000
153700        H-CAPI-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             15370000
153800        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  15380000
153900                                                                  15390000
154000     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR                      15400000
154100                 264 OR 429 OR 483)                               15410000
154200        MOVE 12 TO PPS-RTC                                        15420000
154300        COMPUTE H-CAPI-FSP-PART ROUNDED =                         15430000
154400        H-CAPI-FSP-PART *  H-TRANSFER-ADJ                         15440000
154500        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  15450000
154600                                                                  15460000
154700***********************************************************       15470000
154800***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                15480000
154900***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                15490000
155000                                                                  15500000
155100     IF (B-DRG = 209 OR 210 OR 211)                               15510000
155200        MOVE 10 TO PPS-RTC                                        15520000
155300        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                     15530000
155400        H-CAPI-OLD-HARMLESS * (.5 * (1 + H-TRANSFER-ADJ))         15540000
155500        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              15550000
155600                                                                  15560000
155700     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR                      15570000
155800                 264 OR 429 OR 483)                               15580000
155900        MOVE 12 TO PPS-RTC                                        15590000
156000        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                     15600000
156100        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ                     15610000
156200        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              15620000
156300                                                                  15630000
156400 3600-CALC-OUTLIER.                                               15640000
156500******************************************************************15650000
156600***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97             15660000
156700***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97             15670000
156800***  ZEROED OUT THE H-DAYOUT-PCT FIELD AS OF 10/01/97             15680000
156900                                                                  15690000
157000     MOVE 0.00 TO H-DAYOUT-PCT.                                   15700000
157100******************************************************************15710000
157200                                                                  15720000
157300     MOVE 0.80 TO H-CSTOUT-PCT.                                   15730000
157400                                                                  15740000
157500     IF  B-DRG = 504 OR 505 OR 506 OR 507 OR 508 OR               15750000
157600                 509 OR 510 OR 511                                15760000
157700             MOVE 0.90 TO H-CSTOUT-PCT.                           15770000
157800                                                                  15780000
157900***     NATIONAL PERCENTAGE                                       15790000
158000     MOVE 0.7110   TO H-LABOR-PCT.                                15800000
158100     MOVE 0.2890   TO H-NONLABOR-PCT.                             15810000
158200                                                                  15820000
158300***     PUERTO RICO PERCENTAGE                                    15830000
158400     MOVE 0.7130   TO H-PR-LABOR-PCT.                             15840000
158500     MOVE 0.2870   TO H-PR-NONLABOR-PCT.                          15850000
158600                                                                  15860000
158700     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC                          15870000
158800             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO  15880000
158900     ELSE                                                         15890000
159000             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.                   15900000
159100                                                                  15910000
159200     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC                           15920000
159300             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO  15930000
159400     ELSE                                                         15940000
159500             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.                   15950000
159600                                                                  15960000
159700***********************************************************       15970000
159800***  CAPITAL PAYMENT METHOD B                                     15980000
159900***  CAPITAL PAYMENT METHOD B                                     15990000
160000                                                                  16000000
160100     IF W-SIZE = 'L'                                              16010000
160200        MOVE 1.03 TO H-CAPI-LARG-URBAN                            16020000
160300     ELSE                                                         16030000
160400        MOVE 1.00 TO H-CAPI-LARG-URBAN.                           16040000
160500                                                                  16050000
160600     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).     16060000
160700     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).  16070000
160800                                                                  16080000
160900     IF B-DISCHARGE-DATE < 19990301                               16090000
161000        COMPUTE H-FEDERAL-RATE ROUNDED =                          16100000
161100                                 (0378.05 * H-CAPI-GAF)           16110000
161200     ELSE                                                         16120000
161300        COMPUTE H-FEDERAL-RATE ROUNDED =                          16130000
161400                                 (0378.10 * H-CAPI-GAF).          16140000
161500                                                                  16150000
161600     COMPUTE H-PUERTO-RICO-RATE ROUNDED =                         16160000
161700                                 (0181.10 * H-PR-CAPI-GAF).       16170000
161800                                                                  16180000
161900     COMPUTE H-CAPI-COLA ROUNDED =                                16190000
162000                     (.3152 * (H-OPER-COLA - 1) + 1).             16200000
162100                                                                  16210000
162200     IF P-NEW-STATE = 40                                          16220000
162300        COMPUTE  H-CAPI-FED-RATE ROUNDED =                        16230000
162400                 (H-NAT-PCT * H-FEDERAL-RATE) +                   16240000
162500                 (H-REG-PCT * H-PUERTO-RICO-RATE)                 16250000
162600     ELSE                                                         16260000
162700        MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.                   16270000
162800                                                                  16280000
162900***********************************************************       16290000
163000***  CAPITAL HSP CALCULATION                                      16300000
163100***  CAPITAL HSP CALCULATION                                      16310000
163200                                                                  16320000
163300     MOVE 0.9784 TO H-HSP-UPDATE94.                               16330000
163400     MOVE 1.0005 TO H-HSP-UPDATE95.                               16340000
163500     MOVE 1.2110 TO H-HSP-UPDATE96.                               16350000
163600     MOVE 0.9568 TO H-HSP-UPDATE97.                               16360000
163700     MOVE 0.8563 TO H-HSP-UPDATE98.                               16370000
163800     MOVE 1.0138 TO H-HSP-UPDATE99.                               16380000
163900                                                                  16390000
164000     COMPUTE H-ACCUM-TO-HSP ROUNDED = (H-HSP-UPDATE94 *           16400000
164100                                       H-HSP-UPDATE95 *           16410000
164200                                       H-HSP-UPDATE96 *           16420000
164300                                       H-HSP-UPDATE97 *           16430000
164400                                       H-HSP-UPDATE98 *           16440000
164500                                       H-HSP-UPDATE99).           16450000
164600                                                                  16460000
164700     COMPUTE H-CAPI-HSP-PART ROUNDED = (H-DRG-WT *                16470000
164800                   P-NEW-CAPI-HOSP-SPEC-RATE * H-ACCUM-TO-HSP).   16480000
164900***********************************************************       16490000
165000***  CAPITAL FSP CALCULATION                                      16500000
165100***  CAPITAL FSP CALCULATION                                      16510000
165200                                                                  16520000
165300     COMPUTE H-CAPI-FSP-PART ROUNDED =                            16530000
165400                               H-DRG-WT * H-CAPI-FED-RATE *       16540000
165500                               H-CAPI-COLA *                      16550000
165600                               H-CAPI-LARG-URBAN.                 16560000
165700                                                                  16570000
165800***********************************************************       16580000
165900***  CAPITAL PAYMENT METHOD A                                     16590000
166000***  CAPITAL PAYMENT METHOD A                                     16600000
166100                                                                  16610000
166200     IF P-N-SCH-REBASED-FY90 OR P-N-EACH                          16620000
166300        MOVE 1.00 TO H-CAPI-SCH                                   16630000
166400     ELSE                                                         16640000
166500        MOVE 0.85 TO H-CAPI-SCH.                                  16650000
166600                                                                  16660000
166700***********************************************************       16670000
166800***********  CAPITAL OLD-HARMLESS CALCULATION ***********         16680000
166900***********  CAPITAL OLD-HARMLESS CALCULATION ***********         16690000
167000                                                                  16700000
167100     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                        16710000
167200                    (P-NEW-CAPI-OLD-HARM-RATE *                   16720000
167300                    H-CAPI-SCH).                                  16730000
167400                                                                  16740000
167500***********************************************************       16750000
167600***  COST OUTLIER OPERATING AND CAPITAL CALCULATION               16760000
167700***  COST OUTLIER OPERATING AND CAPITAL CALCULATION               16770000
167800                                                                  16780000
167900     IF H-CAPI-CSTCHG-RATIO > 0 OR                                16790000
168000       H-OPER-CSTCHG-RATIO > 0                                    16800000
168100        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =             16810000
168200                H-OPER-CSTCHG-RATIO /                             16820000
168300               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)        16830000
168400        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =             16840000
168500                H-CAPI-CSTCHG-RATIO /                             16850000
168600               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)        16860000
168700     ELSE                                                         16870000
168800         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD                    16880000
168900                   H-CAPI-SHARE-DOLL-THRESHOLD.                   16890000
169000                                                                  16900000
169100     MOVE 11100.00 TO H-CST-THRESH.                               16910000
169200     MOVE 10129.00 TO H-PRE-CAPI-THRESH.                          16920000
169300                                                                  16930000
169400     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                    16940000
169500        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +            16950000
169600         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *         16960000
169700          H-OPER-SHARE-DOLL-THRESHOLD.                            16970000
169800                                                                  16980000
169900     IF P-NEW-STATE = 40                                          16990000
170000        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =              17000000
170100           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +   17010000
170200            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *   17020000
170300             H-OPER-SHARE-DOLL-THRESHOLD                          17030000
170400        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                 17040000
170500               (H-OPER-DOLLAR-THRESHOLD +                         17050000
170600                H-OPER-PR-DOLLAR-THRESHOLD) * H-NAT-PCT.          17060000
170700                                                                  17070000
170800***********************************************************       17080000
170900***  CAPITAL DSH CALCULATION                                      17090000
171000***  CAPITAL DSH CALCULATION                                      17100000
171100                                                                  17110000
171200     MOVE 0 TO H-CAPI-DSH.                                        17120000
171300                                                                  17130000
171400     IF P-NEW-BED-SIZE NOT NUMERIC                                17140000
171500         MOVE 0 TO P-NEW-BED-SIZE.                                17150000
171600                                                                  17160000
171700     IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99             17170000
171800         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **                   17180000
171900                  (.2025 * (P-NEW-SSI-RATIO                       17190000
172000                          + P-NEW-MEDICAID-RATIO)) - 1.           17200000
172100                                                                  17210000
172200***********************************************************       17220000
172300***  CAPITAL IME TEACH CALCULATION                                17230000
172400***  CAPITAL IME TEACH CALCULATION                                17240000
172500                                                                  17250000
172600     MOVE 0 TO H-WK-CAPI-IME-TEACH.                               17260000
172700                                                                  17270000
172800     IF P-NEW-CAPI-IME NUMERIC                                    17280000
172900        IF P-NEW-CAPI-IME > 1.5000                                17290000
173000           MOVE 1.5000 TO P-NEW-CAPI-IME.                         17300000
173100                                                                  17310000
173200     IF P-NEW-CAPI-IME NUMERIC                                    17320000
173300        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =                     17330000
173400          (2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1.               17340000
173500                                                                  17350000
173600***********************************************************       17360000
173700***  DIFFERENT THRESHOLD   PRE-CAPITAL                            17370000
173800***  DIFFERENT THRESHOLD   PRE-CAPITAL                            17380000
173900                                                                  17390000
174000     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               17400003
174100        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                 17410000
174200        (H-PRE-CAPI-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +        17420000
174300        (H-PRE-CAPI-THRESH * H-NONLABOR-PCT * H-OPER-COLA)        17430000
174400       IF P-NEW-STATE = 40                                        17440000
174500        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =              17450000
174600         (H-PRE-CAPI-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) + 17460000
174700         (H-PRE-CAPI-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)    17470000
174800        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                 17480000
174900               (H-OPER-DOLLAR-THRESHOLD +                         17490000
175000                H-OPER-PR-DOLLAR-THRESHOLD) * H-NAT-PCT.          17500000
175100***********************************************************       17510000
175200                                                                  17520000
175300     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =                    17530000
175400          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *         17540000
175500          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.              17550000
175600                                                                  17560000
175700                                                                  17570000
175800     IF P-NEW-STATE = 40                                          17580000
175900        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =              17590000
176000           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *     17600000
176100           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA              17610000
176200        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =                 17620000
176300               (H-CAPI-DOLLAR-THRESHOLD +                         17630000
176400                H-CAPI-PR-DOLLAR-THRESHOLD) * H-NAT-PCT.          17640000
176500                                                                  17650000
176600     COMPUTE H-OPER-COST-OUTLIER ROUNDED =                        17660000
176700      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))     17670000
176800                       +                                          17680000
176900             H-OPER-DOLLAR-THRESHOLD.                             17690000
177000                                                                  17700000
177100     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =                        17710000
177200      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))  17720000
177300                       +                                          17730000
177400             H-CAPI-DOLLAR-THRESHOLD.                             17740000
177500                                                                  17750000
177600     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               17760000
177700         MOVE 0 TO H-CAPI-COST-OUTLIER.                           17770000
177800                                                                  17780000
177900     IF (B-REVIEW-CODE = '03') AND                                17790000
178000         H-PERDIEM-DAYS < H-ALOS                                  17800000
178100        COMPUTE H-OPER-COST-OUTLIER ROUNDED =                     17810000
178200*               (H-OPER-COST-OUTLIER * H-PERDIEM-DAYS / H-ALOS)   17820000
178300                (H-OPER-COST-OUTLIER * H-TRANSFER-ADJ)            17830000
178400                ON SIZE ERROR MOVE 0 TO H-OPER-COST-OUTLIER.      17840000
178500                                                                  17850000
178600     IF (B-REVIEW-CODE = '03') AND                                17860000
178700         H-PERDIEM-DAYS < H-ALOS                                  17870000
178800        COMPUTE H-CAPI-COST-OUTLIER ROUNDED =                     17880000
178900*               (H-CAPI-COST-OUTLIER * H-PERDIEM-DAYS / H-ALOS)   17890000
179000                (H-CAPI-COST-OUTLIER * H-TRANSFER-ADJ)            17900000
179100                ON SIZE ERROR MOVE 0 TO H-CAPI-COST-OUTLIER.      17910000
179200                                                                  17920000
179300     IF ((B-REVIEW-CODE = '09') AND                               17930000
179400         (H-PERDIEM-DAYS < H-ALOS))                               17940000
179500         IF (B-DRG = 209 OR 210 OR 211)                           17950000
179600           COMPUTE H-OPER-COST-OUTLIER ROUNDED =                  17960000
179700               (H-OPER-COST-OUTLIER * (.5 * (1 + H-TRANSFER-ADJ)))17970000
179800                ON SIZE ERROR MOVE 0 TO H-OPER-COST-OUTLIER.      17980000
179900                                                                  17990000
180000     IF ((B-REVIEW-CODE = '09') AND                               18000000
180100         (H-PERDIEM-DAYS < H-ALOS))                               18010000
180200         IF (B-DRG = 014 OR 113 OR 236 OR 263 OR                  18020000
180300                     264 OR 429 OR 483)                           18030000
180400            COMPUTE H-OPER-COST-OUTLIER ROUNDED =                 18040000
180500                (H-OPER-COST-OUTLIER *  H-TRANSFER-ADJ)           18050000
180600                ON SIZE ERROR MOVE 0 TO H-OPER-COST-OUTLIER.      18060000
180700                                                                  18070000
180800     IF ((B-REVIEW-CODE = '09') AND                               18080000
180900         (H-PERDIEM-DAYS < H-ALOS))                               18090000
181000         IF (B-DRG = 209 OR 210 OR 211)                           18100000
181100           COMPUTE H-CAPI-COST-OUTLIER ROUNDED =                  18110000
181200               (H-CAPI-COST-OUTLIER * (.5 * (1 + H-TRANSFER-ADJ)))18120000
181300                ON SIZE ERROR MOVE 0 TO H-CAPI-COST-OUTLIER.      18130000
181400                                                                  18140000
181500     IF ((B-REVIEW-CODE = '09') AND                               18150000
181600         (H-PERDIEM-DAYS < H-ALOS))                               18160000
181700         IF (B-DRG = 014 OR 113 OR 236 OR 263 OR                  18170000
181800                     264 OR 429 OR 483)                           18180000
181900            COMPUTE H-CAPI-COST-OUTLIER ROUNDED =                 18190000
182000                (H-CAPI-COST-OUTLIER *  H-TRANSFER-ADJ)           18200000
182100                ON SIZE ERROR MOVE 0 TO H-CAPI-COST-OUTLIER.      18210000
182200                                                                  18220000
182300                                                                  18230000
182400***********************************************************       18240000
182500***  OPERATING COST CALCULATION                                   18250000
182600***  OPERATING COST CALCULATION                                   18260000
182700                                                                  18270000
182800     COMPUTE H-OPER-BILL-COSTS ROUNDED =                          18280000
182900         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO                  18290000
183000         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.               18300000
183100                                                                  18310000
183200                                                                  18320000
183300     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER                  18330000
183400         COMPUTE H-OPER-OUTCST-PART ROUNDED =                     18340000
183500         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -                      18350000
183600                         H-OPER-COST-OUTLIER).                    18360000
183700                                                                  18370000
183800     IF PAY-WITHOUT-COST OR                                       18380000
183900        PAY-XFER-NO-COST OR                                       18390000
184000        PAY-XFER-SPEC-DRG-NO-COST                                 18400000
184100         MOVE 0 TO H-OPER-OUTCST-PART.                            18410000
184200                                                                  18420000
184300***********************************************************       18430000
184400***  CAPITAL COST CALCULATION                                     18440000
184500***  CAPITAL COST CALCULATION                                     18450000
184600                                                                  18460000
184700     COMPUTE H-CAPI-BILL-COSTS ROUNDED =                          18470000
184800             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO              18480000
184900         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.               18490000
185000                                                                  18500000
185100     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER                  18510000
185200         COMPUTE H-CAPI-OUTCST-PART ROUNDED =                     18520000
185300         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -                      18530000
185400                         H-CAPI-COST-OUTLIER).                    18540000
185500                                                                  18550000
185600     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'                             18560000
185700       COMPUTE H-CAPI-OUTCST-PART ROUNDED =                       18570000
185800              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).   18580000
185900                                                                  18590000
186000     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'                             18600000
186100        COMPUTE H-CAPI-OUTCST-PART ROUNDED =                      18610000
186200               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).         18620000
186300                                                                  18630000
186400     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <               18640000
186500        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)               18650000
186600        MOVE 0 TO H-CAPI-OUTCST-PART                              18660000
186700                  H-OPER-OUTCST-PART.                             18670000
186800                                                                  18680000
186900     IF PAY-WITHOUT-COST OR                                       18690000
187000        PAY-XFER-NO-COST OR                                       18700000
187100        PAY-XFER-SPEC-DRG-NO-COST                                 18710000
187200         MOVE 0 TO H-CAPI-OUTCST-PART.                            18720000
187300                                                                  18730000
187400***********************************************************       18740000
187500***  DETERMINES THE BILL TO BE COST  OUTLIER                      18750000
187600                                                                  18760000
187700     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               18770000
187800         MOVE 0 TO H-CAPI-OUTDAY-PART                             18780000
187900                   H-CAPI-OUTCST-PART.                            18790000
188000                                                                  18800000
188100     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0             18810000
188200                 MOVE H-OPER-OUTCST-PART TO                       18820000
188300                      H-OPER-OUTLIER-PART                         18830000
188400                 MOVE H-CAPI-OUTCST-PART TO                       18840000
188500                      H-CAPI-OUTLIER-PART                         18850000
188600                 MOVE 02 TO PPS-RTC.                              18860000
188700                                                                  18870000
188800                                                                  18880000
188900***********************************************************       18890000
189000                                                                  18900000
189100***  DETERMINES IF COST OUTLIER                                   18910010
189200***  RECOMPUTES DOLLAR THRESHOLD WITH A RETURN CODE 02            18920010
189300                                                                  18930010
189400     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.                           18940001
189500                                                                  18950001
189600     IF PPS-RTC = 02                                              18960000
189700             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =            18970000
189800                     (H-CAPI-COST-OUTLIER  +                      18980000
189900                      H-OPER-COST-OUTLIER)                        18990000
190000                             /                                    19000000
190100                    (H-CAPI-CSTCHG-RATIO  +                       19010000
190200                     H-OPER-CSTCHG-RATIO)                         19020000
190300             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.     19030010
190400                                                                  19040010
190500***********************************************************       19050010
190600***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS       19060010
190700***  RETURNS THE DOLLAR THRESHOLD TO BE SENT BACK WITH            19070010
190800***         RETURN CODE OF 67                                     19080010
190900     IF PPS-RTC = 02                                              19090010
191000         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR                19100009
191100            PPS-PC-COT-FLAG = 'Y'                                 19110009
191200             MOVE 67 TO PPS-RTC.                                  19120010
191300***********************************************************       19130000
191400                                                                  19140000
191500***********************************************************       19150000
191600***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF          19160000
191700***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE          19170000
191800                                                                  19180000
191900     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'                             19190000
192000        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =                  19200000
192100                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO   19210000
192200         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.          19220000
192300                                                                  19230000
192400     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'                             19240000
192500        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =                  19250000
192600                H-CAPI-OUTLIER-PART.                              19260000
192700                                                                  19270000
192800     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'                             19280000
192900        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =                  19290000
193000                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1          19300000
193100         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.          19310000
193200***********************************************************       19320000
193300                                                                  19330000
193400 3800-CALC-TOT-AMT.                                               19340000
193500                                                                  19350000
193600***********************************************************       19360000
193700***  CALCULATE FINAL TOTALS FOR OPERATING                         19370000
193800***  CALCULATE FINAL TOTALS FOR OPERATING                         19380000
193900                                                                  19390000
194000     COMPUTE PPS-OPER-HSP-PART ROUNDED =                          19400000
194100         H-OPER-HSP-PCT * H-OPER-HSP-PART.                        19410000
194200                                                                  19420000
194300     COMPUTE PPS-OPER-FSP-PART ROUNDED =                          19430000
194400         H-OPER-FSP-PCT * H-OPER-FSP-PART.                        19440000
194500                                                                  19450000
194600     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =                      19460000
194700             H-OPER-FSP-PCT * H-OPER-OUTLIER-PART.                19470000
194800                                                                  19480000
194900     MOVE ZERO TO PPS-OPER-DSH-ADJ.                               19490000
195000                                                                  19500000
195100     IF  H-OPER-DSH NUMERIC                                       19510000
195200             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =                   19520000
195300              PPS-OPER-FSP-PART                                   19530000
195400              * H-OPER-DSH.                                       19540000
195500                                                                  19550000
195600     COMPUTE PPS-OPER-IME-ADJ ROUNDED =                           19560000
195700          PPS-OPER-FSP-PART *                                     19570000
195800                 H-OPER-IME-TEACH.                                19580000
195900                                                                  19590000
196000***********************************************************       19600000
196100***  CALCULATE FINAL TOTALS FOR CAPITAL                           19610000
196200***  CALCULATE FINAL TOTALS FOR CAPITAL                           19620000
196300                                                                  19630000
196400     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.           19640000
196500                                                                  19650000
196600     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'                             19660000
196700        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT          19670000
196800        MOVE 0.00 TO H-CAPI-HSP-PCT.                              19680000
196900                                                                  19690000
197000     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'                             19700000
197100        MOVE 0    TO H-CAPI-OLD-HARMLESS                          19710000
197200        MOVE 1.00 TO H-CAPI-FSP-PCT                               19720000
197300        MOVE 0.00 TO H-CAPI-HSP-PCT.                              19730000
197400                                                                  19740000
197500     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'                             19750000
197600        MOVE 0    TO H-CAPI-OLD-HARMLESS                          19760000
197700        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT                 19770000
197800        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.                19780000
197900                                                                  19790000
198000     COMPUTE H-CAPI-HSP ROUNDED =                                 19800000
198100         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.                        19810000
198200                                                                  19820000
198300     COMPUTE H-CAPI-FSP ROUNDED =                                 19830000
198400         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.                        19840000
198500                                                                  19850000
198600     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.             19860000
198700                                                                  19870000
198800     COMPUTE H-CAPI-OUTLIER ROUNDED =                             19880000
198900             1.00 * H-CAPI-OUTLIER-PART.                          19890000
199000                                                                  19900000
199100     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =                          19910000
199200             1.00 * H-CAPI2-B-OUTLIER-PART.                       19920000
199300                                                                  19930000
199400     COMPUTE H-CAPI2-B-FSP ROUNDED =                              19940000
199500             1.00 * H-CAPI2-B-FSP-PART.                           19950000
199600                                                                  19960000
199700     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.                 19970000
199800                                                                  19980000
199900     COMPUTE H-CAPI-DSH-ADJ ROUNDED =                             19990000
200000             H-CAPI-FSP                                           20000000
200100              * H-CAPI-DSH.                                       20010000
200200                                                                  20020000
200300     COMPUTE H-CAPI-IME-ADJ ROUNDED =                             20030000
200400          H-CAPI-FSP *                                            20040000
200500                 H-WK-CAPI-IME-TEACH.                             20050000
200600                                                                  20060000
200700***********************************************************       20070000
200800***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER               20080000
200900***        THIS ZEROES OUT ALL CAPITAL DATA                       20090000
201000                                                                  20100000
201100     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               20110000
201200        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.                   20120000
201300                                                                  20130000
201400     IF HMO-TAG  = 'Y'                                            20140000
201500        PERFORM 3850-HMO-IME-ADJ.                                 20150000
201600                                                                  20160000
201700     IF (H-CAPI-OUTLIER > 0 AND                                   20170012
201800         PPS-OPER-OUTLIER-PART = 0)                               20180012
201900         COMPUTE PPS-OPER-OUTLIER-PART =                          20190012
202000                 PPS-OPER-OUTLIER-PART + .01.                     20200012
202100                                                                  20210012
202200     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =                           20220000
202300             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +        20230000
202400             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +                    20240000
202500             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.                    20250000
202600                                                                  20260000
202700***********************************************************       20270000
202800***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING             20280000
202900***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING             20290000
203000                                                                  20300000
203100     COMPUTE PPS-TOTAL-PAYMENT ROUNDED =                          20310000
203200             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +              20320000
203300             PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +           20330000
203400             PPS-OPER-IME-ADJ                                     20340000
203500                           +                                      20350000
203600                H-WK-PASS-AMT-PLUS-MISC                           20360000
203700                           +                                      20370000
203800                  H-CAPI-TOTAL-PAY.                               20380000
203900                                                                  20390000
204000 3850-HMO-IME-ADJ.                                                20400000
204100***********************************************************       20410000
204200***  HMO ADJUSTMENT FOR OPERATING IME                             20420000
204300***  HMO ADJUSTMENT FOR OPERATING IME                             20430000
204400***  HMO CALC FOR PASS THRU ADDON                                 20440000
204500***  HMO CALC FOR PASS THRU ADDON                                 20450000
204600                                                                  20460000
204700     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =                    20470000
204800             P-NEW-PASS-AMT-PLUS-MISC  * B-LOS.                   20480000
204900                                                                  20490000
205000        IF B-DISCHARGE-DATE < 19990101                            20500000
205100           COMPUTE PPS-OPER-IME-ADJ ROUNDED =                     20510000
205200                   PPS-OPER-IME-ADJ * .8                          20520000
205300        ELSE                                                      20530000
205400           COMPUTE PPS-OPER-IME-ADJ ROUNDED =                     20540000
205500                   PPS-OPER-IME-ADJ * .6.                         20550000
205600                                                                  20560000
205700 3900-CALC-OPER-DSH.                                              20570000
205800***********************************************************       20580000
205900***  OPERATING DSH CALCULATION                                    20590000
206000***  OPERATING DSH CALCULATION                                    20600000
206100                                                                  20610000
206200      MOVE 0.0000 TO H-OPER-DSH.                                  20620000
206300                                                                  20630000
206400      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO           20640000
206500                                     + P-NEW-MEDICAID-RATIO).     20650000
206600                                                                  20660000
206700      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100           20670000
206800                               AND H-WK-OPER-DSH > .3999          20680000
206900        MOVE .05 TO H-OPER-DSH.                                   20690000
207000                                                                  20700000
207100      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99            20710000
207200                               AND H-WK-OPER-DSH > .1499          20720000
207300                               AND H-WK-OPER-DSH < .2021          20730000
207400        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        20740000
207500                                      * .65 + .025.               20750000
207600                                                                  20760000
207700      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499           20770000
207800                               AND H-WK-OPER-DSH > .1499          20780000
207900                               AND H-WK-OPER-DSH < .2021          20790000
208000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        20800000
208100                                 * .65 + .025.                    20810000
208200                                                                  20820000
208300      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99            20830000
208400                               AND H-WK-OPER-DSH > .202           20840000
208500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       20850000
208600                                 * .825 + .0588.                  20860000
208700                                                                  20870000
208800      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499           20880000
208900                               AND H-WK-OPER-DSH > .202           20890000
209000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       20900000
209100                                 * .825 + .0588.                  20910000
209200                                                                  20920000
209300      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE < 101           20930000
209400                               AND H-WK-OPER-DSH > .4499          20940000
209500        MOVE .04 TO H-OPER-DSH.                                   20950000
209600                                                                  20960000
209700      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 100           20970000
209800                               AND P-NEW-BED-SIZE < 500           20980000
209900                               AND H-WK-OPER-DSH > .2999          20990000
210000        MOVE .04 TO H-OPER-DSH.                                   21000000
210100                                                                  21010000
210200      IF W-SIZE = 'R'                                             21020000
210300         IF (P-NEW-PROVIDER-TYPE = '16' OR '21')                  21030000
210400                               AND H-WK-OPER-DSH > .2999          21040000
210500                               AND P-NEW-BED-SIZE < 500           21050000
210600            MOVE .10 TO H-OPER-DSH.                               21060000
210700                                                                  21070000
210800      IF W-SIZE = 'R'                                             21080000
210900         IF (P-NEW-PROVIDER-TYPE = '07')                          21090000
211000                               AND H-WK-OPER-DSH > .2999          21100000
211100                               AND P-NEW-BED-SIZE > 100           21110000
211200                               AND P-NEW-BED-SIZE < 500           21120000
211300            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)     21130000
211400                                 * .6 + .04.                      21140000
211500                                                                  21150000
211600      IF W-SIZE = 'R'                                             21160000
211700         IF (P-NEW-PROVIDER-TYPE = '17' OR '22')                  21170000
211800                               AND H-WK-OPER-DSH > .2999          21180000
211900                               AND P-NEW-BED-SIZE < 500           21190000
212000            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)     21200000
212100                                 * .6 + .04.                      21210000
212200                                                                  21220000
212300      IF W-SIZE = 'R'                                             21230000
212400         IF (P-NEW-PROVIDER-TYPE = '17' OR '22')                  21240000
212500                               AND H-WK-OPER-DSH > .2999          21250000
212600                               AND P-NEW-BED-SIZE < 500           21260000
212700                               AND H-OPER-DSH < .10               21270000
212800            MOVE .10 TO H-OPER-DSH.                               21280000
212900                                                                  21290000
213000      MOVE 0.9800 TO H-DSH-REDUCT-FACTOR.                         21300000
213100                                                                  21310000
213200      COMPUTE H-OPER-DSH ROUNDED =                                21320000
213300                        H-OPER-DSH * H-DSH-REDUCT-FACTOR.         21330000
213400                                                                  21340000
213500                                                                  21350000
213600******        L A S T   S O U R C E   S T A T E M E N T   *****   21360000
