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

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

initial load of FOIAVistA 6/30/08 version

File size: 4.5 KB
Line 
1IBARXEU3 ;ALB/AAS - RX COPAY EXEMPTION PROCESS AR CANCELS ; 8-JAN-93
2 ;;Version 2.0 ; INTEGRATED BILLING ;**16,34**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5CANCEL ; Cancel Rx copay charges when veteran becomes exempt.
6 ; Required variable input:
7 ; DFN -- Pointer to the patient in file #2
8 ; IBSTAT -- patient is non-exempt (0) or exempt (1)
9 ; IBEVTA -- Zeroth node in #354.1 of CURRENT exemption
10 ; IBEVTP -- Zeroth node in #354.1 of PRIOR exemption
11 ;
12 N IBDT,IBEDT,IBCODA,IBCODP,IBSITE,IBAFY,IBATYP,IBCHRG,IBXX
13 N IBCRES,IBERR,IBFAC,IBIL,IBL,IBLAST,IBLDT,IBN,IBND,IBNN,IBNOW,IBFOUND
14 N IBPARNT,IBPARNT1,IBSEQNO,IBUNIT,IBVLAST,IBCODVL,IBANVD,IBFIL
15 ;
16 ; - veteran must be currently exempt,
17 I 'IBSTAT G CANCELQ
18 ;
19 ; - due to income < pension,
20 S IBCODP=$$ACODE^IBARXEU0(IBEVTP),IBCODA=$$ACODE^IBARXEU0(IBEVTA)
21 G:IBCODA'=120 CANCELQ
22 ;
23 ; - when s/he was previously non-exempt, due to no income data,
24 I $S(IBCODP="":0,IBCODP=210:0,1:1) G CANCELQ
25 ;
26 ; - after having been exempt due to income < pension.
27 S IBVLAST=$$LST^IBARXEU0(DFN,+IBEVTP-.01),IBCODVL=$$ACODE^IBARXEU0(IBVLAST)
28 G:IBCODVL'=120 CANCELQ
29 ;
30 ; - calculate 'anniversary date' from original exemption
31 S IBANVD=$$PLUS^IBARXEU0(+IBVLAST)
32 ;
33 ; - 'filing' date of new exemption must be within 90 days of this date
34 S IBFIL=$P($G(^DGMT(408.31,+$$LST^DGMTCOU1(DFN,+IBEVTA,3),0)),"^",7)
35 I $$FMDIFF^XLFDT(IBFIL,IBANVD)>90 G CANCELQ
36 ;
37 ; - set start date for cancelling at beginning of non-exempt period.
38 ; - end date: today (if the new exemption is the most current), or
39 ; the end of the exemption just started (day before
40 ; the most current exemption)
41 S IBBDT=+IBEVTA I IBEVTP,+IBEVTP<+IBEVTA S IBBDT=+IBEVTP
42 S:IBBDT<$$STDATE^IBARXEU IBBDT=$$STDATE^IBARXEU
43 S IBXX=$$LST^IBARXEU0(DFN)
44 S IBEDT=$S(+IBXX=+IBEVTA:DT,1:$$FMADD^XLFDT(+IBXX,-1))
45 ;
46 ; - move the start date up past the last cancellation end date
47 S X=-$O(^IBA(354.1,"ACAN",DFN,""))
48 I X'<IBBDT S IBBDT=X
49 ;
50 ; - quit if the start date slipped ahead of the end date
51 I IBEDT<IBBDT G CANCELQ
52 ;
53 ; - quit if there are no charges to cancel
54 S X=$O(^IB("APTDT",DFN,(IBBDT-.01))) I 'X!(X>(IBEDT+.9)) G CANCELQ
55 ;
56 ; - cancel the charges in billing
57 S Y=1 D ARPARM^IBAUTL I Y<0 G CANCELQ
58 ;
59 S IBDATE=IBBDT-.0001,IBFOUND=0
60 F S IBDATE=$O(^IB("APTDT",DFN,IBDATE)) Q:'IBDATE!((IBEDT+.9)<IBDATE) D
61 .S IBNN=0 F S IBNN=$O(^IB("APTDT",DFN,IBDATE,IBNN)) Q:'IBNN D BILL
62 ;
63 ; - cancel bills in AR, if at least one charge was cancelled
64 I IBFOUND S IBARCAN=1 D ARCAN^IBARXEU4(DFN,IBSTAT,IBBDT,IBEDT)
65 ;
66CANCELQ Q
67 ;
68BILL ; -- process cancelling one bill
69 S X=$G(^IB(IBNN,0)) Q:X=""
70 Q:+$P(X,"^",4)'=52 ;quit if not pharmacy co-pay
71 ;
72 ; -- find parent
73 S IBPARNT=$P(X,"^",9)
74 ;
75 S IBPARDT=$P($G(^IB(IBPARNT,1)),"^",2) ; get date of parent charge
76 I $S(IBPARDT="":1,IBPARDT<IBBDT:1,IBPARDT>(IBEDT+.9):1,1:0) Q ; ignore charges started before or after date range
77 ;
78 ; -- get most recent ibaction
79 S IBPARNT1=IBPARNT F S IBPARNT1=$P($G(^IB(IBPARNT,0)),"^",9) Q:IBPARNT1=IBPARNT S IBPARNT=IBPARNT1 ;gets parent of parents
80 S IBLAST=$$LAST^IBECEAU(IBPARNT)
81 ;
82 Q:$P(^IBE(350.1,$P(^IB(IBLAST,0),"^",3),0),"^",5)=2 ;quit if already cancelled
83 ;
84 S IBCRES=$O(^IBE(350.3,"B","RX COPAY INCOME EXEMPTION",0)) ; get cancellation reason
85 ;
86 D CANRX
87 Q
88 ;
89CANRX ; -- do actual cancellation without calling ar
90 ; input : iblast := last entry for parnt
91 ; ibparnt := parent charge
92 ; ibnd := ^(0) node of iblast
93 ;
94 I $D(^IB(IBLAST,0)),$P(^IBE(350.1,$P(^IB(IBLAST,0),"^",3),0),"^",5)=2 G CANRXQ ;already cancelled
95 S IBND=$G(^IB(+IBLAST,0)),IBDUZ=DUZ
96 ;
97 S IBATYP=$P(^IBE(350.1,+$P($G(^IB(IBPARNT,0)),"^",3),0),"^",6) ;cancellation action type for parent
98 I '$D(^IBE(350.1,+IBATYP,0)) G CANRXQ
99 S IBSEQNO=$P(^IBE(350.1,+IBATYP,0),"^",5) I 'IBSEQNO G CANRXQ
100 S IBIL=$P($G(^IB(IBPARNT,0)),"^",11)
101 S IBUNIT=$S($P(IBND,"^",6):$P(IBND,"^",6),$D(^IB(IBPARNT,0)):$P(^(0),"^",6),1:0) I IBUNIT<1 G CANRXQ
102 S IBCHRG=$S($P(IBND,"^",7):$P(IBND,"^",7),$D(^IB(IBPARNT,0)):$P(^(0),"^",7),1:0) I IBCHRG<1 G CANRXQ
103 ;
104 D ADD^IBAUTL I +Y<1 G CANRXQ
105 S $P(^IB(IBN,1),"^",1)=IBDUZ,$P(^IB(IBN,0),"^",2,13)=DFN_"^"_IBATYP_"^"_$P(IBND,"^",4)_"^11^"_IBUNIT_"^"_IBCHRG_"^"_$P(IBND,"^",8)_"^"_IBPARNT_"^"_IBCRES_"^"_IBIL_"^^"_IBFAC
106 K ^IB("AC",1,IBN)
107 S DA=IBN,DIK="^IB(" D IX^DIK
108 S IBFOUND=1
109 ;
110 ; -- update parent to cancelled
111 ; note: parent status=10, cancellation due to exemption reason only
112 ; on charge cancelled so reports work right.
113 S DIE="^IB(",DA=IBPARNT,DR=".05////10;.1////"_IBCRES D ^DIE K DIE,DA,DR
114CANRXQ Q
Note: See TracBrowser for help on using the repository browser.