       IDENTIFICATION DIVISION.
       PROGRAM-ID.        OPPSCAL.
      *AUTHOR.            TAMARA HOWARD.
      *REMARKS.           CMS.
      ***********************************************************
      *                                                         *
      *                 OPPS PRICER CHANGE LOG                  *
      *                                                         *
      ***********************************************************
      * 5/8/00  - ADD WINX TO RETURN RECORD                     *
      * 5/10/00 - ADD MSA TO RETURN RECORD                      *
      * 5/11/00 - CHANGE PROVIDER FILE FROM 9999 OCCURS TO 999  *
      *         - CHANGE ALL LINE OCCURS FROM 999 TO 450        *
      * 5/17/00 - RELOCATE MOVE OF H-WINX1 TO A-WINX TO         *
      *           0000-PROCESS-MAINLINE                         *
      * 6/08/00 - ADD CODE IN 0550-CALC-STANDARD:               *
      *              MOVE W-MIN-COIN (W-LP-INDX) TO H-MIN-COIN  *
      *         - CORRECTED PROBLEM OF COINSURANCE ELECTION     *
      *           BEING DROPPED AFTER FIRST LINE WAS PROCESSED  *
      * 6/14/00 - UPDATED WAGE INDEX TABLE                      *
      *         - CREATED NEW COPY BOOK                         *
      * 7/10/00 - CORRECTED 0150-INIT PARAGRAPH                 *
      *         - WILL INCLUDE ALL PACKAGED LINES IN TOTAL      *
      *           CHARGES FOR OUTLIER CALCULATION               *
      *           - INCLUDED OPPS-PKG-FLAG = 0 OR 1 OR 2        *
      * 7/18/00 - CORRECTED MAX-COINSURANCE PARAGRAPH 0550-CALC *
      *           - CHANGED >>  MOVE 776 TO H-NAT-COIN << TO    *
      *           -            MOVE H-MAX-COIN TO H-NAT-COIN    *
      * 8/02/00 - CHANGED OPPSAPCS COPYBOOK TO RANK NEW DEVICES *
      *           LAST IN DEDUCTIBLE CALCULATION                *
      *           - OCE SERVICE INDICATOR = H                   *
      *           - PAYMENT AND COINSURANCE = ZERO              *
      * 8/02/00 - CHANGED OPPSWINX COPYBOOK TO INCLUDE NEW      *
      *           MARYLAND CODE                                 *
      *           - '  80' = 008631 000000                      *
      * 8/03/00 - CHANGED 0300-COIN-DEDUCT                      *
      *           - REMOVE CONDITION OF SERVICE INDICATOR       *
      *             NOT EQUAL 'T'                               *
      *             - MOVE 1 TO DISCOUNT RATE                   *
      *           - ALWAYS ACCEPT DISCOUNT FROM OCE             *
      * 8/07/00 - CHANGED 0150-INIT PARAGRAPH                   *
      *           - ADD CONDITION OF OPPS-PKG-FLAG NOT = ZERO   *
      *             - WILL NOT PAY PACKAGED PARTIAL             *
      *               HOSPITALIZATIONS  FLAG = 1 OR 2           *
      * 8/07/00 - CHANGED 0250-CALC-DISCOUNT                    *
      *           - DISCOUNT INDICATOR OF '8' NOW EQUAL TO 2    *
      *             - FORMULA NOW = 2 (DOUBLE)                  *
      *             - FORMULA WAS = 2 / UNITS                   *
      * 8/15/00 - CHANGED 0100-INIT                             *
      *           - ALLOW PROPER PROCESSING OF SPECIAL WAGE     *
      *             INDEX CONSIDERATIONS                        *
      *           - PERFORM 0220-CHNG-WAGEINDX FIRST            *
      *           - IF WAGE INDEX = 0                           *
      *              PERFORM 0200-CALC-WAGEINDX                 *
      * 8/17/00 - CHANGED 0150-INIT                             *
      *           - ALLOW THE PROCESSING OF PARTIAL HOSP. IF    *
      *             - LINE ITEM DENIAL/REJECT FLAG = 1          *
      *               AND APC = 0033,0034,0322-0325,0373,0374   *
      * 8/18/00 - CHANGED 0900-END-PRICE-RTN                    *
      *           - PREVENT OUTLIER PROCESSING OF NON-OPPS      *
      *             CLAIMS                                      *
      *             - IF TOTAL CLAIM PAYMENT = 0                *
      *                DO NOT CALCULATE OUTLIER AMOUNT          *
      * 8/18/00 - ADD 0125-INIT PARAGRAPH                       *
      *           - SET FLAG IF APC = 0033 ON CLAIM             *
      * 8/18/00 - CHANGE 0150-INIT                              *
      *           - IF TYPE OF BILL INCLUSION = 0  (OLD)        *
      *           - (NEW) OR (APC 0033 IS ON THE CLAIM          *
      *                   AND SERVICE INDICATOR = 'P'           *
      *                   OR  APC = 0322-0325,0373,0374)        *
      * 8/22/00 - CHANGE 0F 200LCULATE                         *
      *           - IF PROVIDER REDUCED COINSURANCE IS GREATER  *
      *             THAN NATIONAL ADJUSTED COINSURANCE          *
      *                 - MOVE NATIONAL COINSURANCE TO THE      *
      *                   PROVIDER REDUCE COINSURANCE           *
      * 9/14/00 - CHANGE 0550-CALCULATE-STANDARD                *
      *           - CHANGE MINIMUM COINSURANCE CALCULATION      *
      *             FOR DRUGS AND DEVICES (SERVICE INDICATORS   *
      *             'G','H', OR 'J')                            *
      * 9/14/00 - CHANGE APC AND WAGE INDEX LOOKUP ROUTINES.    *
      *           - LOGIC DID NOT ALLOW FOR MULTIPLE RELEASE    *
      *             DATES                                       *
      * 10/12/00- CONTROL THE PROCESSING OF PARAGRAPH 0220-     *
      *             CHNG-WAGEINDX BY USING THE SERVICE FROM     *
      *             DATE - ONLY PROCESS IF < 20010101           *
      * 10/12/00- CONTROL THE PROCESSING OF PARAGRAPHS 0105     *
      *             AND 0110  BY USING THE SERVICE FROM         *
      *             DATE - RESET FLOOR MSA                      *
      * 10/12/00- CONTROL H-MAX-COIN USING THE SERVICE FROM     *
      *             DATE - IP MAX = 776 IF < 20010101           *
      *                  - IP MAX = 792 IF > 20001231           *
      *                  (PARAGRAPH 0550)                       *
      * 10/12/00- LIMIT THE H-MAX-COIN FOR STATUS INDICATORS    *
      *           'G' 'J' 'K' (DRUGS) TO $792 PER LINE ITEM     *
      *            EFFECT 20010101 (PARAGRAPH 0550)             *
      * 10/12/00- ALLOW FOR A NEW SERVICE INDICATOR  'K'        *
      * 11/15/00- ADJUST THE COST-TO-CHARGE FOR 2001 BY A       *
      *           FACTOR OF .981956                             *
      *               - PARAGRAPHS 0555 AND 0910                *
      * 11/16/00- CREATED WAGE INDEX COPY BOOK FOR 20010101     *
      * 12/06/00- ALLOW FOR NEW SERVICE INDICATOR  'B'          *
      *         - NON-ALLOWED ITEM OR SERVICE FOR OPPS          *
      * 12/07/00- INSERTED W-APC-ADJ-TABLE TO ADJUST APC        *
      *           FROM OCE                                      *
      *         - RESET SERVICE INDICATOR IF NECESSARY          *
      *         - RESET PAYMENT INDICATOR IF NECESSARY          *
      * 12/07/00- INSERTED PARAGRAPH 0160-ADJUST-APC            *
      * 12/28/00- CORRECTED WAGE INDEX LOOK-UP ROUTINE          *
      *         - PARAGRAPH 0210-WAGE-LOOKUP ( > INSTEAD OF < ) *
      *         - CHECK RECLASS VALUE OF 'Y' ELSE ALLOW ANY     *
      *           OTHER VALUE FOR NON-RECLASS                   *
      * 02/28/01- ADDED NEW APCS - 'C' CODES DEVICE PASSTHRUS   *
      *         - 125 CODES                                     *
      * 02/28/01- REMOVED OCE/APC PATCH - EFFECTIVE APR 01,2001 *
      *           (0160-ADJUST-APC)                             *
      * 03/05/01- SET RETURN CODE TO '30' TO BY-PASS THE PASS   *
      *           THRU PAYMENTS FOR THE FOLLOWING APCS:         *
      *           01111 - 01114, 01117, 06300, AND 06600        *
      * 03/06/01- ADD PATCH FOR HCPCS CODE C1050                *
      *           CHANGE SERVICE INDICATOR TO 'S'               *
      *           CHANGE PAYMENT APC TO '0976'                  *
      * 03/07/01- ADDED NEW APCS - 'C' CODES DEVICE PASSTHRUS   *
      *         - 25 CODES                                      *
      * 05/02/01- ADD CODE FOR DAILY COINSURANCE LIMITATION     *
      *         - UPDATE APC TABLE FOR 7/1/2001                 *
      *         - NEW PROCESS FOR "DELETED" APC CODES           *
      * 06/12/01- CORRECT TRUNCATION OF APC RANKING FACTOR      *
      *         - INCREASE THE SIZE OF THE RANKING VARIABLE     *
      *         - 9(03) TO 9(05)                                *
      * 07/23/01- ADD NEW PROVIDER SPECIFIC WAGE INDEX LOGIC    *
      *         - PARAGRAPH 0225-CHNG-WAGEINDX                  *
      * 07/23/01- UPDATE APC TABLE                              *
      * 08/20/01- REMOVE REFERENCE TO L-PSF-GEO-MSA FROM LOGIC  *
      *         - IN PARAGRAPH 0225-CHNG-WAGEINDX               *
      * 12/19/01- ADD INPATIENT LIMIT LOGIC FOR CY 2002         *
      *         - IN PARAGRAPH 0100-INIT                        *
      * 01/16/02- CREATE COPYBOOK FOR FY 2002 WAGE INDEX        *
      *         - NEW BASEWINX (EFF. 04/01/2002)                *
      * 01/16/02- ADD APC 0339 SERVICE UNITS OVERRIDE           *
      *         - UNITS = 1 (EFF. 04/01/2002)                   *
      * 01/17/02- ADD SECTION 401 AND FLOOR MSA DESIGNATIONS    *
      *         - PARAGRAPHS 0115-FLOOR-2002 AND                *
      *                      0115-SEC401-2002 (EFF. 04/01/2002) *
      * 01/17/02- ADD LOGIC TO PROCESS LINE LEVEL OUTLIER       *
      *           PAYMENT                                       *
      * 01/30/02- ADD NEW COPYBOOK FOR DEVICE OFFSET PROCESS    *
      *         - SERVICE INDICATOR TYPE H                      *
      *         - EFFECTIVE 04/01/2002                          *
      *         - TOTAL AND WAGE ADJUST OFFSET AMOUNT AND       *
      *           SUBTRACT PROPORTIONATELY FROM ANY SERVICE     *
      *           INDICATOR TYPE 'H' THAT HAVE HCPCS CODE       *
      *           BEGINNING WITH 'C' (C1713 - C263)             *
      * 01/31/02- ADD LOGIC FOR PRO RATA REDUCTION FOR ALL      *
      *           SERVICE INDICATOR TYPES G AND H               *
      *         - CURRENTLY .689                                *
      *         - EFFECTIVE 04/01/2002                          *
      * 02/27/02- CHANGE PRO RATA REDUCTION TO .634             *
      * 02/27/02- CHANGE LINE ITEM CALCULATION                  *
      *            FROM 3.0 * LINE PYMT TO 3.5 * LINE PYMT      *
      * 02/28/02- UPDATE APC RATE TABLE                         *
      * 02/28/02- UPDATE DEVICE OFFSET TABLE                    *
      * 04/24/02- UPDATE APC TABLE                              *
      *           -  APC 00034 FOR 20020401                     *
      * 04/24/02- MOVED LOGIC TO CALCULATE DISCOUNT RATE        *
      *           BEFORE CALCULATING TOTAL OFFSET AMOUNT        *
      *           - PERFORM 1250-CALC-DISCOUNT                  *
      * 04/24/02- ADDED DISCOUNTING TO OFFSET AMOUNT            *
      *           - PARAGRAPH 1160-TOTAL-OFFSET                 *
      * 04/24/02- PARAGRAPH 1150-INIT                           *
      *           - COMPUTE H-TOT-N-CHRG WHEN PACKAGE INDICATOR *
      *             = '1' OR '2'                                *
      * 07/23/02- MOVED LOGIC TO RESET SERVICE UNITS TO 1 IF    *
      *           APC = 0339 BEFORE CALCULATING DISCOUNT        *
      *           FRACTION                                      *
      *           - PERFORM 1150-INIT                           *
      * 10/31/02- REMOVED SERVICE INDICATOR 'S' FROM 2500-ADJ-  *
      *           CHRGS LOGIC                                   *
      * 12/02/02- ADDED 2180-MOD-CCODE-PYMT TO ADJUST PYMT FOR  *
      *           C9114 AND C9115 BETWEEN 12/31/2002 AND        *
      *           04/01/2003                                    *
      * 12/02/02- ADD NEW APC RATE TABLE                        *
      * 02/10/03- ADD NEW PROCESS FOR CALCULATING BLOOD         *
      *           DEDUCTIBLES                                   *
      *           - 2375-BLOOD-DEDUCT                           *
      * 02/10/03- ALLOW FOR NEW INPUT FIELDS TO BE PASSED TO    *
      *           OPPSCAL                                       *
      *           -CLAIM LEVEL:                                 *
      *             01  BENE-BLOOD-PINTS        PIC 9(01).      *
      *           -LINE LEVEL:                                  *
      *             05  A-BLOOD-PINTS-USED      PIC 9(01).      *
      *             05  A-BLOOD-DEDUCT-DUE      PIC 9(05)V9(02).*
      * 03/03/03- UPDATE APC TABLE FOR:                         *
      *            APCS: 1348 1607 1814 9111 9202 9203 9204     *
      * 04/11/03- CORRECT BLOOD DEDUCTIBLE PROCESS              *
      * 07/21/03- INCLUDE OVR '4' LOGIC IN PARAGRAPH 2400       *
      *            BACK TO 8/1/2000 LOGIC                       *
      * 10/21/03- INCREASED IP DEDUCTIBLE AMOUNT TO $876        *
      *            FOR CALENDAR YEAR 2004                       *
      * 10/30/03- ADD PARAGRAPHS FOR MSA FLOOR AND SECTION 401  *
      *           HOSPITALS FOR CALENDAR YEAR 2004              *
      *           - 2120-FLOOR-2004                             *
      *           - 2120-SEC401-2004                            *
      * 03/02/04- ADD LOGIC IN 2600-ADJ-CHRG-OUTL TO INCLUDE    *
      *           SPECIFIED "K" INDICATORS IN OUTLIER           *
      *           CALCULATIO - FOR 04/01/2004                   *
      * 03/03/04- INCLUDE NEW APC UPDATES FOR 04/01/2004 AND    *
      *           RETROACTIVE RATES                             *
      * 03/04/04- NEW LOGIC FOR SPECIFIED "H" INDICATORS TO     *
      *           ALTER COINSURANCE AMOUNT IN 2550-CALC-STANDARD*
      * 04/08/04- REMOVE OVERRIDE LOGIC FROM 2150-INIT          *
      *           ALLOW OCE STATUS INDICATOR FOR A9526 & Q4078  *
      * 10/27/04- ADD NEW SECTION PROCESS FOR CY2005            *
      *             - 3000-PROCESS-MAIN-NEW                     *
      * 10/27/04- ALLOW FOR NEW PACKAGING FLAG VALUE - '4'      *
      *             - 3150-INIT                                 *
      * 10/27/04- ADD NEW VARIABLE TO PASS CBSA BACK TO CALLING *
      *           PROGRAM: LOCATED IN -                         *
      *           - 01  A-ADDITIONAL-VARIABLES                  *
      *             -  05  A-CBSA                               *
      * 10/27/04- ADD NEW IP DEDUCTIBLE FOR CY2005 - $912.00    *
      * 10/27/04- REMOVE LOGIC IN 2600-ADJ-CHRG-OUTL TO INCLUDE *
      *           SPECIFIED "K" INDICATORS IN OUTLIER           *
      *           ALLOW OCE STATUS INDICATOR FOR A9526 & Q4078  *
      * 10/27/04- CHANGE OUTLIER CALCULATION PROCESS IN         *
      *           3600-ADJ-CHRG-OUT THIS INCLUDES CMHC'S        *
      * 11/09/04- ADD NEW FLOOR AND SECTION 401 HOSPITAL        *
      *           OVER RIDES FOR CY2005                         *
      *             - 3120-FLOOR-2005                           *
      *             - 3120-SEC401-2005                          *
      * 11/09/04- ADD NEW BASEAPCS FILE AND OPPSAPCS TABLE      *
      *           FOR CY 2005                                   *
      * 11/09/04- CHANGE WAGE INDEX PROCESS TO USE CBSA TO      *
      *           LOOK-UP WAGE INDEX FOR CY 2005                *
      * 11/30/04- ADD NEW APC 9126                              *
      * 02/01/05- UPDATED BLOOD CODES FOR DEDUCTIBLE PROCESS    *
      *           - 2550-CALC-GJK                               *
      *           - 3550-CALC-GJK                               *
      * 02/01/05- UPDATED BLOOD CODES IN BLOOD DEDUCTIBLE TABLE *
      *           - CURRENT RANKING TABLE                       *
      *           - ADDED NEW RANKING TABLE FOR 2005            *
      * 02/01/05- REVISED PROCESSING OF LINES WITH PACKAGING    *
      *           FLAG = '4'                                    *
      *                                                         *
      * 02/16/05- ALLOW FOR NEW SERVICE INDICATOR               *
      *           - 'M' NOT PROCESS IN OPPS                     *
      *           - WILL TRIGGER RETURN CODE '41'               *
      *                                                         *
      * 02/22/05- CHANGE SPECIAL PAYMENT INDICATOR LOGIC        *
      *           - '1' OR '2' SPECIAL PAYMENT INDICATOR        *
      *             WILL NOT ALLOW WAGE INDEX TO BE ALTERED     *
      *           - CHANGE MADE IN 3100-INIT                    *
      *                                                         *
      * 03/14/05- CHANGE 2005 FLOOR AND SEC 401 FOR APRIL       *
      *           - UPDATE 2005 FLOOR                           *
      *           - UPDATE 2005 SEC 401 AND ADD NEW SEC 401     *
      *             EFFECTIVE APRIL 01, 2005                    *
      *                                                         *
      * 05/05/05- CHANGE BLOOD DEDUCTIBLE LOGIC FOR JULY 2005   *
      *           - ACCEPT PAYMENT ADJUSTMENT FLAGS 5 AND 6     *
      *           - ONLY APPLY DEDUCTIBLE TO BLOOD PRODUCT      *
      *             REVENUE CODE 0380                           *
      *                                                         *
      * 06/08/05- ADD APC RATES FOR ASP DRUGS                   *
      *                                                         *
      * 07/13/05- INCREASE FIELD SIZE FROM 1 TO 2 BYTES FOR:    *
      *           - OPPS-SRVC-IND                               *
      *           - OPPS-PYMT-IND                               *
      *           - OPPS-PYMT-ADJ-FLAG                          *
      *           - W-DCP-SRVC-IND                              *
      *                                                         *
      * 07/13/05- CHANGE ALL LOGIC ASSOCIATED WITH THE ABOVE    *
      *           FIELDS                                        *
      *                                                         *
      * 09/06/05- UPDATE ASP DRUG RATES IN THE APC TABLE        *
      *                                                         *
      * 09/13/05- CORRECT APC 09224 EFFECTIVE DATE              *
      *                                                         *
      * 11/22/05- ADD 5000 SECTION FOR CY2006                   *
      *                                                         *
      * 11/22/05- UPDATE APC RATES FOR CY2006                   *
      *                                                         *
      * 11/22/05- UPDATE OFFSET LOGIC FOR CY2006                *
      *           - NEW TABLE ADDED                             *
      *             - OPPSOF06                                  *
      *               - OFFSET FOR APC 00222                    *
      *                                                         *
      * 11/22/05- ADD LOGIC TO ADJUST PAYMENT FOR 505           *
      *           HOSPITALS (7.1%)                              *
      *           - 5550-SCH-ADJ                                *
      *                                                         *
      * 11/22/05- UPDATE OUTLIER FACTOR FOR CMHC'S              *
      *           - 5600-ADJ-CHRG-OUTL                          *
      *             - H-OUTLIER-FACTOR = 3.4                    *
      *                                                         *
      * 11/22/05- UPDATE OUTLIER THRESHOLD                      *
      *           - 5600-ADJ-CHRG-OUTL                          *
      *             - THRESHOLD INCREASED TO $1250              *
      *                                                         *
      * 06/26/06- UPDATE ASP DRUGS FOR JULY 2006                *
      *           UPDATED THE SCH LOOKUP-PROCESS                *
      *           CORRECTED THE PAYMENT PROCESS FOR BLOOD       *
      *             PRODUCTS.                                   *
      *           INCREASED THE SIZE OF WORK COINSURACE FIELDS  *
      *                                                         *
      * 11/13/06- ADDED 6000 SECTION FOR CY2007                 *
      *           REDEFINE OF UNUSED L-PROV-SPEC-AREA FIELD     *
      *              BEFORE                                     *
      *                  L-PSF-BED-SIZE               PIC 9(5)  *
      *              AFTER                                      *
      *                  L-PSF-STATE-CODE             PIC 9(02) *
      *                  L-PSF-TOPS-INDICATOR         PIC X(01) *
      *                  L-PSF-HOSP-QUAL-IND          PIC X(01) *
      *                  FILLER                       PIC X(01) *
      *                                                         *
      *           MOVE 992 TO H-IP-LIMIT.                       *
      *           OUTLIER HOSPITAL THRESHOLD OF $1825.          *
      *           NEW WAC TABLE RENAMED PD-AT-CST-W-COIN7.      *
      *           ADDED MANY COMMENTS.                          *
      *           MOVED PROCEDURE DIV. PARAGRAPHS TO COLUMN 8.  *
      *           NEW BLOOD RANKING TABLE FOR 2007.             *
      *           NEW 2007 BRACH & RADIOPHARM TABLE FOR 20% COIN*
      *           NEW COPYBOOK OPPSOF07 FOR 2007 OFFSETS.       *
      *           NEW COPYBOOK DEVRED07 FOR 2007 DEVICE REDUCT. *
      *           INITIALIZED BLOOD FRACTION IN PARAGRAPH       *
      *             6550-CALC-STANDARD.                         *
      *           ALLOW OPPS-PYMT-ADJ-FLAG VALUE OF ' 7'        *
      *           ALLOW OUTLIER PAYMENT TO CERTAIN BRACHYTHERAPY*
      *             CODES WHEN SERVICE INDICATOR IS K IN        *
      *             PARAGRAPH 6600-ADJ-CHRG-OUTL.               *
      * 12/12/06- REMOVED BRACHYTHERAPY CODES FROM OUTLIER LOGIC*
      *           & ADDED THEM TO THE PD-AT-CST LIST TABLE.     *
      *                                                         *
      * 02/20/07- ADDED APC 00039 TO OFFSET TABLES FOR 2006 &   *
      *           2007.  ALSO ADDED CODE TO 5160-TOTAL & TO     *
      *           6160-TOTAL PARAGRAPHS TO CHECK THAT OFFSET    *
      *           DOES NOT RESULT IN A LINE PAYMENT LESS THAN   *
      *           ZERO.                                         *
      * 04/01/07- PROPOSED:                                     *
      *           ADDED CODE TO 5160-TOTAL & TO 6160-TOTAL      *
      *           TO PERFORM 5161 & 6161 RESPECTIVELY. THE      *
      *           OFFSET CALCULATIONS WILL BE SKIPPED IN THE    *
      *           *161 PARAGRAPHS IF THE OFFSET AMOUNT IS ZERO  *
      *           WHEN A HIT IS MADE WHEN LOOKING UP THE APC.   *
      *                                                         *
      * 05/10/07- VERSION 2007.3.0 UPDATES:                     *
      *           NEW PAID-AT-COST WITH 20% COINSURANCE TABLE   *
      *           EFFECTIVE JULY 1, 2007 FOR SPECIFIED          *
      *           RADIOPHARMS & BRACHYTHERAPY (INCLUDES NEW     *
      *           LOOK-UP LOGIC IN PARAGRAPH 6550-CALC-STANDARD)*
      *                                                         *
      *           ADDED CODE TO 5160-TOTAL & TO 6160-TOTAL      *
      *           TO PERFORM 5161 & 6161 RESPECTIVELY. THE      *
      *           OFFSET CALCULATIONS WILL BE SKIPPED IN THE    *
      *           *161 PARAGRAPHS IF THE OFFSET AMOUNT IS ZERO  *
      *           WHEN A HIT IS MADE WHEN LOOKING UP THE APC.   *
      *                                                         *
      *           APC 00034 ADDED - EFFECTIVE 01/01/2007        *
      *                                                         *
      *           14 APC UPDATES EFFECTIVE 07/01/2007           *
      *                                                         *
      * 06/18/07- VERSION 2007.3.1 UPDATE:                      *
      *           APC TABLE CORRECTED TO INCLUDE 04/01/2007     *
      *           RECORDS AND UPDATES THAT WERE OMITTED FROM    *
      *           VERSION 2007.3.0.                             *
      *                                                         *
      * 06/21/07- VERSION 2007.3.2 UPDATE:                      *
      *           APC TABLE UPDATED WITH THE JULY 2007 ASP DRUG *
      *           RATES AND OTHER RETROACTIVE RATE UPDATES.     *
      *                                                         *
      * 06/27/07- VERSION 2007.3.3 UPDATE:                      *
      *           APC TABLE CORRECTIONS MADE:                   *
      *           - APCS 00844, 01695, & 09002 - 20070701       *
      *             RECORDS' PAYMENT RATES CORRECTED            *
      *           - APC 02632 - 20070101 RECORD PMT RATE        *
      *             CHANGED FROM 'DELETED' (INCORRECTLY DELETED *
      *             IN VERSION 2007.2.1) TO '0000000.'          *
      *                                                         *
      * 07/03/07- VERSION 2007.3.4 UPDATE:                      *
      *           APC TABLE CORRECTION MADE FOR APC 00951       *
      *           (PAYMENT RATES & COINSURANCE CORRECTED)       *
      *                                                         *
      * 08/10/07- VERSION 2007.4.0 UPDATE:                      *
      *           1) UPDATE DEVICE REDUCTION TABLE              *
      *              - APC 315 -> $12,422.60 EFFECTIVE 1/1/07   *
      *              - APC 385 -> $ 2,282.53 EFFECTIVE 1/1/07   *
      *           2) REMOVE HOSPITALS 330044 AND 330245 FROM    *
      *              401 HOSPITAL LOGIC EFFECTIVE 1/1/07        *
      *                                                         *
      * 08/21/07- PREPARE FOR VERSION 2008.1.0 UPDATE:          *
      *           ADDED 7000-... PARAGRAPHS TO PREPARE FOR      *
      *           JANUARY 2008 RELEASE                          *
      *                                                         *
      * 10/30/07- VERSION 2008.1.0 UPDATES:                     *
      * THROUGH   - DOCUMENT ENTIRE PROGRAM (COMMENTS)          *
      * 12/07/07  - CREATED CAL-VERSION7                        *
      *           - NEW APC TABLE                               *
      *           - NEW CBSA WAGE INDEX TABLE                   *
      *           - NEW OFFSET TABLE (ALL OFFSETS = $0)         *
      *           - NEW DEVICE REDUCTION TABLE                  *
      *           - NEW BLOOD DEDUCTIBLE HCPCS TABLE            *
      *           - TABLE FOR COMPOSITE APCS CREATED            *
      *           - TABLE FOR MENTAL HEALTH (MH) HCPCS CREATED  *
      *           - TABLE FOR PARTIAL HOSPITALIZATION (PHP)     *
      *             HCPCS CREATED                               *
      *           - NEW FLAGS: APC34-FLAG, PHP-HCPCS-FLAG,      *
      *             MH-HCPCS-FLAG, BRACHY-APC-FLAG, &           *
      *             BLD-DEDUC-HCPCS-FLAG                        *
      *           - NEW INPATIENT LIMIT (H-IP-LIMIT) = $1,024   *
      *           - NEW OUTLIER THRESHOLD = $1,575              *
      *           - NEW CY 2008 CBSA WAGE INDEX FLOORS          *
      *           - NEW CY 2008 SECTION 401 HOSPITALS           *
      *           - REMOVED PAID AT COST LOGIC - PARAGRAPHS     *
      *             7550-PD-AT-CST-JAN07 & 7550-PD-AT-CST-JUL07 *
      *           - PHP & MH HCPCS ADDED TO LINE ITEM ACTION    *
      *             FLAG VALIDATION LOGIC                       *
      *           - NEW PAYMENT ADJUSTMENT FLAG OF ' 8' &       *
      *             CORRESPONDING PARTIAL CREDIT DEVICE         *
      *             REDUCTION LOGIC ADDED - 7550-DEVICE-COMPUTE *
      *             (APC PMT REDUCED BY 1/2 THE REDUCTION AMT)  *
      *           - PHP HCPCS ADDED TO SITE OF SERVICE VALIDA-  *
      *             TION LOGIC                                  *
      *           - ADDED LOGIC TO EXCLUDE COMPOSITE AND MENTAL *
      *             HEALTH CHARGES FROM TOTAL CLAIM PACKAGED    *
      *             CHARGES                                     *
      *           - ADDED LOGIC TO ACCUMULATE PACKAGED MENTAL   *
      *             HEALTH CHARGES & ADD THEM TO THE APC 34     *
      *             LINE'S CHARGES FOR OUTLIER CALCULATION      *
      *           - ADDED LOGIC TO ACCUMULATE NON-PRIME         *
      *             COMPOSITE APC CHARGES & ADD THEM TO THE     *
      *             PRIME LINE'S CHARGES FOR OUTLIER CALC       *
      *             (NEW PARAGRAPHS: 7170-COMPOSITES,           *
      *              7171-SEARCH-PAF, 7172-ADD-ENTRY,           *
      *              7173-UPDATE-ENTRY, 7174-STAGE-CMP-ENTRY)   *
      *           - ADDED DISCOUNT FACTOR VALUE OF 9 &          *
      *             CORRESPONDING DISCOUNT CALCULATION          *
      *           - 7560-CALC-BENE-DEDUCT PERFORM MOVED FROM    *
      *             7550-SCH-ADJ TO 7550-CALC-STANDARD          *
      *           - LIST OF BRACHYTHERAPY APCS CREATED IN NEW   *
      *             PARAGRAPH 7650-SET-BRACHY-APC-FLAG          *
      *           - NEW LIST OF BLOOD DEDUCTIBLE HCPCS IN NEW   *
      *             PARAGRAPH 7655-SET-BD-HCPCS-FLAG            *
      *           - 7550-CALC-GJK MODIFIED TO CHECK BLOOD       *
      *             DEDUCTIBLE HCPCS FLAG INSTEAD OF LIST       *
      *           - 7550-SCH-ADJ & 7550-CALC-GJK MODIFIED TO    *
      *             APPLY THE SOLE COMMUNITY HOSPITAL ADJ. TO   *
      *             BRACHYTHERAPY & BLOOD LINES WHEN APPLICABLE *
      *           - ADDED LOGIC TO CALCULATE LINE REIMBURSEMENT *
      *             & NATIONAL COININSURANCE TO PARAGRAPH       *
      *             7550-CALC-STANDARD (COPIED FROM LOGIC IN    *
      *             7550-PD-AT-CST-JAN07, WHICH WAS DELETED     *
      *             ALONG WITH 7550-PD-AT-CST-JUL07 FOR CY 2008)*
      *                                                         *
      * 12/17/07- VERSION 2008.1.1 UPDATES:                     *
      *           - REVISED STEP #12 & #13 IN THE PRICING       *
      *             PROCESS OVERVIEW FOR THE 7000 SECTION       *
      *           - ADDED A PERIOD AFTER THE H-NAT-COIN COMPUTE *
      *             IN PARAGRAPH 7550-CALC-STANDARD & MOVED     *
      *             H-MIN-COIN MOVE STATEMENT                   *
      *                                                         *
      * 12/27/07- VERSION 2008.1.2 UPDATES:                     *
      *           - BRACHYTHERPY AND RADIOPHARM LINES' STATUS   *
      *             INDICATORS CHANGED BACK TO 'H' IN THE OCE   *
      *           - INSERT PAID-AT-COST LOGIC FOR BRACHYTHERAPY *
      *             AND RADIOPHARM LINES                        *
      *             - NO PAID-AT-COST TABLE FOR 2008            *
      *             - RADIOPHARM APCS ARE IDENTIFIED BY         *
      *               RADIOPH-APC-FLAG = 'Y'                    *
      *               NEW PARAGRAPH: 7660-SET-RADIOPH-APC-FLAG  *
      *             - BRACHYTHERAPY APCS ARE IDENTIFIED BY      *
      *               BRACHY-APC-FLAG = 'Y'                     *
      *           - NEW LOGIC FOR BRACHYTHERAPY LINES WITH A    *
      *             STATUS INDICATOR OF 'K' RETAINED BECAUSE    *
      *             NO LINES WILL MEET THE CRITERIA; AND        *
      *             THEREFORE, NO CLAIMS WILL BE AFFECTED       *
      *                                                         *
      * 02/08/08 - UPDATED RECORDS OF 24 APCS IN THE APC TABLE  *
      *            THESE RECORDS INCORRECTLY HAD A STATUS       *
      *            INDICATOR OF 'K' IN THE JANUARY RELEASE,     *
      *            THEIR STATUS INDICATORS WERE CHANGED TO 'H'  *
      *            AND THEIR PAYMENT RATES AND COINSURANCE      *
      *            AMOUNTS WERE CHANGED TO $0                   *
      *                                                         *
      * 02/08/08 - ADDED NEW TABLES AND LOGIC FOR ADDING PASS-  *
      * THROUGH    THROUGH DEVICE CHARGES AND PAYMENTS TO ELIG- *
      * 02/14/08   IGIBLE PROCEDURES FOR OUTLIER DETERMINATION  *
      *          - IN PARAGRAPH 7600-ADJ-CHRG-OUT, A-LITEM-PYMT *
      *            IS NO LONGER USED IN THE OUTLIER CALCS.      *
      *            H-LITEM-PYMT-OUTL IS USED INSTEAD            *
      *          - USES NEW APC TABLE THAT INCLUDES STATUS      *
      *            INDICATOR CHANGES FOR 24 APCS (FROM K TO H)  *
      *            AND 2 DELETED HCPCS EFFECTIVE 4/1/08 (APCS   *
      *            1691 & 1692)                                 *
      *          - ROUNDED W-SUB-CHRG WHEN ADDING COMPOSITES IN *
      *            PARAGRAPH 7600-ADJ-CHRG-OUT                  *
      *          - CODE CHANGES AND ADDITIONS ARE AS FOLLOWS:   *
      *                                                         *
      *            LOGIC ADDED TO                               *
      *            PARAGRAPHS:     7150-INIT                    *
      *                            7125-INIT                    *
      *                            7400-CALCULATE               *
      *                            7555-CALC-H-STANDARD         *
      *                            7600-ADJ-CHRG-OUTL           *
      *                                                         *
      *            NEW TABLES:     W-PTD-PROC-HCPCS-TBL         *
      *                            W-PASS-THRU-DEV-PTR-TABLE    *
      *                                                         *
      *            NEW PARAGRAPHS: 7390-PASS-THRU-DEVICES       *
      *                            7391-STAGE-ENTRY             *
      *                            7392-PASS-THRU-DEV-PROCS     *
      *                            7393-PERFORM-SEARCH          *
      *                            7394-SEARCH-PTD-HCPCS        *
      *                            7395-UPDATE-ENTRY            *
      *                            7610-PERFORM-SEARCH          *
      *                            7611-SEARCH-PTD-HCPCS        *
      *                                                         *
      *            NEW VARIABLES:  PTD-FLAG                     *
      *                            PTD-LINE-FLAG                *
      *                            PTD-PROC-FLAG                *
      *                            W-PTD-LINE-HCPCS             *
      *                            W-PTD-CNT                    *
      *                            W-PTD-PROC-SUB               *
      *                            W-END-OF-PTD-TBL             *
      *                            W-PTD-MAX                    *
      *                            H-PTD-UNIT-RATE              *
      *                            H-PTD-SUB-CHRG               *
      *                            H-PTD-LITEM-PYMT             *
      *                            H-LITEM-PYMT-OUTL            *
      *                                                         *
      * 03/20/08- UPDATED APC TABLE WITH ASP DRUGS              *
      *                                                         *
      * 05/13/08- UPDATED APC TABLE WITH THERAPEUTIC RADIOPHARM *
      *           & BRACHYTHERAPY APC SI CHANGE TO ' K' AND TWO *
      *           DRUG APCS' SI CHANGE FROM ' K' TO ' G'        *
      *           (26 TOTAL APC CHANGES)                        *
      *                                                         *
      *           NEW HANDLING OF THERAPEUTIC RADIOPHARMS &     *
      *           BRACHYTHERAPY LINES EFFECTIVE 7/1/2008        *
      *           (LOGIC CREATED IN JANUARY, ENABLED BY THE     *
      *           SI CHANGE TO ' K' ON 7/1/2008)                *
      *           - BRACHYTHERAPIES ARE ELIGIBLE FOR OUTLIER;   *
      *             THERAPEUTIC RADIOPHARMS ARE NOT             *
      *           - BRACHYTHERAPIES & THERAPEUTIC RADIOPHARMS   *
      *             ARE NO LONGER PAID-AT-COST                  *
      *           - BRACHYTHERAPIES ARE ELIGIBLE FOR SCH ADJ.;  *
      *             THERAPEUTIC RADIOPHARMS ARE NOT             *
      *                                                         *
      * 06/23/08- UPDATED APC TABLE WITH ASP DRUGS              *
      *           (271 TOTAL APC CHANGES)                       *
      *                                                         *
      * 08/07/08- UPDATED APC TABLE FOR OCTOBER 2008 RELEASE    *
      *           - CHANGED STATUS INDICATOR OF BRACHYTHERAPY   *
      *             SOURCE & THERAPEUTIC RADIOPHARM APCS FROM   *
      *             'K' BACK TO 'H' - EFFECTIVE 7/1/2008 FOR    *
      *             24 APCS                                     *
      *           - CHANGED STATUS INDICATOR OF APC 1711 FROM   *
      *             'K' TO 'G' EFFECTIVE 10/1/2008              *
      *           UPDATED PROGRAM COMMENTS FOR BRACHYTHERAPY &  *
      *           THERAPEUTIC RADIOPHARM SI CHANGE AND          *
      *           REVISED MENTAL HEALTH PACKAGING COMMENT IN    *
      *           THE OUTLIER ROUTINE.                          *
      *                                                         *
      * 08/08/08- CORRECTED PACKAGING LOGIC FOR MENTAL HEALTH   *
      *           CLAIMS EFFECTIVE RETROACTIVE TO JANUARY 1,    *
      *           2008 IN PARAGRAPH 7150-INIT.                  *
      *                                                         *
      * 09/18/08- ADDED ASP DRUG UPDATES, APC RATE CORRECTIONS, *
      *           & 3 NEW APCS EFFECTIVE 10/01/2008 TO THE APC  *
      *           TABLE (251 CHANGES & ADDITIONS).  UPDATED     *
      *           PRICER VERSION NUMBER TO 2008.4.1.            *
      *                                                         *
      * 11/03/08- CY 2009 UPDATES - VERSION 2009.1.0            *
      *           - ADDED NEW COPY STATEMENTS FOR TABLES        *
      *           - CREATED NEW 8000- SECTION                   *
      *           - ADDED FY 2009 FLOOR LOGIC                   *
      *           - ADDED FY 2009 401 HOSPITAL LOGIC            *
      *           - CHANGED PARTIAL HOSPITALIZATION APC FLAG    *
      *             FROM APC33-FLAG TO PHP-APC-FLAG & UPDATED   *
      *             RELATED LOGIC                               *
      *                                                         *
      * 11/10/08- - ADDED SSRFBN09 TABLE AND COPY STATMENT      *
      *           - ADDED LOGIC TO APPLY SSRFBN TO CBSA WAGE    *
      *             INDEX VALUES BY PROVIDER STATE - ADDED      *
      *             PARAGRAPHS (LOGIC ADAPTED FROM LTCH PRICER  *
      *             V 2009.3 PROGRAM LTCAL093)                  *
      *           - UPDATED DAILY INPATIENT COINSURANCE LIMIT   *
      *             TO $1068                                    *
      *           - UPDATED OUTLIER THRESHOLD TO $1800          *
      *           - UPDATED THE OCE RECORD LAYOUT:              *
      *             - SERVICE UNITS INCREASED FROM 7 TO 9 BYTES *
      *             - ADDED COMPOSITE ADJUSTMENT FLAG, 2 BYTES  *
      *               (OPPS-COMP-ADJ-FLAG)                      *
      *                                                         *
      * 11/12/08- - DISABLED LOGIC THAT FLAGS CLAIMS WITH       *
      *             HCPCS C1820 B/C NO HCPCS ARE ELIGIBLE FOR   *
      *             PASS-THROUGH FOR CY 2009 (7125-INIT)        *
      *           - REMOVED PASS-THROUGH DEVICE (PTD) LIST &    *
      *             PROCEDURES ELIGIBLE FOR PTD LIST B/C THERE  *
      *             ARE NO PAIRINGS FOR CY 2009                 *
      *             (8665-SET-PTD-LINE-FLAG,                    *
      *              8670-SET-PTD-PROC-FLAG)                    *
      *           - CHANGED SECOND PTD-FLAG CHECK IN PARAGRAPH  *
      *             8600-ADJ-CHRG-OUTL TO PTD-PROC-FLAG CHECK   *
      *           - CHANGE LOGIC TO LOOK AT COMPOSITE ADJUSTMENT*
      *             FLAG (NEW FOR CY 2009) INSTEAD OF PAYMENT   *
      *             ADJUSTMENT FLAGS 91 - 99 TO ID COMPOSITES   *
      *           - BRACHYTHERAPY APC LIST REMOVED,             *
      *             BRACHYTHERAPY LINES NOW IDENTIFIED WITH A   *
      *             STATUS INDICATOR OF ' U'                    *
      *             PARAGRAPH 8650-SET-BRACHY-APC-FLAG DISABLED *
      *           - ADDED ' U' AND ' R' TO LIST OF VALID STATUS *
      *             INDICATORS FOR BRACHY AND BLOOD LINES       *
      *                                                         *
      * 11/13/08- - EXCLUDED THERAPEUTIC RADIOPHARM LINES FROM  *
      *             CLAIM DEVICE UNITS CALC, CLAIM DEVICE       *
      *             CHARGES CALC, AND WAGE ADJ DEVICE OFFSET    *
      *             CALC                                        *
      *           - EXCLUDED BRACHYTHERAPIES FROM OUTLIER CALC  *
      *           - ADDED VARIABLES AND CALC LINE PAYMENTS FOR  *
      *             APC 0173 - WITH AND WITHOUT SCH ADJ.        *
      *           - ALTERED PHP OUTLIER LOGIC TO ALWAYS USE THE *
      *             PHP "CAP" APC'S LINE PAYMENT IN THE CALC    *
      *           - EXCLUDED BRACHY LINES FROM ALL DEVICE LOGIC *
      *           - ADDED REDUCED UPDATE RATIO FOR HOSPITAL     *
      *             QUALITY INDICATOR, PAR 8180-REDUCE-APC-PYMT *
      *           - REVISED ALL SI = K LOGIC TO ACCOMODATE      *
      *             BLOOD DEDUCTIBLE LINE SI CHANGE FROM K TO R *
      *             (SCH PYMT, BLOOD DEDUCTIBLE CALCS)          *
      *                                                         *
      * 11/24/08- - REVISED COMMENT IN 8560-CALC-BENE-DEDUCT    *
      *             TO EXPLAIN THAT LINES WITH A PAF=4 ARE      *
      *             CLINICAL TRIAL LINES FOR MANAGED CARE BENES *
      *                                                         *
      * 12/02/08- - INCREASED H-SRVC-UNITS, W-BD-SRVC-UNITS,    *
      *             AND W-SRVC-UNITS FROM 7 TO 9 BYTES          *
      *           - INCREASED FILLER IN GROUP OCE-IN-DATE       *
      *             FROM 21 TO 23 TO ACCOUNT FOR INCREASE IN    *
      *             UNITS                                       *
      *                                                         *
      * 12/05/08- - ASSIGNED RETURN CODE 11 IN PARAGRAPH        *
      *             8180-REDUCE-APC-PYMT WHEN THE ABSENCE OF    *
      *             QUALITY REPORTING LEADS TO A REDUCED PMT,   *
      *             ADDED SI=R TO ELIGIBLE SI LIST              *
      *           - CORRECTED SCH LOGIC TO CALCULATE BLOOD      *
      *             LINES INELIGIBLE FOR A DEDUCTIBLE           *
      *           - IN PARAGRAPH 8550-CALC-GJK, CORRECTED LOGIC *
      *             TO CALCULATE THE SCH ADJUSTMENT (WHEN       *
      *             APPLICABLE) FOR BLOOD LINES THAT DON'T HAVE *
      *             A PAF OF 5 OR 6                             *
      *           - IN PARAGRAPH 8600-ADJ-CHRG-OUTL ADDED       *
      *             SI=K TO LIST OF SIS INELIGIBLE FOR OUTLIERS *
      *                                                         *
      * 12/18/08- CREATE VERSION 2009.1.1                       *
      *           - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (325 TOTAL APC CHANGES)                     *
      *                                                         *
      * 02/09/09- CREATE VERSION 2009.2.0 (FOR APRIL 2009)      *
      * 2009.2.0  ADD COMMENT TO PARAGRAPH 7600-ADJ-CHRG-OUTL   *
      *           TO EXPLAIN THAT NO CY 2008 BLOOD LINES ARE    *
      *           PAID AN OUTLIER                               *
      *                                                         *
      * 02/10/09- ADD COMMENTS TO WORKING STORAGE SECTION       *
      * 2009.2.0  MOVED LOCATION OF PASS-THROUGH DEVICE         *
      *           PROCEDURE TABLE IN WORKING STORAGE FOR        *
      *           ORGANIZATIONAL PURPOSES                       *
      *                                                         *
      * 02/10/09- ADD LOGIC TO PROCESS PASS-THROUGH             *
      * THROUGH   RADIOPHARMACEUTICAL OFFSETS                   *
      * 02/13/09                                                *
      * 2009.2.0  NEW COPYBOOKS:                                *
      *               - PT RADIOPHARM HCPCS TABLE (OPPSPTRH)    *
      *                 (HCPCS WITH EFFECTIVE DATE &            *
      *                  TERMINATION DATE)                      *
      *               - PT RADIOPHARM OFFSET TABLE (OPPSPTRO)   *
      *                 (NUCLEAR APCS WITH OFFSET               *
      *                  AMOUNTS & EFFECTIVE YEAR)              *
      *                                                         *
      *           NEW WORKING-STORAGE TABLE:                    *
      *               - W-NUCMED-APC-TBL                        *
      *                                                         *
      *           NEW VARIABLES:                                *
      *               - PTRADIO-CLAIM-FLAG                      *
      *               - PTRADIO-LINE-FLAG                       *
      *               - W-PTRADIO-LINE-HCPCS                    *
      *               - W-PTRADIO-CHRG-RATE                     *
      *               - W-PTRADIO-LINE-OFFSET                   *
      *               - NUCMED-LINE-FLAG                        *
      *               - W-NUCMED-LINE-APC                       *
      *               - W-NUCMED-SUB                            *
      *               - W-NUCMED-UNIT-CNT                       *
      *               - W-END-OF-NUCMED-TBL                     *
      *               - W-NUCMED-OFFSET                         *
      *               - W-NUCMED-WA-OFFSET                      *
      *               - W-LINE-SRVC-DATE                        *
      *               - H-PTRADIO-TOT-CHRGS                     *
      *               - H-NUCMED-TOT-OFFSET                     *
      *               - H-PTRADIO-HCPCS-CNT                     *
      *                                                         *
      *           NEW PARAGRAPHS:                               *
      *               - 8165-PROCESS-NUCLEAR-MED                *
      *               - 8166-LOAD-NUCMED-TABLE                  *
      *               - 8167-STAGE-NUCMED-ENTRY                 *
      *               - 8550-PTRADIO-OFFSET                     *
      *               - 8680-SET-PTRADIO-LINE-FLAG              *
      *                                                         *
      *           EXISTING PARAGRAPHS WITH NEW LOGIC:           *
      *               - 8000-PROCESS-MAIN-NEW                   *
      *               - 8100-INIT                               *
      *               - 8125-INIT                               *
      *               - 8150-INIT                               *
      *               - 8550-CALC-STANDARD                      *
      *                                                         *
      * 03/19/09- CREATE VERSION 2009.2.1                       *
      * 2009.2.1  - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (254 TOTAL APC CHANGES)                     *
      *                                                         *
      * 03/26/09- CREATE VERSION 2009.2.2                       *
      * 2009.2.2  - CORRECTED MEMBERS OPPSPTRO AND BASEPTRO BY  *
      *             ADDING APC 00414 TO NUCLEAR MEDICINE LIST   *
      *             PER HPAR CR6416H                            *
      *                                                         *
      * 05/08/09- CREATE VERSION 2009.3.0                       *
      * 2009.3.0  UPDATED WORKING STORAGE VERSION NUMBER        *
      *                                                         *
      * 05/11/09- REVISED LOGIC THAT IDENTIFIES LINES ELIGIBLE  *
      * 2009.3.0  FOR BLOOD DEDUCTIBLE FOR YEARS 2005 - 2009.   *
      *           IN ADDITION TO HAVING A HCPCS IN BD TABLE,    *
      *           OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')  *
      *           EXISTING PARAGRAPHS WITH NEW LOGIC:           *
      *               - 4150-INIT                               *
      *               - 5150-INIT                               *
      *               - 6150-INIT                               *
      *               - 7150-INIT                               *
      *               - 8150-INIT                               *
      *               - 8550-SCH-ADJ                            *
      *                                                         *
      * 05/12/09- REVISED LOGIC FOR YEARS 2005 - 2008 TO ALLOW  *
      * 2009.3.0  ALL BLOOD LINES TO ENTER THE OUTLIER LOGIC BY *
      *           IDENTIFYING BLOOD LINES BY HCPCS              *
      *           NEW TABLE:    W-2005-2008-BLOOD-HCPCS-TABLE   *
      *           NEW VARIABLE: W-BLD-HCPCS-FLAG                *
      *           EXISTING PARAGRAPHS WITH NEW LOGIC:           *
      *               - 4600-ADJ-CHRG-OUTL                      *
      *               - 5600-ADJ-CHRG-OUTL                      *
      *               - 6600-ADJ-CHRG-OUTL                      *
      *               - 7600-ADJ-CHRG-OUTL                      *
      *                                                         *
      * 05/12/09- REVISED CY 2008 LOGIC FOR MENTAL HEALTH       *
      * 2009.3.0  COMPOSITES TO DISTRIBUTE PACKAGED MENTAL      *
      *           HEALTH CHARGES EVENLY TO ALL PAYABLE APC 34   *
      *           LINES ON THE CLAIM                            *
      *           NEW VARIABLE: W-APC34-CNT                     *
      *           EXISTING PARAGRAPHS WITH NEW LOGIC:           *
      *               - 7125-INIT                               *
      *               - 7600-ADJ-CHRG-OUTL                      *
      *                                                         *
      * 05/14/09- CORRECTED FORMAT OF FIELD W-BD-RANK           *
      * 2009.3.0  CHANGED FROM PIC 9(05) TO PIC 9(02)           *
      *           AFFECTS BLOOD DEDUCTIBLE PAYMENTS FOR YEARS   *
      *           2005 THROUGH 2009; BEFORE CORRECTION BLOOD    *
      *           DEDUCTIBLE APC LINES WERE NOT ORDERED FROM    *
      *           LOWEST TO HIGHEST RANK (APC PMT) AS INTENDED  *
      *                                                         *
      * 06/18/09- CREATE VERSION 2009.3.1                       *
      * 2009.3.1  - ADDED PERIODS TO END IF STATEMENTS IN       *
      *             PARAGRAPH 4550-ADJ-PLATE-COST               *
      *           - UPDATED APC TABLE WITH ASP DRUGS            *
      *             (270 TOTAL APC CHANGES)                     *
      *           - UPDATED WORKING STORAGE VERSION NUMBER      *
      *           - UPDATED CAL-VERSION TO REFLECT THE THIRD    *
      *             QUARTER UPDATE                              *
      *                                                         *
      * 06/23/09- CREATE VERSION 2009.3.2                       *
      * 2009.3.2  - UPDATED APC TABLE WITH JULY ASP DRUG RATES  *
      *             (270 TOTAL APC CHANGES; 2 CHANGES SINCE THE *
      *              LAST RELEASE: CORRECTIONS TO RATES OF APCS *
      *              01608 AND 01686)                           *
      *           - UPDATED WORKING STORAGE VERSION NUMBER      *
      *                                                         *
      ***********************************************************
       DATE-COMPILED.
       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       SOURCE-COMPUTER.            IBM-370.
       OBJECT-COMPUTER.            IBM-370.
       INPUT-OUTPUT  SECTION.
       FILE-CONTROL.

       DATA DIVISION.
       FILE SECTION.

       WORKING-STORAGE SECTION.

      ***************************************************************
      *   OPPS PRICER VERSION NUMBER (YYYY.Q.V - YEAR.QTR.VERSION)  *
      *-------------------------------------------------------------*
      *   UPDATE FOR EVERY NEW RELEASE                              *
      ***************************************************************
       01  W-STORAGE-REF                  PIC X(46)  VALUE
           'OPCAL2009.3.2 - W O R K I N G   S T O R A G E'.


      ***************************************************************   00000100
      *   OPPS PRICER CALCULATION SECTION VERSION                   *
      *-------------------------------------------------------------*
      *   UPDATE EVERY JANUARY & FOR ANY NEW SECTIONS CREATED       *   00000300
      *   MID-YEAR DUE TO A MAJOR LOGIC CHANGE                      *
      ***************************************************************   00000600
       01  CAL-VERSION0                   PIC X(07)  VALUE 'C2002.0'.
       01  CAL-VERSION1                   PIC X(07)  VALUE 'C2002.3'.
       01  CAL-VERSION2                   PIC X(07)  VALUE 'C2003.1'.
       01  CAL-VERSION3                   PIC X(07)  VALUE 'C2004.4'.
       01  CAL-VERSION4                   PIC X(07)  VALUE 'C2005.4'.
       01  CAL-VERSION5                   PIC X(07)  VALUE 'C2006.1'.
       01  CAL-VERSION6                   PIC X(07)  VALUE 'C2007.1'.
       01  CAL-VERSION7                   PIC X(07)  VALUE 'C2008.1'.
       01  CAL-VERSION8                   PIC X(07)  VALUE 'C2009.3'.
       01  R1                             PIC S9(04) COMP SYNC.
       01  R2                             PIC S9(04) COMP SYNC.
       01  R3                             PIC S9(04) COMP SYNC.
       01  R4                             PIC S9(04) COMP SYNC.



      ***************************************************************
      ***************************************************************
      ***                                                         ***
      **                       COPYBOOKS                           **
      ***                                                         ***
      ***************************************************************
      ***************************************************************
      *                                                             *
      *   1) APC PASS-THROUGH DEVICE OFFSET TABLES                  *
      *   2) APC RATE HISTORY TABLE                                 *
      *   3) MSA WAGE INDEX HISTORY TABLE                           *
      *   4) CBSA WAGE INDEX HISTORY TABLE                          *
      *   5) PARTIAL HOSPITALIZATION HCPCS TABLES                   *
      *   6) MENTAL HEALTH HCPCS TABLES                             *
      *   7) DEVICE REDUCTION TABLES                                *
      *   8) STATE-SPECIFIC RURAL FLOOR BUDGET NEUTRALITY TABLES    *
      *                                                             *
      ***************************************************************


      ***************************************************************
      *   LAYUP TABLE AREA FOR ANNUAL APC OFFSET ADJUSTMENTS        *
      *-------------------------------------------------------------*   00000100
      *   OFFSETS ARE THE DIFFERENCE IN APC $'S FOR THAT APC.       *   00000300
      *   DEVICES (C-CODE HCPCS) ARE OFFSET.                        *   00000400
      *                                                             *   00000500
      *   ADJUST YEARS FOR CONSISTENCY                              *   00000300
      *   ASK JOEY EACH JANUARY IF THERE ARE OFFSETS FOR THE YR     *   00000300
      *                                                             *   00000500
      *   OPPSOF02 - EFFECTIVE AS OF 04-01-2002                     *
      *   OPPSOF03 - EFFECTIVE AS OF 01-01-2003                     *
      *                                                             *   00000500
      *   CY 2004 - WOO-INDX2                                       *   00000500
      *   CY 2005 - WOO-INDX3                                       *   00000400
      *   CY 2006 - WOO-INDX4                                       *   00000400
      *   CY 2007 - WOO-INDX7                                       *   00000500
      *   CY 2008 - WOO-INDX8 - ALL APC OFFSETS = $0                *   00000500
      *   CY 2009 - NO PASS-THROUGH DEVICE OFFSETS                  *   00000500
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** WOO-INDX   ******************************
       COPY OPPSOF02.

      ****** WOO-INDX2  ******************************
       COPY OPPSOF03.

      ****** WOO-INDX3  ******************************
       COPY OPPSOF04.

      ****** WOO-INDX4  ******************************
       COPY OPPSOF06.

      ****** WOO-INDX7  ******************************
       COPY OPPSOF07.

      ****** WOO-INDX8  ******************************
       COPY OPPSOF08.


      ***************************************************************
      *   LAYUP TABLE AREA FOR APC HISTORY TABLE                    *
      *-------------------------------------------------------------*
      *   HISTORY TABLE IS UPDATED QUARTERLY, TABLE NAME REMAINS    *
      *   THE SAME.                                                 *
      ***************************************************************
      ****** WAA-INDX   ******************************
       COPY OPPSAPCS.


      ***************************************************************
      *   MSA BASED WAGE INDEX HISTORY TABLE                        *
      *-------------------------------------------------------------*
      *   THIS AREA IS FROZEN. DON'T USE MSA ANYMORE USE CBSA       *   00000300
      ***************************************************************   00000600
      ****** WWM-INDX   ******************************
       COPY OPPSWINX.


      ***************************************************************
      *   CBSA BASED WAGE INDEX HISTORY TABLE                       *
      *-------------------------------------------------------------*
      *   HISTORY TABLE IS UPDATED EVERY JANUARY, TABLE NAME        *   00000300
      *   REMAINS THE SAME.                                         *
      ***************************************************************   00000600
      ****** WCM-INDX   ******************************
       COPY OPPSWNXC.


      ***************************************************************
      *   LAYUP TABLE AREA FOR ANNUAL PARTIAL HOSPITALIZATION       *
      *   (PHP) HCPCS LIST                                          *
      *-------------------------------------------------------------*   00000100
      *   THE PHP HCPCS TABLE IS NEW FOR CY 2008 (ADDED 11/5/2007). *   00000300
      *   ASK JOSEPH BRYSON IF THERE IS A NEW LIST EVERY JANUARY.   *   00000500
      *   WHEN THERE IS A NEW LIST, CREATE A NEW TABLE AND ADD IT   *   00000500
      *   TO THE LIST OF COPYBOOKS.                                 *   00000500
      *                                                             *   00000500
      *   CY 2008 - PHP-INDX8                                       *   00000500
      *   CY 2009 - PHP-INDX9                                       *   00000500
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** PHP-INDX8  ******************************
       COPY OPPSPH08.

      ****** PHP-INDX9  ******************************
       COPY OPPSPH09.


      ***************************************************************
      *   LAYUP TABLE AREA FOR ANNUAL MENTAL HEALTH (MH) HCPCS LIST *
      *-------------------------------------------------------------*   00000100
      *   THE MH HCPCS TABLE IS NEW FOR CY 2008 (ADDED 11/5/2007).  *   00000300
      *   ASK JOSEPH BRYSON IF THERE IS A NEW LIST EVERY JANUARY.   *   00000500
      *   WHEN THERE IS A NEW LIST, CREATE A NEW TABLE AND ADD IT   *   00000500
      *   TO THE LIST OF COPYBOOKS.                                 *   00000500
      *                                                             *   00000500
      *   CY 2008 - MH-INDX8                                        *   00000500
      *   CY 2009 - MH-INDX9                                        *   00000500
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** MH-INDX8  *******************************
       COPY OPPSMH08.

      ****** MH-INDX9  *******************************
       COPY OPPSMH09.


      ***************************************************************
      *            THIS IS THE DEVICE REDUCTION TABLE               *
      *          ASSOCIATED WITH DEVICES THAT ARE REPLACED          *
      *          FREE OF CHARGE WITH THEIR OFFSET AMOUNTS           *
      *-------------------------------------------------------------*
      *   THE DEVICE REDUCTION TABLE WAS NEW FOR CY 2007.           *
      *   CHECK WITH POLICY TO DETERMINE WHETHER A NEW TABLE IS     *   00000300
      *   NEEDED EACH JANUARY.                                      *
      *                                                             *   00000500
      *   CY 2007 - DEV-INDX7                                       *   00000500
      *   CY 2008 - DEV-INDX8                                       *   00000500
      *   CY 2009 - DEV-INDX9                                       *   00000500
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** DEV-INDX7  ******************************
       COPY DEVRED07.

      ****** DEV-INDX8  ******************************
       COPY DEVRED08.

      ****** DEV-INDX9  ******************************
       COPY DEVRED09.


      ***************************************************************
      *  THIS IS THE STATE-SPECIFIC RURAL FLOOR BUDGET NEUTRALITY   *
      *  TABLE (SSRFBN) - THE FACTORS IN THIS TABLE ARE APPLIED     *
      *  TO THE CBSA WAGE INDEX VALUES BY PROVIDER STATE.           *
      *-------------------------------------------------------------*
      *   THE SSRFBN TABLE WAS NEW FOR CY 2009.                     *
      *   CHECK WITH POLICY EACH JANUARY FOR A NEW TABLE.           *   00000300
      *   COPY THE COPYBOOK IRFBN___ FROM THE MOST CURRENT VERSION  *   00000300
      *   OF THE LTCH PRICER PACKAGE (MU00.@BFN2699.LTNDM___).      *   00000500
      *                                                             *   00000500
      *   CY 2009 - SSRFBN-IDX09                                    *   00000500
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** SSRFBN-IDX09 ****************************
       COPY SSRFBN09.


      ***************************************************************
      *    LAYUP TABLE AREA FOR PASS-THROUGH RADIOPHARMACEUTICAL    *
      *                    HCPCS HISTORY TABLE                      *
      *-------------------------------------------------------------*
      *   THE PT RADIOPHARM TABLE WAS NEW FOR APRIL 2009            *
      *   CHECK WITH POLICY TO DETERMINE WHETHER TABLE UPDATES ARE  *   00000300
      *   NEEDED EACH QUARTER.  BECAUSE THIS IS A HISTORY TABLE,    *
      *   THE TABLE NAME REMAINS THE SAME.                          *
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** PTRH-INDX   *****************************
       COPY OPPSPTRH.


      ***************************************************************
      *    LAYUP TABLE AREA FOR PASS-THROUGH RADIOPHARMACEUTICAL    *
      *                   OFFSET HISTORY TABLE                      *
      *-------------------------------------------------------------*
      *   THE PT RADIOPHARM OFFSET TBL WAS NEW FOR APRIL 2009       *
      *   THIS TABLE LISTS NUCLEAR MEDICINE APCS WITH THEIR PER     *
      *   UNIT OFFSET AMOUNTS AND EFFECTIVE YEAR.  THESE OFFSETS    *
      *   ARE ASSOCIATED WITH PASS-THROUGH RADIOPHARM SERVICES.     *
      *   CHECK WITH POLICY FOR ANNUAL UPDATES / TABLES.            *   00000300
      *   BECAUSE THIS IS A HISTORY TABLE, THE TABLE NAME REMAINS   *
      *   THE SAME.                                                 *
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** PTRO-INDX   *****************************
       COPY OPPSPTRO.



      ***************************************************************
      ***************************************************************
      ***                                                         ***
      **               WORKING-STORAGE DATA TABLES                 **
      ***                                                         ***
      ***************************************************************
      ***************************************************************
      *                                                             *
      *   1) BLOOD DEDUCTIBLE RANKING TABLES (2005 - 2008)          *
      *   2) MAXIMUM COINSURANCE DATE TABLE (NOT USED)              *
      *   3) PAID AT COST / 20% COIN TABLES (2006 - 2007)           *
      *   4) BLOOD HCPCS TABLE (2005 - 2008)                        *
      *                                                             *
      ***************************************************************


      ***************************************************************
      *          THIS IS THE BLOOD DEDUCTIBLE RANKING TABLE         *
      *        FOR THE BILL BEING PROCESSED BEFORE 01/01/2005       *
      ***************************************************************
      ****** WBD-INDX   ******************************

       01  W-BLOOD-APC-FILLS.
           03                          PIC X(42)  VALUE
              'P902101P901002P903803P901604C101005P905106'.
           03                          PIC X(42)  VALUE
              'C101807P905608P902209P903910P904011C102112'.
           03                          PIC X(35)  VALUE
              'P905813C101614P905415C102016P905717'.
       01  W-BLOOD-APC-TABLE REDEFINES W-BLOOD-APC-FILLS.
           03 WBD-ENTRY OCCURS 17 TIMES
                  INDEXED BY WBD-INDX.
              05  W-BLOOD-HCPCS        PIC X(05).
              05  W-BLOOD-RANK         PIC 9(02).


      ***************************************************************
      *         THIS IS THE BLOOD DEDUCTIBLE RANKING TABLE          *
      *          FOR THE BILL BEING PROCESSED FROM 01/01/2005       *
      ***************************************************************
      ****** WNBD-INDX   ******************************

       01  W-NEW-BLOOD-APC-FILLS.
           03                          PIC X(42)  VALUE
              'P901001P902102P903803P901604P905105P905606'.
           03                          PIC X(42)  VALUE
              'P902207P904008P905409P905810P903911P905712'.
       01  W-NEW-BLOOD-APC-TABLE REDEFINES W-NEW-BLOOD-APC-FILLS.
           03 WNBD-ENTRY OCCURS 12 TIMES
                  INDEXED BY WNBD-INDX.
              05  W-NEW-BLOOD-HCPCS        PIC X(05).
              05  W-NEW-BLOOD-RANK         PIC 9(02).


      ***************************************************************
      *         THIS IS THE BLOOD DEDUCTIBLE RANKING TABLE          *
      *          FOR THE BILL BEING PROCESSED FROM 01/01/2006       *
      *-------------------------------------------------------------*
      *   ASK POLICY IF DIFFERENT EACH YEAR                         *   00000300
      *   P-CODES - BLOOD                                           *   00000500
      *                                                             *   00000500
      *   BENE IS RESPONSIBLE FOR CHEAPEST BLOOD PRODUCT.           *   00000500
      *   3 UNITS/CALENDAR YEAR.                                    *   00000500
      ***************************************************************   00000600
      ****** W6BD-INDX   ******************************

       01  W-2006-BLOOD-APC-FILLS.
           03                          PIC X(42)  VALUE
              'P901001P902102P903803P901604P905605P902206'.
           03                          PIC X(42)  VALUE
              'P905107P904008P905409P905810P903911P905712'.
       01  W-2006-BLOOD-APC-TABLE REDEFINES W-2006-BLOOD-APC-FILLS.
           03 W6BD-ENTRY OCCURS 12 TIMES
                  INDEXED BY W6BD-INDX.
              05  W-2006-BLOOD-HCPCS       PIC X(05).
              05  W-2006-BLOOD-RANK        PIC 9(02).


      ***************************************************************
      *         THIS IS THE BLOOD DEDUCTIBLE RANKING TABLE          *
      *          FOR THE BILL BEING PROCESSED FROM 01/01/2007       *
      *-------------------------------------------------------------*
      *   ASK POLICY IF DIFFERENT EACH YEAR                         *   00000300
      *   P-CODES - BLOOD                                           *   00000500
      *                                                             *   00000500
      *   BENE IS RESPONSIBLE FOR CHEAPEST BLOOD PRODUCT.           *   00000500
      *   3 UNITS/CALENDAR YEAR.                                    *   00000500
      ***************************************************************   00000600
      ****** W7BD-INDX   ******************************

       01  W-2007-BLOOD-APC-FILLS.
           03                          PIC X(42)  VALUE
              'P902101P901002P905603P905104P901605P903806'.
           03                          PIC X(42)  VALUE
              'P902207P905408P904009P905810P903911P905712'.
       01  W-2007-BLOOD-APC-TABLE REDEFINES W-2007-BLOOD-APC-FILLS.
           03 W7BD-ENTRY OCCURS 12 TIMES
                  INDEXED BY W7BD-INDX.
              05  W-2007-BLOOD-HCPCS       PIC X(05).
              05  W-2007-BLOOD-RANK        PIC 9(02).


      ***************************************************************
      *         THIS IS THE BLOOD DEDUCTIBLE RANKING TABLE          *
      *          FOR THE BILL BEING PROCESSED FROM 01/01/2008       *
      *-------------------------------------------------------------*
      *   ASK POLICY IF DIFFERENT EACH YEAR                         *   00000300
      *   P-CODES - BLOOD                                           *   00000500
      *                                                             *   00000500
      *   BENE IS RESPONSIBLE FOR CHEAPEST BLOOD PRODUCT.           *   00000500
      *   DEDUCTIBLE LIMIT IS 3 UNITS/CALENDAR YEAR.                *   00000500
      *   BLOOD HCPCS ARE ORDERED FROM THE LOWEST TO HIGHEST        *
      *   APC PAYMENT RATE.                                         *
      ***************************************************************   00000600
      ****** W8BD-INDX   ******************************

       01  W-2008-BLOOD-APC-FILLS.
           03                          PIC X(42)  VALUE
              'P902101P905602P905103P901604P903805P905406'.
           03                          PIC X(42)  VALUE
              'P904007P901008P905809P902210P903911P905712'.
       01  W-2008-BLOOD-APC-TABLE REDEFINES W-2008-BLOOD-APC-FILLS.
           03 W8BD-ENTRY OCCURS 12 TIMES
                  INDEXED BY W8BD-INDX.
              05  W-2008-BLOOD-HCPCS       PIC X(05).
              05  W-2008-BLOOD-RANK        PIC 9(02).


      ***************************************************************
      *         THIS IS THE BLOOD DEDUCTIBLE RANKING TABLE          *
      *          FOR THE BILL BEING PROCESSED FROM 01/01/2009       *
      *-------------------------------------------------------------*
      *   ASK POLICY IF DIFFERENT EACH YEAR                         *   00000300
      *   P-CODES - BLOOD                                           *   00000500
      *                                                             *   00000500
      *   BENE IS RESPONSIBLE FOR CHEAPEST BLOOD PRODUCT.           *   00000500
      *   DEDUCTIBLE LIMIT IS 3 UNITS/CALENDAR YEAR.                *   00000500
      *   BLOOD HCPCS ARE ORDERED FROM THE LOWEST TO HIGHEST        *
      *   APC PAYMENT RATE.                                         *
      ***************************************************************   00000600
      ****** W9BD-INDX   ******************************

       01  W-2009-BLOOD-APC-FILLS.
           03                          PIC X(42)  VALUE
              'P905401P902102P905103P901604P905605P901006'.
           03                          PIC X(42)  VALUE
              'P903807P904008P902209P905810P903911P905712'.
       01  W-2009-BLOOD-APC-TABLE REDEFINES W-2009-BLOOD-APC-FILLS.
           03 W9BD-ENTRY OCCURS 12 TIMES
                  INDEXED BY W9BD-INDX.
              05  W-2009-BLOOD-HCPCS       PIC X(05).
              05  W-2009-BLOOD-RANK        PIC 9(02).


      ***************************************************************
      *                 THIS IS THE MAX-COINSURANCE                 *
      *           DETERMINED BY DATE LINE-ITEM PROCESSING           *
      *-------------------------------------------------------------*
      *   THIS TABLE IS NOT REFERENCED ANYWHERE IN THE PROGRAM      *
      *   (THE REASON FOR THIS TABLE IS NOT KNOWN AS OF 11/6/2007)  *
      ***************************************************************
      ****** WMC-INDX   ******************************

       01  W-MAX-COIN-DATE-FILLS.
           03                          PIC X(44)  VALUE
              '20000801001200101010022002010100320030101004'.
           03                          PIC X(33)  VALUE
              '200401010052005010100620060101007'.
       01  W-MAX-COIN-DATE-TABLE REDEFINES W-MAX-COIN-DATE-FILLS.
           03  WMC-ENTRY  OCCURS 7 TIMES.
              05  WMC-DATE             PIC X(8).
              05  WMC-DTCD             PIC 9(3).


      ***************************************************************   00000100
      *   FOR THESE 2006 APC'S, 20% COINSURANCE.                    *   00000300
      *   VERIFY IF NEW LIST EACH YEAR                              *   00000500
      *   CONTAINS BRACHYTHERAPY CODES.                             *   00000500
      ***************************************************************   00000600
       01  W-APC-CODE-FILLS.
           03                          PIC X(44)  VALUE
              '07010702070407050737104510641065108810961150'.
           03                          PIC X(44)  VALUE
              '16001602160316041641164216431644164516461647'.
           03                          PIC X(44)  VALUE
              '16481649165016511652165316541671167216731674'.
           03                          PIC X(44)  VALUE
              '16751676167716781679171617171718171917202616'.
           03                          PIC X(44)  VALUE
              '26322633263426352636263791009146914891499150'.
       01  W-APC-CODE-TABLE REDEFINES W-APC-CODE-FILLS.
           03  WAC-ENTRY  OCCURS 55 TIMES
                 INDEXED BY WAC-INDX.
               05  WAC-CODE            PIC X(4).


      ***************************************************************   00000100
      *   FOR THESE 2007 APC'S, 20% COINSURANCE. (NEW WAC NAME)     *   00000300
      *   VERIFY IF NEW LIST EACH YEAR                              *   00000500
      *   CONTAINS BRACHYTHERAPY & RADIOPHARM CODES                 *   00000500
      *   TABLE EFFECTIVE 1/1/2007 - 6/30/2007                      *
      ***************************************************************   00000600
       01  W-PD-AT-CST-W-COIN7.
           03                          PIC X(44)  VALUE
              '07010702070407050722072307240737073907400741'.
           03                          PIC X(44)  VALUE
              '07420743082910451064108810961150160016031604'.
           03                          PIC X(44)  VALUE
              '16421643164416451646164716481650165116541671'.
           03                          PIC X(44)  VALUE
              '16721675167616771678171617171718171917202616'.
           03                          PIC X(32)  VALUE
              '26322633263426352636263791009148'.
       01  W-PD-AT-CST-TABLE7 REDEFINES W-PD-AT-CST-W-COIN7.
           03  PD-AT-CST-W-COIN7-ENTRY OCCURS 52 TIMES
                 INDEXED BY PD-AT-CST-INDX7.
               05  PD-AT-CST-CODE7     PIC X(4).


      ***************************************************************   00000100
      *   FOR THESE 2007 APC'S, 20% COINSURANCE. (NEW WAC NAME)     *   00000300
      *   VERIFY IF NEW LIST EACH YEAR                              *   00000500
      *   CONTAINS BRACHYTHERAPY & RADIOPHARM CODES                 *   00000500
      *   NEW 2007 TABLE, EFFECTIVE JULY 2007                       *
      ***************************************************************   00000600
       01  W-PD-AT-CST-W-COIN7B.
           03                          PIC X(44)  VALUE
              '07010702070407050722072307240737073907400741'.
           03                          PIC X(44)  VALUE
              '07420743082910451064108810961150160016031604'.
           03                          PIC X(44)  VALUE
              '16421643164416451646164716481650165116541671'.
           03                          PIC X(44)  VALUE
              '16721675167616771678171617171719261626322634'.
           03                          PIC X(44)  VALUE
              '26352636263726382639264026412642264326982699'.
           03                          PIC X(08)  VALUE
              '91009148'.
       01  W-PD-AT-CST-TABLE7B REDEFINES W-PD-AT-CST-W-COIN7B.
           03  PD-AT-CST-W-COIN7B-ENTRY OCCURS 57 TIMES
                 INDEXED BY PD-AT-CST-INDX7B.
               05  PD-AT-CST-CODE7B    PIC X(4).


      ***************************************************************
      *                THIS IS THE BLOOD HCPCS TABLE                *
      *  FOR THE BILL BEING PROCESSED FROM 01/01/2005 - 12/31/2008  *
      *-------------------------------------------------------------*
      *   THIS TABLE LISTS EVERY BLOOD AND BLOOD PRODUCT HCPCS      *   00000300
      *   EFFECTIVE CY 2005 THROUGH CY 2008                         *   00000500
      *                                                             *   00000500
      ***************************************************************   00000600
      ****** WBLH-INDX   ******************************

       01  W-2005-2008-BLOOD-HCPCS-FILLS.
           03                          PIC X(45)  VALUE
                'P9010P9011P9012P9016P9017P9019P9020P9021P9022'.
           03                          PIC X(45)  VALUE
                'P9023P9031P9032P9033P9034P9035P9036P9037P9038'.
           03                          PIC X(45)  VALUE
                'P9039P9040P9043P9044P9048P9050P9051P9052P9053'.
           03                          PIC X(35)  VALUE
                'P9054P9055P9056P9057P9058P9059P9060'.
       01  W-2005-2008-BLOOD-HCPCS-TABLE REDEFINES
              W-2005-2008-BLOOD-HCPCS-FILLS.
           03 WBLHCPCS-ENTRY OCCURS 34 TIMES
                  INDEXED BY WBLH-INDX.
              05  W-2005-2008-BLOOD-HCPCS  PIC X(05).



      ***************************************************************
      ***************************************************************
      ***                                                         ***
      **               MISCELLANEOUS WORK VARIABLES                **
      ***                                                         ***
      ***************************************************************
      ***************************************************************
       01  WORK-AREA.
           05  H-SUB                   PIC S9(07) COMP-3  VALUE ZERO.
           05  W-SUB1                  PIC S9(07) COMP-3  VALUE ZERO.
           05  W-SUB2                  PIC S9(07) COMP-3  VALUE ZERO.
           05  W-SUB3                  PIC S9(07) COMP-3  VALUE ZERO.
           05  PS-SUB                  PIC S9(07) COMP-3  VALUE ZERO.
           05  LN-SUB                  PIC S9(07) COMP-3  VALUE ZERO.
           05  DISC-FRACTION           PIC 9V9(03)  VALUE .500.
           05  TERM-PROC-DISC          PIC 9V9(03)  VALUE .500.
           05  APC33-FLAG              PIC X(01).
      *----------------------------------------------*
      * 11/03/2008 - PHP APC FLAG ADDED              *
      *----------------------------------------------*
           05  PHP-APC-FLAG            PIC X(01).
      *----------------------------------------------*
      * 11/28/2007 - APC 34 FLAG ADDED               *
      *----------------------------------------------*
           05  APC34-FLAG              PIC X(01).
      *----------------------------------------------*
      * 05/12/2009 - APC 34 COUNTER ADDED            *
      *----------------------------------------------*
           05  W-APC34-CNT             PIC 9(03).
           05  C1820-OFFSET-FLAG       PIC X(01).
           05  GJK-FLAG                PIC X(01).
           05  ST0-FLAG                PIC X(01).
           05  N-FLAG                  PIC X(01).
           05  C-FLAG                  PIC X(01).
           05  T-LITEM-PYMT            PIC S9(07)V9(02).
           05  W-OFF-APC               PIC X(05).
      *--------------------------------------------------*
      * 11/5/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED *
      *--------------------------------------------------*
           05  PHP-HCPCS-FLAG          PIC X(01).
           05  MH-HCPCS-FLAG           PIC X(01).
      *--------------------------------------------------*
      * 11/6/2007 - BRACHYTHERAPY APC FLAG ADDED         *
      *--------------------------------------------------*
           05  BRACHY-APC-FLAG         PIC X(01).
      *--------------------------------------------------*
      * 12/27/2007 - RADIOPHARM APC FLAG ADDED           *
      *--------------------------------------------------*
           05  RADIOPH-APC-FLAG         PIC X(01).
      *-------------------------------------------------------------*
      * 11/13/2007 - BLOOD HCPCS SUBJECT TO BLOOD DEDUC. FLAG ADDED *
      *-------------------------------------------------------------*
           05  BLD-DEDUC-HCPCS-FLAG    PIC X(01).
      *-------------------------------------------------------------*
      * 02/11/2008 - PASS-THROUGH DEVICE FLAGS ADDED                *
      *-------------------------------------------------------------*
           05  PTD-FLAG                PIC X(01).
           05  PTD-LINE-FLAG           PIC X(01).
           05  PTD-PROC-FLAG           PIC X(01).
      *-------------------------------------------------------------*
      * 02/13/2008 - ADDED W-PTD VARIABLES FOR PASS-THROUGH DEVICES *
      *-------------------------------------------------------------*
           05  W-PTD-LINE-HCPCS        PIC X(05).
           05  W-PTD-CNT               PIC 9(03).
           05  W-PTD-PROC-SUB          PIC 9(03).
           05  W-END-OF-PTD-TBL        PIC X(01).
      *-------------------------------------------------------------*
      * 02/10/2009 - VARIABLES FOR PASS-THROUGH RADIOPHARM LOGIC    *
      *-------------------------------------------------------------*
           05  PTRADIO-CLAIM-FLAG      PIC X(01).
           05  PTRADIO-LINE-FLAG       PIC X(01).
           05  W-PTRADIO-LINE-HCPCS    PIC X(05).
           05  W-PTRADIO-CHRG-RATE     PIC 9(01)V9(8).
           05  W-PTRADIO-LINE-OFFSET   PIC 9(07)V99.
           05  NUCMED-LINE-FLAG        PIC X(01).
           05  W-NUCMED-LINE-APC       PIC X(05).
           05  W-NUCMED-SUB            PIC 9(03).
           05  W-NUCMED-UNIT-CNT       PIC 9(03).
           05  W-END-OF-NUCMED-TBL     PIC X(01).
           05  W-NUCMED-OFFSET         PIC 9(07)V99.
           05  W-NUCMED-WA-OFFSET      PIC 9(07)V99.
           05  W-LINE-SRVC-DATE.
               10  W-LINE-SRVC-YEAR    PIC 9(04).
               10  W-LINE-SRVC-MONTH   PIC 9(02).
               10  W-LINE-SRVC-DAY     PIC 9(02).
      *-------------------------------------------------------------*
      * 05/12/2009 - ADDED TO IDENTIFY BLOOD HCPCS FOR 2005 - 2008  *
      *-------------------------------------------------------------*
           05 W-BLD-HCPCS-FLAG         PIC X(01).

       01  EIGHTY-8-SWS.
           05  GEO-CBSA-FLAG           PIC X(5).
               88 RURAL-GEO              VALUE '   01' THRU '   99'.
           05  WI-CBSA-FLAG            PIC X(5).
               88 RURAL-WI               VALUE '   01' THRU '   99'.


      ***************************************************************
      ***************************************************************
      ***                                                         ***
      **   BELOW ARE THE VARIABLES THAT WILL BE HELD FOR CLAIM     **
      **   LEVEL PROCESSING (OUTLIER/DEDUCTIBLE/COINSURANCE)       **
      ***                                                         ***
      ***************************************************************
      ***************************************************************
       01  H-ADDITIONAL-VARIABLES.
           05  H-OUTLIER-PYMT             PIC S9(07)V9(02).
           05  H-PRTL-HOSP-PYMT           PIC 9(07)V9(02).
           05  H-TOTAL-CLM-DEDUCT         PIC 9(03)V9(02).
           05  H-TOTAL-OFFSET             PIC S9(07)V9(02).
           05  H-TOTAL-WAOFF              PIC 9(07)V9(02).
           05  H-TOT-CHRG                 PIC 9(07)V9(02).
           05  H-TOT-PYMT                 PIC 9(07)V9(02).
           05  H-BENE-DEDUCT              PIC 9(03)V9(02).
           05  H-MAX-COIN                 PIC 9(07)V9(02).
           05  H-IP-LIMIT                 PIC 9(05)V9(02).
           05  H-NEW-COIN                 PIC 9(05)V9(02).
           05  H-NEW-WGNAT                PIC 9(05)V9(02).
           05  H-BLOOD-DEDUCT-DUE         PIC 9(05)V9(02).
           05  H-TOT-ST-CHRG              PIC 9(08)V99.
           05  H-TOT-N-CHRG               PIC 9(08)V99.
           05  H-TOT-H-CHRG               PIC 9(08)V99.
      *-------------------------------------------------------------*
      * 11/28/2007 - TOTAL MENTAL HEALTH CHARGES ADDED              *
      *-------------------------------------------------------------*
           05  H-TOT-MH-CHRG              PIC 9(08)V99.
           05  H-TOT-38X                  PIC 9(08)V99.
           05  H-TOT-38X-39X              PIC 9(08)V99.
           05  H-38X-39X-RATE             PIC 9(01)V9(04).
           05  H-TOT-ST-PYMT              PIC 9(08)V99.
           05  H-TOT-STVX-PYMT            PIC 9(08)V99.
           05  H-TOT-HTD-UNITS            PIC S9(09).
           05  H-TOT-OFF-UNITS            PIC S9(09).
           05  H-BENE-BLOOD-PINTS         PIC 9(01).
           05  H-BENE-PINTS-USED          PIC 9(01).
      *-------------------------------------------------------------*
      * 02/10/2009 - VARIABLES FOR PASS-THROUGH RADIOPHARM LOGIC    *
      *-------------------------------------------------------------*
           05  H-PTRADIO-TOT-CHRGS      PIC 9(08)V99.
           05  H-NUCMED-TOT-OFFSET      PIC 9(08)V99.
           05  H-PTRADIO-HCPCS-CNT      PIC 9(03).


      ***************************************************************
      ***************************************************************
      ***                                                         ***
      **   BELOW ARE THE VARIABLES THAT WILL BE HELD FOR LINE      **
      **                      LEVEL PROCESSING                     **
      ***                                                         ***
      ***************************************************************
      ***************************************************************
           05  LINE-HOLD-ITEMS.
              10  H-COIN-PERCENT          PIC 9(01)V9(04).
              10  H-LITEM-PYMT            PIC S9(07)V9(02).
              10  H-LITEM-OUTL-PYMT       PIC S9(07)V9(02).
              10  H-COST                  PIC S9(07)V9(02).
              10  H-LITEM-REIM            PIC 9(07)V9(02).
              10  H-SCH-PYMT              PIC 9(07)V9(02).
              10  H-APC-PYMT              PIC 9(07)V9(02).
              10  H-APC-ADJ-PYMT          PIC 9(07)V9(02).
              10  H-TOTAL-LN-DEDUCT       PIC 9(03)V9(02).
              10  H-LN-BLOOD-DEDUCT       PIC 9(05)V9(02).
              10  H-LN-BLD-PYMT           PIC 9(05)V9(02).
              10  H-NAT-COIN              PIC 9(07)V9(02).
              10  H-MIN-COIN              PIC 9(05)V9(02).
              10  H-PSF-COIN              PIC 9(05)V9(02).
              10  H-RED-COIN              PIC 9(05)V9(02).
              10  H-RATIO                 PIC S9(03)V9(07).
              10  H-SHIFT                 PIC 9(05)V9(02).
              10  H-TOTAL                 PIC 9(05)V9(02).
              10  H-OUTLIER-FACTOR        PIC 9(01)V9(02).
              10  H-OUTLIER-PCT           PIC 9(01)V9(02).
              10  H-LN-PTR                PIC 9(03).
              10  H-SRVC-UNITS            PIC 9(09).
      *       10  H-SRVC-UNITS            PIC 9(07). CHANGED FOR CY09
              10  H-RANK                  PIC 9(05).
              10  H-BLD-RNK.
                15  H-BLD-DOS             PIC 9(08).
                15  H-BLOOD-RANK          PIC 9(02).
      *-------------------------------------------------------------*
      * 11/28/2007 - ADDED PAF FOR COMPOSITE LINES                  *
      * 11/12/2008 - ADDED CAF FOR COMPOSITE LINES (COMP ADJ FLAG)  *
      *-------------------------------------------------------------*
              10  H-CMP-PAF               PIC 9(02).
              10  H-CMP-CAF               PIC 9(02).
              10  H-PSF-MSA               PIC X(04).
              10  H-PSF-CBSA              PIC X(05).
              10  H-DCP-STAGE.
                15  H-DCP-DOS             PIC 9(08).
                15  H-DCP-CODE            PIC 9(01).
              10  H-PPCT                  PIC S9V9(06) COMP-3.
              10  H-DISC-RATE             PIC S9V9(08) COMP-3.
              10  H-BLOOD-FRACTION        PIC S9V9(08) COMP-3.
              10  H-WINX1                 PIC S9V9(04) COMP-3.
              10  H-SUB-CHRG              PIC 9(08)V99.
              10  H-CHRG-RATE             PIC 9(01)V9(8).
              10  H-OFF-RATE              PIC 9(01)V9(8).
      *-------------------------------------------------------------*
      * 02/14/2008 - ADDED W-PTD VARIABLES FOR PASS-THROUGH DEVICES *
      *-------------------------------------------------------------*
              10  H-PTD-UNIT-RATE         PIC 9(01)V9(8).
              10  H-PTD-SUB-CHRG          PIC 9(08)V99.
              10  H-PTD-LITEM-PYMT        PIC 9(07)V99.
      *-------------------------------------------------------------*
      * 02/14/2008 - ADDED H-LITEM-PYMT-OUTL FOR OUTLIER CALC       *
      *-------------------------------------------------------------*
              10 H-LITEM-PYMT-OUTL        PIC 9(07)V99.
      *-------------------------------------------------------------*
      * 11/13/2008 - ADDED VARIABLE FOR PHP APC PAYMENTS            *
      *-------------------------------------------------------------*
           05  H-PHP-LITEM-PYMT-OUTL   PIC 9(07)V99.



      ***************************************************************
      ***************************************************************
      ***                                                         ***
      **     WORKING-STORAGE TABLES TO BE POPULATED IN PROGRAM     **
      ***                                                         ***
      ***************************************************************
      ***************************************************************
      *                                                             *
      *   1) COINSURANCE DEDUCTIBLE TABLE (TO HOLD CLAIM LINES)     *
      *   2) BLOOD DEDUCTIBLE TABLE (TO HOLD BLOOD DEDUCTIBLE LINES)*
      *   3) DRUG COINSURANCE ROLL-UP TABLE                         *
      *   4) PACKAGED COMPOSITE CHARGES TABLE                       *
      *   5) PASS-THROUGH DEVICE TABLE                              *
      *   6) PASS-THROUGH DEVICE PROCEDURE TABLE                    *
      *   7) NUCLEAR MEDICINE APC TABLE (FOR PT RADIOPHARM LOGIC)   *
      *                                                             *
      ***************************************************************


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE TO PROCESS DEDUCTIBLES.         *
      *-------------------------------------------------------------*
      *   THIS TABLE RANKS APC LOW PAYMENT TO HIGH PAYMENT %        *
      *   TABLE TO RANK PRICE DEDUCTIBLES.                          *
      *                                                             *
      ***************************************************************
      ****** W-LP-INDX  ******************************

       01  W-LNC-MAX                      PIC S9(07)  COMP-3 VALUE +0.

       01  W-LINE-PTR-TABLE.
          05  W-LP-ENTRY
                OCCURS 0 TO 450 TIMES
                DEPENDING ON W-LNC-MAX
                ASCENDING KEY IS W-RANK
                INDEXED BY W-LP-INDX.
              10  W-LP-SUB                PIC S9(07)   COMP-3.
              10  W-APC-PYMT              PIC 9(07)V99.
              10  W-NAT-COIN              PIC 9(05)V99.
              10  W-MIN-COIN              PIC 9(05)V99.
              10  W-RED-COIN              PIC 9(04)V99.
              10  W-DISC-RATE             PIC 9(01)V9(08).
              10  W-SRVC-UNITS            PIC 9(09).
      *       10  W-SRVC-UNITS            PIC 9(07).  CHANGED FOR CY09
              10  W-RANK                  PIC 9(05).
              10  W-PPCT                  PIC S9V9(06) COMP-3.
              10  W-WINX1                 PIC S9V9(04) COMP-3.
              10  W-SUB-CHRG              PIC 9(08)V99.


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE TO PROCESS BLOOD DEDUCTIBLES    *
      *-------------------------------------------------------------*
      *   RANK BLOOD DEDUCTIBLE TO DETERMINE LOWEST PRICE FOR       *   00000300
      *   BENE TO PAY.                                              *   00000400
      *                                                             *   00000500
      *   IF PINTS REMAINING, THIS DETERMINES THE CHEAPEST UNIT     *   00000500
      *   FOR BENE TO PAY.                                          *   00000500
      ***************************************************************   00000600
      ****** W-BD-INDX  ******************************

       01  W-BLD-MAX                      PIC S9(07)  COMP-3 VALUE +0.
       01  W-BLOOD-PTR-TABLE.
          05  W-BD-ENTRY
                OCCURS 0 TO 450 TIMES
                DEPENDING ON W-BLD-MAX
                INDEXED BY W-BD-INDX.
              10  W-BD-SUB                PIC S9(07)   COMP-3.
              10  W-BD-APC-PYMT           PIC 9(07)V99.
              10  W-BD-NAT-COIN           PIC 9(05)V99.
              10  W-BD-MIN-COIN           PIC 9(05)V99.
              10  W-BD-RED-COIN           PIC 9(04)V99.
              10  W-BD-DISC-RATE          PIC 9(01)V9(08).
              10  W-BD-SRVC-UNITS         PIC 9(09).
      *       10  W-BD-SRVC-UNITS         PIC 9(07). CHANGED FOR CY09
              10  W-BD-RNK.
                  15  W-BD-DOS            PIC 9(08).
                  15  W-BD-RANK           PIC 9(02).
              10  W-BD-PPCT               PIC S9V9(06) COMP-3.
              10  W-BD-WINX1              PIC S9V9(04) COMP-3.
              10  W-BD-SUB-CHRG           PIC 9(08)V99.


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE TO PROCESS DRUG COINSURANCE     *
      *   ROLL-UP                                                   *
      ***************************************************************
      ****** W-DCP-INDX  ******************************

       01  W-DCP-MAX                      PIC S9(07)  COMP-3 VALUE +0.
       01  W-DOS-COIN-PTR-TABLE.
          05  W-DCP-ENTRY
                OCCURS 0 TO 450 TIMES
                DEPENDING ON W-DCP-MAX
                ASCENDING KEY IS W-DCP-STAGE
                INDEXED BY W-DCP-INDX.
              10  W-DCP-SUB               PIC S9(07).
              10  W-DCP-STAGE.
                 15  W-DCP-DOS            PIC 9(08).
                 15  W-DCP-CODE           PIC 9(01).
              10  W-DCP-SRVC-IND          PIC X(02).
              10  W-DCP-COIN1             PIC 9(05)V99.
              10  W-DCP-COIN2             PIC 9(05)V99.
              10  W-DCP-WGNAT             PIC 9(05)V99.


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE TO ACCUMULATE COMPOSITE APC     *
      *   NON-PRIME LINE CHARGES                                    *
      *   NEW FOR JANUARY 2008                                      *
      ***************************************************************
      ****** W-CMP-INDX  ******************************

       01  W-CMP-MAX                      PIC S9(07)  COMP-3 VALUE +0.
       01  W-COMPOSITE-PTR-TABLE.
          05  W-CMP-ENTRY
                OCCURS 0 TO 450 TIMES
                DEPENDING ON W-CMP-MAX
                ASCENDING KEY IS W-CMP-PAF
                INDEXED BY W-CMP-INDX.
              10  W-CMP-PAF               PIC 9(02).
              10  W-CMP-TOT-SUB-CHRG      PIC 9(10)V99.


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE FOR PASS-THROUGH DEVICES        *
      *   NEW FOR APRIL 2008                                        *
      ***************************************************************
      ****** W-PTD-INDX  *****************************

       01  W-PTD-MAX                      PIC S9(07)  COMP-3 VALUE +0.
       01  W-PASS-THRU-DEV-PTR-TABLE.
          05  W-PTD-ENTRY
                OCCURS 0 TO 450 TIMES
                DEPENDING ON W-PTD-MAX
                ASCENDING KEY IS W-PTD-HCPCS
                INDEXED BY W-PTD-INDX.
              10  W-PTD-HCPCS             PIC X(05).
              10  W-PTD-SUB               PIC S9(07)   COMP-3.
              10  W-PTD-SUB-CHRG          PIC 9(08)V99.
              10  W-PTD-LITEM-PYMT        PIC 9(07)V99.
              10  W-PTD-TOTAL-PROC-UNITS  PIC 9(03).
              10  W-PTD-PROC-CNT          PIC 9(03).


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE FOR PASS-THROUGH DEVICE PROCS   *
      *   NEW FOR APRIL 2008                                        *
      *   02/11/2009 - CHANGED OCCURS FROM 999 TO '0 TO 450' TIMES  *
      ***************************************************************

       01  W-PTD-PROC-HCPCS-TBL.
           05  W-PTD-PROC-HCPCS-ENTRY OCCURS 0 TO 450 TIMES
                 DEPENDING ON W-PTD-CNT.
               10 W-PTD-PROC-HCPCS     PIC X(05).


      ***************************************************************
      *   BELOW IS THE LAY-UP TABLE FOR NUCLEAR MEDICINE APCS       *
      *                                                             *
      *   THIS TABLE HOLDS A NUCLEAR MEDICINE APC RECORD WITH ITS   *
      *   WAGE ADJUSTED OFFSET AMOUNT FOR EVERY NUCLEAR MEDICINE    *
      *   UNIT ON THE CLAIM WHEN A PASS-THROUGH RADIOPHARM HCPCS    *
      *   IS ALSO ON THE CLAIM.                                     *
      *   NEW FOR APRIL 2009 - TABLE ADDED 02/10/2009               *
      *                                                             *
      ***************************************************************
      ****** W-NUCMED-INDX ***************************

       01  W-NUCMED-MAX                    PIC S9(07)  COMP-3 VALUE +0.
       01  W-NUCMED-APC-TBL.
           05  W-NUCMED-APC-ENTRY OCCURS 0 TO 450 TIMES
                 DEPENDING ON W-NUCMED-MAX
                 INDEXED BY W-NUCMED-INDX.
               10 W-NUCMED-APC             PIC X(05).
               10 W-NUCMED-WAGE-ADJ-OFFSET PIC 9(07)V99.



       LINKAGE SECTION.
      ***************************************************************   00000100
      *   WHEN FISS CALLS THIS PROGRAM, THEY GET THE LINKAGE        *   00000300
      *   SECTION.                                                  *   00000400
      ***************************************************************   00000600

      ***************************************************************
      *        LAYUP TABLE AREA FOR PROVIDER SPECIFIC RECORD        *
      ***************************************************************

       01  L-PROV-SPEC-AREA.
               05  L-PSF-NPI                    PIC X(08).
               05  L-PSF-NPI-FILLER             PIC X(02).
               05  L-PSF-PROV-OSCAR.
                 10  L-PSF-PROV-ST              PIC X(02).
                 10  L-PSF-PROV-3456            PIC X(04).
               05  L-PSF-EFFDT                  PIC 9(08).
               05  L-PSF-FY-BEGIN-DT            PIC 9(08).
               05  L-PSF-REPORT-DT              PIC 9(08).
               05  L-PSF-TERMDT                 PIC 9(08).
               05  L-PSF-WAIVE-IND              PIC X(01).
               05  L-PSF-FI-NUM                 PIC 9(05).
               05  L-PSF-PROV-TYPE              PIC X(02).
               05  L-PSF-SPCL-LOCATION-IND      PIC X(01).
               05  L-PSF-WGIDX-RECLASS          PIC X(01).
               05  L-PSF-GEO-MSA                PIC X(04).
               05  L-PSF-WI-MSA                 PIC X(04).
               05  L-PSF-COLA                   PIC 9V9(03).
               05  L-PSF-STATE-CODE             PIC 9(02).
               05  L-PSF-TOPS-INDICATOR         PIC X(01).
               05  L-PSF-HOSP-QUAL-IND          PIC X(01).
               05  FILLER                       PIC X(01).
               05  L-PSF-OPCOST-RATIO           PIC 9V9(03).
               05  L-PSF-GEO-CBSA               PIC X(05).
               05  L-PSF-WI-CBSA                PIC X(05).
               05  L-PSF-SPEC-WGIDX             PIC 9(02)V9(04).
               05  L-PSF-SPEC-PYMT-IND          PIC X(01).
               05  L-PSF-APC-LINE-CNT           PIC 9(04).
               05  L-PSF-APC-TABLE     OCCURS 999 TIMES
                        DEPENDING ON L-PSF-APC-LINE-CNT.
                   10  L-PSF-APC                PIC X(04).
                   10  L-PSF-RED-COIN           PIC 9(04)V99.


      ***************************************************************   00000100
      *  INPUT RECORD FROM THE OCE/STANDARD SYSTEM                  *
      *-------------------------------------------------------------*
      * BELOW ARE THE VARIABLES THAT WILL BE PASSED                 *
      * TO PRICER FROM THE OCE BEGINNING OCT. 1, 2005 THERE WILL BE *
      *    - INCREASED SIZE OF SERVICE AND PAYMENT - 1 TO 2 BYTES   *
      *    - INCREASED SIZE OF PYMT ADJUSTMENT FLAG - 1 TO 2 BYTES  *
      *    CY 2009 EDITS - MADE 11/10/2008:                         *
      *    - INCREASED SIZE OF SERVICE UNITS - 7 TO 9 BYTES         *
      *    - ADDED COMPOSITE ADJUSTMENT FLAG - 2 BYTES              *
      ***************************************************************
       01  OPPS-LINE-CNT                  PIC 9(08) COMP.
       01  OCE-DATA.
           05  OPPS-OCE-LINE OCCURS 450 TIMES
                     DEPENDING ON OPPS-LINE-CNT.
               10  OPPS-HCPCS.
                 15  OPPS-ALPHA           PIC X(01).
                 15  FILLER               PIC X(04).
               10  OPPS-GRP.
                 15  FILLER               PIC X(01).
                 15  OPPS-APC             PIC X(04).
               10  OPPS-HCPCS-APC         PIC X(05).
               10  OPPS-SRVC-IND          PIC X(02).
               10  OPPS-PYMT-IND          PIC X(02).
               10  OPPS-DISC-FACT         PIC 9(01).
               10  OPPS-LITEM-DR-FLAG     PIC X(01).
               10  OPPS-PKG-FLAG          PIC X(01).
               10  OPPS-PYMT-ADJ-FLAG     PIC X(02).
               10  OPPS-SITE-SRVC-FLAG    PIC X(01).
               10  OPPS-SRVC-UNITS        PIC 9(09).
               10  OPPS-SUB-CHRG          PIC 9(08)V99.
               10  OPPS-LITEM-ACT-FLAG    PIC X(01).
               10  OPPS-COMP-ADJ-FLAG     PIC X(02).
       01  L-SERVICE-FROM-DATE       PIC 9(08).
       01  BENE-DEDUCT               PIC 9(03)V9(02).
       01  BENE-BLOOD-PINTS          PIC 9(01).


      ***************************************************************
      *   BELOW ARE THE VARIABLES THAT WILL BE PASSED BACK          *
      *   TO SS ASSOCIATED WITH THE BILL BEING PROCESSED            *
      *   - EFF. 04/01/2002 CALCULATE LINE ITEM OUTIER PAYMENT      *
      ***************************************************************
       01  A-ADDITIONAL-VARIABLES.
           05  A-CALC-VERS             PIC X(07).
           05  A-TOTAL-CLM-DEDUCT      PIC 9(03)V9(02).
           05  A-OUTLIER-PYMT          PIC 9(07)V9(02).
           05  A-TOT-CLM-PYMT          PIC 9(07)V9(02).
           05  A-TOT-CLM-CHRG          PIC 9(07)V9(02).
           05  A-CLM-RTN-CODE          PIC 9(02).
           05  A-MSA                   PIC X(04).
           05  A-CBSA                  PIC X(05).
           05  A-WINX                  PIC S9V9(04).
           05  A-BLOOD-PINTS-USED      PIC 9(01).
           05  A-BLOOD-DEDUCT-DUE      PIC 9(05)V9(02).
           05  A-LINE-ITEMS OCCURS 450 TIMES
                   DEPENDING ON OPPS-LINE-CNT.
             10  A-LITEM-PYMT          PIC 9(07)V9(02).
             10  A-LITEM-REIM          PIC 9(07)V9(02).
             10  A-TOTAL-LN-DEDUCT     PIC 9(03)V9(02).
             10  A-ADJ-COIN            PIC 9(05)V9(02).
             10  A-RED-COIN            PIC 9(05)V9(02).
             10  A-BLOOD-LN-DEDUCT     PIC 9(05)V9(02).
             10  A-RETURN-CODE         PIC 9(02).

       01  OCE-IN-DATE.
           05  OCE-IN-LINES OCCURS 450 TIMES.
              10  FILLER               PIC X(15).
              10  OPPS-LITEM-DOS       PIC 9(08).
              10  FILLER               PIC X(23).
      *       10  FILLER               PIC X(21). CHANGED 12/2/2008




      ******************************************************************
      ******************************************************************
      ***                                                            ***
      **                                                              **
      **        OUTPATIENT PROSPECTIVE PAYMENT SYSTEM PRICER          **
      **        --------------------------------------------          **
      **                 PROCEDURE DIVISION START                     **
      **                                                              **
      ***                                                            ***
      ******************************************************************
      ******************************************************************


      ***************************************************************
      *    PROCESSING: PRIOR TO 20020401                            *
      *        A. WILL PROCESS LINE ITEMS BASED ON OCE FLAGS.       *
      *        B. INITIALIZE OPPS   HOLD VARIABLES.                 *
      *        C. EDIT THE DATA PASSED FROM THE OCE.                *
      *        D. ASSEMBLE PRICING COMPONENTS.                      *
      *        E. CALCULATE THE PRICE.                              *
      *        F. RETURN COINSURANCE/REIMBURSEMENT/DEDUCTIBLE/      *
      *                  PAYMENT/OUTLIER AMOUNT/RETURN CODES        *
      ***************************************************************

       PROCEDURE DIVISION  USING OPPS-LINE-CNT
                                 OCE-DATA
                                 A-ADDITIONAL-VARIABLES
                                 L-PROV-SPEC-AREA
                                 L-SERVICE-FROM-DATE
                                 BENE-DEDUCT
                                 BENE-BLOOD-PINTS
                                 OCE-IN-DATE.
       0000-DATE-CONTROL.

      ************************************************************      00000100
      *                                                          *      00000200
      *    THIS SEPERATES EACH NEW YEAR INTO ITS OWN 1000-LEVEL  *      00000300
      *    PROCESS AREA.                                         *      00000400
      *                                                          *      00000500
      ************************************************************      00000600
              IF L-SERVICE-FROM-DATE > 20081231
                 PERFORM 8000-PROCESS-MAIN-NEW
                    THRU 8000-PROCESS-MAIN-NEW-EXIT
              ELSE
              IF L-SERVICE-FROM-DATE > 20071231
                 PERFORM 7000-PROCESS-MAIN-NEW
                    THRU 7000-PROCESS-MAIN-NEW-EXIT
              ELSE
              IF L-SERVICE-FROM-DATE > 20061231
                 PERFORM 6000-PROCESS-MAIN-NEW
                    THRU 6000-PROCESS-MAIN-NEW-EXIT
              ELSE
              IF L-SERVICE-FROM-DATE > 20051231
                 PERFORM 5000-PROCESS-MAIN-NEW
                    THRU 5000-PROCESS-MAIN-NEW-EXIT
              ELSE
              IF L-SERVICE-FROM-DATE > 20050630
                 PERFORM 4000-PROCESS-MAIN-NEW
                    THRU 4000-PROCESS-MAIN-NEW-EXIT
              ELSE
              IF L-SERVICE-FROM-DATE > 20041231
                 PERFORM 3000-PROCESS-MAIN-NEW
                    THRU 3000-PROCESS-MAIN-NEW-EXIT
              ELSE
              IF L-SERVICE-FROM-DATE > 20021231
                 PERFORM 2000-PROCESS-MAIN-NEW
                    THRU 2000-PROCESS-MAIN-NEW-EXIT
              ELSE
              IF L-SERVICE-FROM-DATE > 20020331
                 PERFORM 1000-PROCESS-MAIN-NEW
                    THRU 1000-PROCESS-MAIN-NEW-EXIT
              ELSE
                 PERFORM 0000-PROCESS-MAIN-OLD
                    THRU 0000-PROCESS-MAIN-OLD-EXIT.

              GOBACK.

       0000-PROCESS-MAIN-OLD.

              PERFORM 0100-INIT
                 THRU 0100-INIT-EXIT.
              IF A-CLM-RTN-CODE >= 50
                 GOBACK.
              MOVE H-WINX1 TO A-WINX.

              PERFORM 0125-INIT
                 THRU 0125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

              MOVE 0 TO W-DCP-MAX W-BLD-MAX.
              PERFORM 0150-INIT
                 THRU 0150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

              SET W-BD-INDX TO 1.
              MOVE 0 TO W-DCP-MAX.
              PERFORM 0400-CALCULATE
                 THRU 0400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.

              IF GJK-FLAG = 'Y'
                 PERFORM 0800-ADJ-STV-REIM
                    THRU 0800-ADJ-STV-REIM-EXIT
                       VARYING W-DCP-INDX FROM 1 BY 1
                         UNTIL W-DCP-INDX > W-DCP-MAX
              ELSE
                 NEXT SENTENCE.

              PERFORM 0900-END-PRICE-RTN
                 THRU 0900-END-PRICE-RTN-EXIT.

          0000-PROCESS-MAIN-OLD-EXIT.
              EXIT.

      ***************************************************************
      *    INITIALIZE WORKING STORAGE HOLD AREAS                    *
      *    AND ADDITIONAL VARIABLES TO BE PASSED BACK TO            *
      *    THE STANDARD SYSTEM.                                     *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      ***************************************************************
       0100-INIT.

             MOVE 01 TO A-CLM-RTN-CODE.
             MOVE 'N' TO APC33-FLAG GJK-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO TO A-OUTLIER-PYMT
                          A-TOTAL-CLM-DEDUCT
                          A-TOT-CLM-CHRG
                          A-TOT-CLM-PYMT
                          A-BLOOD-PINTS-USED
                          A-BLOOD-DEDUCT-DUE
                          A-WINX
                          W-LNC-MAX.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 0100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < 20000801
                   MOVE 53 TO A-CLM-RTN-CODE
                   GO TO 0100-INIT-EXIT
                ELSE
                   IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                      MOVE 54 TO A-CLM-RTN-CODE
                      GO TO 0100-INIT-EXIT
                   ELSE
                      IF L-PSF-TERMDT > 0
                         IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                            MOVE 54 TO A-CLM-RTN-CODE
                            GO TO 0100-INIT-EXIT
                         END-IF
                      END-IF.
      **********************************************************        00000100
      * COMMENT:                                               *        00000200
      *   UPDATE EVERY JANUARY                                 *        00000300
      **********************************************************        00000600
             MOVE CAL-VERSION0 TO A-CALC-VERS.
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.
             IF L-PSF-WGIDX-RECLASS = 'Y'
                MOVE L-PSF-WI-MSA TO H-PSF-MSA
             ELSE
                IF L-PSF-WGIDX-RECLASS = 'N'
                   MOVE L-PSF-GEO-MSA TO H-PSF-MSA
                ELSE
                   MOVE  52  TO A-CLM-RTN-CODE
                   GO TO 0100-INIT-EXIT.

             IF L-SERVICE-FROM-DATE >= 20020101
                MOVE 812 TO H-IP-LIMIT
             ELSE
               IF L-SERVICE-FROM-DATE >= 20010101
                  MOVE 792 TO H-IP-LIMIT
               ELSE
                 IF L-SERVICE-FROM-DATE >= 20000801
                    MOVE 776 TO H-IP-LIMIT.

             IF L-SERVICE-FROM-DATE < 20010101
                PERFORM 0105-FLOOR-2000
                   THRU 0105-FLOOR-2000-EXIT.

             IF L-SERVICE-FROM-DATE > 20001231
                PERFORM 0110-FLOOR-2001
                   THRU 0110-FLOOR-2001-EXIT.

                MOVE H-PSF-MSA TO A-MSA.

             IF L-SERVICE-FROM-DATE >= 20010101
                 PERFORM 0225-CHNG-WAGEINDX
                    THRU 0225-CHNG-WAGEINDX-EXIT
             ELSE
                PERFORM 0220-CHNG-WAGEINDX
                   THRU 0220-CHNG-WAGEINDX-EXIT.

             IF H-WINX1 = 0 THEN
                PERFORM 0200-CALC-WAGEINDX
                   THRU 0200-CALC-WAGEINDX-EXIT.

       0100-INIT-EXIT.
            EXIT.

      ***************************************************************
      *  RESET FLOOR MSA - 'FROM-DATE' CONTROLLED                   *
      *     - YEAR 2000                                             *
      *     - YEAR 2001                                             *
      ***************************************************************

       0105-FLOOR-2000.

             IF (H-PSF-MSA = '6020' OR '9000' OR '8080') AND
                (L-PSF-PROV-ST = '36')
                  MOVE '  36' TO H-PSF-MSA
             ELSE
                IF (H-PSF-MSA = '2440') AND
                   (L-PSF-PROV-ST = '15')
                     MOVE '  15' TO H-PSF-MSA
                ELSE
                   IF (H-PSF-MSA = '2520') AND
                      (L-PSF-PROV-ST = '24') AND
                      (L-PSF-WGIDX-RECLASS = 'Y')
                        MOVE '  24' TO H-PSF-MSA
                   ELSE
                      IF (H-PSF-MSA = '1123') AND
                         (L-PSF-PROV-ST = '22')
                            MOVE '  22' TO H-PSF-MSA.


       0105-FLOOR-2000-EXIT.
           EXIT.

       0110-FLOOR-2001.

             IF (H-PSF-MSA = '6020' OR '9000' OR '8080') AND
                (L-PSF-PROV-ST = '36')
                  MOVE '  36' TO H-PSF-MSA
             ELSE
                IF (H-PSF-MSA = '2440') AND
                   (L-PSF-PROV-ST = '15')
                     MOVE '  15' TO H-PSF-MSA
                ELSE
                   IF (H-PSF-MSA = '9000') AND
                      (L-PSF-PROV-ST = '51')
                        MOVE '  51' TO H-PSF-MSA
                   ELSE
                      IF (H-PSF-MSA = '1900') AND
                         (L-PSF-PROV-ST = '21')
                            MOVE '  21' TO H-PSF-MSA
                     ELSE
                        IF (H-PSF-MSA = '1123') AND
                           (L-PSF-PROV-ST = '22')
                              MOVE '  22' TO H-PSF-MSA.

       0110-FLOOR-2001-EXIT.
           EXIT.

      ***************************************************************
      *  SET FLAG IF APC = 0033                                     *
      *    - TERMINATE PROCESS IF 0033 LOCATED                      *
      *                                                             *
      ***************************************************************

       0125-INIT.

             IF OPPS-APC (LN-SUB) = '0033'
                MOVE 'Y' TO APC33-FLAG
                MOVE 451 TO LN-SUB.

       0125-INIT-EXIT.
           EXIT.

      ***************************************************************
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1 OR 2)   *
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0                    *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM DENIAL/REJECT FLAG  = TO 1     *
      *                 AND (APC NOT = 0033 OR 0034 OR 0322 OR      *
      *                      0323 OR 0324 OR 0325 OR 0373 OR 0374)) *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0              *
      *               - OR (APC 0033 IS NOT ON THE CLAIM            *
      *                     AND SERVICE INDICATOR = 'P'             *
      *                     OR  APC = 0322-0325,0373,0374)          *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      ***************************************************************
       0150-INIT.

      ***************************************************************
      *  - DISABLED AS OF 04-01-2001                                *
      *      PERFORM 0160-ADJUST-APC                                *
      *         THRU 0160-ADJUST-APC-EXIT.                          *
      ***************************************************************
      *  DISABLED AS OF 07-01-2001                                  *
      ***************************************************************
      *      IF (L-SERVICE-FROM-DATE > 20010331) AND                *
      *         (OPPS-APC (LN-SUB) = '1410') AND                    *
      *         (OPPS-HCPCS (LN-SUB) = 'C1050')                     *
      *           MOVE ' S' TO  OPPS-SRVC-IND (LN-SUB)              *
      *           MOVE '0976' TO OPPS-APC (LN-SUB).                 *
      ***************************************************************


             SET W-BD-INDX TO LN-SUB.
             SET W-LP-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

      *      IF OPPS-APC (LN-SUB) = '1111' OR '1112' OR '1113'
      *            OR '1114' OR '1117' OR '6300' OR '6600'
      *        IF L-SERVICE-FROM-DATE > 20010331
      *           MOVE  30  TO A-RETURN-CODE (LN-SUB)
      *           GO TO 0150-INIT-EXIT.

             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C'
              OR ' E' OR ' F' OR ' G' OR ' H' OR ' J' OR ' K' OR
              ' L' OR ' N' OR ' P' OR ' S' OR ' T' OR ' V' OR
              ' X' OR ' W' OR ' Y' OR ' Z') THEN
                MOVE  40  TO A-RETURN-CODE (LN-SUB)
                GO TO 0150-INIT-EXIT
              ELSE
                MOVE  01  TO A-RETURN-CODE (LN-SUB).

             IF OPPS-SRVC-IND (LN-SUB) =
                          ' A' OR ' B' OR ' C' OR ' E' OR ' F'
                MOVE  41  TO A-RETURN-CODE (LN-SUB)
                GO TO 0150-INIT-EXIT.

               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                        ' 7' OR ' 8' OR ' 9'
                 IF OPPS-PKG-FLAG (LN-SUB) = '0' OR '1' OR '2'
                   IF (OPPS-LITEM-DR-FLAG (LN-SUB) = '0' OR
                       OPPS-LITEM-DR-FLAG (LN-SUB) = '1' AND
                       (OPPS-APC (LN-SUB) = '0033' OR '0034'
                       OR '0322' OR '0323' OR '0324' OR '0325'
                       OR '0373' OR '0374')) OR
                      (OPPS-LITEM-ACT-FLAG (LN-SUB) = '1')
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                                           OR ' 2' OR ' 3' OR ' 4'
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR
                            ((APC33-FLAG = 'Y') AND
                             ((OPPS-SRVC-IND (LN-SUB) = ' P') OR
                             (OPPS-APC (LN-SUB) = '0322' OR '0323'
                              OR '0324' OR '0325' OR '0373'
                              OR '0374')))
                MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS

                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG
                    IF (OPPS-APC (LN-SUB) = '0000') OR
                       (OPPS-PKG-FLAG (LN-SUB) NOT = 0)
                       MOVE 42 TO A-RETURN-CODE (LN-SUB)
                       GO TO 0150-INIT-EXIT
                    END-IF
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 0150-INIT-EXIT
                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2
                      PERFORM 0175-APC-LOOKUP
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 0150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 0150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 0150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 0150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 0150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 0150-INIT-EXIT.


             IF A-RETURN-CODE (LN-SUB) = 01
               PERFORM 0250-CALC-DISCOUNT
                  THRU 0250-CALC-DISCOUNT-EXIT
             ELSE
                GO TO 0150-INIT-EXIT.
             IF A-RETURN-CODE (LN-SUB) =  01
                PERFORM 0300-COIN-DEDUCT
                   THRU 0300-COIN-DEDUCT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 01
                SET WBD-INDX TO 1
                SEARCH WBD-ENTRY VARYING WBD-INDX
                   AT END
                      GO TO 0150-INIT-EXIT
                 WHEN W-BLOOD-HCPCS (WBD-INDX) = OPPS-HCPCS (LN-SUB)
                     MOVE W-BLOOD-RANK (WBD-INDX) TO H-BLOOD-RANK
                     PERFORM 0375-BLOOD-DEDUCT
                        THRU 0375-BLOOD-DEDUCT-EXIT.

       0150-INIT-EXIT.
            EXIT.

      ***************************************************************
      *  ADJUST APC FROM 3M USING THE HCPCS CODE AND APC            *
      *    - RESET SERVICE INDICATOR WHEN NECESSARY                 *
      *      - DISABLED AS OF 04-01-2001                            *
      ***************************************************************
      *0160-ADJUST-APC.
      *
      *      MOVE OPPS-HCPCS (LN-SUB) TO W-ADJ-HCPCS.
      *      MOVE OPPS-GRP (LN-SUB) TO W-ADJ-APC.
      *      SET WAAJ-INDX TO 1.
      *      SEARCH WAAJ-ENTRY VARYING WAAJ-INDX
      *         AT END
      *            GO TO 0160-ADJUST-APC-EXIT
      *         WHEN WAAJ-HCPCSAPC (WAAJ-INDX) = W-ADJ-HCPCSAPC
      *            MOVE WAAJ-FED-APC (WAAJ-INDX) TO
      *                           OPPS-GRP (LN-SUB)
      *            MOVE WAAJ-NEW-SRVC-IND (WAAJ-INDX) TO
      *                           OPPS-SRVC-IND (LN-SUB)
      *            MOVE WAAJ-NEW-PYMT-IND (WAAJ-INDX) TO
      *                           OPPS-PYMT-IND (LN-SUB)
      *            MOVE WAAJ-NEW-PYMT-ADJ (WAAJ-INDX) TO
      *                           OPPS-PYMT-ADJ-FLAG (LN-SUB).
      *0160-ADJUST-APC-EXIT.
      *    EXIT.
      ***************************************************************

       0175-APC-LOOKUP.

             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)
               IF WAR-RATEX (W-SUB2) = 'DELETED'
                 MOVE 30 TO A-RETURN-CODE (LN-SUB)
                 COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                      H-SUB-CHRG
               ELSE
                 MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                 MOVE WAR-RANK (W-SUB2) TO H-RANK
                 MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                 MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                 MOVE WAR-PPCT (W-SUB2) TO H-PPCT
             ELSE
                SUBTRACT 1 FROM W-SUB2
                IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                  GO TO 0175-APC-LOOKUP
                ELSE
                   MOVE 0 TO H-APC-PYMT
                             H-RANK
                             H-MIN-COIN
                             H-NAT-COIN
                             H-PPCT.

       0175-APC-LOOKUP-EXIT.
           EXIT.

      ***************************************************************
      *    SEARCH WAGE INDEX TABLE AND SELECT THE WAGE INDEX        *
      *    WHEN EQUAL TO PROVIDER SPECIFIC WAGE INDEX               *
      *    IF WAGE INDEX NOT LOCATED                                *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      ***************************************************************
       0200-CALC-WAGEINDX.

             MOVE WWD-MAX TO WWD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WWD-DATE (WWD-SUB)
                 SUBTRACT 1 FROM WWD-SUB
             END-PERFORM.

             SEARCH ALL WWM-ENTRY
                AT END
                   MOVE  50  TO A-CLM-RTN-CODE
                   GO TO 0200-CALC-WAGEINDX-EXIT
                WHEN WWM-MSA (WWM-INDX) = H-PSF-MSA
                  MOVE WWM-PTR (WWM-INDX) TO W-SUB2
                  PERFORM 0210-WAGE-LOOKUP.

             IF H-WINX1 = 0 THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       0200-CALC-WAGEINDX-EXIT.
           EXIT.

       0210-WAGE-LOOKUP.

             IF WWW-DTCD (W-SUB2) NOT > WWD-DTCD (WWD-SUB)
                IF L-PSF-WGIDX-RECLASS = 'Y'
                  MOVE WWW-WINX2 (W-SUB2) TO H-WINX1
                ELSE
                  MOVE WWW-WINX1 (W-SUB2) TO H-WINX1
                END-IF
             ELSE
                SUBTRACT 1 FROM W-SUB2
                IF W-SUB2 > WWM-PTR (WWM-INDX - 1)
                   GO TO 0210-WAGE-LOOKUP
                ELSE
                   MOVE 0 TO H-WINX1.

       0210-WAGE-LOOKUP-EXIT.
           EXIT.

       0220-CHNG-WAGEINDX.

             IF (L-PSF-PROV-OSCAR = '140012' OR '150002' OR '150004'
                                OR '150008' OR '150034' OR '150090'
                                OR '150125' OR '150128' OR '150132')
                     AND (L-PSF-GEO-MSA = '1600'
                     AND L-PSF-WI-MSA = '1600'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 01.0750 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '250078')
                     AND (L-PSF-GEO-MSA = '3285'
                     AND L-PSF-WI-MSA = '3285'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.7634 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '330001' OR '330126' OR '330135'
                                OR '330205' OR '330209' OR '330264')
                     AND (L-PSF-GEO-MSA = '5600'
                     AND L-PSF-WI-MSA = '5600'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 01.4342 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '340039' OR '340129' OR '340144')
                     AND (L-PSF-GEO-MSA = '1520'
                     AND L-PSF-WI-MSA = '1520'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.9434 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '360046' OR '360056' OR '360076'
                                OR '360132')
                     AND (L-PSF-GEO-MSA = '1640'
                     AND L-PSF-WI-MSA = '1640'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.9419 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '390019' OR '390049' OR '390162'
                                OR '390194' OR '390197' OR '390263')
                     AND (L-PSF-GEO-MSA = '0240'
                     AND L-PSF-WI-MSA = '0240'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 01.0228 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '450065' OR '450072' OR '450591')
                     AND (L-PSF-GEO-MSA = '3360'
                     AND L-PSF-WI-MSA = '3360'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.9388 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '470003')
                     AND (L-PSF-GEO-MSA = '1123'
                     AND L-PSF-WI-MSA = '1123'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 01.1359 TO H-WINX1.

       0220-CHNG-WAGEINDX-EXIT.
           EXIT.

      ***************************************************************
      *    FOR FY 2001 NEW LUGAR HOSPITALS ONLY                     *
      ***************************************************************

       0225-CHNG-WAGEINDX.

             IF (L-PSF-PROV-OSCAR = '010043')
                     AND (L-PSF-WI-MSA = '1000'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.8490 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '010072' OR '010101')
                     AND (L-PSF-WI-MSA = '0450'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.7871 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '100098')
                     AND (L-PSF-WI-MSA = '8960'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.9615 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '100232')
                     AND (L-PSF-WI-MSA = '2900'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 01.0074 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '110130')
                     AND (L-PSF-WI-MSA = '0500'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.9739 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '140230')
                     AND (L-PSF-WI-MSA = '1400'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.9069 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '230027')
                     AND (L-PSF-WI-MSA = '3000'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 01.0119 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '340071' OR '340124')
                     AND (L-PSF-WI-MSA = '6640'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.9506 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '390030' OR '390181' OR '390183')
                     AND (L-PSF-WI-MSA = '6680'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.8992 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '390201')
                     AND (L-PSF-WI-MSA = '5640'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 01.0890 TO H-WINX1.

       0225-CHNG-WAGEINDX-EXIT.
           EXIT.

      ***************************************************************
      *    CALCULATE DISCOUNT FACTOR BASED ON THE DISCOUNT          *
      *    INDICATOR PASSED BY THE OCE: VALUE 1 - 8                 *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      ***************************************************************
       0250-CALC-DISCOUNT.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     MOVE  38  TO A-RETURN-CODE (LN-SUB).

       0250-CALC-DISCOUNT-EXIT.
           EXIT.

      ***************************************************************
      *    DETERMINE THE DEDUCTIBLE SEQUENCE. DEDUCTIBLE WILL BE    *
      *    TAKEN FROM OPPS SERVICES FIRST, THEN FROM ANY OTHER      *
      *    TYPES OF SERVICES FROM THE CLAIM.                        *
      *       - SET POINTERS TO THE HIGHEST RANKED PERCENTAGE       *
      *         (LARGEST NATIONAL UNADJUSTED COINSURANCE /          *
      *          THE APC PAYMENT)                                   *
      *       - MOVE ALL PRICING VARIABLES TO STAGING AREA          *
      ***************************************************************
       0300-COIN-DEDUCT.

             ADD 1 TO W-LNC-MAX.
             SET W-LP-INDX TO W-LNC-MAX.
             PERFORM 0350-STAGE-ENTRY
                THRU 0350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).
             MOVE LN-SUB TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN TO W-MIN-COIN (W-LP-INDX).
             MOVE H-APC-PYMT TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX1    TO W-WINX1 (W-LP-INDX).
             MOVE H-RANK     TO W-RANK (W-LP-INDX).
             MOVE H-PPCT     TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
              UNTIL PS-SUB > L-PSF-APC-LINE-CNT
              IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS * H-DISC-RATE
                MOVE 25 TO A-RETURN-CODE (LN-SUB)
                MOVE L-PSF-APC-LINE-CNT TO PS-SUB
              END-IF
             END-PERFORM.

       0300-COIN-DEDUCT-EXIT.
           EXIT.

       0350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       0350-STAGE-ENTRY-EXIT.
           EXIT.

      ***************************************************************
      *    DETERMINE THE BLOOD DEDUCTIBLE SEQUENCE. DEDUCTIBLE      *
      *    WILL BE CALCULATED BASED ON RANKING.                     *
      *       - SET POINTERS TO THE HIGHEST RANKED APC              *
      *         (SMALLEST UNADJUSTED APC PAYMENT)                   *
      *       - MOVE ALL PRICING VARIABLES TO STAGING AREA          *
      ***************************************************************
       0375-BLOOD-DEDUCT.

             ADD 1 TO W-BLD-MAX.
             SET W-BD-INDX TO W-BLD-MAX.
             PERFORM 0385-STAGE-ENTRY
                THRU 0385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLOOD-RANK NOT < W-BD-RANK (W-BD-INDX - 1).
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX1    TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK TO W-BD-RANK (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).

             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
              UNTIL PS-SUB > L-PSF-APC-LINE-CNT
              IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS * H-DISC-RATE
                MOVE 25 TO A-RETURN-CODE (LN-SUB)
                MOVE L-PSF-APC-LINE-CNT TO PS-SUB
              END-IF
             END-PERFORM.

       0375-BLOOD-DEDUCT-EXIT.
           EXIT.

       0385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       0385-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *    FIRST STEP IN DETERMINING A LINE ITEM PRICE.             *
      *    CHECK ALL APPROPRIATE FLAGS AND INDICATORS PASSED        *
      *    BY THE OCE.                                              *
      *      - SET RETURN CODES TO INDICATE ERRORS OR STATUS        *
      *        - '20' - LINE PROCESSED BUT PAYMENT = 0              *
      *                 - BENE DEDUCTIBLE => ADJUSTED PAYMENT       *
      *                                                             *
      ***************************************************************
       0400-CALCULATE.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 0400-CALCULATE-EXIT.

             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 0550-CALC-STANDARD
                   THRU 0550-CALC-STANDARD-EXIT
             ELSE
                GO TO 0400-CALCULATE-EXIT.

      ***************************************************************
      *  SET STVX AND / OR GJK FLAGS                                *
      *    - TEST LINE ITEM DATE OF SERVICE > 20010630              *
      *    - TOTAL DRUG / DEVICE COINSURANCE                        *
      ***************************************************************

             IF (A-RETURN-CODE (LN-SUB) <  30) AND
                (OPPS-LITEM-DOS (LN-SUB) > 20001231)
               PERFORM 0450-ADJ-PROC-COIN
                  THRU 0450-ADJ-PROC-COIN-EXIT
             ELSE
               NEXT SENTENCE.

             IF A-RETURN-CODE (LN-SUB) <  30
               COMPUTE A-TOTAL-CLM-DEDUCT =
                       H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT
               COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT
               COMPUTE A-BLOOD-DEDUCT-DUE =
                     A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT
               MOVE H-LITEM-PYMT TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN TO A-RED-COIN (LN-SUB)
               IF H-RED-COIN > H-NAT-COIN
                 MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF
               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.
             MOVE ZERO TO LINE-HOLD-ITEMS.

       0400-CALCULATE-EXIT.
           EXIT.

      ***************************************************************
      *  SET STVX AND / OR GJK FLAGS                                *
      *    - STAGE BY SERVICE INDICATOR                             *
      *                                                             *
      ***************************************************************
       0450-ADJ-PROC-COIN.

             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX1 (W-LP-INDX) + .4)
                  IF H-NEW-WGNAT > H-IP-LIMIT
                    MOVE H-IP-LIMIT TO H-NEW-WGNAT
                  END-IF
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                MOVE 1 TO H-DCP-CODE
                PERFORM 0455-SEARCH-KEY
                   THRU 0455-SEARCH-KEY-EXIT
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR ' K'
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                       H-TOTAL-LN-DEDUCT - H-LITEM-REIM
                                     - H-LN-BLOOD-DEDUCT
                   MOVE 'Y' TO GJK-FLAG
                   MOVE 1 TO H-DCP-CODE
                   PERFORM 0455-SEARCH-KEY
                      THRU 0455-SEARCH-KEY-EXIT
                   MOVE 2 TO H-DCP-CODE
                   ADD 1 TO W-DCP-MAX
                   SET W-DCP-INDX TO W-DCP-MAX
                   PERFORM 0475-STAGE-DCP-ENTRY
                     THRU 0475-STAGE-DCP-ENTRY-EXIT
                       UNTIL W-DCP-INDX = 1 OR
                       H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       0450-ADJ-PROC-COIN-EXIT.
           EXIT.

       0455-SEARCH-KEY.

             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX
                AT END
                   PERFORM 0460-ADD-ENTRY
                      THRU 0460-ADD-ENTRY-EXIT
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 0465-UPDATE-ENTRY
                      THRU 0465-UPDATE-ENTRY-EXIT.

       0455-SEARCH-KEY-EXIT.
           EXIT.

       0460-ADD-ENTRY.

             ADD 1 TO W-DCP-MAX.
             SET W-DCP-INDX TO W-DCP-MAX.
             PERFORM 0475-STAGE-DCP-ENTRY
               THRU 0475-STAGE-DCP-ENTRY-EXIT
                UNTIL W-DCP-INDX = 1 OR
                  H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR ' K'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       0460-ADD-ENTRY-EXIT.
           EXIT.

       0465-UPDATE-ENTRY.

             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR ' K'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 0485-REPLACE-TYPE1
                     THRU 0485-REPLACE-TYPE1-EXIT
               ELSE
                  PERFORM 0480-RANK-COIN
                     THRU 0480-RANK-COIN-EXIT.

       0465-UPDATE-ENTRY-EXIT.
           EXIT.

       0475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       0475-STAGE-DCP-ENTRY-EXIT.
           EXIT.

       0480-RANK-COIN.

             IF H-NEW-WGNAT > W-DCP-WGNAT (W-DCP-INDX)
               MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
               MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
               MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
               MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       0480-RANK-COIN-EXIT.
           EXIT.

       0485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       0485-REPLACE-TYPE1-EXIT.
           EXIT.

      ***************************************************************
      * 1. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *     - DESCENDING UNTIL DEDUCTIBLE = 0.                      *
      * 2. CALCULATE THE STANDARD LINE PRICE                        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS                *
      *          * DISCOUNT FACTOR)                                 *
      *     - WAGE ADJUST 60% OF THE APC PAYMENT ONLY               *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA.                     *
      *                                                             *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *       AND DRUGS                                             *
      ***************************************************************
       0550-CALC-STANDARD.

             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).
             MOVE 0 TO H-BLOOD-FRACTION.
             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' X') AND
                (OPPS-HCPCS (LN-SUB) = 'P9010' OR 'P9016' OR 'P9021'
                 OR 'P9022' OR 'P9038' OR 'P9039' OR 'P9040'
                 OR 'C1010' OR 'C1018')
               PERFORM 0550-SET-BLOOD-FRACTION
                  THRU 0550-SET-BLOOD-FRACTION-EXIT
               PERFORM 0550-CALC-FY00-BLOOD-DED
                  THRU 0550-CALC-FY00-BLOOD-DED-EXIT
               GO TO 0550-CALC-STANDARD-EXIT.

             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' V'
                        OR ' T' OR ' P' OR ' X' THEN
                COMPUTE H-LITEM-PYMT ROUNDED =
                    (((W-APC-PYMT (W-LP-INDX) * .60) *
                            W-WINX1 (W-LP-INDX))
                                + (W-APC-PYMT (W-LP-INDX) * .40)) *
                  W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)
                  PERFORM 0560-CALC-BENE-DEDUCT
                     THRU 0560-CALC-BENE-DEDUCT-EXIT
             ELSE
               IF OPPS-SRVC-IND (LN-SUB) = ' H' THEN
                 IF OPPS-PYMT-IND (LN-SUB) = ' 6' THEN
                   PERFORM 0555-CALC-H-STANDARD
                      THRU 0555-CALC-H-STANDARD-EXIT
                   PERFORM 0560-CALC-BENE-DEDUCT
                      THRU 0560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 0550-CALC-STANDARD-EXIT
                 END-IF
               ELSE
               IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR ' K' THEN
                IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 7' THEN
                  PERFORM 0550-CALC-GJK
                     THRU 0550-CALC-GJK-EXIT
                  PERFORM 0560-CALC-BENE-DEDUCT
                     THRU 0560-CALC-BENE-DEDUCT-EXIT
                ELSE
                 MOVE  41  TO A-RETURN-CODE (LN-SUB)
                 GO TO 0550-CALC-STANDARD-EXIT
                END-IF
               END-IF.

             IF H-LITEM-PYMT > 0
                COMPUTE H-LITEM-REIM ROUNDED =
                ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                   H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX)
                COMPUTE H-NAT-COIN = H-LITEM-PYMT  -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT.
             MOVE W-MIN-COIN (W-LP-INDX) TO H-MIN-COIN.
             IF H-MIN-COIN > 0
               IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' H'
                                      OR ' J' OR ' K'
                 COMPUTE H-MIN-COIN ROUNDED = H-MIN-COIN *
                 (W-SRVC-UNITS (W-LP-INDX) -
                    (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION))
                   * W-DISC-RATE (W-LP-INDX)
               ELSE
                 IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                   COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25
                 ELSE
                   COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                 END-IF
               END-IF
             END-IF.

             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.
             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                  MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                         (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                            (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       0550-CALC-STANDARD-EXIT.
           EXIT.

       0550-CALC-FY00-BLOOD-DED.

               COMPUTE H-LITEM-PYMT ROUNDED =
                   (((W-BD-APC-PYMT (W-BD-INDX) * .60) *
                           W-BD-WINX1 (W-BD-INDX))
                        + (W-BD-APC-PYMT (W-BD-INDX) * .40)) *
                    W-BD-SRVC-UNITS (W-BD-INDX) *
                           W-BD-DISC-RATE (W-BD-INDX)
               COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                    H-LITEM-PYMT * H-BLOOD-FRACTION
               SET W-BD-INDX UP BY 1
               PERFORM 0560-CALC-BENE-DEDUCT
                  THRU 0560-CALC-BENE-DEDUCT-EXIT.

             IF H-LITEM-PYMT > 0
                COMPUTE H-LITEM-REIM ROUNDED =
                ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                   H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX)
                COMPUTE H-NAT-COIN = H-LITEM-PYMT  -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT.
             MOVE W-MIN-COIN (W-LP-INDX) TO H-MIN-COIN.
             IF H-MIN-COIN > 0
                COMPUTE H-MIN-COIN ROUNDED = H-MIN-COIN *
                 (W-SRVC-UNITS (W-LP-INDX) -
                   (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION))
                  * W-DISC-RATE (W-LP-INDX).

             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.
             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                  MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                         (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                            (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

             IF H-LITEM-PYMT = H-LN-BLOOD-DEDUCT
                MOVE 0 TO H-LITEM-REIM
                MOVE 0 TO H-NAT-COIN.

       0550-CALC-FY00-BLOOD-DED-EXIT.
           EXIT.
      ***************************************************************
      * 1. CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR        *
      *    TYPES G , J , OR K.                                      *
      * 2. EFFECTIVE 01/01/2003 REMOVE PRO RATA REDUCTION FOR       *
      *       ALL SERVICE INDICATOR 'G' PAYMENTS                    *
      ***************************************************************

       0550-CALC-GJK.

             IF OPPS-HCPCS(LN-SUB) = 'P9021' OR 'P9010' OR 'P9038'
                      OR 'P9016' OR 'C1010' OR 'C1018' OR 'P9022'
                      OR 'P9039' OR 'P9040' OR 'C1016'
               PERFORM 0550-SET-BLOOD-FRACTION
                  THRU 0550-SET-BLOOD-FRACTION-EXIT
             ELSE
               COMPUTE H-LITEM-PYMT ROUNDED =
               W-APC-PYMT (W-LP-INDX) * W-SRVC-UNITS (W-LP-INDX)
                      * W-DISC-RATE (W-LP-INDX)
               GO TO 0550-CALC-GJK-EXIT.


             COMPUTE H-LITEM-PYMT ROUNDED =
             W-BD-APC-PYMT (W-BD-INDX) * W-BD-SRVC-UNITS (W-BD-INDX)
                      * W-BD-DISC-RATE (W-BD-INDX).

             COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                 H-LITEM-PYMT * H-BLOOD-FRACTION.

             SET W-BD-INDX UP BY 1.

       0550-CALC-GJK-EXIT.
           EXIT.

       0550-SET-BLOOD-FRACTION.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.
              IF H-BENE-PINTS-USED > 0
                IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                   MOVE 1 TO H-BLOOD-FRACTION
                   COMPUTE H-BENE-PINTS-USED =
                     H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)
                ELSE
                  IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                    COMPUTE H-BLOOD-FRACTION =
                      H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                    MOVE 0 TO H-BENE-PINTS-USED
                  ELSE
                     MOVE 0 TO H-BLOOD-FRACTION
              ELSE
                 MOVE 0 TO H-BLOOD-FRACTION.

       0550-SET-BLOOD-FRACTION-EXIT.
           EXIT.

       0555-CALC-H-STANDARD.

             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
             IF L-SERVICE-FROM-DATE > 20001231
                COMPUTE T-LITEM-PYMT ROUNDED =
               (H-SUB-CHRG * (L-PSF-OPCOST-RATIO * .981956)) -
               (((W-APC-PYMT (W-LP-INDX) * .60) *
                       W-WINX1 (W-LP-INDX))
                       + (W-APC-PYMT (W-LP-INDX) * .40))
             ELSE
                COMPUTE T-LITEM-PYMT ROUNDED =
                (H-SUB-CHRG * L-PSF-OPCOST-RATIO) -
                (((W-APC-PYMT (W-LP-INDX) * .60) *
                        W-WINX1 (W-LP-INDX))
                        + (W-APC-PYMT (W-LP-INDX) * .40)).

                IF T-LITEM-PYMT < 0 THEN
                   MOVE 0 TO H-LITEM-PYMT
                ELSE
                   MOVE T-LITEM-PYMT TO H-LITEM-PYMT.

       0555-CALC-H-STANDARD-EXIT.
           EXIT.

       0560-CALC-BENE-DEDUCT.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 4'
                GO TO 0560-CALC-BENE-DEDUCT-EXIT.
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                  H-LITEM-PYMT - H-LN-BLOOD-DEDUCT
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                      H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       0560-CALC-BENE-DEDUCT-EXIT.
           EXIT.

       0800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 0810-PROCESS-TYPE1
                   THRU 0810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 0840-PROCESS-TYPE2
                   THRU 0840-PROCESS-TYPE2-EXIT.

       0800-ADJ-STV-REIM-EXIT.
           EXIT.

       0810-PROCESS-TYPE1.

             IF  W-DCP-COIN2 (W-DCP-INDX) > 0
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-WGNAT (W-DCP-INDX) TO H-TOTAL
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-WGNAT (W-DCP-INDX)) /
                                  W-DCP-COIN2 (W-DCP-INDX)
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.
                IF H-RATIO > 1
                    MOVE 1 TO H-RATIO.

       0810-PROCESS-TYPE1-EXIT.
           EXIT.

       0840-PROCESS-TYPE2.

             IF W-DCP-DOS (W-DCP-INDX) >= 20010701
                IF W-DCP-DOS (W-DCP-INDX) =  H-DCP-DOS
                   MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB
                   COMPUTE H-SHIFT =
                       W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)
                   COMPUTE H-TOTAL =
                        A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT
                   IF H-TOTAL > H-IP-LIMIT
                      COMPUTE H-SHIFT = H-SHIFT + H-TOTAL
                            - H-IP-LIMIT
                   END-IF
                   COMPUTE A-ADJ-COIN (LN-SUB) =
                        A-ADJ-COIN (LN-SUB) - H-SHIFT
                   COMPUTE A-LITEM-REIM (LN-SUB) =
                      A-LITEM-REIM (LN-SUB) + H-SHIFT
                   MOVE 22 TO A-RETURN-CODE (LN-SUB)
                END-IF
             ELSE
                IF W-DCP-DOS (W-DCP-INDX) >= 20010101
                  IF W-DCP-COIN2 (W-DCP-INDX) > H-IP-LIMIT
                     MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB
                     COMPUTE H-SHIFT =
                         W-DCP-COIN2 (W-DCP-INDX) - H-IP-LIMIT
                     COMPUTE A-ADJ-COIN (LN-SUB) =
                          A-ADJ-COIN (LN-SUB) - H-SHIFT
                     COMPUTE A-LITEM-REIM (LN-SUB) =
                        A-LITEM-REIM (LN-SUB) + H-SHIFT
                     MOVE 22 TO A-RETURN-CODE (LN-SUB)
                  END-IF
                END-IF
             END-IF.


       0840-PROCESS-TYPE2-EXIT.
           EXIT.

      ***************************************************************
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      ***************************************************************

       0900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.
             IF A-TOT-CLM-PYMT > 0
                PERFORM 0910-CALC-OUTLIER
                   THRU 0910-CALC-OUTLIER-EXIT.
             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       0900-END-PRICE-RTN-EXIT.
           EXIT.

       0910-CALC-OUTLIER.

             IF L-SERVICE-FROM-DATE > 20001231
              COMPUTE H-OUTLIER-PYMT ROUNDED =
                ((H-TOT-CHRG * (L-PSF-OPCOST-RATIO * .981956))
                      - (2.5 * H-TOT-PYMT)) * .75
             ELSE
              COMPUTE H-OUTLIER-PYMT ROUNDED =
                ((H-TOT-CHRG * L-PSF-OPCOST-RATIO)
                      - (2.5 * H-TOT-PYMT)) * .75.

       0910-CALC-OUTLIER-EXIT.
           EXIT.

      ***************************************************************
      *    PROCESSING: AFTER 20020331                               *
      *        A. WILL PROCESS LINE ITEMS BASED ON OCE FLAGS.       *
      *        B. INITIALIZE OPPS   HOLD VARIABLES.                 *
      *        C. EDIT THE DATA PASSED FROM THE OCE.                *
      *        D. ASSEMBLE PRICING COMPONENTS.                      *
      *        E. CALCULATE THE PRICE.                              *
      *        F. RETURN COINSURANCE/REIMBURSEMENT/DEDUCTIBLE/      *
      *                  PAYMENT/OUTLIER AMOUNT/RETURN CODES        *
      ***************************************************************

          1000-PROCESS-MAIN-NEW.

              PERFORM 1100-INIT
                 THRU 1100-INIT-EXIT.

              IF A-CLM-RTN-CODE >= 50
                 GOBACK.
              MOVE H-WINX1 TO A-WINX.
              PERFORM 1125-INIT
                 THRU 1125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

              MOVE 0 TO W-DCP-MAX W-BLD-MAX.
              PERFORM 1150-INIT
                 THRU 1150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

              MOVE 0 TO W-DCP-MAX.
              IF L-SERVICE-FROM-DATE > 20020331
                PERFORM 1555-CALC-H-TOT
                   THRU 1555-CALC-H-TOT-EXIT
                      VARYING W-LP-INDX FROM 1 BY 1
                        UNTIL W-LP-INDX > W-LNC-MAX.

              SET W-BD-INDX TO 1.
              MOVE 0 TO W-DCP-MAX.
              PERFORM 1400-CALCULATE
                 THRU 1400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.

              IF L-SERVICE-FROM-DATE > 20020331
                PERFORM 1600-ADJ-CHRG-OUTL
                   THRU 1600-ADJ-CHRG-OUTL-EXIT
                      VARYING W-LP-INDX FROM 1 BY 1
                        UNTIL W-LP-INDX > W-LNC-MAX
              ELSE
                NEXT SENTENCE.


              IF GJK-FLAG = 'Y'
                PERFORM 1800-ADJ-STV-REIM
                   THRU 1800-ADJ-STV-REIM-EXIT
                      VARYING W-DCP-INDX FROM 1 BY 1
                        UNTIL W-DCP-INDX > W-DCP-MAX
              ELSE
                 NEXT SENTENCE.

              PERFORM 1900-END-PRICE-RTN
                 THRU 1900-END-PRICE-RTN-EXIT.

          1000-PROCESS-MAIN-NEW-EXIT.
              EXIT.

      ***************************************************************
      *    INITIALIZE WORKING STORAGE HOLD AREAS                    *
      *    AND ADDITIONAL VARIABLES TO BE PASSED BACK TO            *
      *    THE STANDARD SYSTEM.                                     *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      ***************************************************************
       1100-INIT.

             MOVE 01 TO A-CLM-RTN-CODE.
             MOVE 'N' TO APC33-FLAG GJK-FLAG ST0-FLAG
                         N-FLAG C-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO TO A-OUTLIER-PYMT
                          A-TOTAL-CLM-DEDUCT
                          A-TOT-CLM-CHRG
                          A-TOT-CLM-PYMT
                          A-BLOOD-PINTS-USED
                          A-BLOOD-DEDUCT-DUE
                          A-WINX
                          W-LNC-MAX.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 1100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < 20000801
                   MOVE 53 TO A-CLM-RTN-CODE
                   GO TO 1100-INIT-EXIT
                ELSE
                   IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                      MOVE 54 TO A-CLM-RTN-CODE
                      GO TO 1100-INIT-EXIT
                   ELSE
                      IF L-PSF-TERMDT > 0
                         IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                            MOVE 54 TO A-CLM-RTN-CODE
                            GO TO 1100-INIT-EXIT
                         END-IF
                      END-IF.
             MOVE CAL-VERSION1 TO A-CALC-VERS.
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.
             IF L-PSF-WGIDX-RECLASS = 'Y'
                MOVE L-PSF-WI-MSA TO H-PSF-MSA
             ELSE
                IF L-PSF-WGIDX-RECLASS = 'N'
                   MOVE L-PSF-GEO-MSA TO H-PSF-MSA
                ELSE
                   MOVE  52  TO A-CLM-RTN-CODE
                   GO TO 1100-INIT-EXIT.

             IF L-SERVICE-FROM-DATE >= 20020101
                MOVE 812 TO H-IP-LIMIT
             ELSE
               IF L-SERVICE-FROM-DATE >= 20010101
                 MOVE 792 TO H-IP-LIMIT
               ELSE
                 IF L-SERVICE-FROM-DATE >= 20000801
                    MOVE 776 TO H-IP-LIMIT.

             IF L-SERVICE-FROM-DATE > 20020331
                PERFORM 1115-FLOOR-2002
                   THRU 1115-FLOOR-2002-EXIT
                PERFORM 1115-SEC401-2002
                   THRU 1115-SEC401-2002-EXIT
             ELSE
               IF L-SERVICE-FROM-DATE > 20001231
                  PERFORM 1110-FLOOR-2001
                     THRU 1110-FLOOR-2001-EXIT
               ELSE
                 IF L-SERVICE-FROM-DATE > 20000731
                    PERFORM 1105-FLOOR-2000
                       THRU 1105-FLOOR-2000-EXIT.


                MOVE H-PSF-MSA TO A-MSA.

             IF L-SERVICE-FROM-DATE >= 20010101
                 PERFORM 1225-CHNG-WAGEINDX
                    THRU 1225-CHNG-WAGEINDX-EXIT
             ELSE
                PERFORM 1220-CHNG-WAGEINDX
                   THRU 1220-CHNG-WAGEINDX-EXIT.

             IF H-WINX1 = 0 THEN
                PERFORM 1200-CALC-WAGEINDX
                   THRU 1200-CALC-WAGEINDX-EXIT.

       1100-INIT-EXIT.
           EXIT.

      ***************************************************************
      *  RESET FLOOR MSA - 'FROM-DATE' CONTROLLED                   *
      *     - YEAR 2000                                             *
      *     - YEAR 2001                                             *
      *     - YEAR 2002                                             *
      ***************************************************************

       1105-FLOOR-2000.

             IF (H-PSF-MSA = '6020' OR '9000' OR '8080') AND
                (L-PSF-PROV-ST = '36')
                  MOVE '  36' TO H-PSF-MSA
             ELSE
                IF (H-PSF-MSA = '2440') AND
                   (L-PSF-PROV-ST = '15')
                     MOVE '  15' TO H-PSF-MSA
                ELSE
                   IF (H-PSF-MSA = '2520') AND
                      (L-PSF-PROV-ST = '24') AND
                      (L-PSF-WGIDX-RECLASS = 'Y')
                        MOVE '  24' TO H-PSF-MSA
                   ELSE
                      IF (H-PSF-MSA = '1123') AND
                         (L-PSF-PROV-ST = '22')
                            MOVE '  22' TO H-PSF-MSA.


       1105-FLOOR-2000-EXIT.
           EXIT.

       1110-FLOOR-2001.

             IF (H-PSF-MSA = '6020' OR '9000' OR '8080') AND
                (L-PSF-PROV-ST = '36')
                  MOVE '  36' TO H-PSF-MSA
             ELSE
                IF (H-PSF-MSA = '2440') AND
                   (L-PSF-PROV-ST = '15')
                     MOVE '  15' TO H-PSF-MSA
                ELSE
                   IF (H-PSF-MSA = '9000') AND
                      (L-PSF-PROV-ST = '51')
                        MOVE '  51' TO H-PSF-MSA
                   ELSE
                      IF (H-PSF-MSA = '1900') AND
                         (L-PSF-PROV-ST = '21')
                            MOVE '  21' TO H-PSF-MSA
                     ELSE
                        IF (H-PSF-MSA = '1123') AND
                           (L-PSF-PROV-ST = '22')
                              MOVE '  22' TO H-PSF-MSA.

       1110-FLOOR-2001-EXIT.
           EXIT.

       1115-FLOOR-2002.

             IF (H-PSF-MSA = '6020' OR '9000' OR '8080') AND
                (L-PSF-PROV-ST = '36')
                  MOVE '  36' TO H-PSF-MSA
             ELSE
                IF (H-PSF-MSA = '2440') AND
                   (L-PSF-PROV-ST = '15')
                     MOVE '  15' TO H-PSF-MSA
                ELSE
                   IF (H-PSF-MSA = '1303') AND
                      (L-PSF-PROV-ST = '47') AND
                      (L-PSF-WGIDX-RECLASS = 'Y')
                        MOVE '  47' TO H-PSF-MSA
                        MOVE 'N' TO L-PSF-WGIDX-RECLASS
                   ELSE
                      IF (H-PSF-MSA = '1900') AND
                         (L-PSF-PROV-ST = '21')
                            MOVE '  21' TO H-PSF-MSA
                     ELSE
                        IF (H-PSF-MSA = '1123') AND
                           (L-PSF-PROV-ST = '22')
                              MOVE '  22' TO H-PSF-MSA
                       ELSE
                          IF (H-PSF-MSA = '  14') AND
                             (L-PSF-PROV-ST = '16') AND
                             (L-PSF-WGIDX-RECLASS = 'Y')
                                MOVE 'N' TO L-PSF-WGIDX-RECLASS
                                MOVE '  16' TO H-PSF-MSA.

       1115-FLOOR-2002-EXIT.
           EXIT.

       1115-SEC401-2002.

             IF (L-PSF-PROV-OSCAR = '050192' OR '050286' OR
                                    '050446' OR '050469' OR
                                    '050528' OR '050542')
                MOVE '  05' TO H-PSF-MSA
             ELSE
               IF (L-PSF-PROV-OSCAR = '100048' OR '100118')
                  MOVE '  10' TO H-PSF-MSA
               ELSE
                 IF (L-PSF-PROV-OSCAR = '170137')
                    MOVE '  17' TO H-PSF-MSA
                 ELSE
                   IF (L-PSF-PROV-OSCAR = '190048' OR '190110')
                      MOVE '  19' TO H-PSF-MSA
                   ELSE
                     IF (L-PSF-PROV-OSCAR = '230078')
                        MOVE '  23' TO H-PSF-MSA
                     ELSE
                       IF (L-PSF-PROV-OSCAR = '260006')
                          MOVE '  26' TO H-PSF-MSA
                       ELSE
                         IF (L-PSF-PROV-OSCAR = '290038')
                            MOVE '  29' TO H-PSF-MSA
                         ELSE
                           IF (L-PSF-PROV-OSCAR = '300009')
                              MOVE '  30' TO H-PSF-MSA
                           ELSE
                             IF (L-PSF-PROV-OSCAR = '390106')
                                MOVE '  39' TO H-PSF-MSA
                             ELSE
                               IF (L-PSF-PROV-OSCAR = '520007' OR
                                                      '520153')
                                  MOVE '  52' TO H-PSF-MSA.

       1115-SEC401-2002-EXIT.
           EXIT.

      ***************************************************************
      *  SET FLAG IF APC = 0033                                     *
      *    - TERMINATE PROCESS IF 0033 LOCATED                      *
      *                                                             *
      ***************************************************************

       1125-INIT.

             IF OPPS-APC (LN-SUB) = '0033'
                MOVE 'Y' TO APC33-FLAG
                MOVE 451 TO LN-SUB.

       1125-INIT-EXIT.
           EXIT.

      ***************************************************************
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1 OR 2)   *
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0                    *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM DENIAL/REJECT FLAG  = TO 1     *
      *                 AND (APC NOT = 0033 OR 0034 OR 0322 OR      *
      *                      0323 OR 0324 OR 0325 OR 0373 OR 0374)) *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0              *
      *               - OR (APC 0033 IS NOT ON THE CLAIM            *
      *                     AND SERVICE INDICATOR = 'P'             *
      *                     OR  APC = 0322-0325,0373,0374)          *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      ***************************************************************
       1150-INIT.

             MOVE  01  TO A-RETURN-CODE (LN-SUB).

      ***************************************************************
      * OVER-RIDE SERVICE UNITS FOR APC 0339 - EFFECTIVE 04/01/2002 *
      *   - CHANGE UNIT VALUE TO 1                                  *
      ***************************************************************

             IF (L-SERVICE-FROM-DATE > 20020331) AND
                (OPPS-APC (LN-SUB) = '0339')
                  MOVE 1 TO OPPS-SRVC-UNITS (LN-SUB).

             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 1250-CALC-DISCOUNT
                THRU 1250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 1150-INIT-EXIT.

      ***************************************************************
      *  EFFECTIVE AS OF 04-01-2002                                 *
      *    - TOTAL DEVICE OFFSET                                    *
      ***************************************************************

             IF L-SERVICE-FROM-DATE > 20020331 AND
                OPPS-SRVC-IND (LN-SUB) = ' H'
                MOVE 'Y' TO C-FLAG.
             IF L-SERVICE-FROM-DATE > 20020331
                PERFORM 1160-TOTAL-OFFSET
                   THRU 1160-TOTAL-OFFSET-EXIT.

             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C'
              OR ' E' OR ' F' OR ' G' OR ' H' OR ' J' OR ' K' OR
              ' L' OR ' N' OR ' P' OR ' S' OR ' T' OR ' V' OR
              ' X' OR ' W' OR ' Y' OR ' Z') THEN
                MOVE  40  TO A-RETURN-CODE (LN-SUB)
                GO TO 1150-INIT-EXIT
              ELSE
                MOVE  01  TO A-RETURN-CODE (LN-SUB).

             IF OPPS-SRVC-IND (LN-SUB) =
                          ' A' OR ' B' OR ' C' OR ' E' OR ' F'
                MOVE  41  TO A-RETURN-CODE (LN-SUB)
                GO TO 1150-INIT-EXIT.

               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'
                 IF OPPS-PKG-FLAG (LN-SUB) = '0' OR '1' OR '2'
                   IF (OPPS-LITEM-DR-FLAG (LN-SUB) = '0' OR
                       OPPS-LITEM-DR-FLAG (LN-SUB) = '1' AND
                       (OPPS-APC (LN-SUB) = '0033' OR '0034'
                       OR '0322' OR '0323' OR '0324' OR '0325'
                       OR '0373' OR '0374')) OR
                      (OPPS-LITEM-ACT-FLAG (LN-SUB) = '1')
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                                         OR ' 2' OR ' 3' OR ' 4'
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR
                            ((APC33-FLAG = 'Y') AND
                             ((OPPS-SRVC-IND (LN-SUB) = ' P') OR
                             (OPPS-APC (LN-SUB) = '0322' OR '0323'
                              OR '0324' OR '0325' OR '0373'
                              OR '0374')))
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

                    IF OPPS-PKG-FLAG (LN-SUB) = '1' OR '2'
                       COMPUTE H-TOT-N-CHRG = H-SUB-CHRG
                                  + H-TOT-N-CHRG
                       MOVE 'Y' TO N-FLAG
                    END-IF
                    IF (OPPS-APC (LN-SUB) = '0000') OR
                       (OPPS-PKG-FLAG (LN-SUB) NOT = 0)
                       MOVE 42 TO A-RETURN-CODE (LN-SUB)
                       GO TO 1150-INIT-EXIT
                    END-IF
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 1150-INIT-EXIT
                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2
                      PERFORM 1175-APC-LOOKUP
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 1150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 1150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 1150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 1150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 1150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 1150-INIT-EXIT.

             IF A-RETURN-CODE (LN-SUB) =  01
                PERFORM 1300-COIN-DEDUCT
                   THRU 1300-COIN-DEDUCT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 01
                SET WBD-INDX TO 1
                SEARCH WBD-ENTRY VARYING WBD-INDX
                   AT END
                      GO TO 1150-INIT-EXIT
                 WHEN W-BLOOD-HCPCS (WBD-INDX) = OPPS-HCPCS (LN-SUB)
                     MOVE W-BLOOD-RANK (WBD-INDX) TO H-BLOOD-RANK
                     PERFORM 1375-BLOOD-DEDUCT
                        THRU 1375-BLOOD-DEDUCT-EXIT.

       1150-INIT-EXIT.
           EXIT.

      ***************************************************************
      *  COMPUTE TOTAL OFFSET FROM TABLE 5 FOR DEVICES              *
      *      - EFFECTIVE  OF 04-01-2002                             *
      ***************************************************************
       1160-TOTAL-OFFSET.

             MOVE OPPS-GRP (LN-SUB) TO W-OFF-APC.
             SEARCH ALL WOO-ENTRY
                AT END
                   GO TO 1160-TOTAL-OFFSET-EXIT
                WHEN WOO-APC (WOO-INDX) = W-OFF-APC
                   COMPUTE H-TOTAL-OFFSET = H-TOTAL-OFFSET
                      + (WOO-OFFSET (WOO-INDX) * H-DISC-RATE).

       1160-TOTAL-OFFSET-EXIT.
           EXIT.
      ***************************************************************

       1175-APC-LOOKUP.

             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)
               IF WAR-RATEX (W-SUB2) = 'DELETED'
                 MOVE 30 TO A-RETURN-CODE (LN-SUB)
                 COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                      H-SUB-CHRG
               ELSE
                 MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                 MOVE WAR-RANK (W-SUB2) TO H-RANK
                 MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                 MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                 MOVE WAR-PPCT (W-SUB2) TO H-PPCT
             ELSE
                SUBTRACT 1 FROM W-SUB2
                IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                  GO TO 1175-APC-LOOKUP
                ELSE
                   MOVE 0 TO H-APC-PYMT
                             H-RANK
                             H-MIN-COIN
                             H-NAT-COIN
                             H-PPCT.

       1175-APC-LOOKUP-EXIT.
           EXIT.

      ***************************************************************
      *    SEARCH WAGE INDEX TABLE AND SELECT THE WAGE INDEX        *
      *    WHEN EQUAL TO PROVIDER SPECIFIC WAGE INDEX               *
      *    IF WAGE INDEX NOT LOCATED                                *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      ***************************************************************
       1200-CALC-WAGEINDX.

             MOVE WWD-MAX TO WWD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WWD-DATE (WWD-SUB)
                 SUBTRACT 1 FROM WWD-SUB
             END-PERFORM.

             SEARCH ALL WWM-ENTRY
                AT END
                   MOVE  50  TO A-CLM-RTN-CODE
                   GO TO 1200-CALC-WAGEINDX-EXIT
                WHEN WWM-MSA (WWM-INDX) = H-PSF-MSA
                  MOVE WWM-PTR (WWM-INDX) TO W-SUB2
                  PERFORM 1210-WAGE-LOOKUP.

             IF H-WINX1 = 0 THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       1200-CALC-WAGEINDX-EXIT.
           EXIT.

       1210-WAGE-LOOKUP.

             IF WWW-DTCD (W-SUB2) NOT > WWD-DTCD (WWD-SUB)
                IF L-PSF-WGIDX-RECLASS = 'Y'
                  MOVE WWW-WINX2 (W-SUB2) TO H-WINX1
                ELSE
                  MOVE WWW-WINX1 (W-SUB2) TO H-WINX1
                END-IF
             ELSE
                SUBTRACT 1 FROM W-SUB2
                IF W-SUB2 > WWM-PTR (WWM-INDX - 1)
                   GO TO 1210-WAGE-LOOKUP
                ELSE
                   MOVE 0 TO H-WINX1.

       1210-WAGE-LOOKUP-EXIT.
           EXIT.

       1220-CHNG-WAGEINDX.

             IF (L-PSF-PROV-OSCAR = '140012' OR '150002' OR '150004'
                                OR '150008' OR '150034' OR '150090'
                                OR '150125' OR '150128' OR '150132')
                     AND (L-PSF-GEO-MSA = '1600'
                     AND L-PSF-WI-MSA = '1600'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 01.0750 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '250078')
                     AND (L-PSF-GEO-MSA = '3285'
                     AND L-PSF-WI-MSA = '3285'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.7634 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '330001' OR '330126' OR '330135'
                                OR '330205' OR '330209' OR '330264')
                     AND (L-PSF-GEO-MSA = '5600'
                     AND L-PSF-WI-MSA = '5600'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 01.4342 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '340039' OR '340129' OR '340144')
                     AND (L-PSF-GEO-MSA = '1520'
                     AND L-PSF-WI-MSA = '1520'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.9434 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '360046' OR '360056' OR '360076'
                                OR '360132')
                     AND (L-PSF-GEO-MSA = '1640'
                     AND L-PSF-WI-MSA = '1640'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.9419 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '390019' OR '390049' OR '390162'
                                OR '390194' OR '390197' OR '390263')
                     AND (L-PSF-GEO-MSA = '0240'
                     AND L-PSF-WI-MSA = '0240'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 01.0228 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '450065' OR '450072' OR '450591')
                     AND (L-PSF-GEO-MSA = '3360'
                     AND L-PSF-WI-MSA = '3360'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.9388 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '470003')
                     AND (L-PSF-GEO-MSA = '1123'
                     AND L-PSF-WI-MSA = '1123'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 01.1359 TO H-WINX1.

       1220-CHNG-WAGEINDX-EXIT.
           EXIT.

      ***************************************************************
      *    FOR FY 2001 NEW LUGAR HOSPITALS ONLY                     *
      ***************************************************************

       1225-CHNG-WAGEINDX.

             IF (L-PSF-PROV-OSCAR = '010043')
                     AND (L-PSF-WI-MSA = '1000'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.8490 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '010072' OR '010101')
                     AND (L-PSF-WI-MSA = '0450'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.7871 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '100098')
                     AND (L-PSF-WI-MSA = '8960'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.9615 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '100232')
                     AND (L-PSF-WI-MSA = '2900'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 01.0074 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '110130')
                     AND (L-PSF-WI-MSA = '0500'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.9739 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '140230')
                     AND (L-PSF-WI-MSA = '1400'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.9069 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '230027')
                     AND (L-PSF-WI-MSA = '3000'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 01.0119 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '340071' OR '340124')
                     AND (L-PSF-WI-MSA = '6640'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.9506 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '390030' OR '390181' OR '390183')
                     AND (L-PSF-WI-MSA = '6680'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 00.8992 TO H-WINX1.

             IF (L-PSF-PROV-OSCAR = '390201')
                     AND (L-PSF-WI-MSA = '5640'
                     AND L-PSF-WGIDX-RECLASS = 'Y')
                MOVE 01.0890 TO H-WINX1.

       1225-CHNG-WAGEINDX-EXIT.
           EXIT.

      ***************************************************************
      *    CALCULATE DISCOUNT FACTOR BASED ON THE DISCOUNT          *
      *    INDICATOR PASSED BY THE OCE: VALUE 1 - 8                 *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      ***************************************************************
       1250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 1250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     MOVE  38  TO A-RETURN-CODE (LN-SUB).

       1250-CALC-DISCOUNT-EXIT.
           EXIT.

      ***************************************************************
      *    DETERMINE THE DEDUCTIBLE SEQUENCE. DEDUCTIBLE WILL BE    *
      *    TAKEN FROM OPPS SERVICES FIRST, THEN FROM ANY OTHER      *
      *    TYPES OF SERVICES FROM THE CLAIM.                        *
      *       - SET POINTERS TO THE HIGHEST RANKED PERCENTAGE       *
      *         (LARGEST NATIONAL UNADJUSTED COINSURANCE /          *
      *          THE APC PAYMENT)                                   *
      *       - MOVE ALL PRICING VARIABLES TO STAGING AREA          *
      ***************************************************************
       1300-COIN-DEDUCT.

             ADD 1 TO W-LNC-MAX.
             SET W-LP-INDX TO W-LNC-MAX.
             PERFORM 1350-STAGE-ENTRY
                THRU 1350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).
             MOVE LN-SUB TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX1    TO W-WINX1 (W-LP-INDX).
             MOVE H-RANK     TO W-RANK (W-LP-INDX).
             MOVE H-PPCT     TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
              UNTIL PS-SUB > L-PSF-APC-LINE-CNT
              IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS * H-DISC-RATE
                MOVE 25 TO A-RETURN-CODE (LN-SUB)
                MOVE L-PSF-APC-LINE-CNT TO PS-SUB
              END-IF
             END-PERFORM.

       1300-COIN-DEDUCT-EXIT.
           EXIT.

       1350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       1350-STAGE-ENTRY-EXIT.
           EXIT.

      ***************************************************************
      *    DETERMINE THE BLOOD DEDUCTIBLE SEQUENCE. DEDUCTIBLE      *
      *    WILL BE CALCULATED BASED ON RANKING.                     *
      *       - SET POINTERS TO THE HIGHEST RANKED APC              *
      *         (SMALLEST UNADJUSTED APC PAYMENT)                   *
      *       - MOVE ALL PRICING VARIABLES TO STAGING AREA          *
      ***************************************************************
       1375-BLOOD-DEDUCT.

             ADD 1 TO W-BLD-MAX.
             SET W-BD-INDX TO W-BLD-MAX.
             PERFORM 1385-STAGE-ENTRY
                THRU 1385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLOOD-RANK NOT < W-BD-RANK (W-BD-INDX - 1).
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX1    TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK TO W-BD-RANK (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).

             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
              UNTIL PS-SUB > L-PSF-APC-LINE-CNT
              IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS * H-DISC-RATE
                MOVE 25 TO A-RETURN-CODE (LN-SUB)
                MOVE L-PSF-APC-LINE-CNT TO PS-SUB
              END-IF
             END-PERFORM.

       1375-BLOOD-DEDUCT-EXIT.
           EXIT.

       1385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       1385-STAGE-ENTRY-EXIT.
           EXIT.

      ***************************************************************
      *    FIRST STEP IN DETERMINING A LINE ITEM PRICE.             *
      *    CHECK ALL APPROPRIATE FLAGS AND INDICATORS PASSED        *
      *    BY THE OCE.                                              *
      *      - SET RETURN CODES TO INDICATE ERRORS OR STATUS        *
      *        - '20' - LINE PROCESSED BUT PAYMENT = 0              *
      *                 - BENE DEDUCTIBLE => ADJUSTED PAYMENT       *
      *                                                             *
      ***************************************************************
       1400-CALCULATE.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 1400-CALCULATE-EXIT.

             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 1550-CALC-STANDARD
                   THRU 1550-CALC-STANDARD-EXIT
             ELSE
                GO TO 1400-CALCULATE-EXIT.

      ***************************************************************
      *  SET GJK FLAG                                               *
      *    - TEST LINE ITEM DATE OF SERVICE > 20010630              *
      *    - TOTAL DRUG / DEVICE COINSURANCE                        *
      ***************************************************************

             IF (A-RETURN-CODE (LN-SUB) <  30) AND
                (OPPS-LITEM-DOS (LN-SUB) > 20001231)
               PERFORM 1450-ADJ-PROC-COIN
                  THRU 1450-ADJ-PROC-COIN-EXIT
             ELSE
               NEXT SENTENCE.

      ***************************************************************
      *  SET ST0 AND STVX FLAGS                                     *
      *    - TEST LINE ITEM DATE OF SERVICE > 20020331              *
      *    - TOTAL PROCEDURE CHARGES AND BUNDLED CHARGES            *
      ***************************************************************

             IF (OPPS-LITEM-DOS (LN-SUB) > 20020331)
               PERFORM 1500-ADJ-CHRGS
                  THRU 1500-ADJ-CHRGS-EXIT
             ELSE
               NEXT SENTENCE.

             IF A-RETURN-CODE (LN-SUB) <  30
               COMPUTE A-TOTAL-CLM-DEDUCT =
                       H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT
               COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT
               COMPUTE A-BLOOD-DEDUCT-DUE =
                     A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT
               MOVE H-LITEM-PYMT TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN TO A-RED-COIN (LN-SUB)
               IF H-RED-COIN > H-NAT-COIN
                  MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF
               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.
             MOVE ZERO TO LINE-HOLD-ITEMS.

       1400-CALCULATE-EXIT.
           EXIT.

      ***************************************************************
      *  SET GJK FLAG                                               *
      *    - STAGE BY SERVICE INDICATOR                             *
      *                                                             *
      ***************************************************************
       1450-ADJ-PROC-COIN.

             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX1 (W-LP-INDX) + .4)
                  IF H-NEW-WGNAT > H-IP-LIMIT
                    MOVE H-IP-LIMIT TO H-NEW-WGNAT
                  END-IF
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                MOVE 1 TO H-DCP-CODE
                PERFORM 1455-SEARCH-KEY
                   THRU 1455-SEARCH-KEY-EXIT
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR ' K'
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                        H-TOTAL-LN-DEDUCT - H-LITEM-REIM
                                   - H-LN-BLOOD-DEDUCT
                   MOVE 'Y' TO GJK-FLAG
                   MOVE 1 TO H-DCP-CODE
                   PERFORM 1455-SEARCH-KEY
                      THRU 1455-SEARCH-KEY-EXIT
                   MOVE 2 TO H-DCP-CODE
                   ADD 1 TO W-DCP-MAX
                   SET W-DCP-INDX TO W-DCP-MAX
                   PERFORM 1475-STAGE-DCP-ENTRY
                     THRU 1475-STAGE-DCP-ENTRY-EXIT
                       UNTIL W-DCP-INDX = 1 OR
                       H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       1450-ADJ-PROC-COIN-EXIT.
           EXIT.

       1455-SEARCH-KEY.

             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX
                AT END
                   PERFORM 1460-ADD-ENTRY
                      THRU 1460-ADD-ENTRY-EXIT
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 1465-UPDATE-ENTRY
                      THRU 1465-UPDATE-ENTRY-EXIT.

       1455-SEARCH-KEY-EXIT.
           EXIT.

       1460-ADD-ENTRY.

             ADD 1 TO W-DCP-MAX.
             SET W-DCP-INDX TO W-DCP-MAX.
             PERFORM 1475-STAGE-DCP-ENTRY
               THRU 1475-STAGE-DCP-ENTRY-EXIT
                UNTIL W-DCP-INDX = 1 OR
                  H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR ' K'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       1460-ADD-ENTRY-EXIT.
           EXIT.

       1465-UPDATE-ENTRY.

             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR ' K'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 1485-REPLACE-TYPE1
                     THRU 1485-REPLACE-TYPE1-EXIT
               ELSE
                  PERFORM 1480-RANK-COIN
                     THRU 1480-RANK-COIN-EXIT.

       1465-UPDATE-ENTRY-EXIT.
           EXIT.

       1475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       1475-STAGE-DCP-ENTRY-EXIT.
           EXIT.

       1480-RANK-COIN.

             IF H-NEW-WGNAT > W-DCP-WGNAT (W-DCP-INDX)
               MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
               MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
               MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
               MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       1480-RANK-COIN-EXIT.
           EXIT.

       1485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       1485-REPLACE-TYPE1-EXIT.
           EXIT.

       1500-ADJ-CHRGS.

             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T') AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                MOVE 'Y' TO ST0-FLAG.

             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T') AND
                (OPPS-PKG-FLAG (LN-SUB) = '0')
                COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX)
                               + H-TOT-ST-CHRG
                COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT
                               + H-TOT-ST-PYMT.

             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                OR ' X' OR ' P') AND (OPPS-PKG-FLAG (LN-SUB) = '0')
                COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT
                               + H-TOT-STVX-PYMT.

       1500-ADJ-CHRGS-EXIT.
           EXIT.
      ***************************************************************
      * 1. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *     - DESCENDING UNTIL DEDUCTIBLE = 0.                      *
      * 2. CALCULATE THE STANDARD LINE PRICE                        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS                *
      *          * DISCOUNT FACTOR)                                 *
      *     - WAGE ADJUST 60% OF THE APC PAYMENT ONLY               *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA.                     *
      *                                                             *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *       AND DRUGS                                             *
      ***************************************************************
       1550-CALC-STANDARD.

             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' V'
                        OR ' T' OR ' P' OR ' X' THEN
                COMPUTE H-LITEM-PYMT ROUNDED =
                    (((W-APC-PYMT (W-LP-INDX) * .60) *
                            W-WINX1 (W-LP-INDX))
                                + (W-APC-PYMT (W-LP-INDX) * .40)) *
                  W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)
                  PERFORM 1560-CALC-BENE-DEDUCT
                     THRU 1560-CALC-BENE-DEDUCT-EXIT
             ELSE
               IF OPPS-SRVC-IND (LN-SUB) = ' H' THEN
                 IF OPPS-PYMT-IND (LN-SUB) = ' 6' THEN
                   PERFORM 1555-CALC-H-STANDARD
                      THRU 1555-CALC-H-STANDARD-EXIT
                   PERFORM 1560-CALC-BENE-DEDUCT
                      THRU 1560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 1550-CALC-STANDARD-EXIT
                 END-IF
               ELSE
               IF OPPS-SRVC-IND (LN-SUB) = ' G' OR
                                           ' J' OR ' K' THEN
                IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR
                                            ' 5' OR ' 7' THEN
                  MOVE 0 TO H-BLOOD-FRACTION
                  PERFORM 1550-CALC-GJK
                     THRU 1550-CALC-GJK-EXIT
                  PERFORM 1560-CALC-BENE-DEDUCT
                     THRU 1560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                  MOVE  41  TO A-RETURN-CODE (LN-SUB)
                  GO TO 1550-CALC-STANDARD-EXIT
                 END-IF
                END-IF.

             IF H-LITEM-PYMT > 0
                COMPUTE H-LITEM-REIM ROUNDED =
                ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                   H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX)
                COMPUTE H-NAT-COIN = H-LITEM-PYMT -
               H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT.
             MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN.
             IF H-MIN-COIN > 0
               IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' H' OR
                                           ' J' OR ' K'
                 COMPUTE H-MIN-COIN ROUNDED = H-MIN-COIN *
                 (W-SRVC-UNITS (W-LP-INDX) -
                    (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION))
                   * W-DISC-RATE (W-LP-INDX)
               ELSE
                 IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                   COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25
                 ELSE
                   COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                 END-IF
               END-IF
             END-IF.

             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.
             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                  MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                         (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                            (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       1550-CALC-STANDARD-EXIT.
           EXIT.

      ***************************************************************
      * 1. CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR        *
      *    TYPES G , J , OR K.                                      *
      * 2. EFFECTIVE 04/01/2002 A PRO RATA REDUCTION APPLIES TO     *
      *       ALL SERVICE INDICATOR 'G' PAYMENTS (CURRENTLY .636)   *
      ***************************************************************

       1550-CALC-GJK.

             IF OPPS-HCPCS(LN-SUB) = 'P9021' OR 'P9010' OR 'P9038'
                      OR 'P9016' OR 'C1010' OR 'C1018' OR 'P9022'
                      OR 'P9039' OR 'P9040' OR 'C1016'
               PERFORM 1550-SET-BLOOD-FRACTION
                  THRU 1550-SET-BLOOD-FRACTION-EXIT
             ELSE
               IF (OPPS-SRVC-IND (LN-SUB) = ' G')
                COMPUTE H-LITEM-PYMT ROUNDED =
                 (((W-APC-PYMT (W-LP-INDX) -
                      (5 * W-MIN-COIN (W-LP-INDX))) * .364)
                    + (5 * W-MIN-COIN (W-LP-INDX)))
                 * W-SRVC-UNITS (W-LP-INDX)
                          * W-DISC-RATE (W-LP-INDX)
                COMPUTE W-PPCT (W-LP-INDX) =
                  (H-LITEM-PYMT - (W-NAT-COIN (W-LP-INDX) *
                  W-SRVC-UNITS (W-LP-INDX) *
                  W-DISC-RATE (W-LP-INDX))) / H-LITEM-PYMT
                  GO TO 1550-CALC-GJK-EXIT
             ELSE
                COMPUTE H-LITEM-PYMT ROUNDED =
                 (W-APC-PYMT (W-LP-INDX) * W-SRVC-UNITS (W-LP-INDX))
                          * W-DISC-RATE (W-LP-INDX)
                GO TO 1550-CALC-GJK-EXIT.

             COMPUTE H-LITEM-PYMT ROUNDED =
             W-BD-APC-PYMT (W-BD-INDX) * W-BD-SRVC-UNITS (W-BD-INDX)
                      * W-BD-DISC-RATE (W-BD-INDX).

             COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                 H-LITEM-PYMT * H-BLOOD-FRACTION.

             SET W-BD-INDX UP BY 1.

       1550-CALC-GJK-EXIT.
           EXIT.

       1550-SET-BLOOD-FRACTION.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.
              IF H-BENE-PINTS-USED > 0
                IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                   MOVE 1 TO H-BLOOD-FRACTION
                   COMPUTE H-BENE-PINTS-USED =
                     H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)
                ELSE
                  IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                    COMPUTE H-BLOOD-FRACTION =
                      H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                    MOVE 0 TO H-BENE-PINTS-USED
                  ELSE
                     MOVE 0 TO H-BLOOD-FRACTION
              ELSE
                 MOVE 0 TO H-BLOOD-FRACTION.

       1550-SET-BLOOD-FRACTION-EXIT.
           EXIT.

      ***************************************************************
      * 1. CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR        *
      *    TYPE  H.                                                 *
      * 2. EFFECTIVE 04/01/2002 A PRO RATA REDUCTION APPLIES TO     *
      *       ALL SERVICE INDICATOR 'H' PAYMENTS (CURRENTLY .689)   *
      ***************************************************************

       1555-CALC-H-TOT.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.
             IF OPPS-SRVC-IND (LN-SUB) = ' H'
               IF OPPS-PYMT-IND (LN-SUB) = ' 6'
                  COMPUTE H-TOT-H-CHRG =
                     (H-TOT-H-CHRG + H-SUB-CHRG)
               ELSE
                  NEXT SENTENCE
             ELSE
                NEXT SENTENCE.

       1555-CALC-H-TOT-EXIT.
           EXIT.

       1555-CALC-H-STANDARD.

             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

             IF L-SERVICE-FROM-DATE > 20001231
                COMPUTE T-LITEM-PYMT ROUNDED =
                (H-SUB-CHRG * (L-PSF-OPCOST-RATIO * .981956))
                 - (((W-APC-PYMT (W-LP-INDX) * .60) *
                        W-WINX1 (W-LP-INDX))
                        + (W-APC-PYMT (W-LP-INDX) * .40))
             ELSE
                COMPUTE T-LITEM-PYMT ROUNDED =
                (H-SUB-CHRG * L-PSF-OPCOST-RATIO)
                 - (((W-APC-PYMT (W-LP-INDX) * .60) *
                        W-WINX1 (W-LP-INDX))
                        + (W-APC-PYMT (W-LP-INDX) * .40)).


              IF C-FLAG = 'Y' AND L-SERVICE-FROM-DATE > 20020331
                COMPUTE H-TOTAL-WAOFF ROUNDED =
                ((H-TOTAL-OFFSET * .60) * A-WINX)
                         + (H-TOTAL-OFFSET * .40)
                PERFORM 1700-CALC-H-OFFSET
                   THRU 1700-CALC-H-OFFSET-EXIT
              ELSE
                 NEXT SENTENCE.

                IF T-LITEM-PYMT < 0 THEN
                   MOVE 0 TO H-LITEM-PYMT
                ELSE
                   MOVE T-LITEM-PYMT TO H-LITEM-PYMT.


       1555-CALC-H-STANDARD-EXIT.
           EXIT.

       1560-CALC-BENE-DEDUCT.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 4'
                GO TO 1560-CALC-BENE-DEDUCT-EXIT.
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                  H-LITEM-PYMT - H-LN-BLOOD-DEDUCT
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                      H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       1560-CALC-BENE-DEDUCT-EXIT.
           EXIT.

       1600-ADJ-CHRG-OUTL.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR
                                         ' H' OR ' N'
                GO TO 1600-ADJ-CHRG-OUTL-EXIT.

             IF (ST0-FLAG = 'Y') AND (OPPS-SRVC-IND (LN-SUB)
                 = ' S' OR ' T') AND (H-TOT-ST-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND
                ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                  ' X' OR ' P') AND (OPPS-PKG-FLAG (LN-SUB) = '0'))
                 AND (H-TOT-STVX-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                   (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)
                COMPUTE H-SUB-CHRG ROUNDED =
                     (H-CHRG-RATE * H-TOT-N-CHRG)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.

              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND
                ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                  ' X' OR ' P') AND (OPPS-PKG-FLAG (LN-SUB) = '0'))
                 AND (H-TOT-STVX-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                     (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)
                COMPUTE H-SUB-CHRG ROUNDED =
                     (H-CHRG-RATE * H-TOT-N-CHRG)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.

             COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
               ((W-SUB-CHRG (W-LP-INDX) *
                (L-PSF-OPCOST-RATIO * .981956)) -
                     (3.5 * A-LITEM-PYMT (LN-SUB))) * .50.

             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

       1600-ADJ-CHRG-OUTL-EXIT.
           EXIT.

      ***************************************************************
      * 1. RE-CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR     *
      *    TYPE H.                                                  *
      * 2. SUBTRACT WAGE ADJUSTED OFFSET AMOUNT FROM SI TYPE 'H'    *
      *    WITH HCPCS CODE BEGINNING WITH 'C'                       *
      * 2. EFFECTIVE 04/01/2002                                     *
      ***************************************************************

       1700-CALC-H-OFFSET.

             IF H-TOT-H-CHRG > 0
               COMPUTE H-OFF-RATE ROUNDED =
                    H-SUB-CHRG / H-TOT-H-CHRG
               COMPUTE T-LITEM-PYMT ROUNDED = (T-LITEM-PYMT -
                      (H-TOTAL-WAOFF * H-OFF-RATE)) * .364
             ELSE
                NEXT SENTENCE.

       1700-CALC-H-OFFSET-EXIT.
           EXIT.

       1800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 1810-PROCESS-TYPE1
                   THRU 1810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 1840-PROCESS-TYPE2
                   THRU 1840-PROCESS-TYPE2-EXIT.

       1800-ADJ-STV-REIM-EXIT.
           EXIT.

       1810-PROCESS-TYPE1.

             IF  W-DCP-COIN2 (W-DCP-INDX) > 0
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-WGNAT (W-DCP-INDX) TO H-TOTAL
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-WGNAT (W-DCP-INDX)) /
                                  W-DCP-COIN2 (W-DCP-INDX)
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.
                IF H-RATIO > 1
                    MOVE 1 TO H-RATIO.

       1810-PROCESS-TYPE1-EXIT.
           EXIT.

       1840-PROCESS-TYPE2.

             IF W-DCP-DOS (W-DCP-INDX) >= 20010701
                IF W-DCP-DOS (W-DCP-INDX) =  H-DCP-DOS
                   MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB
                   COMPUTE H-SHIFT =
                       W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)
                   COMPUTE H-TOTAL =
                        A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT
                   IF H-TOTAL > H-IP-LIMIT
                      COMPUTE H-SHIFT = H-SHIFT + H-TOTAL
                            - H-IP-LIMIT
                   END-IF
                   COMPUTE A-ADJ-COIN (LN-SUB) =
                        A-ADJ-COIN (LN-SUB) - H-SHIFT
                   COMPUTE A-LITEM-REIM (LN-SUB) =
                      A-LITEM-REIM (LN-SUB) + H-SHIFT
                   MOVE 22 TO A-RETURN-CODE (LN-SUB)
                END-IF
             ELSE
                IF W-DCP-DOS (W-DCP-INDX) >= 20010101
                  IF W-DCP-COIN2 (W-DCP-INDX) > H-IP-LIMIT
                     MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB
                     COMPUTE H-SHIFT =
                         W-DCP-COIN2 (W-DCP-INDX) - H-IP-LIMIT
                     COMPUTE A-ADJ-COIN (LN-SUB) =
                          A-ADJ-COIN (LN-SUB) - H-SHIFT
                     COMPUTE A-LITEM-REIM (LN-SUB) =
                        A-LITEM-REIM (LN-SUB) + H-SHIFT
                     MOVE 22 TO A-RETURN-CODE (LN-SUB)
                  END-IF
                END-IF
             END-IF.


       1840-PROCESS-TYPE2-EXIT.
           EXIT.

      ***************************************************************
      * 1. CALCULATE CLAIM LEVEL OUTLIER AMOUNT                     *
      ***************************************************************
       1900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.
      *      IF (A-TOT-CLM-PYMT > 0) AND
      *           (L-SERVICE-FROM-DATE < 20020401)
      *         PERFORM 1910-CALC-OUTLIER
      *            THRU 1910-CALC-OUTLIER-EXIT.
             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       1900-END-PRICE-RTN-EXIT.
           EXIT.

      *1910-CALC-OUTLIER.
      *
      *      IF L-SERVICE-FROM-DATE > 20001231
      *       COMPUTE H-OUTLIER-PYMT ROUNDED =
      *         ((H-TOT-CHRG * (L-PSF-OPCOST-RATIO * .981956))
      *               - (2.5 * H-TOT-PYMT)) * .75
      *      ELSE
      *       COMPUTE H-OUTLIER-PYMT ROUNDED =
      *         ((H-TOT-CHRG * L-PSF-OPCOST-RATIO)
      *               - (2.5 * H-TOT-PYMT)) * .75.
      *
      *1910-CALC-OUTLIER-EXIT.
      *    EXIT.

      ***************************************************************
      *    PROCESSING: AFTER 20021231                               *
      *        A. WILL PROCESS LINE ITEMS BASED ON OCE FLAGS.       *
      *        B. INITIALIZE OPPS   HOLD VARIABLES.                 *
      *        C. EDIT THE DATA PASSED FROM THE OCE.                *
      *        D. ASSEMBLE PRICING COMPONENTS.                      *
      *        E. CALCULATE THE PRICE.                              *
      *        F. RETURN COINSURANCE/REIMBURSEMENT/DEDUCTIBLE/      *
      *                  PAYMENT/OUTLIER AMOUNT/RETURN CODES        *
      ***************************************************************

          2000-PROCESS-MAIN-NEW.

              PERFORM 2100-INIT
                 THRU 2100-INIT-EXIT.

              IF A-CLM-RTN-CODE >= 50
                 GOBACK.
              MOVE H-WINX1 TO A-WINX.
              PERFORM 2125-INIT
                 THRU 2125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

              MOVE 0 TO W-DCP-MAX W-BLD-MAX.
              PERFORM 2150-INIT
                 THRU 2150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

              MOVE 0 TO W-DCP-MAX.
              PERFORM 2555-CALC-H-TOT
                 THRU 2555-CALC-H-TOT-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.

              SET W-BD-INDX TO 1.
              MOVE 0 TO W-DCP-MAX.
              PERFORM 2400-CALCULATE
                 THRU 2400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.

              PERFORM 2600-ADJ-CHRG-OUTL
                 THRU 2600-ADJ-CHRG-OUTL-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX


              IF GJK-FLAG = 'Y'
                PERFORM 2800-ADJ-STV-REIM
                   THRU 2800-ADJ-STV-REIM-EXIT
                      VARYING W-DCP-INDX FROM 1 BY 1
                        UNTIL W-DCP-INDX > W-DCP-MAX
              ELSE
                 NEXT SENTENCE.

              PERFORM 2900-END-PRICE-RTN
                 THRU 2900-END-PRICE-RTN-EXIT.

       2000-PROCESS-MAIN-NEW-EXIT.
           EXIT.

      ***************************************************************
      *    INITIALIZE WORKING STORAGE HOLD AREAS                    *
      *    AND ADDITIONAL VARIABLES TO BE PASSED BACK TO            *
      *    THE STANDARD SYSTEM.                                     *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      ***************************************************************
       2100-INIT.

             MOVE 01 TO A-CLM-RTN-CODE.
             MOVE 'N' TO APC33-FLAG GJK-FLAG ST0-FLAG
                         N-FLAG C-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO TO A-OUTLIER-PYMT
                          A-TOTAL-CLM-DEDUCT
                          A-TOT-CLM-CHRG
                          A-TOT-CLM-PYMT
                          A-BLOOD-DEDUCT-DUE
                          A-BLOOD-PINTS-USED
                          A-WINX
                          W-LNC-MAX.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 2100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                   MOVE 54 TO A-CLM-RTN-CODE
                   GO TO 2100-INIT-EXIT
                ELSE
                   IF L-PSF-TERMDT > 0
                      IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                         MOVE 54 TO A-CLM-RTN-CODE
                         GO TO 2100-INIT-EXIT
                      END-IF
                   END-IF.
             IF L-SERVICE-FROM-DATE >= 20040101
                MOVE CAL-VERSION3 TO A-CALC-VERS
             ELSE
                MOVE CAL-VERSION2 TO A-CALC-VERS.
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.
             IF L-PSF-WGIDX-RECLASS = 'Y'
                MOVE L-PSF-WI-MSA TO H-PSF-MSA
             ELSE
                IF L-PSF-WGIDX-RECLASS = 'N'
                   MOVE L-PSF-GEO-MSA TO H-PSF-MSA
                ELSE
                   MOVE  52  TO A-CLM-RTN-CODE
                   GO TO 2100-INIT-EXIT.

             IF L-SERVICE-FROM-DATE >= 20040101
                MOVE 876 TO H-IP-LIMIT
             ELSE
                IF L-SERVICE-FROM-DATE >= 20030101
                   MOVE 840 TO H-IP-LIMIT.

             IF L-SERVICE-FROM-DATE >= 20040101
                PERFORM 2120-FLOOR-2004
                   THRU 2120-FLOOR-2004-EXIT
                PERFORM 2120-SEC401-2004
                   THRU 2120-SEC401-2004-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE >= 20030101
                   PERFORM 2120-FLOOR-2003
                      THRU 2120-FLOOR-2003-EXIT
                   PERFORM 2120-SEC401-2003
                      THRU 2120-SEC401-2003-EXIT.

                MOVE H-PSF-MSA TO A-MSA.


             PERFORM 2230-CHNG-WAGEINDX
                THRU 2230-CHNG-WAGEINDX-EXIT.

             IF H-WINX1 = 0 THEN
                PERFORM 2200-CALC-WAGEINDX
                   THRU 2200-CALC-WAGEINDX-EXIT.

       2100-INIT-EXIT.
            EXIT.

      ***************************************************************
      *  RESET FLOOR MSA - 'FROM-DATE' CONTROLLED                   *
      *     - YEAR 2003                                             *
      *     - YEAR 2004                                             *
      ***************************************************************

       2120-FLOOR-2003.

             IF H-PSF-MSA = '  14'
                AND L-PSF-WGIDX-RECLASS = 'Y'
                AND L-PSF-PROV-ST = '16'
                   MOVE 'N' TO L-PSF-WGIDX-RECLASS
                   MOVE '  16' TO H-PSF-MSA.

             IF H-PSF-MSA = '1123'
                AND L-PSF-PROV-ST = '22'
                   MOVE '  22' TO H-PSF-MSA.

             IF H-PSF-MSA = '1800'
                AND L-PSF-WGIDX-RECLASS = 'Y'
                AND L-PSF-PROV-ST = '11'
                   MOVE 'N' TO L-PSF-WGIDX-RECLASS
                   MOVE '  11' TO H-PSF-MSA.

             IF H-PSF-MSA = '1900'
                AND L-PSF-PROV-ST = '21'
                   MOVE '  21' TO H-PSF-MSA.

             IF H-PSF-MSA = '2440'
                AND L-PSF-PROV-ST = '15'
                   MOVE '  15' TO H-PSF-MSA.

             IF H-PSF-MSA = '3660'
                AND L-PSF-PROV-ST = '49'
                   MOVE 'N' TO L-PSF-WGIDX-RECLASS
                   MOVE '  49' TO H-PSF-MSA.

             IF H-PSF-MSA = '3700'
                AND L-PSF-WGIDX-RECLASS = 'Y'
                AND L-PSF-PROV-ST = '26'
                   MOVE 'N' TO L-PSF-WGIDX-RECLASS
                   MOVE '  26' TO H-PSF-MSA.

             IF H-PSF-MSA = '6020'
                AND L-PSF-PROV-ST = '36'
                   MOVE '  36' TO H-PSF-MSA.

             IF H-PSF-MSA = '9000'
                AND L-PSF-PROV-ST = '36'
                   MOVE '  36' TO H-PSF-MSA.

       2120-FLOOR-2003-EXIT.
           EXIT.

       2120-SEC401-2003.

             IF (L-PSF-PROV-OSCAR = '050192' OR '050286' OR
                                    '050446' OR '050469' OR
                                    '050528')
                MOVE '  05' TO H-PSF-MSA
             ELSE
               IF (L-PSF-PROV-OSCAR = '100048' OR '100118')
                  MOVE '  10' TO H-PSF-MSA
               ELSE
                 IF (L-PSF-PROV-OSCAR = '170137')
                    MOVE '  17' TO H-PSF-MSA
                 ELSE
                   IF (L-PSF-PROV-OSCAR = '190048' OR '190110')
                      MOVE '  19' TO H-PSF-MSA
                   ELSE
                     IF (L-PSF-PROV-OSCAR = '230078')
                        MOVE '  23' TO H-PSF-MSA
                     ELSE
                       IF (L-PSF-PROV-OSCAR = '260006')
                          MOVE '  26' TO H-PSF-MSA
                       ELSE
                         IF (L-PSF-PROV-OSCAR = '300009')
                            MOVE '  30' TO H-PSF-MSA
                         ELSE
                           IF (L-PSF-PROV-OSCAR = '380084')
                              MOVE '  38' TO H-PSF-MSA.

       2120-SEC401-2003-EXIT.
           EXIT.

       2120-FLOOR-2004.

             IF H-PSF-MSA = '  14'
                AND L-PSF-WGIDX-RECLASS = 'Y'
                AND L-PSF-PROV-ST = '16'
                   MOVE 'N' TO L-PSF-WGIDX-RECLASS
                   MOVE '  16' TO H-PSF-MSA.

             IF H-PSF-MSA = '0200'
                AND L-PSF-WGIDX-RECLASS = 'Y'
                AND L-PSF-PROV-ST = '06'
                   MOVE 'N' TO L-PSF-WGIDX-RECLASS
                   MOVE '  06' TO H-PSF-MSA.

             IF H-PSF-MSA = '1480'
                AND L-PSF-WGIDX-RECLASS = 'Y'
                AND L-PSF-PROV-ST = '36'
                   MOVE 'N' TO L-PSF-WGIDX-RECLASS
                   MOVE '  36' TO H-PSF-MSA.

             IF H-PSF-MSA = '1900'
                AND L-PSF-PROV-ST = '21'
                   MOVE '  21' TO H-PSF-MSA.

             IF H-PSF-MSA = '2440'
                AND L-PSF-PROV-ST = '15'
                   MOVE '  15' TO H-PSF-MSA.

             IF H-PSF-MSA = '2985'
                AND L-PSF-PROV-ST = '24'
                   MOVE '  24' TO H-PSF-MSA.

             IF H-PSF-MSA = '3660'
                AND L-PSF-WGIDX-RECLASS = 'Y'
                AND L-PSF-PROV-ST = '49'
                   MOVE 'N' TO L-PSF-WGIDX-RECLASS
                   MOVE '  49' TO H-PSF-MSA.

             IF H-PSF-MSA = '3660'
                AND L-PSF-PROV-ST = '49'
                   MOVE '  49' TO H-PSF-MSA.

             IF H-PSF-MSA = '3700'
                AND L-PSF-WGIDX-RECLASS = 'Y'
                AND L-PSF-PROV-ST = '26'
                   MOVE 'N' TO L-PSF-WGIDX-RECLASS
                   MOVE '  26' TO H-PSF-MSA.

             IF H-PSF-MSA = '6020'
                AND L-PSF-PROV-ST = '36'
                   MOVE '  36' TO H-PSF-MSA.

             IF H-PSF-MSA = '6740'
                AND L-PSF-WGIDX-RECLASS = 'Y'
                AND L-PSF-PROV-ST = '50'
                   MOVE 'N' TO L-PSF-WGIDX-RECLASS
                   MOVE '  50' TO H-PSF-MSA.

             IF H-PSF-MSA = '7720'
                AND L-PSF-WGIDX-RECLASS = 'Y'
                AND L-PSF-PROV-ST = '28'
                   MOVE 'N' TO L-PSF-WGIDX-RECLASS
                   MOVE '  28' TO H-PSF-MSA.

             IF H-PSF-MSA = '8080'
                AND L-PSF-PROV-ST = '36'
                   MOVE '  36' TO H-PSF-MSA.

             IF H-PSF-MSA = '9000'
                AND L-PSF-PROV-ST = '36'
                   MOVE '  36' TO H-PSF-MSA.

       2120-FLOOR-2004-EXIT.
           EXIT.

       2120-SEC401-2004.

             IF (L-PSF-PROV-OSCAR = '050192' OR '050286' OR
                                    '050469' OR '050528' OR
                                    '050618')
                MOVE '  05' TO H-PSF-MSA
             ELSE
               IF (L-PSF-PROV-OSCAR = '100048' OR '100118')
                  MOVE '  10' TO H-PSF-MSA
               ELSE
                 IF (L-PSF-PROV-OSCAR = '170137')
                    MOVE '  17' TO H-PSF-MSA
                 ELSE
                   IF (L-PSF-PROV-OSCAR = '190048' OR '190110')
                      MOVE '  19' TO H-PSF-MSA
                   ELSE
                     IF (L-PSF-PROV-OSCAR = '230078')
                        MOVE '  23' TO H-PSF-MSA
                     ELSE
                       IF (L-PSF-PROV-OSCAR = '260006')
                          MOVE '  26' TO H-PSF-MSA
                       ELSE
                         IF (L-PSF-PROV-OSCAR = '300009')
                            MOVE '  30' TO H-PSF-MSA
                         ELSE
                           IF (L-PSF-PROV-OSCAR = '380084')
                              MOVE '  38' TO H-PSF-MSA
                           ELSE
                             IF (L-PSF-PROV-OSCAR = '390106')
                                MOVE '  39' TO H-PSF-MSA.

       2120-SEC401-2004-EXIT.
           EXIT.

      ***************************************************************
      *  SET FLAG IF APC = 0033                                     *
      *    - TERMINATE PROCESS IF 0033 LOCATED                      *
      *                                                             *
      ***************************************************************

       2125-INIT.

             IF OPPS-APC (LN-SUB) = '0033'
                MOVE 'Y' TO APC33-FLAG
                MOVE 451 TO LN-SUB.

       2125-INIT-EXIT.
           EXIT.

      ***************************************************************
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1 OR 2)   *
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0 OR 1 OR 2          *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM DENIAL/REJECT FLAG  = TO 1     *
      *                 AND (APC NOT = 0033 OR 0034 OR 0322 OR      *
      *                      0323 OR 0324 OR 0325 OR 0373 OR 0374)) *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0              *
      *               - OR (APC 0033 IS NOT ON THE CLAIM            *
      *                     AND SERVICE INDICATOR = 'P'             *
      *                     OR  APC = 0322-0325,0373,0374)          *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      ***************************************************************
       2150-INIT.

             MOVE  01  TO A-RETURN-CODE (LN-SUB).

      ***************************************************************
      * OVER-RIDE SERVICE UNITS FOR APC 0339 - EFFECTIVE 04/01/2002 *
      *   - CHANGE UNIT VALUE TO 1                                  *
      ***************************************************************

             IF OPPS-APC (LN-SUB) = '0339'
                  MOVE 1 TO OPPS-SRVC-UNITS (LN-SUB).

      ***************************************************************
      * OVER-RIDE SERVICE INDICATOR FOR      - EFFECTIVE 01/01/2004 *
      *   - CHANGE INDICATOR TO 'N' AND MOVE SPACES TO APC          *
      *   - OCE CORRECTION WILL REPLACE THIS OVERRIDE 04/01/2004    *
      ***************************************************************
      *      IF ((L-SERVICE-FROM-DATE > 20031231) AND
      *         (L-SERVICE-FROM-DATE < 20040401)) AND
      *         (OPPS-HCPCS (LN-SUB) = 'Q4078' OR 'A9526')
      *           MOVE ' N' TO OPPS-SRVC-IND (LN-SUB)
      *           MOVE '00000' TO OPPS-GRP (LN-SUB)
      *           MOVE '00000' TO OPPS-HCPCS-APC (LN-SUB).
      ***************************************************************

      ***************************************************************
      * OVER-RIDE SERVICE INDICATOR FOR      - EFFECTIVE 01/01/2004 *
      *   - CHANGE AS OF 04/01/2004                                 *
      *   - CHANGE INDICATOR TO 'N' AND MOVE ZEROS TO APC 0738      *
      *   - CHANGE PACKGAGE FLAG TO '1'                             *
      *   - OCE CORRECTION WILL REPLACE THIS OVERRIDE 07/01/2004    *
      ***************************************************************
             IF ((L-SERVICE-FROM-DATE > 20031231) AND
                (L-SERVICE-FROM-DATE < 20040401)) AND
                (OPPS-APC (LN-SUB) = '0738')
                  MOVE ' N' TO OPPS-SRVC-IND (LN-SUB)
                  MOVE '00000' TO OPPS-GRP (LN-SUB)
                  MOVE '00000' TO OPPS-HCPCS-APC (LN-SUB)
                  MOVE '1' TO OPPS-PKG-FLAG (LN-SUB).
      ***************************************************************

             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 2250-CALC-DISCOUNT
                THRU 2250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 2150-INIT-EXIT.

      ***************************************************************
      *  EFFECTIVE AS OF 04-01-2002                                 *
      *    - TOTAL DEVICE OFFSET                                    *
      ***************************************************************

             IF OPPS-SRVC-IND (LN-SUB) = ' H'
                MOVE 'Y' TO C-FLAG
                COMPUTE H-TOT-HTD-UNITS = H-TOT-HTD-UNITS
                        + H-SRVC-UNITS.

             PERFORM 2160-TOTAL-OFFSET
                THRU 2160-TOTAL-OFFSET-EXIT.

             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C'
              OR ' E' OR ' F' OR ' G' OR ' H' OR ' J' OR ' K' OR
              ' L' OR ' N' OR ' P' OR ' S' OR ' T' OR ' V' OR
              ' X' OR ' W' OR ' Y' OR ' Z') THEN
                MOVE  40  TO A-RETURN-CODE (LN-SUB)
                GO TO 2150-INIT-EXIT
              ELSE
                MOVE  01  TO A-RETURN-CODE (LN-SUB).

             IF OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR ' E'
                           OR ' F' OR ' L' OR ' W' OR ' Y' OR ' Z'
                MOVE  41  TO A-RETURN-CODE (LN-SUB)
                GO TO 2150-INIT-EXIT.

               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'
                 IF OPPS-PKG-FLAG (LN-SUB) = '0' OR '1' OR '2'
                                             OR '3'
                   IF (OPPS-LITEM-DR-FLAG (LN-SUB) = '0' OR
                       OPPS-LITEM-DR-FLAG (LN-SUB) = '1' AND
                       (OPPS-APC (LN-SUB) = '0033' OR '0034'
                       OR '0322' OR '0323' OR '0324' OR '0325'
                       OR '0373' OR '0374')) OR
                      (OPPS-LITEM-ACT-FLAG (LN-SUB) = '1')
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                                           OR ' 2' OR ' 3' OR ' 4'
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR
                            ((APC33-FLAG = 'Y') AND
                             ((OPPS-SRVC-IND (LN-SUB) = ' P') OR
                             (OPPS-APC (LN-SUB) = '0322' OR '0323'
                              OR '0324' OR '0325' OR '0373'
                              OR '0374')))
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

                    IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                       COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                            H-SUB-CHRG
                    END-IF
                    IF OPPS-PKG-FLAG (LN-SUB) = '1' OR '2'
                       COMPUTE H-TOT-N-CHRG = H-SUB-CHRG
                                  + H-TOT-N-CHRG
                       MOVE 'Y' TO N-FLAG
                    END-IF
                    IF (OPPS-APC (LN-SUB) = '0000') OR
                       (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2')
                       MOVE 42 TO A-RETURN-CODE (LN-SUB)
                       GO TO 2150-INIT-EXIT
                    END-IF
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 2150-INIT-EXIT
                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2
                      PERFORM 2175-APC-LOOKUP
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 2150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 2150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 2150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 2150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 2150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 2150-INIT-EXIT.

             IF (A-RETURN-CODE (LN-SUB) =  01) AND
                (OPPS-HCPCS (LN-SUB) = 'C9114' OR 'C9115')
                PERFORM 2180-MOD-CCODE-PYMT
                   THRU 2180-MOD-CCODE-PYMT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 01
                PERFORM 2300-COIN-DEDUCT
                   THRU 2300-COIN-DEDUCT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 01
                SET WBD-INDX TO 1
                SEARCH WBD-ENTRY VARYING WBD-INDX
                   AT END
                      GO TO 2150-INIT-EXIT
                 WHEN W-BLOOD-HCPCS (WBD-INDX) = OPPS-HCPCS (LN-SUB)
                     MOVE W-BLOOD-RANK (WBD-INDX) TO H-BLOOD-RANK
                     PERFORM 2375-BLOOD-DEDUCT
                        THRU 2375-BLOOD-DEDUCT-EXIT.

       2150-INIT-EXIT.
           EXIT.

      ***************************************************************
      *  COMPUTE TOTAL OFFSET FROM TABLE 5 FOR DEVICES              *
      *      - EFFECTIVE AS OF 01-01-2003                           *
      *      - EFFECTIVE AS OF 01-01-2004                           *
      *        - SEARCH TABLE OPPSOF04                              *
      *          - WHERE ALL OFFSET VALUES EQUAL ZERO               *
      ***************************************************************
       2160-TOTAL-OFFSET.

             MOVE OPPS-GRP (LN-SUB) TO W-OFF-APC.
             IF L-SERVICE-FROM-DATE >= 20040101
               SEARCH ALL WOO-ENTRY3
                  AT END
                     GO TO 2160-TOTAL-OFFSET-EXIT
                  WHEN WOO-APC3 (WOO-INDX3) = W-OFF-APC
                     COMPUTE H-TOTAL-OFFSET = H-TOTAL-OFFSET
                        + (WOO-OFFSET3 (WOO-INDX3) * H-DISC-RATE
                            * H-SRVC-UNITS)
                     COMPUTE H-TOT-OFF-UNITS = H-TOT-OFF-UNITS
                        + H-SRVC-UNITS
             ELSE
                SEARCH ALL WOO-ENTRY2
                   AT END
                      GO TO 2160-TOTAL-OFFSET-EXIT
                   WHEN WOO-APC2 (WOO-INDX2) = W-OFF-APC
                      COMPUTE H-TOTAL-OFFSET = H-TOTAL-OFFSET
                         + (WOO-OFFSET2 (WOO-INDX2) * H-DISC-RATE
                             * H-SRVC-UNITS)
                      COMPUTE H-TOT-OFF-UNITS = H-TOT-OFF-UNITS
                         + H-SRVC-UNITS.

       2160-TOTAL-OFFSET-EXIT.
           EXIT.

      ***************************************************************
      *  SEARCH APC TABLE - MOVE VALUES TO HOLD AREA FOR PROCESSING *
      *      - ADJUST TOTAL CHARGE FOR DELETED APC'S                *
      ***************************************************************
       2175-APC-LOOKUP.

             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)
               IF WAR-RATEX (W-SUB2) = 'DELETED'
                 MOVE 30 TO A-RETURN-CODE (LN-SUB)
                 COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                      H-SUB-CHRG
               ELSE
                 MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                 MOVE WAR-RANK (W-SUB2) TO H-RANK
                 MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                 MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                 MOVE WAR-PPCT (W-SUB2) TO H-PPCT
             ELSE
                SUBTRACT 1 FROM W-SUB2
                IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                  GO TO 2175-APC-LOOKUP
                ELSE
                   MOVE 0 TO H-APC-PYMT
                             H-RANK
                             H-MIN-COIN
                             H-NAT-COIN
                             H-PPCT.

       2175-APC-LOOKUP-EXIT.
           EXIT.

      ***************************************************************
      *  IF DATE OF SERVICE BETWEEN 12/31/2002 AND 04/01/2003       *
      *    IF HCPCS CODE = C9114 OR C9115 ADJUST PAYMENT AND        *
      *    COINSURANCE AMOUNTS                                      *
      ***************************************************************
       2180-MOD-CCODE-PYMT.

             IF L-SERVICE-FROM-DATE > 20021231 AND
                L-SERVICE-FROM-DATE < 20030401
                IF OPPS-HCPCS (LN-SUB) = 'C9114'
                   COMPUTE H-APC-PYMT = H-APC-PYMT * 3
                   COMPUTE H-NAT-COIN = H-NAT-COIN * 3
                   COMPUTE H-MIN-COIN = H-MIN-COIN * 3
                ELSE
                  IF OPPS-HCPCS (LN-SUB) = 'C9115'
                     COMPUTE H-APC-PYMT = H-APC-PYMT * 2
                     COMPUTE H-NAT-COIN = H-NAT-COIN * 2
                     COMPUTE H-MIN-COIN = H-MIN-COIN * 2
                  ELSE
                    NEXT SENTENCE.

       2180-MOD-CCODE-PYMT-EXIT.
           EXIT.

      ***************************************************************
      *    SEARCH WAGE INDEX TABLE AND SELECT THE WAGE INDEX        *
      *    WHEN EQUAL TO PROVIDER SPECIFIC WAGE INDEX               *
      *    IF WAGE INDEX NOT LOCATED                                *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      ***************************************************************
       2200-CALC-WAGEINDX.

             MOVE WWD-MAX TO WWD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WWD-DATE (WWD-SUB)
                 SUBTRACT 1 FROM WWD-SUB
             END-PERFORM.

             SEARCH ALL WWM-ENTRY
                AT END
                   MOVE  50  TO A-CLM-RTN-CODE
                   GO TO 2200-CALC-WAGEINDX-EXIT
                WHEN WWM-MSA (WWM-INDX) = H-PSF-MSA
                  MOVE WWM-PTR (WWM-INDX) TO W-SUB2
                  PERFORM 2210-WAGE-LOOKUP.

             IF H-WINX1 = 0 THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       2200-CALC-WAGEINDX-EXIT.
           EXIT.

       2210-WAGE-LOOKUP.

             IF WWW-DTCD (W-SUB2) NOT > WWD-DTCD (WWD-SUB)
                IF L-PSF-WGIDX-RECLASS = 'Y'
                  MOVE WWW-WINX2 (W-SUB2) TO H-WINX1
                ELSE
                  MOVE WWW-WINX1 (W-SUB2) TO H-WINX1
                END-IF
             ELSE
                SUBTRACT 1 FROM W-SUB2
                IF W-SUB2 > WWM-PTR (WWM-INDX - 1)
                   GO TO 2210-WAGE-LOOKUP
                ELSE
                   MOVE 0 TO H-WINX1.

       2210-WAGE-LOOKUP-EXIT.
           EXIT.

      ***************************************************************
      *    FOR FY 2003 NEW LUGAR HOSPITALS ONLY                     *
      ***************************************************************

       2230-CHNG-WAGEINDX.

             IF (L-SERVICE-FROM-DATE > 20021231 AND
                 L-SERVICE-FROM-DATE < 20040101)
               IF (L-PSF-PROV-OSCAR = '110130')
                       AND (L-PSF-WI-MSA = '  11'
                       AND L-PSF-WGIDX-RECLASS = 'Y')
                  MOVE 00.8230 TO H-WINX1.

             IF (L-SERVICE-FROM-DATE > 20031231 AND
                 L-SERVICE-FROM-DATE < 20050101)
               IF (L-PSF-PROV-OSCAR = '330001' OR '330126' OR
                     '330135' OR '330205' OR '330209' OR '330264')
                       AND (L-PSF-WI-MSA = '5600'
                       AND L-PSF-WGIDX-RECLASS = 'Y')
                  MOVE 01.3892 TO H-WINX1.

             IF (L-SERVICE-FROM-DATE > 20031231 AND
                 L-SERVICE-FROM-DATE < 20050101)
               IF (L-PSF-PROV-OSCAR = '470003')
                       AND (L-PSF-WI-MSA = '1123'
                       AND L-PSF-WGIDX-RECLASS = 'Y')
                  MOVE 01.1120 TO H-WINX1.

       2230-CHNG-WAGEINDX-EXIT.
           EXIT.

      ***************************************************************
      *    CALCULATE DISCOUNT FACTOR BASED ON THE DISCOUNT          *
      *    INDICATOR PASSED BY THE OCE: VALUE 1 - 8                 *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      ***************************************************************
       2250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 2250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     MOVE  38  TO A-RETURN-CODE (LN-SUB).

       2250-CALC-DISCOUNT-EXIT.
           EXIT.

      ***************************************************************
      *    DETERMINE THE DEDUCTIBLE SEQUENCE. DEDUCTIBLE WILL BE    *
      *    TAKEN FROM OPPS SERVICES FIRST, THEN FROM ANY OTHER      *
      *    TYPES OF SERVICES FROM THE CLAIM.                        *
      *       - SET POINTERS TO THE HIGHEST RANKED PERCENTAGE       *
      *         (LARGEST NATIONAL UNADJUSTED COINSURANCE /          *
      *          THE APC PAYMENT)                                   *
      *       - MOVE ALL PRICING VARIABLES TO STAGING AREA          *
      ***************************************************************
       2300-COIN-DEDUCT.

             ADD 1 TO W-LNC-MAX.
             SET W-LP-INDX TO W-LNC-MAX.
             PERFORM 2350-STAGE-ENTRY
                THRU 2350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).
             MOVE LN-SUB TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX1    TO W-WINX1 (W-LP-INDX).
             MOVE H-RANK     TO W-RANK (W-LP-INDX).
             MOVE H-PPCT     TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
              UNTIL PS-SUB > L-PSF-APC-LINE-CNT
              IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS * H-DISC-RATE
                MOVE 25 TO A-RETURN-CODE (LN-SUB)
                MOVE L-PSF-APC-LINE-CNT TO PS-SUB
              END-IF
             END-PERFORM.

       2300-COIN-DEDUCT-EXIT.
           EXIT.

       2350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       2350-STAGE-ENTRY-EXIT.
           EXIT.

      ***************************************************************
      *    DETERMINE THE BLOOD DEDUCTIBLE SEQUENCE. DEDUCTIBLE      *
      *    WILL BE CALCULATED BASED ON RANKING.                     *
      *       - SET POINTERS TO THE HIGHEST RANKED APC              *
      *         (SMALLEST UNADJUSTED APC PAYMENT)                   *
      *       - MOVE ALL PRICING VARIABLES TO STAGING AREA          *
      ***************************************************************
       2375-BLOOD-DEDUCT.

             ADD 1 TO W-BLD-MAX.
             SET W-BD-INDX TO W-BLD-MAX.
             PERFORM 2385-STAGE-ENTRY
                THRU 2385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLOOD-RANK NOT < W-BD-RANK (W-BD-INDX - 1).
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX1    TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK TO W-BD-RANK (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).

             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
              UNTIL PS-SUB > L-PSF-APC-LINE-CNT
              IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS * H-DISC-RATE
                MOVE 25 TO A-RETURN-CODE (LN-SUB)
                MOVE L-PSF-APC-LINE-CNT TO PS-SUB
              END-IF
             END-PERFORM.

       2375-BLOOD-DEDUCT-EXIT.
           EXIT.

       2385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       2385-STAGE-ENTRY-EXIT.
           EXIT.

      ***************************************************************
      *    FIRST STEP IN DETERMINING A LINE ITEM PRICE.             *
      *    CHECK ALL APPROPRIATE FLAGS AND INDICATORS PASSED        *
      *    BY THE OCE.                                              *
      *      - SET RETURN CODES TO INDICATE ERRORS OR STATUS        *
      *        - '20' - LINE PROCESSED BUT PAYMENT = 0              *
      *                 - BENE DEDUCTIBLE => ADJUSTED PAYMENT       *
      *                                                             *
      ***************************************************************
       2400-CALCULATE.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 2400-CALCULATE-EXIT.

             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 2550-CALC-STANDARD
                   THRU 2550-CALC-STANDARD-EXIT
             ELSE
                GO TO 2400-CALCULATE-EXIT.

      ***************************************************************
      *  SET GJK FLAG                                               *
      *    - TEST LINE ITEM DATE OF SERVICE > 20010630              *
      *    - TOTAL DRUG / DEVICE COINSURANCE                        *
      ***************************************************************

             IF (A-RETURN-CODE (LN-SUB) <  30)
               PERFORM 2450-ADJ-PROC-COIN
                  THRU 2450-ADJ-PROC-COIN-EXIT
             ELSE
               NEXT SENTENCE.

      ***************************************************************
      *  SET ST0 AND STVX FLAGS                                     *
      *    - TEST LINE ITEM DATE OF SERVICE > 20020331              *
      *    - TOTAL PROCEDURE CHARGES AND BUNDLED CHARGES            *
      ***************************************************************

             PERFORM 2500-ADJ-CHRGS
                THRU 2500-ADJ-CHRGS-EXIT.

             IF A-RETURN-CODE (LN-SUB) <  30
               COMPUTE A-TOTAL-CLM-DEDUCT =
                       H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT
               COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT
               COMPUTE A-BLOOD-DEDUCT-DUE =
                     A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT
               MOVE H-LITEM-PYMT TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN TO A-RED-COIN (LN-SUB)
               IF H-RED-COIN > H-NAT-COIN
                 MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF
               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.
             MOVE ZERO TO LINE-HOLD-ITEMS.

       2400-CALCULATE-EXIT.
           EXIT.

      ***************************************************************
      *  SET GJK FLAG                                               *
      *    - STAGE BY SERVICE INDICATOR                             *
      *                                                             *
      ***************************************************************
       2450-ADJ-PROC-COIN.

             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX1 (W-LP-INDX) + .4)
                  IF H-NEW-WGNAT > H-IP-LIMIT
                    MOVE H-IP-LIMIT TO H-NEW-WGNAT
                  END-IF
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                MOVE 1 TO H-DCP-CODE
                PERFORM 2455-SEARCH-KEY
                   THRU 2455-SEARCH-KEY-EXIT
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR ' K'
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                        H-TOTAL-LN-DEDUCT - H-LITEM-REIM
                                   - H-LN-BLOOD-DEDUCT
                   MOVE 'Y' TO GJK-FLAG
                   MOVE 1 TO H-DCP-CODE
                   PERFORM 2455-SEARCH-KEY
                      THRU 2455-SEARCH-KEY-EXIT
                   MOVE 2 TO H-DCP-CODE
                   ADD 1 TO W-DCP-MAX
                   SET W-DCP-INDX TO W-DCP-MAX
                   PERFORM 2475-STAGE-DCP-ENTRY
                     THRU 2475-STAGE-DCP-ENTRY-EXIT
                       UNTIL W-DCP-INDX = 1 OR
                       H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       2450-ADJ-PROC-COIN-EXIT.
           EXIT.

       2455-SEARCH-KEY.

             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX
                AT END
                   PERFORM 2460-ADD-ENTRY
                      THRU 2460-ADD-ENTRY-EXIT
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 2465-UPDATE-ENTRY
                      THRU 2465-UPDATE-ENTRY-EXIT.

       2455-SEARCH-KEY-EXIT.
           EXIT.

       2460-ADD-ENTRY.

             ADD 1 TO W-DCP-MAX.
             SET W-DCP-INDX TO W-DCP-MAX.
             PERFORM 2475-STAGE-DCP-ENTRY
               THRU 2475-STAGE-DCP-ENTRY-EXIT
                UNTIL W-DCP-INDX = 1 OR
                  H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR ' K'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       2460-ADD-ENTRY-EXIT.
           EXIT.

       2465-UPDATE-ENTRY.

             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR ' K'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 2485-REPLACE-TYPE1
                     THRU 2485-REPLACE-TYPE1-EXIT
               ELSE
                  PERFORM 2480-RANK-COIN
                     THRU 2480-RANK-COIN-EXIT.

       2465-UPDATE-ENTRY-EXIT.
           EXIT.

       2475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       2475-STAGE-DCP-ENTRY-EXIT.
           EXIT.

       2480-RANK-COIN.

             IF H-NEW-WGNAT > W-DCP-WGNAT (W-DCP-INDX)
               MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
               MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
               MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
               MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       2480-RANK-COIN-EXIT.
           EXIT.

       2485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       2485-REPLACE-TYPE1-EXIT.
           EXIT.

       2500-ADJ-CHRGS.

      *****************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY              *
      *****************************************************
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                 OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                MOVE 'Y' TO ST0-FLAG.

             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                 OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX)
                               + H-TOT-ST-CHRG
                COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT
                               + H-TOT-ST-PYMT.

             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                OR ' X' OR ' P')
                AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT
                               + H-TOT-STVX-PYMT.

       2500-ADJ-CHRGS-EXIT.
           EXIT.
      ***************************************************************
      * 1. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *     - DESCENDING UNTIL DEDUCTIBLE = 0.                      *
      * 2. CALCULATE THE STANDARD LINE PRICE                        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS                *
      *          * DISCOUNT FACTOR)                                 *
      *     - WAGE ADJUST 60% OF THE APC PAYMENT ONLY               *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA.                     *
      *                                                             *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *       AND DRUGS                                             *
      ***************************************************************
       2550-CALC-STANDARD.

             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' V'
                        OR ' T' OR ' P' OR ' X' THEN
                COMPUTE H-LITEM-PYMT ROUNDED =
                    (((W-APC-PYMT (W-LP-INDX) * .60) *
                            W-WINX1 (W-LP-INDX))
                                + (W-APC-PYMT (W-LP-INDX) * .40)) *
                  W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)
                  PERFORM 2560-CALC-BENE-DEDUCT
                     THRU 2560-CALC-BENE-DEDUCT-EXIT
             ELSE
               IF OPPS-SRVC-IND (LN-SUB) = ' H' THEN
                 IF OPPS-PYMT-IND (LN-SUB) = ' 6' THEN
                   PERFORM 2555-CALC-H-STANDARD
                      THRU 2555-CALC-H-STANDARD-EXIT
                   PERFORM 2560-CALC-BENE-DEDUCT
                      THRU 2560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 2550-CALC-STANDARD-EXIT
                 END-IF
               ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' G' OR
                                            ' J' OR ' K' THEN
                 IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR
                                             ' 5' OR ' 7' THEN
                  MOVE 0 TO H-BLOOD-FRACTION
                  PERFORM 2550-CALC-GJK
                     THRU 2550-CALC-GJK-EXIT
                  PERFORM 2560-CALC-BENE-DEDUCT
                     THRU 2560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                  MOVE  41  TO A-RETURN-CODE (LN-SUB)
                  GO TO 2550-CALC-STANDARD-EXIT
                 END-IF
                END-IF.

             IF H-LITEM-PYMT > 0
              IF L-SERVICE-FROM-DATE >= 20040101
               IF OPPS-APC (LN-SUB) = ('1716' OR '1717' OR
                  '1718' OR '1719' OR '1720' OR '2616' OR '2633')
                  COMPUTE H-LITEM-REIM ROUNDED =
                  ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                     H-LN-BLOOD-DEDUCT) * .8
                  COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                  H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                  MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN
               ELSE
                  COMPUTE H-LITEM-REIM ROUNDED =
                  ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                     H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX)
                  COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                  H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                  MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN
              ELSE
                 COMPUTE H-LITEM-REIM ROUNDED =
                 ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                    H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX)
                 COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                 H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                 MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN
             ELSE
              NEXT SENTENCE.

             IF H-MIN-COIN > 0
               IF OPPS-SRVC-IND (LN-SUB) = ' G' OR
                                           ' H' OR ' J' OR ' K'
                 COMPUTE H-MIN-COIN ROUNDED = H-MIN-COIN *
                 (W-SRVC-UNITS (W-LP-INDX) -
                    (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION))
                   * W-DISC-RATE (W-LP-INDX)
               ELSE
                 IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                   COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25
                 ELSE
                   COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                 END-IF
               END-IF
             END-IF.

             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.
             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                  MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                         (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                            (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       2550-CALC-STANDARD-EXIT.
           EXIT.

      ***************************************************************
      * 1. CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR        *
      *    TYPES G , J , OR K.                                      *
      * 2. EFFECTIVE 01/01/2003 REMOVE PRO RATA REDUCTION FOR       *
      *       ALL SERVICE INDICATOR 'G' PAYMENTS                    *
      ***************************************************************

       2550-CALC-GJK.

             IF OPPS-HCPCS(LN-SUB) = 'P9021' OR 'P9010' OR 'P9038'
                      OR 'P9016' OR 'C1010' OR 'C1018' OR 'P9022'
                      OR 'P9039' OR 'P9040' OR 'C1016' OR 'C1021'
                      OR 'C1020' OR 'P9051' OR 'P9054' OR 'P9056'
                      OR 'P9057' OR 'P9058'
               PERFORM 2550-SET-BLOOD-FRACTION
                  THRU 2550-SET-BLOOD-FRACTION-EXIT
             ELSE
               COMPUTE H-LITEM-PYMT ROUNDED =
               W-APC-PYMT (W-LP-INDX) * W-SRVC-UNITS (W-LP-INDX)
                      * W-DISC-RATE (W-LP-INDX)
               GO TO 2550-CALC-GJK-EXIT.


             COMPUTE H-LITEM-PYMT ROUNDED =
             W-BD-APC-PYMT (W-BD-INDX) * W-BD-SRVC-UNITS (W-BD-INDX)
                      * W-BD-DISC-RATE (W-BD-INDX).

             COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                 H-LITEM-PYMT * H-BLOOD-FRACTION.

             SET W-BD-INDX UP BY 1.

       2550-CALC-GJK-EXIT.
           EXIT.

       2550-SET-BLOOD-FRACTION.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.
              IF H-BENE-PINTS-USED > 0
                IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                   MOVE 1 TO H-BLOOD-FRACTION
                   COMPUTE H-BENE-PINTS-USED =
                     H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)
                ELSE
                  IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                    COMPUTE H-BLOOD-FRACTION =
                      H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                    MOVE 0 TO H-BENE-PINTS-USED
                  ELSE
                     MOVE 0 TO H-BLOOD-FRACTION
              ELSE
                 MOVE 0 TO H-BLOOD-FRACTION.

       2550-SET-BLOOD-FRACTION-EXIT.
           EXIT.

      ***************************************************************
      * 1. CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR        *
      *    TYPE  H.                                                 *
      * 2. EFFECTIVE 04/01/2002 A PRO RATA REDUCTION APPLIES TO     *
      *       ALL SERVICE INDICATOR 'H' PAYMENTS (CURRENTLY .689)   *
      ***************************************************************

       2555-CALC-H-TOT.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.
             IF OPPS-SRVC-IND (LN-SUB) = ' H'
               IF OPPS-PYMT-IND (LN-SUB) = ' 6'
                  COMPUTE H-TOT-H-CHRG =
                     (H-TOT-H-CHRG + H-SUB-CHRG)
               ELSE
                  NEXT SENTENCE
             ELSE
                NEXT SENTENCE.

       2555-CALC-H-TOT-EXIT.
           EXIT.

       2555-CALC-H-STANDARD.

             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

             COMPUTE T-LITEM-PYMT ROUNDED =
               (H-SUB-CHRG * L-PSF-OPCOST-RATIO).

              IF (C-FLAG = 'Y')
                 IF (H-TOT-OFF-UNITS > H-TOT-HTD-UNITS)
                   COMPUTE H-TOTAL-WAOFF ROUNDED =
                     (((H-TOTAL-OFFSET * .60) * A-WINX)
                      + (H-TOTAL-OFFSET * .40))
                      * (H-TOT-HTD-UNITS / H-TOT-OFF-UNITS)
                   PERFORM 2700-CALC-H-OFFSET
                      THRU 2700-CALC-H-OFFSET-EXIT
                 ELSE
                    COMPUTE H-TOTAL-WAOFF ROUNDED =
                      ((H-TOTAL-OFFSET * .60) * A-WINX)
                       + (H-TOTAL-OFFSET * .40)
                    PERFORM 2700-CALC-H-OFFSET
                       THRU 2700-CALC-H-OFFSET-EXIT
              ELSE
                 NEXT SENTENCE.

                IF T-LITEM-PYMT < 0 THEN
                   MOVE 0 TO H-LITEM-PYMT
                ELSE
                   MOVE T-LITEM-PYMT TO H-LITEM-PYMT.


       2555-CALC-H-STANDARD-EXIT.
           EXIT.

       2560-CALC-BENE-DEDUCT.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 4'
                GO TO 2560-CALC-BENE-DEDUCT-EXIT.
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                  H-LITEM-PYMT - H-LN-BLOOD-DEDUCT
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                      H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       2560-CALC-BENE-DEDUCT-EXIT.
             EXIT.

      *********************************************************************
      ** - NEW FOR JANUARY 2004                                          **
      **   - CHECK >= 20040101 AND SRVC-IND = 'K'                        **
      **      - DISCONTINUE OUTLIER PROCESS                              **
      *********************************************************************
       2600-ADJ-CHRG-OUTL.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.
      *      IF ((L-SERVICE-FROM-DATE > 20031231) AND
      *         (L-SERVICE-FROM-DATE < 20040401)) AND
      *         (OPPS-SRVC-IND (LN-SUB) = ' K')
      *         GO TO 2600-ADJ-CHRG-OUTL-EXIT.
      *********************************************************************
      ** - NEW FOR APRIL 2004                                            **
      **   - CHECK >= 20040101 AND SRVC-IND = 'K'                        **
      **      - CONTINUE OUTLIER PROCESS FOR SPECIFIED APCS              **
      *********************************************************************
             IF L-SERVICE-FROM-DATE >= 20040101
               IF OPPS-SRVC-IND (LN-SUB) = ' K'
                 IF (OPPS-APC (LN-SUB)  = '0702' OR '0704' OR
                 '0705' OR '0737' OR '1045' OR '1064' OR '1065' OR
                 '1079' OR '1080' OR '1081' OR '1089' OR '1091' OR
                 '1092' OR '1095' OR '1096' OR '1122' OR '1200' OR
                 '1201' OR '1600' OR '1603' OR '1604' OR '1619' OR
                 '1620' OR '1622' OR '1624' OR '1625' OR '1628' OR
                 '1775' OR '9013' OR '9025' OR '9100' OR '9117' OR
                 '9118' OR '9400' OR '9402' OR '9403' OR '9404' OR
                 '9405' OR '9408' OR '9434' OR '0701')
                  NEXT SENTENCE
                 ELSE
                  GO TO 2600-ADJ-CHRG-OUTL-EXIT
               ELSE
                NEXT SENTENCE
             ELSE
                NEXT SENTENCE.

             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR
                                         ' H' OR ' N'
                GO TO 2600-ADJ-CHRG-OUTL-EXIT.

      *****************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY              *
      *****************************************************
             IF (ST0-FLAG = 'Y') AND ((OPPS-SRVC-IND (LN-SUB)
                 = ' T' ) OR ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                             (OPPS-HCPCS (LN-SUB) > '09999' AND
                              OPPS-HCPCS (LN-SUB) < '70000')))
                   AND (H-TOT-ST-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND
                ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                  ' X' OR ' P')
                   AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3'))
                   AND (H-TOT-STVX-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                   (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)
                COMPUTE H-SUB-CHRG ROUNDED =
                     (H-CHRG-RATE * H-TOT-N-CHRG)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.

              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND
                ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                  ' X' OR ' P')
                  AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3'))
                  AND (H-TOT-STVX-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                     (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)
                COMPUTE H-SUB-CHRG ROUNDED =
                     (H-CHRG-RATE * H-TOT-N-CHRG)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.
      *********************************************************************
      ** - NEW FOR JANUARY 2004                                          **
      **   - CHECK >= 20040101 AND PROVIDER RANGE FOR CMHC               **
      **   - COMPUTE H-LITEM-OUTL-PYMT USING NEW FORMULA                 **
      *********************************************************************

             IF L-SERVICE-FROM-DATE >= 20040101
                MOVE 2.6 TO H-OUTLIER-FACTOR
                MOVE .50 TO H-OUTLIER-PCT
               IF (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999')
                  MOVE 3.65 TO H-OUTLIER-FACTOR
               ELSE
                  NEXT SENTENCE
             ELSE
                MOVE 2.75 TO H-OUTLIER-FACTOR
                MOVE .45 TO H-OUTLIER-PCT.

             COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
                ((W-SUB-CHRG (W-LP-INDX) * L-PSF-OPCOST-RATIO) -
                 (H-OUTLIER-FACTOR * A-LITEM-PYMT (LN-SUB))) *
                  H-OUTLIER-PCT.

             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

             IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                       H-LITEM-OUTL-PYMT
               MOVE 0 TO H-LITEM-OUTL-PYMT.

       2600-ADJ-CHRG-OUTL-EXIT.
             EXIT.

      ***************************************************************
      * 1. RE-CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR     *
      *    TYPE H.                                                  *
      * 2. SUBTRACT WAGE ADJUSTED OFFSET AMOUNT FROM SI TYPE 'H'    *
      *    WITH HCPCS CODE BEGINNING WITH 'C'                       *
      * 2. EFFECTIVE 04/01/2002                                     *
      ***************************************************************

       2700-CALC-H-OFFSET.

             IF H-TOT-H-CHRG > 0
               COMPUTE H-OFF-RATE ROUNDED =
                    H-SUB-CHRG / H-TOT-H-CHRG
               COMPUTE T-LITEM-PYMT ROUNDED = T-LITEM-PYMT -
                      (H-TOTAL-WAOFF * H-OFF-RATE)
             ELSE
                NEXT SENTENCE.

       2700-CALC-H-OFFSET-EXIT.
           EXIT.

       2800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 2810-PROCESS-TYPE1
                   THRU 2810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 2840-PROCESS-TYPE2
                   THRU 2840-PROCESS-TYPE2-EXIT.

       2800-ADJ-STV-REIM-EXIT.
           EXIT.

       2810-PROCESS-TYPE1.

             IF  W-DCP-COIN2 (W-DCP-INDX) > 0
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-WGNAT (W-DCP-INDX) TO H-TOTAL
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-WGNAT (W-DCP-INDX)) /
                                  W-DCP-COIN2 (W-DCP-INDX)
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.
                IF H-RATIO > 1
                    MOVE 1 TO H-RATIO.

       2810-PROCESS-TYPE1-EXIT.
           EXIT.

       2840-PROCESS-TYPE2.

             IF W-DCP-DOS (W-DCP-INDX) >= 20010701
                IF W-DCP-DOS (W-DCP-INDX) =  H-DCP-DOS
                   MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB
                   COMPUTE H-SHIFT =
                       W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)
                   COMPUTE H-TOTAL =
                        A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT
                   IF H-TOTAL > H-IP-LIMIT
                      COMPUTE H-SHIFT = H-SHIFT + H-TOTAL
                            - H-IP-LIMIT
                   END-IF
                   COMPUTE A-ADJ-COIN (LN-SUB) =
                        A-ADJ-COIN (LN-SUB) - H-SHIFT
                   COMPUTE A-LITEM-REIM (LN-SUB) =
                      A-LITEM-REIM (LN-SUB) + H-SHIFT
                   MOVE 22 TO A-RETURN-CODE (LN-SUB)
                END-IF
             ELSE
                IF W-DCP-DOS (W-DCP-INDX) >= 20010101
                  IF W-DCP-COIN2 (W-DCP-INDX) > H-IP-LIMIT
                     MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB
                     COMPUTE H-SHIFT =
                         W-DCP-COIN2 (W-DCP-INDX) - H-IP-LIMIT
                     COMPUTE A-ADJ-COIN (LN-SUB) =
                          A-ADJ-COIN (LN-SUB) - H-SHIFT
                     COMPUTE A-LITEM-REIM (LN-SUB) =
                        A-LITEM-REIM (LN-SUB) + H-SHIFT
                     MOVE 22 TO A-RETURN-CODE (LN-SUB)
                  END-IF
                END-IF
             END-IF.

       2840-PROCESS-TYPE2-EXIT.
           EXIT.

      ***************************************************************
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      ***************************************************************
       2900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.
             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       2900-END-PRICE-RTN-EXIT.
           EXIT.

      ***************************************************************
      *    PROCESSING: AFTER 20041231                               *
      *    PROCESSING: AFTER 20021231                               *
      *        A. WILL PROCESS LINE ITEMS BASED ON OCE FLAGS.       *
      *        B. INITIALIZE OPPS   HOLD VARIABLES.                 *
      *        C. EDIT THE DATA PASSED FROM THE OCE.                *
      *        D. ASSEMBLE PRICING COMPONENTS.                      *
      *        E. CALCULATE THE PRICE.                              *
      *        F. RETURN COINSURANCE/REIMBURSEMENT/DEDUCTIBLE/      *
      *                  PAYMENT/OUTLIER AMOUNT/RETURN CODES        *
      ***************************************************************

       3000-PROCESS-MAIN-NEW.

              PERFORM 3100-INIT
                 THRU 3100-INIT-EXIT.

              IF H-WINX1 = 0 AND A-CLM-RTN-CODE = 01
                MOVE 51 TO A-CLM-RTN-CODE.

              IF A-CLM-RTN-CODE >= 50
                 GOBACK.
              MOVE H-WINX1 TO A-WINX.
              PERFORM 3125-INIT
                 THRU 3125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

              MOVE 0 TO W-DCP-MAX W-BLD-MAX.
              PERFORM 3150-INIT
                 THRU 3150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

              MOVE 0 TO W-DCP-MAX.
              PERFORM 3555-CALC-H-TOT
                 THRU 3555-CALC-H-TOT-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.

              SET W-BD-INDX TO 1.
              MOVE 0 TO W-DCP-MAX.
              PERFORM 3400-CALCULATE
                 THRU 3400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.

              PERFORM 3600-ADJ-CHRG-OUTL
                 THRU 3600-ADJ-CHRG-OUTL-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX


              IF GJK-FLAG = 'Y'
                PERFORM 3800-ADJ-STV-REIM
                   THRU 3800-ADJ-STV-REIM-EXIT
                      VARYING W-DCP-INDX FROM 1 BY 1
                        UNTIL W-DCP-INDX > W-DCP-MAX
              ELSE
                 NEXT SENTENCE.

              PERFORM 3900-END-PRICE-RTN
                 THRU 3900-END-PRICE-RTN-EXIT.

          3000-PROCESS-MAIN-NEW-EXIT.
              EXIT.

      ***************************************************************
      *    INITIALIZE WORKING STORAGE HOLD AREAS                    *
      *    AND ADDITIONAL VARIABLES TO BE PASSED BACK TO            *
      *    THE STANDARD SYSTEM.                                     *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      ***************************************************************
       3100-INIT.

             MOVE 01 TO A-CLM-RTN-CODE.
             MOVE 'N' TO APC33-FLAG GJK-FLAG ST0-FLAG
                         N-FLAG C-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO TO A-OUTLIER-PYMT
                          A-TOTAL-CLM-DEDUCT
                          A-TOT-CLM-CHRG
                          A-TOT-CLM-PYMT
                          A-BLOOD-DEDUCT-DUE
                          A-BLOOD-PINTS-USED
                          A-WINX
                          W-LNC-MAX.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 3100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                   MOVE 54 TO A-CLM-RTN-CODE
                   GO TO 3100-INIT-EXIT
                ELSE
                   IF L-PSF-TERMDT > 0
                      IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                         MOVE 54 TO A-CLM-RTN-CODE
                         GO TO 3100-INIT-EXIT
                      END-IF
                   END-IF.
             MOVE CAL-VERSION4 TO A-CALC-VERS.
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.
             IF L-PSF-SPEC-PYMT-IND = 'Y'
                MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
             ELSE
                IF L-PSF-SPEC-PYMT-IND = ' '
                   MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA
                ELSE
                   IF L-PSF-SPEC-PYMT-IND = '1' OR '2'
                      MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA A-CBSA
                      MOVE L-PSF-SPEC-WGIDX TO H-WINX1
                      MOVE 912 TO H-IP-LIMIT
                      GO TO 3100-INIT-EXIT
                   ELSE
                      MOVE  52  TO A-CLM-RTN-CODE
                      GO TO 3100-INIT-EXIT.

             IF H-PSF-CBSA = SPACE
                MOVE  52  TO A-CLM-RTN-CODE
                GO TO 3100-INIT-EXIT.

             MOVE 912 TO H-IP-LIMIT.

             PERFORM 3120-FLOOR-2005
                THRU 3120-FLOOR-2005-EXIT.
             IF L-SERVICE-FROM-DATE < 20050401
                PERFORM 3120-SEC401-2005
                   THRU 3120-SEC401-2005-EXIT
             ELSE
                PERFORM 3120-SEC401-2005-APR
                   THRU 3120-SEC401-2005-APR-EXIT.

             MOVE H-PSF-CBSA TO A-CBSA.

             IF H-WINX1 = 0
                PERFORM 3200-CALC-WAGEINDX
                   THRU 3200-CALC-WAGEINDX-EXIT.

       3100-INIT-EXIT.
           EXIT.

000100*************************************************************           02
000200** NEW 2005 FLOOR AND SEC 401 FOR CBSA                    ***           02
000300*************************************************************           02
260700 3120-FLOOR-2005.                                                       02
260800                                                                        00
260900        IF H-PSF-CBSA = '10900'                                         00
261000           AND L-PSF-PROV-ST = '31'                                     00
261100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
261200               MOVE '   31' TO H-PSF-CBSA.                              00
261300                                                                        00
261400        IF H-PSF-CBSA = '16620'                                         00
261500           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
261600           AND L-PSF-PROV-ST = '36'                                     00
261700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
261800               MOVE '   36' TO H-PSF-CBSA.                              00
262500                                                                        00
262600        IF H-PSF-CBSA = '19060'                                         00
262700           AND L-PSF-PROV-ST = '21'                                     00
262800               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
262900               MOVE '   21' TO H-PSF-CBSA.                              00
263500                                                                        00
263600        IF H-PSF-CBSA = '21780'                                         00
263700           AND L-PSF-PROV-ST = '15'                                     00
263800               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
263900               MOVE '   15' TO H-PSF-CBSA.                              00
264500                                                                        00
264600        IF H-PSF-CBSA = '22020'                                         00
264800           AND L-PSF-PROV-ST = '24'                                     00
264900               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
265000               MOVE '   24' TO H-PSF-CBSA.                              00
264500                                                                        00
264600        IF H-PSF-CBSA = '22020'                                         00
264700           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
264800           AND L-PSF-PROV-ST = '24'                                     00
264900               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
265000               MOVE '   24' TO H-PSF-CBSA.                              00
266300                                                                        00
266400        IF H-PSF-CBSA = '24220'                                         00
266500           AND L-PSF-PROV-ST = '24'                                     00
266600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
266700               MOVE '   24' TO H-PSF-CBSA.                              00
267300                                                                        00
267400        IF H-PSF-CBSA = '25540'                                         00
267500           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
267600           AND L-PSF-PROV-ST = '07'                                     00
267700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
267800               MOVE '   07' TO H-PSF-CBSA.                              00
267900                                                                        00
268000        IF H-PSF-CBSA = '29100'                                         00
268200           AND L-PSF-PROV-ST = '52'                                     00
268300               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
268400               MOVE '   52' TO H-PSF-CBSA.                              00
267900                                                                        00
268000        IF H-PSF-CBSA = '30300'                                         00
268200           AND L-PSF-PROV-ST = '50'                                     00
268300               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
268400               MOVE '   50' TO H-PSF-CBSA.                              00
269700                                                                        00
269800        IF H-PSF-CBSA = '37620'                                         00
269900           AND L-PSF-PROV-ST = '36'                                     00
270000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
270100               MOVE '   36' TO H-PSF-CBSA.                              00
270700                                                                        00
270800        IF H-PSF-CBSA = '48260'                                         00
270900           AND L-PSF-PROV-ST = '36'                                     00
271000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
271100               MOVE '   36' TO H-PSF-CBSA.                              00
271700                                                                        00
271800        IF H-PSF-CBSA = '48540'                                         00
271900           AND L-PSF-PROV-ST = '36'                                     00
272000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
272100               MOVE '   36' TO H-PSF-CBSA.                              00
273200                                                                        00
273300        IF H-PSF-CBSA = '48864'                                         00
273400           AND L-PSF-PROV-ST = '31'                                     00
273500               MOVE 'N' TO L-PSF-SPEC-PYMT-IND                          00
273600               MOVE '   31' TO H-PSF-CBSA.                              00
273700                                                                        00
273800        IF H-PSF-CBSA = '48864'                                         00
273900           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
274000           AND L-PSF-PROV-ST = '31'                                     00
274100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
274200               MOVE '   31' TO H-PSF-CBSA.                              00
274300                                                                        00
274300        IF H-PSF-CBSA = '39900'                                         00
274300           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
274300           AND L-PSF-PROV-ST = '05'                                     00
274300               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
274300               MOVE '   05' TO H-PSF-CBSA.                              00
274300                                                                        00
274400 3120-FLOOR-2005-EXIT.                                                  02
274500     EXIT.                                                              02
309400                                                                        00
309500 3120-SEC401-2005.                                                      02
309600*************************************************************           00
309700****    FOR CY 2005 SECTION 401 HOSPITALS                   *           02
309800*************************************************************           00
310900                                                                        00
309900     IF (L-PSF-PROV-OSCAR = '050192' OR                                 00
310000                            '050469' OR                                 00
310100                            '050528' OR                                 00
310200                            '050618' OR                                 00
310000                            '050286' OR                                 00
310100                            '050446' OR                                 00
310200                            '051301')                                   00
310300         MOVE '   05' TO H-PSF-CBSA.                                    02
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '070004')                                   00
310700         MOVE '   07' TO H-PSF-CBSA.                                    02
310900                                                                        00
311000     IF (L-PSF-PROV-OSCAR = '100048' OR                                 00
                                  '100118')
311100         MOVE '   10' TO H-PSF-CBSA.                                    02
311300                                                                        00
311400     IF (L-PSF-PROV-OSCAR = '170137')                                   00
311500         MOVE '   17' TO H-PSF-CBSA.                                    02
311700                                                                        00
311800     IF (L-PSF-PROV-OSCAR = '190048' OR                                 00
311800                            '190110')                                   00
311900         MOVE '   19' TO H-PSF-CBSA.                                    02
312100                                                                        00
312200     IF (L-PSF-PROV-OSCAR = '230078')                                   00
312300         MOVE '   23' TO H-PSF-CBSA.                                    02
312500                                                                        00
312600     IF (L-PSF-PROV-OSCAR = '260006')                                   00
312700         MOVE '   26' TO H-PSF-CBSA.                                    02
311700                                                                        00
311800     IF (L-PSF-PROV-OSCAR = '290038' OR                                 00
311800                            '291301')                                   00
311900         MOVE '   29' TO H-PSF-CBSA.                                    02
313300                                                                        00
313400     IF (L-PSF-PROV-OSCAR = '300009')                                   00
313500         MOVE '   30' TO H-PSF-CBSA.                                    02
313700                                                                        00
313800     IF (L-PSF-PROV-OSCAR = '380084')                                   00
313900         MOVE '   38' TO H-PSF-CBSA.                                    02
314100                                                                        00
314200     IF (L-PSF-PROV-OSCAR = '390106' OR                                 00
314200                            '390181')                                   00
314300         MOVE '   39' TO H-PSF-CBSA.                                    00
314500                                                                        00
314600 3120-SEC401-2005-EXIT.                                                 02
314610     EXIT.                                                              02
314500                                                                        00
314600 3120-SEC401-2005-APR.                                                  02
309600*************************************************************           00
309700****    FOR CY 2005 SECTION 401 HOSPITALS -EFF. 04/01/2005  *           02
309800*************************************************************           00
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '030007')                                   00
310700         MOVE '   03' TO H-PSF-CBSA.                                    02
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '040075')                                   00
310700         MOVE '   04' TO H-PSF-CBSA.                                    02
310900                                                                        00
309900     IF (L-PSF-PROV-OSCAR = '050192' OR                                 00
310000                            '050469' OR                                 00
310100                            '050528' OR                                 00
310200                            '050618')                                   00
310300         MOVE '   05' TO H-PSF-CBSA.                                    02
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '070004')                                   00
310700         MOVE '   07' TO H-PSF-CBSA.                                    02
310900                                                                        00
311000     IF (L-PSF-PROV-OSCAR = '100048' OR                                 00
                                  '100134')
311100         MOVE '   10' TO H-PSF-CBSA.                                    02
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '130018')                                   00
310700         MOVE '   13' TO H-PSF-CBSA.                                    02
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '140167')                                   00
310700         MOVE '   14' TO H-PSF-CBSA.                                    02
310900                                                                        00
311000     IF (L-PSF-PROV-OSCAR = '150051' OR                                 00
                                  '150078')
311100         MOVE '   15' TO H-PSF-CBSA.                                    02
311300                                                                        00
311400     IF (L-PSF-PROV-OSCAR = '170137')                                   00
311500         MOVE '   17' TO H-PSF-CBSA.                                    02
311700                                                                        00
311800     IF (L-PSF-PROV-OSCAR = '190048')                                   00
311900         MOVE '   19' TO H-PSF-CBSA.                                    02
312100                                                                        00
312200     IF (L-PSF-PROV-OSCAR = '230078')                                   00
312300         MOVE '   23' TO H-PSF-CBSA.                                    02
312100                                                                        00
312200     IF (L-PSF-PROV-OSCAR = '240037')                                   00
312300         MOVE '   24' TO H-PSF-CBSA.                                    02
312500                                                                        00
312600     IF (L-PSF-PROV-OSCAR = '260006' OR                                 00
                                  '260122')
312700         MOVE '   26' TO H-PSF-CBSA.                                    02
313300                                                                        00
313400     IF (L-PSF-PROV-OSCAR = '300009')                                   00
313500         MOVE '   30' TO H-PSF-CBSA.                                    02
313300                                                                        00
313400     IF (L-PSF-PROV-OSCAR = '370054')                                   00
313500         MOVE '   37' TO H-PSF-CBSA.                                    02
313700                                                                        00
313800     IF (L-PSF-PROV-OSCAR = '380040' OR                                 00
                                  '380084')
313900         MOVE '   38' TO H-PSF-CBSA.                                    02
314100                                                                        00
314200     IF (L-PSF-PROV-OSCAR = '390181' OR                                 00
314200                            '390183' OR                                 00
314200                            '390201')                                   00
314300         MOVE '   39' TO H-PSF-CBSA.                                    00
313300                                                                        00
313400     IF (L-PSF-PROV-OSCAR = '450052' OR                                 00
                                  '450078' OR
                                  '450243' OR
                                  '450276' OR
                                  '450348')
313500         MOVE '   45' TO H-PSF-CBSA.                                    02
314100                                                                        00
314200     IF (L-PSF-PROV-OSCAR = '500023' OR                                 00
314200                            '500037' OR                                 00
314200                            '500122' OR                                 00
314200                            '500147' OR                                 00
314200                            '500148')                                   00
314300         MOVE '   50' TO H-PSF-CBSA.                                    00
314500                                                                        00
314600 3120-SEC401-2005-APR-EXIT.                                             02
314610     EXIT.                                                              02
314620                                                                        02
      *************************************************************
      *  SET FLAG IF APC = 0033                                   *
      *    - TERMINATE PROCESS IF 0033 LOCATED                    *
      *                                                           *
      *************************************************************

       3125-INIT.

             IF OPPS-APC (LN-SUB) = '0033'
                MOVE 'Y' TO APC33-FLAG
                MOVE 451 TO LN-SUB.

       3125-INIT-EXIT.
           EXIT.

      ***************************************************************
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1, 2,OR 4)*
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0 OR 1 OR 2          *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM DENIAL/REJECT FLAG  = TO 1     *
      *                 AND (APC NOT = 0033 OR 0034 OR 0322 OR      *
      *                      0323 OR 0324 OR 0325 OR 0373 OR 0374)) *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0              *
      *               - OR (APC 0033 IS NOT ON THE CLAIM            *
      *                     AND SERVICE INDICATOR = 'P'             *
      *                     OR  APC = 0322-0325,0373,0374)          *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      ***************************************************************
       3150-INIT.

             MOVE  01  TO A-RETURN-CODE (LN-SUB).

      ***************************************************************
      * OVER-RIDE SERVICE UNITS FOR APC 0339 - EFFECTIVE 04/01/2002 *
      *   - CHANGE UNIT VALUE TO 1                                  *
      ***************************************************************

             IF OPPS-APC (LN-SUB) = '0339'
                  MOVE 1 TO OPPS-SRVC-UNITS (LN-SUB).

             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 3250-CALC-DISCOUNT
                THRU 3250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 3150-INIT-EXIT.

      ***************************************************************
      *  EFFECTIVE AS OF 04-01-2002                                 *
      *    - TOTAL DEVICE OFFSET                                    *
      ***************************************************************

             IF OPPS-SRVC-IND (LN-SUB) = ' H'
                MOVE 'Y' TO C-FLAG
                COMPUTE H-TOT-HTD-UNITS = H-TOT-HTD-UNITS
                        + H-SRVC-UNITS.

             PERFORM 3160-TOTAL-OFFSET
                THRU 3160-TOTAL-OFFSET-EXIT.

             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C'
              OR ' E' OR ' F' OR ' G' OR ' H' OR ' J' OR ' K' OR
              ' L' OR ' N' OR ' P' OR ' S' OR ' T' OR ' V' OR
              ' X' OR ' W' OR ' Y' OR ' Z' OR ' M') THEN
                MOVE  40  TO A-RETURN-CODE (LN-SUB)
                GO TO 3150-INIT-EXIT
              ELSE
                MOVE  01  TO A-RETURN-CODE (LN-SUB).

             IF OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR ' E'
                   OR ' F' OR ' L' OR ' W' OR ' Y' OR ' Z' OR ' M'
                MOVE  41  TO A-RETURN-CODE (LN-SUB)
                GO TO 3150-INIT-EXIT.

               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'
                 IF OPPS-PKG-FLAG (LN-SUB) = '0' OR '1' OR '2'
                                             OR '3' OR '4'
                   IF (OPPS-LITEM-DR-FLAG (LN-SUB) = '0' OR
                       OPPS-LITEM-DR-FLAG (LN-SUB) = '1' AND
                       (OPPS-APC (LN-SUB) = '0033' OR '0034'
                       OR '0322' OR '0323' OR '0324' OR '0325'
                       OR '0373' OR '0374')) OR
                      (OPPS-LITEM-ACT-FLAG (LN-SUB) = '1')
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                                           OR ' 2' OR ' 3' OR ' 4'
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR
                            ((APC33-FLAG = 'Y') AND
                             ((OPPS-SRVC-IND (LN-SUB) = ' P') OR
                             (OPPS-APC (LN-SUB) = '0322' OR '0323'
                              OR '0324' OR '0325' OR '0373'
                              OR '0374')))
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

                    IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                       COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                            H-SUB-CHRG
                    END-IF
                    IF (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                       COMPUTE H-TOT-N-CHRG = H-SUB-CHRG
                                  + H-TOT-N-CHRG
                       MOVE 'Y' TO N-FLAG
                    END-IF
                    IF (OPPS-APC (LN-SUB) = '0000') OR
                       (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                       MOVE 42 TO A-RETURN-CODE (LN-SUB)
                       GO TO 3150-INIT-EXIT
                    END-IF
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 3150-INIT-EXIT
                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2
                      PERFORM 3175-APC-LOOKUP
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 3150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 3150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 3150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 3150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 3150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 3150-INIT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 01
                PERFORM 3300-COIN-DEDUCT
                   THRU 3300-COIN-DEDUCT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 01
                SET WNBD-INDX TO 1
                SEARCH WNBD-ENTRY VARYING WNBD-INDX
                   AT END
                      GO TO 3150-INIT-EXIT
                WHEN W-NEW-BLOOD-HCPCS (WNBD-INDX) =
                                              OPPS-HCPCS (LN-SUB)
                   MOVE W-NEW-BLOOD-RANK (WNBD-INDX) TO H-BLOOD-RANK
                   PERFORM 3375-BLOOD-DEDUCT
                      THRU 3375-BLOOD-DEDUCT-EXIT.

       3150-INIT-EXIT.
           EXIT.

      ***************************************************************
      *  COMPUTE TOTAL OFFSET FROM TABLE 5 FOR DEVICES              *
      *      - EFFECTIVE AS OF 01-01-2003                           *
      *      - CONTINUE FOR   01-01-2004                            *
      *      - CONTINUE FOR   01-01-2005                            *
      *        - SEARCH TABLE OPPSOF04                              *
      *          - WHERE ALL OFFSET VALUES EQUAL ZERO               *
      ***************************************************************
       3160-TOTAL-OFFSET.

             MOVE OPPS-GRP (LN-SUB) TO W-OFF-APC.
             SEARCH ALL WOO-ENTRY3
                AT END
                   GO TO 3160-TOTAL-OFFSET-EXIT
                WHEN WOO-APC3 (WOO-INDX3) = W-OFF-APC
                   COMPUTE H-TOTAL-OFFSET = H-TOTAL-OFFSET
                      + (WOO-OFFSET3 (WOO-INDX3) * H-DISC-RATE
                          * H-SRVC-UNITS)
                   COMPUTE H-TOT-OFF-UNITS = H-TOT-OFF-UNITS
                      + H-SRVC-UNITS.

       3160-TOTAL-OFFSET-EXIT.
           EXIT.

      ***************************************************************
      *  SEARCH APC TABLE - MOVE VALUES TO HOLD AREA FOR PROCESSING *
      *      - ADJUST TOTAL CHARGE FOR DELETED APC'S                *
      ***************************************************************
       3175-APC-LOOKUP.

             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)
               IF WAR-RATEX (W-SUB2) = 'DELETED'
                 MOVE 30 TO A-RETURN-CODE (LN-SUB)
                 COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                      H-SUB-CHRG
               ELSE
                 MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                 MOVE WAR-RANK (W-SUB2) TO H-RANK
                 MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                 MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                 MOVE WAR-PPCT (W-SUB2) TO H-PPCT
             ELSE
                SUBTRACT 1 FROM W-SUB2
                IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                  GO TO 3175-APC-LOOKUP
                ELSE
                   MOVE 0 TO H-APC-PYMT
                             H-RANK
                             H-MIN-COIN
                             H-NAT-COIN
                             H-PPCT.

       3175-APC-LOOKUP-EXIT.
           EXIT.

      ***************************************************************
      *  IF DATE OF SERVICE BETWEEN 12/31/2002 AND 04/01/2003       *
      *    IF HCPCS CODE = C9114 OR C9115 ADJUST PAYMENT AND        *
      *    COINSURANCE AMOUNTS - LOGIC REMOVED FOR 20050101         *
      ***************************************************************

      ***************************************************************
      *    SEARCH WAGE INDEX TABLE AND SELECT THE WAGE INDEX        *
      *    WHEN EQUAL TO PROVIDER SPECIFIC WAGE INDEX               *
      *    IF WAGE INDEX NOT LOCATED                                *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      ***************************************************************
       3200-CALC-WAGEINDX.

             MOVE WCD-MAX TO WCD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WCD-DATE (WCD-SUB)
                 SUBTRACT 1 FROM WCD-SUB
             END-PERFORM.

             SEARCH ALL WCM-ENTRY
                AT END
                   MOVE  50  TO A-CLM-RTN-CODE
                   GO TO 3200-CALC-WAGEINDX-EXIT
                WHEN WCM-CBSA (WCM-INDX) = H-PSF-CBSA
                  MOVE WCM-PTR (WCM-INDX) TO W-SUB3
                  PERFORM 3210-WAGE-LOOKUP.

             IF H-WINX1 = 0 THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       3200-CALC-WAGEINDX-EXIT.
           EXIT.

       3210-WAGE-LOOKUP.

             IF WCW-DTCD (W-SUB3) NOT > WCD-DTCD (WCD-SUB)
                IF L-PSF-SPEC-PYMT-IND = 'Y'
                  MOVE WCW-WINX2 (W-SUB3) TO H-WINX1
                ELSE
                    MOVE WCW-WINX1 (W-SUB3) TO H-WINX1
             ELSE
                SUBTRACT 1 FROM W-SUB3
                IF W-SUB3 > WCM-PTR (WCM-INDX - 1)
                   GO TO 3210-WAGE-LOOKUP
                ELSE
                   MOVE 0 TO H-WINX1.

       3210-WAGE-LOOKUP-EXIT.
           EXIT.

      ***************************************************************
      *    CALCULATE DISCOUNT FACTOR BASED ON THE DISCOUNT          *
      *    INDICATOR PASSED BY THE OCE: VALUE 1 - 8                 *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      ***************************************************************
       3250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 3250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     MOVE  38  TO A-RETURN-CODE (LN-SUB).

       3250-CALC-DISCOUNT-EXIT.
           EXIT.

      ***************************************************************
      *    DETERMINE THE DEDUCTIBLE SEQUENCE. DEDUCTIBLE WILL BE    *
      *    TAKEN FROM OPPS SERVICES FIRST, THEN FROM ANY OTHER      *
      *    TYPES OF SERVICES FROM THE CLAIM.                        *
      *       - SET POINTERS TO THE HIGHEST RANKED PERCENTAGE       *
      *         (LARGEST NATIONAL UNADJUSTED COINSURANCE /          *
      *          THE APC PAYMENT)                                   *
      *       - MOVE ALL PRICING VARIABLES TO STAGING AREA          *
      ***************************************************************
       3300-COIN-DEDUCT.

             ADD 1 TO W-LNC-MAX.
             SET W-LP-INDX TO W-LNC-MAX.
             PERFORM 3350-STAGE-ENTRY
                THRU 3350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).
             MOVE LN-SUB TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX1    TO W-WINX1 (W-LP-INDX).
             MOVE H-RANK     TO W-RANK (W-LP-INDX).
             MOVE H-PPCT     TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
              UNTIL PS-SUB > L-PSF-APC-LINE-CNT
              IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS * H-DISC-RATE
                MOVE 25 TO A-RETURN-CODE (LN-SUB)
                MOVE L-PSF-APC-LINE-CNT TO PS-SUB
              END-IF
             END-PERFORM.

       3300-COIN-DEDUCT-EXIT.
           EXIT.

       3350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       3350-STAGE-ENTRY-EXIT.
           EXIT.

      ***************************************************************
      *    DETERMINE THE BLOOD DEDUCTIBLE SEQUENCE. DEDUCTIBLE      *
      *    WILL BE CALCULATED BASED ON RANKING.                     *
      *       - SET POINTERS TO THE HIGHEST RANKED APC              *
      *         (SMALLEST UNADJUSTED APC PAYMENT)                   *
      *       - MOVE ALL PRICING VARIABLES TO STAGING AREA          *
      ***************************************************************
       3375-BLOOD-DEDUCT.

             ADD 1 TO W-BLD-MAX.
             SET W-BD-INDX TO W-BLD-MAX.
             PERFORM 3385-STAGE-ENTRY
                THRU 3385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLOOD-RANK NOT < W-BD-RANK (W-BD-INDX - 1).
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX1    TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK TO W-BD-RANK (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).

             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
              UNTIL PS-SUB > L-PSF-APC-LINE-CNT
              IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS * H-DISC-RATE
                MOVE 25 TO A-RETURN-CODE (LN-SUB)
                MOVE L-PSF-APC-LINE-CNT TO PS-SUB
              END-IF
             END-PERFORM.

       3375-BLOOD-DEDUCT-EXIT.
           EXIT.

       3385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       3385-STAGE-ENTRY-EXIT.
           EXIT.

      ***************************************************************
      *    FIRST STEP IN DETERMINING A LINE ITEM PRICE.             *
      *    CHECK ALL APPROPRIATE FLAGS AND INDICATORS PASSED        *
      *    BY THE OCE.                                              *
      *      - SET RETURN CODES TO INDICATE ERRORS OR STATUS        *
      *        - '20' - LINE PROCESSED BUT PAYMENT = 0              *
      *                 - BENE DEDUCTIBLE => ADJUSTED PAYMENT       *
      *                                                             *
      ***************************************************************
       3400-CALCULATE.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 3400-CALCULATE-EXIT.

             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 3550-CALC-STANDARD
                   THRU 3550-CALC-STANDARD-EXIT
             ELSE
                GO TO 3400-CALCULATE-EXIT.

      ***************************************************************
      *  SET GJK FLAG                                               *
      *    - TEST LINE ITEM DATE OF SERVICE > 20010630              *
      *    - TOTAL DRUG / DEVICE COINSURANCE                        *
      ***************************************************************

             IF (A-RETURN-CODE (LN-SUB) <  30)
               PERFORM 3450-ADJ-PROC-COIN
                  THRU 3450-ADJ-PROC-COIN-EXIT
             ELSE
               NEXT SENTENCE.

      ***************************************************************
      *  SET ST0 AND STVX FLAGS                                     *
      *    - TEST LINE ITEM DATE OF SERVICE > 20020331              *
      *    - TOTAL PROCEDURE CHARGES AND BUNDLED CHARGES            *
      ***************************************************************

             PERFORM 3500-ADJ-CHRGS
                THRU 3500-ADJ-CHRGS-EXIT.

             IF A-RETURN-CODE (LN-SUB) <  30
               COMPUTE A-TOTAL-CLM-DEDUCT =
                       H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT
               COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT
               COMPUTE A-BLOOD-DEDUCT-DUE =
                     A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT
               MOVE H-LITEM-PYMT TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN TO A-RED-COIN (LN-SUB)
               IF H-RED-COIN > H-NAT-COIN
                 MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF
               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.
             MOVE ZERO TO LINE-HOLD-ITEMS.

       3400-CALCULATE-EXIT.
           EXIT.

      ***************************************************************
      *  SET GJK FLAG                                               *
      *    - STAGE BY SERVICE INDICATOR                             *
      *                                                             *
      ***************************************************************
       3450-ADJ-PROC-COIN.

             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX1 (W-LP-INDX) + .4)
                  IF H-NEW-WGNAT > H-IP-LIMIT
                    MOVE H-IP-LIMIT TO H-NEW-WGNAT
                  END-IF
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                MOVE 1 TO H-DCP-CODE
                PERFORM 3455-SEARCH-KEY
                   THRU 3455-SEARCH-KEY-EXIT
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR ' K'
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                        H-TOTAL-LN-DEDUCT - H-LITEM-REIM
                                   - H-LN-BLOOD-DEDUCT
                   MOVE 'Y' TO GJK-FLAG
                   MOVE 1 TO H-DCP-CODE
                   PERFORM 3455-SEARCH-KEY
                      THRU 3455-SEARCH-KEY-EXIT
                   MOVE 2 TO H-DCP-CODE
                   ADD 1 TO W-DCP-MAX
                   SET W-DCP-INDX TO W-DCP-MAX
                   PERFORM 3475-STAGE-DCP-ENTRY
                     THRU 3475-STAGE-DCP-ENTRY-EXIT
                       UNTIL W-DCP-INDX = 1 OR
                       H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       3450-ADJ-PROC-COIN-EXIT.
           EXIT.

       3455-SEARCH-KEY.

             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX
                AT END
                   PERFORM 3460-ADD-ENTRY
                      THRU 3460-ADD-ENTRY-EXIT
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 3465-UPDATE-ENTRY
                      THRU 3465-UPDATE-ENTRY-EXIT.

       3455-SEARCH-KEY-EXIT.
           EXIT.

       3460-ADD-ENTRY.

             ADD 1 TO W-DCP-MAX.
             SET W-DCP-INDX TO W-DCP-MAX.
             PERFORM 3475-STAGE-DCP-ENTRY
               THRU 3475-STAGE-DCP-ENTRY-EXIT
                UNTIL W-DCP-INDX = 1 OR
                  H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR ' K'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       3460-ADD-ENTRY-EXIT.
           EXIT.

       3465-UPDATE-ENTRY.

             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR ' K'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 3485-REPLACE-TYPE1
                     THRU 3485-REPLACE-TYPE1-EXIT
               ELSE
                  PERFORM 3480-RANK-COIN
                     THRU 3480-RANK-COIN-EXIT.

       3465-UPDATE-ENTRY-EXIT.
           EXIT.

       3475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       3475-STAGE-DCP-ENTRY-EXIT.
           EXIT.

       3480-RANK-COIN.

             IF H-NEW-WGNAT > W-DCP-WGNAT (W-DCP-INDX)
               MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
               MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
               MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
               MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       3480-RANK-COIN-EXIT.
           EXIT.

       3485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       3485-REPLACE-TYPE1-EXIT.
           EXIT.

       3500-ADJ-CHRGS.

      *****************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY              *
      *****************************************************
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                 OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                MOVE 'Y' TO ST0-FLAG.

             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                 OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX)
                               + H-TOT-ST-CHRG
                COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT
                               + H-TOT-ST-PYMT.

             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                OR ' X' OR ' P')
                AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT
                               + H-TOT-STVX-PYMT.

       3500-ADJ-CHRGS-EXIT.
             EXIT.
      ***************************************************************
      * 1. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *     - DESCENDING UNTIL DEDUCTIBLE = 0.                      *
      * 2. CALCULATE THE STANDARD LINE PRICE                        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS                *
      *          * DISCOUNT FACTOR)                                 *
      *     - WAGE ADJUST 60% OF THE APC PAYMENT ONLY               *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA.                     *
      *                                                             *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *       AND DRUGS                                             *
      ***************************************************************
       3550-CALC-STANDARD.

             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' V'
                        OR ' T' OR ' P' OR ' X' THEN
                COMPUTE H-LITEM-PYMT ROUNDED =
                    (((W-APC-PYMT (W-LP-INDX) * .60) *
                            W-WINX1 (W-LP-INDX))
                                + (W-APC-PYMT (W-LP-INDX) * .40)) *
                  W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)
                  PERFORM 3560-CALC-BENE-DEDUCT
                     THRU 3560-CALC-BENE-DEDUCT-EXIT
             ELSE
               IF OPPS-SRVC-IND (LN-SUB) = ' H' THEN
                 IF OPPS-PYMT-IND (LN-SUB) = ' 6' THEN
                   PERFORM 3555-CALC-H-STANDARD
                      THRU 3555-CALC-H-STANDARD-EXIT
                   PERFORM 3560-CALC-BENE-DEDUCT
                      THRU 3560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 3550-CALC-STANDARD-EXIT
                 END-IF
               ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' G' OR
                                            ' J' OR ' K' THEN
                 IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR
                                             ' 5' OR ' 7' THEN
                  MOVE 0 TO H-BLOOD-FRACTION
                  PERFORM 3550-CALC-GJK
                     THRU 3550-CALC-GJK-EXIT
                  PERFORM 3560-CALC-BENE-DEDUCT
                     THRU 3560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                  MOVE  41  TO A-RETURN-CODE (LN-SUB)
                  GO TO 3550-CALC-STANDARD-EXIT
                 END-IF
                END-IF.

             IF H-LITEM-PYMT > 0
               IF OPPS-APC (LN-SUB) = ('1716' OR '1717' OR
                  '1718' OR '1719' OR '1720' OR '2616' OR '2632'
                  OR '2633' OR '2634' OR '2635' OR '2636')
                  COMPUTE H-LITEM-REIM ROUNDED =
                  ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                     H-LN-BLOOD-DEDUCT) * .8
                  COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                  H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                  MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN
               ELSE
                  COMPUTE H-LITEM-REIM ROUNDED =
                  ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                     H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX)
                  COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                  H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                  MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN
             ELSE
              NEXT SENTENCE.

             IF H-MIN-COIN > 0
               IF OPPS-SRVC-IND (LN-SUB) = ' G' OR
                                           ' H' OR ' J' OR ' K'
                 COMPUTE H-MIN-COIN ROUNDED = H-MIN-COIN *
                 (W-SRVC-UNITS (W-LP-INDX) -
                    (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION))
                   * W-DISC-RATE (W-LP-INDX)
               ELSE
                 IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                   COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25
                 ELSE
                   COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                 END-IF
               END-IF
             END-IF.

             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.
             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                  MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                         (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                            (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       3550-CALC-STANDARD-EXIT.
           EXIT.

      ***************************************************************
      * 1. CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR        *
      *    TYPES G , J , OR K.                                      *
      * 2. EFFECTIVE 01/01/2003 REMOVE PRO RATA REDUCTION FOR       *
      *       ALL SERVICE INDICATOR 'G' PAYMENTS                    *
      ***************************************************************

       3550-CALC-GJK.

             IF OPPS-HCPCS (LN-SUB) = 'P9010' OR 'P9016' OR 'P9021'
                      OR 'P9022' OR 'P9038' OR 'P9039' OR 'P9040'
                      OR 'P9051' OR 'P9054' OR 'P9056' OR 'P9057'
                      OR 'P9058'
               PERFORM 3550-SET-BLOOD-FRACTION
                  THRU 3550-SET-BLOOD-FRACTION-EXIT
             ELSE
               COMPUTE H-LITEM-PYMT ROUNDED =
               W-APC-PYMT (W-LP-INDX) * W-SRVC-UNITS (W-LP-INDX)
                      * W-DISC-RATE (W-LP-INDX)
               GO TO 3550-CALC-GJK-EXIT.


             COMPUTE H-LITEM-PYMT ROUNDED =
             W-BD-APC-PYMT (W-BD-INDX) * W-BD-SRVC-UNITS (W-BD-INDX)
                      * W-BD-DISC-RATE (W-BD-INDX).

             COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                 H-LITEM-PYMT * H-BLOOD-FRACTION.

             SET W-BD-INDX UP BY 1.

       3550-CALC-GJK-EXIT.
           EXIT.

       3550-SET-BLOOD-FRACTION.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.
              IF H-BENE-PINTS-USED > 0
                IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                   MOVE 1 TO H-BLOOD-FRACTION
                   COMPUTE H-BENE-PINTS-USED =
                     H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)
                ELSE
                  IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                    COMPUTE H-BLOOD-FRACTION =
                      H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                    MOVE 0 TO H-BENE-PINTS-USED
                  ELSE
                     MOVE 0 TO H-BLOOD-FRACTION
              ELSE
                 MOVE 0 TO H-BLOOD-FRACTION.

       3550-SET-BLOOD-FRACTION-EXIT.
           EXIT.

      ***************************************************************
      * 1. CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR        *
      *    TYPE  H.                                                 *
      * 2. EFFECTIVE 04/01/2002 A PRO RATA REDUCTION APPLIES TO     *
      *       ALL SERVICE INDICATOR 'H' PAYMENTS (CURRENTLY .689)   *
      ***************************************************************

       3555-CALC-H-TOT.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.
             IF OPPS-SRVC-IND (LN-SUB) = ' H'
               IF OPPS-PYMT-IND (LN-SUB) = ' 6'
                  COMPUTE H-TOT-H-CHRG =
                     (H-TOT-H-CHRG + H-SUB-CHRG)
               ELSE
                  NEXT SENTENCE
             ELSE
                NEXT SENTENCE.

       3555-CALC-H-TOT-EXIT.
           EXIT.

       3555-CALC-H-STANDARD.

             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

             COMPUTE T-LITEM-PYMT ROUNDED =
               (H-SUB-CHRG * L-PSF-OPCOST-RATIO).

              IF (C-FLAG = 'Y')
                 IF (H-TOT-OFF-UNITS > H-TOT-HTD-UNITS)
                   COMPUTE H-TOTAL-WAOFF ROUNDED =
                     (((H-TOTAL-OFFSET * .60) * A-WINX)
                      + (H-TOTAL-OFFSET * .40))
                      * (H-TOT-HTD-UNITS / H-TOT-OFF-UNITS)
                   PERFORM 3700-CALC-H-OFFSET
                      THRU 3700-CALC-H-OFFSET-EXIT
                 ELSE
                    COMPUTE H-TOTAL-WAOFF ROUNDED =
                      ((H-TOTAL-OFFSET * .60) * A-WINX)
                       + (H-TOTAL-OFFSET * .40)
                    PERFORM 3700-CALC-H-OFFSET
                       THRU 3700-CALC-H-OFFSET-EXIT
              ELSE
                 NEXT SENTENCE.

                IF T-LITEM-PYMT < 0 THEN
                   MOVE 0 TO H-LITEM-PYMT
                ELSE
                   MOVE T-LITEM-PYMT TO H-LITEM-PYMT.


       3555-CALC-H-STANDARD-EXIT.
           EXIT.

       3560-CALC-BENE-DEDUCT.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 4'
                GO TO 3560-CALC-BENE-DEDUCT-EXIT.
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                  H-LITEM-PYMT - H-LN-BLOOD-DEDUCT
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                      H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       3560-CALC-BENE-DEDUCT-EXIT.
           EXIT.

      *********************************************************************
      ** - NEW FOR JANUARY 2004                                          **
      **   - CHECK >= 20040101 AND SRVC-IND = 'K'                        **
      **      - DISCONTINUE OUTLIER PROCESS                              **
      *********************************************************************
       3600-ADJ-CHRG-OUTL.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *********************************************************************
      ** - NEW FOR JANUARY 2005                                          **
      **   - TURN OFF OUTLIER PROCESS FOR SPECIFIED K TYPE APCS          **
      **                                                                 **
      *********************************************************************

             IF (OPPS-SRVC-IND (LN-SUB) = ' G' OR ' J' OR ' K' OR
                 ' H' OR ' N') OR (OPPS-PKG-FLAG (LN-SUB) = '4')
                GO TO 3600-ADJ-CHRG-OUTL-EXIT.

      *****************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY              *
      *****************************************************
             IF (ST0-FLAG = 'Y') AND ((OPPS-SRVC-IND (LN-SUB)
                 = ' T' ) OR ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                             (OPPS-HCPCS (LN-SUB) > '09999' AND
                              OPPS-HCPCS (LN-SUB) < '70000')))
                   AND (H-TOT-ST-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND
                ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                  ' X' OR ' P')
                   AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3'))
                   AND (H-TOT-STVX-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                   (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)
                COMPUTE H-SUB-CHRG ROUNDED =
                     (H-CHRG-RATE * H-TOT-N-CHRG)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.

              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND
                ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                  ' X' OR ' P')
                  AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3'))
                  AND (H-TOT-STVX-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                     (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)
                COMPUTE H-SUB-CHRG ROUNDED =
                     (H-CHRG-RATE * H-TOT-N-CHRG)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.
      *********************************************************************
      ** - NEW FOR JANUARY 2005                                          **
      **   - PROVIDER RANGE FOR CMHC                                     **
      **   - COMPUTE H-LITEM-OUTL-PYMT USING NEW FORMULA                 **
      *********************************************************************

               MOVE 1.75 TO H-OUTLIER-FACTOR.
               MOVE .50 TO H-OUTLIER-PCT.
               COMPUTE H-COST ROUNDED =
                  W-SUB-CHRG (W-LP-INDX) * L-PSF-OPCOST-RATIO.
               COMPUTE H-APC-ADJ-PYMT ROUNDED =
                  H-OUTLIER-FACTOR * A-LITEM-PYMT (LN-SUB).
               IF (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999')
                  MOVE 3.5 TO H-OUTLIER-FACTOR
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED = (H-COST -
                    (H-OUTLIER-FACTOR * A-LITEM-PYMT (LN-SUB))) *
                     H-OUTLIER-PCT
               ELSE
                IF (H-COST > H-APC-ADJ-PYMT) AND
                   (H-COST > A-LITEM-PYMT (LN-SUB) + 1175)
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
                    (H-COST - H-APC-ADJ-PYMT) * H-OUTLIER-PCT
                ELSE
                   MOVE ZERO TO H-LITEM-OUTL-PYMT.

             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

             IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                       H-LITEM-OUTL-PYMT
               MOVE 0 TO H-LITEM-OUTL-PYMT.

       3600-ADJ-CHRG-OUTL-EXIT.
           EXIT.

      ***************************************************************
      * 1. RE-CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR     *
      *    TYPE H.                                                  *
      * 2. SUBTRACT WAGE ADJUSTED OFFSET AMOUNT FROM SI TYPE 'H'    *
      *    WITH HCPCS CODE BEGINNING WITH 'C'                       *
      * 2. EFFECTIVE 04/01/2002                                     *
      ***************************************************************

       3700-CALC-H-OFFSET.

             IF H-TOT-H-CHRG > 0
               COMPUTE H-OFF-RATE ROUNDED =
                    H-SUB-CHRG / H-TOT-H-CHRG
               COMPUTE T-LITEM-PYMT ROUNDED = T-LITEM-PYMT -
                      (H-TOTAL-WAOFF * H-OFF-RATE)
             ELSE
                NEXT SENTENCE.

       3700-CALC-H-OFFSET-EXIT.
           EXIT.

       3800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 3810-PROCESS-TYPE1
                   THRU 3810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 3840-PROCESS-TYPE2
                   THRU 3840-PROCESS-TYPE2-EXIT.

       3800-ADJ-STV-REIM-EXIT.
           EXIT.

       3810-PROCESS-TYPE1.

             IF  W-DCP-COIN2 (W-DCP-INDX) > 0
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-WGNAT (W-DCP-INDX) TO H-TOTAL
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-WGNAT (W-DCP-INDX)) /
                                  W-DCP-COIN2 (W-DCP-INDX)
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.
                IF H-RATIO > 1
                    MOVE 1 TO H-RATIO.

       3810-PROCESS-TYPE1-EXIT.
           EXIT.

       3840-PROCESS-TYPE2.

             IF W-DCP-DOS (W-DCP-INDX) =  H-DCP-DOS
                MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB
                COMPUTE H-SHIFT =
                    W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)
                COMPUTE H-TOTAL =
                     A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT
                IF H-TOTAL > H-IP-LIMIT
                   COMPUTE H-SHIFT = H-SHIFT + H-TOTAL
                         - H-IP-LIMIT
                END-IF
                COMPUTE A-ADJ-COIN (LN-SUB) =
                     A-ADJ-COIN (LN-SUB) - H-SHIFT
                COMPUTE A-LITEM-REIM (LN-SUB) =
                   A-LITEM-REIM (LN-SUB) + H-SHIFT
                   MOVE 22 TO A-RETURN-CODE (LN-SUB)
             END-IF.

       3840-PROCESS-TYPE2-EXIT.
           EXIT.

      ***************************************************************
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      ***************************************************************
       3900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.
             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       3900-END-PRICE-RTN-EXIT.
           EXIT.

      ***************************************************************
      *    PROCESSING: AFTER 20050701                               *
      *        A. WILL PROCESS LINE ITEMS BASED ON OCE FLAGS.       *
      *        B. INITIALIZE OPPS   HOLD VARIABLES.                 *
      *        C. EDIT THE DATA PASSED FROM THE OCE.                *
      *        D. ASSEMBLE PRICING COMPONENTS.                      *
      *        E. CALCULATE THE PRICE.                              *
      *        F. RETURN COINSURANCE/REIMBURSEMENT/DEDUCTIBLE/      *
      *                  PAYMENT/OUTLIER AMOUNT/RETURN CODES        *
      ***************************************************************

       4000-PROCESS-MAIN-NEW.

              PERFORM 4100-INIT
                 THRU 4100-INIT-EXIT.

              IF H-WINX1 = 0 AND A-CLM-RTN-CODE = 01
                MOVE 51 TO A-CLM-RTN-CODE.

              IF A-CLM-RTN-CODE >= 50
                 GOBACK.
              MOVE H-WINX1 TO A-WINX.
              PERFORM 4125-INIT
                 THRU 4125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

              MOVE 0 TO W-DCP-MAX W-BLD-MAX.
              PERFORM 4150-INIT
                 THRU 4150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

              IF H-TOT-38X-39X > 0
                 COMPUTE H-38X-39X-RATE ROUNDED =
                    H-TOT-38X / H-TOT-38X-39X.

              MOVE 0 TO W-DCP-MAX.
              PERFORM 4555-CALC-H-TOT
                 THRU 4555-CALC-H-TOT-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.

              SET W-BD-INDX TO 1.
              MOVE 0 TO W-DCP-MAX.
              PERFORM 4400-CALCULATE
                 THRU 4400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.

              PERFORM 4600-ADJ-CHRG-OUTL
                 THRU 4600-ADJ-CHRG-OUTL-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX


              IF GJK-FLAG = 'Y'
                PERFORM 4800-ADJ-STV-REIM
                   THRU 4800-ADJ-STV-REIM-EXIT
                      VARYING W-DCP-INDX FROM 1 BY 1
                        UNTIL W-DCP-INDX > W-DCP-MAX
              ELSE
                 NEXT SENTENCE.

              PERFORM 4900-END-PRICE-RTN
                 THRU 4900-END-PRICE-RTN-EXIT.

       4000-PROCESS-MAIN-NEW-EXIT.
           EXIT.

      ***************************************************************
      *    INITIALIZE WORKING STORAGE HOLD AREAS                    *
      *    AND ADDITIONAL VARIABLES TO BE PASSED BACK TO            *
      *    THE STANDARD SYSTEM.                                     *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      * 05/12/2009 - W-BLD-HCPCS-FLAG ADDED                         *
      ***************************************************************
       4100-INIT.

             MOVE 01 TO A-CLM-RTN-CODE.
             MOVE 'N' TO APC33-FLAG GJK-FLAG ST0-FLAG
                         N-FLAG C-FLAG W-BLD-HCPCS-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO TO A-OUTLIER-PYMT
                          A-TOTAL-CLM-DEDUCT
                          A-TOT-CLM-CHRG
                          A-TOT-CLM-PYMT
                          A-BLOOD-DEDUCT-DUE
                          A-BLOOD-PINTS-USED
                          A-WINX
                          W-LNC-MAX.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 4100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                   MOVE 54 TO A-CLM-RTN-CODE
                   GO TO 4100-INIT-EXIT
                ELSE
                   IF L-PSF-TERMDT > 0
                      IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                         MOVE 54 TO A-CLM-RTN-CODE
                         GO TO 4100-INIT-EXIT
                      END-IF
                   END-IF.
             MOVE CAL-VERSION4 TO A-CALC-VERS.
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.
             IF L-PSF-SPEC-PYMT-IND = 'Y'
                MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
             ELSE
                IF L-PSF-SPEC-PYMT-IND = ' '
                   MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA
                ELSE
                   IF L-PSF-SPEC-PYMT-IND = '1' OR '2'
                      MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA A-CBSA
                      MOVE L-PSF-SPEC-WGIDX TO H-WINX1
                      MOVE 912 TO H-IP-LIMIT
                      GO TO 4100-INIT-EXIT
                   ELSE
                      MOVE  52  TO A-CLM-RTN-CODE
                      GO TO 4100-INIT-EXIT.

             IF H-PSF-CBSA = SPACE
                MOVE  52  TO A-CLM-RTN-CODE
                GO TO 4100-INIT-EXIT.

             MOVE 912 TO H-IP-LIMIT.

             PERFORM 4120-FLOOR-2005
                THRU 4120-FLOOR-2005-EXIT.
             IF L-SERVICE-FROM-DATE < 20050401
                PERFORM 4120-SEC401-2005
                   THRU 4120-SEC401-2005-EXIT
             ELSE
                PERFORM 4120-SEC401-2005-APR
                   THRU 4120-SEC401-2005-APR-EXIT.

             MOVE H-PSF-CBSA TO A-CBSA.

             IF H-WINX1 = 0
                PERFORM 4200-CALC-WAGEINDX
                   THRU 4200-CALC-WAGEINDX-EXIT.

       4100-INIT-EXIT.
           EXIT.

000100*************************************************************           02
000200** NEW 2005 FLOOR AND SEC 401 FOR CBSA                    ***           02
000300*************************************************************           02
260700 4120-FLOOR-2005.                                                       02
260800                                                                        00
260900        IF H-PSF-CBSA = '10900'                                         00
261000           AND L-PSF-PROV-ST = '31'                                     00
261100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
261200               MOVE '   31' TO H-PSF-CBSA.                              00
261300                                                                        00
261400        IF H-PSF-CBSA = '16620'                                         00
261500           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
261600           AND L-PSF-PROV-ST = '36'                                     00
261700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
261800               MOVE '   36' TO H-PSF-CBSA.                              00
262500                                                                        00
262600        IF H-PSF-CBSA = '19060'                                         00
262700           AND L-PSF-PROV-ST = '21'                                     00
262800               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
262900               MOVE '   21' TO H-PSF-CBSA.                              00
263500                                                                        00
263600        IF H-PSF-CBSA = '21780'                                         00
263700           AND L-PSF-PROV-ST = '15'                                     00
263800               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
263900               MOVE '   15' TO H-PSF-CBSA.                              00
264500                                                                        00
264600        IF H-PSF-CBSA = '22020'                                         00
264800           AND L-PSF-PROV-ST = '24'                                     00
264900               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
265000               MOVE '   24' TO H-PSF-CBSA.                              00
264500                                                                        00
264600        IF H-PSF-CBSA = '22020'                                         00
264700           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
264800           AND L-PSF-PROV-ST = '24'                                     00
264900               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
265000               MOVE '   24' TO H-PSF-CBSA.                              00
266300                                                                        00
266400        IF H-PSF-CBSA = '24220'                                         00
266500           AND L-PSF-PROV-ST = '24'                                     00
266600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
266700               MOVE '   24' TO H-PSF-CBSA.                              00
267300                                                                        00
267400        IF H-PSF-CBSA = '25540'                                         00
267500           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
267600           AND L-PSF-PROV-ST = '07'                                     00
267700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
267800               MOVE '   07' TO H-PSF-CBSA.                              00
267900                                                                        00
268000        IF H-PSF-CBSA = '29100'                                         00
268200           AND L-PSF-PROV-ST = '52'                                     00
268300               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
268400               MOVE '   52' TO H-PSF-CBSA.                              00
267900                                                                        00
268000        IF H-PSF-CBSA = '30300'                                         00
268200           AND L-PSF-PROV-ST = '50'                                     00
268300               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
268400               MOVE '   50' TO H-PSF-CBSA.                              00
269700                                                                        00
269800        IF H-PSF-CBSA = '37620'                                         00
269900           AND L-PSF-PROV-ST = '36'                                     00
270000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
270100               MOVE '   36' TO H-PSF-CBSA.                              00
270700                                                                        00
270800        IF H-PSF-CBSA = '48260'                                         00
270900           AND L-PSF-PROV-ST = '36'                                     00
271000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
271100               MOVE '   36' TO H-PSF-CBSA.                              00
271700                                                                        00
271800        IF H-PSF-CBSA = '48540'                                         00
271900           AND L-PSF-PROV-ST = '36'                                     00
272000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
272100               MOVE '   36' TO H-PSF-CBSA.                              00
273200                                                                        00
273300        IF H-PSF-CBSA = '48864'                                         00
273400           AND L-PSF-PROV-ST = '31'                                     00
273500               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
273600               MOVE '   31' TO H-PSF-CBSA.                              00
273700                                                                        00
273800        IF H-PSF-CBSA = '48864'                                         00
273900           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
274000           AND L-PSF-PROV-ST = '31'                                     00
274100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
274200               MOVE '   31' TO H-PSF-CBSA.                              00
274300                                                                        00
274300        IF H-PSF-CBSA = '39900'                                         00
274300           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
274300           AND L-PSF-PROV-ST = '05'                                     00
274300               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
274300               MOVE '   05' TO H-PSF-CBSA.                              00
274300                                                                        00
274400 4120-FLOOR-2005-EXIT.                                                  02
274500       EXIT.                                                            02
309400                                                                        00
309500 4120-SEC401-2005.                                                      02
309600*************************************************************           00
309700****    FOR CY 2005 SECTION 401 HOSPITALS                   *           02
309800*************************************************************           00
310900                                                                        00
309900     IF (L-PSF-PROV-OSCAR = '050192' OR                                 00
310000                            '050469' OR                                 00
310100                            '050528' OR                                 00
310200                            '050618' OR                                 00
310000                            '050286' OR                                 00
310100                            '050446' OR                                 00
310200                            '051301')                                   00
310300         MOVE '   05' TO H-PSF-CBSA.                                    02
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '070004')                                   00
310700         MOVE '   07' TO H-PSF-CBSA.                                    02
310900                                                                        00
311000     IF (L-PSF-PROV-OSCAR = '100048' OR                                 00
                                  '100118')
311100         MOVE '   10' TO H-PSF-CBSA.                                    02
311300                                                                        00
311400     IF (L-PSF-PROV-OSCAR = '170137')                                   00
311500         MOVE '   17' TO H-PSF-CBSA.                                    02
311700                                                                        00
311800     IF (L-PSF-PROV-OSCAR = '190048' OR                                 00
311800                            '190110')                                   00
311900         MOVE '   19' TO H-PSF-CBSA.                                    02
312100                                                                        00
312200     IF (L-PSF-PROV-OSCAR = '230078')                                   00
312300         MOVE '   23' TO H-PSF-CBSA.                                    02
312500                                                                        00
312600     IF (L-PSF-PROV-OSCAR = '260006')                                   00
312700         MOVE '   26' TO H-PSF-CBSA.                                    02
311700                                                                        00
311800     IF (L-PSF-PROV-OSCAR = '290038' OR                                 00
311800                            '291301')                                   00
311900         MOVE '   29' TO H-PSF-CBSA.                                    02
313300                                                                        00
313400     IF (L-PSF-PROV-OSCAR = '300009')                                   00
313500         MOVE '   30' TO H-PSF-CBSA.                                    02
313700                                                                        00
313800     IF (L-PSF-PROV-OSCAR = '380084')                                   00
313900         MOVE '   38' TO H-PSF-CBSA.                                    02
314100                                                                        00
314200     IF (L-PSF-PROV-OSCAR = '390106' OR                                 00
314200                            '390181')                                   00
314300         MOVE '   39' TO H-PSF-CBSA.                                    00
314500                                                                        00
314600 4120-SEC401-2005-EXIT.                                                 02
314610       EXIT.                                                            02
314500                                                                        00
314600 4120-SEC401-2005-APR.                                                  02
309600*************************************************************           00
309700****    FOR CY 2005 SECTION 401 HOSPITALS -EFF. 04/01/2005  *           02
309800*************************************************************           00
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '030007')                                   00
310700         MOVE '   03' TO H-PSF-CBSA.                                    02
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '040075')                                   00
310700         MOVE '   04' TO H-PSF-CBSA.                                    02
310900                                                                        00
309900     IF (L-PSF-PROV-OSCAR = '050192' OR                                 00
310000                            '050469' OR                                 00
310100                            '050528' OR                                 00
310200                            '050618')                                   00
310300         MOVE '   05' TO H-PSF-CBSA.                                    02
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '070004')                                   00
310700         MOVE '   07' TO H-PSF-CBSA.                                    02
310900                                                                        00
311000     IF (L-PSF-PROV-OSCAR = '100048' OR                                 00
                                  '100134')
311100         MOVE '   10' TO H-PSF-CBSA.                                    02
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '130018')                                   00
310700         MOVE '   13' TO H-PSF-CBSA.                                    02
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '140167')                                   00
310700         MOVE '   14' TO H-PSF-CBSA.                                    02
310900                                                                        00
311000     IF (L-PSF-PROV-OSCAR = '150051' OR                                 00
                                  '150078')
311100         MOVE '   15' TO H-PSF-CBSA.                                    02
311300                                                                        00
311400     IF (L-PSF-PROV-OSCAR = '170137')                                   00
311500         MOVE '   17' TO H-PSF-CBSA.                                    02
311700                                                                        00
311800     IF (L-PSF-PROV-OSCAR = '190048')                                   00
311900         MOVE '   19' TO H-PSF-CBSA.                                    02
312100                                                                        00
312200     IF (L-PSF-PROV-OSCAR = '230078')                                   00
312300         MOVE '   23' TO H-PSF-CBSA.                                    02
312100                                                                        00
312200     IF (L-PSF-PROV-OSCAR = '240037')                                   00
312300         MOVE '   24' TO H-PSF-CBSA.                                    02
312500                                                                        00
312600     IF (L-PSF-PROV-OSCAR = '260006' OR                                 00
                                  '260122')
312700         MOVE '   26' TO H-PSF-CBSA.                                    02
313300                                                                        00
313400     IF (L-PSF-PROV-OSCAR = '300009')                                   00
313500         MOVE '   30' TO H-PSF-CBSA.                                    02
313300                                                                        00
313400     IF (L-PSF-PROV-OSCAR = '370054')                                   00
313500         MOVE '   37' TO H-PSF-CBSA.                                    02
313700                                                                        00
313800     IF (L-PSF-PROV-OSCAR = '380040' OR                                 00
                                  '380084')
313900         MOVE '   38' TO H-PSF-CBSA.                                    02
314100                                                                        00
314200     IF (L-PSF-PROV-OSCAR = '390181' OR                                 00
314200                            '390183' OR                                 00
314200                            '390201')                                   00
314300         MOVE '   39' TO H-PSF-CBSA.                                    00
313300                                                                        00
313400     IF (L-PSF-PROV-OSCAR = '450052' OR                                 00
                                  '450078' OR
                                  '450243' OR
                                  '450276' OR
                                  '450348')
313500         MOVE '   45' TO H-PSF-CBSA.                                    02
314100                                                                        00
314200     IF (L-PSF-PROV-OSCAR = '500023' OR                                 00
314200                            '500037' OR                                 00
314200                            '500122' OR                                 00
314200                            '500147' OR                                 00
314200                            '500148')                                   00
314300         MOVE '   50' TO H-PSF-CBSA.                                    00
314500                                                                        00
314600 4120-SEC401-2005-APR-EXIT.                                             02
314610     EXIT.                                                              02
314620                                                                        02
      *************************************************************
      *  SET FLAG IF APC = 0033                                   *
      *    - TERMINATE PROCESS IF 0033 LOCATED                    *
      *                                                           *
      *************************************************************

       4125-INIT.

             IF OPPS-APC (LN-SUB) = '0033'
                MOVE 'Y' TO APC33-FLAG
                MOVE 451 TO LN-SUB.

       4125-INIT-EXIT.
           EXIT.

      ***************************************************************
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1, 2,OR 4)*
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0 OR 1 OR 2          *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM DENIAL/REJECT FLAG  = TO 1     *
      *                 AND (APC NOT = 0033 OR 0034 OR 0322 OR      *
      *                      0323 OR 0324 OR 0325 OR 0373 OR 0374)) *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0              *
      *               - OR (APC 0033 IS NOT ON THE CLAIM            *
      *                     AND SERVICE INDICATOR = 'P'             *
      *                     OR  APC = 0322-0325,0373,0374)          *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      ***************************************************************
       4150-INIT.

             MOVE  01  TO A-RETURN-CODE (LN-SUB).

      ***************************************************************
      * OVER-RIDE SERVICE UNITS FOR APC 0339 - EFFECTIVE 04/01/2002 *
      *   - CHANGE UNIT VALUE TO 1                                  *
      ***************************************************************

             IF OPPS-APC (LN-SUB) = '0339'
                  MOVE 1 TO OPPS-SRVC-UNITS (LN-SUB).

             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 4250-CALC-DISCOUNT
                THRU 4250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 4150-INIT-EXIT.

      ***************************************************************
      *  EFFECTIVE AS OF 04-01-2002                                 *
      *    - TOTAL DEVICE OFFSET                                    *
      ***************************************************************

             IF OPPS-SRVC-IND (LN-SUB) = ' H'
                MOVE 'Y' TO C-FLAG
                COMPUTE H-TOT-HTD-UNITS = H-TOT-HTD-UNITS
                        + H-SRVC-UNITS.

             PERFORM 4160-TOTAL-OFFSET
                THRU 4160-TOTAL-OFFSET-EXIT.

             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C'
              OR ' E' OR ' F' OR ' G' OR ' H' OR ' K' OR
              ' L' OR ' N' OR ' P' OR ' S' OR ' T' OR ' V' OR
              ' X' OR ' W' OR ' Y' OR ' Z' OR ' M') THEN
                MOVE  40  TO A-RETURN-CODE (LN-SUB)
                GO TO 4150-INIT-EXIT
              ELSE
                MOVE  01  TO A-RETURN-CODE (LN-SUB).

             IF OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' L' OR ' W' OR ' Y' OR ' Z' OR ' M'
                MOVE  41  TO A-RETURN-CODE (LN-SUB)
                GO TO 4150-INIT-EXIT.

               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'
                 IF OPPS-PKG-FLAG (LN-SUB) = '0' OR '1' OR '2'
                                             OR '3' OR '4'
                   IF (OPPS-LITEM-DR-FLAG (LN-SUB) = '0' OR
                       OPPS-LITEM-DR-FLAG (LN-SUB) = '1' AND
                       (OPPS-APC (LN-SUB) = '0033' OR '0034'
                       OR '0322' OR '0323' OR '0324' OR '0325'
                       OR '0373' OR '0374')) OR
                      (OPPS-LITEM-ACT-FLAG (LN-SUB) = '1')
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                             OR ' 2' OR ' 3' OR ' 4' OR ' 5' OR ' 6'
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR
                            ((APC33-FLAG = 'Y') AND
                             ((OPPS-SRVC-IND (LN-SUB) = ' P') OR
                             (OPPS-APC (LN-SUB) = '0322' OR '0323'
                              OR '0324' OR '0325' OR '0373'
                              OR '0374')))
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

                    IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                       COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                            H-SUB-CHRG
                    END-IF
                    IF (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                       COMPUTE H-TOT-N-CHRG = H-SUB-CHRG
                                  + H-TOT-N-CHRG
                       MOVE 'Y' TO N-FLAG
                    END-IF
                    IF (OPPS-APC (LN-SUB) = '0000') OR
                       (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                       MOVE 42 TO A-RETURN-CODE (LN-SUB)
                       GO TO 4150-INIT-EXIT
                    END-IF
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 4150-INIT-EXIT
                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2
                      PERFORM 4175-APC-LOOKUP
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 4150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 4150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 4150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 4150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 4150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 4150-INIT-EXIT.

      ***************************************************************
      *   NEW LOGIC FOR PROCESSING BLOOD DEDUCTIBLE                 *
      *  EFFECTIVE AS OF 07-01-2005                                 *
      *    - TOTAL BLOOD CODE CHARGES                               *
      *      - WHEN PAYMENT ADJUSTMENT FLAG = '5' OR '6'            *
      ***************************************************************

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE H-TOT-38X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' OR ' 6'
                COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X-39X.
********************************************************

             IF A-RETURN-CODE (LN-SUB) = 01
                PERFORM 4300-COIN-DEDUCT
                   THRU 4300-COIN-DEDUCT-EXIT.


      ***************************************************************
      *   BLOOD DEDUCTIBLE LINE PROCESSING                          *
      *   05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD  *
      *                DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.   *
      *                FIX EFFECTIVE RETROACTIVE TO 01/01/2005.     *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01
                SET WNBD-INDX TO 1
                SEARCH WNBD-ENTRY VARYING WNBD-INDX
                   AT END
                      GO TO 4150-INIT-EXIT
                WHEN W-NEW-BLOOD-HCPCS (WNBD-INDX) =
                                              OPPS-HCPCS (LN-SUB)
                 IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                   MOVE W-NEW-BLOOD-RANK (WNBD-INDX) TO H-BLOOD-RANK
                   MOVE OPPS-LITEM-DOS (LN-SUB) TO H-BLD-DOS
                   PERFORM 4375-BLOOD-DEDUCT
                      THRU 4375-BLOOD-DEDUCT-EXIT
                 END-IF.

       4150-INIT-EXIT.
           EXIT.

      ***************************************************************
      *  COMPUTE TOTAL OFFSET FROM TABLE 5 FOR DEVICES              *
      *      - EFFECTIVE AS OF 01-01-2003                           *
      *      - CONTINUE FOR   01-01-2004                            *
      *      - CONTINUE FOR   01-01-2005                            *
      *        - SEARCH TABLE OPPSOF04                              *
      *          - WHERE ALL OFFSET VALUES EQUAL ZERO               *
      ***************************************************************
       4160-TOTAL-OFFSET.

             MOVE OPPS-GRP (LN-SUB) TO W-OFF-APC.
             SEARCH ALL WOO-ENTRY3
                AT END
                   GO TO 4160-TOTAL-OFFSET-EXIT
                WHEN WOO-APC3 (WOO-INDX3) = W-OFF-APC
                   COMPUTE H-TOTAL-OFFSET = H-TOTAL-OFFSET
                      + (WOO-OFFSET3 (WOO-INDX3) * H-DISC-RATE
                          * H-SRVC-UNITS)
                   COMPUTE H-TOT-OFF-UNITS = H-TOT-OFF-UNITS
                      + H-SRVC-UNITS.

       4160-TOTAL-OFFSET-EXIT.
           EXIT.

      ***************************************************************
      *  SEARCH APC TABLE - MOVE VALUES TO HOLD AREA FOR PROCESSING *
      *      - ADJUST TOTAL CHARGE FOR DELETED APC'S                *
      ***************************************************************
       4175-APC-LOOKUP.

             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)
               IF WAR-RATEX (W-SUB2) = 'DELETED'
                 MOVE 30 TO A-RETURN-CODE (LN-SUB)
                 COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                      H-SUB-CHRG
               ELSE
                 MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                 MOVE WAR-RANK (W-SUB2) TO H-RANK
                 MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                 MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                 MOVE WAR-PPCT (W-SUB2) TO H-PPCT
             ELSE
                SUBTRACT 1 FROM W-SUB2
                IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                  GO TO 4175-APC-LOOKUP
                ELSE
                   MOVE 0 TO H-APC-PYMT
                             H-RANK
                             H-MIN-COIN
                             H-NAT-COIN
                             H-PPCT.

       4175-APC-LOOKUP-EXIT.
           EXIT.

      ***************************************************************
      *  IF DATE OF SERVICE BETWEEN 12/31/2002 AND 04/01/2003       *
      *    IF HCPCS CODE = C9114 OR C9115 ADJUST PAYMENT AND        *
      *    COINSURANCE AMOUNTS - LOGIC REMOVED FOR 20050101         *
      ***************************************************************

      ***************************************************************
      *    SEARCH WAGE INDEX TABLE AND SELECT THE WAGE INDEX        *
      *    WHEN EQUAL TO PROVIDER SPECIFIC WAGE INDEX               *
      *    IF WAGE INDEX NOT LOCATED                                *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      ***************************************************************
       4200-CALC-WAGEINDX.

             MOVE WCD-MAX TO WCD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WCD-DATE (WCD-SUB)
                 SUBTRACT 1 FROM WCD-SUB
             END-PERFORM.

             SEARCH ALL WCM-ENTRY
                AT END
                   MOVE  50  TO A-CLM-RTN-CODE
                   GO TO 4200-CALC-WAGEINDX-EXIT
                WHEN WCM-CBSA (WCM-INDX) = H-PSF-CBSA
                  MOVE WCM-PTR (WCM-INDX) TO W-SUB3
                  PERFORM 4210-WAGE-LOOKUP.

             IF H-WINX1 = 0 THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       4200-CALC-WAGEINDX-EXIT.
           EXIT.

       4210-WAGE-LOOKUP.

             IF WCW-DTCD (W-SUB3) NOT > WCD-DTCD (WCD-SUB)
                IF L-PSF-SPEC-PYMT-IND = 'Y'
                  MOVE WCW-WINX2 (W-SUB3) TO H-WINX1
                ELSE
                    MOVE WCW-WINX1 (W-SUB3) TO H-WINX1
             ELSE
                SUBTRACT 1 FROM W-SUB3
                IF W-SUB3 > WCM-PTR (WCM-INDX - 1)
                   GO TO 4210-WAGE-LOOKUP
                ELSE
                   MOVE 0 TO H-WINX1.

       4210-WAGE-LOOKUP-EXIT.
           EXIT.

      ***************************************************************
      *    CALCULATE DISCOUNT FACTOR BASED ON THE DISCOUNT          *
      *    INDICATOR PASSED BY THE OCE: VALUE 1 - 8                 *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      ***************************************************************
       4250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 4250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     MOVE  38  TO A-RETURN-CODE (LN-SUB).

       4250-CALC-DISCOUNT-EXIT.
           EXIT.

      ***************************************************************
      *    DETERMINE THE DEDUCTIBLE SEQUENCE. DEDUCTIBLE WILL BE    *
      *    TAKEN FROM OPPS SERVICES FIRST, THEN FROM ANY OTHER      *
      *    TYPES OF SERVICES FROM THE CLAIM.                        *
      *       - SET POINTERS TO THE HIGHEST RANKED PERCENTAGE       *
      *         (LARGEST NATIONAL UNADJUSTED COINSURANCE /          *
      *          THE APC PAYMENT)                                   *
      *       - MOVE ALL PRICING VARIABLES TO STAGING AREA          *
      ***************************************************************
       4300-COIN-DEDUCT.

             ADD 1 TO W-LNC-MAX.
             SET W-LP-INDX TO W-LNC-MAX.
             PERFORM 4350-STAGE-ENTRY
                THRU 4350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).
             MOVE LN-SUB TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX1    TO W-WINX1 (W-LP-INDX).
             MOVE H-RANK     TO W-RANK (W-LP-INDX).
             MOVE H-PPCT     TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
              UNTIL PS-SUB > L-PSF-APC-LINE-CNT
              IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS * H-DISC-RATE
                MOVE 25 TO A-RETURN-CODE (LN-SUB)
                MOVE L-PSF-APC-LINE-CNT TO PS-SUB
              END-IF
             END-PERFORM.

       4300-COIN-DEDUCT-EXIT.
           EXIT.

       4350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       4350-STAGE-ENTRY-EXIT.
           EXIT.

      ***************************************************************
      *    DETERMINE THE BLOOD DEDUCTIBLE SEQUENCE. DEDUCTIBLE      *
      *    WILL BE CALCULATED BASED ON RANKING.                     *
      *       - SET POINTERS TO THE HIGHEST RANKED APC              *
      *         (SMALLEST UNADJUSTED APC PAYMENT)                   *
      *       - MOVE ALL PRICING VARIABLES TO STAGING AREA          *
      ***************************************************************
       4375-BLOOD-DEDUCT.

             ADD 1 TO W-BLD-MAX.
             SET W-BD-INDX TO W-BLD-MAX.
             PERFORM 4385-STAGE-ENTRY
                THRU 4385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLD-RNK NOT < W-BD-RNK (W-BD-INDX - 1).
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX1    TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK  TO W-BD-RANK (W-BD-INDX).
             MOVE H-BLD-DOS TO W-BD-DOS (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).
             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
              UNTIL PS-SUB > L-PSF-APC-LINE-CNT
              IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS * H-DISC-RATE
                MOVE 25 TO A-RETURN-CODE (LN-SUB)
                MOVE L-PSF-APC-LINE-CNT TO PS-SUB
              END-IF
             END-PERFORM.

       4375-BLOOD-DEDUCT-EXIT.
           EXIT.

       4385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       4385-STAGE-ENTRY-EXIT.
           EXIT.

      ***************************************************************
      *    FIRST STEP IN DETERMINING A LINE ITEM PRICE.             *
      *    CHECK ALL APPROPRIATE FLAGS AND INDICATORS PASSED        *
      *    BY THE OCE.                                              *
      *      - SET RETURN CODES TO INDICATE ERRORS OR STATUS        *
      *        - '20' - LINE PROCESSED BUT PAYMENT = 0              *
      *                 - BENE DEDUCTIBLE => ADJUSTED PAYMENT       *
      *                                                             *
      ***************************************************************
       4400-CALCULATE.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 4400-CALCULATE-EXIT.

             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 4550-CALC-STANDARD
                   THRU 4550-CALC-STANDARD-EXIT
             ELSE
                GO TO 4400-CALCULATE-EXIT.

      ***************************************************************
      *  SET GJK FLAG                                               *
      *    - TEST LINE ITEM DATE OF SERVICE > 20010630              *
      *    - TOTAL DRUG / DEVICE COINSURANCE                        *
      ***************************************************************

             IF (A-RETURN-CODE (LN-SUB) <  30)
               PERFORM 4450-ADJ-PROC-COIN
                  THRU 4450-ADJ-PROC-COIN-EXIT
             ELSE
               NEXT SENTENCE.

      ***************************************************************
      *  SET ST0 AND STVX FLAGS                                     *
      *    - TEST LINE ITEM DATE OF SERVICE > 20020331              *
      *    - TOTAL PROCEDURE CHARGES AND BUNDLED CHARGES            *
      ***************************************************************

             PERFORM 4500-ADJ-CHRGS
                THRU 4500-ADJ-CHRGS-EXIT.

             IF A-RETURN-CODE (LN-SUB) <  30
               COMPUTE A-TOTAL-CLM-DEDUCT =
                       H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT
               COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT
               COMPUTE A-BLOOD-DEDUCT-DUE =
                     A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT
               MOVE H-LITEM-PYMT TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN TO A-RED-COIN (LN-SUB)
               IF H-RED-COIN > H-NAT-COIN
                 MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF
               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.
             MOVE ZERO TO LINE-HOLD-ITEMS.

       4400-CALCULATE-EXIT.
           EXIT.

      ***************************************************************
      *  SET GJK FLAG                                               *
      *    - STAGE BY SERVICE INDICATOR                             *
      *                                                             *
      ***************************************************************
       4450-ADJ-PROC-COIN.

             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX1 (W-LP-INDX) + .4)
                  IF H-NEW-WGNAT > H-IP-LIMIT
                    MOVE H-IP-LIMIT TO H-NEW-WGNAT
                  END-IF
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                MOVE 1 TO H-DCP-CODE
                PERFORM 4455-SEARCH-KEY
                   THRU 4455-SEARCH-KEY-EXIT
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                        H-TOTAL-LN-DEDUCT - H-LITEM-REIM
                                   - H-LN-BLOOD-DEDUCT
                   MOVE 'Y' TO GJK-FLAG
                   MOVE 1 TO H-DCP-CODE
                   PERFORM 4455-SEARCH-KEY
                      THRU 4455-SEARCH-KEY-EXIT
                   MOVE 2 TO H-DCP-CODE
                   ADD 1 TO W-DCP-MAX
                   SET W-DCP-INDX TO W-DCP-MAX
                   PERFORM 4475-STAGE-DCP-ENTRY
                     THRU 4475-STAGE-DCP-ENTRY-EXIT
                       UNTIL W-DCP-INDX = 1 OR
                       H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       4450-ADJ-PROC-COIN-EXIT.
           EXIT.

       4455-SEARCH-KEY.

             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX
                AT END
                   PERFORM 4460-ADD-ENTRY
                      THRU 4460-ADD-ENTRY-EXIT
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 4465-UPDATE-ENTRY
                      THRU 4465-UPDATE-ENTRY-EXIT.

       4455-SEARCH-KEY-EXIT.
           EXIT.

       4460-ADD-ENTRY.

             ADD 1 TO W-DCP-MAX.
             SET W-DCP-INDX TO W-DCP-MAX.
             PERFORM 4475-STAGE-DCP-ENTRY
               THRU 4475-STAGE-DCP-ENTRY-EXIT
                UNTIL W-DCP-INDX = 1 OR
                  H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       4460-ADD-ENTRY-EXIT.
           EXIT.

       4465-UPDATE-ENTRY.

             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 4485-REPLACE-TYPE1
                     THRU 4485-REPLACE-TYPE1-EXIT
               ELSE
                  PERFORM 4480-RANK-COIN
                     THRU 4480-RANK-COIN-EXIT.

       4465-UPDATE-ENTRY-EXIT.
           EXIT.

       4475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       4475-STAGE-DCP-ENTRY-EXIT.
           EXIT.

       4480-RANK-COIN.

             IF H-NEW-WGNAT > W-DCP-WGNAT (W-DCP-INDX)
               MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
               MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
               MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
               MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       4480-RANK-COIN-EXIT.
           EXIT.

       4485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       4485-REPLACE-TYPE1-EXIT.
           EXIT.

       4500-ADJ-CHRGS.

      *****************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY              *
      *****************************************************
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                 OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                MOVE 'Y' TO ST0-FLAG.

             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                 OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX)
                               + H-TOT-ST-CHRG
                COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT
                               + H-TOT-ST-PYMT.

             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                OR ' X' OR ' P')
                AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT
                               + H-TOT-STVX-PYMT.

       4500-ADJ-CHRGS-EXIT.
           EXIT.
      ***************************************************************
      * 1. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *     - DESCENDING UNTIL DEDUCTIBLE = 0.                      *
      * 2. CALCULATE THE STANDARD LINE PRICE                        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS                *
      *          * DISCOUNT FACTOR)                                 *
      *     - WAGE ADJUST 60% OF THE APC PAYMENT ONLY               *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA.                     *
      *                                                             *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *       AND DRUGS                                             *
      ***************************************************************
       4550-CALC-STANDARD.

             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' V'
                        OR ' T' OR ' P' OR ' X' THEN
                COMPUTE H-LITEM-PYMT ROUNDED =
                    (((W-APC-PYMT (W-LP-INDX) * .60) *
                            W-WINX1 (W-LP-INDX))
                                + (W-APC-PYMT (W-LP-INDX) * .40)) *
                  W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)
                  PERFORM 4560-CALC-BENE-DEDUCT
                     THRU 4560-CALC-BENE-DEDUCT-EXIT
             ELSE
               IF OPPS-SRVC-IND (LN-SUB) = ' H' THEN
                 IF OPPS-PYMT-IND (LN-SUB) = ' 6' THEN
                   PERFORM 4555-CALC-H-STANDARD
                      THRU 4555-CALC-H-STANDARD-EXIT
                   PERFORM 4560-CALC-BENE-DEDUCT
                      THRU 4560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 4550-CALC-STANDARD-EXIT
                 END-IF
               ELSE
               IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' THEN
                IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 7' THEN
                  MOVE 0 TO H-BLOOD-FRACTION
                  PERFORM 4550-CALC-GJK
                     THRU 4550-CALC-GJK-EXIT
                  PERFORM 4560-CALC-BENE-DEDUCT
                     THRU 4560-CALC-BENE-DEDUCT-EXIT
                ELSE
                 MOVE  41  TO A-RETURN-CODE (LN-SUB)
                 GO TO 4550-CALC-STANDARD-EXIT
                END-IF
               END-IF.

             IF H-LITEM-PYMT > 0
               IF OPPS-APC (LN-SUB) = ('1716' OR '1717' OR
                  '1718' OR '1719' OR '1720' OR '2616' OR '2632'
                  OR '2633' OR '2634' OR '2635' OR '2636' OR '2637')
                  COMPUTE H-LITEM-REIM ROUNDED =
                  ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                     H-LN-BLOOD-DEDUCT) * .8
                  COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                  H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                  MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN
               ELSE
                  COMPUTE H-LITEM-REIM ROUNDED =
                  ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                     H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX)
                  COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                  H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                  MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN
             ELSE
              NEXT SENTENCE.

             IF H-MIN-COIN > 0
               IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' H'
                        OR ' K'
                 COMPUTE H-MIN-COIN ROUNDED = H-MIN-COIN *
                 (W-SRVC-UNITS (W-LP-INDX) -
                    (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION))
                   * W-DISC-RATE (W-LP-INDX)
               ELSE
                 IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                   COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25
                 ELSE
                   COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                 END-IF
               END-IF
             END-IF.

             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.
             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                  MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                         (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                            (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       4550-CALC-STANDARD-EXIT.
           EXIT.

      ***************************************************************
      * 1. CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR        *
      *    TYPES G  OR K.                                           *
      * 2. EFFECTIVE 01/01/2003 REMOVE PRO RATA REDUCTION FOR       *
      *       ALL SERVICE INDICATOR 'G' PAYMENTS                    *
      ***************************************************************

       4550-CALC-GJK.

             IF (OPPS-HCPCS(LN-SUB) = ('P9010' OR 'P9016' OR 'P9021'
                      OR 'P9022' OR 'P9038' OR 'P9039' OR 'P9040'
                      OR 'P9051' OR 'P9054' OR 'P9056' OR 'P9057'
                      OR 'P9058') AND
                 OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6'))
               PERFORM 4550-SET-BLOOD-FRACTION
                  THRU 4550-SET-BLOOD-FRACTION-EXIT
               PERFORM 4550-ADJ-BLOOD-COST
                  THRU 4550-ADJ-BLOOD-COST-EXIT
             ELSE
               IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                  PERFORM 4550-ADJ-PLATE-COST
                     THRU 4550-ADJ-PLATE-COST-EXIT
                  GO TO 4550-CALC-GJK-EXIT
             ELSE
               COMPUTE H-LITEM-PYMT ROUNDED =
               W-APC-PYMT (W-LP-INDX) * W-SRVC-UNITS (W-LP-INDX)
                      * W-DISC-RATE (W-LP-INDX)
               GO TO 4550-CALC-GJK-EXIT.

             COMPUTE H-LITEM-PYMT ROUNDED =
             W-BD-APC-PYMT (W-BD-INDX) * W-BD-SRVC-UNITS (W-BD-INDX)
                      * W-BD-DISC-RATE (W-BD-INDX).
             COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                 H-LITEM-PYMT * H-BLOOD-FRACTION.
             SET W-BD-INDX UP BY 1.

       4550-CALC-GJK-EXIT.
           EXIT.

       4550-SET-BLOOD-FRACTION.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              IF H-BENE-PINTS-USED > 0
                IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                   MOVE 1 TO H-BLOOD-FRACTION
                   COMPUTE H-BENE-PINTS-USED =
                     H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)
                ELSE
                  IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                    COMPUTE H-BLOOD-FRACTION =
                      H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                    MOVE 0 TO H-BENE-PINTS-USED
                  ELSE
                     MOVE 0 TO H-BLOOD-FRACTION
              ELSE
                 MOVE 0 TO H-BLOOD-FRACTION
             ELSE
                MOVE 0 TO H-BLOOD-FRACTION.

       4550-SET-BLOOD-FRACTION-EXIT.
           EXIT.

       4550-ADJ-BLOOD-COST.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * H-38X-39X-RATE.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * (1 - H-38X-39X-RATE).

       4550-ADJ-BLOOD-COST-EXIT.
           EXIT.

       4550-ADJ-PLATE-COST.

           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * H-38X-39X-RATE.

           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * (1 - H-38X-39X-RATE).

           COMPUTE H-LITEM-PYMT ROUNDED =
              W-APC-PYMT (W-LP-INDX) * W-SRVC-UNITS (W-LP-INDX)
                      * W-DISC-RATE (W-LP-INDX).

       4550-ADJ-PLATE-COST-EXIT.
           EXIT.

      ***************************************************************
      * 1. CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR        *
      *    TYPE  H.                                                 *
      * 2. EFFECTIVE 04/01/2002 A PRO RATA REDUCTION APPLIES TO     *
      *       ALL SERVICE INDICATOR 'H' PAYMENTS (CURRENTLY .689)   *
      ***************************************************************

       4555-CALC-H-TOT.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.
             IF OPPS-SRVC-IND (LN-SUB) = ' H'
               IF OPPS-PYMT-IND (LN-SUB) = ' 6'
                  COMPUTE H-TOT-H-CHRG =
                     (H-TOT-H-CHRG + H-SUB-CHRG)
               ELSE
                  NEXT SENTENCE
             ELSE
                NEXT SENTENCE.

       4555-CALC-H-TOT-EXIT.
           EXIT.

       4555-CALC-H-STANDARD.

             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

             COMPUTE T-LITEM-PYMT ROUNDED =
               (H-SUB-CHRG * L-PSF-OPCOST-RATIO).

              IF (C-FLAG = 'Y')
                 IF (H-TOT-OFF-UNITS > H-TOT-HTD-UNITS)
                   COMPUTE H-TOTAL-WAOFF ROUNDED =
                     (((H-TOTAL-OFFSET * .60) * A-WINX)
                      + (H-TOTAL-OFFSET * .40))
                      * (H-TOT-HTD-UNITS / H-TOT-OFF-UNITS)
                   PERFORM 4700-CALC-H-OFFSET
                      THRU 4700-CALC-H-OFFSET-EXIT
                 ELSE
                    COMPUTE H-TOTAL-WAOFF ROUNDED =
                      ((H-TOTAL-OFFSET * .60) * A-WINX)
                       + (H-TOTAL-OFFSET * .40)
                    PERFORM 4700-CALC-H-OFFSET
                       THRU 4700-CALC-H-OFFSET-EXIT
              ELSE
                 NEXT SENTENCE.

                IF T-LITEM-PYMT < 0 THEN
                   MOVE 0 TO H-LITEM-PYMT
                ELSE
                   MOVE T-LITEM-PYMT TO H-LITEM-PYMT.


       4555-CALC-H-STANDARD-EXIT.
           EXIT.

       4560-CALC-BENE-DEDUCT.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 4'
                GO TO 4560-CALC-BENE-DEDUCT-EXIT.
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                  H-LITEM-PYMT - H-LN-BLOOD-DEDUCT
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                      H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       4560-CALC-BENE-DEDUCT-EXIT.
           EXIT.

      *********************************************************************
      ** - NEW FOR JANUARY 2004                                          **
      **   - CHECK >= 20040101 AND SRVC-IND = 'K'                        **
      **      - DISCONTINUE OUTLIER PROCESS                              **
      *********************************************************************
       4600-ADJ-CHRG-OUTL.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *********************************************************************
      ** - NEW FOR JANUARY 2005                                          **
      **   - TURN OFF OUTLIER PROCESS FOR SPECIFIED K TYPE APCS          **
      **                                                                 **
      ** 05/12/2009 - ALTERED LOGIC TO ALLOW ALL BLOOD LINES (WITH A     **
      **              STATUS INDICATOR = ' K') TO ENTER OUTLIER LOGIC    **
      **                                                                 **
      *********************************************************************
             MOVE 'N' TO W-BLD-HCPCS-FLAG.
             SET WBLH-INDX TO 1.
             SEARCH WBLHCPCS-ENTRY VARYING WBLH-INDX
                AT END
                   MOVE 'N' TO W-BLD-HCPCS-FLAG
                WHEN W-2005-2008-BLOOD-HCPCS (WBLH-INDX) =
                     OPPS-HCPCS (LN-SUB)
                   MOVE 'Y' TO W-BLD-HCPCS-FLAG.

             IF (OPPS-SRVC-IND (LN-SUB) = ' G' OR ' H' OR ' N') OR
                (OPPS-PKG-FLAG (LN-SUB) = '4') OR
                (OPPS-SRVC-IND (LN-SUB) = ' K' AND
                   W-BLD-HCPCS-FLAG = 'N')
                GO TO 4600-ADJ-CHRG-OUTL-EXIT.

      *----------------------------------------------------------*
      * CODE COMMENTED OUT 05/12/2009 & REPLACED WITH CODE ABOVE *
      *----------------------------------------------------------*
      *      IF (OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' OR
      *        ' H' OR ' N') OR (OPPS-PKG-FLAG (LN-SUB) = '4')
      *         GO TO 4600-ADJ-CHRG-OUTL-EXIT.


      *****************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY              *
      *****************************************************
             IF (ST0-FLAG = 'Y') AND ((OPPS-SRVC-IND (LN-SUB)
                 = ' T' ) OR ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                             (OPPS-HCPCS (LN-SUB) > '09999' AND
                              OPPS-HCPCS (LN-SUB) < '70000')))
                   AND (H-TOT-ST-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND
                ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                  ' X' OR ' P')
                   AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3'))
                   AND (H-TOT-STVX-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                   (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)
                COMPUTE H-SUB-CHRG ROUNDED =
                     (H-CHRG-RATE * H-TOT-N-CHRG)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.

              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND
                ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                  ' X' OR ' P')
                  AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3'))
                  AND (H-TOT-STVX-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                     (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)
                COMPUTE H-SUB-CHRG ROUNDED =
                     (H-CHRG-RATE * H-TOT-N-CHRG)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.
      *********************************************************************
      ** - NEW FOR JANUARY 2005                                          **
      **   - PROVIDER RANGE FOR CMHC                                     **
      **   - COMPUTE H-LITEM-OUTL-PYMT USING NEW FORMULA                 **
      *********************************************************************

               MOVE 1.75 TO H-OUTLIER-FACTOR.
               MOVE .50 TO H-OUTLIER-PCT.
               COMPUTE H-COST ROUNDED =
                  W-SUB-CHRG (W-LP-INDX) * L-PSF-OPCOST-RATIO.
               COMPUTE H-APC-ADJ-PYMT ROUNDED =
                  H-OUTLIER-FACTOR * A-LITEM-PYMT (LN-SUB).
               IF (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999')
                  MOVE 3.5 TO H-OUTLIER-FACTOR
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED = (H-COST -
                    (H-OUTLIER-FACTOR * A-LITEM-PYMT (LN-SUB))) *
                     H-OUTLIER-PCT
               ELSE
                IF (H-COST > H-APC-ADJ-PYMT) AND
                   (H-COST > A-LITEM-PYMT (LN-SUB) + 1175)
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
                    (H-COST - H-APC-ADJ-PYMT) * H-OUTLIER-PCT
                ELSE
                   MOVE ZERO TO H-LITEM-OUTL-PYMT.

             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

             IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                       H-LITEM-OUTL-PYMT
               MOVE 0 TO H-LITEM-OUTL-PYMT.

       4600-ADJ-CHRG-OUTL-EXIT.
           EXIT.

      ***************************************************************
      * 1. RE-CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR     *
      *    TYPE H.                                                  *
      * 2. SUBTRACT WAGE ADJUSTED OFFSET AMOUNT FROM SI TYPE 'H'    *
      *    WITH HCPCS CODE BEGINNING WITH 'C'                       *
      * 2. EFFECTIVE 04/01/2002                                     *
      ***************************************************************

       4700-CALC-H-OFFSET.

             IF H-TOT-H-CHRG > 0
               COMPUTE H-OFF-RATE ROUNDED =
                    H-SUB-CHRG / H-TOT-H-CHRG
               COMPUTE T-LITEM-PYMT ROUNDED = T-LITEM-PYMT -
                      (H-TOTAL-WAOFF * H-OFF-RATE)
             ELSE
                NEXT SENTENCE.

       4700-CALC-H-OFFSET-EXIT.
           EXIT.

       4800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 4810-PROCESS-TYPE1
                   THRU 4810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 4840-PROCESS-TYPE2
                   THRU 4840-PROCESS-TYPE2-EXIT.

       4800-ADJ-STV-REIM-EXIT.
           EXIT.

       4810-PROCESS-TYPE1.

             IF  W-DCP-COIN2 (W-DCP-INDX) > 0
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-WGNAT (W-DCP-INDX) TO H-TOTAL
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-WGNAT (W-DCP-INDX)) /
                                  W-DCP-COIN2 (W-DCP-INDX)
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.
                IF H-RATIO > 1
                    MOVE 1 TO H-RATIO.

       4810-PROCESS-TYPE1-EXIT.
           EXIT.

       4840-PROCESS-TYPE2.

             IF W-DCP-DOS (W-DCP-INDX) =  H-DCP-DOS
                MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB
                COMPUTE H-SHIFT =
                    W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)
                COMPUTE H-TOTAL =
                     A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT
                IF H-TOTAL > H-IP-LIMIT
                   COMPUTE H-SHIFT = H-SHIFT + H-TOTAL
                         - H-IP-LIMIT
                END-IF
                COMPUTE A-ADJ-COIN (LN-SUB) =
                     A-ADJ-COIN (LN-SUB) - H-SHIFT
                COMPUTE A-LITEM-REIM (LN-SUB) =
                   A-LITEM-REIM (LN-SUB) + H-SHIFT
                   MOVE 22 TO A-RETURN-CODE (LN-SUB)
             END-IF.

       4840-PROCESS-TYPE2-EXIT.
           EXIT.

      ***************************************************************
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      ***************************************************************
       4900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.
             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       4900-END-PRICE-RTN-EXIT.
           EXIT.

       5000-PROCESS-MAIN-NEW.

              PERFORM 5100-INIT
                 THRU 5100-INIT-EXIT.

              IF H-WINX1 = 0 AND A-CLM-RTN-CODE = 01
                MOVE 51 TO A-CLM-RTN-CODE.

              IF A-CLM-RTN-CODE >= 50
                 GOBACK.
              MOVE H-WINX1 TO A-WINX.
              PERFORM 5125-INIT
                 THRU 5125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

              MOVE 0 TO W-DCP-MAX W-BLD-MAX.
              PERFORM 5150-INIT
                 THRU 5150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

              IF H-TOT-38X-39X > 0
                 COMPUTE H-38X-39X-RATE ROUNDED =
                    H-TOT-38X / H-TOT-38X-39X.

              MOVE 0 TO W-DCP-MAX.
              PERFORM 5555-CALC-H-TOT
                 THRU 5555-CALC-H-TOT-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.

              SET W-BD-INDX TO 1.
              MOVE 0 TO W-DCP-MAX.
              PERFORM 5400-CALCULATE
                 THRU 5400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.

              PERFORM 5600-ADJ-CHRG-OUTL
                 THRU 5600-ADJ-CHRG-OUTL-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX


              IF GJK-FLAG = 'Y'
                PERFORM 5800-ADJ-STV-REIM
                   THRU 5800-ADJ-STV-REIM-EXIT
                      VARYING W-DCP-INDX FROM 1 BY 1
                        UNTIL W-DCP-INDX > W-DCP-MAX
              ELSE
                 NEXT SENTENCE.

              PERFORM 5900-END-PRICE-RTN
                 THRU 5900-END-PRICE-RTN-EXIT.

       5000-PROCESS-MAIN-NEW-EXIT.
           EXIT.

      ***************************************************************
      *    INITIALIZE WORKING STORAGE HOLD AREAS                    *
      *    AND ADDITIONAL VARIABLES TO BE PASSED BACK TO            *
      *    THE STANDARD SYSTEM.                                     *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      * 05/12/2009 - W-BLD-HCPCS-FLAG ADDED                         *
      ***************************************************************
       5100-INIT.

             MOVE 01 TO A-CLM-RTN-CODE.
             MOVE 'N' TO APC33-FLAG GJK-FLAG ST0-FLAG
                         N-FLAG C-FLAG C1820-OFFSET-FLAG
                         W-BLD-HCPCS-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO TO A-OUTLIER-PYMT
                          A-TOTAL-CLM-DEDUCT
                          A-TOT-CLM-CHRG
                          A-TOT-CLM-PYMT
                          A-BLOOD-DEDUCT-DUE
                          A-BLOOD-PINTS-USED
                          A-WINX
                          W-LNC-MAX.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 5100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                   MOVE 54 TO A-CLM-RTN-CODE
                   GO TO 5100-INIT-EXIT
                ELSE
                   IF L-PSF-TERMDT > 0
                      IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                         MOVE 54 TO A-CLM-RTN-CODE
                         GO TO 5100-INIT-EXIT
                      END-IF
                   END-IF.
             MOVE CAL-VERSION5 TO A-CALC-VERS.
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.
             IF L-PSF-SPEC-PYMT-IND = 'Y'
                MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
             ELSE
                IF L-PSF-SPEC-PYMT-IND = ' '
                   MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA
                ELSE
                   IF L-PSF-SPEC-PYMT-IND = '1' OR '2'
                      MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA A-CBSA
                      MOVE L-PSF-SPEC-WGIDX TO H-WINX1
                      MOVE 952 TO H-IP-LIMIT
                      GO TO 5100-INIT-EXIT
                   ELSE
                      MOVE  52  TO A-CLM-RTN-CODE
                      GO TO 5100-INIT-EXIT.

             IF H-PSF-CBSA = SPACE
                MOVE  52  TO A-CLM-RTN-CODE
                GO TO 5100-INIT-EXIT.

             MOVE 952 TO H-IP-LIMIT.

             PERFORM 5120-FLOOR-2006
                THRU 5120-FLOOR-2006-EXIT.

             PERFORM 5120-SEC401-2006
                THRU 5120-SEC401-2006-EXIT.

             MOVE H-PSF-CBSA TO A-CBSA.

             IF H-WINX1 = 0
                PERFORM 5200-CALC-WAGEINDX
                   THRU 5200-CALC-WAGEINDX-EXIT.

       5100-INIT-EXIT.
           EXIT.

000100*************************************************************           02
000200** NEW 2006 FLOOR AND SEC 401 FOR CBSA                    ***           02
000300*************************************************************           02
260700 5120-FLOOR-2006.                                                       02
261300                                                                        00
261400        IF H-PSF-CBSA = '   10'                                         00
261500           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
261600           AND L-PSF-PROV-ST = '10'                                     00
261700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
261800               MOVE '   10' TO H-PSF-CBSA.                              00
261300                                                                        00
261400        IF H-PSF-CBSA = '   50'                                         00
261500           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
261600           AND L-PSF-PROV-ST = '50'                                     00
261700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
261800               MOVE '   50' TO H-PSF-CBSA.                              00
260800                                                                        00
260900        IF H-PSF-CBSA = '10900'                                         00
261000           AND L-PSF-PROV-ST = '31'                                     00
261100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
261200               MOVE '   31' TO H-PSF-CBSA.                              00
261300                                                                        00
261400        IF H-PSF-CBSA = '15764'                                         00
261500           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
261600           AND L-PSF-PROV-ST = '30'                                     00
261700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
261800               MOVE '   30' TO H-PSF-CBSA.                              00
261300                                                                        00
261400        IF H-PSF-CBSA = '16620'                                         00
261500           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
261600           AND L-PSF-PROV-ST = '36'                                     00
261700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
261800               MOVE '   36' TO H-PSF-CBSA.                              00
262500                                                                        00
262600        IF H-PSF-CBSA = '19060'                                         00
262700           AND L-PSF-PROV-ST = '21'                                     00
262800               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
262900               MOVE '   21' TO H-PSF-CBSA.                              00
264500                                                                        00
264600        IF H-PSF-CBSA = '22020'                                         00
264800           AND L-PSF-PROV-ST = '24'                                     00
264900               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
265000               MOVE '   24' TO H-PSF-CBSA.                              00
266300                                                                        00
266400        IF H-PSF-CBSA = '24220'                                         00
266500           AND L-PSF-PROV-ST = '24'                                     00
266600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
266700               MOVE '   24' TO H-PSF-CBSA.                              00
267300                                                                        00
267400        IF H-PSF-CBSA = '24580'                                         00
267500           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
267600           AND L-PSF-PROV-ST = '52'                                     00
267700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
267800               MOVE '   52' TO H-PSF-CBSA.                              00
267300                                                                        00
267400        IF H-PSF-CBSA = '25540'                                         00
267500           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
267600           AND L-PSF-PROV-ST = '07'                                     00
267700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
267800               MOVE '   07' TO H-PSF-CBSA.                              00
267900                                                                        00
268000        IF H-PSF-CBSA = '30300'                                         00
268200           AND L-PSF-PROV-ST = '50'                                     00
268300               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
268400               MOVE '   50' TO H-PSF-CBSA.                              00
269700                                                                        00
269800        IF H-PSF-CBSA = '37620'                                         00
269900           AND L-PSF-PROV-ST = '36'                                     00
270000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
270100               MOVE '   36' TO H-PSF-CBSA.                              00
267300                                                                        00
267400        IF H-PSF-CBSA = '39900'                                         00
267500           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
267600           AND L-PSF-PROV-ST = '05'                                     00
267700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
267800               MOVE '   05' TO H-PSF-CBSA.                              00
270700                                                                        00
270800        IF H-PSF-CBSA = '48260'                                         00
270900           AND L-PSF-PROV-ST = '36'                                     00
271000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
271100               MOVE '   36' TO H-PSF-CBSA.                              00
271700                                                                        00
271800        IF H-PSF-CBSA = '48540'                                         00
271900           AND L-PSF-PROV-ST = '36'                                     00
272000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
272100               MOVE '   36' TO H-PSF-CBSA.                              00
271700                                                                        00
271800        IF H-PSF-CBSA = '48540'                                         00
271900           AND L-PSF-PROV-ST = '51'                                     00
272000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
272100               MOVE '   51' TO H-PSF-CBSA.                              00
273200                                                                        00
273300        IF H-PSF-CBSA = '48864'                                         00
273400           AND L-PSF-PROV-ST = '31'                                     00
273500               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
273600               MOVE '   31' TO H-PSF-CBSA.                              00
273700                                                                        00
273800        IF H-PSF-CBSA = '49660'                                         00
274000           AND L-PSF-PROV-ST = '36'                                     00
274100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
274200               MOVE '   36' TO H-PSF-CBSA.                              00
274300                                                                        00
274400 5120-FLOOR-2006-EXIT.                                                  02
274500     EXIT.                                                              02
309400                                                                        00
309500 5120-SEC401-2006.                                                      02
309600*************************************************************           00
309700****    FOR CY 2006 SECTION 401 HOSPITALS                   *           02
309800*************************************************************           00
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '030007')                                   00
310700         MOVE '   03' TO H-PSF-CBSA.                                    02
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '040075')                                   00
310700         MOVE '   04' TO H-PSF-CBSA.                                    02
310900                                                                        00
309900     IF (L-PSF-PROV-OSCAR = '050192' OR                                 00
310000                            '050469' OR                                 00
310100                            '050528' OR                                 00
310200                            '050618')                                   00
310300         MOVE '   05' TO H-PSF-CBSA.                                    02
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '070004')                                   00
310700         MOVE '   07' TO H-PSF-CBSA.                                    02
310900                                                                        00
311000     IF (L-PSF-PROV-OSCAR = '100048' OR                                 00
                                  '100134')
311100         MOVE '   10' TO H-PSF-CBSA.                                    02
311300                                                                        00
311400     IF (L-PSF-PROV-OSCAR = '130018')                                   00
311500         MOVE '   13' TO H-PSF-CBSA.                                    02
311300                                                                        00
311400     IF (L-PSF-PROV-OSCAR = '140167')                                   00
311500         MOVE '   14' TO H-PSF-CBSA.                                    02
310900                                                                        00
311000     IF (L-PSF-PROV-OSCAR = '150051' OR                                 00
                                  '150078')
311100         MOVE '   15' TO H-PSF-CBSA.                                    02
311300                                                                        00
311400     IF (L-PSF-PROV-OSCAR = '170137')                                   00
311500         MOVE '   17' TO H-PSF-CBSA.                                    02
311700                                                                        00
311800     IF (L-PSF-PROV-OSCAR = '190048' OR                                 00
311800                            '190110')                                   00
311900         MOVE '   19' TO H-PSF-CBSA.                                    02
312100                                                                        00
311800     IF (L-PSF-PROV-OSCAR = '230042' OR                                 00
311800                            '230078')                                   00
312300         MOVE '   23' TO H-PSF-CBSA.                                    02
312100                                                                        00
311800     IF (L-PSF-PROV-OSCAR = '240037' OR                                 00
311800                            '240122')                                   00
312300         MOVE '   24' TO H-PSF-CBSA.                                    02
312500                                                                        00
312600     IF (L-PSF-PROV-OSCAR = '260006')                                   00
312700         MOVE '   26' TO H-PSF-CBSA.                                    02
313300                                                                        00
313400     IF (L-PSF-PROV-OSCAR = '300009')                                   00
313500         MOVE '   30' TO H-PSF-CBSA.                                    02
313300                                                                        00
313400     IF (L-PSF-PROV-OSCAR = '330268')                                   00
313500         MOVE '   33' TO H-PSF-CBSA.                                    02
313300                                                                        00
313400     IF (L-PSF-PROV-OSCAR = '370054')                                   00
313500         MOVE '   37' TO H-PSF-CBSA.                                    02
313700                                                                        00
313800     IF (L-PSF-PROV-OSCAR = '380040' OR                                 00
314200                            '380084')                                   00
313900         MOVE '   38' TO H-PSF-CBSA.                                    02
314100                                                                        00
314200     IF (L-PSF-PROV-OSCAR = '390181' OR                                 00
314200                            '390183' OR                                 00
314200                            '390201')                                   00
314300         MOVE '   39' TO H-PSF-CBSA.                                    00
313300                                                                        00
313400     IF (L-PSF-PROV-OSCAR = '440135')                                   00
313500         MOVE '   44' TO H-PSF-CBSA.                                    02
314100                                                                        00
314200     IF (L-PSF-PROV-OSCAR = '450052' OR                                 00
314200                            '450078' OR                                 00
314200                            '450243' OR                                 00
314200                            '450276' OR                                 00
314200                            '450348')                                   00
314300         MOVE '   45' TO H-PSF-CBSA.                                    00
314100                                                                        00
314200     IF (L-PSF-PROV-OSCAR = '500023' OR                                 00
314200                            '500043' OR                                 00
314200                            '500086' OR                                 00
314200                            '500103' OR                                 00
314200                            '500122' OR                                 00
314200                            '500147' OR                                 00
314200                            '500148')                                   00
314300         MOVE '   50' TO H-PSF-CBSA.                                    00
314500                                                                        00
314600 5120-SEC401-2006-EXIT.                                                 02
314610     EXIT.                                                              02
314500                                                                        00
      *************************************************************
      *  SET FLAG IF APC = 0033                                   *
      *    - TERMINATE PROCESS IF 0033 LOCATED                    *
      *                                                           *
      *************************************************************

       5125-INIT.

             IF OPPS-APC (LN-SUB) = '0033'
                MOVE 'Y' TO APC33-FLAG.

             IF OPPS-HCPCS (LN-SUB) = 'C1820'
                MOVE 'Y' TO C1820-OFFSET-FLAG.

       5125-INIT-EXIT.
           EXIT.

      ***************************************************************
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1, 2,OR 4)*
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0 OR 1 OR 2          *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM DENIAL/REJECT FLAG  = TO 1     *
      *                 AND (APC NOT = 0033 OR 0034 OR 0322 OR      *
      *                      0323 OR 0324 OR 0325 OR 0373 OR 0374)) *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0              *
      *               - OR (APC 0033 IS NOT ON THE CLAIM            *
      *                     AND SERVICE INDICATOR = 'P'             *
      *                     OR  APC = 0322-0325,0373,0374)          *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      ***************************************************************
       5150-INIT.

             MOVE  01  TO A-RETURN-CODE (LN-SUB).

      ***************************************************************
      * OVER-RIDE SERVICE UNITS FOR APC 0339 - EFFECTIVE 04/01/2002 *
      *   - CHANGE UNIT VALUE TO 1                                  *
      ***************************************************************

             IF OPPS-APC (LN-SUB) = '0339'
                  MOVE 1 TO OPPS-SRVC-UNITS (LN-SUB).

             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 5250-CALC-DISCOUNT
                THRU 5250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 5150-INIT-EXIT.

      ***************************************************************
      *  EFFECTIVE AS OF 04-01-2002                                 *
      *    - TOTAL DEVICE OFFSET                                    *
      ***************************************************************

             IF OPPS-SRVC-IND (LN-SUB) = ' H'
                MOVE 'Y' TO C-FLAG
                COMPUTE H-TOT-HTD-UNITS = H-TOT-HTD-UNITS
                        + H-SRVC-UNITS.

             IF C1820-OFFSET-FLAG = 'Y'
                PERFORM 5160-TOTAL-OFFSET
                   THRU 5160-TOTAL-OFFSET-EXIT.

             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C'
              OR ' E' OR ' F' OR ' G' OR ' H' OR ' K' OR
              ' L' OR ' N' OR ' P' OR ' S' OR ' T' OR ' V' OR
              ' X' OR ' W' OR ' Y' OR ' Z' OR ' M') THEN
                MOVE  40  TO A-RETURN-CODE (LN-SUB)
                GO TO 5150-INIT-EXIT
              ELSE
                MOVE  01  TO A-RETURN-CODE (LN-SUB).

             IF OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' L' OR ' W' OR ' Y' OR ' Z' OR ' M'
                MOVE  41  TO A-RETURN-CODE (LN-SUB)
                GO TO 5150-INIT-EXIT.

               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'
                 IF OPPS-PKG-FLAG (LN-SUB) = '0' OR '1' OR '2'
                                             OR '3' OR '4'
                   IF (OPPS-LITEM-DR-FLAG (LN-SUB) = '0' OR
                       OPPS-LITEM-DR-FLAG (LN-SUB) = '1' AND
                       (OPPS-APC (LN-SUB) = '0033' OR '0034'
                       OR '0322' OR '0323' OR '0324' OR '0325'
                       OR '0373' OR '0374')) OR
                      (OPPS-LITEM-ACT-FLAG (LN-SUB) = '1')
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                             OR ' 2' OR ' 3' OR ' 4' OR ' 5' OR ' 6'
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR
                            ((APC33-FLAG = 'Y') AND
                             ((OPPS-SRVC-IND (LN-SUB) = ' P') OR
                             (OPPS-APC (LN-SUB) = '0322' OR '0323'
                              OR '0324' OR '0325' OR '0373'
                              OR '0374')))
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

                    IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                       COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                            H-SUB-CHRG
                    END-IF
                    IF (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                       COMPUTE H-TOT-N-CHRG = H-SUB-CHRG
                                  + H-TOT-N-CHRG
                       MOVE 'Y' TO N-FLAG
                    END-IF
                    IF (OPPS-APC (LN-SUB) = '0000') OR
                       (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                       MOVE 42 TO A-RETURN-CODE (LN-SUB)
                       GO TO 5150-INIT-EXIT
                    END-IF
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 5150-INIT-EXIT
                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2
                      PERFORM 5175-APC-LOOKUP
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 5150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 5150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 5150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 5150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 5150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 5150-INIT-EXIT.

      ***************************************************************
      *   NEW LOGIC FOR PROCESSING BLOOD DEDUCTIBLE                 *
      *  EFFECTIVE AS OF 07-01-2005                                 *
      *    - TOTAL BLOOD CODE CHARGES                               *
      *      - WHEN PAYMENT ADJUSTMENT FLAG = '5' OR '6'            *
      ***************************************************************

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE H-TOT-38X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' OR ' 6'
                COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X-39X.
********************************************************

             IF A-RETURN-CODE (LN-SUB) = 01
                PERFORM 5300-COIN-DEDUCT
                   THRU 5300-COIN-DEDUCT-EXIT.


      ***************************************************************
      *   BLOOD DEDUCTIBLE LINE PROCESSING                          *
      *   05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD  *
      *                DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.   *
      *                FIX EFFECTIVE RETROACTIVE TO 01/01/2006.     *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01
                SET W6BD-INDX TO 1
                SEARCH W6BD-ENTRY VARYING W6BD-INDX
                   AT END
                      GO TO 5150-INIT-EXIT
                WHEN W-2006-BLOOD-HCPCS (W6BD-INDX) =
                                              OPPS-HCPCS (LN-SUB)
                 IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                   MOVE W-2006-BLOOD-RANK (W6BD-INDX) TO H-BLOOD-RANK
                   MOVE OPPS-LITEM-DOS (LN-SUB) TO H-BLD-DOS
                   PERFORM 5375-BLOOD-DEDUCT
                      THRU 5375-BLOOD-DEDUCT-EXIT
                 END-IF.

       5150-INIT-EXIT.
           EXIT.

      ***************************************************************
      *  COMPUTE TOTAL OFFSET FROM TABLE 5 FOR DEVICES              *
      *      - EFFECTIVE AS OF 01-01-2003                           *
      *      - CONTINUE FOR   01-01-2004                            *
      *      - CONTINUE FOR   01-01-2005                            *
      *        - SEARCH TABLE OPPSOF04                              *
      *          - WHERE ALL OFFSET VALUES EQUAL ZERO               *
      ***************************************************************
       5160-TOTAL-OFFSET.

             MOVE OPPS-GRP (LN-SUB) TO W-OFF-APC.
             SEARCH ALL WOO-ENTRY4
                AT END
                   GO TO 5160-TOTAL-OFFSET-EXIT
                WHEN WOO-APC4 (WOO-INDX4) = W-OFF-APC
                   PERFORM 5161-TOTAL-OFFSET-AMT THRU
                           5161-TOTAL-OFFSET-AMT-EXIT.

       5160-TOTAL-OFFSET-EXIT.
           EXIT.

       5161-TOTAL-OFFSET-AMT.

           IF WOO-OFFSET4 (WOO-INDX4) EQUAL 0
              GO TO 5161-TOTAL-OFFSET-AMT-EXIT.

           COMPUTE H-TOTAL-OFFSET = H-TOTAL-OFFSET
              + (WOO-OFFSET4 (WOO-INDX4) * H-DISC-RATE
               * H-SRVC-UNITS).
           COMPUTE H-TOT-OFF-UNITS = H-TOT-OFF-UNITS
              + H-SRVC-UNITS.

           IF H-TOTAL-OFFSET < 0
              MOVE 0 TO H-TOTAL-OFFSET.

       5161-TOTAL-OFFSET-AMT-EXIT.
           EXIT.

      ***************************************************************
      *  SEARCH APC TABLE - MOVE VALUES TO HOLD AREA FOR PROCESSING *
      *      - ADJUST TOTAL CHARGE FOR DELETED APC'S                *
      ***************************************************************
       5175-APC-LOOKUP.

             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)
               IF WAR-RATEX (W-SUB2) = 'DELETED'
                 MOVE 30 TO A-RETURN-CODE (LN-SUB)
                 COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                      H-SUB-CHRG
               ELSE
                 MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                 MOVE WAR-RANK (W-SUB2) TO H-RANK
                 MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                 MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                 MOVE WAR-PPCT (W-SUB2) TO H-PPCT
             ELSE
                SUBTRACT 1 FROM W-SUB2
                IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                  GO TO 5175-APC-LOOKUP
                ELSE
                   MOVE 0 TO H-APC-PYMT
                             H-RANK
                             H-MIN-COIN
                             H-NAT-COIN
                             H-PPCT.

       5175-APC-LOOKUP-EXIT.
           EXIT.

      ***************************************************************
      *  IF DATE OF SERVICE BETWEEN 12/31/2002 AND 04/01/2003       *
      *    IF HCPCS CODE = C9114 OR C9115 ADJUST PAYMENT AND        *
      *    COINSURANCE AMOUNTS - LOGIC REMOVED FOR 20050101         *
      ***************************************************************

      ***************************************************************
      *    SEARCH WAGE INDEX TABLE AND SELECT THE WAGE INDEX        *
      *    WHEN EQUAL TO PROVIDER SPECIFIC WAGE INDEX               *
      *    IF WAGE INDEX NOT LOCATED                                *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      ***************************************************************
       5200-CALC-WAGEINDX.

             MOVE WCD-MAX TO WCD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WCD-DATE (WCD-SUB)
                 SUBTRACT 1 FROM WCD-SUB
             END-PERFORM.

             SEARCH ALL WCM-ENTRY
                AT END
                   MOVE  50  TO A-CLM-RTN-CODE
                   GO TO 5200-CALC-WAGEINDX-EXIT
                WHEN WCM-CBSA (WCM-INDX) = H-PSF-CBSA
                  MOVE WCM-PTR (WCM-INDX) TO W-SUB3
                  PERFORM 5210-WAGE-LOOKUP.

             IF H-WINX1 = 0 THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       5200-CALC-WAGEINDX-EXIT.
           EXIT.

       5210-WAGE-LOOKUP.

             IF WCW-DTCD (W-SUB3) NOT > WCD-DTCD (WCD-SUB)
                IF L-PSF-SPEC-PYMT-IND = 'Y'
                  MOVE WCW-WINX2 (W-SUB3) TO H-WINX1
                ELSE
                    MOVE WCW-WINX1 (W-SUB3) TO H-WINX1
             ELSE
                SUBTRACT 1 FROM W-SUB3
                IF W-SUB3 > WCM-PTR (WCM-INDX - 1)
                   GO TO 5210-WAGE-LOOKUP
                ELSE
                   MOVE 0 TO H-WINX1.

       5210-WAGE-LOOKUP-EXIT.
           EXIT.

      ***************************************************************
      *    CALCULATE DISCOUNT FACTOR BASED ON THE DISCOUNT          *
      *    INDICATOR PASSED BY THE OCE: VALUE 1 - 8                 *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      ***************************************************************
       5250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 5250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     MOVE  38  TO A-RETURN-CODE (LN-SUB).

       5250-CALC-DISCOUNT-EXIT.
           EXIT.

      ***************************************************************
      *    DETERMINE THE DEDUCTIBLE SEQUENCE. DEDUCTIBLE WILL BE    *
      *    TAKEN FROM OPPS SERVICES FIRST, THEN FROM ANY OTHER      *
      *    TYPES OF SERVICES FROM THE CLAIM.                        *
      *       - SET POINTERS TO THE HIGHEST RANKED PERCENTAGE       *
      *         (LARGEST NATIONAL UNADJUSTED COINSURANCE /          *
      *          THE APC PAYMENT)                                   *
      *       - MOVE ALL PRICING VARIABLES TO STAGING AREA          *
      ***************************************************************
       5300-COIN-DEDUCT.

             ADD 1 TO W-LNC-MAX.
             SET W-LP-INDX TO W-LNC-MAX.
             PERFORM 5350-STAGE-ENTRY
                THRU 5350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).
             MOVE LN-SUB TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX1    TO W-WINX1 (W-LP-INDX).
             MOVE H-RANK     TO W-RANK (W-LP-INDX).
             MOVE H-PPCT     TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
              UNTIL PS-SUB > L-PSF-APC-LINE-CNT
              IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS * H-DISC-RATE
                MOVE 25 TO A-RETURN-CODE (LN-SUB)
                MOVE L-PSF-APC-LINE-CNT TO PS-SUB
              END-IF
             END-PERFORM.

       5300-COIN-DEDUCT-EXIT.
           EXIT.

       5350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       5350-STAGE-ENTRY-EXIT.
           EXIT.

      ***************************************************************
      *    DETERMINE THE BLOOD DEDUCTIBLE SEQUENCE. DEDUCTIBLE      *
      *    WILL BE CALCULATED BASED ON RANKING.                     *
      *       - SET POINTERS TO THE HIGHEST RANKED APC              *
      *         (SMALLEST UNADJUSTED APC PAYMENT)                   *
      *       - MOVE ALL PRICING VARIABLES TO STAGING AREA          *
      ***************************************************************
       5375-BLOOD-DEDUCT.

             ADD 1 TO W-BLD-MAX.
             SET W-BD-INDX TO W-BLD-MAX.
             PERFORM 5385-STAGE-ENTRY
                THRU 5385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLD-RNK NOT < W-BD-RNK (W-BD-INDX - 1).
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX1    TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK  TO W-BD-RANK (W-BD-INDX).
             MOVE H-BLD-DOS TO W-BD-DOS (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).

             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
              UNTIL PS-SUB > L-PSF-APC-LINE-CNT
              IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS * H-DISC-RATE
                MOVE 25 TO A-RETURN-CODE (LN-SUB)
                MOVE L-PSF-APC-LINE-CNT TO PS-SUB
              END-IF
             END-PERFORM.

       5375-BLOOD-DEDUCT-EXIT.
           EXIT.

       5385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       5385-STAGE-ENTRY-EXIT.
           EXIT.

      ***************************************************************
      *    FIRST STEP IN DETERMINING A LINE ITEM PRICE.             *
      *    CHECK ALL APPROPRIATE FLAGS AND INDICATORS PASSED        *
      *    BY THE OCE.                                              *
      *      - SET RETURN CODES TO INDICATE ERRORS OR STATUS        *
      *        - '20' - LINE PROCESSED BUT PAYMENT = 0              *
      *                 - BENE DEDUCTIBLE => ADJUSTED PAYMENT       *
      *                                                             *
      ***************************************************************
       5400-CALCULATE.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 5400-CALCULATE-EXIT.

             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 5550-CALC-STANDARD
                   THRU 5550-CALC-STANDARD-EXIT
             ELSE
                GO TO 5400-CALCULATE-EXIT.

      ***************************************************************
      *  SET GJK FLAG                                               *
      *    - TEST LINE ITEM DATE OF SERVICE > 20010630              *
      *    - TOTAL DRUG / DEVICE COINSURANCE                        *
      ***************************************************************

             IF (A-RETURN-CODE (LN-SUB) <  30)
               PERFORM 5450-ADJ-PROC-COIN
                  THRU 5450-ADJ-PROC-COIN-EXIT
             ELSE
               NEXT SENTENCE.

      ***************************************************************
      *  SET ST0 AND STVX FLAGS                                     *
      *    - TEST LINE ITEM DATE OF SERVICE > 20020331              *
      *    - TOTAL PROCEDURE CHARGES AND BUNDLED CHARGES            *
      ***************************************************************

             PERFORM 5500-ADJ-CHRGS
                THRU 5500-ADJ-CHRGS-EXIT.

             IF A-RETURN-CODE (LN-SUB) <  30
               COMPUTE A-TOTAL-CLM-DEDUCT =
                       H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT
               COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT
               COMPUTE A-BLOOD-DEDUCT-DUE =
                     A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT
               MOVE H-LITEM-PYMT TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN TO A-RED-COIN (LN-SUB)
               IF H-RED-COIN > H-NAT-COIN
                 MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF
               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.
             MOVE ZERO TO LINE-HOLD-ITEMS.

       5400-CALCULATE-EXIT.
           EXIT.

      ***************************************************************
      *  SET GJK FLAG                                               *
      *    - STAGE BY SERVICE INDICATOR                             *
      *                                                             *
      ***************************************************************
       5450-ADJ-PROC-COIN.

             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX1 (W-LP-INDX) + .4)
                  IF H-NEW-WGNAT > H-IP-LIMIT
                    MOVE H-IP-LIMIT TO H-NEW-WGNAT
                  END-IF
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                MOVE 1 TO H-DCP-CODE
                PERFORM 5455-SEARCH-KEY
                   THRU 5455-SEARCH-KEY-EXIT
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                        H-TOTAL-LN-DEDUCT - H-LITEM-REIM
                                   - H-LN-BLOOD-DEDUCT
                   MOVE 'Y' TO GJK-FLAG
                   MOVE 1 TO H-DCP-CODE
                   PERFORM 5455-SEARCH-KEY
                      THRU 5455-SEARCH-KEY-EXIT
                   MOVE 2 TO H-DCP-CODE
                   ADD 1 TO W-DCP-MAX
                   SET W-DCP-INDX TO W-DCP-MAX
                   PERFORM 5475-STAGE-DCP-ENTRY
                     THRU 5475-STAGE-DCP-ENTRY-EXIT
                       UNTIL W-DCP-INDX = 1 OR
                       H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       5450-ADJ-PROC-COIN-EXIT.
           EXIT.

       5455-SEARCH-KEY.

             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX
                AT END
                   PERFORM 5460-ADD-ENTRY
                      THRU 5460-ADD-ENTRY-EXIT
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 5465-UPDATE-ENTRY
                      THRU 5465-UPDATE-ENTRY-EXIT.

       5455-SEARCH-KEY-EXIT.
           EXIT.

       5460-ADD-ENTRY.

             ADD 1 TO W-DCP-MAX.
             SET W-DCP-INDX TO W-DCP-MAX.
             PERFORM 5475-STAGE-DCP-ENTRY
               THRU 5475-STAGE-DCP-ENTRY-EXIT
                UNTIL W-DCP-INDX = 1 OR
                  H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       5460-ADD-ENTRY-EXIT.
           EXIT.

       5465-UPDATE-ENTRY.

             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 5485-REPLACE-TYPE1
                     THRU 5485-REPLACE-TYPE1-EXIT
               ELSE
                  PERFORM 5480-RANK-COIN
                     THRU 5480-RANK-COIN-EXIT.

       5465-UPDATE-ENTRY-EXIT.
           EXIT.

       5475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       5475-STAGE-DCP-ENTRY-EXIT.
             EXIT.

       5480-RANK-COIN.

             IF H-NEW-WGNAT > W-DCP-WGNAT (W-DCP-INDX)
               MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
               MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
               MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
               MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       5480-RANK-COIN-EXIT.
           EXIT.

       5485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       5485-REPLACE-TYPE1-EXIT.
           EXIT.

       5500-ADJ-CHRGS.

      *****************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY              *
      *****************************************************
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                 OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                MOVE 'Y' TO ST0-FLAG.

             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                 OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX)
                               + H-TOT-ST-CHRG
                COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT
                               + H-TOT-ST-PYMT.

             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                OR ' X' OR ' P')
                AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT
                               + H-TOT-STVX-PYMT.

       5500-ADJ-CHRGS-EXIT.
           EXIT.
      ***************************************************************
      * 1. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *     - DESCENDING UNTIL DEDUCTIBLE = 0.                      *
      * 2. CALCULATE THE STANDARD LINE PRICE                        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS                *
      *          * DISCOUNT FACTOR)                                 *
      *     - WAGE ADJUST 60% OF THE APC PAYMENT ONLY               *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA.                     *
      *                                                             *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *       AND DRUGS                                             *
      ***************************************************************
       5550-CALC-STANDARD.

             MOVE 0 TO H-BLOOD-FRACTION.
             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' V'
                        OR ' T' OR ' P' OR ' X' THEN
JB              PERFORM 5550-SCH-ADJ THRU 5550-SCH-ADJ-EXIT
             ELSE
               IF OPPS-SRVC-IND (LN-SUB) = ' H' THEN
                 IF OPPS-PYMT-IND (LN-SUB) = ' 6' THEN
                   MOVE 0 TO H-BLOOD-FRACTION
                   PERFORM 5555-CALC-H-STANDARD
                      THRU 5555-CALC-H-STANDARD-EXIT
                   PERFORM 5560-CALC-BENE-DEDUCT
                      THRU 5560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 5550-CALC-STANDARD-EXIT
                 END-IF
               ELSE
               IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' THEN
                IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 7' THEN
                  MOVE 0 TO H-BLOOD-FRACTION
                  PERFORM 5550-CALC-GJK
                     THRU 5550-CALC-GJK-EXIT
                  PERFORM 5560-CALC-BENE-DEDUCT
                     THRU 5560-CALC-BENE-DEDUCT-EXIT
                ELSE
                 MOVE  41  TO A-RETURN-CODE (LN-SUB)
                 GO TO 5550-CALC-STANDARD-EXIT
                END-IF
               END-IF.
JB    *
JB    * THE FOLLOWING SEARCH IS AN APC TABLE SEARCH TO SEE IF PRESENT
JB    *
JB           IF H-LITEM-PYMT > 0
JB             SET WAC-INDX TO 1
JB             SEARCH WAC-ENTRY VARYING WAC-INDX
JB                AT END
JB                  COMPUTE H-LITEM-REIM ROUNDED =
JB                  ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
JB                    H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX)
JB                  COMPUTE H-NAT-COIN = H-LITEM-PYMT -
JB                  H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
JB                  MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN
JB             WHEN OPPS-APC(LN-SUB) = WAC-CODE (WAC-INDX)
JB                COMPUTE H-LITEM-REIM ROUNDED =
JB                ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
JB                   H-LN-BLOOD-DEDUCT) * .8
JB                COMPUTE H-NAT-COIN = H-LITEM-PYMT -
JB                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
JB                MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN
JB           ELSE
              NEXT SENTENCE.

             IF H-MIN-COIN > 0
               IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' H'
                        OR ' K'
                 COMPUTE H-MIN-COIN ROUNDED = H-MIN-COIN *
                 (W-SRVC-UNITS (W-LP-INDX) -
                    (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION))
                   * W-DISC-RATE (W-LP-INDX)
               ELSE
                 IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                   COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25
                 ELSE
                   COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                 END-IF
               END-IF
             END-IF.

             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.
             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                  MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                         (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                            (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       5550-CALC-STANDARD-EXIT.
           EXIT.



JB     5550-SCH-ADJ.
JB    *  IN THE BELOW IF STATEMENT, THE FOLLOWING MUST BE TRUE TO
JB    *  DO THE COMPUTE. OTHERWISE THE ELSE PATH IS TAKEN:
JB    *
JB    *  EITHER THE L-PSF-GEO-CBSA OR THE L-PSF-WI-CBSA MUST BE A VALUE
JB    *  OF '   01' THRU '   99' AND THE L-PSF-PROV-TYPE MUST BE
JB    *  A '16' OR '17' OR '21' OR '22'
JB    *
JB           MOVE L-PSF-GEO-CBSA TO GEO-CBSA-FLAG.
JB           MOVE L-PSF-WI-CBSA  TO WI-CBSA-FLAG.
JB
JB           IF ((RURAL-GEO OR RURAL-WI) AND
JB               (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22'))
JB                COMPUTE H-SCH-PYMT ROUNDED =
JB                             (W-APC-PYMT (W-LP-INDX) * 1.071)
EF           ELSE
EF               MOVE W-APC-PYMT (W-LP-INDX) TO H-SCH-PYMT.
JB
JB           COMPUTE H-LITEM-PYMT ROUNDED =
JB               (((H-SCH-PYMT * .60) *
JB                       W-WINX1 (W-LP-INDX))
JB                           + (H-SCH-PYMT * .40)) *
JB             W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX).
JB             PERFORM 5560-CALC-BENE-DEDUCT
JB                THRU 5560-CALC-BENE-DEDUCT-EXIT.
JB     5550-SCH-ADJ-EXIT.
JB         EXIT.

      ***************************************************************
      * 1. CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR        *
      *    TYPES G  OR K.                                           *
      * 2. EFFECTIVE 01/01/2003 REMOVE PRO RATA REDUCTION FOR       *
      *       ALL SERVICE INDICATOR 'G' PAYMENTS                    *
      ***************************************************************

       5550-CALC-GJK.

             IF (OPPS-HCPCS(LN-SUB) = ('P9010' OR 'P9016' OR 'P9021'
                          OR 'P9022' OR 'P9038' OR 'P9039' OR 'P9040'
                          OR 'P9051' OR 'P9054' OR 'P9056' OR 'P9057'
                          OR 'P9058') AND
                 OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6'))

                  PERFORM 5550-SET-BLOOD-FRACTION
                   THRU 5550-SET-BLOOD-FRACTION-EXIT
                  PERFORM 5550-ADJ-BLOOD-COST
                   THRU 5550-ADJ-BLOOD-COST-EXIT
             ELSE
                IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                  PERFORM 5550-ADJ-PLATE-COST
                     THRU 5550-ADJ-PLATE-COST-EXIT
                  GO TO 5550-CALC-GJK-EXIT
             ELSE
               COMPUTE H-LITEM-PYMT ROUNDED =
               W-APC-PYMT (W-LP-INDX) * W-SRVC-UNITS (W-LP-INDX)
                      * W-DISC-RATE (W-LP-INDX)
               GO TO 5550-CALC-GJK-EXIT.

             COMPUTE H-LITEM-PYMT ROUNDED =
             W-BD-APC-PYMT (W-BD-INDX) * W-BD-SRVC-UNITS (W-BD-INDX)
                      * W-BD-DISC-RATE (W-BD-INDX).

             COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                 H-LITEM-PYMT * H-BLOOD-FRACTION.

             SET W-BD-INDX UP BY 1.

       5550-CALC-GJK-EXIT.
           EXIT.

       5550-SET-BLOOD-FRACTION.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              IF H-BENE-PINTS-USED > 0
                IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                   MOVE 1 TO H-BLOOD-FRACTION
                   COMPUTE H-BENE-PINTS-USED =
                     H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)
                ELSE
                  IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                    COMPUTE H-BLOOD-FRACTION =
                      H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                    MOVE 0 TO H-BENE-PINTS-USED
                  ELSE
                     MOVE 0 TO H-BLOOD-FRACTION
              ELSE
                 MOVE 0 TO H-BLOOD-FRACTION
             ELSE
                MOVE 0 TO H-BLOOD-FRACTION.

       5550-SET-BLOOD-FRACTION-EXIT.
           EXIT.

       5550-ADJ-BLOOD-COST.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * H-38X-39X-RATE.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * (1 - H-38X-39X-RATE).

       5550-ADJ-BLOOD-COST-EXIT.
           EXIT.

       5550-ADJ-PLATE-COST.

           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * H-38X-39X-RATE.

           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * (1 - H-38X-39X-RATE).

           COMPUTE H-LITEM-PYMT ROUNDED =
              W-APC-PYMT (W-LP-INDX) * W-SRVC-UNITS (W-LP-INDX)
                      * W-DISC-RATE (W-LP-INDX).

       5550-ADJ-PLATE-COST-EXIT.
           EXIT.

      ***************************************************************
      * 1. CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR        *
      *    TYPE  H.                                                 *
      * 2. EFFECTIVE 04/01/2002 A PRO RATA REDUCTION APPLIES TO     *
      *       ALL SERVICE INDICATOR 'H' PAYMENTS (CURRENTLY .689)   *
      ***************************************************************

       5555-CALC-H-TOT.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.
             IF OPPS-SRVC-IND (LN-SUB) = ' H'
               IF OPPS-PYMT-IND (LN-SUB) = ' 6'
                  COMPUTE H-TOT-H-CHRG =
                     (H-TOT-H-CHRG + H-SUB-CHRG)
               ELSE
                  NEXT SENTENCE
             ELSE
                NEXT SENTENCE.

       5555-CALC-H-TOT-EXIT.
           EXIT.

       5555-CALC-H-STANDARD.

             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

             COMPUTE T-LITEM-PYMT ROUNDED =
               (H-SUB-CHRG * L-PSF-OPCOST-RATIO).

              IF (C-FLAG = 'Y')
                 IF (H-TOT-OFF-UNITS > H-TOT-HTD-UNITS)
                   COMPUTE H-TOTAL-WAOFF ROUNDED =
                     (((H-TOTAL-OFFSET * .60) * A-WINX)
                      + (H-TOTAL-OFFSET * .40))
                      * (H-TOT-HTD-UNITS / H-TOT-OFF-UNITS)
                   PERFORM 5700-CALC-H-OFFSET
                      THRU 5700-CALC-H-OFFSET-EXIT
                 ELSE
                    COMPUTE H-TOTAL-WAOFF ROUNDED =
                      ((H-TOTAL-OFFSET * .60) * A-WINX)
                       + (H-TOTAL-OFFSET * .40)
                    PERFORM 5700-CALC-H-OFFSET
                       THRU 5700-CALC-H-OFFSET-EXIT
              ELSE
                 NEXT SENTENCE.

                IF T-LITEM-PYMT < 0 THEN
                   MOVE 0 TO H-LITEM-PYMT
                ELSE
                   MOVE T-LITEM-PYMT TO H-LITEM-PYMT.


       5555-CALC-H-STANDARD-EXIT.
             EXIT.

       5560-CALC-BENE-DEDUCT.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 4'
                GO TO 5560-CALC-BENE-DEDUCT-EXIT.
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                  H-LITEM-PYMT - H-LN-BLOOD-DEDUCT
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                      H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       5560-CALC-BENE-DEDUCT-EXIT.
           EXIT.

      *********************************************************************
      ** - NEW FOR JANUARY 2004                                          **
      **   - CHECK >= 20040101 AND SRVC-IND = 'K'                        **
      **      - DISCONTINUE OUTLIER PROCESS                              **
      *********************************************************************
       5600-ADJ-CHRG-OUTL.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *********************************************************************
      ** - NEW FOR JANUARY 2005                                          **
      **   - TURN OFF OUTLIER PROCESS FOR SPECIFIED K TYPE APCS          **
      **                                                                 **
      ** 05/12/2009 - ALTERED LOGIC TO ALLOW ALL BLOOD LINES (WITH A     **
      **              STATUS INDICATOR = ' K') TO ENTER OUTLIER LOGIC    **
      **                                                                 **
      *********************************************************************
             MOVE 'N' TO W-BLD-HCPCS-FLAG.
             SET WBLH-INDX TO 1.
             SEARCH WBLHCPCS-ENTRY VARYING WBLH-INDX
                AT END
                   MOVE 'N' TO W-BLD-HCPCS-FLAG
                WHEN W-2005-2008-BLOOD-HCPCS (WBLH-INDX) =
                     OPPS-HCPCS (LN-SUB)
                   MOVE 'Y' TO W-BLD-HCPCS-FLAG.

             IF (OPPS-SRVC-IND (LN-SUB) = ' G' OR ' H' OR ' N') OR
                (OPPS-PKG-FLAG (LN-SUB) = '4') OR
                (OPPS-SRVC-IND (LN-SUB) = ' K' AND
                   W-BLD-HCPCS-FLAG = 'N')
                GO TO 5600-ADJ-CHRG-OUTL-EXIT.

      *----------------------------------------------------------*
      * CODE COMMENTED OUT 05/12/2009 & REPLACED WITH CODE ABOVE *
      *----------------------------------------------------------*
      *      IF (OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' OR
      *        ' H' OR ' N') OR (OPPS-PKG-FLAG (LN-SUB) = '4')
      *         GO TO 5600-ADJ-CHRG-OUTL-EXIT.


      *****************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY              *
      *****************************************************
             IF (ST0-FLAG = 'Y') AND ((OPPS-SRVC-IND (LN-SUB)
                 = ' T' ) OR ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                             (OPPS-HCPCS (LN-SUB) > '09999' AND
                              OPPS-HCPCS (LN-SUB) < '70000')))
                   AND (H-TOT-ST-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND
                ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                  ' X' OR ' P')
                   AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3'))
                   AND (H-TOT-STVX-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                   (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)
                COMPUTE H-SUB-CHRG ROUNDED =
                     (H-CHRG-RATE * H-TOT-N-CHRG)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.

              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND
                ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                  ' X' OR ' P')
                  AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3'))
                  AND (H-TOT-STVX-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                     (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)
                COMPUTE H-SUB-CHRG ROUNDED =
                     (H-CHRG-RATE * H-TOT-N-CHRG)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.
      *********************************************************************
      ** - NEW FOR JANUARY 2005                                          **
      **   - PROVIDER RANGE FOR CMHC                                     **
      **   - COMPUTE H-LITEM-OUTL-PYMT USING NEW FORMULA                 **
      **   - THIS IS THE OUTLIER THRESHOLD AMOUNT                        **
      *********************************************************************

               MOVE 1.75 TO H-OUTLIER-FACTOR.
               MOVE .50 TO H-OUTLIER-PCT.
               COMPUTE H-COST ROUNDED =
                  W-SUB-CHRG (W-LP-INDX) * L-PSF-OPCOST-RATIO.
               COMPUTE H-APC-ADJ-PYMT ROUNDED =
                  H-OUTLIER-FACTOR * A-LITEM-PYMT (LN-SUB).
               IF (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999')
                  MOVE 3.4 TO H-OUTLIER-FACTOR
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED = (H-COST -
                    (H-OUTLIER-FACTOR * A-LITEM-PYMT (LN-SUB))) *
                     H-OUTLIER-PCT
               ELSE
                IF (H-COST > H-APC-ADJ-PYMT) AND
                   (H-COST > A-LITEM-PYMT (LN-SUB) + 1250)
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
                    (H-COST - H-APC-ADJ-PYMT) * H-OUTLIER-PCT
                ELSE
                   MOVE ZERO TO H-LITEM-OUTL-PYMT.

             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

             IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                       H-LITEM-OUTL-PYMT
               MOVE 0 TO H-LITEM-OUTL-PYMT.

       5600-ADJ-CHRG-OUTL-EXIT.
           EXIT.

      ***************************************************************
      * 1. RE-CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR     *
      *    TYPE H.                                                  *
      * 2. SUBTRACT WAGE ADJUSTED OFFSET AMOUNT FROM SI TYPE 'H'    *
      *    WITH HCPCS CODE BEGINNING WITH 'C'                       *
      * 2. EFFECTIVE 04/01/2002                                     *
      ***************************************************************

       5700-CALC-H-OFFSET.

             IF H-TOT-H-CHRG > 0
               COMPUTE H-OFF-RATE ROUNDED =
                    H-SUB-CHRG / H-TOT-H-CHRG
               COMPUTE T-LITEM-PYMT ROUNDED = T-LITEM-PYMT -
                      (H-TOTAL-WAOFF * H-OFF-RATE)
             ELSE
                NEXT SENTENCE.

             IF T-LITEM-PYMT < 0
                MOVE 0 TO T-LITEM-PYMT.

       5700-CALC-H-OFFSET-EXIT.
           EXIT.

       5800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 5810-PROCESS-TYPE1
                   THRU 5810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 5840-PROCESS-TYPE2
                   THRU 5840-PROCESS-TYPE2-EXIT.

       5800-ADJ-STV-REIM-EXIT.
           EXIT.

       5810-PROCESS-TYPE1.

             IF  W-DCP-COIN2 (W-DCP-INDX) > 0
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-WGNAT (W-DCP-INDX) TO H-TOTAL
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-WGNAT (W-DCP-INDX)) /
                                  W-DCP-COIN2 (W-DCP-INDX)
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.
                IF H-RATIO > 1
                    MOVE 1 TO H-RATIO.

       5810-PROCESS-TYPE1-EXIT.
           EXIT.

       5840-PROCESS-TYPE2.

             IF W-DCP-DOS (W-DCP-INDX) =  H-DCP-DOS
                MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB
                COMPUTE H-SHIFT =
                    W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)
                COMPUTE H-TOTAL =
                     A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT
                IF H-TOTAL > H-IP-LIMIT
                   COMPUTE H-SHIFT = H-SHIFT + H-TOTAL
                         - H-IP-LIMIT
                END-IF
                COMPUTE A-ADJ-COIN (LN-SUB) =
                     A-ADJ-COIN (LN-SUB) - H-SHIFT
                COMPUTE A-LITEM-REIM (LN-SUB) =
                   A-LITEM-REIM (LN-SUB) + H-SHIFT
                   MOVE 22 TO A-RETURN-CODE (LN-SUB)
             END-IF.

       5840-PROCESS-TYPE2-EXIT.
           EXIT.

      ***************************************************************
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      ***************************************************************
       5900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.
             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       5900-END-PRICE-RTN-EXIT.
           EXIT.

       6000-PROCESS-MAIN-NEW.

      **********************************************************        00000100
      * COMMENT:                                               *        00000200
      *   1ST LOOP                                             *        00000300
      *   LOOP THE CLAIM TO FIND APC '0033'                    *        00000300
      **********************************************************        00000600
              PERFORM 6100-INIT
                 THRU 6100-INIT-EXIT.

              IF H-WINX1 = 0 AND A-CLM-RTN-CODE = 01
                MOVE 51 TO A-CLM-RTN-CODE.

              IF A-CLM-RTN-CODE >= 50
                 GOBACK.
              MOVE H-WINX1 TO A-WINX.
              PERFORM 6125-INIT
                 THRU 6125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

      **********************************************************        00000100
      * COMMENT:                                               *        00000200
      *   2ND LOOP                                             *        00000300
      **********************************************************        00000600
              MOVE 0 TO W-DCP-MAX W-BLD-MAX.
              PERFORM 6150-INIT
                 THRU 6150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

      **********************************************************        00000100
      * COMMENT:                                               *        00000200
      *   BREAKING OUT BLOOD PRODUCT & LABOR PORTION           *        00000300
      **********************************************************        00000600
              IF H-TOT-38X-39X > 0
                 COMPUTE H-38X-39X-RATE ROUNDED =
                    H-TOT-38X / H-TOT-38X-39X.

      **********************************************************        00000100
      * COMMENT:                                               *        00000200
      *   3RD LOOP                                             *        00000300
      *   TOTALS H RELEATED CHARGES.                           *        00000300
      **********************************************************        00000600
              MOVE 0 TO W-DCP-MAX.
              PERFORM 6555-CALC-H-TOT
                 THRU 6555-CALC-H-TOT-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.

              SET W-BD-INDX TO 1.
              MOVE 0 TO W-DCP-MAX.
              PERFORM 6400-CALCULATE
                 THRU 6400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.

              PERFORM 6600-ADJ-CHRG-OUTL
                 THRU 6600-ADJ-CHRG-OUTL-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX


              IF GJK-FLAG = 'Y'
                PERFORM 6800-ADJ-STV-REIM
                   THRU 6800-ADJ-STV-REIM-EXIT
                      VARYING W-DCP-INDX FROM 1 BY 1
                        UNTIL W-DCP-INDX > W-DCP-MAX
              ELSE
                 NEXT SENTENCE.

              PERFORM 6900-END-PRICE-RTN
                 THRU 6900-END-PRICE-RTN-EXIT.

       6000-PROCESS-MAIN-NEW-EXIT.
           EXIT.

      ***************************************************************
      *    INITIALIZE WORKING STORAGE HOLD AREAS                    *
      *    AND ADDITIONAL VARIABLES TO BE PASSED BACK TO            *
      *    THE STANDARD SYSTEM.                                     *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      * 05/12/2009 - W-BLD-HCPCS-FLAG ADDED                         *
      ***************************************************************
       6100-INIT.

             MOVE 01 TO A-CLM-RTN-CODE.
             MOVE 'N' TO APC33-FLAG GJK-FLAG ST0-FLAG
                         N-FLAG C-FLAG C1820-OFFSET-FLAG
                         W-BLD-HCPCS-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO TO A-OUTLIER-PYMT
                          A-TOTAL-CLM-DEDUCT
                          A-TOT-CLM-CHRG
                          A-TOT-CLM-PYMT
                          A-BLOOD-DEDUCT-DUE
                          A-BLOOD-PINTS-USED
                          A-WINX
                          W-LNC-MAX.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 6100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                   MOVE 54 TO A-CLM-RTN-CODE
                   GO TO 6100-INIT-EXIT
                ELSE
                   IF L-PSF-TERMDT > 0
                      IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                         MOVE 54 TO A-CLM-RTN-CODE
                         GO TO 6100-INIT-EXIT
                      END-IF
                   END-IF.
      **********************************************************        00000100
      * COMMENT:                                               *        00000200
      *   UPDATE EVERY JANUARY                                 *        00000300
      **********************************************************        00000600
             MOVE CAL-VERSION6 TO A-CALC-VERS.
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.
             MOVE WAD-MAX TO WAD-SUB.
      **********************************************************        00000100
      * COMMENT:                                               *        00000200
      *   GET TO PROPER APC DATE BY SERVICE DATE               *        00000300
      *     (WALKS APC DATE TABLE)                             *        00000300
      **********************************************************        00000600
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.
      **********************************************************        00000100
      * COMMENT:                                               *        00000200
      *   CHANGE FOLOWING 2 HARDCODED VALUES EACH YEAR.        *        00000300
      *   GET THIS AMOUNT EACH YEAR FROM JOEY BRYSON.          *        00000300
      *   FOLLOWING MOVES A SPEC WAGE INDX FROM PROV FILE.     *        00000300
      **********************************************************        00000600
             IF L-PSF-SPEC-PYMT-IND = 'Y'
                MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
             ELSE
                IF L-PSF-SPEC-PYMT-IND = ' '
                   MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA
                ELSE
                   IF L-PSF-SPEC-PYMT-IND = '1' OR '2'
                      MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA A-CBSA
                      MOVE L-PSF-SPEC-WGIDX TO H-WINX1
                      MOVE 992 TO H-IP-LIMIT
                      GO TO 6100-INIT-EXIT
                   ELSE
                      MOVE  52  TO A-CLM-RTN-CODE
                      GO TO 6100-INIT-EXIT.

             IF H-PSF-CBSA = SPACE
                MOVE  52  TO A-CLM-RTN-CODE
                GO TO 6100-INIT-EXIT.

             MOVE 992 TO H-IP-LIMIT.

             PERFORM 6120-FLOOR-2007
                THRU 6120-FLOOR-2007-EXIT.

             PERFORM 6120-SEC401-2007
                THRU 6120-SEC401-2007-EXIT.

             MOVE H-PSF-CBSA TO A-CBSA.

      ***********************************************************       00000100
      * COMMENT:                                                *       00000200
      *   IF NOT OVERRIDDEN WAGE INDEX AS OF YET, GO LOOK IT UP *       00000300
      ***********************************************************       00000600
             IF H-WINX1 = 0
                PERFORM 6200-CALC-WAGEINDX
                   THRU 6200-CALC-WAGEINDX-EXIT.

       6100-INIT-EXIT.
           EXIT.

000100*************************************************************           02
000200** NEW 2006 FLOOR AND SEC 401 FOR CBSA                    ***           02
000300*************************************************************           02
      ***********************************************************       00000100
      * COMMENT:                                                *       00000200
      *   SYNC ALL OF THE FOLLOWING WITH INPATIENT.             *       00000300
      *   SEE DAVE PANUSKA, OR FOLLOWER.                        *       00000300
      *   INPATIENT MOVE 'N' TO L-PSF-SPEC-PYMT-IND             *       00000300
      *       OPPS MOVES ' ' TO L-PSF-SPEC-PYMT-IND             *       00000300
      ***********************************************************       00000600
260700 6120-FLOOR-2007.                                                       02
261300                                                                        00
261400        IF H-PSF-CBSA = '   10'                                         00
261500           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
261600           AND L-PSF-PROV-ST = '10'                                     00
261700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
261800               MOVE '   10' TO H-PSF-CBSA.                              00
261300                                                                        00
261400        IF H-PSF-CBSA = '   14'                                         00
261500           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
261600           AND L-PSF-PROV-ST = '14'                                     00
261700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
261800               MOVE '   14' TO H-PSF-CBSA.                              00
260800                                                                        00
260900        IF H-PSF-CBSA = '   26'                                         00
260910           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
261000           AND L-PSF-PROV-ST = '26'                                     00
261100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
261200               MOVE '   26' TO H-PSF-CBSA.                              00
261300                                                                        00
261400        IF H-PSF-CBSA = '   50'                                         00
261500           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
261600           AND L-PSF-PROV-ST = '50'                                     00
261700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
261800               MOVE '   50' TO H-PSF-CBSA.                              00
261300                                                                        00
261400        IF H-PSF-CBSA = '10900'                                         00
261600           AND L-PSF-PROV-ST = '31'                                     00
261700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
261800               MOVE '   31' TO H-PSF-CBSA.                              00
262500                                                                        00
262600        IF H-PSF-CBSA = '19060'                                         00
262700           AND L-PSF-PROV-ST = '21'                                     00
262800               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
262900               MOVE '   21' TO H-PSF-CBSA.                              00
264500                                                                        00
264600        IF H-PSF-CBSA = '22020'                                         00
264800           AND L-PSF-PROV-ST = '24'                                     00
264900               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
265000               MOVE '   24' TO H-PSF-CBSA.                              00
266300                                                                        00
266400        IF H-PSF-CBSA = '24220'                                         00
266500           AND L-PSF-PROV-ST = '24'                                     00
266600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
266700               MOVE '   24' TO H-PSF-CBSA.                              00
267300                                                                        00
267400        IF H-PSF-CBSA = '24580'                                         00
267500           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
267600           AND L-PSF-PROV-ST = '52'                                     00
267700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
267800               MOVE '   52' TO H-PSF-CBSA.                              00
267900                                                                        00
268000        IF H-PSF-CBSA = '25540'                                         00
268100           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
268200           AND L-PSF-PROV-ST = '07'                                     00
268300               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
268400               MOVE '   07' TO H-PSF-CBSA.                              00
269700                                                                        00
269800        IF H-PSF-CBSA = '26580'                                         00
269810           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
269900           AND L-PSF-PROV-ST = '36'                                     00
270000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
270100               MOVE '   36' TO H-PSF-CBSA.                              00
267300                                                                        00
270800        IF H-PSF-CBSA = '29100'                                         00
270900           AND L-PSF-PROV-ST = '52'                                     00
271000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
271100               MOVE '   52' TO H-PSF-CBSA.                              00
271700                                                                        00
271800        IF H-PSF-CBSA = '30300'                                         00
271900           AND L-PSF-PROV-ST = '50'                                     00
272000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
272100               MOVE '   50' TO H-PSF-CBSA.                              00
271700                                                                        00
271800        IF H-PSF-CBSA = '37620'                                         00
271900           AND L-PSF-PROV-ST = '36'                                     00
272000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
272100               MOVE '   36' TO H-PSF-CBSA.                              00
273200                                                                        00
273300        IF H-PSF-CBSA = '37964'                                         00
273310           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
273400           AND L-PSF-PROV-ST = '31'                                     00
273500               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
273600               MOVE '   31' TO H-PSF-CBSA.                              00
273700                                                                        00
273800        IF H-PSF-CBSA = '38300'                                         00
273810           AND L-PSF-SPEC-PYMT-IND = 'Y'                                00
274000           AND L-PSF-PROV-ST = '36'                                     00
274100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
274200               MOVE '   36' TO H-PSF-CBSA.                              00
274300                                                                        00
273800        IF H-PSF-CBSA = '39300'                                         00
274000           AND L-PSF-PROV-ST = '22'                                     00
274100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
274200               MOVE '   22' TO H-PSF-CBSA.                              00
274300                                                                        00
273800        IF H-PSF-CBSA = '39300'                                         00
274000           AND L-PSF-PROV-ST = '41'                                     00
274100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
274200               MOVE '   41' TO H-PSF-CBSA.                              00
274300                                                                        00
273800        IF H-PSF-CBSA = '45500'                                         00
274000           AND L-PSF-PROV-ST = '45'                                     00
274100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
274200               MOVE '   45' TO H-PSF-CBSA.                              00
274300                                                                        00
273800        IF H-PSF-CBSA = '48260'                                         00
274000           AND L-PSF-PROV-ST = '36'                                     00
274100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
274200               MOVE '   36' TO H-PSF-CBSA.                              00
274300                                                                        00
273800        IF H-PSF-CBSA = '48540'                                         00
274000           AND L-PSF-PROV-ST = '36'                                     00
274100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
274200               MOVE '   36' TO H-PSF-CBSA.                              00
274300                                                                        00
273800        IF H-PSF-CBSA = '48540'                                         00
274000           AND L-PSF-PROV-ST = '51'                                     00
274100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
274200               MOVE '   51' TO H-PSF-CBSA.                              00
274300                                                                        00
273800        IF H-PSF-CBSA = '48864'                                         00
274000           AND L-PSF-PROV-ST = '31'                                     00
274100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND                          00
274200               MOVE '   31' TO H-PSF-CBSA.                              00
274300                                                                        00
274400 6120-FLOOR-2007-EXIT.                                                  02
274500     EXIT.                                                              02
309400                                                                        00
309500 6120-SEC401-2007.                                                      02
309600*************************************************************           00
309700****    FOR CY 2007 SECTION 401 HOSPITALS                   *           02
309800*************************************************************           00
      ***********************************************************       00000100
      * COMMENT:                                                *       00000200
      *   SYNC ALL OF THE FOLLOWING WITH INPATIENT.             *       00000300
      *   SEE DAVE PANUSKA, OR FOLLOWER.                        *       00000300
      ***********************************************************       00000100
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '050192' OR '050469' OR                     00
310700                            '050528' OR '050618')                       02
310700         MOVE '   05' TO H-PSF-CBSA.                                    02
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '070004')                                   00
310700         MOVE '   07' TO H-PSF-CBSA.                                    02
310900                                                                        00
309900     IF (L-PSF-PROV-OSCAR = '100048' OR '100134')                       00
310300         MOVE '   10' TO H-PSF-CBSA.                                    02
310500                                                                        00
310600     IF (L-PSF-PROV-OSCAR = '140167')                                   00
310700         MOVE '   14' TO H-PSF-CBSA.                                    02
310900                                                                        00
311000     IF (L-PSF-PROV-OSCAR = '170137')                                   00
311100         MOVE '   17' TO H-PSF-CBSA.                                    02
311300                                                                        00
311400     IF (L-PSF-PROV-OSCAR = '230078')                                   00
311500         MOVE '   23' TO H-PSF-CBSA.                                    02
311300                                                                        00
311400     IF (L-PSF-PROV-OSCAR = '260006' OR '260047' OR '260195')           00
311500         MOVE '   26' TO H-PSF-CBSA.                                    02
310900                                                                        00
310900*--------------------------------------------------------------*        00
310900* THIS LOGIC HAS BEEN DISABLED & REPLACED WITH THE LOGIC BELOW *        00
310900* HOSPITALS 330044 AND 330245 WERE REMOVED 8/10/2007 FOR       *        00
310900* VERSION 2007.4.0.                                            *        00
310900*--------------------------------------------------------------*        00
311000*    IF (L-PSF-PROV-OSCAR = '330044' OR '330245' OR '330268')  *        00
311100*        MOVE '   33' TO H-PSF-CBSA.                           *        02
310900*--------------------------------------------------------------*        00
310900                                                                        00
311000     IF (L-PSF-PROV-OSCAR = '330268')                                   00
311100         MOVE '   33' TO H-PSF-CBSA.                                    02
311300                                                                        00
311400     IF (L-PSF-PROV-OSCAR = '360125')                                   00
311500         MOVE '   36' TO H-PSF-CBSA.                                    02
311700                                                                        00
311800     IF (L-PSF-PROV-OSCAR = '370054')                                   00
311900         MOVE '   37' TO H-PSF-CBSA.                                    02
312100                                                                        00
311800     IF (L-PSF-PROV-OSCAR = '380040')                                   00
312300         MOVE '   38' TO H-PSF-CBSA.                                    02
312100                                                                        00
311800     IF (L-PSF-PROV-OSCAR = '440135' OR '440144')                       00
312300         MOVE '   44' TO H-PSF-CBSA.                                    02
312500                                                                        00
312600     IF (L-PSF-PROV-OSCAR = '450052' OR '450078' OR                     00
312640                            '450243' OR '450348')                       00
312700         MOVE '   45' TO H-PSF-CBSA.                                    02
313300                                                                        00
313400     IF (L-PSF-PROV-OSCAR = '500148')                                   00
313500         MOVE '   50' TO H-PSF-CBSA.                                    02
313300                                                                        00
313400     IF (L-PSF-PROV-OSCAR = '520060')                                   00
313500         MOVE '   52' TO H-PSF-CBSA.                                    02
314500                                                                        00
314600 6120-SEC401-2007-EXIT.                                                 02
314610     EXIT.                                                              02
314500                                                                        00
      *************************************************************
      *  SET FLAG IF APC = 0033                                   *
      *    - TERMINATE PROCESS IF 0033 LOCATED                    *
      *                                                           *
      *************************************************************

       6125-INIT.

             IF OPPS-APC (LN-SUB) = '0033'
                MOVE 'Y' TO APC33-FLAG.

             IF OPPS-HCPCS (LN-SUB) = 'C1820'
                MOVE 'Y' TO C1820-OFFSET-FLAG.

       6125-INIT-EXIT.
           EXIT.

      ***************************************************************
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1, 2,OR 4)*
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0 OR 1 OR 2          *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM DENIAL/REJECT FLAG  = TO 1     *
      *                 AND (APC NOT = 0033 OR 0034 OR 0322 OR      *
      *                      0323 OR 0324 OR 0325 OR 0373 OR 0374)) *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0              *
      *               - OR (APC 0033 IS NOT ON THE CLAIM            *
      *                     AND SERVICE INDICATOR = 'P'             *
      *                     OR  APC = 0322-0325,0373,0374)          *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      ***************************************************************
       6150-INIT.

             MOVE  01  TO A-RETURN-CODE (LN-SUB).

      ***************************************************************
      * OVER-RIDE SERVICE UNITS FOR APC 0339 - EFFECTIVE 04/01/2002 *
      *   - CHANGE UNIT VALUE TO 1                                  *
      ***************************************************************

             IF OPPS-APC (LN-SUB) = '0339'
                  MOVE 1 TO OPPS-SRVC-UNITS (LN-SUB).

             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 6250-CALC-DISCOUNT
                THRU 6250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 6150-INIT-EXIT.

      ***************************************************************
      *  EFFECTIVE AS OF 04-01-2002                                 *
      *    - TOTAL DEVICE OFFSET                                    *
      ***************************************************************

             IF OPPS-SRVC-IND (LN-SUB) = ' H'
                MOVE 'Y' TO C-FLAG
                COMPUTE H-TOT-HTD-UNITS = H-TOT-HTD-UNITS
                        + H-SRVC-UNITS.

             IF C1820-OFFSET-FLAG = 'Y'
                PERFORM 6160-TOTAL-OFFSET
                   THRU 6160-TOTAL-OFFSET-EXIT.

             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C'
              OR ' E' OR ' F' OR ' G' OR ' H' OR ' K' OR
              ' L' OR ' N' OR ' P' OR ' S' OR ' T' OR ' V' OR
              ' X' OR ' W' OR ' Y' OR ' Z' OR ' M') THEN
                MOVE  40  TO A-RETURN-CODE (LN-SUB)
                GO TO 6150-INIT-EXIT
              ELSE
                MOVE  01  TO A-RETURN-CODE (LN-SUB).

             IF OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' L' OR ' W' OR ' Y' OR ' Z' OR ' M'
                MOVE  41  TO A-RETURN-CODE (LN-SUB)
                GO TO 6150-INIT-EXIT.

               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'
                 IF OPPS-PKG-FLAG (LN-SUB) = '0' OR '1' OR '2'
                                             OR '3' OR '4'
                   IF (OPPS-LITEM-DR-FLAG (LN-SUB) = '0' OR
                       OPPS-LITEM-DR-FLAG (LN-SUB) = '1' AND
                       (OPPS-APC (LN-SUB) = '0033' OR '0034'
                       OR '0322' OR '0323' OR '0324' OR '0325'
                       OR '0373' OR '0374')) OR
                      (OPPS-LITEM-ACT-FLAG (LN-SUB) = '1')
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                             OR ' 2' OR ' 3' OR ' 4' OR ' 5' OR ' 6'
                             OR ' 7'
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR
                            ((APC33-FLAG = 'Y') AND
                             ((OPPS-SRVC-IND (LN-SUB) = ' P') OR
                             (OPPS-APC (LN-SUB) = '0322' OR '0323'
                              OR '0324' OR '0325' OR '0373'
                              OR '0374')))
      **********************************************************        00000100
      * COMMENT:                                               *        00000200
      *   ACCUMULATING TOTAL CHARGES.                          *        00000300
      **********************************************************        00000600
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

                    IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                       COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                            H-SUB-CHRG
                    END-IF
                    IF (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                       COMPUTE H-TOT-N-CHRG = H-SUB-CHRG
                                  + H-TOT-N-CHRG
                       MOVE 'Y' TO N-FLAG
                    END-IF
                    IF (OPPS-APC (LN-SUB) = '0000') OR
                       (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                       MOVE 42 TO A-RETURN-CODE (LN-SUB)
                       GO TO 6150-INIT-EXIT
                    END-IF
      **********************************************************        00000100
      * COMMENT:                                               *        00000200
      *   LOOK-UP APC RATE                                     *        00000300
      **********************************************************        00000600
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 6150-INIT-EXIT
                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2
                      PERFORM 6175-APC-LOOKUP
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 6150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 6150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 6150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 6150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 6150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 6150-INIT-EXIT.

      ***************************************************************
      *   NEW LOGIC FOR PROCESSING BLOOD DEDUCTIBLE                 *
      *  EFFECTIVE AS OF 07-01-2005                                 *
      *    - TOTAL BLOOD CODE CHARGES                               *
      *      - WHEN PAYMENT ADJUSTMENT FLAG = '5' OR '6'            *
      ***************************************************************

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE H-TOT-38X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' OR ' 6'
                COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X-39X.
********************************************************

             IF A-RETURN-CODE (LN-SUB) = 01
                PERFORM 6300-COIN-DEDUCT
                   THRU 6300-COIN-DEDUCT-EXIT.

      ***************************************************************
      *   BLOOD DEDUCTIBLE LINE PROCESSING                          *
      *   05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD  *
      *                DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.   *
      *                FIX EFFECTIVE RETROACTIVE TO 01/01/2007.     *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01
                SET W7BD-INDX TO 1
                SEARCH W7BD-ENTRY VARYING W7BD-INDX
                   AT END
                      GO TO 6150-INIT-EXIT
                WHEN W-2007-BLOOD-HCPCS (W7BD-INDX) =
                                              OPPS-HCPCS (LN-SUB)
                 IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                   MOVE W-2007-BLOOD-RANK (W7BD-INDX) TO H-BLOOD-RANK
                   MOVE OPPS-LITEM-DOS (LN-SUB) TO H-BLD-DOS
                   PERFORM 6375-BLOOD-DEDUCT
                      THRU 6375-BLOOD-DEDUCT-EXIT
                 END-IF.

       6150-INIT-EXIT.
           EXIT.

      ***************************************************************
      *  COMPUTE TOTAL OFFSET FROM TABLE 7 FOR DEVICES              *
      *      - EFFECTIVE AS OF 01-01-2003                           *
      *      - CONTINUE FOR   01-01-2004                            *
      *      - CONTINUE FOR   01-01-2005                            *
      *        - SEARCH TABLE OPPSOF04                              *
      *          - WHERE ALL OFFSET VALUES EQUAL ZERO               *
      ***************************************************************
       6160-TOTAL-OFFSET.

             MOVE OPPS-GRP (LN-SUB) TO W-OFF-APC.
             SEARCH ALL WOO-ENTRY7
                AT END
                   GO TO 6160-TOTAL-OFFSET-EXIT
                WHEN WOO-APC7 (WOO-INDX7) = W-OFF-APC
                   PERFORM 6161-TOTAL-OFFSET-AMT THRU
                           6161-TOTAL-OFFSET-AMT-EXIT.

       6160-TOTAL-OFFSET-EXIT.
           EXIT.

       6161-TOTAL-OFFSET-AMT.

           IF WOO-OFFSET7 (WOO-INDX7) EQUAL 0
              GO TO 6161-TOTAL-OFFSET-AMT-EXIT.

           COMPUTE H-TOTAL-OFFSET = H-TOTAL-OFFSET
            + (WOO-OFFSET7 (WOO-INDX7) * H-DISC-RATE * H-SRVC-UNITS).
           COMPUTE H-TOT-OFF-UNITS = H-TOT-OFF-UNITS + H-SRVC-UNITS.

           IF H-TOTAL-OFFSET < 0
              MOVE 0 TO H-TOTAL-OFFSET.

       6161-TOTAL-OFFSET-AMT-EXIT.
           EXIT.

      ***************************************************************
      *  SEARCH APC TABLE - MOVE VALUES TO HOLD AREA FOR PROCESSING *
      *      - ADJUST TOTAL CHARGE FOR DELETED APC'S                *
      ***************************************************************
       6175-APC-LOOKUP.

             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)
               IF WAR-RATEX (W-SUB2) = 'DELETED'
                 MOVE 30 TO A-RETURN-CODE (LN-SUB)
                 COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                      H-SUB-CHRG
               ELSE
                 MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                 MOVE WAR-RANK (W-SUB2) TO H-RANK
                 MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                 MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                 MOVE WAR-PPCT (W-SUB2) TO H-PPCT
             ELSE
                SUBTRACT 1 FROM W-SUB2
                IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                  GO TO 6175-APC-LOOKUP
                ELSE
                   MOVE 0 TO H-APC-PYMT
                             H-RANK
                             H-MIN-COIN
                             H-NAT-COIN
                             H-PPCT.

       6175-APC-LOOKUP-EXIT.
           EXIT.

      ***************************************************************
      *  IF DATE OF SERVICE BETWEEN 12/31/2002 AND 04/01/2003       *
      *    IF HCPCS CODE = C9114 OR C9115 ADJUST PAYMENT AND        *
      *    COINSURANCE AMOUNTS - LOGIC REMOVED FOR 20050101         *
      ***************************************************************

      ***************************************************************
      *    SEARCH WAGE INDEX TABLE AND SELECT THE WAGE INDEX        *
      *    WHEN EQUAL TO PROVIDER SPECIFIC WAGE INDEX               *
      *    IF WAGE INDEX NOT LOCATED                                *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      ***************************************************************
       6200-CALC-WAGEINDX.

             MOVE WCD-MAX TO WCD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WCD-DATE (WCD-SUB)
                 SUBTRACT 1 FROM WCD-SUB
             END-PERFORM.

             SEARCH ALL WCM-ENTRY
                AT END
                   MOVE  50  TO A-CLM-RTN-CODE
                   GO TO 6200-CALC-WAGEINDX-EXIT
                WHEN WCM-CBSA (WCM-INDX) = H-PSF-CBSA
                  MOVE WCM-PTR (WCM-INDX) TO W-SUB3
                  PERFORM 6210-WAGE-LOOKUP.

             IF H-WINX1 = 0 THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       6200-CALC-WAGEINDX-EXIT.
           EXIT.

       6210-WAGE-LOOKUP.

             IF WCW-DTCD (W-SUB3) NOT > WCD-DTCD (WCD-SUB)
                IF L-PSF-SPEC-PYMT-IND = 'Y'
                  MOVE WCW-WINX2 (W-SUB3) TO H-WINX1
                ELSE
                    MOVE WCW-WINX1 (W-SUB3) TO H-WINX1
             ELSE
                SUBTRACT 1 FROM W-SUB3
                IF W-SUB3 > WCM-PTR (WCM-INDX - 1)
                   GO TO 6210-WAGE-LOOKUP
                ELSE
                   MOVE 0 TO H-WINX1.

       6210-WAGE-LOOKUP-EXIT.
           EXIT.

      ***************************************************************
      *    CALCULATE DISCOUNT FACTOR BASED ON THE DISCOUNT          *
      *    INDICATOR PASSED BY THE OCE: VALUE 1 - 8                 *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      ***************************************************************
       6250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 6250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     MOVE  38  TO A-RETURN-CODE (LN-SUB).

       6250-CALC-DISCOUNT-EXIT.
           EXIT.

      ***************************************************************
      *    DETERMINE THE DEDUCTIBLE SEQUENCE. DEDUCTIBLE WILL BE    *
      *    TAKEN FROM OPPS SERVICES FIRST, THEN FROM ANY OTHER      *
      *    TYPES OF SERVICES FROM THE CLAIM.                        *
      *       - SET POINTERS TO THE HIGHEST RANKED PERCENTAGE       *
      *         (LARGEST NATIONAL UNADJUSTED COINSURANCE /          *
      *          THE APC PAYMENT)                                   *
      *       - MOVE ALL PRICING VARIABLES TO STAGING AREA          *
      ***************************************************************
       6300-COIN-DEDUCT.

             ADD 1 TO W-LNC-MAX.
             SET W-LP-INDX TO W-LNC-MAX.
             PERFORM 6350-STAGE-ENTRY
                THRU 6350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).
             MOVE LN-SUB TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX1    TO W-WINX1 (W-LP-INDX).
             MOVE H-RANK     TO W-RANK (W-LP-INDX).
             MOVE H-PPCT     TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
              UNTIL PS-SUB > L-PSF-APC-LINE-CNT
              IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS * H-DISC-RATE
                MOVE 25 TO A-RETURN-CODE (LN-SUB)
                MOVE L-PSF-APC-LINE-CNT TO PS-SUB
              END-IF
             END-PERFORM.

       6300-COIN-DEDUCT-EXIT.
           EXIT.

       6350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       6350-STAGE-ENTRY-EXIT.
           EXIT.

      ***************************************************************
      *    DETERMINE THE BLOOD DEDUCTIBLE SEQUENCE. DEDUCTIBLE      *
      *    WILL BE CALCULATED BASED ON RANKING.                     *
      *       - SET POINTERS TO THE HIGHEST RANKED APC              *
      *         (SMALLEST UNADJUSTED APC PAYMENT)                   *
      *       - MOVE ALL PRICING VARIABLES TO STAGING AREA          *
      ***************************************************************
       6375-BLOOD-DEDUCT.

             ADD 1 TO W-BLD-MAX.
             SET W-BD-INDX TO W-BLD-MAX.
             PERFORM 6385-STAGE-ENTRY
                THRU 6385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLD-RNK NOT < W-BD-RNK (W-BD-INDX - 1).
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX1    TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK  TO W-BD-RANK (W-BD-INDX).
             MOVE H-BLD-DOS TO W-BD-DOS (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).

      **********************************************************        00000100
      * COMMENT:                                               *        00000200
      *   IF PROVIDER ELECTS TO REDUCE COINSURANCE.            *        00000300
      **********************************************************        00000600
             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
              UNTIL PS-SUB > L-PSF-APC-LINE-CNT
              IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS * H-DISC-RATE
                MOVE 25 TO A-RETURN-CODE (LN-SUB)
                MOVE L-PSF-APC-LINE-CNT TO PS-SUB
              END-IF
             END-PERFORM.

       6375-BLOOD-DEDUCT-EXIT.
           EXIT.

       6385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       6385-STAGE-ENTRY-EXIT.
           EXIT.

      ***************************************************************
      *    FIRST STEP IN DETERMINING A LINE ITEM PRICE.             *
      *    CHECK ALL APPROPRIATE FLAGS AND INDICATORS PASSED        *
      *    BY THE OCE.                                              *
      *      - SET RETURN CODES TO INDICATE ERRORS OR STATUS        *
      *        - '20' - LINE PROCESSED BUT PAYMENT = 0              *
      *                 - BENE DEDUCTIBLE => ADJUSTED PAYMENT       *
      *                                                             *
      ***************************************************************
       6400-CALCULATE.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 6400-CALCULATE-EXIT.

             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 6550-CALC-STANDARD
                   THRU 6550-CALC-STANDARD-EXIT
             ELSE
                GO TO 6400-CALCULATE-EXIT.

      ***************************************************************
      *  SET GJK FLAG                                               *
      *    - TEST LINE ITEM DATE OF SERVICE > 20010630              *
      *    - TOTAL DRUG / DEVICE COINSURANCE                        *
      ***************************************************************

             IF (A-RETURN-CODE (LN-SUB) <  30)
               PERFORM 6450-ADJ-PROC-COIN
                  THRU 6450-ADJ-PROC-COIN-EXIT
             ELSE
               NEXT SENTENCE.

      ***************************************************************
      *  SET ST0 AND STVX FLAGS                                     *
      *    - TEST LINE ITEM DATE OF SERVICE > 20020331              *
      *    - TOTAL PROCEDURE CHARGES AND BUNDLED CHARGES            *
      ***************************************************************

             PERFORM 6500-ADJ-CHRGS
                THRU 6500-ADJ-CHRGS-EXIT.

             IF A-RETURN-CODE (LN-SUB) <  30
               COMPUTE A-TOTAL-CLM-DEDUCT =
                       H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT
               COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT
               COMPUTE A-BLOOD-DEDUCT-DUE =
                     A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT
               MOVE H-LITEM-PYMT TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN TO A-RED-COIN (LN-SUB)
               IF H-RED-COIN > H-NAT-COIN
                 MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF
               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.
             MOVE ZERO TO LINE-HOLD-ITEMS.

       6400-CALCULATE-EXIT.
           EXIT.

      ***************************************************************
      *  SET GJK FLAG                                               *
      *    - STAGE BY SERVICE INDICATOR                             *
      *                                                             *
      ***************************************************************
       6450-ADJ-PROC-COIN.

             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX1 (W-LP-INDX) + .4)
                  IF H-NEW-WGNAT > H-IP-LIMIT
                    MOVE H-IP-LIMIT TO H-NEW-WGNAT
                  END-IF
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                MOVE 1 TO H-DCP-CODE
                PERFORM 6455-SEARCH-KEY
                   THRU 6455-SEARCH-KEY-EXIT
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                        H-TOTAL-LN-DEDUCT - H-LITEM-REIM
                                   - H-LN-BLOOD-DEDUCT
                   MOVE 'Y' TO GJK-FLAG
                   MOVE 1 TO H-DCP-CODE
                   PERFORM 6455-SEARCH-KEY
                      THRU 6455-SEARCH-KEY-EXIT
                   MOVE 2 TO H-DCP-CODE
                   ADD 1 TO W-DCP-MAX
                   SET W-DCP-INDX TO W-DCP-MAX
                   PERFORM 6475-STAGE-DCP-ENTRY
                     THRU 6475-STAGE-DCP-ENTRY-EXIT
                       UNTIL W-DCP-INDX = 1 OR
                       H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       6450-ADJ-PROC-COIN-EXIT.
           EXIT.

       6455-SEARCH-KEY.

             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX
                AT END
                   PERFORM 6460-ADD-ENTRY
                      THRU 6460-ADD-ENTRY-EXIT
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 6465-UPDATE-ENTRY
                      THRU 6465-UPDATE-ENTRY-EXIT.

       6455-SEARCH-KEY-EXIT.
           EXIT.

       6460-ADD-ENTRY.

             ADD 1 TO W-DCP-MAX.
             SET W-DCP-INDX TO W-DCP-MAX.
             PERFORM 6475-STAGE-DCP-ENTRY
               THRU 6475-STAGE-DCP-ENTRY-EXIT
                UNTIL W-DCP-INDX = 1 OR
                  H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       6460-ADD-ENTRY-EXIT.
           EXIT.

       6465-UPDATE-ENTRY.

             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 6485-REPLACE-TYPE1
                     THRU 6485-REPLACE-TYPE1-EXIT
               ELSE
                  PERFORM 6480-RANK-COIN
                     THRU 6480-RANK-COIN-EXIT.

       6465-UPDATE-ENTRY-EXIT.
           EXIT.

       6475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       6475-STAGE-DCP-ENTRY-EXIT.
             EXIT.

       6480-RANK-COIN.

             IF H-NEW-WGNAT > W-DCP-WGNAT (W-DCP-INDX)
               MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
               MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
               MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
               MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       6480-RANK-COIN-EXIT.
           EXIT.

       6485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       6485-REPLACE-TYPE1-EXIT.
           EXIT.

       6500-ADJ-CHRGS.

      *****************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY              *
      *****************************************************
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                 OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                MOVE 'Y' TO ST0-FLAG.

             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                 OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX)
                               + H-TOT-ST-CHRG
                COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT
                               + H-TOT-ST-PYMT.

             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                OR ' X' OR ' P')
                AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT
                               + H-TOT-STVX-PYMT.

       6500-ADJ-CHRGS-EXIT.
           EXIT.
      ***************************************************************
      * 1. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *     - DESCENDING UNTIL DEDUCTIBLE = 0.                      *
      * 2. CALCULATE THE STANDARD LINE PRICE                        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS                *
      *          * DISCOUNT FACTOR)                                 *
      *     - WAGE ADJUST 60% OF THE APC PAYMENT ONLY               *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA.                     *
      *                                                             *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *       AND DRUGS                                             *
      ***************************************************************
       6550-CALC-STANDARD.

      **********************************************************        00000100
      * COMMENT:                                               *        00000200
      *    THE S,V,T,P & X ARE WAGE ADJUSTED ITEMS             *        00000300
      **********************************************************        00000600
             MOVE 0 TO H-BLOOD-FRACTION.
             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 7'
                PERFORM 6550-DEVICE-REDUC THRU 6550-DEVICE-REDUC-EXIT.
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' V'
                        OR ' T' OR ' P' OR ' X' THEN
                PERFORM 6550-SCH-ADJ THRU 6550-SCH-ADJ-EXIT
             ELSE
               IF OPPS-SRVC-IND (LN-SUB) = ' H' THEN
                 IF OPPS-PYMT-IND (LN-SUB) = ' 6' THEN
                   PERFORM 6555-CALC-H-STANDARD
                      THRU 6555-CALC-H-STANDARD-EXIT
                   PERFORM 6560-CALC-BENE-DEDUCT
                      THRU 6560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 6550-CALC-STANDARD-EXIT
                 END-IF
               ELSE
               IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' THEN
                IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 7' THEN
                  MOVE 0 TO H-BLOOD-FRACTION
                  PERFORM 6550-CALC-GJK
                     THRU 6550-CALC-GJK-EXIT
                  PERFORM 6560-CALC-BENE-DEDUCT
                     THRU 6560-CALC-BENE-DEDUCT-EXIT
                ELSE
                 MOVE  41  TO A-RETURN-CODE (LN-SUB)
                 GO TO 6550-CALC-STANDARD-EXIT
                END-IF
               END-IF.
      *
      * THE FOLLOWING SEARCH IS AN APC TABLE SEARCH TO SEE IF PRESENT
      *
             IF H-LITEM-PYMT > 0
                IF L-SERVICE-FROM-DATE < 20070701
                   PERFORM 6550-PD-AT-CST-JAN07
                      THRU 6550-PD-AT-CST-JAN07-EXIT
                ELSE
                   PERFORM 6550-PD-AT-CST-JUL07
                      THRU 6550-PD-AT-CST-JUL07-EXIT
                END-IF
             ELSE
              NEXT SENTENCE.

             IF H-MIN-COIN > 0
               IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' H'
                        OR ' K'
                 COMPUTE H-MIN-COIN ROUNDED = H-MIN-COIN *
                 (W-SRVC-UNITS (W-LP-INDX) -
                    (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION))
                   * W-DISC-RATE (W-LP-INDX)
               ELSE
                 IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                   COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25
                 ELSE
                   COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                 END-IF
               END-IF
             END-IF.

             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.
             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                  MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                         (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                            (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       6550-CALC-STANDARD-EXIT.
           EXIT.


       6550-PD-AT-CST-JAN07.

               SET PD-AT-CST-INDX7 TO 1.
               SEARCH PD-AT-CST-W-COIN7-ENTRY VARYING PD-AT-CST-INDX7
                  AT END
                    COMPUTE H-LITEM-REIM ROUNDED =
                    ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                      H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX)
                    COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                    H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                    MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN
      **********************************************************        00000100
      * COMMENT:                                               *        00000200
      *   PD-AT-CST-CODE7 GET 20% COINSURANCE (SEE TABLE)      *        00000300
      **********************************************************        00000600
               WHEN OPPS-APC(LN-SUB) = PD-AT-CST-CODE7 (PD-AT-CST-INDX7)
                  COMPUTE H-LITEM-REIM ROUNDED =
                  ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                     H-LN-BLOOD-DEDUCT) * .8
                  COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                  H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                  MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN.

       6550-PD-AT-CST-JAN07-EXIT.
           EXIT.


       6550-PD-AT-CST-JUL07.

               SET PD-AT-CST-INDX7B TO 1.
               SEARCH PD-AT-CST-W-COIN7B-ENTRY VARYING PD-AT-CST-INDX7B
                  AT END
                    COMPUTE H-LITEM-REIM ROUNDED =
                    ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                      H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX)
                    COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                    H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                    MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN
      **********************************************************              00
      * COMMENT:                                               *              00
      *   PD-AT-CST-CODE7B GET 20% COINSURANCE (SEE TABLE)     *              00
      **********************************************************              00
            WHEN OPPS-APC(LN-SUB) = PD-AT-CST-CODE7B (PD-AT-CST-INDX7B)
                  COMPUTE H-LITEM-REIM ROUNDED =
                  ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                     H-LN-BLOOD-DEDUCT) * .8
                  COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                  H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT
                  MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN.

       6550-PD-AT-CST-JUL07-EXIT.
           EXIT.


       6550-DEVICE-REDUC.

      *********************************************************
      * SEARCH THE DEVICE REDUCTION TABLE TO SEE IF THERE IS  *
      * AN APC MATCH, IF SO REDUCE THE PAYMENT BECAUSE THIS IS*
      * A FREE OR REPLACEMENT DEVICE.                         *
      *********************************************************

           SEARCH ALL DEV-RED07
              AT END
                 GO TO 6550-DEVICE-REDUC-EXIT
              WHEN DEV-APC7 (DEV-INDX7) = OPPS-APC (LN-SUB)
                PERFORM 6550-DEVICE-COMPUTE THRU
                        6550-DEVICE-COMPUTE-EXIT.

       6550-DEVICE-REDUC-EXIT.
           EXIT.

       6550-DEVICE-COMPUTE.

      *********************************************************
      * IF DEVICE IS FOUND, AND REDUCTION AMOUNT IS LESS THAN *
      * PAYMENT AMOUNT, SUBTRACT REDUCTION AMOUNT FROM PYMNT  *
      *********************************************************

           IF W-APC-PYMT (W-LP-INDX) NUMERIC
              IF W-APC-PYMT (W-LP-INDX) > DEV-REDUC7 (DEV-INDX7)
                 COMPUTE W-APC-PYMT (W-LP-INDX) =
                   (W-APC-PYMT (W-LP-INDX) - DEV-REDUC7 (DEV-INDX7)).

       6550-DEVICE-COMPUTE-EXIT.
           EXIT.

       6550-SCH-ADJ.
      *  IN THE BELOW IF STATEMENT, THE FOLLOWING MUST BE TRUE TO
      *  DO THE COMPUTE. OTHERWISE THE ELSE PATH IS TAKEN:
      *
      *  EITHER THE L-PSF-GEO-CBSA OR THE L-PSF-WI-CBSA MUST BE A VALUE
      *  OF '   01' THRU '   99' AND THE L-PSF-PROV-TYPE MUST BE
      *  A '16' OR '17' OR '21' OR '22'
      *
             MOVE L-PSF-GEO-CBSA TO GEO-CBSA-FLAG.
             MOVE L-PSF-WI-CBSA  TO WI-CBSA-FLAG.

             IF ((RURAL-GEO OR RURAL-WI) AND
                 (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22'))
                  COMPUTE H-SCH-PYMT ROUNDED =
                               (W-APC-PYMT (W-LP-INDX) * 1.071)
             ELSE
                 MOVE W-APC-PYMT (W-LP-INDX) TO H-SCH-PYMT.

             COMPUTE H-LITEM-PYMT ROUNDED =
                 (((H-SCH-PYMT * .60) *
                         W-WINX1 (W-LP-INDX))
                             + (H-SCH-PYMT * .40)) *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX).
               PERFORM 6560-CALC-BENE-DEDUCT
                  THRU 6560-CALC-BENE-DEDUCT-EXIT.
       6550-SCH-ADJ-EXIT.
           EXIT.

      ***************************************************************
      * 1. CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR        *
      *    TYPES G  OR K.                                           *
      * 2. EFFECTIVE 01/01/2003 REMOVE PRO RATA REDUCTION FOR       *
      *       ALL SERVICE INDICATOR 'G' PAYMENTS                    *
      ***************************************************************

       6550-CALC-GJK.

             IF (OPPS-HCPCS(LN-SUB) = ('P9010' OR 'P9016' OR 'P9021'
                          OR 'P9022' OR 'P9038' OR 'P9039' OR 'P9040'
                          OR 'P9051' OR 'P9054' OR 'P9056' OR 'P9057'
                          OR 'P9058') AND
                 OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6'))

                  PERFORM 6550-SET-BLOOD-FRACTION
                   THRU 6550-SET-BLOOD-FRACTION-EXIT
                  PERFORM 6550-ADJ-BLOOD-COST
                   THRU 6550-ADJ-BLOOD-COST-EXIT
             ELSE
                IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                  PERFORM 6550-ADJ-PLATE-COST
                     THRU 6550-ADJ-PLATE-COST-EXIT
                  GO TO 6550-CALC-GJK-EXIT
             ELSE
               COMPUTE H-LITEM-PYMT ROUNDED =
               W-APC-PYMT (W-LP-INDX) * W-SRVC-UNITS (W-LP-INDX)
                      * W-DISC-RATE (W-LP-INDX)
               GO TO 6550-CALC-GJK-EXIT.

             COMPUTE H-LITEM-PYMT ROUNDED =
             W-BD-APC-PYMT (W-BD-INDX) * W-BD-SRVC-UNITS (W-BD-INDX)
                      * W-BD-DISC-RATE (W-BD-INDX).

             COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                 H-LITEM-PYMT * H-BLOOD-FRACTION.

             SET W-BD-INDX UP BY 1.

       6550-CALC-GJK-EXIT.
           EXIT.

       6550-SET-BLOOD-FRACTION.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              IF H-BENE-PINTS-USED > 0
                IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                   MOVE 1 TO H-BLOOD-FRACTION
                   COMPUTE H-BENE-PINTS-USED =
                     H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)
                ELSE
                  IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                    COMPUTE H-BLOOD-FRACTION =
                      H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                    MOVE 0 TO H-BENE-PINTS-USED
                  ELSE
                     MOVE 0 TO H-BLOOD-FRACTION
              ELSE
                 MOVE 0 TO H-BLOOD-FRACTION
             ELSE
                MOVE 0 TO H-BLOOD-FRACTION.

       6550-SET-BLOOD-FRACTION-EXIT.
           EXIT.

       6550-ADJ-BLOOD-COST.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * H-38X-39X-RATE.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * (1 - H-38X-39X-RATE).

       6550-ADJ-BLOOD-COST-EXIT.
           EXIT.

       6550-ADJ-PLATE-COST.

           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * H-38X-39X-RATE.

           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * (1 - H-38X-39X-RATE).

           COMPUTE H-LITEM-PYMT ROUNDED =
              W-APC-PYMT (W-LP-INDX) * W-SRVC-UNITS (W-LP-INDX)
                      * W-DISC-RATE (W-LP-INDX).

       6550-ADJ-PLATE-COST-EXIT.
           EXIT.

      ***************************************************************
      * 1. CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR        *
      *    TYPE  H.                                                 *
      * 2. EFFECTIVE 04/01/2002 A PRO RATA REDUCTION APPLIES TO     *
      *       ALL SERVICE INDICATOR 'H' PAYMENTS (CURRENTLY .689)   *
      ***************************************************************
      **********************************************************        00000100
      * COMMENT:                                               *        00000200
      *   H = DEVICE                                           *        00000300
      **********************************************************        00000600

       6555-CALC-H-TOT.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.
             IF OPPS-SRVC-IND (LN-SUB) = ' H'
               IF OPPS-PYMT-IND (LN-SUB) = ' 6'
                  COMPUTE H-TOT-H-CHRG =
                     (H-TOT-H-CHRG + H-SUB-CHRG)
               ELSE
                  NEXT SENTENCE
             ELSE
                NEXT SENTENCE.

       6555-CALC-H-TOT-EXIT.
           EXIT.

       6555-CALC-H-STANDARD.

             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

             COMPUTE T-LITEM-PYMT ROUNDED =
               (H-SUB-CHRG * L-PSF-OPCOST-RATIO).


      ***********************************************
      * C-FLAG MEANS THERE IS A DEVICE ON THE CLAIM *
      ***********************************************

              IF (C-FLAG = 'Y')
                 IF (H-TOT-OFF-UNITS > H-TOT-HTD-UNITS)
                   COMPUTE H-TOTAL-WAOFF ROUNDED =
                     (((H-TOTAL-OFFSET * .60) * A-WINX)
                      + (H-TOTAL-OFFSET * .40))
                      * (H-TOT-HTD-UNITS / H-TOT-OFF-UNITS)
                   PERFORM 6700-CALC-H-OFFSET
                      THRU 6700-CALC-H-OFFSET-EXIT
                 ELSE
                    COMPUTE H-TOTAL-WAOFF ROUNDED =
                      ((H-TOTAL-OFFSET * .60) * A-WINX)
                       + (H-TOTAL-OFFSET * .40)
                    PERFORM 6700-CALC-H-OFFSET
                       THRU 6700-CALC-H-OFFSET-EXIT
              ELSE
                 NEXT SENTENCE.

                IF T-LITEM-PYMT < 0 THEN
                   MOVE 0 TO H-LITEM-PYMT
                ELSE
                   MOVE T-LITEM-PYMT TO H-LITEM-PYMT.


       6555-CALC-H-STANDARD-EXIT.
             EXIT.

       6560-CALC-BENE-DEDUCT.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 4'
                GO TO 6560-CALC-BENE-DEDUCT-EXIT.
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                  H-LITEM-PYMT - H-LN-BLOOD-DEDUCT
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                      H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       6560-CALC-BENE-DEDUCT-EXIT.
           EXIT.

      *********************************************************************
      ** - NEW FOR JANUARY 2004                                          **
      **   - CHECK >= 20040101 AND SRVC-IND = 'K'                        **
      **      - DISCONTINUE OUTLIER PROCESS                              **
      *********************************************************************
       6600-ADJ-CHRG-OUTL.

             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *********************************************************************
      ** - NEW FOR JANUARY 2005                                          **
      **   - TURN ON OUTLIER PROCESS FOR SPECIFIED K TYPE APCS           **
      **   - CHECK >= 20070101 AND SRVC-IND = 'K'
      **                                                                 **
      *********************************************************************
      *
      * BRACHYTHERAPY BACKED OUT FROM RELEASE V200711 TO V200712.
      *
      *    IF OPPS-SRVC-IND (LN-SUB) = ' K'
      *       IF (OPPS-APC (LN-SUB)  = '1716' OR '1717' OR
      *         '1718' OR '1719' OR '1720' OR '2616' OR '2632' OR
      *         '2633' OR '2634' OR '2635' OR '2636' OR '2637')
      *          NEXT SENTENCE
      *       ELSE
      *          GO TO 6600-ADJ-CHRG-OUTL-EXIT
      *    ELSE
      *       NEXT SENTENCE.

             IF (OPPS-SRVC-IND (LN-SUB) = ' G' OR ' H' OR
               ' N') OR (OPPS-PKG-FLAG (LN-SUB) = '4')
                GO TO 6600-ADJ-CHRG-OUTL-EXIT.


      ******************************************************************
      ** IF BLOOD CODE, INCLUDE IN OUTLIER CALCULATION                 *
      ******************************************************************
      ** 05/12/2009 - ALTERED LOGIC TO ALLOW ALL BLOOD LINES (WITH A   * **
      **              STATUS INDICATOR = ' K') TO ENTER OUTLIER LOGIC  * **
      **              (PREVIOUSLY ONLY BLOOD DEDUCTIBLE LINES ALLOWED) * **
      *********************************************************************
             MOVE 'N' TO W-BLD-HCPCS-FLAG.
             SET WBLH-INDX TO 1.
             SEARCH WBLHCPCS-ENTRY VARYING WBLH-INDX
                AT END
                   MOVE 'N' TO W-BLD-HCPCS-FLAG
                WHEN W-2005-2008-BLOOD-HCPCS (WBLH-INDX) =
                     OPPS-HCPCS (LN-SUB)
                   MOVE 'Y' TO W-BLD-HCPCS-FLAG.

           IF OPPS-SRVC-IND (LN-SUB) = ' K'
              IF W-BLD-HCPCS-FLAG = 'Y'
                 NEXT SENTENCE
              ELSE
                 GO TO 6600-ADJ-CHRG-OUTL-EXIT
           ELSE
              NEXT SENTENCE.

      *----------------------------------------------------------*
      * CODE COMMENTED OUT 05/12/2009 & REPLACED WITH CODE ABOVE *
      *----------------------------------------------------------*
      *    IF OPPS-SRVC-IND (LN-SUB) = ' K'
      *       IF (OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' OR ' 6')
      *          NEXT SENTENCE
      *       ELSE
      *          GO TO 6600-ADJ-CHRG-OUTL-EXIT
      *    ELSE
      *       NEXT SENTENCE.


      *****************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY              *
      *****************************************************
             IF (ST0-FLAG = 'Y') AND ((OPPS-SRVC-IND (LN-SUB)
                 = ' T' ) OR ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                             (OPPS-HCPCS (LN-SUB) > '09999' AND
                              OPPS-HCPCS (LN-SUB) < '70000')))
                   AND (H-TOT-ST-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND
                ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                  ' X' OR ' P')
                   AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3'))
                   AND (H-TOT-STVX-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                   (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)
                COMPUTE H-SUB-CHRG ROUNDED =
                     (H-CHRG-RATE * H-TOT-N-CHRG)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.

              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND
                ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                  ' X' OR ' P')
                  AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3'))
                  AND (H-TOT-STVX-PYMT > 0)
                COMPUTE H-CHRG-RATE ROUNDED =
                     (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)
                COMPUTE H-SUB-CHRG ROUNDED =
                     (H-CHRG-RATE * H-TOT-N-CHRG)
                COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.
      *********************************************************************
      ** - NEW FOR JANUARY 2005                                          **
      **   - PROVIDER RANGE FOR CMHC                                     **
      **   - COMPUTE H-LITEM-OUTL-PYMT USING NEW FORMULA                 **
      **   - THIS IS THE OUTLIER THRESHOLD AMOUNT                        **
      *********************************************************************

               MOVE 1.75 TO H-OUTLIER-FACTOR.
               MOVE .50 TO H-OUTLIER-PCT.
               COMPUTE H-COST ROUNDED =
                  W-SUB-CHRG (W-LP-INDX) * L-PSF-OPCOST-RATIO.
               COMPUTE H-APC-ADJ-PYMT ROUNDED =
                  H-OUTLIER-FACTOR * A-LITEM-PYMT (LN-SUB).
               IF (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999')
                  MOVE 3.4 TO H-OUTLIER-FACTOR
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED = (H-COST -
                    (H-OUTLIER-FACTOR * A-LITEM-PYMT (LN-SUB))) *
                     H-OUTLIER-PCT
               ELSE
                IF (H-COST > H-APC-ADJ-PYMT) AND
                   (H-COST > A-LITEM-PYMT (LN-SUB) + 1825)
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
                    (H-COST - H-APC-ADJ-PYMT) * H-OUTLIER-PCT
                ELSE
                   MOVE ZERO TO H-LITEM-OUTL-PYMT.

             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

             IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                       H-LITEM-OUTL-PYMT
               MOVE 0 TO H-LITEM-OUTL-PYMT.

       6600-ADJ-CHRG-OUTL-EXIT.
           EXIT.

      ***************************************************************
      * 1. RE-CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR     *
      *    TYPE H.                                                  *
      * 2. SUBTRACT WAGE ADJUSTED OFFSET AMOUNT FROM SI TYPE 'H'    *
      *    WITH HCPCS CODE BEGINNING WITH 'C'                       *
      * 2. EFFECTIVE 04/01/2002                                     *
      ***************************************************************

       6700-CALC-H-OFFSET.

             IF H-TOT-H-CHRG > 0
               COMPUTE H-OFF-RATE ROUNDED =
                    H-SUB-CHRG / H-TOT-H-CHRG
               COMPUTE T-LITEM-PYMT ROUNDED = T-LITEM-PYMT -
                      (H-TOTAL-WAOFF * H-OFF-RATE)
             ELSE
                NEXT SENTENCE.

             IF T-LITEM-PYMT < 0
                MOVE 0 TO T-LITEM-PYMT.

       6700-CALC-H-OFFSET-EXIT.
           EXIT.

       6800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 6810-PROCESS-TYPE1
                   THRU 6810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 6840-PROCESS-TYPE2
                   THRU 6840-PROCESS-TYPE2-EXIT.

       6800-ADJ-STV-REIM-EXIT.
           EXIT.

       6810-PROCESS-TYPE1.

             IF  W-DCP-COIN2 (W-DCP-INDX) > 0
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-WGNAT (W-DCP-INDX) TO H-TOTAL
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-WGNAT (W-DCP-INDX)) /
                                  W-DCP-COIN2 (W-DCP-INDX)
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.
                IF H-RATIO > 1
                    MOVE 1 TO H-RATIO.

       6810-PROCESS-TYPE1-EXIT.
           EXIT.

       6840-PROCESS-TYPE2.

             IF W-DCP-DOS (W-DCP-INDX) =  H-DCP-DOS
                MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB
                COMPUTE H-SHIFT =
                    W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)
                COMPUTE H-TOTAL =
                     A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT
                IF H-TOTAL > H-IP-LIMIT
                   COMPUTE H-SHIFT = H-SHIFT + H-TOTAL
                         - H-IP-LIMIT
                END-IF
                COMPUTE A-ADJ-COIN (LN-SUB) =
                     A-ADJ-COIN (LN-SUB) - H-SHIFT
                COMPUTE A-LITEM-REIM (LN-SUB) =
                   A-LITEM-REIM (LN-SUB) + H-SHIFT
                   MOVE 22 TO A-RETURN-CODE (LN-SUB)
             END-IF.

       6840-PROCESS-TYPE2-EXIT.
           EXIT.

      ***************************************************************
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      ***************************************************************
       6900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.
             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       6900-END-PRICE-RTN-EXIT.
           EXIT.




      ******************************************************************
      ******************************************************************
      ***                                                            ***
      **                                                              **
      **        OUTPATIENT PROSPECTIVE PAYMENT SYSTEM PRICER          **
      **        --------------------------------------------          **
      **       SECTION 7000 FOR CALENDAR YEAR 2008 PROCESSING         **
      **          SERVICE FROM DATES: 1/1/2008 - 12/31/2008           **
      **                                                              **
      ***                                                            ***
      ******************************************************************
      ******************************************************************


      ******************************************************************
      *                                                                *
      *                   PRICING PROCESS OVERVIEW                     *
      *                   ------------------------                     *
      *                                                                *
      *  1. GET RATES & OTHER INFORMATION FOR THE CLAIM                *
      *  2. VALIDATE CLAIM                                             *
      *  3. VALIDATE SERVICE LINES (INCLUDING DATA FROM THE OCE)       *
      *  4. GET RATES & OTHER INFORMATION FOR THE SERVICE LINES        *
      *  5. ACCUMULATE NON-PRIME LINE CHARGES FOR COMPOSITE APCS       *
      *  6. ACCUMULATE PACKAGED MENTAL HEALTH CHARGES                  *
      *  7. ORDER THE SERVICE LINES IN THE SEQUENCE IN WHICH           *
      *     DEDUCTIBLES WILL BE APPLIED                                *
      *  8. ORDER BLOOD LINES IN THE SEQUENCE IN WHICH DEDUCTIBLES     *
      *     WILL BE APPLIED                                            *
      *  9. CALCULATE SERVICE LINE PAYMENTS                            *
      * 10. CALCULATE DEDUCTIBLE AMOUNT APPLIED TO EACH SERVICE LINE   *
      * 11. CALCULATE BLOOD DEDUCTIBLE AMOUNT APPLIED TO EACH BLOOD    *
      *     DEDUCTIBLE LINE                                            *
      * 12. CALCULATE BENEFICIARY MAXIMUM (IP LIMIT), NATIONAL,        *
      *     MINIMUM, & REDUCED COINSURANCE FOR EACH SERVICE LINE       *
      * 13. CALCULATE REIMBURSEMENT FOR EACH SERVICE LINE              *
      * 14. ADJUST LINE CHARGES FOR ARTIFICAL, PACKAGED, COMPOSITE,    *
      *     AND MENTAL HEALTH CHARGES OF APPLICABLE PROCEDURES.  ALSO, *
      *     ADJUST LINE CHARGES AND PAYMENTS FOR PASS-THROUGH DEVICES  *
      *     FOR ELIGIBLE PROCEDURES.  ALL ADJUSTMENTS ARE DONE FOR     *
      *     OUTLIER DETERMINATION ONLY.                                *
      * 15. CALCULATE OUTLIER PAYMENT FOR ELIGIBLE SERVICE LINES       *
      * 16. APPLY THE DAILY INPATIENT LIMIT IN CALCULATING THE         *
      *     COINSURANCE TO BE PAID BY THE BENEFICIARY FOR DRUG LINES;  *
      *     ADD ANY COINSURANCE AMOUNT THAT EXCEEDS THE INPATIENT      *
      *     LIMIT TO THE DRUG LINE'S REIMBURSEMENT                     *
      * 17. ACCUMULATE CLAIM TOTALS                                    *
      * 18. MOVE FINAL SERVICE LINE AMOUNTS TO AREA TO BE PASSED BACK  *
      *                                                                *
      ******************************************************************


       7000-PROCESS-MAIN-NEW.

      *****************************************************************
      *                                                               *
      *   STEP 1 - INITIALIZE & SET WORKING-STORAGE VARIABLES, ASSIGN *
      *   ------   CBSA & WAGE INDEX, PERFORM CLAIM DATE EDITS, SET   *
      *            INPATIENT DAILY COINSURANCE LIMIT (SET ANNUALLY)   *
      *                                                               *
      *****************************************************************
              PERFORM 7100-INIT
                 THRU 7100-INIT-EXIT.

      *--------------------------------------------------------*
      * SET ERROR CODE IF THE WAGE INDEX = 0                   *
      *--------------------------------------------------------*
              IF H-WINX1 = 0 AND A-CLM-RTN-CODE = 01
                 MOVE 51 TO A-CLM-RTN-CODE.

      *--------------------------------------------------------*
      * IF THE CLAIM HAS ERROR(S), STOP PROCESSING             *
      *--------------------------------------------------------*
              IF A-CLM-RTN-CODE >= 50
                 GOBACK.

      *--------------------------------------------------------*
      * MOVE WAGE INDEX TO VARIABLE TO BE PASSED BACK          *
      *--------------------------------------------------------*
              MOVE H-WINX1 TO A-WINX.


      *****************************************************************
      *                                                               *
      *   STEP 2 - SET CLAIM FLAGS WHEN CERTAIN CODES ARE FOUND       *
      *   ------   (LOOP THROUGH THE CLAIM)                           *
      *                                                               *
      *   - APC33-FLAG - PARTIAL HOSPITALIZATION CLAIM                *
      *   - C1820-OFFSET-FLAG - DEVICE OFFSET CLAIM                   *
      *   - APC34-FLAG - MENTAL HEALTH CLAIM                          *
      *   - PTD-FLAG - PASS-THROUGH DEVICE(S) ON CLAIM                *
      *                                                               *
      *****************************************************************
              PERFORM 7125-INIT
                 THRU 7125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.


      *****************************************************************
      *                                                               *
      *   STEP 3 - VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS &   *
      *   ------   OFFSETS, ACCUMULATE CLAIM TOTALS, SET FLAGS,       *
      *            POPULATE COINSURANCE & BLOOD DEDUCTIBLE TABLES     *
      *            WITH VALID SERVICE LINES, POPULATE COMPOSITE APC   *
      *            TABLE WITH NON-PRIME COMPOSITE LINE CHARGES,       *
      *            CALCULATE TOTAL PACKAGED MENTAL HEALTH CHARGES,    *
      *            AND CREATE PASS-THROUGH DEVICE TABLE               *
      *            (LOOP THROUGH THE CLAIM)                           *
      *                                                               *
      *****************************************************************
              MOVE 0 TO W-DCP-MAX W-BLD-MAX W-CMP-MAX W-PTD-MAX
                        W-NUCMED-MAX.
              PERFORM 7150-INIT
                 THRU 7150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

      *--------------------------------------------------------*
      * CALCULATE RATIO OF BLOOD PRODUCT CHARGES TO TOTAL      *
      * BLOOD CHARGES (PRODUCT & STORAGE/PROCESSING)           *
      *--------------------------------------------------------*
              IF H-TOT-38X-39X > 0
                 COMPUTE H-38X-39X-RATE ROUNDED =
                    H-TOT-38X / H-TOT-38X-39X.


      *****************************************************************
      *                                                               *
      *   STEP 4 - ACCUMULATE TOTAL CLAIM CHARGES FROM DEVICE LINES   *
      *   ------   (FOR DEVICES, SERVICE INDICATOR = H)               *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************
              MOVE 0 TO W-DCP-MAX.
              PERFORM 7555-CALC-H-TOT
                 THRU 7555-CALC-H-TOT-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 5 - CALCULATE LINE PAYMENTS, DEDUCTIBLES, COINSURANCE, *
      *   ------   & REIMBURSEMENT, ACCUMULATE CLAIM TOTALS, POPULATE *
      *            DRUG COINSURANCE TABLE, POPULATE PASS-THROUGH      *
      *            DEVICE TABLE WITH ELIGIBLE PROCEDURE DATA AND      *
      *            DEVICE LINE ITEM PAYMENT, AND MOVE LINE ITEM       *
      *            VALUES TO VARIABLES TO BE PASSED BACK              *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * POINT TO 1ST RECORD IN THE BLOOD DEDUCTIBLE TABLE      *
      *--------------------------------------------------------*
              SET W-BD-INDX TO 1.

      *--------------------------------------------------------*
      * CLEAR THE DRUG COINSURANCE TABLE                       *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX.
              PERFORM 7400-CALCULATE
                 THRU 7400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 6 - ADJUST PROCEDURE LINE CHARGES FOR ARTIFICIAL       *
      *   ------   CHARGES, PACKAGING, COMPOSITES, MENTAL HEALTH, AND *
      *            PASS-THROUGH DEVICES, AND CALCULATE OUTLIER        *
      *            PAYMENTS                                           *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************
              PERFORM 7600-ADJ-CHRG-OUTL
                 THRU 7600-ADJ-CHRG-OUTL-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX


      *****************************************************************
      *                                                               *
      *   STEP 7 - CALCULATE THE COINSURANCE & REIMBURSEMENT AMOUNTS  *
      *   ------   FOR STATUS INDICATOR G & K LINES.  THE DAILY INPA- *
      *            TIENT COINSURANCE LIMIT IS APPLIED USING THE WAGE  *
      *            ADJUSTED COINSURANCE OF EACH DAY'S MOST EXPENSIVE  *
      *            PROCEDURE OR VISIT.                                *
      *            (LOOP THROUGH THE DRUG COINSURANCE TABLE)          *
      *                                                               *
      *****************************************************************
                IF GJK-FLAG = 'Y'
                   PERFORM 7800-ADJ-STV-REIM
                      THRU 7800-ADJ-STV-REIM-EXIT
                        VARYING W-DCP-INDX FROM 1 BY 1
                          UNTIL W-DCP-INDX > W-DCP-MAX
                ELSE
                   NEXT SENTENCE.


      *****************************************************************
      *                                                               *
      *   STEP 8 - MOVE CLAIM TOTAL CHARGES, PAYMENTS, BLOOD PINTS    *
      *   ------   USED, AND OUTLIER PAYMENTS TO VARIABLES TO BE      *
      *            PASSED BACK.  CALCULATE BLOOD PINTS USED.          *
      *                                                               *
      *****************************************************************
              PERFORM 7900-END-PRICE-RTN
                 THRU 7900-END-PRICE-RTN-EXIT.

       7000-PROCESS-MAIN-NEW-EXIT.
           EXIT.



      ***************************************************************
      *                                                             *
      * INITIALIZE WORKING STORAGE HOLD AREAS AND ADDITIONAL        *
      * VARIABLES TO BE PASSED BACK TO THE STANDARD SYSTEM,         *
      * ASSIGN CLAIM CBSA AND WAGE INDEX, & PERFORM DATE EDITS      *
      *                                                             *
      * ** CHANGE EVERY JANUARY:                                    *
      *    - INPATIENT DAILY COINSURANCE LIMIT (H-IP-LIMIT)         *
      *    - CAL-VERSION                                            *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ERROR RETURN CODES:                                         *
      * -------------------                                         *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       7100-INIT.

      *-------------------------------------------------------------*
      *  INITIALIZE CLAIM RETURN CODE (01 = CLAIM PROCESSED)        *
      *-------------------------------------------------------------*
             MOVE 01 TO A-CLM-RTN-CODE.

      *-------------------------------------------------------------*
      * INITIALIZE CLAIM AND LINE VARIABLES                         *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      * 11/06/2007 - BRACHY-APC-FLAG ADDED                          *
      * 11/13/2007 - BLD-DEDUC-HCPCS-FLAG ADDED                     *
      * 11/28/2007 - APC34-FLAG ADDED                               *
      * 12/27/2007 - RADIOPH-APC-FLAG ADDED                         *
      * 02/11/2008 - PTD-FLAG, PTD-LINE-FLAG, PTD-PROC-FLAG ADDED   *
      * 05/12/2009 - W-BLD-HCPCS-FLAG, W-APC34-CNT ADDED            *
      *-------------------------------------------------------------*
             MOVE 'N' TO APC33-FLAG GJK-FLAG ST0-FLAG
                         N-FLAG C-FLAG   C1820-OFFSET-FLAG
                         PHP-HCPCS-FLAG  MH-HCPCS-FLAG
                         BRACHY-APC-FLAG BLD-DEDUC-HCPCS-FLAG
                         APC34-FLAG      RADIOPH-APC-FLAG
                         PTD-FLAG        PTD-LINE-FLAG
                         PTD-PROC-FLAG   W-BLD-HCPCS-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO TO A-OUTLIER-PYMT
                          A-TOTAL-CLM-DEDUCT
                          A-TOT-CLM-CHRG
                          A-TOT-CLM-PYMT
                          A-BLOOD-DEDUCT-DUE
                          A-BLOOD-PINTS-USED
                          A-WINX
                          W-LNC-MAX
                          W-APC34-CNT.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.

      *-------------------------------------------------------------*
      * VALIDATE CLAIM & PSF DATES                                  *
      *-------------------------------------------------------------*
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 7100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                   MOVE 54 TO A-CLM-RTN-CODE
                   GO TO 7100-INIT-EXIT
                ELSE
                   IF L-PSF-TERMDT > 0
                      IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                         MOVE 54 TO A-CLM-RTN-CODE
                         GO TO 7100-INIT-EXIT
                      END-IF
                   END-IF.

      *-------------------------------------------------------------*
      * UPDATE CAL-VERSION EVERY JANUARY                            *
      *-------------------------------------------------------------*
             MOVE CAL-VERSION7 TO A-CALC-VERS.

      *-------------------------------------------------------------*
      * RECEIVE BENEFICIARY SPECIFIC ITEMS FROM THE OCE             *
      *-------------------------------------------------------------*
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.

      *-------------------------------------------------------------*
      * GET TO PROPER APC DATE BY SERVICE DATE (STARTING AT THE     *
      * LATEST EFFECTIVE DATE IN THE APC DATE TABLE)                *
      *-------------------------------------------------------------*
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.

      *-------------------------------------------------------------*
      * DETERMINE WHICH CBSA TO USE & WHETHER TO USE THE SPECIAL    *
      * WAGE INDEX IN THE PSF, AND SET THE INPATIENT DAILY          *
      * COINSURANCE LIMIT (IN 2 PLACES; CHANGE EVERY JANUARY)       *
      *-------------------------------------------------------------*
             IF L-PSF-SPEC-PYMT-IND = 'Y'
                MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
             ELSE
                IF L-PSF-SPEC-PYMT-IND = ' '
                   MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA
                ELSE
                   IF L-PSF-SPEC-PYMT-IND = '1' OR '2'
                      MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA A-CBSA
                      MOVE L-PSF-SPEC-WGIDX TO H-WINX1
                      MOVE 1024 TO H-IP-LIMIT
                      GO TO 7100-INIT-EXIT
                   ELSE
                      MOVE  52  TO A-CLM-RTN-CODE
                      GO TO 7100-INIT-EXIT.

             IF H-PSF-CBSA = SPACE
                MOVE  52  TO A-CLM-RTN-CODE
                GO TO 7100-INIT-EXIT.

             MOVE 1024 TO H-IP-LIMIT.

      *-------------------------------------------------------------*
      * APPLY WAGE INDEX FLOOR POLICY                               *
      * UPDATE WITH NEW FLOOR PARAGRAPH EVERY JANUARY               *
      *-------------------------------------------------------------*
             PERFORM 7120-FLOOR-2008
                THRU 7120-FLOOR-2008-EXIT.

      *-------------------------------------------------------------*
      * APPLY SECTION 401 WAGE INDEX POLICY                         *
      * UPDATE WITH NEW SECTION 401 PARAGRAPH EVERY JANUARY         *
      *-------------------------------------------------------------*
             PERFORM 7120-SEC401-2008
                THRU 7120-SEC401-2008-EXIT.

      *-------------------------------------------------------------*
      *   GET THE CBSA WAGE INDEX VALUE (IF NOT ALREADY OVERRIDDEN  *
      *   BY THE PSF SPECIAL WAGE INDEX VALUE)                      *
      *-------------------------------------------------------------*
             MOVE H-PSF-CBSA TO A-CBSA.
             IF H-WINX1 = 0
                PERFORM 7200-CALC-WAGEINDX
                   THRU 7200-CALC-WAGEINDX-EXIT.

       7100-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  NEW CY 2008 FLOOR FOR CBSA WAGE INDEX                      *
      *  IPPS PRICER PGM FLOORS TAKEN FROM: IPDRV084                *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  SYNC ALL OF THE FOLLOWING WITH INPATIENT.                  *
      *  SEE IPPS PRICER MAINTAINER.                                *
      *                                                             *
      * * SPECIAL NOTES *                                           *
      *   -------------                                             *
      *   1) INPATIENT MOVES 'N' TO P-NEW-CBSA-SPEC-PAY-IND         *
      *           OPPS MOVES ' ' TO L-PSF-SPEC-PYMT-IND             *
      *                                                             *
      *   2) INPATIENT CHECKS P-NEW-CBSA-SPEC-PAY-IND = 'Y'         *
      *           OPPS CHECKS L-PSF-SPEC-PYMT-IND = 'Y'             *
      *                                                             *
      *   3) INPATIENT CHECKS VALUE OF HOLD-PROV-CBSA               *
      *           OPPS CHECKS VALUE OF H-PSF-CBSA                   *
      *                                                             *
      *   4) INPATIENT MOVES THE STATE CBSA TO HOLD-PROV-CBSA       *
      *           OPPS MOVES THE STATE CBSA TO H-PSF-CBSA           *
      *                                                             *
      *   5) INPATIENT CHECKS P-NEW-STATE                           *
      *           OPPS CHECKS L-PSF-PROV-ST                         *
      *                                                             *
      *   6) ADD SINGLE QUOTES AROUND L-PSF-PROV-ST VALUES          *
      *                                                             *
      *                                                             *
      *   BE SURE TO MAKE THESE SIX CHANGES EVERY JANUARY           *
      *                                                             *
      ***************************************************************
       7120-FLOOR-2008.

274000        IF H-PSF-CBSA = '   39'
274100           AND L-PSF-SPEC-PYMT-IND = 'Y'
274200           AND L-PSF-PROV-ST = '33'
274300               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
274400               MOVE '   33' TO H-PSF-CBSA.
274500
274600        IF H-PSF-CBSA = '   39'
274700           AND L-PSF-SPEC-PYMT-IND = 'Y'
274800           AND L-PSF-PROV-ST = '39'
274900               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
275000               MOVE '   39' TO H-PSF-CBSA.
275100
275200        IF H-PSF-CBSA = '10900'
275300           AND L-PSF-PROV-ST = '31'
275400               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
275500               MOVE '   31' TO H-PSF-CBSA.
275600
275700        IF H-PSF-CBSA = '19060'
275800           AND L-PSF-PROV-ST = '21'
275900               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
276000               MOVE '   21' TO H-PSF-CBSA.
276100
276200        IF H-PSF-CBSA = '21780'
276300           AND L-PSF-PROV-ST = '15'
276400               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
276500               MOVE '   15' TO H-PSF-CBSA.
276600
276700        IF H-PSF-CBSA = '21780'
276800           AND L-PSF-SPEC-PYMT-IND = 'Y'
276900           AND L-PSF-PROV-ST = '15'
277000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
277100               MOVE '   15' TO H-PSF-CBSA.
277200
277300        IF H-PSF-CBSA = '22020'
277400           AND L-PSF-PROV-ST = '24'
277500               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
277600               MOVE '   24' TO H-PSF-CBSA.
277700
277800        IF H-PSF-CBSA = '24220'
277900           AND L-PSF-PROV-ST = '24'
278000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
278100               MOVE '   24' TO H-PSF-CBSA.
278200
278300        IF H-PSF-CBSA = '24580'
278400           AND L-PSF-SPEC-PYMT-IND = 'Y'
278500           AND L-PSF-PROV-ST = '52'
278600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
278700               MOVE '   52' TO H-PSF-CBSA.
278800
278900        IF H-PSF-CBSA = '25540'
279000           AND L-PSF-SPEC-PYMT-IND = 'Y'
279100           AND L-PSF-PROV-ST = '07'
279200               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
279300               MOVE '   07' TO H-PSF-CBSA.
279400
279500        IF H-PSF-CBSA = '28420'
279600           AND L-PSF-SPEC-PYMT-IND = 'Y'
279700           AND L-PSF-PROV-ST = '50'
279800               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
279900               MOVE '   50' TO H-PSF-CBSA.
280000
280100        IF H-PSF-CBSA = '28700'
280200           AND L-PSF-PROV-ST = '44'
280300               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
280400               MOVE '   44' TO H-PSF-CBSA.
280500
280600        IF H-PSF-CBSA = '28700'
280700           AND L-PSF-PROV-ST = '49'
280800               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
280900               MOVE '   49' TO H-PSF-CBSA.
281000
281100        IF H-PSF-CBSA = '30300'
281200           AND L-PSF-PROV-ST = '50'
281300               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
281400               MOVE '   50' TO H-PSF-CBSA.
281500
281600        IF H-PSF-CBSA = '35084'
281700           AND L-PSF-SPEC-PYMT-IND = 'Y'
281800           AND L-PSF-PROV-ST = '31'
281900               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
282000               MOVE '   31' TO H-PSF-CBSA.
282100
282200        IF H-PSF-CBSA = '37620'
282300           AND L-PSF-PROV-ST = '36'
282400               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
282500               MOVE '   36' TO H-PSF-CBSA.
282600
282700        IF H-PSF-CBSA = '37964'
282800           AND L-PSF-SPEC-PYMT-IND = 'Y'
282900           AND L-PSF-PROV-ST = '31'
283000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
283100               MOVE '   31' TO H-PSF-CBSA.
283200
283300        IF H-PSF-CBSA = '38300'
283400           AND L-PSF-SPEC-PYMT-IND = 'Y'
283500           AND L-PSF-PROV-ST = '36'
283600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
283700               MOVE '   36' TO H-PSF-CBSA.
283800
283900        IF H-PSF-CBSA = '45500'
284000           AND L-PSF-PROV-ST = '45'
284100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
284200               MOVE '   45' TO H-PSF-CBSA.
284300
284400        IF H-PSF-CBSA = '48260'
284500           AND L-PSF-PROV-ST = '36'
284600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
284700               MOVE '   36' TO H-PSF-CBSA.
284800
284900        IF H-PSF-CBSA = '48540'
285000           AND L-PSF-PROV-ST = '36'
285100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
285200               MOVE '   36' TO H-PSF-CBSA.
285300
285400        IF H-PSF-CBSA = '48540'
285500           AND L-PSF-PROV-ST = '51'
285600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
285700               MOVE '   51' TO H-PSF-CBSA.
285800
285900        IF H-PSF-CBSA = '48864'
286000           AND L-PSF-PROV-ST = '31'
286100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
286200               MOVE '   31' TO H-PSF-CBSA.
286300
286400        IF H-PSF-CBSA = '48864'
286500           AND L-PSF-SPEC-PYMT-IND = 'Y'
286600           AND L-PSF-PROV-ST = '31'
286700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
286800               MOVE '   31' TO H-PSF-CBSA.

       7120-FLOOR-2008-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  NEW CY 2008 SECTION 401 HOSPITALS                          *
      *  IPPS PRICER PGM SECTION 401S TAKEN FROM: IPDRV084          *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  SYNC ALL OF THE FOLLOWING WITH INPATIENT.                  *
      *  SEE IPPS PRICER MAINTAINER.                                *
      *                                                             *
      * * SPECIAL NOTES *                                           *
      *   -------------                                             *
      *   1) INPATIENT CHECKS P-NEW-PROVIDER-NO                     *
      *           OPPS CHECKS L-PSF-PROV-OSCAR                      *
      *                                                             *
      *   2) INPATIENT MOVES THE STATE CBSA TO HOLD-PROV-CBSA       *
      *            AND P-NEW-CBSA-STAND-AMT-LOC                     *
      *           OPPS MOVES THE STATE CBSA TO H-PSF-CBSA ONLY      *
      *                                                             *
      *   3) DELETE THE P-NEW-CBSA-STAND-AMT-LOC LINES              *
      *                                                             *
      *   BE SURE TO MAKE THESE THREE CHANGES EVERY JANUARY         *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      *  NOTE: PROVIDER 250126 REMOVED FROM THIS LIST PER           *
      *        THE OCT 2007 IPPS CORRECTION NOTICE (11/1/2007)      *
      *                                                             *
      ***************************************************************
       7120-SEC401-2008.
353900
354000     IF (L-PSF-PROV-OSCAR = '050192' OR
354100                             '050528' OR '050618')
354200         MOVE '   05' TO H-PSF-CBSA.
354400
354500     IF (L-PSF-PROV-OSCAR = '100134')
354600         MOVE '   10' TO H-PSF-CBSA.
354800
354900     IF (L-PSF-PROV-OSCAR = '170137')
355000         MOVE '   17' TO H-PSF-CBSA.
355200
355300     IF (L-PSF-PROV-OSCAR = '230051' OR '230078')
355400         MOVE '   23' TO H-PSF-CBSA.
355600
355700     IF (L-PSF-PROV-OSCAR = '250017')
355800         MOVE '   25' TO H-PSF-CBSA.
356000
356100     IF (L-PSF-PROV-OSCAR = '260006' OR '260195')
356200         MOVE '   26' TO H-PSF-CBSA.
356400
356500     IF (L-PSF-PROV-OSCAR = '330044' OR '330268')
356600         MOVE '   33' TO H-PSF-CBSA.
356800
356900     IF (L-PSF-PROV-OSCAR = '360125')
357000         MOVE '   36' TO H-PSF-CBSA.
357200
357300     IF (L-PSF-PROV-OSCAR = '370054')
357400         MOVE '   37' TO H-PSF-CBSA.
357600
357700     IF (L-PSF-PROV-OSCAR = '380040')
357800         MOVE '   38' TO H-PSF-CBSA.
358000
358100     IF (L-PSF-PROV-OSCAR = '390130' OR '390183' OR
358200                             '390185' OR '390201')
358300         MOVE '   39' TO H-PSF-CBSA.
358500
358600     IF (L-PSF-PROV-OSCAR = '440135')
358700         MOVE '   44' TO H-PSF-CBSA.
358900
359000     IF (L-PSF-PROV-OSCAR = '450052' OR '450078' OR
359100                             '450243' OR '450348')
359200         MOVE '   45' TO H-PSF-CBSA.
359400
359500     IF (L-PSF-PROV-OSCAR = '500148')
359600         MOVE '   50' TO H-PSF-CBSA.

       7120-SEC401-2008-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    LOOP THROUGH ALL CLAIM LINES TO FIND AN APC / HCPCS      *
      *                                                             *
      *  - SET FLAG IF APC = 0033 (FOR PARITAL HOSPITALIZATION)     *
      *  - SET FLAG IF HCPCS = C1820 (FOR DEVICE OFFSETS)           *
      *  - SET FLAG IF APC = 0034 (FOR MENTAL HEALTH CHARGES)       *
      *    (NEW FOR CY 2008 - ADDED 11/28/2007)                     *
      *  - SET FLAG IF PASS-THROUGH DEVICE(S) ON CLAIM              *
      *    (NEW FOR CY 2008 - ADDED 02/11/2008)                     *
      *                                                             *
      *  5/12/2009 - ADDED COUNTER FOR APC 34 LINES (W-APC34-CNT)   *
      *              FOR REVISED MENTAL HEALTH COMPOSITE LOGIC      *
      *                                                             *
      ***************************************************************
       7125-INIT.

             IF OPPS-APC (LN-SUB) = '0033'
                MOVE 'Y' TO APC33-FLAG.

             IF OPPS-APC (LN-SUB) = '0034'
                MOVE 'Y' TO APC34-FLAG
                ADD 1 TO W-APC34-CNT.

             IF OPPS-HCPCS (LN-SUB) = 'C1820'
                MOVE 'Y' TO C1820-OFFSET-FLAG.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST ONE LINE IS A PASS-THROUGH DEVICE  *
      *-------------------------------------------------------------*
             PERFORM 7665-SET-PTD-LINE-FLAG
                THRU 7665-SET-PTD-LINE-FLAG-EXIT.

             IF PTD-LINE-FLAG = 'Y'
                MOVE 'Y' TO PTD-FLAG
             END-IF.

       7125-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS & OFFSETS,  *
      *  ACCUMULATE CLAIM TOTALS, SET FLAGS, POPULATE COINSURANCE & *
      *  BLOOD DEDUCTIBLE TABLES WITH VALID SERVICE LINES, POPULATE *
      *  COMPOSITE APC TABLE WITH NON-PRIME COMPOSITE LINE CHARGES, *
      *  AND CALCULATE TOTAL PACKAGED MENTAL HEALTH CHARGES.        *
      *  CREATE PASS-THROUGH DEVICE TABLE (NEW FOR CY 2008 QTR 2).  *
      *                                                             *
      *  ** UPDATE PARTIAL HOSPITALIZATION (PHP) & MENTAL HEALTH    *
      *     (MH) TABLE REFERENCES EVERY JANUARY                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      * VALIDATION RULES & RETURN CODES:                            *
      * --------------------------------                            *
      *                                                             *
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1, 2,OR 4)*
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0, 1, 2, 3, OR 4     *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM DENIAL/REJECT FLAG  = TO 1     *
      *                 AND (NOT A PARTIAL HOSPITALIZATION OR       *
      *                      MENTAL HEALTH HCPCS))                  *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0              *
      *               - OR (APC 0033 IS NOT ON THE CLAIM            *
      *                     AND SERVICE INDICATOR = 'P'             *
      *                     OR  PARTIAL HOSPITALIZATION HCPCS)      *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      *                                                             *
      ***************************************************************
       7150-INIT.

      ***************************************************************
      *  INITIALIZE LINE RETURN CODE TO VALID VALUE                 *
      ***************************************************************
             MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *  OVERRIDE SERVICE UNITS FOR APC 0339 - EFFECTIVE 04/01/2002 *
      ***************************************************************
             IF OPPS-APC (LN-SUB) = '0339'
                  MOVE 1 TO OPPS-SRVC-UNITS (LN-SUB).


      ***************************************************************
      *  CALCULATE DISCOUNT RATE (FOR REDUCED COIN & OFFSET CALCS)  *
      ***************************************************************
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 7250-CALC-DISCOUNT
                THRU 7250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 7150-INIT-EXIT.


      ***************************************************************
      *  ACCUMULATE TOTAL CLAIM DEVICE SERVICE UNITS -AND-          *
      *  FLAG CLAIMS THAT HAVE AT LEAST ONE DEVICE LINE             *
      *    - SI = H IDENTIFIES DEVICE LINES                         *
      *    - EFFECTIVE AS OF 04-01-2002                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' H'
                MOVE 'Y' TO C-FLAG
                COMPUTE H-TOT-HTD-UNITS =
                        H-TOT-HTD-UNITS + H-SRVC-UNITS.


      ***************************************************************
      *  ACCUMULATE CLAIM TOTAL OFFSET AMOUNT & OFFSET UNITS        *
      *  WHEN HCPCS C1820 IS ON THE CLAIM                           *
      *-------------------------------------------------------------*
      * - HCPCS C1820 EXPIRES FROM PASS-THRU PMT 01-01-2008.  THERE *
      *   ARE NO OFFSET DEVICES FOR CY 2008; LOGIC RETAINED & ALL   *
      *   OFFSET AMOUNTS IN OFFSET TABLE SET TO $0.                 *
      ***************************************************************
             IF C1820-OFFSET-FLAG = 'Y'
                PERFORM 7160-TOTAL-OFFSET
                   THRU 7160-TOTAL-OFFSET-EXIT.


      ***************************************************************
      *  SET AND INTIALIZE LINE SPECIFIC DATA ITEMS                 *
      ***************************************************************

      *-------------------------------------------------------------*
      * SET COIN & BLOOD DEDUCTIBLE TABLES UP FOR CURRENT LINE      *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).

      *-------------------------------------------------------------*
      * INITIALIZE LINE ITEM VARIABLES TO BE PASSED BACK            *
      *-------------------------------------------------------------*
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

      *-------------------------------------------------------------*
      * INITIALIZE LINE FLAGS                                       *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      *-------------------------------------------------------------*
             MOVE 'N' TO PHP-HCPCS-FLAG  MH-HCPCS-FLAG.


      ***************************************************************
      *  SEARCH PARTIAL HOSPITALIZATION (PHP) TABLE FOR LINE HCPCS  *
      *  (LOGIC NEW FOR CY2008; ADDED 11/5/2007)                    *
      ***************************************************************
             SEARCH ALL PHP-ENTRY8
                AT END
                   MOVE 'N' TO PHP-HCPCS-FLAG
                WHEN PHP-HCPCS8 (PHP-INDX8) = OPPS-HCPCS (LN-SUB)
                   MOVE 'Y' TO PHP-HCPCS-FLAG.


      ***************************************************************
      *  SEARCH MENTAL HEALTH (MH) TABLE FOR LINE HCPCS             *
      *  (LOGIC NEW FOR CY2008; ADDED 11/5/2007)                    *
      ***************************************************************
             SEARCH ALL MH-ENTRY8
                AT END
                   MOVE 'N' TO MH-HCPCS-FLAG
                WHEN MH-HCPCS8 (MH-INDX8) = OPPS-HCPCS (LN-SUB)
                   MOVE 'Y' TO MH-HCPCS-FLAG.


      ***************************************************************
      *   POPULATE PASS-THROUGH DEVICE TABLE W/ PASS-THROUGH        *
      *   DEVICE LINE DATA                                          *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 AND
                PTD-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' H'

                  PERFORM 7665-SET-PTD-LINE-FLAG
                     THRU 7665-SET-PTD-LINE-FLAG-EXIT

                  IF PTD-LINE-FLAG = 'Y'
                     MOVE OPPS-HCPCS (LN-SUB) TO W-PTD-LINE-HCPCS
                     PERFORM 7390-PASS-THRU-DEVICES
                        THRU 7390-PASS-THRU-DEVICES-EXIT
                  END-IF

             END-IF.



      ***************************************************************
      *                                                             *
      *         **  CHECK LINE OCE VALUES FOR VALIDITY **           *
      *                                                             *
      ***************************************************************

      ***************************************************************
      *   IDENTIFY ALL VALID SERVICE INDICATORS (SI) & RETURN       *
      *   ERROR CODE 40 IF THE SI IS INVALID.                       *
      ***************************************************************
             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C'
                OR ' E' OR ' F' OR ' G' OR ' H' OR ' K' OR
                ' L' OR ' N' OR ' P' OR ' S' OR ' T' OR ' V' OR
                ' X' OR ' W' OR ' Y' OR ' Z' OR ' M') THEN
                  MOVE  40  TO A-RETURN-CODE (LN-SUB)
                  GO TO 7150-INIT-EXIT
             ELSE
                  MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *   IDENTIFY SERVICE INDICATORS (SI) NOT VALID FOR THE OPPS   *
      *   PRICER & RETURN ERROR CODE 41 IF THE SI IS INVALID        *
      *   FOR THE OPPS PRICER.                                      *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' L' OR ' W' OR ' Y' OR ' Z' OR ' M'
                  MOVE  41  TO A-RETURN-CODE (LN-SUB)
                  GO TO 7150-INIT-EXIT.


      ***************************************************************
      **                                                           **
      **  NOTE: ERROR CODES FOR THE VALIDATION RULES BELOW ARE     **
      **        ASSIGNED IN THE ELSE STATMENTS AFTER THE APC       **
      **        TABLE SEARCH.                                      **
      **                                                           **
      ***************************************************************

      ***************************************************************
      *   IDENTIFY VALID PAYMENT INDICATORS & RETURN ERROR CODE 43  *
      *   IF THE PAYMENT INDICATOR IS INVALID.                      *
      ***************************************************************
               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'


      ***************************************************************
      *   IDENTIFY VALID PACKAGING FLAGS & RETURN ERROR CODE 45     *
      *   IF THE PACKAGING FLAG IS INVALID.                         *
      ***************************************************************
                 IF OPPS-PKG-FLAG (LN-SUB) = '0'  OR '1'  OR '2'  OR
                                             '3'  OR '4'


      ***************************************************************
      *   IDENTIFY VALID LINE ITEM DENIAL OR REJECTION (D/R) FLAGS  *
      *   AND VALID D/R FLAG-HCPCS COMBINATIONS & RETURN ERROR CODE *
      *   46 IF THE D/R FLAG OR D/R FLAG-HCPCS COMBO IS INVALID.    *
      *-------------------------------------------------------------*
      * 11/6/2007 - CHANGED PHP/MENTAL HEALTH CODES LISTED FROM     *
      *             APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008    *
      ***************************************************************

      *--------------------------------------------------------*
      *   LINE IS NOT DENIED OR REJECTED                       *
      *--------------------------------------------------------*
                   IF ( OPPS-LITEM-DR-FLAG (LN-SUB) = '0' OR

      *--------------------------------------------------------*
      *   LINE IS DENIED OR REJECTED AND HAS A PHP OR MH HCPCS *
      *--------------------------------------------------------*
                        OPPS-LITEM-DR-FLAG (LN-SUB) = '1' AND

                            ( PHP-HCPCS-FLAG = 'Y' OR
                              MH-HCPCS-FLAG  = 'Y' ) ) OR

      *--------------------------------------------------------*
      *   LINE ITEM DENIAL/REJECTION CODE IS IGNORED           *
      *--------------------------------------------------------*
                      ( OPPS-LITEM-ACT-FLAG (LN-SUB) = '1' )



      ***************************************************************
      *   IDENTIFY INVALID LINE ITEM ACTION FLAGS & RETURN ERROR    *
      *   CODE 47 IF THE LINE ITEM ACTION FLAG IS INVALID.          *
      ***************************************************************
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')


      ***************************************************************
      *   IDENTIFY VALID PAYMENT ADJUSTMENT FLAGS (PAF) & RETURN    *
      *   ERROR CODE 48 IF THE PAF IS INVALID.                      *
      *-------------------------------------------------------------*
      * 10/31/2007 - ADDED ' 8' AS A VALID PAF FOR CY 2008          *
      * 12/06/2007 - ADDED PAFS 91 - 99 FOR COMPOSITES FOR CY 2008  *
      ***************************************************************
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                             OR ' 2' OR ' 3' OR ' 4' OR ' 5' OR ' 6'
                             OR ' 7' OR ' 8' OR '91' OR '92' OR '93'
                             OR '94' OR '95' OR '96' OR '97' OR '98'
                             OR '99'


      ***************************************************************
      *   IDENTIFY VALID SITE OF SERVICE (SOS) FLAG AND CASES       *
      *   WHERE THE SOS FLAG IS IGNORED & RETURN ERROR CODE 49 IF   *
      *   THE SOS FLAG IS INVALID AND NOT IGNORED.                  *
      *   NOTE: PHP = PARTIAL HOSPITALIZATION                       *
      *         WHEN SI = 'P', APC 0033 IS ON THE CURRENT LINE      *
      *-------------------------------------------------------------*
      * 11/6/2007 - CHANGED PHP HEALTH CODES LISTED FROM            *
      *             APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008    *
      ***************************************************************

      *-------------------------------------------------------------*
      *   LINE SOS FLAG IS VALID                                    *
      *-------------------------------------------------------------*
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR

      *-------------------------------------------------------------*
      *   LINE SOS FLAG INVALID & APC 33 ON CLAIM - CHECK FURTHER   *
      *-------------------------------------------------------------*
                            ( (APC33-FLAG = 'Y') AND

      *-------------------------------------------------------------*
      *   LINE SOS FLAG INVALID, APC 33 ON CLAIM, & LINE APC = 33   *
      *-------------------------------------------------------------*
                                ( (OPPS-SRVC-IND (LN-SUB) = ' P') OR

      *-------------------------------------------------------------*
      *   LINE SOS FLAG INVALID, APC 33 ON CLAIM, & LINE PHP HCPCS  *
      *-------------------------------------------------------------*
                                  (PHP-HCPCS-FLAG = 'Y') ) )



      ***************************************************************
      *                                                             *
      *  **  ACCUMULATE TOTAL CHARGES OF ALL LINES THAT PASS  **    *
      *                  **  VALIDATION RULES  **                   *
      *                                                             *
      ***************************************************************
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG

                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

      *-------------------------------------------------------------*
      *   EXCLUDE LINES THAT RECEIVE EXTERNAL LINE ITEM ADJ.        *
      *-------------------------------------------------------------*
                IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED LINE TOTAL CHARGES & SET CLAIM N-FLAG *
      *   EXCLUDE PACKAGED COMPOSITE & MENTAL HEALTH (MH) LINES     *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED TO EXCLUDE COMPOSITE & MENTAL    *
      *                HEALTH LINES (APC34-FLAG INDICATES MH)       *
      *   08/08/2008 - LOGIC CORRECTED TO ADD CHARGES OF PACKAGED   *
      *                LINES WITH A PACKAGING FLAG OF '1' OR '4' TO *
      *                THE CLAIM'S TOTAL DISTRIBUTED PACKAGED       *
      *                CHARGES WHEN A CLAIM HAS APC 34 (MENTAL      *
      *                HEALTH) ON IT - EFFECTIVE RETROCTIVE TO      *
      *                JANUARY 1, 2008.                             *
      *-------------------------------------------------------------*
                IF (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4') AND
                   NOT (OPPS-PYMT-ADJ-FLAG (LN-SUB) =
                       '91' OR '92' OR '93' OR '94' OR '95' OR
                       '96' OR '97' OR '98' OR '99') AND
                   NOT (APC34-FLAG = 'Y' AND
                        OPPS-PKG-FLAG (LN-SUB) = '2')
                      COMPUTE H-TOT-N-CHRG = H-SUB-CHRG +
                                             H-TOT-N-CHRG
                      MOVE 'Y' TO N-FLAG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED MENTAL HEALTH LINE CHARGES            *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED FOR CY 2008                      *
      *-------------------------------------------------------------*
                IF (APC34-FLAG = 'Y') AND
                   (OPPS-SRVC-IND (LN-SUB) = ' N') AND
                   (OPPS-PKG-FLAG (LN-SUB) = '2')
                      COMPUTE H-TOT-MH-CHRG = H-SUB-CHRG +
                                              H-TOT-MH-CHRG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE NON-PRIME COMPOSITE APC CHARGES FOR EACH       *
      *   COMPOSITE APC USING PACKAGED LINES WITH A PAF = 91 - 99   *
      *   (POPULATE COMPOSITE TABLE)                                *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED FOR CY 2008                      *
      *-------------------------------------------------------------*
                IF (OPPS-PYMT-ADJ-FLAG (LN-SUB) =
                       '91' OR '92' OR '93' OR '94' OR '95' OR
                       '96' OR '97' OR '98' OR '99') AND
                   (OPPS-SRVC-IND (LN-SUB) = ' N')
                      PERFORM 7170-COMPOSITES
                         THRU 7170-COMPOSITES-EXIT
                END-IF

      *-------------------------------------------------------------*
      *   RETURN ERROR CODE WHEN PACKAGED LINE OR LINE APC = 0000   *
      *-------------------------------------------------------------*
                IF (OPPS-APC (LN-SUB) = '0000') OR
                   (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                      MOVE 42 TO A-RETURN-CODE (LN-SUB)
                      GO TO 7150-INIT-EXIT
                END-IF



      ***************************************************************
      *                                                             *
      *  **  LOOK-UP LINE APC IN APC TABLE FOR ALL LINES THAT  **   *
      *                ** PASS VALIDATION RULES  **                 *
      *                                                             *
      ***************************************************************
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 7150-INIT-EXIT

                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)

      *-------------------------------------------------------------*
      *   START SEARCH AT THE APC'S MOST CURRENT RECORD             *
      *-------------------------------------------------------------*
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2

      *-------------------------------------------------------------*
      *   GET APC DATA FROM THE REC WITH THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                      PERFORM 7175-APC-LOOKUP



      ***************************************************************
      *                                                             *
      *     **  RETURN ERROR CODE AND STOP PROCESSING LINES  **     *
      *            **  THAT FAIL OCE VALIDATION RULES  **           *
      *                                                             *
      ***************************************************************
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 7150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 7150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 7150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 7150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 7150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 7150-INIT-EXIT.



      ***************************************************************
      *   PROCESS BLOOD DEDUCTIBLE (EFFECTIVE AS OF 07-01-2005)     *
      *     - TOTAL BLOOD CODE CHARGES WHEN PAF = '5' OR '6'        *
      *       5: BLOOD/BLOOD PRODUCT USED IN BLOOD DEDUC CALC       *
      *       6: BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE H-TOT-38X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' OR ' 6'
                COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X-39X.


      ***************************************************************
      *   POPULATE COINSURANCE DEDUCTIBLE TABLE W/ ALL VALID LINES  *
      *   ORDERED LOWEST TO HIGHEST RANK FROM APC TABLE             *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01
                PERFORM 7300-COIN-DEDUCT
                   THRU 7300-COIN-DEDUCT-EXIT.


      ***************************************************************
      *   POPULATE BLOOD DEDUCTIBLE TABLE W/ BLOOD DEDUC LINES      *
      *   ORDERED EARLIEST TO LATEST DATE OF SERVICE AND THEN       *
      *   LOWEST TO HIGHEST RANK FROM BLOOD DEDUCTIBLE TABLE        *
      *   (APPLIES WHEN HCPCS IS IN BLOOD DEDUCTIBLE RANKING TABLE) *
      *                                                             *
      *   05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD  *
      *                DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.   *
      *                FIX EFFECTIVE RETROACTIVE TO 01/01/2008.     *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01
                SET W8BD-INDX TO 1
                SEARCH W8BD-ENTRY VARYING W8BD-INDX
                   AT END
                      GO TO 7150-INIT-EXIT
                   WHEN W-2008-BLOOD-HCPCS (W8BD-INDX) =
                                            OPPS-HCPCS (LN-SUB)
                    IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                      MOVE W-2008-BLOOD-RANK (W8BD-INDX) TO H-BLOOD-RANK
                      MOVE OPPS-LITEM-DOS (LN-SUB) TO H-BLD-DOS
                      PERFORM 7375-BLOOD-DEDUCT
                         THRU 7375-BLOOD-DEDUCT-EXIT
                    END-IF.

       7150-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * ACCUMULATE CLAIM TOTAL OFFSET AMT FROM CY 2008 OFFSET TABLE *
      *                     FOR PASS-THRU ITEMS                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      *      - SEARCH TABLE OPPSOF08 FOR LINE APC.                  *
      *      - CALCULATE TOTAL OFFSET & TOTAL OFFSET UNITS IF APC   *
      *        OFFSET AMOUNT IN TABLE NOT EQUAL TO 0.               *
      *      * NOTE: C1820 EXPIRES FROM PASS-THRU PAYMENT IN 2008.  *
      *              ALL OFFSET AMOUNTS IN THE 2008 TABLE = $0.     *
      *              THIS LOGIC KEPT FOR FUTURE OFFSET CODES.       *
      *                                                             *
      *      EFFECTIVE AS OF 01-01-2003                             *
      *      - CONTINUE FOR  01-01-2004                             *
      *      - CONTINUE FOR  01-01-2005                             *
      *      - CONTINUE FOR  01-01-2006                             *
      *      - CONTINUE FOR  01-01-2007                             *
      *      - CONTINUE FOR  01-01-2008 (ALL OFFSETS IN TBL = $0)   *
      *      - CONTINUE FOR  01-01-2009 (ALL OFFSETS IN TBL = $0)   *
      *                                                             *
      ***************************************************************
       7160-TOTAL-OFFSET.

             MOVE OPPS-GRP (LN-SUB) TO W-OFF-APC.
             SEARCH ALL WOO-ENTRY8
                AT END
                   GO TO 7160-TOTAL-OFFSET-EXIT
                WHEN WOO-APC8 (WOO-INDX8) = W-OFF-APC
                   PERFORM 7161-TOTAL-OFFSET-AMT
                      THRU 7161-TOTAL-OFFSET-AMT-EXIT.

       7160-TOTAL-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *       ACCUMULATE CLAIM TOTAL OFFSET AND OFFSET UNITS        *
      *                                                             *
      ***************************************************************
       7161-TOTAL-OFFSET-AMT.

           IF WOO-OFFSET8 (WOO-INDX8) EQUAL 0
              GO TO 7161-TOTAL-OFFSET-AMT-EXIT.

           COMPUTE H-TOTAL-OFFSET = H-TOTAL-OFFSET
              + (WOO-OFFSET8 (WOO-INDX8) * H-DISC-RATE * H-SRVC-UNITS).

           COMPUTE H-TOT-OFF-UNITS = H-TOT-OFF-UNITS + H-SRVC-UNITS.

           IF H-TOTAL-OFFSET < 0
              MOVE 0 TO H-TOTAL-OFFSET.

       7161-TOTAL-OFFSET-AMT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  ACCUMULATE NON-PRIME COMPOSITE APC CHARGES FOR EACH        *
      *  COMPOSITE APC USING PACKAGED LINES WITH A PAF = 91 - 99    *
      *  & POPULATE COMPOSITE APC TABLE                             *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER SERVICE LINES BY PAYMENT ADJUSTMENT FLAG (PAF) -     *
      *    LOWEST TO HIGHEST FLAG VALUE (91 - 99)                   *
      *                                                             *
      *  EACH NON-PRIME COMPOSITE PACKAGED LINE'S CHARGES ARE ADDED *
      *  TO THE TOTAL NON-PRIME CHARGES FOR EACH PAF, WHICH         *
      *  CORRESPONDS TO THE PRIME LINE'S APC.  THESE CHARGES ARE    *
      *  LATER ADDED TO THE PRIME LINE'S CHARGES TO CALCULATE THE   *
      *  OUTLIER PAYMENT.                                           *
      *                                                             *
      *  11/28/2007 - LOGIC ADDED FOR CY 2008                       *
      *                                                             *
      ***************************************************************
       7170-COMPOSITES.

      *-------------------------------------------------------------*
      * GET THE LINE'S PAYMENT ADJUSTMENT FLAG FOR TABLE SEARCH     *
      *-------------------------------------------------------------*
             MOVE OPPS-PYMT-ADJ-FLAG (LN-SUB) TO H-CMP-PAF.

      *-------------------------------------------------------------*
      * ADD OR UPDATE COMPOSITE APC TABLE ENTRY FOR THE PAF         *
      *-------------------------------------------------------------*
                PERFORM 7171-SEARCH-PAF
                   THRU 7171-SEARCH-PAF-EXIT.

       7170-COMPOSITES-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW COMPOSITE APC TABLE RECORD SHOULD   *
      * BE ADDED OR IF AN EXISITING RECORD NEEDS TO BE UPDATED      *
      *                                                             *
      ***************************************************************
       7171-SEARCH-PAF.

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO 1.
             SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS NOT        *
      * ALREADY IN THE TABLE, ADD IT                                *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 7172-ADD-ENTRY
                      THRU 7172-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS ALREADY IN *
      * THE TABLE, UPDATE THE ENTRY                                 *
      *-------------------------------------------------------------*
                WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-PAF
                   PERFORM 7173-UPDATE-ENTRY
                      THRU 7173-UPDATE-ENTRY-EXIT.

       7171-SEARCH-PAF-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COMPOSITE APC RECORD IN THE CORRECT POSITION *
      * (LOWEST TO HIGHEST PAF) OF THE COMPOSITE APC TABLE          *
      *                                                             *
      ***************************************************************
       7172-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW COMPOSITE APC ENTRY FOR THE CURRENT *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS PAYMENT ADJUSTMENT FLAG (PAF) - LOWEST TO HIGHEST PAF.  *
      *-------------------------------------------------------------*
             PERFORM 7174-STAGE-CMP-ENTRY
                THRU 7174-STAGE-CMP-ENTRY-EXIT
                  UNTIL W-CMP-INDX = 1 OR
                     H-CMP-PAF NOT < W-CMP-PAF (W-CMP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE H-CMP-PAF  TO W-CMP-PAF (W-CMP-INDX).
             MOVE H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       7172-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING COMPOSITE APC RECORD WITH THE SAME      *
      * PAYMENT ADJUSTMENT FLAG OF THE CURRENT SERVICE LINE         *
      *                                                             *
      ***************************************************************
       7173-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * ACCUMULATE THE PAF'S TOTAL NON-PRIME SUBMITTED CHARGES      *
      *-------------------------------------------------------------*
             ADD H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       7173-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING COMPOSITE APC RECORD WITH A HIGHER PAF    *
      * UP ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE     *
      * NEW ENTRY'S INDEX TO THE NEXT LOWER RECORD POSITION.        *
      *                                                             *
      ***************************************************************
       7174-STAGE-CMP-ENTRY.

             MOVE W-CMP-ENTRY (W-CMP-INDX - 1) TO
                  W-CMP-ENTRY (W-CMP-INDX).
             SET W-CMP-INDX DOWN BY 1.

       7174-STAGE-CMP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      ***************************************************************
       7175-APC-LOOKUP.

      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS BEFORE OR ON THE LATEST       *
      *  EFFECTIVE DATE THE CLAIM CAN USE (SEARCH STARTS AT THE     *
      *  MOST CURRENT RECORD FOR THE APC)                           *
      ***************************************************************
             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC DELETED - ERROR     *
      *-------------------------------------------------------------*
                IF WAR-RATEX (W-SUB2) = 'DELETED'
                   MOVE 30 TO A-RETURN-CODE (LN-SUB)
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC ACTIVE - ACCEPT REC *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                   MOVE WAR-RANK (W-SUB2) TO H-RANK
                   MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                   MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                   MOVE WAR-PPCT (W-SUB2) TO H-PPCT


      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS AFTER THE LATEST EFFECTIVE    *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  APC TABLE.                                                 *
      ***************************************************************
             ELSE
                   SUBTRACT 1 FROM W-SUB2

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE LINE APC, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                   IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                      GO TO 7175-APC-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE LINE APC WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZEROS.                *
      *-------------------------------------------------------------*
                   ELSE
                      MOVE 0 TO H-APC-PYMT
                                H-RANK
                                H-MIN-COIN
                                H-NAT-COIN
                                H-PPCT.

       7175-APC-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DELETED CODE:                                              *
      *    IF DATE OF SERVICE BETWEEN 12/31/2002 AND 04/01/2003     *
      *    IF HCPCS CODE = C9114 OR C9115 ADJUST PAYMENT AND        *
      *    COINSURANCE AMOUNTS - LOGIC REMOVED FOR 20050101         *
      *                                                             *
      ***************************************************************


      ***************************************************************
      *                                                             *
      *    SEARCH WAGE INDEX TABLE FOR THE CBSA IN THE PROVIDER     *
      *                     SPECIFIC FILE (PSF)                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    IF CBSA NOT LOCATED                                      *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       7200-CALC-WAGEINDX.

      ***************************************************************
      * STARTING AT THE LAST DATE IN THE TABLE, SEARCH WAGE INDEX   *
      * DATE TABLE FOR THE MOST CURRENT EFFECTIVE DATE THAT CAN BE  *
      * USED BY THE CLAIM                                           *
      ***************************************************************
             MOVE WCD-MAX TO WCD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WCD-DATE (WCD-SUB)
                 SUBTRACT 1 FROM WCD-SUB
             END-PERFORM.


      ***************************************************************
      *   SEARCH CBSA TABLE FOR THE PSF CBSA                        *
      ***************************************************************
             SEARCH ALL WCM-ENTRY

      *-------------------------------------------------------------*
      *   PSF CBSA NOT FOUND IN CBSA TABLE, RETURN ERROR            *
      *-------------------------------------------------------------*
                AT END
                   MOVE  50  TO A-CLM-RTN-CODE
                   GO TO 7200-CALC-WAGEINDX-EXIT

      *-------------------------------------------------------------*
      *   PSF CBSA FOUND IN CBSA TABLE                              *
      *-------------------------------------------------------------*
                WHEN WCM-CBSA (WCM-INDX) = H-PSF-CBSA

      *-------------------------------------------------------------*
      *   START SEARCH AT THE MOST CURRENT RECORD FOR THE CBSA      *
      *-------------------------------------------------------------*
                  MOVE WCM-PTR (WCM-INDX) TO W-SUB3

      *-------------------------------------------------------------*
      *   GET WAGE INDEX FROM THE REC W/ THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                  PERFORM 7210-WAGE-LOOKUP.


      ***************************************************************
      *   RETURN ERROR IF WAGE INDEX = 0                            *
      ***************************************************************
             IF H-WINX1 = 0 THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       7200-CALC-WAGEINDX-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE CBSA RECORD WITH THE APPROPRIATE EFFECTIVE DATE *
      *     WHEN FOUND, SELECT THE APPLICABLE WAGE INDEX VALUE      *
      *                                                             *
      ***************************************************************
       7210-WAGE-LOOKUP.

      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE IS BEFORE OR ON THE       *
      *  LATEST EFFECTIVE DATE THE CLAIM CAN USE - CORRECT          *
      *  (SEARCH STARTS AT THE MOST CURRENT RECORD FOR THE CBSA)    *
      ***************************************************************
             IF WCW-DTCD (W-SUB3) NOT > WCD-DTCD (WCD-SUB)

      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS RECLASSIFIED, USE THE WAGE INDEX IN THE *
      *   SECOND COLUMN FOR RECLASSIFYING PROVIDERS.                *
      *-------------------------------------------------------------*
                IF L-PSF-SPEC-PYMT-IND = 'Y'
                   MOVE WCW-WINX2 (W-SUB3) TO H-WINX1

      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS NOT RECLASSIFIED, USE THE WAGE INDEX IN *
      *   THE FIRST COLUMN FOR AREA PROVIDERS.                      *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WCW-WINX1 (W-SUB3) TO H-WINX1


      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE IS AFTER LATEST EFFECTIVE *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  CBSA WAGE INDEX TABLE.                                     *
      ***************************************************************
             ELSE
                SUBTRACT 1 FROM W-SUB3

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE PSF CBSA, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                IF W-SUB3 > WCM-PTR (WCM-INDX - 1)
                   GO TO 7210-WAGE-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE PSF CBSA WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZERO.                 *
      *-------------------------------------------------------------*
                ELSE
                   MOVE 0 TO H-WINX1.

       7210-WAGE-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE DISCOUNT RATE BASED ON THE DISCOUNT            *
      *    FACTOR PASSED BY THE OCE: VALUES 1 - 9                   *
      *                                                             *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *       - DISCONTINUE LINE PROCESSING                         *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  11/1/2007 - NEW DISCOUNT INDICATOR 9 ADDED FOR CY 2008     *
      *                                                             *
      ***************************************************************
       7250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 7250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     IF OPPS-DISC-FACT (LN-SUB) = 9 THEN
                        COMPUTE H-DISC-RATE = 1 / H-SRVC-UNITS
                     ELSE
                        MOVE  38  TO A-RETURN-CODE (LN-SUB).

       7250-CALC-DISCOUNT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  POPULATE COINSURANCE DEDUCTIBLE TABLE WITH SERVICE LINES   *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY THE DEDUCTIBLE SEQUENCE -         *
      *     LOWEST TO HIGHEST APC RANK FROM APC TABLE               *
      *                                                             *
      *     DEDUCTIBLE WILL BE TAKEN FROM OPPS SERVICES FIRST,      *
      *     THEN FROM ANY OTHER TYPES OF SERVICES FROM THE CLAIM.   *
      *     ALL VALID SERVICE LINES APPEAR IN THIS TABLE IN THE     *
      *     ORDER OF THEIR RANK FROM LOWEST TO HIGHEST.             *
      *       - THE LOWER THE RANK, THE HIGHER % THE NATIONAL       *
      *         UNADJUSTED COINSURANCE IS OF THE APC PAYMENT RATE   *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW COINSURANCE DEDUCTIBLE TABLE RECORD)           *
      *                                                             *
      *   NOTE: THE PURPOSE OF APC RANKING IS TO ENSURE THAT THE    *
      *         BENEFICIARY DEDUCTIBLE GOES TOWARD LINES WITH       *
      *         HIGHER COINSURANCE %S FIRST.  THIS RESULTS IN THE   *
      *         BENEFICIARY PAYING LESS TOTAL COINSURANCE FOR THE   *
      *         CLAIM.                                              *
      *                                                             *
      ***************************************************************
       7300-COIN-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      *-------------------------------------------------------------*
             PERFORM 7350-STAGE-ENTRY
                THRU 7350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB      TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN  TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN  TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG  TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT  TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX1     TO W-WINX1 (W-LP-INDX).
             MOVE H-RANK      TO W-RANK (W-LP-INDX).
             MOVE H-PPCT      TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

      *-------------------------------------------------------------*
      * PARTIAL HOSPITALIZATION LINES RECEIVE 1 SERVICE UNIT        *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)

      *-------------------------------------------------------------*
      * NON-PARTIAL HOSPITALIZATION LINES RECEIVE INPUT SVC UNITS   *
      *-------------------------------------------------------------*
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       7300-COIN-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING COINSURANCE DEDUCTIBLE RECORD WITH A    *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       7350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       7350-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     POPULATE BLOOD DEDUCTIBLE TABLE WITH SERVICE LINES      *
      *            THAT HAVE A BLOOD DEDUCTIBLE HCPCS               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY DEDUCTIBLE SEQUENCE -             *
      *     1. EARLIEST TO LATEST DATE OF SERVICE                   *
      *     2. LOWEST TO HIGHEST BLOOD RANK FROM BLOOD DEDUC TABLE  *
      *                                                             *
      *     DEDUCTIBLES WILL PAID FOR LINES IN THE ORDER OF DATE OF *
      *     SERVICE (EARLIEST TO LATEST) AND THEN BY COST (LEAST TO *
      *     MOST EXPENSIVE).  ONLY VALID LINES WITH A HCPCS IN THE  *
      *     BLOOD DEDUCTIBLE RANKING TABLE APPEAR IN THIS TABLE.    *
      *       - BLOOD RANK OF 1 IS ASSIGNED TO THE LEAST EXPENSIVE  *
      *         BLOOD CODE                                          *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW BLOOD DEDUCTIBLE TABLE RECORD)                 *
      *                                                             *
      *    NOTE: THE PURPOSE OF BLOOD LINE RANKING IS TO ENSURE     *
      *          THAT THE BENEFICIARY PAYS DEDUCTIBLES FOR THE      *
      *          THREE LEAST EXPENSIVE BLOOD PRODUCTS.              *
      *                                                             *
      ***************************************************************
       7375-BLOOD-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-BD-INDX TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      * (RANK IS THE DATE OF SERVICE & BLOOD RANK)                  *
      *-------------------------------------------------------------*
             PERFORM 7385-STAGE-ENTRY
                THRU 7385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLD-RNK NOT < W-BD-RNK (W-BD-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX1    TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK  TO W-BD-RANK (W-BD-INDX).
             MOVE H-BLD-DOS TO W-BD-DOS (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).


      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       7375-BLOOD-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING BLOOD DEDUCTIBLE RECORD WITH A          *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       7385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       7385-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *            POPULATE PASS-THROUGH DEVICE TABLE               *
      *            (IMPLEMENTED IN APRIL 2008 PRICER)               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER RECORDS AS FOLLOWS -                                 *
      *     1. HCPCS, ASCENDING                                     *
      *     2. LOWEST TO HIGHEST LINE SUBSCRIPT                     *
      *                                                             *
      *  02/11/2008 - LOGIC ADDED FOR CY 2008, QTR 2                *
      *                                                             *
      ***************************************************************
       7390-PASS-THRU-DEVICES.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-PTD-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-PTD-INDX TO W-PTD-MAX.
             INITIALIZE W-PTD-ENTRY (W-PTD-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW RECORD SHOULD BE ENTERED INTO THE   *
      * TABLE ACCORDING TO ITS HCPCS AND THE HCPCS OF THE RECORDS   *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST HCPCS              *
      *-------------------------------------------------------------*
             PERFORM 7391-STAGE-ENTRY
                THRU 7391-STAGE-ENTRY-EXIT
                   UNTIL W-PTD-INDX = 1 OR
                     W-PTD-LINE-HCPCS NOT <
                       W-PTD-HCPCS (W-PTD-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE OPPS-HCPCS (LN-SUB)    TO W-PTD-HCPCS (W-PTD-INDX).
             MOVE LN-SUB                 TO W-PTD-SUB (W-PTD-INDX).
             MOVE OPPS-SUB-CHRG (LN-SUB) TO W-PTD-SUB-CHRG (W-PTD-INDX).

       7390-PASS-THRU-DEVICES-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING PASS-THROUGH DEVICE RECORD WITH A       *
      *   HIGHER HCPCS UP ONE RECORD POSITION AND SET THE INDEX OF  *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       7391-STAGE-ENTRY.

             MOVE W-PTD-ENTRY (W-PTD-INDX - 1) TO
                  W-PTD-ENTRY (W-PTD-INDX).
             SET W-PTD-INDX DOWN BY 1.

       7391-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    UPDATE PASS-THROUGH DEVICE TABLE WITH PROCEDURE DATA     *
      *              (IMPLEMENTED IN APRIL 2008 PRICER)             *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  02/11/2008 - LOGIC ADDED FOR CY 2008, QTR 2                *
      *                                                             *
      ***************************************************************
       7392-PASS-THRU-DEV-PROCS.

      *-------------------------------------------------------------*
      * LOOP THROUGH ELIGIBLE PROCEDURE'S PASS-THROUGH DEVICE TABLE *
      *-------------------------------------------------------------*
             PERFORM 7393-PERFORM-SEARCH
                THRU 7393-PERFORM-SEARCH-EXIT
                VARYING W-PTD-PROC-SUB FROM 1 BY 1
                UNTIL W-PTD-PROC-SUB > W-PTD-CNT.

       7392-PASS-THRU-DEV-PROCS-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * SEARCH FOR THE PASS-THROUGH DEVICE FOR WHICH THE PROCEDURE  *
      * IS ELIGIBLE IN THE TABLE                                    *
      *                                                             *
      ***************************************************************
       7393-PERFORM-SEARCH.

      *-------------------------------------------------------------*
      * SEARCH PTD TABLE STARTING AT ENTRY #1 FOR ALL OCCURANCES    *
      * OF THE PASS-THRU DEVICE HCPCS IN THE PASS-THRU DEVICE TABLE.*
      * THIS IS DONE FOR ALL PASS-THROUGH DEVICES THE PROCEDURE IS  *
      * ELIGIBLE FOR.                                               *
      *-------------------------------------------------------------*
                 MOVE 'N' TO W-END-OF-PTD-TBL.

                 IF W-PTD-PROC-HCPCS (W-PTD-PROC-SUB) NOT = '     '
                    SET W-PTD-INDX TO 1
                    PERFORM 7394-SEARCH-PTD-HCPCS
                       THRU 7394-SEARCH-PTD-HCPCS-EXIT
                      UNTIL W-END-OF-PTD-TBL = 'Y'
                 END-IF.

       7393-PERFORM-SEARCH-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * SEARCH FOR THE PASS-THROUGH DEVICE FOR WHICH THE PROCEDURE  *
      * IS ELIGIBLE IN THE TABLE                                    *
      *                                                             *
      ***************************************************************
       7394-SEARCH-PTD-HCPCS.

             MOVE 'N' TO W-END-OF-PTD-TBL.

      *-------------------------------------------------------------*
      * SEARCH PASS-THROUGH DEVICE TABLE                            *
      *-------------------------------------------------------------*
             SEARCH W-PTD-ENTRY VARYING W-PTD-INDX

      *-------------------------------------------------------------*
      * IF THERE ARE NO MORE OCCURANCES OF THE PASS-THROUGH DEVICE, *
      * STOP THE SEARCH AND INDICATE END OF FILE                    *
      *-------------------------------------------------------------*
                AT END
                   MOVE 'Y' TO W-END-OF-PTD-TBL
                   GO TO 7394-SEARCH-PTD-HCPCS-EXIT

      *-------------------------------------------------------------*
      * IF THE PASS-THROUGH DEVICE IS FOUND, INDICATE NOT END OF    *
      * FILE AND UPDATE THE DEVICE'S RECORD WITH THE PROCEDURE DATA *
      *-------------------------------------------------------------*
                WHEN  W-PTD-HCPCS (W-PTD-INDX) =
                      W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)

                         MOVE 'N' TO W-END-OF-PTD-TBL

                         PERFORM 7395-UPDATE-ENTRY
                            THRU 7395-UPDATE-ENTRY-EXIT

                         SET W-PTD-INDX UP BY 1

             END-SEARCH.

       7394-SEARCH-PTD-HCPCS-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING PASS-THROUGH DEVICE RECORD WITH THE     *
      * CURRENT ELIGIBLE PROCEDURE'S DATA                           *
      *                                                             *
      ***************************************************************
       7395-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * UPDATE PASS-THROUGH DEVICE RECORD                           *
      *-------------------------------------------------------------*
             ADD 1 TO W-PTD-PROC-CNT (W-PTD-INDX).

             ADD OPPS-SRVC-UNITS (LN-SUB) TO
                 W-PTD-TOTAL-PROC-UNITS (W-PTD-INDX).

       7395-UPDATE-ENTRY-EXIT.
           EXIT.




      ***************************************************************
      *                                                             *
      *  CALCULATE LINE PYMNTS, DEDUCTIBLES, REIM., & COINSURANCE,  *
      *  ACCUMULATE CLAIM TOTALS, POPULATE DRUG DEDUCTIBLE TABLE,   *
      *  UPDATE PASS-THROUGH DEVICE TABLE WITH PROCEDURE & DEVICE   *
      *  LINE DATA, MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE    *
      *  FOLLOWING FOR EACH SERVICE LINE:                           *
      *                                                             *
      *  - CHECK ALL APPROPRIATE FLAGS AND INDICATORS FROM OCE      *
      *  - SET RETURN CODES TO INDICATE ERRORS OR STATUS            *
      *      '20' - LINE PROCESSED BUT PAYMENT = 0,                 *
      *             BENE DEDUCTIBLE => ADJUSTED PAYMENT             *
      *  - CALCULATE & ACCUMULATE LINE AND CLAIM LEVEL ITEMS        *
      *  - POPULATE DRUG COINSURANCE TABLE                          *
      *  - MOVE LINE VARIABLE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
       7400-CALCULATE.

      *-------------------------------------------------------------*
      * SET THE SERVICE LINE SUBSCRIPT TO THE CLAIM SERVICE LINE #  *
      * ASSOCIATED WITH THE COINSURANCE DEDUCTIBLE TABLE RECORD     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * STOP PROCESSING LINE IF ERROR CODE                          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 7400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *   - LINE ITEM REIMBURSEMENT IF MAX COIN LIMIT EXCEEDED      *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 7550-CALC-STANDARD
                   THRU 7550-CALC-STANDARD-EXIT
             ELSE
                GO TO 7400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * POPULATE DRG COINSURANCE TABLE FOR LATER PROCESSING         *
      *  - ENFORCE INPATIENT COINSURANCE LIMIT                      *
      *  - SET GJK-FLAG WHEN SERVICE = G OR K                       *
      *-------------------------------------------------------------*
             IF (A-RETURN-CODE (LN-SUB) <  30)
                PERFORM 7450-ADJ-PROC-COIN
                   THRU 7450-ADJ-PROC-COIN-EXIT
             ELSE
                NEXT SENTENCE.

      *-------------------------------------------------------------*
      * FLAG CLAIMS WITH ARTIFICIAL CHARGES AND TOTAL PAYMENTS &    *
      * CHARGES FOR ARTIFICIAL CHARGE AND PACKAGING PROCESSING      *
      *-------------------------------------------------------------*
             PERFORM 7500-ADJ-CHRGS
                THRU 7500-ADJ-CHRGS-EXIT.


      *-------------------------------------------------------------*
      *   UPDATE PASS-THROUGH DEVICE TABLE W/ ELIGIBLE PROCEDURE    *
      *   LINE DATA                                                 *
      *   EFFECTIVE CY 2008 QTR 2, LOGIC ADDED 02/12/2008           *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) < 30 AND
                PTD-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR ' X'

                  PERFORM 7670-SET-PTD-PROC-FLAG
                     THRU 7670-SET-PTD-PROC-FLAG-EXIT

                  IF PTD-PROC-FLAG = 'Y'
                     PERFORM 7392-PASS-THRU-DEV-PROCS
                        THRU 7392-PASS-THRU-DEV-PROCS-EXIT
                  END-IF

             END-IF.

      *-------------------------------------------------------------*
      * ACCUMULATE CLAIM TOTALS USING DATA FROM THE CURRENT VALID   *
      * SERVICE LINE (IN THE COINSURANCE DEDUCTIBLE TABLE)          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) <  30

                COMPUTE A-TOTAL-CLM-DEDUCT =
                        H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT

                COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT

                COMPUTE A-BLOOD-DEDUCT-DUE =
                        A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK             *
      *  - THE LINE REIM. & ADJ-COIN IS ADJUSTED LATER (IF NEEDED)  *
      *    FOR THE INPATIENT DAILY LIMIT IN 7840-PROCESS-TYPE2      *
      *-------------------------------------------------------------*
               MOVE H-LITEM-PYMT      TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM      TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN        TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN        TO A-RED-COIN (LN-SUB)

               IF H-RED-COIN > H-NAT-COIN
                  MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF

               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.

      *-------------------------------------------------------------*
      * INITIALIZE LINE VARIABLES FOR THE NEXT SERVICE LINE IN THE  *
      * COINSURANCE DEDUCTIBLE TABLE                                *
      *-------------------------------------------------------------*
             MOVE ZERO TO LINE-HOLD-ITEMS.

       7400-CALCULATE-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     POPULATE DRUG COINSURANCE ROLL-UP TABLE WITH THE        *
      *  COINSURANCE AMOUNTS OF SERVICE LINES IN THE COINSURANCE    *
      *                      DEDUCTIBLE TABLE                       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ORDER LINES BY:                                             *
      *   1. DATE OF SERVICE (EARLIEST TO LATEST)                   *
      *   2. DCP-CODE - TYPE OF ENTRY BASED ON SERVICE INDICATOR    *
      *      DCP-CODE OF 1: DAY SUMMARY                             *
      *      DCP-CODE OF 2: DRUG / BLOOD LINE                       *
      *   THERE IS ONE TYPE 1 RECORD PER DAY; THERE MAY BE MULTIPLE *
      *   TYPE 2 RECORDS PER DAY - ONE FOR EVERY DRUG LINE          *
      *   ("DRUG" REFERS TO ANY SI = G OR K LINE FOR SIMPLICITY)    *
      *                                                             *
      * DRUG COINSURANCE RECORD COMBINATIONS:                       *
      *   - TYPE 1, COIN1 = 0, COIN2 > 0, & SI = X =>               *
      *       DRUG(S) ADMINISTERED INDEPENDENT OF A PROCEDURE VISIT *
      *       ON THE DATE OF SERVICE                                *
      *   - TYPE 1, COIN1 > 0, COIN2 = 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH NO DRUG(S) ADMINISTERED ON THE *
      *       DATE OF SERVICE                                       *
      *   - TYPE 1, COIN1 > 0, COIN2 > 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH DRUG(S) ADMINISTERED ON THE    *
      *       DATE OF SERVICE                                       *
      *   - TYPE 2, COIN1 = 0, COIN2 > 0, & SI = G OR K =>          *
      *       DRUG ADMINSTERED ON THE DATE OF SERVICE               *
      *                                                             *
      ***************************************************************
       7450-ADJ-PROC-COIN.

      ***************************************************************
      * MOVE LINE DATE OF SERVICE TO DATE OF SERVICE HOLD AREA      *
      ***************************************************************
             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.


      ***************************************************************
      *                                                             *
      * PROCESS SI = S, T, OR V LINES (PROCEDURE OR VISIT)          *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'

      *-------------------------------------------------------------*
      * CALCULATE WAGE ADJUSTED LINE NATIONAL COINSURANCE AMOUNT    *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX1 (W-LP-INDX) + .4)

      *-------------------------------------------------------------*
      * ENFORCE INPATIENT LIMIT ON NATIONAL COINSURANCE AMOUNT      *
      *-------------------------------------------------------------*
                IF H-NEW-WGNAT > H-IP-LIMIT
                   MOVE H-IP-LIMIT TO H-NEW-WGNAT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                     H-TOTAL-LN-DEDUCT -
                                     H-LITEM-REIM -
                                     H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE DRUG COINSURANCE TABLE ENTRY FOR THE DOS      *
      *-------------------------------------------------------------*
                PERFORM 7455-SEARCH-KEY
                   THRU 7455-SEARCH-KEY-EXIT


      ***************************************************************
      *                                                             *
      * PROCESS SI = G OR K LINES ("DRUG")                          *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                        H-TOTAL-LN-DEDUCT -
                                        H-LITEM-REIM -
                                        H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * SET GJK-FLAG TO INDICATE "DRUG" LINE                        *
      *-------------------------------------------------------------*
                   MOVE 'Y' TO GJK-FLAG

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                   MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE DRUG COINSURANCE TABLE ENTRY FOR THE DOS      *
      *-------------------------------------------------------------*
                   PERFORM 7455-SEARCH-KEY
                      THRU 7455-SEARCH-KEY-EXIT

      *-------------------------------------------------------------*
      * INDICATE TYPE 2 RECORD (ONE TYPE 2 REC FOR EVERY DRUG LINE) *
      *-------------------------------------------------------------*
                   MOVE 2 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
                   ADD 1 TO W-DCP-MAX

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      * A NEW TYPE 2 RECORD ENTRY IS CREATED FOR EVERY SI = G OR K  *
      * SERVICE LINE REGARDLESS OF THE DATE OF SERVICE              *
      *-------------------------------------------------------------*
                   SET W-DCP-INDX TO W-DCP-MAX

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW DRUG / DEVICE COINSURANCE ENTRY     *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY. (RECORD TYPE 2 ONLY)     *
      *-------------------------------------------------------------*
                   PERFORM 7475-STAGE-DCP-ENTRY
                      THRU 7475-STAGE-DCP-ENTRY-EXIT
                        UNTIL W-DCP-INDX = 1 OR
                         H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 2, "DRUG"                                       *
      *-------------------------------------------------------------*
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       7450-ADJ-PROC-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW DRUG/DEVICE COINSURANCE TABLE       *
      * RECORD SHOULD BE ADDED OR IF AN EXISITING RECORD NEEDS TO   *
      * BE UPDATED                                                  *
      *                                                             *
      * (RECORD KEY IS DATE OF SERVICE & RECORD TYPE)               *
      *                                                             *
      ***************************************************************
       7455-SEARCH-KEY.

      *-------------------------------------------------------------*
      * SEARCH DRUG/DEVICE COINSURANCE TABLE STARTING AT ENTRY #1   *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS NOT ALREADY IN THE TABLE, ADD IT                         *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 7460-ADD-ENTRY
                      THRU 7460-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS ALREADY IN THE TABLE, UPDATE THE ENTRY                   *
      *-------------------------------------------------------------*
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 7465-UPDATE-ENTRY
                      THRU 7465-UPDATE-ENTRY-EXIT.

       7455-SEARCH-KEY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COINSURANCE RECORD INTO THE CORRECT POSITION *
      * (LOWEST TO HIGHEST DATE OF SERVICE - RECORD TYPR COMBO) OF  *
      * THE DRUG / DEVICE COINSURANCE TABLE                         *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       7460-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW DRUG / DEVICE COINSURANCE ENTRY     *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY.  (TYPE 1 RECORDS ONLY)   *
      *-------------------------------------------------------------*
             PERFORM 7475-STAGE-DCP-ENTRY
                THRU 7475-STAGE-DCP-ENTRY-EXIT
                  UNTIL W-DCP-INDX = 1 OR
                     H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, "DRUG"                                       *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, PROCEDURE OR VISIT                           *
      *-------------------------------------------------------------*
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       7460-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING DRUG COINSURANCE RECORD WITH THE SAME   *
      * DATE OF SERVICE AND RECORD TYPE OF THE CURRENT SERVICE LINE *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       7465-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * FOR "DRUG" LINES - ACCUMULATE DAY'S TOTAL "DRUG" COIN DUE   *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISITING RECORD WAS *
      * WAS INITIALLY CREATED FOR A "DRUG" LINE, UPDATE THE RECORD  *
      *-------------------------------------------------------------*
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 7485-REPLACE-TYPE1
                     THRU 7485-REPLACE-TYPE1-EXIT

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISTING RECORD HAS  *
      * DATA FROM ANOTHER PROCEDURE / VISIT, ENSURE THE PROC/VISIT  *
      * WITH THE HIGHEST WAGE ADJUSTED NATIONAL COIN IS IN THE TBL  *
      *-------------------------------------------------------------*
               ELSE
                  PERFORM 7480-RANK-COIN
                     THRU 7480-RANK-COIN-EXIT.

       7465-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING DRUG COINSURANCE RECORD WITH A HIGHER     *
      * RANK UP ONE RECORD POSITION AND SET THE INDEX OF THE EMPTY  *
      * RECORD FOR THE NEW ENTRY TO THE NEXT LOWER RECORD POSITION. *
      *                                                             *
      ***************************************************************
       7475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       7475-STAGE-DCP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * ENSURE THAT THE PROCEDURE/VISIT WITH THE HIGHEST WAGE ADJ.  *
      * NATIONAL COINSURANCE AMOUNT IS IN THE TABLE WHEN THERE ARE  *
      * MULTIPLE PROCEDURES/VISITS ON THE SAME DATE OF SERVICE.     *
      * ONLY ONE PROCEDURE/VISIT'S DATA PER DAY APPEARS IN THE TBL. *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       7480-RANK-COIN.

             IF H-NEW-WGNAT > W-DCP-WGNAT (W-DCP-INDX)
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       7480-RANK-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * ENTER VALUES FROM THE CURRENT SI = S, V, OR T SERVICE LINE  *
      * INTO AN EXISITING RECORD THAT WAS FORMERLY AN SI = G OR K   *
      * ONLY ENTRY.                                                 *
      * - SERVICE LINE REFERENCES CURRENT PROCEDURE / VISIT LINE    *
      * - COIN1 = PROCEDURE / VISIT LINE NEW COINSURANCE AMOUNT     *
      * - COIN2 = DRUG / BLOOD LINE NEW COINSURANCE AMOUNT(S)       *
      * - WAGE ADJUSTED NATIONAL COIN OF CURRENT LINE ENTERED       *
      * - SERVICE INDICATOR = SI OF CURRENT LINE (S, V, OR T)       *
      *                                                             *
      ***************************************************************
       7485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       7485-REPLACE-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * IDENTIFY CLAIMS THAT HAVE SIGNIFICANT PROCEDURE (SURGERY)   *
      * LINE(S) WITH ARTIFICIAL CHARGES FOR FURTHER PROCESSING,     *
      * ACCUMULATE TOTAL CLAIM PAYMENTS AND CHARGES FOR SIGNIFICANT *
      * PROCEDURE LINES, AND ACCUMULATE TOTAL CLAIM CHARGES OF ALL  *
      * SEPARATELY PAYABLE LINES.  (THE FLAG AND CLAIM TOTALS ARE   *
      * USED IN PARAGRAPH 7600-ADJ-CHRG-OUTL.)                      *
      *                                                             *
      ***************************************************************
       7500-ADJ-CHRGS.

      ***************************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY                        *
      ***************************************************************

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN A SIGNIFICANT PROCEDURE LINE HAS ARTIFICIAL *
      * CHARGES ($1 OR LESS) - FLAGS ENTIRE CLAIM                   *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                   MOVE 'Y' TO ST0-FLAG.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM CHARGES AND PAYMENTS FROM UNPACKAGED *
      * SIGNIFICANT PROCEDURE (SURGERY) LINES                       *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                   COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX) +
                                           H-TOT-ST-CHRG
                   COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT +
                                           H-TOT-ST-PYMT.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM PAYMENTS FROM UNPACKAGED SEPARATELY  *
      * PAYABLE LINES (FOR PACKAGING LATER)                         *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                 OR ' X' OR ' P')
                AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                   COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT +
                                             H-TOT-STVX-PYMT.

       7500-ADJ-CHRGS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * 1. CALCULATE STANDARD LINE ITEM PAYMENT (LINE PRICE)        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS *              *
      *     DISCOUNT FACTOR)                                        *
      *    WAGE ADJUST 60% OF THE APC PAYMENT FOR SI = S, V, T, P,  *
      *    OR X LINES, THESE ARE ELIGIBLE FOR THE SCH ADJUSTMENT    *
      * 2. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *    DESCENDING UNTIL DEDUCTIBLE = 0.                         *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA                      *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *    AND DRUGS                                                *
      * 5. CALCULATE DEVICE REDUCTIONS                              *
      *                                                             *
      ***************************************************************
       7550-CALC-STANDARD.

      ***************************************************************
      * INITIALIZE & SET LINE VARIABLES AND FLAGS                   *
      ***************************************************************

      *-------------------------------------------------------------*
      * INITIALIZE VARIABLE FOR LINES ELIGIBLE FOR BLOOD DEDUCTIBLE *
      *-------------------------------------------------------------*
             MOVE 0 TO H-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * FLAG LINE IF THE LINE APC IS A BRACHYTHERAPY APC            *
      * ** NEW LIST EVERY JANUARY **                                *
      *-------------------------------------------------------------*
      * 11/13/2007 - BRACHY APC CHECK ADDED                         *
      * 12/28/2007 - LOGIC MOVED HERE                               *
      *-------------------------------------------------------------*
             PERFORM 7650-SET-BRACHY-APC-FLAG
                THRU 7650-SET-BRACHY-APC-FLAG-EXIT.

      *-------------------------------------------------------------*
      * FLAG LINE IF THE LINE HCPCS IS A BLOOD DEDUCTIBLE HCPCS     *
      * ** NEW LIST EVERY JANUARY **                                *
      *-------------------------------------------------------------*
      * 11/13/2007 - HCPCS LIST MOVED FROM 7550-CALC-GJK TO HERE    *
      * 12/04/2007 - LIST MOVED TO 7655-SET-BD-HCPCS-FLAG           *
      * 12/28/2007 - LOGIC MOVED HERE                               *
      *-------------------------------------------------------------*
             PERFORM 7655-SET-BD-HCPCS-FLAG
                THRU 7655-SET-BD-HCPCS-FLAG-EXIT.

      *-------------------------------------------------------------*
      * FLAG LINE IF THE LINE APC IS A RADIOPHARM APC               *
      * ** NEW LIST EVERY JANUARY **                                *
      *-------------------------------------------------------------*
      * 12/27/2007 - RADIOPHARM APC CHECK ADDED                     *
      * 12/28/2007 - LOGIC MOVED HERE                               *
      *-------------------------------------------------------------*
             PERFORM 7660-SET-RADIOPH-APC-FLAG
                THRU 7660-SET-RADIOPH-APC-FLAG-EXIT.


      ***************************************************************
      * CALCULATE MAXIMUM COINSURANCE AMOUNT (INPATIENT LIMIT)      *
      ***************************************************************
             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).


      ***************************************************************
      * CALCULATE FULL AND PARTIAL CREDIT DEVICE REDUCTIONS AND     *
      * REDUCE THE APC PAYMENT BY THE REDUCTION AMOUNT              *
      * PAYMENT ADJUSTMENT FLAGS: 7 = FULL, 8 = PARTIAL CREDIT      *
      *-------------------------------------------------------------*
      * 11/1/2007 - PYMT ADJ FLAG 8 ADDED FOR PARTIAL CREDIT        *
      *             DEDUCTIONS - NEW FOR CY 2008                    *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 7' OR ' 8'
                PERFORM 7550-DEVICE-REDUC
                   THRU 7550-DEVICE-REDUC-EXIT.


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = S, V, T, P, OR X LINES           *
      * THE APC PAYMENT IS 60% WAGE ADJUSTED                        *
      *-------------------------------------------------------------*
      * 11/13/2007 - ADDED PERFORM 7560-CALC-BENE-DEDUCT            *
      *              (REMOVED FROM PARAGRAPH 7550-SCH-ADJ)          *
      ***************************************************************
             IF (OPPS-SRVC-IND (LN-SUB) =
                 ' S' OR ' V' OR ' T' OR ' P' OR ' X') THEN
                  PERFORM 7550-SCH-ADJ
                     THRU 7550-SCH-ADJ-EXIT
                  PERFORM 7560-CALC-BENE-DEDUCT
                     THRU 7560-CALC-BENE-DEDUCT-EXIT


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = H (DEVICE) LINES, PAYMENT IND.   *
      * SHOULD BE 6 FOR THESE LINES (BASED ON CHARGE ADJ. TO COST)  *
      * RETURN ERROR CODE 44 IF THIS IS NOT THE CASE                *
      ***************************************************************
             ELSE
               IF OPPS-SRVC-IND (LN-SUB) = ' H' THEN
                 IF OPPS-PYMT-IND (LN-SUB) = ' 6' THEN
                   PERFORM 7555-CALC-H-STANDARD
                      THRU 7555-CALC-H-STANDARD-EXIT
                   PERFORM 7560-CALC-BENE-DEDUCT
                      THRU 7560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 7550-CALC-STANDARD-EXIT
                 END-IF


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = G AND K LINES; THE PAYMENT IND.  *
      * SHOULD BE 1, 5, OR 7 FOR THESE LINES (PAY STANDARD AMOUNT)  *
      * RETURN ERROR CODE 41 IF INVALID SI - PYMT IND. COMBO        *
      *-------------------------------------------------------------*
      * 12/31/2007 - REMOVED REDUNDANT H-BLOOD-FRAC. INITIALIZATION *
      ***************************************************************
               ELSE
                 IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' THEN
                   IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 7' THEN
                      PERFORM 7550-CALC-GJK
                         THRU 7550-CALC-GJK-EXIT
                      PERFORM 7560-CALC-BENE-DEDUCT
                         THRU 7560-CALC-BENE-DEDUCT-EXIT
                   ELSE
                      MOVE  41  TO A-RETURN-CODE (LN-SUB)
                      GO TO 7550-CALC-STANDARD-EXIT
                   END-IF
                 END-IF
               END-IF
             END-IF.


      ***************************************************************
      * CALCULATE LINE REIMBURSEMENT                                *
      *-------------------------------------------------------------*
      * 11/01/2007 - PERFORMS FOR PARAGRAPHS 7550-PD-AT-CST-JAN07   *
      *   AND 7550-PD-AT-CST-JUL07 WERE DELETED (THE PARAGRAPHS     *
      *   WERE ALSO DELETED).  THERE IS NO PAID AT COST TABLE FOR   *
      *   2008.  UNDER THE ORIGINAL 2008 LEGISLATION, DIAGNOSIS     *
      *   RADIOPHARM LINES WERE PACKAGED (SI=' N') AND THERAPEUTIC  *
      *   RADIOPHARM AND BRACHYTHERAPY LINES WERE SEPARATELY        *
      *   PAYABLE (SI=' K').  THEREFORE, PAID AT COST LOGIC WAS NOT *
      *   NEEDED.                                                   *
      *                                                             *
      * 12/06/2007 - LINE REIMBURSEMENT AND NATIONAL COINSURANCE    *
      *   CALCULATIONS, AND MINIMUM COINSURANCE MOVE INSERTED       *
      *   (TAKEN FROM 6550-PD-AT-CST-JAN07).                        *
      *                                                             *
      * 12/27/2007 - PAID AT COST LOGIC REINSTATED FOR RADIOPHARM   *
      *   AND BRACHYTHERAPY LINES WITH A STATUS INDICATOR = ' H'.   *
      *   PAID AT COST LOGIC REVISED: NO TABLE OR TABLE SEARCH;     *
      *   FLAGS ARE USED INSTEAD.  (REINSTATEMENT IS DUE TO A       *
      *   CHANGE IN LEGISLATION; ALL RADIO. & BRACHY SI = ' H'.)    *
      *                                                             *
      * 05/14/2008 - PAID AT COST LOGIC NO LONGER APPLIED TO        *
      *   RADIOPHARM AND BRACHYTHERAPY LINES AS OF JULY 1, 2008.    *
      *   THESE LINES ARE ASSIGNED A SI OF ' K' EFFECTIVE JULY 1,   *
      *   2008, SO THEY WILL AUTOMATICALLY BY-PASS THE LOGIC AND    *
      *   RECEIVE THE STANDARD REIM.  PAID AT COST LOGIC RETAINED   *
      *   FOR PREVIOUS QUARTERS (JANUARY 1 - JUNE 30, 2008).        *
      *                                                             *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *   BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H';   *
      *   THEY CONTINUE TO BE PAID AT COST (EFFECTIVE 7/1/2008)     *
      *                                                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * PAID AT COST LINE REIMBURSEMENT CALCULATION (REIM = 80%)    *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' H' AND
                (BRACHY-APC-FLAG = 'Y' OR RADIOPH-APC-FLAG = 'Y')
                  COMPUTE H-LITEM-REIM ROUNDED =
                     ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                       H-LN-BLOOD-DEDUCT) * .8

      *-------------------------------------------------------------*
      * STANDARD LINE REIMBURSEMENT CALCULATION                     *
      *-------------------------------------------------------------*
             ELSE
                  COMPUTE H-LITEM-REIM ROUNDED =
                     ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                       H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX)
             END-IF.


      ***************************************************************
      * CALCULATE NATIONAL COINSURANCE                              *
      *-------------------------------------------------------------*
      * 12/6/2007 - LOGIC ADDED (TAKEN FROM 6550-PD-AT-CST-JAN07)   *
      ***************************************************************
             COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT.


      ***************************************************************
      * ADJUST MINIMUM COINSURANCE AMOUNT                           *
      * (REPLACES WHAT WAS IN THE APC TABLE IF > 0)                 *
      ***************************************************************
             MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN.
             IF H-MIN-COIN > 0

      *-------------------------------------------------------------*
      * DRUGS, DEVICES, BRACHYTHERAPY, THERAP. RADIO, & BLOOD       *
      *-------------------------------------------------------------*
               IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' H' OR ' K'
                  COMPUTE H-MIN-COIN ROUNDED =
                     H-MIN-COIN * (W-SRVC-UNITS (W-LP-INDX) -
                     (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION)) *
                     W-DISC-RATE (W-LP-INDX)

      *-------------------------------------------------------------*
      * APCS 0158 & 0159'S MIN COINSURANCE = 25% OF LINE PMT        *
      *-------------------------------------------------------------*
               ELSE
                  IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25

      *-------------------------------------------------------------*
      * OTHER SERVICE TYPES AND APCS' MIN COIN = 20% OF LINE PMT    *
      *-------------------------------------------------------------*
                  ELSE
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                  END-IF
               END-IF
             END-IF.


      ***************************************************************
      * ADJUST REDUCED COINSURANCE WHEN NECESSARY & ADJUST CLAIM    *
      * TOTAL LINE ITEM REIMBURSEMENT WHEN THE REDUCED AND/OR       *
      * NATIONAL COINSURANCE AMOUNTS EXCEED THE MAXIMUM COINSURANCE *
      * (PROVIDER MAY ELECT TO REDUCE COINSURANCE)                  *
      ***************************************************************
             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.

             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                          (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                       (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       7550-CALC-STANDARD-EXIT.
           EXIT.



      ***************************************************************
      *                                                             *
      * DELETED CODE:                                               *
      *   PAID AT COST WITH COINSURANCE TABLE SEARCH REMOVED        *
      *   11/1/2007 FOR CY 2008.  THERE IS NO NEW PAID AT COST      *
      *   TABLE FOR 2008.  PARAGRAPHS REMOVED:                      *
      *    - 7550-PD-AT-CST-JAN07,                                  *
      *    - 7550-PD-AT-CST-JAN07-EXIT,                             *
      *    - 7550-PD-AT-CST-JUL07,                                  *
      *    - 7550-PD-AT-CST-JUL07-EXIT.                             *
      *                                                             *
      ***************************************************************



      ***************************************************************
      *                                                             *
      *                  DEVICE REDUCTION PROCESSING                *
      *                                                             *
      ***************************************************************
      *                                                             *
      * SEARCH THE DEVICE REDUCTION TABLE TO SEE IF THERE IS AN APC *
      * MATCH; IF SO, REDUCE THE PYMT BY THE REDUCTION AMOUNT       *
      * BECAUSE THIS IS A FREE OR REPLACEMENT DEVICE -OR- A PARTIAL *
      * CREDIT DEVICE.                                              *
      *                                                             *
      *    * BE SURE TO UPDATE THE TABLE REFERENCES EACH YEAR *     *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/1/2007 - PARTIAL CREDIT DEVICE PROCESSING ADDED          *
      *             NEW FOR CY 2008                                 *
      *                                                             *
      ***************************************************************
       7550-DEVICE-REDUC.

           SEARCH ALL DEV-RED08
              AT END
                 GO TO 7550-DEVICE-REDUC-EXIT
              WHEN DEV-APC8 (DEV-INDX8) = OPPS-APC (LN-SUB)
                 PERFORM 7550-DEVICE-COMPUTE
                    THRU 7550-DEVICE-COMPUTE-EXIT.

       7550-DEVICE-REDUC-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * IF THE DEVICE IS FOUND, AND REDUCTION AMOUNT IS LESS THAN   *
      * PAYMENT AMOUNT, SUBTRACT REDUCTION AMOUNT FROM THE PAYMENT  *
      *                                                             *
      *    * BE SURE TO UPDATE THE TABLE REFERENCES EACH YEAR *     *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/1/2007 - PARTIAL CREDIT DEVICE PROCESSING ADDED          *
      *             NEW FOR CY 2008                                 *
      *                                                             *
      ***************************************************************
       7550-DEVICE-COMPUTE.

      *-------------------------------------------------------------*
      * PROCESS FULL DEVICE REDUCTION (PAF = 7)                     *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 7'
              IF W-APC-PYMT (W-LP-INDX) NUMERIC
                 IF W-APC-PYMT (W-LP-INDX) > DEV-REDUC8 (DEV-INDX8)
                    COMPUTE W-APC-PYMT (W-LP-INDX) =
                      (W-APC-PYMT (W-LP-INDX) - DEV-REDUC8 (DEV-INDX8)).

      *-------------------------------------------------------------*
      * PROCESS PARTIAL CREDIT DEVICE REDUCTION (PAF = 8)           *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 8'
              IF W-APC-PYMT (W-LP-INDX) NUMERIC
                 IF W-APC-PYMT (W-LP-INDX) >
                      (DEV-REDUC8 (DEV-INDX8) / 2)
                          COMPUTE W-APC-PYMT (W-LP-INDX) =
                            (W-APC-PYMT (W-LP-INDX) -
                              (DEV-REDUC8 (DEV-INDX8) / 2)).

       7550-DEVICE-COMPUTE-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE LINE ITEM PAYMENT WITH SOLE COMMUNITY HOSPITAL   *
      *             (SCH) ADJUSTMENT WHEN APPLICABLE                *
      *                                                             *
      *        FOR LINES WITH AN SI OF S, V, T, P, OR X -AND-       *
      *         BRACHYTHERAPY & BLOOD LINES WITH AN SI OF K         *
      *                                                             *
      ***************************************************************
      *                                                             *
      * THE SCH ADJUSTMENT IS MADE WHEN THE FOLLOWING IS TRUE:      *
      *   EITHER THE L-PSF-GEO-CBSA OR THE L-PSF-WI-CBSA MUST BE A  *
      *   VALUE OF '   01' THRU '   99' AND THE L-PSF-PROV-TYPE     *
      *   MUST BE A '16' OR '17' OR '21' OR '22'.                   *
      *                                                             *
      * EACH YEAR, CHECK WHETHER THE SCH ADJUSTMENT HARDCODED BELOW *
      * HAS CHANGED.                                                *
      * CYS 2006 - 2008: SCH ADJ = 7.1% (1.071)                     *
      *                                                             *
      *                                                             *
      * 11/08/2007 - PROCESSING FOR BRACHY & BLOOD CODES WITH AN SI *
      *              = K ADDED FOR CY 2008                          *
      * 11/13/2007 - PROCESSING FOR BRACHY & BLOOD CODES REVISED.   *
      *              BLD-DEDUC-HCPCS-FLAG ADDED TO LOGIC.           *
      * 11/13/2007 - PARAGRAPH 7560-CALC-BENE-DEDUCT PERFORM        *
      *              DELETED & MOVED TO PAR. 7550-CALC-STANDARD     *
      * 05/14/2008 - BRACHYTHERAPY LINES PROCESSED IN THIS          *
      *              PARAGRAPH STARTING 7/1/2008 BECAUSE SI CHANGED *
      *              TO ' K' ON THIS DATE.                          *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *              BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K'     *
      *              BACK TO 'H' EFFECTIVE 7/1/2008; THESE LINES    *
      *              ARE NOT YET PROCESSED IN THIS PARAGRAPH        *
      *                                                             *
      ***************************************************************
       7550-SCH-ADJ.

             MOVE L-PSF-GEO-CBSA TO GEO-CBSA-FLAG.
             MOVE L-PSF-WI-CBSA  TO WI-CBSA-FLAG.

      ***************************************************************
      * CALCULATE THE SCH PAYMENT                                   *
      *   - FOR SCHS = APC OR BLOOD APC PAYMENT ADJUSTED BY 7.1%    *
      *   - FOR NON-SCHS = UNADJUSTED APC OR BLOOD APC PAYMENT      *
      ***************************************************************

             IF ((RURAL-GEO OR RURAL-WI) AND
                 (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22'))

      *-------------------------------------------------------------*
      * SCH, BLOOD DEDUCTIBLE HCPCS LINE                            *
      *-------------------------------------------------------------*
                IF OPPS-SRVC-IND (LN-SUB) = ' K' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y'
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-BD-APC-PYMT (W-BD-INDX) * 1.071)

      *-------------------------------------------------------------*
      * SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS               *
      *-------------------------------------------------------------*
                ELSE
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-APC-PYMT (W-LP-INDX) * 1.071)
                END-IF

      *-------------------------------------------------------------*
      * NON-SCH, BLOOD DEDUCTIBLE HCPCS LINE                        *
      *-------------------------------------------------------------*
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' K' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y'
                     MOVE W-BD-APC-PYMT (W-BD-INDX) TO H-SCH-PYMT

      *-------------------------------------------------------------*
      * NON-SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS           *
      *-------------------------------------------------------------*
                ELSE
                     MOVE W-APC-PYMT (W-LP-INDX) TO H-SCH-PYMT
                END-IF
             END-IF.


      ***************************************************************
      * CALCULATE THE LINE ITEM PAYMENT                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * SI = K LINES (BRACHY & BLOOD) ARE NOT WAGE-ADJUSTED         *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' K'

      *-------------------------------------------------------------*
      * SI = K LINE & LINE HAS A BLOOD DEDUCTIBLE HCPCS             *
      *-------------------------------------------------------------*
                IF BLD-DEDUC-HCPCS-FLAG = 'Y'
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-BD-SRVC-UNITS (W-BD-INDX) *
                             W-BD-DISC-RATE (W-BD-INDX)

      *-------------------------------------------------------------*
      * SI = K LINE & LINE DOES NOT HAVE A BLOOD DEDUCTIBLE HCPCS   *
      *-------------------------------------------------------------*
                ELSE
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-SRVC-UNITS (W-LP-INDX) *
                             W-DISC-RATE (W-LP-INDX)
                END-IF

      *-------------------------------------------------------------*
      * SI = S, V, T, P, OR X LINES ARE WAGE-ADJUSTED (60%)         *
      *-------------------------------------------------------------*
             ELSE
                COMPUTE H-LITEM-PYMT ROUNDED =
                          (((H-SCH-PYMT * .60) *
                               W-WINX1 (W-LP-INDX)) +
                            (H-SCH-PYMT * .40)) *
                          W-SRVC-UNITS (W-LP-INDX) *
                          W-DISC-RATE (W-LP-INDX)
             END-IF.


       7550-SCH-ADJ-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID SI = G OR K LINES:        *
      *   - APC PAYMENT FOR BLOOD LINES                             *
      *   - BLOOD SPECIFIC ITEMS FOR BLOOD LINES                    *
      *   - LINE ITEM PMT FOR ALL SI = G OR K LINES                 *
      *     SCH ADJUSTMENT APPLIED TO ELIGIBLE BLOOD & BRACHY LINES *
      *   - BLOOD DEDUCTIBLE FOR BLOOD DEDUCTIBLE HCPCS LINES       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * - EFFECTIVE 01/01/2003, REMOVE PRO RATA REDUCTION FOR       *
      *   ALL SERVICE INDICATOR 'G' PAYMENTS.                       *
      * - 11/13/2007 - LINE ITEM PAYMENTS FOR BLOOD AND BRACHY      *
      *   LINES ARE CALCULATED IN PARAGRAPH 7550-SCH-ADJ TO APPLY   *
      *   THE SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN         *
      *   APPLICABLE                                                *
      * - 12/31/2007 - BRACHYTHERAPY & RADIOPHARM LINES' STATUS     *
      *   INDICATOR CHANGED BACK TO 'H' TEMPORARILY; THESE LINES    *
      *   WILL NOT ENTER THIS PARAGRAPH NOR PARAGRAPH 7550-SCH-ADJ  *
      *   UNTIL THEIR STATUS INDICATOR IS CHANGED BACK TO 'K'       *
      * - 05/14/2008 - BRACHYTHERAPY & RADIOPHARM LINES' SI CHANGED *
      *   TO ' K' EFFECTIVE 7/1/2008.  THESE LINES ARE PROCESSED    *
      *   IN THIS PARAGRAPH STARTING 7/1/2008.                      *
      * - 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS  *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET PROCESSED IN  *
      *   THIS PARAGRAPH.                                           *
      *                                                             *
      ***************************************************************
       7550-CALC-GJK.

      ***************************************************************
      *                                                             *
      *  CALCULATE LINE ITEM PAYMENT & BLOOD DEDUCTIBLE FOR BLOOD   *
      *   LINE WITH A HCPCS SUBJECT TO THE BLOOD DEDUCTIBLE (BD)    *
      *                                                             *
      * (BLOOD DEDUCTIBLE LINES ARE PROCESSED IN THE ORDER THEY     *
      *  APPEAR IN THE BLOOD DEDUCTIBLE TABLE - EARLIEST TO LATEST  *
      *  DATE, LEAST TO MOST EXPENSIVE PAYMENT RATE.  THE CURRENT   *
      *  COINSURANCE DEDUCTIBLE TABLE LINE BEING PROCESSED DOES NOT *
      *  NECESSARILY CORRESPOND TO THE BLOOD DEDUCTIBLE LINE        *
      *  PROCESSED IN THE LOGIC BELOW.)                             *
      *                                                             *
      ***************************************************************
             IF BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * CALCULATE BLOOD FRACTION & BLOOD PINTS USED                 *
      *-------------------------------------------------------------*
                  PERFORM 7550-SET-BLOOD-FRACTION
                     THRU 7550-SET-BLOOD-FRACTION-EXIT

      *-------------------------------------------------------------*
      * ADJUST BLOOD APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE     *
      *-------------------------------------------------------------*
                  PERFORM 7550-ADJ-BLOOD-COST
                     THRU 7550-ADJ-BLOOD-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                  PERFORM 7550-SCH-ADJ
                     THRU 7550-SCH-ADJ-EXIT

      *-------------------------------------------------------------*
      * CALCULATE BLOOD DEDUCTIBLE (BD) - H-BLOOD-FRACTION IS THE   *
      * FRACTION OF THE CURRENT LINE'S PINTS COVERED BY THE BD      *
      *-------------------------------------------------------------*
                  COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                      H-LITEM-PYMT * H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * POINT TO NEXT BLOOD DEDUCTIBLE RECORD FOR NEXT BD LINE      *
      *-------------------------------------------------------------*
                  SET W-BD-INDX UP BY 1


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      *              SUBJECT TO THE BLOOD DEDUCTIBLE                *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE           *
      *-------------------------------------------------------------*
      * 11/13/2007 - LINE ITEM PMT NO LONGER CALCULATED IN          *
      *              7550-ADJ-PLATE-COST, BUT IN 7550-SCH-ADJ       *
      *-------------------------------------------------------------*
                   PERFORM 7550-ADJ-PLATE-COST
                      THRU 7550-ADJ-PLATE-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 7550-SCH-ADJ
                      THRU 7550-SCH-ADJ-EXIT


      ***************************************************************
      *                                                             *
      *     CALCULATE LINE ITEM PAYMENT FOR NON-BLOOD G/K LINE      *
      *                                                             *
      ***************************************************************
                ELSE

      *-------------------------------------------------------------*
      * FOR BRACHYS, CALC. LINE ITEM PMT W/ SCH ADJ. IF APPLICABLE  *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED FOR BRACHYS         *
      *-------------------------------------------------------------*
                   IF BRACHY-APC-FLAG = 'Y'
                      PERFORM 7550-SCH-ADJ
                         THRU 7550-SCH-ADJ-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT FOR NON-BRACHY, NON-BLOOD LINES *
      *-------------------------------------------------------------*
                   ELSE
                      COMPUTE H-LITEM-PYMT ROUNDED =
                       W-APC-PYMT (W-LP-INDX) * W-SRVC-UNITS (W-LP-INDX)
                        * W-DISC-RATE (W-LP-INDX)
                   END-IF
                END-IF
             END-IF.

       7550-CALC-GJK-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   DETERMINE THE FRACTION OF THE BLOOD LINE'S PAYMENT THAT   *
      *  WILL BE COVERED BY THE THE BENEFICIARY'S BLOOD DEDUCTIBLE  *
      *     FOR LINES WITH A HCPCS IN THE BLOOD DEDUCTIBLE LIST     *
      *                                                             *
      *    THE BENEFICIARY PAYS A BLOOD DEDUCTIBLE FOR THE FIRST    *
      *    3 CHEAPEST BLOOD PINTS.  MEDICARE COVERS ANY ADDITIONAL  *
      *    PINTS USED BY THE BENEFICIARY.                           *
      *                                                             *
      ***************************************************************
       7550-SET-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * NAVIGATE TO SERVICE LINE ASSOCIATED WITH THE BLOOD ENTRY    *
      *-------------------------------------------------------------*
             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * BLOOD/BLOOD PRODUCT LINE                                    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                IF H-BENE-PINTS-USED > 0

      *-------------------------------------------------------------*
      * BENEFICIARY HAS ENOUGH PINTS TO COVER ALL BLOOD LINE UNITS  *
      *  - BLOOD DEDUCTIBLE WILL COVER THE ENTIRE PYMNT (FRAC. = 1) *
      *  - CALCULATE THE NUMBER OF DEDUCTIBLE PINTS BENE HAS LEFT   *
      *-------------------------------------------------------------*
                   IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                      MOVE 1 TO H-BLOOD-FRACTION
                      COMPUTE H-BENE-PINTS-USED =
                         H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)

      *-------------------------------------------------------------*
      * BENE. DOESN'T HAVE ENOUGH PINTS TO COVER ENTIRE BLOOD LINE  *
      *   - BLOOD DEDUCTIBLE WILL COVER A FRACTION OF THE PAYMENT   *
      *     (ACCORDING TO THE % OF PINTS COVERED)                   *
      *   - BENEFICIARY HAS NO DEDUCTIBLE PINTS LEFT (PINTS = 0)    *
      *-------------------------------------------------------------*
                   ELSE
                     IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                        COMPUTE H-BLOOD-FRACTION =
                         H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                        MOVE 0 TO H-BENE-PINTS-USED
                     ELSE
                        MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NO BLOOD DEDUCTIBLE PINTS LEFT              *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
                ELSE
                   MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BLOOD PROCESS/STORAGE LINE (PAF = 6)                        *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
             ELSE
                MOVE 0 TO H-BLOOD-FRACTION.

       7550-SET-BLOOD-FRACTION-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR LINES WITH A HCPCS    *
      *                IN THE BLOOD DEDUCTIBLE LIST                 *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
       7550-ADJ-BLOOD-COST.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * (1 - H-38X-39X-RATE).

       7550-ADJ-BLOOD-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR BLOOD LINES WITH A    *
      *           HCPCS NOT IN THE BLOOD DEDUCTIBLE LIST            *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    11/13/2007 - REMOVED LINE ITEM PAYMENT CALCULATION FROM  *
      *                 THIS PARAGRAPH, NOW PERFORMED IN            *
      *                 7550-SCH-ADJ (CALLED FROM 7550-CALC-GJK)    *
      *                                                             *
      ***************************************************************
       7550-ADJ-PLATE-COST.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * (1 - H-38X-39X-RATE).

       7550-ADJ-PLATE-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      ACCUMULATE TOTAL CLAIM CHARGES FROM DEVICE LINES       *
      *                                                             *
      *  EFFECTIVE 04/01/2002 A PRO RATA REDUCTION APPLIES TO ALL   *
      *  ALL SERVICE INDICATOR 'H' PAYMENTS (CURRENTLY .689)        *
      *                                                             *
      *  SERVICE INDICATOR OF 'H' = PASS-THROUGH DEVICE LINE        *
      *                                                             *
      ***************************************************************
       7555-CALC-H-TOT.

      *-------------------------------------------------------------*
      * SET THE SERVICE LINE SUBSCRIPT TO THE CLAIM SERVICE LINE    *
      * ASSOCIATED WITH THE COINSURANCE DEDUCTIBLE TABLE RECORD     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM DEVICE CHARGES FOR DEVICE LINES      *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

             IF OPPS-SRVC-IND (LN-SUB) = ' H'
               IF OPPS-PYMT-IND (LN-SUB) = ' 6'
                  COMPUTE H-TOT-H-CHRG =
                     (H-TOT-H-CHRG + H-SUB-CHRG)
               ELSE
                  NEXT SENTENCE
             ELSE
                NEXT SENTENCE.

       7555-CALC-H-TOT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *              CALCULATE PAYMENT FOR DEVICE LINES             *
      *          (PAYMENT BASED ON CHARGE ADJUSTED TO COST)         *
      *              UPDATE PASS-THROUGH DEVICE TABLE               *
      *                                                             *
      ***************************************************************
       7555-CALC-H-STANDARD.

      *-------------------------------------------------------------*
      * SET LINE ITEM PAYMENT TO LINE COST                          *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

             COMPUTE T-LITEM-PYMT ROUNDED =
               (H-SUB-CHRG * L-PSF-OPCOST-RATIO).


      *-------------------------------------------------------------*
      * WAGE ADJUST 60% OF THE CLAIM TOTAL DEVICE OFFSET AMOUNT     *
      * (OFFSET AMOUNTS ARE COSTS, NOT CHARGES)                     *
      * (C-FLAG = Y MEANS THERE IS A DEVICE ON THE CLAIM)           *
      *-------------------------------------------------------------*
              IF (C-FLAG = 'Y')

      *-------------------------------------------------------------*
      * OTHER LINES ON THE CLAIM BESIDES DEVICE LINES ARE OFFSET;   *
      * CALCULATE DEVICE PORTION OF THE TOTAL WAGE ADJUSTED OFFSET  *
      *-------------------------------------------------------------*
                 IF (H-TOT-OFF-UNITS > H-TOT-HTD-UNITS)
                      COMPUTE H-TOTAL-WAOFF ROUNDED =
                         (((H-TOTAL-OFFSET * .60) * A-WINX) +
                          (H-TOTAL-OFFSET * .40)) *
                         (H-TOT-HTD-UNITS / H-TOT-OFF-UNITS)
                      PERFORM 7700-CALC-H-OFFSET
                         THRU 7700-CALC-H-OFFSET-EXIT
                 ELSE

      *-------------------------------------------------------------*
      * ONLY DEVICE LINES ON THE CLAIM ARE OFFSET;                  *
      * WAGE ADJUST THE TOTAL CLAIM OFFSET AMOUNT                   *
      *-------------------------------------------------------------*
                      COMPUTE H-TOTAL-WAOFF ROUNDED =
                         ((H-TOTAL-OFFSET * .60) * A-WINX) +
                         (H-TOTAL-OFFSET * .40)
                      PERFORM 7700-CALC-H-OFFSET
                         THRU 7700-CALC-H-OFFSET-EXIT

      *-------------------------------------------------------------*
      * THERE IS NO DEVICE ON THE CLAIM                             *
      *-------------------------------------------------------------*
              ELSE
                 NEXT SENTENCE.

                IF T-LITEM-PYMT < 0 THEN
                   MOVE 0 TO H-LITEM-PYMT
                ELSE
                   MOVE T-LITEM-PYMT TO H-LITEM-PYMT.

      *-------------------------------------------------------------*
      * UPDATE PASS-THROUGH DEVICE TABLE WITH LINE ITEM PAYMENT OF  *
      * DEVICE LINE (CHARGES CONVERTED TO COST LESS APPLICABLE      *
      * OFFSET AMOUNT)                                              *
      * WHEN PTD-FLAG = 'Y', A PASS-THROUGH DEVICE IS ON THE CLAIM  *
      *-------------------------------------------------------------*
             IF PTD-FLAG = 'Y'
                PERFORM 7557-LOAD-PTD-LINE-PYMT
                   THRU 7557-LOAD-PTD-LINE-PYMT-EXIT
             END-IF.

       7555-CALC-H-STANDARD-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  UPDATE PASS-THROUGH DEVICE TABLE WITH CHARGES FOR THE      *
      *  DEVICE LINE (LINE ITEM PAYMENT LESS OFFSET CONVERTED TO    *
      *  CHARGES)                                                   *
      *                                                             *
      ***************************************************************
       7557-LOAD-PTD-LINE-PYMT.

      *-------------------------------------------------------------*
      * SEARCH PTD TABLE STARTING AT ENTRY #1 FOR THE RECORD THAT   *
      * CORRESPONDS TO THE CURRENT SERVICE LINE                     *
      *-------------------------------------------------------------*
             SET W-PTD-INDX TO 1.
             SEARCH W-PTD-ENTRY VARYING W-PTD-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS NOT        *
      * ALREADY IN THE TABLE, ADD IT                                *
      *-------------------------------------------------------------*
                AT END
                   GO TO 7557-LOAD-PTD-LINE-PYMT-EXIT

      *-------------------------------------------------------------*
      * IF THE LINE'S HCPCS IS IN THE TABLE, CALCULATE THE LINE'S   *
      * CHARGES AND PLACE INTO TABLE (FOR H LINES, THE PAYMENT IS   *
      * CONVERTED TO COST AND OFFSET.  HERE, THE PAYMENT IS         *
      * CONVERTED BACK INTO CHARGES BY DIVIDING IT BY THE COST TO   *
      * CHARGE RATIO.)                                              *
      *-------------------------------------------------------------*
                WHEN  W-PTD-SUB (W-PTD-INDX) = LN-SUB
                      MOVE H-LITEM-PYMT TO W-PTD-LITEM-PYMT (W-PTD-INDX)

             END-SEARCH.

       7557-LOAD-PTD-LINE-PYMT-EXIT.
            EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE THE BENEFICIARY DEDUCTIBLE AMOUNT THAT WILL BE   *
      *    APPLIED TO THE SERVICE LINES IN THE DEDUCTIBLE TABLE     *
      *                                                             *
      * (THE DEDUCTIBLE IS APPLIED TO THE LOWEST TO HIGHEST RANKED  *
      *  APCS.  THE LOWER THE RANK, THE HIGHER THE COINSURANCE %.   *
      *  THE TOTAL CLAIM BENEFICIARY COINSURANCE AMOUNT IS CHEAPER  *
      *  WHEN THE DEDUCTIBLE IS APPLIED IN THIS ORDER.)             *
      *                                                             *
      ***************************************************************
       7560-CALC-BENE-DEDUCT.

      *-------------------------------------------------------------*
      * DO NOT CALCULATE DEDUCTIBLE FOR LINES WHERE A DEDUCTIBLE IS *
      * NOT APPLICABLE                                              *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 4'
                GO TO 7560-CALC-BENE-DEDUCT-EXIT.

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NOT MET HIS/HER DEDUCTIBLE LIMIT.           *
      * CALCULATE THE "LINE BLOOD PAYMENT"                          *
      *-------------------------------------------------------------*
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                        H-LITEM-PYMT - H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE DOES NOT COVER OR JUST COVERS THE  *
      * ENTIRE LINE BLOOD PAYMENT:                                  *
      * - BENEFICIARY'S REMAINING DEDUCTIBLE AMT APPLIED TO LINE    *
      * - BENEFICIARY HAS REACHED HIS/HER DEDUCTIBLE LIMIT          *
      *-------------------------------------------------------------*
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE MORE THAN COVERS THE LINE BLOOD    *
      * PAYMENT, DO THE FOLLOWING:                                  *
      * - CALCULATE THE BENEFICIARY'S REMAINING DEDUCTIBLE AMOUNT   *
      *   AFTER PAYING FOR CURRENT SERVICE LINE                     *
      * - MEDICARE LINE PAYMENT = 0                                 *
      *-------------------------------------------------------------*
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                          H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       7560-CALC-BENE-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  CALCULATE OUTLIER PAYMENT                  *
      *  ** CHANGE OUTLIER THRESHOLD EVERY JANUARY (HARD-CODED) **  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE     *
      * FOLLOWING FOR EACH SERVICE LINE:                            *
      *                                                             *
      * - DETERMINE IF THE LINE IS ELIGIBLE FOR AN OUTLIER PAYMENT  *
      * - ADJUST CHARGES FOR LINES WITH ARTIFICIAL CHARGES ON CLAIM *
      * - DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO NON-      *
      *   PACKAGED PAYABLE LINES                                    *
      * - ADJUST CHARGES OF PRIME CODE COMPOSITE APC LINES          *
      * - ADJUST CHARGES OF MENTAL HEALTH LINES (APC = 34)          *
      * - CALCULATE THE LINE OUTLIER PAYMENT FOR ELIGIBLE LINES     *
      *                                                             *
      *                                                             *
      * NOTES:                                                      *
      * ------                                                      *
      * - NEW FOR JANUARY 2004:                                     *
      *   - CHECK >= 20040101 AND SRVC-IND = 'K'                    *
      *      - DISCONTINUE OUTLIER PROCESS                          *
      *                                                             *
      * - NEW FOR JANUARY 2008:                                     *
      *   - REVISED LOGIC FOR DETERMINING WHICH LINES WITH SRVC-IND *
      *     = 'K' ARE ELIGIBLE FOR AN OUTLIER PAYMENT.  THIS WAS    *
      *     NECESSARY B/C SOME RADIOPHARMS & ALL BRACHYTHERAPIES    *
      *     SRVC-IND = 'K' STARTING CY 2008.                        *
      *   - PER LEGISLATION, BRACHYTHERAPY & RADIOPARM LINES'       *
      *     STATUS INDICATOR CHANGED BACK TO ' H' FOR CY 2008 QTR 1 *
      *     ' K' LOGIC RETAINED B/C IT WILL NOT AFFECT PAYMENTS TO  *
      *     BRACHYTHERAPY OR RADIOPHARM LINES                       *
      *   - COMPOSITE APC AND MENTAL HEALTH LINE CHARGE CALCS       *
      *                                                             *
      * - NEW FOR APRIL 2008: ADD CHARGES AND PAYMENTS OF           *
      *   - PASS-THROUGH DEVICES TO THE CHARGES AND PAYMENTS OF     *
      *     PROCEDURES ELIGIBLE FOR THE DEVICES                     *
      *   - A-LITEM-PYMT MOVED TO H-LITEM-PYMT-OUTL B/C PAYMENTS    *
      *     ARE ADJUSTED FOR PASS-THROUGH DEVICES FOR OUTLIER       *
      *     DETERMINATION ONLY                                      *
      *                                                             *
      * - NEW FOR JULY 2008: BRACHYTHERAPY AND THERAPEUTIC          *
      *   RADIOPHARM LINES' SI CHANGED TO ' K'.  BRACHYTHERAPY      *
      *   LINES ARE NOW ELIGIBLE FOR AN OUTLIER PAYMENT.            *
      *                                                             *
      * - JULY 2008: DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS    *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET ELIGIBLE FOR  *
      *   AN OUTLIER PAYMENT.                                       *
      *                                                             *
      ***************************************************************
       7600-ADJ-CHRG-OUTL.

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE ASSOCIATED WITH THE CURRENT COINSURANCE  *
      * DEDUCTIBLE TABLE RECORD                                     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.


      *-------------------------------------------------------------*
      * DETERMINE WHETHER THE CURRENT LINE'S APC IS A BRACHY APC    *
      * * UPDATE LIST OF BRACHYTHERAPY APCS EVERY JANUARY           *
      *-------------------------------------------------------------*
             PERFORM 7650-SET-BRACHY-APC-FLAG
                THRU 7650-SET-BRACHY-APC-FLAG-EXIT.


      *-------------------------------------------------------------*
      *   LINES WITH SERVICE INDICATOR OF 'K' THAT DO NOT HAVE      *
      *   A BRACHYTHERAPY APC AND DO NOT HAVE A BLOOD HCPCS         *
      *   BYPASS OUTLIER CALCULATION (THERAPEUTIC RADIOPHARMS)      *
      *-------------------------------------------------------------*
      *   11/6/2007 - NEW LOGIC ADDED                               *
      *   02/9/2009 - THIS LOGIC EXCLUDES ALL BLOOD LINES FROM      *
      *               THE OUTLIER PAYMENT LOGIC                     *
      *   5/12/2009 - ALTERED LOGIC TO ALLOW ALL BLOOD LINES (WITH  *    **
      *               STATUS INDICATOR = K) TO ENTER OUTLIER LOGIC  *    **
      *-------------------------------------------------------------*   ***
             MOVE 'N' TO W-BLD-HCPCS-FLAG.
             SET WBLH-INDX TO 1.
             SEARCH WBLHCPCS-ENTRY VARYING WBLH-INDX
                AT END
                   MOVE 'N' TO W-BLD-HCPCS-FLAG
                WHEN W-2005-2008-BLOOD-HCPCS (WBLH-INDX) =
                     OPPS-HCPCS (LN-SUB)
                   MOVE 'Y' TO W-BLD-HCPCS-FLAG.

             IF OPPS-SRVC-IND (LN-SUB) = ' K' AND
                ( (BRACHY-APC-FLAG = 'N') AND
                  (W-BLD-HCPCS-FLAG = 'N') )
                   GO TO 7600-ADJ-CHRG-OUTL-EXIT
             END-IF.

      *----------------------------------------------------------*
      * CODE COMMENTED OUT 05/12/2009 & REPLACED WITH CODE ABOVE *
      *----------------------------------------------------------*
      *      IF OPPS-SRVC-IND (LN-SUB) = ' K' AND
      *         ( (BRACHY-APC-FLAG = 'N') AND
      *           (OPPS-PYMT-ADJ-FLAG (LN-SUB) NOT = ' 5' OR ' 6') )
      *            GO TO 7600-ADJ-CHRG-OUTL-EXIT
      *      END-IF.


      *-------------------------------------------------------------*
      *   LINES WITH SERVICE INDICATORS NOT ELIGIBLE FOR AN OUTLIER *
      *   PAYMENT AND LINES PACKAGED AS PART OF DRUG ADMINISTRATION *
      *   APC PAYMENT BYPASS OUTLIER CALCULATION                    *
      *   (DRUGS, DEVICES, & PACKAGED SERVICES)                     *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' G' OR ' H' OR ' N') OR
                (OPPS-PKG-FLAG (LN-SUB) = '4')
                   GO TO 7600-ADJ-CHRG-OUTL-EXIT.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PROCEDURE CHARGES TO PROCEDURE LINES *
      * IN PROPORTION TO THE PROCEDURE LINES' PAYMENTS WHEN THERE   *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES REPLACE BILLED CHARGES)                *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF (ST0-FLAG = 'Y') AND

                ((OPPS-SRVC-IND (LN-SUB)  = ' T') OR

                 ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                   (OPPS-HCPCS (LN-SUB) > '09999' AND
                    OPPS-HCPCS (LN-SUB) < '70000'))) AND

                (H-TOT-ST-PYMT > 0)

                  COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)

                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE NO ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM. *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND

                  ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                             ' X' OR ' P') AND
                   (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                  (H-TOT-STVX-PYMT > 0)

                    COMPUTE H-CHRG-RATE ROUNDED =
                        (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                    COMPUTE H-SUB-CHRG ROUNDED =
                        (H-CHRG-RATE * H-TOT-N-CHRG)

                    COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                        W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND

                 ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                            ' X' OR ' P') AND
                  (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                 (H-TOT-STVX-PYMT > 0)

                   COMPUTE H-CHRG-RATE ROUNDED =
                       (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                   COMPUTE H-SUB-CHRG ROUNDED =
                       (H-CHRG-RATE * H-TOT-N-CHRG)

                   COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                       W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      ***************************************************************
      *    CALCULATE COMPOSITE APC CHARGES FOR PRIME CODE LINES     *
      *                                                             *
      * THE CHARGES OF ALL PACKAGED LINES WITH A PAYMENT ADJUSTMENT *
      * FLAG THAT INDICATES THE LINE IS A PART OF A COMPOSITE APC   *
      * (VALUES 91 - 99 INCLUSIVE) ARE ACCUMULATED BY PAYMENT       *
      * ADJUSTMENT FLAG AND ADDED TO THE CORRESPONDING PRIME CODE   *
      * LINE.                                                       *
      *-------------------------------------------------------------*
      * 11/29/2007 - LOGIC ADDED FOR CY 2008                        *
      * 12/14/2008 - ROUNDED W-SUB-CHRG WHEN ADDING COMPOSITES      *
      ***************************************************************

      *-------------------------------------------------------------*
      * PAYMENT ADJUSTMENT FLAG INDICATES COMPOSITE APC             *
      *-------------------------------------------------------------*
           IF (OPPS-PYMT-ADJ-FLAG (LN-SUB) =
                 '91' OR '92' OR '93' OR '94' OR '95' OR
                 '96' OR '97' OR '98' OR '99')

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
              MOVE OPPS-PYMT-ADJ-FLAG (LN-SUB) TO H-CMP-PAF
              SET W-CMP-INDX TO 1
              SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG NOT IN TABLE         *
      *-------------------------------------------------------------*
               AT END
                  ADD 0 TO W-SUB-CHRG (W-LP-INDX)

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS IN TABLE,         *
      * ADD THE PACKAGED SUBMITTED CHARGES TO THE LINE'S CHARGES    *
      *-------------------------------------------------------------*
               WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-PAF
                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                          W-SUB-CHRG (W-LP-INDX) +
                          W-CMP-TOT-SUB-CHRG (W-CMP-INDX)
           END-IF.


      ***************************************************************
      *   CALCULATE TOTAL MENTAL HEALTH CHARGES FOR APC 34 LINES    *
      *                                                             *
      * THE CHARGES OF PACKAGED LINES WITH A PACKAGING FLAG OF '2'  *
      * ON A CLAIM WITH APC 34 (MENTAL HEALTH APC) ARE ACCUMULATED  *
      * AND ADDED TO THE SEPARATELY PAYABLE APC 34 LINE'S CHARGES.  *
      *-------------------------------------------------------------*
      * 11/29/2007 - LOGIC ADDED FOR CY 2008                        *
      * 05/12/2009 - REVISED LOGIC TO DISTRIBUTE TOTAL PACKAGED     *
      *              MENTAL HEALTH CHARGES EVENLY ACROSS PAYABLE    *
      *              APC 34 LINES                                   *
      ***************************************************************
           IF APC34-FLAG = 'Y' AND OPPS-APC (LN-SUB) = '0034'
              COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      W-SUB-CHRG (W-LP-INDX) +
                     (H-TOT-MH-CHRG / W-APC34-CNT)
           END-IF.


      ***************************************************************
      *   MOVE LINE PAYMENTS TO HOLD FIELD BECAUSE PAYMENTS MAY BE  *
      *   ADJUSTED FOR PASS-THROUGH DEVICES - ADDED 02/14/2008      *
      ***************************************************************
           MOVE ZEROS TO H-LITEM-PYMT-OUTL.
           MOVE A-LITEM-PYMT (LN-SUB) TO H-LITEM-PYMT-OUTL.


      ***************************************************************
      *   CALCULATE TOTAL CHARGES AND PAYMENTS FOR PROCEDURE LINES  *
      *             ELIGIBLE FOR PASS-THROUGH DEVICE(S)             *
      *                                                             *
      * THE CHARGES AND LINE PAYMENTS OF PASS-THROUGH DEVICE LINES  *
      * ARE ADDED TO THE CHARGES AND PAYMENTS OF ALL PROCEDURES     *
      * ELIGIBLE TO BE BILLED WITH THE PASS-THROUGH DEVICE.         *
      * (PTD-FLAG = 'Y' INDICATES THERE IS AT LEAST ONE             *
      *  PASS-THROUGH DEVICE ON THE CLAIM)                          *
      *-------------------------------------------------------------*
      * 02/12/2008 - LOGIC ADDED FOR CY 2008 QTR 2                  *
      ***************************************************************
           IF (PTD-FLAG = 'Y') AND
              (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR ' X')

      *-------------------------------------------------------------*
      * DETERMINE WHETHER THE LINE IS ELIGIBLE FOR A PT DEVICE      *
      *-------------------------------------------------------------*
              PERFORM 7670-SET-PTD-PROC-FLAG
                 THRU 7670-SET-PTD-PROC-FLAG-EXIT

      *-------------------------------------------------------------*
      * PROCEDURE IS ELIGIBLE FOR A PASS-THROUGH DEVICE             *
      *-------------------------------------------------------------*
              IF PTD-FLAG = 'Y'

      *-------------------------------------------------------------*
      * LOOP THROUGH ELIGIBLE PROCEDURE'S PASS-THROUGH DEVICE TABLE *
      * GET THE PASS-THROUGH DEVICE HCPCS(S) FOR WHICH THE          *
      * PROCEDURE IS ELIGIBLE & UPDATE PROCEDURE CHARGES & PAYMENTS *
      *-------------------------------------------------------------*
                 PERFORM 7610-PERFORM-SEARCH
                    THRU 7610-PERFORM-SEARCH-EXIT
                    VARYING W-PTD-PROC-SUB FROM 1 BY 1
                    UNTIL W-PTD-PROC-SUB > W-PTD-CNT
              END-IF
           END-IF.


      ***************************************************************
      *      CALCULATE THE OUTLIER PAYMENT FOR ELIGIBLE LINES       *
      *                                                             *
      * -NEW FOR JANUARY 2005                                       *
      *   - PROVIDER RANGE FOR CMHC                                 *
      *   - COMPUTE H-LITEM-OUTL-PYMT USING NEW FORMULA             *
      *   - CHANGE OUTLIER THRESHOLD AMOUNT EVERY JANUARY           *
      *                                                             *
      * -NEW FOR APRIL 2008                                         *
      *   - A-LITEM-PYMT (LN-SUB) CHANGED TO H-LITEM-PYMT-OUTL B/C  *
      *     PAYMENTS ARE NOW ADJUSTED FOR OUTLIER DETERMINATION     *
      *                                                             *
      ***************************************************************

               MOVE 1.75 TO H-OUTLIER-FACTOR.
               MOVE .50 TO H-OUTLIER-PCT.

               COMPUTE H-COST ROUNDED =
                  W-SUB-CHRG (W-LP-INDX) * L-PSF-OPCOST-RATIO.

               COMPUTE H-APC-ADJ-PYMT ROUNDED =
                  H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL.

      *-------------------------------------------------------------*
      * IDENTIFY COMMUNITY MENTAL HEALTH CENTER (CMHC) PROVIDERS    *
      * FOR CMHCS, INCREASE OUTLIER FACTOR & CALC LINE OUTLIER PMT  *
      *-------------------------------------------------------------*
               IF (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999')
                  MOVE 3.4 TO H-OUTLIER-FACTOR
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED = (H-COST -
                    (H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL)) *
                     H-OUTLIER-PCT

      *-------------------------------------------------------------*
      * FOR NON-CMHC PROVIDERS, LINE'S OUTLIER ELIGIBILITY &        *
      * CALCULATE OUTLIER PAYMENT IF ELIGIBLE                       *
      * ** UPDATE THE LITERAL NUMBER BELOW EACH JANUARY **          *
      *-------------------------------------------------------------*
               ELSE
                  IF (H-COST > H-APC-ADJ-PYMT) AND
                     (H-COST > H-LITEM-PYMT-OUTL + 1575)
                       COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
                          (H-COST - H-APC-ADJ-PYMT) * H-OUTLIER-PCT
                  ELSE
                     MOVE ZERO TO H-LITEM-OUTL-PYMT.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM OUTLIER PAYMENTS                     *
      *-------------------------------------------------------------*
             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

      *-------------------------------------------------------------*
      * LINES THAT RECEIVE AN EXTERNAL ADJUSTMENT ARE NOT ELIGIBLE  *
      * FOR AN OUTLIER PAYMENT - ZERO OUT PAYMENT & REMOVE FROM     *
      * CLAIM TOTAL                                                 *
      *-------------------------------------------------------------*
             IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                       H-LITEM-OUTL-PYMT
               MOVE 0 TO H-LITEM-OUTL-PYMT.

       7600-ADJ-CHRG-OUTL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  SEARCH THE PASS-THROUGH DEVICE TABLE FOR THE PASS-THROUGH  *
      *           DEVICE(S) THE PROCEDURE IS ELIGIBLE FOR           *
      *                                                             *
      ***************************************************************
       7610-PERFORM-SEARCH.

      *-------------------------------------------------------------*
      * SEARCH PTD TABLE STARTING AT ENTRY #1 FOR ALL OCCURANCES    *
      * OF THE PASS-THRU DEVICE HCPCS IN THE PASS-THRU DEVICE TABLE.*
      * THIS IS DONE FOR ALL PASS-THROUGH DEVICES THE PROCEDURE IS  *
      * ELIGIBLE FOR.                                               *
      *-------------------------------------------------------------*
           MOVE 'N' TO W-END-OF-PTD-TBL.

           IF W-PTD-PROC-HCPCS (W-PTD-PROC-SUB) NOT = '     '
              SET W-PTD-INDX TO 1
              PERFORM 7611-SEARCH-PTD-HCPCS
                 THRU 7611-SEARCH-PTD-HCPCS-EXIT
                UNTIL W-END-OF-PTD-TBL = 'Y'
           END-IF.

       7610-PERFORM-SEARCH-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * SEARCH FOR THE PASS-THROUGH DEVICE FOR WHICH THE PROCEDURE  *
      * IS ELIGIBLE IN THE TABLE & UPDATE PROCEDURE LINE PAYMENTS   *
      *                         AND CHARGES                         *
      *                                                             *
      ***************************************************************
       7611-SEARCH-PTD-HCPCS.

           MOVE 'N' TO W-END-OF-PTD-TBL.

      *-------------------------------------------------------------*
      * SEARCH PASS-THROUGH DEVICE TABLE                            *
      *-------------------------------------------------------------*
           SEARCH W-PTD-ENTRY VARYING W-PTD-INDX

      *-------------------------------------------------------------*
      * IF THERE ARE NO MORE OCCURANCES OF THE PASS-THROUGH DEVICE, *
      * STOP THE SEARCH AND INDICATE END OF FILE                    *
      *-------------------------------------------------------------*
                AT END
                   MOVE 'Y' TO W-END-OF-PTD-TBL
                   GO TO 7611-SEARCH-PTD-HCPCS-EXIT

      *-------------------------------------------------------------*
      * IF THE PASS-THROUGH DEVICE IS FOUND, INDICATE NOT END OF    *
      * FILE AND UPDATE THE PROCEDURE'S CHARGES AND PAYMENTS        *
      *-------------------------------------------------------------*
                WHEN  W-PTD-HCPCS (W-PTD-INDX) =
                      W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)

                      MOVE 'N' TO W-END-OF-PTD-TBL

                      PERFORM 7612-UPDATE-PTD-PROC
                         THRU 7612-UPDATE-PTD-PROC-EXIT

                      SET W-PTD-INDX UP BY 1

             END-SEARCH.

      *-------------------------------------------------------------*
      * SET UP FOR NEXT PASS-THROUGH DEVICE RECORD                  *
      *-------------------------------------------------------------*
             MOVE ZEROS TO H-PTD-UNIT-RATE
                           H-PTD-SUB-CHRG
                           H-PTD-LITEM-PYMT.

       7611-SEARCH-PTD-HCPCS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE PROCEDURE LINE'S PAYMENTS AND CHARGES WITH THE   *
      * PASS-THROUGH DEVICE'S PAYMENTS AND CHARGES (IN PROPORTION   *
      * TO THE PROCEDURE'S UNITS IF OTHER PROCEDURES ARE ELIGIBLE   *
      *            FOR THE PASS-THROUGH DEVICE AS WELL)             *
      *                                                             *
      ***************************************************************
       7612-UPDATE-PTD-PROC.

      *-------------------------------------------------------------*
      * DETERMINE PROPORTION OF CHARGES & PAYMENTS PROCEDURE LINE   *
      * WILL RECEIVE BASED ON ITS NUMBER OF UNITS                   *
      *-------------------------------------------------------------*
           IF W-PTD-TOTAL-PROC-UNITS (W-PTD-INDX) NOT = 0
              COMPUTE H-PTD-UNIT-RATE ROUNDED =
                      OPPS-SRVC-UNITS (LN-SUB) /
                      W-PTD-TOTAL-PROC-UNITS (W-PTD-INDX)
           ELSE
              MOVE 0 TO H-PTD-UNIT-RATE
           END-IF.

      *-------------------------------------------------------------*
      * CALCULATE THE AMOUNT OF PASS-THROUGH DEVICE CHARGES TO BE   *
      * ADDED TO THE PROCEDURE'S CHARGES IN PROPORTION TO UNITS     *
      *-------------------------------------------------------------*
           COMPUTE H-PTD-SUB-CHRG ROUNDED =
                   W-PTD-SUB-CHRG (W-PTD-INDX) *
                   H-PTD-UNIT-RATE.

      *-------------------------------------------------------------*
      * ADD PASS-THROUGH DEVICE CHARGES TO PROCEDURE LINE CHARGES   *
      *-------------------------------------------------------------*
           COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                   W-SUB-CHRG (W-LP-INDX) +
                   H-PTD-SUB-CHRG.

      *-------------------------------------------------------------*
      * CALCULATE THE AMOUNT OF PASS-THROUGH DEVICE PAYMENTS TO BE  *
      * ADDED TO THE PROCEDURE'S PAYMENTS IN PROPORTION TO UNITS    *
      *-------------------------------------------------------------*
           COMPUTE H-PTD-LITEM-PYMT ROUNDED =
                   W-PTD-LITEM-PYMT (W-PTD-INDX) *
                   H-PTD-UNIT-RATE.

      *-------------------------------------------------------------*
      * ADD PASS-THROUGH DEVICE PAYMENT TO PROCEDURE LINE PAYMENT   *
      *-------------------------------------------------------------*
           COMPUTE H-LITEM-PYMT-OUTL ROUNDED =
                   H-LITEM-PYMT-OUTL +
                   H-PTD-LITEM-PYMT.

       7612-UPDATE-PTD-PROC-EXIT.
           EXIT.



      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT APC IS A BRACHYTHERAPY APC   *
      *    - IF SO, SET BRACHY-APC-FLAG = 'Y'                       *
      *    - THIS FLAG IS USED IN PARAGRAPHS 7600-ADJ-CHRG-OUTL &   *
      *      7550-CALC-GJK TO PROCESS BRACHYS                       *
      *  ** UPDATE THIS LIST EVERY JANUARY                          *
      *  (CODE NEW FOR CY2008; ADDED 11/6/2007)                     *
      *                                                             *
      ***************************************************************
       7650-SET-BRACHY-APC-FLAG.

           MOVE 'N' TO BRACHY-APC-FLAG.

           IF OPPS-APC (LN-SUB) = ('2632' OR
                                   '1716' OR
                                   '1717' OR
                                   '1719' OR
                                   '2616' OR
                                   '2634' OR
                                   '2635' OR
                                   '2636' OR
                                   '2638' OR
                                   '2639' OR
                                   '2640' OR
                                   '2641' OR
                                   '2642' OR
                                   '2643' OR
                                   '2698' OR
                                   '2699')

              MOVE 'Y' TO BRACHY-APC-FLAG
           END-IF.

       7650-SET-BRACHY-APC-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A BLOOD DEDUCTIBLE  *
      *  HCPCS                                                      *
      *    - IF SO, SET BLD-DEDUC-HCPCS-FLAG = 'Y'                  *
      *    - THIS FLAG IS USED IN PARAGRAPHS 7550-CALC-GJK &        *
      *      7550-SCH-ADJ TO PROCESS BLOOD DEDUCTIBLE LINES         *
      *  ** UPDATE THIS LIST EVERY JANUARY                          *
      *  (CODE NEW FOR CY2008; ADDED 12/4/2007)                     *
      *                                                             *
      ***************************************************************
       7655-SET-BD-HCPCS-FLAG.

           MOVE 'N' TO BLD-DEDUC-HCPCS-FLAG.

           IF OPPS-HCPCS(LN-SUB) = ('P9010' OR
                                    'P9016' OR
                                    'P9021' OR
                                    'P9022' OR
                                    'P9038' OR
                                    'P9039' OR
                                    'P9040' OR
                                    'P9051' OR
                                    'P9054' OR
                                    'P9056' OR
                                    'P9057' OR
                                    'P9058'   )

              MOVE 'Y' TO BLD-DEDUC-HCPCS-FLAG
           END-IF.

       7655-SET-BD-HCPCS-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT APC IS A RADIOPHARM APC      *
      *    - IF SO, SET RADIOPH-APC-FLAG = 'Y'                      *
      *    - THIS FLAG IS USED IN PARAGRAPH 7550-CALC-STANDARD      *
      *      TO PROCESS RADIOPHARM LINES                            *
      *  ** UPDATE THIS LIST EVERY JANUARY                          *
      *  (CODE NEW FOR CY2008; ADDED 12/27/2007)                    *
      *                                                             *
      ***************************************************************
       7660-SET-RADIOPH-APC-FLAG.

           MOVE 'N' TO RADIOPH-APC-FLAG.

           IF OPPS-APC (LN-SUB) = ('1064' OR
                                   '1150' OR
                                   '1643' OR
                                   '1645' OR
                                   '1675' OR
                                   '1676' OR
                                   '0701' OR
                                   '0702')

              MOVE 'Y' TO RADIOPH-APC-FLAG
           END-IF.

       7660-SET-RADIOPH-APC-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A PASS-THROUGH      *
      *  DEVICE HCPCS                                               *
      *    - IF SO, SET PTD-LINE-FLAG = 'Y'                         *
      *    - THIS FLAG IS USED IN THE PASS-THROUGH DEVICE LOGIC     *
      *      TO POPULATE THE PASS-THROUGH-DEVICE TABLE              *
      *  ** UPDATE THIS LIST EVERY QUARTER                          *
      *  (CODE NEW FOR CY2008 QTR 2; ADDED 02/11/2008)              *
      *                                                             *
      ***************************************************************
       7665-SET-PTD-LINE-FLAG.

           MOVE 'N' TO PTD-LINE-FLAG.

      *---------------------------------------------------------*
      * ONLY CLAIMS WITH A DATE OF SERVICE ON OR AFTER          *
      * APRIL 1, 2008 ARE ELIGIBLE                              *
      *---------------------------------------------------------*
           IF OPPS-LITEM-DOS (LN-SUB) >= 20080401

              IF OPPS-HCPCS (LN-SUB) = ('C1821' OR
                                        'L8690')

                 MOVE 'Y' TO PTD-LINE-FLAG

              END-IF
           END-IF.

       7665-SET-PTD-LINE-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A PROCEDURE         *
      *  ELIGIBLE FOR A PASS-THROUGH DEVICE                         *
      *    - IF SO, SET PTD-PROC-FLAG = 'Y'                         *
      *    - THIS FLAG IS USED IN THE PASS-THROUGH DEVICE LOGIC     *
      *  ** UPDATE THIS LIST EVERY QUARTER                          *
      *  (CODE NEW FOR CY2008 QTR 2; ADDED 02/11/2008)              *
      *                                                             *
      ***************************************************************
       7670-SET-PTD-PROC-FLAG.

           MOVE 'N' TO PTD-PROC-FLAG.

      *---------------------------------------------------------*
      * ONLY CLAIMS WITH A DATE OF SERVICE ON OR AFTER          *
      * APRIL 1, 2008 ARE ELIGIBLE                              *
      *---------------------------------------------------------*
           IF OPPS-LITEM-DOS (LN-SUB) >= 20080401

      *---------------------------------------------------------*
      *  SPECIFY NUMBER OF ENTRIES (# OF PT DEVICES FROM POLICY)*
      *---------------------------------------------------------*
              MOVE 2 TO W-PTD-CNT

      *---------------------------------------------------------*
      *  INITIALIZE PROCEDURE'S PTD HCPCS TABLE TO SPACES       *
      *---------------------------------------------------------*
              PERFORM VARYING W-PTD-PROC-SUB FROM 1 BY 1
                UNTIL W-PTD-PROC-SUB > W-PTD-CNT
                   MOVE SPACES TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-PERFORM

      *---------------------------------------------------------*
      *  PROCEDURES ELIGIBLE FOR PASS-THROUGH DEVICE 1          *
      *---------------------------------------------------------*
              IF OPPS-HCPCS (LN-SUB) = ('0171T' OR
                                        '0172T')

                 MOVE 'Y'     TO PTD-PROC-FLAG
                 MOVE 1       TO W-PTD-PROC-SUB
                 MOVE 'C1821' TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-IF

      *---------------------------------------------------------*
      *  PROCEDURES ELIGIBLE FOR PASS-THROUGH DEVICE 2          *
      *---------------------------------------------------------*
              IF OPPS-HCPCS (LN-SUB) = ('69714' OR
                                        '69715' OR
                                        '69717' OR
                                        '69718')

                 MOVE 'Y'     TO PTD-PROC-FLAG
                 MOVE 2       TO W-PTD-PROC-SUB
                 MOVE 'L8690' TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
              END-IF
           END-IF.

       7670-SET-PTD-PROC-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * REDUCE LINE ITEM PAYMENTS OF DEVICE LINES (SI = H) BY THE   *
      * WAGE ADJUSTED DEVICE OFFSET AMOUNT WHEN THERE ARE DEVICE    *
      *         OFFSETS ON THE CLAIM (PASS-THROUGH DEVICES)         *
      *                                                             *
      ***************************************************************
      *                                                             *
      * 1. RE-CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR     *
      *    TYPE H                                                   *
      * 2. SUBTRACT WAGE ADJUSTED OFFSET AMOUNT FROM SI TYPE 'H'    *
      *    WITH HCPCS CODE BEGINNING WITH 'C'                       *
      * ** EFFECTIVE 04/01/2002                                     *
      *                                                             *
      ***************************************************************
       7700-CALC-H-OFFSET.

      *-------------------------------------------------------------*
      * REDUCE EACH DEVICE LINE'S PAYMENT BY THE WAGE ADJUSTED      *
      * OFFSET AMOUNT IN PROPORTION TO THE DEVICE LINE'S CHARGES    *
      *-------------------------------------------------------------*
             IF H-TOT-H-CHRG > 0
                COMPUTE H-OFF-RATE ROUNDED =
                    H-SUB-CHRG / H-TOT-H-CHRG
                COMPUTE T-LITEM-PYMT ROUNDED =
                    T-LITEM-PYMT - (H-TOTAL-WAOFF * H-OFF-RATE)
             ELSE
                NEXT SENTENCE.

             IF T-LITEM-PYMT < 0
                MOVE 0 TO T-LITEM-PYMT.

       7700-CALC-H-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *            PROCESS DRUG COINSURANCE TABLE RECORDS           *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ADJUST THE "DRUG" LINE COINSURANCE WHEN THE PROCEDURE      *
      *  COINSURANCE AMOUNTS PLUS THE "DRUG" COINSURANCE AMOUNT(S)  *
      *  BILLED ON THE SAME DAY EXCEED THE DAILY INPATIENT          *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      ***************************************************************
       7800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 7810-PROCESS-TYPE1
                   THRU 7810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 7840-PROCESS-TYPE2
                   THRU 7840-PROCESS-TYPE2-EXIT.

       7800-ADJ-STV-REIM-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  FOR DAYS OF SERVICE WITH "DRUG" COINSURANCE, DETERMINE THE *
      *  % OF TOTAL "DRUG" COINSURANCE THAT CAN BE PAID IN ADDITION *
      *  TO THE DAY'S MOST EXPENSIVE PROCEDURE/VISIT WAGE ADJUSTED  *
      *  COINSURANCE WHILE KEEPING WITHIN THE INPATIENT DAILY       *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      *  WHEN H-RATIO = 0, NONE OF THE DRUG COINSURANCE CAN BE PAID *
      *  WHEN H-RATIO = 1, ALL OF THE DRUG COINSURANCE CAN BE PAID  *
      *                                                             *
      *  BY USING THE DAY'S MOST EXPENSIVE PROCEDURE/VIST WAGE      *
      *  ADJUSTED COINSURANCE, THE BENEFICIARY RECEIVES THE         *
      *  GREATEST BENEFIT FROM THE INPATIENT LIMITATION PROVISION.  *
      *                                                             *
      ***************************************************************
       7810-PROCESS-TYPE1.

      *-------------------------------------------------------------*
      * DRUGS WERE ADMINISTERED ON THE DAY                          *
      *-------------------------------------------------------------*
             IF W-DCP-COIN2 (W-DCP-INDX) > 0

      *-------------------------------------------------------------*
      * GET DATE OF SERVICE & WAGE ADJUSTED COINSURANCE OF THE      *
      * DAY'S MOST EXPENSIVE PROCEDURE/VISIT                        *
      *-------------------------------------------------------------*
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-WGNAT (W-DCP-INDX) TO H-TOTAL

      *-------------------------------------------------------------*
      * CALCULATE THE % OF THE DAY'S TOTAL DRUG COIN THAT CAN BE    *
      * PAID IN ADDITION TO THE PROCEDURE/VISIT COIN WITHIN THE     *
      * INPATIENT LIMIT                                             *
      *-------------------------------------------------------------*
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-WGNAT (W-DCP-INDX)) /
                                 W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * NONE OF THE DAY'S DRUG COIN CAN BE PAID B/C THE PROCEDURE/  *
      * VISIT COIN > INPATIENT COIN LIMIT                           *
      *-------------------------------------------------------------*
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.

      *-------------------------------------------------------------*
      * THE DAY'S TOTAL DRUG COINSURANCE CAN BE PAID WITHIN THE     *
      * INPATIENT COIN LIMIT                                        *
      *-------------------------------------------------------------*
             IF H-RATIO > 1
                MOVE 1 TO H-RATIO.

       7810-PROCESS-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  REDUCE THE "DRUG" LINE'S NATIONAL COINSURANCE AMOUNT AND   *
      *    ADD THE REDUCTION AMOUNT TO THE LINE'S REIMBURSEMENT     *
      *        AMOUNT WHEN THE INPATIENT LIMIT IS EXCEEDED          *
      *                                                             *
      ***************************************************************
       7840-PROCESS-TYPE2.

      *-------------------------------------------------------------*
      * CURRENT TYPE 2 DRUG COIN REC HAS SAME DATE OF SERVICE AS    *
      * THE LAST TYPE 1 RECORD PROCESSED                            *
      *-------------------------------------------------------------*
             IF W-DCP-DOS (W-DCP-INDX) = H-DCP-DOS

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE THAT CORRESPONDS TO THE DRUG COIN RECORD *
      *-------------------------------------------------------------*
                MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB

      *-------------------------------------------------------------*
      * CALCULATE ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT  *
      *-------------------------------------------------------------*
                COMPUTE H-SHIFT =
                    W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)

      *-------------------------------------------------------------*
      * ACCUMULATE THE TOTAL NATIONAL COIN DUE FOR THE DAY          *
      * (LESS ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT)     *
      *-------------------------------------------------------------*
                COMPUTE H-TOTAL =
                     A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT

      *-------------------------------------------------------------*
      * DETERMINE HOW MUCH THE DAY'S TOTAL NATIONAL COIN DUE        *
      * EXCEEDS THE DAILY INPATIENT LIMIT (IF IT EXCEEDS THE LIMIT) *
      *-------------------------------------------------------------*
      * OCCURS WHEN THE NATIONAL COIN OF THIS LINE AND/OR PREVIOUS  *
      * LINES FROM THE SAME DAY IS GREATER THAN THE ACTUAL COIN DUE *
      * & PUSHES THE DAILY TOTAL OVER THE INPATIENT LIMIT           *
      *-------------------------------------------------------------*
                IF H-TOTAL > H-IP-LIMIT
                   COMPUTE H-SHIFT = H-SHIFT + H-TOTAL - H-IP-LIMIT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE THE ADJUSTED NATIONAL COIN FOR THE DRUG LINE BY   *
      * DEDUCTING THE AMT THAT EXCEEDS THE INPATIENT LIMIT          *
      *-------------------------------------------------------------*
                COMPUTE A-ADJ-COIN (LN-SUB) =
                    A-ADJ-COIN (LN-SUB) - H-SHIFT

      *-------------------------------------------------------------*
      * ADD DRUG COIN AMT THAT EXCEEDS IP LIMIT TO LINE REIM AMT    *
      * SET RETURN CODE TO INDICATE DAILY COINSURANCE LIMITATION    *
      *-------------------------------------------------------------*
                COMPUTE A-LITEM-REIM (LN-SUB) =
                    A-LITEM-REIM (LN-SUB) + H-SHIFT

                   MOVE 22 TO A-RETURN-CODE (LN-SUB)

             END-IF.

       7840-PROCESS-TYPE2-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  END OF CLAIM PROCESSING                    *
      *                                                             *
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      *                                                             *
      ***************************************************************
       7900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.

      *-------------------------------------------------------------*
      * NUMBER OF BLOOD PINTS USED FOR BLOOD DEDUCTIBLES ON CLAIM = *
      *   INITIAL NUMBER OF BLOOD PINTS ALLOWED FOR DEDUCTIBLES -   *
      *   BLOOD PINTS STILL LEFT AFTER PROCESSING BLOOD DEDUCTIBLES *
      *-------------------------------------------------------------*
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.

             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       7900-END-PRICE-RTN-EXIT.
           EXIT.




      ******************************************************************
      ******************************************************************
      ***                                                            ***
      **                                                              **
      **        OUTPATIENT PROSPECTIVE PAYMENT SYSTEM PRICER          **
      **        --------------------------------------------          **
      **       SECTION 8000 FOR CALENDAR YEAR 2009 PROCESSING         **
      **          SERVICE FROM DATES: 1/1/2009 - 12/31/2009           **
      **                                                              **
      ***                                                            ***
      ******************************************************************
      ******************************************************************


      ******************************************************************
      *                                                                *
      *                   PRICING PROCESS OVERVIEW                     *
      *                   ------------------------                     *
      *                                                                *
      *  1. GET RATES & OTHER INFORMATION FOR THE CLAIM                *
      *  2. VALIDATE CLAIM                                             *
      *  3. VALIDATE SERVICE LINES (INCLUDING DATA FROM THE OCE)       *
      *  4. GET RATES & OTHER INFORMATION FOR THE SERVICE LINES        *
      *  5. ACCUMULATE NON-PRIME LINE CHARGES FOR COMPOSITE APCS       *
      *  6. ACCUMULATE PACKAGED MENTAL HEALTH CHARGES                  *
      *  7. ORDER THE SERVICE LINES IN THE SEQUENCE IN WHICH           *
      *     DEDUCTIBLES WILL BE APPLIED                                *
      *  8. ORDER BLOOD LINES IN THE SEQUENCE IN WHICH DEDUCTIBLES     *
      *     WILL BE APPLIED                                            *
      *  9. CALCULATE SERVICE LINE PAYMENTS                            *
      * 10. CALCULATE DEDUCTIBLE AMOUNT APPLIED TO EACH SERVICE LINE   *
      * 11. CALCULATE BLOOD DEDUCTIBLE AMOUNT APPLIED TO EACH BLOOD    *
      *     DEDUCTIBLE LINE                                            *
      * 12. CALCULATE BENEFICIARY MAXIMUM (IP LIMIT), NATIONAL,        *
      *     MINIMUM, & REDUCED COINSURANCE FOR EACH SERVICE LINE       *
      * 13. CALCULATE REIMBURSEMENT FOR EACH SERVICE LINE              *
      * 14. ADJUST LINE CHARGES FOR ARTIFICAL, PACKAGED, COMPOSITE,    *
      *     AND MENTAL HEALTH CHARGES OF APPLICABLE PROCEDURES.  ALSO, *
      *     ADJUST LINE CHARGES AND PAYMENTS FOR PASS-THROUGH DEVICES  *
      *     FOR ELIGIBLE PROCEDURES.  ALL ADJUSTMENTS ARE DONE FOR     *
      *     OUTLIER DETERMINATION ONLY.                                *
      * 15. CALCULATE OUTLIER PAYMENT FOR ELIGIBLE SERVICE LINES       *
      * 16. APPLY THE DAILY INPATIENT LIMIT IN CALCULATING THE         *
      *     COINSURANCE TO BE PAID BY THE BENEFICIARY FOR DRUG LINES;  *
      *     ADD ANY COINSURANCE AMOUNT THAT EXCEEDS THE INPATIENT      *
      *     LIMIT TO THE DRUG LINE'S REIMBURSEMENT                     *
      * 17. ACCUMULATE CLAIM TOTALS                                    *
      * 18. MOVE FINAL SERVICE LINE AMOUNTS TO AREA TO BE PASSED BACK  *
      *                                                                *
      ******************************************************************


       8000-PROCESS-MAIN-NEW.

      *****************************************************************
      *                                                               *
      *   STEP 1 - INITIALIZE & SET WORKING-STORAGE VARIABLES, ASSIGN *
      *   ------   CBSA & WAGE INDEX, PERFORM CLAIM DATE EDITS, SET   *
      *            INPATIENT DAILY COINSURANCE LIMIT (SET ANNUALLY)   *
      *                                                               *
      *****************************************************************
              PERFORM 8100-INIT
                 THRU 8100-INIT-EXIT.

      *--------------------------------------------------------*
      * SET ERROR CODE IF THE WAGE INDEX = 0                   *
      *--------------------------------------------------------*
              IF H-WINX1 = 0 AND A-CLM-RTN-CODE = 01
                 MOVE 51 TO A-CLM-RTN-CODE.

      *--------------------------------------------------------*
      * IF THE CLAIM HAS ERROR(S), STOP PROCESSING             *
      *--------------------------------------------------------*
              IF A-CLM-RTN-CODE >= 50
                 GOBACK.

      *--------------------------------------------------------*
      * MOVE WAGE INDEX TO VARIABLE TO BE PASSED BACK          *
      *--------------------------------------------------------*
              MOVE H-WINX1 TO A-WINX.


      *****************************************************************
      *                                                               *
      *   STEP 2 - SET CLAIM FLAGS WHEN CERTAIN CODES ARE FOUND       *
      *   ------   (LOOP THROUGH THE CLAIM)                           *
      *                                                               *
      *   - PHP-APC-FLAG - PARTIAL HOSPITALIZATION CLAIM (0172 & 0173)*
      *   - APC34-FLAG - MENTAL HEALTH CLAIM                          *
      *   - PTD-FLAG - PASS-THROUGH DEVICE(S) ON CLAIM                *
      *   - PTRADIO-CLAIM-FLAG - PASS-THROUGH RADIOPAHARM(S) ON CLAIM *
      *                                                               *
      *   - DISABLED CY 2009: C1820-OFFSET-FLAG - DEVICE OFFSET CLAIM *
      *                                                               *
      *****************************************************************
              PERFORM 8125-INIT
                 THRU 8125-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.


      *****************************************************************
      *                                                               *
      *   STEP 3 - VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS &   *
      *   ------   OFFSETS, ACCUMULATE CLAIM TOTALS, SET FLAGS,       *
      *            POPULATE COINSURANCE & BLOOD DEDUCTIBLE TABLES     *
      *            WITH VALID SERVICE LINES, POPULATE COMPOSITE APC   *
      *            TABLE WITH NON-PRIME COMPOSITE LINE CHARGES,       *
      *            CALCULATE TOTAL PACKAGED MENTAL HEALTH CHARGES,    *
      *            CREATE PASS-THROUGH DEVICE TABLE, AND CREATE       *
      *            CREATE NUCLEAR MEDICINE APC TABLE FOR PASS-THROUGH *
      *            RADIOPHARMACEUTICAL OFFSET                         *
      *            (LOOP THROUGH THE CLAIM)                           *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * EMPTY TABLES FOR NEW CLAIM                             *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX W-BLD-MAX W-CMP-MAX W-PTD-MAX
                        W-NUCMED-MAX.

              PERFORM 8150-INIT
                 THRU 8150-INIT-EXIT
                   VARYING LN-SUB FROM 1 BY 1
                     UNTIL LN-SUB > OPPS-LINE-CNT.

      *--------------------------------------------------------*
      * CALCULATE RATIO OF BLOOD PRODUCT CHARGES TO TOTAL      *
      * BLOOD CHARGES (PRODUCT & STORAGE/PROCESSING)           *
      *--------------------------------------------------------*
              IF H-TOT-38X-39X > 0
                 COMPUTE H-38X-39X-RATE ROUNDED =
                    H-TOT-38X / H-TOT-38X-39X.

      *--------------------------------------------------------*
      * CALCULATE TOTAL OFFSET AMT FOR PT RADIOPHARM LINE(S)   *
      * (# OF UNITS SUMMED LIMITED TO THE LESSER OF THE # OF   *
      *  PT RADIOPHARM HCPCS & THE # OF NUCLEAR MEDICINE UNITS)*
      *--------------------------------------------------------*
              IF W-NUCMED-MAX > 0
                 SET W-NUCMED-INDX TO 1
                 PERFORM UNTIL (W-NUCMED-INDX > W-NUCMED-MAX) OR
                               (W-NUCMED-INDX > H-PTRADIO-HCPCS-CNT)
                    COMPUTE H-NUCMED-TOT-OFFSET ROUNDED =
                            H-NUCMED-TOT-OFFSET +
                            W-NUCMED-WAGE-ADJ-OFFSET (W-NUCMED-INDX)
                    SET W-NUCMED-INDX UP BY 1
                 END-PERFORM
              END-IF.


      *****************************************************************
      *                                                               *
      *   STEP 4 - ACCUMULATE TOTAL CLAIM CHARGES FROM DEVICE LINES   *
      *   ------   (FOR DEVICES, SERVICE INDICATOR = H)               *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************
              MOVE 0 TO W-DCP-MAX.
              PERFORM 8555-CALC-H-TOT
                 THRU 8555-CALC-H-TOT-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 5 - CALCULATE LINE PAYMENTS, DEDUCTIBLES, COINSURANCE, *
      *   ------   & REIMBURSEMENT, ACCUMULATE CLAIM TOTALS, POPULATE *
      *            DRUG COINSURANCE TABLE, POPULATE PASS-THROUGH      *
      *            DEVICE TABLE WITH ELIGIBLE PROCEDURE DATA AND      *
      *            DEVICE LINE ITEM PAYMENT, AND MOVE LINE ITEM       *
      *            VALUES TO VARIABLES TO BE PASSED BACK              *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************

      *--------------------------------------------------------*
      * POINT TO 1ST RECORD IN THE BLOOD DEDUCTIBLE TABLE      *
      *--------------------------------------------------------*
              SET W-BD-INDX TO 1.

      *--------------------------------------------------------*
      * CLEAR THE DRUG COINSURANCE TABLE                       *
      *--------------------------------------------------------*
              MOVE 0 TO W-DCP-MAX.
              PERFORM 8400-CALCULATE
                 THRU 8400-CALCULATE-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX.


      *****************************************************************
      *                                                               *
      *   STEP 6 - ADJUST PROCEDURE LINE CHARGES FOR ARTIFICIAL       *
      *   ------   CHARGES, PACKAGING, COMPOSITES, MENTAL HEALTH, AND *
      *            PASS-THROUGH DEVICES, AND CALCULATE OUTLIER        *
      *            PAYMENTS                                           *
      *            (LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE)    *
      *                                                               *
      *****************************************************************
              PERFORM 8600-ADJ-CHRG-OUTL
                 THRU 8600-ADJ-CHRG-OUTL-EXIT
                    VARYING W-LP-INDX FROM 1 BY 1
                      UNTIL W-LP-INDX > W-LNC-MAX


      *****************************************************************
      *                                                               *
      *   STEP 7 - CALCULATE THE COINSURANCE & REIMBURSEMENT AMOUNTS  *
      *   ------   FOR STATUS INDICATOR G & K LINES.  THE DAILY INPA- *
      *            TIENT COINSURANCE LIMIT IS APPLIED USING THE WAGE  *
      *            ADJUSTED COINSURANCE OF EACH DAY'S MOST EXPENSIVE  *
      *            PROCEDURE OR VISIT.                                *
      *            (LOOP THROUGH THE DRUG COINSURANCE TABLE)          *
      *                                                               *
      *****************************************************************
                IF GJK-FLAG = 'Y'
                   PERFORM 8800-ADJ-STV-REIM
                      THRU 8800-ADJ-STV-REIM-EXIT
                        VARYING W-DCP-INDX FROM 1 BY 1
                          UNTIL W-DCP-INDX > W-DCP-MAX
                ELSE
                   NEXT SENTENCE.


      *****************************************************************
      *                                                               *
      *   STEP 8 - MOVE CLAIM TOTAL CHARGES, PAYMENTS, BLOOD PINTS    *
      *   ------   USED, AND OUTLIER PAYMENTS TO VARIABLES TO BE      *
      *            PASSED BACK.  CALCULATE BLOOD PINTS USED.          *
      *                                                               *
      *****************************************************************
              PERFORM 8900-END-PRICE-RTN
                 THRU 8900-END-PRICE-RTN-EXIT.

       8000-PROCESS-MAIN-NEW-EXIT.
           EXIT.



      ***************************************************************
      *                                                             *
      * INITIALIZE WORKING STORAGE HOLD AREAS AND ADDITIONAL        *
      * VARIABLES TO BE PASSED BACK TO THE STANDARD SYSTEM,         *
      * ASSIGN CLAIM CBSA AND WAGE INDEX, & PERFORM DATE EDITS      *
      *                                                             *
      * ** CHANGE EVERY JANUARY:                                    *
      *    - INPATIENT DAILY COINSURANCE LIMIT (H-IP-LIMIT)         *
      *    - CAL-VERSION                                            *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ERROR RETURN CODES:                                         *
      * -------------------                                         *
      *    - IF PROVIDER SPECIFIC FILE WAGE INDEX RECLASSIFICATION  *
      *      CODE INVALID OR MISSING                                *
      *       - MOVE '52' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE NOT NUMERIC OR < 20000801         *
      *       - MOVE '53' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE < PROVIDER EFFECTIVE DATE         *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    - IF SERVICE FROM DATE > PROVIDER TERMINATION DATE       *
      *       - MOVE '54' TO CLAIM LEVEL RETURN CODE                *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       8100-INIT.

      *-------------------------------------------------------------*
      *  INITIALIZE CLAIM RETURN CODE (01 = CLAIM PROCESSED)        *
      *-------------------------------------------------------------*
             MOVE 01 TO A-CLM-RTN-CODE.

      *-------------------------------------------------------------*
      * INITIALIZE CLAIM AND LINE VARIABLES                         *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      * 11/06/2007 - BRACHY-APC-FLAG ADDED                          *
      * 11/13/2007 - BLD-DEDUC-HCPCS-FLAG ADDED                     *
      * 11/28/2007 - APC34-FLAG ADDED                               *
      * 12/27/2007 - RADIOPH-APC-FLAG ADDED                         *
      * 02/11/2008 - PTD-FLAG, PTD-LINE-FLAG, PTD-PROC-FLAG ADDED   *
      * 11/03/2008 - APC33-FLAG REPLACED BY PHP-APC-FLAG            *
      * 11/12/2008 - BRACHY-APC-FLAG REMOVED, NOT USED FOR CY 2009  *
      * 02/09/2009 - PTRADIO-CLAIM-FLAG, PTRADIO-LINE-FLAG ADDED    *
      *-------------------------------------------------------------*
             MOVE 'N' TO PHP-APC-FLAG GJK-FLAG ST0-FLAG
                         N-FLAG C-FLAG       C1820-OFFSET-FLAG
                         PHP-HCPCS-FLAG      MH-HCPCS-FLAG
                         APC34-FLAG          RADIOPH-APC-FLAG
                         PTD-FLAG            PTD-LINE-FLAG
                         PTD-PROC-FLAG       BLD-DEDUC-HCPCS-FLAG
                         PTRADIO-CLAIM-FLAG  PTRADIO-LINE-FLAG.
             MOVE SPACE TO A-MSA A-CBSA.
             MOVE ZERO TO A-OUTLIER-PYMT
                          A-TOTAL-CLM-DEDUCT
                          A-TOT-CLM-CHRG
                          A-TOT-CLM-PYMT
                          A-BLOOD-DEDUCT-DUE
                          A-BLOOD-PINTS-USED
                          A-WINX
                          W-LNC-MAX.
             INITIALIZE H-ADDITIONAL-VARIABLES.
             INITIALIZE LINE-HOLD-ITEMS.
             INITIALIZE T-LITEM-PYMT.

      *-------------------------------------------------------------*
      * VALIDATE CLAIM & PSF DATES                                  *
      *-------------------------------------------------------------*
             IF L-SERVICE-FROM-DATE NOT NUMERIC
                MOVE 53 TO A-CLM-RTN-CODE
                GO TO 8100-INIT-EXIT
             ELSE
                IF L-SERVICE-FROM-DATE < L-PSF-EFFDT
                   MOVE 54 TO A-CLM-RTN-CODE
                   GO TO 8100-INIT-EXIT
                ELSE
                   IF L-PSF-TERMDT > 0
                      IF L-SERVICE-FROM-DATE > L-PSF-TERMDT
                         MOVE 54 TO A-CLM-RTN-CODE
                         GO TO 8100-INIT-EXIT
                      END-IF
                   END-IF.

      *-------------------------------------------------------------*
      * UPDATE CAL-VERSION EVERY JANUARY                            *
      *-------------------------------------------------------------*
             MOVE CAL-VERSION8 TO A-CALC-VERS.

      *-------------------------------------------------------------*
      * RECEIVE BENEFICIARY SPECIFIC ITEMS FROM THE OCE             *
      *-------------------------------------------------------------*
             MOVE BENE-DEDUCT TO H-BENE-DEDUCT.
             MOVE BENE-BLOOD-PINTS TO H-BENE-BLOOD-PINTS
                                      H-BENE-PINTS-USED.

      *-------------------------------------------------------------*
      * GET TO PROPER APC DATE BY SERVICE DATE (STARTING AT THE     *
      * LATEST EFFECTIVE DATE IN THE APC DATE TABLE)                *
      *-------------------------------------------------------------*
             MOVE WAD-MAX TO WAD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE
                     NOT < WAD-DATE (WAD-SUB)
                 SUBTRACT 1 FROM WAD-SUB
             END-PERFORM.

      *-------------------------------------------------------------*
      * DETERMINE WHICH CBSA TO USE & WHETHER TO USE THE SPECIAL    *
      * WAGE INDEX IN THE PSF, AND SET THE INPATIENT DAILY          *
      * COINSURANCE LIMIT (IN 2 PLACES; CHANGE EVERY JANUARY)       *
      *-------------------------------------------------------------*
             IF L-PSF-SPEC-PYMT-IND = 'Y'
                MOVE L-PSF-WI-CBSA TO H-PSF-CBSA
             ELSE
                IF L-PSF-SPEC-PYMT-IND = ' '
                   MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA
                ELSE
                   IF L-PSF-SPEC-PYMT-IND = '1' OR '2'
                      MOVE L-PSF-GEO-CBSA TO H-PSF-CBSA A-CBSA
                      MOVE L-PSF-SPEC-WGIDX TO H-WINX1
                      MOVE 1068 TO H-IP-LIMIT
                      GO TO 8100-INIT-EXIT
                   ELSE
                      MOVE  52  TO A-CLM-RTN-CODE
                      GO TO 8100-INIT-EXIT.

             IF H-PSF-CBSA = SPACE
                MOVE  52  TO A-CLM-RTN-CODE
                GO TO 8100-INIT-EXIT.

             MOVE 1068 TO H-IP-LIMIT.

      *-------------------------------------------------------------*
      * APPLY WAGE INDEX FLOOR POLICY                               *
      * UPDATE WITH NEW FLOOR PARAGRAPH EVERY JANUARY               *
      *-------------------------------------------------------------*
             PERFORM 8120-FLOOR-2009
                THRU 8120-FLOOR-2009-EXIT.

      *-------------------------------------------------------------*
      * APPLY SECTION 401 WAGE INDEX POLICY                         *
      * UPDATE WITH NEW SECTION 401 PARAGRAPH EVERY JANUARY         *
      *-------------------------------------------------------------*
             PERFORM 8120-SEC401-2009
                THRU 8120-SEC401-2009-EXIT.

      *-------------------------------------------------------------*
      *   GET THE CBSA WAGE INDEX VALUE (IF NOT ALREADY OVERRIDDEN  *
      *   BY THE PSF SPECIAL WAGE INDEX VALUE)                      *
      *-------------------------------------------------------------*
             MOVE H-PSF-CBSA TO A-CBSA.
             IF H-WINX1 = 0
                PERFORM 8200-CALC-WAGEINDX
                   THRU 8200-CALC-WAGEINDX-EXIT.

       8100-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  NEW CY 2009 FLOOR FOR CBSA WAGE INDEX                      *
      *  IPPS PRICER PGM FLOORS TAKEN FROM: IPDRV094                *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  SYNC ALL OF THE FOLLOWING WITH INPATIENT.                  *
      *  SEE IPPS PRICER MAINTAINER.                                *
      *                                                             *
      * * SPECIAL NOTES *                                           *
      *   -------------                                             *
      *   1) INPATIENT MOVES 'N' TO P-NEW-CBSA-SPEC-PAY-IND         *
      *           OPPS MOVES ' ' TO L-PSF-SPEC-PYMT-IND             *
      *                                                             *
      *   2) INPATIENT CHECKS P-NEW-CBSA-SPEC-PAY-IND = 'Y'         *
      *           OPPS CHECKS L-PSF-SPEC-PYMT-IND = 'Y'             *
      *                                                             *
      *   3) INPATIENT CHECKS VALUE OF HOLD-PROV-CBSA               *
      *           OPPS CHECKS VALUE OF H-PSF-CBSA                   *
      *                                                             *
      *   4) INPATIENT MOVES THE STATE CBSA TO HOLD-PROV-CBSA       *
      *           OPPS MOVES THE STATE CBSA TO H-PSF-CBSA           *
      *                                                             *
      *   5) INPATIENT CHECKS P-NEW-STATE                           *
      *           OPPS CHECKS L-PSF-PROV-ST                         *
      *                                                             *
      *   6) ADD SINGLE QUOTES AROUND L-PSF-PROV-ST VALUES          *
      *                                                             *
      *                                                             *
      *   BE SURE TO MAKE THESE SIX CHANGES EVERY JANUARY           *
      *                                                             *
      ***************************************************************
       8120-FLOOR-2009.

292000        IF H-PSF-CBSA = '   04'
292100           AND L-PSF-SPEC-PYMT-IND = 'Y'
292200           AND L-PSF-PROV-ST = '04'
292300               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
292400               MOVE '   04' TO H-PSF-CBSA.
292500
292600        IF H-PSF-CBSA = '   04'
292700           AND L-PSF-SPEC-PYMT-IND = 'Y'
292800           AND L-PSF-PROV-ST = '19'
292900               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
293000               MOVE '   19' TO H-PSF-CBSA.
293100
293200        IF H-PSF-CBSA = '   14'
293300           AND L-PSF-SPEC-PYMT-IND = 'Y'
293400           AND L-PSF-PROV-ST = '14'
293500               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
293600               MOVE '   14' TO H-PSF-CBSA.
293700
293800        IF H-PSF-CBSA = '   14'
293900           AND L-PSF-SPEC-PYMT-IND = 'Y'
294000           AND L-PSF-PROV-ST = '26'
294100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
294200               MOVE '   26' TO H-PSF-CBSA.
294300
294400        IF H-PSF-CBSA = '10900'
294500           AND L-PSF-PROV-ST = '31'
294600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
294700               MOVE '   31' TO H-PSF-CBSA.
294800
294900        IF H-PSF-CBSA = '19340'
295000           AND L-PSF-PROV-ST = '16'
295100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
295200               MOVE '   16' TO H-PSF-CBSA.
295300
295400        IF H-PSF-CBSA = '21780'
295500           AND L-PSF-SPEC-PYMT-IND = 'Y'
295600           AND L-PSF-PROV-ST = '15'
295700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
295800               MOVE '   15' TO H-PSF-CBSA.
295900
296000        IF H-PSF-CBSA = '22020'
296100           AND L-PSF-SPEC-PYMT-IND = 'Y'
296200           AND L-PSF-PROV-ST = '43'
296300               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
296400               MOVE '   43' TO H-PSF-CBSA.
296500
296600        IF H-PSF-CBSA = '22900'
296700           AND L-PSF-PROV-ST = '37'
296800               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
296900               MOVE '   37' TO H-PSF-CBSA.
297000
297100        IF H-PSF-CBSA = '24580'
297200           AND L-PSF-SPEC-PYMT-IND = 'Y'
297300           AND L-PSF-PROV-ST = '52'
297400               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
297500               MOVE '   52' TO H-PSF-CBSA.
297600
297700        IF H-PSF-CBSA = '25540'
297800           AND L-PSF-SPEC-PYMT-IND = 'Y'
297900           AND L-PSF-PROV-ST = '07'
298000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
298100               MOVE '   07' TO H-PSF-CBSA.
298200
298300        IF H-PSF-CBSA = '28420'
298400           AND L-PSF-SPEC-PYMT-IND = 'Y'
298500           AND L-PSF-PROV-ST = '50'
298600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
298700               MOVE '   50' TO H-PSF-CBSA.
298800
298900        IF H-PSF-CBSA = '28700'
299000           AND L-PSF-PROV-ST = '44'
299100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
299200               MOVE '   44' TO H-PSF-CBSA.
299300
299400        IF H-PSF-CBSA = '28700'
299500           AND L-PSF-PROV-ST = '49'
299600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
299700               MOVE '   49' TO H-PSF-CBSA.
299800
299900        IF H-PSF-CBSA = '28700'
300000           AND L-PSF-SPEC-PYMT-IND = 'Y'
300100           AND L-PSF-PROV-ST = '18'
300200               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
300300               MOVE '   18' TO H-PSF-CBSA.
300400
300500        IF H-PSF-CBSA = '28700'
300600           AND L-PSF-SPEC-PYMT-IND = 'Y'
300700           AND L-PSF-PROV-ST = '44'
300800               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
300900               MOVE '   44' TO H-PSF-CBSA.
301000
301100        IF H-PSF-CBSA = '28940'
301200           AND L-PSF-SPEC-PYMT-IND = 'Y'
301300           AND L-PSF-PROV-ST = '18'
301400               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
301500               MOVE '   18' TO H-PSF-CBSA.
301600
301700        IF H-PSF-CBSA = '28940'
301800           AND L-PSF-SPEC-PYMT-IND = 'Y'
301900           AND L-PSF-PROV-ST = '44'
302000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
302100               MOVE '   44' TO H-PSF-CBSA.
302200
302300        IF H-PSF-CBSA = '34820'
302400           AND L-PSF-SPEC-PYMT-IND = 'Y'
302500           AND L-PSF-PROV-ST = '34'
302600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
302700               MOVE '   34' TO H-PSF-CBSA.
302800
302900        IF H-PSF-CBSA = '34820'
303000           AND L-PSF-SPEC-PYMT-IND = 'Y'
303100           AND L-PSF-PROV-ST = '42'
303200               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
303300               MOVE '   42' TO H-PSF-CBSA.
303400
303500        IF H-PSF-CBSA = '37620'
303600           AND L-PSF-PROV-ST = '36'
303700               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
303800               MOVE '   36' TO H-PSF-CBSA.
303900
304000        IF H-PSF-CBSA = '37964'
304100           AND L-PSF-SPEC-PYMT-IND = 'Y'
304200           AND L-PSF-PROV-ST = '31'
304300               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
304400               MOVE '   31' TO H-PSF-CBSA.
304500
304600        IF H-PSF-CBSA = '38340'
304700           AND L-PSF-SPEC-PYMT-IND = 'Y'
304800           AND L-PSF-PROV-ST = '47'
304900               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
305000               MOVE '   47' TO H-PSF-CBSA.
305100
305200        IF H-PSF-CBSA = '41620'
305300           AND L-PSF-SPEC-PYMT-IND = 'Y'
305400           AND L-PSF-PROV-ST = '29'
305500               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
305600               MOVE '   29' TO H-PSF-CBSA.
305700
305800        IF H-PSF-CBSA = '43580'
305900           AND L-PSF-PROV-ST = '16'
306000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
306100               MOVE '   16' TO H-PSF-CBSA.
306200
306300        IF H-PSF-CBSA = '48540'
306400           AND L-PSF-PROV-ST = '36'
306500               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
306600               MOVE '   36' TO H-PSF-CBSA.
306700
306800        IF H-PSF-CBSA = '48540'
306900           AND L-PSF-PROV-ST = '51'
307000               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
307100               MOVE '   51' TO H-PSF-CBSA.
307200
307300        IF H-PSF-CBSA = '48864'
307400           AND L-PSF-PROV-ST = '31'
307500               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
307600               MOVE '   31' TO H-PSF-CBSA.
307700
307800        IF H-PSF-CBSA = '48864'
307900           AND L-PSF-SPEC-PYMT-IND = 'Y'
308000           AND L-PSF-PROV-ST = '31'
308100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
308200               MOVE '   31' TO H-PSF-CBSA.
308300
308400        IF H-PSF-CBSA = '19060'
308500           AND L-PSF-PROV-ST = '21'
308600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
308700               MOVE '   21' TO H-PSF-CBSA.
308800
308900        IF H-PSF-CBSA = '19060'
309000           AND L-PSF-PROV-ST = '51'
309100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
309200               MOVE '   51' TO H-PSF-CBSA.
309300
309400        IF H-PSF-CBSA = '22020'
309500           AND L-PSF-PROV-ST = '24'
309600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
309700               MOVE '   24' TO H-PSF-CBSA.
309800
309900        IF H-PSF-CBSA = '24220'
310000           AND L-PSF-PROV-ST = '24'
310100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
310200               MOVE '   24' TO H-PSF-CBSA.
310300
310400        IF H-PSF-CBSA = '30300'
310500           AND L-PSF-PROV-ST = '50'
310600               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
310700               MOVE '   50' TO H-PSF-CBSA.
310800
310900        IF H-PSF-CBSA = '48260'
311000           AND L-PSF-PROV-ST = '36'
311100               MOVE ' ' TO L-PSF-SPEC-PYMT-IND
311200               MOVE '   36' TO H-PSF-CBSA.

       8120-FLOOR-2009-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  NEW CY 2009 SECTION 401 HOSPITALS                          *
      *  IPPS PRICER PGM SECTION 401S TAKEN FROM: IPDRV094          *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  SYNC ALL OF THE FOLLOWING WITH INPATIENT.                  *
      *  SEE IPPS PRICER MAINTAINER.                                *
      *                                                             *
      * * SPECIAL NOTES *                                           *
      *   -------------                                             *
      *   1) INPATIENT CHECKS P-NEW-PROVIDER-NO                     *
      *           OPPS CHECKS L-PSF-PROV-OSCAR                      *
      *                                                             *
      *   2) INPATIENT MOVES THE STATE CBSA TO HOLD-PROV-CBSA       *
      *            AND P-NEW-CBSA-STAND-AMT-LOC                     *
      *           OPPS MOVES THE STATE CBSA TO H-PSF-CBSA ONLY      *
      *                                                             *
      *   3) DELETE THE P-NEW-CBSA-STAND-AMT-LOC LINES              *
      *                                                             *
      *   BE SURE TO MAKE THESE THREE CHANGES EVERY JANUARY         *
      *                                                             *
      ***************************************************************
       8120-SEC401-2009.
385200
385300     IF (L-PSF-PROV-OSCAR = '040118')
385400         MOVE '   04' TO H-PSF-CBSA.
385600
385700     IF (L-PSF-PROV-OSCAR = '234202' OR
385800                             '329008' OR '040140')
385900         MOVE '   05' TO H-PSF-CBSA.
386100
386200     IF (L-PSF-PROV-OSCAR = '070004' OR
386300                             '070036')
386400         MOVE '   07' TO H-PSF-CBSA.
386600
386700     IF (L-PSF-PROV-OSCAR = '100048' OR
386800                             '100118' OR '100134')
386900         MOVE '   10' TO H-PSF-CBSA.
387100
387200     IF (L-PSF-PROV-OSCAR = '140167')
387300         MOVE '   14' TO H-PSF-CBSA.
387500
387600     IF (L-PSF-PROV-OSCAR = '170137')
387700         MOVE '   17' TO H-PSF-CBSA.
387900
388000     IF (L-PSF-PROV-OSCAR = '180038')
388100         MOVE '   18' TO H-PSF-CBSA.
388300
388400     IF (L-PSF-PROV-OSCAR = '220051')
388500         MOVE '   22' TO H-PSF-CBSA.
388700
388800     IF (L-PSF-PROV-OSCAR = '230078')
388900         MOVE '   23' TO H-PSF-CBSA.
389100
389200     IF (L-PSF-PROV-OSCAR = '250017')
389300         MOVE '   25' TO H-PSF-CBSA.
389500
389600     IF (L-PSF-PROV-OSCAR = '260006' OR '260047' OR '260195')
389700         MOVE '   26' TO H-PSF-CBSA.
389900
390000     IF (L-PSF-PROV-OSCAR = '330235' OR '330268')
390100         MOVE '   33' TO H-PSF-CBSA.
390300
390400     IF (L-PSF-PROV-OSCAR = '360125')
390500         MOVE '   36' TO H-PSF-CBSA.
390700
390800     IF (L-PSF-PROV-OSCAR = '370054')
390900         MOVE '   37' TO H-PSF-CBSA.
391100
391200     IF (L-PSF-PROV-OSCAR = '380040')
391300         MOVE '   38' TO H-PSF-CBSA.
391500
391600     IF (L-PSF-PROV-OSCAR = '390130' OR '390183' OR
391700                             '390233')
391800         MOVE '   39' TO H-PSF-CBSA.
392000
392100     IF (L-PSF-PROV-OSCAR = '440135')
392200         MOVE '   44' TO H-PSF-CBSA.
392400
392500     IF (L-PSF-PROV-OSCAR = '450052' OR '450078' OR
392600                             '450243' OR '450348')
392700         MOVE '   45' TO H-PSF-CBSA.
392900
393000     IF (L-PSF-PROV-OSCAR = '490116')
393100         MOVE '   49' TO H-PSF-CBSA.
393300
393400     IF (L-PSF-PROV-OSCAR = '500148')
393500         MOVE '   50' TO H-PSF-CBSA.

       8120-SEC401-2009-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    LOOP THROUGH ALL CLAIM LINES TO FIND AN APC / HCPCS      *
      *                                                             *
      *  - SET FLAG IF APC = 0172/0173 (FOR PARITAL HOSPITALIZATION)*
      *  - SET FLAG IF APC = 0034 (FOR MENTAL HEALTH CHARGES)       *
      *    (NEW FOR CY 2008 - ADDED 11/28/2007)                     *
      *  - SET FLAG IF PASS-THROUGH DEVICE(S) ON CLAIM              *
      *    (NEW FOR CY 2008 - ADDED 02/11/2008)                     *
      *  - SET FLAG IF PASS-THROUGH RADIOPHARMS(S) ON CLAIM         *
      *    (NEW FOR APRIL CY 2009 - ADDED 02/10/2009)               *
      *                                                             *
      *  - DISABLED: SET FLAG IF HCPCS = C1820 (FOR DEVICE OFFSETS) *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION HCPCS FROM     *
      *              0033 TO 0172 & 0173 FOR CY 2009                *
      *                                                             *
      * 11/12/2008 - HCPCS C1820 EXPIRED FROM PASS-THROUGH STATUS   *
      *              DECEMBER 2007, OFFSET FLAG LOGIC DISABLED      *
      *                                                             *
      ***************************************************************
       8125-INIT.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE HAS A PHP APC               *
      *-------------------------------------------------------------*
             IF OPPS-APC (LN-SUB) = '0172' OR
                OPPS-APC (LN-SUB) = '0173'
                MOVE 'Y' TO PHP-APC-FLAG.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE HAS APC 0034                *
      *-------------------------------------------------------------*
             IF OPPS-APC (LN-SUB) = '0034'
                MOVE 'Y' TO APC34-FLAG.

      *-------------------------------------------------------------*
      * FOR CY 2009, NO HCPCS HAVE PASS-THROUGH STATUS              *
      *-------------------------------------------------------------*
      *      IF OPPS-HCPCS (LN-SUB) = 'C1820'
      *         MOVE 'Y' TO C1820-OFFSET-FLAG.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST ONE LINE IS A PASS-THROUGH DEVICE  *
      *-------------------------------------------------------------*
             PERFORM 8665-SET-PTD-LINE-FLAG
                THRU 8665-SET-PTD-LINE-FLAG-EXIT.

             IF PTD-LINE-FLAG = 'Y'
                MOVE 'Y' TO PTD-FLAG
             END-IF.

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN AT LEAST 1 LINE IS PASS-THROUGH RADIOPHARM  *
      * AND ACCUMULATE TOTAL PT RADIOPHARM LINES & CHARGES          *
      *-------------------------------------------------------------*
             PERFORM 8680-SET-PTRADIO-LINE-FLAG
                THRU 8680-SET-PTRADIO-LINE-FL-EXIT.

             IF PTRADIO-LINE-FLAG = 'Y'
                MOVE 'Y' TO PTRADIO-CLAIM-FLAG
                ADD 1 TO H-PTRADIO-HCPCS-CNT
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG
                COMPUTE H-PTRADIO-TOT-CHRGS ROUNDED =
                        H-PTRADIO-TOT-CHRGS + H-SUB-CHRG
             END-IF.

       8125-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  VALIDATE CLAIM LINES, CALCULATE LINE DISCOUNTS & OFFSETS,  *
      *  ACCUMULATE CLAIM TOTALS, SET FLAGS, POPULATE COINSURANCE & *
      *  BLOOD DEDUCTIBLE TABLES WITH VALID SERVICE LINES, POPULATE *
      *  COMPOSITE APC TABLE WITH NON-PRIME COMPOSITE LINE CHARGES, *
      *  AND CALCULATE TOTAL PACKAGED MENTAL HEALTH CHARGES.        *
      *  CREATE PASS-THROUGH DEVICE TABLE (NEW FOR CY 2008 QTR 2).  *
      *                                                             *
      *  ** UPDATE PARTIAL HOSPITALIZATION (PHP) & MENTAL HEALTH    *
      *     (MH) TABLE REFERENCES EVERY JANUARY                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      * VALIDATION RULES & RETURN CODES:                            *
      * --------------------------------                            *
      *                                                             *
      * 1. VERIFY THE SERVICE INDICATOR PASSED BY THE OCE           *
      *      - IF INVALID SET RETURN CODE TO '40'                   *
      *         - DISCONTINUE LINE PROCESSING                       *
      *      - IF VALID SET RETURN CODE TO '01'                     *
      *         - CONTINUE LINE PROCESSING                          *
      * 2. PROCESS LINES AND LOAD WORK TABLE ACCORDING TO PRICE     *
      *    RANKING                                                  *
      * 3. CHECK OCE EDIT INDICATORS AND SET RETURN CODES IF        *
      *    INDICATORS ARE INVALID.                                  *
      *     - VALID RETURN CODES FOR EDIT INDICATORS                *
      *       - '41' - SERVICE INDICATOR INVALID FOR OPPS PRICER    *
      *       - '42' - APC = '00000' OR (PACKAGING FLAG = 1, 2,OR 4)*
      *       - '43' - PAYMENT INDICATOR NOT = TO 1 OR 5 THRU 9     *
      *       - '44' - SERVICE INDICATOR = 'H' BUT PAYMENT          *
      *                  INDICATOR NOT = TO 6                       *
      *       - '45' - PACKAGING FLAG NOT = TO 0, 1, 2, 3, OR 4     *
      *       - '46' - (LINE ITEM DENIAL/REJECT FLAG NOT = TO 0     *
      *                 OR LINE ITEM DENIAL/REJECT FLAG  = TO 1     *
      *                 AND (NOT A PARTIAL HOSPITALIZATION OR       *
      *                      MENTAL HEALTH HCPCS))                  *
      *                 OR LINE ITEM ACTION FLAG NOT = TO 1         *
      *       - '47' - LINE ITEM ACTION FLAG = 2 OR 3               *
      *       - '48' - PAYMENT ADJUSTMENT FLAG NOT VALID            *
      *       - '49' - SITE OF SERVICE FLAG NOT = TO 0              *
      *               - OR (PARTIAL HOSP. APC IS NOT ON THE CLAIM   *
      *                     AND SERVICE INDICATOR = 'P'             *
      *                     OR  PARTIAL HOSPITALIZATION HCPCS)      *
      * 4. IF OCE INDICATORS ARE VALID, SEARCH APC TABLE            *
      *     - IF MISSING, DELETED OR INVALID APC                    *
      *       - SET RETURN CODE TO '30'                             *
      *         - DISCONTINUE LINE PROCESSING                       *
      *                                                             *
      ***************************************************************
       8150-INIT.

      ***************************************************************
      *  INITIALIZE LINE RETURN CODE TO VALID VALUE                 *
      ***************************************************************
             MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *  OVERRIDE SERVICE UNITS FOR APC 0339 - EFFECTIVE 04/01/2002 *
      ***************************************************************
             IF OPPS-APC (LN-SUB) = '0339'
                  MOVE 1 TO OPPS-SRVC-UNITS (LN-SUB).


      ***************************************************************
      *  CALCULATE DISCOUNT RATE (FOR REDUCED COIN & OFFSET CALCS)  *
      ***************************************************************
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO H-SRVC-UNITS.
             PERFORM 8250-CALC-DISCOUNT
                THRU 8250-CALC-DISCOUNT-EXIT.

             IF A-RETURN-CODE (LN-SUB) = 42
                GO TO 8150-INIT-EXIT.


      ***************************************************************
      * FLAG LINE IF THE LINE APC IS A RADIOPHARM APC               *
      * ** NEW LIST EVERY JANUARY **                                *
      ***************************************************************
      * 11/13/2008 - LOGIC ADDED B/C THERAP. RADIO. LINES MUST BE   *
      *              EXCLUDED FROM SI=H DEVICE UNIT CALCULATION     *
      *-------------------------------------------------------------*
             PERFORM 8660-SET-RADIOPH-APC-FLAG
                THRU 8660-SET-RADIOPH-APC-FLAG-EXIT.


      ***************************************************************
      *  ACCUMULATE TOTAL CLAIM DEVICE SERVICE UNITS -AND-          *
      *  FLAG CLAIMS THAT HAVE AT LEAST ONE DEVICE LINE             *
      *    - SI = H IDENTIFIES DEVICE LINES                         *
      *    - EFFECTIVE AS OF 04-01-2002                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' H' AND
                RADIOPH-APC-FLAG = 'N'
                  MOVE 'Y' TO C-FLAG
                  COMPUTE H-TOT-HTD-UNITS =
                          H-TOT-HTD-UNITS + H-SRVC-UNITS.


      ***************************************************************
      *  ACCUMULATE CLAIM TOTAL OFFSET AMOUNT & OFFSET UNITS        *
      *  WHEN PASS-THROUGH/OFFSET DEVICE APPEARS ON THE CLAIM       *
      *-------------------------------------------------------------*
      *  - HCPCS C1820 EXPIRES FROM PASS-THRU PMT 01-01-2008. THERE *
      *    ARE NO OFFSET DEVICES FOR CY 2008; LOGIC RETAINED & ALL  *
      *    OFFSET AMOUNTS IN OFFSET TABLE SET TO $0.                *
      *  - THERE ARE NO PASS-THROUGH/OFFSET DEVICES FOR CY 2009     *
      *    C1820-OFFSET-FLAG ALWAYS = 'N', OFFSET LOGIC NOT         *
      *    NEVER PERFORMED, RETAINED FOR FUTURE USE                 *
      ***************************************************************
             IF C1820-OFFSET-FLAG = 'Y'
                PERFORM 8160-TOTAL-OFFSET
                   THRU 8160-TOTAL-OFFSET-EXIT.


      ***************************************************************
      *  CREATE NUCLEAR MEDICINE APC TABLE FOR PASS-THROUGH         *
      *  RADIOPHARM OFFSET WHEN PASS-THROUGH RADIOPHARM(S) ON CLAIM *
      *-------------------------------------------------------------*
      *  - HCPCS C1820 EXPIRES FROM PASS-THRU PMT 01-01-2008. THERE *
      *    ARE NO OFFSET DEVICES FOR CY 2008; LOGIC RETAINED & ALL  *
      *    OFFSET AMOUNTS IN OFFSET TABLE SET TO $0.                *
      *  - THERE ARE NO PASS-THROUGH/OFFSET DEVICES FOR CY 2009     *
      *    C1820-OFFSET-FLAG ALWAYS = 'N', OFFSET LOGIC NOT         *
      *    NEVER PERFORMED, RETAINED FOR FUTURE USE                 *
      ***************************************************************
             IF PTRADIO-CLAIM-FLAG = 'Y'
                PERFORM 8165-PROCESS-NUCLEAR-MED
                   THRU 8165-PROCESS-NUCLEAR-MED-EXIT.


      ***************************************************************
      *  SET AND INTIALIZE LINE SPECIFIC DATA ITEMS                 *
      ***************************************************************

      *-------------------------------------------------------------*
      * SET COIN & BLOOD DEDUCTIBLE TABLES UP FOR CURRENT LINE      *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO LN-SUB.
             SET W-BD-INDX TO LN-SUB.
             INITIALIZE W-LP-ENTRY (W-LP-INDX).
             INITIALIZE W-BD-ENTRY (W-BD-INDX).

      *-------------------------------------------------------------*
      * INITIALIZE LINE ITEM VARIABLES TO BE PASSED BACK            *
      *-------------------------------------------------------------*
             MOVE ZERO TO A-LITEM-PYMT (LN-SUB)
                          A-LITEM-REIM (LN-SUB)
                          A-ADJ-COIN (LN-SUB)
                          A-RED-COIN (LN-SUB)
                          A-TOTAL-LN-DEDUCT (LN-SUB)
                          A-BLOOD-LN-DEDUCT (LN-SUB).

      *-------------------------------------------------------------*
      * INITIALIZE LINE FLAGS                                       *
      *-------------------------------------------------------------*
      * 11/05/2007 - PHP-HCPCS-FLAG & MH-HCPCS-FLAG ADDED           *
      *-------------------------------------------------------------*
             MOVE 'N' TO PHP-HCPCS-FLAG  MH-HCPCS-FLAG.


      ***************************************************************
      *  SEARCH PARTIAL HOSPITALIZATION (PHP) TABLE FOR LINE HCPCS  *
      *  (LOGIC NEW FOR CY2008; ADDED 11/5/2007)                    *
      ***************************************************************
             SEARCH ALL PHP-ENTRY9
                AT END
                   MOVE 'N' TO PHP-HCPCS-FLAG
                WHEN PHP-HCPCS9 (PHP-INDX9) = OPPS-HCPCS (LN-SUB)
                   MOVE 'Y' TO PHP-HCPCS-FLAG.


      ***************************************************************
      *  SEARCH MENTAL HEALTH (MH) TABLE FOR LINE HCPCS             *
      *  (LOGIC NEW FOR CY2008; ADDED 11/5/2007)                    *
      ***************************************************************
             SEARCH ALL MH-ENTRY9
                AT END
                   MOVE 'N' TO MH-HCPCS-FLAG
                WHEN MH-HCPCS9 (MH-INDX9) = OPPS-HCPCS (LN-SUB)
                   MOVE 'Y' TO MH-HCPCS-FLAG.


      ***************************************************************
      *   POPULATE PASS-THROUGH DEVICE TABLE W/ PASS-THROUGH        *
      *   DEVICE LINE DATA                                          *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 AND
                PTD-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' H' AND
                RADIOPH-APC-FLAG = 'N'

                  PERFORM 8665-SET-PTD-LINE-FLAG
                     THRU 8665-SET-PTD-LINE-FLAG-EXIT

                  IF PTD-LINE-FLAG = 'Y'
                     MOVE OPPS-HCPCS (LN-SUB) TO W-PTD-LINE-HCPCS
                     PERFORM 8390-PASS-THRU-DEVICES
                        THRU 8390-PASS-THRU-DEVICES-EXIT
                  END-IF

             END-IF.



      ***************************************************************
      *                                                             *
      *         **  CHECK LINE OCE VALUES FOR VALIDITY **           *
      *                                                             *
      ***************************************************************

      ***************************************************************
      *   IDENTIFY ALL VALID SERVICE INDICATORS (SI) & RETURN       *
      *   ERROR CODE 40 IF THE SI IS INVALID.                       *
      ***************************************************************
             IF NOT (OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' G' OR ' H' OR ' K' OR ' L' OR
                ' N' OR ' P' OR ' R' OR ' S' OR ' T' OR ' U' OR
                ' V' OR ' X' OR ' W' OR ' Y' OR ' Z' OR ' M') THEN
                  MOVE  40  TO A-RETURN-CODE (LN-SUB)
                  GO TO 8150-INIT-EXIT
             ELSE
                  MOVE  01  TO A-RETURN-CODE (LN-SUB).


      ***************************************************************
      *   IDENTIFY SERVICE INDICATORS (SI) NOT VALID FOR THE OPPS   *
      *   PRICER & RETURN ERROR CODE 41 IF THE SI IS INVALID        *
      *   FOR THE OPPS PRICER.                                      *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' A' OR ' B' OR ' C' OR
                ' E' OR ' F' OR ' L' OR ' W' OR ' Y' OR ' Z' OR ' M'
                  MOVE  41  TO A-RETURN-CODE (LN-SUB)
                  GO TO 8150-INIT-EXIT.


      ***************************************************************
      **                                                           **
      **  NOTE: ERROR CODES FOR THE VALIDATION RULES BELOW ARE     **
      **        ASSIGNED IN THE ELSE STATMENTS AFTER THE APC       **
      **        TABLE SEARCH.                                      **
      **                                                           **
      ***************************************************************

      ***************************************************************
      *   IDENTIFY VALID PAYMENT INDICATORS & RETURN ERROR CODE 43  *
      *   IF THE PAYMENT INDICATOR IS INVALID.                      *
      ***************************************************************
               IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 6' OR
                                           ' 7' OR ' 8' OR ' 9'


      ***************************************************************
      *   IDENTIFY VALID PACKAGING FLAGS & RETURN ERROR CODE 45     *
      *   IF THE PACKAGING FLAG IS INVALID.                         *
      ***************************************************************
                 IF OPPS-PKG-FLAG (LN-SUB) = '0'  OR '1'  OR '2'  OR
                                             '3'  OR '4'


      ***************************************************************
      *   IDENTIFY VALID LINE ITEM DENIAL OR REJECTION (D/R) FLAGS  *
      *   AND VALID D/R FLAG-HCPCS COMBINATIONS & RETURN ERROR CODE *
      *   46 IF THE D/R FLAG OR D/R FLAG-HCPCS COMBO IS INVALID.    *
      *-------------------------------------------------------------*
      * 11/6/2007 - CHANGED PHP/MENTAL HEALTH CODES LISTED FROM     *
      *             APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008    *
      ***************************************************************

      *--------------------------------------------------------*
      *   LINE IS NOT DENIED OR REJECTED                       *
      *--------------------------------------------------------*
                   IF ( OPPS-LITEM-DR-FLAG (LN-SUB) = '0' OR

      *--------------------------------------------------------*
      *   LINE IS DENIED OR REJECTED AND HAS A PHP OR MH HCPCS *
      *--------------------------------------------------------*
                        OPPS-LITEM-DR-FLAG (LN-SUB) = '1' AND

                            ( PHP-HCPCS-FLAG = 'Y' OR
                              MH-HCPCS-FLAG  = 'Y' ) ) OR

      *--------------------------------------------------------*
      *   LINE ITEM DENIAL/REJECTION CODE IS IGNORED           *
      *--------------------------------------------------------*
                      ( OPPS-LITEM-ACT-FLAG (LN-SUB) = '1' )



      ***************************************************************
      *   IDENTIFY INVALID LINE ITEM ACTION FLAGS & RETURN ERROR    *
      *   CODE 47 IF THE LINE ITEM ACTION FLAG IS INVALID.          *
      ***************************************************************
                     IF NOT (OPPS-LITEM-ACT-FLAG (LN-SUB)
                                         EQUAL '2' OR '3')


      ***************************************************************
      *   IDENTIFY VALID PAYMENT ADJUSTMENT FLAGS (PAF) & RETURN    *
      *   ERROR CODE 48 IF THE PAF IS INVALID.                      *
      *-------------------------------------------------------------*
      * 10/31/2007 - ADDED ' 8' AS A VALID PAF FOR CY 2008          *
      * 12/06/2007 - ADDED PAFS 91 - 99 FOR COMPOSITES FOR CY 2008  *
      * 11/03/2008 - REMOVED PAFS 91 - 99 FOR COMPOSITES FOR CY 2009*
      ***************************************************************
                       IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 0' OR ' 1'
                             OR ' 2' OR ' 3' OR ' 4' OR ' 5' OR ' 6'
                             OR ' 7' OR ' 8'


      ***************************************************************
      *   IDENTIFY VALID SITE OF SERVICE (SOS) FLAG AND CASES       *
      *   WHERE THE SOS FLAG IS IGNORED & RETURN ERROR CODE 49 IF   *
      *   THE SOS FLAG IS INVALID AND NOT IGNORED.                  *
      *                                                             *
      *   ** SITE OF SERVICE FLAG = PAYMENT METHOD FLAG IN OCE **   *
      *                                                             *
      *   NOTE: PHP = PARTIAL HOSPITALIZATION                       *
      *         WHEN SI = 'P', PHP APC IS ON THE CURRENT LINE       *
      *-------------------------------------------------------------*
      * 11/06/2007 - CHANGED PHP HEALTH CODES LISTED FROM           *
      *              APCS TO HCPCS (VIA TABLE SEARCH) FOR CY 2008   *
      * 11/03/2008 - CHANGED PARTIAL HOSPITALIZATION APC FROM       *
      *              0033 TO 0172 & 0173 FOR CY 2009, FLAG CHANGED  *
      *              FROM APC33-FLAG TO PHP-APC-FLAG                *
      ***************************************************************

      *-------------------------------------------------------------*
      *   LINE SOS FLAG IS VALID                                    *
      *-------------------------------------------------------------*
                         IF (OPPS-SITE-SRVC-FLAG (LN-SUB) = '0') OR

      *-------------------------------------------------------------*
      *   LINE SOS FLAG INVALID & PHP APC ON CLAIM - CHECK FURTHER  *
      *-------------------------------------------------------------*
                            ( (PHP-APC-FLAG = 'Y') AND

      *-------------------------------------------------------------*
      *   LINE SOS FLAG INVALID, PHP APC ON CLAIM, & LINE APC IS PHP*
      *-------------------------------------------------------------*
                                ( (OPPS-SRVC-IND (LN-SUB) = ' P') OR

      *-------------------------------------------------------------*
      *   LINE SOS FLAG INVALID, PHP APC ON CLAIM, & LINE PHP HCPCS *
      *-------------------------------------------------------------*
                                  (PHP-HCPCS-FLAG = 'Y') ) )



      ***************************************************************
      *                                                             *
      *  **  ACCUMULATE TOTAL CHARGES OF ALL LINES THAT PASS  **    *
      *                  **  VALIDATION RULES  **                   *
      *                                                             *
      ***************************************************************
                MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG

                COMPUTE H-TOT-CHRG = H-TOT-CHRG +
                                     H-SUB-CHRG

      *-------------------------------------------------------------*
      *   EXCLUDE LINES THAT RECEIVE EXTERNAL LINE ITEM ADJ.        *
      *-------------------------------------------------------------*
                IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED LINE TOTAL CHARGES & SET CLAIM N-FLAG *
      *   EXCLUDE ALL PACKAGED COMPOSITE LINES                      *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED TO EXCLUDE COMPOSITE & MENTAL    *
      *                HEALTH LINES (APC34-FLAG INDICATES MH)       *
      *   08/08/2008 - LOGIC CORRECTED TO ADD CHARGES OF PACKAGED   *
      *                LINES WITH A PACKAGING FLAG OF '1' OR '4' TO *
      *                THE CLAIM'S TOTAL DISTRIBUTED PACKAGED       *
      *                CHARGES WHEN A CLAIM HAS APC 34 (MENTAL      *
      *                HEALTH) ON IT - EFFECTIVE RETROCTIVE TO      *
      *                JANUARY 1, 2008.                             *
      *   11/12/2008 - CHANGED LOGIC THAT EXCLUDES ALL COMPOSITE    *
      *                LINES & MENTAL HEALTH PKG LINES TO USE THE   *
      *                COMPOSITE ADJUSTMENT FLAG INSTEAD OF PAYMENT *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *-------------------------------------------------------------*
                IF (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4') AND
                   (OPPS-COMP-ADJ-FLAG (LN-SUB) = '00')
                      COMPUTE H-TOT-N-CHRG = H-SUB-CHRG +
                                             H-TOT-N-CHRG
                      MOVE 'Y' TO N-FLAG
                END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE PACKAGED MENTAL HEALTH LINE CHARGES            *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED FOR CY 2008                      *
      *   11/12/2008 - LOGIC DISABLED B/C MENTAL HEALTH COMPOSITE   *
      *                LINES ARE NOW IDENTIFIED WITH THE COMPOSITE  *
      *                ADJUSTMENT FLAG JUST AS ALL OTHER COMPOSITES *
      *                (MENTAL HEALTH COMPOSITE LINES NOW HAVE A    *
      *                 PACKAGING FLAG OF '1' (CY 2009)             *
      *-------------------------------------------------------------*
      *         IF (APC34-FLAG = 'Y') AND
      *            (OPPS-SRVC-IND (LN-SUB) = ' N') AND
      *            (OPPS-PKG-FLAG (LN-SUB) = '1')
      *               COMPUTE H-TOT-MH-CHRG = H-SUB-CHRG +
      *                                       H-TOT-MH-CHRG
      *         END-IF

      *-------------------------------------------------------------*
      *   ACCUMULATE NON-PRIME (PACKAGED) COMPOSITE APC CHARGES     *
      *   FOR EACH COMPOSITE APC BY THE COMPOSITE ADJUSTMENT FLAG   *
      *   (POPULATE COMPOSITE TABLE)                                *
      *-------------------------------------------------------------*
      *   11/28/2007 - LOGIC ADDED FOR CY 2008                      *
      *   11/12/2007 - LOGIC REVISED FOR CY 2009 TO IDENTIFY ALL    *
      *                COMPOSITE LINES USING THE COMPOSITE          *
      *                ADJUSTMENT FLAG INSTEAD OF PAYMENT           *
      *                ADJUSTMENT FLAG VALUES 91 - 99               *
      *                (INCLUDES PROCESSING FOR MENTAL HEALTH       *
      *                 COMPOSITES)                                 *
      *-------------------------------------------------------------*
                IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "00" AND
                   OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = "  " AND
                   OPPS-SRVC-IND (LN-SUB) = ' N'
                      PERFORM 8170-COMPOSITES
                         THRU 8170-COMPOSITES-EXIT
                END-IF

      *-------------------------------------------------------------*
      *   RETURN ERROR CODE WHEN PACKAGED LINE OR LINE APC = 0000   *
      *-------------------------------------------------------------*
                IF (OPPS-APC (LN-SUB) = '0000') OR
                   (OPPS-PKG-FLAG (LN-SUB) = '1' OR '2' OR '4')
                      MOVE 42 TO A-RETURN-CODE (LN-SUB)
                      GO TO 8150-INIT-EXIT
                END-IF



      ***************************************************************
      *                                                             *
      *  **  LOOK-UP LINE APC IN APC TABLE FOR ALL LINES THAT  **   *
      *                ** PASS VALIDATION RULES  **                 *
      *                                                             *
      ***************************************************************
                SEARCH ALL WAA-ENTRY
                   AT END
                      MOVE 30 TO A-RETURN-CODE (LN-SUB)
                      GO TO 8150-INIT-EXIT

                   WHEN WAA-APC (WAA-INDX) = OPPS-GRP (LN-SUB)

      *-------------------------------------------------------------*
      *   START SEARCH AT THE APC'S MOST CURRENT RECORD             *
      *-------------------------------------------------------------*
                      MOVE WAA-PTR (WAA-INDX) TO W-SUB2

      *-------------------------------------------------------------*
      *   GET APC DATA FROM THE REC WITH THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                      PERFORM 8175-APC-LOOKUP

      *-------------------------------------------------------------*
      *   REDUCE APC PMT BY REDUCED UPDATE RATIO WHEN APPROPRIATE   *
      *   11/13/2009 - NEW FOR CY 2009                              *
      *-------------------------------------------------------------*
                      PERFORM 8180-REDUCE-APC-PYMT
                         THRU 8180-REDUCE-APC-PYMT-EXIT



      ***************************************************************
      *                                                             *
      *     **  RETURN ERROR CODE AND STOP PROCESSING LINES  **     *
      *            **  THAT FAIL OCE VALIDATION RULES  **           *
      *                                                             *
      ***************************************************************
                         ELSE
                            MOVE  49  TO A-RETURN-CODE (LN-SUB)
                            GO TO 8150-INIT-EXIT
                       ELSE
                          MOVE  48  TO A-RETURN-CODE (LN-SUB)
                          GO TO 8150-INIT-EXIT
                     ELSE
                        MOVE  47  TO A-RETURN-CODE (LN-SUB)
                        GO TO 8150-INIT-EXIT
                   ELSE
                      MOVE  46  TO A-RETURN-CODE (LN-SUB)
                      GO TO 8150-INIT-EXIT
                 ELSE
                    MOVE  45  TO A-RETURN-CODE (LN-SUB)
                    GO TO 8150-INIT-EXIT
               ELSE
                  MOVE  43  TO A-RETURN-CODE (LN-SUB)
                  GO TO 8150-INIT-EXIT.



      ***************************************************************
      *   PROCESS BLOOD DEDUCTIBLE (EFFECTIVE AS OF 07-01-2005)     *
      *     - TOTAL BLOOD CODE CHARGES WHEN PAF = '5' OR '6'        *
      *       5: BLOOD/BLOOD PRODUCT USED IN BLOOD DEDUC CALC       *
      *       6: BLOOD PROCESS/STORAGE (LABOR) NOT SBJ TO BLD DEDUC *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE H-TOT-38X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X.

             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5' OR ' 6'
                COMPUTE H-TOT-38X-39X = OPPS-SUB-CHRG (LN-SUB)
                             + H-TOT-38X-39X.


      ***************************************************************
      *   POPULATE COINSURANCE DEDUCTIBLE TABLE W/ ALL VALID LINES  *
      *   ORDERED LOWEST TO HIGHEST RANK FROM APC TABLE             *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                PERFORM 8300-COIN-DEDUCT
                   THRU 8300-COIN-DEDUCT-EXIT.


      ***************************************************************
      *   POPULATE BLOOD DEDUCTIBLE TABLE W/ BLOOD DEDUC LINES      *
      *   ORDERED EARLIEST TO LATEST DATE OF SERVICE AND THEN       *
      *   LOWEST TO HIGHEST RANK FROM BLOOD DEDUCTIBLE TABLE        *
      *   (APPLIES WHEN HCPCS IS IN BLOOD DEDUCTIBLE RANKING TABLE) *
      *                                                             *
      *   05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD  *
      *                DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.   *
      *                FIX EFFECTIVE RETROACTIVE TO 01/01/2009.     *
      ***************************************************************
             IF A-RETURN-CODE (LN-SUB) = 01 OR 11
                SET W9BD-INDX TO 1
                SEARCH W9BD-ENTRY VARYING W9BD-INDX
                   AT END
                      GO TO 8150-INIT-EXIT
                   WHEN W-2009-BLOOD-HCPCS (W9BD-INDX) =
                                            OPPS-HCPCS (LN-SUB)
                    IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                      MOVE W-2009-BLOOD-RANK (W9BD-INDX) TO H-BLOOD-RANK
                      MOVE OPPS-LITEM-DOS (LN-SUB) TO H-BLD-DOS
                      PERFORM 8375-BLOOD-DEDUCT
                         THRU 8375-BLOOD-DEDUCT-EXIT
                    END-IF.

       8150-INIT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * ACCUMULATE CLAIM TOTAL OFFSET AMT FROM CURRENT OFFSET TABLE *
      *                     FOR PASS-THRU ITEMS                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      *      - SEARCH TABLE OPPSOF08 FOR LINE APC.                  *
      *      - CALCULATE TOTAL OFFSET & TOTAL OFFSET UNITS IF APC   *
      *        OFFSET AMOUNT IN TABLE NOT EQUAL TO 0.               *
      *      * NOTE: C1820 EXPIRES FROM PASS-THRU PAYMENT IN 2008.  *
      *              ALL OFFSET AMOUNTS IN THE 2008 TABLE = $0.     *
      *              THIS LOGIC KEPT FOR FUTURE OFFSET CODES.       *
      *                                                             *
      *      EFFECTIVE AS OF 01-01-2003                             *
      *      - CONTINUE FOR  01-01-2004                             *
      *      - CONTINUE FOR  01-01-2005                             *
      *      - CONTINUE FOR  01-01-2006                             *
      *      - CONTINUE FOR  01-01-2007                             *
      *      - CONTINUE FOR  01-01-2008 (ALL OFFSETS IN TBL = $0)   *
      *      - CONTINUE FOR  01-01-2009 (ALL OFFSETS IN TBL = $0)   *
      *                                                             *
      ***************************************************************
       8160-TOTAL-OFFSET.

             MOVE OPPS-GRP (LN-SUB) TO W-OFF-APC.
             SEARCH ALL WOO-ENTRY8
                AT END
                   GO TO 8160-TOTAL-OFFSET-EXIT
                WHEN WOO-APC8 (WOO-INDX8) = W-OFF-APC
                   PERFORM 8161-TOTAL-OFFSET-AMT
                      THRU 8161-TOTAL-OFFSET-AMT-EXIT.

       8160-TOTAL-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *       ACCUMULATE CLAIM TOTAL OFFSET AND OFFSET UNITS        *
      *                                                             *
      ***************************************************************
       8161-TOTAL-OFFSET-AMT.

           IF WOO-OFFSET8 (WOO-INDX8) EQUAL 0
              GO TO 8161-TOTAL-OFFSET-AMT-EXIT.

           COMPUTE H-TOTAL-OFFSET = H-TOTAL-OFFSET
              + (WOO-OFFSET8 (WOO-INDX8) * H-DISC-RATE * H-SRVC-UNITS).

           COMPUTE H-TOT-OFF-UNITS = H-TOT-OFF-UNITS + H-SRVC-UNITS.

           IF H-TOTAL-OFFSET < 0
              MOVE 0 TO H-TOTAL-OFFSET.

       8161-TOTAL-OFFSET-AMT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     PROCESS LINES WITH A NUCLEAR MEDICINE APC FOR THE       *
      *              PASS-THROUGH RADIOPHARM OFFSET                 *
      *                                                             *
      ***************************************************************
      *                                                             *
      *      - SEARCH TABLE PTROFFST FOR LINE APC & LINE YEAR       *
      *      - IF FOUND, ADD A RECORD TO TABLE W-NUCMED-APC-TBL     *
      *        FOR EVERY UNIT.                                      *
      *                                                             *
      *  02/10/2009 - LOGIC ADDED EFFECTIVE STARTING APRIL 2009     *
      *                                                             *
      ***************************************************************
       8165-PROCESS-NUCLEAR-MED.

      *-------------------------------------------------------------*
      * HOLD THE LINE'S APC, UNITS, & SERVICE FROM DATE             *
      *-------------------------------------------------------------*
             MOVE OPPS-GRP (LN-SUB)        TO W-NUCMED-LINE-APC.
             MOVE OPPS-SRVC-UNITS (LN-SUB) TO W-NUCMED-UNIT-CNT.
             MOVE OPPS-LITEM-DOS (LN-SUB)  TO W-LINE-SRVC-DATE.

      *-------------------------------------------------------------*
      * SEARCH PT RADIOPHARM OFFSET TABLE FOR THE APC & YEAR        *
      *-------------------------------------------------------------*
             SET PTRO-INDX TO 1.
             SEARCH PTRO-ENTRY
              AT END
                 GO TO 8165-PROCESS-NUCLEAR-MED-EXIT

      *-------------------------------------------------------------*
      * WHEN APC & YEAR FOUND, WAGE ADJUST OFFSET & ADD NEW RECORD  *
      * TO NUCLEAR MEDICINE TABLE FOR EVERY UNIT                    *
      *-------------------------------------------------------------*
              WHEN PTRO-NUCMED-APC (PTRO-INDX) = W-NUCMED-LINE-APC AND
                   PTRO-EFF-YEAR (PTRO-INDX) = W-LINE-SRVC-YEAR
                     MOVE PTRO-OFFSET-AMT (PTRO-INDX) TO W-NUCMED-OFFSET
                     COMPUTE W-NUCMED-WA-OFFSET ROUNDED =
                             W-NUCMED-OFFSET * (.6 * H-WINX1 + .4)
                     PERFORM 8166-LOAD-NUCMED-TABLE
                        THRU 8166-LOAD-NUCMED-TABLE-EXIT
                        VARYING W-NUCMED-SUB FROM 1 BY 1
                        UNTIL W-NUCMED-SUB > W-NUCMED-UNIT-CNT.

       8165-PROCESS-NUCLEAR-MED-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * LOAD A NUCLEAR MEDICINE APC TABLE RECORD FOR EVERY UNIT OF  *
      * THE NUCLEAR MEDICINE LINE AND WAGE ADJUST 60% OF THE OFFSET *
      * (INSERT THE NEW RECORD IN THE CORRECT TABLE POSITION -      *
      *  HIGHEST TO LOWEST OFFSET)                                  *
      *                                                             *
      ***************************************************************
       8166-LOAD-NUCMED-TABLE.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-NUCMED-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW (LAST) ENTRY POSITION (EMPTY RECORD)        *
      *-------------------------------------------------------------*
             SET W-NUCMED-INDX TO W-NUCMED-MAX.
             INITIALIZE W-NUCMED-APC-ENTRY (W-NUCMED-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW NUCMED APC ENTRY FOR THE CURRENT    *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS OFFSET VALUE - HIGHEST TO LOWEST OFFSET                 *
      *-------------------------------------------------------------*
             PERFORM 8167-STAGE-NUCMED-ENTRY
                THRU 8167-STAGE-NUCMED-ENTRY-EXIT
                  UNTIL W-NUCMED-INDX = 1 OR
                     W-NUCMED-WA-OFFSET NOT >
                        W-NUCMED-WAGE-ADJ-OFFSET (W-NUCMED-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE W-NUCMED-LINE-APC TO W-NUCMED-APC (W-NUCMED-INDX).
             MOVE W-NUCMED-WA-OFFSET TO
                  W-NUCMED-WAGE-ADJ-OFFSET (W-NUCMED-INDX).

       8166-LOAD-NUCMED-TABLE-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING NUCMED APC RECORD WITH A HIGHER OFFSET    *
      * DOWN ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE   *
      * NEW ENTRY'S INDEX TO THE NEXT HIGHER RECORD POSITION.       *
      *                                                             *
      ***************************************************************
       8167-STAGE-NUCMED-ENTRY.

             MOVE W-NUCMED-APC-ENTRY (W-NUCMED-INDX - 1) TO
                  W-NUCMED-APC-ENTRY (W-NUCMED-INDX).
             SET W-NUCMED-INDX DOWN BY 1.

       8167-STAGE-NUCMED-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  ACCUMULATE NON-PRIME COMPOSITE APC CHARGES FOR EACH        *
      *  COMPOSITE APC USING PACKAGED LINES WITH COMPOSITE          *
      *  ADJUSTMENT FLAG NOT = '00' & POPULATE COMPOSITE APC TABLE  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER SERVICE LINES BY COMPOSITE ADJUSTMENT FLAG (CAF) -   *
      *    LOWEST TO HIGHEST FLAG VALUE (01 - NN)                   *
      *                                                             *
      *  EACH NON-PRIME COMPOSITE PACKAGED LINE'S CHARGES ARE ADDED *
      *  TO THE TOTAL NON-PRIME CHARGES FOR EACH CAF, WHICH         *
      *  CORRESPONDS TO THE PRIME LINE'S APC.  THESE CHARGES ARE    *
      *  LATER ADDED TO THE PRIME LINE'S CHARGES TO CALCULATE THE   *
      *  OUTLIER PAYMENT.                                           *
      *                                                             *
      *  11/28/2007 - LOGIC ADDED FOR CY 2008                       *
      *  11/12/2008 - LOGIC REVISED FOR CY 2009 TO USE THE          *
      *               COMPOSITE ADJUSTMENT FLAG INSTEAD OF THE      *
      *               PAYMENT ADJUSTMENT FLAG, VARIABLE H-CMP-CAF   *
      *               HOLDS COMPOSITE ADJUSTMENT FLAG, VARIABLE     *
      *               W-CMP-PAF RETAINED AND NOW HOLDS THE CAF      *
      *               (RETAINED TO CONTINUE USE OF EXISTING TABLE)  *
      *                                                             *
      ***************************************************************
       8170-COMPOSITES.

      *-------------------------------------------------------------*
      * GET THE LINE'S COMPOSITE ADJUSTMENT FLAG FOR TABLE SEARCH   *
      *-------------------------------------------------------------*
             MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF.

      *-------------------------------------------------------------*
      * ADD OR UPDATE COMPOSITE APC TABLE ENTRY FOR THE CAF         *
      *-------------------------------------------------------------*
                PERFORM 8171-SEARCH-CAF
                   THRU 8171-SEARCH-CAF-EXIT.

       8170-COMPOSITES-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW COMPOSITE APC TABLE RECORD SHOULD   *
      * BE ADDED OR IF AN EXISITING RECORD NEEDS TO BE UPDATED      *
      *                                                             *
      ***************************************************************
       8171-SEARCH-CAF.

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO 1.
             SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS NOT      *
      * ALREADY IN THE TABLE, ADD IT                                *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 8172-ADD-ENTRY
                      THRU 8172-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S COMPOSITE ADJUSTMENT FLAG IS ALREADY  *
      * IN THE TABLE, UPDATE THE ENTRY                              *
      *-------------------------------------------------------------*
                WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                   PERFORM 8173-UPDATE-ENTRY
                      THRU 8173-UPDATE-ENTRY-EXIT.

       8171-SEARCH-CAF-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COMPOSITE APC RECORD IN THE CORRECT POSITION *
      * (LOWEST TO HIGHEST CAF) OF THE COMPOSITE APC TABLE          *
      *                                                             *
      ***************************************************************
       8172-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-CMP-INDX TO W-CMP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW COMPOSITE APC ENTRY FOR THE CURRENT *
      * SERVICE LINE SHOULD BE ENTERED INTO THE TABLE ACCORDING TO  *
      * ITS COMPOSITE ADJUSTMENT FLAG (CAF) - LOWEST TO HIGHEST CAF *
      *-------------------------------------------------------------*
             PERFORM 8174-STAGE-CMP-ENTRY
                THRU 8174-STAGE-CMP-ENTRY-EXIT
                  UNTIL W-CMP-INDX = 1 OR
                     H-CMP-CAF NOT < W-CMP-PAF (W-CMP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE H-CMP-CAF  TO W-CMP-PAF (W-CMP-INDX).
             MOVE H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       8172-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING COMPOSITE APC RECORD WITH THE SAME      *
      * COMPOSITE ADJUSTMENT FLAG OF THE CURRENT SERVICE LINE       *
      *                                                             *
      ***************************************************************
       8173-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * ACCUMULATE THE CAF'S TOTAL NON-PRIME SUBMITTED CHARGES      *
      *-------------------------------------------------------------*
             ADD H-SUB-CHRG TO W-CMP-TOT-SUB-CHRG (W-CMP-INDX).

       8173-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING COMPOSITE APC RECORD WITH A HIGHER CAF    *
      * UP ONE RECORD POSITION AND SET THE EMPTY RECORD FOR THE     *
      * NEW ENTRY'S INDEX TO THE NEXT LOWER RECORD POSITION.        *
      *                                                             *
      ***************************************************************
       8174-STAGE-CMP-ENTRY.

             MOVE W-CMP-ENTRY (W-CMP-INDX - 1) TO
                  W-CMP-ENTRY (W-CMP-INDX).
             SET W-CMP-INDX DOWN BY 1.

       8174-STAGE-CMP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      ***************************************************************
       8175-APC-LOOKUP.

      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS BEFORE OR ON THE LATEST       *
      *  EFFECTIVE DATE THE CLAIM CAN USE (SEARCH STARTS AT THE     *
      *  MOST CURRENT RECORD FOR THE APC)                           *
      ***************************************************************
             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC DELETED - ERROR     *
      *-------------------------------------------------------------*
                IF WAR-RATEX (W-SUB2) = 'DELETED'
                   MOVE 30 TO A-RETURN-CODE (LN-SUB)
                   COMPUTE H-TOT-CHRG = H-TOT-CHRG -
                                        H-SUB-CHRG

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC ACTIVE - ACCEPT REC *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT
                   MOVE WAR-RANK (W-SUB2) TO H-RANK
                   MOVE WAR-MINC (W-SUB2) TO H-MIN-COIN
                   MOVE WAR-COIN (W-SUB2) TO H-NAT-COIN
                   MOVE WAR-PPCT (W-SUB2) TO H-PPCT


      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS AFTER THE LATEST EFFECTIVE    *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  APC TABLE.                                                 *
      ***************************************************************
             ELSE
                   SUBTRACT 1 FROM W-SUB2

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE LINE APC, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                   IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                      GO TO 8175-APC-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE LINE APC WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZEROS.                *
      *-------------------------------------------------------------*
                   ELSE
                      MOVE 0 TO H-APC-PYMT
                                H-RANK
                                H-MIN-COIN
                                H-NAT-COIN
                                H-PPCT.

       8175-APC-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE APC RECORD WITH THE APPROPRIATE EFFECTIVE DATE  *
      *    - MOVE APC DATA TO HOLD AREA FOR PROCESSING WHEN FOUND   *
      *    - ADJUST TOTAL CHARGES FOR DELETED APCS & RETURN ERROR   *
      *    - RETURN ERROR WHEN USABLE EFFECTIVE DATE NOT FOUND      *
      *                                                             *
      ***************************************************************
       8180-REDUCE-APC-PYMT.

      *-------------------------------------------------------------*
      *  SPECIFY LINES ELIGIBLE FOR REDUCTION                       *
      *-------------------------------------------------------------*
             IF ( L-PSF-HOSP-QUAL-IND = ' ' )  AND

                (  (OPPS-SRVC-IND (LN-SUB) = ' P')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' R')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' S' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01491' AND
                           OPPS-GRP (LN-SUB) <= '01537'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' T' AND
                      NOT (OPPS-GRP (LN-SUB) >= '01539' AND
                           OPPS-GRP (LN-SUB) <= '01574'))  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' V')  OR

                   (OPPS-SRVC-IND (LN-SUB) = ' X')  ) THEN

                COMPUTE H-APC-PYMT ROUNDED = H-APC-PYMT * 0.981
                MOVE 11 TO A-RETURN-CODE (LN-SUB)

             END-IF.




       8180-REDUCE-APC-PYMT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DELETED CODE:                                              *
      *    IF DATE OF SERVICE BETWEEN 12/31/2002 AND 04/01/2003     *
      *    IF HCPCS CODE = C9114 OR C9115 ADJUST PAYMENT AND        *
      *    COINSURANCE AMOUNTS - LOGIC REMOVED FOR 20050101         *
      *                                                             *
      ***************************************************************


      ***************************************************************
      *                                                             *
      *    SEARCH WAGE INDEX TABLE FOR THE CBSA IN THE PROVIDER     *
      *                     SPECIFIC FILE (PSF)                     *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    IF CBSA NOT LOCATED                                      *
      *       - SET CLAIM RETURN CODE TO '50'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *    IF WAGE INDEX EQUALS ZERO                                *
      *       - SET CLAIM RETURN CODE TO '51'                       *
      *       - DISCONTINUE CLAIM PROCESSING                        *
      *                                                             *
      ***************************************************************
       8200-CALC-WAGEINDX.

      ***************************************************************
      * STARTING AT THE LAST DATE IN THE TABLE, SEARCH WAGE INDEX   *
      * DATE TABLE FOR THE MOST CURRENT EFFECTIVE DATE THAT CAN BE  *
      * USED BY THE CLAIM                                           *
      ***************************************************************
             MOVE WCD-MAX TO WCD-SUB.
             PERFORM UNTIL L-SERVICE-FROM-DATE NOT < WCD-DATE (WCD-SUB)
                 SUBTRACT 1 FROM WCD-SUB
             END-PERFORM.


      ***************************************************************
      *   SEARCH CBSA TABLE FOR THE PSF CBSA                        *
      ***************************************************************
             SEARCH ALL WCM-ENTRY

      *-------------------------------------------------------------*
      *   PSF CBSA NOT FOUND IN CBSA TABLE, RETURN ERROR            *
      *-------------------------------------------------------------*
                AT END
                   MOVE  50  TO A-CLM-RTN-CODE
                   GO TO 8200-CALC-WAGEINDX-EXIT

      *-------------------------------------------------------------*
      *   PSF CBSA FOUND IN CBSA TABLE                              *
      *-------------------------------------------------------------*
                WHEN WCM-CBSA (WCM-INDX) = H-PSF-CBSA

      *-------------------------------------------------------------*
      *   START SEARCH AT THE MOST CURRENT RECORD FOR THE CBSA      *
      *-------------------------------------------------------------*
                  MOVE WCM-PTR (WCM-INDX) TO W-SUB3

      *-------------------------------------------------------------*
      *   GET WAGE INDEX FROM THE REC W/ THE CORRECT EFFECTIVE DATE *
      *-------------------------------------------------------------*
                  PERFORM 8210-WAGE-LOOKUP.

      *-------------------------------------------------------------*
      *   ADJUST THE WAGE INDEX BY THE APPROPRIATE STATE SPECIFIC   *
      *   RURAL FLOOR BUDGET NEUTRALILTY FACTOR (SSRFBN)            *
      *   11/10/2008 - NEW FOR CY 2009                              *
      *-------------------------------------------------------------*
                  PERFORM 8220-APPLY-SSRFBN
                     THRU 8220-EXIT.

      ***************************************************************
      *   RETURN ERROR IF WAGE INDEX = 0 OR NOT NUMERIC             *
      ***************************************************************
             IF H-WINX1 = 0 OR H-WINX1 NOT NUMERIC THEN
                MOVE  51  TO A-CLM-RTN-CODE.

       8200-CALC-WAGEINDX-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  LOCATE THE CBSA RECORD WITH THE APPROPRIATE EFFECTIVE DATE *
      *     WHEN FOUND, SELECT THE APPLICABLE WAGE INDEX VALUE      *
      *                                                             *
      ***************************************************************
       8210-WAGE-LOOKUP.

      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE IS BEFORE OR ON THE       *
      *  LATEST EFFECTIVE DATE THE CLAIM CAN USE - CORRECT          *
      *  (SEARCH STARTS AT THE MOST CURRENT RECORD FOR THE CBSA)    *
      ***************************************************************
             IF WCW-DTCD (W-SUB3) NOT > WCD-DTCD (WCD-SUB)

      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS RECLASSIFIED, USE THE WAGE INDEX IN THE *
      *   SECOND COLUMN FOR RECLASSIFYING PROVIDERS.                *
      *-------------------------------------------------------------*
                IF L-PSF-SPEC-PYMT-IND = 'Y'
                   MOVE WCW-WINX2 (W-SUB3) TO H-WINX1

      *-------------------------------------------------------------*
      *   THIS PROVIDER HAS NOT RECLASSIFIED, USE THE WAGE INDEX IN *
      *   THE FIRST COLUMN FOR AREA PROVIDERS.                      *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WCW-WINX1 (W-SUB3) TO H-WINX1


      ***************************************************************
      *  WAGE INDEX RECORD EFFECTIVE DATE IS AFTER LATEST EFFECTIVE *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  CBSA WAGE INDEX TABLE.                                     *
      ***************************************************************
             ELSE
                SUBTRACT 1 FROM W-SUB3

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE PSF CBSA, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                IF W-SUB3 > WCM-PTR (WCM-INDX - 1)
                   GO TO 8210-WAGE-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE PSF CBSA WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZERO.                 *
      *-------------------------------------------------------------*
                ELSE
                   MOVE 0 TO H-WINX1.

       8210-WAGE-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *         ADJUST THE WAGE INDEX BY THE STATE SPECIFIC         *
      *        RURAL FLOOR BUDGET NEUTRALITY FACTOR (SSRFBN)        *
      *                       (NEW FOR CY 2009)                     *
      *                                                             *
      ***************************************************************
       8220-APPLY-SSRFBN.

      *-------------------------------------------------------------*
      * THE PROVIDER'S STATE IS THE SSRFBN TABLE SEARCH KEY;        *
      * SEARCH SSRFBN TABLE FOR APPROPRIATE FACTOR                  *
      *-------------------------------------------------------------*
           MOVE L-PSF-PROV-ST TO MES-PPS-STATE.
           PERFORM 8225-FIND-SSRFBN
              THRU 8225-EXIT.

      *-------------------------------------------------------------*
      * ADJUST THE WAGE INDEX BY THE SSRFBN FACTOR FOUND IN THE TBL *
      *-------------------------------------------------------------*
           IF H-WINX1 NOT = 0 AND
              H-WINX1 IS NUMERIC AND
              A-CLM-RTN-CODE NOT = 51
              COMPUTE H-WINX1 ROUNDED =
                      H-WINX1 * MES-SSRFBN-RATE
           END-IF.

       8220-EXIT.
            EXIT.


      ***************************************************************
      *                                                             *
      *          FIND THE STATE SPECIFIC RURAL FLOOR BUDGET         *
      *                   NEUTRALITY FACTOR (SSRFBN)                *
      *                       (NEW FOR CY 2009)                     *
      *                                                             *
      ***************************************************************
       8225-FIND-SSRFBN.

      *----------------------------------------------------------------*
      * SEARCH SSRFBN STARTING WITH THE FIRST RECORD                   *
      *----------------------------------------------------------------*
           SET SSRFBN-IDX09 TO 1.
           SEARCH SSRFBN-TAB VARYING SSRFBN-IDX09

      *----------------------------------------------------------------*
      * PROVIDER STATE NOT FOUND IN SSRFBN TABLE, ASSIGN ERROR CODE    *
      *----------------------------------------------------------------*
               AT END
                  MOVE  51  TO A-CLM-RTN-CODE
                 GO TO 8225-EXIT

      *----------------------------------------------------------------*
      * PROVIDER STATE FOUND, CAPTURE SSRFBN FACTOR                    *
      *----------------------------------------------------------------*
               WHEN WK-SSRFBN-STATE(SSRFBN-IDX09) = MES-PPS-STATE
                 MOVE WK-SSRFBN-REASON-ALL (SSRFBN-IDX09) TO MES-SSRFBN.

       8225-EXIT.
            EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE DISCOUNT RATE BASED ON THE DISCOUNT            *
      *    FACTOR PASSED BY THE OCE: VALUES 1 - 9                   *
      *                                                             *
      *    IF MISSING OR INVALID DISCOUNT FACTOR                    *
      *       - SET RETURN CODE TO '38'                             *
      *       - DISCONTINUE LINE PROCESSING                         *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  11/1/2007 - NEW DISCOUNT INDICATOR 9 ADDED FOR CY 2008     *
      *                                                             *
      ***************************************************************
       8250-CALC-DISCOUNT.

             IF (H-SRVC-UNITS = 0 AND
                 OPPS-APC (LN-SUB) = '0000')
                 MOVE 42 TO A-RETURN-CODE (LN-SUB)
                 GO TO 8250-CALC-DISCOUNT-EXIT
             ELSE
                IF (H-SRVC-UNITS = 0 AND
                    OPPS-APC (LN-SUB) > '0000')
                    MOVE 1 TO H-SRVC-UNITS.

             IF OPPS-DISC-FACT (LN-SUB) = 1 THEN
                MOVE 1 TO H-DISC-RATE
             ELSE
              IF OPPS-DISC-FACT (LN-SUB) = 2 THEN
                 COMPUTE H-DISC-RATE = (1 + DISC-FRACTION  *
                 (H-SRVC-UNITS - 1)) / H-SRVC-UNITS
              ELSE
               IF OPPS-DISC-FACT (LN-SUB) = 3 THEN
                  COMPUTE H-DISC-RATE = TERM-PROC-DISC
                                     / H-SRVC-UNITS
               ELSE
                IF OPPS-DISC-FACT (LN-SUB) = 4 THEN
                   COMPUTE H-DISC-RATE = (1 + DISC-FRACTION)
                                     / H-SRVC-UNITS
                ELSE
                 IF OPPS-DISC-FACT (LN-SUB) = 5 THEN
                    COMPUTE H-DISC-RATE = DISC-FRACTION
                 ELSE
                  IF OPPS-DISC-FACT (LN-SUB) = 6 THEN
                     COMPUTE H-DISC-RATE = (TERM-PROC-DISC *
                        DISC-FRACTION) / H-SRVC-UNITS
                  ELSE
                   IF OPPS-DISC-FACT (LN-SUB) = 7 THEN
                      COMPUTE H-DISC-RATE = (DISC-FRACTION *
                      (1 + DISC-FRACTION) / H-SRVC-UNITS)
                   ELSE
                    IF OPPS-DISC-FACT (LN-SUB) = 8 THEN
                       MOVE 2 TO H-DISC-RATE
                    ELSE
                     IF OPPS-DISC-FACT (LN-SUB) = 9 THEN
                        COMPUTE H-DISC-RATE = 1 / H-SRVC-UNITS
                     ELSE
                        MOVE  38  TO A-RETURN-CODE (LN-SUB).

       8250-CALC-DISCOUNT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  POPULATE COINSURANCE DEDUCTIBLE TABLE WITH SERVICE LINES   *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY THE DEDUCTIBLE SEQUENCE -         *
      *     LOWEST TO HIGHEST APC RANK FROM APC TABLE               *
      *                                                             *
      *     DEDUCTIBLE WILL BE TAKEN FROM OPPS SERVICES FIRST,      *
      *     THEN FROM ANY OTHER TYPES OF SERVICES FROM THE CLAIM.   *
      *     ALL VALID SERVICE LINES APPEAR IN THIS TABLE IN THE     *
      *     ORDER OF THEIR RANK FROM LOWEST TO HIGHEST.             *
      *       - THE LOWER THE RANK, THE HIGHER % THE NATIONAL       *
      *         UNADJUSTED COINSURANCE IS OF THE APC PAYMENT RATE   *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW COINSURANCE DEDUCTIBLE TABLE RECORD)           *
      *                                                             *
      *   NOTE: THE PURPOSE OF APC RANKING IS TO ENSURE THAT THE    *
      *         BENEFICIARY DEDUCTIBLE GOES TOWARD LINES WITH       *
      *         HIGHER COINSURANCE %S FIRST.  THIS RESULTS IN THE   *
      *         BENEFICIARY PAYING LESS TOTAL COINSURANCE FOR THE   *
      *         CLAIM.                                              *
      *                                                             *
      ***************************************************************
       8300-COIN-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-LP-INDX TO W-LNC-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      *-------------------------------------------------------------*
             PERFORM 8350-STAGE-ENTRY
                THRU 8350-STAGE-ENTRY-EXIT
                   UNTIL W-LP-INDX = 1 OR
                     H-RANK NOT < W-RANK (W-LP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB      TO W-LP-SUB (W-LP-INDX).
             MOVE H-NAT-COIN  TO W-NAT-COIN (W-LP-INDX).
             MOVE H-MIN-COIN  TO W-MIN-COIN (W-LP-INDX).
             MOVE H-SUB-CHRG  TO W-SUB-CHRG (W-LP-INDX).
             MOVE H-APC-PYMT  TO W-APC-PYMT (W-LP-INDX).
             MOVE H-WINX1     TO W-WINX1 (W-LP-INDX).
             MOVE H-RANK      TO W-RANK (W-LP-INDX).
             MOVE H-PPCT      TO W-PPCT (W-LP-INDX).
             MOVE H-DISC-RATE TO W-DISC-RATE (W-LP-INDX).

      *-------------------------------------------------------------*
      * PARTIAL HOSPITALIZATION LINES RECEIVE 1 SERVICE UNIT        *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                 MOVE 1 TO W-SRVC-UNITS (W-LP-INDX)

      *-------------------------------------------------------------*
      * NON-PARTIAL HOSPITALIZATION LINES RECEIVE INPUT SVC UNITS   *
      *-------------------------------------------------------------*
             ELSE
                 MOVE H-SRVC-UNITS TO W-SRVC-UNITS (W-LP-INDX).

      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-RED-COIN (W-LP-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-RED-COIN (W-LP-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       8300-COIN-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING COINSURANCE DEDUCTIBLE RECORD WITH A    *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       8350-STAGE-ENTRY.

             MOVE W-LP-ENTRY (W-LP-INDX - 1) TO
                  W-LP-ENTRY (W-LP-INDX).
             SET W-LP-INDX DOWN BY 1.

       8350-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     POPULATE BLOOD DEDUCTIBLE TABLE WITH SERVICE LINES      *
      *            THAT HAVE A BLOOD DEDUCTIBLE HCPCS               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *   ORDER SERVICES LINES BY DEDUCTIBLE SEQUENCE -             *
      *     1. EARLIEST TO LATEST DATE OF SERVICE                   *
      *     2. LOWEST TO HIGHEST BLOOD RANK FROM BLOOD DEDUC TABLE  *
      *                                                             *
      *     DEDUCTIBLES WILL PAID FOR LINES IN THE ORDER OF DATE OF *
      *     SERVICE (EARLIEST TO LATEST) AND THEN BY COST (LEAST TO *
      *     MOST EXPENSIVE).  ONLY VALID LINES WITH A HCPCS IN THE  *
      *     BLOOD DEDUCTIBLE RANKING TABLE APPEAR IN THIS TABLE.    *
      *       - BLOOD RANK OF 1 IS ASSIGNED TO THE LEAST EXPENSIVE  *
      *         BLOOD CODE                                          *
      *       - MOVE ALL LINE PRICING VARIABLES TO STAGING AREA     *
      *         (NEW BLOOD DEDUCTIBLE TABLE RECORD)                 *
      *                                                             *
      *    NOTE: THE PURPOSE OF BLOOD LINE RANKING IS TO ENSURE     *
      *          THAT THE BENEFICIARY PAYS DEDUCTIBLES FOR THE      *
      *          THREE LEAST EXPENSIVE BLOOD PRODUCTS.              *
      *                                                             *
      ***************************************************************
       8375-BLOOD-DEDUCT.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-BD-INDX TO W-BLD-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW SERVICE LINE SHOULD BE ENTERED INTO *
      * THE TABLE ACCORDING TO ITS RANK AND THE RANK OF THE RECORDS *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST RANK.              *
      * (RANK IS THE DATE OF SERVICE & BLOOD RANK)                  *
      *-------------------------------------------------------------*
             PERFORM 8385-STAGE-ENTRY
                THRU 8385-STAGE-ENTRY-EXIT
                   UNTIL W-BD-INDX = 1 OR
                     H-BLD-RNK NOT < W-BD-RNK (W-BD-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE LN-SUB TO W-BD-SUB (W-BD-INDX).
             MOVE H-NAT-COIN TO W-BD-NAT-COIN (W-BD-INDX).
             MOVE H-MIN-COIN TO W-BD-MIN-COIN (W-BD-INDX).
             MOVE H-SUB-CHRG TO W-BD-SUB-CHRG (W-BD-INDX).
             MOVE H-APC-PYMT TO W-BD-APC-PYMT (W-BD-INDX).
             MOVE H-WINX1    TO W-BD-WINX1 (W-BD-INDX).
             MOVE H-BLOOD-RANK  TO W-BD-RANK (W-BD-INDX).
             MOVE H-BLD-DOS TO W-BD-DOS (W-BD-INDX).
             MOVE H-PPCT     TO W-BD-PPCT (W-BD-INDX).
             MOVE H-DISC-RATE TO W-BD-DISC-RATE (W-BD-INDX).
             MOVE H-SRVC-UNITS TO W-BD-SRVC-UNITS (W-BD-INDX).


      *-------------------------------------------------------------*
      * SEARCH PROVIDER SPECIFIC FILE FOR THE LINE APC.             *
      * IF FOUND, CALCULATE THE REDUCED COINSURANCE AMOUNT FOR      *
      * THE LINE, ENTER IT INTO THE NEW COIN DEDUC TABLE REC, &     *
      * RETURN CODE 25                                              *
      *-------------------------------------------------------------*
             MOVE 0 TO W-BD-RED-COIN (W-BD-INDX).
             PERFORM VARYING PS-SUB FROM 1 BY 1
               UNTIL PS-SUB > L-PSF-APC-LINE-CNT

                  IF L-PSF-APC (PS-SUB) = OPPS-APC (LN-SUB)
                     COMPUTE W-BD-RED-COIN (W-BD-INDX) ROUNDED =
                             L-PSF-RED-COIN (PS-SUB) * H-SRVC-UNITS *
                             H-DISC-RATE
                     MOVE 25 TO A-RETURN-CODE (LN-SUB)
                     MOVE L-PSF-APC-LINE-CNT TO PS-SUB
                  END-IF

             END-PERFORM.

       8375-BLOOD-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING BLOOD DEDUCTIBLE RECORD WITH A          *
      *   HIGHER RANK UP ONE RECORD POSITION AND SET THE INDEX OF   *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       8385-STAGE-ENTRY.

             MOVE W-BD-ENTRY (W-BD-INDX - 1) TO
                  W-BD-ENTRY (W-BD-INDX).
             SET W-BD-INDX DOWN BY 1.

       8385-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *            POPULATE PASS-THROUGH DEVICE TABLE               *
      *            (IMPLEMENTED IN APRIL 2008 PRICER)               *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ORDER RECORDS AS FOLLOWS -                                 *
      *     1. HCPCS, ASCENDING                                     *
      *     2. LOWEST TO HIGHEST LINE SUBSCRIPT                     *
      *                                                             *
      *  02/11/2008 - LOGIC ADDED FOR CY 2008, QTR 2                *
      *  11/12/2008 - LOGIC NOT CHANGED, NO CY 2009 PT DEVICES      *
      *                                                             *
      ***************************************************************
       8390-PASS-THRU-DEVICES.

      *-------------------------------------------------------------*
      * ADD 1 TO THE TOTAL TABLE RECORDS FOR THE NEW ENTRY          *
      *-------------------------------------------------------------*
             ADD 1 TO W-PTD-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-PTD-INDX TO W-PTD-MAX.
             INITIALIZE W-PTD-ENTRY (W-PTD-INDX).

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW RECORD SHOULD BE ENTERED INTO THE   *
      * TABLE ACCORDING TO ITS HCPCS AND THE HCPCS OF THE RECORDS   *
      * ALREADY IN THE TABLE - LOWEST TO HIGHEST HCPCS              *
      *-------------------------------------------------------------*
             PERFORM 8391-STAGE-ENTRY
                THRU 8391-STAGE-ENTRY-EXIT
                   UNTIL W-PTD-INDX = 1 OR
                     W-PTD-LINE-HCPCS NOT <
                       W-PTD-HCPCS (W-PTD-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      *-------------------------------------------------------------*
             MOVE OPPS-HCPCS (LN-SUB)    TO W-PTD-HCPCS (W-PTD-INDX).
             MOVE LN-SUB                 TO W-PTD-SUB (W-PTD-INDX).
             MOVE OPPS-SUB-CHRG (LN-SUB) TO W-PTD-SUB-CHRG (W-PTD-INDX).

       8390-PASS-THRU-DEVICES-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   MOVE THE EXISTING PASS-THROUGH DEVICE RECORD WITH A       *
      *   HIGHER HCPCS UP ONE RECORD POSITION AND SET THE INDEX OF  *
      *   THE EMPTY RECORD FOR THE NEW ENTRY TO THE NEXT LOWER      *
      *   RECORD POSITION.                                          *
      *                                                             *
      ***************************************************************
       8391-STAGE-ENTRY.

             MOVE W-PTD-ENTRY (W-PTD-INDX - 1) TO
                  W-PTD-ENTRY (W-PTD-INDX).
             SET W-PTD-INDX DOWN BY 1.

       8391-STAGE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    UPDATE PASS-THROUGH DEVICE TABLE WITH PROCEDURE DATA     *
      *              (IMPLEMENTED IN APRIL 2008 PRICER)             *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  02/11/2008 - LOGIC ADDED FOR CY 2008, QTR 2                *
      *                                                             *
      ***************************************************************
       8392-PASS-THRU-DEV-PROCS.

      *-------------------------------------------------------------*
      * LOOP THROUGH ELIGIBLE PROCEDURE'S PASS-THROUGH DEVICE TABLE *
      *-------------------------------------------------------------*
             PERFORM 8393-PERFORM-SEARCH
                THRU 8393-PERFORM-SEARCH-EXIT
                VARYING W-PTD-PROC-SUB FROM 1 BY 1
                UNTIL W-PTD-PROC-SUB > W-PTD-CNT.

       8392-PASS-THRU-DEV-PROCS-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * SEARCH FOR THE PASS-THROUGH DEVICE FOR WHICH THE PROCEDURE  *
      * IS ELIGIBLE IN THE TABLE                                    *
      *                                                             *
      ***************************************************************
       8393-PERFORM-SEARCH.

      *-------------------------------------------------------------*
      * SEARCH PTD TABLE STARTING AT ENTRY #1 FOR ALL OCCURANCES    *
      * OF THE PASS-THRU DEVICE HCPCS IN THE PASS-THRU DEVICE TABLE.*
      * THIS IS DONE FOR ALL PASS-THROUGH DEVICES THE PROCEDURE IS  *
      * ELIGIBLE FOR.                                               *
      *-------------------------------------------------------------*
                 MOVE 'N' TO W-END-OF-PTD-TBL.

                 IF W-PTD-PROC-HCPCS (W-PTD-PROC-SUB) NOT = '     '
                    SET W-PTD-INDX TO 1
                    PERFORM 8394-SEARCH-PTD-HCPCS
                       THRU 8394-SEARCH-PTD-HCPCS-EXIT
                      UNTIL W-END-OF-PTD-TBL = 'Y'
                 END-IF.

       8393-PERFORM-SEARCH-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * SEARCH FOR THE PASS-THROUGH DEVICE FOR WHICH THE PROCEDURE  *
      * IS ELIGIBLE IN THE TABLE                                    *
      *                                                             *
      ***************************************************************
       8394-SEARCH-PTD-HCPCS.

             MOVE 'N' TO W-END-OF-PTD-TBL.

      *-------------------------------------------------------------*
      * SEARCH PASS-THROUGH DEVICE TABLE                            *
      *-------------------------------------------------------------*
             SEARCH W-PTD-ENTRY VARYING W-PTD-INDX

      *-------------------------------------------------------------*
      * IF THERE ARE NO MORE OCCURANCES OF THE PASS-THROUGH DEVICE, *
      * STOP THE SEARCH AND INDICATE END OF FILE                    *
      *-------------------------------------------------------------*
                AT END
                   MOVE 'Y' TO W-END-OF-PTD-TBL
                   GO TO 8394-SEARCH-PTD-HCPCS-EXIT

      *-------------------------------------------------------------*
      * IF THE PASS-THROUGH DEVICE IS FOUND, INDICATE NOT END OF    *
      * FILE AND UPDATE THE DEVICE'S RECORD WITH THE PROCEDURE DATA *
      *-------------------------------------------------------------*
                WHEN  W-PTD-HCPCS (W-PTD-INDX) =
                      W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)

                         MOVE 'N' TO W-END-OF-PTD-TBL

                         PERFORM 8395-UPDATE-ENTRY
                            THRU 8395-UPDATE-ENTRY-EXIT

                         SET W-PTD-INDX UP BY 1

             END-SEARCH.

       8394-SEARCH-PTD-HCPCS-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING PASS-THROUGH DEVICE RECORD WITH THE     *
      * CURRENT ELIGIBLE PROCEDURE'S DATA                           *
      *                                                             *
      ***************************************************************
       8395-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * UPDATE PASS-THROUGH DEVICE RECORD                           *
      *-------------------------------------------------------------*
             ADD 1 TO W-PTD-PROC-CNT (W-PTD-INDX).

             ADD OPPS-SRVC-UNITS (LN-SUB) TO
                 W-PTD-TOTAL-PROC-UNITS (W-PTD-INDX).

       8395-UPDATE-ENTRY-EXIT.
           EXIT.




      ***************************************************************
      *                                                             *
      *  CALCULATE LINE PYMNTS, DEDUCTIBLES, REIM., & COINSURANCE,  *
      *  ACCUMULATE CLAIM TOTALS, POPULATE DRUG DEDUCTIBLE TABLE,   *
      *  UPDATE PASS-THROUGH DEVICE TABLE WITH PROCEDURE & DEVICE   *
      *  LINE DATA, MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE    *
      *  FOLLOWING FOR EACH SERVICE LINE:                           *
      *                                                             *
      *  - CHECK ALL APPROPRIATE FLAGS AND INDICATORS FROM OCE      *
      *  - SET RETURN CODES TO INDICATE ERRORS OR STATUS            *
      *      '20' - LINE PROCESSED BUT PAYMENT = 0,                 *
      *             BENE DEDUCTIBLE => ADJUSTED PAYMENT             *
      *  - CALCULATE & ACCUMULATE LINE AND CLAIM LEVEL ITEMS        *
      *  - POPULATE DRUG COINSURANCE TABLE                          *
      *  - MOVE LINE VARIABLE VALUES TO VARIABLES TO BE PASSED BACK *
      *                                                             *
      ***************************************************************
       8400-CALCULATE.

      *-------------------------------------------------------------*
      * SET THE SERVICE LINE SUBSCRIPT TO THE CLAIM SERVICE LINE #  *
      * ASSOCIATED WITH THE COINSURANCE DEDUCTIBLE TABLE RECORD     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * STOP PROCESSING LINE IF ERROR CODE                          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) >  25
                GO TO 8400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *   - LINE ITEM REIMBURSEMENT IF MAX COIN LIMIT EXCEEDED      *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5'
                               OR ' 6' OR ' 7' OR ' 8'
                PERFORM 8550-CALC-STANDARD
                   THRU 8550-CALC-STANDARD-EXIT
             ELSE
                GO TO 8400-CALCULATE-EXIT.

      *-------------------------------------------------------------*
      * POPULATE DRG COINSURANCE TABLE FOR LATER PROCESSING         *
      *  - ENFORCE INPATIENT COINSURANCE LIMIT                      *
      *  - SET GJK-FLAG WHEN SERVICE = G OR K                       *
      *-------------------------------------------------------------*
             IF (A-RETURN-CODE (LN-SUB) <  30)
                PERFORM 8450-ADJ-PROC-COIN
                   THRU 8450-ADJ-PROC-COIN-EXIT
             ELSE
                NEXT SENTENCE.

      *-------------------------------------------------------------*
      * FLAG CLAIMS WITH ARTIFICIAL CHARGES AND TOTAL PAYMENTS &    *
      * CHARGES FOR ARTIFICIAL CHARGE AND PACKAGING PROCESSING      *
      *-------------------------------------------------------------*
             PERFORM 8500-ADJ-CHRGS
                THRU 8500-ADJ-CHRGS-EXIT.


      *-------------------------------------------------------------*
      *   UPDATE PASS-THROUGH DEVICE TABLE W/ ELIGIBLE PROCEDURE    *
      *   LINE DATA                                                 *
      *   EFFECTIVE CY 2008 QTR 2, LOGIC ADDED 02/12/2008           *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) < 30 AND
                PTD-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR ' X'

                  PERFORM 8670-SET-PTD-PROC-FLAG
                     THRU 8670-SET-PTD-PROC-FLAG-EXIT

                  IF PTD-PROC-FLAG = 'Y'
                     PERFORM 8392-PASS-THRU-DEV-PROCS
                        THRU 8392-PASS-THRU-DEV-PROCS-EXIT
                  END-IF

             END-IF.

      *-------------------------------------------------------------*
      * ACCUMULATE CLAIM TOTALS USING DATA FROM THE CURRENT VALID   *
      * SERVICE LINE (IN THE COINSURANCE DEDUCTIBLE TABLE)          *
      *-------------------------------------------------------------*
             IF A-RETURN-CODE (LN-SUB) <  30

                COMPUTE A-TOTAL-CLM-DEDUCT =
                        H-TOTAL-LN-DEDUCT + A-TOTAL-CLM-DEDUCT

                COMPUTE H-TOT-PYMT = H-TOT-PYMT + H-LITEM-PYMT

                COMPUTE A-BLOOD-DEDUCT-DUE =
                        A-BLOOD-DEDUCT-DUE + H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * MOVE LINE VALUES TO VARIABLES TO BE PASSED BACK             *
      *  - THE LINE REIM. & ADJ-COIN IS ADJUSTED LATER (IF NEEDED)  *
      *    FOR THE INPATIENT DAILY LIMIT IN 8840-PROCESS-TYPE2      *
      *-------------------------------------------------------------*
               MOVE H-LITEM-PYMT      TO A-LITEM-PYMT (LN-SUB)
               MOVE H-LITEM-REIM      TO A-LITEM-REIM (LN-SUB)
               MOVE H-TOTAL-LN-DEDUCT TO A-TOTAL-LN-DEDUCT (LN-SUB)
               MOVE H-LN-BLOOD-DEDUCT TO A-BLOOD-LN-DEDUCT (LN-SUB)
               MOVE H-NAT-COIN        TO A-ADJ-COIN (LN-SUB)
               MOVE H-RED-COIN        TO A-RED-COIN (LN-SUB)

               IF H-RED-COIN > H-NAT-COIN
                  MOVE H-NAT-COIN TO A-RED-COIN (LN-SUB)
               END-IF

               IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
                  MOVE 0 TO A-LITEM-PYMT (LN-SUB)
                  MOVE 0 TO A-LITEM-REIM (LN-SUB)
                  COMPUTE H-TOT-PYMT = H-TOT-PYMT - H-LITEM-PYMT
               END-IF
             END-IF.

      *-------------------------------------------------------------*
      * INITIALIZE LINE VARIABLES FOR THE NEXT SERVICE LINE IN THE  *
      * COINSURANCE DEDUCTIBLE TABLE                                *
      *-------------------------------------------------------------*
             MOVE ZERO TO LINE-HOLD-ITEMS.

       8400-CALCULATE-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *     POPULATE DRUG COINSURANCE ROLL-UP TABLE WITH THE        *
      *  COINSURANCE AMOUNTS OF SERVICE LINES IN THE COINSURANCE    *
      *                      DEDUCTIBLE TABLE                       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * ORDER LINES BY:                                             *
      *   1. DATE OF SERVICE (EARLIEST TO LATEST)                   *
      *   2. DCP-CODE - TYPE OF ENTRY BASED ON SERVICE INDICATOR    *
      *      DCP-CODE OF 1: DAY SUMMARY                             *
      *      DCP-CODE OF 2: DRUG / BLOOD LINE                       *
      *   THERE IS ONE TYPE 1 RECORD PER DAY; THERE MAY BE MULTIPLE *
      *   TYPE 2 RECORDS PER DAY - ONE FOR EVERY DRUG LINE          *
      *   ("DRUG" REFERS TO ANY SI = G OR K LINE FOR SIMPLICITY)    *
      *                                                             *
      * DRUG COINSURANCE RECORD COMBINATIONS:                       *
      *   - TYPE 1, COIN1 = 0, COIN2 > 0, & SI = X =>               *
      *       DRUG(S) ADMINISTERED INDEPENDENT OF A PROCEDURE VISIT *
      *       ON THE DATE OF SERVICE                                *
      *   - TYPE 1, COIN1 > 0, COIN2 = 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH NO DRUG(S) ADMINISTERED ON THE *
      *       DATE OF SERVICE                                       *
      *   - TYPE 1, COIN1 > 0, COIN2 > 0, & SI = S, V, OR T =>      *
      *       PROCEDURE / VISIT WITH DRUG(S) ADMINISTERED ON THE    *
      *       DATE OF SERVICE                                       *
      *   - TYPE 2, COIN1 = 0, COIN2 > 0, & SI = G OR K =>          *
      *       DRUG ADMINSTERED ON THE DATE OF SERVICE               *
      *                                                             *
      ***************************************************************
       8450-ADJ-PROC-COIN.

      ***************************************************************
      * MOVE LINE DATE OF SERVICE TO DATE OF SERVICE HOLD AREA      *
      ***************************************************************
             MOVE OPPS-LITEM-DOS (LN-SUB) TO H-DCP-DOS.


      ***************************************************************
      *                                                             *
      * PROCESS SI = S, T, OR V LINES (PROCEDURE OR VISIT)          *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'

      *-------------------------------------------------------------*
      * CALCULATE WAGE ADJUSTED LINE NATIONAL COINSURANCE AMOUNT    *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-WGNAT ROUNDED =
                      W-NAT-COIN (W-LP-INDX) *
                         (.6 * W-WINX1 (W-LP-INDX) + .4)

      *-------------------------------------------------------------*
      * ENFORCE INPATIENT LIMIT ON NATIONAL COINSURANCE AMOUNT      *
      *-------------------------------------------------------------*
                IF H-NEW-WGNAT > H-IP-LIMIT
                   MOVE H-IP-LIMIT TO H-NEW-WGNAT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                     H-TOTAL-LN-DEDUCT -
                                     H-LITEM-REIM -
                                     H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE DRUG COINSURANCE TABLE ENTRY FOR THE DOS      *
      *-------------------------------------------------------------*
                PERFORM 8455-SEARCH-KEY
                   THRU 8455-SEARCH-KEY-EXIT


      ***************************************************************
      *                                                             *
      * PROCESS SI = G, K, & R LINES ("DRUG" & BLOOD)               *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' OR ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE NEW COINSURANCE AMOUNT (ACTUAL COIN DUE)     *
      *-------------------------------------------------------------*
                   COMPUTE H-NEW-COIN = H-LITEM-PYMT -
                                        H-TOTAL-LN-DEDUCT -
                                        H-LITEM-REIM -
                                        H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * SET GJK-FLAG TO INDICATE "DRUG" LINE                        *
      *-------------------------------------------------------------*
                   MOVE 'Y' TO GJK-FLAG

      *-------------------------------------------------------------*
      * INDICATE TYPE 1 RECORD (ONE TYPE 1 RECORD PER DAY)          *
      *-------------------------------------------------------------*
                   MOVE 1 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * ADD OR UPDATE DRUG COINSURANCE TABLE ENTRY FOR THE DOS      *
      *-------------------------------------------------------------*
                   PERFORM 8455-SEARCH-KEY
                      THRU 8455-SEARCH-KEY-EXIT

      *-------------------------------------------------------------*
      * INDICATE TYPE 2 RECORD (ONE TYPE 2 REC FOR EVERY DRUG LINE) *
      *-------------------------------------------------------------*
                   MOVE 2 TO H-DCP-CODE

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
                   ADD 1 TO W-DCP-MAX

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      * A NEW TYPE 2 RECORD ENTRY IS CREATED FOR EVERY SI = G OR K  *
      * SERVICE LINE REGARDLESS OF THE DATE OF SERVICE              *
      *-------------------------------------------------------------*
                   SET W-DCP-INDX TO W-DCP-MAX

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW DRUG / DEVICE COINSURANCE ENTRY     *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY. (RECORD TYPE 2 ONLY)     *
      *-------------------------------------------------------------*
                   PERFORM 8475-STAGE-DCP-ENTRY
                      THRU 8475-STAGE-DCP-ENTRY-EXIT
                        UNTIL W-DCP-INDX = 1 OR
                         H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 2, "DRUG"                                       *
      *-------------------------------------------------------------*
                   MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                   MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                   MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                   MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                   MOVE OPPS-SRVC-IND (LN-SUB) TO
                               W-DCP-SRVC-IND (W-DCP-INDX).

       8450-ADJ-PROC-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * DETERMINE WHETHER A NEW DRUG/DEVICE COINSURANCE TABLE       *
      * RECORD SHOULD BE ADDED OR IF AN EXISITING RECORD NEEDS TO   *
      * BE UPDATED                                                  *
      *                                                             *
      * (RECORD KEY IS DATE OF SERVICE & RECORD TYPE)               *
      *                                                             *
      ***************************************************************
       8455-SEARCH-KEY.

      *-------------------------------------------------------------*
      * SEARCH DRUG/DEVICE COINSURANCE TABLE STARTING AT ENTRY #1   *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO 1.
             SEARCH  W-DCP-ENTRY VARYING W-DCP-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS NOT ALREADY IN THE TABLE, ADD IT                         *
      *-------------------------------------------------------------*
                AT END
                   PERFORM 8460-ADD-ENTRY
                      THRU 8460-ADD-ENTRY-EXIT

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S DATE OF SERVICE AND RECORD TYPE COMBO *
      * IS ALREADY IN THE TABLE, UPDATE THE ENTRY                   *
      *-------------------------------------------------------------*
                WHEN W-DCP-STAGE (W-DCP-INDX) = H-DCP-STAGE
                   PERFORM 8465-UPDATE-ENTRY
                      THRU 8465-UPDATE-ENTRY-EXIT.

       8455-SEARCH-KEY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * INSERT THE NEW COINSURANCE RECORD INTO THE CORRECT POSITION *
      * (LOWEST TO HIGHEST DATE OF SERVICE - RECORD TYPR COMBO) OF  *
      * THE DRUG / DEVICE COINSURANCE TABLE                         *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       8460-ADD-ENTRY.

      *-------------------------------------------------------------*
      * INCREASE THE TOTAL NUMBER OF TABLE RECORDS FOR NEW ENTRY    *
      *-------------------------------------------------------------*
             ADD 1 TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * MOVE TO THE NEW ENTRY POSITION (EMPTY RECORD)               *
      *-------------------------------------------------------------*
             SET W-DCP-INDX TO W-DCP-MAX.

      *-------------------------------------------------------------*
      * DETERMINE WHERE THE NEW DRUG / DEVICE COINSURANCE ENTRY     *
      * FOR THE CURRENT SERVICE LINE SHOULD BE ENTERED INTO THE     *
      * TABLE ACCORDING TO ITS DATE OF SERVICE AND RECORD TYPE      *
      * COMBO KEY - LOWEST TO HIGHEST KEY.  (TYPE 1 RECORDS ONLY)   *
      *-------------------------------------------------------------*
             PERFORM 8475-STAGE-DCP-ENTRY
                THRU 8475-STAGE-DCP-ENTRY-EXIT
                  UNTIL W-DCP-INDX = 1 OR
                     H-DCP-STAGE NOT < W-DCP-STAGE (W-DCP-INDX - 1).

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, "DRUG"                                       *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' OR ' R'
                MOVE ZERO TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE ZERO TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE ' X' TO W-DCP-SRVC-IND (W-DCP-INDX)

      *-------------------------------------------------------------*
      * POPULATE THE EMPTY RECORD WITH THE NEW SERVICE LINE'S DATA  *
      * RECORD TYPE 1, PROCEDURE OR VISIT                           *
      *-------------------------------------------------------------*
             ELSE
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-DCP-STAGE TO W-DCP-STAGE (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE ZERO TO W-DCP-COIN2 (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB) TO
                                  W-DCP-SRVC-IND (W-DCP-INDX).

       8460-ADD-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE EXISTING DRUG COINSURANCE RECORD WITH THE SAME   *
      * DATE OF SERVICE AND RECORD TYPE OF THE CURRENT SERVICE LINE *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       8465-UPDATE-ENTRY.

      *-------------------------------------------------------------*
      * FOR "DRUG" LINES - ACCUMULATE DAY'S TOTAL "DRUG" COIN DUE   *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' OR ' R'
               ADD H-NEW-COIN TO W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISITING RECORD WAS *
      * WAS INITIALLY CREATED FOR A "DRUG" LINE, UPDATE THE RECORD  *
      *-------------------------------------------------------------*
             ELSE
               IF W-DCP-SRVC-IND (W-DCP-INDX) = ' X'
                  PERFORM 8485-REPLACE-TYPE1
                     THRU 8485-REPLACE-TYPE1-EXIT

      *-------------------------------------------------------------*
      * FOR PROCEDURE & VISIT LINES - WHEN THE EXISTING RECORD HAS  *
      * DATA FROM ANOTHER PROCEDURE / VISIT, ENSURE THE PROC/VISIT  *
      * WITH THE HIGHEST WAGE ADJUSTED NATIONAL COIN IS IN THE TBL  *
      *-------------------------------------------------------------*
               ELSE
                  PERFORM 8480-RANK-COIN
                     THRU 8480-RANK-COIN-EXIT.

       8465-UPDATE-ENTRY-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * MOVE THE EXISTING DRUG COINSURANCE RECORD WITH A HIGHER     *
      * RANK UP ONE RECORD POSITION AND SET THE INDEX OF THE EMPTY  *
      * RECORD FOR THE NEW ENTRY TO THE NEXT LOWER RECORD POSITION. *
      *                                                             *
      ***************************************************************
       8475-STAGE-DCP-ENTRY.

             MOVE W-DCP-ENTRY (W-DCP-INDX - 1) TO
                  W-DCP-ENTRY (W-DCP-INDX).
             SET W-DCP-INDX DOWN BY 1.

       8475-STAGE-DCP-ENTRY-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      * ENSURE THAT THE PROCEDURE/VISIT WITH THE HIGHEST WAGE ADJ.  *
      * NATIONAL COINSURANCE AMOUNT IS IN THE TABLE WHEN THERE ARE  *
      * MULTIPLE PROCEDURES/VISITS ON THE SAME DATE OF SERVICE.     *
      * ONLY ONE PROCEDURE/VISIT'S DATA PER DAY APPEARS IN THE TBL. *
      * (ONLY PROCESSES TYPE 1 RECORDS)                             *
      *                                                             *
      ***************************************************************
       8480-RANK-COIN.

             IF H-NEW-WGNAT > W-DCP-WGNAT (W-DCP-INDX)
                MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
                MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
                MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
                MOVE OPPS-SRVC-IND (LN-SUB)
                           TO W-DCP-SRVC-IND (W-DCP-INDX).

       8480-RANK-COIN-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * ENTER VALUES FROM THE CURRENT SI = S, V, OR T SERVICE LINE  *
      * INTO AN EXISITING RECORD THAT WAS FORMERLY AN SI = G OR K   *
      * ONLY ENTRY.                                                 *
      * - SERVICE LINE REFERENCES CURRENT PROCEDURE / VISIT LINE    *
      * - COIN1 = PROCEDURE / VISIT LINE NEW COINSURANCE AMOUNT     *
      * - COIN2 = DRUG / BLOOD LINE NEW COINSURANCE AMOUNT(S)       *
      * - WAGE ADJUSTED NATIONAL COIN OF CURRENT LINE ENTERED       *
      * - SERVICE INDICATOR = SI OF CURRENT LINE (S, V, OR T)       *
      *                                                             *
      ***************************************************************
       8485-REPLACE-TYPE1.

             MOVE LN-SUB TO W-DCP-SUB (W-DCP-INDX)
             MOVE H-NEW-COIN TO W-DCP-COIN1 (W-DCP-INDX)
             MOVE H-NEW-WGNAT TO W-DCP-WGNAT (W-DCP-INDX)
             MOVE OPPS-SRVC-IND (LN-SUB)
                         TO W-DCP-SRVC-IND (W-DCP-INDX).

       8485-REPLACE-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * IDENTIFY CLAIMS THAT HAVE SIGNIFICANT PROCEDURE (SURGERY)   *
      * LINE(S) WITH ARTIFICIAL CHARGES FOR FURTHER PROCESSING,     *
      * ACCUMULATE TOTAL CLAIM PAYMENTS AND CHARGES FOR SIGNIFICANT *
      * PROCEDURE LINES, AND ACCUMULATE TOTAL CLAIM CHARGES OF ALL  *
      * SEPARATELY PAYABLE LINES.  (THE FLAG AND CLAIM TOTALS ARE   *
      * USED IN PARAGRAPH 8600-ADJ-CHRG-OUTL.)                      *
      *                                                             *
      ***************************************************************
       8500-ADJ-CHRGS.

      ***************************************************************
      ** NEW LOGIC INSERTED FOR WEB USE ONLY                        *
      ***************************************************************

      *-------------------------------------------------------------*
      * FLAG CLAIM WHEN A SIGNIFICANT PROCEDURE LINE HAS ARTIFICIAL *
      * CHARGES ($1 OR LESS) - FLAGS ENTIRE CLAIM                   *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (W-SUB-CHRG (W-LP-INDX) < 1.01)
                   MOVE 'Y' TO ST0-FLAG.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM CHARGES AND PAYMENTS FROM UNPACKAGED *
      * SIGNIFICANT PROCEDURE (SURGERY) LINES                       *
      *-------------------------------------------------------------*
             IF ((OPPS-SRVC-IND (LN-SUB) = ' T') OR
                ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                 (OPPS-HCPCS (LN-SUB) > '09999' AND
                  OPPS-HCPCS (LN-SUB) < '70000'))) AND
                (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                   COMPUTE H-TOT-ST-CHRG = W-SUB-CHRG (W-LP-INDX) +
                                           H-TOT-ST-CHRG
                   COMPUTE H-TOT-ST-PYMT = H-LITEM-PYMT +
                                           H-TOT-ST-PYMT.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM PAYMENTS FROM UNPACKAGED SEPARATELY  *
      * PAYABLE LINES (FOR PACKAGING LATER)                         *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V'
                 OR ' X' OR ' P')
                AND (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')
                   COMPUTE H-TOT-STVX-PYMT = H-LITEM-PYMT +
                                             H-TOT-STVX-PYMT.

       8500-ADJ-CHRGS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID LINES IN THE COINSURANCE  *
      * DEDUCTIBLE TABLE WITH A PAYABLE STATUS:                     *
      *   - LINE ITEM PAYMENT (BASED ON LINE SERVICE INDICATOR)     *
      *   - BENEFICIARY DEDUCTIBLE (IN ORDER OF APC RANK)           *
      *   - MINIMUM, MAXIMUM, AND REDUCED COINSURANCE AMOUNTS       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * 1. CALCULATE STANDARD LINE ITEM PAYMENT (LINE PRICE)        *
      *    (APC PAYMENT * WAGE INDEX * SERVICE UNITS *              *
      *     DISCOUNT FACTOR)                                        *
      *    WAGE ADJUST 60% OF THE APC PAYMENT FOR SI = S, V, T, P,  *
      *    OR X LINES, THESE ARE ELIGIBLE FOR THE SCH ADJUSTMENT    *
      * 2. APPLY DEDUCTIBLE TO HIGHEST NATIONAL COINSURANCE AMOUNT  *
      *    DESCENDING UNTIL DEDUCTIBLE = 0.                         *
      * 3. ADD LINE PRICE TO OUTLIER HOLD AREA                      *
      * 4. CALCULATE THE LINE PRICE FOR DESIGNATED DEVICES          *
      *    AND DRUGS                                                *
      * 5. CALCULATE DEVICE REDUCTIONS                              *
      *                                                             *
      ***************************************************************
       8550-CALC-STANDARD.

      ***************************************************************
      * INITIALIZE & SET LINE VARIABLES AND FLAGS                   *
      ***************************************************************

      *-------------------------------------------------------------*
      * INITIALIZE VARIABLE FOR LINES ELIGIBLE FOR BLOOD DEDUCTIBLE *
      *-------------------------------------------------------------*
             MOVE 0 TO H-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * FLAG LINE IF THE LINE APC IS A BRACHYTHERAPY APC            *
      * ** NEW LIST EVERY JANUARY **                                *
      *-------------------------------------------------------------*
      * 11/13/2007 - BRACHY APC CHECK ADDED                         *
      * 12/28/2007 - LOGIC MOVED HERE                               *
      * 11/12/2008 - LOGIC DISABLED, BRACHYTHERAPY LINES IDENTIFIED *
      *              WITH A STATUS INDICATOR OF ' U' FOR CY 2009    *
      *-------------------------------------------------------------*
      *      PERFORM 8650-SET-BRACHY-APC-FLAG
      *         THRU 8650-SET-BRACHY-APC-FLAG-EXIT.

      *-------------------------------------------------------------*
      * FLAG LINE IF THE LINE HCPCS IS A BLOOD DEDUCTIBLE HCPCS     *
      * ** NEW LIST EVERY JANUARY **                                *
      *-------------------------------------------------------------*
      * 11/13/2007 - HCPCS LIST MOVED FROM 7550-CALC-GJK TO HERE    *
      * 12/04/2007 - LIST MOVED TO 7655-SET-BD-HCPCS-FLAG           *
      * 12/28/2007 - LOGIC MOVED HERE                               *
      *-------------------------------------------------------------*
             PERFORM 8655-SET-BD-HCPCS-FLAG
                THRU 8655-SET-BD-HCPCS-FLAG-EXIT.

      *-------------------------------------------------------------*
      * FLAG LINE IF THE LINE APC IS A RADIOPHARM APC               *
      * ** NEW LIST EVERY JANUARY **                                *
      *-------------------------------------------------------------*
      * 12/27/2007 - RADIOPHARM APC CHECK ADDED                     *
      * 12/28/2007 - LOGIC MOVED HERE                               *
      *-------------------------------------------------------------*
             PERFORM 8660-SET-RADIOPH-APC-FLAG
                THRU 8660-SET-RADIOPH-APC-FLAG-EXIT.

      *-------------------------------------------------------------*
      * FLAG LINE IF LINE HCPCS IS A PASS-THROUGH RADIOPHARM HCPCS  *
      * ** QUARTERLY UPDATES TO TABLE **                            *
      *-------------------------------------------------------------*
      * 02/10/2009 - PT RADIOPHARM HCPCS CHECK ADDED                *
      *-------------------------------------------------------------*
             PERFORM 8680-SET-PTRADIO-LINE-FLAG
                THRU 8680-SET-PTRADIO-LINE-FL-EXIT.


      ***************************************************************
      * CALCULATE MAXIMUM COINSURANCE AMOUNT (INPATIENT LIMIT)      *
      ***************************************************************
             COMPUTE H-MAX-COIN ROUNDED = (H-IP-LIMIT *
               W-SRVC-UNITS (W-LP-INDX) * W-DISC-RATE (W-LP-INDX)).


      ***************************************************************
      * CALCULATE FULL AND PARTIAL CREDIT DEVICE REDUCTIONS AND     *
      * REDUCE THE APC PAYMENT BY THE REDUCTION AMOUNT              *
      * PAYMENT ADJUSTMENT FLAGS: 7 = FULL, 8 = PARTIAL CREDIT      *
      *-------------------------------------------------------------*
      * 11/1/2007 - PYMT ADJ FLAG 8 ADDED FOR PARTIAL CREDIT        *
      *             DEDUCTIONS - NEW FOR CY 2008                    *
      ***************************************************************
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 7' OR ' 8'
                PERFORM 8550-DEVICE-REDUC
                   THRU 8550-DEVICE-REDUC-EXIT.


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = S, V, T, P, OR X LINES           *
      * THE APC PAYMENT IS 60% WAGE ADJUSTED                        *
      *-------------------------------------------------------------*
      * 11/13/2007 - ADDED PERFORM 7560-CALC-BENE-DEDUCT            *
      *              (REMOVED FROM PARAGRAPH 7550-SCH-ADJ)          *
      ***************************************************************
             IF (OPPS-SRVC-IND (LN-SUB) =
                 ' S' OR ' V' OR ' T' OR ' P' OR ' X') THEN
                  PERFORM 8550-SCH-ADJ
                     THRU 8550-SCH-ADJ-EXIT
                  PERFORM 8560-CALC-BENE-DEDUCT
                     THRU 8560-CALC-BENE-DEDUCT-EXIT

                  IF OPPS-SRVC-IND (LN-SUB) = ' P' THEN
                     PERFORM 8550-PHP-PMT-FOR-OUTL
                        THRU 8550-PHP-PMT-FOR-OUTL-EXIT
                  END-IF


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = H (DEVICE) LINES, PAYMENT IND.   *
      * SHOULD BE 6 FOR THESE LINES (BASED ON CHARGE ADJ. TO COST)  *
      * AND SI = U (BRACHYTHERAPY) LINES, PAYMENT ADJ. FLAG SHOULD  *
      * BE 2 FOR THESE LINES                                        *
      * RETURN ERROR CODE 44 IF THIS IS NOT THE CASE                *
      ***************************************************************
             ELSE
               IF (OPPS-SRVC-IND (LN-SUB) = ' H' OR ' U') THEN
                 IF (OPPS-SRVC-IND (LN-SUB) = ' H' AND
                       OPPS-PYMT-IND (LN-SUB) = ' 6') OR
                    (OPPS-SRVC-IND (LN-SUB) = ' U' AND
                       OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 2') THEN
                   PERFORM 8555-CALC-H-STANDARD
                      THRU 8555-CALC-H-STANDARD-EXIT
                   PERFORM 8560-CALC-BENE-DEDUCT
                      THRU 8560-CALC-BENE-DEDUCT-EXIT
                 ELSE
                   MOVE  44  TO A-RETURN-CODE (LN-SUB)
                   GO TO 8550-CALC-STANDARD-EXIT
                 END-IF


      ***************************************************************
      * CALCULATE PAYMENT FOR SI = G, K & R LINES; THE PAYMENT IND. *
      * SHOULD BE 1, 5, OR 7 FOR THESE LINES (PAY STANDARD AMOUNT)  *
      * RETURN ERROR CODE 41 IF INVALID SI - PYMT IND. COMBO        *
      *-------------------------------------------------------------*
      * 12/31/2007 - REMOVED REDUNDANT H-BLOOD-FRAC. INITIALIZATION *
      ***************************************************************
               ELSE
                 IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K' OR ' R' THEN
                   IF OPPS-PYMT-IND (LN-SUB) = ' 1' OR ' 5' OR ' 7' THEN
                      PERFORM 8550-CALC-GJK
                         THRU 8550-CALC-GJK-EXIT

                      IF PTRADIO-LINE-FLAG = 'Y' AND
                         H-NUCMED-TOT-OFFSET > 0 THEN
                         PERFORM 8550-PTRADIO-OFFSET
                            THRU 8550-PTRADIO-OFFSET-EXIT
                      END-IF

                      PERFORM 8560-CALC-BENE-DEDUCT
                         THRU 8560-CALC-BENE-DEDUCT-EXIT
                   ELSE
                      MOVE  41  TO A-RETURN-CODE (LN-SUB)
                      GO TO 8550-CALC-STANDARD-EXIT
                   END-IF
                 END-IF
               END-IF
             END-IF.


      ***************************************************************
      * CALCULATE LINE REIMBURSEMENT                                *
      *-------------------------------------------------------------*
      * 11/01/2007 - PERFORMS FOR PARAGRAPHS 7550-PD-AT-CST-JAN07   *
      *   AND 7550-PD-AT-CST-JUL07 WERE DELETED (THE PARAGRAPHS     *
      *   WERE ALSO DELETED).  THERE IS NO PAID AT COST TABLE FOR   *
      *   2008.  UNDER THE ORIGINAL 2008 LEGISLATION, DIAGNOSIS     *
      *   RADIOPHARM LINES WERE PACKAGED (SI=' N') AND THERAPEUTIC  *
      *   RADIOPHARM AND BRACHYTHERAPY LINES WERE SEPARATELY        *
      *   PAYABLE (SI=' K').  THEREFORE, PAID AT COST LOGIC WAS NOT *
      *   NEEDED.                                                   *
      *                                                             *
      * 12/06/2007 - LINE REIMBURSEMENT AND NATIONAL COINSURANCE    *
      *   CALCULATIONS, AND MINIMUM COINSURANCE MOVE INSERTED       *
      *   (TAKEN FROM 6550-PD-AT-CST-JAN07).                        *
      *                                                             *
      * 12/27/2007 - PAID AT COST LOGIC REINSTATED FOR RADIOPHARM   *
      *   AND BRACHYTHERAPY LINES WITH A STATUS INDICATOR = ' H'.   *
      *   PAID AT COST LOGIC REVISED: NO TABLE OR TABLE SEARCH;     *
      *   FLAGS ARE USED INSTEAD.  (REINSTATEMENT IS DUE TO A       *
      *   CHANGE IN LEGISLATION; ALL RADIO. & BRACHY SI = ' H'.)    *
      *                                                             *
      * 05/14/2008 - PAID AT COST LOGIC NO LONGER APPLIED TO        *
      *   RADIOPHARM AND BRACHYTHERAPY LINES AS OF JULY 1, 2008.    *
      *   THESE LINES ARE ASSIGNED A SI OF ' K' EFFECTIVE JULY 1,   *
      *   2008, SO THEY WILL AUTOMATICALLY BY-PASS THE LOGIC AND    *
      *   RECEIVE THE STANDARD REIM.  PAID AT COST LOGIC RETAINED   *
      *   FOR PREVIOUS QUARTERS (JANUARY 1 - JUNE 30, 2008).        *
      *                                                             *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *   BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H';   *
      *   THEY CONTINUE TO BE PAID AT COST (EFFECTIVE 7/1/2008)     *
      *                                                             *
      * 11/12/2008 - BRACHYTHERAPY SOURCE'S STATUS INDICATOR = ' U' *
      *              EFFECTIVE 1/1/2009                             *
      *                                                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * PAID AT COST LINE REIMBURSEMENT CALCULATION (REIM = 80%)    *
      * THERAPEUTIC RADIOPHARMACEUTICALS & BRACHYTHERAPY SOURCES    *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' H' AND
                 RADIOPH-APC-FLAG = 'Y') OR
                (OPPS-SRVC-IND (LN-SUB) = ' U' AND
                 OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 2')
                  COMPUTE H-LITEM-REIM ROUNDED =
                     ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                       H-LN-BLOOD-DEDUCT) * .8

      *-------------------------------------------------------------*
      * STANDARD LINE REIMBURSEMENT CALCULATION                     *
      *-------------------------------------------------------------*
             ELSE
                  COMPUTE H-LITEM-REIM ROUNDED =
                     ((H-LITEM-PYMT - H-TOTAL-LN-DEDUCT) -
                       H-LN-BLOOD-DEDUCT) * W-PPCT (W-LP-INDX)
             END-IF.


      ***************************************************************
      * CALCULATE NATIONAL COINSURANCE                              *
      *-------------------------------------------------------------*
      * 12/6/2007 - LOGIC ADDED (TAKEN FROM 6550-PD-AT-CST-JAN07)   *
      ***************************************************************
             COMPUTE H-NAT-COIN = H-LITEM-PYMT -
                H-TOTAL-LN-DEDUCT - H-LITEM-REIM - H-LN-BLOOD-DEDUCT.


      ***************************************************************
      * ADJUST MINIMUM COINSURANCE AMOUNT                           *
      * (REPLACES WHAT WAS IN THE APC TABLE IF > 0)                 *
      ***************************************************************
             MOVE W-MIN-COIN (W-LP-INDX) TO  H-MIN-COIN.
             IF H-MIN-COIN > 0

      *-------------------------------------------------------------*
      * DRUGS, DEVICES, BRACHYTHERAPY, THERAP. RADIO, & BLOOD       *
      * (SI = G AND H LINES HAVE A MIN-COIN = 0, WON'T ENTER LOGIC) *
      *-------------------------------------------------------------*
               IF OPPS-SRVC-IND (LN-SUB) =
                  ' G' OR ' H' OR ' K' OR ' R' OR ' U'
                  COMPUTE H-MIN-COIN ROUNDED =
                     H-MIN-COIN * (W-SRVC-UNITS (W-LP-INDX) -
                     (W-SRVC-UNITS (W-LP-INDX) * H-BLOOD-FRACTION)) *
                     W-DISC-RATE (W-LP-INDX)

      *-------------------------------------------------------------*
      * APCS 0158 & 0159'S MIN COINSURANCE = 25% OF LINE PMT        *
      *-------------------------------------------------------------*
               ELSE
                  IF OPPS-APC (LN-SUB) = '0158' OR '0159'
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .25

      *-------------------------------------------------------------*
      * OTHER SERVICE TYPES AND APCS' MIN COIN = 20% OF LINE PMT    *
      *-------------------------------------------------------------*
                  ELSE
                     COMPUTE H-MIN-COIN ROUNDED = H-LITEM-PYMT * .2
                  END-IF
               END-IF
             END-IF.


      ***************************************************************
      * ADJUST REDUCED COINSURANCE WHEN NECESSARY & ADJUST CLAIM    *
      * TOTAL LINE ITEM REIMBURSEMENT WHEN THE REDUCED AND/OR       *
      * NATIONAL COINSURANCE AMOUNTS EXCEED THE MAXIMUM COINSURANCE *
      * (PROVIDER MAY ELECT TO REDUCE COINSURANCE)                  *
      ***************************************************************
             MOVE W-RED-COIN (W-LP-INDX) TO H-RED-COIN.

             IF (H-RED-COIN  > 0 AND < H-MIN-COIN)
                MOVE H-MIN-COIN TO H-RED-COIN
             ELSE
                IF H-RED-COIN < H-NAT-COIN AND > H-MIN-COIN
                   AND > H-MAX-COIN
                   COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                          (H-RED-COIN - H-MAX-COIN)
                END-IF
             END-IF.

             IF H-NAT-COIN > H-MAX-COIN AND H-RED-COIN = 0 THEN
                COMPUTE H-LITEM-REIM = H-LITEM-REIM +
                                       (H-NAT-COIN - H-MAX-COIN)
                MOVE H-MAX-COIN TO H-NAT-COIN.

       8550-CALC-STANDARD-EXIT.
           EXIT.



      ***************************************************************
      *                                                             *
      * DELETED CODE:                                               *
      *   PAID AT COST WITH COINSURANCE TABLE SEARCH REMOVED        *
      *   11/1/2007 FOR CY 2008.  THERE IS NO NEW PAID AT COST      *
      *   TABLE FOR 2008.  PARAGRAPHS REMOVED:                      *
      *    - 7550-PD-AT-CST-JAN07,                                  *
      *    - 7550-PD-AT-CST-JAN07-EXIT,                             *
      *    - 7550-PD-AT-CST-JUL07,                                  *
      *    - 7550-PD-AT-CST-JUL07-EXIT.                             *
      *                                                             *
      ***************************************************************



      ***************************************************************
      *                                                             *
      *                  DEVICE REDUCTION PROCESSING                *
      *                                                             *
      ***************************************************************
      *                                                             *
      * SEARCH THE DEVICE REDUCTION TABLE TO SEE IF THERE IS AN APC *
      * MATCH; IF SO, REDUCE THE PYMT BY THE REDUCTION AMOUNT       *
      * BECAUSE THIS IS A FREE OR REPLACEMENT DEVICE -OR- A PARTIAL *
      * CREDIT DEVICE.                                              *
      *                                                             *
      *    * BE SURE TO UPDATE THE TABLE REFERENCES EACH YEAR *     *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/1/2007 - PARTIAL CREDIT DEVICE PROCESSING ADDED          *
      *             NEW FOR CY 2008                                 *
      *                                                             *
      ***************************************************************
       8550-DEVICE-REDUC.

           SEARCH ALL DEV-RED09
              AT END
                 GO TO 8550-DEVICE-REDUC-EXIT
              WHEN DEV-APC9 (DEV-INDX9) = OPPS-APC (LN-SUB)
                 PERFORM 8550-DEVICE-COMPUTE
                    THRU 8550-DEVICE-COMPUTE-EXIT.

       8550-DEVICE-REDUC-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * IF THE DEVICE IS FOUND, AND REDUCTION AMOUNT IS LESS THAN   *
      * PAYMENT AMOUNT, SUBTRACT REDUCTION AMOUNT FROM THE PAYMENT  *
      *                                                             *
      *    * BE SURE TO UPDATE THE TABLE REFERENCES EACH YEAR *     *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/1/2007 - PARTIAL CREDIT DEVICE PROCESSING ADDED          *
      *             NEW FOR CY 2008                                 *
      *                                                             *
      ***************************************************************
       8550-DEVICE-COMPUTE.

      *-------------------------------------------------------------*
      * PROCESS FULL DEVICE REDUCTION (PAF = 7)                     *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 7'
              IF W-APC-PYMT (W-LP-INDX) NUMERIC
                 IF W-APC-PYMT (W-LP-INDX) > DEV-REDUC9 (DEV-INDX9)
                    COMPUTE W-APC-PYMT (W-LP-INDX) =
                      (W-APC-PYMT (W-LP-INDX) - DEV-REDUC9 (DEV-INDX9)).

      *-------------------------------------------------------------*
      * PROCESS PARTIAL CREDIT DEVICE REDUCTION (PAF = 8)           *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 8'
              IF W-APC-PYMT (W-LP-INDX) NUMERIC
                 IF W-APC-PYMT (W-LP-INDX) >
                      (DEV-REDUC9 (DEV-INDX9) / 2)
                          COMPUTE W-APC-PYMT (W-LP-INDX) =
                            (W-APC-PYMT (W-LP-INDX) -
                              (DEV-REDUC9 (DEV-INDX9) / 2)).

       8550-DEVICE-COMPUTE-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE WAGE ADJUSTED LINE ITEM PAYMENT WITH RURAL     *
      *  SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN APPLICABLE   *
      *                                                             *
      *          FOR LINES WITH A SI OF S, V, T, P, X, OR R         *
      *                                                             *
      ***************************************************************
      *                                                             *
      * THE SCH ADJUSTMENT IS MADE WHEN THE FOLLOWING IS TRUE:      *
      *   EITHER THE L-PSF-GEO-CBSA OR THE L-PSF-WI-CBSA MUST BE A  *
      *   VALUE OF '   01' THRU '   99' AND THE L-PSF-PROV-TYPE     *
      *   MUST BE A '16' OR '17' OR '21' OR '22'.                   *
      *                                                             *
      * EACH YEAR, CHECK WHETHER THE SCH ADJUSTMENT HARDCODED BELOW *
      * HAS CHANGED.                                                *
      * CYS 2006 - 2009: SCH ADJ = 7.1% (1.071)                     *
      *                                                             *
      *                                                             *
      * 11/08/2007 - PROCESSING FOR BRACHY & BLOOD CODES WITH AN SI *
      *              = K ADDED FOR CY 2008                          *
      * 11/13/2007 - PROCESSING FOR BRACHY & BLOOD CODES REVISED.   *
      *              BLD-DEDUC-HCPCS-FLAG ADDED TO LOGIC.           *
      * 11/13/2007 - PARAGRAPH 7560-CALC-BENE-DEDUCT PERFORM        *
      *              DELETED & MOVED TO PAR. 7550-CALC-STANDARD     *
      * 05/14/2008 - BRACHYTHERAPY LINES PROCESSED IN THIS          *
      *              PARAGRAPH STARTING 7/1/2008 BECAUSE SI CHANGED *
      *              TO ' K' ON THIS DATE.                          *
      * 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS &  *
      *              BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K'     *
      *              BACK TO 'H' EFFECTIVE 7/1/2008; THESE LINES    *
      *              ARE NOT YET PROCESSED IN THIS PARAGRAPH        *
      * 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES (SI=R)     *
      *              ADDED TO LOGIC.  BRACHY LINES NOT PROCESSED IN *
      *              PARAGRAPH & NOW HAVE A SI = U, SI = K LOGIC    *
      *              REMOVED FROM THIS PARAGRAPH.                   *
      * 05/11/2009 - ADDED THE REQUIREMENT PAF = 5 OR 6 TO BLOOD    *
      *              DEDUCTIBLE LOGIC TO CORRECT PRICING ERROR.     *
      *              FIX EFFECTIVE RETROACTIVE TO 01/01/2009.       *
      *                                                             *
      ***************************************************************
       8550-SCH-ADJ.

             MOVE L-PSF-GEO-CBSA TO GEO-CBSA-FLAG.
             MOVE L-PSF-WI-CBSA  TO WI-CBSA-FLAG.

      ***************************************************************
      * CALCULATE THE SCH PAYMENT                                   *
      *   - FOR SCHS = APC OR BLOOD APC PAYMENT ADJUSTED BY 7.1%    *
      *   - FOR NON-SCHS = UNADJUSTED APC OR BLOOD APC PAYMENT      *
      ***************************************************************

             IF ((RURAL-GEO OR RURAL-WI) AND
                 (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22'))

      *-------------------------------------------------------------*
      * SCH, BLOOD DEDUCTIBLE HCPCS LINE                            *
      *-------------------------------------------------------------*
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-BD-APC-PYMT (W-BD-INDX) * 1.071)

      *-------------------------------------------------------------*
      * SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS               *
      *-------------------------------------------------------------*
                ELSE
                     COMPUTE H-SCH-PYMT ROUNDED =
                         (W-APC-PYMT (W-LP-INDX) * 1.071)
                END-IF

      *-------------------------------------------------------------*
      * NON-SCH, BLOOD DEDUCTIBLE HCPCS LINE                        *
      *-------------------------------------------------------------*
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                     MOVE W-BD-APC-PYMT (W-BD-INDX) TO H-SCH-PYMT

      *-------------------------------------------------------------*
      * NON-SCH, NOT A LINE WITH A BLOOD DEDUCTIBLE HCPCS           *
      *-------------------------------------------------------------*
                ELSE
                     MOVE W-APC-PYMT (W-LP-INDX) TO H-SCH-PYMT
                END-IF
             END-IF.


      ***************************************************************
      * CALCULATE THE LINE ITEM PAYMENT                             *
      ***************************************************************

      *-------------------------------------------------------------*
      * SI = R LINES (BLOOD) ARE NOT WAGE-ADJUSTED                  *
      *-------------------------------------------------------------*
             IF OPPS-SRVC-IND (LN-SUB) = ' R'
                IF BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-BD-SRVC-UNITS (W-BD-INDX) *
                             W-BD-DISC-RATE (W-BD-INDX)
                ELSE
                   COMPUTE H-LITEM-PYMT ROUNDED =
                             H-SCH-PYMT *
                             W-SRVC-UNITS (W-LP-INDX) *
                             W-DISC-RATE (W-LP-INDX)
                END-IF

      *-------------------------------------------------------------*
      * SI = S, V, T, P, OR X LINES ARE WAGE-ADJUSTED (60%)         *
      *-------------------------------------------------------------*
             ELSE
                COMPUTE H-LITEM-PYMT ROUNDED =
                          (((H-SCH-PYMT * .60) *
                               W-WINX1 (W-LP-INDX)) +
                            (H-SCH-PYMT * .40)) *
                          W-SRVC-UNITS (W-LP-INDX) *
                          W-DISC-RATE (W-LP-INDX)
             END-IF.


       8550-SCH-ADJ-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    CALCULATE WAGE ADJUSTED LINE ITEM PAYMENT WITH RURAL     *
      *  SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN APPLICABLE   *
      *                                                             *
      *         FOR PARTIAL HOSPITALIZATION (PHP) "CAP" APC         *
      *             FOR USE IN THE OUTLIER CALCULATION              *
      *                  (FOR SI = P LINES ONLY)                    *
      *                                                             *
      *       ** ASK POLICY FOR THE PHP "CAP" APC ANUALLY **        *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/13/2008 - THIS PARAGRAPH IS NEW FOR CY 2009,             *
      *              CY 2009 PHP "CAP" APC = 0173                   *
      *                                                             *
      ***************************************************************
       8550-PHP-PMT-FOR-OUTL.

      *-------------------------------------------------------------*
      *  LOOK-UP PHP "CAP" APC IN THE APC TABLE, STARTING AT        *
      *  THE APC'S MOST CURRENT RECORD - RETRIEVE PAYMENT RATE      *
      *-------------------------------------------------------------*
             SEARCH ALL WAA-ENTRY
                AT END
                   GO TO 8550-PHP-PMT-FOR-OUTL-EXIT

                WHEN WAA-APC (WAA-INDX) = '00173'
                   MOVE WAA-PTR (WAA-INDX) TO W-SUB2
                   PERFORM 8550-PHP-APC-LOOKUP.

      *-------------------------------------------------------------*
      * REDUCE APC PMT RATE BY REDUCED UPDATE RATIO WHEN APPROPRIATE*
      * 11/13/2009 - NEW FOR CY 2009                                *
      *-------------------------------------------------------------*
             PERFORM 8180-REDUCE-APC-PYMT
                THRU 8180-REDUCE-APC-PYMT-EXIT.

      *-------------------------------------------------------------*
      * APPLY THE SCH ADJUSTMENT TO APC RATE WHEN APPLICABLE        *
      * CY 2009 ADJ = 7.1%                                          *
      *-------------------------------------------------------------*
             IF ((RURAL-GEO OR RURAL-WI) AND
                 (L-PSF-PROV-TYPE = '16' OR '17' OR '21' OR '22'))
                     COMPUTE H-APC-PYMT ROUNDED =
                         (H-APC-PYMT * 1.071)
             END-IF.

      *-------------------------------------------------------------*
      *  CALCULATE THE PHP "CAP" APC'S LINE PAYMENT (INCLUDES       *
      *  WAGE ADJUSTMENT AND SCH ADJUSTMENT IF APPLICABLE)          *
      *-------------------------------------------------------------*
             COMPUTE H-PHP-LITEM-PYMT-OUTL ROUNDED =
                       (((H-APC-PYMT * .60) *
                            W-WINX1 (W-LP-INDX)) +
                         (H-APC-PYMT * .40)) *
                       W-SRVC-UNITS (W-LP-INDX) *
                       W-DISC-RATE (W-LP-INDX).

       8550-PHP-PMT-FOR-OUTL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *            LOOK-UP PHP "CAP" APC IN THE APC TABLE           *
      *                                                             *
      *-------------------------------------------------------------*
      *                                                             *
      * 11/13/2008 - THIS PARAGRAPH IS NEW FOR CY 2009              *
      *                                                             *
      ***************************************************************
       8550-PHP-APC-LOOKUP.

      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS BEFORE OR ON THE LATEST       *
      *  EFFECTIVE DATE THE CLAIM CAN USE (SEARCH STARTS AT THE     *
      *  MOST CURRENT RECORD FOR THE APC)                           *
      ***************************************************************
             IF WAR-DTCD (W-SUB2) NOT > WAD-DTCD (WAD-SUB)

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC DELETED - ERROR     *
      *-------------------------------------------------------------*
                IF WAR-RATEX (W-SUB2) = 'DELETED'
                   MOVE ZEROS TO H-APC-PYMT

      *-------------------------------------------------------------*
      *  APC RECORD EFFECTIVE DATE CORRECT, APC ACTIVE - ACCEPT REC *
      *-------------------------------------------------------------*
                ELSE
                   MOVE WAR-RATE (W-SUB2) TO H-APC-PYMT


      ***************************************************************
      *  APC RECORD EFFECTIVE DATE IS AFTER THE LATEST EFFECTIVE    *
      *  DATE THE CLAIM CAN USE.  GO TO THE PREVIOUS RECORD IN THE  *
      *  APC TABLE.                                                 *
      ***************************************************************
             ELSE
                   SUBTRACT 1 FROM W-SUB2

      *-------------------------------------------------------------*
      *  PREVIOUS REC BELONGS TO THE LINE APC, TEST EFFECTIVE DATE  *
      *-------------------------------------------------------------*
                   IF W-SUB2 > WAA-PTR (WAA-INDX - 1)
                      GO TO 8550-PHP-APC-LOOKUP

      *-------------------------------------------------------------*
      *  THERE IS NO RECORD FOR THE LINE APC WITH AN ACCEPTABLE     *
      *  EFFECTIVE DATE FOR THE LINE.  RETURN ZEROS.                *
      *-------------------------------------------------------------*
                   ELSE
                      MOVE 0 TO H-APC-PYMT.

       8550-PHP-APC-LOOKUP-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * CALCULATE THE FOLLOWING FOR VALID SI = G, K & R LINES:      *
      *   - APC PAYMENT FOR BLOOD LINES (SI = R)                    *
      *   - BLOOD SPECIFIC ITEMS FOR BLOOD LINES                    *
      *   - LINE ITEM PMT FOR ALL SI = G OR K LINES (DRUGS &        *
      *     BIOLOGICALS)                                            *
      *   - SCH ADJUSTMENT APPLIED TO ELIGIBLE BLOOD LINES          *
      *   - BLOOD DEDUCTIBLE FOR BLOOD DEDUCTIBLE HCPCS LINES       *
      *                                                             *
      ***************************************************************
      *                                                             *
      * - EFFECTIVE 01/01/2003, REMOVE PRO RATA REDUCTION FOR       *
      *   ALL SERVICE INDICATOR 'G' PAYMENTS.                       *
      * - 11/13/2007 - LINE ITEM PAYMENTS FOR BLOOD AND BRACHY      *
      *   LINES ARE CALCULATED IN PARAGRAPH 7550-SCH-ADJ TO APPLY   *
      *   THE SOLE COMMUNITY HOSPITAL (SCH) ADJUSTMENT WHEN         *
      *   APPLICABLE                                                *
      * - 12/31/2007 - BRACHYTHERAPY & RADIOPHARM LINES' STATUS     *
      *   INDICATOR CHANGED BACK TO 'H' TEMPORARILY; THESE LINES    *
      *   WILL NOT ENTER THIS PARAGRAPH NOR PARAGRAPH 7550-SCH-ADJ  *
      *   UNTIL THEIR STATUS INDICATOR IS CHANGED BACK TO 'K'       *
      * - 05/14/2008 - BRACHYTHERAPY & RADIOPHARM LINES' SI CHANGED *
      *   TO ' K' EFFECTIVE 7/1/2008.  THESE LINES ARE PROCESSED    *
      *   IN THIS PARAGRAPH STARTING 7/1/2008.                      *
      * - 08/07/2008 - DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS  *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET PROCESSED IN  *
      *   THIS PARAGRAPH.                                           *
      * - 11/12/2008 - FOR CY 2009, BRACHYS NOT PROCESSED IN THIS   *
      *   PARAGRAPH; BRACHY LINES ASSIGNED A NEW SI OF ' U'         *
      * - 11/13/2008 - FOR CY 2009, BLOOD DEDUCTIBLE LINES HAVE A   *
      *   SI = R                                                    *
      * - 12/05/2008 - MODIFIED LOGIC TO SEND BLOOD LINES WITHOUT   *
      *   A PMT ADJ FLAG = 5 OR 6 TO THE SCH ADJUSTMENT PARAGRAPH,  *
      *   INCLUDED SI = R IN THE BLOOD IDENTIFICATION LOGIC         *
      *                                                             *
      ***************************************************************
       8550-CALC-GJK.

      ***************************************************************
      *                                                             *
      *  CALCULATE LINE ITEM PAYMENT & BLOOD DEDUCTIBLE FOR BLOOD   *
      *   LINE WITH A HCPCS SUBJECT TO THE BLOOD DEDUCTIBLE (BD)    *
      *                                                             *
      * (BLOOD DEDUCTIBLE LINES ARE PROCESSED IN THE ORDER THEY     *
      *  APPEAR IN THE BLOOD DEDUCTIBLE TABLE - EARLIEST TO LATEST  *
      *  DATE, LEAST TO MOST EXPENSIVE PAYMENT RATE.  THE CURRENT   *
      *  COINSURANCE DEDUCTIBLE TABLE LINE BEING PROCESSED DOES NOT *
      *  NECESSARILY CORRESPOND TO THE BLOOD DEDUCTIBLE LINE        *
      *  PROCESSED IN THE LOGIC BELOW.)                             *
      *                                                             *
      ***************************************************************
             IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                BLD-DEDUC-HCPCS-FLAG = 'Y' AND
                OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * CALCULATE BLOOD FRACTION & BLOOD PINTS USED                 *
      *-------------------------------------------------------------*
                  PERFORM 8550-SET-BLOOD-FRACTION
                     THRU 8550-SET-BLOOD-FRACTION-EXIT

      *-------------------------------------------------------------*
      * ADJUST BLOOD APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE     *
      *-------------------------------------------------------------*
                  PERFORM 8550-ADJ-BLOOD-COST
                     THRU 8550-ADJ-BLOOD-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                  PERFORM 8550-SCH-ADJ
                     THRU 8550-SCH-ADJ-EXIT

      *-------------------------------------------------------------*
      * CALCULATE BLOOD DEDUCTIBLE (BD) - H-BLOOD-FRACTION IS THE   *
      * FRACTION OF THE CURRENT LINE'S PINTS COVERED BY THE BD      *
      *-------------------------------------------------------------*
                  COMPUTE H-LN-BLOOD-DEDUCT ROUNDED =
                      H-LITEM-PYMT * H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * POINT TO NEXT BLOOD DEDUCTIBLE RECORD FOR NEXT BD LINE      *
      *-------------------------------------------------------------*
                  SET W-BD-INDX UP BY 1


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE, BUT PAF = 5 OR 6           *
      * (BLOOD PROCESSING AND PRODUCT BILLED TOGETHER)              *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R' AND
                   OPPS-PYMT-ADJ-FLAG (LN-SUB) = (' 5' OR ' 6')

      *-------------------------------------------------------------*
      * ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE           *
      *-------------------------------------------------------------*
      * 11/13/2007 - LINE ITEM PMT NO LONGER CALCULATED IN          *
      *              7550-ADJ-PLATE-COST, BUT IN 7550-SCH-ADJ       *
      *-------------------------------------------------------------*
                   PERFORM 8550-ADJ-PLATE-COST
                      THRU 8550-ADJ-PLATE-COST-EXIT

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 11/14/2007 - 7550-SCH-ADJ PERFORM ADDED; LINE ITEM PAYMENT  *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 8550-SCH-ADJ
                      THRU 8550-SCH-ADJ-EXIT


      ***************************************************************
      *                                                             *
      * CALCULATE LINE ITEM PAYMENT FOR BLOOD LINE WITH A HCPCS NOT *
      * SUBJECT TO THE BLOOD DEDUCTIBLE AND PAF NOT EQUAL TO 5 OR 6 *
      * (ONLY BLOOD PRODUCT BILLED)                                 *
      *                                                             *
      ***************************************************************
             ELSE
                IF OPPS-SRVC-IND (LN-SUB) = ' R'

      *-------------------------------------------------------------*
      * CALCULATE LINE ITEM PAYMENT W/ SCH ADJUSTMENT IF APPLICABLE *
      *-------------------------------------------------------------*
      * 12/05/2008 - 7550-SCH-ADJ PERFORM ADDED FOR BLOOD LINES     *
      *              CALCULATION REMOVED FROM THIS SECTION          *
      *-------------------------------------------------------------*
                   PERFORM 8550-SCH-ADJ
                      THRU 8550-SCH-ADJ-EXIT


      ***************************************************************
      *                                                             *
      *    CALCULATE LINE ITEM PAYMENT FOR DRUGS AND BIOLOGICALS    *
      *                                                             *
      ***************************************************************
                ELSE
                   IF OPPS-SRVC-IND (LN-SUB) = ' G' OR ' K'

                      COMPUTE H-LITEM-PYMT ROUNDED =
                       W-APC-PYMT (W-LP-INDX) * W-SRVC-UNITS (W-LP-INDX)
                        * W-DISC-RATE (W-LP-INDX)

                   END-IF
                END-IF
             END-IF
             END-IF.

       8550-CALC-GJK-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *   DETERMINE THE FRACTION OF THE BLOOD LINE'S PAYMENT THAT   *
      *  WILL BE COVERED BY THE THE BENEFICIARY'S BLOOD DEDUCTIBLE  *
      *     FOR LINES WITH A HCPCS IN THE BLOOD DEDUCTIBLE LIST     *
      *                                                             *
      *    THE BENEFICIARY PAYS A BLOOD DEDUCTIBLE FOR THE FIRST    *
      *    3 CHEAPEST BLOOD PINTS.  MEDICARE COVERS ANY ADDITIONAL  *
      *    PINTS USED BY THE BENEFICIARY.                           *
      *                                                             *
      ***************************************************************
       8550-SET-BLOOD-FRACTION.

      *-------------------------------------------------------------*
      * NAVIGATE TO SERVICE LINE ASSOCIATED WITH THE BLOOD ENTRY    *
      *-------------------------------------------------------------*
             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * BLOOD/BLOOD PRODUCT LINE                                    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                IF H-BENE-PINTS-USED > 0

      *-------------------------------------------------------------*
      * BENEFICIARY HAS ENOUGH PINTS TO COVER ALL BLOOD LINE UNITS  *
      *  - BLOOD DEDUCTIBLE WILL COVER THE ENTIRE PYMNT (FRAC. = 1) *
      *  - CALCULATE THE NUMBER OF DEDUCTIBLE PINTS BENE HAS LEFT   *
      *-------------------------------------------------------------*
                   IF W-BD-SRVC-UNITS (W-BD-INDX) <= H-BENE-PINTS-USED
                      MOVE 1 TO H-BLOOD-FRACTION
                      COMPUTE H-BENE-PINTS-USED =
                         H-BENE-PINTS-USED - W-BD-SRVC-UNITS (W-BD-INDX)

      *-------------------------------------------------------------*
      * BENE. DOESN'T HAVE ENOUGH PINTS TO COVER ENTIRE BLOOD LINE  *
      *   - BLOOD DEDUCTIBLE WILL COVER A FRACTION OF THE PAYMENT   *
      *     (ACCORDING TO THE % OF PINTS COVERED)                   *
      *   - BENEFICIARY HAS NO DEDUCTIBLE PINTS LEFT (PINTS = 0)    *
      *-------------------------------------------------------------*
                   ELSE
                     IF W-BD-SRVC-UNITS (W-BD-INDX) > H-BENE-PINTS-USED
                        COMPUTE H-BLOOD-FRACTION =
                         H-BENE-PINTS-USED / W-BD-SRVC-UNITS (W-BD-INDX)
                        MOVE 0 TO H-BENE-PINTS-USED
                     ELSE
                        MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NO BLOOD DEDUCTIBLE PINTS LEFT              *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
                ELSE
                   MOVE 0 TO H-BLOOD-FRACTION

      *-------------------------------------------------------------*
      * BLOOD PROCESS/STORAGE LINE (PAF = 6)                        *
      * THERE IS NO BLOOD DEDUCTIBLE                                *
      *-------------------------------------------------------------*
             ELSE
                MOVE 0 TO H-BLOOD-FRACTION.

       8550-SET-BLOOD-FRACTION-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR LINES WITH A HCPCS    *
      *                IN THE BLOOD DEDUCTIBLE LIST                 *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
       8550-ADJ-BLOOD-COST.

             MOVE W-BD-SUB (W-BD-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
                COMPUTE W-BD-APC-PYMT (W-BD-INDX) =
                  W-BD-APC-PYMT (W-BD-INDX) * (1 - H-38X-39X-RATE).

       8550-ADJ-BLOOD-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *    ADJUST APC PAYMENT BY BLOOD PRODUCT OR LABOR RATE TO     *
      *   CALCULATE THE BLOOD APC PAYMENT FOR BLOOD LINES WITH A    *
      *           HCPCS NOT IN THE BLOOD DEDUCTIBLE LIST            *
      *                                                             *
      *    THE RATE OF BLOOD TO BLOOD LABOR IS THE CLAIM AVERAGE.   *
      *    THE BLOOD LINE IS PAID ONLY THE PORTION OF THE APC       *
      *    PAYMENT THAT IS INDICATED BY THE PYMNT ADJUSTMENT FLAG.  *
      *                                                             *
      ***************************************************************
      *                                                             *
      *    11/13/2007 - REMOVED LINE ITEM PAYMENT CALCULATION FROM  *
      *                 THIS PARAGRAPH, NOW PERFORMED IN            *
      *                 7550-SCH-ADJ (CALLED FROM 7550-CALC-GJK)    *
      *                                                             *
      ***************************************************************
       8550-ADJ-PLATE-COST.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD/BLOOD PRODUCT LINE    *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 5'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * H-38X-39X-RATE.

      *-------------------------------------------------------------*
      * CALCULATE BLOOD APC PAYMENT FOR BLOOD PROCESS/STORAGE LINE  *
      *-------------------------------------------------------------*
           IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 6'
              COMPUTE W-APC-PYMT (W-LP-INDX) =
                W-APC-PYMT (W-LP-INDX) * (1 - H-38X-39X-RATE).

       8550-ADJ-PLATE-COST-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      ADJUST THE PASS-THROUGH RADIOPHARM PAYMENT BY          *
      *      ITS PROPORTION OF THE NUCLEAR MEDICINE OFFSET          *
      *                                                             *
      *      EFFECTIVE 04/01/2009, LOGIC ADDED 02/11/2009           *
      *                                                             *
      ***************************************************************
       8550-PTRADIO-OFFSET.

      *-------------------------------------------------------------*
      * CALCULATE PROPORTION OF TOTAL OFFSET TO BE APPLIED TO LINE  *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.
             COMPUTE W-PTRADIO-CHRG-RATE ROUNDED =
                     H-SUB-CHRG / H-PTRADIO-TOT-CHRGS.

      *-------------------------------------------------------------*
      * CALCULATE THE OFFSET AMOUNT TO BE APPLIED TO LINE           *
      *-------------------------------------------------------------*
             COMPUTE W-PTRADIO-LINE-OFFSET ROUNDED =
                     H-NUCMED-TOT-OFFSET * W-PTRADIO-CHRG-RATE.

      *-------------------------------------------------------------*
      * SUBTRACT THE APPLICABLE OFFSET FROM THE LINE PAYMENT        *
      *-------------------------------------------------------------*
             COMPUTE H-LITEM-PYMT ROUNDED =
                     H-LITEM-PYMT - W-PTRADIO-LINE-OFFSET.

       8550-PTRADIO-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *      ACCUMULATE TOTAL CLAIM CHARGES FROM DEVICE LINES       *
      *                                                             *
      *  EFFECTIVE 04/01/2002 A PRO RATA REDUCTION APPLIES TO ALL   *
      *  ALL SERVICE INDICATOR 'H' PAYMENTS (CURRENTLY .689)        *
      *                                                             *
      *  SERVICE INDICATOR OF 'H' = PASS-THROUGH DEVICES,           *
      *                             THERAPEUTIC RADIOPHARMS         *
      *                                                             *
      ***************************************************************
       8555-CALC-H-TOT.

      *-------------------------------------------------------------*
      * SET THE SERVICE LINE SUBSCRIPT TO THE CLAIM SERVICE LINE    *
      * ASSOCIATED WITH THE COINSURANCE DEDUCTIBLE TABLE RECORD     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM DEVICE CHARGES FOR DEVICE LINES      *
      *-------------------------------------------------------------*
      * 11/13/2008 - MODIFIED LOGIC TO PROCESS DEVICE LINES ONLY    *
      *              (EXCLUDE THERAPEUTIC RADIOPHARMS)              *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

             IF OPPS-SRVC-IND (LN-SUB) = ' H' AND
                OPPS-PYMT-IND (LN-SUB) = ' 6' AND
                RADIOPH-APC-FLAG = 'N'
                  COMPUTE H-TOT-H-CHRG =
                     (H-TOT-H-CHRG + H-SUB-CHRG)
             END-IF.

       8555-CALC-H-TOT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *           CALCULATE PAYMENT FOR PAID AT COST LINES          *
      *          (PAYMENT BASED ON CHARGE ADJUSTED TO COST)         *
      *              UPDATE PASS-THROUGH DEVICE TABLE               *
      *                                                             *
      ***************************************************************
       8555-CALC-H-STANDARD.

      *-------------------------------------------------------------*
      * SET LINE ITEM PAYMENT TO LINE COST                          *
      *-------------------------------------------------------------*
             MOVE OPPS-SUB-CHRG (LN-SUB) TO H-SUB-CHRG.

             COMPUTE T-LITEM-PYMT ROUNDED =
               (H-SUB-CHRG * L-PSF-OPCOST-RATIO).


      *-------------------------------------------------------------*
      * WAGE ADJUST 60% OF THE CLAIM TOTAL DEVICE OFFSET AMOUNT     *
      * (OFFSET AMOUNTS ARE COSTS, NOT CHARGES)                     *
      * (C-FLAG = Y MEANS THERE IS A DEVICE ON THE CLAIM)           *
      *-------------------------------------------------------------*
      * 11/13/2008 - MODIFIED LOGIC TO PROCESS DEVICES ONLY         *
      *              (EXCLUDE BRACHYS & THERAPEUTIC RADIOPHARMS)    *
      *-------------------------------------------------------------*
              IF C-FLAG = 'Y' AND
                 OPPS-SRVC-IND (LN-SUB) = ' H' AND
                 RADIOPH-APC-FLAG = 'N'

      *-------------------------------------------------------------*
      * OTHER LINES ON THE CLAIM BESIDES DEVICE LINES ARE OFFSET;   *
      * CALCULATE DEVICE PORTION OF THE TOTAL WAGE ADJUSTED OFFSET  *
      *-------------------------------------------------------------*
                 IF (H-TOT-OFF-UNITS > H-TOT-HTD-UNITS)
                      COMPUTE H-TOTAL-WAOFF ROUNDED =
                         (((H-TOTAL-OFFSET * .60) * A-WINX) +
                          (H-TOTAL-OFFSET * .40)) *
                         (H-TOT-HTD-UNITS / H-TOT-OFF-UNITS)
                      PERFORM 8700-CALC-H-OFFSET
                         THRU 8700-CALC-H-OFFSET-EXIT
                 ELSE

      *-------------------------------------------------------------*
      * ONLY DEVICE LINES ON THE CLAIM ARE OFFSET;                  *
      * WAGE ADJUST THE TOTAL CLAIM OFFSET AMOUNT                   *
      *-------------------------------------------------------------*
                      COMPUTE H-TOTAL-WAOFF ROUNDED =
                         ((H-TOTAL-OFFSET * .60) * A-WINX) +
                         (H-TOTAL-OFFSET * .40)
                      PERFORM 8700-CALC-H-OFFSET
                         THRU 8700-CALC-H-OFFSET-EXIT

      *-------------------------------------------------------------*
      * THERE IS NO DEVICE ON THE CLAIM                             *
      *-------------------------------------------------------------*
              ELSE
                 NEXT SENTENCE.

                IF T-LITEM-PYMT < 0 THEN
                   MOVE 0 TO H-LITEM-PYMT
                ELSE
                   MOVE T-LITEM-PYMT TO H-LITEM-PYMT.

      *-------------------------------------------------------------*
      * UPDATE PASS-THROUGH DEVICE TABLE WITH LINE ITEM PAYMENT OF  *
      * DEVICE LINE (CHARGES CONVERTED TO COST LESS APPLICABLE      *
      * OFFSET AMOUNT)                                              *
      * WHEN PTD-FLAG = 'Y', A PASS-THROUGH DEVICE IS ON THE CLAIM  *
      *-------------------------------------------------------------*
             IF PTD-FLAG = 'Y' AND
                OPPS-SRVC-IND (LN-SUB) = ' H' AND
                RADIOPH-APC-FLAG = 'N'
                  PERFORM 8557-LOAD-PTD-LINE-PYMT
                     THRU 8557-LOAD-PTD-LINE-PYMT-EXIT
             END-IF.

       8555-CALC-H-STANDARD-EXIT.
             EXIT.


      ***************************************************************
      *                                                             *
      *  UPDATE PASS-THROUGH DEVICE TABLE WITH CHARGES FOR THE      *
      *  DEVICE LINE (LINE ITEM PAYMENT LESS OFFSET CONVERTED TO    *
      *  CHARGES)                                                   *
      *                                                             *
      ***************************************************************
       8557-LOAD-PTD-LINE-PYMT.

      *-------------------------------------------------------------*
      * SEARCH PTD TABLE STARTING AT ENTRY #1 FOR THE RECORD THAT   *
      * CORRESPONDS TO THE CURRENT SERVICE LINE                     *
      *-------------------------------------------------------------*
             SET W-PTD-INDX TO 1.
             SEARCH W-PTD-ENTRY VARYING W-PTD-INDX

      *-------------------------------------------------------------*
      * IF THE SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS NOT        *
      * ALREADY IN THE TABLE, ADD IT                                *
      *-------------------------------------------------------------*
                AT END
                   GO TO 8557-LOAD-PTD-LINE-PYMT-EXIT

      *-------------------------------------------------------------*
      * IF THE LINE'S HCPCS IS IN THE TABLE, CALCULATE THE LINE'S   *
      * CHARGES AND PLACE INTO TABLE (FOR H LINES, THE PAYMENT IS   *
      * CONVERTED TO COST AND OFFSET.  HERE, THE PAYMENT IS         *
      * CONVERTED BACK INTO CHARGES BY DIVIDING IT BY THE COST TO   *
      * CHARGE RATIO.)                                              *
      *-------------------------------------------------------------*
                WHEN  W-PTD-SUB (W-PTD-INDX) = LN-SUB
                      MOVE H-LITEM-PYMT TO W-PTD-LITEM-PYMT (W-PTD-INDX)

             END-SEARCH.

       8557-LOAD-PTD-LINE-PYMT-EXIT.
            EXIT.


      ***************************************************************
      *                                                             *
      *  CALCULATE THE BENEFICIARY DEDUCTIBLE AMOUNT THAT WILL BE   *
      *    APPLIED TO THE SERVICE LINES IN THE DEDUCTIBLE TABLE     *
      *                                                             *
      * (THE DEDUCTIBLE IS APPLIED TO THE LOWEST TO HIGHEST RANKED  *
      *  APCS.  THE LOWER THE RANK, THE HIGHER THE COINSURANCE %.   *
      *  THE TOTAL CLAIM BENEFICIARY COINSURANCE AMOUNT IS CHEAPER  *
      *  WHEN THE DEDUCTIBLE IS APPLIED IN THIS ORDER.)             *
      *                                                             *
      ***************************************************************
       8560-CALC-BENE-DEDUCT.

      *-------------------------------------------------------------*
      * LINES INELIGIBLE FOR DEDUCTIBLE SKIP DEDUCTIBLE CALCULATION *
      * EFF. 7/1/2009 - CLINICAL TRIAL LINES FOR MANAGED CARE BENES *
      * ASSIGNED A PAF = ' 4'                                       *
      *-------------------------------------------------------------*
             IF OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 4'
                GO TO 8560-CALC-BENE-DEDUCT-EXIT.

      *-------------------------------------------------------------*
      * BENEFICIARY HAS NOT MET HIS/HER DEDUCTIBLE LIMIT.           *
      * CALCULATE THE "LINE BLOOD PAYMENT"                          *
      *-------------------------------------------------------------*
             IF H-BENE-DEDUCT > 0 THEN
                COMPUTE H-LN-BLD-PYMT =
                        H-LITEM-PYMT - H-LN-BLOOD-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE DOES NOT COVER OR JUST COVERS THE  *
      * ENTIRE LINE BLOOD PAYMENT:                                  *
      * - BENEFICIARY'S REMAINING DEDUCTIBLE AMT APPLIED TO LINE    *
      * - BENEFICIARY HAS REACHED HIS/HER DEDUCTIBLE LIMIT          *
      *-------------------------------------------------------------*
               IF H-BENE-DEDUCT <= H-LN-BLD-PYMT THEN
                 MOVE H-BENE-DEDUCT TO H-TOTAL-LN-DEDUCT
                 MOVE 0 TO H-BENE-DEDUCT

      *-------------------------------------------------------------*
      * BENEFICIARY'S DEDUCTIBLE MORE THAN COVERS THE LINE BLOOD    *
      * PAYMENT, DO THE FOLLOWING:                                  *
      * - CALCULATE THE BENEFICIARY'S REMAINING DEDUCTIBLE AMOUNT   *
      *   AFTER PAYING FOR CURRENT SERVICE LINE                     *
      * - MEDICARE LINE PAYMENT = 0                                 *
      *-------------------------------------------------------------*
               ELSE
                  COMPUTE H-BENE-DEDUCT =
                          H-BENE-DEDUCT - H-LN-BLD-PYMT
                  MOVE H-LN-BLD-PYMT TO H-TOTAL-LN-DEDUCT
                  MOVE  20  TO A-RETURN-CODE (LN-SUB)
               END-IF
             END-IF.

       8560-CALC-BENE-DEDUCT-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  CALCULATE OUTLIER PAYMENT                  *
      *  ** CHANGE OUTLIER THRESHOLD EVERY JANUARY (HARD-CODED) **  *
      *                                                             *
      ***************************************************************
      *                                                             *
      * LOOP THROUGH THE COINSURANCE DEDUCTIBLE TABLE TO DO THE     *
      * FOLLOWING FOR EACH SERVICE LINE:                            *
      *                                                             *
      * - DETERMINE IF THE LINE IS ELIGIBLE FOR AN OUTLIER PAYMENT  *
      * - ADJUST CHARGES FOR LINES WITH ARTIFICIAL CHARGES ON CLAIM *
      * - DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO NON-      *
      *   PACKAGED PAYABLE LINES                                    *
      * - ADJUST CHARGES OF PRIME CODE COMPOSITE APC LINES          *
      * - ADJUST CHARGES OF MENTAL HEALTH LINES (APC = 34)          *
      * - CALCULATE THE LINE OUTLIER PAYMENT FOR ELIGIBLE LINES     *
      *                                                             *
      *                                                             *
      * NOTES:                                                      *
      * ------                                                      *
      * - NEW FOR JANUARY 2004:                                     *
      *   - CHECK >= 20040101 AND SRVC-IND = 'K'                    *
      *      - DISCONTINUE OUTLIER PROCESS                          *
      *                                                             *
      * - NEW FOR JANUARY 2008:                                     *
      *   - REVISED LOGIC FOR DETERMINING WHICH LINES WITH SRVC-IND *
      *     = 'K' ARE ELIGIBLE FOR AN OUTLIER PAYMENT.  THIS WAS    *
      *     NECESSARY B/C SOME RADIOPHARMS & ALL BRACHYTHERAPIES    *
      *     SRVC-IND = 'K' STARTING CY 2008.                        *
      *   - PER LEGISLATION, BRACHYTHERAPY & RADIOPARM LINES'       *
      *     STATUS INDICATOR CHANGED BACK TO ' H' FOR CY 2008 QTR 1 *
      *     ' K' LOGIC RETAINED B/C IT WILL NOT AFFECT PAYMENTS TO  *
      *     BRACHYTHERAPY OR RADIOPHARM LINES                       *
      *   - COMPOSITE APC AND MENTAL HEALTH LINE CHARGE CALCS       *
      *                                                             *
      * - NEW FOR APRIL 2008: ADD CHARGES AND PAYMENTS OF           *
      *   - PASS-THROUGH DEVICES TO THE CHARGES AND PAYMENTS OF     *
      *     PROCEDURES ELIGIBLE FOR THE DEVICES                     *
      *   - A-LITEM-PYMT MOVED TO H-LITEM-PYMT-OUTL B/C PAYMENTS    *
      *     ARE ADJUSTED FOR PASS-THROUGH DEVICES FOR OUTLIER       *
      *     DETERMINATION ONLY                                      *
      *                                                             *
      * - NEW FOR JULY 2008: BRACHYTHERAPY AND THERAPEUTIC          *
      *   RADIOPHARM LINES' SI CHANGED TO ' K'.  BRACHYTHERAPY      *
      *   LINES ARE NOW ELIGIBLE FOR AN OUTLIER PAYMENT.            *
      *                                                             *
      * - JULY 2008: DUE TO LEGISLATION, THERAPEUTIC RADIOPHARMS    *
      *   & BRACHYTHERAPY SOURCE'S SI CHANGED FROM 'K' BACK TO 'H'  *
      *   EFFECTIVE 7/1/2008; THESE LINES ARE NOT YET ELIGIBLE FOR  *
      *   AN OUTLIER PAYMENT.                                       *
      *                                                             *
      * - 11/12/2008: FOR CY 2009, BRACHYS SI = U AND BLOOD SI = R  *
      *   BRACHY INELIGIBLE FOR OUTLIER, BLOOD ELIGIBLE FOR OUTLIER *
      *                                                             *
      * - 12/05/2008: ADDED SI = K TO LIST OF SIS INELIGIBLE FOR    *
      *   OUTLIER (BRACHYS & BLOOD NO LONGER HAVE SI = K)           *
      *                                                             *
      ***************************************************************
       8600-ADJ-CHRG-OUTL.

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE ASSOCIATED WITH THE CURRENT COINSURANCE  *
      * DEDUCTIBLE TABLE RECORD                                     *
      *-------------------------------------------------------------*
             MOVE W-LP-SUB (W-LP-INDX) TO LN-SUB.


      *-------------------------------------------------------------*
      * LINES WITH SERVICE INDICATORS NOT ELIGIBLE FOR AN OUTLIER   *
      * PAYMENT AND LINES PACKAGED AS PART OF DRUG ADMINISTRATION   *
      * APC PAYMENT BYPASS OUTLIER CALCULATION                      *
      * (DRUGS, DEVICES, PACKAGED SERVICES, BRACHYS, BIOLOGICALS)   *
      *-------------------------------------------------------------*
      * 11/12/2008 - BRACHY (SI=U) ADDED TO LIST                    *
      * 12/05/2008 - SI K ADDED TO THE LIST                         *
      *-------------------------------------------------------------*
             IF (OPPS-SRVC-IND (LN-SUB) = ' G' OR ' H' OR ' N' OR
                                          ' K') OR
                (OPPS-SRVC-IND (LN-SUB) = ' U' AND
                 OPPS-PYMT-ADJ-FLAG (LN-SUB) = ' 2') OR
                (OPPS-PKG-FLAG (LN-SUB) = '4')
                   GO TO 8600-ADJ-CHRG-OUTL-EXIT.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PROCEDURE CHARGES TO PROCEDURE LINES *
      * IN PROPORTION TO THE PROCEDURE LINES' PAYMENTS WHEN THERE   *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES REPLACE BILLED CHARGES)                *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
             IF (ST0-FLAG = 'Y') AND

                ((OPPS-SRVC-IND (LN-SUB)  = ' T') OR

                 ((OPPS-SRVC-IND (LN-SUB) = ' S') AND
                   (OPPS-HCPCS (LN-SUB) > '09999' AND
                    OPPS-HCPCS (LN-SUB) < '70000'))) AND

                (H-TOT-ST-PYMT > 0)

                  COMPUTE H-CHRG-RATE ROUNDED =
                      (A-LITEM-PYMT (LN-SUB) / H-TOT-ST-PYMT)

                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                      (H-CHRG-RATE * H-TOT-ST-CHRG)


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE NO ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM. *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
             ELSE
               IF (N-FLAG = 'Y' AND ST0-FLAG = 'N') AND

                  ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                             ' X' OR ' P') AND
                   (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                  (H-TOT-STVX-PYMT > 0)

                    COMPUTE H-CHRG-RATE ROUNDED =
                        (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                    COMPUTE H-SUB-CHRG ROUNDED =
                        (H-CHRG-RATE * H-TOT-N-CHRG)

                    COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                        W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      *-------------------------------------------------------------*
      * DISTRIBUTE TOTAL CLAIM PACKAGED LINE CHARGES TO SEPARATELY  *
      * PAYABLE LINES IN PROPORTION TO THEIR PAYMENTS WHEN THERE    *
      * ARE ARTIFICIAL PROCEDURE CHARGES (< $1.01) ON THE CLAIM.    *
      * (DISTRIBUTED CHARGES ARE ADDED TO THE BILLED CHARGES)       *
      *-------------------------------------------------------------*
      * NOTE: LINES WITH CHARGES < $1.01 ARE FIXED BY FISS BEFORE   *
      *       ENTERING THE PRICER.  THEREFORE, THIS LOGIC IS NO     *
      *       LONGER NECESSARY.  THIS LOGIC WAS NECESSARY BEFORE    *
      *       FISS IMPLEMENTED THE FIX.                             *
      *-------------------------------------------------------------*
              IF (N-FLAG = 'Y' AND ST0-FLAG = 'Y') AND

                 ((OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR
                                            ' X' OR ' P') AND
                  (OPPS-PKG-FLAG (LN-SUB) = '0' OR '3')) AND

                 (H-TOT-STVX-PYMT > 0)

                   COMPUTE H-CHRG-RATE ROUNDED =
                       (A-LITEM-PYMT (LN-SUB) / H-TOT-STVX-PYMT)

                   COMPUTE H-SUB-CHRG ROUNDED =
                       (H-CHRG-RATE * H-TOT-N-CHRG)

                   COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                       W-SUB-CHRG (W-LP-INDX) + H-SUB-CHRG.


      ***************************************************************
      *    CALCULATE COMPOSITE APC CHARGES FOR PRIME CODE LINES     *
      *                                                             *
      * THE CHARGES OF ALL PACKAGED LINES WITH A COMPOSITE ADJ.     *
      * FLAG THAT INDICATES THE LINE IS A PART OF A COMPOSITE APC   *
      * (VALUES 01 - NN...) ARE ACCUMULATED BY COMPOSITE            *
      * ADJUSTMENT FLAG AND ADDED TO THE CORRESPONDING PRIME        *
      * (PAYABLE) LINE'S CHARGES.                                   *
      *-------------------------------------------------------------*
      * 11/29/2007 - LOGIC ADDED FOR CY 2008                        *
      * 12/14/2007 - ROUNDED W-SUB-CHRG WHEN ADDING COMPOSITES      *
      * 11/12/2008 - CHANGED LOGIC TO USE THE COMPOSITE ADJUSTMENT  *
      *              FLAG INSTEAD OF THE PAYMENT ADJUSTMENT FLAG    *
      *              VALUES 91 - 99 TO ID PRIME COMPOSITE LINES     *
      ***************************************************************

      *-------------------------------------------------------------*
      * COMPOSITE ADJUSTMENT FLAG > 0 INDICATES COMPOSITE APC       *
      *-------------------------------------------------------------*
           IF OPPS-COMP-ADJ-FLAG (LN-SUB) NOT = '00'

      *-------------------------------------------------------------*
      * SEARCH COMPOSITE APC TABLE STARTING AT ENTRY #1             *
      *-------------------------------------------------------------*
              MOVE OPPS-COMP-ADJ-FLAG (LN-SUB) TO H-CMP-CAF
              SET W-CMP-INDX TO 1
              SEARCH W-CMP-ENTRY VARYING W-CMP-INDX

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG NOT IN TABLE         *
      *-------------------------------------------------------------*
               AT END
                  ADD 0 TO W-SUB-CHRG (W-LP-INDX)

      *-------------------------------------------------------------*
      * SERVICE LINE'S PAYMENT ADJUSTMENT FLAG IS IN TABLE,         *
      * ADD THE PACKAGED SUBMITTED CHARGES TO THE LINE'S CHARGES    *
      *-------------------------------------------------------------*
               WHEN W-CMP-PAF (W-CMP-INDX) = H-CMP-CAF
                  COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                          W-SUB-CHRG (W-LP-INDX) +
                          W-CMP-TOT-SUB-CHRG (W-CMP-INDX)
           END-IF.


      ***************************************************************
      *   CALCULATE TOTAL MENTAL HEALTH CHARGES FOR APC 34 LINES    *
      *                                                             *
      * THE CHARGES OF PACKAGED LINES WITH A PACKAGING FLAG OF '2'  *
      * ON A CLAIM WITH APC 34 (MENTAL HEALTH APC) ARE ACCUMULATED  *
      * AND ADDED TO THE SEPARATELY PAYABLE APC 34 LINE'S CHARGES.  *
      *-------------------------------------------------------------*
      * 11/29/2007 - LOGIC ADDED FOR CY 2008                        *
      * 11/12/2008 - LOGIC DISABLED FOR CY 2009 BECAUSE MENTAL      *
      *              HEALTH COMPOSITES ARE NOW PROCESSED THE SAME   *
      *              AS ALL OTHER COMPOSITES USING THE COMPOSITE    *
      *              ADJUSTMENT FLAG                                *
      ***************************************************************
      *    IF APC34-FLAG = 'Y' AND OPPS-APC (LN-SUB) = '0034'
      *       COMPUTE W-SUB-CHRG (W-LP-INDX) =
      *               W-SUB-CHRG (W-LP-INDX) +
      *               H-TOT-MH-CHRG
      *    END-IF.


      ***************************************************************
      *   MOVE LINE PAYMENTS TO HOLD FIELD BECAUSE PAYMENTS MAY BE  *
      *   ADJUSTED FOR PASS-THROUGH DEVICES - ADDED 02/14/2008      *
      *   NEW FOR CY 2009 - ALWAYS USE THE PHP "CAP" APC'S WAGE ADJ *
      *   PMT FOR PHP LINES (SI=P)                                  *
      ***************************************************************
           MOVE ZEROS TO H-LITEM-PYMT-OUTL.
           IF OPPS-SRVC-IND (LN-SUB) = ' P'
              MOVE H-PHP-LITEM-PYMT-OUTL TO H-LITEM-PYMT-OUTL
           ELSE
              MOVE A-LITEM-PYMT (LN-SUB) TO H-LITEM-PYMT-OUTL
           END-IF.


      ***************************************************************
      *   CALCULATE TOTAL CHARGES AND PAYMENTS FOR PROCEDURE LINES  *
      *             ELIGIBLE FOR PASS-THROUGH DEVICE(S)             *
      *                                                             *
      * THE CHARGES AND LINE PAYMENTS OF PASS-THROUGH DEVICE LINES  *
      * ARE ADDED TO THE CHARGES AND PAYMENTS OF ALL PROCEDURES     *
      * ELIGIBLE TO BE BILLED WITH THE PASS-THROUGH DEVICE.         *
      * (PTD-FLAG = 'Y' INDICATES THERE IS AT LEAST ONE             *
      *  PASS-THROUGH DEVICE ON THE CLAIM)                          *
      *-------------------------------------------------------------*
      * 02/12/2008 - LOGIC ADDED FOR CY 2008 QTR 2                  *
      ***************************************************************
           IF (PTD-FLAG = 'Y') AND
              (OPPS-SRVC-IND (LN-SUB) = ' S' OR ' T' OR ' V' OR ' X')

      *-------------------------------------------------------------*
      * DETERMINE WHETHER THE LINE IS ELIGIBLE FOR A PT DEVICE      *
      *-------------------------------------------------------------*
              PERFORM 8670-SET-PTD-PROC-FLAG
                 THRU 8670-SET-PTD-PROC-FLAG-EXIT

      *-------------------------------------------------------------*
      * PROCEDURE IS ELIGIBLE FOR A PASS-THROUGH DEVICE             *
      *-------------------------------------------------------------*
      * 11/12/2008 - EDITED TO LOOK AT PTD-PROC-FLAG, NOT PTD-FLAG  *
      *              NO HARM DONE USING THE PTD-FLAG PREVIOUSLY     *
      *-------------------------------------------------------------*
              IF PTD-PROC-FLAG = 'Y'

      *-------------------------------------------------------------*
      * LOOP THROUGH ELIGIBLE PROCEDURE'S PASS-THROUGH DEVICE TABLE *
      * GET THE PASS-THROUGH DEVICE HCPCS(S) FOR WHICH THE          *
      * PROCEDURE IS ELIGIBLE & UPDATE PROCEDURE CHARGES & PAYMENTS *
      *-------------------------------------------------------------*
                 PERFORM 8610-PERFORM-SEARCH
                    THRU 8610-PERFORM-SEARCH-EXIT
                    VARYING W-PTD-PROC-SUB FROM 1 BY 1
                    UNTIL W-PTD-PROC-SUB > W-PTD-CNT
              END-IF
           END-IF.


      ***************************************************************
      *                                                             *
      *      CALCULATE THE OUTLIER PAYMENT FOR ELIGIBLE LINES       *
      *                                                             *
      * -NEW FOR JANUARY 2005                                       *
      *   - PROVIDER RANGE FOR CMHC                                 *
      *   - COMPUTE H-LITEM-OUTL-PYMT USING NEW FORMULA             *
      *   - CHANGE OUTLIER THRESHOLD AMOUNT EVERY JANUARY           *
      *                                                             *
      * -NEW FOR APRIL 2008                                         *
      *   - A-LITEM-PYMT (LN-SUB) CHANGED TO H-LITEM-PYMT-OUTL B/C  *
      *     PAYMENTS ARE NOW ADJUSTED FOR OUTLIER DETERMINATION     *
      *                                                             *
      * -NEW FOR JANUARY 2009                                       *
      *   - ALL PARTIAL HOSPITALIZATION (PHP) LINES (SI=P) USE      *
      *     THE PHP "CAP" APC'S LINE PAYMENT                        *
      *                                                             *
      ***************************************************************

               MOVE 1.75 TO H-OUTLIER-FACTOR.
               MOVE .50 TO H-OUTLIER-PCT.

               COMPUTE H-COST ROUNDED =
                  W-SUB-CHRG (W-LP-INDX) * L-PSF-OPCOST-RATIO.

               COMPUTE H-APC-ADJ-PYMT ROUNDED =
                  H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL.

      *-------------------------------------------------------------*
      * IDENTIFY COMMUNITY MENTAL HEALTH CENTER (CMHC) PROVIDERS    *
      * FOR CMHCS, INCREASE OUTLIER FACTOR & CALC LINE OUTLIER PMT  *
      * (CMHC PROVIDERS ONLY PROCESS PARTIAL HOSPITALIZATION LINES) *
      *-------------------------------------------------------------*
               IF (L-PSF-PROV-3456 >= '1400' AND
                   L-PSF-PROV-3456 <= '1499') OR
                  (L-PSF-PROV-3456 >= '4600' AND
                   L-PSF-PROV-3456 <= '4799') OR
                  (L-PSF-PROV-3456 >= '4900' AND
                   L-PSF-PROV-3456 <= '4999')
                  MOVE 3.4 TO H-OUTLIER-FACTOR
                  COMPUTE H-LITEM-OUTL-PYMT ROUNDED = (H-COST -
                    (H-OUTLIER-FACTOR * H-LITEM-PYMT-OUTL)) *
                     H-OUTLIER-PCT


      *-------------------------------------------------------------*
      * FOR NON-CMHC PROVIDERS, LINE'S OUTLIER ELIGIBILITY &        *
      * CALCULATE OUTLIER PAYMENT IF ELIGIBLE                       *
      * ** UPDATE THE LITERAL NUMBER BELOW EACH JANUARY **          *
      *-------------------------------------------------------------*
               ELSE

                  IF (H-COST > H-APC-ADJ-PYMT) AND
                     (H-COST > H-LITEM-PYMT-OUTL + 1800)
                       COMPUTE H-LITEM-OUTL-PYMT ROUNDED =
                          (H-COST - H-APC-ADJ-PYMT) * H-OUTLIER-PCT
                  ELSE
                     MOVE ZERO TO H-LITEM-OUTL-PYMT
                  END-IF

               END-IF.

      *-------------------------------------------------------------*
      * ACCUMULATE TOTAL CLAIM OUTLIER PAYMENTS                     *
      *-------------------------------------------------------------*
             IF H-LITEM-OUTL-PYMT > 0
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT +
                       H-LITEM-OUTL-PYMT.

      *-------------------------------------------------------------*
      * LINES THAT RECEIVE AN EXTERNAL ADJUSTMENT ARE NOT ELIGIBLE  *
      * FOR AN OUTLIER PAYMENT - ZERO OUT PAYMENT & REMOVE FROM     *
      * CLAIM TOTAL                                                 *
      *-------------------------------------------------------------*
             IF OPPS-LITEM-ACT-FLAG (LN-SUB) = '4'
               COMPUTE H-OUTLIER-PYMT = H-OUTLIER-PYMT -
                       H-LITEM-OUTL-PYMT
               MOVE 0 TO H-LITEM-OUTL-PYMT.

       8600-ADJ-CHRG-OUTL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  SEARCH THE PASS-THROUGH DEVICE TABLE FOR THE PASS-THROUGH  *
      *           DEVICE(S) THE PROCEDURE IS ELIGIBLE FOR           *
      *                                                             *
      ***************************************************************
       8610-PERFORM-SEARCH.

      *-------------------------------------------------------------*
      * SEARCH PTD TABLE STARTING AT ENTRY #1 FOR ALL OCCURANCES    *
      * OF THE PASS-THRU DEVICE HCPCS IN THE PASS-THRU DEVICE TABLE.*
      * THIS IS DONE FOR ALL PASS-THROUGH DEVICES THE PROCEDURE IS  *
      * ELIGIBLE FOR.                                               *
      *-------------------------------------------------------------*
           MOVE 'N' TO W-END-OF-PTD-TBL.

           IF W-PTD-PROC-HCPCS (W-PTD-PROC-SUB) NOT = '     '
              SET W-PTD-INDX TO 1
              PERFORM 8611-SEARCH-PTD-HCPCS
                 THRU 8611-SEARCH-PTD-HCPCS-EXIT
                UNTIL W-END-OF-PTD-TBL = 'Y'
           END-IF.

       8610-PERFORM-SEARCH-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * SEARCH FOR THE PASS-THROUGH DEVICE FOR WHICH THE PROCEDURE  *
      * IS ELIGIBLE IN THE TABLE & UPDATE PROCEDURE LINE PAYMENTS   *
      *                         AND CHARGES                         *
      *                                                             *
      ***************************************************************
       8611-SEARCH-PTD-HCPCS.

           MOVE 'N' TO W-END-OF-PTD-TBL.

      *-------------------------------------------------------------*
      * SEARCH PASS-THROUGH DEVICE TABLE                            *
      *-------------------------------------------------------------*
           SEARCH W-PTD-ENTRY VARYING W-PTD-INDX

      *-------------------------------------------------------------*
      * IF THERE ARE NO MORE OCCURANCES OF THE PASS-THROUGH DEVICE, *
      * STOP THE SEARCH AND INDICATE END OF FILE                    *
      *-------------------------------------------------------------*
                AT END
                   MOVE 'Y' TO W-END-OF-PTD-TBL
                   GO TO 8611-SEARCH-PTD-HCPCS-EXIT

      *-------------------------------------------------------------*
      * IF THE PASS-THROUGH DEVICE IS FOUND, INDICATE NOT END OF    *
      * FILE AND UPDATE THE PROCEDURE'S CHARGES AND PAYMENTS        *
      *-------------------------------------------------------------*
                WHEN  W-PTD-HCPCS (W-PTD-INDX) =
                      W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)

                      MOVE 'N' TO W-END-OF-PTD-TBL

                      PERFORM 8612-UPDATE-PTD-PROC
                         THRU 8612-UPDATE-PTD-PROC-EXIT

                      SET W-PTD-INDX UP BY 1

             END-SEARCH.

      *-------------------------------------------------------------*
      * SET UP FOR NEXT PASS-THROUGH DEVICE RECORD                  *
      *-------------------------------------------------------------*
             MOVE ZEROS TO H-PTD-UNIT-RATE
                           H-PTD-SUB-CHRG
                           H-PTD-LITEM-PYMT.

       8611-SEARCH-PTD-HCPCS-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * UPDATE THE PROCEDURE LINE'S PAYMENTS AND CHARGES WITH THE   *
      * PASS-THROUGH DEVICE'S PAYMENTS AND CHARGES (IN PROPORTION   *
      * TO THE PROCEDURE'S UNITS IF OTHER PROCEDURES ARE ELIGIBLE   *
      *            FOR THE PASS-THROUGH DEVICE AS WELL)             *
      *                                                             *
      ***************************************************************
       8612-UPDATE-PTD-PROC.

      *-------------------------------------------------------------*
      * DETERMINE PROPORTION OF CHARGES & PAYMENTS PROCEDURE LINE   *
      * WILL RECEIVE BASED ON ITS NUMBER OF UNITS                   *
      *-------------------------------------------------------------*
           IF W-PTD-TOTAL-PROC-UNITS (W-PTD-INDX) NOT = 0
              COMPUTE H-PTD-UNIT-RATE ROUNDED =
                      OPPS-SRVC-UNITS (LN-SUB) /
                      W-PTD-TOTAL-PROC-UNITS (W-PTD-INDX)
           ELSE
              MOVE 0 TO H-PTD-UNIT-RATE
           END-IF.

      *-------------------------------------------------------------*
      * CALCULATE THE AMOUNT OF PASS-THROUGH DEVICE CHARGES TO BE   *
      * ADDED TO THE PROCEDURE'S CHARGES IN PROPORTION TO UNITS     *
      *-------------------------------------------------------------*
           COMPUTE H-PTD-SUB-CHRG ROUNDED =
                   W-PTD-SUB-CHRG (W-PTD-INDX) *
                   H-PTD-UNIT-RATE.

      *-------------------------------------------------------------*
      * ADD PASS-THROUGH DEVICE CHARGES TO PROCEDURE LINE CHARGES   *
      *-------------------------------------------------------------*
           COMPUTE W-SUB-CHRG (W-LP-INDX) ROUNDED =
                   W-SUB-CHRG (W-LP-INDX) +
                   H-PTD-SUB-CHRG.

      *-------------------------------------------------------------*
      * CALCULATE THE AMOUNT OF PASS-THROUGH DEVICE PAYMENTS TO BE  *
      * ADDED TO THE PROCEDURE'S PAYMENTS IN PROPORTION TO UNITS    *
      *-------------------------------------------------------------*
           COMPUTE H-PTD-LITEM-PYMT ROUNDED =
                   W-PTD-LITEM-PYMT (W-PTD-INDX) *
                   H-PTD-UNIT-RATE.

      *-------------------------------------------------------------*
      * ADD PASS-THROUGH DEVICE PAYMENT TO PROCEDURE LINE PAYMENT   *
      *-------------------------------------------------------------*
           COMPUTE H-LITEM-PYMT-OUTL ROUNDED =
                   H-LITEM-PYMT-OUTL +
                   H-PTD-LITEM-PYMT.

       8612-UPDATE-PTD-PROC-EXIT.
           EXIT.



      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT APC IS A BRACHYTHERAPY APC   *
      *    - IF SO, SET BRACHY-APC-FLAG = 'Y'                       *
      *    - THIS FLAG IS USED IN PARAGRAPHS 8600-ADJ-CHRG-OUTL &   *
      *      8550-CALC-GJK TO PROCESS BRACHYS                       *
      *  ** UPDATE THIS LIST EVERY JANUARY                          *
      *  (CODE NEW FOR CY2008; ADDED 11/6/2007)                     *
      *                                                             *
      *  11/12/2008 - BRACHYTHERAPY APC LIST REMOVED FOR CY 2009;   *
      *               BRACHYTHERAPY LINES NOW IDENTIFIED BY A       *
      *               STATUS INDICATOR OF ' U'                      *
      *                                                             *
      ***************************************************************
      *8650-SET-BRACHY-APC-FLAG.
      *
      *    MOVE 'N' TO BRACHY-APC-FLAG.
      *
      *    IF OPPS-APC (LN-SUB) = ('2632' OR
      *                            '1716' OR
      *                            '1717' OR
      *                            '1719' OR
      *                            '2616' OR
      *                            '2634' OR
      *                            '2635' OR
      *                            '2636' OR
      *                            '2638' OR
      *                            '2639' OR
      *                            '2640' OR
      *                            '2641' OR
      *                            '2642' OR
      *                            '2643' OR
      *                            '2698' OR
      *                            '2699')
      *
      *       MOVE 'Y' TO BRACHY-APC-FLAG
      *    END-IF.
      *
      *8650-SET-BRACHY-APC-FLAG-EXIT.
      *    EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A BLOOD DEDUCTIBLE  *
      *  HCPCS                                                      *
      *    - IF SO, SET BLD-DEDUC-HCPCS-FLAG = 'Y'                  *
      *    - THIS FLAG IS USED IN PARAGRAPHS 8550-CALC-GJK &        *
      *      8550-SCH-ADJ TO PROCESS BLOOD DEDUCTIBLE LINES         *
      *  ** UPDATE THIS LIST EVERY JANUARY                          *
      *  (CODE NEW FOR CY2008; ADDED 12/4/2007)                     *
      *                                                             *
      ***************************************************************
       8655-SET-BD-HCPCS-FLAG.

           MOVE 'N' TO BLD-DEDUC-HCPCS-FLAG.

           IF OPPS-HCPCS(LN-SUB) = ('P9054' OR
                                    'P9021' OR
                                    'P9051' OR
                                    'P9016' OR
                                    'P9056' OR
                                    'P9010' OR
                                    'P9038' OR
                                    'P9040' OR
                                    'P9022' OR
                                    'P9058' OR
                                    'P9039' OR
                                    'P9057'   )

              MOVE 'Y' TO BLD-DEDUC-HCPCS-FLAG
           END-IF.

       8655-SET-BD-HCPCS-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT APC IS A RADIOPHARM APC      *
      *    - IF SO, SET RADIOPH-APC-FLAG = 'Y'                      *
      *    - THIS FLAG IS USED IN PARAGRAPH 8550-CALC-STANDARD      *
      *      TO PROCESS RADIOPHARM LINES                            *
      *  ** UPDATE THIS LIST EVERY JANUARY                          *
      *  (CODE NEW FOR CY2008; ADDED 12/27/2007)                    *
      *                                                             *
      ***************************************************************
       8660-SET-RADIOPH-APC-FLAG.

           MOVE 'N' TO RADIOPH-APC-FLAG.

           IF OPPS-APC (LN-SUB) = ('1064' OR
                                   '1150' OR
                                   '1643' OR
                                   '1645' OR
                                   '1675' OR
                                   '1676' OR
                                   '0701' OR
                                   '0702')

              MOVE 'Y' TO RADIOPH-APC-FLAG
           END-IF.

       8660-SET-RADIOPH-APC-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A PASS-THROUGH      *
      *  DEVICE HCPCS                                               *
      *    - IF SO, SET PTD-LINE-FLAG = 'Y'                         *
      *    - THIS FLAG IS USED IN THE PASS-THROUGH DEVICE LOGIC     *
      *      TO POPULATE THE PASS-THROUGH-DEVICE TABLE              *
      *  ** UPDATE THIS LIST EVERY QUARTER                          *
      *  (CODE NEW FOR CY2008 QTR 2; ADDED 02/11/2008)              *
      *                                                             *
      ***************************************************************
       8665-SET-PTD-LINE-FLAG.

           MOVE 'N' TO PTD-LINE-FLAG.

      ***********************************************************
      * 11/12/2008 - ALL LOGIC DISABLED B/C THERE ARE NO        *
      *              NO PASS-THROUGH DEVICES FOR CY 2009        *
      ***********************************************************

      *---------------------------------------------------------*
      * ONLY CLAIMS WITH A DATE OF SERVICE ON OR AFTER          *
      * _____________ ARE ELIGIBLE                              *
      *---------------------------------------------------------*
      *    IF OPPS-LITEM-DOS (LN-SUB) >= 20080401
      *
      *       IF OPPS-HCPCS (LN-SUB) = ('C1821' OR
      *                                 'L8690')
      *
      *          MOVE 'Y' TO PTD-LINE-FLAG
      *
      *       END-IF
      *    END-IF.

       8665-SET-PTD-LINE-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE CURRENT HCPCS IS A PROCEDURE         *
      *  ELIGIBLE FOR A PASS-THROUGH DEVICE                         *
      *    - IF SO, SET PTD-PROC-FLAG = 'Y'                         *
      *    - THIS FLAG IS USED IN THE PASS-THROUGH DEVICE LOGIC     *
      *  ** UPDATE THIS LIST EVERY QUARTER                          *
      *  (CODE NEW FOR CY2008 QTR 2; ADDED 02/11/2008)              *
      *                                                             *
      ***************************************************************
       8670-SET-PTD-PROC-FLAG.

           MOVE 'N' TO PTD-PROC-FLAG.

      ***********************************************************
      * 11/12/2008 - ALL LOGIC DISABLED B/C THERE ARE NO        *
      *              NO PASS-THROUGH DEVICES FOR CY 2009        *
      ***********************************************************

      *---------------------------------------------------------*
      * ONLY CLAIMS WITH A DATE OF SERVICE ON OR AFTER          *
      * _____________ ARE ELIGIBLE                              *
      *---------------------------------------------------------*
      *    IF OPPS-LITEM-DOS (LN-SUB) >= 20080401
      *
      *---------------------------------------------------------*
      *  SPECIFY NUMBER OF ENTRIES (# OF PT DEVICES FROM POLICY)*
      *---------------------------------------------------------*
      *       MOVE 2 TO W-PTD-CNT
      *
      *---------------------------------------------------------*
      *  INITIALIZE PROCEDURE'S PTD HCPCS TABLE TO SPACES       *
      *---------------------------------------------------------*
      *       PERFORM VARYING W-PTD-PROC-SUB FROM 1 BY 1
      *         UNTIL W-PTD-PROC-SUB > W-PTD-CNT
      *            MOVE SPACES TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
      *       END-PERFORM
      *
      *---------------------------------------------------------*
      *  PROCEDURES ELIGIBLE FOR PASS-THROUGH DEVICE 1          *
      *---------------------------------------------------------*
      *       IF OPPS-HCPCS (LN-SUB) = ('0171T' OR
      *                                 '0172T')
      *
      *          MOVE 'Y'     TO PTD-PROC-FLAG
      *          MOVE 1       TO W-PTD-PROC-SUB
      *          MOVE 'C1821' TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
      *       END-IF
      *
      *---------------------------------------------------------*
      *  PROCEDURES ELIGIBLE FOR PASS-THROUGH DEVICE 2          *
      *---------------------------------------------------------*
      *       IF OPPS-HCPCS (LN-SUB) = ('69714' OR
      *                                 '69715' OR
      *                                 '69717' OR
      *                                 '69718')
      *
      *          MOVE 'Y'     TO PTD-PROC-FLAG
      *          MOVE 2       TO W-PTD-PROC-SUB
      *          MOVE 'L8690' TO W-PTD-PROC-HCPCS (W-PTD-PROC-SUB)
      *       END-IF
      *    END-IF.

       8670-SET-PTD-PROC-FLAG-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  DETERMINE WHETHER THE LINE HCPCS IS A CURRENT PASS-THROUGH *
      *                 RADIOPHARMACEUTICAL HCPCS                   *
      *                                                             *
      *    - IF SO: SET PTRADIO-LINE-FLAG = 'Y',                    *
      *             ADD 1 TO COUNT OF TOTAL PT RADIOPHARMS,         *
      *             ADD CHARGES TO CLAIM TOTAL PT RADIOPHARM CHRGES *
      *    - THIS FLAG IS USED IN PARAGRAPHS 8125-INIT &            *
      *      8550-CALC-STANDARD TO PROCESS PT RADIOPHARM LINES      *
      *                                                             *
      *  ** PASS-THROUGH RADOIOPHARM TABLE IS UPDATED QUARTERLY     *
      *  (CODE NEW FOR CY2009; ADDED 02/10/2009)                    *
      *                                                             *
      ***************************************************************
       8680-SET-PTRADIO-LINE-FLAG.

           MOVE 'N' TO PTRADIO-LINE-FLAG.

           SEARCH ALL PTRH-ENTRY
            AT END
             MOVE 'N' TO PTRADIO-LINE-FLAG

            WHEN PTRH-PTRADIO-HCPCS (PTRH-INDX) = OPPS-HCPCS (LN-SUB)
             IF OPPS-LITEM-DOS (LN-SUB) >= PTRH-EFF-DATE (PTRH-INDX) AND
               (OPPS-LITEM-DOS (LN-SUB) < PTRH-TERM-DATE (PTRH-INDX) OR
                PTRH-TERM-DATE (PTRH-INDX) = 0) THEN
                MOVE 'Y' TO PTRADIO-LINE-FLAG
             END-IF.

       8680-SET-PTRADIO-LINE-FL-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      * REDUCE LINE ITEM PAYMENTS OF DEVICE LINES (SI = H) BY THE   *
      * WAGE ADJUSTED DEVICE OFFSET AMOUNT WHEN THERE ARE DEVICE    *
      *         OFFSETS ON THE CLAIM (PASS-THROUGH DEVICES)         *
      *                                                             *
      ***************************************************************
      *                                                             *
      * 1. RE-CALCULATE LINE ITEM PAYMENT FOR SERVICE INDICATOR     *
      *    TYPE H                                                   *
      * 2. SUBTRACT WAGE ADJUSTED OFFSET AMOUNT FROM SI TYPE 'H'    *
      *    WITH HCPCS CODE BEGINNING WITH 'C'                       *
      * ** EFFECTIVE 04/01/2002                                     *
      *                                                             *
      ***************************************************************
       8700-CALC-H-OFFSET.

      *-------------------------------------------------------------*
      * REDUCE EACH DEVICE LINE'S PAYMENT BY THE WAGE ADJUSTED      *
      * OFFSET AMOUNT IN PROPORTION TO THE DEVICE LINE'S CHARGES    *
      *-------------------------------------------------------------*
             IF H-TOT-H-CHRG > 0
                COMPUTE H-OFF-RATE ROUNDED =
                    H-SUB-CHRG / H-TOT-H-CHRG
                COMPUTE T-LITEM-PYMT ROUNDED =
                    T-LITEM-PYMT - (H-TOTAL-WAOFF * H-OFF-RATE)
             ELSE
                NEXT SENTENCE.

             IF T-LITEM-PYMT < 0
                MOVE 0 TO T-LITEM-PYMT.

       8700-CALC-H-OFFSET-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *            PROCESS DRUG COINSURANCE TABLE RECORDS           *
      *                                                             *
      ***************************************************************
      *                                                             *
      *  ADJUST THE "DRUG" LINE COINSURANCE WHEN THE PROCEDURE      *
      *  COINSURANCE AMOUNTS PLUS THE "DRUG" COINSURANCE AMOUNT(S)  *
      *  BILLED ON THE SAME DAY EXCEED THE DAILY INPATIENT          *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      ***************************************************************
       8800-ADJ-STV-REIM.

             IF W-DCP-CODE (W-DCP-INDX) = 1
                PERFORM 8810-PROCESS-TYPE1
                   THRU 8810-PROCESS-TYPE1-EXIT
             ELSE
                PERFORM 8840-PROCESS-TYPE2
                   THRU 8840-PROCESS-TYPE2-EXIT.

       8800-ADJ-STV-REIM-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  FOR DAYS OF SERVICE WITH "DRUG" COINSURANCE, DETERMINE THE *
      *  % OF TOTAL "DRUG" COINSURANCE THAT CAN BE PAID IN ADDITION *
      *  TO THE DAY'S MOST EXPENSIVE PROCEDURE/VISIT WAGE ADJUSTED  *
      *  COINSURANCE WHILE KEEPING WITHIN THE INPATIENT DAILY       *
      *  COINSURANCE LIMIT.                                         *
      *                                                             *
      *  WHEN H-RATIO = 0, NONE OF THE DRUG COINSURANCE CAN BE PAID *
      *  WHEN H-RATIO = 1, ALL OF THE DRUG COINSURANCE CAN BE PAID  *
      *                                                             *
      *  BY USING THE DAY'S MOST EXPENSIVE PROCEDURE/VIST WAGE      *
      *  ADJUSTED COINSURANCE, THE BENEFICIARY RECEIVES THE         *
      *  GREATEST BENEFIT FROM THE INPATIENT LIMITATION PROVISION.  *
      *                                                             *
      ***************************************************************
       8810-PROCESS-TYPE1.

      *-------------------------------------------------------------*
      * DRUGS WERE ADMINISTERED ON THE DAY                          *
      *-------------------------------------------------------------*
             IF W-DCP-COIN2 (W-DCP-INDX) > 0

      *-------------------------------------------------------------*
      * GET DATE OF SERVICE & WAGE ADJUSTED COINSURANCE OF THE      *
      * DAY'S MOST EXPENSIVE PROCEDURE/VISIT                        *
      *-------------------------------------------------------------*
                MOVE W-DCP-DOS (W-DCP-INDX) TO H-DCP-DOS
                MOVE W-DCP-WGNAT (W-DCP-INDX) TO H-TOTAL

      *-------------------------------------------------------------*
      * CALCULATE THE % OF THE DAY'S TOTAL DRUG COIN THAT CAN BE    *
      * PAID IN ADDITION TO THE PROCEDURE/VISIT COIN WITHIN THE     *
      * INPATIENT LIMIT                                             *
      *-------------------------------------------------------------*
                COMPUTE H-RATIO =
                   (H-IP-LIMIT - W-DCP-WGNAT (W-DCP-INDX)) /
                                 W-DCP-COIN2 (W-DCP-INDX)

      *-------------------------------------------------------------*
      * NONE OF THE DAY'S DRUG COIN CAN BE PAID B/C THE PROCEDURE/  *
      * VISIT COIN > INPATIENT COIN LIMIT                           *
      *-------------------------------------------------------------*
                IF H-RATIO < 0
                    MOVE 0 TO H-RATIO.

      *-------------------------------------------------------------*
      * THE DAY'S TOTAL DRUG COINSURANCE CAN BE PAID WITHIN THE     *
      * INPATIENT COIN LIMIT                                        *
      *-------------------------------------------------------------*
             IF H-RATIO > 1
                MOVE 1 TO H-RATIO.

       8810-PROCESS-TYPE1-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *  REDUCE THE "DRUG" LINE'S NATIONAL COINSURANCE AMOUNT AND   *
      *    ADD THE REDUCTION AMOUNT TO THE LINE'S REIMBURSEMENT     *
      *        AMOUNT WHEN THE INPATIENT LIMIT IS EXCEEDED          *
      *                                                             *
      ***************************************************************
       8840-PROCESS-TYPE2.

      *-------------------------------------------------------------*
      * CURRENT TYPE 2 DRUG COIN REC HAS SAME DATE OF SERVICE AS    *
      * THE LAST TYPE 1 RECORD PROCESSED                            *
      *-------------------------------------------------------------*
             IF W-DCP-DOS (W-DCP-INDX) = H-DCP-DOS

      *-------------------------------------------------------------*
      * GO TO SERVICE LINE THAT CORRESPONDS TO THE DRUG COIN RECORD *
      *-------------------------------------------------------------*
                MOVE W-DCP-SUB (W-DCP-INDX) TO LN-SUB

      *-------------------------------------------------------------*
      * CALCULATE ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT  *
      *-------------------------------------------------------------*
                COMPUTE H-SHIFT =
                    W-DCP-COIN2 (W-DCP-INDX) * (1 - H-RATIO)

      *-------------------------------------------------------------*
      * ACCUMULATE THE TOTAL NATIONAL COIN DUE FOR THE DAY          *
      * (LESS ACTUAL COIN AMT TO BE REIMBURSED DUE TO IP LIMIT)     *
      *-------------------------------------------------------------*
                COMPUTE H-TOTAL =
                     A-ADJ-COIN (LN-SUB) + H-TOTAL - H-SHIFT

      *-------------------------------------------------------------*
      * DETERMINE HOW MUCH THE DAY'S TOTAL NATIONAL COIN DUE        *
      * EXCEEDS THE DAILY INPATIENT LIMIT (IF IT EXCEEDS THE LIMIT) *
      *-------------------------------------------------------------*
      * OCCURS WHEN THE NATIONAL COIN OF THIS LINE AND/OR PREVIOUS  *
      * LINES FROM THE SAME DAY IS GREATER THAN THE ACTUAL COIN DUE *
      * & PUSHES THE DAILY TOTAL OVER THE INPATIENT LIMIT           *
      *-------------------------------------------------------------*
                IF H-TOTAL > H-IP-LIMIT
                   COMPUTE H-SHIFT = H-SHIFT + H-TOTAL - H-IP-LIMIT
                END-IF

      *-------------------------------------------------------------*
      * CALCULATE THE ADJUSTED NATIONAL COIN FOR THE DRUG LINE BY   *
      * DEDUCTING THE AMT THAT EXCEEDS THE INPATIENT LIMIT          *
      *-------------------------------------------------------------*
                COMPUTE A-ADJ-COIN (LN-SUB) =
                    A-ADJ-COIN (LN-SUB) - H-SHIFT

      *-------------------------------------------------------------*
      * ADD DRUG COIN AMT THAT EXCEEDS IP LIMIT TO LINE REIM AMT    *
      * SET RETURN CODE TO INDICATE DAILY COINSURANCE LIMITATION    *
      *-------------------------------------------------------------*
                COMPUTE A-LITEM-REIM (LN-SUB) =
                    A-LITEM-REIM (LN-SUB) + H-SHIFT

                   MOVE 22 TO A-RETURN-CODE (LN-SUB)

             END-IF.

       8840-PROCESS-TYPE2-EXIT.
           EXIT.


      ***************************************************************
      *                                                             *
      *                  END OF CLAIM PROCESSING                    *
      *                                                             *
      * 1. MOVE TOTAL CLAIM CHARGE AMOUNT.                          *
      * 2. MOVE TOTAL CLAIM PAYMENT AMOUNT.                         *
      * 3. MOVE TOTAL CLAIM BLOOD PINTS USED.                       *
      * 4. CALCULATE CLAIM LEVEL OUTLIER AMOUNT.                    *
      *                                                             *
      ***************************************************************
       8900-END-PRICE-RTN.

             MOVE H-TOT-CHRG TO A-TOT-CLM-CHRG.
             MOVE H-TOT-PYMT TO A-TOT-CLM-PYMT.

      *-------------------------------------------------------------*
      * NUMBER OF BLOOD PINTS USED FOR BLOOD DEDUCTIBLES ON CLAIM = *
      *   INITIAL NUMBER OF BLOOD PINTS ALLOWED FOR DEDUCTIBLES -   *
      *   BLOOD PINTS STILL LEFT AFTER PROCESSING BLOOD DEDUCTIBLES *
      *-------------------------------------------------------------*
             COMPUTE A-BLOOD-PINTS-USED =
                     H-BENE-BLOOD-PINTS - H-BENE-PINTS-USED.

             IF H-OUTLIER-PYMT > 0
                MOVE H-OUTLIER-PYMT TO A-OUTLIER-PYMT.

       8900-END-PRICE-RTN-EXIT.
           EXIT.
