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

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1IBARXEU ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE ;2-NOV-92
2 ;;2.0;INTEGRATED BILLING;**20,222,293**;21-MAR-94;Build 1
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6RXST(DFN,IBDT) ; -- Check rx income exemption status of patient
7 ;
8 ; input = : dfn = patient file pointer
9 ; ibdt = date to check for (optional) default is today
10 ;
11 ; returns : -1 if no data ^text^reason code^reason text^date of test
12 ; 0 if non exempt
13 ; 1 if exempt
14 ;
15 N X,Y,Z,IBX,IBON
16 ;
17 S IBON=$$ON^IBARXEU0 I IBON<1 Q IBON
18 ;
19 S IBX=""
20 I '$G(IBDT) S IBDT=DT
21 I IBDT>DT S IBDT=DT ; no future dates
22 ;
23 ; -- date before legislations
24 I IBDT<$$STDATE S IBX="0^NON-EXEMPT^^Date is Prior to Legislation^" G RXSTQ ; nobody exempt prior to legislation
25 ;
26 ; -- if no data on patient quit
27 S X=$G(^IBA(354,DFN,0))
28 I X=""!('$D(^IBA(354.1,"AP",DFN))) S IBX="-1^UNKNOWN^^Medication Copayment Exemption status never determined" G RXSTQ ; no data return -1
29 ;
30 ; -- use current status if ibdt not less than current test and
31 ; not greater than current test date +365
32 I IBDT'<$P(X,U,3),IBDT'>$$PLUS^IBARXEU0($P(X,U,3)) S IBX=$$IBX^IBARXEU0(DFN,IBDT) G RXSTQ
33 ;
34 ; -- if ibdt not less than current date but greater than
35 ; current test +365 is into future
36 I IBDT'<$P(X,U,3),IBDT>$$PLUS^IBARXEU0($P(X,U,3)) D
37 .S Y=$$LST^IBARXEU0(DFN,IBDT)
38 .;
39 .; -- see if patient was SC>50, can't be updated so don't say previous
40 .I $L($$ACODE^IBARXEU0(Y))<3 S IBX=+$P(X,U,4)_U_$$TEXT^IBARXEU0($P(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_$$REASON^IBARXEU0(X)_U_$P(X,U,3) Q
41 .;
42 .S IBX=+$P(X,U,4)_U_"Previously "_$$TEXT^IBARXEU0($P(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_"Requires new exemption. Previously "_$$REASON^IBARXEU0(X)_U_$P(X,U,3)
43 ;
44 ; -- if ibdt less than current date need old exemption data
45 I IBDT<$P(X,U,3) D G RXSTQ
46 .;
47 .; -- find status of prior test
48 .S Y=$$LST^IBARXEU0(DFN,IBDT)
49 .;
50 .; -- no previous data
51 .I Y="" D Q
52 ..S IBX="-1^UNKNOWN^^No data for date requested."
53 ..Q
54 .;
55 .S Z=$G(^IBA(354,DFN,0)),Z=$P(Z,U,5)_U_$P(Z,U,3) ; get status & date
56 .;
57 .; -- if old exemption is current for copay date
58 .I IBDT'>$$PLUS^IBARXEU0(+Y) D Q
59 ..S X=$G(^IBE(354.2,+$P(Y,U,5),0)) ; exemption reason node
60 ..S IBX=+$P(X,U,4)_U_$$TEXT^IBARXEU0($P(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_$$REASON^IBARXEU0(X)_U_$P(X,U,3)
61 ..Q
62 .;
63 .; -- if ibdt is greater than old exemption + 365
64 .; report previous
65 .I IBDT>$$PLUS^IBARXEU0(+Y) D Q
66 ..S X=$G(^IBE(354.2,+$P(Y,U,5),0)) ;exemption reason node
67 ..;
68 ..; -- see if patient was SC>50, can't be updated so don't say previous
69 ..I $L($$ACODE^IBARXEU0(Y))<3 S IBX=+$P(X,U,4)_U_$$TEXT^IBARXEU0($P(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_$$REASON^IBARXEU0(X)_U_$P(X,U,3) Q
70 ..;
71 ..S IBX=+$P(X,U,4)_U_"Previously "_$$TEXT^IBARXEU0($P(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_"Requires new exemption. Previously "_$$REASON^IBARXEU0(X)_U_$P(X,U,3)
72 ..Q
73 .Q
74 ;
75RXSTQ Q IBX
76 ;
77DISP(DFN,IBDT,NO,NULL) ; -- formats text to display
78 ; -- input = dfn
79 ; ibdt = date to check for
80 ; no = number of lines to print (1, 2, or 3)
81 ; null = if zero print unknown, if non-zero quit
82 ;
83 I '$G(IBDT) S IBDT=DT
84 I '$D(NULL) S NULL=1
85 I IBDT>DT S IBDT=DT ; no future dates
86 I '$G(NO) S NO=3
87 S X=$$RXST(DFN,IBDT)
88 S IBON=$$ON^IBARXEU0 I IBON<1 S X=IBON
89 I X<0&(NULL) G DISPQ
90 W !,"Medication Copayment Exemption Status: ",$P(X,U,2) G:NO<2 DISPQ
91 W !,$P(X,U,4) G:NO<3 DISPQ
92 I $P(X,U,5) W !,"Last Rx Copay Exemption date: " S Y=$P(X,U,5) D DT^DIQ
93DISPQ Q
94 ;
95STDATE() ; -- legislative start date for income exemption
96 Q 2921030
97 ;
98 ;
99ACTIVE(IBZ) ; -- SCREEN for active field of billing exemptions file
100 ; only one entry per effective date can be active
101 ;
102 N IBX,IBY,T
103 S T=0
104 S IBZ=$S(IBZ=1:IBZ,$E(IBZ)="A":1,1:0)
105 I 'IBZ S T=1 G ACTIVEQ
106 S IBX=$G(^IBA(354.1,DA,0))
107 S IBY=$O(^IBA(354.1,"AIVDT",+$P(IBX,U,3),+$P(IBX,U,2),-$P(IBX,U),0))
108 I 'IBY!(IBY=DA) S T=1
109 W:$D(IBTALK) !!,"Another entry is already Active, You must inactivate it first",!!
110ACTIVEQ Q T
Note: See TracBrowser for help on using the repository browser.