| [613] | 1 | IBARXECA ;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 | ;
|
|---|
| 20 | CANCEL(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 | ;
|
|---|
| 29 | BILL ; -- 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 | ;
|
|---|
| 62 | END ;K VARIABLES
|
|---|
| 63 | Q
|
|---|
| 64 | ;
|
|---|
| 65 | LAST ; -- 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
|
|---|
