Routine: IBARXET

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

	;;Version 2.0 ; INTEGRATED BILLING ;; 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 $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 IBPRDT=$O(^IBE(354.3,"AIVDT",2,-($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

	K ^TMP($J)

	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 ^%ZISC G PRIORQ

	U IO

DQ	; -- entry point from tasking

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

	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=""  S DFN="" F  S DFN=$O(^TMP($J,"IBPRIOR",IBNAM,DFN)) Q:DFN=""  S IBP=^(DFN) D ONE

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

	K X,Y,DFN,DIR,DIRUT,IBACT,IBPR,IBPRDT,IBQUIT,IBPAG,IBPDAT,IBPRIOR,IBEX,IBNAM,IBND,IBP,IBEXREA

HDR	; -- print prior threshold header

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

	S IBPAG=IBPAG+1

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

	W !,"Patient",?22,"PT. ID",?36,"Exemption Date",?52,"Status" W:IBACT=3 ?65,"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_"^"_IBP

ONE	; -- print line for one patient

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

	I $Y>(IOSL-5) 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 ?65,"Exemption updated"

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

	K DIE,DA,DR,DIC

ONEQ	Q

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

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 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        IF $DATA(DA)

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

               SET $PIECE(IBX,"^",2)=2

               Begin DoDot:1

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

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

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

                               QUIT

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

                   DO ^DIK

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

 +8                KILL DA,DIK

 +9                QUIT

               End DoDot:1

 +10      ;

 +11       IF $DATA(DA)#2

               DO PRIOR

 +12       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        IF $PIECE(IBPR,"^",2)'=2

               GOTO PRIORQ

 +3       ;threshold prior to the one entered

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

 +4       ; minus a negative to make positive

           IF IBPRDT<0

               SET IBPRDT=-IBPRDT

 +5        IF IBPRDT=""

               GOTO PRIORQ

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

               GOTO PRIORQ

 +6       ;

 +7       ; -- is exemptions based on prior thresholds

 +8        KILL ^TMP($JOB)

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

 +10       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"

 +11       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

 +12       SET IBACT=Y

 +13      ;

 +14       SET %ZIS="QM"

           DO ^%ZIS

           IF POP

               GOTO PRIORQ

 +15       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 ^%ZISC

               GOTO PRIORQ

 +16       USE IO

 +17      ;

DQ        ; -- entry point from tasking

 +1        SET (IBQUIT,IBPAG)=0

           DO NOW^%DTC

           SET Y=%

           DO D^DIQ

           SET IBPDAT=Y

 +2        DO HDR

 +3        SET IBEX=""

 +4        FOR

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

               IF IBEX=""

                   QUIT

               DO SET

 +5       ;

 +6        SET IBNAM=""

 +7        FOR

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

               IF IBNAM=""

                   QUIT

               SET DFN=""

FOR

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

                   IF DFN=""

                       QUIT

                   SET IBP=^(DFN)

                   DO ONE

 +8       ;

PRIORQ     IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

               QUIT

 +1        KILL X,Y,DFN,DIR,DIRUT,IBACT,IBPR,IBPRDT,IBQUIT,IBPAG,IBPDAT,IBPRIOR,IBEX,IBNAM,IBND,IBP,IBEXREA

 +2        QUIT

 +3       ;

HDR       ; -- print prior threshold header

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

               WRITE @IOF

 +2        SET IBPAG=IBPAG+1

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

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

           IF IBACT=3

               WRITE ?65,"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_"^"_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 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 ?65,"Exemption updated"

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

               SET DA=IBEX

               SET DIE="^IBA(354.1,"

               SET DR=".15///@"

               DO ^DIE

               WRITE ?65,"No Change"

 +12       KILL DIE,DA,DR,DIC

ONEQ       QUIT

IBARXET.m