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