IBCRBC11 ;ALB/ARH - RATES: BILL CALCULATION BILLABLE EVENTS ;10-OCT-1998
;;2.0;INTEGRATED BILLING;**106,245,155**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; continuation of IBCRBC1
;
INPTDRG(IBIFN,RS,CS) ; Determine charges for INPATIENT DRG billable events
; - the billable events are DRG's, the Transfer DRG of the patient treating specialties movements,
; pulled from the PTF record each time the charges are calculated (INPTPTF^IBCRCG)
; - each day of billable care is calculated separately in case a rate becomes in/active
; - if bedsection is ICU then allow ICU Charge Set only
;
N IBX,IBBLITEM,IBCHGMTH,IBEVDT,IBIDRC,IBBS,IBITM,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q
;
D INPTPTF^IBCRBG(IBIFN,CS)
;
S IBTYPE=6,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7)
;
S IBBDIV=$P($G(^DGCR(399,+IBIFN,0)),U,22) ; bill's default division
;
I IBBLITEM=4,IBCHGMTH=1 D ; inpt/DRG/per diem
. S IBEVDT="" F S IBEVDT=$O(^TMP($J,"IBCRC-INDT",IBEVDT)) Q:IBEVDT="" D
.. ;
.. S IBX=$G(^TMP($J,"IBCRC-INDT",IBEVDT)),IBITM=$P(IBX,U,4),IBBS=$P(IBX,U,2),IBDIV=$P(IBX,U,5) Q:'IBITM
.. ;
.. I '$$CHGICU^IBCRBC2(CS,IBBS) Q ; check icu charges are applied to icu bedsection
.. ;
.. I $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0 Q ; check division
.. ;
.. S IBSAVE="1^^"_IBDIV_"^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT_"^"_IBBS
.. D BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,1,"","",IBIDRC,IBSAVE)
K ^TMP($J,"IBCRC-INDT")
Q
;
UNASSOC(IBIFN,RS,CS,IBMIARR) ; Determine charges for UNASSOCIATED billable events
; - the billable event is not associated with any data element on the bill
; - the item to charge is selected by the user from the list of billing items (363.21)
; - the items the user selected to add charges to the bill for are passed in in array IBMIARR
; - if the charge set is limited by region then either the items division or if no item division then the bill's
; Default Division must be contained in the sets region
;
N IBX,IBBLITEM,IBCHGMTH,IBIDRC,IBBDIV,IBI,IBITM,IBEVDT,IBTUNITS,IBDIV,IBRVCD,IBTYPE,IBCMPNT,IBSAVE
I '$G(IBIFN)!'$G(CS)!'$G(IBMIARR) Q
;
S IBTYPE=9,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7)
;
S IBBDIV=$P($G(^DGCR(399,+IBIFN,0)),U,22) ; bill's default division
;
I IBBLITEM=9,IBCHGMTH=1 D ; charge per item
. S IBI=0 F S IBI=$O(IBMIARR(RS,CS,IBI)) Q:'IBI D
.. S IBX=IBMIARR(RS,CS,IBI),IBITM=+$P(IBX,U,1),IBEVDT=$P(IBX,U,2)
.. S IBTUNITS=$P(IBX,U,3),IBDIV=$P(IBX,U,4),IBRVCD=$P(IBX,U,5)
.. ;
.. I $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0 Q ; check division
.. ;
.. S IBSAVE=IBTUNITS_"^^"_IBDIV_"^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT
.. D BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,1,"",IBRVCD,IBIDRC,IBSAVE)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRBC11 3208 printed Dec 13, 2024@02:18:45 Page 2
IBCRBC11 ;ALB/ARH - RATES: BILL CALCULATION BILLABLE EVENTS ;10-OCT-1998
+1 ;;2.0;INTEGRATED BILLING;**106,245,155**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; continuation of IBCRBC1
+5 ;
INPTDRG(IBIFN,RS,CS) ; Determine charges for INPATIENT DRG billable events
+1 ; - the billable events are DRG's, the Transfer DRG of the patient treating specialties movements,
+2 ; pulled from the PTF record each time the charges are calculated (INPTPTF^IBCRCG)
+3 ; - each day of billable care is calculated separately in case a rate becomes in/active
+4 ; - if bedsection is ICU then allow ICU Charge Set only
+5 ;
+6 NEW IBX,IBBLITEM,IBCHGMTH,IBEVDT,IBIDRC,IBBS,IBITM,IBTYPE,IBCMPNT,IBSAVE
IF '$GET(IBIFN)!'$GET(CS)
QUIT
+7 ;
+8 DO INPTPTF^IBCRBG(IBIFN,CS)
+9 ;
+10 SET IBTYPE=6
SET IBCMPNT=$PIECE($GET(^IBE(363.1,+CS,0)),U,4)
SET IBX=$$CSBR^IBCRU3(CS)
SET IBBLITEM=$PIECE(IBX,U,4)
SET IBCHGMTH=$PIECE(IBX,U,5)
+11 SET IBIDRC=+$GET(^DGCR(399,+IBIFN,"MP"))
+12 IF 'IBIDRC
IF $$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN))
SET IBIDRC=$$CURR^IBCEF2(IBIFN)
+13 SET IBIDRC=$GET(^DIC(36,+IBIDRC,0))
SET IBIDRC=$PIECE(IBIDRC,U,7)
+14 ;
+15 ; bill's default division
SET IBBDIV=$PIECE($GET(^DGCR(399,+IBIFN,0)),U,22)
+16 ;
+17 ; inpt/DRG/per diem
IF IBBLITEM=4
IF IBCHGMTH=1
Begin DoDot:1
+18 SET IBEVDT=""
FOR
SET IBEVDT=$ORDER(^TMP($JOB,"IBCRC-INDT",IBEVDT))
if IBEVDT=""
QUIT
Begin DoDot:2
+19 ;
+20 SET IBX=$GET(^TMP($JOB,"IBCRC-INDT",IBEVDT))
SET IBITM=$PIECE(IBX,U,4)
SET IBBS=$PIECE(IBX,U,2)
SET IBDIV=$PIECE(IBX,U,5)
if 'IBITM
QUIT
+21 ;
+22 ; check icu charges are applied to icu bedsection
IF '$$CHGICU^IBCRBC2(CS,IBBS)
QUIT
+23 ;
+24 ; check division
IF $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0
QUIT
+25 ;
+26 SET IBSAVE="1^^"_IBDIV_"^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT_"^"_IBBS
+27 DO BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,1,"","",IBIDRC,IBSAVE)
End DoDot:2
End DoDot:1
+28 KILL ^TMP($JOB,"IBCRC-INDT")
+29 QUIT
+30 ;
UNASSOC(IBIFN,RS,CS,IBMIARR) ; Determine charges for UNASSOCIATED billable events
+1 ; - the billable event is not associated with any data element on the bill
+2 ; - the item to charge is selected by the user from the list of billing items (363.21)
+3 ; - the items the user selected to add charges to the bill for are passed in in array IBMIARR
+4 ; - if the charge set is limited by region then either the items division or if no item division then the bill's
+5 ; Default Division must be contained in the sets region
+6 ;
+7 NEW IBX,IBBLITEM,IBCHGMTH,IBIDRC,IBBDIV,IBI,IBITM,IBEVDT,IBTUNITS,IBDIV,IBRVCD,IBTYPE,IBCMPNT,IBSAVE
+8 IF '$GET(IBIFN)!'$GET(CS)!'$GET(IBMIARR)
QUIT
+9 ;
+10 SET IBTYPE=9
SET IBCMPNT=$PIECE($GET(^IBE(363.1,+CS,0)),U,4)
SET IBX=$$CSBR^IBCRU3(CS)
SET IBBLITEM=$PIECE(IBX,U,4)
SET IBCHGMTH=$PIECE(IBX,U,5)
+11 SET IBIDRC=+$GET(^DGCR(399,+IBIFN,"MP"))
+12 IF 'IBIDRC
IF $$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN))
SET IBIDRC=$$CURR^IBCEF2(IBIFN)
+13 SET IBIDRC=$GET(^DIC(36,+IBIDRC,0))
SET IBIDRC=$PIECE(IBIDRC,U,7)
+14 ;
+15 ; bill's default division
SET IBBDIV=$PIECE($GET(^DGCR(399,+IBIFN,0)),U,22)
+16 ;
+17 ; charge per item
IF IBBLITEM=9
IF IBCHGMTH=1
Begin DoDot:1
+18 SET IBI=0
FOR
SET IBI=$ORDER(IBMIARR(RS,CS,IBI))
if 'IBI
QUIT
Begin DoDot:2
+19 SET IBX=IBMIARR(RS,CS,IBI)
SET IBITM=+$PIECE(IBX,U,1)
SET IBEVDT=$PIECE(IBX,U,2)
+20 SET IBTUNITS=$PIECE(IBX,U,3)
SET IBDIV=$PIECE(IBX,U,4)
SET IBRVCD=$PIECE(IBX,U,5)
+21 ;
+22 ; check division
IF $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0
QUIT
+23 ;
+24 SET IBSAVE=IBTUNITS_"^^"_IBDIV_"^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT
+25 DO BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,1,"",IBRVCD,IBIDRC,IBSAVE)
End DoDot:2
End DoDot:1
+26 QUIT
