IBAUTL6 ;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.
;
ADDP ; -- Add patient to file 354
; -- Input : dfn = entry in patient file
; returns : ibadd = 0 if not added, 1 if added
;
I '$D(DT) D DT^DICRW
S IBWHER=11,IBEXERR=""
S IBADD=0
I $S('$D(DFN):1,'$D(^IBA(354)):1,$D(^IBA(354,DFN)):1,1:0) G ADDPQ
K DO,DD,DIC,DR,DA,DIE S DIC="^IBA(354,",DIC(0)="L",DLAYGO=354
L +^IBA(354,DFN):15 I $T,'$D(^IBA(354,DFN)) S (DINUM,X)=DFN D FILE^DICN I +Y>0 S IBADD=1
I IBADD'=1 S IBEXERR=9
L -^IBA(354,DFN)
;
ADDPQ K DO,DD,DIC,DR,DIE,DA,IBX
Q
;
ADDEX(IBEXREA,IBDT,IBHOW,IBTYPE,IBOLDAUT) ; -- add entry to 354.1 and update
; -- this will become the active entry for this effective date
; other entries for this effective date should be cancelled
; prior to making this call
;
; -- input dfn = pt ien (required)
; ibexrea = pointer to exemption reason file (required)
; ibdt = internal form of effective date (required)
; ibhow = 1=system added, 2=user override (optional) default =1
; ibtype = type of exemption (optional) default =1 (copay)
; iboldaut = date (optional) if defined is the date of a previous exemption status (automatic) that needs to be inactivated
;
; -- returns ibadde = ibexrea^ibdt or null if not added
; iberr = error if occurs else null
;
L +^IBA(354,DFN):30 I '$T S IBEXERR=1 W:$D(IBTALK)&('$D(ZTQUEUED)) !,"ENTRY LOCKED" G ADDEXQ
A1 I '$D(^IBA(354,DFN,0)) D ADDP G ADDEXQ:$G(IBEXERR)
;
N IBDGMTA,IBDGMTP,IBDGMTF
I $D(DGMTA) S IBDGMTA=$G(DGMTA),IBDGMTP=$G(DGMTP),IBDGMTF=$G(DGMTINF)
N X,X1,X2,Y,IBCNT,DGMTA,DGMTP,DGMTINF
I $D(IBDGMTA) S DGMTA=$G(IBDGMTA),DGMTP=$G(IBDGMTP),DGMTINF=$G(IBDGMTF)
S IBWHER=12,IBEXERR="",IBADDE=""
;
; - one last quick check
I IBDT'?7N S IBEXERR=3 G ADDEXQ
I $G(^VA(200,+DUZ,0))="" S IBEXERR=8 G ADDEXQ
;
D BEFORE^IBARXEVT ;get prior exemption
;
N IBSTAT,IBEXDA
S IBSTAT=$P($G(^IBE(354.2,+IBEXREA,0)),"^",4)
S IBHOW=$S('$D(IBHOW):1,IBHOW="":1,IBHOW>2:1,IBHOW<1:1,1:IBHOW)
S IBTYPE=$S('$D(IBTYPE):1,IBTYPE="":1,1:IBTYPE)
;I '$D(IBACTION) S IBACTION="ADD"
;
; -- inactivate a current autoexempt of no longer autoexempt
I $G(IBOLDAUT)?7N D INACT^IBAUTL7(IBOLDAUT) ;I '$D(ZTQUEUED),$D(IBTALK) W !,"Inactivating current non-income based exemption for patient"
;
; -- if forcing a new entry to correct problems
I $G(IBFORCE)?7N D INACT^IBAUTL7(IBFORCE)
;
; -- check for duplicate entry
I $G(IBOLDAUT)'?7N,$G(IBFORCE)'?7N,$$DUPL() W:'$D(ZTQUEUED)&($D(IBTALK)) !,"Exemption Attempting to Add is a duplicate, nothing added!",! G ADDEXQ
;
; -- inactivate previous active entries
D INACT^IBAUTL7(IBDT) I $G(IBEXERR) G ADDEXQ
;
; -- if no income data from conversion set date = start date
I $D(IBCONVER),$P($G(^IBE(354.2,+IBEXREA,0)),"^",5)=210 S IBDT=$$STDATE^IBARXEU
;
; -- add entry
S DIC="^IBA(354.1,",DIC(0)="L",X=IBDT K DO,DD D FILE^DICN
S (IBEXDA,DA)=+Y I Y<1 W:'$D(ZTQUEUED)&($D(IBTALK)) !,"Can't add entry to exemption file" S IBEXERR=4 G ADDEXQ
;
; -- edit new entry
S DIE="^IBA(354.1,",DR="[IB NEW EXEMPTION]" ; use compiled template
;
;DR=".02////"_DFN_";.03////"_IBTYPE_";.04////"_IBSTAT_";.05////"_IBEXREA_";.06////"_IBHOW_";.07////"_DUZ_";.08///NOW;.1////1;.11////"_$G(IBASIG)
;
D ^DIE K DIC,DIE,DA,DR
I $D(Y) S IBEXERR=5 G ADDEXQ
S IBADDE=IBEXREA_"^"_IBDT
;
; --if effective date is in last 365 days make current
I IBDT>$$MINUS^IBARXEU0(DT) D CURREX^IBAUTL7(IBSTAT,IBDT) I $G(IBEXERR) G ADDEXQ
;
I '$D(ZTQUEUED),$G(IBADDE),$D(IBTALK) W !!,"Medication Copayment Exemption Status Updated: ",$P(^IBE(354.2,+IBADDE,0),"^")," ",$$DAT1^IBOUTL($P(IBADDE,"^",2))
; -- setup and call event driver
I '$D(IBCONVER) D ;if not from conversion do following
.D AFTER^IBARXEVT
.S IBEVT=$$RXST^IBARXEU(DFN,$S(IBDT<$$STDATE^IBARXEU:$$STDATE^IBARXEU,1:IBDT))
.D ^IBARXEVT
.I IBSTAT D CANCEL^IBARXEU3 ;exempt patient cancel old charges
.D ^IBARXEB ; process bulletins and alerts
;
ADDEXQ ;
L -^IBA(354,DFN)
I $G(IBEXERR) D ^IBAERR
K DO,DD,DIC,DIE,DA,DR,IBEVT,IBEVTP,IBEVTA,IBASIG
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
IBAUTL6 ;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 ;
ADDP ; -- Add patient to file 354
+1 ; -- Input : dfn = entry in patient file
+2 ; returns : ibadd = 0 if not added, 1 if added
+3 ;
+4 IF '$DATA(DT)
DO DT^DICRW
+5 SET IBWHER=11
SET IBEXERR=""
+6 SET IBADD=0
+7 IF $SELECT('$DATA(DFN):1,'$DATA(^IBA(354)):1,$DATA(^IBA(354,DFN)):1,1:0)
GOTO ADDPQ
+8 KILL DO,DD,DIC,DR,DA,DIE
SET DIC="^IBA(354,"
SET DIC(0)="L"
SET DLAYGO=354
+9 LOCK +^IBA(354,DFN):15
IF $TEST
IF '$DATA(^IBA(354,DFN))
SET (DINUM,X)=DFN
DO FILE^DICN
IF +Y>0
SET IBADD=1
+10 IF IBADD'=1
SET IBEXERR=9
+11 LOCK -^IBA(354,DFN)
+12 ;
ADDPQ KILL DO,DD,DIC,DR,DIE,DA,IBX
+1 QUIT
+2 ;
ADDEX(IBEXREA,IBDT,IBHOW,IBTYPE,IBOLDAUT) ; -- add entry to 354.1 and update
+1 ; -- this will become the active entry for this effective date
+2 ; other entries for this effective date should be cancelled
+3 ; prior to making this call
+4 ;
+5 ; -- input dfn = pt ien (required)
+6 ; ibexrea = pointer to exemption reason file (required)
+7 ; ibdt = internal form of effective date (required)
+8 ; ibhow = 1=system added, 2=user override (optional) default =1
+9 ; ibtype = type of exemption (optional) default =1 (copay)
+10 ; iboldaut = date (optional) if defined is the date of a previous exemption status (automatic) that needs to be inactivated
+11 ;
+12 ; -- returns ibadde = ibexrea^ibdt or null if not added
+13 ; iberr = error if occurs else null
+14 ;
+15 LOCK +^IBA(354,DFN):30
IF '$TEST
SET IBEXERR=1
IF $DATA(IBTALK)&('$DATA(ZTQUEUED))
WRITE !,"ENTRY LOCKED"
GOTO ADDEXQ
A1 IF '$DATA(^IBA(354,DFN,0))
DO ADDP
IF $GET(IBEXERR)
GOTO ADDEXQ
+1 ;
+2 NEW IBDGMTA,IBDGMTP,IBDGMTF
+3 IF $DATA(DGMTA)
SET IBDGMTA=$GET(DGMTA)
SET IBDGMTP=$GET(DGMTP)
SET IBDGMTF=$GET(DGMTINF)
+4 NEW X,X1,X2,Y,IBCNT,DGMTA,DGMTP,DGMTINF
+5 IF $DATA(IBDGMTA)
SET DGMTA=$GET(IBDGMTA)
SET DGMTP=$GET(IBDGMTP)
SET DGMTINF=$GET(IBDGMTF)
+6 SET IBWHER=12
SET IBEXERR=""
SET IBADDE=""
+7 ;
+8 ; - one last quick check
+9 IF IBDT'?7N
SET IBEXERR=3
GOTO ADDEXQ
+10 IF $GET(^VA(200,+DUZ,0))=""
SET IBEXERR=8
GOTO ADDEXQ
+11 ;
+12 ;get prior exemption
DO BEFORE^IBARXEVT
+13 ;
+14 NEW IBSTAT,IBEXDA
+15 SET IBSTAT=$PIECE($GET(^IBE(354.2,+IBEXREA,0)),"^",4)
+16 SET IBHOW=$SELECT('$DATA(IBHOW):1,IBHOW="":1,IBHOW>2:1,IBHOW<1:1,1:IBHOW)
+17 SET IBTYPE=$SELECT('$DATA(IBTYPE):1,IBTYPE="":1,1:IBTYPE)
+18 ;I '$D(IBACTION) S IBACTION="ADD"
+19 ;
+20 ; -- inactivate a current autoexempt of no longer autoexempt
+21 ;I '$D(ZTQUEUED),$D(IBTALK) W !,"Inactivating current non-income based exemption for patient"
IF $GET(IBOLDAUT)?7N
DO INACT^IBAUTL7(IBOLDAUT)
+22 ;
+23 ; -- if forcing a new entry to correct problems
+24 IF $GET(IBFORCE)?7N
DO INACT^IBAUTL7(IBFORCE)
+25 ;
+26 ; -- check for duplicate entry
+27 IF $GET(IBOLDAUT)'?7N
IF $GET(IBFORCE)'?7N
IF $$DUPL()
IF '$DATA(ZTQUEUED)&($DATA(IBTALK))
WRITE !,"Exemption Attempting to Add is a duplicate, nothing added!",!
GOTO ADDEXQ
+28 ;
+29 ; -- inactivate previous active entries
+30 DO INACT^IBAUTL7(IBDT)
IF $GET(IBEXERR)
GOTO ADDEXQ
+31 ;
+32 ; -- if no income data from conversion set date = start date
+33 IF $DATA(IBCONVER)
IF $PIECE($GET(^IBE(354.2,+IBEXREA,0)),"^",5)=210
SET IBDT=$$STDATE^IBARXEU
+34 ;
+35 ; -- add entry
+36 SET DIC="^IBA(354.1,"
SET DIC(0)="L"
SET X=IBDT
KILL DO,DD
DO FILE^DICN
+37 SET (IBEXDA,DA)=+Y
IF Y<1
IF '$DATA(ZTQUEUED)&($DATA(IBTALK))
WRITE !,"Can't add entry to exemption file"
SET IBEXERR=4
GOTO ADDEXQ
+38 ;
+39 ; -- edit new entry
+40 ; use compiled template
SET DIE="^IBA(354.1,"
SET DR="[IB NEW EXEMPTION]"
+41 ;
+42 ;DR=".02////"_DFN_";.03////"_IBTYPE_";.04////"_IBSTAT_";.05////"_IBEXREA_";.06////"_IBHOW_";.07////"_DUZ_";.08///NOW;.1////1;.11////"_$G(IBASIG)
+43 ;
+44 DO ^DIE
KILL DIC,DIE,DA,DR
+45 IF $DATA(Y)
SET IBEXERR=5
GOTO ADDEXQ
+46 SET IBADDE=IBEXREA_"^"_IBDT
+47 ;
+48 ; --if effective date is in last 365 days make current
+49 IF IBDT>$$MINUS^IBARXEU0(DT)
DO CURREX^IBAUTL7(IBSTAT,IBDT)
IF $GET(IBEXERR)
GOTO ADDEXQ
+50 ;
+51 IF '$DATA(ZTQUEUED)
IF $GET(IBADDE)
IF $DATA(IBTALK)
WRITE !!,"Medication Copayment Exemption Status Updated: ",$PIECE(^IBE(354.2,+IBADDE,0),"^")," ",$$DAT1^IBOUTL($PIECE(IBADDE,"^",2))
+52 ; -- setup and call event driver
+53 ;if not from conversion do following
IF '$DATA(IBCONVER)
Begin DoDot:1
+54 DO AFTER^IBARXEVT
+55 SET IBEVT=$$RXST^IBARXEU(DFN,$SELECT(IBDT<$$STDATE^IBARXEU:$$STDATE^IBARXEU,1:IBDT))
+56 DO ^IBARXEVT
+57 ;exempt patient cancel old charges
IF IBSTAT
DO CANCEL^IBARXEU3
+58 ; process bulletins and alerts
DO ^IBARXEB
End DoDot:1
+59 ;
ADDEXQ ;
+1 LOCK -^IBA(354,DFN)
+2 IF $GET(IBEXERR)
DO ^IBAERR
+3 KILL DO,DD,DIC,DIE,DA,DR,IBEVT,IBEVTP,IBEVTA,IBASIG
+4 QUIT
+5 ;
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
