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
Q
;
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
Q
;
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
Q
;
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)," ","-")
Q
;
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
Q
;
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
