| [613] | 1 | IBARXEX1 ;ALB/AAS - RX COPAY INCOME EXEMPTION ROUTINE - MANUAL UPDATE OPTION, CONT. ; 16-NOV-92
|
|---|
| 2 | ;;Version 2.0 ; INTEGRATED BILLING ;**34**; 21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ;
|
|---|
| 6 | AUTO ; -- auto update of exemption reason file and billing pat file.
|
|---|
| 7 | ; -- if computes to pending but status is adjudicated quit
|
|---|
| 8 | N IBOLDAUT,IBFORCE
|
|---|
| 9 | 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
|
|---|
| 10 | ;
|
|---|
| 11 | ; -- ask if sure
|
|---|
| 12 | 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
|
|---|
| 13 | D SELCY^IBARXEX G:IBQUIT AUTOQ
|
|---|
| 14 | ;
|
|---|
| 15 | L +^IBA(354,DFN):5 I '$T W !,"Another User accessing Record, Try Again Later." G AUTOQ
|
|---|
| 16 | S IBCHANGE=1
|
|---|
| 17 | ;
|
|---|
| 18 | S (IBEVT,X)=$$STATUS^IBARXEU1(DFN,IBDT)
|
|---|
| 19 | ;
|
|---|
| 20 | ; -- not currently autoexempt, see if most recent is auto
|
|---|
| 21 | S IBOLDAUT=""
|
|---|
| 22 | I $L($P(^IBE(354.2,+IBEVT,0),"^",5))>2 D OLDAUT(IBEVT)
|
|---|
| 23 | ;
|
|---|
| 24 | ; -- first inactivate all entries for day
|
|---|
| 25 | S IBFORCE=$P(X,"^",2)
|
|---|
| 26 | ;
|
|---|
| 27 | ; -- for income, inactivate most recent
|
|---|
| 28 | D MOSTR^IBARXEU5($P(X,"^",2),+X)
|
|---|
| 29 | D ADDEX^IBAUTL6(+X,$P(X,"^",2),1,1,$G(IBOLDAUT))
|
|---|
| 30 | L -^IBA(354,DFN)
|
|---|
| 31 | ;W !!,"Entry Updated!"
|
|---|
| 32 | AUTOQ K IBFORCE D PAUSE^IBOUTL
|
|---|
| 33 | Q
|
|---|
| 34 | ;
|
|---|
| 35 | OLDAUT(X1) ; -- not currently autoexempt, most current is auto exempt delete
|
|---|
| 36 | ; inactivate autoexempt
|
|---|
| 37 | N X
|
|---|
| 38 | S X=$$LSTAC^IBARXEU0(DFN) I $L(+X)'=3,$P(X,"^",2)'<$P(X1,"^",2) S IBOLDAUT=$P(X,"^",2)
|
|---|
| 39 | Q
|
|---|
| 40 | ;
|
|---|
| 41 | MANUAL ; -- allow user to do manual change
|
|---|
| 42 | 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
|
|---|
| 43 | ;
|
|---|
| 44 | D SELCY^IBARXEX G:IBQUIT MANUALQ
|
|---|
| 45 | S IBEXREA=$O(^IBE(354.2,"ACODE",2010,0)) ;only hardships
|
|---|
| 46 | S IBCODA=2010
|
|---|
| 47 | ;
|
|---|
| 48 | ; -- if current exemption is exempt can't give hardship
|
|---|
| 49 | S X=$$LST^IBARXEU0(DFN,IBDT)
|
|---|
| 50 | I +X'<(DT-100000),$P(X,"^",4) K IBEXREA W !!,"You can only give a hardship to a Non-Exempt patient",!,*7 G MANUALQ
|
|---|
| 51 | ;
|
|---|
| 52 | L +^IBA(354,DFN):5 I '$T W !,"Another User accessing record, Try Again Later." G MANUALQ
|
|---|
| 53 | S IBCHANGE=1
|
|---|
| 54 | S DIR(0)="Y",DIR("A")="Are You Sure" D ^DIR K DIR G:$D(DIRUT)!(Y<1) MANUALQ
|
|---|
| 55 | ;
|
|---|
| 56 | ; -- get electronic signature code
|
|---|
| 57 | D SIG^XUSESIG
|
|---|
| 58 | I X1=""!(X'=X1) W !,"Not your electronic signature" G MANUALQ
|
|---|
| 59 | S IBASIG=X1
|
|---|
| 60 | ;
|
|---|
| 61 | ; -- add new exemption
|
|---|
| 62 | D ADDEX^IBAUTL6(IBEXREA,IBDT,2,1)
|
|---|
| 63 | ;
|
|---|
| 64 | MANUALQ L -^IBA(354,DFN)
|
|---|
| 65 | D PAUSE^IBOUTL
|
|---|
| 66 | Q
|
|---|
