000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.           PPCAL08D.                                  00020000
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     'PPCAL08D      - W O R K I N G   S T O R A G E'.             00180000
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C08.D'.     00190000
002000 01  HMO-FLAG                       PIC X      VALUE 'N'.         00200000
002100 01  HMO-TAG                        PIC X      VALUE SPACE.       00210000
002200 01  OUTLIER-RECON-FLAG             PIC X      VALUE 'N'.         00220000
002300 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.         00230000
002400 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES. 00240000
002500 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES. 00250000
002600 01  WK-LOW-VOL25PCT                PIC 99V999 VALUE 01.000.      00260000
002700 01  R1                             PIC S9(04) COMP SYNC.         00270000
002800 01  R2                             PIC S9(04) COMP SYNC.         00280000
002900 01  R3                             PIC S9(04) COMP SYNC.         00290000
003000 01  R4                             PIC S9(04) COMP SYNC.         00300000
003100 01  H-OPER-DSH-SCH                 PIC 9(01)V9(04).              00310000
003200 01  H-OPER-DSH-RRC                 PIC 9(01)V9(04).              00320000
003300                                                                  00330000
003400***************************************************************   00340000
003500**************YEARCHANGE***************************************   00341001
003600* TABLE 1                                                     *   00350000
003700*    (69.7% LABOR SHARE/30.3% NONLABOR SHARE)                 *   00360000
003800*    (FULL UPDATE (.697)                                      *   00370000
003900*    (QUALITY = 1 WAGE INDEX > 1)                             *   00380000
004000***************************************************************   00390000
004100**********YEARCHANGE**** 2008.6 *******************************   01320001
004200 01  TB1-RATE-TABLE.                                              00400000
004300     02  TB1-RATE-WORK.                                           00410000
004400*RATE 20071001 REGION  LABOR AND NON-LABOR RATES                  00420000
004500*                  R3=1     /     R3=2                            00430000
004600*               LARGE URBAN / OTHER URBAN                         00440000
004700*               LABOR / NON / LABOR / NON                         00450000
004800*                     /LABOR/       /LABOR                        00460000
004900*             --------------------------------------------        00470000
005000         05  FILLER PIC X(08) VALUE '20071001'.                   00480000
005100         05  TB1-NAT    PIC X(30) VALUE                           00490000
005200            ' 0347845 151215 0347845 151215'.                     00500000
005300         05  TB1-PR     PIC X(30) VALUE                           00510000
005400            ' 0147110 090164 0147110 090164'.                     00520000
005500         05  TB1-NATPR  PIC X(30) VALUE                           00530000
005600            ' 0347845 151215 0347845 151215'.                     00540000
005700***************************************************************   00550000
005800     02  TB1-RATE-TAB REDEFINES TB1-RATE-WORK.                    00560000
005900         05  TB1-RATE-PERIOD            OCCURS 1.                 00570000
006000             10  TB1-RATE-EFF-DATE      PIC X(08).                00580000
006100             10  TB1-REG-NAT            OCCURS 3.                 00590000
006200                 15  TB1-LARGE-OTHER    OCCURS 2.                 00600000
006300                     20  FILLER         PIC X(01).                00610000
006400                     20  TB1-REG-LABOR  PIC 9(05)V9(02).          00620000
006500                     20  FILLER         PIC X(01).                00630000
006600                     20  TB1-REG-NLABOR PIC 9(04)V9(02).          00640000
006700                                                                  00650000
006800***************************************************************   00660000
006900************YEARCHANGE*****************************************   00670000
007000* TABLE 2                                                     *   00680000
007100*    (69.7% LABOR SHARE/30.3% NONLABOR SHARE)                 *   00690000
007200*    (REDUCED UPDATE (.697)                                   *   00700000
007300*    (QUALITY NOT = 1 WAGE INDEX > 1)                         *   00710000
007400***************************************************************   00720000
007500**********YEARCHANGE**** 2008.6 *******************************   01320001
007600 01  TB2-RATE-TABLE.                                              00730000
007700     02  TB2-RATE-WORK.                                           00740000
007800*RATE 20071001 REGION  LABOR AND NON-LABOR RATES                  00750000
007900*                  R3=1     /     R3=2                            00760000
008000*               LARGE URBAN / OTHER URBAN                         00770000
008100*               LABOR / NON / LABOR / NON                         00780000
008200*                     /LABOR/       /LABOR                        00790000
008300*             --------------------------------------------        00800000
008400         05  FILLER PIC X(08) VALUE '20071001'.                   00810000
008500         05  TB2-NAT    PIC X(30) VALUE                           00820000
008600            ' 0341110 148287 0341110 148287'.                     00830000
008700         05  TB2-PR     PIC X(30) VALUE                           00840000
008800            ' 0147110 090164 0147110 090164'.                     00850000
008900         05  TB2-NATPR  PIC X(30) VALUE                           00860000
009000            ' 0341110 148287 0341110 148287'.                     00870000
009100***************************************************************   00880000
009200     02  TB2-RATE-TAB REDEFINES TB2-RATE-WORK.                    00890000
009300         05  TB2-RATE-PERIOD             OCCURS 1.                00900000
009400             10  TB2-RATE-EFF-DATE       PIC X(08).               00910000
009500             10  TB2-REG-NAT             OCCURS 3.                00920000
009600                 15  TB2-LARGE-OTHER     OCCURS 2.                00930000
009700                     20  FILLER          PIC X(01).               00940000
009800                     20  TB2-REG-LABOR   PIC 9(05)V9(02).         00950000
009900                     20  FILLER          PIC X(01).               00960000
010000                     20  TB2-REG-NLABOR  PIC 9(04)V9(02).         00970000
010100***************************************************************   00990000
010200************YEARCHANGE*****************************************   00991000
010300* TABLE 3                                                     *   01000000
010400*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *   01010000
010500*    (FULL UPDATE (.62%)                                      *   01020000
010600*    (QUALITY = 1 WAGE INDEX <= 1)                            *   01030000
010700***************************************************************   01040000
010800**********YEARCHANGE**** 2008.6 *******************************   01320001
010900 01  TB3-RATE-TABLE.                                              01050000
011000     02  TB3-RATE-WORK.                                           01060000
011100*RATE 20071001 REGION  LABOR AND NON-LABOR RATES                  01070000
011200*                  R3=1     /     R3=2                            01080000
011300*               LARGE URBAN / OTHER URBAN                         01090000
011400*               LABOR / NON / LABOR / NON                         01100000
011500*                     /LABOR/       /LABOR                        01110000
011600*             --------------------------------------------        01120000
011700         05  FILLER PIC X(08) VALUE '20071001'.                   01130000
011800         05  TB3-NAT    PIC X(30) VALUE                           01140000
011900            ' 0309417 189643 0309417 189643'.                     01150000
012000         05  TB3-PR     PIC X(30) VALUE                           01160000
012100            ' 0139280 097994 0139280 097994'.                           00
012200         05  TB3-NATPR  PIC X(30) VALUE                                 00
012300            ' 0309417 189643 0309417 189643'.                     01200000
012400****************************************************************  01210000
012500     02  TB3-RATE-TAB REDEFINES TB3-RATE-WORK.                    01210000
012600         05  TB3-RATE-PERIOD            OCCURS 1.                 01220000
012700             10  TB3-RATE-EFF-DATE      PIC X(08).                01230000
012800             10  TB3-REG-NAT            OCCURS 3.                 01240000
012900                 15  TB3-LARGE-OTHER    OCCURS 2.                 01250000
013000                     20  FILLER         PIC X(01).                01260000
013100                     20  TB3-REG-LABOR  PIC 9(05)V9(02).          01270000
013200                     20  FILLER         PIC X(01).                01280000
013300                     20  TB3-REG-NLABOR PIC 9(04)V9(02).          01290000
013400                                                                  01300000
013500***************************************************************   01310000
013600**********YEARCHANGE**** 2008.6 *******************************   01320001
013700* TABLE 4                                                     *   01330000
013800*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *   01340000
013900*    (REDUCED UPDATE (.62%)                                   *   01350000
014000*    (QUALITY NOT = 1 WAGE INDEX <=1)                         *   01360000
014100***************************************************************   01370000
014200 01  TB4-RATE-TABLE.                                              01380000
014300     02  TB4-RATE-WORK.                                           01390000
014400*RATE 20071001 REGION  LABOR AND NON-LABOR RATES                  01400000
014500*                  R3=1     /     R3=2                            01410000
014600*               LARGE URBAN / OTHER URBAN                         01420000
014700*               LABOR / NON / LABOR / NON                         01430000
014800*                     /LABOR/       /LABOR                        01440000
014900*             --------------------------------------------        01450000
015000         05  FILLER PIC X(08) VALUE '20071001'.                   01460000
015100         05  TB4-NAT    PIC X(30) VALUE                           01470000
015200            ' 0303426 185971 0303426 185971'.                     01480001
015300         05  TB4-PR     PIC X(30) VALUE                           01490000
015400            ' 0139280 097994 0139280 097994'.                     01500000
015500         05  TB4-NATPR  PIC X(30) VALUE                           01510000
015600            ' 0303426 185971 0303426 185971'.                     01520001
015700***************************************************************   01530000
015800     02  TB4-RATE-TAB REDEFINES TB4-RATE-WORK.                    01540000
015900         05  TB4-RATE-PERIOD             OCCURS 1.                01550000
016000             10  TB4-RATE-EFF-DATE       PIC X(08).               01560000
016100             10  TB4-REG-NAT             OCCURS 3.                01570000
016200                 15  TB4-LARGE-OTHER     OCCURS 2.                01580000
016300                     20  FILLER          PIC X(01).               01590000
016400                     20  TB4-REG-LABOR   PIC 9(05)V9(02).         01600000
016500                     20  FILLER          PIC X(01).               01610000
016600                     20  TB4-REG-NLABOR  PIC 9(04)V9(02).         01620000
016700                                                                  01630000
016800 01  DRG-TABLE.                                                   01640000
016900     05  D-TAB.                                                   01650000
017000       10  FILLER                  PIC X(08) VALUE                01660000
017100     '20071001'.                                                  01670000
017200       10  FILLER                  PIC X(56) VALUE                01680000
017300     '23111730800456162735161002281877073340040611421923800293'.  01690000
017400       10  FILLER                  PIC X(56) VALUE                01700000
017500     '10612017600235072562091001050840021460017305172610100118'.  01710000
017600       10  FILLER                  PIC X(56) VALUE                01720000
017700     '06484218100217038902092001050414821290016203247208900109'.  01730000
017800       10  FILLER                  PIC X(56) VALUE                01740000
017900     '02676006100072000000000000000000000000000000000000000000'.  01750000
018000       10  FILLER                  PIC X(56) VALUE                01760000
018100     '00000000000000000000000000000000000000000007707315200191'.  01770000
018200       10  FILLER                  PIC X(56) VALUE                01780000
018300     '06702113400155056085078000960470360900012803897806100089'.  01790000
018400       10  FILLER                  PIC X(56) VALUE                01800000
018500     '04236210300133031582065000820232590350004604233910800147'.  01810000
018600       10  FILLER                  PIC X(56) VALUE                01820000
018700     '02835605300073017617028000370322260920013201934203800058'.  01830000
018800       10  FILLER                  PIC X(56) VALUE                01840000
018900     '01428102300031025438048000730189960200002901697701300016'.  01850000
019000       10  FILLER                  PIC X(56) VALUE                01860000
019100     '02263006000087014686025000370109090150001803255010000136'.  01870000
019200       10  FILLER                  PIC X(56) VALUE                01880000
019300     '02359505400073018710025000360000000000000000000000000000'.  01890000
019400       10  FILLER                  PIC X(56) VALUE                01900000
019500     '00000000000000000000000000000000000000000000000000000000'.  01910000
019600       10  FILLER                  PIC X(56) VALUE                01920000
019700     '00000000000000000000000000000000000000000001432904700070'.  01930000
019800       10  FILLER                  PIC X(56) VALUE                01940000
019900     '01117203100040014228053000720112130380005001282005800078'.  01950000
020000       10  FILLER                  PIC X(56) VALUE                01960000
020100     '00895103900049012669058000800092260430005200816003400041'.  01970000
020200       10  FILLER                  PIC X(56) VALUE                01980000
020300     '02554107300096020886053000630186420390004501547005600076'.  01990000
020400       10  FILLER                  PIC X(56) VALUE                02000000
020500     '01190104300053010303031000380121940470006200913102800036'.  02010000
020600       10  FILLER                  PIC X(56) VALUE                02020000
020700     '00733902500031016212060000790125220450005600958602900037'.  02030000
020800       10  FILLER                  PIC X(56) VALUE                02040000
020900     '01171704800064008954034000440153690600007601143903400042'.  02050000
021000       10  FILLER                  PIC X(56) VALUE                02060000
021100     '01461105600072010996037000460098390280003400901403600049'.  02070000
021200       10  FILLER                  PIC X(56) VALUE                02080000
021300     '00716102700034016724039000640133280370005201110602300031'.  02090000
021400       10  FILLER                  PIC X(56) VALUE                02100000
021500     '01694605700079012337040000510092350260003401296804300061'.  02110000
021600       10  FILLER                  PIC X(56) VALUE                02120000
021700     '00947903000038007405020000250132420470006600952903500044'.  02130000
021800       10  FILLER                  PIC X(56) VALUE                02140000
021900     '00771002600032031499097001250256790720009102348204900062'.  02150000
022000       10  FILLER                  PIC X(56) VALUE                02160000
022100     '02666509300118020568068000850181770510006301250004700063'.  02170000
022200       10  FILLER                  PIC X(56) VALUE                02180000
022300     '00825802900037008710036000510066770250003200000000000000'.  02190000
022400       10  FILLER                  PIC X(56) VALUE                02200000
022500     '00000000000000000000000000000000000000000000000000000000'.  02210000
022600       10  FILLER                  PIC X(56) VALUE                02220000
022700     '00000000000000000000000000000000000000000000000000000000'.  02230000
022800       10  FILLER                  PIC X(56) VALUE                02240000
022900     '01414103800055010292020000270111850330004500889102200034'.  02250000
023000       10  FILLER                  PIC X(56) VALUE                02260000
023100     '00709401500019000000000000000000000000000000000000000000'.  02270000
023200       10  FILLER                  PIC X(56) VALUE                02280000
023300     '00880004600058006608033000410072240240002900930803900053'.  02290000
023400       10  FILLER                  PIC X(56) VALUE                02300000
023500     '00679202700035000000000000000000000000000000000000000000'.  02310000
023600       10  FILLER                  PIC X(56) VALUE                02320000
023700     '01799203700051013987024000320163000400005801205402100026'.  02330000
023800       10  FILLER                  PIC X(56) VALUE                02340000
023900     '01433103700058009474017000210153180430006401109401800026'.  02350000
024000       10  FILLER                  PIC X(56) VALUE                02360000
024100     '01267703700054008474019000240084700140001800000000000000'.  02370000
024200       10  FILLER                  PIC X(56) VALUE                02380000
024300     '00000000000000000000000000000000000000000000000000000000'.  02390000
024400       10  FILLER                  PIC X(56) VALUE                02400000
024500     '00000000000000017734071001030121820420005801007002500035'.  02410000
024600       10  FILLER                  PIC X(56) VALUE                02420000
024700     '00615402200027009916040000550062270230002900816003700047'.  02430000
024800       10  FILLER                  PIC X(56) VALUE                02440000
024900     '00620702800034011294048000650086300350004500741202500032'.  02450000
025000       10  FILLER                  PIC X(56) VALUE                02460000
025100     '01190905000069008653034000440073610240003100000000000000'.  02470000
025200       10  FILLER                  PIC X(56) VALUE                02480000
025300     '00000000000000000000000000000404521220015002808106900083'.  02490000
025400       10  FILLER                  PIC X(56) VALUE                02500000
025500     '02410604500054032677101001300241510650008101818104000054'.  02510000
025600       10  FILLER                  PIC X(56) VALUE                02520000
025700     '00000000000000000000000000000000000000000000000000000000'.  02530000
025800       10  FILLER                  PIC X(56) VALUE                02540000
025900     '00000000000000000000000000000141520610007401158004700055'.  02550000
026000       10  FILLER                  PIC X(56) VALUE                02560000
026100     '01844407200092015636060000740127540460005601555006100080'.  02570000
026200       10  FILLER                  PIC X(56) VALUE                02580000
026300     '01312604500060011455033000430126640570007200961103800046'.  02590000
026400       10  FILLER                  PIC X(56) VALUE                02600000
026500     '00729802700033014542058000750119470420005500974503200041'.  02610000
026600       10  FILLER                  PIC X(56) VALUE                02620000
026700     '01366004800062011138051000650094050420005100814503400040'.  02630000
026800       10  FILLER                  PIC X(56) VALUE                02640000
026900     '01250505500069010235045000530083980350004101378105800073'.  02650000
027000       10  FILLER                  PIC X(56) VALUE                02660000
027100     '01145804400054009654035000430146990660008501075303900051'.  02670000
027200       10  FILLER                  PIC X(56) VALUE                02680000
027300     '00858803200041007841036000450062520290003500665802200029'.  02690000
027400       10  FILLER                  PIC X(56) VALUE                02700000
027500     '01063604200056007848027000350512311260015002246305200073'.  02710000
027600       10  FILLER                  PIC X(56) VALUE                02720000
027700     '00000000000000000000000000000000000000000000000000000000'.  02730000
027800       10  FILLER                  PIC X(56) VALUE                02740000
027900     '00000000000000000000000000001200160630012009304015900187'.  02750000
028000       10  FILLER                  PIC X(56) VALUE                02760000
028100     '07581310900122068595083000910720721170014505727807600086'.  02770000
028200       10  FILLER                  PIC X(56) VALUE                02780000
028300     '05246306000064080234108001330688090500006607317809200115'.  02790000
028400       10  FILLER                  PIC X(56) VALUE                02800000
028500     '06295604500057059123062000940504110180002806740012000146'.  02810000
028600       10  FILLER                  PIC X(56) VALUE                02820000
028700     '05319107900090047847056000660729931080013206194708000090'.  02830000
028800       10  FILLER                  PIC X(56) VALUE                02840000
028900     '06449612400143049216082000890513810970011503730706100066'.  02850000
029000       10  FILLER                  PIC X(56) VALUE                02860000
029100     '04495407800112031891034000490394541210015602998308400105'.  02870000
029200       10  FILLER                  PIC X(56) VALUE                02880000
029300     '02470905700069032586069000890254830380005102136702200029'.  02890000
029400       10  FILLER                  PIC X(56) VALUE                02900000
029500     '03107302100033029046037000550212550170002202518004300062'.  02910000
029600       10  FILLER                  PIC X(56) VALUE                02920000
029700     '01812401900025024870053000750174800210003002756405600088'.  02930000
029800       10  FILLER                  PIC X(56) VALUE                02940000
029900     '02253604100060016786020000280214860730009901684705800075'.  02950000
030000       10  FILLER                  PIC X(56) VALUE                02960000
030100     '01399003700049022926055000760165530190002602162507200102'.  02970000
030200       10  FILLER                  PIC X(56) VALUE                02980000
030300     '01321202800039011245019000250149770350005502484005900090'.  02990000
030400       10  FILLER                  PIC X(56) VALUE                03000000
030500     '00000000000000000000000000000000000000000000000000000000'.  03010000
030600       10  FILLER                  PIC X(56) VALUE                03020000
030700     '00000000000000000000000000000000000000000000000000000000'.  03030000
030800       10  FILLER                  PIC X(56) VALUE                03040000
030900     '00000000000000000000000000000000000000000000000000000000'.  03050000
031000       10  FILLER                  PIC X(56) VALUE                03060000
031100     '00000000000000000000000000000000000000000001739105900075'.  03070000
031200       10  FILLER                  PIC X(56) VALUE                03080000
031300     '01312604000049010617026000320157870340005501207402300035'.  03090000
031400       10  FILLER                  PIC X(56) VALUE                03100000
031500     '01042101600022016667052000710114120250003202914309600122'.  03110000
031600       10  FILLER                  PIC X(56) VALUE                03120000
031700     '02307507100087019733052000660125850510006601013404100050'.  03130000
031800       10  FILLER                  PIC X(56) VALUE                03140000
031900     '00876503100037008665046000550069500380004401114402000033'.  03150000
032000       10  FILLER                  PIC X(56) VALUE                03160000
032100     '00849001500019007207012000140122200520006900945104100051'.  03170000
032200       10  FILLER                  PIC X(56) VALUE                03180000
032300     '00718303100038008236033000440060550210002600831203900052'.  03190000
032400       10  FILLER                  PIC X(56) VALUE                03200000
032500     '00594202300029012007045000650082240270003501084104300058'.  03210000
032600       10  FILLER                  PIC X(56) VALUE                03220000
032700     '00823303100039006439023000280051180190002300719702500032'.  03230000
032800       10  FILLER                  PIC X(56) VALUE                03240000
032900     '00548901700021015606051000710117200350004600907502400030'.  03250000
033000       10  FILLER                  PIC X(56) VALUE                03260000
033100     '00000000000000000000000000000000000000000000000000000000'.  03270000
033200       10  FILLER                  PIC X(56) VALUE                03280000
033300     '00000000000000000000000000000000000000000000000000000000'.  03290000
033400       10  FILLER                  PIC X(56) VALUE                03300000
033500     '00000000000000051660134001720329410810010301801703300044'.  03310000
033600       10  FILLER                  PIC X(56) VALUE                03320000
033700     '04505912800159028935084000980184150540006003713912200147'.  03330000
033800       10  FILLER                  PIC X(56) VALUE                03340000
033900     '02578707800089017856049000560347851180014402477607700093'.  03350000
034000       10  FILLER                  PIC X(56) VALUE                03360000
034100     '01698404400057027254091001090198050610007101384903600043'.  03370000
034200       10  FILLER                  PIC X(56) VALUE                03380000
034300     '01882405300073013562034000430098870190002302515609400120'.  03390000
034400       10  FILLER                  PIC X(56) VALUE                03400000
034500     '01702806200072012617044000500176580620008401278104100055'.  03410000
034600       10  FILLER                  PIC X(56) VALUE                03420000
034700     '00862902400030018330059000810124490340004500896701900024'.  03430000
034800       10  FILLER                  PIC X(56) VALUE                03440000
034900     '02024106600088014092040000510101470230002903379009600133'.  03450000
035000       10  FILLER                  PIC X(56) VALUE                03460000
035100     '02494606100080017333034000460000000000000000000000000000'.  03470000
035200       10  FILLER                  PIC X(56) VALUE                03480000
035300     '00000000000000000000000000000000000000000000000000000000'.  03490000
035400       10  FILLER                  PIC X(56) VALUE                03500000
035500     '00000000000000000000000000000000000000000001378805100066'.  03510000
035600       10  FILLER                  PIC X(56) VALUE                03520000
035700     '01083903700046009558028000340162630660008801305905500068'.  03530000
035800       10  FILLER                  PIC X(56) VALUE                03540000
035900     '01110904200050017229065000880133370460006001026803100041'.  03550000
036000       10  FILLER                  PIC X(56) VALUE                03560000
036100     '01336705000065010195037000450084760290003401433405500072'.  03570000
036200       10  FILLER                  PIC X(56) VALUE                03580000
036300     '01130204200051009662030000360110240460005900839903200038'.  03590000
036400       10  FILLER                  PIC X(56) VALUE                03600000
036500     '01493606700090010766046000570094880360004401286005500074'.  03610000
036600       10  FILLER                  PIC X(56) VALUE                03620000
036700     '00953304000050007260030000360095650410005500712102800035'.  03630000
036800       10  FILLER                  PIC X(56) VALUE                03640000
036900     '01323705000070010257038000490078740270003400000000000000'.  03650000
037000       10  FILLER                  PIC X(56) VALUE                03660000
037100     '00000000000000000000000000000000000000000000000000000000'.  03670000
037200       10  FILLER                  PIC X(56) VALUE                03680000
037300     '00000000000000000000000000000000000000000000000000000000'.  03690000
037400       10  FILLER                  PIC X(56) VALUE                03700000
037500     '04827312800173033149071000950224430420005503854012200151'.  03710000
037600       10  FILLER                  PIC X(56) VALUE                03720000
037700     '02912608200099020794057000680341281090013102638207600088'.  03730000
037800       10  FILLER                  PIC X(56) VALUE                03740000
037900     '01941205200060030942097001190227490660007701539804100049'.  03750000
038000       10  FILLER                  PIC X(56) VALUE                03760000
038100     '02136106600084017104045000560124000250003203485110100142'.  03770000
038200       10  FILLER                  PIC X(56) VALUE                03780000
038300     '02255705600078019432034000450395931140015503010407800102'.  03790000
038400       10  FILLER                  PIC X(56) VALUE                03800000
038500     '02581204500056000000000000000000000000000000000000000000'.  03810000
038600       10  FILLER                  PIC X(56) VALUE                03820000
038700     '00000000000000000000000000000000000000000001503305100069'.  03830000
038800       10  FILLER                  PIC X(56) VALUE                03840000
038900     '01143103800049010125028000360156610580007701290604500059'.  03850000
039000       10  FILLER                  PIC X(56) VALUE                03860000
039100     '01170903300044014201056000770106090430005400891203200039'.  03870000
039200       10  FILLER                  PIC X(56) VALUE                03880000
039300     '01397305100070010935040000510090790310003801374405000066'.  03890000
039400       10  FILLER                  PIC X(56) VALUE                03900000
039500     '01103003800048008521026000330000000000000000000000000000'.  03910000
039600       10  FILLER                  PIC X(56) VALUE                03920000
039700     '00000000000000000000000000000000000000000000000000000000'.  03930000
039800       10  FILLER                  PIC X(56) VALUE                03940000
039900     '08431312700159065810068000840570230410004706766912100159'.  03950000
040000       10  FILLER                  PIC X(56) VALUE                03960000
040100     '05465006400078049437041000460486790780009603487003800043'.  03970000
040200       10  FILLER                  PIC X(56) VALUE                03980000
040300     '03834506900085030993039000430396151230016902882107800104'.  03990000
040400       10  FILLER                  PIC X(56) VALUE                04000000
040500     '02341704600062035408076000950275230480005602454503700040'.  04010000
040600       10  FILLER                  PIC X(56) VALUE                04020000
040700     '02666407100084019871037000400347230700010102481902900043'.  04030000
040800       10  FILLER                  PIC X(56) VALUE                04040000
040900     '01944601600020028432095001250213080660008601679903800050'.  04050000
041000       10  FILLER                  PIC X(56) VALUE                04060000
041100     '02655509600125019836048000680167840190002802402708000095'.  04070000
041200       10  FILLER                  PIC X(56) VALUE                04080000
041300     '01848505400060015644045000490199050350004401737602200025'.  04090000
041400       10  FILLER                  PIC X(56) VALUE                04100000
041500     '02936210200124023382068000810177710500005801658404100051'.  04110000
041600       10  FILLER                  PIC X(56) VALUE                04120000
041700     '01451202700031014912033000470100660180002302241306900087'.  04130000
041800       10  FILLER                  PIC X(56) VALUE                04140000
041900     '01718604400053012752028000340257650830011101779204600060'.  04150000
042000       10  FILLER                  PIC X(56) VALUE                04160000
042100     '01230102300031017563058000820118870230003102409608100113'.  04170000
042200       10  FILLER                  PIC X(56) VALUE                04180000
042300     '01559804400059010342023000290175380690008901405805000064'.  04190000
042400       10  FILLER                  PIC X(56) VALUE                04200000
042500     '01158402600034010877023000320142960360005201133001700020'.  04210000
042600       10  FILLER                  PIC X(56) VALUE                04220000
042700     '01076901900028016616050000660125120310003900960201700021'.  04230000
042800       10  FILLER                  PIC X(56) VALUE                04240000
042900     '01174803700051008313020000260248580810010901830704400060'.  04250000
043000       10  FILLER                  PIC X(56) VALUE                04260000
043100     '01419202000029000000000000000000000000000000000000000000'.  04270000
043200       10  FILLER                  PIC X(56) VALUE                04280000
043300     '00000000000000000000000000000000000000000000000000000000'.  04290000
043400       10  FILLER                  PIC X(56) VALUE                04300000
043500     '00000000000000000000000000000000000000000000000000000000'.  04310000
043600       10  FILLER                  PIC X(56) VALUE                04320000
043700     '00000000000000000000000000000000000000000000000000000000'.  04330000
043800       10  FILLER                  PIC X(56) VALUE                04340000
043900     '01129405100069007560032000400108360480006400734003400040'.  04350000
044000       10  FILLER                  PIC X(56) VALUE                04360000
044100     '00752803800047005986026000310176480770010201402605800072'.  04370000
044200       10  FILLER                  PIC X(56) VALUE                04380000
044300     '01210104400057014877068000870111510480006000939503700045'.  04390000
044400       10  FILLER                  PIC X(56) VALUE                04400000
044500     '01833006500090012092043000550090540320003901537207000093'.  04410000
044600       10  FILLER                  PIC X(56) VALUE                04420000
044700     '01152205000062009567036000450116320550007200783903400042'.  04430000
044800       10  FILLER                  PIC X(56) VALUE                04440000
044900     '00919904800061006475030000370078860360004900595802500032'.  04450000
045000       10  FILLER                  PIC X(56) VALUE                04460000
045100     '01217105400069008480035000430121040510007300852103600047'.  04470000
045200       10  FILLER                  PIC X(56) VALUE                04480000
045300     '00675302100027011163050000650069810310003701160605300071'.  04490000
045400       10  FILLER                  PIC X(56) VALUE                04500000
045500     '00900304000051007790029000370000000000000000000000000000'.  04510000
045600       10  FILLER                  PIC X(56) VALUE                04520000
045700     '00000000000000000000000000000000000000000000000000000000'.  04530000
045800       10  FILLER                  PIC X(56) VALUE                04540000
045900     '02748310100138020177072000950142160470005902476607800121'.  04550000
046000       10  FILLER                  PIC X(56) VALUE                04560000
046100     '01626204100060010742025000340230930810011101425603600055'.  04570000
046200       10  FILLER                  PIC X(56) VALUE                04580000
046300     '00912401900026009432021000290075230160001801248403700057'.  04590000
046400       10  FILLER                  PIC X(56) VALUE                04591000
046500     '00906601700022000000000000000000000000000000000000000000'.  04592000
046600       10  FILLER                  PIC X(56) VALUE                04593000
046700     '00000000000000000000000000000000000000000001455506600089'.  04594000
046800       10  FILLER                  PIC X(56) VALUE                04595000
046900     '01106005200065009335039000490139970600008200876603800048'.  04596000
047000       10  FILLER                  PIC X(56) VALUE                04597000
047100     '01403405900082010695042000560072320260003600847104100054'.  04598000
047200       10  FILLER                  PIC X(56) VALUE                04599000
047300     '00671503100038011522055000700080870390004700968104100054'.  04599100
047400       10  FILLER                  PIC X(56) VALUE                04599200
047500     '00686302800035009223042000590065050290003800000000000000'.  04599300
047600       10  FILLER                  PIC X(56) VALUE                04599400
047700     '00000000000000000000000000000000000000000000000000000000'.  04599500
047800       10  FILLER                  PIC X(56) VALUE                04599600
047900     '00000000000000021978052000730165020280003403144912600156'.  04599700
048000       10  FILLER                  PIC X(56) VALUE                04599800
048100     '02207107200090017554049000610276250640009301929403400042'.  04599900
048200       10  FILLER                  PIC X(56) VALUE                04600000
048300     '01687602100024027257097001320200650680008701605604600059'.  04600100
048400       10  FILLER                  PIC X(56) VALUE                04600200
048500     '01592805000075010183022000330081690130001503060207800118'.  04600300
048600       10  FILLER                  PIC X(56) VALUE                04600400
048700     '02473007000088017767037000510000000000000000000000000000'.  04600500
048800       10  FILLER                  PIC X(56) VALUE                04600600
048900     '00000000000000000000000000000000000000000000000000000000'.  04600700
049000       10  FILLER                  PIC X(56) VALUE                04600800
049100     '01089104600062008021034000430067420250003100979304100056'.  04600900
049200       10  FILLER                  PIC X(56) VALUE                04601000
049300     '00724803100039010616038000530139260600007801063804300054'.  04601100
049400       10  FILLER                  PIC X(56) VALUE                04601200
049500     '00831003200039000000000000000000000000000000000000000000'.  04601300
049600       10  FILLER                  PIC X(56) VALUE                04601400
049700     '00000000000000000000000000000000000000000003065406600079'.  04601500
049800       10  FILLER                  PIC X(56) VALUE                04601600
049900     '04571013300168031860088001010270750580006602660308400108'.  04601700
050000       10  FILLER                  PIC X(56) VALUE                04601800
050100     '01899705100061016556033000380281190820011302060504800065'.  04601900
050200       10  FILLER                  PIC X(56) VALUE                04602000
050300     '01400402600033020375073001050142540360005301038801600021'.  04602100
050400       10  FILLER                  PIC X(56) VALUE                04602200
050500     '02139309300122014691043000630093350200002701720806300086'.  04602300
050600       10  FILLER                  PIC X(56) VALUE                04602400
050700     '01207903100044008838019000250128080390005800842201900025'.  04602500
050800       10  FILLER                  PIC X(56) VALUE                04602600
050900     '02523506000102021024040000660171960140001900000000000000'.  04602700
051000       10  FILLER                  PIC X(56) VALUE                04602800
051100     '00000000000000000000000000000000000000000000000000000000'.  04602900
051200       10  FILLER                  PIC X(56) VALUE                04603000
051300     '00000000000000014664053000730119420450005700983503100038'.  04603100
051400       10  FILLER                  PIC X(56) VALUE                04603200
051500     '00859902400035014513060000810111470400005300857702500032'.  04603300
051600       10  FILLER                  PIC X(56) VALUE                04603400
051700     '01058705000064008000036000430115080300004200945701800023'.  04603500
051800       10  FILLER                  PIC X(56) VALUE                04603600
051900     '01045903900052007110020000260094220430005700627602600032'.  04603700
052000       10  FILLER                  PIC X(56) VALUE                04603800
052100     '00722302400033013017051000680103520380004900823202700035'.  04603900
052200       10  FILLER                  PIC X(56) VALUE                04604000
052300     '00000000000000000000000000000000000000000000000000000000'.  04604100
052400       10  FILLER                  PIC X(56) VALUE                04604200
052500     '00000000000000000000000000000155210350004501185802000024'.  04604300
052600       10  FILLER                  PIC X(56) VALUE                04604400
052700     '01613403600065012986015000190160510530007801084202100030'.  04604500
052800       10  FILLER                  PIC X(56) VALUE                04604600
052900     '00985002900042006710017000200153000380006101131001300015'.  04604700
053000       10  FILLER                  PIC X(56) VALUE                04604800
053100     '01565305000075010329021000270000000000000000000000000000'.  04604900
053200       10  FILLER                  PIC X(56) VALUE                04605000
053300     '00000000000000012827056000740106030420005400767702500033'.  04605100
053400       10  FILLER                  PIC X(56) VALUE                04605200
053500     '00907104400057006886028000350100830510006500724103300040'.  04605300
053600       10  FILLER                  PIC X(56) VALUE                04605400
053700     '00954203700051007058024000320000000000000000000000000000'.  04605500
053800       10  FILLER                  PIC X(56) VALUE                04605600
053900     '00000000000000020185058000760137980300003503210811500139'.  04605700
054000       10  FILLER                  PIC X(56) VALUE                04605800
054100     '02102206200074016754035000390220810790010201457704400052'.  04605900
054200       10  FILLER                  PIC X(56) VALUE                04606000
054300     '01030802800031012422035000460086720210002301189604000058'.  04606100
054400       10  FILLER                  PIC X(56) VALUE                04606200
054500     '00866002100025010488030000410084990170001900791601500018'.  04606300
054600       10  FILLER                  PIC X(56) VALUE                04606400
054700     '02281307100098014993026000330000000000000000000000000000'.  04606500
054800       10  FILLER                  PIC X(56) VALUE                04606600
054900     '00000000000000015596064000890116080420005600770202500033'.  04606700
055000       10  FILLER                  PIC X(56) VALUE                04606800
055100     '01432806800089011147049000610096090370004600691002900038'.  04606900
055200       10  FILLER                  PIC X(56) VALUE                04607000
055300     '00556902000025000000000000000000000000000000000000000000'.  04607100
055400       10  FILLER                  PIC X(56) VALUE                04607200
055500     '00994304100053007664030000320072460250002901734804700058'.  04607300
055600       10  FILLER                  PIC X(56) VALUE                04607400
055700     '01911403200057007336016000260000000000000000000000000000'.  04607500
055800       10  FILLER                  PIC X(56) VALUE                04607600
055900     '00000000000000005914026000320044610210002300646002600035'.  04607700
056000       10  FILLER                  PIC X(56) VALUE                04607800
056100     '00708701800021003744020000280060130170002600284501300027'.  04607900
056200       10  FILLER                  PIC X(56) VALUE                04608000
056300     '00568902700039004297017000280000000000000000000000000000'.  04608100
056400       10  FILLER                  PIC X(56) VALUE                04608200
056500     '00000000000000000000000000000000000000000000000000000000'.  04608300
056600       10  FILLER                  PIC X(56) VALUE                04608400
056700     '01425001800018046990179001790320931330013301936408600086'.  04608500
056800       10  FILLER                  PIC X(56) VALUE                04608600
056900     '03296604700047011668034000340015800310003100000000000000'.  04608700
057000       10  FILLER                  PIC X(56) VALUE                04608800
057100     '00000000000000000000000000000395131070014302761706400082'.  04608900
057200       10  FILLER                  PIC X(56) VALUE                04609000
057300     '02325203700048027940091001280182590470006501475402400032'.  04609100
057400       10  FILLER                  PIC X(56) VALUE                04609200
057500     '00000000000000000000000000000000000000000001617106000080'.  04609300
057600       10  FILLER                  PIC X(56) VALUE                04609400
057700     '01203103900050010741031000390100060400005500778002800037'.  04609500
057800       10  FILLER                  PIC X(56) VALUE                04609600
057900     '01342603800052013226053000720102330390004900799002700034'.  04609700
058000       10  FILLER                  PIC X(56) VALUE                04609800
058100     '00000000000000000000000000000000000000000004497013800184'.  04609900
058200       10  FILLER                  PIC X(56) VALUE                04610000
058300     '02684705400078015989027000370351881200015402516406600088'.  04610100
058400       10  FILLER                  PIC X(56) VALUE                04610200
058500     '01620103300047039780130001740242300570007501510902900037'.  04610300
058600       10  FILLER                  PIC X(56) VALUE                04610400
058700     '02489406900105016396025000350000000000000000000000000000'.  04610500
058800       10  FILLER                  PIC X(56) VALUE                04610600
058900     '00000000000000036361089001470256260530008202178503400051'.  04610700
059000       10  FILLER                  PIC X(56) VALUE                04610800
059100     '04778817200227029919062000900239800490006102145406800096'.  04610900
059200       10  FILLER                  PIC X(56) VALUE                04611000
059300     '01644405000066012188032000430163410630008701240304500060'.  04611100
059400       10  FILLER                  PIC X(56) VALUE                04611200
059500     '00966403300043016523058000850102960270003300911602300029'.  04611300
059600       10  FILLER                  PIC X(56) VALUE                04611400
059700     '01266304300060000000000000000000000000000000000000000000'.  04611500
059800       10  FILLER                  PIC X(56) VALUE                04611600
059900     '05184012800168039291091001120336620560007303925712100162'.  04611700
060000       10  FILLER                  PIC X(56) VALUE                04611800
060100     '02491906800089020996047000600000000000000000000000000000'.  04611900
060200       10  FILLER                  PIC X(56) VALUE                04612000
060300     '00000000000000015454062000830105600420005200824003200041'.  04612100
060400       10  FILLER                  PIC X(56) VALUE                04612200
060500     '01207404900068007527028000350219710720009901525804600059'.  04612300
060600       10  FILLER                  PIC X(56) VALUE                04612400
060700     '01361103500044057579126001530174840560007701378304700058'.  04612500
060800       10  FILLER                  PIC X(56) VALUE                04612600
060900     '00000000000000000000000000000000000000000002463206900114'.  04612700
061000       10  FILLER                  PIC X(56) VALUE                04612800
061100     '00000000000000000000000000000000000000000000608502400032'.  04612900
061200       10  FILLER                  PIC X(56) VALUE                04613000
061300     '00519803100042005685031000440089990460007400843104000054'.  04613100
061400       10  FILLER                  PIC X(56) VALUE                04613200
061500     '00778305500076006983040000590083410310004600000000000000'.  04613300
061600       10  FILLER                  PIC X(56) VALUE                04613400
061700     '00000000000000000000000000000000000000000000000000000000'.  04613500
061800       10  FILLER                  PIC X(56) VALUE                04613600
061900     '00000000000000003571021000300075570820010501041904800066'.  04613700
062000       10  FILLER                  PIC X(56) VALUE                04613800
062100     '00614503300041000000000000000000000000000000000000000000'.  04613900
062200       10  FILLER                  PIC X(56) VALUE                04614000
062300     '02853409300144018611057000790149660350004902524607200122'.  04614100
062400       10  FILLER                  PIC X(56) VALUE                04614200
062500     '01592603500047009803022000330310300810011702186505000069'.  04614300
062600       10  FILLER                  PIC X(56) VALUE                04614400
062700     '01411202700036000000000000000000000000000000000000000000'.  04614500
062800       10  FILLER                  PIC X(56) VALUE                04614600
062900     '01063104600062006890027000340086600330004700498601700021'.  04614700
063000       10  FILLER                  PIC X(56) VALUE                04614800
063100     '01171703700052006886021000270128300440006200979703200043'.  04614900
063200       10  FILLER                  PIC X(56) VALUE                04615000
063300     '00710102300029011338041000600070710240003300000000000000'.  04615100
063400       10  FILLER                  PIC X(56) VALUE                04615200
063500     '00000000000000000000000000001230422300028804395612100162'.  04615300
063600       10  FILLER                  PIC X(56) VALUE                04615400
063700     '02353305600077000000000000000000000000000000000000000000'.  04615500
063800       10  FILLER                  PIC X(56) VALUE                04615600
063900     '02662602700059013745047000680116050370005500000000000000'.  04615700
064000       10  FILLER                  PIC X(56) VALUE                04615800
064100     '00000000000000000000000000000216720750010901682304400064'.  04615900
064200       10  FILLER                  PIC X(56) VALUE                04616000
064300     '01353102300030000000000000000000000000000000000000000000'.  04616100
064400       10  FILLER                  PIC X(56) VALUE                04616200
064500     '01100508400103010143070000790087670380005000654202700034'.  04616300
064600       10  FILLER                  PIC X(56) VALUE                04616400
064700     '00732302500041005948024000340061090210003800000000000000'.  04616500
064800       10  FILLER                  PIC X(56) VALUE                04616600
064900     '00000000000000000000000000000510280850012203485407600095'.  04616700
065000       10  FILLER                  PIC X(56) VALUE                04616800
065100     '05796010500160044786079001050369880490006100000000000000'.  04616900
065200       10  FILLER                  PIC X(56) VALUE                04617000
065300     '00000000000000000000000000000229850630009301701505000063'.  04617100
065400       10  FILLER                  PIC X(56) VALUE                04617200
065500     '01410803300041000000000000000000000000000000000000000000'.  04617300
065600       10  FILLER                  PIC X(56) VALUE                04617400
065700     '05139513500187036849066000950000000000000000000000000000'.  04617500
065800       10  FILLER                  PIC X(56) VALUE                04617600
065900     '00000000000000021382074001040159180530007301335703800049'.  04617700
066000       10  FILLER                  PIC X(56) VALUE                04617800
066100     '01038703800053000000000000000000000000000000000000000000'.  04617900
066200       10  FILLER                  PIC X(56) VALUE                04618000
066300     '04516811900153035417078001000297370390005402721711700146'.  04618100
066400       10  FILLER                  PIC X(56) VALUE                04618200
066500     '02086507400097016706035000510285000990013202013405900080'.  04618300
066600       10  FILLER                  PIC X(56) VALUE                04618400
066700     '01631002900041000000000000000000000000000000000000000000'.  04618500
066800       10  FILLER                  PIC X(56) VALUE                04618600
066900     '00000000000000000000000000000000000000000000000000000000'.  04618700
067000       10  FILLER                  PIC X(56) VALUE                04618800
067100     '00000000000000000000000000000000000000000000000000000000'.  04618900
067200     05  DRGX-TAB REDEFINES D-TAB.                                04619000
067300         10  DRGX-PERIOD               OCCURS 1                   04619100
067400                                        INDEXED BY DX5.           04619200
067500             15  DRGX-EFF-DATE         PIC X(08).                 04619300
067600             15  DRG-DATA              OCCURS 1000                04619400
067700                                        INDEXED BY DX6.           04619500
067800                 20  DRG-WT            PIC 9(02)V9(04).           04619600
067900                 20  DRG-ALOS          PIC 9(02)V9(01).           04619700
068000                 20  DRG-DAYS-TRIM     PIC 9(02).                 04619800
068100                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).           04619900
068200                                                                  04620000
068300 01  HOLD-AREA.                                                   04630000
068400     02  HOLD-PPS-COMPONENTS.                                     04640000
068500         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).        04650000
068600         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).        04660000
068700                                                                  04670000
068800         05  H-OPER-HSP-PART              PIC 9(06)V9(09).        04680000
068900         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).        04690000
069000                                                                  04700000
069100         05  H-OPER-FSP-PART              PIC 9(06)V9(09).        04710000
069200         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).        04720000
069300         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).        04730000
069400                                                                  04740000
069500         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).        04750000
069600         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).        04760000
069700         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).        04770000
069800                                                                  04780000
069900         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).        04790000
070000         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).        04800000
070100                                                                  04810000
070200         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).        04820000
070300         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).        04830000
070400                                                                  04840000
070500         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).        04850000
070600         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).        04860000
070700                                                                  04870000
070800         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).        04880000
070900         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).        04890000
071000         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).        04900000
071100         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).        04910000
071200         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).        04920000
071300         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).        04930000
071400         05  H-CAPI-COLA                  PIC 9(01)V9(03).        04940000
071500         05  H-CAPI-SCH                   PIC 9(05)V9(02).        04950000
071600         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).        04960000
071700         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).        04970000
071800         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).        04980000
071900         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).        04990000
072000         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).        05000000
072100         05  H-CAPI-GAF                   PIC 9(05)V9(04).        05010000
072200         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).        05020000
072300         05  H-BLEND-GAF                  PIC 9(05)V9(04).        05030000
072400         05  H-WAGE-INDEX                 PIC 9(02)V9(04).        05040000
072500         05  H-COV-DAYS                   PIC 9(3).               05050000
072600         05  H-PERDIEM-DAYS               PIC 9(3).               05060000
072700         05  H-REG-DAYS                   PIC 9(3).               05070000
072800         05  H-LTR-DAYS                   PIC 9(3).               05080000
072900         05  H-DSCHG-FRCTN                PIC 9(3)V9999.          05090000
073000         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.          05100000
073100         05  H-ALOS                       PIC 9(02)V9(01).        05110000
073200         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).        05120000
073300         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).        05130000
073400         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).        05140000
073500         05  H-CST-THRESH                 PIC 9(05)V9(02).        05150000
073600         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).        05160000
073700         05  H-BUDG-NUTR01                PIC 9(01)V9(06).        05170000
073800         05  H-BUDG-NUTR02                PIC 9(01)V9(06).        05180000
073900         05  H-BUDG-NUTR03                PIC 9(01)V9(06).        05190000
074000         05  H-BUDG-NUTR04                PIC 9(01)V9(06).        05200000
074100         05  H-BUDG-NUTR05                PIC 9(01)V9(06).        05210000
074200         05  H-BUDG-NUTR06                PIC 9(01)V9(06).        05220000
074300         05  H-BUDG-NUTR07                PIC 9(01)V9(06).        05230000
074400         05  H-BUDG-NUTR08                PIC 9(01)V9(06).        05240000
074500         05  H-CASE-MIX-ADJ               PIC 9(01)V9(03).        05250000
074600         05  H-UPDATE-01                  PIC 9(01)V9(04).        05250000
074700         05  H-UPDATE-02                  PIC 9(01)V9(04).        05260000
074800         05  H-UPDATE-03                  PIC 9(01)V9(04).        05270000
074900         05  H-UPDATE-04                  PIC 9(01)V9(04).        05280000
075000         05  H-UPDATE-05                  PIC 9(01)V9(04).        05290000
075100         05  H-UPDATE-06                  PIC 9(01)V9(04).        05300000
075200         05  H-UPDATE-07                  PIC 9(01)V9(04).        05310000
075300         05  H-UPDATE-08                  PIC 9(01)V9(04).        05320000
075400         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).        05330000
075500         05  H-HSP-UPDATE94               PIC 9(01)V9(04).        05340000
075600         05  H-HSP-UPDATE95               PIC 9(01)V9(04).        05350000
075700         05  H-HSP-UPDATE96               PIC 9(01)V9(04).        05360000
075800         05  H-HSP-UPDATE97               PIC 9(01)V9(04).        05370000
075900         05  H-HSP-UPDATE98               PIC 9(01)V9(04).        05380000
076000         05  H-HSP-UPDATE99               PIC 9(01)V9(04).        05390000
076100         05  H-HSP-UPDATE00               PIC 9(01)V9(04).        05400000
076200         05  H-HSP-UPDATE01               PIC 9(01)V9(04).        05410000
076300         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).        05420000
076400         05  H-FEDERAL-RATE               PIC 9(04)V9(02).        05430000
076500         05  H-LABOR-PCT                  PIC 9(01)V9(04).        05440000
076600         05  H-NONLABOR-PCT               PIC 9(01)V9(04).        05450000
076700         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).        05460000
076800         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).        05470000
076900         05  H-HSP-RATE                   PIC 9(06)V9(09).        05480000
077000         05  H-FSP-RATE                   PIC 9(06)V9(09).        05490000
077100         05  H-OUTLIER-OFFSET-NAT         PIC 9(01)V9(06).        05500000
077200         05  H-OUTLIER-OFFSET-PR          PIC 9(01)V9(06).        05510000
077300         05  H-WK-OPER-DSH                PIC 9(01)V9(04).        05520000
077400         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).        05530000
077500         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).        05540000
077600         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).        05550000
077700         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).        05560000
077800         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.           05570000
077900         05  H-BASE-DRG-PAYMENT           PIC S9(07)V99.          05580000
078000         05  H-NEW-TECH-ADDON-NEURO       PIC S9(07)V99.          05590000
078100         05  H-NEW-TECH-ADDON-GRAFT       PIC S9(07)V99.          05600000
078200         05  H-NEW-TECH-ADDON-X-STOP      PIC S9(07)V99.          05610000
078300         05  H-NEW-TECH-ADDON-ISLET       PIC S9(07)V99.          05620000
078400         05  H-TECH-ADDON-ISLET-CNTR      PIC S9(02).             05630000
078500         05  H-TECH-ADDON-ISLET-CNTR2     PIC S9(02).             05631000
078600                                                                  05632000
078700         05  H-LESSER-NEURO-1             PIC S9(07)V99.          05633000
078800         05  H-LESSER-NEURO-2             PIC S9(07)V99.          05634000
078900                                                                  05635000
079000         05  H-LESSER-GRAFT-1             PIC S9(07)V99.          05636000
079100         05  H-LESSER-GRAFT-2             PIC S9(07)V99.          05637000
079200                                                                  05638000
079300         05  H-LESSER-X-STOP-1            PIC S9(07)V99.          05639000
079400         05  H-LESSER-X-STOP-2            PIC S9(07)V99.          05640000
079500                                                                  05650000
079600                                                                  05660000
079700         05  H-CSTMED-NEURO               PIC S9(07)V99.          05670000
079800         05  H-CSTMED-GRAFT               PIC S9(07)V99.          05680000
079900         05  H-CSTMED-X-STOP              PIC S9(07)V99.          05690000
080000                                                                  05700000
080100                                                                  05710000
080200     02  HOLD-ADDITIONAL-VARIABLES.                               05720000
080300         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).        05730000
080400         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).        05740000
080500         05  H-NAT-PCT                    PIC 9(01)V9(02).        05750000
080600         05  H-REG-PCT                    PIC 9(01)V9(02).        05760000
080700         05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).        05770000
080800         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).        05780000
080900         05  H-DRG-WT                     PIC 9(02)V9(04).        05790000
081000         05  H-NAT-LABOR                  PIC 9(05)V9(02).        05800000
081100         05  H-NAT-NONLABOR               PIC 9(05)V9(02).        05810000
081200         05  H-REG-LABOR                  PIC 9(05)V9(02).        05820000
081300         05  H-REG-NONLABOR               PIC 9(05)V9(02).        05830000
081400         05  H-OPER-COLA                  PIC 9(01)V9(03).        05840000
081500         05  H-INTERN-RATIO               PIC 9(01)V9(04).        05850000
081600         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).        05860000
081700         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).        05870000
081800         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).        05880000
081900                                                                  05890000
082000     02  HOLD-CAPITAL-VARIABLES.                                  05900000
082100         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).        05910000
082200         05  H-CAPI-HSP                   PIC 9(07)V9(02).        05920000
082300         05  H-CAPI-FSP                   PIC 9(07)V9(02).        05930000
082400         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).        05940000
082500         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).        05950000
082600         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).        05960000
082700         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).        05970000
082800         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).        05980000
082900                                                                  05990000
083000     02  HOLD-CAPITAL2-VARIABLES.                                 06000000
083100         05  H-CAPI2-PAY-CODE             PIC X(1).               06010000
083200         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).        06020000
083300         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).        06030000
083400                                                                  06040000
083500     02  HOLD-OTHER-VARIABLES.                                    06050000
083600         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).        06060000
083700         05  H-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).        06070000
083800         05  FILLER                       PIC X(21).              06080000
083900                                                                  06090000
084000     02  HOLD-PC-OTH-VARIABLES.                                   06100000
084100         05  H-OPER-DSH                   PIC 9(01)V9(04).        06110000
084200         05  H-CAPI-DSH                   PIC 9(01)V9(04).        06120000
084300         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).        06130000
084400         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).        06140000
084500         05  H-ARITH-ALOS                 PIC 9(02)V9(01).        06150000
084600         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).        06160000
084700         05  H-TRANSFER-ADJ               PIC 9(01)V9(05).        06170000
084800         05  H-PC-HMO-FLAG                PIC X(01).              06180000
084900         05  H-PC-COT-FLAG                PIC X(01).              06190000
085000         05  H-FILLER                     PIC X(09).              06200000
085100                                                                  06210000
085200 01  HLD-PPS-DATA.                                                06220000
085300         10  HLD-PPS-RTC                PIC 9(02).                06230000
085400         10  HLD-PPS-WAGE-INDX          PIC 9(02)V9(04).          06240000
085500         10  HLD-PPS-OUTLIER-DAYS       PIC 9(03).                06250000
085600         10  HLD-PPS-AVG-LOS            PIC 9(02)V9(01).          06260000
085700         10  HLD-PPS-DAYS-CUTOFF        PIC 9(02)V9(01).          06270000
085800         10  HLD-PPS-OPER-IME-ADJ       PIC 9(06)V9(02).          06280000
085900         10  HLD-PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).          06290000
086000         10  HLD-PPS-OPER-HSP-PART      PIC 9(06)V9(02).          06300000
086100         10  HLD-PPS-OPER-FSP-PART      PIC 9(06)V9(02).          06310000
086200         10  HLD-PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).          06320000
086300         10  HLD-PPS-REG-DAYS-USED      PIC 9(03).                06330000
086400         10  HLD-PPS-LTR-DAYS-USED      PIC 9(02).                06340000
086500         10  HLD-PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).          06350000
086600         10  HLD-PPS-CALC-VERS          PIC X(05).                06360000
086700                                                                  06370000
086800 LINKAGE SECTION.                                                 06380000
086900***************************************************************   06390000
087000*                 * * * * * * * * *                           *   06400000
087100*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *   06410000
087200*    IN HOW TO PAY THE BILL.                                  *   06420000
087300*                         *****                               *   06430000
087400*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *   06440000
087500*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *   06450000
087600*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *   06460000
087700*                 OUTLIER COMPUTATION.                        *   06470000
087800*                         *****                               *   06480000
087900*         REVIEW-CODE:                                        *   06490000
088000*            00 = PAY-WITH-OUTLIER.                           *   06500000
088100*                 WILL CALCULATE THE STANDARD PAYMENT.        *   06510000
088200*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *   06520000
088300*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *   06530000
088400*            03 = PAY-PERDIEM-DAYS.                           *   06540000
088500*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   06550000
088600*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *   06560000
088700*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   06570000
088800*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   06580000
088900*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   06590000
089000*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *   06600000
089100*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   06610000
089200*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *   06620000
089300*                 BILL EXCEED THE COST THRESHOLD.             *   06630000
089400*            06 = PAY-XFER-NO-COST                            *   06640000
089500*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   06650000
089600*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *   06660000
089700*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   06670000
089800*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *   06680000
089900*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   06690000
090000*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *   06700000
090100*                 CALCULATE ANY COST OUTLIER PORTION          *   06710000
090200*                 OF THE PAYMENT.                             *   06720000
090300*            07 = PAY-WITHOUT-COST.                           *   06730000
090400*                 WILL CALCULATE THE STANDARD PAYMENT         *   06740000
090500*                 WITHOUT COST PORTION.                       *   06750000
090600*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *   06760000
090700*                 50-50> 28  29  30  40  41  42  219              06770000
090800*                        220 221 477 478 479 480 481              06780000
090900*                        482 492 493 494 500 501 502              06790000
091000*                        515 516 517 956                          06800000
091100* =======================================================         06801000
091200* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S       06801000
091300* =======================================================         06801000
091400*                                                                 06801000
091500*                                                                 06801000
091600*     FULL PERDIEM >   3   4   25  26  27  28          31         06802000
091700*                      32  33              54  55  56  57         06803000
091800*                      64  65  66  70  71  72  85  86  87         06804000
091900*                      91  92  93  100 101 163 164 165 166        06805000
092000*                      167 168 175 176 177 178 179 186 187        06806000
092100*                      188 190 191 192 193 194 195 196 197        06807000
092200*                      198 205 206 207 216 217 218                06808000
092300*                          228 229 230 233 234 235 236 239        06809000
092400*                      240 241 242 243 244 255 256 257 264        06809100
092500*                      280 281 282 288 289 290 291 292 293        06809200
092600*                      299 300 301 314 315 316 326 327 328        06809300
092700*                      329 330 331 332 333 334 335 336 337        06809400
092800*                      356 357 358 371 372 373 374 375 376        06809500
092900*                      377 378 379 380 381 382 388 389 390        06809600
093000*                      405 406 407 414 415 416 441 442 443        06809700
093100*                      459 460 463 464 465 466 467 468 469        06809800
093200*                      470 474 475 476                            06809900
093300*                          483 484 488 489             495        06810000
093400*                      496 497             510 511 512            06810100
093500*                              533 534 535 536 539 540 541        06810200
093600*                      542 543 544 545 546 547 551 552 557        06810300
093700*                      558 559 560 561 562 563 573 574 575        06810400
093800*                      579 580 581 592 593 594 602 603 616        06810500
093900*                      617 618 622 623 624 628 629 630 637        06810600
094000*                      638 639 640 641 643 644 645 653 654        06810700
094100*                      655 659 660 661 682 683 684 689 690        06810800
094200*                      698 699 700 840 841 842 853 854 855        06810900
094300*                      856 857 858 862 863 867 868 869 870        06811000
094400*                      871 872 884 896 897 907 908 909 917        06811100
094500*                      918 945 946 947 948     981 982 983        06811200
094600*                      987 988 989                                06811300
094700*                                                                 06811400
094800*                               POST-ACUTE TRANSFERS          *   06811500
094900*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   06811600
095000*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*   06811700
095100*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   06811800
095200*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   06811900
095300*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   06812000
095400*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *   06813000
095500*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   06814000
095600*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *   06815000
095700*                 BILL EXCEED THE COST THRESHOLD.             *   06816000
095800*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *   06817000
095900*                 POST-ACUTE TRANSFERS                        *   06818000
096000*                 50-50> 28  29  30  40  41  42  219              06819000
096100*                        220 221 477 478 479 480 481              06820000
096200*                        482 492 493 494 500 501 502              06830000
096300*                        515 516 517 956                          06840000
096400*                                                                 06850000
096500* =======================================================         06801000
096600* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S       06801000
096700* =======================================================         06801000
096800*                                                                 06860000
096900*     FULL PERDIEM >     3   4   25  26  27              31       06870000
097000*                        32  33              54  55  56  57       06880000
097100*                        64  65  66  70  71  72  85  86  87       06890000
097200*                        91  92  93  100 101 163 164 165 166      06900000
097300*                        167 168 175 176 177 178 179 186 187      06910000
097400*                        188 190 191 192 193 194 195 196 197      06920000
097500*                        198 205 206 207 216 217 218              06930000
097600*                            228 229 230 233 234 235 236 239      06940000
097700*                        240 241 242 243 244 255 256 257 264      06950000
097800*                        280 281 282 288 289 290 291 292 293      06960000
097900*                        299 300 301 314 315 316 326 327 328      06970000
098000*                        329 330 331 332 333 334 335 336 337      06980000
098100*                        356 357 358 371 372 373 374 375 376      06990000
098200*                        377 378 379 380 381 382 388 389 390      07000000
098300*                        405 406 407 414 415 416 441 442 443      07010000
098400*                        459 460 463 464 465 466 467 468 469      07020000
098500*                        470 474 475 476                          07030000
098600*                            483 484 488 489             495      07040000
098700*                        496 497             510 511 512          07050000
098800*                                533 534 535 536 539 540 541      07060000
098900*                        542 543 544 545 546 547 551 552 557      07070000
099000*                        558 559 560 561 562 563 573 574 575      07080000
099100*                        579 580 581 592 593 594 602 603 616      07090000
099200*                        617 618 622 623 624 628 629 630 637      07100000
099300*                        638 639 640 641 643 644 645 653 654      07110000
099400*                        655 659 660 661 682 683 684 689 690      07120000
099500*                        698 699 700 840 841 842 853 854 855      07130000
099600*                        856 857 858 862 863 867 868 869 870      07140000
099700*                        871 872 884 896 897 907 908 909 917      07150000
099800*                        918 945 946 947 948     981 982 983      07160000
099900*                        987 988 989                              07170000
100000*                                                                 07180000
100100*                                                                 07190000
100200*                               POST-ACUTE TRANSFERS          *   07200000
100300*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   07210000
100400*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*   07220000
100500*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   07230000
100600*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   07240000
100700*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   07250000
100800*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *   07260000
100900*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   07270000
101000*                 PAYMENT.                                    *   07280000
101100***************************************************************   07290000
101200                                                                  07300000
101300**************************************************************    07310000
101400*      MILLINNIUM COMPATIBLE                                 *    07320000
101500*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *    07330000
101600*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *    07340000
101700*      IN THE NEW FORMAT                                     *    07350000
101800**************************************************************    07360000
101900 01  BILL-NEW-DATA.                                               07370000
102000         10  B-NPI10.                                             07380000
102100             15  B-NPI8             PIC X(08).                    07390000
102200             15  B-NPI-FILLER       PIC X(02).                    07400000
102300         10  B-PROVIDER-NO          PIC X(06).                    07410000
102400         10  B-REVIEW-CODE          PIC 9(02).                    07420000
102500             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.    07430000
102600             88  PAY-WITH-OUTLIER     VALUE 00 07.                07440000
102700             88  PAY-PERDIEM-DAYS     VALUE 03.                   07450000
102800             88  PAY-XFER-NO-COST     VALUE 06.                   07460000
102900             88  PAY-WITHOUT-COST     VALUE 07.                   07470000
103000             88  PAY-XFER-SPEC-DRG    VALUE 09 11.                07480000
103100             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.              07490000
103200         10  B-DRG                  PIC 9(03).                    07500000
103300             88  B-DRG-POSTACUTE-50-50                            07510000
103400                   VALUE 28  29  30  40  41  42  219              07520000
103500                         220 221 477 478 479 480 481              07530000
103600                         482 492 493 494 500 501 502              07540000
103700                         515 516 517 956.                         07550000
103800                                                                  07560000
103900* =======================================================         06801000
104000* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S         06801000
104100* =======================================================         06801000
104200*                                                                 06860000
104300             88  B-DRG-POSTACUTE-PERDIEM                          07570000
104400                   VALUE 3   4   25  26  27              31       07580000
104500                         32  33              54  55  56  57       07590000
104600                         64  65  66  70  71  72  85  86  87       07600000
104700                         91  92  93  100 101 163 164 165 166      07610000
104800                         167 168 175 176 177 178 179 186 187      07620000
104900                         188 190 191 192 193 194 195 196 197      07630000
105000                         198 205 206 207 216 217 218              07640000
105100                             228 229 230 233 234 235 236 239      07650000
105200                         240 241 242 243 244 255 256 257 264      07660000
105300                         280 281 282 288 289 290 291 292 293      07670000
105400                         299 300 301 314 315 316 326 327 328      07680000
105500                         329 330 331 332 333 334 335 336 337      07690000
105600                         356 357 358 371 372 373 374 375 376      07700000
105700                         377 378 379 380 381 382 388 389 390      07710000
105800                         405 406 407 414 415 416 441 442 443      07720000
105900                         459 460 463 464 465 466 467 468 469      07730000
106000                         470 474 475 476                          07740000
106100                             483 484 488 489             495      07750000
106200                         496 497             510 511 512          07760000
106300                                 533 534 535 536 539 540 541      07770000
106400                         542 543 544 545 546 547 551 552 557      07780000
106500                         558 559 560 561 562 563 573 574 575      07790000
106600                         579 580 581 592 593 594 602 603 616      07800000
106700                         617 618 622 623 624 628 629 630 637      07810000
106800                         638 639 640 641 643 644 645 653 654      07820000
106900                         655 659 660 661 682 683 684 689 690      07830000
107000                         698 699 700 840 841 842 853 854 855      07840000
107100                         856 857 858 862 863 867 868 869 870      07850000
107200                         871 872 884 896 897 907 908 909 917      07860000
107300                         918 945 946 947 948     981 982 983      07870000
107400                         987 988 989.                             07880000
107500                                                                  07890000
107600         10  B-LOS                  PIC 9(03).                    07900000
107700         10  B-COVERED-DAYS         PIC 9(03).                    07910000
107800         10  B-LTR-DAYS             PIC 9(02).                    07920000
107900         10  B-DISCHARGE-DATE.                                    07930000
108000             15  B-DISCHG-CC        PIC 9(02).                    07940000
108100             15  B-DISCHG-YY        PIC 9(02).                    07950000
108200             15  B-DISCHG-MM        PIC 9(02).                    07960000
108300             15  B-DISCHG-DD        PIC 9(02).                    07970000
108400         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).              07980000
108500         10  B-PRIN-PROC-CODE       PIC X(07).                    07990000
108600         10  B-OTHER-PROC-CODE1     PIC X(07).                    08000000
108700         10  B-OTHER-PROC-CODE2     PIC X(07).                    08010000
108800         10  B-OTHER-PROC-CODE3     PIC X(07).                    08020000
108900         10  B-OTHER-PROC-CODE4     PIC X(07).                    08030000
109000         10  B-OTHER-PROC-CODE5     PIC X(07).                    08040000
109100         10  B-OTHER-PROC-CODE6     PIC X(07).
109200         10  B-OTHER-PROC-CODE7     PIC X(07).
109300         10  B-OTHER-PROC-CODE8     PIC X(07).
109400         10  B-OTHER-PROC-CODE9     PIC X(07).
109500         10  B-OTHER-PROC-CODE10    PIC X(07).
109600         10  B-OTHER-PROC-CODE11    PIC X(07).
109700         10  B-OTHER-PROC-CODE12    PIC X(07).
109800         10  B-OTHER-PROC-CODE13    PIC X(07).
109900         10  B-OTHER-PROC-CODE14    PIC X(07).
110000         10  B-OTHER-PROC-CODE15    PIC X(07).
110100         10  B-OTHER-PROC-CODE16    PIC X(07).
110200         10  B-OTHER-PROC-CODE17    PIC X(07).
110300         10  B-OTHER-PROC-CODE18    PIC X(07).
110400         10  B-OTHER-PROC-CODE19    PIC X(07).
110500         10  B-OTHER-PROC-CODE20    PIC X(07).
110600         10  B-OTHER-PROC-CODE21    PIC X(07).
110700         10  B-OTHER-PROC-CODE22    PIC X(07).
110800         10  B-OTHER-PROC-CODE23    PIC X(07).
110900         10  B-OTHER-PROC-CODE24    PIC X(07).
111000         10  B-OTHER-DIAG-CODE1     PIC X(07).                    06012000
111100         10  B-OTHER-DIAG-CODE2     PIC X(07).                    06013000
111200         10  B-OTHER-DIAG-CODE3     PIC X(07).                    06014000
111300         10  B-OTHER-DIAG-CODE4     PIC X(07).                    06015000
111400         10  B-OTHER-DIAG-CODE5     PIC X(07).                    06016000
111500         10  B-OTHER-DIAG-CODE6     PIC X(07).                    06017000
111600         10  B-OTHER-DIAG-CODE7     PIC X(07).                    06018000
111700         10  B-OTHER-DIAG-CODE8     PIC X(07).                    06019000
111800         10  B-OTHER-DIAG-CODE9     PIC X(07).                    06019100
111900         10  B-OTHER-DIAG-CODE10    PIC X(07).                    06019200
112000         10  B-OTHER-DIAG-CODE11    PIC X(07).                    06019300
112100         10  B-OTHER-DIAG-CODE12    PIC X(07).                    06019400
112200         10  B-OTHER-DIAG-CODE13    PIC X(07).                    06019500
112300         10  B-OTHER-DIAG-CODE14    PIC X(07).                    06019600
112400         10  B-OTHER-DIAG-CODE15    PIC X(07).                    06019700
112500         10  B-OTHER-DIAG-CODE16    PIC X(07).                    06019800
112600         10  B-OTHER-DIAG-CODE17    PIC X(07).                    06019900
112700         10  B-OTHER-DIAG-CODE18    PIC X(07).                    06020000
112800         10  B-OTHER-DIAG-CODE19    PIC X(07).                    06020100
112900         10  B-OTHER-DIAG-CODE20    PIC X(07).                    06020200
113000         10  B-OTHER-DIAG-CODE21    PIC X(07).                    06020300
113100         10  B-OTHER-DIAG-CODE22    PIC X(07).                    06020400
113200         10  B-OTHER-DIAG-CODE23    PIC X(07).                    06020500
113300         10  B-OTHER-DIAG-CODE24    PIC X(07).                    06020600
113400         10  B-OTHER-DIAG-CODE25    PIC X(07).                    06020700
113500         10  BILL-DEMO-DATA.
113600             15  BILL-DEMO-CODE1        PIC X(02).
113700             15  BILL-DEMO-CODE2        PIC X(02).
113800             15  BILL-DEMO-CODE3        PIC X(02).
113900             15  BILL-DEMO-CODE4        PIC X(02).
114000         10  BILL-NDC-DATA.
114100             15  BILL-NDC-NUMBER        PIC X(11).
114200         10  FILLER                     PIC X(73).
114300                                                                  06020800
114400                                                                  06020800
114500                                                                  08050000
114600***************************************************************   08060000
114700*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *   08070000
114800*    AND PASSED BACK TO THE CALLING PROGRAM                   *   08080000
114900*            RETURN CODE VALUES (PPS-RTC)                     *   08090000
115000*                                                             *   08100000
115100*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   08110000
115200*                                                             *   08120000
115300*      PPS-RTC 30,33,40,42,44  = OUTLIER RECONCILIATION       *   08130000
115400*                                                             *   08140000
115500*           30,00 = PAID NORMAL DRG PAYMENT                   *   08150000
115600*                                                             *   08160000
115700*              01 = PAID AS A DAY-OUTLIER.                    *   08170000
115800*                   NOTE:                                     *   08180000
115900*                     DAY-OUTLIER NO LONGER BEING PAID        *   08190000
116000*                         AS OF 10/01/97                      *   08200000
116100*                                                             *   08210000
116200*              02 = PAID AS A COST-OUTLIER.                   *   08220000
116300*                                                             *   08230000
116400*           33,03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   08240000
116500*                   AND INCLUDING THE FULL DRG.               *   08250000
116600*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   08260000
116700*                   AND INCLUDING THE FULL DRG WHICH ALSO     *   08270000
116800*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *   08280000
116900*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   08290000
117000*                   AND INCLUDING THE FULL DRG. PROVIDER      *   08300000
117100*                   REFUSED COST OUTLIER.                     *   08310000
117200*           40,10 = POST-ACUTE TRANSFER                       *   08320000
117300*                   DRG = 28  29  30  40  41  42  219             08330000
117400*                         220 221 477 478 479 480 481             08340000
117500*                         482 492 493 494 500 501 502             08350000
117600*                         515 516 517 956                         08360000
117700*                                                                 08370000
117800* =======================================================         06801000
117900* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S         06801000
118000* =======================================================         06801000
118100*                                                                 06860000
118200*           42,12 = POST-ACAUTE TRANSFER WITH SPECIFIC DRGS   *   08380000
118300*                       THE FOLLOWING DRG'S                   *   08390000
118400*                   DRG = 3   4   25  26  27              31      08400000
118500*                         32  33              54  55  56  57      08410000
118600*                         64  65  66  70  71  72  85  86  87      08420000
118700*                         91  92  93  100 101 163 164 165 166     08430000
118800*                         167 168 175 176 177 178 179 186 187     08440000
118900*                         188 190 191 192 193 194 195 196 197     08450000
119000*                         198 205 206 207 216 217 218             08460000
119100*                             228 229 230 233 234 235 236 239     08470000
119200*                         240 241 242 243 244 255 256 257 264     08480000
119300*                         280 281 282 288 289 290 291 292 293     08490000
119400*                         299 300 301 314 315 316 326 327 328     08500000
119500*                         329 330 331 332 333 334 335 336 337     08510000
119600*                         356 357 358 371 372 373 374 375 376     08520000
119700*                         377 378 379 380 381 382 388 389 390     08530000
119800*                         405 406 407 414 415 416 441 442 443     08540000
119900*                         459 460 463 464 465 466 467 468 469     08550000
120000*                         470 474 475 476                         08560000
120100*                             483 484 488 489             495     08570000
120200*                         496 497             510 511 512         08580000
120300*                                 533 534 535 536 539 540 541     08590000
120400*                         542 543 544 545 546 547 551 552 557     08600000
120500*                         558 559 560 561 562 563 573 574 575     08610000
120600*                         579 580 581 592 593 594 602 603 616     08620000
120700*                         617 618 622 623 624 628 629 630 637     08630000
120800*                         638 639 640 641 643 644 645 653 654     08640000
120900*                         655 659 660 661 682 683 684 689 690     08650000
121000*                         698 699 700 840 841 842 853 854 855     08660000
121100*                         856 857 858 862 863 867 868 869 870     08670000
121200*                         871 872 884 896 897 907 908 909 917     08680000
121300*                         918 945 946 947 948     981 982 983     08690000
121400*                         987 988 989                             08700000
121500*                                                                 08710000
121600*           44,14 = PAID NORMAL DRG PAYMENT WITH              *   08720000
121700*                    PERDIEM DAYS = OR > GM  ALOS             *   08730000
121800*              16 = PAID AS A COST-OUTLIER WITH               *   08740000
121900*                    PERDIEM DAYS = OR > GM  ALOS             *   08750000
122000*                                                             *   08760000
122100*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   08770000
122200*              51 = NO PROVIDER SPECIFIC INFO FOUND           *   08780000
122300*              52 = INVALID CBSA# IN PROVIDER FILE            *   08790000
122400*                   OR INVALID WAGE INDEX                     *   08800000
122500*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   08810000
122600*              54 = INVALID DRG                               *   08820000
122700*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   08830000
122800*                                      OR                     *   08840000
122900*                   DISCHARGE DATE < CBSA EFF START DATE      *   08850000
123000*                   FOR PPS                                   *   08860000
123100*                                      OR                     *   08870000
123200*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *   08880000
123300*                   DISCHARGE DATE                            *   08890000
123400*              56 = INVALID LENGTH OF STAY                    *   08900000
123500*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *   08910000
123600*                                        NOT 11)              *   08920000
123700*              58 = TOTAL CHARGES NOT NUMERIC                 *   08930000
123800*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   08940000
123900*                   OR BILL-LTR-DAYS > 60                     *   08950000
124000*              62 = INVALID NUMBER OF COVERED DAYS            *   08960000
124100*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *   08970000
124200*                   SPECIFIC FILE FOR CAPITAL                 *   08980000
124300*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   08990000
124400*                   OR COST OUTLIER THRESHOLD CALUCULATION    *   09000000
124500*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *   09010000
124600***************************************************************   09020000
124700 01  PPS-DATA.                                                    09030000
124800         10  PPS-RTC                PIC 9(02).                    09040000
124900         10  PPS-WAGE-INDX          PIC 9(02)V9(04).              09050000
125000         10  PPS-OUTLIER-DAYS       PIC 9(03).                    09060000
125100         10  PPS-AVG-LOS            PIC 9(02)V9(01).              09070000
125200         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).              09080000
125300         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).              09090000
125400         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).              09100000
125500         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).              09110000
125600         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).              09120000
125700         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).              09130000
125800         10  PPS-REG-DAYS-USED      PIC 9(03).                    09140000
125900         10  PPS-LTR-DAYS-USED      PIC 9(02).                    09150000
126000         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).              09160000
126100         10  PPS-CALC-VERS          PIC X(05).                    09170000
126200                                                                  09180000
126300******************************************************************09190000
126400*            THESE ARE THE VERSIONS OF THE PPCAL                  09200000
126500*           PROGRAMS THAT WILL BE PASSED BACK----                 09210000
126600*          ASSOCIATED WITH THE BILL BEING PROCESSED               09220000
126700******************************************************************09230000
126800 01  PRICER-OPT-VERS-SW.                                          09240000
126900     02  PRICER-OPTION-SW          PIC X(01).                     09250000
127000         88  ALL-TABLES-PASSED          VALUE 'A'.                09260000
127100         88  PROV-RECORD-PASSED         VALUE 'P'.                09270000
127200         88  ADDITIONAL-VARIABLES       VALUE 'M'.                09280000
127300         88  PC-PRICER                  VALUE 'C'.                09290000
127400     02  PPS-VERSIONS.                                            09300000
127500         10  PPDRV-VERSION         PIC X(05).                     09310000
127600                                                                  09320000
127700******************************************************************09330000
127800*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK           09340000
127900*          ASSOCIATED WITH THE BILL BEING PROCESSED               09350000
128000******************************************************************09360000
128100 01  PPS-ADDITIONAL-VARIABLES.                                    09370000
128200     05  PPS-HSP-PCT                PIC 9(01)V9(02).              09380000
128300     05  PPS-FSP-PCT                PIC 9(01)V9(02).              09390000
128400     05  PPS-NAT-PCT                PIC 9(01)V9(02).              09400000
128500     05  PPS-REG-PCT                PIC 9(01)V9(02).              09410000
128600     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).              09420000
128700     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).              09430000
128800     05  PPS-DRG-WT                 PIC 9(02)V9(04).              09440000
128900     05  PPS-NAT-LABOR              PIC 9(05)V9(02).              09450000
129000     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).              09460000
129100     05  PPS-REG-LABOR              PIC 9(05)V9(02).              09470000
129200     05  PPS-REG-NLABOR             PIC 9(05)V9(02).              09480000
129300     05  PPS-OPER-COLA              PIC 9(01)V9(03).              09490000
129400     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).              09500000
129500     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).              09510000
129600     05  PPS-BILL-COSTS             PIC 9(07)V9(09).              09520000
129700     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).              09530000
129800     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.                09540000
129900     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.                09550000
130000     05  PPS-CAPITAL-VARIABLES.                                   09560000
130100         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).        09570000
130200         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).        09580000
130300         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).        09590000
130400         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).        09600000
130500         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).        09610000
130600         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).        09620000
130700         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).        09630000
130800         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).        09640000
130900     05  PPS-CAPITAL2-VARIABLES.                                  09650000
131000         10  PPS-CAPI2-PAY-CODE             PIC X(1).             09660000
131100         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).      09670000
131200         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).      09680000
131300                                                                  09690000
131400     05  PPS-OTHER-VARIABLES.                                     09700000
131500         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).      09710000
131600         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).      09720000
131700         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
131800         10  PPS-HVBP-HRR-DATA.
131900             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.
132000             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
132100             15  PPS-HOSP-READMISS-REDUCTN    PIC X.
132200             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
132300         10  PPS-OPERATNG-DATA.
132400             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
132500             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
132600             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
132700                                                                  09740000
132800     05  PPS-PC-OTH-VARIABLES.                                    09750000
132900         10  PPS-OPER-DSH                   PIC 9(01)V9(04).      09760000
133000         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).      09770000
133100         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).      09780000
133200         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).      09790000
133300         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).      09800000
133400         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).      09810000
133500         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(05).      09820000
133600         10  PPS-PC-HMO-FLAG                PIC X(01).            09830000
133700         10  PPS-PC-COT-FLAG                PIC X(01).            09840000
133800         10  PPS-FILLER                     PIC X(0998).
133900                                                                  09860000
134000 01  PROV-NEW-HOLD.                                               09870000
134100     02  PROV-NEWREC-HOLD1.                                       09880000
134200         05  P-NEW-NPI10.                                         09890000
134300             10  P-NEW-NPI8             PIC X(08).                09900000
134400             10  P-NEW-NPI-FILLER       PIC X(02).                09910000
134500         05  P-NEW-PROVIDER-NO.                                   09920000
134600             88  P-NEW-DSH-ADJ-PROVIDERS                          09930000
134700                             VALUE '180049' '190044' '190144'     09940000
134800                                   '190191' '330047' '340085'     09950000
134900                                   '370016' '370149' '420043'.    09960000
135000             10  P-NEW-STATE            PIC 9(02).                09970000
135100             10  FILLER                 PIC X(04).                09980000
135200         05  P-NEW-DATE-DATA.                                     09990000
135300             10  P-NEW-EFF-DATE.                                  10000000
135400                 15  P-NEW-EFF-DT-CC    PIC 9(02).                10010000
135500                 15  P-NEW-EFF-DT-YY    PIC 9(02).                10020000
135600                 15  P-NEW-EFF-DT-MM    PIC 9(02).                10030000
135700                 15  P-NEW-EFF-DT-DD    PIC 9(02).                10040000
135800             10  P-NEW-FY-BEGIN-DATE.                             10050000
135900                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                10060000
136000                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                10070000
136100                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                10080000
136200                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                10090000
136300             10  P-NEW-REPORT-DATE.                               10100000
136400                 15  P-NEW-REPORT-DT-CC PIC 9(02).                10110000
136500                 15  P-NEW-REPORT-DT-YY PIC 9(02).                10120000
136600                 15  P-NEW-REPORT-DT-MM PIC 9(02).                10130000
136700                 15  P-NEW-REPORT-DT-DD PIC 9(02).                10140000
136800             10  P-NEW-TERMINATION-DATE.                          10150000
136900                 15  P-NEW-TERM-DT-CC   PIC 9(02).                10160000
137000                 15  P-NEW-TERM-DT-YY   PIC 9(02).                10170000
137100                 15  P-NEW-TERM-DT-MM   PIC 9(02).                10180000
137200                 15  P-NEW-TERM-DT-DD   PIC 9(02).                10190000
137300         05  P-NEW-WAIVER-CODE          PIC X(01).                10200000
137400             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              10210000
137500         05  P-NEW-INTER-NO             PIC 9(05).                10220000
137600         05  P-NEW-PROVIDER-TYPE        PIC X(02).                10230000
137700             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.      10240000
137800             88  P-N-REFERRAL-CENTER        VALUE '07' '11'       10250000
137900                                                  '15' '17'       10260000
138000                                                  '22'.           10270000
138100             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.           10280000
138200             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.           10290000
138300             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.           10300000
138400             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.           10310000
138500             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.      10320000
138600             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.           10330000
138700             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.      10340000
138800             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.           10350000
138900             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.           10360000
139000             88  P-N-EACH                   VALUE '21' '22'.      10370000
139100             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.           10380000
139200             88  P-N-NHCMQ-II-SNF           VALUE '32'.           10390000
139300             88  P-N-NHCMQ-III-SNF          VALUE '33'.           10400000
139400         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                10410000
139500             88  P-N-NEW-ENGLAND            VALUE  1.             10420000
139600             88  P-N-MIDDLE-ATLANTIC        VALUE  2.             10430000
139700             88  P-N-SOUTH-ATLANTIC         VALUE  3.             10440000
139800             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.             10450000
139900             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.             10460000
140000             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.             10470000
140100             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.             10480000
140200             88  P-N-MOUNTAIN               VALUE  8.             10490000
140300             88  P-N-PACIFIC                VALUE  9.             10500000
140400         05  P-NEW-CURRENT-DIV   REDEFINES                        10510000
140500                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         10520000
140600             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.          10530000
140700         05  P-NEW-MSA-DATA.                                      10540000
140800             10  P-NEW-CHG-CODE-INDEX       PIC X.                10550000
140900             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 10560000
141000             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   10570000
141100                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       10580000
141200             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 10590000
141300             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 10600000
141400             10  P-NEW-STAND-AMT-LOC-MSA9                         10610000
141500       REDEFINES P-NEW-STAND-AMT-LOC-MSA.                         10620000
141600                 15  P-NEW-RURAL-1ST.                             10630000
141700                     20  P-NEW-STAND-RURAL  PIC XX.               10640000
141800                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    10650000
141900                 15  P-NEW-RURAL-2ND        PIC XX.               10660000
142000         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    10670000
142100                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           10680000
142200                 88  P-NEW-SCH-YR82       VALUE   '82'.           10690000
142300                 88  P-NEW-SCH-YR87       VALUE   '87'.           10700000
142400         05  P-NEW-LUGAR                    PIC X.                10710000
142500         05  P-NEW-TEMP-RELIEF-IND          PIC X.                10720000
142600         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                10730000
142700         05  FILLER                         PIC X(05).            10740000
142800     02  PROV-NEWREC-HOLD2.                                       10750000
142900         05  P-NEW-VARIABLES.                                     10760000
143000             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        10770000
143100             10  P-NEW-COLA              PIC  9(01)V9(03).        10780000
143200             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        10790000
143300             10  P-NEW-BED-SIZE          PIC  9(05).              10800000
143400             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        10810000
143500             10  P-NEW-CMI               PIC  9(01)V9(04).        10820000
143600             10  P-NEW-SSI-RATIO         PIC  V9(04).             10830000
143700             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             10840000
143800             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              10850000
143900             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        10860000
144000             10  P-NEW-DSH-PERCENT       PIC  V9(04).             10870000
144100             10  P-NEW-FYE-DATE          PIC  X(08).              10880000
144200         05  P-NEW-CBSA-DATA.                                     10890000
144300             10  FILLER                    PIC X.                 10900000
144400             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 10910000
144500             10  FILLER                    PIC X(21).             10920000
144600     02  PROV-NEWREC-HOLD3.                                       10930000
144700         05  P-NEW-PASS-AMT-DATA.                                 10940000
144800             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          10950000
144900             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          10960000
145000             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          10970000
145100             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          10980000
145200         05  P-NEW-CAPI-DATA.                                     10990000
145300             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 11000000
145400             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          11010000
145500             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          11020000
145600             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        11030000
145700             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             11040000
145800             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 11050000
145900             15  P-NEW-CAPI-IME            PIC 9V9999.            11060000
146000             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          11070000
146100         05  P-HVBP-HRR-DATA.                                     08690000
146200             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.                08690100
146300             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).          08690200
146400             15  P-HOSP-READMISSION-REDUCTN PIC X.                08690300
146500             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).           08690400
146600         05  P-MODEL1-BUNDLE-DATA.                                      08
146700             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.                   08
146800             15  P-HAC-REDUC-IND            PIC X.
146900             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
147000             15  P-EHR-REDUC-IND            PIC X.
147100         05  FILLER                         PIC X(09).
147200
147300************************************************************      08694001
147400******************************************************************11090000
147500 01  WAGE-NEW-CBSA-INDEX-RECORD.                                  11100000
147600     05  W-CBSA                        PIC X(5).                  11110000
147700     05  W-CBSA-SIZE                   PIC X.                     11120000
147800         88  LARGE-URBAN       VALUE 'L'.                         11130000
147900         88  OTHER-URBAN       VALUE 'O'.                         11140000
148000         88  ALL-RURAL         VALUE 'R'.                         11150000
148100     05  W-CBSA-EFF-DATE               PIC X(8).                  11160000
148200     05  FILLER                        PIC X.                     11170000
148300     05  W-CBSA-INDEX-RECORD           PIC S9(02)V9(04).          11180000
148400     05  W-CBSA-PR-INDEX-RECORD        PIC S9(02)V9(04).          11190000
148500                                                                  11200000
148600                                                                  11210000
148700 PROCEDURE DIVISION  USING BILL-NEW-DATA                          11220000
148800                           PPS-DATA                               11230000
148900                           PRICER-OPT-VERS-SW                     11240000
149000                           PPS-ADDITIONAL-VARIABLES               11250000
149100                           PROV-NEW-HOLD                          11260000
149200                           WAGE-NEW-CBSA-INDEX-RECORD.            11270000
149300                                                                  11280000
149400***************************************************************   11290000
149500*    PROCESSING:                                              *   11300000
149600*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE            11310000
149700*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *   11320000
149800*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *   11330000
149900*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *   11340000
150000*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   11350000
150100*           GOBACK.                                           *   11360000
150200*        D. ASSEMBLE PRICING COMPONENTS.                      *   11370000
150300*        E. CALCULATE THE PRICE.                              *   11380000
150400***************************************************************   11390000
150500                                                                  11400000
150600     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.                      11410000
150700     MOVE 'N' TO TEMP-RELIEF-FLAG.                                11420000
150800     MOVE 'N' TO OUTLIER-RECON-FLAG.                              11430000
150900                                                                  11440000
151000     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.                11450000
151100                                                                  11460000
151200     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES. 11470000
151300     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.          11480000
151400     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.         11490000
151500     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.    11500000
151600     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.   11510000
151700     MOVE CAL-VERSION               TO  PPS-CALC-VERS.            11520000
151800     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.      11530000
151900     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.     11540000
152000                                                                  11550000
152100     IF (PPS-RTC = '00' OR '03' OR '10' OR                        11560000
152200                   '12' OR '14')                                  11570000
152300        MOVE 'Y' TO OUTLIER-RECON-FLAG                            11580000
152400        MOVE PPS-DATA TO HLD-PPS-DATA                             11590000
152500        PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT              11600000
152600        MOVE HLD-PPS-DATA TO PPS-DATA.                            11610000
152700                                                                  11620000
152800     GOBACK.                                                      11630000
152900                                                                  11640000
153000 0200-MAINLINE-CONTROL.                                           11650000
153100                                                                  11660000
153200     MOVE 'N' TO HMO-TAG.                                         11670000
153300                                                                  11680000
153400     IF PPS-PC-HMO-FLAG = 'Y' OR                                  11690000
153500               HMO-FLAG = 'Y'                                     11700000
153600        MOVE 'Y' TO HMO-TAG.                                      11710000
153700                                                                  11720000
153800     IF P-NEW-STATE NOT = 40                                      11730000
153900        MOVE ZEROES TO W-CBSA-PR-INDEX-RECORD.                    11740000
154000                                                                  11750000
154100     MOVE ALL '0' TO PPS-DATA                                     11760000
154200                     H-OPER-DSH-SCH                               11770000
154300                     H-OPER-DSH-RRC                               11780000
154400                     HOLD-PPS-COMPONENTS                          11790000
154500                     HOLD-PPS-COMPONENTS                          11800000
154600                     HOLD-ADDITIONAL-VARIABLES                    11810000
154700                     HOLD-CAPITAL-VARIABLES                       11820000
154800                     HOLD-CAPITAL2-VARIABLES                      11830000
154900                     HOLD-OTHER-VARIABLES                         11840000
155000                     HOLD-PC-OTH-VARIABLES.                       11850000
155100                                                                  11860000
155200     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC                     11870000
155300        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.                      11880000
155400                                                                  11890000
155500     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC                     11900000
155600        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.                       11910000
155700                                                                  11920000
155800     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC                     11930000
155900        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.                      11940000
156000                                                                  11950000
156100     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC                       11960000
156200        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.                        11970000
156300                                                                  11980000
156400                                                                  11990000
156500     PERFORM 1000-EDIT-THE-BILL-INFO.                             12000000
156600                                                                  12010000
156700     IF  PPS-RTC = 00                                             12020000
156800         PERFORM 2000-ASSEMBLE-PPS-VARIABLES                      12030000
156900         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.                12040000
157000                                                                  12050000
157100     IF OUTLIER-RECON-FLAG = 'Y'                                  12060000
157200        MOVE 'N' TO OUTLIER-RECON-FLAG                            12070000
157300        GO TO 0200-EXIT.                                          12080000
157400                                                                  12090000
157500     IF PPS-RTC = 00                                              12100000
157600        IF H-PERDIEM-DAYS = H-ALOS OR                             12110000
157700           H-PERDIEM-DAYS > H-ALOS                                12120000
157800           MOVE 14 TO PPS-RTC.                                    12130000
157900                                                                  12140000
158000     IF PPS-RTC = 02                                              12150000
158100        IF H-PERDIEM-DAYS = H-ALOS OR                             12160000
158200           H-PERDIEM-DAYS > H-ALOS                                12170000
158300           MOVE 16 TO PPS-RTC.                                    12180000
158400                                                                  12190000
158500 0200-EXIT.   EXIT.                                               12200000
158600                                                                  12210000
158700 1000-EDIT-THE-BILL-INFO.                                         12220000
158800                                                                  12230000
158900     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.                             12240000
159000     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.                             12250000
159100                                                                  12260000
159200     IF  PPS-RTC = 00                                             12270000
159300         IF  P-NEW-WAIVER-STATE                                   12280000
159400             MOVE 53 TO PPS-RTC.                                  12290000
159500                                                                  12300000
159600     IF  PPS-RTC = 00                                             12310000
159700         IF  B-DRG < 001                                                00
159800               OR = 014 OR = 015 OR = 016 OR = 017                12330000
159900               OR = 018 OR = 019 OR = 043 OR = 044                12340000
160000               OR = 045 OR = 046 OR = 047 OR = 048                12350000
160100               OR = 049 OR = 050 OR = 051 OR = 104                12360000
160200               OR = 105 OR = 106 OR = 107 OR = 108                12370000
160300               OR = 109 OR = 110 OR = 111 OR = 112                12380000
160400               OR = 118 OR = 119 OR = 120 OR = 126                12390000
160500               OR = 127 OR = 128 OR = 140 OR = 141                12400000
160600               OR = 142 OR = 143 OR = 144 OR = 145                12410000
160700               OR = 160 OR = 161 OR = 162 OR = 169                12420000
160800               OR = 170 OR = 171 OR = 172 OR = 173                12430000
160900               OR = 174 OR = 209 OR = 210 OR = 211                12440000
161000               OR = 212 OR = 213 OR = 214 OR = 265                12450000
161100               OR = 266 OR = 267 OR = 268 OR = 269                12460000
161200               OR = 270 OR = 271 OR = 272 OR = 273                12470000
161300               OR = 274 OR = 275 OR = 276 OR = 277                12480000
161400               OR = 278 OR = 279 OR = 317 OR = 318                12490000
161500               OR = 319 OR = 320 OR = 321 OR = 322                12500000
161600               OR = 323 OR = 324 OR = 325 OR = 359                12510000
161700               OR = 360 OR = 361 OR = 362 OR = 363                12520000
161800               OR = 364 OR = 365 OR = 366 OR = 367                12530000
161900               OR = 396 OR = 397 OR = 398 OR = 399                12540000
162000               OR = 400 OR = 401 OR = 402 OR = 403                12550000
162100               OR = 404 OR = 426 OR = 427 OR = 428                12560000
162200               OR = 429 OR = 430 OR = 431 OR = 447                12570000
162300               OR = 448 OR = 449 OR = 450 OR = 451                12580000
162400               OR = 452 OR = 518 OR = 519 OR = 520                12590000
162500               OR = 521 OR = 522 OR = 523 OR = 524                12600000
162600               OR = 525 OR = 526 OR = 527 OR = 528                12610000
162700               OR = 529 OR = 530 OR = 531 OR = 532                12620000
162800               OR = 567 OR = 568 OR = 569 OR = 570                12630000
162900               OR = 571 OR = 572 OR = 586 OR = 587                12640000
163000               OR = 588 OR = 589 OR = 590 OR = 591                12650000
163100               OR = 608 OR = 609 OR = 610 OR = 611                12660000
163200               OR = 612 OR = 613 OR = 631 OR = 632                12670000
163300               OR = 633 OR = 634 OR = 635 OR = 636                12680000
163400               OR = 646 OR = 647 OR = 648 OR = 649                12690000
163500               OR = 650 OR = 651 OR = 676 OR = 677                12700000
163600               OR = 678 OR = 679 OR = 680 OR = 681                12710000
163700               OR = 701 OR = 702 OR = 703 OR = 704                12720000
163800               OR = 705 OR = 706 OR = 719 OR = 720                12730000
163900               OR = 721 OR = 731 OR = 732 OR = 733                12740000
164000               OR = 751 OR = 752 OR = 753 OR = 762                12750000
164100               OR = 763 OR = 764 OR = 771 OR = 772                12760000
164200               OR = 773 OR = 783 OR = 784 OR = 785                12770000
164300               OR = 786 OR = 787 OR = 788 OR = 796                12780000
164400               OR = 797 OR = 798 OR = 805 OR = 806                12790000
164500               OR = 807 OR = 817 OR = 818 OR = 819                12800000
164600               OR = 831 OR = 832 OR = 833 OR = 850                12810000
164700               OR = 851 OR = 852 OR = 859 OR = 860                12820000
164800               OR = 861 OR = 873 OR = 874 OR = 875                12830000
164900               OR = 877 OR = 878 OR = 879 OR = 891                12840000
165000               OR = 891 OR = 892 OR = 892 OR = 893                12850000
165100               OR = 893 OR = 898 OR = 899 OR = 900                12860000
165200               OR = 910 OR = 911 OR = 912 OR = 924                12870000
165300               OR = 925 OR = 926 OR = 930 OR = 931                12880000
165400               OR = 932 OR = 936 OR = 937 OR = 938                12890000
165500               OR = 942 OR = 943 OR = 944 OR = 952                12900000
165600               OR = 953 OR = 954 OR = 960 OR = 961                12910000
165700               OR = 962 OR = 966 OR = 967 OR = 968                12920000
165800               OR = 971 OR = 972 OR = 973 OR = 978                12930000
165900               OR = 979 OR = 980 OR = 990 OR = 991                12940000
166000               OR = 992 OR = 993 OR = 994 OR = 995                12950000
166100               OR = 996 OR = 997                                  12960000
166200             MOVE 54 TO PPS-RTC.                                  12970000
166300                                                                  12980000
166400     IF  PPS-RTC = 00                                             12990000
166500            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR           13000000
166600                 (B-DISCHARGE-DATE < W-CBSA-EFF-DATE))            13010000
166700                MOVE 55 TO PPS-RTC.                               13020000
166800                                                                  13030000
166900     IF  PPS-RTC = 00                                             13040000
167000         IF P-NEW-TERMINATION-DATE > 00000000                     13050000
167100            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR   13060000
167200                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))     13070000
167300                  MOVE 55 TO PPS-RTC.                             13080000
167400                                                                  13090000
167500     IF  PPS-RTC = 00                                             13100000
167600         IF  B-LOS NOT NUMERIC                                    13110000
167700             MOVE 56 TO PPS-RTC                                   13120000
167800         ELSE                                                     13130000
167900         IF  B-LOS = 0                                            13140000
168000             IF B-REVIEW-CODE NOT = 00 AND                        13150000
168100                              NOT = 03 AND                        13160000
168200                              NOT = 06 AND                        13170000
168300                              NOT = 07 AND                        13180000
168400                              NOT = 09 AND                        13190000
168500                              NOT = 11                            13200000
168600             MOVE 56 TO PPS-RTC.                                  13210000
168700                                                                  13220000
168800     IF  PPS-RTC = 00                                             13230000
168900         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60            13240000
169000             MOVE 61 TO PPS-RTC                                   13250000
169100         ELSE                                                     13260000
169200             MOVE B-LTR-DAYS TO H-LTR-DAYS.                       13270000
169300                                                                  13280000
169400     IF  PPS-RTC = 00                                             13290000
169500         IF  B-COVERED-DAYS NOT NUMERIC                           13300000
169600             MOVE 62 TO PPS-RTC                                   13310000
169700         ELSE                                                     13320000
169800         IF  B-COVERED-DAYS = 0 AND B-LOS > 0                     13330000
169900             MOVE 62 TO PPS-RTC                                   13340000
170000         ELSE                                                     13350000
170100             MOVE B-COVERED-DAYS TO H-COV-DAYS.                   13360000
170200                                                                  13370000
170300     IF  PPS-RTC = 00                                             13380000
170400         IF  H-LTR-DAYS  > H-COV-DAYS                             13390000
170500             MOVE 62 TO PPS-RTC                                   13400000
170600         ELSE                                                     13410000
170700             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.        13420000
170800                                                                  13430000
170900     IF  PPS-RTC = 00                                             13440000
171000         IF  NOT VALID-REVIEW-CODE                                13450000
171100             MOVE 57 TO PPS-RTC.                                  13460000
171200                                                                  13470000
171300     IF  PPS-RTC = 00                                             13480000
171400         IF  B-CHARGES-CLAIMED NOT NUMERIC                        13490000
171500             MOVE 58 TO PPS-RTC.                                  13500000
171600                                                                  13510000
171700     IF PPS-RTC = 00                                              13520000
171800           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'                       13530000
171900                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND         13540000
172000                                            NOT = 'B' AND         13550000
172100                                            NOT = 'C'             13560000
172200                 MOVE 65 TO PPS-RTC.                              13570000
172300                                                                  13580000
172400 2000-ASSEMBLE-PPS-VARIABLES.                                     13590000
172500***  GET THE PROVIDER SPECIFIC VARIABLES.                         13600000
172600***  GET THE PROVIDER SPECIFIC VARIABLES.                         13610000
172700                                                                  13620000
172800     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.                 13630000
172900     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.                   13640000
173000                                                                  13650000
173100     IF  (P-NEW-STATE = 02 OR 12)                                 13660000
173200         MOVE P-NEW-COLA TO H-OPER-COLA                           13670000
173300     ELSE                                                         13680000
173400         MOVE 1.000  TO H-OPER-COLA.                              13690000
173500                                                                  13700000
173600***************************************************************   13710000
173700***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF              13720000
173800***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF              13730000
173900                                                                  13740000
174000     PERFORM 2600-GET-DRG-WEIGHT                                  13750000
174100             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.               13760000
174200                                                                  13770000
174300***************************************************************   13780000
174400***  GET THE WAGE-INDEX                                           13790000
174500***  GET THE WAGE-INDEX                                           13800000
174600                                                                  13810000
174700     MOVE W-CBSA-INDEX-RECORD TO H-WAGE-INDEX.                    13820000
174800     MOVE W-CBSA-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.              13830000
174900                                                                  13840000
175000***************************************************************   13850000
175100***  GET THE LABOR, NON-LABOR STANDARD RATES                      13860000
175200                                                                  13870000
175300     IF  P-NEW-STATE = 40                                         13880000
175400         MOVE 2 TO R2                                             13890000
175500         MOVE 3 TO R4                                             13900000
175600     ELSE                                                         13910000
175700         MOVE 1 TO R2                                             13920000
175800         MOVE 1 TO R4.                                            13930000
175900                                                                  13940000
176000     IF  LARGE-URBAN                                              13950000
176100         MOVE 1 TO R3                                             13960000
176200     ELSE                                                         13970000
176300         MOVE 2 TO R3.                                            13980000
176400                                                                  13990000
176500     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND                     14000000
176600        (H-WAGE-INDEX > 01.0000))                                 14010000
176700        PERFORM 2300-GET-LAB-NONLAB-TB1-RATES                     14020000
176800             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 14030000
176900                                                                  14040000
177000     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND                 14050000
177100         (H-WAGE-INDEX > 01.0000))                                14060000
177200        PERFORM 2300-GET-LAB-NONLAB-TB2-RATES                     14070000
177300             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 14080000
177400                                                                  14090000
177500     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND                    14100000
177600         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))      14110000
177700        PERFORM 2300-GET-LAB-NONLAB-TB3-RATES                     14120000
177800             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 14130000
177900                                                                  14140000
178000     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND                 14150000
178100         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))      14160000
178200        PERFORM 2300-GET-LAB-NONLAB-TB4-RATES                     14170000
178300             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 14180000
178400                                                                  14190000
178500     IF P-NEW-STATE = 40                                          14200000
178600        IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND                  14210000
178700            (H-PR-WAGE-INDEX > 01.0000))                          14220000
178800             PERFORM 2300-GET-PR-LAB-TB1-RATES                    14230000
178900             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 14240000
179000                                                                  14250000
179100                                                                  14260000
179200     IF P-NEW-STATE = 40                                          14270000
179300        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND              14280000
179400             (H-PR-WAGE-INDEX > 01.0000))                         14290000
179500              PERFORM 2300-GET-PR-LAB-TB2-RATES                   14300000
179600                  VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.            14310000
179700                                                                  14320000
179800     IF P-NEW-STATE = 40                                          14330000
179900        IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND                 14340000
180000         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))14350000
180100          PERFORM 2300-GET-PR-LAB-TB3-RATES                       14360000
180200              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                14370000
180300                                                                  14380000
180400     IF P-NEW-STATE = 40                                          14390000
180500        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND              14400000
180600         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))14410000
180700          PERFORM 2300-GET-PR-LAB-TB4-RATES                       14420000
180800              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                14430000
180900                                                                  14440000
181000***************************************************************   14450000
181100***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL               14460000
181200***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL               14470000
181300                                                                  14480000
181400     MOVE 0.00  TO H-OPER-HSP-PCT.                                14490000
181500     MOVE 1.00  TO H-OPER-FSP-PCT.                                14500000
181600                                                                  14510000
181700***************************************************************   14520000
181800***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL     14530000
181900***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL     14540000
182000                                                                  14550000
182100      MOVE 1.00 TO H-NAT-PCT.                                     14560000
182200      MOVE 0.00 TO H-REG-PCT.                                     14570000
182300                                                                  14580000
182400     IF  P-NEW-STATE = 40                                         14590000
182500         MOVE 0.75 TO H-NAT-PCT                                   14600000
182600         MOVE 0.25 TO H-REG-PCT.                                  14610000
182700                                                                  14620000
182800     IF  P-N-SCH-REBASED-FY90 OR                                  14630000
182900         P-N-EACH OR                                              14640000
183000         P-N-MDH-REBASED-FY90                                     14650000
183100         MOVE 1.00 TO H-OPER-HSP-PCT.                             14660000
183200                                                                  14670000
183300 2300-GET-LAB-NONLAB-TB1-RATES.                                   14680000
183400                                                                  14690000
183500     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)            14700000
183600         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            14710000
183700         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR         14720000
183800         MOVE TB1-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR            14730000
183900         MOVE TB1-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.        14740000
184000                                                                  14750000
184100 2300-GET-LAB-NONLAB-TB2-RATES.                                   14760000
184200                                                                  14770000
184300     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)            14780000
184400         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            14790000
184500         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR         14800000
184600         MOVE TB2-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR            14810000
184700         MOVE TB2-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.        14820000
184800                                                                  14830000
184900 2300-GET-LAB-NONLAB-TB3-RATES.                                   14840000
185000                                                                  14850000
185100     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)            14860000
185200         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            14870000
185300         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR         14880000
185400         MOVE TB3-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR            14890000
185500         MOVE TB3-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.        14900000
185600                                                                  14910000
185700 2300-GET-LAB-NONLAB-TB4-RATES.                                   14920000
185800                                                                  14930000
185900     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)            14940000
186000         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            14950000
186100         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR         14960000
186200         MOVE TB4-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR            14970000
186300         MOVE TB4-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.        14980000
186400                                                                  14990000
186500 2300-GET-PR-LAB-TB1-RATES.                                       15000000
186600                                                                  15010000
186700     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)            15020000
186800         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            15030000
186900         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.        15040000
187000                                                                  15050000
187100 2300-GET-PR-LAB-TB2-RATES.                                       15060000
187200                                                                  15070000
187300     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)            15080000
187400         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            15090000
187500         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.        15100000
187600                                                                  15110000
187700 2300-GET-PR-LAB-TB3-RATES.                                       15120000
187800                                                                  15130000
187900     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)            15140000
188000         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            15150000
188100         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.        15160000
188200                                                                  15170000
188300 2300-GET-PR-LAB-TB4-RATES.                                       15180000
188400                                                                  15190000
188500     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)            15200000
188600         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            15210000
188700         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.        15220000
188800                                                                  15230000
188900                                                                  15240000
189000 2600-GET-DRG-WEIGHT.                                             15250000
189100                                                                  15260000
189200     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)               15270000
189300         SET DX6 TO B-DRG                                         15280000
189400         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT                15290000
189500         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS                  15300000
189600         MOVE ZEROES                   TO H-DAYS-CUTOFF           15310000
189700         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.           15320000
189800                                                                  15330000
189900 3000-CALC-PAYMENT.                                               15340000
190000***************************************************************   15350000
190100                                                                  15360000
190200     PERFORM 3100-CALC-STAY-UTILIZATION.                          15370000
190300     PERFORM 3300-CALC-OPER-FSP-AMT.                              15380000
190400     PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT.                 15390000
190500                                                                  15400000
190600***********************************************************       15410000
190700***  OPERATING IME CALCULATION                                    15420000
190800***  OPERATING IME CALCULATION                                    15430000
190900                                                                  15440000
191000     COMPUTE H-OPER-IME-TEACH ROUNDED =                           15450000
191100            1.35 * ((1 + H-INTERN-RATIO) ** .405  - 1).           15460000
191200                                                                  15470000
191300***********************************************************       15480000
191400                                                                  15490000
191500     IF P-N-SCH-REBASED-FY90 OR                                   15500000
191600        P-N-EACH OR                                               15510000
191700        P-N-MDH-REBASED-FY90                                      15520000
191800         PERFORM 3450-CALC-ADDITIONAL-HSP.                        15530000
191900                                                                  15540000
192000     MOVE 00                 TO  PPS-RTC.                         15550000
192100     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.                   15560000
192200     MOVE H-ALOS             TO  PPS-AVG-LOS.                     15570000
192300     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.                 15580000
192400                                                                  15590000
192500     MOVE B-LOS TO H-PERDIEM-DAYS.                                15600000
192600     IF H-PERDIEM-DAYS < 1                                        15610000
192700         MOVE 1 TO H-PERDIEM-DAYS.                                15620000
192800     ADD 1 TO H-PERDIEM-DAYS.                                     15630000
192900                                                                  15640000
193000     MOVE 1 TO H-DSCHG-FRCTN.                                     15650000
193100                                                                  15660000
193200     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.   15670000
193300                                                                  15680000
193400     IF (PAY-PERDIEM-DAYS  OR                                     15690000
193500         PAY-XFER-NO-COST) OR                                     15700000
193600        (PAY-XFER-SPEC-DRG AND                                    15710000
193700         B-DRG-POSTACUTE-PERDIEM)                                 15720000
193800         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS 15730000
193900         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS 15740000
194000         IF H-DSCHG-FRCTN > 1                                     15750000
194100              MOVE 1 TO H-DSCHG-FRCTN                             15760000
194200              MOVE 1 TO H-TRANSFER-ADJ                            15770000
194300         ELSE                                                     15780000
194400              COMPUTE H-DRG-WT-FRCTN ROUNDED =                    15790000
194500                  (H-PERDIEM-DAYS / H-ALOS) * H-DRG-WT.           15800000
194600                                                                  15810000
194700     IF (PAY-XFER-SPEC-DRG AND                                    15820000
194800         B-DRG-POSTACUTE-50-50)                                   15830000
194900         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS 15840000
195000         COMPUTE H-DSCHG-FRCTN  ROUNDED =                         15850000
195100                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)     15860000
195200         IF H-DSCHG-FRCTN > 1                                     15870000
195300              MOVE 1 TO H-DSCHG-FRCTN                             15880000
195400              MOVE 1 TO H-TRANSFER-ADJ                            15890000
195500         ELSE                                                     15900000
195600              COMPUTE H-DRG-WT-FRCTN ROUNDED =                    15910000
195700            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.   15920000
195800                                                                  15930000
195900                                                                  15940000
196000***********************************************************       15950000
196100***  CAPITAL DSH CALCULATION                                      15960000
196200***  CAPITAL DSH CALCULATION                                      15970000
196300                                                                  15980000
196400     MOVE 0 TO H-CAPI-DSH.                                        15990000
196500                                                                  16000000
196600     IF P-NEW-BED-SIZE NOT NUMERIC                                16010000
196700         MOVE 0 TO P-NEW-BED-SIZE.                                16020000
196800                                                                  16030000
196900     IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99        16040000
197000         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **                   16050000
197100                  (.2025 * (P-NEW-SSI-RATIO                       16060000
197200                          + P-NEW-MEDICAID-RATIO)) - 1.           16070000
197300                                                                  16080000
197400***********************************************************       16090000
197500***  CAPITAL IME TEACH CALCULATION                                16100000
197600***  CAPITAL IME TEACH CALCULATION                                16110000
197700                                                                  16120000
197800     MOVE 0 TO H-WK-CAPI-IME-TEACH.                               16130000
197900                                                                  16140000
198000     IF P-NEW-CAPI-IME NUMERIC                                    16150000
198100        IF P-NEW-CAPI-IME > 1.5000                                16160000
198200           MOVE 1.5000 TO P-NEW-CAPI-IME.                         16170000
198300                                                                  16180000
198400     IF P-NEW-CAPI-IME NUMERIC                                    16190000
198500        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =                     16200000
198600          (2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1.               16210000
198700                                                                  16220000
198800***********************************************************       16230000
198900     MOVE 0.00 TO H-DAYOUT-PCT.                                   16240000
199000     MOVE 0.80 TO H-CSTOUT-PCT.                                   16250000
199100                                                                  16260000
199200******************************************************************16270000
199300**                                                                16280000
199400** BURN DRGS FOR FY08 ARE 927, 928, 929, 933, 934 AND 935.        16281000
199500**                                                                16282000
199600******************************************************************16283000
199700                                                                  16284000
199800     IF  B-DRG = 927 OR 928 OR 929 OR 933 OR 934 OR 935           16285000
199900             MOVE 0.90 TO H-CSTOUT-PCT.                           16286000
200000                                                                  16287000
200100***     NATIONAL PERCENTAGE                                       16288000
200200     MOVE 0.6970   TO H-LABOR-PCT.                                16289000
200300     MOVE 0.3030   TO H-NONLABOR-PCT.                             16290000
200400                                                                  16300000
200500***     PUERTO RICO PERCENTAGE                                    16310000
200600     MOVE 0.6200   TO H-PR-LABOR-PCT.                             16320000
200700     MOVE 0.3800   TO H-PR-NONLABOR-PCT.                          16330000
200800                                                                  16340000
200900     IF (H-WAGE-INDEX < 01.0000 OR                                16350000
201000         H-WAGE-INDEX = 01.0000)                                  16360000
201100        MOVE 0.6200 TO H-LABOR-PCT                                16370000
201200        MOVE 0.3800 TO H-NONLABOR-PCT.                            16380000
201300                                                                  16390000
201400     IF P-NEW-STATE = 40                                          16400000
201500       IF (H-PR-WAGE-INDEX < 01.0000 OR                           16410000
201600           H-PR-WAGE-INDEX = 01.0000)                             16420000
201700          MOVE 0.5870 TO H-PR-LABOR-PCT                           16430000
201800          MOVE 0.4130 TO H-PR-NONLABOR-PCT.                       16440000
201900                                                                  16450000
202000                                                                  16460000
202100     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC                          16470000
202200             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO  16480000
202300     ELSE                                                         16490000
202400             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.                   16500000
202500                                                                  16510000
202600     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC                           16520000
202700             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO  16530000
202800     ELSE                                                         16540000
202900             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.                   16550000
203000                                                                  16560000
203100***********************************************************       16570000
203200*****YEARCHANGE* 2008.6 ***********************************       16570000
203300***  CAPITAL PAYMENT METHOD B - YEARCHNG                          16580000
203400***  CAPITAL PAYMENT METHOD B                                     16590000
203500                                                                  16600000
203600     IF W-CBSA-SIZE = 'L'                                         16610000
203700        MOVE 1.00 TO H-CAPI-LARG-URBAN                            16620000
203800     ELSE                                                         16630000
203900        MOVE 1.00 TO H-CAPI-LARG-URBAN.                           16640000
204000                                                                  16650000
204100     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).     16660000
204200     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).  16670000
204300                                                                  16680000
204400     COMPUTE H-FEDERAL-RATE ROUNDED =                             16690000
204500                                 (0426.14 * H-CAPI-GAF).          16700000
204600     COMPUTE H-PUERTO-RICO-RATE ROUNDED =                         16710000
204700                                 (0202.89 * H-PR-CAPI-GAF).       16720000
204800                                                                  16730000
204900     COMPUTE H-CAPI-COLA ROUNDED =                                16740000
205000                     (.3152 * (H-OPER-COLA - 1) + 1).             16750000
205100                                                                  16760000
205200     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.                      16770000
205300                                                                  16780000
205400     IF P-NEW-STATE = 40                                          16790000
205500        COMPUTE  H-CAPI-FED-RATE ROUNDED =                        16800000
205600                 (H-NAT-PCT * H-FEDERAL-RATE) +                   16810000
205700                 (H-REG-PCT * H-PUERTO-RICO-RATE).                16820000
205800***********************************************************       16830000
205900***  CAPITAL FSP CALCULATION                                      16840000
206000***  CAPITAL FSP CALCULATION                                      16850000
206100                                                                  16860000
206200     COMPUTE H-CAPI-FSP-PART ROUNDED =                            16870000
206300                               H-DRG-WT * H-CAPI-FED-RATE *       16880000
206400                               H-CAPI-COLA *                      16890000
206500                               H-CAPI-LARG-URBAN.                 16900000
206600                                                                  16910000
206700***********************************************************       16920000
206800***  CAPITAL PAYMENT METHOD A                                     16930000
206900***  CAPITAL PAYMENT METHOD A                                     16940000
207000                                                                  16950000
207100     IF P-N-SCH-REBASED-FY90 OR P-N-EACH                          16960000
207200        MOVE 1.00 TO H-CAPI-SCH                                   16970000
207300     ELSE                                                         16980000
207400        MOVE 0.85 TO H-CAPI-SCH.                                  16990000
207500                                                                  17000000
207600***********************************************************       17010000
207700***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********    17020000
207800***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********    17030000
207900                                                                  17040000
208000     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                        17050000
208100                    (P-NEW-CAPI-OLD-HARM-RATE *                   17060000
208200                    H-CAPI-SCH).                                  17070000
208300                                                                  17080000
208400***********************************************************       17090000
208500        IF PAY-PERDIEM-DAYS                                       17100000
208600            IF  H-PERDIEM-DAYS < H-ALOS                           17110000
208700                IF  NOT (B-DRG = 789)                             17120000
208800                    PERFORM 3500-CALC-PERDIEM-AMT                 17130000
208900                    MOVE 03 TO PPS-RTC.                           17140000
209000                                                                  17150000
209100        IF PAY-XFER-SPEC-DRG                                      17160000
209200            IF  H-PERDIEM-DAYS < H-ALOS                           17170000
209300                IF  NOT (B-DRG = 789)                             17180000
209400                    PERFORM 3550-CALC-PERDIEM-AMT.                17190000
209500                                                                  17200000
209600        IF  PAY-XFER-NO-COST                                      17210000
209700            MOVE 00 TO PPS-RTC                                    17220000
209800            IF H-PERDIEM-DAYS < H-ALOS                            17230000
209900               IF  NOT (B-DRG = 789)                              17240000
210000                   PERFORM 3500-CALC-PERDIEM-AMT                  17250000
210100                   MOVE 06 TO PPS-RTC.                            17260000
210200                                                                  17270000
210300     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.                 17280000
210400                                                                  17290000
210500     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.                    17300000
210600                                                                  17310000
210700     IF OUTLIER-RECON-FLAG = 'Y' GO TO 3000-EXIT.                 17320000
210800                                                                  17330000
210900     IF PPS-RTC = 67  GO TO 3000-CONTINUE.                        17340000
211000                                                                  17350000
211100        IF PAY-XFER-SPEC-DRG                                      17360000
211200            IF  H-PERDIEM-DAYS < H-ALOS                           17370000
211300                IF  NOT (B-DRG = 789)                             17380000
211400                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.   17390000
211500                                                                  17400000
211600                                                                  17410000
211700        IF  PAY-PERDIEM-DAYS                                      17420000
211800            IF  H-OPER-OUTCST-PART > 0                            17430000
211900                MOVE H-OPER-OUTCST-PART TO                        17440000
212000                     H-OPER-OUTLIER-PART                          17450000
212100                MOVE 05 TO PPS-RTC                                17460000
212200            ELSE                                                  17470000
212300            IF  PPS-RTC NOT = 03                                  17480000
212400                MOVE 00 TO PPS-RTC                                17490000
212500                MOVE 0  TO H-OPER-OUTLIER-PART.                   17500000
212600                                                                  17510000
212700        IF  PAY-PERDIEM-DAYS                                      17520000
212800            IF  H-CAPI-OUTCST-PART > 0                            17530000
212900                MOVE H-CAPI-OUTCST-PART TO                        17540000
213000                     H-CAPI-OUTLIER-PART                          17550000
213100                MOVE 05 TO PPS-RTC                                17560000
213200            ELSE                                                  17570000
213300            IF  PPS-RTC NOT = 03                                  17580000
213400                MOVE 0  TO H-CAPI-OUTLIER-PART.                   17590000
213500                                                                  17600000
213600                                                                  17610000
213700 3000-CONTINUE.                                                   17620000
213800                                                                  17630000
213900***********************************************************       17640000
214000***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF          17650000
214100***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE          17660000
214200                                                                  17670000
214300     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.        17680000
214400                                                                  17690000
214500***********************************************************       17700000
214600                                                                  17710000
214700     IF  PPS-RTC = 67                                             17720000
214800         MOVE H-OPER-DOLLAR-THRESHOLD TO                          17730000
214900              WK-H-OPER-DOLLAR-THRESHOLD.                         17740000
215000                                                                  17750000
215100     IF  PPS-RTC < 50                                             17760000
215200         PERFORM 3800-CALC-TOT-AMT                                17770000
215300     ELSE                                                         17780000
215400         MOVE ALL '0' TO PPS-OPER-HSP-PART                        17790000
215500                         PPS-OPER-FSP-PART                        17800000
215600                         PPS-OPER-OUTLIER-PART                    17810000
215700                         PPS-OUTLIER-DAYS                         17820000
215800                         PPS-REG-DAYS-USED                        17830000
215900                         PPS-LTR-DAYS-USED                        17840000
216000                         PPS-TOTAL-PAYMENT                        17850000
216100                         PPS-OPER-DSH-ADJ                         17860000
216200                         PPS-OPER-IME-ADJ                         17870000
216300                         H-DSCHG-FRCTN                            17880000
216400                         H-DRG-WT-FRCTN                           17890000
216500                         HOLD-ADDITIONAL-VARIABLES                17900000
216600                         HOLD-CAPITAL-VARIABLES                   17910000
216700                         HOLD-CAPITAL2-VARIABLES                  17920000
216800                         HOLD-OTHER-VARIABLES                     17930000
216900                         HOLD-PC-OTH-VARIABLES.                   17940000
217000                                                                  17950000
217100     IF  PPS-RTC = 67                                             17960000
217200         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO                       17970000
217300                 H-OPER-DOLLAR-THRESHOLD.                         17980000
217400                                                                  17990000
217500 3000-EXIT.  EXIT.                                                18000000
217600                                                                  18010000
217700 3100-CALC-STAY-UTILIZATION.                                      18020000
217800                                                                  18030000
217900     MOVE 0 TO PPS-REG-DAYS-USED.                                 18040000
218000     MOVE 0 TO PPS-LTR-DAYS-USED.                                 18050000
218100                                                                  18060000
218200     IF H-REG-DAYS > 0                                            18070000
218300        IF H-REG-DAYS > B-LOS                                     18080000
218400           MOVE B-LOS TO PPS-REG-DAYS-USED                        18090000
218500        ELSE                                                      18100000
218600           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED                   18110000
218700     ELSE                                                         18120000
218800        IF H-LTR-DAYS > B-LOS                                     18130000
218900           MOVE B-LOS TO PPS-LTR-DAYS-USED                        18140000
219000        ELSE                                                      18150000
219100           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.                  18160000
219200                                                                  18170000
219300                                                                  18180000
219400                                                                  18190000
219500 3300-CALC-OPER-FSP-AMT.                                          18200000
219600***********************************************************       18210000
219700***  OPERATING FSP CALCULATION                                    18220000
219800***  OPERATING FSP CALCULATION                                    18230000
219900                                                                  18240000
220000     COMPUTE H-OPER-FSP-PART ROUNDED =                            18250000
220100           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +             18260000
220200            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)             18270000
220300                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.       18280000
220400                                                                  18290000
220500     IF P-NEW-STATE = 40                                          18300000
220600       COMPUTE H-OPER-FSP-PART ROUNDED =                          18310000
220700           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +             18320000
220800            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)             18330000
220900                           +                                      18340000
221000           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +          18350000
221100            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)             18360000
221200                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.       18370000
221300                                                                  18380000
221400                                                                  18390000
221500 3450-CALC-ADDITIONAL-HSP.                                        18400000
221600***********************************************************       18410000
221700*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR                 18420000
221800*    SOLE COMMUNITY                                               18430000
221900*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)              18440000
222000*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES              18450000
222100***********************************************************       18460000
222200*****YEARCHANGE************************************************   18470000
222300***         GET THE UPDATING FACTOR                               18480000
222400***         GET THE UPDATING FACTOR                               18490000
222500                                                                  18500000
222600     MOVE 0.995743 TO H-BUDG-NUTR08.                              18510000
222700                                                                  18520000
222800     MOVE 1.0330 TO H-UPDATE-08.                                  18530000
222900                                                                  18531000
223000     COMPUTE H-UPDATE-FACTOR ROUNDED =                            18532000
223100                       (H-UPDATE-08 *                             18533000
223200                        H-BUDG-NUTR08).                           18534000
223300                                                                  18535000
223400***************************************************************   18536000
223500     IF P-NEW-CBSA-HOSP-QUAL-IND = '1'                            18537000
223600        COMPUTE H-HSP-RATE ROUNDED =                              18538000
223700         (H-FAC-SPEC-RATE * 1) * H-UPDATE-FACTOR                  18539000
223800     ELSE                                                         18540000
223900        COMPUTE H-HSP-RATE ROUNDED =                              18550000
224000         ((H-FAC-SPEC-RATE / 1.033) * 1.013) * H-UPDATE-FACTOR.   18560000
224100                                                                  18570000
224200***************************************************************   18580000
224300********YEARCHANGE*********************************************   18590000
224400***         CASE MIX ADJUSTMENT - FOR FUTURE USE                  18480000
224500***         CASE MIX ADJUSTMENT - FOR FUTURE USE                  18480000
224600***                                                                     00
224700***  MOVE 0.994 TO H-CASE-MIX-ADJ.                                      00
224800***                                                                     00
224900***  COMPUTE H-HSP-RATE ROUNDED =                                       00
225000***    H-HSP-RATE * H-CASE-MIX-ADJ.                                     00
225100***                                                                     00
225200********YEARCHANGE*********************************************   18590000
225300***     OUTLIER OFFSETS                                           18591000
225400***     OPERATING NATIONAL                                        18600000
225500***     OPERATING PUERTO RICO BLEND                               18610000
225600                                                                  18620000
225700      MOVE 0.948983 TO H-OUTLIER-OFFSET-NAT                       18630000
225800      MOVE 0.964060 TO H-OUTLIER-OFFSET-PR.                       18640000
225900                                                                  18650000
226000***************************************************************   18660000
226100     COMPUTE H-FSP-RATE ROUNDED =                                 18670000
226200         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +               18680000
226300         H-NAT-NONLABOR * H-OPER-COLA))                           18690000
226400                           *                                      18700000
226500     ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-NAT) 18710000
226600                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.            18720000
226700                                                                  18730000
226800     IF P-NEW-STATE = 40                                          18740000
226900       COMPUTE H-FSP-RATE ROUNDED =                               18750000
227000        ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +               18760000
227100         H-NAT-NONLABOR * H-OPER-COLA))                           18770000
227200                         *                                        18771000
227300        ((1 + H-OPER-IME-TEACH + H-OPER-DSH) /                    18772000
227400                                H-OUTLIER-OFFSET-NAT))            18773000
227500                           +                                      18780000
227600         ((H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +           18790000
227700         H-REG-NONLABOR * H-OPER-COLA))                           18800000
227800                           *                                      18810000
227900      ((1 + H-OPER-IME-TEACH + H-OPER-DSH) /
228000                                       H-OUTLIER-OFFSET-PR))
228100                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.            18830000
228200                                                                  18840000
228300                                                                  18850000
228400     IF  H-HSP-RATE > H-FSP-RATE                                  18860000
228500           COMPUTE H-OPER-HSP-PART ROUNDED =                      18870000
228600             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT                 18880000
228700                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART        18890000
228800     ELSE                                                         18900000
228900         MOVE 0 TO H-OPER-HSP-PART.                               18910000
229000                                                                  18920000
229100***************************************************************   18930000
229200***         GET THE MDH REBASE                                    18940000
229300                                                                  18950000
229400     IF  H-HSP-RATE > H-FSP-RATE                                  18960000
229500         IF P-NEW-PROVIDER-TYPE = '14' OR '15'                    18970000
229600           COMPUTE H-OPER-HSP-PART ROUNDED =                      18980000
229700             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .75           18990000
229800                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.       19000000
229900                                                                  19010000
230000 3500-CALC-PERDIEM-AMT.                                           19020000
230100***********************************************************       19030000
230200***  REVIEW CODE = 03 OR 06                                       19040000
230300***  OPERATING PERDIEM-AMT CALCULATION                            19050000
230400***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS              19060000
230500                                                                  19070000
230600        COMPUTE H-OPER-FSP-PART ROUNDED =                         19080000
230700        H-OPER-FSP-PART * H-TRANSFER-ADJ                          19090000
230800        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  19100000
230900                                                                  19110000
231000***********************************************************       19120000
231100***********************************************************       19130000
231200***  REVIEW CODE = 03 OR 06                                       19140000
231300***  CAPITAL   PERDIEM-AMT CALCULATION                            19150000
231400***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS              19160000
231500                                                                  19170000
231600        COMPUTE H-CAPI-FSP-PART ROUNDED =                         19180000
231700        H-CAPI-FSP-PART * H-TRANSFER-ADJ                          19190000
231800        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  19200000
231900                                                                  19210000
232000***********************************************************       19220000
232100***  REVIEW CODE = 03 OR 06                                       19230000
232200***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                19240000
232300***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                19250000
232400                                                                  19260000
232500        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                     19270000
232600        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ                      19280000
232700        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              19290000
232800                                                                  19300000
232900 3550-CALC-PERDIEM-AMT.                                           19310000
233000***********************************************************       19320000
233100***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG            19330000
233200***  OPERATING PERDIEM-AMT CALCULATION                            19340000
233300***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS              19350000
233400                                                                  19360000
233500     IF (B-DRG-POSTACUTE-50-50)                                   19370000
233600        MOVE 10 TO PPS-RTC                                        19380000
233700        COMPUTE H-OPER-FSP-PART ROUNDED =                         19390000
233800        H-OPER-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             19400000
233900        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  19410000
234000                                                                  19420000
234100     IF (B-DRG-POSTACUTE-PERDIEM)                                 19430000
234200        MOVE 12 TO PPS-RTC                                        19440000
234300        COMPUTE H-OPER-FSP-PART ROUNDED =                         19450000
234400        H-OPER-FSP-PART *  H-TRANSFER-ADJ                         19460000
234500        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  19470000
234600                                                                  19480000
234700***********************************************************       19490000
234800***  CAPITAL PERDIEM-AMT CALCULATION                              19500000
234900***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS                19510000
235000                                                                  19520000
235100     IF (B-DRG-POSTACUTE-50-50)                                   19530000
235200        MOVE 10 TO PPS-RTC                                        19540000
235300        COMPUTE H-CAPI-FSP-PART ROUNDED =                         19550000
235400        H-CAPI-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             19560000
235500        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  19570000
235600                                                                  19580000
235700     IF (B-DRG-POSTACUTE-PERDIEM)                                 19590000
235800        MOVE 12 TO PPS-RTC                                        19600000
235900        COMPUTE H-CAPI-FSP-PART ROUNDED =                         19610000
236000        H-CAPI-FSP-PART *  H-TRANSFER-ADJ                         19620000
236100        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  19630000
236200                                                                  19640000
236300***********************************************************       19650000
236400***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                19660000
236500***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                19670000
236600                                                                  19680000
236700     IF (B-DRG-POSTACUTE-50-50)                                   19690000
236800        MOVE 10 TO PPS-RTC                                        19700000
236900        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                     19710000
237000        H-CAPI-OLD-HARMLESS * (.5 * (1 + H-TRANSFER-ADJ))         19720000
237100        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              19730000
237200                                                                  19740000
237300     IF (B-DRG-POSTACUTE-PERDIEM)                                 19750000
237400        MOVE 12 TO PPS-RTC                                        19760000
237500        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                     19770000
237600        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ                     19780000
237700        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              19790000
237800                                                                  19800000
237900 3560-CHECK-RTN-CODE.                                             19810000
238000                                                                  19820000
238100     IF (B-DRG-POSTACUTE-50-50)                                   19830000
238200        MOVE 10 TO PPS-RTC.                                       19840000
238300     IF (B-DRG-POSTACUTE-PERDIEM)                                 19850000
238400        MOVE 12 TO PPS-RTC.                                       19860000
238500                                                                  19870000
238600 3560-EXIT.    EXIT.                                              19880000
238700                                                                  19890000
238800 3600-CALC-OUTLIER.                                               19900000
238900***********************************************************       19910000
239000***  COST OUTLIER OPERATING AND CAPITAL CALCULATION               19920000
239100***  COST OUTLIER OPERATING AND CAPITAL CALCULATION               19930000
239200                                                                  19940000
239300     IF OUTLIER-RECON-FLAG = 'Y'                                  19950000
239400        COMPUTE H-OPER-CSTCHG-RATIO ROUNDED =                     19960000
239500               (H-OPER-CSTCHG-RATIO + .2).                        19970000
239600                                                                  19980000
239700     IF H-CAPI-CSTCHG-RATIO > 0 OR                                19990000
239800       H-OPER-CSTCHG-RATIO > 0                                    20000000
239900        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =             20010000
240000                H-OPER-CSTCHG-RATIO /                             20020000
240100               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)        20030000
240200        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =             20040000
240300                H-CAPI-CSTCHG-RATIO /                             20050000
240400               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)        20060000
240500     ELSE                                                         20070000
240600         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD                    20080000
240700                   H-CAPI-SHARE-DOLL-THRESHOLD.                   20090000
240800                                                                  20100000
240900***********************************************************       20110000
241000*****YEARCHANGE********************************************       20110000
241100***  OUTLIER THRESHOLD AMOUNTS                                    20120000
241200***  OUTLIER THRESHOLD AMOUNTS                                    20130000
241300                                                                  20140000
241400     MOVE 22185.00 TO H-CST-THRESH.                               20150000
241500                                                                  20160000
241600     IF (B-REVIEW-CODE = '03') AND                                20170000
241700         H-PERDIEM-DAYS < H-ALOS                                  20180000
241800        COMPUTE H-CST-THRESH ROUNDED =                            20190000
241900                      (H-CST-THRESH * H-TRANSFER-ADJ)             20200000
242000                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.             20210000
242100                                                                  20220000
242200     IF ((B-REVIEW-CODE = '09') AND                               20230000
242300         (H-PERDIEM-DAYS < H-ALOS))                               20240000
242400         IF (B-DRG-POSTACUTE-PERDIEM)                             20250000
242500            COMPUTE H-CST-THRESH ROUNDED =                        20260000
242600                      (H-CST-THRESH * H-TRANSFER-ADJ)             20270000
242700                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.             20280000
242800                                                                  20290000
242900     IF ((B-REVIEW-CODE = '09') AND                               20300000
243000         (H-PERDIEM-DAYS < H-ALOS))                               20310000
243100         IF (B-DRG-POSTACUTE-50-50)                               20320000
243200           COMPUTE H-CST-THRESH ROUNDED =                         20330000
243300          (H-CST-THRESH * (.5 * (1 + H-TRANSFER-ADJ)))            20340000
243400                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.             20350000
243500                                                                  20360000
243600     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                    20370000
243700        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +            20380000
243800         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *         20390000
243900          H-OPER-SHARE-DOLL-THRESHOLD.                            20400000
244000                                                                  20410000
244100     IF P-NEW-STATE = 40                                          20420000
244200        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =              20430000
244300           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +   20440000
244400            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *   20450000
244500             H-OPER-SHARE-DOLL-THRESHOLD                          20460000
244600        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                 20470000
244700               (H-OPER-DOLLAR-THRESHOLD * H-NAT-PCT) +            20480000
244800               (H-OPER-PR-DOLLAR-THRESHOLD * H-REG-PCT).          20490000
244900                                                                  20500000
245000***********************************************************       20510000
245100                                                                  20520000
245200     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =                    20530000
245300          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *         20540000
245400          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.              20550000
245500                                                                  20560000
245600                                                                  20570000
245700     IF P-NEW-STATE = 40                                          20580000
245800        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =              20590000
245900           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *     20600000
246000           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA              20610000
246100        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =                 20620000
246200               (H-CAPI-DOLLAR-THRESHOLD * H-NAT-PCT) +            20630000
246300               (H-CAPI-PR-DOLLAR-THRESHOLD * H-REG-PCT).          20640000
246400                                                                  20650000
246500                                                                  20660000
246600     COMPUTE H-OPER-COST-OUTLIER ROUNDED =                        20670000
246700      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))     20680000
246800                       +                                          20690000
246900             H-OPER-DOLLAR-THRESHOLD                              20700000
247000                       +                                          20710000
247100                 H-NEW-TECH-PAY-ADD-ON.                           20720000
247200                                                                  20730000
247300     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =                        20740000
247400      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))  20750000
247500                       +                                          20760000
247600             H-CAPI-DOLLAR-THRESHOLD.                             20770000
247700                                                                  20780000
247800     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               20790000
247900         MOVE 0 TO H-CAPI-COST-OUTLIER.                           20800000
248000                                                                  20810000
248100                                                                  20820000
248200***********************************************************       20830000
248300***  OPERATING COST CALCULATION                                   20840000
248400***  OPERATING COST CALCULATION                                   20850000
248500                                                                  20860000
248600     COMPUTE H-OPER-BILL-COSTS ROUNDED =                          20870000
248700         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO                  20880000
248800         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.               20890000
248900                                                                  20900000
249000                                                                  20910000
249100     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER                  20920000
249200         COMPUTE H-OPER-OUTCST-PART ROUNDED =                     20930000
249300         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -                      20940000
249400                         H-OPER-COST-OUTLIER).                    20950000
249500                                                                  20960000
249600     IF PAY-WITHOUT-COST OR                                       20970000
249700        PAY-XFER-NO-COST OR                                       20980000
249800        PAY-XFER-SPEC-DRG-NO-COST                                 20990000
249900         MOVE 0 TO H-OPER-OUTCST-PART.                            21000000
250000                                                                  21010000
250100***********************************************************       21020000
250200***  CAPITAL COST CALCULATION                                     21030000
250300***  CAPITAL COST CALCULATION                                     21040000
250400                                                                  21050000
250500     COMPUTE H-CAPI-BILL-COSTS ROUNDED =                          21060000
250600             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO              21070000
250700         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.               21080000
250800                                                                  21090000
250900     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER                  21100000
251000         COMPUTE H-CAPI-OUTCST-PART ROUNDED =                     21110000
251100         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -                      21120000
251200                         H-CAPI-COST-OUTLIER).                    21130000
251300                                                                  21140000
251400     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'                             21150000
251500       COMPUTE H-CAPI-OUTCST-PART ROUNDED =                       21160000
251600              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).   21170000
251700                                                                  21180000
251800     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'                             21190000
251900        COMPUTE H-CAPI-OUTCST-PART ROUNDED =                      21200000
252000               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).         21210000
252100                                                                  21220000
252200     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <               21230000
252300        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)               21240000
252400        MOVE 0 TO H-CAPI-OUTCST-PART                              21250000
252500                  H-OPER-OUTCST-PART.                             21260000
252600                                                                  21270000
252700     IF PAY-WITHOUT-COST OR                                       21280000
252800        PAY-XFER-NO-COST OR                                       21290000
252900        PAY-XFER-SPEC-DRG-NO-COST                                 21300000
253000         MOVE 0 TO H-CAPI-OUTCST-PART.                            21310000
253100                                                                  21320000
253200***********************************************************       21330000
253300***  DETERMINES THE BILL TO BE COST  OUTLIER                      21340000
253400                                                                  21350000
253500     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               21360000
253600         MOVE 0 TO H-CAPI-OUTDAY-PART                             21370000
253700                   H-CAPI-OUTCST-PART.                            21380000
253800                                                                  21390000
253900     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0             21400000
254000                 MOVE H-OPER-OUTCST-PART TO                       21410000
254100                      H-OPER-OUTLIER-PART                         21420000
254200                 MOVE H-CAPI-OUTCST-PART TO                       21430000
254300                      H-CAPI-OUTLIER-PART                         21440000
254400                 MOVE 02 TO PPS-RTC.                              21450000
254500                                                                  21460000
254600     IF OUTLIER-RECON-FLAG = 'Y'                                  21470000
254700        IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0          21480000
254800           COMPUTE HLD-PPS-RTC = HLD-PPS-RTC + 30                 21490000
254900           GO TO 3600-EXIT                                        21500000
255000        ELSE                                                      21510000
255100           GO TO 3600-EXIT                                        21520000
255200     ELSE                                                         21530000
255300        NEXT SENTENCE.                                            21540000
255400                                                                  21550000
255500                                                                  21560000
255600***********************************************************       21570000
255700***  DETERMINES IF COST OUTLIER                                   21580000
255800***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH             21590000
255900***         RETURN CODE OF 02                                     21600000
256000                                                                  21610000
256100     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.                           21620000
256200                                                                  21630000
256300     IF PPS-RTC = 02                                              21640000
256400             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =            21650000
256500                     (H-CAPI-COST-OUTLIER  +                      21660000
256600                      H-OPER-COST-OUTLIER)                        21670000
256700                             /                                    21680000
256800                    (H-CAPI-CSTCHG-RATIO  +                       21690000
256900                     H-OPER-CSTCHG-RATIO)                         21700000
257000             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.     21710000
257100                                                                  21720000
257200***********************************************************       21730000
257300***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS       21740000
257400***         RETURN CODE OF 67                                     21750000
257500                                                                  21760000
257600     IF PPS-RTC = 02                                              21770000
257700         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR                21780000
257800            PPS-PC-COT-FLAG = 'Y'                                 21790000
257900             MOVE 67 TO PPS-RTC.                                  21800000
258000***********************************************************       21810000
258100                                                                  21820000
258200***********************************************************       21830000
258300***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF          21840000
258400***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE          21850000
258500                                                                  21860000
258600     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'                             21870000
258700        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =                  21880000
258800                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO   21890000
258900         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.          21900000
259000                                                                  21910000
259100     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'                             21920000
259200        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =                  21930000
259300                H-CAPI-OUTLIER-PART.                              21940000
259400                                                                  21950000
259500     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'                             21960000
259600        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =                  21970000
259700                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1          21980000
259800         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.          21990000
259900                                                                  22000000
260000 3600-EXIT.   EXIT.                                               22010000
260100                                                                  22020000
260200***********************************************************       22030000
260300 3800-CALC-TOT-AMT.                                               22040000
260400***********************************************************       22050000
260500***  CALCULATE TOTALS FOR CAPITAL                                 22060000
260600***  CALCULATE TOTALS FOR CAPITAL                                 22070000
260700                                                                  22080000
260800     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.           22090000
260900                                                                  22100000
261000     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'                             22110000
261100        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT          22120000
261200        MOVE 0.00 TO H-CAPI-HSP-PCT.                              22130000
261300                                                                  22140000
261400     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'                             22150000
261500        MOVE 0    TO H-CAPI-OLD-HARMLESS                          22160000
261600        MOVE 1.00 TO H-CAPI-FSP-PCT                               22170000
261700        MOVE 0.00 TO H-CAPI-HSP-PCT.                              22180000
261800                                                                  22190000
261900     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'                             22200000
262000        MOVE 0    TO H-CAPI-OLD-HARMLESS                          22210000
262100        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT                 22220000
262200        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.                22230000
262300                                                                  22240000
262400     COMPUTE H-CAPI-HSP ROUNDED =                                 22250000
262500         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.                        22260000
262600                                                                  22270000
262700     COMPUTE H-CAPI-FSP ROUNDED =                                 22280000
262800         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.                        22290000
262900                                                                  22300000
263000     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.             22310000
263100                                                                  22320000
263200     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.                 22330000
263300                                                                  22340000
263400     COMPUTE H-CAPI-DSH-ADJ ROUNDED =                             22350000
263500             H-CAPI-FSP                                           22360000
263600              * H-CAPI-DSH.                                       22370000
263700                                                                  22380000
263800     COMPUTE H-CAPI-IME-ADJ ROUNDED =                             22390000
263900          H-CAPI-FSP *                                            22400000
264000                 H-WK-CAPI-IME-TEACH.                             22410000
264100                                                                  22420000
264200     COMPUTE H-CAPI-OUTLIER ROUNDED =                             22430000
264300             1.00 * H-CAPI-OUTLIER-PART.                          22440000
264400                                                                  22450000
264500     COMPUTE H-CAPI2-B-FSP ROUNDED =                              22460000
264600             1.00 * H-CAPI2-B-FSP-PART.                           22470000
264700                                                                  22480000
264800     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =                          22490000
264900             1.00 * H-CAPI2-B-OUTLIER-PART.                       22500000
265000***********************************************************       22510000
265100***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER               22520000
265200***        THIS ZEROES OUT ALL CAPITAL DATA                       22530000
265300                                                                  22540000
265400     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               22550000
265500        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.                   22560000
265600***********************************************************       22570000
265700                                                                  22580000
265800***********************************************************       22590000
265900***  CALCULATE FINAL TOTALS FOR OPERATING                         22600000
266000***  CALCULATE FINAL TOTALS FOR OPERATING                         22610000
266100                                                                  22620000
266200     IF (H-CAPI-OUTLIER > 0 AND                                   22630000
266300         PPS-OPER-OUTLIER-PART = 0)                               22640000
266400            COMPUTE PPS-OPER-OUTLIER-PART =                       22650000
266500                    PPS-OPER-OUTLIER-PART + .01.                  22660000
266600                                                                  22670000
266700     MOVE 01.000 TO WK-LOW-VOL25PCT.                              22680000
266800                                                                  22690000
266900     IF P-NEW-TEMP-RELIEF-IND = 'Y'                               22700000
267000        MOVE 01.250 TO WK-LOW-VOL25PCT.                           22710000
267100                                                                  22720000
267200     MOVE ZERO TO PPS-OPER-DSH-ADJ.                               22730000
267300                                                                  22740000
267400     IF  H-OPER-DSH NUMERIC                                       22750000
267500         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =                       22760000
267600       (WK-LOW-VOL25PCT * PPS-OPER-FSP-PART) * H-OPER-DSH.        22770000
267700                                                                  22780000
267800     COMPUTE PPS-OPER-IME-ADJ ROUNDED =                           22790000
267900      (WK-LOW-VOL25PCT * PPS-OPER-FSP-PART) * H-OPER-IME-TEACH.   22800000
268000                                                                  22810000
268100                                                                  22820000
268200     COMPUTE PPS-OPER-FSP-PART ROUNDED =                          22830000
268300        (WK-LOW-VOL25PCT * H-OPER-FSP-PART) * H-OPER-FSP-PCT.     22840000
268400                                                                  22850000
268500     COMPUTE PPS-OPER-HSP-PART ROUNDED =                          22860000
268600        (WK-LOW-VOL25PCT * H-OPER-HSP-PART) * H-OPER-HSP-PCT.     22870000
268700                                                                  22880000
268800     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =                      22890000
268900      (WK-LOW-VOL25PCT * H-OPER-OUTLIER-PART) * H-OPER-FSP-PCT.   22900000
269000                                                                  22910000
269100     IF HMO-TAG  = 'Y'                                            22920000
269200        PERFORM 3850-HMO-IME-ADJ.                                 22930000
269300                                                                  22940000
269400***********************************************************       22950000
269500***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING             22960000
269600***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING             22970000
269700                                                                  22980000
269800     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =                           22990000
269900            (H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +        23000000
270000             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +                    23010000
270100             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM) * WK-LOW-VOL25PCT. 23020000
270200                                                                  23030000
270300     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =                      23040000
270400             (WK-LOW-VOL25PCT * H-NEW-TECH-PAY-ADD-ON).           23050000
270500                                                                  23060000
270600***********************************************************       23070000
270700* PUT NEW CHECK HERE IF H-NEW-TECH ZERO PERFORM                   23080000
270800                                                                  23090000
270900     IF   H-NEW-TECH-PAY-ADD-ON = 0                               23100000
271000                                                                  23110000
271100     PERFORM 4100-ISLET-ISOLATION-ADD-ON THRU 4100-EXIT.          23120000
271200                                                                  23130000
271300                                                                  23140000
271400                                                                  23150000
271500     MOVE H-NEW-TECH-PAY-ADD-ON TO PPS-NEW-TECH-PAY-ADD-ON.       23151000
271600                                                                  23152000
271700     COMPUTE   PPS-TOTAL-PAYMENT ROUNDED =                        23153000
271800               PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +            23154000
271900               PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +         23155000
272000                      PPS-OPER-IME-ADJ                            23156000
272100                           +                                      23157000
272200                 PPS-NEW-TECH-PAY-ADD-ON                          23158000
272300                           +                                      23159000
272400                 H-WK-PASS-AMT-PLUS-MISC                          23160000
272500                           +                                      23170000
272600                   H-CAPI-TOTAL-PAY.                              23180000
272700                                                                  23190000
272800 3850-HMO-IME-ADJ.                                                23200000
272900***********************************************************       23210000
273000***  HMO CALC FOR PASS-THRU ADDON                                 23220000
273100***  HMO CALC FOR PASS-THRU ADDON                                 23230000
273200                                                                  23240000
273300     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =                    23250000
273400          (P-NEW-PASS-AMT-PLUS-MISC -                             23260000
273500          (P-NEW-PASS-AMT-ORGAN-ACQ +                             23270000
273600           P-NEW-PASS-AMT-DIR-MED-ED)) * B-LOS.                   23280000
273700                                                                  23290000
273800***********************************************************       23300000
273900***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002       23310000
274000                                                                  23320000
274100     COMPUTE PPS-OPER-IME-ADJ ROUNDED =                           23330000
274200                   PPS-OPER-IME-ADJ * .0.                         23340000
274300                                                                  23350000
274400***********************************************************       23360000
274500                                                                  23370000
274600                                                                  23380000
274700 3900A-CALC-OPER-DSH.                                             23390000
274800                                                                  23400000
274900***  OPERATING DSH CALCULATION                                    23410000
275000***  OPERATING DSH CALCULATION                                    23420000
275100                                                                  23430000
275200      MOVE 0.0000 TO H-OPER-DSH.                                  23440000
275300                                                                  23450000
275400      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO           23460000
275500                                     + P-NEW-MEDICAID-RATIO).     23470000
275600                                                                  23480000
275700***********************************************************       23490000
275800**1**    0-99 BEDS                                                23500000
275900***  NOT TO EXCEED 12%                                            23510000
276000                                                                  23520000
276100      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100      23530000
276200                               AND H-WK-OPER-DSH > .1499          23540000
276300                               AND H-WK-OPER-DSH < .2020          23550000
276400        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        23560000
276500                                      * .65 + .025                23570000
276600        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.          23580000
276700                                                                  23590000
276800      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100      23600000
276900                               AND H-WK-OPER-DSH > .2019          23610000
277000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       23620000
277100                                      * .825 + .0588              23630000
277200        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.          23640000
277300                                                                  23650000
277400***********************************************************       23660000
277500**2**   100 + BEDS                                                23670000
277600***  NO CAP >> CAN EXCEED 12%                                     23680000
277700                                                                  23690000
277800      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99       23700000
277900                               AND H-WK-OPER-DSH > .1499          23710000
278000                               AND H-WK-OPER-DSH < .2020          23720000
278100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        23730000
278200                                      * .65 + .025.               23740000
278300                                                                  23750000
278400      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99       23760000
278500                               AND H-WK-OPER-DSH > .2019          23770000
278600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       23780000
278700                                      * .825 + .0588.             23790000
278800                                                                  23800000
278900***********************************************************       23810000
279000**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS                  23820000
279100***  NOT TO EXCEED 12%                                            23830000
279200                                                                  23840000
279300      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500           23850000
279400                               AND H-WK-OPER-DSH > .1499          23860000
279500                               AND H-WK-OPER-DSH < .2020          23870000
279600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        23880000
279700                                 * .65 + .025                     23890000
279800        IF H-OPER-DSH > .1200                                     23900000
279900              MOVE .1200 TO H-OPER-DSH.                           23910000
280000                                                                  23920000
280100      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500           23930000
280200                               AND H-WK-OPER-DSH > .2019          23940000
280300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       23950000
280400                                 * .825 + .0588                   23960000
280500        IF H-OPER-DSH > .1200                                     23970000
280600                 MOVE .1200 TO H-OPER-DSH.                        23980000
280700***********************************************************       23990000
280800**4**   OTHER RURAL HOSPITALS 500 BEDS +                          24000000
280900***  NO CAP >> CAN EXCEED 12%                                     24010000
281000                                                                  24020000
281100      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499           24030000
281200                               AND H-WK-OPER-DSH > .1499          24040000
281300                               AND H-WK-OPER-DSH < .2020          24050000
281400        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        24060000
281500                                 * .65 + .025.                    24070000
281600                                                                  24080000
281700      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499           24090000
281800                               AND H-WK-OPER-DSH > .2019          24100000
281900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       24110000
282000                                 * .825 + .0588.                  24120000
282100                                                                  24130000
282200***********************************************************       24140000
282300**7**   RURAL HOSPITALS SCH                                       24150000
282400***  NOT TO EXCEED 12%                                            24160000
282500                                                                  24170000
282600      IF W-CBSA-SIZE = 'R'                                        24180000
282700         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')  24190000
282800                               AND H-WK-OPER-DSH > .1499          24200000
282900                               AND H-WK-OPER-DSH < .2020          24210000
283000         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)       24220000
283100                                 * .65 + .025                     24230000
283200        IF H-OPER-DSH > .1200                                     24240000
283300                 MOVE .1200 TO H-OPER-DSH.                        24250000
283400                                                                  24260000
283500      IF W-CBSA-SIZE = 'R'                                        24270000
283600         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')  24280000
283700                               AND H-WK-OPER-DSH > .2019          24290000
283800         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)      24300000
283900                                 * .825 + .0588                   24310000
284000        IF H-OPER-DSH > .1200                                     24320000
284100                 MOVE .1200 TO H-OPER-DSH.                        24330000
284200                                                                  24340000
284300***********************************************************       24350000
284400**6**   RURAL HOSPITALS RRC   RULE 5 & 6 SAME                     24360000
284500***  RRC OVERRIDES SCH CAP                                        24370000
284600***  NO CAP >> CAN EXCEED 12%                                     24380000
284700                                                                  24390000
284800         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR        24400000
284900                                   '17' OR '22')                  24410000
285000                               AND H-WK-OPER-DSH > .1499          24420000
285100                               AND H-WK-OPER-DSH < .2020          24430000
285200         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)       24440000
285300                                 * .65 + .025.                    24450000
285400         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR        24460000
285500                                   '17' OR '22')                  24470000
285600                               AND H-WK-OPER-DSH > .2019          24480000
285700         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)      24490000
285800                                 * .825 + .0588.                  24500000
285900                                                                  24510000
286000      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.           24520000
286100                                                                  24530000
286200 3900A-EXIT.   EXIT.                                              24540000
286300                                                                  24550000
286400 4000-CALC-TECH-ADDON.                                            24560000
286500                                                                  24570000
286600***********************************************************       24580000
286700***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH              24590000
286800***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH              24600000
286900                                                                  24610000
287000     COMPUTE PPS-OPER-HSP-PART ROUNDED =                          24620000
287100         H-OPER-HSP-PCT * H-OPER-HSP-PART.                        24630000
287200                                                                  24640000
287300     COMPUTE PPS-OPER-FSP-PART ROUNDED =                          24650000
287400         H-OPER-FSP-PCT * H-OPER-FSP-PART.                        24660000
287500                                                                  24670000
287600     MOVE ZERO TO PPS-OPER-DSH-ADJ.                               24680000
287700                                                                  24690000
287800     IF  H-OPER-DSH NUMERIC                                       24700000
287900             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =                   24710000
288000              PPS-OPER-FSP-PART                                   24720000
288100              * H-OPER-DSH.                                       24730000
288200                                                                  24740000
288300     COMPUTE PPS-OPER-IME-ADJ ROUNDED =                           24750000
288400             PPS-OPER-FSP-PART *                                  24760000
288500             H-OPER-IME-TEACH.                                    24770000
288600                                                                  24780000
288700     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =                         24790000
288800             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +              24800000
288900             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ.                 24810000
289000                                                                  24820000
289100***********************************************************       24830000
289200****      NEUROSTIMULATOR CASES                                   24840000
289300***********************************************************       24850000
289400*                                                                 24860000
289500*    IF '8698   ' =  B-PRIN-PROC-CODE   OR                        24870000
289600*                    B-OTHER-PROC-CODE1 OR                        24880000
289700*                    B-OTHER-PROC-CODE2 OR                        24890000
289800*                    B-OTHER-PROC-CODE3 OR                        24900000
289900*                    B-OTHER-PROC-CODE4 OR                        24910000
290000*                    B-OTHER-PROC-CODE5                           24920000
290100*          NEXT SENTENCE                                          24930000
290200*    ELSE                                                         24940000
290300*          MOVE ZEROES TO H-NEW-TECH-ADDON-NEURO                  24950000
290400*          GO TO 4000-CHECK-GRAFT-CASES.                          24960000
290500*                                                                 24970000
290600*    MOVE 18640.00 TO H-CSTMED-NEURO.                             24980000
290700*                                                                 24990000
290800*    COMPUTE H-LESSER-NEURO-1 ROUNDED =                           25000000
290900*            .5   H-CSTMED-NEURO.                                 25010000
291000*                                                                 25020000
291100*    COMPUTE H-LESSER-NEURO-2 ROUNDED =                           25030000
291200*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -       25040000
291300*                    H-BASE-DRG-PAYMENT)   .5.                    25050000
291400*                                                                 25060000
291500*    IF H-LESSER-NEURO-2 > 0                                      25070000
291600*       IF H-LESSER-NEURO-1 < H-LESSER-NEURO-2                    25080000
291700*          MOVE H-LESSER-NEURO-1 TO H-NEW-TECH-ADDON-NEURO        25090000
291800*       ELSE                                                      25100000
291900*          MOVE H-LESSER-NEURO-2 TO H-NEW-TECH-ADDON-NEURO        25110000
292000*    ELSE                                                         25120000
292100*       MOVE ZEROES          TO H-NEW-TECH-ADDON-NEURO.           25130000
292200*                                                                 25140000
292300*4000-CHECK-GRAFT-CASES.                                          25150000
292400*                                                                 25160000
292500***********************************************************       25170000
292600***      GRAFT*(GORE*TAG)*CASES                                   25180000
292700***********************************************************       25190000
292800*                                                                 25200000
292900*    IF '3973   ' =  B-PRIN-PROC-CODE   OR                        25210000
293000*                    B-OTHER-PROC-CODE1 OR                        25220000
293100*                    B-OTHER-PROC-CODE2 OR                        25230000
293200*                    B-OTHER-PROC-CODE3 OR                        25240000
293300*                    B-OTHER-PROC-CODE4 OR                        25250000
293400*                    B-OTHER-PROC-CODE5                           25260000
293500*          NEXT SENTENCE                                          25270000
293600*    ELSE                                                         25280000
293700*          MOVE ZEROES TO H-NEW-TECH-ADDON-GRAFT                  25290000
293800*          GO TO 4000-CHECK-X-STOP.                               25300000
293900*                                                                 25310000
294000*    MOVE 21198.00 TO H-CSTMED-GRAFT.                             25320000
294100*                                                                 25330000
294200*    COMPUTE H-LESSER-GRAFT-1 ROUNDED =                           25340000
294300*            .5   H-CSTMED-GRAFT.                                 25350000
294400*                                                                 25360000
294500*    COMPUTE H-LESSER-GRAFT-2 ROUNDED =                           25370000
294600*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -       25380000
294700*                    H-BASE-DRG-PAYMENT)   .5.                    25390000
294800*                                                                 25400000
294900*    IF H-LESSER-GRAFT-2 > 0                                      25410000
295000*       IF H-LESSER-GRAFT-1 < H-LESSER-GRAFT-2                    25420000
295100*          MOVE H-LESSER-GRAFT-1 TO H-NEW-TECH-ADDON-GRAFT        25430000
295200*       ELSE                                                      25440000
295300*          MOVE H-LESSER-GRAFT-2 TO H-NEW-TECH-ADDON-GRAFT        25450000
295400*    ELSE                                                         25460000
295500*       MOVE ZEROES          TO H-NEW-TECH-ADDON-GRAFT.           25470000
295600*                                                                 25480000
295700*4000-CHECK-X-STOP.                                               25490000
295800*                                                                 25500000
295900***********************************************************       25510000
296000*****    X-STOP INTERSPINOUS PROCESS DECOMPRESSION SYSTEM         25520000
296100***********************************************************       25530000
296200*                                                                 25540000
296300*    IF '8458   ' =  B-PRIN-PROC-CODE   OR                        25550000
296400*                    B-OTHER-PROC-CODE1 OR                        25560000
296500*                    B-OTHER-PROC-CODE2 OR                        25570000
296600*                    B-OTHER-PROC-CODE3 OR                        25580000
296700*                    B-OTHER-PROC-CODE4 OR                        25590000
296800*                    B-OTHER-PROC-CODE5                           25600000
296900*          NEXT SENTENCE                                          25610000
297000*    ELSE                                                         25620000
297100*          MOVE ZEROES TO H-NEW-TECH-ADDON-X-STOP                 25630000
297200*          GO TO 4000-ADD-TECH-CASES.                             25640000
297300*                                                                 25650000
297400*    MOVE 8800.00 TO H-CSTMED-X-STOP.                             25660000
297500*                                                                 25670000
297600*    COMPUTE H-LESSER-X-STOP-1 ROUNDED =                          25680000
297700*            .5   H-CSTMED-X-STOP.                                25690000
297800*                                                                 25700000
297900*    COMPUTE H-LESSER-X-STOP-2 ROUNDED =                          25710000
298000*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -       25720000
298100*                    H-BASE-DRG-PAYMENT)   .5.                    25730000
298200*                                                                 25740000
298300*    IF H-LESSER-X-STOP-2 > 0                                     25750000
298400*       IF H-LESSER-X-STOP-1 < H-LESSER-X-STOP-2                  25760000
298500*        MOVE H-LESSER-X-STOP-1 TO H-NEW-TECH-ADDON-X-STOP        25770000
298600*       ELSE                                                      25780000
298700*        MOVE H-LESSER-X-STOP-2 TO H-NEW-TECH-ADDON-X-STOP        25790000
298800*    ELSE                                                         25800000
298900*       MOVE ZEROES          TO H-NEW-TECH-ADDON-X-STOP.          25810000
299000*                                                                 25820000
299100*                                                                 25830000
299200*4000-ADD-TECH-CASES.                                             25840000
299300*                                                                 25850000
299400*    COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =                      25860000
299500*            H-NEW-TECH-ADDON-NEURO  +                            25870000
299600*            H-NEW-TECH-ADDON-GRAFT +                             25880000
299700*            H-NEW-TECH-ADDON-X-STOP.                             25890000
299800*                                                                 25900000
299900 4000-EXIT.    EXIT.                                              25910000
300000***********************************************************       25920000
300100                                                                  25930000
300200 4100-ISLET-ISOLATION-ADD-ON.                                     25940000
300300***********************************************************       25950000
300400***  TECHNICAL TRANSPLANTATION OF CELLS                           25960000
300500***                                                               25970000
300600*** CODE 52.85 (ALLTRANSPLANTATION OF CELLS OF ISLETS OF          25980000
300700*** ISLETS OF LANGERHAUS) AND                                     25990000
300800*** V70.7 (EXAMINATION OF PARTICIPANT IN CLINICAL TRIAL).         25991000
300900*** V70.7 ONE OR MORE TIMES IN PROC-CODES AND 52.85 ONE OR MORE   25992000
301000*** TIMES IN ANY OTHER PROC-CODE                                  25993000
301100***********************************************************       25994000
301200*** IT WAS DECIDED ON 3/12/07 TO ONLY CHECK FOR 52.85 AND NOT     25995000
301300*** V70.7                                                         25995100
301400***********************************************************       25995200
301500                                                                  25995300
301600     MOVE 0 TO H-TECH-ADDON-ISLET-CNTR                            25995400
301700               H-TECH-ADDON-ISLET-CNTR2.                          25995500
301800                                                                  25995600
301900*    IF 'V707   ' =  B-PRIN-PROC-CODE   OR                        25995700
302000*                    B-OTHER-PROC-CODE1 OR                        25995800
302100*                    B-OTHER-PROC-CODE2 OR                        25995900
302200*                    B-OTHER-PROC-CODE3 OR                        25996000
302300*                    B-OTHER-PROC-CODE4 OR                        25997000
302400*                    B-OTHER-PROC-CODE5                           25998000
302500*          NEXT SENTENCE                                          25999000
302600*    ELSE                                                         25999100
302700*          MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET                  25999200
302800*          GO TO 4100-ADD-TECH-CASES.                             25999300
302900                                                                  25999400
303000     IF '5285   ' =  B-PRIN-PROC-CODE   OR                        25999500
303100                     B-OTHER-PROC-CODE1 OR                        25999600
303200                     B-OTHER-PROC-CODE2 OR                        25999700
303300                     B-OTHER-PROC-CODE3 OR                        25999800
303400                     B-OTHER-PROC-CODE4 OR                        25999900
303500                     B-OTHER-PROC-CODE5   OR                      26000000
303600                     B-OTHER-PROC-CODE6   OR                      25999900
303700                     B-OTHER-PROC-CODE7   OR                      25999900
303800                     B-OTHER-PROC-CODE8   OR                      25999900
303900                     B-OTHER-PROC-CODE9   OR                      25999900
304000                     B-OTHER-PROC-CODE10  OR                      25999900
304100                     B-OTHER-PROC-CODE11  OR                      25999900
304200                     B-OTHER-PROC-CODE12  OR                      25999900
304300                     B-OTHER-PROC-CODE13  OR                      25999900
304400                     B-OTHER-PROC-CODE14  OR                      25999900
304500                     B-OTHER-PROC-CODE15  OR                      25999900
304600                     B-OTHER-PROC-CODE16  OR                      25999900
304700                     B-OTHER-PROC-CODE17  OR                      25999900
304800                     B-OTHER-PROC-CODE18  OR                      25999900
304900                     B-OTHER-PROC-CODE19  OR                      25999900
305000                     B-OTHER-PROC-CODE20  OR                      25999900
305100                     B-OTHER-PROC-CODE21  OR                      25999900
305200                     B-OTHER-PROC-CODE22  OR                      25999900
305300                     B-OTHER-PROC-CODE23  OR                      25999900
305400                     B-OTHER-PROC-CODE24
305500           NEXT SENTENCE                                          26000100
305600     ELSE                                                         26000200
305700           MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET                  26000300
305800           GO TO 4100-ADD-TECH-CASES.                             26000400
305900                                                                  26000500
306000     IF '5285   ' =  B-PRIN-PROC-CODE                             26000600
306100      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26000700
306200                       H-TECH-ADDON-ISLET-CNTR + 1.               26000800
306300                                                                  26000900
306400     IF '5285   ' =  B-OTHER-PROC-CODE1                           26001000
306500      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26001100
306600                       H-TECH-ADDON-ISLET-CNTR + 1.               26001200
306700                                                                  26001300
306800     IF '5285   ' =  B-OTHER-PROC-CODE2                           26001400
306900      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26001500
307000                       H-TECH-ADDON-ISLET-CNTR + 1.               26001600
307100                                                                  26001700
307200     IF '5285   ' =  B-OTHER-PROC-CODE3                           26001800
307300      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26001900
307400                       H-TECH-ADDON-ISLET-CNTR + 1.               26002000
307500                                                                  26002100
307600     IF '5285   ' =  B-OTHER-PROC-CODE4                           26002200
307700      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26002300
307800                       H-TECH-ADDON-ISLET-CNTR + 1.               26002400
307900                                                                  26002500
308000     IF '5285   ' =  B-OTHER-PROC-CODE5                           26002700
308100      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26002800
308200                       H-TECH-ADDON-ISLET-CNTR + 1.               26002900
308300                                                                  26003000
308400     IF '5285   ' =  B-OTHER-PROC-CODE6                           26001000
308500      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26001100
308600                       H-TECH-ADDON-ISLET-CNTR + 1.               26001200
308700                                                                  26001300
308800     IF '5285   ' =  B-OTHER-PROC-CODE7                           26001400
308900      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26001500
309000                       H-TECH-ADDON-ISLET-CNTR + 1.               26001600
309100                                                                  26001700
309200     IF '5285   ' =  B-OTHER-PROC-CODE8                           26001800
309300      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26001900
309400                       H-TECH-ADDON-ISLET-CNTR + 1.               26002000
309500                                                                  26002100
309600     IF '5285   ' =  B-OTHER-PROC-CODE9                           26002200
309700      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26002300
309800                       H-TECH-ADDON-ISLET-CNTR + 1.               26002400
309900                                                                  26002500
310000     IF '5285   ' =  B-OTHER-PROC-CODE10                          26002700
310100      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26002800
310200                       H-TECH-ADDON-ISLET-CNTR + 1.               26002900
310300                                                                  26003000
310400     IF '5285   ' =  B-OTHER-PROC-CODE11                          26001000
310500      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26001100
310600                       H-TECH-ADDON-ISLET-CNTR + 1.               26001200
310700                                                                  26001300
310800     IF '5285   ' =  B-OTHER-PROC-CODE12                          26001400
310900      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26001500
311000                       H-TECH-ADDON-ISLET-CNTR + 1.               26001600
311100                                                                  26001700
311200     IF '5285   ' =  B-OTHER-PROC-CODE13                          26001800
311300      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26001900
311400                       H-TECH-ADDON-ISLET-CNTR + 1.               26002000
311500                                                                  26002100
311600     IF '5285   ' =  B-OTHER-PROC-CODE14                          26002200
311700      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26002300
311800                       H-TECH-ADDON-ISLET-CNTR + 1.               26002400
311900                                                                  26002500
312000     IF '5285   ' =  B-OTHER-PROC-CODE15                          26002700
312100      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26002800
312200                       H-TECH-ADDON-ISLET-CNTR + 1.               26002900
312300                                                                  26003000
312400     IF '5285   ' =  B-OTHER-PROC-CODE16                          26001000
312500      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26001100
312600                       H-TECH-ADDON-ISLET-CNTR + 1.               26001200
312700                                                                  26001300
312800     IF '5285   ' =  B-OTHER-PROC-CODE17                          26001400
312900      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26001500
313000                       H-TECH-ADDON-ISLET-CNTR + 1.               26001600
313100                                                                  26001700
313200     IF '5285   ' =  B-OTHER-PROC-CODE18                          26001800
313300      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26001900
313400                       H-TECH-ADDON-ISLET-CNTR + 1.               26002000
313500                                                                  26002100
313600     IF '5285   ' =  B-OTHER-PROC-CODE19                          26002200
313700      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26002300
313800                       H-TECH-ADDON-ISLET-CNTR + 1.               26002400
313900                                                                  26002500
314000     IF '5285   ' =  B-OTHER-PROC-CODE20                          26002700
314100      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26002800
314200                       H-TECH-ADDON-ISLET-CNTR + 1.               26002900
314300                                                                  26002500
314400     IF '5285   ' =  B-OTHER-PROC-CODE21                          26002700
314500      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26002800
314600                       H-TECH-ADDON-ISLET-CNTR + 1.               26002900
314700                                                                  26002500
314800     IF '5285   ' =  B-OTHER-PROC-CODE22                          26002700
314900      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26002800
315000                       H-TECH-ADDON-ISLET-CNTR + 1.               26002900
315100                                                                  26002500
315200     IF '5285   ' =  B-OTHER-PROC-CODE23                          26002700
315300      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26002800
315400                       H-TECH-ADDON-ISLET-CNTR + 1.               26002900
315500                                                                  26002500
315600     IF '5285   ' =  B-OTHER-PROC-CODE24                          26002700
315700      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26002800
315800                       H-TECH-ADDON-ISLET-CNTR + 1.               26002900
315900                                                                  26002500
316000*    IF 'V707   ' =  B-PRIN-PROC-CODE                             26003100
316100*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =                          26003200
316200*                      H-TECH-ADDON-ISLET-CNTR2 + 1.              26003300
316300*                                                                 26003400
316400*    IF 'V707   ' =  B-OTHER-PROC-CODE1                           26003500
316500*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =                          26003600
316600*                      H-TECH-ADDON-ISLET-CNTR2 + 1.              26003700
316700*                                                                 26003800
316800*    IF 'V707   ' =  B-OTHER-PROC-CODE2                           26003900
316900*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =                          26004000
317000*                      H-TECH-ADDON-ISLET-CNTR2 + 1.              26004100
317100*                                                                 26004200
317200*    IF 'V707   ' =  B-OTHER-PROC-CODE3                           26004300
317300*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =                          26004400
317400*                      H-TECH-ADDON-ISLET-CNTR2 + 1.              26004500
317500*                                                                 26004600
317600*    IF 'V707   ' =  B-OTHER-PROC-CODE4                           26004700
317700*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =                          26004800
317800*                      H-TECH-ADDON-ISLET-CNTR2 + 1.              26004900
317900*                                                                 26005000
318000*    IF 'V707   ' =  B-OTHER-PROC-CODE5                           26005100
318100*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =                          26005200
318200*                    H-TECH-ADDON-ISLET-CNTR2 + 1.                26005300
318300*                                                                 26005400
318400*    IF  H-TECH-ADDON-ISLET-CNTR2 > 0                             26005500
318500*          NEXT SENTENCE                                          26005600
318600*    ELSE                                                         26005700
318700*          MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET                  26005800
318800*          GO TO 4100-ADD-TECH-CASES.                             26005900
318900                                                                  26006000
319000     IF  H-TECH-ADDON-ISLET-CNTR = 1                              26006100
319100     MOVE 18848.00 TO H-NEW-TECH-ADDON-ISLET                      26006200
319200           GO TO 4100-ADD-TECH-CASES.                             26006300
319300                                                                  26006400
319400     IF  H-TECH-ADDON-ISLET-CNTR > 1                              26006500
319500     MOVE 37696.00 TO H-NEW-TECH-ADDON-ISLET                      26006600
319600           GO TO 4100-ADD-TECH-CASES.                             26006700
319700                                                                  26006800
319800     MOVE 0 TO H-NEW-TECH-ADDON-ISLET.                            26006900
319900                                                                  26007000
320000                                                                  26008000
320100 4100-ADD-TECH-CASES.                                             26009000
320200                                                                  26009100
320300     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =                      26009200
320400             H-NEW-TECH-ADDON-ISLET.                              26009300
320500                                                                  26009400
320600 4100-EXIT.    EXIT.                                              26009500
320700                                                                  26009600
320800******        L A S T   S O U R C E   S T A T E M E N T   *****   26009700
