IBAMTED1 ;ALB/AAS - MEANS TEST EVENT DRIVER - EXEMPTION PROCESSING ; 18-DEC-92
;;2.0;INTEGRATED BILLING;**15,112,153,385**;21-MAR-94;Build 35
;;Per VHA Directive 2004-038, this routine should not be modified.
;
EN N IBAD,IBADDE,IBADD,IBDT,IBEXREA,IBAUTO,IBAX,IBAX1,IBOLDAUT,IBWHER,IBEXERR,IBJOB,IBON
N IBAFY,IBATYP,IBBDT,IBCANDT,IBCHRG,IBCODA,IBCODP,IBCRES,IBDEPEN,IBFAC,IBIL,IBL,IBAST,IBLDT,IBN,IBND,IBNN,IBNOW,IBPARNT,IBPARNT1,IBSEQNO,IBSITE,IBUNIT
N DA,DR,DIC,DIE,I,J,X,Y,X1
;
S IBON=$$ON^IBARXEU0 I IBON<1 G ENQ
S IBJOB=12,IBWHER=13
;
; -- quit if nothing different (except completion date)
Q:'$D(DGMTA)!('$D(DGMTP))
I $P(DGMTA,"^",1,5)=$P(DGMTP,"^",1,5),$P(DGMTA,"^",10,20)=$P(DGMTP,"^",10,20) Q
I DGMTA]"",DGMTP]"",DGMTACT="DEL" Q ; IVM 'delete' transmission
;
; -- quit if invoked from ib=>mt=>ib
Q:$D(IBEVT)
;
; -- quit if before start date
I +DGMTA G ENQ:+$$PLUS^IBARXEU0(+DGMTA)<$$STDATE^IBARXEU
I +DGMTP G ENQ:+$$PLUS^IBARXEU0(+DGMTP)<$$STDATE^IBARXEU
;
;
I '$D(ZTQUEUED),$D(IBTALK) W !,"Determining Medication Co-Payment Exemption"
;
; -- if no patient add patient
I '+$G(^IBA(354,DFN,0)) D ADDP^IBAUTL6 I $G(IBEXERR) G ENQ
;
D AUTO I IBAUTO'="" G ENQ
;
; -- not auto exempt any more see if is more current auto status
S X=$$LSTAC^IBARXEU0(DFN) I $L(+X)=2,$P(X,"^",2)>+DGMTA S IBOLDAUT=$P(X,"^",2)
; -- if mean test is required or no longer required
; or copay test is incomplete or no longer applicable
; add exemption of no income data
S X=$P(DGMTA,"^",3) I X=1!(X=3)!(X=10)!(X=9)!($P(DGMTA,"^",14)) D AEX G ENQ
;
I "^ADD^DEL^EDT^ADJ^STA^CAT^COM^UPL^DUP^"[DGMTACT D @DGMTACT
;
ENQ ; -- exit copay exemption creation
I $G(IBEXERR) D ^IBAERR
I $D(IBADDE),$D(IBTALK) W !!,"Medication Copayment Exemption Status Updated: ",$P(^IBE(354.2,+IBADDE,0),"^")," ",$$DAT1^IBOUTL($P(IBADDE,"^",2))
Q
;
ADD ; -- adding a new test
I DGMTACT="ADD" D AEX
;
ADDQ Q
;
AEX ; -- add exemption logic
; DO NOT USER FOR AUTOMATICS
;
S IBEXREA=""
;
; -- if means test required, no longer required,
; or copay test incomplete or no longer applicable
; set up no income data exemption if not automatic.
;
S X=$P(DGMTA,"^",3) I X=1!(X=3)!(X=10)!(X=9)!($P(DGMTA,"^",14)) S IBEXREA=$O(^IBE(354.2,"ACODE",$S($P(DGMTA,"^",14):110,1:210),0))
;
;
I $$NETW^IBARXEU1,'IBEXREA S IBEXREA=+$$MTCOMP^IBARXEU5($$INCDT^IBARXEU1(DGMTA),DGMTA)
I '$$NETW^IBARXEU1,'IBEXREA S IBEXREA=+$P($$INCDT^IBARXEU1(DGMTA),"^",3)
;
; -- make sure more recent exemption than current test date is inactivetd
D MOSTR^IBARXEU5(+DGMTA,+IBEXREA)
D ADDEX^IBAUTL6(+IBEXREA,+DGMTA,1,1,$G(IBOLDAUT))
Q
;
UPL ; -- uploading an IVM-verified means test
DUP ; -- deleting an IVM-verified means test
EDT ; -- editing an old means test
; if data different attempt to add new test
I DGMTA=DGMTP G EDITQ
D AEX
EDITQ Q
;
DEL ; -- means test deleted
; find exemption for date and inactivate
; update current exemption status
;
N IBFORCE,IBVFAOK
Q:'$D(^IBA(354.1,"AIVDT",1,DFN,-DGMTP))
S IBFORCE=+DGMTP ; force inactivate entries for deleted date
;
S IBEXREA=$$STATUS^IBARXEU1(DFN,+DGMTP),IBSTAT=$P($G(^IBE(354.2,+IBEXREA,0)),"^",4)
;
; -- look up VFA status
S IBVFAOK=$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,$P(IBEXREA,"^",2)))
;
; -- cancel prior exemption with a no data exemption if last date older than 1 year, only if it is not VFA OK.
I $$PLUS^IBARXEU0($P(IBEXREA,"^",2))<DT,'IBVFAOK D ADDEX^IBAUTL6(+$O(^IBE(354.2,"ACODE",210,0)),+DGMTP) G DELQ
;
; -- add correct exemption and update current status
D ADDEX^IBAUTL6(+IBEXREA,+$P(IBEXREA,"^",2))
DELQ Q
;
COM ; -- complete a required means test
CAT ; -- category change
STA ; -- status change
ADJ ; -- means test adjudication
;
S IBAX1=$$CODE(DGMTP),IBAX=$$CODE(DGMTA)
;
I $$NETW^IBARXEU1,IBAX1="P",IBAX'="P" D G ADJQ ;treat as an adjudication
.I $P(DGMTA,"^",19)=1 S IBEXREA=$S(IBAX="C":140,IBAX="A":150,1:"") ; means test codes
.I $P(DGMTA,"^",19)=2 S IBEXREA=$S(IBAX="N":140,IBAX="E":150,1:"") ; copay exemption test
.S IBEXREA=$O(^IBE(354.2,"ACODE",+IBEXREA,0))
.Q:'$G(IBEXREA)
.D ADDEX^IBAUTL6(IBEXREA,+DGMTA,1,1)
.Q
;
;I $P(DGMTA,"^",19)=1,IBAX1="C",IBAX="A" D ADDEX^IBAUTL6($O(^IBE(354.2,"ACODE",2010,0)),+DGMTA) G ADJQ ;is a means test hardship
;
I $P(DGMTA,"^",19)=2,IBAX1="N",IBAX="E" D ADDEX^IBAUTL6($O(^IBE(354.2,"ACODE",2010,0)),+DGMTA) G ADJQ ;is income test hardship
;
D AEX
;
ADJQ Q
;
CODE(TEST) ; -- return means test status
I '$G(TEST) S TEST=""
Q $P($G(^DG(408.32,+$P(TEST,"^",3),0)),"^",2)
;
AUTO ; -- if auto status patient
; add auto exemption if needed
S IBDT=$S(+DGMTA:+DGMTA,+DGMTP:+DGMTP,1:"")
S IBAUTO=$$AUTOST^IBARXEU1(DFN,IBDT) I IBAUTO'="" D G AUTOQ
.S X=$$RXST^IBARXEU(DFN,IBDT)
.I X=""!($$PLUS^IBARXEU0($P(X,"^",5))<DT) S IBAD=1 D ADDEX^IBAUTL6(+IBAUTO,DT) Q ; add exemption if none or old
.I $P(X,"^",3)'=$P($G(^IBE(354.2,+IBAUTO,0)),"^",5) S IBAD=1 D ADDEX^IBAUTL6(+IBAUTO,IBDT) Q ; if computes different add new exemption
;
AUTOQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAMTED1 5140 printed Sep 23, 2025@19:42:48 Page 2
IBAMTED1 ;ALB/AAS - MEANS TEST EVENT DRIVER - EXEMPTION PROCESSING ; 18-DEC-92
+1 ;;2.0;INTEGRATED BILLING;**15,112,153,385**;21-MAR-94;Build 35
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN NEW IBAD,IBADDE,IBADD,IBDT,IBEXREA,IBAUTO,IBAX,IBAX1,IBOLDAUT,IBWHER,IBEXERR,IBJOB,IBON
+1 NEW IBAFY,IBATYP,IBBDT,IBCANDT,IBCHRG,IBCODA,IBCODP,IBCRES,IBDEPEN,IBFAC,IBIL,IBL,IBAST,IBLDT,IBN,IBND,IBNN,IBNOW,IBPARNT,IBPARNT1,IBSEQNO,IBSITE,IBUNIT
+2 NEW DA,DR,DIC,DIE,I,J,X,Y,X1
+3 ;
+4 SET IBON=$$ON^IBARXEU0
IF IBON<1
GOTO ENQ
+5 SET IBJOB=12
SET IBWHER=13
+6 ;
+7 ; -- quit if nothing different (except completion date)
+8 if '$DATA(DGMTA)!('$DATA(DGMTP))
QUIT
+9 IF $PIECE(DGMTA,"^",1,5)=$PIECE(DGMTP,"^",1,5)
IF $PIECE(DGMTA,"^",10,20)=$PIECE(DGMTP,"^",10,20)
QUIT
+10 ; IVM 'delete' transmission
IF DGMTA]""
IF DGMTP]""
IF DGMTACT="DEL"
QUIT
+11 ;
+12 ; -- quit if invoked from ib=>mt=>ib
+13 if $DATA(IBEVT)
QUIT
+14 ;
+15 ; -- quit if before start date
+16 IF +DGMTA
if +$$PLUS^IBARXEU0(+DGMTA)<$$STDATE^IBARXEU
GOTO ENQ
+17 IF +DGMTP
if +$$PLUS^IBARXEU0(+DGMTP)<$$STDATE^IBARXEU
GOTO ENQ
+18 ;
+19 ;
+20 IF '$DATA(ZTQUEUED)
IF $DATA(IBTALK)
WRITE !,"Determining Medication Co-Payment Exemption"
+21 ;
+22 ; -- if no patient add patient
+23 IF '+$GET(^IBA(354,DFN,0))
DO ADDP^IBAUTL6
IF $GET(IBEXERR)
GOTO ENQ
+24 ;
+25 DO AUTO
IF IBAUTO'=""
GOTO ENQ
+26 ;
+27 ; -- not auto exempt any more see if is more current auto status
+28 SET X=$$LSTAC^IBARXEU0(DFN)
IF $LENGTH(+X)=2
IF $PIECE(X,"^",2)>+DGMTA
SET IBOLDAUT=$PIECE(X,"^",2)
+29 ; -- if mean test is required or no longer required
+30 ; or copay test is incomplete or no longer applicable
+31 ; add exemption of no income data
+32 SET X=$PIECE(DGMTA,"^",3)
IF X=1!(X=3)!(X=10)!(X=9)!($PIECE(DGMTA,"^",14))
DO AEX
GOTO ENQ
+33 ;
+34 IF "^ADD^DEL^EDT^ADJ^STA^CAT^COM^UPL^DUP^"[DGMTACT
DO @DGMTACT
+35 ;
ENQ ; -- exit copay exemption creation
+1 IF $GET(IBEXERR)
DO ^IBAERR
+2 IF $DATA(IBADDE)
IF $DATA(IBTALK)
WRITE !!,"Medication Copayment Exemption Status Updated: ",$PIECE(^IBE(354.2,+IBADDE,0),"^")," ",$$DAT1^IBOUTL($PIECE(IBADDE,"^",2))
+3 QUIT
+4 ;
ADD ; -- adding a new test
+1 IF DGMTACT="ADD"
DO AEX
+2 ;
ADDQ QUIT
+1 ;
AEX ; -- add exemption logic
+1 ; DO NOT USER FOR AUTOMATICS
+2 ;
+3 SET IBEXREA=""
+4 ;
+5 ; -- if means test required, no longer required,
+6 ; or copay test incomplete or no longer applicable
+7 ; set up no income data exemption if not automatic.
+8 ;
+9 SET X=$PIECE(DGMTA,"^",3)
IF X=1!(X=3)!(X=10)!(X=9)!($PIECE(DGMTA,"^",14))
SET IBEXREA=$ORDER(^IBE(354.2,"ACODE",$SELECT($PIECE(DGMTA,"^",14):110,1:210),0))
+10 ;
+11 ;
+12 IF $$NETW^IBARXEU1
IF 'IBEXREA
SET IBEXREA=+$$MTCOMP^IBARXEU5($$INCDT^IBARXEU1(DGMTA),DGMTA)
+13 IF '$$NETW^IBARXEU1
IF 'IBEXREA
SET IBEXREA=+$PIECE($$INCDT^IBARXEU1(DGMTA),"^",3)
+14 ;
+15 ; -- make sure more recent exemption than current test date is inactivetd
+16 DO MOSTR^IBARXEU5(+DGMTA,+IBEXREA)
+17 DO ADDEX^IBAUTL6(+IBEXREA,+DGMTA,1,1,$GET(IBOLDAUT))
+18 QUIT
+19 ;
UPL ; -- uploading an IVM-verified means test
DUP ; -- deleting an IVM-verified means test
EDT ; -- editing an old means test
+1 ; if data different attempt to add new test
+2 IF DGMTA=DGMTP
GOTO EDITQ
+3 DO AEX
EDITQ QUIT
+1 ;
DEL ; -- means test deleted
+1 ; find exemption for date and inactivate
+2 ; update current exemption status
+3 ;
+4 NEW IBFORCE,IBVFAOK
+5 if '$DATA(^IBA(354.1,"AIVDT",1,DFN,-DGMTP))
QUIT
+6 ; force inactivate entries for deleted date
SET IBFORCE=+DGMTP
+7 ;
+8 SET IBEXREA=$$STATUS^IBARXEU1(DFN,+DGMTP)
SET IBSTAT=$PIECE($GET(^IBE(354.2,+IBEXREA,0)),"^",4)
+9 ;
+10 ; -- look up VFA status
+11 SET IBVFAOK=$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,$PIECE(IBEXREA,"^",2)))
+12 ;
+13 ; -- cancel prior exemption with a no data exemption if last date older than 1 year, only if it is not VFA OK.
+14 IF $$PLUS^IBARXEU0($PIECE(IBEXREA,"^",2))<DT
IF 'IBVFAOK
DO ADDEX^IBAUTL6(+$ORDER(^IBE(354.2,"ACODE",210,0)),+DGMTP)
GOTO DELQ
+15 ;
+16 ; -- add correct exemption and update current status
+17 DO ADDEX^IBAUTL6(+IBEXREA,+$PIECE(IBEXREA,"^",2))
DELQ QUIT
+1 ;
COM ; -- complete a required means test
CAT ; -- category change
STA ; -- status change
ADJ ; -- means test adjudication
+1 ;
+2 SET IBAX1=$$CODE(DGMTP)
SET IBAX=$$CODE(DGMTA)
+3 ;
+4 ;treat as an adjudication
IF $$NETW^IBARXEU1
IF IBAX1="P"
IF IBAX'="P"
Begin DoDot:1
+5 ; means test codes
IF $PIECE(DGMTA,"^",19)=1
SET IBEXREA=$SELECT(IBAX="C":140,IBAX="A":150,1:"")
+6 ; copay exemption test
IF $PIECE(DGMTA,"^",19)=2
SET IBEXREA=$SELECT(IBAX="N":140,IBAX="E":150,1:"")
+7 SET IBEXREA=$ORDER(^IBE(354.2,"ACODE",+IBEXREA,0))
+8 if '$GET(IBEXREA)
QUIT
+9 DO ADDEX^IBAUTL6(IBEXREA,+DGMTA,1,1)
+10 QUIT
End DoDot:1
GOTO ADJQ
+11 ;
+12 ;I $P(DGMTA,"^",19)=1,IBAX1="C",IBAX="A" D ADDEX^IBAUTL6($O(^IBE(354.2,"ACODE",2010,0)),+DGMTA) G ADJQ ;is a means test hardship
+13 ;
+14 ;is income test hardship
IF $PIECE(DGMTA,"^",19)=2
IF IBAX1="N"
IF IBAX="E"
DO ADDEX^IBAUTL6($ORDER(^IBE(354.2,"ACODE",2010,0)),+DGMTA)
GOTO ADJQ
+15 ;
+16 DO AEX
+17 ;
ADJQ QUIT
+1 ;
CODE(TEST) ; -- return means test status
+1 IF '$GET(TEST)
SET TEST=""
+2 QUIT $PIECE($GET(^DG(408.32,+$PIECE(TEST,"^",3),0)),"^",2)
+3 ;
AUTO ; -- if auto status patient
+1 ; add auto exemption if needed
+2 SET IBDT=$SELECT(+DGMTA:+DGMTA,+DGMTP:+DGMTP,1:"")
+3 SET IBAUTO=$$AUTOST^IBARXEU1(DFN,IBDT)
IF IBAUTO'=""
Begin DoDot:1
+4 SET X=$$RXST^IBARXEU(DFN,IBDT)
+5 ; add exemption if none or old
IF X=""!($$PLUS^IBARXEU0($PIECE(X,"^",5))<DT)
SET IBAD=1
DO ADDEX^IBAUTL6(+IBAUTO,DT)
QUIT
+6 ; if computes different add new exemption
IF $PIECE(X,"^",3)'=$PIECE($GET(^IBE(354.2,+IBAUTO,0)),"^",5)
SET IBAD=1
DO ADDEX^IBAUTL6(+IBAUTO,IBDT)
QUIT
End DoDot:1
GOTO AUTOQ
+7 ;
AUTOQ QUIT
