       IDENTIFICATION DIVISION.
       PROGRAM-ID.           OPPSCAL.
      *AUTHOR.            ED FRANEY.
      *REMARKS.                CMS.
      ***********************************************************
      * 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 0400-CALCULATE                         *
      *           - 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              *
      *                                                         *
      ***********************************************************
       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.
       01  W-STORAGE-REF                  PIC X(46)  VALUE
           'OPCAL2006.1.0 - W O R K I N G   S T O R A G E'.
       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  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.

      ***************************************************************
      *    LAYUP TABLE AREA FOR CY2002 APC OFFSET ADJUSTMENTS       *
      *      OPPSOF02 - EFFECTIVE AS OF 04-01-2002                  *
      *      OPPSOF03 - EFFECTIVE AS OF 01-01-2003                  *
      ***************************************************************
      ****** WOO-INDX   ******************************
       COPY OPPSOF02.

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

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

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

      ***************************************************************
      *    LAYUP TABLE AREA FOR CY2000 APC'S                        *
      ***************************************************************
      ***************************************************************
      ****** WAA-INDX   ******************************
       COPY OPPSAPCS.

      ***************************************************************
      * ** MSA **         THIS IS THE WAGE-INDEX                    *
      *          ASSOCIATED WITH THE BILL BEING PROCESSED           *
      ***************************************************************
      ****** WWM-INDX   ******************************
       COPY OPPSWINX.

      ***************************************************************
      * ** CBSA **        THIS IS THE WAGE-INDEX                    *
      *          ASSOCIATED WITH THE BILL BEING PROCESSED           *
      ***************************************************************
      ****** WCM-INDX   ******************************
       COPY OPPSWNXC.

      ***************************************************************
      *          THIS IS THE COPYBOOK FOR THE TABLE OF              *
      *                 SOLE COMMUNITY HOSPITALS                    *
      *            WHICH CALCULATE A SPECIAL 7.1% INCREASE FACTOR   *
      ***************************************************************
      ****** WOS-INDX   ******************************
       COPY OPPSSCHS.

      ***************************************************************
      *          THIS IS THE BLOOD DEDUCTABLE 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 DEDUCTABLE RANKIN 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 DEDUCTABLE RANKIN TABLE           *
      *          FOR THE BILL BEING PROCESSED FROM 01/01/2006       *
      ***************************************************************
      ****** 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 MAX-COINSURANCE               *
      *          DETERMINED BY DATE LINE-ITEM PROCESSING            *
      ***************************************************************
      ****** 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).

JB     01  W-APC-CODE-FILLS.
JB         03                          PIC X(44)  VALUE
JB            '07010702070407050737104510641065108810961150'.
JB         03                          PIC X(44)  VALUE
JB            '16001602160316041641164216431644164516461647'.
JB         03                          PIC X(44)  VALUE
JB            '16481649165016511652165316541671167216731674'.
JB         03                          PIC X(44)  VALUE
JB            '16751676167716781679171617171718171917202616'.
JB         03                          PIC X(44)  VALUE
JB            '26322633263426352636263791009146914891499150'.
JB     01  W-APC-CODE-TABLE REDEFINES W-APC-CODE-FILLS.
JB         03  WAC-ENTRY  OCCURS 55 TIMES
JB               INDEXED BY WAC-INDX.
JB             05  WAC-CODE            PIC X(4).

       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).
           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).

      ****************************************************************
      *   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 9(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(05)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.
           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 9(09).
           05  H-TOT-OFF-UNITS            PIC 9(09).
           05  H-BENE-BLOOD-PINTS         PIC 9(01).
           05  H-BENE-PINTS-USED          PIC 9(01).
           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(05)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(07).
              10  H-RANK                  PIC 9(05).
              10  H-BLD-RNK.
                15  H-BLD-DOS             PIC 9(08).
                15  H-BLOOD-RANK          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).

      ****************************************************************
      *   BELOW IS THE LAY-UP TABLE TO PROCESS 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(07).
              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     *
      *                                                              *
      ****************************************************************
      ****** 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(07).
              10  W-BD-RNK.
                  15  W-BD-DOS            PIC 9(08).
                  15  W-BD-RANK           PIC 9(05).
              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.


       LINKAGE SECTION.
      ***************************************************************
      *    LAYUP TABLE AREA FOR CY2000 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-BED-SIZE               PIC 9(05).
               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.

      ***************************************************************
      *  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  *
      ***************************************************************
       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(07).
               10  OPPS-SUB-CHRG          PIC 9(08)V99.
               10  OPPS-LITEM-ACT-FLAG    PIC X(01).
       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(21).
      ***************************************************************
      *    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.

              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
                         C1820-OFFSET-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.
             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                        *
      ***************************************************************
         4100-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 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.

             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)
                   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.

         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'
               PERFORM 4550-SET-BLOOD-FRACTION
                  THRU 4550-SET-BLOOD-FRACTION-EXIT
               PERFORM 4550-ADJ-BLOOD-COST
                  THRU 4550-ADJ-BLOOD-COST-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.

      ***************************************************************
      * 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          **
      **                                                                 **
      *********************************************************************

             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                        *
      ***************************************************************
         5100-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 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.

             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)
                   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.

         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
                   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.

         5160-TOTAL-OFFSET-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.

             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
                   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           SEARCH ALL WOS-ENTRY
JB              AT END
JB                 MOVE W-APC-PYMT (W-LP-INDX) TO H-SCH-PYMT
JB              WHEN WOS-PROVIDER (WOS-INDX) =  L-PSF-PROV-OSCAR
JB                COMPUTE H-SCH-PYMT ROUNDED =
JB                             (W-APC-PYMT (W-LP-INDX) * 1.071).
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'
               PERFORM 5550-SET-BLOOD-FRACTION
                  THRU 5550-SET-BLOOD-FRACTION-EXIT
               PERFORM 5550-ADJ-BLOOD-COST
                  THRU 5550-ADJ-BLOOD-COST-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.

      ***************************************************************
      * 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          **
      **                                                                 **
      *********************************************************************

             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.

         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.
