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

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

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1IBARXECA ;ALB/AAS -RX CO-PAY INCOME EXEMPTION CANCEL OLD BILLS ; 2-NOV-92
2 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5% ; -- count variables
6 ; Patient Totals Represents
7 ; ------- ------ ----------
8 ; 5 ibcnt ibtcnt = : total patient count checked
9 ; 6 ibecnt ibtecnt = : total exempt patients
10 ; 7 ibncnt ibtncnt = : total non-exempt patients
11 ; 8 ibcecnt ibtcecnt = : total count of exempt charges (rx's)
12 ; 9 ibamt ibtamt = : total dollar amount checked
13 ; 10 ibeamt ibteamt = : total exempt dollar amount
14 ; 11 ibnamt ibtnamt = : total non-exempt dollar amount
15 ; 12 ibceamt ibtceamt = : total cancelled charges amount
16 ; 15 ibnecnt ibtnecnt = : total non-exempt count
17 ; 16 ibbcnt ibtbcnt = : total bills checked
18 ; 17 ibcbcnt ibtcbcnt = : total number of cancelled bills
19 ;
20CANCEL(DFN,IBDT,IBEDT) ; -- cancel all charges for a patient for a date range
21 ; do not pass to ar as its done, call all at once later.
22 ;
23 D ARPARM^IBAUTL
24 S IBBDT=IBDT-.00001
25 F S IBBDT=$O(^IB("APTDT",DFN,IBBDT)) Q:'IBBDT!((IBEDT+.9)<IBBDT) S IBN=0 F S IBN=$O(^IB("APTDT",DFN,IBBDT,IBN)) Q:'IBN D BILL
26 ;
27 Q
28 ;
29BILL ; -- process cancelling one bill
30 S X=$G(^IB(IBN,0)) Q:X=""
31 Q:+$P(X,"^",4)'=52 ;quit if not pharmacy co-pay
32 ; find parent
33 S IBPARNT=$P(X,"^",9) Q:$D(^TMP($J,"IBARRY",DFN,IBPARNT)) ;don't keep checking modifications to charge already checked
34 ;
35 S ^TMP($J,"IBARRY",DFN,IBPARNT)=""
36 S IBPARDT=$P($G(^IB(IBPARNT,1)),"^",2) ; get date of parent charge
37 I $S(IBPARDT="":1,IBPARDT<IBDT:1,IBPARDT>IBEDT:1,1:0) ; ignore charges started before or after date range
38 ;
39 ; -- get exemption status on date of charge
40 ; (NOT NECESSARY, conversion will use only current exemption
41 ;S IBSTAT=$$RXEXMT^IBARXEU0(DFN,IBPARDT)
42 ;
43 ; -- get must recent ibaction
44 S IBPARNT1=IBPARNT F S IBPARNT1=$P($G(^IB(IBPARNT,0)),"^",9) Q:IBPARNT1=IBPARNT S IBPARNT=IBPARNT1 ;gets parent of parents, makes sure old bug where parents get lost isn't a problem
45 D LAST
46 ;
47 ; -- add charge amounts to corrct variable
48 S IBND=$G(^IB(IBLAST,0)),IBBCNT=IBBCNT+1,IBAMT=IBAMT+$P(IBND,"^",7)
49 S:IBSTAT IBCECNT=IBCECNT+1,IBEAMT=IBEAMT+$P(IBND,"^",7)
50 S:'IBSTAT IBNECNT=IBNECNT+1,IBNAMT=IBNAMT+$P(IBND,"^",7)
51 ;
52 Q:'IBSTAT ;quit if non-exempt
53 Q:$P(^IBE(350.1,$P(^IB(IBLAST,0),"^",3),0),"^",5)=2 ;quit if already cancelled
54 ;
55 ; -- add cancellation charge for amount
56 S IBCEAMT=IBCEAMT+$P(IBND,"^",7),IBCBCNT=IBCBCNT+1 ;counts of amount of actual cancellations
57 S IBCRES=$O(^IBE(350.3,"B","RX COPAY INCOME EXEMPTION",0)) ; get cancellation reason
58 ;
59 D CANRX^IBARXEU3
60 Q
61 ;
62END ;K VARIABLES
63 Q
64 ;
65LAST ; -- find most recent (the last) entry for a parent action
66 S IBLAST=""
67 S IBLDT=$O(^IB("APDT",IBPARNT,"")) I +IBLDT F IBL=0:0 S IBL=$O(^IB("APDT",IBPARNT,IBLDT,IBL)) Q:'IBL S IBLAST=IBL
68 I IBLAST="" S IBLAST=IBPARNT
69 Q
Note: See TracBrowser for help on using the repository browser.