- 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 Jan 18, 2025@03:21:09 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