000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.           PPCAL069.                                  00020024
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     'PPCAL069      - W O R K I N G   S T O R A G E'.             00180024
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C06.9'.     00190024
002000***************************************************************   00200000
002100***************************************************************   00210000
002200****ATTENTION******ATTENTION********ATTENTION*******ATTENTION**   00220000
002300****ATTENTION******ATTENTION********ATTENTION*******ATTENTION**   00230000
002400***************************************************************   00240000
002500*    IF YOU ARE A HMO, YOU WANT TO PAY CLAIMS AS A HMO        *   00250000
002600*     - CHANGE THE > 01 HMO-FLAG < TO THE VALUE OF 'Y' *          00260000
002700*     - CHANGE ALL PPCAL___ PROGRAMS BACK TO PPCAL983 *           00270000
002800*        BEFORE YOU COMPILE AND LINK THEM *                       00280000
002900*     - THIS WILL ALLOW YOU TO PAY ALL YOUR CLAIMS WITH *         00290000
003000*        AN HMO ADJUSTMENT *                                      00300000
003100***************************************************************   00310000
003200***************************************************************   00320000
003300 01  HMO-FLAG                       PIC X      VALUE 'N'.         00330000
003400***************************************************************   00340000
003500***************************************************************   00350000
003600 01  HMO-TAG                        PIC X      VALUE SPACE.       00360000
003700 01  OUTLIER-RECON-FLAG             PIC X      VALUE 'N'.         00370000
003800 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.         00380000
003900 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES. 00390000
004000 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES. 00400000
004100 01  WK-LOW-VOL25PCT                PIC 99V999 VALUE 01.000.      00410000
004200 01  R1                             PIC S9(04) COMP SYNC.         00420000
004300 01  R2                             PIC S9(04) COMP SYNC.         00430000
004400 01  R3                             PIC S9(04) COMP SYNC.         00440000
004500 01  R4                             PIC S9(04) COMP SYNC.         00450000
004600                                                                  00460000
004700 01  H-OPER-DSH-SCH               PIC 9(01)V9(04).                00470000
004800 01  H-OPER-DSH-RRC               PIC 9(01)V9(04).                00480000
004900                                                                  00490000
005000***************************************************************   00500000
005100***************************************************************   00510000
005200*    4 SETS OF LABOR AND NONLABOR RATES                       *   00520000
005300*    LAYUP TABLES AREA FOR FY2006 RATES                       *   00530000
005400***************************************************************   00540000
005500***************************************************************   00550000
005600* TABLE 1                                                     *   00560000
005700*    (69.7% LABOR SHARE/30.3% NONLABOR SHARE)                 *   00570000
005800*    (FULL UPDATE (.697)                                      *   00580000
005900*    (QUALITY = 1 WAGE INDEX > 1)                             *   00590000
006000***************************************************************   00600000
006100 01  TB1-RATE-TABLE.                                              00610000
006200     02  TB1-RATE-WORK.                                           00620000
006300*RATE 20051001 REGION  LABOR AND NON-LABOR RATES                  00630000
006400*                  R3=1     /     R3=2                            00640000
006500*               LARGE URBAN / OTHER URBAN                         00650000
006600*               LABOR / NON / LABOR / NON                         00660000
006700*                     /LABOR/       /LABOR                        00670000
006800*             --------------------------------------------        00680000
006900         05  FILLER PIC X(08) VALUE '20051001'.                   00690000
007000         05  TB1-NAT    PIC X(30) VALUE                           00700000
007100            ' 0329784 143363 0329784 143363'.                     00710000
007200         05  TB1-PR     PIC X(30) VALUE                           00720000
007300            ' 0140246 085957 0140246 085957'.                     00730000
007400         05  TB1-NATPR  PIC X(30) VALUE                           00740000
007500            ' 0329784 143363 0329784 143363'.                     00750000
007600***************************************************************   00760000
007700     02  TB1-RATE-TAB REDEFINES TB1-RATE-WORK.                    00770000
007800         05  TB1-RATE-PERIOD            OCCURS 1.                 00780000
007900             10  TB1-RATE-EFF-DATE      PIC X(08).                00790000
008000             10  TB1-REG-NAT            OCCURS 3.                 00800000
008100                 15  TB1-LARGE-OTHER    OCCURS 2.                 00810000
008200                     20  FILLER         PIC X(01).                00820000
008300                     20  TB1-REG-LABOR  PIC 9(05)V9(02).          00830000
008400                     20  FILLER         PIC X(01).                00840000
008500                     20  TB1-REG-NLABOR PIC 9(04)V9(02).          00850000
008600                                                                  00860000
008700***************************************************************   00870000
008800***************************************************************   00880000
008900* TABLE 2                                                     *   00890000
009000*    (69.7% LABOR SHARE/30.3% NONLABOR SHARE)                 *   00900000
009100*    (REDUCED UPDATE (.697)                                   *   00910000
009200*    (QUALITY NOT = 1 WAGE INDEX > 1)                         *   00920000
009300***************************************************************   00930000
009400 01  TB2-RATE-TABLE.                                              00940000
009500     02  TB2-RATE-WORK.                                           00950000
009600*RATE 20051001 REGION  LABOR AND NON-LABOR RATES                  00960000
009700*                  R3=1     /     R3=2                            00970000
009800*               LARGE URBAN / OTHER URBAN                         00980000
009900*               LABOR / NON / LABOR / NON                         00990000
010000*                     /LABOR/       /LABOR                        01000000
010100*             --------------------------------------------        01010000
010200         05  FILLER PIC X(08) VALUE '20051001'.                   01020000
010300         05  TB2-NAT    PIC X(30) VALUE                           01030000
010400            ' 0328512 142810 0328512 142810'.                     01040000
010500         05  TB2-PR     PIC X(30) VALUE                           01050000
010600            ' 0139705 085626 0139795 085626'.                     01060000
010700         05  TB2-NATPR  PIC X(30) VALUE                           01070000
010800            ' 0328512 142810 0328512 142810'.                     01080000
010900***************************************************************   01090000
011000     02  TB2-RATE-TAB REDEFINES TB2-RATE-WORK.                    01100000
011100         05  TB2-RATE-PERIOD             OCCURS 1.                01110000
011200             10  TB2-RATE-EFF-DATE       PIC X(08).               01120000
011300             10  TB2-REG-NAT             OCCURS 3.                01130000
011400                 15  TB2-LARGE-OTHER     OCCURS 2.                01140000
011500                     20  FILLER          PIC X(01).               01150000
011600                     20  TB2-REG-LABOR   PIC 9(05)V9(02).         01160000
011700                     20  FILLER          PIC X(01).               01170000
011800                     20  TB2-REG-NLABOR  PIC 9(04)V9(02).         01180000
011900***************************************************************   01190000
012000***************************************************************   01200000
012100* TABLE 3                                                     *   01210000
012200*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *   01220000
012300*    (FULL UPDATE (.62%)                                      *   01230000
012400*    (QUALITY = 1 WAGE INDEX <= 1)                            *   01240000
012500***************************************************************   01250000
012600 01  TB3-RATE-TABLE.                                              01260000
012700     02  TB3-RATE-WORK.                                           01270000
012800*RATE 20051001 REGION  LABOR AND NON-LABOR RATES                  01280000
012900*                  R3=1     /     R3=2                            01290000
013000*               LARGE URBAN / OTHER URBAN                         01300000
013100*               LABOR / NON / LABOR / NON                         01310000
013200*                     /LABOR/       /LABOR                        01320000
013300*             --------------------------------------------        01330000
013400         05  FILLER PIC X(08) VALUE '20051001'.                   01340000
013500         05  TB3-NAT    PIC X(30) VALUE                           01350000
013600            ' 0293352 179795 0293352 179795'.                     01360000
013700         05  TB3-PR     PIC X(30) VALUE                           01370000
013800            ' 0132781 093422 0132781 093422'.                     01380000
013900         05  TB3-NATPR  PIC X(30) VALUE                           01390000
014000            ' 0293352 179795 0293352 179795'.                     01400000
014100***************************************************************   01410000
014200     02  TB3-RATE-TAB REDEFINES TB3-RATE-WORK.                    01420000
014300         05  TB3-RATE-PERIOD            OCCURS 1.                 01430000
014400             10  TB3-RATE-EFF-DATE      PIC X(08).                01440000
014500             10  TB3-REG-NAT            OCCURS 3.                 01450000
014600                 15  TB3-LARGE-OTHER    OCCURS 2.                 01460000
014700                     20  FILLER         PIC X(01).                01470000
014800                     20  TB3-REG-LABOR  PIC 9(05)V9(02).          01480000
014900                     20  FILLER         PIC X(01).                01490000
015000                     20  TB3-REG-NLABOR PIC 9(04)V9(02).          01500000
015100                                                                  01510000
015200***************************************************************   01520000
015300***************************************************************   01530000
015400* TABLE 4                                                     *   01540000
015500*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *   01550000
015600*    (REDUCED UPDATE (.62%)                                   *   01560000
015700*    (QUALITY NOT = 1 WAGE INDEX <=1)                         *   01570000
015800***************************************************************   01580000
015900 01  TB4-RATE-TABLE.                                              01590000
016000     02  TB4-RATE-WORK.                                           01600000
016100*RATE 20051001 REGION  LABOR AND NON-LABOR RATES                  01610000
016200*                  R3=1     /     R3=2                            01620000
016300*               LARGE URBAN / OTHER URBAN                         01630000
016400*               LABOR / NON / LABOR / NON                         01640000
016500*                     /LABOR/       /LABOR                        01650000
016600*             --------------------------------------------        01660000
016700         05  FILLER PIC X(08) VALUE '20051001'.                   01670000
016800         05  TB4-NAT    PIC X(30) VALUE                           01680000
016900            ' 0292220 179102 0292220 179102'.                     01690000
017000         05  TB4-PR     PIC X(30) VALUE                           01700000
017100            ' 0132269 093062 0132269 093062'.                     01710000
017200         05  TB4-NATPR  PIC X(30) VALUE                           01720000
017300            ' 0292220 179102 0292220 179102'.                     01730000
017400***************************************************************   01740000
017500     02  TB4-RATE-TAB REDEFINES TB4-RATE-WORK.                    01750000
017600         05  TB4-RATE-PERIOD             OCCURS 1.                01760000
017700             10  TB4-RATE-EFF-DATE       PIC X(08).               01770000
017800             10  TB4-REG-NAT             OCCURS 3.                01780000
017900                 15  TB4-LARGE-OTHER     OCCURS 2.                01790000
018000                     20  FILLER          PIC X(01).               01800000
018100                     20  TB4-REG-LABOR   PIC 9(05)V9(02).         01810000
018200                     20  FILLER          PIC X(01).               01820000
018300                     20  TB4-REG-NLABOR  PIC 9(04)V9(02).         01830000
018400***************************************************************   01840000
018500***************************************************************   01850000
018600***************************************************************   01860000
018700***************************************************************   01870000
018800                                                                  01880000
018900***************************************************************   01890000
019000*    LAYUP TABLE AREA FOR FY2006 DRGS                         *   01900000
019100***************************************************************   01910000
019200 01  DRG-TABLE.                                                   01920000
019300     05  D-TAB.                                                   01930000
019400        10  FILLER                PIC X(08) VALUE                 01940000
019500        '20051001'.                                               01950000
019600      10  FILLER                  PIC X(56) VALUE                 01960000
019700     '03434707600101019587035000460198601270012700000000000000'.  01970000
019800       10  FILLER                  PIC X(56) VALUE                01980000
019900     '00000000000000007878022000300269780670009701563502000030'.  01990000
020000       10  FILLER                  PIC X(56) VALUE                02000000
020100     '01404504500064012222046000620087360290003800899804300055'.  02010000
020200       10  FILLER                  PIC X(56) VALUE                02020000
020300     '00857504000050012456045000580094210370004601335105000065'.  02030000
020400       10  FILLER                  PIC X(56) VALUE                02040000
020500     '00722902500032009903041000530070770270003502786508000104'.  02050000
020600       10  FILLER                  PIC X(56) VALUE                02060000
020700     '01445104900063011304040000520077120300003900997003600048'.  02070000
020800       10  FILLER                  PIC X(56) VALUE                02080000
020900     '00618002500031018191034000630135310320005201335304400059'.  02090000
021000       10  FILLER                  PIC X(56) VALUE                02100000
021100     '00721202600034003359020000200095670300004000619401900024'.  02110000
021200       10  FILLER                  PIC X(56) VALUE                02120000
021300     '00210901600016010062037000480062410240003000728801300016'.  02130000
021400       10  FILLER                  PIC X(56) VALUE                02140000
021500     '01185802700042006975025000350071080170002400962703000041'.  02150000
021600       10  FILLER                  PIC X(56) VALUE                02160000
021700     '00341901600016007852020000280061410240003100687403900048'.  02170000
021800       10  FILLER                  PIC X(56) VALUE                02180000
021900     '00747402500031007524032000420052030230002900301202900029'.  02190000
022000       10  FILLER                  PIC X(56) VALUE                02200000
022100     '01636103100044008690015000180088090190002800834801500019'.  02210000
022200       10  FILLER                  PIC X(56) VALUE                02220000
022300     '01326902400039004882032000320095970200003100871101800026'.  02230000
022400       10  FILLER                  PIC X(56) VALUE                02240000
022500     '01042802300036002772015000150080820180002600211001500015'.  02250000
022600       10  FILLER                  PIC X(56) VALUE                02260000
022700     '01286703300054002989013000130139830300004501166304100061'.  02270000
022800       10  FILLER                  PIC X(56) VALUE                02280000
022900     '00599102300028005958024000310077250290003700661103200040'.  02290000
023000       10  FILLER                  PIC X(56) VALUE                02300000
023100     '00485002500030004210021000230075240320004000744902600034'.  02310000
023200       10  FILLER                  PIC X(56) VALUE                02320000
023300     '00852703300044003398021000210307320760009902883008400111'.  02330000
023400       10  FILLER                  PIC X(56) VALUE                02340000
023500     '01185703300047012427054000640162380670008500894704400055'.  02350000
023600       10  FILLER                  PIC X(56) VALUE                02360000
023700     '01538306100061013936051000680098280420005300579902600032'.  02370000
023800       10  FILLER                  PIC X(56) VALUE                02380000
023900     '01240504800063006974028000360136540490006400877804000049'.  02390000
024000       10  FILLER                  PIC X(56) VALUE                02400000
024100     '01032004700057006104032000380081240340004401185304800061'.  02410000
024200       10  FILLER                  PIC X(56) VALUE                02420000
024300     '00715003100039011354046000620060350290003600730303600044'.  02430000
024400       10  FILLER                  PIC X(56) VALUE                02440000
024500     '00536402800034005560037000370070940240003100538201700021'.  02450000
024600       10  FILLER                  PIC X(56) VALUE                02460000
024700     '00873303300043005402020000251856172370037708220112700149'.  02470000
024800       10  FILLER                  PIC X(56) VALUE                02480000
024900     '06019208400102070346095001120000001350013505878908600110'.  02490000
025000       10  FILLER                  PIC X(56) VALUE                02500000
025100     '00000012100121038417057000840248400260003400000000000000'.  02510000
025200       10  FILLER                  PIC X(56) VALUE                02520000
025300     '03168210800137017354067000890000001580015800000009300093'.  02530000
025400       10  FILLER                  PIC X(56) VALUE                02540000
025500     '01322302600042016380021000300134560330005502385305900092'.  02550000
025600       10  FILLER                  PIC X(56) VALUE                02560000
025700     '01613605300066009847028000350154070290004801442503300044'.  02570000
025800       10  FILLER                  PIC X(56) VALUE                02580000
025900     '01094802100027027440094001200103450410005200694904400052'.  02590000
026000       10  FILLER                  PIC X(56) VALUE                02600000
026100     '01040401700026009425044000550055660320003900627302200028'.  02610000
026200       10  FILLER                  PIC X(56) VALUE                02620000
026300     '00533701800022006068024000310089170320004300621402200028'.  02630000
026400       10  FILLER                  PIC X(56) VALUE                02640000
026500     '00828803300033008287030000390052270200002400511602000024'.  02650000
026600       10  FILLER                  PIC X(56) VALUE                02660000
026700     '00752102700035005852020000250056590170002101276104100058'.  02670000
026800       10  FILLER                  PIC X(56) VALUE                02680000
026900     '00583502100026026621086001000147810520005803447910000123'.  02690000
027000       10  FILLER                  PIC X(56) VALUE                02700000
027100     '01432405400060028061089001100126410400005101878306700080'.  02710000
027200       10  FILLER                  PIC X(56) VALUE                02720000
027300     '01082104500050040399099001330128890310004100853506000060'.  02730000
027400       10  FILLER                  PIC X(56) VALUE                02740000
027500     '01335604100058006657021000260140810380005100843102200027'.  02750000
027600       10  FILLER                  PIC X(56) VALUE                02760000
027700     '01193103100044006785017000210067230220002902247606600080'.  02770000
027800       10  FILLER                  PIC X(56) VALUE                02780000
027900     '01186803600042014521033000450089290190002201266203300049'.  02790000
028000       10  FILLER                  PIC X(56) VALUE                02800000
028100     '00729701800023029612078001100119050310004101412505100070'.  02810000
028200       10  FILLER                  PIC X(56) VALUE                02820000
028300     '00744302700036010060038000470056460240002901124604100052'.  02830000
028400       10  FILLER                  PIC X(56) VALUE                02840000
028500     '00916603600044007013026000310109110450005900978404200054'.  02850000
028600       10  FILLER                  PIC X(56) VALUE                02860000
028700     '00561402800033008413034000440058480230002900566302500033'.  02870000
028800       10  FILLER                  PIC X(56) VALUE                02880000
028900     '00870203200045003253029000290083630310004201129004200056'.  02890000
029000       10  FILLER                  PIC X(56) VALUE                02900000
029100     '00606402400031006179031000440396800900012901679304300057'.  02910000
029200       10  FILLER                  PIC X(56) VALUE                02920000
029300     '03281809900121015748056000670305300880010601603104900057'.  02930000
029400       10  FILLER                  PIC X(56) VALUE                02940000
029500     '02542507500092011604037000430240730680009502786806500098'.  02950000
029600       10  FILLER                  PIC X(56) VALUE                02960000
029700     '03733909900137013318047000620135520490006501124904200056'.  02970000
029800       10  FILLER                  PIC X(56) VALUE                02980000
029900     '01205904400060007292030000390117460410005300689502300029'.  02990000
030000       10  FILLER                  PIC X(56) VALUE                03000000
030100     '00000017100171019059061000690126900440004701287702400029'.  03010000
030200       10  FILLER                  PIC X(56) VALUE                03020000
030300     '02042807200097000000000000000000000000000001913103300058'.  03030000
030400       10  FILLER                  PIC X(56) VALUE                03040000
030500     '03059609300132016648044000560104430260003100591305300053'.  03050000
030600       10  FILLER                  PIC X(56) VALUE                03060000
030700     '00000000000000000000000000000111640230003200818501600019'.  03070000
030800       10  FILLER                  PIC X(56) VALUE                03080000
030900     '01225103700052015884045000650083110210002601145902800041'.  03090000
031000       10  FILLER                  PIC X(56) VALUE                03100000
031100     '00697601900025013174037000560000000000000000970201800028'.  03110000
031200       10  FILLER                  PIC X(56) VALUE                03120000
031300     '01918404600068012219020000280077680380004800740703800046'.  03130000
031400       10  FILLER                  PIC X(56) VALUE                03140000
031500     '00609003000037014401067000870107670500006201405105000067'.  03150000
031600       10  FILLER                  PIC X(56) VALUE                03160000
031700     '00662903000037011504051000670076580360004500720003600045'.  03170000
031800       10  FILLER                  PIC X(56) VALUE                03180000
031900     '00458302500031005932028000360057950260003300855403800048'.  03190000
032000       10  FILLER                  PIC X(56) VALUE                03200000
032100     '00709502700039006974032000390047490230002800256701800018'.  03210000
032200       10  FILLER                  PIC X(56) VALUE                03220000
032300     '00774703800046004588026000310029900290002900850903900051'.  03230000
032400       10  FILLER                  PIC X(56) VALUE                03240000
032500     '00896702000026007138015000170096710180002800703201200014'.  03250000
032600       10  FILLER                  PIC X(56) VALUE                03260000
032700     '00973201600022009766033000480211300860011401063505000065'.  03270000
032800       10  FILLER                  PIC X(56) VALUE                03280000
032900     '01659304400068008637023000320089620280004201132602400035'.  03290000
033000       10  FILLER                  PIC X(56) VALUE                03300000
033100     '01835206200086008313027000390101950560007100986004500059'.  03310000
033200       10  FILLER                  PIC X(56) VALUE                03320000
033300     '00553902900037011294047000630053400240003300689203500045'.  03330000
033400       10  FILLER                  PIC X(56) VALUE                03340000
033500     '00867604600056005391034000410078220420004200731303200041'.  03350000
033600       10  FILLER                  PIC X(56) VALUE                03360000
033700     '00491302300029002600022000220074230350004600456302400030'.  03370000
033800       10  FILLER                  PIC X(56) VALUE                03380000
033900     '02183108200105019390040000550194700780010402038403200041'.  03390000
034000       10  FILLER                  PIC X(56) VALUE                03400000
034100     '00931501700026008891016000210108770160002802639507300103'.  03410000
034200       10  FILLER                  PIC X(56) VALUE                03420000
034300     '01347203200045007652033000430072670280003700818703700048'.  03430000
034400       10  FILLER                  PIC X(56) VALUE                03440000
034500     '00487902500031005486025000390103290370005201092204600060'.  03450000
034600       10  FILLER                  PIC X(56) VALUE                03460000
034700     '00611802700034031679070000820221830580007402376106100086'.  03470000
034800       10  FILLER                  PIC X(56) VALUE                03480000
034900     '01159502600032012700036000550062020170002101634903900061'.  03490000
035000       10  FILLER                  PIC X(56) VALUE                03500000
035100     '00908501600020011898030000450064320150001901115903200048'.  03510000
035200       10  FILLER                  PIC X(56) VALUE                03520000
035300     '00678301700022005012023000230208230360006801269204900064'.  03530000
035400       10  FILLER                  PIC X(56) VALUE                03540000
035500     '00794202400035011539042000580063850210002800865804200052'.  03550000
035600       10  FILLER                  PIC X(56) VALUE                03560000
035700     '00565203000036005498029000340082140230003100505001600019'.  03570000
035800       10  FILLER                  PIC X(56) VALUE                03580000
035900     '00643602900037004391021000260037480310003100707902600035'.  03590000
036000       10  FILLER                  PIC X(56) VALUE                03600000
036100     '00470101500018003227016000160106190410005500616002400031'.  03610000
036200       10  FILLER                  PIC X(56) VALUE                03620000
036300     '00966903500053014368035000430110040240002700842502500033'.  03630000
036400       10  FILLER                  PIC X(56) VALUE                03640000
036500     '00574701700019013772039000620118660320005100286802400024'.  03650000
036600       10  FILLER                  PIC X(56) VALUE                03660000
036700     '01262201900032008737025000340015590170001701247501700027'.  03670000
036800       10  FILLER                  PIC X(56) VALUE                03680000
036900     '01147203100048010441042000570061040220003100718803200041'.  03690000
037000       10  FILLER                  PIC X(56) VALUE                03700000
037100     '00421001900024007289035000450023920130001300736002900040'.  03710000
037200       10  FILLER                  PIC X(56) VALUE                03720000
037300     '01850404700063015135046000570088240280003100742801700019'.  03730000
037400       10  FILLER                  PIC X(56) VALUE                03740000
037500     '02223706500081011448032000400079480220002400858202000026'.  03750000
037600       10  FILLER                  PIC X(56) VALUE                03760000
037700     '01084702200030003057014000140097280270003800870903000042'.  03770000
037800       10  FILLER                  PIC X(56) VALUE                03780000
037900     '02040805300077012348048000660057280230003001168405200067'.  03790000
038000       10  FILLER                  PIC X(56) VALUE                03800000
038100     '00631002400033008974041000520060660310003400502702500032'.  03810000
038200       10  FILLER                  PIC X(56) VALUE                03820000
038300     '00355602000022006712025000280058370440004400524202600034'.  03830000
038400       10  FILLER                  PIC X(56) VALUE                03840000
038500     '01699602900045007472019000230035780200002800392501600021'.  03850000
038600       10  FILLER                  PIC X(56) VALUE                03860000
038700     '00603401600022002070013000140050530260003700322501800026'.  03870000
038800       10  FILLER                  PIC X(56) VALUE                03880000
038900     '01393001800018045935179001790313721330013301892908600086'.  03890000
039000       10  FILLER                  PIC X(56) VALUE                03900000
039100     '03222604700047011406034000340015440310003103045906500092'.  03910000
039200       10  FILLER                  PIC X(56) VALUE                03920000
039300     '01364509100091019109045000740083280320004300832302600043'.  03930000
039400       10  FILLER                  PIC X(56) VALUE                03940000
039500     '01298603700051012082044000570066740270003300000000000000'.  03950000
039600       10  FILLER                  PIC X(56) VALUE                03960000
039700     '02967808000113011810028000410184320580008100926503000042'.  03970000
039800       10  FILLER                  PIC X(56) VALUE                03980000
039900     '01934604900049027897070000990122890300003802246004800082'.  03990000
040000       10  FILLER                  PIC X(56) VALUE                04000000
040100     '01207404300058011069030000380036350250003300845101800028'.  04010000
040200       10  FILLER                  PIC X(56) VALUE                04020000
040300     '01304805000068007788030000400398901100014801677405600075'.  04030000
040400       10  FILLER                  PIC X(56) VALUE                04040000
040500     '01168903200041010716048000620084530340004400607702700034'.  04050000
040600       10  FILLER                  PIC X(56) VALUE                04060000
040700     '00766403100041006171026000370191960600008402277307300124'.  04070000
040800       10  FILLER                  PIC X(56) VALUE                04080000
040900     '00619102600035004656030000410051350320004700698104600073'.  04090000
041000       10  FILLER                  PIC X(56) VALUE                04100000
041100     '00791904300056006483058000790051780400005900628202900043'.  04110000
041200       10  FILLER                  PIC X(56) VALUE                04120000
041300     '00277602200030000000000000000000000000000000000000000000'.  04130000
041400       10  FILLER                  PIC X(56) VALUE                04140000
041500     '00000000000000000000000000000193980540008901945705900092'.  04150000
041600       10  FILLER                  PIC X(56) VALUE                04160000
041700     '00938202300034025660060000890099430260003400755603200041'.  04170000
041800       10  FILLER                  PIC X(56) VALUE                04180000
041900     '00503302200028002999024000240055690190002600098702900029'.  04190000
042000       10  FILLER                  PIC X(56) VALUE                04200000
042100     '00852902600037004282016000200026630210002101046203500049'.  04210000
042200       10  FILLER                  PIC X(56) VALUE                04220000
042300     '00528502200028008141029000410047250170002200000000000000'.  04230000
042400       10  FILLER                  PIC X(56) VALUE                04240000
042500     '00000000000000000000000000000000000000000000000000000000'.  04250000
042600       10  FILLER                  PIC X(56) VALUE                04260000
042700     '01397403000051008700089001080069600310003900505502400029'.  04270000
042800       10  FILLER                  PIC X(56) VALUE                04280000
042900     '00622402400038007806028000530048030200002704003109700132'.  04290000
043000       10  FILLER                  PIC X(56) VALUE                04300000
043100     '00000000000000000000000000000313910450005100000000000000'.  04310000
043200       10  FILLER                  PIC X(56) VALUE                04320000
043300     '03423107400127000000000000000360910810011302182207400105'.  04330000
043400       10  FILLER                  PIC X(56) VALUE                04340000
043500     '02060705800087000000000000000144340210002808969313700180'.  04350000
043600       10  FILLER                  PIC X(56) VALUE                04360000
043700     '06232118200217033387096001210000000000000005143809300128'.  04370000
043800       10  FILLER                  PIC X(56) VALUE                04380000
043900     '03495208400102047323085001250194590530007304435311800164'.  04390000
044000       10  FILLER                  PIC X(56) VALUE                04400000
044100     '01805805900084010639038000540167800260003103592608800137'.  04410000
044200       10  FILLER                  PIC X(56) VALUE                04420000
044300     '01833304500061010285021000270857361400017306093206400088'.  04430000
044400       10  FILLER                  PIC X(56) VALUE                04440000
044500     '03622405000059027791034000380138310310004300904601800022'.  04450000
044600       10  FILLER                  PIC X(56) VALUE                04460000
044700     '02646208500104014462049000590120380290003811801821700273'.  04470000
044800       10  FILLER                  PIC X(56) VALUE                04480000
044900     '02295302400046040939112001590173690580008501276705100074'.  04490000
045000       10  FILLER                  PIC X(56) VALUE                04500000
045100     '00821703600052011817044000640074240260004105366010700128'.  04510000
045200       10  FILLER                  PIC X(56) VALUE                04520000
045300     '05966908900099000000000000000552050260004300000000000000'.  04530000
045400       10  FILLER                  PIC X(56) VALUE                04540000
045500     '00000000000000016544018000250246950300004801678801600020'.  04550000
045600       10  FILLER                  PIC X(56) VALUE                04560000
045700     '00693904200056004794077000960037930320003900728802600032'.  04570000
045800       10  FILLER                  PIC X(56) VALUE                04580000
045900     '11428207200136000000000000000000000000000007050513800172'.  04590000
046000       10  FILLER                  PIC X(56) VALUE                04600000
046100     '02316005300083012041024000310312790650009601419502800037'.  04610000
046200       10  FILLER                  PIC X(56) VALUE                04620000
046300     '01576702400038010201015000180797380790010306914405900076'.  04630000
046400       10  FILLER                  PIC X(56) VALUE                04640000
046500     '01836004800069009833021000280327820700010801194002600036'.  04650000
046600       10  FILLER                  PIC X(56) VALUE                04660000
046700     '19803838100457128719291003510441840850012301964304100045'.  04670000
046800       10  FILLER                  PIC X(56) VALUE                04680000
046900     '02482704500052050739071000880619481080012304719808200090'.  04690000
047000       10  FILLER                  PIC X(56) VALUE                04700000
047100     '05098008700103036151062000690310070440006402099602500035'.  04710000
047200       10  FILLER                  PIC X(56) VALUE                04720000
047300     '03095706600097020721040000590243150340004701913201600021'.  04730000
047400       10  FILLER                  PIC X(56) VALUE                04740000
047500     '02871703000041022108015000190224730580007200000000000000'.  04750000
047600     05  DRGX-TAB REDEFINES D-TAB.                                04760000
047700         10  DRGX-PERIOD               OCCURS 1                   04770000
047800                                        INDEXED BY DX5.           04780000
047900             15  DRGX-EFF-DATE         PIC X(08).                 04790000
048000             15  DRG-DATA              OCCURS 560                 04800000
048100                                        INDEXED BY DX6.           04810000
048200                 20  DRG-WT            PIC 9(02)V9(04).           04820000
048300                 20  DRG-ALOS          PIC 9(02)V9(01).           04830000
048400                 20  DRG-DAYS-TRIM     PIC 9(02).                 04840000
048500                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).           04850000
048600                                                                  04860000
048700 01  HOLD-AREA.                                                   04870000
048800     02  HOLD-PPS-COMPONENTS.                                     04880000
048900         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).        04890000
049000         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).        04900000
049100                                                                  04910000
049200         05  H-OPER-HSP-PART              PIC 9(06)V9(09).        04920000
049300         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).        04930000
049400                                                                  04940000
049500         05  H-OPER-FSP-PART              PIC 9(06)V9(09).        04950000
049600         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).        04960000
049700         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).        04970000
049800                                                                  04980000
049900         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).        04990000
050000         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).        05000000
050100         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).        05010000
050200                                                                  05020000
050300         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).        05030000
050400         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).        05040000
050500                                                                  05050000
050600         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).        05060000
050700         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).        05070000
050800                                                                  05080000
050900         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).        05090000
051000         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).        05100000
051100                                                                  05110000
051200         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).        05120000
051300         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).        05130000
051400         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).        05140000
051500         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).        05150000
051600         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).        05160000
051700         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).        05170000
051800         05  H-CAPI-COLA                  PIC 9(01)V9(03).        05180000
051900         05  H-CAPI-SCH                   PIC 9(05)V9(02).        05190000
052000         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).        05200000
052100         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).        05210000
052200         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).        05220000
052300         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).        05230000
052400         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).        05240000
052500         05  H-CAPI-GAF                   PIC 9(05)V9(04).        05250000
052600         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).        05260000
052700         05  H-BLEND-GAF                  PIC 9(05)V9(04).        05270000
052800         05  H-WAGE-INDEX                 PIC 9(02)V9(04).        05280000
052900         05  H-COV-DAYS                   PIC 9(3).               05290000
053000         05  H-PERDIEM-DAYS               PIC 9(3).               05300000
053100         05  H-REG-DAYS                   PIC 9(3).               05310000
053200         05  H-LTR-DAYS                   PIC 9(3).               05320000
053300         05  H-DSCHG-FRCTN                PIC 9(1)V9999.          05330000
053400         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.          05340000
053500         05  H-ALOS                       PIC 9(02)V9(01).        05350000
053600         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).        05360000
053700         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).        05370000
053800         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).        05380000
053900         05  H-CST-THRESH                 PIC 9(05)V9(02).        05390000
054000         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).        05400000
054100         05  H-BUDG-NUTR01                PIC 9(01)V9(06).        05410000
054200         05  H-BUDG-NUTR02                PIC 9(01)V9(06).        05420000
054300         05  H-BUDG-NUTR03                PIC 9(01)V9(06).        05430000
054400         05  H-BUDG-NUTR04                PIC 9(01)V9(06).        05440000
054500         05  H-BUDG-NUTR05                PIC 9(01)V9(06).        05450000
054600         05  H-BUDG-NUTR06                PIC 9(01)V9(06).        05460000
054700         05  H-UPDATE-01                  PIC 9(01)V9(04).        05470000
054800         05  H-UPDATE-02                  PIC 9(01)V9(04).        05480000
054900         05  H-UPDATE-03                  PIC 9(01)V9(04).        05490000
055000         05  H-UPDATE-04                  PIC 9(01)V9(04).        05500000
055100         05  H-UPDATE-05                  PIC 9(01)V9(04).        05510000
055200         05  H-UPDATE-06                  PIC 9(01)V9(04).        05520000
055300         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).        05530000
055400         05  H-HSP-UPDATE94               PIC 9(01)V9(04).        05540000
055500         05  H-HSP-UPDATE95               PIC 9(01)V9(04).        05550000
055600         05  H-HSP-UPDATE96               PIC 9(01)V9(04).        05560000
055700         05  H-HSP-UPDATE97               PIC 9(01)V9(04).        05570000
055800         05  H-HSP-UPDATE98               PIC 9(01)V9(04).        05580000
055900         05  H-HSP-UPDATE99               PIC 9(01)V9(04).        05590000
056000         05  H-HSP-UPDATE00               PIC 9(01)V9(04).        05600000
056100         05  H-HSP-UPDATE01               PIC 9(01)V9(04).        05610000
056200         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).        05620000
056300         05  H-FEDERAL-RATE               PIC 9(04)V9(02).        05630000
056400         05  H-LABOR-PCT                  PIC 9(01)V9(04).        05640000
056500         05  H-NONLABOR-PCT               PIC 9(01)V9(04).        05650000
056600         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).        05660000
056700         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).        05670000
056800         05  H-HSP-RATE                   PIC 9(06)V9(09).        05680000
056900         05  H-FSP-RATE                   PIC 9(06)V9(09).        05690000
057000         05  H-OUTLIER-OFFSET-NAT         PIC 9(01)V9(06).        05700000
057100         05  H-OUTLIER-OFFSET-PR          PIC 9(01)V9(06).        05710000
057200         05  H-WK-OPER-DSH                PIC 9(01)V9(04).        05720000
057300         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).        05730000
057400         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).        05740000
057500         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).        05750000
057600         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).        05760000
057700         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.           05770000
057800         05  H-BASE-DRG-PAYMENT           PIC S9(07)V99.          05780000
057900         05  H-NEW-TECH-ADDON-NEURO       PIC S9(07)V99.          05790000
058000         05  H-NEW-TECH-ADDON-GRAFT       PIC S9(07)V99.          05800000
058100         05  H-NEW-TECH-ADDON-KINETRA     PIC S9(07)V99.          05810000
058200                                                                  05820000
058300         05  H-LESSER-NEURO-1             PIC S9(07)V99.          05830000
058400         05  H-LESSER-NEURO-2             PIC S9(07)V99.          05840000
058500                                                                  05850000
058600         05  H-LESSER-GRAFT-1             PIC S9(07)V99.          05860000
058700         05  H-LESSER-GRAFT-2             PIC S9(07)V99.          05870000
058800                                                                  05880000
058900         05  H-LESSER-KINETRA-1           PIC S9(07)V99.          05890000
059000         05  H-LESSER-KINETRA-2           PIC S9(07)V99.          05900000
059100                                                                  05910000
059200                                                                  05920000
059300         05  H-CSTMED-NEURO               PIC S9(07)V99.          05930000
059400         05  H-CSTMED-GRAFT               PIC S9(07)V99.          05940000
059500         05  H-CSTMED-KINETRA             PIC S9(07)V99.          05950000
059600                                                                  05960000
059700                                                                  05970000
059800     02  HOLD-ADDITIONAL-VARIABLES.                               05980000
059900         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).        05990000
060000         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).        06000000
060100         05  H-NAT-PCT                    PIC 9(01)V9(02).        06010000
060200         05  H-REG-PCT                    PIC 9(01)V9(02).        06020000
060300         05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).        06030000
060400         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).        06040000
060500         05  H-DRG-WT                     PIC 9(02)V9(04).        06050000
060600         05  H-NAT-LABOR                  PIC 9(05)V9(02).        06060000
060700         05  H-NAT-NONLABOR               PIC 9(05)V9(02).        06070000
060800         05  H-REG-LABOR                  PIC 9(05)V9(02).        06080000
060900         05  H-REG-NONLABOR               PIC 9(05)V9(02).        06090000
061000         05  H-OPER-COLA                  PIC 9(01)V9(03).        06100000
061100         05  H-INTERN-RATIO               PIC 9(01)V9(04).        06110000
061200         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).        06120000
061300         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).        06130000
061400         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).        06140000
061500                                                                  06150000
061600     02  HOLD-CAPITAL-VARIABLES.                                  06160000
061700         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).        06170000
061800         05  H-CAPI-HSP                   PIC 9(07)V9(02).        06180000
061900         05  H-CAPI-FSP                   PIC 9(07)V9(02).        06190000
062000         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).        06200000
062100         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).        06210000
062200         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).        06220000
062300         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).        06230000
062400         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).        06240000
062500                                                                  06250000
062600     02  HOLD-CAPITAL2-VARIABLES.                                 06260000
062700         05  H-CAPI2-PAY-CODE             PIC X(1).               06270000
062800         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).        06280000
062900         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).        06290000
063000                                                                  06300000
063100     02  HOLD-OTHER-VARIABLES.                                    06310000
063200         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).        06320000
063300         05  H-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).        06330000
063400         05  H-LOW-VOL-PAYMENT              PIC 9(07)V9(02).      06331011
063500         05  H-HVBP-HRR-DATA.                                     06332011
063600             10  H-VAL-BASED-PURCH-PARTIPNT PIC X.                06333011
063700             10  H-VAL-BASED-PURCH-ADJUST     PIC 9V9(11).        06334011
063800             10  H-HOSP-READMISS-REDUCTN      PIC X.              06335011
063900             10  H-HOSP-HRR-ADJUSTMT          PIC 9V9(4).         06336020
064000         05  H-OPERATNG-DATA.                                     06337011
064100             10  H-MODEL1-BUNDLE-DISPRCNT    PIC V999.            06338023
064200             10  H-OPER-BASE-DRG-PAY         PIC 9(08)V99.        06339011
064300             10  H-OPER-HSP-AMT              PIC 9(08)V99.        06339111
064400                                                                  06350000
064500     02  HOLD-PC-OTH-VARIABLES.                                   06360000
064600         05  H-OPER-DSH                   PIC 9(01)V9(04).        06370000
064700         05  H-CAPI-DSH                   PIC 9(01)V9(04).        06380000
064800         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).        06390000
064900         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).        06400000
065000         05  H-ARITH-ALOS                 PIC 9(02)V9(01).        06410000
065100         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).        06420000
065200         05  H-TRANSFER-ADJ               PIC 9(01)V9(05).        06430000
065300         05  H-PC-HMO-FLAG                PIC X(01).              06440000
065400         05  H-PC-COT-FLAG                PIC X(01).              06450000
065500         05  H-FILLER                        PIC X(0998).         06451023
065600                                                                  06470000
065700 01  HLD-PPS-DATA.                                                06480000
065800         10  HLD-PPS-RTC                PIC 9(02).                06490000
065900         10  HLD-PPS-WAGE-INDX          PIC 9(02)V9(04).          06500000
066000         10  HLD-PPS-OUTLIER-DAYS       PIC 9(03).                06510000
066100         10  HLD-PPS-AVG-LOS            PIC 9(02)V9(01).          06520000
066200         10  HLD-PPS-DAYS-CUTOFF        PIC 9(02)V9(01).          06530000
066300         10  HLD-PPS-OPER-IME-ADJ       PIC 9(06)V9(02).          06540000
066400         10  HLD-PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).          06550000
066500         10  HLD-PPS-OPER-HSP-PART      PIC 9(06)V9(02).          06560000
066600         10  HLD-PPS-OPER-FSP-PART      PIC 9(06)V9(02).          06570000
066700         10  HLD-PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).          06580000
066800         10  HLD-PPS-REG-DAYS-USED      PIC 9(03).                06590000
066900         10  HLD-PPS-LTR-DAYS-USED      PIC 9(02).                06600000
067000         10  HLD-PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).          06610000
067100         10  HLD-PPS-CALC-VERS          PIC X(05).                06620000
067200                                                                  06630000
067300 LINKAGE SECTION.                                                 06640000
067400***************************************************************   06650000
067500*                 * * * * * * * * *                           *   06660000
067600*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *   06670000
067700*    IN HOW TO PAY THE BILL.                                  *   06680000
067800*                         *****                               *   06690000
067900*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *   06700000
068000*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *   06710000
068100*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *   06720000
068200*                 OUTLIER COMPUTATION.                        *   06730000
068300*                         *****                               *   06740000
068400*         REVIEW-CODE:                                        *   06750000
068500*            00 = PAY-WITH-OUTLIER.                           *   06760000
068600*                 WILL CALCULATE THE STANDARD PAYMENT.        *   06770000
068700*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *   06780000
068800*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *   06790000
068900*            03 = PAY-PERDIEM-DAYS.                           *   06800000
069000*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   06810000
069100*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *   06820000
069200*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   06830000
069300*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   06840000
069400*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   06850000
069500*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *   06860000
069600*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   06870000
069700*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *   06880000
069800*                 BILL EXCEED THE COST THRESHOLD.             *   06890000
069900*            06 = PAY-XFER-NO-COST                            *   06900000
070000*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   06910000
070100*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *   06920000
070200*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   06930000
070300*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *   06940000
070400*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   06950000
070500*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *   06960000
070600*                 CALCULATE ANY COST OUTLIER PORTION          *   06970000
070700*                 OF THE PAYMENT.                             *   06980000
070800*            07 = PAY-WITHOUT-COST.                           *   06990000
070900*                 WILL CALCULATE THE STANDARD PAYMENT         *   07000000
071000*                 WITHOUT COST PORTION.                       *   07010000
071100*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *   07020000
071200*                 50-50> 7   8   210 211 233 234 471 497          07030000
071300*                        498 544 545 549 550                      07040000
071400*         FULL PERDIEM > 1    2    10   11   12   13   14         07050000
071500*                        15   16   17   18   19   20   24   25    07060000
071600*                        28   29   34   35   73   75   76   77    07070000
071700*                        78   79   80   82   83   84   85   86    07080000
071800*                        89   90   92   93   101  102  104  105   07090000
071900*                             108       113  114  120  121        07100000
072000*                        126  127  130  131  144  145  146        07110000
072100*                        147  148  149  150  151  154  155        07120000
072200*                        157  158  170  171  172  173  176        07130000
072300*                        180  181  188  189  191  192  197        07140000
072400*                        198  205  206  213  216                  07150000
072500*                        217  218  219  225  226  227             07160000
072600*                        235  236  238  239  240  241             07170000
072700*                        244  245  250  251  253  254  256        07180000
072800*                        263  264  265  266  269  270  271        07190000
072900*                        272  273  277  278  280  281  283        07200000
073000*                        284  285  287  292  293  294  296        07210000
073100*                        297  300  301  304  305  316  320        07220000
073200*                        321  331  332  395  401  402  403        07230000
073300*                        404  415  416  418  423  429  430        07240000
073400*                        440  442  443  444  445  462  463        07250000
073500*                        464  468  475  477       482             07260000
073600*                        485  487  501  502  521                  07270000
073700*                        522  529  530  531  532  537  538        07280000
073800*                        541  542  543  547  548                  07290000
073900*                        553  554                                 07300000
074000*                               POST-ACUTE TRANSFERS          *   07310000
074100*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   07320000
074200*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*   07330000
074300*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   07340000
074400*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   07350000
074500*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   07360000
074600*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *   07370000
074700*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   07380000
074800*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *   07390000
074900*                 BILL EXCEED THE COST THRESHOLD.             *   07400000
075000*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *   07410000
075100*                 POST-ACUTE TRANSFERS                        *   07420000
075200*                 50-50> 7   8   210 211 233 234 471 497          07430000
075300*                        498 544 545 549 550                      07440000
075400*         FULL PERDIEM > 1    2    10   11   12   13   14         07450000
075500*                        15   16   17   18   19   20   24   25    07460000
075600*                        28   29   34   35   73   75   76   77    07470000
075700*                        78   79   80   82   83   84   85   86    07480000
075800*                        89   90   92   93   101  102  104  105   07490000
075900*                             108       113  114  120  121        07500000
076000*                        126  127  130  131  144  145  146        07510000
076100*                        147  148  149  150  151  154  155        07520000
076200*                        157  158  170  171  172  173  176        07530000
076300*                        180  181  188  189  191  192  197        07540000
076400*                        198  205  206  213  216                  07550000
076500*                        217  218  219  225  226  227             07560000
076600*                        235  236  238  239  240  241             07570000
076700*                        244  245  250  251  253  254  256        07580000
076800*                        263  264  265  266  269  270  271        07590000
076900*                        272  273  277  278  280  281  283        07600000
077000*                        284  285  287  292  293  294  296        07610000
077100*                        297  300  301  304  305  316  320        07620000
077200*                        321  331  332  395  401  402  403        07630000
077300*                        404  415  416  418  423  429  430        07640000
077400*                        440  442  443  444  445  462  463        07650000
077500*                        464  468  475  477       482             07660000
077600*                        485  487  501  502  521                  07670000
077700*                        522  529  530  531  532  537  538        07680000
077800*                        541  542  543  547  548                  07690000
077900*                        553  554                                 07700000
078000*                               POST-ACUTE TRANSFERS          *   07710000
078100*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   07720000
078200*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*   07730000
078300*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   07740000
078400*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   07750000
078500*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   07760000
078600*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *   07770000
078700*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   07780000
078800*                 PAYMENT.                                    *   07790000
078900***************************************************************   07800000
079000                                                                  07810000
079100**************************************************************    07820000
079200*      MILLINNIUM COMPATIBLE                                 *    07830000
079300*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *    07840000
079400*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *    07850000
079500*      IN THE NEW FORMAT                                     *    07860000
079600**************************************************************    07870000
079700 01  BILL-NEW-DATA.                                               07880000
079800         10  B-NPI10.                                             07890000
079900             15  B-NPI8             PIC X(08).                    07900000
080000             15  B-NPI-FILLER       PIC X(02).                    07910000
080100         10  B-PROVIDER-NO          PIC X(06).                    07920000
080200         10  B-REVIEW-CODE          PIC 9(02).                    07930000
080300             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.    07940000
080400             88  PAY-WITH-OUTLIER     VALUE 00 07.                07950000
080500             88  PAY-PERDIEM-DAYS     VALUE 03.                   07960000
080600             88  PAY-XFER-NO-COST     VALUE 06.                   07970000
080700             88  PAY-WITHOUT-COST     VALUE 07.                   07980000
080800             88  PAY-XFER-SPEC-DRG    VALUE 09 11.                07990000
080900             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.              08000000
081000         10  B-DRG                  PIC 9(03).                    08010000
081100             88  B-DRG-POSTACUTE-50-50                            08020000
081200                   VALUE   7   8 210 211 233 234 471 497          08030000
081300                         498 544 545 549 550.                     08040000
081400             88  B-DRG-POSTACUTE-PERDIEM                          08050000
081500                   VALUE 1    2    10   11   12   13   14         08060000
081600                         15   16   17   18   19   20   24   25    08070000
081700                         28   29   34   35   73   75   76   77    08080000
081800                         78   79   80   82   83   84   85   86    08090000
081900                         89   90   92   93   101  102  104  105   08100000
082000                              108       113  114  120  121        08110000
082100                         126  127  130  131  144  145  146        08120000
082200                         147  148  149  150  151  154  155        08130000
082300                         157  158  170  171  172  173  176        08140000
082400                         180  181  188  189  191  192  197        08150000
082500                         198  205  206  213  216                  08160000
082600                         217  218  219  225  226  227             08170000
082700                         235  236  238  239  240  241             08180000
082800                         244  245  250  251  253  254  256        08190000
082900                         263  264  265  266  269  270  271        08200000
083000                         272  273  277  278  280  281  283        08210000
083100                         284  285  287  292  293  294  296        08220000
083200                         297  300  301  304  305  316  320        08230000
083300                         321  331  332  395  401  402  403        08240000
083400                         404  415  416  418  423  429  430        08250000
083500                         440  442  443  444  445  462  463        08260000
083600                         464  468  475  477       482             08270000
083700                         485  487  501  502  521                  08280000
083800                         522  529  530  531  532  537  538        08290000
083900                         541  542  543  547  548                  08300000
084000                         553  554.                                08310000
084100         10  B-LOS                  PIC 9(03).                    08320000
084200         10  B-COVERED-DAYS         PIC 9(03).                    08330000
084300         10  B-LTR-DAYS             PIC 9(02).                    08340000
084400         10  B-DISCHARGE-DATE.                                    08350000
084500             15  B-DISCHG-CC        PIC 9(02).                    08360000
084600             15  B-DISCHG-YY        PIC 9(02).                    08370000
084700             15  B-DISCHG-MM        PIC 9(02).                    08380000
084800             15  B-DISCHG-DD        PIC 9(02).                    08390000
084900         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).              08400000
085000         10  B-PRIN-PROC-CODE       PIC X(07).                    08410000
085100         10  B-OTHER-PROC-CODE1     PIC X(07).                    08420000
085200         10  B-OTHER-PROC-CODE2     PIC X(07).                    08430000
085300         10  B-OTHER-PROC-CODE3     PIC X(07).                    08440000
085400         10  B-OTHER-PROC-CODE4     PIC X(07).                    08450000
085500         10  B-OTHER-PROC-CODE5     PIC X(07).                    08460000
085600         10  B-OTHER-PROC-CODE6     PIC X(07).                    08461004
085700         10  B-OTHER-PROC-CODE7     PIC X(07).                    08462004
085800         10  B-OTHER-PROC-CODE8     PIC X(07).                    08463004
085900         10  B-OTHER-PROC-CODE9     PIC X(07).                    08464004
086000         10  B-OTHER-PROC-CODE10    PIC X(07).                    08465004
086100         10  B-OTHER-PROC-CODE11    PIC X(07).                    08466004
086200         10  B-OTHER-PROC-CODE12    PIC X(07).                    08467004
086300         10  B-OTHER-PROC-CODE13    PIC X(07).                    08468004
086400         10  B-OTHER-PROC-CODE14    PIC X(07).                    08469004
086500         10  B-OTHER-PROC-CODE15    PIC X(07).                    08469104
086600         10  B-OTHER-PROC-CODE16    PIC X(07).                    08469204
086700         10  B-OTHER-PROC-CODE17    PIC X(07).                    08469304
086800         10  B-OTHER-PROC-CODE18    PIC X(07).                    08469404
086900         10  B-OTHER-PROC-CODE19    PIC X(07).                    08469504
087000         10  B-OTHER-PROC-CODE20    PIC X(07).                    08469604
087100         10  B-OTHER-PROC-CODE21    PIC X(07).                    08469704
087200         10  B-OTHER-PROC-CODE22    PIC X(07).                    08469804
087300         10  B-OTHER-PROC-CODE23    PIC X(07).                    08469904
087400         10  B-OTHER-PROC-CODE24    PIC X(07).                    08470004
087500         10  B-OTHER-DIAG-CODE1     PIC X(07).                    08470106
087600         10  B-OTHER-DIAG-CODE2     PIC X(07).                    08470206
087700         10  B-OTHER-DIAG-CODE3     PIC X(07).                    08470306
087800         10  B-OTHER-DIAG-CODE4     PIC X(07).                    08470406
087900         10  B-OTHER-DIAG-CODE5     PIC X(07).                    08470506
088000         10  B-OTHER-DIAG-CODE6     PIC X(07).                    08470606
088100         10  B-OTHER-DIAG-CODE7     PIC X(07).                    08470706
088200         10  B-OTHER-DIAG-CODE8     PIC X(07).                    08470806
088300         10  B-OTHER-DIAG-CODE9     PIC X(07).                    08470906
088400         10  B-OTHER-DIAG-CODE10    PIC X(07).                    08471006
088500         10  B-OTHER-DIAG-CODE11    PIC X(07).                    08471106
088600         10  B-OTHER-DIAG-CODE12    PIC X(07).                    08471206
088700         10  B-OTHER-DIAG-CODE13    PIC X(07).                    08471306
088800         10  B-OTHER-DIAG-CODE14    PIC X(07).                    08471406
088900         10  B-OTHER-DIAG-CODE15    PIC X(07).                    08471506
089000         10  B-OTHER-DIAG-CODE16    PIC X(07).                    08471606
089100         10  B-OTHER-DIAG-CODE17    PIC X(07).                    08471706
089200         10  B-OTHER-DIAG-CODE18    PIC X(07).                    08471806
089300         10  B-OTHER-DIAG-CODE19    PIC X(07).                    08471906
089400         10  B-OTHER-DIAG-CODE20    PIC X(07).                    08472006
089500         10  B-OTHER-DIAG-CODE21    PIC X(07).                    08472106
089600         10  B-OTHER-DIAG-CODE22    PIC X(07).                    08472206
089700         10  B-OTHER-DIAG-CODE23    PIC X(07).                    08472306
089800         10  B-OTHER-DIAG-CODE24    PIC X(07).                    08472406
089900         10  B-OTHER-DIAG-CODE25    PIC X(07).                    08472506
090000         10  BILL-DEMO-DATA.                                      08472611
090100             15  BILL-DEMO-CODE1        PIC X(02).                08472711
090200             15  BILL-DEMO-CODE2        PIC X(02).                08472811
090300             15  BILL-DEMO-CODE3        PIC X(02).                08472911
090400             15  BILL-DEMO-CODE4        PIC X(02).                08473011
090500         10  BILL-NDC-DATA.                                       08473111
090600             15  BILL-NDC-NUMBER        PIC X(11).                08473211
090700         10  FILLER                     PIC X(73).                08473311
090800                                                                  08473411
090900                                                                  08473506
091000                                                                  08474000
091100***************************************************************   08480000
091200*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *   08490000
091300*    AND PASSED BACK TO THE CALLING PROGRAM                   *   08500000
091400*            RETURN CODE VALUES (PPS-RTC)                     *   08510000
091500*                                                             *   08520000
091600*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   08530000
091700*                                                             *   08540000
091800*      PPS-RTC 30,33,40,42,44  = OUTLIER RECONCILIATION       *   08550000
091900*                                                             *   08560000
092000*           30,00 = PAID NORMAL DRG PAYMENT                   *   08570000
092100*                                                             *   08580000
092200*              01 = PAID AS A DAY-OUTLIER.                    *   08590000
092300*                   NOTE:                                     *   08600000
092400*                     DAY-OUTLIER NO LONGER BEING PAID        *   08610000
092500*                         AS OF 10/01/97                      *   08620000
092600*                                                             *   08630000
092700*              02 = PAID AS A COST-OUTLIER.                   *   08640000
092800*                                                             *   08650000
092900*           33,03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   08660000
093000*                   AND INCLUDING THE FULL DRG.               *   08670000
093100*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   08680000
093200*                   AND INCLUDING THE FULL DRG WHICH ALSO     *   08690000
093300*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *   08700000
093400*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   08710000
093500*                   AND INCLUDING THE FULL DRG. PROVIDER      *   08720000
093600*                   REFUSED COST OUTLIER.                     *   08730000
093700*           40,10 = POST-ACUTE TRANSFER                       *   08740000
093800*                   DRG =  7   8 210 211 233 234 471 497          08750000
093900*                        498 544 545 549 550                      08760000
094000*           42,12 = POST-CAUTE TRANSFER WITH SPECIFIC DRGS    *   08770000
094100*                       THE FOLLOWING DRG'S                   *   08780000
094200*                   DRG =1    2    10   11   12   13   14         08790000
094300*                        15   16   17   18   19   20   24   25    08800000
094400*                        28   29   34   35   73   75   76   77    08810000
094500*                        78   79   80   82   83   84   85   86    08820000
094600*                        89   90   92   93   101  102  104  105   08830000
094700*                             108       113  114  120  121        08840000
094800*                        126  127  130  131  144  145  146        08850000
094900*                        147  148  149  150  151  154  155        08860000
095000*                        157  158  170  171  172  173  176        08870000
095100*                        180  181  188  189  191  192  197        08880000
095200*                        198  205  206  213  216                  08890000
095300*                        217  218  219  225  226  227             08900000
095400*                        235  236  238  239  240  241             08910000
095500*                        244  245  250  251  253  254  256        08920000
095600*                        263  264  265  266  269  270  271        08930000
095700*                        272  273  277  278  280  281  283        08940000
095800*                        284  285  287  292  293  294  296        08950000
095900*                        297  300  301  304  305  316  320        08960000
096000*                        321  331  332  395  401  402  403        08970000
096100*                        404  415  416  418  423  429  430        08980000
096200*                        440  442  443  444  445  462  463        08990000
096300*                        464  468  475  477       482             09000000
096400*                        485  487  501  502  521                  09010000
096500*                        522  529  530  531  532  537  538        09020000
096600*                        541  542  543  547  548                  09030000
096700*                        553  554.                                09040000
096800*           44,14 = PAID NORMAL DRG PAYMENT WITH              *   09050000
096900*                    PERDIEM DAYS = OR > GM  ALOS             *   09060000
097000*              16 = PAID AS A COST-OUTLIER WITH               *   09070000
097100*                    PERDIEM DAYS = OR > GM  ALOS             *   09080000
097200*                                                             *   09090000
097300*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   09100000
097400*              51 = NO PROVIDER SPECIFIC INFO FOUND           *   09110000
097500*              52 = INVALID CBSA# IN PROVIDER FILE            *   09120000
097600*                   OR INVALID WAGE INDEX                     *   09130000
097700*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   09140000
097800*              54 = DRG < 001 OR > 559,                       *   09150000
097900*                                 OR = 004 OR = 005           *   09160000
098000*                                 OR = 107 OR = 109           *   09170000
098100*                                 OR = 112 OR = 115               09180000
098200*                                 OR = 116 OR = 209               09190000
098300*                                 OR = 214 OR = 215               09200000
098400*                                 OR = 221 OR = 222               09210000
098500*                                 OR = 231 OR = 400               09220000
098600*                                 OR = 434 OR = 435               09230000
098700*                                 OR = 436 OR = 437               09240000
098800*                                 OR = 438 OR = 456               09250000
098900*                                 OR = 457 OR = 458               09260000
099000*                                 OR = 459 OR = 460               09270000
099100*                                 OR = 469 OR = 470               09280000
099200*                                 OR = 472 OR = 474               09290000
099300*                                 OR = 478 OR = 483               09300000
099400*                                 OR = 514 OR = 516               09310000
099500*                                 OR = 517 OR = 526               09320000
099600*                                 OR = 527                        09330000
099700*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   09340000
099800*                                      OR                     *   09350000
099900*                   DISCHARGE DATE < CBSA EFF START DATE      *   09360000
100000*                   FOR PPS                                   *   09370000
100100*                                      OR                     *   09380000
100200*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *   09390000
100300*                   DISCHARGE DATE                            *   09400000
100400*              56 = INVALID LENGTH OF STAY                    *   09410000
100500*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *   09420000
100600*                                        NOT 11)              *   09430000
100700*              58 = TOTAL CHARGES NOT NUMERIC                 *   09440000
100800*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   09450000
100900*                   OR BILL-LTR-DAYS > 60                     *   09460000
101000*              62 = INVALID NUMBER OF COVERED DAYS            *   09470000
101100*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *   09480000
101200*                   SPECIFIC FILE FOR CAPITAL                 *   09490000
101300*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   09500000
101400*                   OR COST OUTLIER THRESHOLD CALUCULATION    *   09510000
101500*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *   09520000
101600***************************************************************   09530000
101700 01  PPS-DATA.                                                    09540000
101800         10  PPS-RTC                PIC 9(02).                    09550000
101900         10  PPS-WAGE-INDX          PIC 9(02)V9(04).              09560000
102000         10  PPS-OUTLIER-DAYS       PIC 9(03).                    09570000
102100         10  PPS-AVG-LOS            PIC 9(02)V9(01).              09580000
102200         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).              09590000
102300         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).              09600000
102400         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).              09610000
102500         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).              09620000
102600         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).              09630000
102700         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).              09640000
102800         10  PPS-REG-DAYS-USED      PIC 9(03).                    09650000
102900         10  PPS-LTR-DAYS-USED      PIC 9(02).                    09660000
103000         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).              09670000
103100         10  PPS-CALC-VERS          PIC X(05).                    09680000
103200                                                                  09690000
103300******************************************************************09700000
103400*            THESE ARE THE VERSIONS OF THE PPCAL                  09710000
103500*           PROGRAMS THAT WILL BE PASSED BACK----                 09720000
103600*          ASSOCIATED WITH THE BILL BEING PROCESSED               09730000
103700******************************************************************09740000
103800 01  PRICER-OPT-VERS-SW.                                          09750000
103900     02  PRICER-OPTION-SW          PIC X(01).                     09760000
104000         88  ALL-TABLES-PASSED          VALUE 'A'.                09770000
104100         88  PROV-RECORD-PASSED         VALUE 'P'.                09780000
104200         88  ADDITIONAL-VARIABLES       VALUE 'M'.                09790000
104300         88  PC-PRICER                  VALUE 'C'.                09800000
104400     02  PPS-VERSIONS.                                            09810000
104500         10  PPDRV-VERSION         PIC X(05).                     09820000
104600                                                                  09830000
104700******************************************************************09840000
104800*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK           09850000
104900*          ASSOCIATED WITH THE BILL BEING PROCESSED               09860000
105000******************************************************************09870000
105100 01  PPS-ADDITIONAL-VARIABLES.                                    09880000
105200     05  PPS-HSP-PCT                PIC 9(01)V9(02).              09890000
105300     05  PPS-FSP-PCT                PIC 9(01)V9(02).              09900000
105400     05  PPS-NAT-PCT                PIC 9(01)V9(02).              09910000
105500     05  PPS-REG-PCT                PIC 9(01)V9(02).              09920000
105600     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).              09930000
105700     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).              09940000
105800     05  PPS-DRG-WT                 PIC 9(02)V9(04).              09950000
105900     05  PPS-NAT-LABOR              PIC 9(05)V9(02).              09960000
106000     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).              09970000
106100     05  PPS-REG-LABOR              PIC 9(05)V9(02).              09980000
106200     05  PPS-REG-NLABOR             PIC 9(05)V9(02).              09990000
106300     05  PPS-OPER-COLA              PIC 9(01)V9(03).              10000000
106400     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).              10010000
106500     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).              10020000
106600     05  PPS-BILL-COSTS             PIC 9(07)V9(09).              10030000
106700     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).              10040000
106800     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.                10050000
106900     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.                10060000
107000     05  PPS-CAPITAL-VARIABLES.                                   10070000
107100         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).        10080000
107200         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).        10090000
107300         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).        10100000
107400         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).        10110000
107500         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).        10120000
107600         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).        10130000
107700         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).        10140000
107800         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).        10150000
107900     05  PPS-CAPITAL2-VARIABLES.                                  10160000
108000         10  PPS-CAPI2-PAY-CODE             PIC X(1).             10170000
108100         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).      10180000
108200         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).      10190000
108300                                                                  10200000
108400     05  PPS-OTHER-VARIABLES.                                     10210000
108500         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).      10220000
108600         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).      10230000
108700         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).      10231004
108800         10  PPS-HVBP-HRR-DATA.                                   10233011
108900             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.              10234011
109000             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).        10235011
109100             15  PPS-HOSP-READMISS-REDUCTN    PIC X.              10236011
109200             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).         10237020
109300         10  PPS-OPERATNG-DATA.                                   10238011
109400             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.            10239023
109500             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.        10239111
109600             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.        10239211
109700                                                                  10250000
109800     05  PPS-PC-OTH-VARIABLES.                                    10260000
109900         10  PPS-OPER-DSH                   PIC 9(01)V9(04).      10270000
110000         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).      10280000
110100         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).      10290000
110200         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).      10300000
110300         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).      10310000
110400         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).      10320000
110500         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(05).      10330000
110600         10  PPS-PC-HMO-FLAG                PIC X(01).            10340000
110700         10  PPS-PC-COT-FLAG                PIC X(01).            10350000
110800         10  PPS-FILLER                     PIC X(0998).          10351023
110900                                                                  10370000
111000**************************************************************    10380000
111100*      MILLINNIUM COMPATIBLE                                 *    10390000
111200*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BACK FROM *    10400000
111300*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *    10410000
111400*      IN THE NEW FORMAT                                     *    10420000
111500**************************************************************    10430000
111600 01  PROV-NEW-HOLD.                                               10440000
111700     02  PROV-NEWREC-HOLD1.                                       10450000
111800         05  P-NEW-NPI10.                                         10460000
111900             10  P-NEW-NPI8             PIC X(08).                10470000
112000             10  P-NEW-NPI-FILLER       PIC X(02).                10480000
112100         05  P-NEW-PROVIDER-NO.                                   10490000
112200             88  P-NEW-DSH-ADJ-PROVIDERS                          10500000
112300                             VALUE '180049' '190044' '190144'     10510000
112400                                   '190191' '330047' '340085'     10520000
112500                                   '370016' '370149' '420043'.    10530000
112600             10  P-NEW-STATE            PIC 9(02).                10540000
112700             10  FILLER                 PIC X(04).                10550000
112800         05  P-NEW-DATE-DATA.                                     10560000
112900             10  P-NEW-EFF-DATE.                                  10570000
113000                 15  P-NEW-EFF-DT-CC    PIC 9(02).                10580000
113100                 15  P-NEW-EFF-DT-YY    PIC 9(02).                10590000
113200                 15  P-NEW-EFF-DT-MM    PIC 9(02).                10600000
113300                 15  P-NEW-EFF-DT-DD    PIC 9(02).                10610000
113400             10  P-NEW-FY-BEGIN-DATE.                             10620000
113500                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                10630000
113600                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                10640000
113700                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                10650000
113800                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                10660000
113900             10  P-NEW-REPORT-DATE.                               10670000
114000                 15  P-NEW-REPORT-DT-CC PIC 9(02).                10680000
114100                 15  P-NEW-REPORT-DT-YY PIC 9(02).                10690000
114200                 15  P-NEW-REPORT-DT-MM PIC 9(02).                10700000
114300                 15  P-NEW-REPORT-DT-DD PIC 9(02).                10710000
114400             10  P-NEW-TERMINATION-DATE.                          10720000
114500                 15  P-NEW-TERM-DT-CC   PIC 9(02).                10730000
114600                 15  P-NEW-TERM-DT-YY   PIC 9(02).                10740000
114700                 15  P-NEW-TERM-DT-MM   PIC 9(02).                10750000
114800                 15  P-NEW-TERM-DT-DD   PIC 9(02).                10760000
114900         05  P-NEW-WAIVER-CODE          PIC X(01).                10770000
115000             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              10780000
115100         05  P-NEW-INTER-NO             PIC 9(05).                10790000
115200         05  P-NEW-PROVIDER-TYPE        PIC X(02).                10800000
115300             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.      10810000
115400             88  P-N-REFERRAL-CENTER        VALUE '07' '11'       10820000
115500                                                  '15' '17'       10830000
115600                                                  '22'.           10840000
115700             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.           10850000
115800             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.           10860000
115900             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.           10870000
116000             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.           10880000
116100             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.      10890000
116200             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.           10900000
116300             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.      10910000
116400             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.           10920000
116500             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.           10930000
116600             88  P-N-EACH                   VALUE '21' '22'.      10940000
116700             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.           10950000
116800             88  P-N-NHCMQ-II-SNF           VALUE '32'.           10960000
116900             88  P-N-NHCMQ-III-SNF          VALUE '33'.           10970000
117000         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                10980000
117100             88  P-N-NEW-ENGLAND            VALUE  1.             10990000
117200             88  P-N-MIDDLE-ATLANTIC        VALUE  2.             11000000
117300             88  P-N-SOUTH-ATLANTIC         VALUE  3.             11010000
117400             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.             11020000
117500             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.             11030000
117600             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.             11040000
117700             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.             11050000
117800             88  P-N-MOUNTAIN               VALUE  8.             11060000
117900             88  P-N-PACIFIC                VALUE  9.             11070000
118000         05  P-NEW-CURRENT-DIV   REDEFINES                        11080000
118100                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         11090000
118200             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.          11100000
118300         05  P-NEW-MSA-DATA.                                      11110000
118400             10  P-NEW-CHG-CODE-INDEX       PIC X.                11120000
118500             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 11130000
118600             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   11140000
118700                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       11150000
118800             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 11160000
118900             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 11170000
119000             10  P-NEW-STAND-AMT-LOC-MSA9                         11180000
119100       REDEFINES P-NEW-STAND-AMT-LOC-MSA.                         11190000
119200                 15  P-NEW-RURAL-1ST.                             11200000
119300                     20  P-NEW-STAND-RURAL  PIC XX.               11210000
119400                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    11220000
119500                 15  P-NEW-RURAL-2ND        PIC XX.               11230000
119600         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    11240000
119700                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           11250000
119800                 88  P-NEW-SCH-YR82       VALUE   '82'.           11260000
119900                 88  P-NEW-SCH-YR87       VALUE   '87'.           11270000
120000         05  P-NEW-LUGAR                    PIC X.                11280000
120100         05  P-NEW-TEMP-RELIEF-IND          PIC X.                11290000
120200         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                11300000
120300         05  FILLER                         PIC X(05).            11310000
120400     02  PROV-NEWREC-HOLD2.                                       11320000
120500         05  P-NEW-VARIABLES.                                     11330000
120600             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        11340000
120700             10  P-NEW-COLA              PIC  9(01)V9(03).        11350000
120800             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        11360000
120900             10  P-NEW-BED-SIZE          PIC  9(05).              11370000
121000             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        11380000
121100             10  P-NEW-CMI               PIC  9(01)V9(04).        11390000
121200             10  P-NEW-SSI-RATIO         PIC  V9(04).             11400000
121300             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             11410000
121400             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              11420000
121500             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        11430000
121600             10  P-NEW-DSH-PERCENT       PIC  V9(04).             11440000
121700             10  P-NEW-FYE-DATE          PIC  X(08).              11450000
121800         05  P-NEW-CBSA-DATA.                                     11460000
121900             10  FILLER                    PIC X.                 11470000
122000             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 11480000
122100             10  FILLER                    PIC X(21).             11490000
122200     02  PROV-NEWREC-HOLD3.                                       11500000
122300         05  P-NEW-PASS-AMT-DATA.                                 11510000
122400             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          11520000
122500             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          11530000
122600             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          11540000
122700             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          11550000
122800         05  P-NEW-CAPI-DATA.                                     11560000
122900             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 11570000
123000             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          11580000
123100             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          11590000
123200             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        11600000
123300             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             11610000
123400             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 11620000
123500             15  P-NEW-CAPI-IME            PIC 9V9999.            11630000
123600             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          11640000
123700         05  P-HVBP-HRR-DATA.                                     11640111
123800             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.                11640211
123900             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).          11640311
124000             15  P-HOSP-READMISSION-REDUCTN PIC X.                11640411
124100             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).           11640520
124200         05  P-MODEL1-BUNDLE-DATA.                                11640617
124300             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.             11640723
124400             15  P-HAC-REDUC-IND            PIC X.                11640825
124500             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.         11640925
124600             15  P-EHR-REDUC-IND            PIC X.                11641025
124700         05  FILLER                         PIC X(09).            11641125
124800                                                                  11641417
124900************************************************************      11642011
125000******************************************************************11660000
125100*      MILLINNIUM COMPATIBLE                                      11670000
125200*                   THIS IS THE WAGE-INDEX                        11680000
125300*          ASSOCIATED WITH THE BILL BEING PROCESSED               11690000
125400******************************************************************11700000
125500 01  WAGE-NEW-CBSA-INDEX-RECORD.                                  11710000
125600     05  W-CBSA                        PIC X(5).                  11720000
125700     05  W-CBSA-SIZE                   PIC X.                     11730000
125800         88  LARGE-URBAN       VALUE 'L'.                         11740000
125900         88  OTHER-URBAN       VALUE 'O'.                         11750000
126000         88  ALL-RURAL         VALUE 'R'.                         11760000
126100     05  W-CBSA-EFF-DATE               PIC X(8).                  11770000
126200     05  FILLER                        PIC X.                     11780000
126300     05  W-CBSA-INDEX-RECORD           PIC S9(02)V9(04).          11790000
126400     05  W-CBSA-PR-INDEX-RECORD        PIC S9(02)V9(04).          11800000
126500                                                                  11810000
126600                                                                  11820000
126700 PROCEDURE DIVISION  USING BILL-NEW-DATA                          11830000
126800                           PPS-DATA                               11840000
126900                           PRICER-OPT-VERS-SW                     11850000
127000                           PPS-ADDITIONAL-VARIABLES               11860000
127100                           PROV-NEW-HOLD                          11870000
127200                           WAGE-NEW-CBSA-INDEX-RECORD.            11880000
127300                                                                  11890000
127400***************************************************************   11900000
127500*    PROCESSING:                                              *   11910000
127600*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE            11920000
127700*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *   11930000
127800*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *   11940000
127900*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *   11950000
128000*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   11960000
128100*           GOBACK.                                           *   11970000
128200*        D. ASSEMBLE PRICING COMPONENTS.                      *   11980000
128300*        E. CALCULATE THE PRICE.                              *   11990000
128400***************************************************************   12000000
128500                                                                  12010000
128600     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.                      12020000
128700     MOVE 'N' TO TEMP-RELIEF-FLAG.                                12030000
128800     MOVE 'N' TO OUTLIER-RECON-FLAG.                              12040000
128900                                                                  12050000
129000     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.                12060000
129100                                                                  12070000
129200     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES. 12080000
129300     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.          12090000
129400     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.         12100000
129500     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.    12110000
129600     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.   12120000
129700     MOVE CAL-VERSION               TO  PPS-CALC-VERS.            12130000
129800     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.      12140000
129900     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.     12150000
130000                                                                  12160000
130100     IF (PPS-RTC = '00' OR '03' OR '10' OR                        12170000
130200                   '12' OR '14')                                  12180000
130300        MOVE 'Y' TO OUTLIER-RECON-FLAG                            12190000
130400        MOVE PPS-DATA TO HLD-PPS-DATA                             12200000
130500        PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT              12210000
130600        MOVE HLD-PPS-DATA TO PPS-DATA.                            12220000
130700                                                                  12230000
130800     GOBACK.                                                      12240000
130900                                                                  12250000
131000 0200-MAINLINE-CONTROL.                                           12260000
131100                                                                  12270000
131200     MOVE 'N' TO HMO-TAG.                                         12280000
131300                                                                  12290000
131400     IF PPS-PC-HMO-FLAG = 'Y' OR                                  12300000
131500               HMO-FLAG = 'Y'                                     12310000
131600        MOVE 'Y' TO HMO-TAG.                                      12320000
131700                                                                  12330000
131800     IF P-NEW-STATE NOT = 40                                      12340000
131900        MOVE ZEROES TO W-CBSA-PR-INDEX-RECORD.                    12350000
132000                                                                  12360000
132100     MOVE ALL '0' TO PPS-DATA                                     12370000
132200                     H-OPER-DSH-SCH                               12380000
132300                     H-OPER-DSH-RRC                               12390000
132400                     HOLD-PPS-COMPONENTS                          12400000
132500                     HOLD-PPS-COMPONENTS                          12410000
132600                     HOLD-ADDITIONAL-VARIABLES                    12420000
132700                     HOLD-CAPITAL-VARIABLES                       12430000
132800                     HOLD-CAPITAL2-VARIABLES                      12440000
132900                     HOLD-OTHER-VARIABLES                         12450000
133000                     HOLD-PC-OTH-VARIABLES.                       12460000
133100                                                                  12470000
133200     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC                     12480000
133300        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.                      12490000
133400                                                                  12500000
133500     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC                     12510000
133600        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.                       12520000
133700                                                                  12530000
133800     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC                     12540000
133900        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.                      12550000
134000                                                                  12560000
134100     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC                       12570000
134200        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.                        12580000
134300                                                                  12590000
134400                                                                  12600000
134500     PERFORM 1000-EDIT-THE-BILL-INFO.                             12610000
134600                                                                  12620000
134700     IF  PPS-RTC = 00                                             12630000
134800         PERFORM 2000-ASSEMBLE-PPS-VARIABLES                      12640000
134900         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.                12650000
135000                                                                  12660000
135100     IF OUTLIER-RECON-FLAG = 'Y'                                  12670000
135200        MOVE 'N' TO OUTLIER-RECON-FLAG                            12680000
135300        GO TO 0200-EXIT.                                          12690000
135400                                                                  12700000
135500     IF PPS-RTC = 00                                              12710000
135600        IF H-PERDIEM-DAYS = H-ALOS OR                             12720000
135700           H-PERDIEM-DAYS > H-ALOS                                12730000
135800           MOVE 14 TO PPS-RTC.                                    12740000
135900                                                                  12750000
136000     IF PPS-RTC = 02                                              12760000
136100        IF H-PERDIEM-DAYS = H-ALOS OR                             12770000
136200           H-PERDIEM-DAYS > H-ALOS                                12780000
136300           MOVE 16 TO PPS-RTC.                                    12790000
136400                                                                  12800000
136500 0200-EXIT.   EXIT.                                               12810000
136600                                                                  12820000
136700 1000-EDIT-THE-BILL-INFO.                                         12830000
136800***************************************************************   12840000
136900*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   12850000
137000*    AND DO NOT ATTEMPT TO PRICE.                             *   12860000
137100***************************************************************   12870000
137200                                                                  12880000
137300     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.                             12890000
137400     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.                             12900000
137500                                                                  12910000
137600     IF  PPS-RTC = 00                                             12920000
137700         IF  P-NEW-WAIVER-STATE                                   12930000
137800             MOVE 53 TO PPS-RTC.                                  12940000
137900                                                                  12950000
138000     IF  PPS-RTC = 00                                             12960000
138100         IF  B-DRG < 001 OR > 559                                 12970000
138200                                  OR = 004 OR = 005               12980000
138300                                  OR = 107 OR = 109               12990000
138400                                  OR = 112 OR = 115               13000000
138500                                  OR = 116 OR = 209               13010000
138600                                  OR = 214 OR = 215               13020000
138700                                  OR = 221 OR = 222               13030000
138800                                  OR = 231 OR = 400               13040000
138900                                  OR = 434 OR = 435               13050000
139000                                  OR = 436 OR = 437               13060000
139100                                  OR = 438 OR = 456               13070000
139200                                  OR = 457 OR = 458               13080000
139300                                  OR = 459 OR = 460               13090000
139400                                  OR = 469 OR = 470               13100000
139500                                  OR = 472 OR = 474               13110000
139600                                  OR = 478 OR = 483               13120000
139700                                  OR = 514 OR = 516               13130000
139800                                  OR = 517 OR = 526               13140000
139900                                  OR = 527                        13150000
140000             MOVE 54 TO PPS-RTC.                                  13160000
140100                                                                  13170000
140200     IF  PPS-RTC = 00                                             13180000
140300            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR           13190000
140400                 (B-DISCHARGE-DATE < W-CBSA-EFF-DATE))            13200000
140500                MOVE 55 TO PPS-RTC.                               13210000
140600                                                                  13220000
140700     IF  PPS-RTC = 00                                             13230000
140800         IF P-NEW-TERMINATION-DATE > 00000000                     13240000
140900            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR   13250000
141000                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))     13260000
141100                  MOVE 55 TO PPS-RTC.                             13270000
141200                                                                  13280000
141300     IF  PPS-RTC = 00                                             13290000
141400         IF  B-LOS NOT NUMERIC                                    13300000
141500             MOVE 56 TO PPS-RTC                                   13310000
141600         ELSE                                                     13320000
141700         IF  B-LOS = 0                                            13330000
141800             IF B-REVIEW-CODE NOT = 00 AND                        13340000
141900                              NOT = 03 AND                        13350000
142000                              NOT = 06 AND                        13360000
142100                              NOT = 07 AND                        13370000
142200                              NOT = 09 AND                        13380000
142300                              NOT = 11                            13390000
142400             MOVE 56 TO PPS-RTC.                                  13400000
142500                                                                  13410000
142600     IF  PPS-RTC = 00                                             13420000
142700         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60            13430000
142800             MOVE 61 TO PPS-RTC                                   13440000
142900         ELSE                                                     13450000
143000             MOVE B-LTR-DAYS TO H-LTR-DAYS.                       13460000
143100                                                                  13470000
143200     IF  PPS-RTC = 00                                             13480000
143300         IF  B-COVERED-DAYS NOT NUMERIC                           13490000
143400             MOVE 62 TO PPS-RTC                                   13500000
143500         ELSE                                                     13510000
143600         IF  B-COVERED-DAYS = 0 AND B-LOS > 0                     13520000
143700             MOVE 62 TO PPS-RTC                                   13530000
143800         ELSE                                                     13540000
143900             MOVE B-COVERED-DAYS TO H-COV-DAYS.                   13550000
144000                                                                  13560000
144100     IF  PPS-RTC = 00                                             13570000
144200         IF  H-LTR-DAYS  > H-COV-DAYS                             13580000
144300             MOVE 62 TO PPS-RTC                                   13590000
144400         ELSE                                                     13600000
144500             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.        13610000
144600                                                                  13620000
144700     IF  PPS-RTC = 00                                             13630000
144800         IF  NOT VALID-REVIEW-CODE                                13640000
144900             MOVE 57 TO PPS-RTC.                                  13650000
145000                                                                  13660000
145100     IF  PPS-RTC = 00                                             13670000
145200         IF  B-CHARGES-CLAIMED NOT NUMERIC                        13680000
145300             MOVE 58 TO PPS-RTC.                                  13690000
145400                                                                  13700000
145500     IF PPS-RTC = 00                                              13710000
145600           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'                       13720000
145700                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND         13730000
145800                                            NOT = 'B' AND         13740000
145900                                            NOT = 'C'             13750000
146000                 MOVE 65 TO PPS-RTC.                              13760000
146100                                                                  13770000
146200 2000-ASSEMBLE-PPS-VARIABLES.                                     13780000
146300***************************************************************   13790000
146400*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   13800000
146500*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   13810000
146600*    OF THAT VARIABLE.                                        *   13820000
146700***************************************************************   13830000
146800***  GET THE PROVIDER SPECIFIC VARIABLES.                         13840000
146900***  GET THE PROVIDER SPECIFIC VARIABLES.                         13850000
147000                                                                  13860000
147100     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.                 13870000
147200     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.                   13880000
147300                                                                  13890000
147400     IF  (P-NEW-STATE = 02 OR 12)                                 13900000
147500         MOVE P-NEW-COLA TO H-OPER-COLA                           13910000
147600     ELSE                                                         13920000
147700         MOVE 1.000  TO H-OPER-COLA.                              13930000
147800                                                                  13940000
147900***************************************************************   13950000
148000***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF              13960000
148100***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF              13970000
148200                                                                  13980000
148300     PERFORM 2600-GET-DRG-WEIGHT                                  13990000
148400             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.               14000000
148500                                                                  14010000
148600***************************************************************   14020000
148700***  GET THE WAGE-INDEX                                           14030000
148800***  GET THE WAGE-INDEX                                           14040000
148900                                                                  14050000
149000     MOVE W-CBSA-INDEX-RECORD TO H-WAGE-INDEX.                    14060000
149100     MOVE W-CBSA-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.              14070000
149200                                                                  14080000
149300***************************************************************   14090000
149400***  GET THE LABOR, NON-LABOR STANDARD RATES                      14100000
149500                                                                  14110000
149600     IF  P-NEW-STATE = 40                                         14120000
149700         MOVE 2 TO R2                                             14130000
149800         MOVE 3 TO R4                                             14140000
149900     ELSE                                                         14150000
150000         MOVE 1 TO R2                                             14160000
150100         MOVE 1 TO R4.                                            14170000
150200                                                                  14180000
150300     IF  LARGE-URBAN                                              14190000
150400         MOVE 1 TO R3                                             14200000
150500     ELSE                                                         14210000
150600         MOVE 2 TO R3.                                            14220000
150700                                                                  14230000
150800     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND                     14240000
150900        (H-WAGE-INDEX > 01.0000))                                 14250000
151000        PERFORM 2300-GET-LAB-NONLAB-TB1-RATES                     14260000
151100             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 14270000
151200                                                                  14280000
151300     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND                 14290000
151400         (H-WAGE-INDEX > 01.0000))                                14300000
151500        PERFORM 2300-GET-LAB-NONLAB-TB2-RATES                     14310000
151600             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 14320000
151700                                                                  14330000
151800     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND                    14340000
151900         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))      14350000
152000        PERFORM 2300-GET-LAB-NONLAB-TB3-RATES                     14360000
152100             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 14370000
152200                                                                  14380000
152300     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND                 14390000
152400         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))      14400000
152500        PERFORM 2300-GET-LAB-NONLAB-TB4-RATES                     14410000
152600             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 14420000
152700                                                                  14430000
152800     IF P-NEW-STATE = 40                                          14440000
152900        IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND                  14450000
153000            (H-PR-WAGE-INDEX > 01.0000))                          14460000
153100             PERFORM 2300-GET-PR-LAB-TB1-RATES                    14470000
153200             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 14480000
153300                                                                  14490000
153400                                                                  14500000
153500     IF P-NEW-STATE = 40                                          14510000
153600        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND              14520000
153700             (H-PR-WAGE-INDEX > 01.0000))                         14530000
153800              PERFORM 2300-GET-PR-LAB-TB2-RATES                   14540000
153900                  VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.            14550000
154000                                                                  14560000
154100     IF P-NEW-STATE = 40                                          14570000
154200        IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND                 14580000
154300         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))14590000
154400          PERFORM 2300-GET-PR-LAB-TB3-RATES                       14600000
154500              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                14610000
154600                                                                  14620000
154700     IF P-NEW-STATE = 40                                          14630000
154800        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND              14640000
154900         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))14650000
155000          PERFORM 2300-GET-PR-LAB-TB4-RATES                       14660000
155100              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                14670000
155200                                                                  14680000
155300***************************************************************   14690000
155400***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL               14700000
155500***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL               14710000
155600                                                                  14720000
155700     MOVE 0.00  TO H-OPER-HSP-PCT.                                14730000
155800     MOVE 1.00  TO H-OPER-FSP-PCT.                                14740000
155900                                                                  14750000
156000***************************************************************   14760000
156100***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL     14770000
156200***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL     14780000
156300                                                                  14790000
156400      MOVE 1.00 TO H-NAT-PCT.                                     14800000
156500      MOVE 0.00 TO H-REG-PCT.                                     14810000
156600                                                                  14820000
156700     IF  P-NEW-STATE = 40                                         14830000
156800         MOVE 0.75 TO H-NAT-PCT                                   14840000
156900         MOVE 0.25 TO H-REG-PCT.                                  14850000
157000                                                                  14860000
157100     IF  P-N-SCH-REBASED-FY90 OR                                  14870000
157200         P-N-EACH OR                                              14880000
157300         P-N-MDH-REBASED-FY90                                     14890000
157400         MOVE 1.00 TO H-OPER-HSP-PCT.                             14900000
157500                                                                  14910000
157600 2300-GET-LAB-NONLAB-TB1-RATES.                                   14920000
157700                                                                  14930000
157800     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)            14940000
157900         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            14950000
158000         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR         14960000
158100         MOVE TB1-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR            14970000
158200         MOVE TB1-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.        14980000
158300                                                                  14990000
158400 2300-GET-LAB-NONLAB-TB2-RATES.                                   15000000
158500                                                                  15010000
158600     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)            15020000
158700         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            15030000
158800         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR         15040000
158900         MOVE TB2-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR            15050000
159000         MOVE TB2-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.        15060000
159100                                                                  15070000
159200 2300-GET-LAB-NONLAB-TB3-RATES.                                   15080000
159300                                                                  15090000
159400     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)            15100000
159500         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            15110000
159600         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR         15120000
159700         MOVE TB3-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR            15130000
159800         MOVE TB3-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.        15140000
159900                                                                  15150000
160000 2300-GET-LAB-NONLAB-TB4-RATES.                                   15160000
160100                                                                  15170000
160200     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)            15180000
160300         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            15190000
160400         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR         15200000
160500         MOVE TB4-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR            15210000
160600         MOVE TB4-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.        15220000
160700                                                                  15230000
160800 2300-GET-PR-LAB-TB1-RATES.                                       15240000
160900                                                                  15250000
161000     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)            15260000
161100         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            15270000
161200         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.        15280000
161300                                                                  15290000
161400 2300-GET-PR-LAB-TB2-RATES.                                       15300000
161500                                                                  15310000
161600     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)            15320000
161700         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            15330000
161800         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.        15340000
161900                                                                  15350000
162000 2300-GET-PR-LAB-TB3-RATES.                                       15360000
162100                                                                  15370000
162200     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)            15380000
162300         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            15390000
162400         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.        15400000
162500                                                                  15410000
162600 2300-GET-PR-LAB-TB4-RATES.                                       15420000
162700                                                                  15430000
162800     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)            15440000
162900         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            15450000
163000         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.        15460000
163100                                                                  15470000
163200                                                                  15480000
163300 2600-GET-DRG-WEIGHT.                                             15490000
163400                                                                  15500000
163500     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)               15510000
163600         SET DX6 TO B-DRG                                         15520000
163700         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT                15530000
163800         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS                  15540000
163900*****    MOVE DRG-DAYS-TRIM (DX5 DX6)  TO H-DAYS-CUTOFF           15550000
164000         MOVE ZEROES                   TO H-DAYS-CUTOFF           15560000
164100         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.           15570000
164200                                                                  15580000
164300 3000-CALC-PAYMENT.                                               15590000
164400***************************************************************   15600000
164500*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   15610000
164600*        CALCULATE THE STAY UTILIZATION.                      *   15620000
164700*        CALCULATE THE FEDERAL PORTION.                       *   15630000
164800*        CALCULATE THE HOSPITAL PORTION.                      *   15640000
164900*        CALCULATE THE COST-OUTLIER PORTION.                  *   15650000
165000*        CALCULATE THE TOTAL PAYMENT OPERATING AND CAPITAL    *   15660000
165100*        CALCULATE THE DSH ADJUSTMENT.                        *   15670000
165200*        CALCULATE THE IME TEACHING.                          *   15680000
165300***************************************************************   15690000
165400                                                                  15700000
165500     PERFORM 3100-CALC-STAY-UTILIZATION.                          15710000
165600     PERFORM 3300-CALC-OPER-FSP-AMT.                              15720000
165700                                                                  15730000
165800     PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT.                 15740000
165900                                                                  15750000
166000***********************************************************       15760000
166100***  OPERATING IME CALCULATION                                    15770000
166200***  OPERATING IME CALCULATION                                    15780000
166300                                                                  15790000
166400     COMPUTE H-OPER-IME-TEACH ROUNDED =                           15800000
166500            1.37 * ((1 + H-INTERN-RATIO) ** .405  - 1).           15810000
166600                                                                  15820000
166700***********************************************************       15830000
166800                                                                  15840000
166900     IF P-N-SCH-REBASED-FY90 OR                                   15850000
167000        P-N-EACH OR                                               15860000
167100        P-N-MDH-REBASED-FY90                                      15870000
167200         PERFORM 3450-CALC-ADDITIONAL-HSP.                        15880000
167300                                                                  15890000
167400     MOVE 00                 TO  PPS-RTC.                         15900000
167500     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.                   15910000
167600     MOVE H-ALOS             TO  PPS-AVG-LOS.                     15920000
167700     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.                 15930000
167800                                                                  15940000
167900     MOVE B-LOS TO H-PERDIEM-DAYS.                                15950000
168000     IF H-PERDIEM-DAYS < 1                                        15960000
168100         MOVE 1 TO H-PERDIEM-DAYS.                                15970000
168200     ADD 1 TO H-PERDIEM-DAYS.                                     15980000
168300                                                                  15990000
168400     MOVE 1 TO H-DSCHG-FRCTN.                                     16000000
168500                                                                  16010000
168600     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.   16020000
168700                                                                  16030000
168800     IF (PAY-PERDIEM-DAYS  OR                                     16040000
168900         PAY-XFER-NO-COST) OR                                     16050000
169000        (PAY-XFER-SPEC-DRG AND                                    16060000
169100         B-DRG-POSTACUTE-PERDIEM)                                 16070000
169200         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS 16080000
169300         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS 16090000
169400         IF H-DSCHG-FRCTN > 1                                     16100000
169500              MOVE 1 TO H-DSCHG-FRCTN                             16110000
169600              MOVE 1 TO H-TRANSFER-ADJ                            16120000
169700         ELSE                                                     16130000
169800              COMPUTE H-DRG-WT-FRCTN ROUNDED =                    16140000
169900                  (H-PERDIEM-DAYS / H-ALOS) * H-DRG-WT.           16150000
170000                                                                  16160000
170100     IF (PAY-XFER-SPEC-DRG AND                                    16170000
170200         B-DRG-POSTACUTE-50-50)                                   16180000
170300         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS 16190000
170400         COMPUTE H-DSCHG-FRCTN  ROUNDED =                         16200000
170500                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)     16210000
170600         IF H-DSCHG-FRCTN > 1                                     16220000
170700              MOVE 1 TO H-DSCHG-FRCTN                             16230000
170800              MOVE 1 TO H-TRANSFER-ADJ                            16240000
170900         ELSE                                                     16250000
171000              COMPUTE H-DRG-WT-FRCTN ROUNDED =                    16260000
171100            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.   16270000
171200                                                                  16280000
171300                                                                  16290000
171400***********************************************************       16300000
171500***  CAPITAL DSH CALCULATION                                      16310000
171600***  CAPITAL DSH CALCULATION                                      16320000
171700                                                                  16330000
171800     MOVE 0 TO H-CAPI-DSH.                                        16340000
171900                                                                  16350000
172000     IF P-NEW-BED-SIZE NOT NUMERIC                                16360000
172100         MOVE 0 TO P-NEW-BED-SIZE.                                16370000
172200                                                                  16380000
172300     IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99        16390000
172400         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **                   16400000
172500                  (.2025 * (P-NEW-SSI-RATIO                       16410000
172600                          + P-NEW-MEDICAID-RATIO)) - 1.           16420000
172700                                                                  16430000
172800***********************************************************       16440000
172900***  CAPITAL IME TEACH CALCULATION                                16450000
173000***  CAPITAL IME TEACH CALCULATION                                16460000
173100                                                                  16470000
173200     MOVE 0 TO H-WK-CAPI-IME-TEACH.                               16480000
173300                                                                  16490000
173400     IF P-NEW-CAPI-IME NUMERIC                                    16500000
173500        IF P-NEW-CAPI-IME > 1.5000                                16510000
173600           MOVE 1.5000 TO P-NEW-CAPI-IME.                         16520000
173700                                                                  16530000
173800     IF P-NEW-CAPI-IME NUMERIC                                    16540000
173900        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =                     16550000
174000          (2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1.               16560000
174100                                                                  16570000
174200***********************************************************       16580000
174300******************************************************************16590000
174400***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97             16600000
174500***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97             16610000
174600***  ZEROED OUT THE H-DAYOUT-PCT FIELD AS OF 10/01/97             16620000
174700                                                                  16630000
174800     MOVE 0.00 TO H-DAYOUT-PCT.                                   16640000
174900******************************************************************16650000
175000                                                                  16660000
175100     MOVE 0.80 TO H-CSTOUT-PCT.                                   16670000
175200                                                                  16680000
175300******************************************************************16690000
175400*****THESE ARE BURNS DRG'S                                        16700000
175500     IF  B-DRG = 504 OR 505 OR 506 OR 507 OR 508 OR               16710000
175600                 509 OR 510 OR 511                                16720000
175700             MOVE 0.90 TO H-CSTOUT-PCT.                           16730000
175800                                                                  16740000
175900***     NATIONAL PERCENTAGE                                       16750000
176000     MOVE 0.6970   TO H-LABOR-PCT.                                16760000
176100     MOVE 0.3030   TO H-NONLABOR-PCT.                             16770000
176200                                                                  16780000
176300***     PUERTO RICO PERCENTAGE                                    16790000
176400     MOVE 0.6200   TO H-PR-LABOR-PCT.                             16800000
176500     MOVE 0.3800   TO H-PR-NONLABOR-PCT.                          16810000
176600                                                                  16820000
176700     IF (H-WAGE-INDEX < 01.0000 OR                                16830000
176800         H-WAGE-INDEX = 01.0000)                                  16840000
176900        MOVE 0.6200 TO H-LABOR-PCT                                16850000
177000        MOVE 0.3800 TO H-NONLABOR-PCT.                            16860000
177100                                                                  16870000
177200     IF P-NEW-STATE = 40                                          16880000
177300       IF (H-PR-WAGE-INDEX < 01.0000 OR                           16890000
177400           H-PR-WAGE-INDEX = 01.0000)                             16900000
177500          MOVE 0.5870 TO H-PR-LABOR-PCT                           16910000
177600          MOVE 0.4130 TO H-PR-NONLABOR-PCT.                       16920000
177700                                                                  16930000
177800                                                                  16940000
177900     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC                          16950000
178000             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO  16960000
178100     ELSE                                                         16970000
178200             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.                   16980000
178300                                                                  16990000
178400     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC                           17000000
178500             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO  17010000
178600     ELSE                                                         17020000
178700             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.                   17030000
178800                                                                  17040000
178900***********************************************************       17050000
179000***  CAPITAL PAYMENT METHOD B                                     17060000
179100***  CAPITAL PAYMENT METHOD B                                     17070000
179200                                                                  17080000
179300     IF W-CBSA-SIZE = 'L'                                         17090000
179400        MOVE 1.03 TO H-CAPI-LARG-URBAN                            17100000
179500     ELSE                                                         17110000
179600        MOVE 1.00 TO H-CAPI-LARG-URBAN.                           17120000
179700                                                                  17130000
179800     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).     17140000
179900     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).  17150000
180000                                                                  17160000
180100     COMPUTE H-FEDERAL-RATE ROUNDED =                             17170000
180200                                 (0420.65 * H-CAPI-GAF).          17180000
180300     COMPUTE H-PUERTO-RICO-RATE ROUNDED =                         17190000
180400                                 (0201.93 * H-PR-CAPI-GAF).       17200000
180500                                                                  17210000
180600     COMPUTE H-CAPI-COLA ROUNDED =                                17220000
180700                     (.3152 * (H-OPER-COLA - 1) + 1).             17230000
180800                                                                  17240000
180900     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.                      17250000
181000                                                                  17260000
181100     IF P-NEW-STATE = 40                                          17270000
181200        COMPUTE  H-CAPI-FED-RATE ROUNDED =                        17280000
181300                 (H-NAT-PCT * H-FEDERAL-RATE) +                   17290000
181400                 (H-REG-PCT * H-PUERTO-RICO-RATE).                17300000
181500***********************************************************       17310000
181600***  NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001                17320000
181700***  CAPITAL HSP CALCULATION                                      17330000
181800***  CAPITAL HSP CALCULATION                                      17340000
181900*                                                                 17350000
182000*    IF B-DISCHARGE-DATE > 20010331                               17360000
182100*        MOVE 1.0149 TO H-HSP-UPDATE01                            17370000
182200*    ELSE                                                         17380000
182300*        MOVE 1.0147 TO H-HSP-UPDATE01.                           17390000
182400*                                                                 17400000
182500*    COMPUTE H-ACCUM-TO-HSP ROUNDED = H-HSP-UPDATE01.             17410000
182600*                                                                 17420000
182700*    COMPUTE H-CAPI-HSP-PART ROUNDED = (H-DRG-WT *                17430000
182800*                  P-NEW-CAPI-HOSP-SPEC-RATE * H-ACCUM-TO-HSP).   17440000
182900***********************************************************       17450000
183000                                                                  17460000
183100***********************************************************       17470000
183200***  CAPITAL FSP CALCULATION                                      17480000
183300***  CAPITAL FSP CALCULATION                                      17490000
183400                                                                  17500000
183500     COMPUTE H-CAPI-FSP-PART ROUNDED =                            17510000
183600                               H-DRG-WT * H-CAPI-FED-RATE *       17520000
183700                               H-CAPI-COLA *                      17530000
183800                               H-CAPI-LARG-URBAN.                 17540000
183900                                                                  17550000
184000***********************************************************       17560000
184100***  CAPITAL PAYMENT METHOD A                                     17570000
184200***  CAPITAL PAYMENT METHOD A                                     17580000
184300                                                                  17590000
184400     IF P-N-SCH-REBASED-FY90 OR P-N-EACH                          17600000
184500        MOVE 1.00 TO H-CAPI-SCH                                   17610000
184600     ELSE                                                         17620000
184700        MOVE 0.85 TO H-CAPI-SCH.                                  17630000
184800                                                                  17640000
184900***********************************************************       17650000
185000***********  CAPITAL OLD-HARMLESS CALCULATION ***********         17660000
185100***********  CAPITAL OLD-HARMLESS CALCULATION ***********         17670000
185200                                                                  17680000
185300     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                        17690000
185400                    (P-NEW-CAPI-OLD-HARM-RATE *                   17700000
185500                    H-CAPI-SCH).                                  17710000
185600                                                                  17720000
185700***********************************************************       17730000
185800        IF PAY-PERDIEM-DAYS                                       17740000
185900            IF  H-PERDIEM-DAYS < H-ALOS                           17750000
186000                IF  NOT (B-DRG = 385)                             17760000
186100                    PERFORM 3500-CALC-PERDIEM-AMT                 17770000
186200                    MOVE 03 TO PPS-RTC.                           17780000
186300                                                                  17790000
186400        IF PAY-XFER-SPEC-DRG                                      17800000
186500            IF  H-PERDIEM-DAYS < H-ALOS                           17810000
186600                IF  NOT (B-DRG = 385)                             17820000
186700                    PERFORM 3550-CALC-PERDIEM-AMT.                17830000
186800                                                                  17840000
186900        IF  PAY-XFER-NO-COST                                      17850000
187000            MOVE 00 TO PPS-RTC                                    17860000
187100            IF H-PERDIEM-DAYS < H-ALOS                            17870000
187200               IF  NOT (B-DRG = 385)                              17880000
187300                   PERFORM 3500-CALC-PERDIEM-AMT                  17890000
187400                   MOVE 06 TO PPS-RTC.                            17900000
187500                                                                  17910000
187600     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.                 17920000
187700                                                                  17930000
187800     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.                    17940000
187900                                                                  17950000
188000     IF OUTLIER-RECON-FLAG = 'Y' GO TO 3000-EXIT.                 17960000
188100                                                                  17970000
188200     IF PPS-RTC = 67  GO TO 3000-CONTINUE.                        17980000
188300                                                                  17990000
188400        IF PAY-XFER-SPEC-DRG                                      18000000
188500            IF  H-PERDIEM-DAYS < H-ALOS                           18010000
188600                IF  NOT (B-DRG = 385)                             18020000
188700                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.   18030000
188800                                                                  18040000
188900                                                                  18050000
189000        IF  PAY-PERDIEM-DAYS                                      18060000
189100            IF  H-OPER-OUTCST-PART > 0                            18070000
189200                MOVE H-OPER-OUTCST-PART TO                        18080000
189300                     H-OPER-OUTLIER-PART                          18090000
189400                MOVE 05 TO PPS-RTC                                18100000
189500            ELSE                                                  18110000
189600            IF  PPS-RTC NOT = 03                                  18120000
189700                MOVE 00 TO PPS-RTC                                18130000
189800                MOVE 0  TO H-OPER-OUTLIER-PART.                   18140000
189900                                                                  18150000
190000        IF  PAY-PERDIEM-DAYS                                      18160000
190100            IF  H-CAPI-OUTCST-PART > 0                            18170000
190200                MOVE H-CAPI-OUTCST-PART TO                        18180000
190300                     H-CAPI-OUTLIER-PART                          18190000
190400                MOVE 05 TO PPS-RTC                                18200000
190500            ELSE                                                  18210000
190600            IF  PPS-RTC NOT = 03                                  18220000
190700                MOVE 0  TO H-CAPI-OUTLIER-PART.                   18230000
190800                                                                  18240000
190900                                                                  18250000
191000 3000-CONTINUE.                                                   18260000
191100                                                                  18270000
191200***********************************************************       18280000
191300***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF          18290000
191400***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE          18300000
191500                                                                  18310000
191600     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.        18320000
191700                                                                  18330000
191800***********************************************************       18340000
191900                                                                  18350000
192000     IF  PPS-RTC = 67                                             18360000
192100         MOVE H-OPER-DOLLAR-THRESHOLD TO                          18370000
192200              WK-H-OPER-DOLLAR-THRESHOLD.                         18380000
192300                                                                  18390000
192400     IF  PPS-RTC < 50                                             18400000
192500         PERFORM 3800-CALC-TOT-AMT                                18410000
192600     ELSE                                                         18420000
192700         MOVE ALL '0' TO PPS-OPER-HSP-PART                        18430000
192800                         PPS-OPER-FSP-PART                        18440000
192900                         PPS-OPER-OUTLIER-PART                    18450000
193000                         PPS-OUTLIER-DAYS                         18460000
193100                         PPS-REG-DAYS-USED                        18470000
193200                         PPS-LTR-DAYS-USED                        18480000
193300                         PPS-TOTAL-PAYMENT                        18490000
193400                         PPS-OPER-DSH-ADJ                         18500000
193500                         PPS-OPER-IME-ADJ                         18510000
193600                         H-DSCHG-FRCTN                            18520000
193700                         H-DRG-WT-FRCTN                           18530000
193800                         HOLD-ADDITIONAL-VARIABLES                18540000
193900                         HOLD-CAPITAL-VARIABLES                   18550000
194000                         HOLD-CAPITAL2-VARIABLES                  18560000
194100                         HOLD-OTHER-VARIABLES                     18570000
194200                         HOLD-PC-OTH-VARIABLES.                   18580000
194300                                                                  18590000
194400     IF  PPS-RTC = 67                                             18600000
194500         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO                       18610000
194600                 H-OPER-DOLLAR-THRESHOLD.                         18620000
194700                                                                  18630000
194800 3000-EXIT.  EXIT.                                                18640000
194900                                                                  18650000
195000 3100-CALC-STAY-UTILIZATION.                                      18660000
195100                                                                  18670000
195200     MOVE 0 TO PPS-REG-DAYS-USED.                                 18680000
195300     MOVE 0 TO PPS-LTR-DAYS-USED.                                 18690000
195400                                                                  18700000
195500     IF H-REG-DAYS > 0                                            18710000
195600        IF H-REG-DAYS > B-LOS                                     18720000
195700           MOVE B-LOS TO PPS-REG-DAYS-USED                        18730000
195800        ELSE                                                      18740000
195900           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED                   18750000
196000     ELSE                                                         18760000
196100        IF H-LTR-DAYS > B-LOS                                     18770000
196200           MOVE B-LOS TO PPS-LTR-DAYS-USED                        18780000
196300        ELSE                                                      18790000
196400           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.                  18800000
196500                                                                  18810000
196600                                                                  18820000
196700                                                                  18830000
196800 3300-CALC-OPER-FSP-AMT.                                          18840000
196900***********************************************************       18850000
197000***  OPERATING FSP CALCULATION                                    18860000
197100***  OPERATING FSP CALCULATION                                    18870000
197200                                                                  18880000
197300     COMPUTE H-OPER-FSP-PART ROUNDED =                            18890000
197400           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +             18900000
197500            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)             18910000
197600                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.       18920000
197700                                                                  18930000
197800****CHECK FOR PUERTO RICO                                         18940000
197900     IF P-NEW-STATE = 40                                          18950000
198000       COMPUTE H-OPER-FSP-PART ROUNDED =                          18960000
198100           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +             18970000
198200            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)             18980000
198300                           +                                      18990000
198400           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +          19000000
198500            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)             19010000
198600                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.       19020000
198700                                                                  19030000
198800                                                                  19040000
198900 3450-CALC-ADDITIONAL-HSP.                                        19050000
199000***********************************************************       19060000
199100*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR                 19070000
199200*    SOLE COMMUNITY                                               19080000
199300*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)              19090000
199400*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES              19100000
199500***********************************************************       19110000
199600**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE       19120000
199700****    USE ACTUAL FEDERAL REGISTER NUMBER                        19130000
199800                                                                  19140000
199900***************************************************************   19150000
200000***         GET THE UPDATING FACTOR                               19160000
200100***         GET THE UPDATING FACTOR                               19170000
200200                                                                  19180000
200300     MOVE 0.997174 TO H-BUDG-NUTR01.                              19190000
200400     MOVE 0.995821 TO H-BUDG-NUTR02.                              19200000
200500     MOVE 0.993111 TO H-BUDG-NUTR03.                              19210000
200600     MOVE 1.002608 TO H-BUDG-NUTR04.                              19220000
200700     MOVE 0.999876 TO H-BUDG-NUTR05.                              19230000
200800     MOVE 0.998993 TO H-BUDG-NUTR06.                              19240000
200900                                                                  19250000
201000     MOVE 1.0340 TO H-UPDATE-01.                                  19260000
201100     MOVE 1.0275 TO H-UPDATE-02.                                  19270000
201200     MOVE 1.0295 TO H-UPDATE-03.                                  19280000
201300     MOVE 1.0340 TO H-UPDATE-04.                                  19290000
201400     MOVE 1.0330 TO H-UPDATE-05.                                  19300000
201500                                                                  19310000
201600     IF P-NEW-CBSA-HOSP-QUAL-IND = '1'                            19320000
201700        MOVE 1.0370 TO H-UPDATE-06                                19330000
201800     ELSE                                                         19340000
201900        MOVE 1.0330 TO H-UPDATE-06.                               19350000
202000                                                                  19360000
202100     COMPUTE H-UPDATE-FACTOR ROUNDED =                            19370000
202200                       (H-UPDATE-01 * H-UPDATE-02 *               19380000
202300                        H-UPDATE-03 * H-UPDATE-04 *               19390000
202400                        H-UPDATE-05 * H-UPDATE-06 *               19400000
202500                        H-BUDG-NUTR01 * H-BUDG-NUTR02 *           19410000
202600                        H-BUDG-NUTR03 * H-BUDG-NUTR04 *           19420000
202700                        H-BUDG-NUTR05 * H-BUDG-NUTR06).           19430000
202800                                                                  19440000
202900     COMPUTE H-HSP-RATE ROUNDED =                                 19450000
203000         H-FAC-SPEC-RATE * H-UPDATE-FACTOR.                       19460000
203100***************************************************************   19470000
203200                                                                  19480000
203300***************************************************************   19490000
203400***     OUTLIER OFFSETS                                           19500000
203500***     OPERATING NATIONAL                                        19510000
203600***     OPERATING PUERTO RICO BLEND                               19520000
203700                                                                  19530000
203800      MOVE 0.948990 TO H-OUTLIER-OFFSET-NAT                       19540000
203900      MOVE 0.955467 TO H-OUTLIER-OFFSET-PR.                       19550000
204000                                                                  19560000
204100***************************************************************   19570000
204200     COMPUTE H-FSP-RATE ROUNDED =                                 19580000
204300         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +               19590000
204400         H-NAT-NONLABOR * H-OPER-COLA))                           19600000
204500                           *                                      19610000
204600     ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-NAT) 19620000
204700                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.            19630000
204800                                                                  19640000
204900     IF P-NEW-STATE = 40                                          19650000
205000       COMPUTE H-FSP-RATE ROUNDED =                               19660000
205100         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +              19670000
205200         H-NAT-NONLABOR * H-OPER-COLA))                           19680000
205300                           +                                      19690000
205400          (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +           19700000
205500         H-REG-NONLABOR * H-OPER-COLA)))                          19710000
205600                           *                                      19720000
205700      ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-PR) 19730000
205800                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.            19740000
205900                                                                  19750000
206000                                                                  19760000
206100     IF  H-HSP-RATE > H-FSP-RATE                                  19770000
206200           COMPUTE H-OPER-HSP-PART ROUNDED =                      19780000
206300             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT                 19790000
206400                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART        19800000
206500     ELSE                                                         19810000
206600         MOVE 0 TO H-OPER-HSP-PART.                               19820000
206700                                                                  19830000
206800***************************************************************   19840000
206900***         GET THE MDH REBASE                                    19850000
207000***     HAS BEEN REVIVED FOR 10/01/97                             19860000
207100                                                                  19870000
207200     IF  H-HSP-RATE > H-FSP-RATE                                  19880000
207300         IF P-NEW-PROVIDER-TYPE = '14' OR '15'                    19890000
207400           COMPUTE H-OPER-HSP-PART ROUNDED =                      19900000
207500             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .5            19910000
207600                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.       19920000
207700                                                                  19930000
207800 3500-CALC-PERDIEM-AMT.                                           19940000
207900***********************************************************       19950000
208000***  REVIEW CODE = 03 OR 06                                       19960000
208100***  OPERATING PERDIEM-AMT CALCULATION                            19970000
208200***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS              19980000
208300                                                                  19990000
208400**    REMOVED AS OF APR 1 2004                                    20000000
208500***     COMPUTE H-OPER-HSP-PART ROUNDED =                         20010000
208600***     H-OPER-HSP-PART * H-TRANSFER-ADJ                          20020000
208700***     ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.                  20030000
208800***********************************************************       20040000
208900                                                                  20050000
209000        COMPUTE H-OPER-FSP-PART ROUNDED =                         20060000
209100        H-OPER-FSP-PART * H-TRANSFER-ADJ                          20070000
209200        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  20080000
209300                                                                  20090000
209400***********************************************************       20100000
209500***********************************************************       20110000
209600***  REVIEW CODE = 03 OR 06                                       20120000
209700***  CAPITAL   PERDIEM-AMT CALCULATION                            20130000
209800***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS              20140000
209900                                                                  20150000
210000***********************************************************       20160000
210100**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    ************** 20170000
210200*       COMPUTE H-CAPI-HSP-PART ROUNDED =                         20180000
210300*       H-CAPI-HSP-PART * H-TRANSFER-ADJ                          20190000
210400*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.                  20200000
210500***********************************************************       20210000
210600                                                                  20220000
210700        COMPUTE H-CAPI-FSP-PART ROUNDED =                         20230000
210800        H-CAPI-FSP-PART * H-TRANSFER-ADJ                          20240000
210900        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  20250000
211000                                                                  20260000
211100***********************************************************       20270000
211200***  REVIEW CODE = 03 OR 06                                       20280000
211300***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                20290000
211400***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                20300000
211500                                                                  20310000
211600        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                     20320000
211700        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ                      20330000
211800        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              20340000
211900                                                                  20350000
212000 3550-CALC-PERDIEM-AMT.                                           20360000
212100***********************************************************       20370000
212200***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG            20380000
212300***  OPERATING PERDIEM-AMT CALCULATION                            20390000
212400***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS              20400000
212500**    REMOVED AS OF APR 1 2004                                    20410000
212600*    IF (B-DRG = 209 OR 210 OR 211)                               20420000
212700*       MOVE 10 TO PPS-RTC                                        20430000
212800*       COMPUTE H-OPER-HSP-PART ROUNDED =                         20440000
212900*       H-OPER-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             20450000
213000*       ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.                  20460000
213100                                                                  20470000
213200*    IF (B-DRG = 014 OR 113 OR 236 OR                             20480000
213300*                012 OR 024 OR 025 OR                             20490000
213400*                088 OR 089 OR 090 OR                             20500000
213500*                121 OR 122 OR 127 OR                             20510000
213600*                130 OR 131 OR 239 OR                             20520000
213700*                277 OR 278 OR 294 OR                             20530000
213800*                296 OR 297 OR 320 OR                             20540000
213900*                321 OR 395 OR 468 OR                             20550000
214000*                429 OR 541 OR 542)                               20560000
214100*       MOVE 12 TO PPS-RTC                                        20570000
214200*       COMPUTE H-OPER-HSP-PART ROUNDED =                         20580000
214300*       H-OPER-HSP-PART *  H-TRANSFER-ADJ                         20590000
214400*       ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.                  20600000
214500***********************************************************       20610000
214600                                                                  20620000
214700     IF (B-DRG-POSTACUTE-50-50)                                   20630000
214800        MOVE 10 TO PPS-RTC                                        20640000
214900        COMPUTE H-OPER-FSP-PART ROUNDED =                         20650000
215000        H-OPER-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             20660000
215100        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  20670000
215200                                                                  20680000
215300     IF (B-DRG-POSTACUTE-PERDIEM)                                 20690000
215400        MOVE 12 TO PPS-RTC                                        20700000
215500        COMPUTE H-OPER-FSP-PART ROUNDED =                         20710000
215600        H-OPER-FSP-PART *  H-TRANSFER-ADJ                         20720000
215700        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  20730000
215800                                                                  20740000
215900***********************************************************       20750000
216000***  CAPITAL PERDIEM-AMT CALCULATION                              20760000
216100***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS                20770000
216200                                                                  20780000
216300***********************************************************       20790000
216400**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    ************** 20800000
216500*    IF (B-DRG-POSTACUTE-50-50)                                   20810000
216600*       MOVE 10 TO PPS-RTC                                        20820000
216700*       COMPUTE H-CAPI-HSP-PART ROUNDED =                         20830000
216800*       H-CAPI-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             20840000
216900*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.                  20850000
217000*                                                                 20860000
217100*    IF (B-DRG = 014 OR 113 OR 236 OR 263 OR                      20870000
217200*                264 OR 429 OR 483)                               20880000
217300*       MOVE 12 TO PPS-RTC                                        20890000
217400*       COMPUTE H-CAPI-HSP-PART ROUNDED =                         20900000
217500*       H-CAPI-HSP-PART *  H-TRANSFER-ADJ                         20910000
217600*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.                  20920000
217700***********************************************************       20930000
217800                                                                  20940000
217900     IF (B-DRG-POSTACUTE-50-50)                                   20950000
218000        MOVE 10 TO PPS-RTC                                        20960000
218100        COMPUTE H-CAPI-FSP-PART ROUNDED =                         20970000
218200        H-CAPI-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             20980000
218300        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  20990000
218400                                                                  21000000
218500     IF (B-DRG-POSTACUTE-PERDIEM)                                 21010000
218600        MOVE 12 TO PPS-RTC                                        21020000
218700        COMPUTE H-CAPI-FSP-PART ROUNDED =                         21030000
218800        H-CAPI-FSP-PART *  H-TRANSFER-ADJ                         21040000
218900        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  21050000
219000                                                                  21060000
219100***********************************************************       21070000
219200***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                21080000
219300***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                21090000
219400                                                                  21100000
219500     IF (B-DRG-POSTACUTE-50-50)                                   21110000
219600        MOVE 10 TO PPS-RTC                                        21120000
219700        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                     21130000
219800        H-CAPI-OLD-HARMLESS * (.5 * (1 + H-TRANSFER-ADJ))         21140000
219900        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              21150000
220000                                                                  21160000
220100     IF (B-DRG-POSTACUTE-PERDIEM)                                 21170000
220200        MOVE 12 TO PPS-RTC                                        21180000
220300        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                     21190000
220400        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ                     21200000
220500        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              21210000
220600                                                                  21220000
220700 3560-CHECK-RTN-CODE.                                             21230000
220800                                                                  21240000
220900     IF (B-DRG-POSTACUTE-50-50)                                   21250000
221000        MOVE 10 TO PPS-RTC.                                       21260000
221100     IF (B-DRG-POSTACUTE-PERDIEM)                                 21270000
221200        MOVE 12 TO PPS-RTC.                                       21280000
221300                                                                  21290000
221400 3560-EXIT.    EXIT.                                              21300000
221500                                                                  21310000
221600 3600-CALC-OUTLIER.                                               21320000
221700***********************************************************       21330000
221800***  COST OUTLIER OPERATING AND CAPITAL CALCULATION               21340000
221900***  COST OUTLIER OPERATING AND CAPITAL CALCULATION               21350000
222000                                                                  21360000
222100     IF OUTLIER-RECON-FLAG = 'Y'                                  21370000
222200        COMPUTE H-OPER-CSTCHG-RATIO ROUNDED =                     21380000
222300               (H-OPER-CSTCHG-RATIO + .2).                        21390000
222400                                                                  21400000
222500     IF H-CAPI-CSTCHG-RATIO > 0 OR                                21410000
222600       H-OPER-CSTCHG-RATIO > 0                                    21420000
222700        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =             21430000
222800                H-OPER-CSTCHG-RATIO /                             21440000
222900               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)        21450000
223000        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =             21460000
223100                H-CAPI-CSTCHG-RATIO /                             21470000
223200               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)        21480000
223300     ELSE                                                         21490000
223400         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD                    21500000
223500                   H-CAPI-SHARE-DOLL-THRESHOLD.                   21510000
223600                                                                  21520000
223700***********************************************************       21530000
223800***********************************************************       21540000
223900***********************************************************       21550000
224000***********************************************************       21560000
224100***********************************************************       21570000
224200***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************       21580000
224300***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS          21590000
224400***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS          21600000
224500                                                                  21610000
224600***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************       21620000
224700***     MOVE 16036.00 TO H-PRE-CAPI-THRESH.                       21630000
224800***********************************************************       21640000
224900***********************************************************       21650000
225000***********************************************************       21660000
225100***********************************************************       21670000
225200                                                                  21680000
225300                                                                  21690000
225400                                                                  21700000
225500***********************************************************       21710000
225600***  OUTLIER THRESHOLD AMOUNTS                                    21720000
225700***  OUTLIER THRESHOLD AMOUNTS                                    21730000
225800                                                                  21740000
225900     MOVE 23600.00 TO H-CST-THRESH.                               21750000
226000                                                                  21760000
226100     IF (B-REVIEW-CODE = '03') AND                                21770000
226200         H-PERDIEM-DAYS < H-ALOS                                  21780000
226300        COMPUTE H-CST-THRESH ROUNDED =                            21790000
226400                      (H-CST-THRESH * H-TRANSFER-ADJ)             21800000
226500                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.             21810000
226600                                                                  21820000
226700     IF ((B-REVIEW-CODE = '09') AND                               21830000
226800         (H-PERDIEM-DAYS < H-ALOS))                               21840000
226900         IF (B-DRG-POSTACUTE-PERDIEM)                             21850000
227000            COMPUTE H-CST-THRESH ROUNDED =                        21860000
227100                      (H-CST-THRESH * H-TRANSFER-ADJ)             21870000
227200                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.             21880000
227300                                                                  21890000
227400     IF ((B-REVIEW-CODE = '09') AND                               21900000
227500         (H-PERDIEM-DAYS < H-ALOS))                               21910000
227600         IF (B-DRG-POSTACUTE-50-50)                               21920000
227700           COMPUTE H-CST-THRESH ROUNDED =                         21930000
227800          (H-CST-THRESH * (.5 * (1 + H-TRANSFER-ADJ)))            21940000
227900                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.             21950000
228000                                                                  21960000
228100     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                    21970000
228200        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +            21980000
228300         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *         21990000
228400          H-OPER-SHARE-DOLL-THRESHOLD.                            22000000
228500                                                                  22010000
228600     IF P-NEW-STATE = 40                                          22020000
228700        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =              22030000
228800           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +   22040000
228900            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *   22050000
229000             H-OPER-SHARE-DOLL-THRESHOLD                          22060000
229100        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                 22070000
229200               (H-OPER-DOLLAR-THRESHOLD * H-NAT-PCT) +            22080000
229300               (H-OPER-PR-DOLLAR-THRESHOLD * H-REG-PCT).          22090000
229400                                                                  22100000
229500***********************************************************       22110000
229600                                                                  22120000
229700     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =                    22130000
229800          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *         22140000
229900          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.              22150000
230000                                                                  22160000
230100                                                                  22170000
230200     IF P-NEW-STATE = 40                                          22180000
230300        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =              22190000
230400           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *     22200000
230500           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA              22210000
230600        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =                 22220000
230700               (H-CAPI-DOLLAR-THRESHOLD * H-NAT-PCT) +            22230000
230800               (H-CAPI-PR-DOLLAR-THRESHOLD * H-REG-PCT).          22240000
230900                                                                  22250000
231000                                                                  22260000
231100     COMPUTE H-OPER-COST-OUTLIER ROUNDED =                        22270000
231200      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))     22280000
231300                       +                                          22290000
231400             H-OPER-DOLLAR-THRESHOLD                              22300000
231500                       +                                          22310000
231600                 H-NEW-TECH-PAY-ADD-ON.                           22320000
231700                                                                  22330000
231800     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =                        22340000
231900      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))  22350000
232000                       +                                          22360000
232100             H-CAPI-DOLLAR-THRESHOLD.                             22370000
232200                                                                  22380000
232300     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               22390000
232400         MOVE 0 TO H-CAPI-COST-OUTLIER.                           22400000
232500                                                                  22410000
232600                                                                  22420000
232700***********************************************************       22430000
232800***  OPERATING COST CALCULATION                                   22440000
232900***  OPERATING COST CALCULATION                                   22450000
233000                                                                  22460000
233100     COMPUTE H-OPER-BILL-COSTS ROUNDED =                          22470000
233200         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO                  22480000
233300         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.               22490000
233400                                                                  22500000
233500                                                                  22510000
233600     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER                  22520000
233700         COMPUTE H-OPER-OUTCST-PART ROUNDED =                     22530000
233800         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -                      22540000
233900                         H-OPER-COST-OUTLIER).                    22550000
234000                                                                  22560000
234100     IF PAY-WITHOUT-COST OR                                       22570000
234200        PAY-XFER-NO-COST OR                                       22580000
234300        PAY-XFER-SPEC-DRG-NO-COST                                 22590000
234400         MOVE 0 TO H-OPER-OUTCST-PART.                            22600000
234500                                                                  22610000
234600***********************************************************       22620000
234700***  CAPITAL COST CALCULATION                                     22630000
234800***  CAPITAL COST CALCULATION                                     22640000
234900                                                                  22650000
235000     COMPUTE H-CAPI-BILL-COSTS ROUNDED =                          22660000
235100             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO              22670000
235200         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.               22680000
235300                                                                  22690000
235400     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER                  22700000
235500         COMPUTE H-CAPI-OUTCST-PART ROUNDED =                     22710000
235600         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -                      22720000
235700                         H-CAPI-COST-OUTLIER).                    22730000
235800                                                                  22740000
235900     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'                             22750000
236000       COMPUTE H-CAPI-OUTCST-PART ROUNDED =                       22760000
236100              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).   22770000
236200                                                                  22780000
236300     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'                             22790000
236400        COMPUTE H-CAPI-OUTCST-PART ROUNDED =                      22800000
236500               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).         22810000
236600                                                                  22820000
236700     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <               22830000
236800        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)               22840000
236900        MOVE 0 TO H-CAPI-OUTCST-PART                              22850000
237000                  H-OPER-OUTCST-PART.                             22860000
237100                                                                  22870000
237200     IF PAY-WITHOUT-COST OR                                       22880000
237300        PAY-XFER-NO-COST OR                                       22890000
237400        PAY-XFER-SPEC-DRG-NO-COST                                 22900000
237500         MOVE 0 TO H-CAPI-OUTCST-PART.                            22910000
237600                                                                  22920000
237700***********************************************************       22930000
237800***  DETERMINES THE BILL TO BE COST  OUTLIER                      22940000
237900                                                                  22950000
238000     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               22960000
238100         MOVE 0 TO H-CAPI-OUTDAY-PART                             22970000
238200                   H-CAPI-OUTCST-PART.                            22980000
238300                                                                  22990000
238400     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0             23000000
238500                 MOVE H-OPER-OUTCST-PART TO                       23010000
238600                      H-OPER-OUTLIER-PART                         23020000
238700                 MOVE H-CAPI-OUTCST-PART TO                       23030000
238800                      H-CAPI-OUTLIER-PART                         23040000
238900                 MOVE 02 TO PPS-RTC.                              23050000
239000                                                                  23060000
239100     IF OUTLIER-RECON-FLAG = 'Y'                                  23070000
239200        IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0          23080000
239300           COMPUTE HLD-PPS-RTC = HLD-PPS-RTC + 30                 23090000
239400           GO TO 3600-EXIT                                        23100000
239500        ELSE                                                      23110000
239600           GO TO 3600-EXIT                                        23120000
239700     ELSE                                                         23130000
239800        NEXT SENTENCE.                                            23140000
239900                                                                  23150000
240000                                                                  23160000
240100***********************************************************       23170000
240200***  DETERMINES IF COST OUTLIER                                   23180000
240300***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH             23190000
240400***         RETURN CODE OF 02                                     23200000
240500                                                                  23210000
240600     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.                           23220000
240700                                                                  23230000
240800     IF PPS-RTC = 02                                              23240000
240900             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =            23250000
241000                     (H-CAPI-COST-OUTLIER  +                      23260000
241100                      H-OPER-COST-OUTLIER)                        23270000
241200                             /                                    23280000
241300                    (H-CAPI-CSTCHG-RATIO  +                       23290000
241400                     H-OPER-CSTCHG-RATIO)                         23300000
241500             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.     23310000
241600                                                                  23320000
241700***********************************************************       23330000
241800***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS       23340000
241900***         RETURN CODE OF 67                                     23350000
242000                                                                  23360000
242100     IF PPS-RTC = 02                                              23370000
242200         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR                23380000
242300            PPS-PC-COT-FLAG = 'Y'                                 23390000
242400             MOVE 67 TO PPS-RTC.                                  23400000
242500***********************************************************       23410000
242600                                                                  23420000
242700***********************************************************       23430000
242800***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF          23440000
242900***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE          23450000
243000                                                                  23460000
243100     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'                             23470000
243200        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =                  23480000
243300                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO   23490000
243400         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.          23500000
243500                                                                  23510000
243600     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'                             23520000
243700        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =                  23530000
243800                H-CAPI-OUTLIER-PART.                              23540000
243900                                                                  23550000
244000     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'                             23560000
244100        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =                  23570000
244200                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1          23580000
244300         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.          23590000
244400                                                                  23600000
244500 3600-EXIT.   EXIT.                                               23610000
244600***********************************************************       23620000
244700***********************************************************       23630000
244800                                                                  23640000
244900***********************************************************       23650000
245000 3800-CALC-TOT-AMT.                                               23660000
245100***********************************************************       23670000
245200***  CALCULATE TOTALS FOR CAPITAL                                 23680000
245300***  CALCULATE TOTALS FOR CAPITAL                                 23690000
245400                                                                  23700000
245500     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.           23710000
245600                                                                  23720000
245700     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'                             23730000
245800        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT          23740000
245900        MOVE 0.00 TO H-CAPI-HSP-PCT.                              23750000
246000                                                                  23760000
246100     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'                             23770000
246200        MOVE 0    TO H-CAPI-OLD-HARMLESS                          23780000
246300        MOVE 1.00 TO H-CAPI-FSP-PCT                               23790000
246400        MOVE 0.00 TO H-CAPI-HSP-PCT.                              23800000
246500                                                                  23810000
246600     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'                             23820000
246700        MOVE 0    TO H-CAPI-OLD-HARMLESS                          23830000
246800        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT                 23840000
246900        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.                23850000
247000                                                                  23860000
247100     COMPUTE H-CAPI-HSP ROUNDED =                                 23870000
247200         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.                        23880000
247300                                                                  23890000
247400     COMPUTE H-CAPI-FSP ROUNDED =                                 23900000
247500         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.                        23910000
247600                                                                  23920000
247700     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.             23930000
247800                                                                  23940000
247900     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.                 23950000
248000                                                                  23960000
248100     COMPUTE H-CAPI-DSH-ADJ ROUNDED =                             23970000
248200             H-CAPI-FSP                                           23980000
248300              * H-CAPI-DSH.                                       23990000
248400                                                                  24000000
248500     COMPUTE H-CAPI-IME-ADJ ROUNDED =                             24010000
248600          H-CAPI-FSP *                                            24020000
248700                 H-WK-CAPI-IME-TEACH.                             24030000
248800                                                                  24040000
248900     COMPUTE H-CAPI-OUTLIER ROUNDED =                             24050000
249000             1.00 * H-CAPI-OUTLIER-PART.                          24060000
249100                                                                  24070000
249200     COMPUTE H-CAPI2-B-FSP ROUNDED =                              24080000
249300             1.00 * H-CAPI2-B-FSP-PART.                           24090000
249400                                                                  24100000
249500     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =                          24110000
249600             1.00 * H-CAPI2-B-OUTLIER-PART.                       24120000
249700***********************************************************       24130000
249800***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER               24140000
249900***        THIS ZEROES OUT ALL CAPITAL DATA                       24150000
250000                                                                  24160000
250100     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               24170000
250200        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.                   24180000
250300***********************************************************       24190000
250400                                                                  24200000
250500***********************************************************       24210000
250600***  CALCULATE FINAL TOTALS FOR OPERATING                         24220000
250700***  CALCULATE FINAL TOTALS FOR OPERATING                         24230000
250800                                                                  24240000
250900     IF (H-CAPI-OUTLIER > 0 AND                                   24250000
251000         PPS-OPER-OUTLIER-PART = 0)                               24260000
251100            COMPUTE PPS-OPER-OUTLIER-PART =                       24270000
251200                    PPS-OPER-OUTLIER-PART + .01.                  24280000
251300                                                                  24290000
251400     MOVE 01.000 TO WK-LOW-VOL25PCT.                              24300000
251500                                                                  24310000
251600     IF P-NEW-TEMP-RELIEF-IND = 'Y'                               24320000
251700        MOVE 01.250 TO WK-LOW-VOL25PCT.                           24330000
251800                                                                  24340000
251900     MOVE ZERO TO PPS-OPER-DSH-ADJ.                               24350000
252000                                                                  24360000
252100     IF  H-OPER-DSH NUMERIC                                       24370000
252200         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =                       24380000
252300       (WK-LOW-VOL25PCT * PPS-OPER-FSP-PART) * H-OPER-DSH.        24390000
252400                                                                  24400000
252500     COMPUTE PPS-OPER-IME-ADJ ROUNDED =                           24410000
252600      (WK-LOW-VOL25PCT * PPS-OPER-FSP-PART) * H-OPER-IME-TEACH.   24420000
252700                                                                  24430000
252800                                                                  24440000
252900     COMPUTE PPS-OPER-FSP-PART ROUNDED =                          24450000
253000        (WK-LOW-VOL25PCT * H-OPER-FSP-PART) * H-OPER-FSP-PCT.     24460000
253100                                                                  24470000
253200     COMPUTE PPS-OPER-HSP-PART ROUNDED =                          24480000
253300        (WK-LOW-VOL25PCT * H-OPER-HSP-PART) * H-OPER-HSP-PCT.     24490000
253400                                                                  24500000
253500     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =                      24510000
253600      (WK-LOW-VOL25PCT * H-OPER-OUTLIER-PART) * H-OPER-FSP-PCT.   24520000
253700                                                                  24530000
253800     IF HMO-TAG  = 'Y'                                            24540000
253900        PERFORM 3850-HMO-IME-ADJ.                                 24550000
254000                                                                  24560000
254100***********************************************************       24570000
254200***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING             24580000
254300***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING             24590000
254400                                                                  24600000
254500     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =                           24610000
254600            (H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +        24620002
254700             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +                    24630000
254800             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM) * WK-LOW-VOL25PCT. 24640002
254900                                                                  24650000
255000     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =                      24660000
255100             (WK-LOW-VOL25PCT * H-NEW-TECH-PAY-ADD-ON).           24670000
255200                                                                  24680000
255300     MOVE H-NEW-TECH-PAY-ADD-ON TO PPS-NEW-TECH-PAY-ADD-ON.       24690000
255400                                                                  24700000
255500     COMPUTE   PPS-TOTAL-PAYMENT ROUNDED =                        24710000
255600               PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +            24720000
255700               PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +         24730000
255800                      PPS-OPER-IME-ADJ                            24740000
255900                           +                                      24750000
256000                 PPS-NEW-TECH-PAY-ADD-ON                          24760000
256100                           +                                      24770000
256200                 H-WK-PASS-AMT-PLUS-MISC                          24780000
256300                           +                                      24790000
256400                   H-CAPI-TOTAL-PAY.                              24800000
256500                                                                  24810000
256600 3850-HMO-IME-ADJ.                                                24820000
256700***********************************************************       24830000
256800***  HMO CALC FOR PASS-THRU ADDON                                 24840000
256900***  HMO CALC FOR PASS-THRU ADDON                                 24850000
257000                                                                  24860000
257100***  HMO DIR-MED-ED  ---- NO LONGER PAID AS OF 10/01/2002         24870000
257200***  HMO ORGAN-ACQ   ---- NO LONGER PAID AS OF 10/01/2005         24880001
257300                                                                  24890000
257400     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =                    24900000
257500          (P-NEW-PASS-AMT-PLUS-MISC -                             24910001
257600          (P-NEW-PASS-AMT-ORGAN-ACQ +                             24920001
257700           P-NEW-PASS-AMT-DIR-MED-ED)) * B-LOS.                   24930001
257800                                                                  24940000
257900***********************************************************       24950000
258000***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002       24960000
258100                                                                  24970000
258200     COMPUTE PPS-OPER-IME-ADJ ROUNDED =                           24980000
258300                   PPS-OPER-IME-ADJ * .0.                         24990000
258400                                                                  25000000
258500***********************************************************       25010000
258600                                                                  25020000
258700                                                                  25030000
258800 3900A-CALC-OPER-DSH.                                             25040000
258900                                                                  25050000
259000***  OPERATING DSH CALCULATION EFFECTIVE OCT 1, 2005              25060000
259100***  OPERATING DSH CALCULATION EFFECTIVE OCT 1, 2005              25070000
259200                                                                  25080000
259300      MOVE 0.0000 TO H-OPER-DSH.                                  25090000
259400                                                                  25100000
259500      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO           25110000
259600                                     + P-NEW-MEDICAID-RATIO).     25120000
259700                                                                  25130000
259800***********************************************************       25140000
259900**1**    0-99 BEDS                                                25150000
260000***  NOT TO EXCEED 12%                                            25160000
260100                                                                  25170000
260200      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100      25180000
260300                               AND H-WK-OPER-DSH > .1499          25190000
260400                               AND H-WK-OPER-DSH < .2020          25200000
260500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        25210000
260600                                      * .65 + .025                25220000
260700        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.          25230000
260800                                                                  25240000
260900      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100      25250000
261000                               AND H-WK-OPER-DSH > .2019          25260000
261100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       25270000
261200                                      * .825 + .0588              25280000
261300        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.          25290000
261400                                                                  25300000
261500***********************************************************       25310000
261600**2**   100 + BEDS                                                25320000
261700***  NO CAP >> CAN EXCEED 12%                                     25330000
261800                                                                  25340000
261900      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99       25350000
262000                               AND H-WK-OPER-DSH > .1499          25360000
262100                               AND H-WK-OPER-DSH < .2020          25370000
262200        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        25380000
262300                                      * .65 + .025.               25390000
262400                                                                  25400000
262500      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99       25410000
262600                               AND H-WK-OPER-DSH > .2019          25420000
262700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       25430000
262800                                      * .825 + .0588.             25440000
262900                                                                  25450000
263000***********************************************************       25460000
263100**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS                  25470000
263200***  NOT TO EXCEED 12%                                            25480000
263300***  EXCEPT FOR URBAN TO RURAL HOSPITALS CR3459                   25490000
263400                                                                  25500000
263500      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500           25510000
263600                               AND H-WK-OPER-DSH > .1499          25520000
263700                               AND H-WK-OPER-DSH < .2020          25530000
263800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        25540000
263900                                 * .65 + .025                     25550000
264000        IF H-OPER-DSH > .1200                                     25560000
264100           IF P-NEW-DSH-ADJ-PROVIDERS                             25570000
264200              IF P-NEW-BED-SIZE > 99                              25580000
264300                 COMPUTE H-OPER-DSH ROUNDED =                     25590000
264400                 (.1200 + ((H-OPER-DSH - .1200) * .3333))         25600000
264500              ELSE                                                25610000
264600                 MOVE .1200 TO H-OPER-DSH                         25620000
264700           ELSE                                                   25630000
264800              MOVE .1200 TO H-OPER-DSH                            25640000
264900        ELSE                                                      25650000
265000           NEXT SENTENCE                                          25660000
265100      ELSE                                                        25670000
265200         NEXT SENTENCE.                                           25680000
265300                                                                  25690000
265400      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500           25700000
265500                               AND H-WK-OPER-DSH > .2019          25710000
265600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       25720000
265700                                 * .825 + .0588                   25730000
265800        IF H-OPER-DSH > .1200                                     25740000
265900           IF P-NEW-DSH-ADJ-PROVIDERS                             25750000
266000              IF P-NEW-BED-SIZE > 99                              25760000
266100                 COMPUTE H-OPER-DSH ROUNDED =                     25770000
266200                 (.1200 + ((H-OPER-DSH - .1200) * .3333))         25780000
266300              ELSE                                                25790000
266400                 MOVE .1200 TO H-OPER-DSH                         25800000
266500           ELSE                                                   25810000
266600              MOVE .1200 TO H-OPER-DSH                            25820000
266700        ELSE                                                      25830000
266800           NEXT SENTENCE                                          25840000
266900      ELSE                                                        25850000
267000         NEXT SENTENCE.                                           25860000
267100***********************************************************       25870000
267200**4**   OTHER RURAL HOSPITALS 500 BEDS +                          25880000
267300***  NO CAP >> CAN EXCEED 12%                                     25890000
267400                                                                  25900000
267500      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499           25910000
267600                               AND H-WK-OPER-DSH > .1499          25920000
267700                               AND H-WK-OPER-DSH < .2020          25930000
267800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        25940000
267900                                 * .65 + .025.                    25950000
268000                                                                  25960000
268100      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499           25970000
268200                               AND H-WK-OPER-DSH > .2019          25980000
268300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       25990000
268400                                 * .825 + .0588.                  26000000
268500                                                                  26010000
268600***********************************************************       26020000
268700**7**   RURAL HOSPITALS SCH                                       26030000
268800***  NOT TO EXCEED 12%                                            26040000
268900***  EXCEPT FOR URBAN TO RURAL HOSPITALS CR3459                   26050000
269000                                                                  26060000
269100      IF W-CBSA-SIZE = 'R'                                        26070000
269200         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')  26080000
269300                               AND H-WK-OPER-DSH > .1499          26090000
269400                               AND H-WK-OPER-DSH < .2020          26100000
269500         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)       26110000
269600                                 * .65 + .025                     26120000
269700        IF H-OPER-DSH > .1200                                     26130000
269800           IF P-NEW-DSH-ADJ-PROVIDERS                             26140000
269900              IF P-NEW-BED-SIZE > 99                              26150000
270000                 COMPUTE H-OPER-DSH ROUNDED =                     26160000
270100                 (.1200 + ((H-OPER-DSH - .1200) * .3333))         26170000
270200              ELSE                                                26180000
270300                 MOVE .1200 TO H-OPER-DSH                         26190000
270400           ELSE                                                   26200000
270500              MOVE .1200 TO H-OPER-DSH                            26210000
270600        ELSE                                                      26220000
270700           NEXT SENTENCE                                          26230000
270800      ELSE                                                        26240000
270900         NEXT SENTENCE.                                           26250000
271000                                                                  26260000
271100      IF W-CBSA-SIZE = 'R'                                        26270000
271200         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')  26280000
271300                               AND H-WK-OPER-DSH > .2019          26290000
271400         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)      26300000
271500                                 * .825 + .0588                   26310000
271600        IF H-OPER-DSH > .1200                                     26320000
271700           IF P-NEW-DSH-ADJ-PROVIDERS                             26330000
271800              IF P-NEW-BED-SIZE > 99                              26340000
271900                 COMPUTE H-OPER-DSH ROUNDED =                     26350000
272000                 (.1200 + ((H-OPER-DSH - .1200) * .3333))         26360000
272100              ELSE                                                26370000
272200                 MOVE .1200 TO H-OPER-DSH                         26380000
272300           ELSE                                                   26390000
272400              MOVE .1200 TO H-OPER-DSH                            26400000
272500        ELSE                                                      26410000
272600           NEXT SENTENCE                                          26420000
272700      ELSE                                                        26430000
272800         NEXT SENTENCE.                                           26440000
272900***********************************************************       26450000
273000**6**   RURAL HOSPITALS RRC   RULE 5 & 6 SAME                     26460000
273100***  RRC OVERRIDES SCH CAP                                        26470000
273200***  REMOVED CHECK FOR RURAL ON RRC'S CR3784H1                    26480000
273300***     MADE THIS CHG ON 03/06/2006                               26490000
273400***  NO CAP >> CAN EXCEED 12%                                     26500000
273500                                                                  26510000
273600***   IF W-CBSA-SIZE = 'R'                                        26520000
273700         IF (P-NEW-PROVIDER-TYPE = '07' OR '15' OR                26530000
273800                                   '17' OR '22')                  26540000
273900                               AND H-WK-OPER-DSH > .1499          26550000
274000                               AND H-WK-OPER-DSH < .2020          26560000
274100         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)       26570000
274200                                 * .65 + .025.                    26580000
274300***   IF W-CBSA-SIZE = 'R'                                        26590000
274400         IF (P-NEW-PROVIDER-TYPE = '07' OR '15' OR                26600000
274500                                   '17' OR '22')                  26610000
274600                               AND H-WK-OPER-DSH > .2019          26620000
274700         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)      26630000
274800                                 * .825 + .0588.                  26640000
274900                                                                  26650000
275000***********************************************************       26660000
275100                                                                  26670000
275200***********************************************************       26680000
275300***********************************************************       26690000
275400                                                                  26700000
275500      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.           26710000
275600                                                                  26720000
275700 3900A-EXIT.   EXIT.                                              26730000
275800                                                                  26740000
275900***********************************************************       26750000
276000***********************************************************       26760000
276100***********************************************************       26770000
276200***********************************************************       26780000
276300                                                                  26790000
276400 4000-CALC-TECH-ADDON.                                            26800000
276500                                                                  26810000
276600***********************************************************       26820000
276700***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH              26830000
276800***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH              26840000
276900***      CALCULATED FOR ADD ON DONE BEFORE OUTLER                 26850000
277000***      CALCULATED FOR ADD ON DONE BEFORE SPECIAL DRGS           26860000
277100                                                                  26870000
277200     COMPUTE PPS-OPER-HSP-PART ROUNDED =                          26880000
277300         H-OPER-HSP-PCT * H-OPER-HSP-PART.                        26890000
277400                                                                  26900000
277500     COMPUTE PPS-OPER-FSP-PART ROUNDED =                          26910000
277600         H-OPER-FSP-PCT * H-OPER-FSP-PART.                        26920000
277700                                                                  26930000
277800     MOVE ZERO TO PPS-OPER-DSH-ADJ.                               26940000
277900                                                                  26950000
278000     IF  H-OPER-DSH NUMERIC                                       26960000
278100             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =                   26970000
278200              PPS-OPER-FSP-PART                                   26980000
278300              * H-OPER-DSH.                                       26990000
278400                                                                  27000000
278500     COMPUTE PPS-OPER-IME-ADJ ROUNDED =                           27010000
278600             PPS-OPER-FSP-PART *                                  27020000
278700             H-OPER-IME-TEACH.                                    27030000
278800                                                                  27040000
278900     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =                         27050000
279000             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +              27060000
279100             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ.                 27070000
279200                                                                  27080000
279300***********************************************************       27090000
279400***       NEUROSTIMULATOR CASES                                   27100000
279500***********************************************************       27110000
279600                                                                  27120000
279700     IF '8698   ' =  B-PRIN-PROC-CODE   OR                        27130000
279800                     B-OTHER-PROC-CODE1 OR                        27140000
279900                     B-OTHER-PROC-CODE2 OR                        27150000
280000                     B-OTHER-PROC-CODE3 OR                        27160000
280100                     B-OTHER-PROC-CODE4 OR                        27170000
280200                     B-OTHER-PROC-CODE5                           27180000
280300           NEXT SENTENCE                                          27190000
280400     ELSE                                                         27200000
280500           MOVE ZEROES TO H-NEW-TECH-ADDON-NEURO                  27210000
280600           GO TO 4000-CHECK-GRAFT-CASES.                          27220000
280700                                                                  27230000
280800     MOVE 18640.00 TO H-CSTMED-NEURO.                             27240000
280900                                                                  27250000
281000     COMPUTE H-LESSER-NEURO-1 ROUNDED =                           27260000
281100             .5 * H-CSTMED-NEURO.                                 27270000
281200                                                                  27280000
281300     COMPUTE H-LESSER-NEURO-2 ROUNDED =                           27290000
281400           ((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -       27300000
281500                     H-BASE-DRG-PAYMENT) * .5.                    27310000
281600                                                                  27320000
281700     IF H-LESSER-NEURO-2 > 0                                      27330000
281800        IF H-LESSER-NEURO-1 < H-LESSER-NEURO-2                    27340000
281900           MOVE H-LESSER-NEURO-1 TO H-NEW-TECH-ADDON-NEURO        27350000
282000        ELSE                                                      27360000
282100           MOVE H-LESSER-NEURO-2 TO H-NEW-TECH-ADDON-NEURO        27370000
282200     ELSE                                                         27380000
282300        MOVE ZEROES          TO H-NEW-TECH-ADDON-NEURO.           27390000
282400                                                                  27400000
282500 4000-CHECK-GRAFT-CASES.                                          27410000
282600***********************************************************       27420000
282700***      GRAFT (GORE TAG) CASES                                   27430000
282800***********************************************************       27440000
282900                                                                  27450000
283000     IF '3973   ' =  B-PRIN-PROC-CODE   OR                        27460000
283100                     B-OTHER-PROC-CODE1 OR                        27470000
283200                     B-OTHER-PROC-CODE2 OR                        27480000
283300                     B-OTHER-PROC-CODE3 OR                        27490000
283400                     B-OTHER-PROC-CODE4 OR                        27500000
283500                     B-OTHER-PROC-CODE5                           27510000
283600           NEXT SENTENCE                                          27520000
283700     ELSE                                                         27530000
283800           MOVE ZEROES TO H-NEW-TECH-ADDON-GRAFT                  27540000
283900           GO TO 4000-CHECK-KINETRA-CASES.                        27550000
284000                                                                  27560000
284100     MOVE 21198.00 TO H-CSTMED-GRAFT.                             27570000
284200                                                                  27580000
284300     COMPUTE H-LESSER-GRAFT-1 ROUNDED =                           27590000
284400             .5 * H-CSTMED-GRAFT.                                 27600000
284500                                                                  27610000
284600     COMPUTE H-LESSER-GRAFT-2 ROUNDED =                           27620000
284700           ((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -       27630000
284800                     H-BASE-DRG-PAYMENT) * .5.                    27640000
284900                                                                  27650000
285000     IF H-LESSER-GRAFT-2 > 0                                      27660000
285100        IF H-LESSER-GRAFT-1 < H-LESSER-GRAFT-2                    27670000
285200           MOVE H-LESSER-GRAFT-1 TO H-NEW-TECH-ADDON-GRAFT        27680000
285300        ELSE                                                      27690000
285400           MOVE H-LESSER-GRAFT-2 TO H-NEW-TECH-ADDON-GRAFT        27700000
285500     ELSE                                                         27710000
285600        MOVE ZEROES          TO H-NEW-TECH-ADDON-GRAFT.           27720000
285700                                                                  27730000
285800 4000-CHECK-KINETRA-CASES.                                        27740000
285900***********************************************************       27750000
286000***      KINETRA CASES                                            27760000
286100***********************************************************       27770000
286200                                                                  27780000
286300     IF '0293   ' =  B-PRIN-PROC-CODE   OR                        27790000
286400                     B-OTHER-PROC-CODE1 OR                        27800000
286500                     B-OTHER-PROC-CODE2 OR                        27810000
286600                     B-OTHER-PROC-CODE3 OR                        27820000
286700                     B-OTHER-PROC-CODE4 OR                        27830000
286800                     B-OTHER-PROC-CODE5                           27840000
286900           NEXT SENTENCE                                          27850000
287000     ELSE                                                         27860000
287100           MOVE ZEROES TO H-NEW-TECH-ADDON-KINETRA                27870000
287200           GO TO 4000-ADD-TECH-CASES.                             27880000
287300                                                                  27890000
287400     IF '8695   ' =  B-PRIN-PROC-CODE   OR                        27900000
287500                     B-OTHER-PROC-CODE1 OR                        27910000
287600                     B-OTHER-PROC-CODE2 OR                        27920000
287700                     B-OTHER-PROC-CODE3 OR                        27930000
287800                     B-OTHER-PROC-CODE4 OR                        27940000
287900                     B-OTHER-PROC-CODE5                           27950000
288000           NEXT SENTENCE                                          27960000
288100     ELSE                                                         27970000
288200           MOVE ZEROES TO H-NEW-TECH-ADDON-KINETRA                27980000
288300           GO TO 4000-ADD-TECH-CASES.                             27990000
288400                                                                  28000000
288500     MOVE 16570.00 TO H-CSTMED-KINETRA.                           28010000
288600                                                                  28020000
288700     COMPUTE H-LESSER-KINETRA-1 ROUNDED =                         28030000
288800             .5 * H-CSTMED-KINETRA.                               28040000
288900                                                                  28050000
289000     COMPUTE H-LESSER-KINETRA-2 ROUNDED =                         28060000
289100           ((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -       28070000
289200                     H-BASE-DRG-PAYMENT) * .5.                    28080000
289300                                                                  28090000
289400     IF H-LESSER-KINETRA-2 > 0                                    28100000
289500        IF H-LESSER-KINETRA-1 < H-LESSER-KINETRA-2                28110000
289600         MOVE H-LESSER-KINETRA-1 TO H-NEW-TECH-ADDON-KINETRA      28120000
289700        ELSE                                                      28130000
289800         MOVE H-LESSER-KINETRA-2 TO H-NEW-TECH-ADDON-KINETRA      28140000
289900     ELSE                                                         28150000
290000        MOVE ZEROES          TO H-NEW-TECH-ADDON-KINETRA.         28160000
290100                                                                  28170000
290200                                                                  28180000
290300 4000-ADD-TECH-CASES.                                             28190000
290400                                                                  28200000
290500     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =                      28210000
290600             H-NEW-TECH-ADDON-NEURO  +                            28220000
290700             H-NEW-TECH-ADDON-GRAFT +                             28230000
290800             H-NEW-TECH-ADDON-KINETRA.                            28240000
290900                                                                  28250000
291000 4000-EXIT.    EXIT.                                              28260000
291100                                                                  28270000
291200******        L A S T   S O U R C E   S T A T E M E N T   *****   28280000
