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
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 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
Q
;
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)," ","-")
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)=IBEX_"^"_IBP
Q
;
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 Nov 22, 2024@17:17:27 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
