IBCRU1 ;ALB/ARH - RATES: UTILITIES ; 22-MAY-1996
;;2.0;INTEGRATED BILLING;**52,106,210**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
EMUTL(X,LNG) ; returns external form of an MCCR Utility entry (399.1), full or abbrev.
S X=$G(^DGCR(399.1,+$G(X),0)),LNG=$S(+$G(LNG)=2:3,1:1)
S X=$P(X,U,LNG)
Q X
;
MCCRUTL(N,P) ; returns IFN of MCCR Utility entry (399.1) if Name N is found and piece P is true
N X,I,Y S X=0
I +$G(P),$G(N)'="" S I=0 F S I=$O(^DGCR(399.1,"B",$E(N,1,30),I)) Q:'I S Y=$G(^DGCR(399.1,I,0)) I +$P(Y,U,P),$P(Y,U,1)=N S X=I Q
Q X
;
EXPAND(FILE,FIELD,VALUE) ; return expanded external form of a data element
N Y,C S Y=$G(VALUE)
I +$G(FILE),+$G(FIELD),Y'="" S C=$P(^DD(FILE,FIELD,0),"^",2) D Y^DIQ
Q Y
;
DATE(X) ; date in external format
N Y S Y="" I $G(X)?7N.E S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
Q Y
;
GETDT(DEFAULT,PROMPT,MIN,MAX) ; user select effective date (-1 if ^, 0 if none) DT1
N IBX,DIR,X,Y,DTOUT,DUOUT,DIRUT S IBX=0 I $G(DEFAULT) S DIR("B")=$$DATE(DEFAULT)
S DIR("A")=$S($G(PROMPT)'="":PROMPT,1:"Select EFFECTIVE DATE")
S DIR(0)="DO^"_$G(MIN)_":"_$G(MAX)_":EX" D ^DIR K DIR I Y?7N S IBX=+Y
I $D(DTOUT)!$D(DUOUT) S IBX=-1
Q IBX
;
GETBR(BI) ; ask and return a billing rate (363.3): (-1 if ^, 0 if none) IFN^.01
; if BI passed in then only allow selection of billing rates with that type of billable item
N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
I +$G(BI) S DIC("S")="I $P(^(0),U,4)="_BI
S DIC="^IBE(363.3,",DIC(0)="AENQ" D ^DIC K DIC
I $D(DTOUT)!($D(DUOUT)) S IBX=-1
I +Y>0 S IBX=Y
Q IBX
;
GETCS() ; ask and return a charge set (363.2): (-1 if ^, 0 if none) IFN^.01
N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
S DIC="^IBE(363.1,",DIC(0)="AENQ" D ^DIC K DIC
I $D(DTOUT)!($D(DUOUT)) S IBX=-1
I +Y>0 S IBX=Y
Q IBX
;
GETSG(TYPE,BR) ; ask and return a special group (363.32): (-1 if ^, 0 if none) IFN^.01
; if TYPE is passed in then only groups of that type may be selected
; if BR is passed in then only groups assigned that billing rate may be selected
N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
I +$G(TYPE) S DIC("S")="I $P(^(0),U,2)="_TYPE_$S(+$G(BR):" ",1:"")
I +$G(BR) S DIC("S")=$G(DIC("S"))_"I $O(^IBE(363.32,Y,11,""B"",+BR,0))"
S DIC="^IBE(363.32,",DIC(0)="AENQ" D ^DIC K DIC
I $D(DTOUT)!($D(DUOUT)) S IBX=-1
I +Y>0 S IBX=Y
Q IBX
;
GETBED(COL) ; ask and return billable bedsection (399.1): (-1 if ^, 0 if none) IFN^.01
N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
S DIC("A")=$J("",$G(COL))_"Select BEDSECTION: "
S DIC="^DGCR(399.1,",DIC(0)="AENQ",DIC("S")="I +$P(^(0),U,5)=1" D ^DIC K DIC
I $D(DTOUT)!($D(DUOUT)) S IBX=-1
I +Y>0 S IBX=Y
Q IBX
;
GETCPT(COL,ALL) ; ask and return CPT (81): (-1 if ^, 0 if none) IFN^.01
N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
S DIC("A")=$J("",$G(COL))_"Select CPT: " I '$G(ALL) S DIC("S")="I $$CPTACT^IBACSV(+Y,DT)"
S DIC="^ICPT(",DIC(0)="AEMNQ" D ^DIC K DIC
I $D(DTOUT)!($D(DUOUT)) S IBX=-1
I +Y>0 S IBX=Y
Q IBX
;
GETNDC(COL) ; ask and return NDC #'s (363.21): (-1 if ^, 0 if none) IFN^.01
N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
S DIC("A")=$J("",$G(COL))_"Select NDC #: "
S DIC="^IBA(363.21,",DIC(0)="AENQ",DIC("S")="I +$P(^(0),U,2)=1" D ^DIC K DIC
I $D(DTOUT)!($D(DUOUT)) S IBX=-1
I +Y>0 S IBX=Y
Q IBX
;
GETDRG(COL,ALL) ; ask and return DRG (80.2): (-1 if ^, 0 if none) IFN^.01
; ALL: Default is 1 (disable screening)
N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
S DIC("A")=$J("",$G(COL))_"Select DRG: " I '$G(ALL,1) S DIC("S")="I $$DRGACT^IBACSV(+Y,DT)"
S DIC="^ICD(",DIC(0)="AEMNQ" D ^DIC K DIC
I $D(DTOUT)!($D(DUOUT)) S IBX=-1
I +Y>0 S IBX=Y
Q IBX
;
GETMISC(COL,CS) ; ask and return MISCELLANEOUS item (363.21): (-1 if ^, 0 if none) IFN^.01
; if CS is passed in then only billing items with charges in that set are selectable
N IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT S IBX=0
S DIC("A")=$J("",$G(COL))_"Select MISCELLANEOUS Item: "
S DIC("S")="I +$P(^(0),U,2)=9" I +$G(CS) S DIC("S")=DIC("S")_",$D(^IBA(363.2,""AIVDTS""_+CS,Y))"
S DIC="^IBA(363.21,",DIC(0)="AENQ" D ^DIC K DIC
I $D(DTOUT)!($D(DUOUT)) S IBX=-1
I +Y>0 S IBX=Y
Q IBX
;
GETITEM(IBCSFN,COL,ALL) ; returns user selected item for a specific charge set:
; IFN ^ .01 ^ source file reference ^ source file (-1 if ^, 0 if none)
N IBCS0,IBBRFN,IBBR0,IBBRBI,IBITEM S IBITEM=0,COL=$G(COL),ALL=$G(ALL)
I '$G(IBCSFN) S IBCSFN=+$$GETCS I IBCSFN'>0 G GIQ
;
S IBCS0=$G(^IBE(363.1,+IBCSFN,0)),IBBRFN=$P(IBCS0,U,2)
S IBBR0=$G(^IBE(363.3,+IBBRFN,0)),IBBRBI=$P(IBBR0,U,4)
;
I IBBRBI=1 S IBITEM=$$GETBED(COL) S:IBITEM>0 IBITEM=IBITEM_U_$$BIFILE^IBCRU2(IBBRBI) G GIQ
I IBBRBI=2 S IBITEM=$$GETCPT(COL,ALL) S:IBITEM>0 IBITEM=IBITEM_U_$$BIFILE^IBCRU2(IBBRBI) G GIQ
I IBBRBI=3 S IBITEM=$$GETNDC(COL) S:IBITEM>0 IBITEM=IBITEM_U_$$BIFILE^IBCRU2(IBBRBI) G GIQ
I IBBRBI=4 S IBITEM=$$GETDRG(COL) S:IBITEM>0 IBITEM=IBITEM_U_$$BIFILE^IBCRU2(IBBRBI) G GIQ
I IBBRBI=9 S IBITEM=$$GETMISC(COL,$S('ALL:+IBCSFN,1:0)) S:IBITEM>0 IBITEM=IBITEM_U_$$BIFILE^IBCRU2(IBBRBI) G GIQ
GIQ Q IBITEM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRU1 5155 printed Dec 13, 2024@02:19:56 Page 2
IBCRU1 ;ALB/ARH - RATES: UTILITIES ; 22-MAY-1996
+1 ;;2.0;INTEGRATED BILLING;**52,106,210**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
EMUTL(X,LNG) ; returns external form of an MCCR Utility entry (399.1), full or abbrev.
+1 SET X=$GET(^DGCR(399.1,+$GET(X),0))
SET LNG=$SELECT(+$GET(LNG)=2:3,1:1)
+2 SET X=$PIECE(X,U,LNG)
+3 QUIT X
+4 ;
MCCRUTL(N,P) ; returns IFN of MCCR Utility entry (399.1) if Name N is found and piece P is true
+1 NEW X,I,Y
SET X=0
+2 IF +$GET(P)
IF $GET(N)'=""
SET I=0
FOR
SET I=$ORDER(^DGCR(399.1,"B",$EXTRACT(N,1,30),I))
if 'I
QUIT
SET Y=$GET(^DGCR(399.1,I,0))
IF +$PIECE(Y,U,P)
IF $PIECE(Y,U,1)=N
SET X=I
QUIT
+3 QUIT X
+4 ;
EXPAND(FILE,FIELD,VALUE) ; return expanded external form of a data element
+1 NEW Y,C
SET Y=$GET(VALUE)
+2 IF +$GET(FILE)
IF +$GET(FIELD)
IF Y'=""
SET C=$PIECE(^DD(FILE,FIELD,0),"^",2)
DO Y^DIQ
+3 QUIT Y
+4 ;
DATE(X) ; date in external format
+1 NEW Y
SET Y=""
IF $GET(X)?7N.E
SET Y=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+2 QUIT Y
+3 ;
GETDT(DEFAULT,PROMPT,MIN,MAX) ; user select effective date (-1 if ^, 0 if none) DT1
+1 NEW IBX,DIR,X,Y,DTOUT,DUOUT,DIRUT
SET IBX=0
IF $GET(DEFAULT)
SET DIR("B")=$$DATE(DEFAULT)
+2 SET DIR("A")=$SELECT($GET(PROMPT)'="":PROMPT,1:"Select EFFECTIVE DATE")
+3 SET DIR(0)="DO^"_$GET(MIN)_":"_$GET(MAX)_":EX"
DO ^DIR
KILL DIR
IF Y?7N
SET IBX=+Y
+4 IF $DATA(DTOUT)!$DATA(DUOUT)
SET IBX=-1
+5 QUIT IBX
+6 ;
GETBR(BI) ; ask and return a billing rate (363.3): (-1 if ^, 0 if none) IFN^.01
+1 ; if BI passed in then only allow selection of billing rates with that type of billable item
+2 NEW IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT
SET IBX=0
+3 IF +$GET(BI)
SET DIC("S")="I $P(^(0),U,4)="_BI
+4 SET DIC="^IBE(363.3,"
SET DIC(0)="AENQ"
DO ^DIC
KILL DIC
+5 IF $DATA(DTOUT)!($DATA(DUOUT))
SET IBX=-1
+6 IF +Y>0
SET IBX=Y
+7 QUIT IBX
+8 ;
GETCS() ; ask and return a charge set (363.2): (-1 if ^, 0 if none) IFN^.01
+1 NEW IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT
SET IBX=0
+2 SET DIC="^IBE(363.1,"
SET DIC(0)="AENQ"
DO ^DIC
KILL DIC
+3 IF $DATA(DTOUT)!($DATA(DUOUT))
SET IBX=-1
+4 IF +Y>0
SET IBX=Y
+5 QUIT IBX
+6 ;
GETSG(TYPE,BR) ; ask and return a special group (363.32): (-1 if ^, 0 if none) IFN^.01
+1 ; if TYPE is passed in then only groups of that type may be selected
+2 ; if BR is passed in then only groups assigned that billing rate may be selected
+3 NEW IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT
SET IBX=0
+4 IF +$GET(TYPE)
SET DIC("S")="I $P(^(0),U,2)="_TYPE_$SELECT(+$GET(BR):" ",1:"")
+5 IF +$GET(BR)
SET DIC("S")=$GET(DIC("S"))_"I $O(^IBE(363.32,Y,11,""B"",+BR,0))"
+6 SET DIC="^IBE(363.32,"
SET DIC(0)="AENQ"
DO ^DIC
KILL DIC
+7 IF $DATA(DTOUT)!($DATA(DUOUT))
SET IBX=-1
+8 IF +Y>0
SET IBX=Y
+9 QUIT IBX
+10 ;
GETBED(COL) ; ask and return billable bedsection (399.1): (-1 if ^, 0 if none) IFN^.01
+1 NEW IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT
SET IBX=0
+2 SET DIC("A")=$JUSTIFY("",$GET(COL))_"Select BEDSECTION: "
+3 SET DIC="^DGCR(399.1,"
SET DIC(0)="AENQ"
SET DIC("S")="I +$P(^(0),U,5)=1"
DO ^DIC
KILL DIC
+4 IF $DATA(DTOUT)!($DATA(DUOUT))
SET IBX=-1
+5 IF +Y>0
SET IBX=Y
+6 QUIT IBX
+7 ;
GETCPT(COL,ALL) ; ask and return CPT (81): (-1 if ^, 0 if none) IFN^.01
+1 NEW IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT
SET IBX=0
+2 SET DIC("A")=$JUSTIFY("",$GET(COL))_"Select CPT: "
IF '$GET(ALL)
SET DIC("S")="I $$CPTACT^IBACSV(+Y,DT)"
+3 SET DIC="^ICPT("
SET DIC(0)="AEMNQ"
DO ^DIC
KILL DIC
+4 IF $DATA(DTOUT)!($DATA(DUOUT))
SET IBX=-1
+5 IF +Y>0
SET IBX=Y
+6 QUIT IBX
+7 ;
GETNDC(COL) ; ask and return NDC #'s (363.21): (-1 if ^, 0 if none) IFN^.01
+1 NEW IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT
SET IBX=0
+2 SET DIC("A")=$JUSTIFY("",$GET(COL))_"Select NDC #: "
+3 SET DIC="^IBA(363.21,"
SET DIC(0)="AENQ"
SET DIC("S")="I +$P(^(0),U,2)=1"
DO ^DIC
KILL DIC
+4 IF $DATA(DTOUT)!($DATA(DUOUT))
SET IBX=-1
+5 IF +Y>0
SET IBX=Y
+6 QUIT IBX
+7 ;
GETDRG(COL,ALL) ; ask and return DRG (80.2): (-1 if ^, 0 if none) IFN^.01
+1 ; ALL: Default is 1 (disable screening)
+2 NEW IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT
SET IBX=0
+3 SET DIC("A")=$JUSTIFY("",$GET(COL))_"Select DRG: "
IF '$GET(ALL,1)
SET DIC("S")="I $$DRGACT^IBACSV(+Y,DT)"
+4 SET DIC="^ICD("
SET DIC(0)="AEMNQ"
DO ^DIC
KILL DIC
+5 IF $DATA(DTOUT)!($DATA(DUOUT))
SET IBX=-1
+6 IF +Y>0
SET IBX=Y
+7 QUIT IBX
+8 ;
GETMISC(COL,CS) ; ask and return MISCELLANEOUS item (363.21): (-1 if ^, 0 if none) IFN^.01
+1 ; if CS is passed in then only billing items with charges in that set are selectable
+2 NEW IBX,DIC,DIE,DA,DR,X,Y,DTOUT,DUOUT
SET IBX=0
+3 SET DIC("A")=$JUSTIFY("",$GET(COL))_"Select MISCELLANEOUS Item: "
+4 SET DIC("S")="I +$P(^(0),U,2)=9"
IF +$GET(CS)
SET DIC("S")=DIC("S")_",$D(^IBA(363.2,""AIVDTS""_+CS,Y))"
+5 SET DIC="^IBA(363.21,"
SET DIC(0)="AENQ"
DO ^DIC
KILL DIC
+6 IF $DATA(DTOUT)!($DATA(DUOUT))
SET IBX=-1
+7 IF +Y>0
SET IBX=Y
+8 QUIT IBX
+9 ;
GETITEM(IBCSFN,COL,ALL) ; returns user selected item for a specific charge set:
+1 ; IFN ^ .01 ^ source file reference ^ source file (-1 if ^, 0 if none)
+2 NEW IBCS0,IBBRFN,IBBR0,IBBRBI,IBITEM
SET IBITEM=0
SET COL=$GET(COL)
SET ALL=$GET(ALL)
+3 IF '$GET(IBCSFN)
SET IBCSFN=+$$GETCS
IF IBCSFN'>0
GOTO GIQ
+4 ;
+5 SET IBCS0=$GET(^IBE(363.1,+IBCSFN,0))
SET IBBRFN=$PIECE(IBCS0,U,2)
+6 SET IBBR0=$GET(^IBE(363.3,+IBBRFN,0))
SET IBBRBI=$PIECE(IBBR0,U,4)
+7 ;
+8 IF IBBRBI=1
SET IBITEM=$$GETBED(COL)
if IBITEM>0
SET IBITEM=IBITEM_U_$$BIFILE^IBCRU2(IBBRBI)
GOTO GIQ
+9 IF IBBRBI=2
SET IBITEM=$$GETCPT(COL,ALL)
if IBITEM>0
SET IBITEM=IBITEM_U_$$BIFILE^IBCRU2(IBBRBI)
GOTO GIQ
+10 IF IBBRBI=3
SET IBITEM=$$GETNDC(COL)
if IBITEM>0
SET IBITEM=IBITEM_U_$$BIFILE^IBCRU2(IBBRBI)
GOTO GIQ
+11 IF IBBRBI=4
SET IBITEM=$$GETDRG(COL)
if IBITEM>0
SET IBITEM=IBITEM_U_$$BIFILE^IBCRU2(IBBRBI)
GOTO GIQ
+12 IF IBBRBI=9
SET IBITEM=$$GETMISC(COL,$SELECT('ALL:+IBCSFN,1:0))
if IBITEM>0
SET IBITEM=IBITEM_U_$$BIFILE^IBCRU2(IBBRBI)
GOTO GIQ
GIQ QUIT IBITEM
