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