IBAUTL6 ;AAS/ALB-RX EXEMPTION UTILITY ROUTINE (CONT.);2-NOV-92
;;2.0;INTEGRATED BILLING;**34,195,385**;21-MAR-94;Build 35
;;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
;
N DINUM,DLAYGO,X
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
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,IBVFAOK
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 DUZ,$G(^VA(200,+DUZ,0))="" S IBEXERR=8 G ADDEXQ
; if DUZ=0, it will be considered as .5 (POSTMASTER) by the input template [IB NEW EXEMPTION]
;
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
I $D(Y) S IBEXERR=5 G ADDEXQ
S IBADDE=IBEXREA_"^"_IBDT
;
; -- VFA check
S IBVFAOK=$$VFAOK^IBARXEU($G(^IBA(354.1,DA,0)))
;
; -- clean up a bit
K DIC,DIE,DA,DR
;
; --if effective date is in last 365 days make current
I IBDT>$$MINUS^IBARXEU0(DT)!(IBVFAOK) 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,IBARCAN
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAUTL6 4751 printed Jun 11, 2024@21:56:50 Page 2
IBAUTL6 ;AAS/ALB-RX EXEMPTION UTILITY ROUTINE (CONT.);2-NOV-92
+1 ;;2.0;INTEGRATED BILLING;**34,195,385**;21-MAR-94;Build 35
+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 NEW DINUM,DLAYGO,X
+5 IF '$DATA(DT)
DO DT^DICRW
+6 SET IBWHER=11
SET IBEXERR=""
+7 SET IBADD=0
+8 IF $SELECT('$DATA(DFN):1,'$DATA(^IBA(354)):1,$DATA(^IBA(354,DFN)):1,1:0)
GOTO ADDPQ
+9 KILL DO,DD,DIC,DR,DA,DIE
SET DIC="^IBA(354,"
SET DIC(0)="L"
SET DLAYGO=354
+10 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
+11 IF IBADD'=1
SET IBEXERR=9
+12 LOCK -^IBA(354,DFN)
+13 ;
ADDPQ KILL DO,DD,DIC,DR,DIE,DA
+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,IBVFAOK
+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 DUZ
IF $GET(^VA(200,+DUZ,0))=""
SET IBEXERR=8
GOTO ADDEXQ
+11 ; if DUZ=0, it will be considered as .5 (POSTMASTER) by the input template [IB NEW EXEMPTION]
+12 ;
+13 ;get prior exemption
DO BEFORE^IBARXEVT
+14 ;
+15 NEW IBSTAT,IBEXDA
+16 SET IBSTAT=$PIECE($GET(^IBE(354.2,+IBEXREA,0)),"^",4)
+17 SET IBHOW=$SELECT('$DATA(IBHOW):1,IBHOW="":1,IBHOW>2:1,IBHOW<1:1,1:IBHOW)
+18 SET IBTYPE=$SELECT('$DATA(IBTYPE):1,IBTYPE="":1,1:IBTYPE)
+19 ;I '$D(IBACTION) S IBACTION="ADD"
+20 ;
+21 ; -- inactivate a current autoexempt of no longer autoexempt
+22 ;I '$D(ZTQUEUED),$D(IBTALK) W !,"Inactivating current non-income based exemption for patient"
IF $GET(IBOLDAUT)?7N
DO INACT^IBAUTL7(IBOLDAUT)
+23 ;
+24 ; -- if forcing a new entry to correct problems
+25 IF $GET(IBFORCE)?7N
DO INACT^IBAUTL7(IBFORCE)
+26 ;
+27 ; -- check for duplicate entry
+28 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
+29 ;
+30 ; -- inactivate previous active entries
+31 DO INACT^IBAUTL7(IBDT)
IF $GET(IBEXERR)
GOTO ADDEXQ
+32 ;
+33 ; -- if no income data from conversion set date = start date
+34 IF $DATA(IBCONVER)
IF $PIECE($GET(^IBE(354.2,+IBEXREA,0)),"^",5)=210
SET IBDT=$$STDATE^IBARXEU
+35 ;
+36 ; -- add entry
+37 SET DIC="^IBA(354.1,"
SET DIC(0)="L"
SET X=IBDT
KILL DO,DD
DO FILE^DICN
+38 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
+39 ;
+40 ; -- edit new entry
+41 ; use compiled template
SET DIE="^IBA(354.1,"
SET DR="[IB NEW EXEMPTION]"
+42 ;
+43 ;DR=".02////"_DFN_";.03////"_IBTYPE_";.04////"_IBSTAT_";.05////"_IBEXREA_";.06////"_IBHOW_";.07////"_DUZ_";.08///NOW;.1////1;.11////"_$G(IBASIG)
+44 ;
+45 DO ^DIE
+46 IF $DATA(Y)
SET IBEXERR=5
GOTO ADDEXQ
+47 SET IBADDE=IBEXREA_"^"_IBDT
+48 ;
+49 ; -- VFA check
+50 SET IBVFAOK=$$VFAOK^IBARXEU($GET(^IBA(354.1,DA,0)))
+51 ;
+52 ; -- clean up a bit
+53 KILL DIC,DIE,DA,DR
+54 ;
+55 ; --if effective date is in last 365 days make current
+56 IF IBDT>$$MINUS^IBARXEU0(DT)!(IBVFAOK)
DO CURREX^IBAUTL7(IBSTAT,IBDT)
IF $GET(IBEXERR)
GOTO ADDEXQ
+57 ;
+58 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))
+59 ; -- setup and call event driver
+60 ;if not from conversion do following
IF '$DATA(IBCONVER)
Begin DoDot:1
+61 DO AFTER^IBARXEVT
+62 SET IBEVT=$$RXST^IBARXEU(DFN,$SELECT(IBDT<$$STDATE^IBARXEU:$$STDATE^IBARXEU,1:IBDT))
+63 DO ^IBARXEVT
+64 ;exempt patient cancel old charges
IF IBSTAT
DO CANCEL^IBARXEU3
+65 ; process bulletins and alerts
DO ^IBARXEB
End DoDot:1
+66 ;
ADDEXQ ;
+1 LOCK -^IBA(354,DFN)
+2 IF $GET(IBEXERR)
DO ^IBAERR
+3 KILL DO,DD,DIC,DIE,DA,DR,IBEVT,IBEVTP,IBEVTA,IBASIG,IBARCAN
+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
