IBAMTED2 ;ALB/GN - RX COPAY TEST EVENT DRIVER - Z06 EXEMPTION PROCESSING ; 6/5/04 2:32pm
;;2.0;INTEGRATED BILLING;**269,385**;21-MAR-94;Build 35
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;IB*2*269 add this new API to handle updating IVM converted RX Copay
; Tests via Z06 transmissions.
;
;
EN N IBAD,IBADDE,IBADD,IBDT,IBEXREA,IBAUTO,IBAX,IBAX1,IBOLDAUT,IBWHER
N IBEXERR,IBJOB,IBON,IBAFY,IBATYP,IBBDT,IBCANDT,IBCHRG,IBCODA,IBCODP
N IBCRES,IBDEPEN,IBFAC,IBIL,IBL,IBAST,IBLDT,IBN,IBND,IBNN,IBNOW
N IBPARNT,IBPARNT1,IBSEQNO,IBSITE,IBUNIT
N DA,DR,DIC,DIE,I,J,X,Y,X1
;
;
;check if add and/or delete of a Z06 was performed by ^EASPREC7
I DGMTACT="UPL",+DGMTA,'$G(EASZ06D) D ADD
I DGMTACT="DEL",+DGMTP,$G(EASZ06D) D DEL
Q
;
ADD ;quit if before start date
Q:+$$PLUS^IBARXEU0(+DGMTA)<$$STDATE^IBARXEU
;
;if no patient add patient
I '+$G(^IBA(354,DFN,0)) D ADDP^IBAUTL6 I $G(IBEXERR) D ^IBAERR Q
;
;see if last reason is auto type and save date, used by ADDEX tag
N IB0 S IB0=$$LSTAC^IBARXEU0(DFN)
I $L(+IB0)=2,$P(IB0,"^",2)>+DGMTA S IBOLDAUT=$P(IB0,"^",2)
;
;set IVM converted case to reason: Income>Threshold (Not Exempt)
S IBEXREA=$O(^IBE(354.2,"ACODE",110,0))
;
;inactivate most recent exemption test
D MOSTR^IBARXEU5(+DGMTA,+IBEXREA)
;
;add new IVM converted test
D ADDEX^IBAUTL6(+IBEXREA,+DGMTA,1,1,$G(IBOLDAUT))
;
Q
;
DEL ; Converted Copay test deleted. Now inactivate that exemption for
; that date & update current exemption status for this date
;
;force inactivate entries for deleted date
N IBFORCE
Q:'$D(^IBA(354.1,"AIVDT",1,DFN,-DGMTP))
S IBFORCE=+DGMTP
;
;test in DGMT(408.31) has been deleted at this point, now get
;the last test that remains on file in order to activate it
S IBEXREA=$$STATUS^IBARXEU1(DFN,+DGMTP)
S IBSTAT=$P($G(^IBE(354.2,+IBEXREA,0)),"^",4)
;
;if last date is older than 1 year, then cancel prior exemption
; --- only if test is also not VFA ok
;cancel prior exemption with a no exemption
I $$PLUS^IBARXEU0($P(IBEXREA,"^",2))<DT,'$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,$P(IBEXREA,"^",2))) D Q
. D ADDEX^IBAUTL6(+$O(^IBE(354.2,"ACODE",210,0)),+DGMTP)
;
;else, add correct exemption and update current status
D ADDEX^IBAUTL6(+IBEXREA,+$P(IBEXREA,"^",2))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAMTED2 2336 printed Oct 16, 2024@18:07:16 Page 2
IBAMTED2 ;ALB/GN - RX COPAY TEST EVENT DRIVER - Z06 EXEMPTION PROCESSING ; 6/5/04 2:32pm
+1 ;;2.0;INTEGRATED BILLING;**269,385**;21-MAR-94;Build 35
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;IB*2*269 add this new API to handle updating IVM converted RX Copay
+5 ; Tests via Z06 transmissions.
+6 ;
+7 ;
EN NEW IBAD,IBADDE,IBADD,IBDT,IBEXREA,IBAUTO,IBAX,IBAX1,IBOLDAUT,IBWHER
+1 NEW IBEXERR,IBJOB,IBON,IBAFY,IBATYP,IBBDT,IBCANDT,IBCHRG,IBCODA,IBCODP
+2 NEW IBCRES,IBDEPEN,IBFAC,IBIL,IBL,IBAST,IBLDT,IBN,IBND,IBNN,IBNOW
+3 NEW IBPARNT,IBPARNT1,IBSEQNO,IBSITE,IBUNIT
+4 NEW DA,DR,DIC,DIE,I,J,X,Y,X1
+5 ;
+6 ;
+7 ;check if add and/or delete of a Z06 was performed by ^EASPREC7
+8 IF DGMTACT="UPL"
IF +DGMTA
IF '$GET(EASZ06D)
DO ADD
+9 IF DGMTACT="DEL"
IF +DGMTP
IF $GET(EASZ06D)
DO DEL
+10 QUIT
+11 ;
ADD ;quit if before start date
+1 if +$$PLUS^IBARXEU0(+DGMTA)<$$STDATE^IBARXEU
QUIT
+2 ;
+3 ;if no patient add patient
+4 IF '+$GET(^IBA(354,DFN,0))
DO ADDP^IBAUTL6
IF $GET(IBEXERR)
DO ^IBAERR
QUIT
+5 ;
+6 ;see if last reason is auto type and save date, used by ADDEX tag
+7 NEW IB0
SET IB0=$$LSTAC^IBARXEU0(DFN)
+8 IF $LENGTH(+IB0)=2
IF $PIECE(IB0,"^",2)>+DGMTA
SET IBOLDAUT=$PIECE(IB0,"^",2)
+9 ;
+10 ;set IVM converted case to reason: Income>Threshold (Not Exempt)
+11 SET IBEXREA=$ORDER(^IBE(354.2,"ACODE",110,0))
+12 ;
+13 ;inactivate most recent exemption test
+14 DO MOSTR^IBARXEU5(+DGMTA,+IBEXREA)
+15 ;
+16 ;add new IVM converted test
+17 DO ADDEX^IBAUTL6(+IBEXREA,+DGMTA,1,1,$GET(IBOLDAUT))
+18 ;
+19 QUIT
+20 ;
DEL ; Converted Copay test deleted. Now inactivate that exemption for
+1 ; that date & update current exemption status for this date
+2 ;
+3 ;force inactivate entries for deleted date
+4 NEW IBFORCE
+5 if '$DATA(^IBA(354.1,"AIVDT",1,DFN,-DGMTP))
QUIT
+6 SET IBFORCE=+DGMTP
+7 ;
+8 ;test in DGMT(408.31) has been deleted at this point, now get
+9 ;the last test that remains on file in order to activate it
+10 SET IBEXREA=$$STATUS^IBARXEU1(DFN,+DGMTP)
+11 SET IBSTAT=$PIECE($GET(^IBE(354.2,+IBEXREA,0)),"^",4)
+12 ;
+13 ;if last date is older than 1 year, then cancel prior exemption
+14 ; --- only if test is also not VFA ok
+15 ;cancel prior exemption with a no exemption
+16 IF $$PLUS^IBARXEU0($PIECE(IBEXREA,"^",2))<DT
IF '$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,$PIECE(IBEXREA,"^",2)))
Begin DoDot:1
+17 DO ADDEX^IBAUTL6(+$ORDER(^IBE(354.2,"ACODE",210,0)),+DGMTP)
End DoDot:1
QUIT
+18 ;
+19 ;else, add correct exemption and update current status
+20 DO ADDEX^IBAUTL6(+IBEXREA,+$PIECE(IBEXREA,"^",2))
+21 QUIT
