- IBCRU2 ;ALB/ARH - RATES: UTILITIES (CI DEFINITIONS) ; 22-MAY-1996
- ;;2.0;INTEGRATED BILLING;**52,106,138,210**;21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;
- FNDBI(T,N) ; returns IFN of Billing Items entry (363.21) if Name N is found and of Type T
- N X,I,Y S X=0,T=$G(T),T=$S(T["NDC":1,T["MISCELLANEOUS":9,1:T)
- I +T,$G(N)'="" S I=0 F S I=$O(^IBA(363.21,"B",$E(N,1,30),I)) Q:'I S Y=$G(^IBA(363.21,I,0)) I +$P(Y,U,2)=T,$P(Y,U,1)=N S X=I Q
- Q X
- ;
- BIFILE(BI) ; returns the source file reference for a billable item (363.3,.04)
- N IBX S IBX="",BI=+$G(BI)
- I BI=1 S IBX=";DGCR(399.1,^399.1" ; billable bedsections
- I BI=2 S IBX=";ICPT(^81" ; CPT procedures
- I BI=3 S IBX=";IBA(363.21,^363.21" ; NDC numbers
- I BI=4 S IBX=";ICD(^80.2" ; DRG codes
- I BI=9 S IBX=";IBA(363.21,^363.21" ; Miscellaneous
- Q IBX
- ;
- ITPTR(BI,NAME) ; returns pointer to item in source file if found for this billable item type
- N IBX S IBX=0 S BI=+$G(BI),NAME=$G(NAME)
- I BI=1,NAME'="" S IBX=$$MCCRUTL^IBCRU1(NAME,5)
- I BI=2,NAME'="" S IBX=$$CPTIEN^IBACSV(NAME)
- I BI=3,NAME'="" S IBX=$$FNDBI("NDC",NAME)
- I BI=4,NAME'="" S IBX=$$DRGIEN^IBACSV(NAME)
- I BI=9,NAME'="" S IBX=$$FNDBI("MISCELLANEOUS",NAME)
- Q +IBX
- ;
- ITFILE(BI,ITEM,EFFDT) ; returns source item pointer (true) if the item is an active source entry for this billable item type
- N IBX,IBY S IBX=0,BI=+$G(BI),ITEM=+$G(ITEM),EFFDT=$G(EFFDT) I 'EFFDT S EFFDT=DT
- I BI=1,+ITEM S IBY=$G(^DGCR(399.1,ITEM,0)) I IBY'="",+$P(IBY,U,5) S IBX=ITEM
- I BI=2,+ITEM,$$CPTACT^IBACSV(ITEM,EFFDT) S IBX=ITEM
- I BI=3,+ITEM S IBY=$G(^IBA(363.21,ITEM,0)) I IBY'="",+$P(IBY,U,2)=1 S IBX=ITEM
- I BI=4,+ITEM,$$DRGACT^IBACSV(ITEM,EFFDT) S IBX=ITEM
- I BI=9,+ITEM S IBY=$G(^IBA(363.21,ITEM,0)) I IBY'="",+$P(IBY,U,2)=9 S IBX=ITEM
- Q IBX
- ;
- ITBICHK(CS,ITEM,NAME) ; returns source item pointer (true) if the item is a valid active item for the Charge Set
- N IBX,IBBI,IBITEM S IBX=0
- S IBBI=$$CSBI^IBCRU3($G(CS))
- S IBITEM=$G(ITEM) I 'IBITEM,$G(NAME)'="" S IBITEM=$$ITPTR(IBBI,NAME)
- I +IBBI,+IBITEM S IBX=$$ITFILE(+IBBI,+IBITEM)
- Q IBX
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRU2 2166 printed Jan 18, 2025@03:21:09 Page 2
- IBCRU2 ;ALB/ARH - RATES: UTILITIES (CI DEFINITIONS) ; 22-MAY-1996
- +1 ;;2.0;INTEGRATED BILLING;**52,106,138,210**;21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 ;
- FNDBI(T,N) ; returns IFN of Billing Items entry (363.21) if Name N is found and of Type T
- +1 NEW X,I,Y
- SET X=0
- SET T=$GET(T)
- SET T=$SELECT(T["NDC":1,T["MISCELLANEOUS":9,1:T)
- +2 IF +T
- IF $GET(N)'=""
- SET I=0
- FOR
- SET I=$ORDER(^IBA(363.21,"B",$EXTRACT(N,1,30),I))
- if 'I
- QUIT
- SET Y=$GET(^IBA(363.21,I,0))
- IF +$PIECE(Y,U,2)=T
- IF $PIECE(Y,U,1)=N
- SET X=I
- QUIT
- +3 QUIT X
- +4 ;
- BIFILE(BI) ; returns the source file reference for a billable item (363.3,.04)
- +1 NEW IBX
- SET IBX=""
- SET BI=+$GET(BI)
- +2 ; billable bedsections
- IF BI=1
- SET IBX=";DGCR(399.1,^399.1"
- +3 ; CPT procedures
- IF BI=2
- SET IBX=";ICPT(^81"
- +4 ; NDC numbers
- IF BI=3
- SET IBX=";IBA(363.21,^363.21"
- +5 ; DRG codes
- IF BI=4
- SET IBX=";ICD(^80.2"
- +6 ; Miscellaneous
- IF BI=9
- SET IBX=";IBA(363.21,^363.21"
- +7 QUIT IBX
- +8 ;
- ITPTR(BI,NAME) ; returns pointer to item in source file if found for this billable item type
- +1 NEW IBX
- SET IBX=0
- SET BI=+$GET(BI)
- SET NAME=$GET(NAME)
- +2 IF BI=1
- IF NAME'=""
- SET IBX=$$MCCRUTL^IBCRU1(NAME,5)
- +3 IF BI=2
- IF NAME'=""
- SET IBX=$$CPTIEN^IBACSV(NAME)
- +4 IF BI=3
- IF NAME'=""
- SET IBX=$$FNDBI("NDC",NAME)
- +5 IF BI=4
- IF NAME'=""
- SET IBX=$$DRGIEN^IBACSV(NAME)
- +6 IF BI=9
- IF NAME'=""
- SET IBX=$$FNDBI("MISCELLANEOUS",NAME)
- +7 QUIT +IBX
- +8 ;
- ITFILE(BI,ITEM,EFFDT) ; returns source item pointer (true) if the item is an active source entry for this billable item type
- +1 NEW IBX,IBY
- SET IBX=0
- SET BI=+$GET(BI)
- SET ITEM=+$GET(ITEM)
- SET EFFDT=$GET(EFFDT)
- IF 'EFFDT
- SET EFFDT=DT
- +2 IF BI=1
- IF +ITEM
- SET IBY=$GET(^DGCR(399.1,ITEM,0))
- IF IBY'=""
- IF +$PIECE(IBY,U,5)
- SET IBX=ITEM
- +3 IF BI=2
- IF +ITEM
- IF $$CPTACT^IBACSV(ITEM,EFFDT)
- SET IBX=ITEM
- +4 IF BI=3
- IF +ITEM
- SET IBY=$GET(^IBA(363.21,ITEM,0))
- IF IBY'=""
- IF +$PIECE(IBY,U,2)=1
- SET IBX=ITEM
- +5 IF BI=4
- IF +ITEM
- IF $$DRGACT^IBACSV(ITEM,EFFDT)
- SET IBX=ITEM
- +6 IF BI=9
- IF +ITEM
- SET IBY=$GET(^IBA(363.21,ITEM,0))
- IF IBY'=""
- IF +$PIECE(IBY,U,2)=9
- SET IBX=ITEM
- +7 QUIT IBX
- +8 ;
- ITBICHK(CS,ITEM,NAME) ; returns source item pointer (true) if the item is a valid active item for the Charge Set
- +1 NEW IBX,IBBI,IBITEM
- SET IBX=0
- +2 SET IBBI=$$CSBI^IBCRU3($GET(CS))
- +3 SET IBITEM=$GET(ITEM)
- IF 'IBITEM
- IF $GET(NAME)'=""
- SET IBITEM=$$ITPTR(IBBI,NAME)
- +4 IF +IBBI
- IF +IBITEM
- SET IBX=$$ITFILE(+IBBI,+IBITEM)
- +5 QUIT IBX