source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBARXEU0.m@ 1259

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

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1IBARXEU0 ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE ; 2-NOV-92
2 ;;2.0;INTEGRATED BILLING;**139**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6RXEXMT(DFN,IBDT) ; -- Check income exemption status of patient
7 ; -- Warning, this function may cause new entries to be created
8 ; when no data exists of new entry for current caledar year exists.
9 ;
10 ; input = : dfn = patient file pointer
11 ; ibdt = date to check for
12 ; returns :
13 ; 0 if not exempt
14 ; 1 if exempt^text^reason code^reason^date of test
15 ;
16 ;*** START RT CLOCK
17 ;S XRTN="ADD EXEMPTION",XRTL=$ZU(0) D T0^%ZOSV
18 ;
19 N X,Y,IBON,IBX,IBJOB,IBEXERR,IBWHER,DA,DR,DIC,DIE
20 ;
21 S IBON=$$ON I IBON<1 Q IBON
22 ;
23 S IBX="",IBJOB=14,IBEXERR=""
24 I '$G(IBDT) S IBDT=DT
25 I IBDT>DT S IBDT=DT ; no future dates
26 ;
27 ; -- date before legislation
28 I IBDT<$$STDATE^IBARXEU S IBX="0^NON-EXEMPT^^Date is prior to legislation^" G RXEXMTQ
29 ;
30 S X=$G(^IBA(354,DFN,0))
31 ;
32 ; -- if current patient, current request, get data and quit
33 I IBDT'<$P(X,"^",3),IBDT'>$$PLUS($P(X,"^",3)),$P(X,"^",4)'="" S IBX=$$IBX(DFN,IBDT) G RXEXMTQ
34 ;
35 ; -- if no patient add one
36 I '+X D ADDP^IBAUTL6 S X=$G(^IBA(354,DFN,0)) G:$G(IBEXERR) RXEXMTQ D AEX(DFN,IBDT) S IBX=$$IBX(DFN,IBDT) G RXEXMTQ
37 ;
38 ; -- if current exemption older than 365 days add new one
39 I IBDT'<$P(X,"^",3),IBDT>$$PLUS($P(X,"^",3)) D AEX(DFN,IBDT) S IBX=$$IBX(DFN,IBDT) G RXEXMTQ
40 ;
41 ; -- if ibdt less than current date need old exemption data
42 I IBDT<$P(X,"^",3) D
43 .;
44 .;find status of prior year
45 .S Y=$G(^IBA(354.1,+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(IBDT+.0001))),0)),0))
46 .; -- no data
47 .I Y="" D AEX(DFN,IBDT)
48 .;
49 .; -- old data too old need to insert exemption
50 .I IBDT>$$PLUS(+Y) D AEX(DFN,IBDT)
51 .;
52 .; -- if old exemption is current for this copay date
53 .S IBX=$$IBXOLD(DFN,IBDT)
54 .Q
55 ;
56 ;*** STOP RT CLOCK
57RXEXMTQ ;I $D(XRT0),$D(XRTN) D T1^%ZOSV
58 ;
59 Q IBX
60 ;
61 ;
62AEX(DFN,IBDT) ; -- add exemption
63 ; set exemption effective date to means test dates
64 ;
65 N X
66 S X=$$STATUS^IBARXEU1(DFN,IBDT)
67 D ADDEX^IBAUTL6(+X,$P(X,"^",2))
68 Q
69 ;
70IBX(DFN,IBDT) ; -- format output from current status
71 N X,Y
72 S X=$G(^IBA(354,DFN,0)),Y=$$LST(DFN,IBDT)
73 Q +$P(X,"^",4)_"^"_$$TEXT(+$P(X,"^",4))_"^"_$$ACODE(Y)_"^"_$$REASON(Y)_"^"_+Y
74 ;
75IBXOLD(DFN,IBDT) ; -- format output from old exemption
76 N X,Y
77 S Y=$$LST(DFN,IBDT)
78 S X=$G(^IBE(354.2,+$P(Y,"^",5),0)) ; exemption reason node
79 Q +$P(X,"^",4)_"^"_$$TEXT(+$P(X,"^",4))_"^"_$$ACODE(Y)_"^"_$$REASON(Y)_"^"_+Y
80 ;
81 ;
82ON() ; -- is copay exemption testing on
83 ; output 1 = exemption testing is active
84 ; 0 = exemption testing is inactive (everybody non-exempt)
85 ; -1 = copay is off (everybody exempt)
86 Q 1
87 ;Q "0^NON-EXEMPT^0^Medication Copay Exemption Testing turned off^"_DT
88 ;Q "-1^EXEMPT^0^Medication Copayment has been turned off^"_DT
89 ;
90PLUS(X1) ; -- computes plus 1 year (into future)
91 ; if x1=2920930 + 1 year = +10000 = 2930930
92 I $E(X1,4,7)="0229" Q X1+10072 ;makes the anniversary date March 1
93 Q X1+10000
94 ;
95MINUS(X1) ; -- computes minus 1 year (into past)
96 Q X1-10000
97 ;
98ACODE(Y) ; -- return lookup code of reason, input zeroth node of exemption
99 Q $P($G(^IBE(354.2,+$P($G(Y),"^",5),0)),"^",5)
100 ;
101REASON(Y) ; -- return reason description, input zeroth node of exemption
102 Q $P($G(^IBE(354.2,+$P($G(Y),"^",5),0)),"^",2)
103 ;
104TEXT(X) ; -- convert 0 or 1 to text
105 Q $S(X=1:"EXEMPT",X=0:"NON-EXEMPT",1:"UNKNOWN")
106 ;
107LST(DFN,IBDT) ; -- returns last exemption entry before date x
108 ;
109 ; -- returns zeroth node of last test before date
110 ;
111 I '$G(IBDT) S IBDT=DT
112 Q $G(^IBA(354.1,+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(IBDT+.00001))),0)),0))
113 ;
114LSTAC(DFN) ; -- computes last reason code and date for a patient
115 ; -- returns exemption reason ^ exemption date
116 N X1
117 S X1=$G(^IBA(354.1,+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(DT+.00001))),0)),0))
118 Q $P($G(^IBE(354.2,+$P(X1,"^",5),0)),"^",5)_"^"_+X1
Note: See TracBrowser for help on using the repository browser.