IBCRBG2 ;ALB/ARH - RATES: BILL SOURCE EVENTS (INPT CONT) ; 01-OCT-03
;;2.0;INTEGRATED BILLING;**245,175,332,364,399,422,418**;21-MAR-94;Build 16
;;Per VHA Directive 2004-038, this routine should not be modified.
;
INPTRSET(IBIFN,CS) ; reset Inpatient data due to bedsection Tort 03 and Other Type of Care RC v2.0
; (based on INPTPTF since that deals with timeframe and end of bill)
N IBRC S IBRC=1 I +$G(CS),$E($G(^IBE(363.1,+CS,0)),1,2)'="RC" S IBRC=0
;
D INPTBS(IBIFN,IBRC)
D INPTOTH(IBIFN,IBRC)
Q
;
INPTBS(IBIFN,RC) ; with output from INPTPTF^IBCRBG, reset bedsections due to changes with Tort 03 and RC
; - Some Specialties are changed to PRRTP bedsection (beginning with Tort 03)
; - Some Specialties are changed to ICU bedsection for RC only (beginning with RC v2.0)
; - Nursing Home Care and Observation bedsections are not billable with RC DRG (per diem) so remove DRG
; (based on INPTPTF since that deals with timeframe and end of bill)
;
N IBDT,IBLN,IBSPCLTY,IBNLN,IBNBS,IBNDRG,IBCGTY
;
S IBDT=0 F S IBDT=$O(^TMP($J,"IBCRC-INDT",IBDT)) Q:'IBDT D
. S IBLN=$G(^TMP($J,"IBCRC-INDT",IBDT)) Q:'IBLN
. S IBSPCLTY=$P(IBLN,U,6) Q:'IBSPCLTY
. ;
. S IBNLN=IBLN
. S IBNBS=$$BSUPD(IBSPCLTY,IBDT,+$G(RC)) I +IBNBS S $P(IBNLN,U,2)=+IBNBS
. S IBNDRG=$$NODRG(IBSPCLTY) I +IBNDRG S $P(IBNLN,U,4)=""
. I 'IBNBS,'IBNDRG Q
. S ^TMP($J,"IBCRC-INDT",IBDT)=IBNLN
Q
;
INPTOTH(IBIFN,RC) ; with output from INPTPTF^IBCRBG, reset Other type of care and Tort 03 changes
; - If type of care is Other then bedsection is replaced and DRG deleted (began with RC v2.0)
; (based on INPTPTF since that deals with timeframe and end of bill)
;
N IBOT,IBOTLN,IBBS,IBDT1,IBDT2,IBDT,IBLN,IBNLN Q:'$G(RC)
I +$G(IBIFN) S IBOT=0 F S IBOT=$O(^DGCR(399,IBIFN,"OT",IBOT)) Q:'IBOT D
. S IBOTLN=$G(^DGCR(399,IBIFN,"OT",IBOT,0)) Q:'IBOTLN
. S IBDT1=+$P(IBOTLN,U,2) Q:'IBDT1 S IBDT2=+$P(IBOTLN,U,3) Q:'IBDT2
. I (IBDT1\1)=(IBDT2\1) S IBDT2=IBDT2+.3 ; allow for 1 day SNF stay
. S IBBS=+IBOTLN Q:'IBOTLN
. ;
. S IBDT=IBDT1-.1 F S IBDT=$O(^TMP($J,"IBCRC-INDT",IBDT)) Q:('IBDT)!(IBDT'<IBDT2) D
.. S IBLN=$G(^TMP($J,"IBCRC-INDT",IBDT)) Q:'IBLN
.. I IBDT<$$RC20 Q
.. ;
.. S IBNLN=IBLN
.. S $P(IBNLN,U,2)=+IBBS,$P(IBNLN,U,4)=""
.. S ^TMP($J,"IBCRC-INDT",IBDT)=IBNLN
Q
;
;
BSUPD(SPCLTY,DATE,RC) ; return updated bedsection name for specialty passed in (42.4 ifn)
; beginning with TORT 2003 some specialties were moved to new PRRTP bedsection
; beginning with RC v2.0 some specialties were moved to a new ICU bedsection, only applies to RC charges
N IBX,IBY,IBZ S (IBZ,IBX)="",SPCLTY=","_+$G(SPCLTY)_",",DATE=$S(+$G(DATE):(DATE\1),1:DT)
I DATE'<$$TORT03,",25,26,27,28,29,38,39,"[SPCLTY S IBX="PRRTP"
I DATE'<$$TORT11,",112,"[SPCLTY S IBX="POLYTRAUMA INPATIENT"
I +$G(RC),DATE'<$$RC20,",12,13,16,17,63,"[SPCLTY S IBX="ICU"
I IBX'="" S IBY=$O(^DGCR(399.1,"B",IBX,0)) I +IBY S IBZ=IBY_U_IBX
Q IBZ
;
TORT03() ; return effective date of TORT 2003, date when PRRTP bedsection specialties changed
Q 3040107
;
TORT11() ; return effective date when POLYTRAUMA bedsection specialty changed
Q 3110711
;
RC20() ; return effective date of RC v2.0, date when ICU bedsection specialties changed
Q 3031219
;
NODRG(SPCLTY) ; return specialty ifn followed by bedsection name if the specialty should not be charged a DRG charge
N IBX,IBS S IBX=0,IBS=","_+$G(SPCLTY)_","
I ",80,81,96,42,43,44,45,46,64,66,67,68,69,95,100,101,102,"[IBS S IBX=+SPCLTY_"^Nursing Home Care"
I ",18,23,24,36,41,65,94,108,"[IBS S IBX=+SPCLTY_"^Observation"
Q IBX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRBG2 3624 printed Sep 23, 2025@19:55:08 Page 2
IBCRBG2 ;ALB/ARH - RATES: BILL SOURCE EVENTS (INPT CONT) ; 01-OCT-03
+1 ;;2.0;INTEGRATED BILLING;**245,175,332,364,399,422,418**;21-MAR-94;Build 16
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
INPTRSET(IBIFN,CS) ; reset Inpatient data due to bedsection Tort 03 and Other Type of Care RC v2.0
+1 ; (based on INPTPTF since that deals with timeframe and end of bill)
+2 NEW IBRC
SET IBRC=1
IF +$GET(CS)
IF $EXTRACT($GET(^IBE(363.1,+CS,0)),1,2)'="RC"
SET IBRC=0
+3 ;
+4 DO INPTBS(IBIFN,IBRC)
+5 DO INPTOTH(IBIFN,IBRC)
+6 QUIT
+7 ;
INPTBS(IBIFN,RC) ; with output from INPTPTF^IBCRBG, reset bedsections due to changes with Tort 03 and RC
+1 ; - Some Specialties are changed to PRRTP bedsection (beginning with Tort 03)
+2 ; - Some Specialties are changed to ICU bedsection for RC only (beginning with RC v2.0)
+3 ; - Nursing Home Care and Observation bedsections are not billable with RC DRG (per diem) so remove DRG
+4 ; (based on INPTPTF since that deals with timeframe and end of bill)
+5 ;
+6 NEW IBDT,IBLN,IBSPCLTY,IBNLN,IBNBS,IBNDRG,IBCGTY
+7 ;
+8 SET IBDT=0
FOR
SET IBDT=$ORDER(^TMP($JOB,"IBCRC-INDT",IBDT))
if 'IBDT
QUIT
Begin DoDot:1
+9 SET IBLN=$GET(^TMP($JOB,"IBCRC-INDT",IBDT))
if 'IBLN
QUIT
+10 SET IBSPCLTY=$PIECE(IBLN,U,6)
if 'IBSPCLTY
QUIT
+11 ;
+12 SET IBNLN=IBLN
+13 SET IBNBS=$$BSUPD(IBSPCLTY,IBDT,+$GET(RC))
IF +IBNBS
SET $PIECE(IBNLN,U,2)=+IBNBS
+14 SET IBNDRG=$$NODRG(IBSPCLTY)
IF +IBNDRG
SET $PIECE(IBNLN,U,4)=""
+15 IF 'IBNBS
IF 'IBNDRG
QUIT
+16 SET ^TMP($JOB,"IBCRC-INDT",IBDT)=IBNLN
End DoDot:1
+17 QUIT
+18 ;
INPTOTH(IBIFN,RC) ; with output from INPTPTF^IBCRBG, reset Other type of care and Tort 03 changes
+1 ; - If type of care is Other then bedsection is replaced and DRG deleted (began with RC v2.0)
+2 ; (based on INPTPTF since that deals with timeframe and end of bill)
+3 ;
+4 NEW IBOT,IBOTLN,IBBS,IBDT1,IBDT2,IBDT,IBLN,IBNLN
if '$GET(RC)
QUIT
+5 IF +$GET(IBIFN)
SET IBOT=0
FOR
SET IBOT=$ORDER(^DGCR(399,IBIFN,"OT",IBOT))
if 'IBOT
QUIT
Begin DoDot:1
+6 SET IBOTLN=$GET(^DGCR(399,IBIFN,"OT",IBOT,0))
if 'IBOTLN
QUIT
+7 SET IBDT1=+$PIECE(IBOTLN,U,2)
if 'IBDT1
QUIT
SET IBDT2=+$PIECE(IBOTLN,U,3)
if 'IBDT2
QUIT
+8 ; allow for 1 day SNF stay
IF (IBDT1\1)=(IBDT2\1)
SET IBDT2=IBDT2+.3
+9 SET IBBS=+IBOTLN
if 'IBOTLN
QUIT
+10 ;
+11 SET IBDT=IBDT1-.1
FOR
SET IBDT=$ORDER(^TMP($JOB,"IBCRC-INDT",IBDT))
if ('IBDT)!(IBDT'<IBDT2)
QUIT
Begin DoDot:2
+12 SET IBLN=$GET(^TMP($JOB,"IBCRC-INDT",IBDT))
if 'IBLN
QUIT
+13 IF IBDT<$$RC20
QUIT
+14 ;
+15 SET IBNLN=IBLN
+16 SET $PIECE(IBNLN,U,2)=+IBBS
SET $PIECE(IBNLN,U,4)=""
+17 SET ^TMP($JOB,"IBCRC-INDT",IBDT)=IBNLN
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
+20 ;
BSUPD(SPCLTY,DATE,RC) ; return updated bedsection name for specialty passed in (42.4 ifn)
+1 ; beginning with TORT 2003 some specialties were moved to new PRRTP bedsection
+2 ; beginning with RC v2.0 some specialties were moved to a new ICU bedsection, only applies to RC charges
+3 NEW IBX,IBY,IBZ
SET (IBZ,IBX)=""
SET SPCLTY=","_+$GET(SPCLTY)_","
SET DATE=$SELECT(+$GET(DATE):(DATE\1),1:DT)
+4 IF DATE'<$$TORT03
IF ",25,26,27,28,29,38,39,"[SPCLTY
SET IBX="PRRTP"
+5 IF DATE'<$$TORT11
IF ",112,"[SPCLTY
SET IBX="POLYTRAUMA INPATIENT"
+6 IF +$GET(RC)
IF DATE'<$$RC20
IF ",12,13,16,17,63,"[SPCLTY
SET IBX="ICU"
+7 IF IBX'=""
SET IBY=$ORDER(^DGCR(399.1,"B",IBX,0))
IF +IBY
SET IBZ=IBY_U_IBX
+8 QUIT IBZ
+9 ;
TORT03() ; return effective date of TORT 2003, date when PRRTP bedsection specialties changed
+1 QUIT 3040107
+2 ;
TORT11() ; return effective date when POLYTRAUMA bedsection specialty changed
+1 QUIT 3110711
+2 ;
RC20() ; return effective date of RC v2.0, date when ICU bedsection specialties changed
+1 QUIT 3031219
+2 ;
NODRG(SPCLTY) ; return specialty ifn followed by bedsection name if the specialty should not be charged a DRG charge
+1 NEW IBX,IBS
SET IBX=0
SET IBS=","_+$GET(SPCLTY)_","
+2 IF ",80,81,96,42,43,44,45,46,64,66,67,68,69,95,100,101,102,"[IBS
SET IBX=+SPCLTY_"^Nursing Home Care"
+3 IF ",18,23,24,36,41,65,94,108,"[IBS
SET IBX=+SPCLTY_"^Observation"
+4 QUIT IBX
