IBACVA1 ;ALB/CPM - BILL CHAMPVA SUBSISTENCE CHARGE ; 29-JUL-93
;;Version 2.0 ; INTEGRATED BILLING ;**27,45,52**; 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,1) G BILLQ
S IBCHGT=0
D LIM($$HTFM^XLFDT(IBBDT,1))
I IBY<0 W:$G(IBJOB)=4 !!,"Cannot determine the Subsistence limit!" D ERRMSG^IBACVA2(1,1) G BILLQ
;
; - calculate the subsistence charge for the episode
F IBD=IBBDT:1:IBEDT S IBDT=$$HTFM^XLFDT(IBD,1) D Q:IBY<0
.I IBBDT'=IBEDT S VAIP("D")=IBDT_.2359 D IN5^VADPT Q:'VAIP(10) ; on leave
.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 IBY<0 W:$G(IBJOB)=4 !!,"Cannot determine Subsistence per diem rate!" D ERRMSG^IBACVA2(1,1) G BILLQ
I IBCHGT<IBLIM S IBCHGT=IBLIM,IBTO=IBDT
;
; - 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:'$G(DGQUIET) !,"Billing the CHAMPVA inpatient subsistence charge..."
S IBUNIT=1,IBDESC="CHAMPVA SUBSISTENCE",IBCHG=IBCHGT,IBSL="405:"_IBSL
D ADD^IBECEAU3 I IBY<0 D ERRMSG^IBACVA2(1,1) G BILLQ
;
; - release the charge to AR
D AR^IBR I IBY<0 D ERRMSG^IBACVA2(1,1) G BILLQ
;
S:$G(IBJOB)=4 IBCOMMIT=1 W:'$G(DGQUIET) "completed."
;
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,Y
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)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBACVA1 3137 printed Dec 13, 2024@02:05:54 Page 2
IBACVA1 ;ALB/CPM - BILL CHAMPVA SUBSISTENCE CHARGE ; 29-JUL-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**27,45,52**; 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,1)
GOTO BILLQ
+2 SET IBCHGT=0
+3 DO LIM($$HTFM^XLFDT(IBBDT,1))
+4 IF IBY<0
if $GET(IBJOB)=4
WRITE !!,"Cannot determine the Subsistence limit!"
DO ERRMSG^IBACVA2(1,1)
GOTO BILLQ
+5 ;
+6 ; - calculate the subsistence charge for the episode
+7 FOR IBD=IBBDT:1:IBEDT
SET IBDT=$$HTFM^XLFDT(IBD,1)
Begin DoDot:1
+8 ; on leave
IF IBBDT'=IBEDT
SET VAIP("D")=IBDT_.2359
DO IN5^VADPT
if 'VAIP(10)
QUIT
+9 ; can't find daily per diem
DO PD(IBDT)
if IBY<0
QUIT
+10 ; set 'from date' on 1st pass
if 'IBCHGT
SET IBFR=IBDT
+11 ; build cumulative charge/set 'to date'
SET IBCHGT=IBCHGT+IBCHG
SET IBTO=IBDT
End DoDot:1
if IBY<0
QUIT
+12 IF IBY<0
if $GET(IBJOB)=4
WRITE !!,"Cannot determine Subsistence per diem rate!"
DO ERRMSG^IBACVA2(1,1)
GOTO BILLQ
+13 IF IBCHGT<IBLIM
SET IBCHGT=IBLIM
SET IBTO=IBDT
+14 ;
+15 ; - display message and get confirmation for Cancel/Edit/Add.
+16 IF $GET(IBJOB)=4
Begin DoDot:1
+17 WRITE !!,"The following billing parameters have been calculated:"
+18 WRITE !!," Bill From: ",$$DAT1^IBOUTL(IBFR)
+19 WRITE !," Bill To: ",$$DAT1^IBOUTL(IBTO)
+20 WRITE !," Charge: $",IBCHGT,!
+21 DO PROC^IBECEAU4("add")
End DoDot:1
if IBY<0
GOTO BILLQ
+22 ;
+23 ; - bill the charge
+24 if '$GET(DGQUIET)
WRITE !,"Billing the CHAMPVA inpatient subsistence charge..."
+25 SET IBUNIT=1
SET IBDESC="CHAMPVA SUBSISTENCE"
SET IBCHG=IBCHGT
SET IBSL="405:"_IBSL
+26 DO ADD^IBECEAU3
IF IBY<0
DO ERRMSG^IBACVA2(1,1)
GOTO BILLQ
+27 ;
+28 ; - release the charge to AR
+29 DO AR^IBR
IF IBY<0
DO ERRMSG^IBACVA2(1,1)
GOTO BILLQ
+30 ;
+31 if $GET(IBJOB)=4
SET IBCOMMIT=1
if '$GET(DGQUIET)
WRITE "completed."
+32 ;
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,Y
+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)
