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