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