IBAUTL4 ;ALB/CPM - MEANS TEST BILLING UTILITIES (CON'T.) ; 10-OCT-91
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ; Calculate inpatient co-pay, per diem charges for a date range
; Input: DFN, IBBDT, IBEDT, IBCLDA, IBEVDA, IBY, IBAFY
; IBCLCT/IBCLDAY/IBCLDOL (if IBCLDA'=0)
F IBDATE=IBBDT:1:IBEDT S %H=IBDATE D YMD^%DTC S IBDT=X D CALC Q:IBY<1
Q
;
CALC ; Find charges for one day
S (IBEVNEW,IBEVOLD)=0
; - increment clock
I IBCLDA S IBCLCT=IBCLCT+1 I IBCLCT>365 S IBWHER=2 D PASS^IBAUTL5:IBEVDA,CLOCKCL^IBAUTL3:IBY>0 G:IBY<1 CALCQ
; - Cat C?
I '$$BIL^DGMTUB(DFN,IBDT+.2359) G:'IBCLDA CALCQ S IBWHER=3 D PASS^IBAUTL5:IBEVDA,CLOCKCL^IBAUTL3:IBY>0 G CALCQ
; - on leave?
S VAIP("D")=IBDT_.2359 D IN5^VADPT S IBBS=$$SECT^IBAUTL5(+VAIP(8)),IBSL="405:"_VAIP(1)
I 'VAIP(10) D G CALCQ
. I IBBS,'IBCLDA S IBCLDT=IBDT,IBWHER=7 D CLADD^IBAUTL3 S (IBCLDAY,IBCLDOL)=0,IBCLCT=1
. Q:'IBCLDA S IBWHER=4 D PASS^IBAUTL5:IBEVDA,CLOCKCL^IBAUTL3:IBCLCT'<365&(IBY>0)
; - check billing status
I 'IBBS S IBWHER=5 D:IBEVDA PASS^IBAUTL5,EVCLOS1^IBAUTL3:IBY>0 D G CALCQ
. S IBEVDA=0 Q:'IBCLDA!(IBY<1) D:IBCLCT'<365 CLOCKCL^IBAUTL3
S IBNH=$P($G(^DGCR(399.1,IBBS,0)),"^")["NURSING"
I 'IBEVDA S IBEVDT=+VAIP(3)\1,IBWHER=6 D EVADD^IBAUTL3 G:IBY<1 CALCQ
; - will bill today--got a clock?
I 'IBCLDA S IBCLDT=IBDT,IBWHER=7 D CLADD^IBAUTL3 G:IBY<1 CALCQ S (IBCLDAY,IBCLDOL)=0,IBCLCT=1
; - cancel any OPT charges
D OPT^IBAMTD1(DFN,IBDT)
; - update clock, $$ if starting another 90-day period of care
I IBCLDAY,'(IBCLDAY#90) D CLUPD^IBAUTL3 S:IBCLDAY'=360 IBCLDOL=0
S IBCLDAY=IBCLDAY+1
; - process per diem
G:IBDT<$$DIEM^IBAUTL5 COPAY ; date is prior to per diem billing date
S IBX="P",IBWHER=8 D TYPE^IBAUTL2 G:IBY<1 CALCQ
D CHFIND^IBAUTL2 S IBNOS=IBCHPDA,IBCHPDE=$P($G(^IB(+IBCHPDA,0)),"^",8),IBWHER=9
; - update or pass to A/R an incomplete per diem charge
I IBCHPDA D G:IBY<1 CALCQ
. I (IBCHPDE["INPT"&(IBNH))!(IBCHPDE["NHC"&('IBNH)) D Q
.. D FILER^IBAUTL5,EVCLOS1^IBAUTL3:IBY>0 Q:IBY<1
.. S IBEVDT=+VAIP(3)\1,IBEVOLD=IBEVDA,IBWHER=10
.. D EVADD^IBAUTL3 Q:IBY<1 S IBCHPDA=0,IBEVNEW=IBEVDA
. S X1=IBDT,X2=IBCHTO D ^%DTC I X'=1 S IBWHER=11 D FILER^IBAUTL5 S IBCHPDA=0 Q
. S IBN=IBCHPDA D CHUPD^IBAUTL2
I 'IBCHPDA S IBWHER=13 D CHADD^IBAUTL2 G:IBY<0 CALCQ S IBCHPDA=IBN
COPAY ; - process co-payment
G:IBCLDAY>360!($$CONT^IBAUTL5(DFN)>IBDT) LAST ; last 5 days are grace days, or pt is continuous
S IBMAX=IBMED I IBCLDAY>90,'IBNH S IBMAX=IBMAX/2
G:IBCLDOL'<IBMAX LAST
S IBWHER=14 D COPAY^IBAUTL2 G:IBY<1 CALCQ
S IBCHARG=IBMAX-IBCLDOL I IBCHG<IBCHARG S IBCHARG=IBCHG
S IBCHG=IBCHARG S:IBCHG<0 IBCHG=0
S IBCLDOL=IBCLDOL+IBCHG
S:IBEVOLD IBEVDA=IBEVOLD S IBX="C" D CHFIND^IBAUTL2
S IBNOS=IBCHCDA,IBCHCTY=$P($G(^IB(+IBCHCDA,0)),"^",3) S:IBEVNEW IBEVDA=IBEVNEW
; - update or pass to A/R an incomplete copay charge
I IBCHCDA D G:IBY<1 CALCQ
. I IBCHCTY'=IBATYP S IBWHER=15 D FILER^IBAUTL5 S IBCHCDA=0 Q
. S X1=IBDT,X2=IBCHTO D ^%DTC I X'=1 S IBWHER=16 D FILER^IBAUTL5 S IBCHCDA=0 Q
. S IBN=IBCHCDA D CHUPD^IBAUTL2
I 'IBCHCDA S IBWHER=18 D CHADD^IBAUTL2 G:IBY<1 CALCQ S IBCHCDA=IBN
I IBCHCDA,IBCLDOL'<IBMAX S IBEVOLD=0,IBNOS=IBCHCDA,IBWHER=19 D FILER^IBAUTL5 G:IBY<1 CALCQ S IBCHCDA=0
LAST ; - handle last day of billing clock
G:IBCLCT<365 CALCQ
I $G(IBCHPDA) S IBNOS=IBCHPDA,IBWHER=20 D FILER^IBAUTL5 G:IBY<1 CALCQ S IBCHPDA=0
I $G(IBCHCDA) S IBNOS=IBCHCDA,IBWHER=21 D FILER^IBAUTL5 G:IBY<1 CALCQ S IBCHCDA=0
D CLOCKCL^IBAUTL3
CALCQ W:$G(IBJOB)=2 "." Q
IBAUTL4 ;ALB/CPM - MEANS TEST BILLING UTILITIES (CON'T.) ; 10-OCT-91
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ; Calculate inpatient co-pay, per diem charges for a date range
+1 ; Input: DFN, IBBDT, IBEDT, IBCLDA, IBEVDA, IBY, IBAFY
+2 ; IBCLCT/IBCLDAY/IBCLDOL (if IBCLDA'=0)
+3 FOR IBDATE=IBBDT:1:IBEDT
SET %H=IBDATE
DO YMD^%DTC
SET IBDT=X
DO CALC
IF IBY<1
QUIT
+4 QUIT
+5 ;
CALC ; Find charges for one day
+1 SET (IBEVNEW,IBEVOLD)=0
+2 ; - increment clock
+3 IF IBCLDA
SET IBCLCT=IBCLCT+1
IF IBCLCT>365
SET IBWHER=2
IF IBEVDA
DO PASS^IBAUTL5
IF IBY>0
DO CLOCKCL^IBAUTL3
IF IBY<1
GOTO CALCQ
+4 ; - Cat C?
+5 IF '$$BIL^DGMTUB(DFN,IBDT+.2359)
IF 'IBCLDA
GOTO CALCQ
SET IBWHER=3
IF IBEVDA
DO PASS^IBAUTL5
IF IBY>0
DO CLOCKCL^IBAUTL3
GOTO CALCQ
+6 ; - on leave?
+7 SET VAIP("D")=IBDT_.2359
DO IN5^VADPT
SET IBBS=$$SECT^IBAUTL5(+VAIP(8))
SET IBSL="405:"_VAIP(1)
+8 IF 'VAIP(10)
Begin DoDot:1
+9 IF IBBS
IF 'IBCLDA
SET IBCLDT=IBDT
SET IBWHER=7
DO CLADD^IBAUTL3
SET (IBCLDAY,IBCLDOL)=0
SET IBCLCT=1
+10 IF 'IBCLDA
QUIT
SET IBWHER=4
IF IBEVDA
DO PASS^IBAUTL5
IF IBCLCT'<365&(IBY>0)
DO CLOCKCL^IBAUTL3
End DoDot:1
GOTO CALCQ
+11 ; - check billing status
+12 IF 'IBBS
SET IBWHER=5
IF IBEVDA
DO PASS^IBAUTL5
IF IBY>0
DO EVCLOS1^IBAUTL3
Begin DoDot:1
+13 SET IBEVDA=0
IF 'IBCLDA!(IBY<1)
QUIT
IF IBCLCT'<365
DO CLOCKCL^IBAUTL3
End DoDot:1
GOTO CALCQ
+14 SET IBNH=$PIECE($GET(^DGCR(399.1,IBBS,0)),"^")["NURSING"
+15 IF 'IBEVDA
SET IBEVDT=+VAIP(3)\1
SET IBWHER=6
DO EVADD^IBAUTL3
IF IBY<1
GOTO CALCQ
+16 ; - will bill today--got a clock?
+17 IF 'IBCLDA
SET IBCLDT=IBDT
SET IBWHER=7
DO CLADD^IBAUTL3
IF IBY<1
GOTO CALCQ
SET (IBCLDAY,IBCLDOL)=0
SET IBCLCT=1
+18 ; - cancel any OPT charges
+19 DO OPT^IBAMTD1(DFN,IBDT)
+20 ; - update clock, $$ if starting another 90-day period of care
+21 IF IBCLDAY
IF '(IBCLDAY#90)
DO CLUPD^IBAUTL3
IF IBCLDAY'=360
SET IBCLDOL=0
+22 SET IBCLDAY=IBCLDAY+1
+23 ; - process per diem
+24 ; date is prior to per diem billing date
IF IBDT<$$DIEM^IBAUTL5
GOTO COPAY
+25 SET IBX="P"
SET IBWHER=8
DO TYPE^IBAUTL2
IF IBY<1
GOTO CALCQ
+26 DO CHFIND^IBAUTL2
SET IBNOS=IBCHPDA
SET IBCHPDE=$PIECE($GET(^IB(+IBCHPDA,0)),"^",8)
SET IBWHER=9
+27 ; - update or pass to A/R an incomplete per diem charge
+28 IF IBCHPDA
Begin DoDot:1
+29 IF (IBCHPDE["INPT"&(IBNH))!(IBCHPDE["NHC"&('IBNH))
Begin DoDot:2
+30 DO FILER^IBAUTL5
IF IBY>0
DO EVCLOS1^IBAUTL3
IF IBY<1
QUIT
+31 SET IBEVDT=+VAIP(3)\1
SET IBEVOLD=IBEVDA
SET IBWHER=10
+32 DO EVADD^IBAUTL3
IF IBY<1
QUIT
SET IBCHPDA=0
SET IBEVNEW=IBEVDA
End DoDot:2
QUIT
+33 SET X1=IBDT
SET X2=IBCHTO
DO ^%DTC
IF X'=1
SET IBWHER=11
DO FILER^IBAUTL5
SET IBCHPDA=0
QUIT
+34 SET IBN=IBCHPDA
DO CHUPD^IBAUTL2
End DoDot:1
IF IBY<1
GOTO CALCQ
+35 IF 'IBCHPDA
SET IBWHER=13
DO CHADD^IBAUTL2
IF IBY<0
GOTO CALCQ
SET IBCHPDA=IBN
COPAY ; - process co-payment
+1 ; last 5 days are grace days, or pt is continuous
IF IBCLDAY>360!($$CONT^IBAUTL5(DFN)>IBDT)
GOTO LAST
+2 SET IBMAX=IBMED
IF IBCLDAY>90
IF 'IBNH
SET IBMAX=IBMAX/2
+3 IF IBCLDOL'<IBMAX
GOTO LAST
+4 SET IBWHER=14
DO COPAY^IBAUTL2
IF IBY<1
GOTO CALCQ
+5 SET IBCHARG=IBMAX-IBCLDOL
IF IBCHG<IBCHARG
SET IBCHARG=IBCHG
+6 SET IBCHG=IBCHARG
IF IBCHG<0
SET IBCHG=0
+7 SET IBCLDOL=IBCLDOL+IBCHG
+8 IF IBEVOLD
SET IBEVDA=IBEVOLD
SET IBX="C"
DO CHFIND^IBAUTL2
+9 SET IBNOS=IBCHCDA
SET IBCHCTY=$PIECE($GET(^IB(+IBCHCDA,0)),"^",3)
IF IBEVNEW
SET IBEVDA=IBEVNEW
+10 ; - update or pass to A/R an incomplete copay charge
+11 IF IBCHCDA
Begin DoDot:1
+12 IF IBCHCTY'=IBATYP
SET IBWHER=15
DO FILER^IBAUTL5
SET IBCHCDA=0
QUIT
+13 SET X1=IBDT
SET X2=IBCHTO
DO ^%DTC
IF X'=1
SET IBWHER=16
DO FILER^IBAUTL5
SET IBCHCDA=0
QUIT
+14 SET IBN=IBCHCDA
DO CHUPD^IBAUTL2
End DoDot:1
IF IBY<1
GOTO CALCQ
+15 IF 'IBCHCDA
SET IBWHER=18
DO CHADD^IBAUTL2
IF IBY<1
GOTO CALCQ
SET IBCHCDA=IBN
+16 IF IBCHCDA
IF IBCLDOL'<IBMAX
SET IBEVOLD=0
SET IBNOS=IBCHCDA
SET IBWHER=19
DO FILER^IBAUTL5
IF IBY<1
GOTO CALCQ
SET IBCHCDA=0
LAST ; - handle last day of billing clock
+1 IF IBCLCT<365
GOTO CALCQ
+2 IF $GET(IBCHPDA)
SET IBNOS=IBCHPDA
SET IBWHER=20
DO FILER^IBAUTL5
IF IBY<1
GOTO CALCQ
SET IBCHPDA=0
+3 IF $GET(IBCHCDA)
SET IBNOS=IBCHCDA
SET IBWHER=21
DO FILER^IBAUTL5
IF IBY<1
GOTO CALCQ
SET IBCHCDA=0
+4 DO CLOCKCL^IBAUTL3
CALCQ IF $GET(IBJOB)=2
WRITE "."
QUIT
