IBAUTL4 ;ALB/CPM-MEANS TEST BILLING UTILITIES (CON'T.) ;10-OCT-91
;;2.0;INTEGRATED BILLING;**45,153,171,176,179,183,202**;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
N IBGMT,IBGMTR,IBGMTEFD ;GMT Status,GMT Related flag,GMT Effective Date
S (IBEVNEW,IBEVOLD,IBGMT,IBGMTR)=0
; - is LTC?
I IBDT'<$$STDATE^IBAECU1() S VAIP("D")=IBDT_.2359 D IN5^VADPT I $P($$TREATSP^IBAECU2($P($G(^DIC(45.7,+VAIP(8),0)),U,2)),"^",1)="L"!($$ASIHORG^IBAECN1(DFN,+$G(IBEVDA),IBDT)=1) D G CALCQ
. I '$D(IBSITE) N IBSITE,IBFAC D SITE^IBAUTL
. D CANCVIS^IBAECU5(DFN,IBDT) ;cancel OPT charges for this date
. Q:$$CLOCK^IBAECU(DFN,IBDT) ; - 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
; - Means Test billable?
I '$$BIL^DGMTUB(DFN,IBDT+.2359) G:'IBCLDA CALCQ S IBWHER=3 D PASS^IBAUTL5:IBEVDA,CLOCKCL^IBAUTL3:IBY>0 G CALCQ
; - GMT Status?
S IBGMT=$$ISGMTPT^IBAGMT(DFN,IBDT+.2359)
S IBGMTEFD=$$GMTEFD^IBAGMT() ; GMT Effective Date
; - 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
S IBGMTR=0 I IBGMT>0,IBDT'<IBGMTEFD,$$ISGMTTYP^IBAGMT(IBATYP) S IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG) ;GMT Charge Adjustment
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
. ; Split pre- and post- GMT Eff.Date charges, for GMT patients only
. I IBGMT'=0,IBDT'<IBGMTEFD,$$ISGMTTYP^IBAGMT(IBATYP),IBCHTO<IBGMTEFD S IBWHER=11 D FILER^IBAUTL5 S IBCHPDA=0 Q
. ; Split charges, if the patient just received or lost GMT Status
. I (+$P($G(^IB(+IBCHPDA,0)),"^",21))'=IBGMTR 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 IBGMT>0,IBDT'<IBGMTEFD S IBMAX=$$REDUCE^IBAGMT(IBMAX) ;Adjust deductible for GMT patients
I IBCLDAY>90,'IBNH S IBMAX=IBMAX/2
G:IBCLDOL'<IBMAX LAST
S IBWHER=14 D COPAY^IBAUTL2 G:IBY<1 CALCQ
S IBGMTR=0 I IBGMT>0,IBDT'<IBGMTEFD S IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG) ;GMT Charge Adjustment
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
. ; Split pre- and post- GMT Eff.Date charges
. I IBGMT'=0,IBDT'<IBGMTEFD,IBCHTO<IBGMTEFD S IBWHER=16 D FILER^IBAUTL5 S IBCHPDA=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 I $G(IBJOB)=2,'$G(DGQUIET) W "."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAUTL4 5031 printed Oct 16, 2024@18:08:48 Page 2
IBAUTL4 ;ALB/CPM-MEANS TEST BILLING UTILITIES (CON'T.) ;10-OCT-91
+1 ;;2.0;INTEGRATED BILLING;**45,153,171,176,179,183,202**;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 ;GMT Status,GMT Related flag,GMT Effective Date
NEW IBGMT,IBGMTR,IBGMTEFD
+2 SET (IBEVNEW,IBEVOLD,IBGMT,IBGMTR)=0
+3 ; - is LTC?
+4 IF IBDT'<$$STDATE^IBAECU1()
SET VAIP("D")=IBDT_.2359
DO IN5^VADPT
IF $PIECE($$TREATSP^IBAECU2($PIECE($GET(^DIC(45.7,+VAIP(8),0)),U,2)),"^",1)="L"!($$ASIHORG^IBAECN1(DFN,+$GET(IBEVDA),IBDT)=1)
Begin DoDot:1
+5 IF '$DATA(IBSITE)
NEW IBSITE,IBFAC
DO SITE^IBAUTL
+6 ;cancel OPT charges for this date
DO CANCVIS^IBAECU5(DFN,IBDT)
+7 ; - increment clock
if $$CLOCK^IBAECU(DFN,IBDT)
QUIT
End DoDot:1
GOTO CALCQ
+8 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
+9 ; - Means Test billable?
+10 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
+11 ; - GMT Status?
+12 SET IBGMT=$$ISGMTPT^IBAGMT(DFN,IBDT+.2359)
+13 ; GMT Effective Date
SET IBGMTEFD=$$GMTEFD^IBAGMT()
+14 ; - on leave?
+15 SET VAIP("D")=IBDT_.2359
DO IN5^VADPT
SET IBBS=$$SECT^IBAUTL5(+VAIP(8))
SET IBSL="405:"_VAIP(1)
+16 IF 'VAIP(10)
Begin DoDot:1
+17 IF IBBS
IF 'IBCLDA
SET IBCLDT=IBDT
SET IBWHER=7
DO CLADD^IBAUTL3
SET (IBCLDAY,IBCLDOL)=0
SET IBCLCT=1
+18 if 'IBCLDA
QUIT
SET IBWHER=4
if IBEVDA
DO PASS^IBAUTL5
if IBCLCT'<365&(IBY>0)
DO CLOCKCL^IBAUTL3
End DoDot:1
GOTO CALCQ
+19 ; - check billing status
+20 IF 'IBBS
SET IBWHER=5
if IBEVDA
DO PASS^IBAUTL5
if IBY>0
DO EVCLOS1^IBAUTL3
Begin DoDot:1
+21 SET IBEVDA=0
if 'IBCLDA!(IBY<1)
QUIT
if IBCLCT'<365
DO CLOCKCL^IBAUTL3
End DoDot:1
GOTO CALCQ
+22 SET IBNH=$PIECE($GET(^DGCR(399.1,IBBS,0)),"^")["NURSING"
+23 IF 'IBEVDA
SET IBEVDT=+VAIP(3)\1
SET IBWHER=6
DO EVADD^IBAUTL3
if IBY<1
GOTO CALCQ
+24 ; - will bill today--got a clock?
+25 IF 'IBCLDA
SET IBCLDT=IBDT
SET IBWHER=7
DO CLADD^IBAUTL3
if IBY<1
GOTO CALCQ
SET (IBCLDAY,IBCLDOL)=0
SET IBCLCT=1
+26 ; - cancel any OPT charges
+27 DO OPT^IBAMTD1(DFN,IBDT)
+28 ; - update clock, $$ if starting another 90-day period of care
+29 IF IBCLDAY
IF '(IBCLDAY#90)
DO CLUPD^IBAUTL3
if IBCLDAY'=360
SET IBCLDOL=0
+30 SET IBCLDAY=IBCLDAY+1
+31 ; - process per diem
+32 ; date is prior to per diem billing date
if IBDT<$$DIEM^IBAUTL5
GOTO COPAY
+33 SET IBX="P"
SET IBWHER=8
DO TYPE^IBAUTL2
if IBY<1
GOTO CALCQ
+34 ;GMT Charge Adjustment
SET IBGMTR=0
IF IBGMT>0
IF IBDT'<IBGMTEFD
IF $$ISGMTTYP^IBAGMT(IBATYP)
SET IBGMTR=1
SET IBCHG=$$REDUCE^IBAGMT(IBCHG)
+35 DO CHFIND^IBAUTL2
SET IBNOS=IBCHPDA
SET IBCHPDE=$PIECE($GET(^IB(+IBCHPDA,0)),"^",8)
SET IBWHER=9
+36 ; - update or pass to A/R an incomplete per diem charge
+37 IF IBCHPDA
Begin DoDot:1
+38 IF (IBCHPDE["INPT"&(IBNH))!(IBCHPDE["NHC"&('IBNH))
Begin DoDot:2
+39 DO FILER^IBAUTL5
if IBY>0
DO EVCLOS1^IBAUTL3
if IBY<1
QUIT
+40 SET IBEVDT=+VAIP(3)\1
SET IBEVOLD=IBEVDA
SET IBWHER=10
+41 DO EVADD^IBAUTL3
if IBY<1
QUIT
SET IBCHPDA=0
SET IBEVNEW=IBEVDA
End DoDot:2
QUIT
+42 SET X1=IBDT
SET X2=IBCHTO
DO ^%DTC
IF X'=1
SET IBWHER=11
DO FILER^IBAUTL5
SET IBCHPDA=0
QUIT
+43 ; Split pre- and post- GMT Eff.Date charges, for GMT patients only
+44 IF IBGMT'=0
IF IBDT'<IBGMTEFD
IF $$ISGMTTYP^IBAGMT(IBATYP)
IF IBCHTO<IBGMTEFD
SET IBWHER=11
DO FILER^IBAUTL5
SET IBCHPDA=0
QUIT
+45 ; Split charges, if the patient just received or lost GMT Status
+46 IF (+$PIECE($GET(^IB(+IBCHPDA,0)),"^",21))'=IBGMTR
SET IBWHER=11
DO FILER^IBAUTL5
SET IBCHPDA=0
QUIT
+47 SET IBN=IBCHPDA
DO CHUPD^IBAUTL2
End DoDot:1
if IBY<1
GOTO CALCQ
+48 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
+3 ;Adjust deductible for GMT patients
IF IBGMT>0
IF IBDT'<IBGMTEFD
SET IBMAX=$$REDUCE^IBAGMT(IBMAX)
+4 IF IBCLDAY>90
IF 'IBNH
SET IBMAX=IBMAX/2
+5 if IBCLDOL'<IBMAX
GOTO LAST
+6 SET IBWHER=14
DO COPAY^IBAUTL2
if IBY<1
GOTO CALCQ
+7 ;GMT Charge Adjustment
SET IBGMTR=0
IF IBGMT>0
IF IBDT'<IBGMTEFD
SET IBGMTR=1
SET IBCHG=$$REDUCE^IBAGMT(IBCHG)
+8 SET IBCHARG=IBMAX-IBCLDOL
IF IBCHG<IBCHARG
SET IBCHARG=IBCHG
+9 SET IBCHG=IBCHARG
if IBCHG<0
SET IBCHG=0
+10 SET IBCLDOL=IBCLDOL+IBCHG
+11 if IBEVOLD
SET IBEVDA=IBEVOLD
SET IBX="C"
DO CHFIND^IBAUTL2
+12 SET IBNOS=IBCHCDA
SET IBCHCTY=$PIECE($GET(^IB(+IBCHCDA,0)),"^",3)
if IBEVNEW
SET IBEVDA=IBEVNEW
+13 ; - update or pass to A/R an incomplete copay charge
+14 IF IBCHCDA
Begin DoDot:1
+15 IF IBCHCTY'=IBATYP
SET IBWHER=15
DO FILER^IBAUTL5
SET IBCHCDA=0
QUIT
+16 SET X1=IBDT
SET X2=IBCHTO
DO ^%DTC
IF X'=1
SET IBWHER=16
DO FILER^IBAUTL5
SET IBCHCDA=0
QUIT
+17 ; Split pre- and post- GMT Eff.Date charges
+18 IF IBGMT'=0
IF IBDT'<IBGMTEFD
IF IBCHTO<IBGMTEFD
SET IBWHER=16
DO FILER^IBAUTL5
SET IBCHPDA=0
QUIT
+19 SET IBN=IBCHCDA
DO CHUPD^IBAUTL2
End DoDot:1
if IBY<1
GOTO CALCQ
+20 IF 'IBCHCDA
SET IBWHER=18
DO CHADD^IBAUTL2
if IBY<1
GOTO CALCQ
SET IBCHCDA=IBN
+21 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
IF '$GET(DGQUIET)
WRITE "."
+1 QUIT
