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