IBACVA1 ;ALB/CPM - BILL CHAMPVA SUBSISTENCE CHARGE ; 29-JUL-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
BILL ; Create the CHAMPVA inpatient subsistence charge.
S IBY=1 I '$$CHECK^IBECEAU(0) D ERRMSG^IBACVA2(1) G BILLQ
S (IBCHGT,IBBILLED)=0
;
; - loop through each day of the admission, or until limit reached.
F IBD=IBBDT:1:IBEDT S %H=IBD D YMD^%DTC S IBDT=X D Q:IBY<0!(IBBILLED)
.I IBBDT'=IBEDT S VAIP("D")=IBDT_.2359 D IN5^VADPT Q:'VAIP(10) ; on leave
.D LIM(IBDT) Q:IBY<0 ; can't find maximum limit
.D PD(IBDT) Q:IBY<0 ; can't find daily per diem
.S:'IBCHGT IBFR=IBDT ; set 'from date' on 1st pass
.S IBCHGT=IBCHGT+IBCHG,IBTO=IBDT ; build cumulative charge/set 'to date'
.I IBCHGT'<IBLIM S IBCHGT=IBLIM,IBBILLED=1 ; quit if max limit reached
;
; - quit if there is no error, no charge to bill.
I IBY=1,'IBCHGT W:$G(IBJOB)=4 !!,"There are no charges to be billed for this admission!" G BILLQ
;
; - send error message if error occurs.
I $G(IBJOB)'=4,IBY<0 D ERRMSG^IBACVA2(1) G BILLQ
;
; - display message and get confirmation for Cancel/Edit/Add.
I $G(IBJOB)=4 D G:IBY<0 BILLQ
.W !!,"The following billing parameters have been calculated:"
.W !!," Bill From: ",$$DAT1^IBOUTL(IBFR)
.W !," Bill To: ",$$DAT1^IBOUTL(IBTO)
.W !," Charge: $",IBCHGT,!
.D PROC^IBECEAU4("add")
;
; - bill the charge
W !,"Billing the CHAMPVA inpatient subsistence charge..."
S IBUNIT=1,IBDESC="CHAMPVA SUBSISTENCE",IBCHG=IBCHGT,IBSL="405:"_IBSL
D ADD^IBECEAU3 W "completed."
;
; - need to pass to AR when I get an AR Category...
; - AND, set IBCOMMIT=1 for C/E/A
;
BILLQ Q
;
LIM(DATE) ; Find the CHAMPVA subsistence limit on DATE.
; Input: DATE -- The date on which to determine the limit
; Output: IBLIM -- The maximum subsistence charge for an episode
N X S IBLIM=0
S X=$O(^IBE(350.1,"E","CHAMPVA LIMIT",0)) I 'X S IBY="-1^IB083" G LIMQ
S X=$O(^IBE(350.2,"AIVDT",+X,-(DATE+.1))),X=$O(^(+X,0))
S IBLIM=$P($G(^IBE(350.2,+X,0)),"^",4) I 'IBLIM S IBY="-1^IB084"
LIMQ Q
;
PD(IBDT) ; Find the CHAMPVA per diem charge on IBDT.
; Input: IBDT -- The date on which to determine the per diem
; Output: IBCHG -- The CHAMPVA per diem charge on IBDT
; IBATYP -- CHAMPVA Action Type
S IBATYP=$O(^IBE(350.1,"E","CHAMPVA SUBSISTENCE",0)),IBCHG=0
I 'IBATYP S IBY="-1^IB008" G PDQ
D COST^IBAUTL2 I 'IBCHG S IBY="-1^IB029"
PDQ Q
;
PREV(DFN,DATE,LINK) ; Billed an admission the CHAMPVA subsistence charge?
; Input: DFN -- Pointer to patient in file #2
; DATE -- Event (admission) date
; LINK -- Pointer to mvmt in file #405
; Output: 0 -- Admission has not been billed, or
; >0 -- ien of billed charge in file #350
I '$G(DFN)!'$G(DATE)!'$G(LINK) G PREVQ
N IBN,IBND,IBP
S IBP=0 F S IBP=$O(^IB("ACVA",DFN,DATE,IBP)) Q:'IBP S IBN=$$LAST^IBECEAU(IBP),IBND=$G(^IB(IBN,0)) I $P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^",5)'=2,$P(IBND,"^",4)=("405:"_LINK),"^3^4^"[("^"_+$P(IBND,"^",5)_"^") S Y=IBN Q
PREVQ Q +$G(Y)
IBACVA1 ;ALB/CPM - BILL CHAMPVA SUBSISTENCE CHARGE ; 29-JUL-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
BILL ; Create the CHAMPVA inpatient subsistence charge.
+1 SET IBY=1
IF '$$CHECK^IBECEAU(0)
DO ERRMSG^IBACVA2(1)
GOTO BILLQ
+2 SET (IBCHGT,IBBILLED)=0
+3 ;
+4 ; - loop through each day of the admission, or until limit reached.
+5 FOR IBD=IBBDT:1:IBEDT
SET %H=IBD
DO YMD^%DTC
SET IBDT=X
Begin DoDot:1
+6 ; on leave
IF IBBDT'=IBEDT
SET VAIP("D")=IBDT_.2359
DO IN5^VADPT
IF 'VAIP(10)
QUIT
+7 ; can't find maximum limit
DO LIM(IBDT)
IF IBY<0
QUIT
+8 ; can't find daily per diem
DO PD(IBDT)
IF IBY<0
QUIT
+9 ; set 'from date' on 1st pass
IF 'IBCHGT
SET IBFR=IBDT
+10 ; build cumulative charge/set 'to date'
SET IBCHGT=IBCHGT+IBCHG
SET IBTO=IBDT
+11 ; quit if max limit reached
IF IBCHGT'<IBLIM
SET IBCHGT=IBLIM
SET IBBILLED=1
End DoDot:1
IF IBY<0!(IBBILLED)
QUIT
+12 ;
+13 ; - quit if there is no error, no charge to bill.
+14 IF IBY=1
IF 'IBCHGT
IF $GET(IBJOB)=4
WRITE !!,"There are no charges to be billed for this admission!"
GOTO BILLQ
+15 ;
+16 ; - send error message if error occurs.
+17 IF $GET(IBJOB)'=4
IF IBY<0
DO ERRMSG^IBACVA2(1)
GOTO BILLQ
+18 ;
+19 ; - display message and get confirmation for Cancel/Edit/Add.
+20 IF $GET(IBJOB)=4
Begin DoDot:1
+21 WRITE !!,"The following billing parameters have been calculated:"
+22 WRITE !!," Bill From: ",$$DAT1^IBOUTL(IBFR)
+23 WRITE !," Bill To: ",$$DAT1^IBOUTL(IBTO)
+24 WRITE !," Charge: $",IBCHGT,!
+25 DO PROC^IBECEAU4("add")
End DoDot:1
IF IBY<0
GOTO BILLQ
+26 ;
+27 ; - bill the charge
+28 WRITE !,"Billing the CHAMPVA inpatient subsistence charge..."
+29 SET IBUNIT=1
SET IBDESC="CHAMPVA SUBSISTENCE"
SET IBCHG=IBCHGT
SET IBSL="405:"_IBSL
+30 DO ADD^IBECEAU3
WRITE "completed."
+31 ;
+32 ; - need to pass to AR when I get an AR Category...
+33 ; - AND, set IBCOMMIT=1 for C/E/A
+34 ;
BILLQ QUIT
+1 ;
LIM(DATE) ; Find the CHAMPVA subsistence limit on DATE.
+1 ; Input: DATE -- The date on which to determine the limit
+2 ; Output: IBLIM -- The maximum subsistence charge for an episode
+3 NEW X
SET IBLIM=0
+4 SET X=$ORDER(^IBE(350.1,"E","CHAMPVA LIMIT",0))
IF 'X
SET IBY="-1^IB083"
GOTO LIMQ
+5 SET X=$ORDER(^IBE(350.2,"AIVDT",+X,-(DATE+.1)))
SET X=$ORDER(^(+X,0))
+6 SET IBLIM=$PIECE($GET(^IBE(350.2,+X,0)),"^",4)
IF 'IBLIM
SET IBY="-1^IB084"
LIMQ QUIT
+1 ;
PD(IBDT) ; Find the CHAMPVA per diem charge on IBDT.
+1 ; Input: IBDT -- The date on which to determine the per diem
+2 ; Output: IBCHG -- The CHAMPVA per diem charge on IBDT
+3 ; IBATYP -- CHAMPVA Action Type
+4 SET IBATYP=$ORDER(^IBE(350.1,"E","CHAMPVA SUBSISTENCE",0))
SET IBCHG=0
+5 IF 'IBATYP
SET IBY="-1^IB008"
GOTO PDQ
+6 DO COST^IBAUTL2
IF 'IBCHG
SET IBY="-1^IB029"
PDQ QUIT
+1 ;
PREV(DFN,DATE,LINK) ; Billed an admission the CHAMPVA subsistence charge?
+1 ; Input: DFN -- Pointer to patient in file #2
+2 ; DATE -- Event (admission) date
+3 ; LINK -- Pointer to mvmt in file #405
+4 ; Output: 0 -- Admission has not been billed, or
+5 ; >0 -- ien of billed charge in file #350
+6 IF '$GET(DFN)!'$GET(DATE)!'$GET(LINK)
GOTO PREVQ
+7 NEW IBN,IBND,IBP
+8 SET IBP=0
FOR
SET IBP=$ORDER(^IB("ACVA",DFN,DATE,IBP))
IF 'IBP
QUIT
SET IBN=$$LAST^IBECEAU(IBP)
SET IBND=$GET(^IB(IBN,0))
IF $PIECE($GET(^IBE(350.1,+$PIECE(IBND,"^",3),0)),"^",5)'=2
IF $PIECE(IBND,"^",4)=("405:"_LINK)
IF "^3^4^"[("^"_+$PIECE(IBND,"^",5)_"^")
SET Y=IBN
QUIT
PREVQ QUIT +$GET(Y)
