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