- 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 Feb 18, 2025@23:32:36 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 ;