- 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 Mar 13, 2025@21:23:51 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
