source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBARXEX1.m@ 1791

Last change on this file since 1791 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.3 KB
Line 
1IBARXEX1 ;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 ;
6AUTO ; -- 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!"
32AUTOQ K IBFORCE D PAUSE^IBOUTL
33 Q
34 ;
35OLDAUT(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 ;
41MANUAL ; -- 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 ;
64MANUALQ L -^IBA(354,DFN)
65 D PAUSE^IBOUTL
66 Q
Note: See TracBrowser for help on using the repository browser.