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