- 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 Jan 18, 2025@03:09:20 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