000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL10P.
000300*AUTHOR.            DDS TEAM    .
000400*REMARKS.                CMS.
000500 DATE-COMPILED.
000600 ENVIRONMENT DIVISION.
000700 CONFIGURATION SECTION.
000800 SOURCE-COMPUTER.            IBM-370.
000900 OBJECT-COMPUTER.            IBM-370.
001000 INPUT-OUTPUT  SECTION.
001100 FILE-CONTROL.
001200
001300 DATA DIVISION.
001400 FILE SECTION.
001500
001600 WORKING-STORAGE SECTION.
001700 01  W-STORAGE-REF                  PIC X(46)  VALUE
001800     'PPCAL10P      - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C10.P'.
002000 01  HMO-FLAG                       PIC X      VALUE 'N'.
002100 01  HMO-TAG                        PIC X      VALUE SPACE.
002200 01  OUTLIER-RECON-FLAG             PIC X      VALUE 'N'.
002300 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.
002400 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES.
002500 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES.
002600 01  WK-LOW-VOL25PCT                PIC 99V999 VALUE 01.000.
002700 01  WK-LOW-VOL-ADDON               PIC 9(07)V9(02).
002800 01  R1                             PIC S9(04) COMP SYNC.
002900 01  R2                             PIC S9(04) COMP SYNC.
003000 01  R3                             PIC S9(04) COMP SYNC.
003100 01  R4                             PIC S9(04) COMP SYNC.
003200 01  H-OPER-DSH-SCH                 PIC 9(01)V9(04).
003300 01  H-OPER-DSH-RRC                 PIC 9(01)V9(04).
003400
003500***************************************************************
003600**************YEARCHANGE 2010.7 *******************************
003700* TABLE 1                                                     *
003800*    (69.7% LABOR SHARE/30.3% NONLABOR SHARE)                 *
003900*    (FULL UPDATE (.697)                                      *
004000*    (QUALITY = 1 WAGE INDEX > 1)                             *
004100***************************************************************
004200 01  TB1-RATE-TABLE.
004300     02  TB1-RATE-WORK.
004400*RATE 20100401 REGION  LABOR AND NON-LABOR RATES
004500*                  R3=1     /     R3=2
004600*               LARGE URBAN / OTHER URBAN
004700*               LABOR / NON / LABOR / NON
004800*                     /LABOR/       /LABOR
004900*             --------------------------------------------
005000         05  FILLER PIC X(08) VALUE '20100401'.
005100         05  TB1-NAT    PIC X(30) VALUE
005200            ' 0358724 162678 0358724 162678'.
005300         05  TB1-PR     PIC X(30) VALUE
005400            ' 0154361 094207 0154361 094207'.
005500         05  TB1-NATPR  PIC X(30) VALUE
005600            ' 0358724 162678 0358724 162678'.
005700***************************************************************
005800     02  TB1-RATE-TAB REDEFINES TB1-RATE-WORK.
005900         05  TB1-RATE-PERIOD            OCCURS 1.
006000             10  TB1-RATE-EFF-DATE      PIC X(08).
006100             10  TB1-REG-NAT            OCCURS 3.
006200                 15  TB1-LARGE-OTHER    OCCURS 2.
006300                     20  FILLER         PIC X(01).
006400                     20  TB1-REG-LABOR  PIC 9(05)V9(02).
006500                     20  FILLER         PIC X(01).
006600                     20  TB1-REG-NLABOR PIC 9(04)V9(02).
006700
006800***************************************************************
006900************YEARCHANGE 2010.7 *********************************
007000* TABLE 2                                                     *
007100*    (69.7% LABOR SHARE/30.3% NONLABOR SHARE)                 *
007200*    (REDUCED UPDATE (.697)                                   *
007300*    (QUALITY NOT = 1 WAGE INDEX > 1)                         *
007400***************************************************************
007500 01  TB2-RATE-TABLE.
007600     02  TB2-RATE-WORK.
007700*RATE 20100401 REGION  LABOR AND NON-LABOR RATES
007800*                  R3=1     /     R3=2
007900*               LARGE URBAN / OTHER URBAN
008000*               LABOR / NON / LABOR / NON
008100*                     /LABOR/       /LABOR
008200*             --------------------------------------------
008300         05  FILLER PIC X(08) VALUE '20100401'.
008400         05  TB2-NAT    PIC X(30) VALUE
008500            ' 0351680 159484 0351680 159484'.
008600         05  TB2-PR     PIC X(30) VALUE
008700            ' 0154361 094207 0154361 094207'.
008800         05  TB2-NATPR  PIC X(30) VALUE
008900            ' 0351680 159480 0351680 159485'.
009000***************************************************************
009100     02  TB2-RATE-TAB REDEFINES TB2-RATE-WORK.
009200         05  TB2-RATE-PERIOD             OCCURS 1.
009300             10  TB2-RATE-EFF-DATE       PIC X(08).
009400             10  TB2-REG-NAT             OCCURS 3.
009500                 15  TB2-LARGE-OTHER     OCCURS 2.
009600                     20  FILLER          PIC X(01).
009700                     20  TB2-REG-LABOR   PIC 9(05)V9(02).
009800                     20  FILLER          PIC X(01).
009900                     20  TB2-REG-NLABOR  PIC 9(04)V9(02).
010000***************************************************************
010100************YEARCHANGE 2010.7 *********************************
010200* TABLE 3                                                     *
010300*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
010400*    (FULL UPDATE (.62%)                                      *
010500*    (QUALITY = 1 WAGE INDEX <= 1)                            *
010600***************************************************************
010700 01  TB3-RATE-TABLE.
010800     02  TB3-RATE-WORK.
010900*RATE 20100401 REGION  LABOR AND NON-LABOR RATES
011000*                  R3=1     /     R3=2
011100*               LARGE URBAN / OTHER URBAN
011200*               LABOR / NON / LABOR / NON
011300*                     /LABOR/       /LABOR
011400*             --------------------------------------------
011500         05  FILLER PIC X(08) VALUE '20100401'.
011600         05  TB3-NAT    PIC X(30) VALUE
011700            ' 0323269 198133 0323269 198133'.
011800         05  TB3-PR     PIC X(30) VALUE
011900            ' 0154112 094456 0154112 094456'.
012000         05  TB3-NATPR  PIC X(30) VALUE
012100            ' 0323269 198133 0323269 198133'.
012200****************************************************************
012300     02  TB3-RATE-TAB REDEFINES TB3-RATE-WORK.
012400         05  TB3-RATE-PERIOD            OCCURS 1.
012500             10  TB3-RATE-EFF-DATE      PIC X(08).
012600             10  TB3-REG-NAT            OCCURS 3.
012700                 15  TB3-LARGE-OTHER    OCCURS 2.
012800                     20  FILLER         PIC X(01).
012900                     20  TB3-REG-LABOR  PIC 9(05)V9(02).
013000                     20  FILLER         PIC X(01).
013100                     20  TB3-REG-NLABOR PIC 9(04)V9(02).
013200
013300***************************************************************
013400**********YEARCHANGE 2010.7 ***********************************
013500* TABLE 4                                                     *
013600*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
013700*    (REDUCED UPDATE (.62%)                                   *
013800*    (QUALITY NOT = 1 WAGE INDEX <=1)                         *
013900***************************************************************
014000 01  TB4-RATE-TABLE.
014100     02  TB4-RATE-WORK.
014200*RATE 20100401 REGION  LABOR AND NON-LABOR RATES
014300*                  R3=1     /     R3=2
014400*               LARGE URBAN / OTHER URBAN
014500*               LABOR / NON / LABOR / NON
014600*                     /LABOR/       /LABOR
014700*             --------------------------------------------
014800         05  FILLER PIC X(08) VALUE '20100401'.
014900         05  TB4-NAT    PIC X(30) VALUE
015000            ' 0316922 194242 0316922 194242'.
015100         05  TB4-PR     PIC X(30) VALUE
015200            ' 0154112 094456 0154112 094456'.
015300         05  TB4-NATPR  PIC X(30) VALUE
015400            ' 0316922 194242 0316922 194242'.
015500***************************************************************
015600     02  TB4-RATE-TAB REDEFINES TB4-RATE-WORK.
015700         05  TB4-RATE-PERIOD             OCCURS 1.
015800             10  TB4-RATE-EFF-DATE       PIC X(08).
015900             10  TB4-REG-NAT             OCCURS 3.
016000                 15  TB4-LARGE-OTHER     OCCURS 2.
016100                     20  FILLER          PIC X(01).
016200                     20  TB4-REG-LABOR   PIC 9(05)V9(02).
016300                     20  FILLER          PIC X(01).
016400                     20  TB4-REG-NLABOR  PIC 9(04)V9(02).
016500
016600 01  DRG-TABLE.
016700     05  D-TAB.
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.
067100         10  DRGX-PERIOD               OCCURS 1
067200                                        INDEXED BY DX5.
067300             15  DRGX-EFF-DATE         PIC X(08).
067400             15  DRG-DATA              OCCURS 1000
067500                                        INDEXED BY DX6.
067600                 20  DRG-WT            PIC 9(02)V9(04).
067700                 20  DRG-ALOS          PIC 9(02)V9(01).
067800                 20  DRG-DAYS-TRIM     PIC 9(02).
067900                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).
068000
068100*****YEARCHANGE 2010.0 ************************************
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  099317  05 CALIFORNIA                                '.
069500          05  FILLER   PIC X(58)  VALUE
069600     '06  099413  06 COLORADO                                  '.
069700         05  FILLER   PIC X(58)  VALUE
069800     '07  098016  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  099756  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  099783  16 IOWA                                      '.
071700         05  FILLER   PIC X(58)  VALUE
071800     '17  099827  17 KANSAS                                    '.
071900         05  FILLER   PIC X(58)  VALUE
072000     '18  099835  18 KENTUCKY                                  '.
072100         05  FILLER   PIC X(58)  VALUE
072200     '19  099834  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  099834  22 MASSACHUSETTS                             '.
072900         05  FILLER   PIC X(58)  VALUE
073000     '23  099833  23 MICHIGAN                                  '.
073100         05  FILLER   PIC X(58)  VALUE
073200     '24  099835  24 MINNESOTA                                 '.
073300         05  FILLER   PIC X(58)  VALUE
073400     '25  099834  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  099699  30 NEW HAMPSHIRE                             '.
074500         05  FILLER   PIC X(58)  VALUE
074600     '31  098587  31 NEW JERSEY                                '.
074700         05  FILLER   PIC X(58)  VALUE
074800     '32  099577  32 NEW MEXICO                                '.
074900         05  FILLER   PIC X(58)  VALUE
075000     '33  099835  33 NEW YORK                                  '.
075100         05  FILLER   PIC X(58)  VALUE
075200     '34  099834  34 NORTH CAROLINA                            '.
075300         05  FILLER   PIC X(58)  VALUE
075400     '35  099833  35 NORTH DAKOTA                              '.
075500         05  FILLER   PIC X(58)  VALUE
075600     '36  099784  36 OHIO                                      '.
075700         05  FILLER   PIC X(58)  VALUE
075800     '37  099835  37 OKLAHOMA                                  '.
075900         05  FILLER   PIC X(58)  VALUE
076000     '38  099708  38 OREGON                                    '.
076100         05  FILLER   PIC X(58)  VALUE
076200     '39  099834  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  099779  42 SOUTH CAROLINA                            '.
076900         05  FILLER   PIC X(58)  VALUE
077000     '43  099834  43 SOUTH DAKOTA                              '.
077100         05  FILLER   PIC X(58)  VALUE
077200     '44  099690  44 TENNESSEE                                 '.
077300         05  FILLER   PIC X(58)  VALUE
077400     '45  099832  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  099712  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  099317  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  099832  67 TEXAS                                     '.
080500         05  FILLER   PIC X(58)  VALUE
080600     '68  099756  68 FLORIDA                                   '.
080700         05  FILLER   PIC X(58)  VALUE
080800     '69  099756  69 FLORIDA                                   '.
080900         05  FILLER   PIC X(58)  VALUE
081000     '70  099827  70 KANSAS                                    '.
081100         05  FILLER   PIC X(58)  VALUE
081200     '71  099834  71 LOUISIANA                                 '.
081300         05  FILLER   PIC X(58)  VALUE
081400     '72  099784  72 OHIO                                      '.
081500         05  FILLER   PIC X(58)  VALUE
081600     '73  099834  73 PENNSYLVANIA                              '.
081700         05  FILLER   PIC X(58)  VALUE
081800     '74  099832  74 TEXAS                                     '.
081900         05  FILLER   PIC X(58)  VALUE
082000     '75  099317  75 CALIFORNIA                                '.
082100         05  FILLER   PIC X(58)  VALUE
082200     '76  099783  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 ************************************
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
086100 01  HOLD-AREA.
086200     02  HOLD-PPS-COMPONENTS.
086300         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
086400         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
086500
086600         05  H-OPER-HSP-PART              PIC 9(06)V9(09).
086700         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).
086800
086900         05  H-OPER-FSP-PART              PIC 9(06)V9(09).
087000         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).
087100         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).
087200
087300         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).
087400         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).
087500         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).
087600
087700         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).
087800         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).
087900
088000         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).
088100         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).
088200
088300         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).
088400         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).
088500
088600         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
088700         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).
088800         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).
088900         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
089000         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
089100         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
089200         05  H-CAPI-COLA                  PIC 9(01)V9(03).
089300         05  H-CAPI-SCH                   PIC 9(05)V9(02).
089400         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
089500         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
089600         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
089700         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
089800         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
089900         05  H-CAPI-GAF                   PIC 9(05)V9(04).
090000         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).
090100         05  H-BLEND-GAF                  PIC 9(05)V9(04).
090200         05  H-WAGE-INDEX                 PIC 9(02)V9(04).
090300         05  H-COV-DAYS                   PIC 9(3).
090400         05  H-PERDIEM-DAYS               PIC 9(3).
090500         05  H-REG-DAYS                   PIC 9(3).
090600         05  H-LTR-DAYS                   PIC 9(3).
090700         05  H-DSCHG-FRCTN                PIC 9(3)V9999.
090800         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
090900         05  H-ALOS                       PIC 9(02)V9(01).
091000         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
091100         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
091200         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
091300         05  H-CST-THRESH                 PIC 9(05)V9(02).
091400         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).
091500         05  H-BUDG-NUTR01                PIC 9(01)V9(06).
091600         05  H-BUDG-NUTR02                PIC 9(01)V9(06).
091700         05  H-BUDG-NUTR03                PIC 9(01)V9(06).
091800         05  H-BUDG-NUTR04                PIC 9(01)V9(06).
091900         05  H-BUDG-NUTR05                PIC 9(01)V9(06).
092000         05  H-BUDG-NUTR06                PIC 9(01)V9(06).
092100         05  H-BUDG-NUTR07                PIC 9(01)V9(06).
092200         05  H-BUDG-NUTR08                PIC 9(01)V9(06).
092300         05  H-BUDG-NUTR09                PIC 9(01)V9(06).
092400         05  H-BUDG-NUTR10                PIC 9(01)V9(06).
092500         05  H-BUDG-NUTR10D               PIC 9(01)V9(06).
092600         05  H-CASE-MIX-ADJ               PIC 9(01)V9(03).
092700         05  H-UPDATE-01                  PIC 9(01)V9(04).
092800         05  H-UPDATE-02                  PIC 9(01)V9(04).
092900         05  H-UPDATE-03                  PIC 9(01)V9(04).
093000         05  H-UPDATE-04                  PIC 9(01)V9(04).
093100         05  H-UPDATE-05                  PIC 9(01)V9(04).
093200         05  H-UPDATE-06                  PIC 9(01)V9(04).
093300         05  H-UPDATE-07                  PIC 9(01)V9(04).
093400         05  H-UPDATE-08                  PIC 9(01)V9(04).
093500         05  H-UPDATE-09                  PIC 9(01)V9(04).
093600         05  H-UPDATE-10                  PIC 9(01)V9(04).
093700         05  H-UPDATE-10D                 PIC 9(01)V9(04).
093800         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).
093900         05  H-HSP-UPDATE94               PIC 9(01)V9(04).
094000         05  H-HSP-UPDATE95               PIC 9(01)V9(04).
094100         05  H-HSP-UPDATE96               PIC 9(01)V9(04).
094200         05  H-HSP-UPDATE97               PIC 9(01)V9(04).
094300         05  H-HSP-UPDATE98               PIC 9(01)V9(04).
094400         05  H-HSP-UPDATE99               PIC 9(01)V9(04).
094500         05  H-HSP-UPDATE00               PIC 9(01)V9(04).
094600         05  H-HSP-UPDATE01               PIC 9(01)V9(04).
094700         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).
094800         05  H-FEDERAL-RATE               PIC 9(04)V9(02).
094900         05  H-LABOR-PCT                  PIC 9(01)V9(04).
095000         05  H-NONLABOR-PCT               PIC 9(01)V9(04).
095100         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).
095200         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).
095300         05  H-HSP-RATE                   PIC 9(06)V9(09).
095400         05  H-FSP-RATE                   PIC 9(06)V9(09).
095500         05  H-OUTLIER-OFFSET-NAT         PIC 9(01)V9(06).
095600         05  H-OUTLIER-OFFSET-PR          PIC 9(01)V9(06).
095700         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
095800         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
095900         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
096000         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
096100         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).
096200         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.
096300         05  H-BASE-DRG-PAYMENT           PIC S9(07)V99.
096400         05  H-NEW-TECH-ADDON-NEURO       PIC S9(07)V99.
096500         05  H-NEW-TECH-ADDON-GRAFT       PIC S9(07)V99.
096600         05  H-NEW-TECH-ADDON-X-STOP      PIC S9(07)V99.
096700         05  H-NEW-TECH-ADDON-HRTIMP-STOP PIC S9(07)V99.
096800         05  H-NEW-TECH-ADDON-ISLET       PIC S9(07)V99.
096900         05  H-NEW-TECH-ADDON-SPIRAT-STOP PIC S9(07)V99.
097000         05  H-TECH-ADDON-ISLET-CNTR      PIC S9(02).
097100         05  H-TECH-ADDON-ISLET-CNTR2     PIC S9(02).
097200
097300         05  H-LESSER-NEURO-1             PIC S9(07)V99.
097400         05  H-LESSER-NEURO-2             PIC S9(07)V99.
097500
097600         05  H-LESSER-GRAFT-1             PIC S9(07)V99.
097700         05  H-LESSER-GRAFT-2             PIC S9(07)V99.
097800
097900         05  H-LESSER-X-STOP-1            PIC S9(07)V99.
098000         05  H-LESSER-X-STOP-2            PIC S9(07)V99.
098100
098200         05  H-LESSER-HRTIMP-STOP-1       PIC S9(07)V99.
098300         05  H-LESSER-HRTIMP-STOP-2       PIC S9(07)V99.
098400
098500         05  H-LESSER-SPIRAT-STOP-1       PIC S9(07)V99.
098600         05  H-LESSER-SPIRAT-STOP-2       PIC S9(07)V99.
098700
098800         05  H-CSTMED-NEURO               PIC S9(07)V99.
098900         05  H-CSTMED-GRAFT               PIC S9(07)V99.
099000         05  H-CSTMED-X-STOP              PIC S9(07)V99.
099100         05  H-CSTMED-HRTIMP-STOP         PIC S9(07)V99.
099200         05  H-CSTMED-SPIRAT-STOP         PIC S9(07)V99.
099300
099400
099500     02  HOLD-ADDITIONAL-VARIABLES.
099600         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
099700         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
099800         05  H-NAT-PCT                    PIC 9(01)V9(02).
099900         05  H-REG-PCT                    PIC 9(01)V9(02).
100000         05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).
100100         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
100200         05  H-DRG-WT                     PIC 9(02)V9(04).
100300         05  H-NAT-LABOR                  PIC 9(05)V9(02).
100400         05  H-NAT-NONLABOR               PIC 9(05)V9(02).
100500         05  H-REG-LABOR                  PIC 9(05)V9(02).
100600         05  H-REG-NONLABOR               PIC 9(05)V9(02).
100700         05  H-OPER-COLA                  PIC 9(01)V9(03).
100800         05  H-INTERN-RATIO               PIC 9(01)V9(04).
100900         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
101000         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
101100         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
101200
101300     02  HOLD-CAPITAL-VARIABLES.
101400         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
101500         05  H-CAPI-HSP                   PIC 9(07)V9(02).
101600         05  H-CAPI-FSP                   PIC 9(07)V9(02).
101700         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
101800         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
101900         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
102000         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
102100         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
102200
102300     02  HOLD-CAPITAL2-VARIABLES.
102400         05  H-CAPI2-PAY-CODE             PIC X(1).
102500         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
102600         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
102700
102800     02  HOLD-OTHER-VARIABLES.
102900         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
103000         05  H-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
103100         05  H-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
103200         05  H-HVBP-HRR-DATA.
103300             10  H-VAL-BASED-PURCH-PARTIPNT PIC X.
103400             10  H-VAL-BASED-PURCH-ADJUST     PIC 9V9(11).
103500             10  H-HOSP-READMISS-REDUCTN      PIC X.
103600             10  H-HOSP-HRR-ADJUSTMT          PIC 9V9(4).
103700         05  H-OPERATNG-DATA.
103800             10  H-MODEL1-BUNDLE-DISPRCNT    PIC V999.
103900             10  H-OPER-BASE-DRG-PAY         PIC 9(08)V99.
104000             10  H-OPER-HSP-AMT              PIC 9(08)V99.
104100
104200     02  HOLD-PC-OTH-VARIABLES.
104300         05  H-OPER-DSH                   PIC 9(01)V9(04).
104400         05  H-CAPI-DSH                   PIC 9(01)V9(04).
104500         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
104600         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
104700         05  H-ARITH-ALOS                 PIC 9(02)V9(01).
104800         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).
104900         05  H-TRANSFER-ADJ               PIC 9(01)V9(05).
105000         05  H-PC-HMO-FLAG                PIC X(01).
105100         05  H-PC-COT-FLAG                PIC X(01).
105200         05  H-FILLER                     PIC X(0998).
105300
105400 01  HLD-PPS-DATA.
105500         10  HLD-PPS-RTC                PIC 9(02).
105600         10  HLD-PPS-WAGE-INDX          PIC 9(02)V9(04).
105700         10  HLD-PPS-OUTLIER-DAYS       PIC 9(03).
105800         10  HLD-PPS-AVG-LOS            PIC 9(02)V9(01).
105900         10  HLD-PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
106000         10  HLD-PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
106100         10  HLD-PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
106200         10  HLD-PPS-OPER-HSP-PART      PIC 9(06)V9(02).
106300         10  HLD-PPS-OPER-FSP-PART      PIC 9(06)V9(02).
106400         10  HLD-PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
106500         10  HLD-PPS-REG-DAYS-USED      PIC 9(03).
106600         10  HLD-PPS-LTR-DAYS-USED      PIC 9(02).
106700         10  HLD-PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
106800         10  HLD-PPS-CALC-VERS          PIC X(05).
106900
107000 LINKAGE SECTION.
107100***************************************************************
107200*                 * * * * * * * * *                           *
107300*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
107400*    IN HOW TO PAY THE BILL.                                  *
107500*                         *****                               *
107600*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *
107700*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *
107800*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *
107900*                 OUTLIER COMPUTATION.                        *
108000*                         *****                               *
108100*         REVIEW-CODE:                                        *
108200*            00 = PAY-WITH-OUTLIER.                           *
108300*                 WILL CALCULATE THE STANDARD PAYMENT.        *
108400*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *
108500*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *
108600*            03 = PAY-PERDIEM-DAYS.                           *
108700*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
108800*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
108900*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
109000*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
109100*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
109200*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
109300*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
109400*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
109500*                 BILL EXCEED THE COST THRESHOLD.             *
109600*            06 = PAY-XFER-NO-COST                            *
109700*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
109800*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
109900*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
110000*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
110100*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
110200*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
110300*                 CALCULATE ANY COST OUTLIER PORTION          *
110400*                 OF THE PAYMENT.                             *
110500*            07 = PAY-WITHOUT-COST.                           *
110600*                 WILL CALCULATE THE STANDARD PAYMENT         *
110700*                 WITHOUT COST PORTION.                       *
110800*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *
110900*                 50-50> 28  29  30  40  41  42  219
111000*                        220 221 477 478 479 480 481
111100*                        482 492 493 494 500 501 502
111200*                        515 516 517 495 496 497
111300* =======================================================
111400* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S
111500* =======================================================
111600*
111700*
111800*     FULL PERDIEM >   3   4   25  26  27  28          31
111900*                      32  33              54  55  56  57
112000*                      64  65  66  70  71  72  85  86  87
112100*                      91  92  93  100 101 163 164 165 166
112200*                      167 168 175 176 177 178 179 186 187
112300*                      188 190 191 192 193 194 195 196 197
112400*                      198 205 206 207 216 217 218
112500*                          228 229 230 233 234 235 236 239
112600*                      240 241 242 243 244 255 256 257 264
112700*                      280 281 282 288 289 290 291 292 293
112800*                      299 300 301 314 315 316 326 327 328
112900*                      329 330 331 332 333 334 335 336 337
113000*                      356 357 358 371 372 373 374 375 376
113100*                      377 378 379 380 381 382 388 389 390
113200*                      405 406 407 414 415 416 441 442 443
113300*                      459 460 463 464 465 466 467 468 469
113400*                      470 474 475 476
113500*                          483 484 488 489
113600*                                          510 511 512
113700*                              533 534 535 536 539 540 541
113800*                      542 543 544 545 546 547 551 552 557
113900*                      558 559 560 561 562 563 573 574 575
114000*                      579 580 581 592 593 594 602 603 616
114100*                      617 618 622 623 624 628 629 630 637
114200*                      638 639 640 641 643 644 645 653 654
114300*                      655 659 660 661 682 683 684 689 690
114400*                      698 699 700 840 841 842 853 854 855
114500*                      856 857 858 862 863 867 868 869 870
114600*                      871 872 884 896 897 907 908 909 917
114700*                      918 945 946 947 948 956 981 982 983
114800*                      987 988 989
114900*
115000*                               POST-ACUTE TRANSFERS          *
115100*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
115200*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
115300*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
115400*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
115500*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
115600*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
115700*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
115800*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
115900*                 BILL EXCEED THE COST THRESHOLD.             *
116000*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *
116100*                 POST-ACUTE TRANSFERS                        *
116200*                 50-50> 28  29  30  40  41  42  219
116300*                        220 221 477 478 479 480 481
116400*                        482 492 493 494 500 501 502
116500*                        515 516 517 495 496 497
116600*
116700* =======================================================
116800* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S
116900* =======================================================
117000*
117100*     FULL PERDIEM >     3   4   25  26  27              31
117200*                        32  33              54  55  56  57
117300*                        64  65  66  70  71  72  85  86  87
117400*                        91  92  93  100 101 163 164 165 166
117500*                        167 168 175 176 177 178 179 186 187
117600*                        188 190 191 192 193 194 195 196 197
117700*                        198 205 206 207 216 217 218
117800*                            228 229 230 233 234 235 236 239
117900*                        240 241 242 243 244 255 256 257 264
118000*                        280 281 282 288 289 290 291 292 293
118100*                        299 300 301 314 315 316 326 327 328
118200*                        329 330 331 332 333 334 335 336 337
118300*                        356 357 358 371 372 373 374 375 376
118400*                        377 378 379 380 381 382 388 389 390
118500*                        405 406 407 414 415 416 441 442 443
118600*                        459 460 463 464 465 466 467 468 469
118700*                        470 474 475 476
118800*                            483 484 488 489
118900*                                            510 511 512
119000*                                533 534 535 536 539 540 541
119100*                        542 543 544 545 546 547 551 552 557
119200*                        558 559 560 561 562 563 573 574 575
119300*                        579 580 581 592 593 594 602 603 616
119400*                        617 618 622 623 624 628 629 630 637
119500*                        638 639 640 641 643 644 645 653 654
119600*                        655 659 660 661 682 683 684 689 690
119700*                        698 699 700 840 841 842 853 854 855
119800*                        856 857 858 862 863 867 868 869 870
119900*                        871 872 884 896 897 907 908 909 917
120000*                        918 945 946 947 948 956 981 982 983
120100*                        987 988 989
120200*
120300*
120400*                               POST-ACUTE TRANSFERS          *
120500*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
120600*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
120700*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
120800*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
120900*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
121000*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
121100*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
121200*                 PAYMENT.                                    *
121300***************************************************************
121400
121500**************************************************************
121600*      MILLINNIUM COMPATIBLE                                 *
121700*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *
121800*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
121900*      IN THE NEW FORMAT                                     *
122000**************************************************************
122100 01  BILL-NEW-DATA.
122200         10  B-NPI10.
122300             15  B-NPI8             PIC X(08).
122400             15  B-NPI-FILLER       PIC X(02).
122500         10  B-PROVIDER-NO          PIC X(06).
122600         10  B-REVIEW-CODE          PIC 9(02).
122700             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.
122800             88  PAY-WITH-OUTLIER     VALUE 00 07.
122900             88  PAY-PERDIEM-DAYS     VALUE 03.
123000             88  PAY-XFER-NO-COST     VALUE 06.
123100             88  PAY-WITHOUT-COST     VALUE 07.
123200             88  PAY-XFER-SPEC-DRG    VALUE 09 11.
123300             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.
123400         10  B-DRG                  PIC 9(03).
123500             88  B-DRG-POSTACUTE-50-50
123600                   VALUE 28  29  30  40  41  42  219
123700                         220 221 477 478 479 480 481
123800                         482 492 493 494 495 496 497
123900                         500 501 502 515 516 517.
124000             88  B-DRG-SPIRATN-DRG
124100                   VALUE 163 164 165.
124200
124300* =======================================================
124400* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S
124500* =======================================================
124600*
124700             88  B-DRG-POSTACUTE-PERDIEM
124800                   VALUE 3   4   25  26  27              31
124900                         32  33              54  55  56  57
125000                         64  65  66  70  71  72  85  86  87
125100                         91  92  93  100 101 163 164 165 166
125200                         167 168 175 176 177 178 179 186 187
125300                         188 190 191 192 193 194 195 196 197
125400                         198 205 206 207 216 217 218
125500                             228 229 230 233 234 235 236 239
125600                         240 241 242 243 244 255 256 257 264
125700                         280 281 282 288 289 290 291 292 293
125800                         299 300 301 314 315 316 326 327 328
125900                         329 330 331 332 333 334 335 336 337
126000                         356 357 358 371 372 373 374 375 376
126100                         377 378 379 380 381 382 388 389 390
126200                         405 406 407 414 415 416 441 442 443
126300                         459 460 463 464 465 466 467 468 469
126400                         470 474 475 476
126500                             483 484 488 489
126600                                             510 511 512
126700                                 533 534 535 536 539 540 541
126800                         542 543 544 545 546 547 551 552 557
126900                         558 559 560 561 562 563 573 574 575
127000                         579 580 581 592 593 594 602 603 616
127100                         617 618 622 623 624 628 629 630 637
127200                         638 639 640 641 643 644 645 653 654
127300                         655 659 660 661 682 683 684 689 690
127400                         698 699 700 840 841 842 853 854 855
127500                         856 857 858 862 863 867 868 869 870
127600                         871 872 884 896 897 907 908 909 917
127700                         918 945 946 947 948 956 981 982 983
127800                         987 988 989.
127900
128000         10  B-LOS                  PIC 9(03).
128100         10  B-COVERED-DAYS         PIC 9(03).
128200         10  B-LTR-DAYS             PIC 9(02).
128300         10  B-DISCHARGE-DATE.
128400             15  B-DISCHG-CC        PIC 9(02).
128500             15  B-DISCHG-YY        PIC 9(02).
128600             15  B-DISCHG-MM        PIC 9(02).
128700             15  B-DISCHG-DD        PIC 9(02).
128800         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
128900         10  B-PRIN-PROC-CODE       PIC X(07).
129000         10  B-OTHER-PROC-CODE1     PIC X(07).
129100         10  B-OTHER-PROC-CODE2     PIC X(07).
129200         10  B-OTHER-PROC-CODE3     PIC X(07).
129300         10  B-OTHER-PROC-CODE4     PIC X(07).
129400         10  B-OTHER-PROC-CODE5     PIC X(07).
129500         10  B-OTHER-PROC-CODE6     PIC X(07).
129600         10  B-OTHER-PROC-CODE7     PIC X(07).
129700         10  B-OTHER-PROC-CODE8     PIC X(07).
129800         10  B-OTHER-PROC-CODE9     PIC X(07).
129900         10  B-OTHER-PROC-CODE10    PIC X(07).
130000         10  B-OTHER-PROC-CODE11    PIC X(07).
130100         10  B-OTHER-PROC-CODE12    PIC X(07).
130200         10  B-OTHER-PROC-CODE13    PIC X(07).
130300         10  B-OTHER-PROC-CODE14    PIC X(07).
130400         10  B-OTHER-PROC-CODE15    PIC X(07).
130500         10  B-OTHER-PROC-CODE16    PIC X(07).
130600         10  B-OTHER-PROC-CODE17    PIC X(07).
130700         10  B-OTHER-PROC-CODE18    PIC X(07).
130800         10  B-OTHER-PROC-CODE19    PIC X(07).
130900         10  B-OTHER-PROC-CODE20    PIC X(07).
131000         10  B-OTHER-PROC-CODE21    PIC X(07).
131100         10  B-OTHER-PROC-CODE22    PIC X(07).
131200         10  B-OTHER-PROC-CODE23    PIC X(07).
131300         10  B-OTHER-PROC-CODE24    PIC X(07).
131400         10  B-OTHER-DIAG-CODE1     PIC X(07).
131500         10  B-OTHER-DIAG-CODE2     PIC X(07).
131600         10  B-OTHER-DIAG-CODE3     PIC X(07).
131700         10  B-OTHER-DIAG-CODE4     PIC X(07).
131800         10  B-OTHER-DIAG-CODE5     PIC X(07).
131900         10  B-OTHER-DIAG-CODE6     PIC X(07).
132000         10  B-OTHER-DIAG-CODE7     PIC X(07).
132100         10  B-OTHER-DIAG-CODE8     PIC X(07).
132200         10  B-OTHER-DIAG-CODE9     PIC X(07).
132300         10  B-OTHER-DIAG-CODE10    PIC X(07).
132400         10  B-OTHER-DIAG-CODE11    PIC X(07).
132500         10  B-OTHER-DIAG-CODE12    PIC X(07).
132600         10  B-OTHER-DIAG-CODE13    PIC X(07).
132700         10  B-OTHER-DIAG-CODE14    PIC X(07).
132800         10  B-OTHER-DIAG-CODE15    PIC X(07).
132900         10  B-OTHER-DIAG-CODE16    PIC X(07).
133000         10  B-OTHER-DIAG-CODE17    PIC X(07).
133100         10  B-OTHER-DIAG-CODE18    PIC X(07).
133200         10  B-OTHER-DIAG-CODE19    PIC X(07).
133300         10  B-OTHER-DIAG-CODE20    PIC X(07).
133400         10  B-OTHER-DIAG-CODE21    PIC X(07).
133500         10  B-OTHER-DIAG-CODE22    PIC X(07).
133600         10  B-OTHER-DIAG-CODE23    PIC X(07).
133700         10  B-OTHER-DIAG-CODE24    PIC X(07).
133800         10  B-OTHER-DIAG-CODE25    PIC X(07).
133900         10  BILL-DEMO-DATA.
134000             15  BILL-DEMO-CODE1        PIC X(02).
134100             15  BILL-DEMO-CODE2        PIC X(02).
134200             15  BILL-DEMO-CODE3        PIC X(02).
134300             15  BILL-DEMO-CODE4        PIC X(02).
134400         10  BILL-NDC-DATA.
134500             15  BILL-NDC-NUMBER        PIC X(11).
134600         10  FILLER                     PIC X(73).
134700
134800
134900
135000***************************************************************
135100*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
135200*    AND PASSED BACK TO THE CALLING PROGRAM                   *
135300*            RETURN CODE VALUES (PPS-RTC)                     *
135400*                                                             *
135500*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
135600*                                                             *
135700*      PPS-RTC 30,33,40,42,44  = OUTLIER RECONCILIATION       *
135800*                                                             *
135900*           30,00 = PAID NORMAL DRG PAYMENT                   *
136000*                                                             *
136100*              01 = PAID AS A DAY-OUTLIER.                    *
136200*                   NOTE:                                     *
136300*                     DAY-OUTLIER NO LONGER BEING PAID        *
136400*                         AS OF 10/01/97                      *
136500*                                                             *
136600*              02 = PAID AS A COST-OUTLIER.                   *
136700*                                                             *
136800*           33,03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
136900*                   AND INCLUDING THE FULL DRG.               *
137000*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
137100*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
137200*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
137300*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
137400*                   AND INCLUDING THE FULL DRG. PROVIDER      *
137500*                   REFUSED COST OUTLIER.                     *
137600*           40,10 = POST-ACUTE TRANSFER                       *
137700*                   DRG = 28  29  30  40  41  42  219
137800*                         220 221 477 478 479 480 481
137900*                         482 492 493 494 500 501 502
138000*                         515 516 517
138100*
138200* =======================================================
138300* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S
138400* =======================================================
138500*
138600*           42,12 = POST-ACAUTE TRANSFER WITH SPECIFIC DRGS   *
138700*                       THE FOLLOWING DRG'S                   *
138800*                   DRG = 3   4   25  26  27              31
138900*                         32  33              54  55  56  57
139000*                         64  65  66  70  71  72  85  86  87
139100*                         91  92  93  100 101 163 164 165 166
139200*                         167 168 175 176 177 178 179 186 187
139300*                         188 190 191 192 193 194 195 196 197
139400*                         198 205 206 207 216 217 218
139500*                             228 229 230 233 234 235 236 239
139600*                         240 241 242 243 244 255 256 257 264
139700*                         280 281 282 288 289 290 291 292 293
139800*                         299 300 301 314 315 316 326 327 328
139900*                         329 330 331 332 333 334 335 336 337
140000*                         356 357 358 371 372 373 374 375 376
140100*                         377 378 379 380 381 382 388 389 390
140200*                         405 406 407 414 415 416 441 442 443
140300*                         459 460 463 464 465 466 467 468 469
140400*                         470 474 475 476
140500*                             483 484 488 489             495
140600*                         496 497             510 511 512
140700*                                 533 534 535 536 539 540 541
140800*                         542 543 544 545 546 547 551 552 557
140900*                         558 559 560 561 562 563 573 574 575
141000*                         579 580 581 592 593 594 602 603 616
141100*                         617 618 622 623 624 628 629 630 637
141200*                         638 639 640 641 643 644 645 653 654
141300*                         655 659 660 661 682 683 684 689 690
141400*                         698 699 700 840 841 842 853 854 855
141500*                         856 857 858 862 863 867 868 869 870
141600*                         871 872 884 896 897 907 908 909 917
141700*                         918 945 946 947 948 956 981 982 983
141800*                         987 988 989
141900*
142000*           44,14 = PAID NORMAL DRG PAYMENT WITH              *
142100*                    PERDIEM DAYS = OR > GM  ALOS             *
142200*              16 = PAID AS A COST-OUTLIER WITH               *
142300*                    PERDIEM DAYS = OR > GM  ALOS             *
142400*                                                             *
142500*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
142600*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
142700*              52 = INVALID CBSA# IN PROVIDER FILE            *
142800*                   OR INVALID WAGE INDEX                     *
142900*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
143000*              54 = INVALID DRG                               *
143100*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *
143200*                                      OR                     *
143300*                   DISCHARGE DATE < CBSA EFF START DATE      *
143400*                   FOR PPS                                   *
143500*                                      OR                     *
143600*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *
143700*                   DISCHARGE DATE                            *
143800*              56 = INVALID LENGTH OF STAY                    *
143900*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *
144000*                                        NOT 11)              *
144100*              58 = TOTAL CHARGES NOT NUMERIC                 *
144200*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
144300*                   OR BILL-LTR-DAYS > 60                     *
144400*              62 = INVALID NUMBER OF COVERED DAYS            *
144500*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *
144600*                   SPECIFIC FILE FOR CAPITAL                 *
144700*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *
144800*                   OR COST OUTLIER THRESHOLD CALUCULATION    *
144900*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
145000***************************************************************
145100 01  PPS-DATA.
145200         10  PPS-RTC                PIC 9(02).
145300         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
145400         10  PPS-OUTLIER-DAYS       PIC 9(03).
145500         10  PPS-AVG-LOS            PIC 9(02)V9(01).
145600         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
145700         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
145800         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
145900         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
146000         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
146100         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
146200         10  PPS-REG-DAYS-USED      PIC 9(03).
146300         10  PPS-LTR-DAYS-USED      PIC 9(02).
146400         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
146500         10  PPS-CALC-VERS          PIC X(05).
146600
146700******************************************************************
146800*            THESE ARE THE VERSIONS OF THE PPCAL
146900*           PROGRAMS THAT WILL BE PASSED BACK----
147000*          ASSOCIATED WITH THE BILL BEING PROCESSED
147100******************************************************************
147200 01  PRICER-OPT-VERS-SW.
147300     02  PRICER-OPTION-SW          PIC X(01).
147400         88  ALL-TABLES-PASSED          VALUE 'A'.
147500         88  PROV-RECORD-PASSED         VALUE 'P'.
147600         88  ADDITIONAL-VARIABLES       VALUE 'M'.
147700         88  PC-PRICER                  VALUE 'C'.
147800     02  PPS-VERSIONS.
147900         10  PPDRV-VERSION         PIC X(05).
148000
148100******************************************************************
148200*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
148300*          ASSOCIATED WITH THE BILL BEING PROCESSED
148400******************************************************************
148500 01  PPS-ADDITIONAL-VARIABLES.
148600     05  PPS-HSP-PCT                PIC 9(01)V9(02).
148700     05  PPS-FSP-PCT                PIC 9(01)V9(02).
148800     05  PPS-NAT-PCT                PIC 9(01)V9(02).
148900     05  PPS-REG-PCT                PIC 9(01)V9(02).
149000     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).
149100     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
149200     05  PPS-DRG-WT                 PIC 9(02)V9(04).
149300     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
149400     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
149500     05  PPS-REG-LABOR              PIC 9(05)V9(02).
149600     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
149700     05  PPS-OPER-COLA              PIC 9(01)V9(03).
149800     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
149900     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
150000     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
150100     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
150200     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
150300     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
150400     05  PPS-CAPITAL-VARIABLES.
150500         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
150600         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
150700         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
150800         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
150900         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
151000         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
151100         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
151200         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
151300     05  PPS-CAPITAL2-VARIABLES.
151400         10  PPS-CAPI2-PAY-CODE             PIC X(1).
151500         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
151600         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
151700
151800     05  PPS-OTHER-VARIABLES.
151900         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
152000         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
152100         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
152200         10  PPS-HVBP-HRR-DATA.
152300             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.
152400             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
152500             15  PPS-HOSP-READMISS-REDUCTN    PIC X.
152600             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
152700         10  PPS-OPERATNG-DATA.
152800             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
152900             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
153000             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
153100
153200     05  PPS-PC-OTH-VARIABLES.
153300         10  PPS-OPER-DSH                   PIC 9(01)V9(04).
153400         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).
153500         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).
153600         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).
153700         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).
153800         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).
153900         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(05).
154000         10  PPS-PC-HMO-FLAG                PIC X(01).
154100         10  PPS-PC-COT-FLAG                PIC X(01).
154200         10  PPS-FILLER                     PIC X(0998).
154300
154400 01  PROV-NEW-HOLD.
154500     02  PROV-NEWREC-HOLD1.
154600         05  P-NEW-NPI10.
154700             10  P-NEW-NPI8             PIC X(08).
154800             10  P-NEW-NPI-FILLER       PIC X(02).
154900         05  P-NEW-PROVIDER-NO.
155000             88  P-NEW-DSH-ADJ-PROVIDERS
155100                             VALUE '180049' '190044' '190144'
155200                                   '190191' '330047' '340085'
155300                                   '370016' '370149' '420043'.
155400             10  P-NEW-STATE            PIC 9(02).
155500             10  FILLER                 PIC X(04).
155600         05  P-NEW-DATE-DATA.
155700             10  P-NEW-EFF-DATE.
155800                 15  P-NEW-EFF-DT-CC    PIC 9(02).
155900                 15  P-NEW-EFF-DT-YY    PIC 9(02).
156000                 15  P-NEW-EFF-DT-MM    PIC 9(02).
156100                 15  P-NEW-EFF-DT-DD    PIC 9(02).
156200             10  P-NEW-FY-BEGIN-DATE.
156300                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
156400                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
156500                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
156600                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
156700             10  P-NEW-REPORT-DATE.
156800                 15  P-NEW-REPORT-DT-CC PIC 9(02).
156900                 15  P-NEW-REPORT-DT-YY PIC 9(02).
157000                 15  P-NEW-REPORT-DT-MM PIC 9(02).
157100                 15  P-NEW-REPORT-DT-DD PIC 9(02).
157200             10  P-NEW-TERMINATION-DATE.
157300                 15  P-NEW-TERM-DT-CC   PIC 9(02).
157400                 15  P-NEW-TERM-DT-YY   PIC 9(02).
157500                 15  P-NEW-TERM-DT-MM   PIC 9(02).
157600                 15  P-NEW-TERM-DT-DD   PIC 9(02).
157700         05  P-NEW-WAIVER-CODE          PIC X(01).
157800             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
157900         05  P-NEW-INTER-NO             PIC 9(05).
158000         05  P-NEW-PROVIDER-TYPE        PIC X(02).
158100             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
158200             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
158300                                                  '15' '17'
158400                                                  '22'.
158500             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
158600             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
158700             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
158800             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
158900             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
159000             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
159100             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
159200             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
159300             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
159400             88  P-N-EACH                   VALUE '21' '22'.
159500             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
159600             88  P-N-NHCMQ-II-SNF           VALUE '32'.
159700             88  P-N-NHCMQ-III-SNF          VALUE '33'.
159800         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
159900             88  P-N-NEW-ENGLAND            VALUE  1.
160000             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
160100             88  P-N-SOUTH-ATLANTIC         VALUE  3.
160200             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
160300             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
160400             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
160500             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
160600             88  P-N-MOUNTAIN               VALUE  8.
160700             88  P-N-PACIFIC                VALUE  9.
160800         05  P-NEW-CURRENT-DIV   REDEFINES
160900                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
161000             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
161100         05  P-NEW-MSA-DATA.
161200             10  P-NEW-CHG-CODE-INDEX       PIC X.
161300             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
161400             10  P-NEW-GEO-LOC-MSA9   REDEFINES
161500                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
161600             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
161700             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
161800             10  P-NEW-STAND-AMT-LOC-MSA9
161900       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
162000                 15  P-NEW-RURAL-1ST.
162100                     20  P-NEW-STAND-RURAL  PIC XX.
162200                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
162300                 15  P-NEW-RURAL-2ND        PIC XX.
162400         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
162500                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
162600                 88  P-NEW-SCH-YR82       VALUE   '82'.
162700                 88  P-NEW-SCH-YR87       VALUE   '87'.
162800         05  P-NEW-LUGAR                    PIC X.
162900         05  P-NEW-TEMP-RELIEF-IND          PIC X.
163000         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
163100         05  FILLER                         PIC X(05).
163200     02  PROV-NEWREC-HOLD2.
163300         05  P-NEW-VARIABLES.
163400             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
163500             10  P-NEW-COLA              PIC  9(01)V9(03).
163600             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
163700             10  P-NEW-BED-SIZE          PIC  9(05).
163800             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).
163900             10  P-NEW-CMI               PIC  9(01)V9(04).
164000             10  P-NEW-SSI-RATIO         PIC  V9(04).
164100             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
164200             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).
164300             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).
164400             10  P-NEW-DSH-PERCENT       PIC  V9(04).
164500             10  P-NEW-FYE-DATE          PIC  X(08).
164600         05  P-NEW-CBSA-DATA.
164700             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.
164800             10  P-NEW-CBSA-HOSP-QUAL-IND   PIC X.
164900             10  P-NEW-CBSA-GEO-LOC         PIC X(05) JUST RIGHT.
165000             10  P-NEW-CBSA-GEO-RURAL REDEFINES
165100                 P-NEW-CBSA-GEO-LOC.
165200                 15  P-NEW-CBSA-GEO-RURAL1ST PIC XXX.
165300                     88  P-NEW-CBSA-GEO-RURAL1    VALUE '   '.
165400                 15  P-NEW-CBSA-GEO-RURAL2ND PIC XX.
165500
165600             10  P-NEW-CBSA-RECLASS-LOC     PIC X(05) JUST RIGHT.
165700             10  P-NEW-CBSA-STAND-AMT-LOC   PIC X(05) JUST RIGHT.
165800             10  P-NEW-CBSA-SPEC-WAGE-INDEX    PIC 9(02)V9(04).
165900     02  PROV-NEWREC-HOLD3.
166000         05  P-NEW-PASS-AMT-DATA.
166100             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
166200             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
166300             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
166400             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
166500         05  P-NEW-CAPI-DATA.
166600             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
166700             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
166800             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
166900             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
167000             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
167100             15  P-NEW-CAPI-NEW-HOSP       PIC X.
167200             15  P-NEW-CAPI-IME            PIC 9V9999.
167300             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
167400         05  P-HVBP-HRR-DATA.
167500             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.
167600             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
167700             15  P-HOSP-READMISSION-REDUCTN PIC X.
167800             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
167900         05  P-MODEL1-BUNDLE-DATA.
168000             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
168100             15  P-HAC-REDUC-IND            PIC X.
168200             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
168300             15  P-EHR-REDUC-IND            PIC X.
168400         05  FILLER                         PIC X(09).
168500
168600******************************************************************
168700 01  WAGE-NEW-CBSA-INDEX-RECORD.
168800     05  W-CBSA                        PIC X(5).
168900     05  W-CBSA-SIZE                   PIC X.
169000         88  LARGE-URBAN       VALUE 'L'.
169100         88  OTHER-URBAN       VALUE 'O'.
169200         88  ALL-RURAL         VALUE 'R'.
169300     05  W-CBSA-EFF-DATE               PIC X(8).
169400     05  FILLER                        PIC X.
169500     05  W-CBSA-INDEX-RECORD           PIC S9(02)V9(04).
169600     05  W-CBSA-PR-INDEX-RECORD        PIC S9(02)V9(04).
169700
169800
169900 PROCEDURE DIVISION  USING BILL-NEW-DATA
170000                           PPS-DATA
170100                           PRICER-OPT-VERS-SW
170200                           PPS-ADDITIONAL-VARIABLES
170300                           PROV-NEW-HOLD
170400                           WAGE-NEW-CBSA-INDEX-RECORD.
170500
170600***************************************************************
170700*    PROCESSING:                                              *
170800*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
170900*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
171000*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
171100*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
171200*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
171300*           GOBACK.                                           *
171400*        D. ASSEMBLE PRICING COMPONENTS.                      *
171500*        E. CALCULATE THE PRICE.                              *
171600***************************************************************
171700
171800     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.
171900     MOVE 'N' TO TEMP-RELIEF-FLAG.
172000     MOVE 'N' TO OUTLIER-RECON-FLAG.
172100
172200     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.
172300
172400     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
172500     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
172600     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
172700     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
172800     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
172900     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
173000     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.
173100     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.
173200
173300     IF (PPS-RTC = '00' OR '03' OR '10' OR
173400                   '12' OR '14')
173500        MOVE 'Y' TO OUTLIER-RECON-FLAG
173600        MOVE PPS-DATA TO HLD-PPS-DATA
173700        PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT
173800        MOVE HLD-PPS-DATA TO PPS-DATA.
173900
174000     GOBACK.
174100
174200 0200-MAINLINE-CONTROL.
174300
174400     MOVE 'N' TO HMO-TAG.
174500
174600     IF PPS-PC-HMO-FLAG = 'Y' OR
174700               HMO-FLAG = 'Y'
174800        MOVE 'Y' TO HMO-TAG.
174900
175000     IF P-NEW-STATE NOT = 40
175100        MOVE ZEROES TO W-CBSA-PR-INDEX-RECORD.
175200
175300     MOVE ALL '0' TO PPS-DATA
175400                     H-OPER-DSH-SCH
175500                     H-OPER-DSH-RRC
175600                     HOLD-PPS-COMPONENTS
175700                     HOLD-PPS-COMPONENTS
175800                     HOLD-ADDITIONAL-VARIABLES
175900                     HOLD-CAPITAL-VARIABLES
176000                     HOLD-CAPITAL2-VARIABLES
176100                     HOLD-OTHER-VARIABLES
176200                     HOLD-PC-OTH-VARIABLES.
176300
176400     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC
176500        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.
176600
176700     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC
176800        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.
176900
177000     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC
177100        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.
177200
177300     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC
177400        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.
177500
177600
177700     PERFORM 1000-EDIT-THE-BILL-INFO.
177800
177900     IF  PPS-RTC = 00
178000         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
178100         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.
178200
178300     IF OUTLIER-RECON-FLAG = 'Y'
178400        MOVE 'N' TO OUTLIER-RECON-FLAG
178500        GO TO 0200-EXIT.
178600
178700     IF PPS-RTC = 00
178800        IF H-PERDIEM-DAYS = H-ALOS OR
178900           H-PERDIEM-DAYS > H-ALOS
179000           MOVE 14 TO PPS-RTC.
179100
179200     IF PPS-RTC = 02
179300        IF H-PERDIEM-DAYS = H-ALOS OR
179400           H-PERDIEM-DAYS > H-ALOS
179500           MOVE 16 TO PPS-RTC.
179600
179700 0200-EXIT.   EXIT.
179800
179900 1000-EDIT-THE-BILL-INFO.
180000
180100     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.
180200     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.
180300
180400     IF  PPS-RTC = 00
180500         IF  P-NEW-WAIVER-STATE
180600             MOVE 53 TO PPS-RTC.
180700
180800     IF  PPS-RTC = 00
180900         IF  B-DRG < 001
181000               OR = 014 OR = 015 OR = 016 OR = 017
181100               OR = 018 OR = 019 OR = 043 OR = 044
181200               OR = 045 OR = 046 OR = 047 OR = 048
181300               OR = 049 OR = 050 OR = 051 OR = 104
181400               OR = 105 OR = 106 OR = 107 OR = 108
181500               OR = 109 OR = 110 OR = 111 OR = 112
181600               OR = 118 OR = 119 OR = 120 OR = 126
181700               OR = 127 OR = 128 OR = 140 OR = 141
181800               OR = 142 OR = 143 OR = 144 OR = 145
181900               OR = 160 OR = 161 OR = 162 OR = 169
182000               OR = 170 OR = 171 OR = 172 OR = 173
182100               OR = 174 OR = 209 OR = 210 OR = 211
182200               OR = 212 OR = 213 OR = 214
182300               OR = 266 OR = 267 OR = 268 OR = 269
182400               OR = 270 OR = 271 OR = 272 OR = 273
182500               OR = 274 OR = 275 OR = 276 OR = 277
182600               OR = 278 OR = 279 OR = 317 OR = 318
182700               OR = 319 OR = 320 OR = 321 OR = 322
182800               OR = 323 OR = 324 OR = 325 OR = 359
182900               OR = 360 OR = 361 OR = 362 OR = 363
183000               OR = 364 OR = 365 OR = 366 OR = 367
183100               OR = 396 OR = 397 OR = 398 OR = 399
183200               OR = 400 OR = 401 OR = 402 OR = 403
183300               OR = 404 OR = 426 OR = 427 OR = 428
183400               OR = 429 OR = 430 OR = 431 OR = 447
183500               OR = 448 OR = 449 OR = 450 OR = 451
183600               OR = 452 OR = 518 OR = 519 OR = 520
183700               OR = 521 OR = 522 OR = 523 OR = 524
183800               OR = 525 OR = 526 OR = 527 OR = 528
183900               OR = 529 OR = 530 OR = 531 OR = 532
184000               OR = 567 OR = 568 OR = 569 OR = 570
184100               OR = 571 OR = 572 OR = 586 OR = 587
184200               OR = 588 OR = 589 OR = 590 OR = 591
184300               OR = 608 OR = 609 OR = 610 OR = 611
184400               OR = 612 OR = 613 OR = 631 OR = 632
184500               OR = 633 OR = 634 OR = 635 OR = 636
184600               OR = 646 OR = 647 OR = 648 OR = 649
184700               OR = 650 OR = 651 OR = 676 OR = 677
184800               OR = 678 OR = 679 OR = 680 OR = 681
184900               OR = 701 OR = 702 OR = 703 OR = 704
185000               OR = 705 OR = 706 OR = 719 OR = 720
185100               OR = 721 OR = 731 OR = 732 OR = 733
185200               OR = 751 OR = 752 OR = 753 OR = 762
185300               OR = 763 OR = 764 OR = 771 OR = 772
185400               OR = 773 OR = 783 OR = 784 OR = 785
185500               OR = 786 OR = 787 OR = 788 OR = 796
185600               OR = 797 OR = 798 OR = 805 OR = 806
185700               OR = 807 OR = 817 OR = 818 OR = 819
185800               OR = 831 OR = 832 OR = 833 OR = 850
185900               OR = 851 OR = 852 OR = 859 OR = 860
186000               OR = 861 OR = 873 OR = 874 OR = 875
186100               OR = 877 OR = 878 OR = 879
186200               OR = 888 OR = 889 OR = 890
186300               OR = 891 OR = 892
186400               OR = 893 OR = 898 OR = 899 OR = 900
186500               OR = 910 OR = 911 OR = 912 OR = 924
186600               OR = 925 OR = 926 OR = 930 OR = 931
186700               OR = 932 OR = 936 OR = 937 OR = 938
186800               OR = 942 OR = 943 OR = 944 OR = 952
186900               OR = 953 OR = 954 OR = 960 OR = 961
187000               OR = 962 OR = 966 OR = 967 OR = 968
187100               OR = 971 OR = 972 OR = 973 OR = 978
187200               OR = 979 OR = 980 OR = 990 OR = 991
187300               OR = 992 OR = 993 OR = 994 OR = 995
187400               OR = 996 OR = 997
187500             MOVE 54 TO PPS-RTC.
187600
187700     IF  PPS-RTC = 00
187800            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR
187900                 (B-DISCHARGE-DATE < W-CBSA-EFF-DATE))
188000                MOVE 55 TO PPS-RTC.
188100
188200     IF  PPS-RTC = 00
188300         IF P-NEW-TERMINATION-DATE > 00000000
188400            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR
188500                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))
188600                  MOVE 55 TO PPS-RTC.
188700
188800     IF  PPS-RTC = 00
188900         IF  B-LOS NOT NUMERIC
189000             MOVE 56 TO PPS-RTC
189100         ELSE
189200         IF  B-LOS = 0
189300             IF B-REVIEW-CODE NOT = 00 AND
189400                              NOT = 03 AND
189500                              NOT = 06 AND
189600                              NOT = 07 AND
189700                              NOT = 09 AND
189800                              NOT = 11
189900             MOVE 56 TO PPS-RTC.
190000
190100     IF  PPS-RTC = 00
190200         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
190300             MOVE 61 TO PPS-RTC
190400         ELSE
190500             MOVE B-LTR-DAYS TO H-LTR-DAYS.
190600
190700     IF  PPS-RTC = 00
190800         IF  B-COVERED-DAYS NOT NUMERIC
190900             MOVE 62 TO PPS-RTC
191000         ELSE
191100         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
191200             MOVE 62 TO PPS-RTC
191300         ELSE
191400             MOVE B-COVERED-DAYS TO H-COV-DAYS.
191500
191600     IF  PPS-RTC = 00
191700         IF  H-LTR-DAYS  > H-COV-DAYS
191800             MOVE 62 TO PPS-RTC
191900         ELSE
192000             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
192100
192200     IF  PPS-RTC = 00
192300         IF  NOT VALID-REVIEW-CODE
192400             MOVE 57 TO PPS-RTC.
192500
192600     IF  PPS-RTC = 00
192700         IF  B-CHARGES-CLAIMED NOT NUMERIC
192800             MOVE 58 TO PPS-RTC.
192900
193000     IF PPS-RTC = 00
193100           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'
193200                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND
193300                                            NOT = 'B' AND
193400                                            NOT = 'C'
193500                 MOVE 65 TO PPS-RTC.
193600
193700 2000-ASSEMBLE-PPS-VARIABLES.
193800***  GET THE PROVIDER SPECIFIC VARIABLES.
193900***  GET THE PROVIDER SPECIFIC VARIABLES.
194000
194100     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.
194200     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.
194300
194400     IF  (P-NEW-STATE = 02 OR 12)
194500         MOVE P-NEW-COLA TO H-OPER-COLA
194600     ELSE
194700         MOVE 1.000  TO H-OPER-COLA.
194800
194900***************************************************************
195000***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
195100***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
195200
195300     PERFORM 2600-GET-DRG-WEIGHT
195400             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
195500
195600***************************************************************
195700***  GET THE WAGE-INDEX
195800***  GET THE WAGE-INDEX
195900
196000     MOVE W-CBSA-INDEX-RECORD TO H-WAGE-INDEX.
196100     MOVE W-CBSA-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.
196200     MOVE P-NEW-STATE            TO MES-PPS-STATE.
196300
196400
196500     PERFORM 4200-SSRFBN-CODE-RTN THRU 4200-EXIT.
196600
196700*****YEARCHANGE 2009.3 ************************************
196800
196900     IF  P-NEW-CBSA-SPEC-PAY-IND = '1' OR '2'
197000       COMPUTE H-WAGE-INDEX ROUNDED =
197100                         H-WAGE-INDEX * 1
197200     ELSE
197300       COMPUTE H-WAGE-INDEX ROUNDED =
197400                         H-WAGE-INDEX * MES-SSRFBN-RATE.
197500
197600*****YEARCHANGE 2009.3 ************************************
197700
197800***************************************************************
197900***  GET THE LABOR, NON-LABOR STANDARD RATES
198000
198100     IF  P-NEW-STATE = 40
198200         MOVE 2 TO R2
198300         MOVE 3 TO R4
198400     ELSE
198500         MOVE 1 TO R2
198600         MOVE 1 TO R4.
198700
198800     IF  LARGE-URBAN
198900         MOVE 1 TO R3
199000     ELSE
199100         MOVE 2 TO R3.
199200
199300     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
199400        (H-WAGE-INDEX > 01.0000))
199500        PERFORM 2300-GET-LAB-NONLAB-TB1-RATES
199600             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
199700
199800     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
199900         (H-WAGE-INDEX > 01.0000))
200000        PERFORM 2300-GET-LAB-NONLAB-TB2-RATES
200100             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
200200
200300     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
200400         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
200500        PERFORM 2300-GET-LAB-NONLAB-TB3-RATES
200600             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
200700
200800     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
200900         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
201000        PERFORM 2300-GET-LAB-NONLAB-TB4-RATES
201100             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
201200
201300     IF P-NEW-STATE = 40
201400        IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
201500            (H-PR-WAGE-INDEX > 01.0000))
201600             PERFORM 2300-GET-PR-LAB-TB1-RATES
201700             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
201800
201900
202000     IF P-NEW-STATE = 40
202100        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
202200             (H-PR-WAGE-INDEX > 01.0000))
202300              PERFORM 2300-GET-PR-LAB-TB2-RATES
202400                  VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
202500
202600     IF P-NEW-STATE = 40
202700        IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
202800         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
202900          PERFORM 2300-GET-PR-LAB-TB3-RATES
203000              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
203100
203200     IF P-NEW-STATE = 40
203300        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
203400         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
203500          PERFORM 2300-GET-PR-LAB-TB4-RATES
203600              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
203700
203800***************************************************************
203900***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
204000***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
204100
204200     MOVE 0.00  TO H-OPER-HSP-PCT.
204300     MOVE 1.00  TO H-OPER-FSP-PCT.
204400
204500***************************************************************
204600***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
204700***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
204800
204900      MOVE 1.00 TO H-NAT-PCT.
205000      MOVE 0.00 TO H-REG-PCT.
205100
205200     IF  P-NEW-STATE = 40
205300         MOVE 0.75 TO H-NAT-PCT
205400         MOVE 0.25 TO H-REG-PCT.
205500
205600     IF  P-N-SCH-REBASED-FY90 OR
205700         P-N-EACH OR
205800         P-N-MDH-REBASED-FY90
205900         MOVE 1.00 TO H-OPER-HSP-PCT.
206000
206100 2300-GET-LAB-NONLAB-TB1-RATES.
206200
206300     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
206400         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
206500         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
206600         MOVE TB1-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
206700         MOVE TB1-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
206800
206900 2300-GET-LAB-NONLAB-TB2-RATES.
207000
207100     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
207200         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
207300         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
207400         MOVE TB2-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
207500         MOVE TB2-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
207600
207700 2300-GET-LAB-NONLAB-TB3-RATES.
207800
207900     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
208000         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
208100         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
208200         MOVE TB3-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
208300         MOVE TB3-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
208400
208500 2300-GET-LAB-NONLAB-TB4-RATES.
208600
208700     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
208800         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
208900         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
209000         MOVE TB4-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
209100         MOVE TB4-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
209200
209300 2300-GET-PR-LAB-TB1-RATES.
209400
209500     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
209600         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
209700         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
209800
209900 2300-GET-PR-LAB-TB2-RATES.
210000
210100     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
210200         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
210300         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
210400
210500 2300-GET-PR-LAB-TB3-RATES.
210600
210700     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
210800         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
210900         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
211000
211100 2300-GET-PR-LAB-TB4-RATES.
211200
211300     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
211400         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
211500         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
211600
211700
211800 2600-GET-DRG-WEIGHT.
211900
212000     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)
212100         SET DX6 TO B-DRG
212200         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT
212300         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS
212400         MOVE ZEROES                   TO H-DAYS-CUTOFF
212500         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.
212600
212700 3000-CALC-PAYMENT.
212800***************************************************************
212900
213000     PERFORM 3100-CALC-STAY-UTILIZATION.
213100     PERFORM 3300-CALC-OPER-FSP-AMT.
213200     PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT.
213300
213400***********************************************************
213500***  OPERATING IME CALCULATION
213600***  OPERATING IME CALCULATION
213700
213800     COMPUTE H-OPER-IME-TEACH ROUNDED =
213900            1.35 * ((1 + H-INTERN-RATIO) ** .405  - 1).
214000
214100***********************************************************
214200
214300     IF P-N-SCH-REBASED-FY90 OR
214400        P-N-EACH OR
214500        P-N-MDH-REBASED-FY90
214600         PERFORM 3450-CALC-ADDITIONAL-HSP.
214700
214800     MOVE 00                 TO  PPS-RTC.
214900     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
215000     MOVE H-ALOS             TO  PPS-AVG-LOS.
215100     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
215200
215300     MOVE B-LOS TO H-PERDIEM-DAYS.
215400     IF H-PERDIEM-DAYS < 1
215500         MOVE 1 TO H-PERDIEM-DAYS.
215600     ADD 1 TO H-PERDIEM-DAYS.
215700
215800     MOVE 1 TO H-DSCHG-FRCTN.
215900
216000     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.
216100
216200     IF (PAY-PERDIEM-DAYS  OR
216300         PAY-XFER-NO-COST) OR
216400        (PAY-XFER-SPEC-DRG AND
216500         B-DRG-POSTACUTE-PERDIEM)
216600         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
216700         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS
216800         IF H-DSCHG-FRCTN > 1
216900              MOVE 1 TO H-DSCHG-FRCTN
217000              MOVE 1 TO H-TRANSFER-ADJ
217100         ELSE
217200              COMPUTE H-DRG-WT-FRCTN ROUNDED =
217300                  (H-PERDIEM-DAYS / H-ALOS) * H-DRG-WT.
217400
217500     IF (PAY-XFER-SPEC-DRG AND
217600         B-DRG-POSTACUTE-50-50)
217700         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
217800         COMPUTE H-DSCHG-FRCTN  ROUNDED =
217900                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)
218000         IF H-DSCHG-FRCTN > 1
218100              MOVE 1 TO H-DSCHG-FRCTN
218200              MOVE 1 TO H-TRANSFER-ADJ
218300         ELSE
218400              COMPUTE H-DRG-WT-FRCTN ROUNDED =
218500            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.
218600
218700
218800***********************************************************
218900***  CAPITAL DSH CALCULATION
219000***  CAPITAL DSH CALCULATION
219100
219200     MOVE 0 TO H-CAPI-DSH.
219300
219400     IF P-NEW-BED-SIZE NOT NUMERIC
219500         MOVE 0 TO P-NEW-BED-SIZE.
219600
219700     IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
219800         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
219900                  (.2025 * (P-NEW-SSI-RATIO
220000                          + P-NEW-MEDICAID-RATIO)) - 1.
220100
220200***********************************************************
220300***  CAPITAL IME TEACH CALCULATION
220400***  CAPITAL IME TEACH CALCULATION
220500
220600     MOVE 0 TO H-WK-CAPI-IME-TEACH.
220700
220800     IF P-NEW-CAPI-IME NUMERIC
220900        IF P-NEW-CAPI-IME > 1.5000
221000           MOVE 1.5000 TO P-NEW-CAPI-IME.
221100
221200*****YEARCHANGE 2009.5 ****************************************
221300***
221400***  PER POLICY, WE REMOVED THE .5 MULTIPLER
221500***
221600***********************************************************
221700     IF P-NEW-CAPI-IME NUMERIC
221800        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =
221900         ((2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1).
222000
222100*****YEARCHANGE 2009.5 ****************************************
222200***********************************************************
222300     MOVE 0.00 TO H-DAYOUT-PCT.
222400     MOVE 0.80 TO H-CSTOUT-PCT.
222500
222600******************************************************************
222700**
222800** BURN DRGS FOR FY09 ARE 927, 928, 929, 933, 934 AND 935.
222900**
223000******************************************************************
223100
223200     IF  B-DRG = 927 OR 928 OR 929 OR 933 OR 934 OR 935
223300             MOVE 0.90 TO H-CSTOUT-PCT.
223400
223500***     NATIONAL PERCENTAGE
223600     MOVE 0.6880   TO H-LABOR-PCT.
223700     MOVE 0.3120   TO H-NONLABOR-PCT.
223800
223900***     PUERTO RICO PERCENTAGE
224000     MOVE 0.6210   TO H-PR-LABOR-PCT.
224100     MOVE 0.3790   TO H-PR-NONLABOR-PCT.
224200
224300     IF (H-WAGE-INDEX < 01.0000 OR
224400         H-WAGE-INDEX = 01.0000)
224500        MOVE 0.6200 TO H-LABOR-PCT
224600        MOVE 0.3800 TO H-NONLABOR-PCT.
224700***       ??????????
224800     IF P-NEW-STATE = 40
224900       IF (H-PR-WAGE-INDEX < 01.0000 OR
225000           H-PR-WAGE-INDEX = 01.0000)
225100          MOVE 0.6200 TO H-PR-LABOR-PCT
225200          MOVE 0.3800 TO H-PR-NONLABOR-PCT.
225300
225400
225500     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC
225600             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
225700     ELSE
225800             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
225900
226000     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC
226100             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
226200     ELSE
226300             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
226400
226500***********************************************************
226600*****YEARCHANGE 2010.0 ************************************
226700***  CAPITAL PAYMENT METHOD B - YEARCHNG
226800***  CAPITAL PAYMENT METHOD B
226900
227000     IF W-CBSA-SIZE = 'L'
227100        MOVE 1.00 TO H-CAPI-LARG-URBAN
227200     ELSE
227300        MOVE 1.00 TO H-CAPI-LARG-URBAN.
227400
227500     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).
227600     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).
227700
227800*****YEARCHANGE 2010.7 ************************************
227900     COMPUTE H-FEDERAL-RATE ROUNDED =
228000                                 (0429.56 * H-CAPI-GAF).
228100     COMPUTE H-PUERTO-RICO-RATE ROUNDED =
228200                                 (0203.57 * H-PR-CAPI-GAF).
228300*****YEARCHANGE 2010.7 ************************************
228400
228500     COMPUTE H-CAPI-COLA ROUNDED =
228600                     (.3152 * (H-OPER-COLA - 1) + 1).
228700
228800     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
228900
229000     IF P-NEW-STATE = 40
229100        COMPUTE  H-CAPI-FED-RATE ROUNDED =
229200                 (H-NAT-PCT * H-FEDERAL-RATE) +
229300                 (H-REG-PCT * H-PUERTO-RICO-RATE).
229400***********************************************************
229500***  CAPITAL FSP CALCULATION
229600***  CAPITAL FSP CALCULATION
229700
229800     COMPUTE H-CAPI-FSP-PART ROUNDED =
229900                               H-DRG-WT * H-CAPI-FED-RATE *
230000                               H-CAPI-COLA *
230100                               H-CAPI-LARG-URBAN.
230200
230300***********************************************************
230400***  CAPITAL PAYMENT METHOD A
230500***  CAPITAL PAYMENT METHOD A
230600
230700     IF P-N-SCH-REBASED-FY90 OR P-N-EACH
230800        MOVE 1.00 TO H-CAPI-SCH
230900     ELSE
231000        MOVE 0.85 TO H-CAPI-SCH.
231100
231200***********************************************************
231300***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
231400***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
231500
231600     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
231700                    (P-NEW-CAPI-OLD-HARM-RATE *
231800                    H-CAPI-SCH).
231900
232000***********************************************************
232100        IF PAY-PERDIEM-DAYS
232200            IF  H-PERDIEM-DAYS < H-ALOS
232300                IF  NOT (B-DRG = 789)
232400                    PERFORM 3500-CALC-PERDIEM-AMT
232500                    MOVE 03 TO PPS-RTC.
232600
232700        IF PAY-XFER-SPEC-DRG
232800            IF  H-PERDIEM-DAYS < H-ALOS
232900                IF  NOT (B-DRG = 789)
233000                    PERFORM 3550-CALC-PERDIEM-AMT.
233100
233200        IF  PAY-XFER-NO-COST
233300            MOVE 00 TO PPS-RTC
233400            IF H-PERDIEM-DAYS < H-ALOS
233500               IF  NOT (B-DRG = 789)
233600                   PERFORM 3500-CALC-PERDIEM-AMT
233700                   MOVE 06 TO PPS-RTC.
233800
233900     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.
234000
234100     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.
234200
234300     IF OUTLIER-RECON-FLAG = 'Y' GO TO 3000-EXIT.
234400
234500     IF PPS-RTC = 67  GO TO 3000-CONTINUE.
234600
234700        IF PAY-XFER-SPEC-DRG
234800            IF  H-PERDIEM-DAYS < H-ALOS
234900                IF  NOT (B-DRG = 789)
235000                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.
235100
235200
235300        IF  PAY-PERDIEM-DAYS
235400            IF  H-OPER-OUTCST-PART > 0
235500                MOVE H-OPER-OUTCST-PART TO
235600                     H-OPER-OUTLIER-PART
235700                MOVE 05 TO PPS-RTC
235800            ELSE
235900            IF  PPS-RTC NOT = 03
236000                MOVE 00 TO PPS-RTC
236100                MOVE 0  TO H-OPER-OUTLIER-PART.
236200
236300        IF  PAY-PERDIEM-DAYS
236400            IF  H-CAPI-OUTCST-PART > 0
236500                MOVE H-CAPI-OUTCST-PART TO
236600                     H-CAPI-OUTLIER-PART
236700                MOVE 05 TO PPS-RTC
236800            ELSE
236900            IF  PPS-RTC NOT = 03
237000                MOVE 0  TO H-CAPI-OUTLIER-PART.
237100
237200
237300 3000-CONTINUE.
237400
237500***********************************************************
237600***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
237700***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
237800
237900     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.
238000
238100***********************************************************
238200
238300     IF  PPS-RTC = 67
238400         MOVE H-OPER-DOLLAR-THRESHOLD TO
238500              WK-H-OPER-DOLLAR-THRESHOLD.
238600
238700     IF  PPS-RTC < 50
238800         PERFORM 3800-CALC-TOT-AMT
238900     ELSE
239000         MOVE ALL '0' TO PPS-OPER-HSP-PART
239100                         PPS-OPER-FSP-PART
239200                         PPS-OPER-OUTLIER-PART
239300                         PPS-OUTLIER-DAYS
239400                         PPS-REG-DAYS-USED
239500                         PPS-LTR-DAYS-USED
239600                         PPS-TOTAL-PAYMENT
239700                         PPS-OPER-DSH-ADJ
239800                         PPS-OPER-IME-ADJ
239900                         H-DSCHG-FRCTN
240000                         H-DRG-WT-FRCTN
240100                         HOLD-ADDITIONAL-VARIABLES
240200                         HOLD-CAPITAL-VARIABLES
240300                         HOLD-CAPITAL2-VARIABLES
240400                         HOLD-OTHER-VARIABLES
240500                         HOLD-PC-OTH-VARIABLES.
240600
240700     IF  PPS-RTC = 67
240800         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO
240900                 H-OPER-DOLLAR-THRESHOLD.
241000
241100 3000-EXIT.  EXIT.
241200
241300 3100-CALC-STAY-UTILIZATION.
241400
241500     MOVE 0 TO PPS-REG-DAYS-USED.
241600     MOVE 0 TO PPS-LTR-DAYS-USED.
241700
241800     IF H-REG-DAYS > 0
241900        IF H-REG-DAYS > B-LOS
242000           MOVE B-LOS TO PPS-REG-DAYS-USED
242100        ELSE
242200           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
242300     ELSE
242400        IF H-LTR-DAYS > B-LOS
242500           MOVE B-LOS TO PPS-LTR-DAYS-USED
242600        ELSE
242700           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.
242800
242900
243000
243100 3300-CALC-OPER-FSP-AMT.
243200***********************************************************
243300***  OPERATING FSP CALCULATION
243400***  OPERATING FSP CALCULATION
243500
243600     COMPUTE H-OPER-FSP-PART ROUNDED =
243700           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
243800            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
243900                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
244000
244100     IF P-NEW-STATE = 40
244200       COMPUTE H-OPER-FSP-PART ROUNDED =
244300           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
244400            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
244500                           +
244600           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
244700            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
244800                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
244900
245000
245100 3450-CALC-ADDITIONAL-HSP.
245200***********************************************************
245300*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
245400*    SOLE COMMUNITY
245500*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
245600*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
245700***********************************************************
245800*****YEARCHANGE 2010.0 ****************************************
245900***         GET THE UPDATING FACTOR
246000***         GET THE UPDATING FACTOR
246100
246200     MOVE 0.995743 TO H-BUDG-NUTR08.
246300     MOVE 0.998795 TO H-BUDG-NUTR09.
246400*****YEARCHANGE 2010.0 ****************************************
246500     MOVE 0.997941 TO H-BUDG-NUTR10.
246600*****YEARCHANGE 2010.7 ****************************************
246700     MOVE 0.997935 TO H-BUDG-NUTR10D.
246800*****YEARCHANGE 2010.7 ****************************************
246900
247000     MOVE 1.0330 TO H-UPDATE-08.
247100
247200*****YEARCHANGE 2009.0 ****************************************
247300     MOVE 1.0360 TO H-UPDATE-09.
247400*****YEARCHANGE 2009.0 ****************************************
247500
247600     IF P-NEW-CBSA-HOSP-QUAL-IND = '1'
247700*****YEARCHANGE 2010.0 ****************************************
247800        MOVE 1.0210 TO H-UPDATE-10
247900     ELSE
248000        MOVE 1.0010 TO H-UPDATE-10.
248100*****YEARCHANGE 2010.0 ****************************************
248200
248300     IF P-NEW-CBSA-HOSP-QUAL-IND = '1'
248400*****YEARCHANGE 2010.7 ****************************************
248500        MOVE 1.0185 TO H-UPDATE-10D
248600     ELSE
248700        MOVE 0.9985 TO H-UPDATE-10D.
248800*****YEARCHANGE 2010.7 ****************************************
248900
249000     IF P-NEW-STATE = 40
249100*****YEARCHANGE 2010.7 ****************************************
249200        MOVE 1.0210 TO H-UPDATE-10D.
249300*****YEARCHANGE 2010.7 ****************************************
249400
249500     COMPUTE H-UPDATE-FACTOR ROUNDED =
249600                       (H-UPDATE-08 * H-UPDATE-09 *
249700                        H-UPDATE-10D *
249800                        H-BUDG-NUTR08 * H-BUDG-NUTR09 *
249900                                        H-BUDG-NUTR10D).
250000
250100     COMPUTE H-HSP-RATE ROUNDED =
250200         H-FAC-SPEC-RATE * H-UPDATE-FACTOR.
250300***************************************************************
250400*
250500*    IF P-NEW-CBSA-HOSP-QUAL-IND = '1'
250600*       COMPUTE H-HSP-RATE ROUNDED =
250700*        (H-FAC-SPEC-RATE * 1) * H-UPDATE-FACTOR
250800*    ELSE
250900*       COMPUTE H-HSP-RATE ROUNDED =
251000*        ((H-FAC-SPEC-RATE / 1.036) * 1.016) * H-UPDATE-FACTOR.
251100*
251200***************************************************************
251300********YEARCHANGE 2010.0 *************************************
251400***         CASE MIX ADJUSTMENT - FOR FUTURE USE
251500***         CASE MIX ADJUSTMENT - FOR FUTURE USE
251600***
251700***  MOVE 0.994 TO H-CASE-MIX-ADJ.
251800***
251900***  COMPUTE H-HSP-RATE ROUNDED =
252000***    H-HSP-RATE * H-CASE-MIX-ADJ.
252100***
252200********YEARCHANGE 2010.0 *************************************
252300***     OUTLIER OFFSETS
252400***     OPERATING NATIONAL
252500***     OPERATING PUERTO RICO BLEND
252600
252700********YEARCHANGE 2010.7 *************************************
252800
252900      MOVE 0.948998 TO H-OUTLIER-OFFSET-NAT
253000      MOVE 0.957417 TO H-OUTLIER-OFFSET-PR.
253100
253200********YEARCHANGE 2010.7 *************************************
253300
253400***************************************************************
253500     COMPUTE H-FSP-RATE ROUNDED =
253600         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
253700         H-NAT-NONLABOR * H-OPER-COLA))
253800                           *
253900     ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-NAT)
254000                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
254100
254200     IF P-NEW-STATE = 40
254300       COMPUTE H-FSP-RATE ROUNDED =
254400         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
254500         H-NAT-NONLABOR * H-OPER-COLA))
254600                           *
254700         ((1 + H-OPER-IME-TEACH + H-OPER-DSH) /
254800                            H-OUTLIER-OFFSET-NAT))
254900                               +
255000         ((H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
255100         H-REG-NONLABOR * H-OPER-COLA))
255200                           *
255300      ((1 + H-OPER-IME-TEACH + H-OPER-DSH) /
255400                             H-OUTLIER-OFFSET-PR))
255500                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
255600
255700
255800     IF  H-HSP-RATE > H-FSP-RATE
255900           COMPUTE H-OPER-HSP-PART ROUNDED =
256000             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT
256100                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
256200     ELSE
256300         MOVE 0 TO H-OPER-HSP-PART.
256400
256500***************************************************************
256600***         GET THE MDH REBASE
256700
256800     IF  H-HSP-RATE > H-FSP-RATE
256900         IF P-NEW-PROVIDER-TYPE = '14' OR '15'
257000           COMPUTE H-OPER-HSP-PART ROUNDED =
257100             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .75
257200                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
257300
257400 3500-CALC-PERDIEM-AMT.
257500***********************************************************
257600***  REVIEW CODE = 03 OR 06
257700***  OPERATING PERDIEM-AMT CALCULATION
257800***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
257900
258000        COMPUTE H-OPER-FSP-PART ROUNDED =
258100        H-OPER-FSP-PART * H-TRANSFER-ADJ
258200        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
258300
258400***********************************************************
258500***********************************************************
258600***  REVIEW CODE = 03 OR 06
258700***  CAPITAL   PERDIEM-AMT CALCULATION
258800***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS
258900
259000        COMPUTE H-CAPI-FSP-PART ROUNDED =
259100        H-CAPI-FSP-PART * H-TRANSFER-ADJ
259200        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
259300
259400***********************************************************
259500***  REVIEW CODE = 03 OR 06
259600***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
259700***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
259800
259900        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
260000        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ
260100        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
260200
260300 3550-CALC-PERDIEM-AMT.
260400***********************************************************
260500***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG
260600***  OPERATING PERDIEM-AMT CALCULATION
260700***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
260800
260900     IF (B-DRG-POSTACUTE-50-50)
261000        MOVE 10 TO PPS-RTC
261100        COMPUTE H-OPER-FSP-PART ROUNDED =
261200        H-OPER-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
261300        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
261400
261500     IF (B-DRG-POSTACUTE-PERDIEM)
261600        MOVE 12 TO PPS-RTC
261700        COMPUTE H-OPER-FSP-PART ROUNDED =
261800        H-OPER-FSP-PART *  H-TRANSFER-ADJ
261900        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
262000
262100***********************************************************
262200***  CAPITAL PERDIEM-AMT CALCULATION
262300***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
262400
262500     IF (B-DRG-POSTACUTE-50-50)
262600        MOVE 10 TO PPS-RTC
262700        COMPUTE H-CAPI-FSP-PART ROUNDED =
262800        H-CAPI-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
262900        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
263000
263100     IF (B-DRG-POSTACUTE-PERDIEM)
263200        MOVE 12 TO PPS-RTC
263300        COMPUTE H-CAPI-FSP-PART ROUNDED =
263400        H-CAPI-FSP-PART *  H-TRANSFER-ADJ
263500        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
263600
263700***********************************************************
263800***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
263900***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
264000
264100     IF (B-DRG-POSTACUTE-50-50)
264200        MOVE 10 TO PPS-RTC
264300        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
264400        H-CAPI-OLD-HARMLESS * (.5 * (1 + H-TRANSFER-ADJ))
264500        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
264600
264700     IF (B-DRG-POSTACUTE-PERDIEM)
264800        MOVE 12 TO PPS-RTC
264900        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
265000        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ
265100        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
265200
265300 3560-CHECK-RTN-CODE.
265400
265500     IF (B-DRG-POSTACUTE-50-50)
265600        MOVE 10 TO PPS-RTC.
265700     IF (B-DRG-POSTACUTE-PERDIEM)
265800        MOVE 12 TO PPS-RTC.
265900
266000 3560-EXIT.    EXIT.
266100
266200 3600-CALC-OUTLIER.
266300***********************************************************
266400***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
266500***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
266600
266700     IF OUTLIER-RECON-FLAG = 'Y'
266800        COMPUTE H-OPER-CSTCHG-RATIO ROUNDED =
266900               (H-OPER-CSTCHG-RATIO + .2).
267000
267100     IF H-CAPI-CSTCHG-RATIO > 0 OR
267200       H-OPER-CSTCHG-RATIO > 0
267300        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =
267400                H-OPER-CSTCHG-RATIO /
267500               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
267600        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =
267700                H-CAPI-CSTCHG-RATIO /
267800               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
267900     ELSE
268000         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
268100                   H-CAPI-SHARE-DOLL-THRESHOLD.
268200
268300***********************************************************
268400*****YEARCHANGE 2010.0 ************************************
268500***  OUTLIER THRESHOLD AMOUNTS
268600***  OUTLIER THRESHOLD AMOUNTS
268700
268800*****YEARCHANGE 2010.7 ************************************
268900
269000     MOVE 23135.00 TO H-CST-THRESH.
269100
269200*****YEARCHANGE 2010.7 ************************************
269300
269400     IF (B-REVIEW-CODE = '03') AND
269500         H-PERDIEM-DAYS < H-ALOS
269600        COMPUTE H-CST-THRESH ROUNDED =
269700                      (H-CST-THRESH * H-TRANSFER-ADJ)
269800                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
269900
270000     IF ((B-REVIEW-CODE = '09') AND
270100         (H-PERDIEM-DAYS < H-ALOS))
270200         IF (B-DRG-POSTACUTE-PERDIEM)
270300            COMPUTE H-CST-THRESH ROUNDED =
270400                      (H-CST-THRESH * H-TRANSFER-ADJ)
270500                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
270600
270700     IF ((B-REVIEW-CODE = '09') AND
270800         (H-PERDIEM-DAYS < H-ALOS))
270900         IF (B-DRG-POSTACUTE-50-50)
271000           COMPUTE H-CST-THRESH ROUNDED =
271100          (H-CST-THRESH * (.5 * (1 + H-TRANSFER-ADJ)))
271200                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
271300
271400     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
271500        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
271600         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *
271700          H-OPER-SHARE-DOLL-THRESHOLD.
271800
271900     IF P-NEW-STATE = 40
272000        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
272100           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
272200            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
272300             H-OPER-SHARE-DOLL-THRESHOLD
272400        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
272500               (H-OPER-DOLLAR-THRESHOLD * H-NAT-PCT) +
272600               (H-OPER-PR-DOLLAR-THRESHOLD * H-REG-PCT).
272700
272800***********************************************************
272900
273000     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
273100          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
273200          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
273300
273400
273500     IF P-NEW-STATE = 40
273600        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
273700           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
273800           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
273900        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
274000               (H-CAPI-DOLLAR-THRESHOLD * H-NAT-PCT) +
274100               (H-CAPI-PR-DOLLAR-THRESHOLD * H-REG-PCT).
274200
274300
274400     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
274500      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))
274600                       +
274700             H-OPER-DOLLAR-THRESHOLD
274800                       +
274900                 H-NEW-TECH-PAY-ADD-ON.
275000
275100     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
275200      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))
275300                       +
275400             H-CAPI-DOLLAR-THRESHOLD.
275500
275600     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
275700         MOVE 0 TO H-CAPI-COST-OUTLIER.
275800
275900
276000***********************************************************
276100***  OPERATING COST CALCULATION
276200***  OPERATING COST CALCULATION
276300
276400     COMPUTE H-OPER-BILL-COSTS ROUNDED =
276500         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
276600         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
276700
276800
276900     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
277000         COMPUTE H-OPER-OUTCST-PART ROUNDED =
277100         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
277200                         H-OPER-COST-OUTLIER).
277300
277400     IF PAY-WITHOUT-COST OR
277500        PAY-XFER-NO-COST OR
277600        PAY-XFER-SPEC-DRG-NO-COST
277700         MOVE 0 TO H-OPER-OUTCST-PART.
277800
277900***********************************************************
278000***  CAPITAL COST CALCULATION
278100***  CAPITAL COST CALCULATION
278200
278300     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
278400             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO
278500         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
278600
278700     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
278800         COMPUTE H-CAPI-OUTCST-PART ROUNDED =
278900         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
279000                         H-CAPI-COST-OUTLIER).
279100
279200     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
279300       COMPUTE H-CAPI-OUTCST-PART ROUNDED =
279400              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).
279500
279600     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
279700        COMPUTE H-CAPI-OUTCST-PART ROUNDED =
279800               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
279900
280000     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
280100        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
280200        MOVE 0 TO H-CAPI-OUTCST-PART
280300                  H-OPER-OUTCST-PART.
280400
280500     IF PAY-WITHOUT-COST OR
280600        PAY-XFER-NO-COST OR
280700        PAY-XFER-SPEC-DRG-NO-COST
280800         MOVE 0 TO H-CAPI-OUTCST-PART.
280900
281000***********************************************************
281100***  DETERMINES THE BILL TO BE COST  OUTLIER
281200
281300     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
281400         MOVE 0 TO H-CAPI-OUTDAY-PART
281500                   H-CAPI-OUTCST-PART.
281600
281700     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
281800                 MOVE H-OPER-OUTCST-PART TO
281900                      H-OPER-OUTLIER-PART
282000                 MOVE H-CAPI-OUTCST-PART TO
282100                      H-CAPI-OUTLIER-PART
282200                 MOVE 02 TO PPS-RTC.
282300
282400     IF OUTLIER-RECON-FLAG = 'Y'
282500        IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
282600           COMPUTE HLD-PPS-RTC = HLD-PPS-RTC + 30
282700           GO TO 3600-EXIT
282800        ELSE
282900           GO TO 3600-EXIT
283000     ELSE
283100        NEXT SENTENCE.
283200
283300
283400***********************************************************
283500***  DETERMINES IF COST OUTLIER
283600***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH
283700***         RETURN CODE OF 02
283800
283900     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
284000
284100     IF PPS-RTC = 02
284200             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
284300                     (H-CAPI-COST-OUTLIER  +
284400                      H-OPER-COST-OUTLIER)
284500                             /
284600                    (H-CAPI-CSTCHG-RATIO  +
284700                     H-OPER-CSTCHG-RATIO)
284800             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
284900
285000***********************************************************
285100***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS
285200***         RETURN CODE OF 67
285300
285400     IF PPS-RTC = 02
285500         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR
285600            PPS-PC-COT-FLAG = 'Y'
285700             MOVE 67 TO PPS-RTC.
285800***********************************************************
285900
286000***********************************************************
286100***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
286200***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
286300
286400     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
286500        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
286600                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO
286700         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
286800
286900     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
287000        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
287100                H-CAPI-OUTLIER-PART.
287200
287300     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
287400        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
287500                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
287600         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
287700
287800 3600-EXIT.   EXIT.
287900
288000***********************************************************
288100 3800-CALC-TOT-AMT.
288200***********************************************************
288300***  CALCULATE TOTALS FOR CAPITAL
288400***  CALCULATE TOTALS FOR CAPITAL
288500
288600     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
288700
288800     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
288900        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
289000        MOVE 0.00 TO H-CAPI-HSP-PCT.
289100
289200     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
289300        MOVE 0    TO H-CAPI-OLD-HARMLESS
289400        MOVE 1.00 TO H-CAPI-FSP-PCT
289500        MOVE 0.00 TO H-CAPI-HSP-PCT.
289600
289700     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
289800        MOVE 0    TO H-CAPI-OLD-HARMLESS
289900        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
290000        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
290100
290200     COMPUTE H-CAPI-HSP ROUNDED =
290300         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
290400
290500     COMPUTE H-CAPI-FSP ROUNDED =
290600         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
290700
290800     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
290900
291000     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
291100
291200     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
291300             H-CAPI-FSP
291400              * H-CAPI-DSH.
291500
291600     COMPUTE H-CAPI-IME-ADJ ROUNDED =
291700          H-CAPI-FSP *
291800                 H-WK-CAPI-IME-TEACH.
291900
292000     COMPUTE H-CAPI-OUTLIER ROUNDED =
292100             1.00 * H-CAPI-OUTLIER-PART.
292200
292300     COMPUTE H-CAPI2-B-FSP ROUNDED =
292400             1.00 * H-CAPI2-B-FSP-PART.
292500
292600     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
292700             1.00 * H-CAPI2-B-OUTLIER-PART.
292800***********************************************************
292900***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
293000***        THIS ZEROES OUT ALL CAPITAL DATA
293100
293200     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
293300        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
293400***********************************************************
293500
293600***********************************************************
293700***  CALCULATE FINAL TOTALS FOR OPERATING
293800***  CALCULATE FINAL TOTALS FOR OPERATING
293900
294000     IF (H-CAPI-OUTLIER > 0 AND
294100         PPS-OPER-OUTLIER-PART = 0)
294200            COMPUTE PPS-OPER-OUTLIER-PART =
294300                    PPS-OPER-OUTLIER-PART + .01.
294400
294500     MOVE ZERO TO PPS-OPER-DSH-ADJ.
294600
294700     IF  H-OPER-DSH NUMERIC
294800         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
294900       (PPS-OPER-FSP-PART * H-OPER-DSH).
295000
295100     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
295200        (PPS-OPER-FSP-PART * H-OPER-IME-TEACH).
295300
295400
295500     COMPUTE PPS-OPER-FSP-PART ROUNDED =
295600          (H-OPER-FSP-PART * H-OPER-FSP-PCT).
295700
295800     COMPUTE PPS-OPER-HSP-PART ROUNDED =
295900         (H-OPER-HSP-PART * H-OPER-HSP-PCT).
296000
296100     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
296200         (H-OPER-OUTLIER-PART * H-OPER-FSP-PCT).
296300
296400     IF HMO-TAG  = 'Y'
296500        PERFORM 3850-HMO-IME-ADJ.
296600
296700***********************************************************
296800***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
296900***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
297000
297100     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =
297200            (H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
297300             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
297400             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM).
297500
297600     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
297700              H-NEW-TECH-PAY-ADD-ON.
297800
297900***********************************************************
298000* PUT NEW CHECK HERE IF H-NEW-TECH ZERO PERFORM
298100*
298200     IF   H-NEW-TECH-PAY-ADD-ON = 0
298300
298400     PERFORM 4100-ISLET-ISOLATION-ADD-ON THRU 4100-EXIT.
298500
298600     MOVE H-NEW-TECH-PAY-ADD-ON TO PPS-NEW-TECH-PAY-ADD-ON.
298700
298800     MOVE 01.000 TO WK-LOW-VOL25PCT.
298900
299000     IF P-NEW-TEMP-RELIEF-IND = 'Y'
299100        MOVE 00.250 TO WK-LOW-VOL25PCT.
299200
299300     IF  WK-LOW-VOL25PCT < 1.000000
299400     COMPUTE WK-LOW-VOL-ADDON  ROUNDED =
299500              (PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
299600               PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
299700                      PPS-OPER-IME-ADJ
299800                           +
299900             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
300000             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
300100             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM +
300200                 PPS-NEW-TECH-PAY-ADD-ON) *  WK-LOW-VOL25PCT
300300     ELSE
300400     COMPUTE WK-LOW-VOL-ADDON  ROUNDED = 0.000000.
300500
300600     COMPUTE H-LOW-VOL-PAYMENT ROUNDED = WK-LOW-VOL-ADDON.
300700
300800     COMPUTE   PPS-TOTAL-PAYMENT ROUNDED =
300900               PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
301000               PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
301100                      PPS-OPER-IME-ADJ
301200                           +
301300                 PPS-NEW-TECH-PAY-ADD-ON
301400                           +
301500                 H-WK-PASS-AMT-PLUS-MISC
301600                           +
301700                   H-CAPI-TOTAL-PAY.
301800
301900 3850-HMO-IME-ADJ.
302000***********************************************************
302100***  HMO CALC FOR PASS-THRU ADDON
302200***  HMO CALC FOR PASS-THRU ADDON
302300
302400     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
302500          (P-NEW-PASS-AMT-PLUS-MISC -
302600          (P-NEW-PASS-AMT-ORGAN-ACQ +
302700           P-NEW-PASS-AMT-DIR-MED-ED)) * B-LOS.
302800
302900***********************************************************
303000***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002
303100
303200     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
303300                   PPS-OPER-IME-ADJ * .0.
303400
303500***********************************************************
303600
303700
303800 3900A-CALC-OPER-DSH.
303900
304000***  OPERATING DSH CALCULATION
304100***  OPERATING DSH CALCULATION
304200
304300      MOVE 0.0000 TO H-OPER-DSH.
304400
304500      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
304600                                     + P-NEW-MEDICAID-RATIO).
304700
304800***********************************************************
304900**1**    0-99 BEDS
305000***  NOT TO EXCEED 12%
305100
305200      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
305300                               AND H-WK-OPER-DSH > .1499
305400                               AND H-WK-OPER-DSH < .2020
305500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
305600                                      * .65 + .025
305700        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
305800
305900      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
306000                               AND H-WK-OPER-DSH > .2019
306100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
306200                                      * .825 + .0588
306300        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
306400
306500***********************************************************
306600**2**   100 + BEDS
306700***  NO CAP >> CAN EXCEED 12%
306800
306900      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
307000                               AND H-WK-OPER-DSH > .1499
307100                               AND H-WK-OPER-DSH < .2020
307200        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
307300                                      * .65 + .025.
307400
307500      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
307600                               AND H-WK-OPER-DSH > .2019
307700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
307800                                      * .825 + .0588.
307900
308000***********************************************************
308100**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
308200***  NOT TO EXCEED 12%
308300
308400      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
308500                               AND H-WK-OPER-DSH > .1499
308600                               AND H-WK-OPER-DSH < .2020
308700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
308800                                 * .65 + .025
308900        IF H-OPER-DSH > .1200
309000              MOVE .1200 TO H-OPER-DSH.
309100
309200      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
309300                               AND H-WK-OPER-DSH > .2019
309400        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
309500                                 * .825 + .0588
309600        IF H-OPER-DSH > .1200
309700                 MOVE .1200 TO H-OPER-DSH.
309800***********************************************************
309900**4**   OTHER RURAL HOSPITALS 500 BEDS +
310000***  NO CAP >> CAN EXCEED 12%
310100
310200      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
310300                               AND H-WK-OPER-DSH > .1499
310400                               AND H-WK-OPER-DSH < .2020
310500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
310600                                 * .65 + .025.
310700
310800      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
310900                               AND H-WK-OPER-DSH > .2019
311000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
311100                                 * .825 + .0588.
311200
311300***********************************************************
311400**7**   RURAL HOSPITALS SCH
311500***  NOT TO EXCEED 12%
311600
311700      IF W-CBSA-SIZE = 'R'
311800         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
311900                               AND H-WK-OPER-DSH > .1499
312000                               AND H-WK-OPER-DSH < .2020
312100         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
312200                                 * .65 + .025
312300        IF H-OPER-DSH > .1200
312400                 MOVE .1200 TO H-OPER-DSH.
312500
312600      IF W-CBSA-SIZE = 'R'
312700         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
312800                               AND H-WK-OPER-DSH > .2019
312900         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
313000                                 * .825 + .0588
313100        IF H-OPER-DSH > .1200
313200                 MOVE .1200 TO H-OPER-DSH.
313300
313400***********************************************************
313500**6**   RURAL HOSPITALS RRC   RULE 5 & 6 SAME
313600***  RRC OVERRIDES SCH CAP
313700***  NO CAP >> CAN EXCEED 12%
313800
313900         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
314000                                   '17' OR '22')
314100                               AND H-WK-OPER-DSH > .1499
314200                               AND H-WK-OPER-DSH < .2020
314300         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
314400                                 * .65 + .025.
314500
314600         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
314700                                   '17' OR '22')
314800                               AND H-WK-OPER-DSH > .2019
314900         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
315000                                 * .825 + .0588.
315100
315200      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
315300
315400 3900A-EXIT.   EXIT.
315500
315600 4000-CALC-TECH-ADDON.
315700
315800***********************************************************
315900***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
316000***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
316100
316200     COMPUTE PPS-OPER-HSP-PART ROUNDED =
316300         H-OPER-HSP-PCT * H-OPER-HSP-PART.
316400
316500     COMPUTE PPS-OPER-FSP-PART ROUNDED =
316600         H-OPER-FSP-PCT * H-OPER-FSP-PART.
316700
316800     MOVE ZERO TO PPS-OPER-DSH-ADJ.
316900
317000     IF  H-OPER-DSH NUMERIC
317100             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
317200              PPS-OPER-FSP-PART
317300              * H-OPER-DSH.
317400
317500     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
317600             PPS-OPER-FSP-PART *
317700             H-OPER-IME-TEACH.
317800
317900     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =
318000             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
318100             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ.
318200
318300***********************************************************
318400****      NEUROSTIMULATOR CASES
318500***********************************************************
318600*
318700*    IF '8698   ' =  B-PRIN-PROC-CODE   OR
318800*                    B-OTHER-PROC-CODE1 OR
318900*                    B-OTHER-PROC-CODE2 OR
319000*                    B-OTHER-PROC-CODE3 OR
319100*                    B-OTHER-PROC-CODE4 OR
319200*                    B-OTHER-PROC-CODE5
319300*          NEXT SENTENCE
319400*    ELSE
319500*          MOVE ZEROES TO H-NEW-TECH-ADDON-NEURO
319600*          GO TO 4000-CHECK-GRAFT-CASES.
319700*
319800*    MOVE 18640.00 TO H-CSTMED-NEURO.
319900*
320000*    COMPUTE H-LESSER-NEURO-1 ROUNDED =
320100*            .5   H-CSTMED-NEURO.
320200*
320300*    COMPUTE H-LESSER-NEURO-2 ROUNDED =
320400*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -
320500*                    H-BASE-DRG-PAYMENT)   .5.
320600*
320700*    IF H-LESSER-NEURO-2 > 0
320800*       IF H-LESSER-NEURO-1 < H-LESSER-NEURO-2
320900*          MOVE H-LESSER-NEURO-1 TO H-NEW-TECH-ADDON-NEURO
321000*       ELSE
321100*          MOVE H-LESSER-NEURO-2 TO H-NEW-TECH-ADDON-NEURO
321200*    ELSE
321300*       MOVE ZEROES          TO H-NEW-TECH-ADDON-NEURO.
321400*
321500*4000-CHECK-GRAFT-CASES.
321600*
321700***********************************************************
321800***      GRAFT*(GORE*TAG)*CASES
321900***********************************************************
322000*
322100*    IF '3973   ' =  B-PRIN-PROC-CODE   OR
322200*                    B-OTHER-PROC-CODE1 OR
322300*                    B-OTHER-PROC-CODE2 OR
322400*                    B-OTHER-PROC-CODE3 OR
322500*                    B-OTHER-PROC-CODE4 OR
322600*                    B-OTHER-PROC-CODE5
322700*          NEXT SENTENCE
322800*    ELSE
322900*          MOVE ZEROES TO H-NEW-TECH-ADDON-GRAFT
323000*          GO TO 4000-CHECK-X-STOP.
323100*
323200*    MOVE 21198.00 TO H-CSTMED-GRAFT.
323300*
323400*    COMPUTE H-LESSER-GRAFT-1 ROUNDED =
323500*            .5   H-CSTMED-GRAFT.
323600*
323700*    COMPUTE H-LESSER-GRAFT-2 ROUNDED =
323800*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -
323900*                    H-BASE-DRG-PAYMENT)   .5.
324000*
324100*    IF H-LESSER-GRAFT-2 > 0
324200*       IF H-LESSER-GRAFT-1 < H-LESSER-GRAFT-2
324300*          MOVE H-LESSER-GRAFT-1 TO H-NEW-TECH-ADDON-GRAFT
324400*       ELSE
324500*          MOVE H-LESSER-GRAFT-2 TO H-NEW-TECH-ADDON-GRAFT
324600*    ELSE
324700*       MOVE ZEROES          TO H-NEW-TECH-ADDON-GRAFT.
324800*
324900*4000-CHECK-X-STOP.
325000*
325100***********************************************************
325200*****    X-STOP INTERSPINOUS PROCESS DECOMPRESSION SYSTEM
325300***********************************************************
325400*
325500*    IF '8458   ' =  B-PRIN-PROC-CODE   OR
325600*                    B-OTHER-PROC-CODE1 OR
325700*                    B-OTHER-PROC-CODE2 OR
325800*                    B-OTHER-PROC-CODE3 OR
325900*                    B-OTHER-PROC-CODE4 OR
326000*                    B-OTHER-PROC-CODE5
326100*          NEXT SENTENCE
326200*    ELSE
326300*          MOVE ZEROES TO H-NEW-TECH-ADDON-X-STOP
326400*          GO TO 4000-ADD-TECH-CASES.
326500*
326600*    MOVE 8800.00 TO H-CSTMED-X-STOP.
326700*
326800*    COMPUTE H-LESSER-HRTIMP-STOP-1 ROUNDED =
326900*            .5   H-CSTMED-X-STOP.
327000*
327100*    COMPUTE H-LESSER-HRTIMP-STOP-2 ROUNDED =
327200*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -
327300*                    H-BASE-DRG-PAYMENT)   .5.
327400*
327500*    IF H-LESSER-HRTIMP-STOP-2 > 0
327600*       IF H-LESSER-HRTIMP-STOP-1 < H-LESSER-HRTIMP-STOP-2
327700*        MOVE H-LESSER-HRTIMP-STOP-1 TO H-NEW-TECH-ADDON-X-STOP
327800*       ELSE
327900*        MOVE H-LESSER-HRTIMP-STOP-2 TO H-NEW-TECH-ADDON-X-STOP
328000*    ELSE
328100*       MOVE ZEROES          TO H-NEW-TECH-ADDON-X-STOP.
328200*
328300*
328400*4000-ADD-TECH-CASES.
328500*
328600*    COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
328700*            H-NEW-TECH-ADDON-NEURO  +
328800*            H-NEW-TECH-ADDON-GRAFT +
328900*            H-NEW-TECH-ADDON-X-STOP.
329000*
329100***********************************************************
329200***** HRTIMP-STOP INTERSPINOUS PROCESS DECOMPRESSION SYSTEM
329300***********************************************************
329400
329500     IF '3752   ' =  B-PRIN-PROC-CODE   OR
329600                     B-OTHER-PROC-CODE1 OR
329700                     B-OTHER-PROC-CODE2 OR
329800                     B-OTHER-PROC-CODE3 OR
329900                     B-OTHER-PROC-CODE4 OR
330000                     B-OTHER-PROC-CODE5
330100           NEXT SENTENCE
330200     ELSE
330300           MOVE ZEROES TO H-NEW-TECH-ADDON-HRTIMP-STOP
330400           GO TO 4000-ADD-TECH-CASES.
330500
330600     MOVE 53000.00 TO H-CSTMED-HRTIMP-STOP.
330700
330800     COMPUTE H-LESSER-HRTIMP-STOP-1 ROUNDED =
330900                  H-CSTMED-HRTIMP-STOP.
331000
331100     COMPUTE H-LESSER-HRTIMP-STOP-2 ROUNDED =
331200          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
331300                     H-BASE-DRG-PAYMENT)) * .5.
331400
331500     IF H-LESSER-HRTIMP-STOP-2 > 0
331600        IF H-LESSER-HRTIMP-STOP-1 < H-LESSER-HRTIMP-STOP-2
331700         MOVE H-LESSER-HRTIMP-STOP-1 TO
331800                                  H-NEW-TECH-ADDON-HRTIMP-STOP
331900        ELSE
332000         MOVE H-LESSER-HRTIMP-STOP-2 TO
332100                                  H-NEW-TECH-ADDON-HRTIMP-STOP
332200     ELSE
332300        MOVE ZEROES          TO H-NEW-TECH-ADDON-HRTIMP-STOP.
332400
332500
332600 4000-ADD-TECH-CASES.
332700
332800     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
332900             H-NEW-TECH-ADDON-HRTIMP-STOP.
333000*
333100***********************************************************
333200* PUT NEW CHECK HERE IF H-NEW-TECH ZERO PERFORM
333300
333400     IF   H-NEW-TECH-PAY-ADD-ON = 0 AND
333500          B-DRG-SPIRATN-DRG
333600        PERFORM 4300-SPIRAT-TECH-ADD-ON THRU 4300-EXIT.
333700
333800     COMPUTE PPS-NEW-TECH-PAY-ADD-ON ROUNDED =
333900             H-NEW-TECH-PAY-ADD-ON.
334000
334100*
334200 4000-EXIT.    EXIT.
334300***********************************************************
334400
334500 4100-ISLET-ISOLATION-ADD-ON.
334600***********************************************************
334700***  TECHNICAL TRANSPLANTATION OF CELLS
334800***
334900*** CODE 52.85 (ALLTRANSPLANTATION OF CELLS OF ISLETS OF
335000*** ISLETS OF LANGERHAUS) AND
335100*** V70.7 (EXAMINATION OF PARTICIPANT IN CLINICAL TRIAL).
335200*** V70.7 ONE OR MORE TIMES IN PROC-CODES AND 52.85 ONE OR MORE
335300*** TIMES IN ANY OTHER PROC-CODE
335400***********************************************************
335500*** IT WAS DECIDED ON 3/12/07 TO ONLY CHECK FOR 52.85 AND NOT
335600*** V70.7
335700***********************************************************
335800
335900     MOVE 0 TO H-TECH-ADDON-ISLET-CNTR
336000               H-TECH-ADDON-ISLET-CNTR2.
336100
336200*    IF 'V707   ' =  B-PRIN-PROC-CODE   OR
336300*                    B-OTHER-PROC-CODE1 OR
336400*                    B-OTHER-PROC-CODE2 OR
336500*                    B-OTHER-PROC-CODE3 OR
336600*                    B-OTHER-PROC-CODE4 OR
336700*                    B-OTHER-PROC-CODE5
336800*          NEXT SENTENCE
336900*    ELSE
337000*          MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
337100*          GO TO 4100-ADD-TECH-CASES.
337200
337300     IF '5285   ' =  B-PRIN-PROC-CODE   OR
337400                     B-OTHER-PROC-CODE1 OR
337500                     B-OTHER-PROC-CODE2 OR
337600                     B-OTHER-PROC-CODE3 OR
337700                     B-OTHER-PROC-CODE4 OR
337800                     B-OTHER-PROC-CODE5
337900           NEXT SENTENCE
338000     ELSE
338100           MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
338200           GO TO 4100-ADD-TECH-CASES.
338300
338400     IF '5285   ' =  B-PRIN-PROC-CODE
338500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
338600                       H-TECH-ADDON-ISLET-CNTR + 1.
338700
338800     IF '5285   ' =  B-OTHER-PROC-CODE1
338900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
339000                       H-TECH-ADDON-ISLET-CNTR + 1.
339100
339200     IF '5285   ' =  B-OTHER-PROC-CODE2
339300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
339400                       H-TECH-ADDON-ISLET-CNTR + 1.
339500
339600     IF '5285   ' =  B-OTHER-PROC-CODE3
339700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
339800                       H-TECH-ADDON-ISLET-CNTR + 1.
339900
340000     IF '5285   ' =  B-OTHER-PROC-CODE4
340100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
340200                       H-TECH-ADDON-ISLET-CNTR + 1.
340300
340400
340500     IF '5285   ' =  B-OTHER-PROC-CODE5
340600      COMPUTE H-TECH-ADDON-ISLET-CNTR =
340700                       H-TECH-ADDON-ISLET-CNTR + 1.
340800
340900*    IF 'V707   ' =  B-PRIN-PROC-CODE
341000*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
341100*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
341200*
341300*    IF 'V707   ' =  B-OTHER-PROC-CODE1
341400*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
341500*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
341600*
341700*    IF 'V707   ' =  B-OTHER-PROC-CODE2
341800*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
341900*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
342000*
342100*    IF 'V707   ' =  B-OTHER-PROC-CODE3
342200*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
342300*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
342400*
342500*    IF 'V707   ' =  B-OTHER-PROC-CODE4
342600*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
342700*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
342800*
342900*    IF 'V707   ' =  B-OTHER-PROC-CODE5
343000*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
343100*                    H-TECH-ADDON-ISLET-CNTR2 + 1.
343200*
343300*    IF  H-TECH-ADDON-ISLET-CNTR2 > 0
343400*          NEXT SENTENCE
343500*    ELSE
343600*          MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
343700*          GO TO 4100-ADD-TECH-CASES.
343800
343900     IF  H-TECH-ADDON-ISLET-CNTR = 1
344000     MOVE 18848.00 TO H-NEW-TECH-ADDON-ISLET
344100           GO TO 4100-ADD-TECH-CASES.
344200
344300     IF  H-TECH-ADDON-ISLET-CNTR > 1
344400     MOVE 37696.00 TO H-NEW-TECH-ADDON-ISLET
344500           GO TO 4100-ADD-TECH-CASES.
344600
344700     MOVE 0 TO H-NEW-TECH-ADDON-ISLET.
344800
344900
345000 4100-ADD-TECH-CASES.
345100
345200     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
345300             H-NEW-TECH-ADDON-ISLET.
345400
345500 4100-EXIT.    EXIT.
345600
345700
345800 4200-SSRFBN-CODE-RTN.
345900     SET SSRFBN-IDX TO 1.
346000     SEARCH SSRFBN-TAB VARYING SSRFBN-IDX
346100         AT END
346200           MOVE ' NO SSRFBN MESSAGE FOUND' TO MES-SSRFBN
346300       WHEN WK-SSRFBN-STATE(SSRFBN-IDX) = MES-PPS-STATE
346400         MOVE WK-SSRFBN-REASON-ALL (SSRFBN-IDX) TO MES-SSRFBN.
346500
346600 4200-EXIT.   EXIT.
346700
346800 4300-SPIRAT-TECH-ADD-ON.
346900***********************************************************
347000***** SPIRAT-STOP INTERSPINOUS PROCESS DECOMPRESSION SYSTEM
347100***********************************************************
347200
347300     IF '3371   ' =  B-PRIN-PROC-CODE   OR
347400                     B-OTHER-PROC-CODE1 OR
347500                     B-OTHER-PROC-CODE2 OR
347600                     B-OTHER-PROC-CODE3 OR
347700                     B-OTHER-PROC-CODE4 OR
347800                     B-OTHER-PROC-CODE5
347900        IF '3222   ' =  B-PRIN-PROC-CODE   OR
348000                        B-OTHER-PROC-CODE1 OR
348100                        B-OTHER-PROC-CODE2 OR
348200                        B-OTHER-PROC-CODE3 OR
348300                        B-OTHER-PROC-CODE4 OR
348400                        B-OTHER-PROC-CODE5
348500           GO TO 4300-COMPUTE-SPIRAT
348600        ELSE
348700        IF '3230   ' =  B-PRIN-PROC-CODE   OR
348800                        B-OTHER-PROC-CODE1 OR
348900                        B-OTHER-PROC-CODE2 OR
349000                        B-OTHER-PROC-CODE3 OR
349100                        B-OTHER-PROC-CODE4 OR
349200                        B-OTHER-PROC-CODE5
349300           GO TO 4300-COMPUTE-SPIRAT
349400        ELSE
349500        IF '3239   ' =  B-PRIN-PROC-CODE   OR
349600                        B-OTHER-PROC-CODE1 OR
349700                        B-OTHER-PROC-CODE2 OR
349800                        B-OTHER-PROC-CODE3 OR
349900                        B-OTHER-PROC-CODE4 OR
350000                        B-OTHER-PROC-CODE5
350100           GO TO 4300-COMPUTE-SPIRAT
350200        ELSE
350300        IF '3241   ' =  B-PRIN-PROC-CODE   OR
350400                        B-OTHER-PROC-CODE1 OR
350500                        B-OTHER-PROC-CODE2 OR
350600                        B-OTHER-PROC-CODE3 OR
350700                        B-OTHER-PROC-CODE4 OR
350800                        B-OTHER-PROC-CODE5
350900           GO TO 4300-COMPUTE-SPIRAT
351000        ELSE
351100        IF '3249   ' =  B-PRIN-PROC-CODE   OR
351200                        B-OTHER-PROC-CODE1 OR
351300                        B-OTHER-PROC-CODE2 OR
351400                        B-OTHER-PROC-CODE3 OR
351500                        B-OTHER-PROC-CODE4 OR
351600                        B-OTHER-PROC-CODE5
351700           GO TO 4300-COMPUTE-SPIRAT
351800     ELSE
351900           NEXT SENTENCE.
352000
352100     IF '3373   ' =  B-PRIN-PROC-CODE   OR
352200                     B-OTHER-PROC-CODE1 OR
352300                     B-OTHER-PROC-CODE2 OR
352400                     B-OTHER-PROC-CODE3 OR
352500                     B-OTHER-PROC-CODE4 OR
352600                     B-OTHER-PROC-CODE5
352700        IF '3222   ' =  B-PRIN-PROC-CODE   OR
352800                        B-OTHER-PROC-CODE1 OR
352900                        B-OTHER-PROC-CODE2 OR
353000                        B-OTHER-PROC-CODE3 OR
353100                        B-OTHER-PROC-CODE4 OR
353200                        B-OTHER-PROC-CODE5
353300           GO TO 4300-COMPUTE-SPIRAT
353400        ELSE
353500        IF '3230   ' =  B-PRIN-PROC-CODE   OR
353600                        B-OTHER-PROC-CODE1 OR
353700                        B-OTHER-PROC-CODE2 OR
353800                        B-OTHER-PROC-CODE3 OR
353900                        B-OTHER-PROC-CODE4 OR
354000                        B-OTHER-PROC-CODE5
354100           GO TO 4300-COMPUTE-SPIRAT
354200        ELSE
354300        IF '3239   ' =  B-PRIN-PROC-CODE   OR
354400                        B-OTHER-PROC-CODE1 OR
354500                        B-OTHER-PROC-CODE2 OR
354600                        B-OTHER-PROC-CODE3 OR
354700                        B-OTHER-PROC-CODE4 OR
354800                        B-OTHER-PROC-CODE5
354900           GO TO 4300-COMPUTE-SPIRAT
355000        ELSE
355100        IF '3241   ' =  B-PRIN-PROC-CODE   OR
355200                        B-OTHER-PROC-CODE1 OR
355300                        B-OTHER-PROC-CODE2 OR
355400                        B-OTHER-PROC-CODE3 OR
355500                        B-OTHER-PROC-CODE4 OR
355600                        B-OTHER-PROC-CODE5
355700           GO TO 4300-COMPUTE-SPIRAT
355800        ELSE
355900        IF '3249   ' =  B-PRIN-PROC-CODE   OR
356000                        B-OTHER-PROC-CODE1 OR
356100                        B-OTHER-PROC-CODE2 OR
356200                        B-OTHER-PROC-CODE3 OR
356300                        B-OTHER-PROC-CODE4 OR
356400                        B-OTHER-PROC-CODE5
356500           GO TO 4300-COMPUTE-SPIRAT.
356600
356700           MOVE ZEROES TO H-NEW-TECH-ADDON-SPIRAT-STOP.
356800           GO TO 4300-ADD-TECH-CASES.
356900
357000 4300-COMPUTE-SPIRAT.
357100
357200     MOVE  3437.50 TO H-CSTMED-SPIRAT-STOP.
357300
357400     COMPUTE H-LESSER-SPIRAT-STOP-1 ROUNDED =
357500                  H-CSTMED-SPIRAT-STOP.
357600
357700     COMPUTE H-LESSER-SPIRAT-STOP-2 ROUNDED =
357800          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
357900                     H-BASE-DRG-PAYMENT)) * .5.
358000
358100     IF H-LESSER-SPIRAT-STOP-2 > 0
358200        IF H-LESSER-SPIRAT-STOP-1 < H-LESSER-SPIRAT-STOP-2
358300         MOVE H-LESSER-SPIRAT-STOP-1 TO
358400                                  H-NEW-TECH-ADDON-SPIRAT-STOP
358500        ELSE
358600         MOVE H-LESSER-SPIRAT-STOP-2 TO
358700                                  H-NEW-TECH-ADDON-SPIRAT-STOP
358800     ELSE
358900        MOVE ZEROES          TO H-NEW-TECH-ADDON-SPIRAT-STOP.
359000
359100
359200 4300-ADD-TECH-CASES.
359300
359400     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
359500             H-NEW-TECH-ADDON-SPIRAT-STOP.
359600*
359700 4300-EXIT.    EXIT.
359800***********************************************************
359900******        L A S T   S O U R C E   S T A T E M E N T   *****
