IBAUTL7 ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE (CONT.) ; 2-NOV-92
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
CURREX(IBSTAT,IBDT) ;update current status if current year
; input : dfn = patient file pointer
; ibdt = internal form of effective date
; ibstat = status = 1 if exempt, 0 if not exempt
;
N X,Y,DIC,DIE,DR,DA
I $S('$D(DFN):1,'$D(IBSTAT):1,IBSTAT=0:0,IBSTAT=1:0,1:1) G CURREXQ
;
; -- make sure ibdt > old current date
S X=+$P($G(^IBA(354,DFN,0)),"^",3)
I '$G(IBFORCE),$G(IBOLDAUT)'?7N,X>IBDT G CURREXQ ;only if most recent (I took this out for awhile but don't know why, its needed to keep from updating old over new)
;
; -- not greater than today
;I IBDT>DT G CURREXQ
;
S DIE="^IBA(354,",DA=DFN,DR="[IB CURRENT STATUS]" D ^DIE ; set status in billing patient file
I $D(Y) S IBEXERR=6,IBWHER=14
;DR=".04////"_IBSTAT_";.03////"_IBDT_";.05////"_IBEXREA
;
CURREXQ Q
;
INACT(IBDT) ; -- must inactivate active exemptions before creating new exemption
; should only be called from addex so event driver logic works
;
N IBX,X,Y,DA,DR,DIE,DIC
S IBX=0 F S IBX=$O(^IBA(354.1,"AIVDT",1,DFN,-IBDT,IBX)) Q:'IBX D
.S DA=IBX
.I $P($G(^IBA(354.1,DA,0)),"^",10)'=1 Q
.I '$D(ZTQUEUED),$D(IBTALK) W:IBTALK<2 !,"Deleting Active flag from current entry" S IBTALK=IBTALK+1
.S DA=IBX,DIE="^IBA(354.1,",DR="[IB INACTIVATE EXEMPTION]" D ^DIE K DIC,DIE,DA,DR
.I $D(Y) S IBEXERR=7,IBWHER=15
.;S IBACTION="CHG"
.Q
INACTQ Q
;
DUPL() ; -- see if entry is a duplicate
N X,Y
S X=0
S Y=$$LST^IBARXEU0(DFN,IBDT)
I IBDT=+Y,+IBEXREA=+$P(Y,"^",5),IBTYPE=$P(Y,"^",3) S X=1
Q X
;
;
ALERT() ; -- use alerts or bulletins
; returns 1 = use alerts
; 0 = use bulletins
;
Q $P($G(^IBE(350.9,1,0)),"^",14)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAUTL7 1889 printed Apr 09, 2024@21:24:31 Page 2
IBAUTL7 ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE (CONT.) ; 2-NOV-92
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
CURREX(IBSTAT,IBDT) ;update current status if current year
+1 ; input : dfn = patient file pointer
+2 ; ibdt = internal form of effective date
+3 ; ibstat = status = 1 if exempt, 0 if not exempt
+4 ;
+5 NEW X,Y,DIC,DIE,DR,DA
+6 IF $SELECT('$DATA(DFN):1,'$DATA(IBSTAT):1,IBSTAT=0:0,IBSTAT=1:0,1:1)
GOTO CURREXQ
+7 ;
+8 ; -- make sure ibdt > old current date
+9 SET X=+$PIECE($GET(^IBA(354,DFN,0)),"^",3)
+10 ;only if most recent (I took this out for awhile but don't know why, its needed to keep from updating old over new)
IF '$GET(IBFORCE)
IF $GET(IBOLDAUT)'?7N
IF X>IBDT
GOTO CURREXQ
+11 ;
+12 ; -- not greater than today
+13 ;I IBDT>DT G CURREXQ
+14 ;
+15 ; set status in billing patient file
SET DIE="^IBA(354,"
SET DA=DFN
SET DR="[IB CURRENT STATUS]"
DO ^DIE
+16 IF $DATA(Y)
SET IBEXERR=6
SET IBWHER=14
+17 ;DR=".04////"_IBSTAT_";.03////"_IBDT_";.05////"_IBEXREA
+18 ;
CURREXQ QUIT
+1 ;
INACT(IBDT) ; -- must inactivate active exemptions before creating new exemption
+1 ; should only be called from addex so event driver logic works
+2 ;
+3 NEW IBX,X,Y,DA,DR,DIE,DIC
+4 SET IBX=0
FOR
SET IBX=$ORDER(^IBA(354.1,"AIVDT",1,DFN,-IBDT,IBX))
if 'IBX
QUIT
Begin DoDot:1
+5 SET DA=IBX
+6 IF $PIECE($GET(^IBA(354.1,DA,0)),"^",10)'=1
QUIT
+7 IF '$DATA(ZTQUEUED)
IF $DATA(IBTALK)
if IBTALK<2
WRITE !,"Deleting Active flag from current entry"
SET IBTALK=IBTALK+1
+8 SET DA=IBX
SET DIE="^IBA(354.1,"
SET DR="[IB INACTIVATE EXEMPTION]"
DO ^DIE
KILL DIC,DIE,DA,DR
+9 IF $DATA(Y)
SET IBEXERR=7
SET IBWHER=15
+10 ;S IBACTION="CHG"
+11 QUIT
End DoDot:1
INACTQ QUIT
+1 ;
DUPL() ; -- see if entry is a duplicate
+1 NEW X,Y
+2 SET X=0
+3 SET Y=$$LST^IBARXEU0(DFN,IBDT)
+4 IF IBDT=+Y
IF +IBEXREA=+$PIECE(Y,"^",5)
IF IBTYPE=$PIECE(Y,"^",3)
SET X=1
+5 QUIT X
+6 ;
+7 ;
ALERT() ; -- use alerts or bulletins
+1 ; returns 1 = use alerts
+2 ; 0 = use bulletins
+3 ;
+4 QUIT $PIECE($GET(^IBE(350.9,1,0)),"^",14)
