- 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
