IBARXEX1 ;ALB/AAS - RX COPAY INCOME EXEMPTION ROUTINE - MANUAL UPDATE OPTION, CONT. ; 16-NOV-92
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
AUTO ; -- auto update of exemption reason file and billing pat file.
; -- if computes to pending but status is adjudicated quit
N IBOLDAUT,IBFORCE
I $$NETW^IBARXEU1,$P(IBSTAT,"^",5)=130 S X=$$LST^IBARXEU0(DFN,DT),Y=$P($G(^IBE(354.2,$P(X,"^",5),0)),"^",5) I Y=140!(Y=150) Q
;
; -- ask if sure
S DIR(0)="Y",DIR("A")="Update Patient Billing Status",DIR("B")="NO" D ^DIR K DIR I $D(DIRUT)!(Y<1) S IBQUIT=1 G AUTOQ
D SELCY^IBARXEX G:IBQUIT AUTOQ
;
L +^IBA(354,DFN):5 I '$T W !,"Another User accessing Record, Try Again Later." G AUTOQ
S IBCHANGE=1
;
S (IBEVT,X)=$$STATUS^IBARXEU1(DFN,IBDT)
;
; -- not currently autoexempt, see if most recent is auto
S IBOLDAUT=""
I $L($P(^IBE(354.2,+IBEVT,0),"^",5))>2 D OLDAUT(IBEVT)
;
; -- first inactivate all entries for day
S IBFORCE=$P(X,"^",2)
;
; -- for income, inactivate most recent
D MOSTR^IBARXEU5($P(X,"^",2),+X)
D ADDEX^IBAUTL6(+X,$P(X,"^",2),1,1,$G(IBOLDAUT))
L -^IBA(354,DFN)
;W !!,"Entry Updated!"
AUTOQ K IBFORCE D PAUSE^IBOUTL
Q
;
OLDAUT(X1) ; -- not currently autoexempt, most current is auto exempt delete
; inactivate autoexempt
N X
S X=$$LSTAC^IBARXEU0(DFN) I $L(+X)'=3,$P(X,"^",2)'<$P(X1,"^",2) S IBOLDAUT=$P(X,"^",2)
Q
;
MANUAL ; -- allow user to do manual change
S DIR(0)="Y",DIR("A")="Do you wish to manually assign a Hardship Copay Exemption",DIR("B")="NO" D ^DIR K DIR I $D(DIRUT)!(Y<1) S IBQUIT=1 G MANUALQ
;
D SELCY^IBARXEX G:IBQUIT MANUALQ
S IBEXREA=$O(^IBE(354.2,"ACODE",2010,0)) ;only hardships
S IBCODA=2010
;
; -- if current exemption is exempt can't give hardship
S X=$$LST^IBARXEU0(DFN,IBDT)
I +X'<(DT-100000),$P(X,"^",4) K IBEXREA W !!,"You can only give a hardship to a Non-Exempt patient",!,*7 G MANUALQ
;
L +^IBA(354,DFN):5 I '$T W !,"Another User accessing record, Try Again Later." G MANUALQ
S IBCHANGE=1
S DIR(0)="Y",DIR("A")="Are You Sure" D ^DIR K DIR G:$D(DIRUT)!(Y<1) MANUALQ
;
; -- get electronic signature code
D SIG^XUSESIG
I X1=""!(X'=X1) W !,"Not your electronic signature" G MANUALQ
S IBASIG=X1
;
; -- add new exemption
D ADDEX^IBAUTL6(IBEXREA,IBDT,2,1)
L -^IBA(354,DFN)
;
MANUALQ D PAUSE^IBOUTL
Q
IBARXEX1 ;ALB/AAS - RX COPAY INCOME EXEMPTION ROUTINE - MANUAL UPDATE OPTION, CONT. ; 16-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 ;
+4 ;
AUTO ; -- auto update of exemption reason file and billing pat file.
+1 ; -- if computes to pending but status is adjudicated quit
+2 NEW IBOLDAUT,IBFORCE
+3 IF $$NETW^IBARXEU1
IF $PIECE(IBSTAT,"^",5)=130
SET X=$$LST^IBARXEU0(DFN,DT)
SET Y=$PIECE($GET(^IBE(354.2,$PIECE(X,"^",5),0)),"^",5)
IF Y=140!(Y=150)
QUIT
+4 ;
+5 ; -- ask if sure
+6 SET DIR(0)="Y"
SET DIR("A")="Update Patient Billing Status"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y<1)
SET IBQUIT=1
GOTO AUTOQ
+7 DO SELCY^IBARXEX
IF IBQUIT
GOTO AUTOQ
+8 ;
+9 LOCK +^IBA(354,DFN):5
IF '$TEST
WRITE !,"Another User accessing Record, Try Again Later."
GOTO AUTOQ
+10 SET IBCHANGE=1
+11 ;
+12 SET (IBEVT,X)=$$STATUS^IBARXEU1(DFN,IBDT)
+13 ;
+14 ; -- not currently autoexempt, see if most recent is auto
+15 SET IBOLDAUT=""
+16 IF $LENGTH($PIECE(^IBE(354.2,+IBEVT,0),"^",5))>2
DO OLDAUT(IBEVT)
+17 ;
+18 ; -- first inactivate all entries for day
+19 SET IBFORCE=$PIECE(X,"^",2)
+20 ;
+21 ; -- for income, inactivate most recent
+22 DO MOSTR^IBARXEU5($PIECE(X,"^",2),+X)
+23 DO ADDEX^IBAUTL6(+X,$PIECE(X,"^",2),1,1,$GET(IBOLDAUT))
+24 LOCK -^IBA(354,DFN)
+25 ;W !!,"Entry Updated!"
AUTOQ KILL IBFORCE
DO PAUSE^IBOUTL
+1 QUIT
+2 ;
OLDAUT(X1) ; -- not currently autoexempt, most current is auto exempt delete
+1 ; inactivate autoexempt
+2 NEW X
+3 SET X=$$LSTAC^IBARXEU0(DFN)
IF $LENGTH(+X)'=3
IF $PIECE(X,"^",2)'<$PIECE(X1,"^",2)
SET IBOLDAUT=$PIECE(X,"^",2)
+4 QUIT
+5 ;
MANUAL ; -- allow user to do manual change
+1 SET DIR(0)="Y"
SET DIR("A")="Do you wish to manually assign a Hardship Copay Exemption"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y<1)
SET IBQUIT=1
GOTO MANUALQ
+2 ;
+3 DO SELCY^IBARXEX
IF IBQUIT
GOTO MANUALQ
+4 ;only hardships
SET IBEXREA=$ORDER(^IBE(354.2,"ACODE",2010,0))
+5 SET IBCODA=2010
+6 ;
+7 ; -- if current exemption is exempt can't give hardship
+8 SET X=$$LST^IBARXEU0(DFN,IBDT)
+9 IF +X'<(DT-100000)
IF $PIECE(X,"^",4)
KILL IBEXREA
WRITE !!,"You can only give a hardship to a Non-Exempt patient",!,*7
GOTO MANUALQ
+10 ;
+11 LOCK +^IBA(354,DFN):5
IF '$TEST
WRITE !,"Another User accessing record, Try Again Later."
GOTO MANUALQ
+12 SET IBCHANGE=1
+13 SET DIR(0)="Y"
SET DIR("A")="Are You Sure"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y<1)
GOTO MANUALQ
+14 ;
+15 ; -- get electronic signature code
+16 DO SIG^XUSESIG
+17 IF X1=""!(X'=X1)
WRITE !,"Not your electronic signature"
GOTO MANUALQ
+18 SET IBASIG=X1
+19 ;
+20 ; -- add new exemption
+21 DO ADDEX^IBAUTL6(IBEXREA,IBDT,2,1)
+22 LOCK -^IBA(354,DFN)
+23 ;
MANUALQ DO PAUSE^IBOUTL
+1 QUIT
