Routine: IBARXET

IBARXET ;ALB/AAS - RX COPAY EXEMPTION THRESHOLD ENTER/LIST ; 20-JAN-93

 ;;2.0;INTEGRATED BILLING;**26,74**; 21-MAR-94

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

ADD ; -- add/edit new thresholds

 S IBTH=""

 S DIC="^IBE(354.3,",DIC(0)="AEQLMN",DLAYGO=354.3,DIC("DR")="" D ^DIC G ADDQ:Y<1

 S DA=+Y,DIE="^IBE(354.3,",DR="[IB ENTER THRESHOLD]" D ^DIE

 ;I $D(DA) S IBX=$G(^IBE(354.3,DA,0)),$P(IBX,"^",2)=2 D

 I $D(DA) S IBX=$G(^IBE(354.3,DA,0)),$P(IBX,"^",2)=$S($E($P(IBX,"^",1),1,5)<29612:2,1:1) D

 .I $P(IBX,"^",3)'="",$P(IBX,"^",4)'="",$P(IBX,"^",12)'="" Q

 .S DIK="^IBE(354.3," D ^DIK

 .W !!,"Entry Deleted, not enough information."

 .K DA,DIK

.Q

 D:$D(DA)#2 PRIOR

 W ! G ADD

ADDQ K DLAYGO,DIC,DIE,DA,DR,X,Y,IBDA,IBTH,IBX

PRINT ; -- print threshold list

 I '$D(IOF) D HOME^%ZIS

 W @IOF,?15,"Print Medication Copayment Income Thresholds",!!!

 W !!,"You will need a 132 column printer for this report!",!

 S DIC="^IBE(354.3,",L=0,FLDS="[IB PRINT THRESHOLD]",BY="[IB PRINT THRESHOLD]",FR="?,?",TO="?,?"

 S DHD="Medication Copayment Income Thresholds"

 D EN1^DIP

PRINTQ K L,FLDS,BY,FR,TO,DHD,DIC

PRIOR ; -- check to see if prior year thresholds used

 S IBPR=$G(^IBE(354.3,+DA,0)) I IBPR="" G PRIORQ

 ;I $P(IBPR,"^",2)'=2 G PRIORQ

 S X=$S($P(IBPR,"^",2)=2:1,$P(IBPR,"^",2)=1:1,1:"") G:X="" PRIORQ

 ;S IBPRDT=$O(^IBE(354.3,"AIVDT",2,-($P(IBPR,"^")))) ;threshold prior to the one entered

 S X=$S($E($P(IBPR,"^"),1,5)'<29712:1,1:2) S IBPRDT=$O(^IBE(354.3,"AIVDT",X,-($P(IBPR,"^")))) ;threshold prior to the one entered

 I IBPRDT<0 S IBPRDT=-IBPRDT ; minus a negative to make positive

 G:IBPRDT="" PRIORQ I '$D(^IBA(354.1,"APRIOR",IBPRDT)) G PRIORQ

 ; -- is exemptions based on prior thresholds

 W !!,"There are Medication Copayment Exemptions based on prior thresholds",!

 S DIR("?")="There are exemptions that were based on the threshold values over a year old.  You can ignore this, print a list of patients with old exemptions, or automatically update while printing the same list"

 S DIR(0)="S^1:IGNORE;2:PRINT;3:UPDATE AND PRINT",DIR("A")="Select ACTION",DIR("B")="IGNORE" D ^DIR K DIR I $D(DIRUT)!(Y<2)!(Y>3) G PRIORQ

 S IBACT=Y

 S %ZIS="QM" D ^%ZIS G:POP PRIORQ

 I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^IBARXET",ZTDESC="IB PRIOR YEAR THRESHOLD PRINT"_$S(IBACT=3:" AND UPDATE",1:""),ZTSAVE("IB*")="" D ^%ZTLOAD K ZTSK D HOME^%ZIS G PRIORQ

 U IO

DQ ; -- entry point from tasking

 S (IBQUIT,IBPAG)=0 D NOW^%DTC S Y=% D D^DIQ S IBPDAT=Y

 K ^TMP($J,"IBPRIOR") S IBJOB=17

 D HDR

 S IBEX=""

 F  S IBEX=$O(^IBA(354.1,"APRIOR",IBPRDT,IBEX)) Q:IBEX=""  D SET

 S IBNAM=""

 F  S IBNAM=$O(^TMP($J,"IBPRIOR",IBNAM)) Q:IBNAM=""!IBQUIT  D

 .S DFN="" F  S DFN=$O(^TMP($J,"IBPRIOR",IBNAM,DFN)) Q:DFN=""!IBQUIT  D

 ..S IBXXX=0 F  S IBXXX=$O(^TMP($J,"IBPRIOR",IBNAM,DFN,IBXXX)) Q:'IBXXX!IBQUIT  S IBP=^(IBXXX) D ONE

 I 'IBQUIT D PAUSE^IBOUTL

 K ^TMP($J,"IBPRIOR")

 I $D(ZTQUEUED) S ZTREQ="@" Q

 D ^%ZISC

PRIORQ K X,Y,DFN,DIR,DIRUT,IBACT,IBPR,IBPRDT,IBQUIT,IBPAG,IBPDAT,IBPRIOR

 K IBEX,IBNAM,IBND,IBP,IBEXREA,IBJOB,IBQUIT,IBXXX,IBWHER,IBEXERR,IBADDE,IBADD,IBCODA,IBCODP

HDR ; -- print prior threshold header

 I IBPAG!($E(IOST,1,2)="C-") W @IOF,*13

 S IBPAG=IBPAG+1

 W "Exemptions Based on Prior Year Thresholds",?(IOM-35),$P(IBPDAT,"@")," @ ",$P(IBPDAT,"@",2)," Page ",IBPAG

 W !,"Patient",?22,"PT. ID",?36,"Exemption Date",?52,"Status" W:IBACT=3 ?63,"Action"

 W !,$TR($J(" ",IOM)," ","-")

SET ; -- set up sortable array by patient

 S IBND=$G(^IBA(354.1,IBEX,0)) Q:IBND=""

 S DFN=$P(IBND,"^",2),IBP=$$PT^IBEFUNC(DFN)

 S ^TMP($J,"IBPRIOR",$P(IBP,"^"),DFN,IBEX)=IBEX_"^"_IBP

ONE ; -- print line for one patient

 S IBEX=+IBP,IBP=$P(IBP,"^",2,5)

 I $Y>(IOSL-5) D PAUSE^IBOUTL G:IBQUIT ONEQ D HDR

 S IBND=$G(^IBA(354.1,IBEX,0)) G ONEQ:IBND=""

 S Y=+IBND D D^DIQ

 W !,$E(IBNAM,1,20),?22,$P(IBP,"^",2),?36,Y,?52,$$TEXT^IBARXEU0($P(IBND,"^",4))

 ; -- compute exempt, add if different, else delete prior

 G:IBACT'=3 ONEQ

 S IBEXREA=$$STATUS^IBARXEU1(DFN,+IBND)

 I +IBEXREA'=$P(IBND,"^",5) D ADDEX^IBAUTL6(+IBEXREA,+IBND,1,1) W ?63,"Exemption updated"

 I +IBEXREA=$P(IBND,"^",5) S DA=IBEX,DIE="^IBA(354.1,",DR=".15///@" D ^DIE W ?63,"No Change"

 K DIE,DA,DR,DIC

ONEQ Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXET   4310     printed  Feb 18, 2025@23:33:46                                                                                                                                                                                                     Page 2

IBARXET   ;ALB/AAS - RX COPAY EXEMPTION THRESHOLD ENTER/LIST ; 20-JAN-93

 +1       ;;2.0;INTEGRATED BILLING;**26,74**; 21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

ADD       ; -- add/edit new thresholds

 +1        SET IBTH=""

 +2        SET DIC="^IBE(354.3,"

           SET DIC(0)="AEQLMN"

           SET DLAYGO=354.3

           SET DIC("DR")=""

           DO ^DIC

           if Y<1

               GOTO ADDQ

 +3        SET DA=+Y

           SET DIE="^IBE(354.3,"

           SET DR="[IB ENTER THRESHOLD]"

           DO ^DIE

 +4       ;I $D(DA) S IBX=$G(^IBE(354.3,DA,0)),$P(IBX,"^",2)=2 D

 +5        IF $DATA(DA)

               SET IBX=$GET(^IBE(354.3,DA,0))

               SET $PIECE(IBX,"^",2)=$SELECT($EXTRACT($PIECE(IBX,"^",1),1,5)<29612:2,1:1)

               Begin DoDot:1

 +6                IF $PIECE(IBX,"^",3)'=""

                       IF $PIECE(IBX,"^",4)'=""

                           IF $PIECE(IBX,"^",12)'=""

                               QUIT

 +7                SET DIK="^IBE(354.3,"

                   DO ^DIK

 +8                WRITE !!,"Entry Deleted, not enough information."

 +9                KILL DA,DIK

 +10               QUIT

               End DoDot:1

 +11      ;

 +12       if $DATA(DA)#2

               DO PRIOR

 +13       WRITE !

           GOTO ADD

ADDQ       KILL DLAYGO,DIC,DIE,DA,DR,X,Y,IBDA,IBTH,IBX

 +1        QUIT

 +2       ;

PRINT     ; -- print threshold list

 +1        IF '$DATA(IOF)

               DO HOME^%ZIS

 +2        WRITE @IOF,?15,"Print Medication Copayment Income Thresholds",!!!

 +3        WRITE !!,"You will need a 132 column printer for this report!",!

 +4        SET DIC="^IBE(354.3,"

           SET L=0

           SET FLDS="[IB PRINT THRESHOLD]"

           SET BY="[IB PRINT THRESHOLD]"

           SET FR="?,?"

           SET TO="?,?"

 +5        SET DHD="Medication Copayment Income Thresholds"

 +6        DO EN1^DIP

PRINTQ     KILL L,FLDS,BY,FR,TO,DHD,DIC

 +1        QUIT

 +2       ;

PRIOR     ; -- check to see if prior year thresholds used

 +1        SET IBPR=$GET(^IBE(354.3,+DA,0))

           IF IBPR=""

               GOTO PRIORQ

 +2       ;I $P(IBPR,"^",2)'=2 G PRIORQ

 +3        SET X=$SELECT($PIECE(IBPR,"^",2)=2:1,$PIECE(IBPR,"^",2)=1:1,1:"")

           if X=""

               GOTO PRIORQ

 +4       ;S IBPRDT=$O(^IBE(354.3,"AIVDT",2,-($P(IBPR,"^")))) ;threshold prior to the one entered

 +5       ;threshold prior to the one entered

           SET X=$SELECT($EXTRACT($PIECE(IBPR,"^"),1,5)'<29712:1,1:2)

           SET IBPRDT=$ORDER(^IBE(354.3,"AIVDT",X,-($PIECE(IBPR,"^"))))

 +6       ; minus a negative to make positive

           IF IBPRDT<0

               SET IBPRDT=-IBPRDT

 +7        if IBPRDT=""

               GOTO PRIORQ

           IF '$DATA(^IBA(354.1,"APRIOR",IBPRDT))

               GOTO PRIORQ

 +8       ;

 +9       ; -- is exemptions based on prior thresholds

 +10       WRITE !!,"There are Medication Copayment Exemptions based on prior thresholds",!

 +11       SET DIR("?")="There are exemptions that were based on the threshold values over a year old.  You can ignore this, print a list of patients with old exemptions, or automatically update while printing the same list"

 +12       SET DIR(0)="S^1:IGNORE;2:PRINT;3:UPDATE AND PRINT"

           SET DIR("A")="Select ACTION"

           SET DIR("B")="IGNORE"

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)!(Y<2)!(Y>3)

               GOTO PRIORQ

 +13       SET IBACT=Y

 +14      ;

 +15       SET %ZIS="QM"

           DO ^%ZIS

           if POP

               GOTO PRIORQ

 +16       IF $DATA(IO("Q"))

               KILL IO("Q")

               SET ZTRTN="DQ^IBARXET"

               SET ZTDESC="IB PRIOR YEAR THRESHOLD PRINT"_$SELECT(IBACT=3:" AND UPDATE",1:"")

               SET ZTSAVE("IB*")=""

               DO ^%ZTLOAD

               KILL ZTSK

               DO HOME^%ZIS

               GOTO PRIORQ

 +17       USE IO

 +18      ;

DQ        ; -- entry point from tasking

 +1        SET (IBQUIT,IBPAG)=0

           DO NOW^%DTC

           SET Y=%

           DO D^DIQ

           SET IBPDAT=Y

 +2        KILL ^TMP($JOB,"IBPRIOR")

           SET IBJOB=17

 +3        DO HDR

 +4        SET IBEX=""

 +5        FOR

               SET IBEX=$ORDER(^IBA(354.1,"APRIOR",IBPRDT,IBEX))

               if IBEX=""

                   QUIT

               DO SET

 +6       ;

 +7        SET IBNAM=""

 +8        FOR

               SET IBNAM=$ORDER(^TMP($JOB,"IBPRIOR",IBNAM))

               if IBNAM=""!IBQUIT

                   QUIT

               Begin DoDot:1

 +9                SET DFN=""

FOR

                       SET DFN=$ORDER(^TMP($JOB,"IBPRIOR",IBNAM,DFN))

                       if DFN=""!IBQUIT

                           QUIT

                       Begin DoDot:2

 +10                       SET IBXXX=0

FOR

                               SET IBXXX=$ORDER(^TMP($JOB,"IBPRIOR",IBNAM,DFN,IBXXX))

                               if 'IBXXX!IBQUIT

                                   QUIT

                               SET IBP=^(IBXXX)

                               DO ONE

                       End DoDot:2

               End DoDot:1

 +11      ;

 +12       IF 'IBQUIT

               DO PAUSE^IBOUTL

 +13       KILL ^TMP($JOB,"IBPRIOR")

 +14       IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

               QUIT

 +15       DO ^%ZISC

PRIORQ     KILL X,Y,DFN,DIR,DIRUT,IBACT,IBPR,IBPRDT,IBQUIT,IBPAG,IBPDAT,IBPRIOR

 +1        KILL IBEX,IBNAM,IBND,IBP,IBEXREA,IBJOB,IBQUIT,IBXXX,IBWHER,IBEXERR,IBADDE,IBADD,IBCODA,IBCODP

 +2        QUIT

 +3       ;

HDR       ; -- print prior threshold header

 +1        IF IBPAG!($EXTRACT(IOST,1,2)="C-")

               WRITE @IOF,*13

 +2        SET IBPAG=IBPAG+1

 +3        WRITE "Exemptions Based on Prior Year Thresholds",?(IOM-35),$PIECE(IBPDAT,"@")," @ ",$PIECE(IBPDAT,"@",2)," Page ",IBPAG

 +4        WRITE !,"Patient",?22,"PT. ID",?36,"Exemption Date",?52,"Status"

           if IBACT=3

               WRITE ?63,"Action"

 +5        WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")

 +6        QUIT

 +7       ;

SET       ; -- set up sortable array by patient

 +1        SET IBND=$GET(^IBA(354.1,IBEX,0))

           if IBND=""

               QUIT

 +2        SET DFN=$PIECE(IBND,"^",2)

           SET IBP=$$PT^IBEFUNC(DFN)

 +3        SET ^TMP($JOB,"IBPRIOR",$PIECE(IBP,"^"),DFN,IBEX)=IBEX_"^"_IBP

 +4        QUIT

 +5       ;

ONE       ; -- print line for one patient

 +1        SET IBEX=+IBP

           SET IBP=$PIECE(IBP,"^",2,5)

 +2        IF $Y>(IOSL-5)

               DO PAUSE^IBOUTL

               if IBQUIT

                   GOTO ONEQ

               DO HDR

 +3        SET IBND=$GET(^IBA(354.1,IBEX,0))

           if IBND=""

               GOTO ONEQ

 +4        SET Y=+IBND

           DO D^DIQ

 +5        WRITE !,$EXTRACT(IBNAM,1,20),?22,$PIECE(IBP,"^",2),?36,Y,?52,$$TEXT^IBARXEU0($PIECE(IBND,"^",4))

 +6       ;

 +7       ; -- compute exempt, add if different, else delete prior

 +8        if IBACT'=3

               GOTO ONEQ

 +9        SET IBEXREA=$$STATUS^IBARXEU1(DFN,+IBND)

 +10       IF +IBEXREA'=$PIECE(IBND,"^",5)

               DO ADDEX^IBAUTL6(+IBEXREA,+IBND,1,1)

               WRITE ?63,"Exemption updated"

 +11       IF +IBEXREA=$PIECE(IBND,"^",5)

               SET DA=IBEX

               SET DIE="^IBA(354.1,"

               SET DR=".15///@"

               DO ^DIE

               WRITE ?63,"No Change"

 +12       KILL DIE,DA,DR,DIC

ONEQ       QUIT

IBARXET.m