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