Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBAUTL4

IBAUTL4.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. EN ; Calculate inpatient co-pay, per diem charges for a date range
  1. ; Input: DFN, IBBDT, IBEDT, IBCLDA, IBEVDA, IBY, IBAFY
  1. ; IBCLCT/IBCLDAY/IBCLDOL (if IBCLDA'=0)
  1. F IBDATE=IBBDT:1:IBEDT S %H=IBDATE D YMD^%DTC S IBDT=X D CALC Q:IBY<1
  1. Q
  1. ;
  1. CALC ; Find charges for one day
  1. N IBGMT,IBGMTR,IBGMTEFD ;GMT Status,GMT Related flag,GMT Effective Date
  1. S (IBEVNEW,IBEVOLD,IBGMT,IBGMTR)=0
  1. ; - is LTC?
  1. 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
  1. . I '$D(IBSITE) N IBSITE,IBFAC D SITE^IBAUTL
  1. . D CANCVIS^IBAECU5(DFN,IBDT) ;cancel OPT charges for this date
  1. . Q:$$CLOCK^IBAECU(DFN,IBDT) ; - increment clock
  1. I IBCLDA S IBCLCT=IBCLCT+1 I IBCLCT>365 S IBWHER=2 D PASS^IBAUTL5:IBEVDA,CLOCKCL^IBAUTL3:IBY>0 G:IBY<1 CALCQ
  1. ; - Means Test billable?
  1. I '$$BIL^DGMTUB(DFN,IBDT+.2359) G:'IBCLDA CALCQ S IBWHER=3 D PASS^IBAUTL5:IBEVDA,CLOCKCL^IBAUTL3:IBY>0 G CALCQ
  1. ; - GMT Status?
  1. S IBGMT=$$ISGMTPT^IBAGMT(DFN,IBDT+.2359)
  1. S IBGMTEFD=$$GMTEFD^IBAGMT() ; GMT Effective Date
  1. ; - on leave?
  1. S VAIP("D")=IBDT_.2359 D IN5^VADPT S IBBS=$$SECT^IBAUTL5(+VAIP(8)),IBSL="405:"_VAIP(1)
  1. I 'VAIP(10) D G CALCQ
  1. . I IBBS,'IBCLDA S IBCLDT=IBDT,IBWHER=7 D CLADD^IBAUTL3 S (IBCLDAY,IBCLDOL)=0,IBCLCT=1
  1. . Q:'IBCLDA S IBWHER=4 D PASS^IBAUTL5:IBEVDA,CLOCKCL^IBAUTL3:IBCLCT'<365&(IBY>0)
  1. ; - check billing status
  1. I 'IBBS S IBWHER=5 D:IBEVDA PASS^IBAUTL5,EVCLOS1^IBAUTL3:IBY>0 D G CALCQ
  1. . S IBEVDA=0 Q:'IBCLDA!(IBY<1) D:IBCLCT'<365 CLOCKCL^IBAUTL3
  1. S IBNH=$P($G(^DGCR(399.1,IBBS,0)),"^")["NURSING"
  1. I 'IBEVDA S IBEVDT=+VAIP(3)\1,IBWHER=6 D EVADD^IBAUTL3 G:IBY<1 CALCQ
  1. ; - will bill today--got a clock?
  1. I 'IBCLDA S IBCLDT=IBDT,IBWHER=7 D CLADD^IBAUTL3 G:IBY<1 CALCQ S (IBCLDAY,IBCLDOL)=0,IBCLCT=1
  1. ; - cancel any OPT charges
  1. D OPT^IBAMTD1(DFN,IBDT)
  1. ; - update clock, $$ if starting another 90-day period of care
  1. I IBCLDAY,'(IBCLDAY#90) D CLUPD^IBAUTL3 S:IBCLDAY'=360 IBCLDOL=0
  1. S IBCLDAY=IBCLDAY+1
  1. ; - process per diem
  1. G:IBDT<$$DIEM^IBAUTL5 COPAY ; date is prior to per diem billing date
  1. S IBX="P",IBWHER=8 D TYPE^IBAUTL2 G:IBY<1 CALCQ
  1. S IBGMTR=0 I IBGMT>0,IBDT'<IBGMTEFD,$$ISGMTTYP^IBAGMT(IBATYP) S IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG) ;GMT Charge Adjustment
  1. D CHFIND^IBAUTL2 S IBNOS=IBCHPDA,IBCHPDE=$P($G(^IB(+IBCHPDA,0)),"^",8),IBWHER=9
  1. ; - update or pass to A/R an incomplete per diem charge
  1. I IBCHPDA D G:IBY<1 CALCQ
  1. . I (IBCHPDE["INPT"&(IBNH))!(IBCHPDE["NHC"&('IBNH)) D Q
  1. .. D FILER^IBAUTL5,EVCLOS1^IBAUTL3:IBY>0 Q:IBY<1
  1. .. S IBEVDT=+VAIP(3)\1,IBEVOLD=IBEVDA,IBWHER=10
  1. .. D EVADD^IBAUTL3 Q:IBY<1 S IBCHPDA=0,IBEVNEW=IBEVDA
  1. . S X1=IBDT,X2=IBCHTO D ^%DTC I X'=1 S IBWHER=11 D FILER^IBAUTL5 S IBCHPDA=0 Q
  1. . ; Split pre- and post- GMT Eff.Date charges, for GMT patients only
  1. . I IBGMT'=0,IBDT'<IBGMTEFD,$$ISGMTTYP^IBAGMT(IBATYP),IBCHTO<IBGMTEFD S IBWHER=11 D FILER^IBAUTL5 S IBCHPDA=0 Q
  1. . ; Split charges, if the patient just received or lost GMT Status
  1. . I (+$P($G(^IB(+IBCHPDA,0)),"^",21))'=IBGMTR S IBWHER=11 D FILER^IBAUTL5 S IBCHPDA=0 Q
  1. . S IBN=IBCHPDA D CHUPD^IBAUTL2
  1. I 'IBCHPDA S IBWHER=13 D CHADD^IBAUTL2 G:IBY<0 CALCQ S IBCHPDA=IBN
  1. COPAY ; - process co-payment
  1. G:IBCLDAY>360!($$CONT^IBAUTL5(DFN)>IBDT) LAST ; last 5 days are grace days, or pt is continuous
  1. S IBMAX=IBMED
  1. I IBGMT>0,IBDT'<IBGMTEFD S IBMAX=$$REDUCE^IBAGMT(IBMAX) ;Adjust deductible for GMT patients
  1. I IBCLDAY>90,'IBNH S IBMAX=IBMAX/2
  1. G:IBCLDOL'<IBMAX LAST
  1. S IBWHER=14 D COPAY^IBAUTL2 G:IBY<1 CALCQ
  1. S IBGMTR=0 I IBGMT>0,IBDT'<IBGMTEFD S IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG) ;GMT Charge Adjustment
  1. S IBCHARG=IBMAX-IBCLDOL I IBCHG<IBCHARG S IBCHARG=IBCHG
  1. S IBCHG=IBCHARG S:IBCHG<0 IBCHG=0
  1. S IBCLDOL=IBCLDOL+IBCHG
  1. S:IBEVOLD IBEVDA=IBEVOLD S IBX="C" D CHFIND^IBAUTL2
  1. S IBNOS=IBCHCDA,IBCHCTY=$P($G(^IB(+IBCHCDA,0)),"^",3) S:IBEVNEW IBEVDA=IBEVNEW
  1. ; - update or pass to A/R an incomplete copay charge
  1. I IBCHCDA D G:IBY<1 CALCQ
  1. . I IBCHCTY'=IBATYP S IBWHER=15 D FILER^IBAUTL5 S IBCHCDA=0 Q
  1. . S X1=IBDT,X2=IBCHTO D ^%DTC I X'=1 S IBWHER=16 D FILER^IBAUTL5 S IBCHCDA=0 Q
  1. . ; Split pre- and post- GMT Eff.Date charges
  1. . I IBGMT'=0,IBDT'<IBGMTEFD,IBCHTO<IBGMTEFD S IBWHER=16 D FILER^IBAUTL5 S IBCHPDA=0 Q
  1. . S IBN=IBCHCDA D CHUPD^IBAUTL2
  1. I 'IBCHCDA S IBWHER=18 D CHADD^IBAUTL2 G:IBY<1 CALCQ S IBCHCDA=IBN
  1. I IBCHCDA,IBCLDOL'<IBMAX S IBEVOLD=0,IBNOS=IBCHCDA,IBWHER=19 D FILER^IBAUTL5 G:IBY<1 CALCQ S IBCHCDA=0
  1. LAST ; - handle last day of billing clock
  1. G:IBCLCT<365 CALCQ
  1. I $G(IBCHPDA) S IBNOS=IBCHPDA,IBWHER=20 D FILER^IBAUTL5 G:IBY<1 CALCQ S IBCHPDA=0
  1. I $G(IBCHCDA) S IBNOS=IBCHCDA,IBWHER=21 D FILER^IBAUTL5 G:IBY<1 CALCQ S IBCHCDA=0
  1. D CLOCKCL^IBAUTL3
  1. CALCQ I $G(IBJOB)=2,'$G(DGQUIET) W "."
  1. Q