IBAECU5 ;WOIFO/SS-LTC PHASE 2 UTILITIES ; 20-FEB-02
;;2.0;INTEGRATED BILLING;**171,176**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;check if there is LTC in ^TMP of INPINFO^IBAECU2
ISLTC(IBDFN,IBLBL) ;
N IBFL5,IBVA,IBVT,IBVD
S (IBFL5,IBVA)=0
F S IBVA=$O(^TMP($J,IBLBL,IBDFN,IBVA)) Q:IBVA=""!(IBFL5>0) D
. S IBVT=0
. F S IBVT=$O(^TMP($J,IBLBL,IBDFN,IBVA,IBVT)) Q:IBVT=""!(IBFL5>0) D
. . S IBVD=0
. . F S IBVD=$O(^TMP($J,IBLBL,IBDFN,IBVA,IBVT,IBVD)) Q:IBVD=""!(IBFL5>0) D
. . . S:$P($G(^TMP($J,IBLBL,IBDFN,IBVA,IBVT,IBVD)),"^",1)="L" IBFL5=IBVD
Q IBFL5
;
;is C&P exam this date
;IBDFN1 - patient's ien #2
;IBDT1 -date
;returns
; 1 - YES, 0 -NO
ISCOMPEN(IBDFN1,IBDT1) ;
Q $$CNP^IBECEAU(IBDFN1,IBDT1)
;
;checks if charge for outpatient visit and then cancels it
;IBDFN - Pointer to patient in file #2
;IBDATE - Date to check for OPT charges
CANCVIS(IBDFN,IBDATE) ;
N IBN,IBCRES,IBDUZ
S IBDUZ=+$G(DUZ)
S IBN=$$BFO^IBECEAU(IBDFN,IBDATE)
Q:'IBN
S IBCRES=$O(^IBE(350.3,"B","BILLED LTC CHARGE",0))
S:'IBCRES IBCRES=4 S IBWHER=""
D CANCH^IBECEAU4(IBN,IBCRES,0)
Q
;
;prepares error messages
;IBDFN - patient's ien
;IBIEN - ien of applicable file
;IBACT - action
;IBMESS - error message
ERRLOG(IBDFN,IBIEN,IBACT,IBMESS) ;
Q:+IBDFN=0!(+IBIEN=0)!(IBACT="")
N VADM,VA,VAERR,DFN,IBCNT
S DFN=IBDFN
D DEM^VADPT
S ^TMP($J,"IBMJERR")=$G(^TMP($J,"IBMJERR"))+1
S IBCNT=$G(^TMP($J,"IBMJERR"))
S ^TMP($J,"IBMJERR",IBCNT,1)=" "
S ^TMP($J,"IBMJERR",IBCNT,2)="*********************************"
S ^TMP($J,"IBMJERR",IBCNT,3)=" "_$G(IBMESS)
S ^TMP($J,"IBMJERR",IBCNT,4)=" Action : "_$G(IBACT)
S ^TMP($J,"IBMJERR",IBCNT,5)=" Applicable IEN : "_$G(IBIEN)
S ^TMP($J,"IBMJERR",IBCNT,6)=" Patient : "_$G(VADM(1))
S ^TMP($J,"IBMJERR",IBCNT,7)=" SSN : "_$P($G(VADM(2)),"^",2)
Q
;
;sends all errors in TMP($J,"IBMJERR" to IB ERROR mail group
SENDERR ;
N XMSUB,XMTEXT,XMY,XMZ,XMMG,IBL,IBT,XMDUZ,IBV1,IBV2,IBV3
N IBMAXLN S IBMAXLN=200
N XMGROUP S XMGROUP=$$GET1^DIQ(350.9,"1,",.09)
Q:XMGROUP=""
S XMGROUP="G."_XMGROUP
S XMSUB="LTC Monthly Job error report",XMY(XMGROUP)=""
S XMTEXT="IBT(",XMDUZ="INTEGRATED BILLING PACKAGE"
S IBV1=0,IBV3=1
F S IBV1=$O(^TMP($J,"IBMJERR",IBV1)) Q:+IBV1=0!(IBV3>IBMAXLN) D
. S IBV2=0
. F S IBV2=$O(^TMP($J,"IBMJERR",IBV1,IBV2)) Q:+IBV2=0 D
. . S IBT(IBV3,0)=$G(^TMP($J,"IBMJERR",IBV1,IBV2)),IBV3=IBV3+1
S:IBV3>IBMAXLN IBT(IBV3,0)="******* Too many errors! *******"
D ^XMD
Q
;
;sends message to user group if there is no 1010EC form forthe patient
MESS10EC(DFN,IBDT) ;
D XMNOEC^IBAECU(DFN,IBDT)
Q
;
;Creates charge, sends amount to AR
;IBPATDFN - patient DFN
;.IBAMOUNT - array with all amounts for each day
;array IBMNTH - month info
;.IBMNTH - number of days
;IBMNTH(0)- first day (in FM format)
;IBMNTH(1)- last day (in FM format)
;IBMNTH(2)- year_month (like 30201)
;IBMONCAP - maximum monthly copay (180 days stuff)
SEND2AR(IBPATDFN,IBAMOUNT,IBMNTH,IBMONCAP) ;
;arrays
N IBPAYS,IBRCHRGS
;vars
N IBADM,IB350P,IBDD,IBRES,IBTOT,IBV1,IBNOS,IBAMNT
N IBDAY,IB350,IBRATE,IBTP,IBDT,IBSL,IBPRDAY,IBV1
N IBINPDS,IBFDAY,IBLDAY,IBEPSSUM,IBFRD,IBTOD
S IBDAY=0,IBPAYS=0,IBRCHRGS=0
;1.outpatient visit charges
F S IBDAY=$O(IBAMOUNT("A",IBDAY)) Q:+IBDAY=0 I +$G(IBAMOUNT("A",IBDAY,"T"))=1 D
. S IBRATE=+$G(IBAMOUNT("A",IBDAY,"R"))
. S IBTP=$P($G(IBAMOUNT("A",IBDAY,"R")),"^",2)
. S IBDT=$$MKDATE^IBAECU4(IBMNTH(2),IBDAY)
. S IBSL="409.68:"_$P($G(IBAMOUNT("A",IBDAY,"T")),"^",2)
. S IBPAYS=$G(IBPAYS)+1,IBPAYS(IBDAY)=IBPATDFN_"^"_IBTP_"^1^"_IBRATE_"^"_IBDT_"^"_IBDT_"^"_IBSL_"^^*^"_IBDT
;2.inpatient stay charges
S IBFDAY=0 ;first day of episode
S IBLDAY=0 ;last day of episode
S IBINPDS=0 ;length of each episode (Exmpl. Jan3-Jan5=2days, Jan21-Jan31=10 days)
S IBEPSSUM=0 ;total for episode
S IBDAY=0
F S IBDAY=$O(IBAMOUNT("A",IBDAY)) Q:+IBDAY=0 I +$G(IBAMOUNT("A",IBDAY,"T"))=2 D
. S:IBFDAY=0 IBFDAY=IBDAY ;set first day
. S IBINPDS=IBINPDS+1 ;count days
. S IBRATE=+$G(IBAMOUNT("A",IBDAY,"R"))
. S IBEPSSUM=IBEPSSUM+IBRATE ;total
. S IBV1=+$O(IBAMOUNT("A",IBDAY)) ;check the next day
. ;if next "is the end" OR "if AA/ASIH gap" OR "if another admission"
. I (IBV1=0)!((IBV1-IBDAY)>1)!($P($G(IBAMOUNT("A",IBDAY,"T")),"^",2)'=$P($G(IBAMOUNT("A",IBV1,"T")),"^",2)) D
. . S IBLDAY=IBDAY ; set last day
. . S IBTP=$P($G(IBAMOUNT("A",IBDAY,"R")),"^",2) ;action type
. . S IBFRD=$$MKDATE^IBAECU4(IBMNTH(2),IBFDAY) ;from
. . S IBTOD=$$MKDATE^IBAECU4(IBMNTH(2),IBLDAY) ;to
. . S IBADM=$P($G(IBAMOUNT("A",IBDAY,"T")),"^",2) ;admission
. . S IBDT=+$P($G(IBAMOUNT("A",IBDAY,"T")),"^",3) ;default is admission date
. . I IBDT<IBMNTH(0) S IBDT=IBMNTH(0) ;if admission date < begining of month
. . S IB350P=+$$FIND350^IBAECN1(IBPATDFN,IBFRD+0.9,IBADM,1) ;find INCOMLETE parent event
. . I IB350P=0 D
. . . N VAIP,IB350PCL,DFN
. . . S DFN=IBPATDFN,VAIP("D")=IBFRD_.2359 D IN5^VADPT
. . . I '$$ASIH^IBAUTL5($G(^DGPM(+VAIP(1),0))) D Q
. . . . ;find "completed" - ASIH could complete event entry
. . . . S IB350PCL=+$$FIND350^IBAECN1(IBPATDFN,IBFRD+0.9,+IBADM,2)
. . . . I IB350PCL>0 S IB350P=IB350PCL
. . . S IB350P=+$$FIND350^IBAECN1(IBPATDFN,IBFRD+0.9,+VAIP(1),1)
. . . S IBADM=+VAIP(1),IBDT=+$G(^DGPM(VAIP(1),0))\1
. . ;if not found - create new one with LTC type
. . I IB350P=0 S IB350P=$$CREV350^IBAECN1(IBPATDFN,+IBADM,IBDT,93)
. . S IBSL="405:"_IBADM ;soft link
. . S IBPAYS=$G(IBPAYS)+1
. . I $D(IBPAYS(IBDAY)) D ERRLOG(+$G(IBPATDFN),+$G(IB350P),"SEND2AR: charges","Attempt to create more than one charge a day ")
. . S IBPAYS(IBDAY)=IBPATDFN_"^"_IBTP_"^"_IBINPDS_"^"_IBEPSSUM_"^"_IBFRD_"^"_IBTOD_"^"_IBSL_"^^"_IB350P_"^"_IBDT
. . S (IBFDAY,IBLDAY,IBINPDS,IBEPSSUM)=0
;3. make charges until it less than monthly cap
;
S (IBTOT,IBFL,IBDD)=0
F S IBDD=$O(IBPAYS(IBDD)) Q:+IBDD=0!(IBFL=1) D
. S IBRES=$G(IBPAYS(IBDD))
. S IBAMNT=0
. I IBTOT'<IBMONCAP S IBFL=1 Q ;don't charge anymore
. I (IBTOT+$P(IBRES,"^",4))'>IBMONCAP D ;charge whole amount
. . S IBAMNT=$P(IBRES,"^",4)
. E S IBAMNT=IBMONCAP-IBTOT ;charge a rest
. S IBTOT=IBTOT+IBAMNT
. S IB350=$$CHARGE(IBPATDFN,$P(IBRES,"^",2),$P(IBRES,"^",3),IBAMNT,$P(IBRES,"^",5),$P(IBRES,"^",6),$P(IBRES,"^",7),$P(IBRES,"^",8),$P(IBRES,"^",9),$P(IBRES,"^",10))
. I IB350>0 S IBRCHRGS=IBRCHRGS+1,IBRCHRGS(IBRCHRGS)=IB350
. ;Edit parent event in #350 V 11F
. I +$P(IBRES,"^",9)>0 D STAT350^IBAECN1(+$P(IBRES,"^",9),IBMNTH(1),+$P($P(IBRES,"^",7),":",2))
;4. Send to AR
S IBV1=0,IBNOS=""
F S IBV1=$O(IBRCHRGS(IBV1)) Q:+IBV1=0 D
. S:IBNOS'="" IBNOS=IBNOS_"^"_IBRCHRGS(IBV1)
. S:IBNOS="" IBNOS=IBRCHRGS(IBV1)
. I (IBV1#5)=0 S IBRES=$$TOAR(IBPATDFN,1,IBNOS,+$G(DUZ)),IBNOS=""
I IBNOS'="" S IBRES=$$TOAR(IBPATDFN,1,IBNOS,+$G(DUZ)),IBNOS=""
Q
;call ^IBR
TOAR(DFN,IBSEQNO,IBNOS,IBDUZ) ;
;
N Y,IBERR,IBIL
D ^IBR
Q Y
;
;create outppatient charge
; Input:
; DFN -- Pointer to patient in file #2
; IBATYP -- Pointer to Action Type in file #350.1
; IBUNIT -- Number of units of charge (1 day for outpatient, 1 or more for inpatients)
; IBCHG -- $$ amount of charge
; IBFR -- Bill From date
; inpatient: first day of episode
; outpatient: date of service
; IBTO -- Bill To date
; inpatient: last day of episode
; outpatient: date of service
; IBSL -- Softlink 405:IEN or 409.68:IEN
; IBPAR -- placeholder for IBPARNT (see below)
; IBEVDA -- Pointer to parent event in #350 for inpatients,
; or "*" for outpatients to set ibevda=ibn
; IBEVDT -- for outpatient: Event Date
; for inpatient:admission date or begining of month if admission began
; before the begining of the month
CHARGE(DFN,IBATYP,IBUNIT,IBCHG,IBFR,IBTO,IBSL,IBPAR,IBEVDA,IBEVDT) ;
;
N IBN,IBDESC,IBSITE,IBFAC,IBXA
D SITE^IBAUTL
S IBDESC=$P($G(^IBE(350.1,+$G(IBATYP),0)),"^",8)
I IBDESC="" S IBDESC=$$ACTNM(+$G(IBATYP)) D ERRLOG(+$G(DFN),+$G(IBATYP),"CHARGE","No USER LOOKUP NAME in #350.1")
S IBN=0
;IBPARNT -- Pointer to parent entry in #350 [OPTIONAL], i.e. to previous record(s)
; for the same charge, that were edited or cancelled
; Here IBPARNT must be undefined, because we always create "NEW" charges
N IBPARNT ;undefined
D ADD^IBECEAU3
Q IBN
;
ACTNM(X) ;X -input pointer to action type file (350.1)
S Y=$P($G(^IBE(350.1,+X,0)),"^",9) ;new action type
Q $S($P($G(^IBE(350.1,+Y,0)),"^",8)]"":$P(^(0),"^",8),$P($G(^IBE(350.1,+X,0)),"^",8)]"":$P(^(0),"^",8),1:$P($G(^IBE(350.1,+X,0)),"^"))
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAECU5 8709 printed Sep 23, 2025@19:42:25 Page 2
IBAECU5 ;WOIFO/SS-LTC PHASE 2 UTILITIES ; 20-FEB-02
+1 ;;2.0;INTEGRATED BILLING;**171,176**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;check if there is LTC in ^TMP of INPINFO^IBAECU2
ISLTC(IBDFN,IBLBL) ;
+1 NEW IBFL5,IBVA,IBVT,IBVD
+2 SET (IBFL5,IBVA)=0
+3 FOR
SET IBVA=$ORDER(^TMP($JOB,IBLBL,IBDFN,IBVA))
if IBVA=""!(IBFL5>0)
QUIT
Begin DoDot:1
+4 SET IBVT=0
+5 FOR
SET IBVT=$ORDER(^TMP($JOB,IBLBL,IBDFN,IBVA,IBVT))
if IBVT=""!(IBFL5>0)
QUIT
Begin DoDot:2
+6 SET IBVD=0
+7 FOR
SET IBVD=$ORDER(^TMP($JOB,IBLBL,IBDFN,IBVA,IBVT,IBVD))
if IBVD=""!(IBFL5>0)
QUIT
Begin DoDot:3
+8 if $PIECE($GET(^TMP($JOB,IBLBL,IBDFN,IBVA,IBVT,IBVD)),"^",1)="L"
SET IBFL5=IBVD
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT IBFL5
+10 ;
+11 ;is C&P exam this date
+12 ;IBDFN1 - patient's ien #2
+13 ;IBDT1 -date
+14 ;returns
+15 ; 1 - YES, 0 -NO
ISCOMPEN(IBDFN1,IBDT1) ;
+1 QUIT $$CNP^IBECEAU(IBDFN1,IBDT1)
+2 ;
+3 ;checks if charge for outpatient visit and then cancels it
+4 ;IBDFN - Pointer to patient in file #2
+5 ;IBDATE - Date to check for OPT charges
CANCVIS(IBDFN,IBDATE) ;
+1 NEW IBN,IBCRES,IBDUZ
+2 SET IBDUZ=+$GET(DUZ)
+3 SET IBN=$$BFO^IBECEAU(IBDFN,IBDATE)
+4 if 'IBN
QUIT
+5 SET IBCRES=$ORDER(^IBE(350.3,"B","BILLED LTC CHARGE",0))
+6 if 'IBCRES
SET IBCRES=4
SET IBWHER=""
+7 DO CANCH^IBECEAU4(IBN,IBCRES,0)
+8 QUIT
+9 ;
+10 ;prepares error messages
+11 ;IBDFN - patient's ien
+12 ;IBIEN - ien of applicable file
+13 ;IBACT - action
+14 ;IBMESS - error message
ERRLOG(IBDFN,IBIEN,IBACT,IBMESS) ;
+1 if +IBDFN=0!(+IBIEN=0)!(IBACT="")
QUIT
+2 NEW VADM,VA,VAERR,DFN,IBCNT
+3 SET DFN=IBDFN
+4 DO DEM^VADPT
+5 SET ^TMP($JOB,"IBMJERR")=$GET(^TMP($JOB,"IBMJERR"))+1
+6 SET IBCNT=$GET(^TMP($JOB,"IBMJERR"))
+7 SET ^TMP($JOB,"IBMJERR",IBCNT,1)=" "
+8 SET ^TMP($JOB,"IBMJERR",IBCNT,2)="*********************************"
+9 SET ^TMP($JOB,"IBMJERR",IBCNT,3)=" "_$GET(IBMESS)
+10 SET ^TMP($JOB,"IBMJERR",IBCNT,4)=" Action : "_$GET(IBACT)
+11 SET ^TMP($JOB,"IBMJERR",IBCNT,5)=" Applicable IEN : "_$GET(IBIEN)
+12 SET ^TMP($JOB,"IBMJERR",IBCNT,6)=" Patient : "_$GET(VADM(1))
+13 SET ^TMP($JOB,"IBMJERR",IBCNT,7)=" SSN : "_$PIECE($GET(VADM(2)),"^",2)
+14 QUIT
+15 ;
+16 ;sends all errors in TMP($J,"IBMJERR" to IB ERROR mail group
SENDERR ;
+1 NEW XMSUB,XMTEXT,XMY,XMZ,XMMG,IBL,IBT,XMDUZ,IBV1,IBV2,IBV3
+2 NEW IBMAXLN
SET IBMAXLN=200
+3 NEW XMGROUP
SET XMGROUP=$$GET1^DIQ(350.9,"1,",.09)
+4 if XMGROUP=""
QUIT
+5 SET XMGROUP="G."_XMGROUP
+6 SET XMSUB="LTC Monthly Job error report"
SET XMY(XMGROUP)=""
+7 SET XMTEXT="IBT("
SET XMDUZ="INTEGRATED BILLING PACKAGE"
+8 SET IBV1=0
SET IBV3=1
+9 FOR
SET IBV1=$ORDER(^TMP($JOB,"IBMJERR",IBV1))
if +IBV1=0!(IBV3>IBMAXLN)
QUIT
Begin DoDot:1
+10 SET IBV2=0
+11 FOR
SET IBV2=$ORDER(^TMP($JOB,"IBMJERR",IBV1,IBV2))
if +IBV2=0
QUIT
Begin DoDot:2
+12 SET IBT(IBV3,0)=$GET(^TMP($JOB,"IBMJERR",IBV1,IBV2))
SET IBV3=IBV3+1
End DoDot:2
End DoDot:1
+13 if IBV3>IBMAXLN
SET IBT(IBV3,0)="******* Too many errors! *******"
+14 DO ^XMD
+15 QUIT
+16 ;
+17 ;sends message to user group if there is no 1010EC form forthe patient
MESS10EC(DFN,IBDT) ;
+1 DO XMNOEC^IBAECU(DFN,IBDT)
+2 QUIT
+3 ;
+4 ;Creates charge, sends amount to AR
+5 ;IBPATDFN - patient DFN
+6 ;.IBAMOUNT - array with all amounts for each day
+7 ;array IBMNTH - month info
+8 ;.IBMNTH - number of days
+9 ;IBMNTH(0)- first day (in FM format)
+10 ;IBMNTH(1)- last day (in FM format)
+11 ;IBMNTH(2)- year_month (like 30201)
+12 ;IBMONCAP - maximum monthly copay (180 days stuff)
SEND2AR(IBPATDFN,IBAMOUNT,IBMNTH,IBMONCAP) ;
+1 ;arrays
+2 NEW IBPAYS,IBRCHRGS
+3 ;vars
+4 NEW IBADM,IB350P,IBDD,IBRES,IBTOT,IBV1,IBNOS,IBAMNT
+5 NEW IBDAY,IB350,IBRATE,IBTP,IBDT,IBSL,IBPRDAY,IBV1
+6 NEW IBINPDS,IBFDAY,IBLDAY,IBEPSSUM,IBFRD,IBTOD
+7 SET IBDAY=0
SET IBPAYS=0
SET IBRCHRGS=0
+8 ;1.outpatient visit charges
+9 FOR
SET IBDAY=$ORDER(IBAMOUNT("A",IBDAY))
if +IBDAY=0
QUIT
IF +$GET(IBAMOUNT("A",IBDAY,"T"))=1
Begin DoDot:1
+10 SET IBRATE=+$GET(IBAMOUNT("A",IBDAY,"R"))
+11 SET IBTP=$PIECE($GET(IBAMOUNT("A",IBDAY,"R")),"^",2)
+12 SET IBDT=$$MKDATE^IBAECU4(IBMNTH(2),IBDAY)
+13 SET IBSL="409.68:"_$PIECE($GET(IBAMOUNT("A",IBDAY,"T")),"^",2)
+14 SET IBPAYS=$GET(IBPAYS)+1
SET IBPAYS(IBDAY)=IBPATDFN_"^"_IBTP_"^1^"_IBRATE_"^"_IBDT_"^"_IBDT_"^"_IBSL_"^^*^"_IBDT
End DoDot:1
+15 ;2.inpatient stay charges
+16 ;first day of episode
SET IBFDAY=0
+17 ;last day of episode
SET IBLDAY=0
+18 ;length of each episode (Exmpl. Jan3-Jan5=2days, Jan21-Jan31=10 days)
SET IBINPDS=0
+19 ;total for episode
SET IBEPSSUM=0
+20 SET IBDAY=0
+21 FOR
SET IBDAY=$ORDER(IBAMOUNT("A",IBDAY))
if +IBDAY=0
QUIT
IF +$GET(IBAMOUNT("A",IBDAY,"T"))=2
Begin DoDot:1
+22 ;set first day
if IBFDAY=0
SET IBFDAY=IBDAY
+23 ;count days
SET IBINPDS=IBINPDS+1
+24 SET IBRATE=+$GET(IBAMOUNT("A",IBDAY,"R"))
+25 ;total
SET IBEPSSUM=IBEPSSUM+IBRATE
+26 ;check the next day
SET IBV1=+$ORDER(IBAMOUNT("A",IBDAY))
+27 ;if next "is the end" OR "if AA/ASIH gap" OR "if another admission"
+28 IF (IBV1=0)!((IBV1-IBDAY)>1)!($PIECE($GET(IBAMOUNT("A",IBDAY,"T")),"^",2)'=$PIECE($GET(IBAMOUNT("A",IBV1,"T")),"^",2))
Begin DoDot:2
+29 ; set last day
SET IBLDAY=IBDAY
+30 ;action type
SET IBTP=$PIECE($GET(IBAMOUNT("A",IBDAY,"R")),"^",2)
+31 ;from
SET IBFRD=$$MKDATE^IBAECU4(IBMNTH(2),IBFDAY)
+32 ;to
SET IBTOD=$$MKDATE^IBAECU4(IBMNTH(2),IBLDAY)
+33 ;admission
SET IBADM=$PIECE($GET(IBAMOUNT("A",IBDAY,"T")),"^",2)
+34 ;default is admission date
SET IBDT=+$PIECE($GET(IBAMOUNT("A",IBDAY,"T")),"^",3)
+35 ;if admission date < begining of month
IF IBDT<IBMNTH(0)
SET IBDT=IBMNTH(0)
+36 ;find INCOMLETE parent event
SET IB350P=+$$FIND350^IBAECN1(IBPATDFN,IBFRD+0.9,IBADM,1)
+37 IF IB350P=0
Begin DoDot:3
+38 NEW VAIP,IB350PCL,DFN
+39 SET DFN=IBPATDFN
SET VAIP("D")=IBFRD_.2359
DO IN5^VADPT
+40 IF '$$ASIH^IBAUTL5($GET(^DGPM(+VAIP(1),0)))
Begin DoDot:4
+41 ;find "completed" - ASIH could complete event entry
+42 SET IB350PCL=+$$FIND350^IBAECN1(IBPATDFN,IBFRD+0.9,+IBADM,2)
+43 IF IB350PCL>0
SET IB350P=IB350PCL
End DoDot:4
QUIT
+44 SET IB350P=+$$FIND350^IBAECN1(IBPATDFN,IBFRD+0.9,+VAIP(1),1)
+45 SET IBADM=+VAIP(1)
SET IBDT=+$GET(^DGPM(VAIP(1),0))\1
End DoDot:3
+46 ;if not found - create new one with LTC type
+47 IF IB350P=0
SET IB350P=$$CREV350^IBAECN1(IBPATDFN,+IBADM,IBDT,93)
+48 ;soft link
SET IBSL="405:"_IBADM
+49 SET IBPAYS=$GET(IBPAYS)+1
+50 IF $DATA(IBPAYS(IBDAY))
DO ERRLOG(+$GET(IBPATDFN),+$GET(IB350P),"SEND2AR: charges","Attempt to create more than one charge a day ")
+51 SET IBPAYS(IBDAY)=IBPATDFN_"^"_IBTP_"^"_IBINPDS_"^"_IBEPSSUM_"^"_IBFRD_"^"_IBTOD_"^"_IBSL_"^^"_IB350P_"^"_IBDT
+52 SET (IBFDAY,IBLDAY,IBINPDS,IBEPSSUM)=0
End DoDot:2
End DoDot:1
+53 ;3. make charges until it less than monthly cap
+54 ;
+55 SET (IBTOT,IBFL,IBDD)=0
+56 FOR
SET IBDD=$ORDER(IBPAYS(IBDD))
if +IBDD=0!(IBFL=1)
QUIT
Begin DoDot:1
+57 SET IBRES=$GET(IBPAYS(IBDD))
+58 SET IBAMNT=0
+59 ;don't charge anymore
IF IBTOT'<IBMONCAP
SET IBFL=1
QUIT
+60 ;charge whole amount
IF (IBTOT+$PIECE(IBRES,"^",4))'>IBMONCAP
Begin DoDot:2
+61 SET IBAMNT=$PIECE(IBRES,"^",4)
End DoDot:2
+62 ;charge a rest
IF '$TEST
SET IBAMNT=IBMONCAP-IBTOT
+63 SET IBTOT=IBTOT+IBAMNT
+64 SET IB350=$$CHARGE(IBPATDFN,$PIECE(IBRES,"^",2),$PIECE(IBRES,"^",3),IBAMNT,$PIECE(IBRES,"^",5),$PIECE(IBRES,"^",6),$PIECE(IBRES,"^",7),$PIECE(IBRES,"^",8),$PIECE(IBRES,"^",9),$PIECE(IBRES,"^",10))
+65 IF IB350>0
SET IBRCHRGS=IBRCHRGS+1
SET IBRCHRGS(IBRCHRGS)=IB350
+66 ;Edit parent event in #350 V 11F
+67 IF +$PIECE(IBRES,"^",9)>0
DO STAT350^IBAECN1(+$PIECE(IBRES,"^",9),IBMNTH(1),+$PIECE($PIECE(IBRES,"^",7),":",2))
End DoDot:1
+68 ;4. Send to AR
+69 SET IBV1=0
SET IBNOS=""
+70 FOR
SET IBV1=$ORDER(IBRCHRGS(IBV1))
if +IBV1=0
QUIT
Begin DoDot:1
+71 if IBNOS'=""
SET IBNOS=IBNOS_"^"_IBRCHRGS(IBV1)
+72 if IBNOS=""
SET IBNOS=IBRCHRGS(IBV1)
+73 IF (IBV1#5)=0
SET IBRES=$$TOAR(IBPATDFN,1,IBNOS,+$GET(DUZ))
SET IBNOS=""
End DoDot:1
+74 IF IBNOS'=""
SET IBRES=$$TOAR(IBPATDFN,1,IBNOS,+$GET(DUZ))
SET IBNOS=""
+75 QUIT
+76 ;call ^IBR
TOAR(DFN,IBSEQNO,IBNOS,IBDUZ) ;
+1 ;
+2 NEW Y,IBERR,IBIL
+3 DO ^IBR
+4 QUIT Y
+5 ;
+6 ;create outppatient charge
+7 ; Input:
+8 ; DFN -- Pointer to patient in file #2
+9 ; IBATYP -- Pointer to Action Type in file #350.1
+10 ; IBUNIT -- Number of units of charge (1 day for outpatient, 1 or more for inpatients)
+11 ; IBCHG -- $$ amount of charge
+12 ; IBFR -- Bill From date
+13 ; inpatient: first day of episode
+14 ; outpatient: date of service
+15 ; IBTO -- Bill To date
+16 ; inpatient: last day of episode
+17 ; outpatient: date of service
+18 ; IBSL -- Softlink 405:IEN or 409.68:IEN
+19 ; IBPAR -- placeholder for IBPARNT (see below)
+20 ; IBEVDA -- Pointer to parent event in #350 for inpatients,
+21 ; or "*" for outpatients to set ibevda=ibn
+22 ; IBEVDT -- for outpatient: Event Date
+23 ; for inpatient:admission date or begining of month if admission began
+24 ; before the begining of the month
CHARGE(DFN,IBATYP,IBUNIT,IBCHG,IBFR,IBTO,IBSL,IBPAR,IBEVDA,IBEVDT) ;
+1 ;
+2 NEW IBN,IBDESC,IBSITE,IBFAC,IBXA
+3 DO SITE^IBAUTL
+4 SET IBDESC=$PIECE($GET(^IBE(350.1,+$GET(IBATYP),0)),"^",8)
+5 IF IBDESC=""
SET IBDESC=$$ACTNM(+$GET(IBATYP))
DO ERRLOG(+$GET(DFN),+$GET(IBATYP),"CHARGE","No USER LOOKUP NAME in #350.1")
+6 SET IBN=0
+7 ;IBPARNT -- Pointer to parent entry in #350 [OPTIONAL], i.e. to previous record(s)
+8 ; for the same charge, that were edited or cancelled
+9 ; Here IBPARNT must be undefined, because we always create "NEW" charges
+10 ;undefined
NEW IBPARNT
+11 DO ADD^IBECEAU3
+12 QUIT IBN
+13 ;
ACTNM(X) ;X -input pointer to action type file (350.1)
+1 ;new action type
SET Y=$PIECE($GET(^IBE(350.1,+X,0)),"^",9)
+2 QUIT $SELECT($PIECE($GET(^IBE(350.1,+Y,0)),"^",8)]"":$PIECE(^(0),"^",8),$PIECE($GET(^IBE(350.1,+X,0)),"^",8)]"":$PIECE(^(0),"^",8),1:$PIECE($GET(^IBE(350.1,+X,0)),"^"))
+3 ;
