- IBCSC61 ;ALB/MJB - MCCR SCREEN UTILITY ;20 JUN 88 10:58
- ;;2.0;INTEGRATED BILLING;**52,80,106,51,210,230,309,389**;21-MAR-94;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;MAP TO IBCSC61
- ;
- REV I I>1 W !?4,"Rev. Code",?16,": "
- N IBNAME S IBNAME=$E($$NAME($P(IBREVC(I),U,10),$P(IBREVC(I),U,11)),1,17)
- S DGRCD=$S($D(^DGCR(399.2,+IBREVC(I),0)):^(0),1:""),DGRCD=$P(DGRCD,"^",1)_"-"_$S(IBNAME'="":IBNAME,1:$E($P(DGRCD,"^",2),1,17))
- I $P(IBREVC(I),"^",6) S DGRCD=DGRCD_$J("",21-$L(DGRCD))_" "_$P($$CPT^ICPTCOD(+$P(IBREVC(I),"^",6)),U,2)
- I '$P(IBREVC(I),U,6),$P(IBREVC,U,11) S DGRCD=DGRCD_$J("",21-$L(DGRCD))_" *"_$P($$CPT^ICPTCOD(+$P(IBREVC(I),"^",11)),U,2)
- S DGRCD=DGRCD_$J("",28-$L(DGRCD))
- I (+$P(IBREVC(I),"^",3)>1)!($P(IBREVC(I),U,10)'=4) S DGRCD=DGRCD_$J($P(IBREVC(I),"^",3),3)
- S X=$S($P(IBREVC(I),"^",4)]"":$P(IBREVC(I),"^",4),1:IBU) I X'=IBU S X2="2$" D COMMA^%DTC
- W DGRCD,$J("",32-$L(DGRCD)),X
- I $P(IBREVC(I),"^",5)]"",$D(^DGCR(399.1,$P(IBREVC(I),"^",5),0)) W ?60," ",$E($P(^DGCR(399.1,$P(IBREVC(I),"^",5),0),"^"),1,16)
- I IBREVC<10,$P(IBREVC(I),U,9)'="",$$FT^IBCEF(IBIFN)=3 S X=$P(IBREVC(I),U,9),X2="2$" D COMMA^%DTC W !,?50,X S IBREVC=IBREVC+1 W ?64,"(Non-Covered)"
- Q
- ;
- CHARGE S (IBCH,IBUCH)=0 F I=1:1 Q:'$D(IBREVC(I)) S IBCH=IBCH+($P(IBREVC(I),U,4)),IBUCH=IBUCH+$P(IBREVC(I),U,9)
- I IB("U1")]"" S X=$P(IB("U1"),"^",1),X1=$P(IB("U1"),"^",2),IBCH=X
- Q
- ;
- OFFSET S IBOFFC="" W !?4,"OFFSET",?16,": " S X=$S(IB("U1")']"":0,1:+$P(IB("U1"),U,2)),X2="2$" S:X IBOFFC=$P(IB("U1"),U,3) D COMMA^%DTC
- W X," [",$S($L(IBOFFC):IBOFFC,'$P(X,"$",2):"NO OFFSET RECORDED",1:"OFFSET DESCRIPTION UNSPECIFIED"),"]"
- D CHARGE W !?4,"BILL TOTAL",?16,": " S X=$S('$D(IBCH):0,1:+IBCH),X2="2$" D COMMA^%DTC W X
- K IBOFFC
- Q
- ;
- NAME(TYPE,ITEM) ; if rx or pros or DRG or unassociated return name of the item
- N IBNAME S IBNAME=""
- I $G(TYPE)=3,+$G(ITEM) D
- .D ZERO^IBRXUTL($P($G(^IBA(362.4,+ITEM,0)),U,4))
- .S IBNAME=$G(^TMP($J,"IBDRUG",+$P($G(^IBA(362.4,+ITEM,0)),U,4),.01))
- .K ^TMP($J,"IBDRUG")
- .Q
- I $G(TYPE)=5,+$G(ITEM) S IBNAME=$P($G(^IBA(362.5,+ITEM,0)),U,5)
- I $G(TYPE)=6,+$G(ITEM) S IBNAME=$P($$DRG^IBACSV(+ITEM),U,1)
- I $G(TYPE)=9,+$G(ITEM) S IBNAME=$P($G(^IBA(363.21,+ITEM,0)),U,1)
- Q IBNAME
- ;IBCSC61
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC61 2279 printed Feb 18, 2025@23:46:47 Page 2
- IBCSC61 ;ALB/MJB - MCCR SCREEN UTILITY ;20 JUN 88 10:58
- +1 ;;2.0;INTEGRATED BILLING;**52,80,106,51,210,230,309,389**;21-MAR-94;Build 6
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ;MAP TO IBCSC61
- +5 ;
- REV IF I>1
- WRITE !?4,"Rev. Code",?16,": "
- +1 NEW IBNAME
- SET IBNAME=$EXTRACT($$NAME($PIECE(IBREVC(I),U,10),$PIECE(IBREVC(I),U,11)),1,17)
- +2 SET DGRCD=$SELECT($DATA(^DGCR(399.2,+IBREVC(I),0)):^(0),1:"")
- SET DGRCD=$PIECE(DGRCD,"^",1)_"-"_$SELECT(IBNAME'="":IBNAME,1:$EXTRACT($PIECE(DGRCD,"^",2),1,17))
- +3 IF $PIECE(IBREVC(I),"^",6)
- SET DGRCD=DGRCD_$JUSTIFY("",21-$LENGTH(DGRCD))_" "_$PIECE($$CPT^ICPTCOD(+$PIECE(IBREVC(I),"^",6)),U,2)
- +4 IF '$PIECE(IBREVC(I),U,6)
- IF $PIECE(IBREVC,U,11)
- SET DGRCD=DGRCD_$JUSTIFY("",21-$LENGTH(DGRCD))_" *"_$PIECE($$CPT^ICPTCOD(+$PIECE(IBREVC(I),"^",11)),U,2)
- +5 SET DGRCD=DGRCD_$JUSTIFY("",28-$LENGTH(DGRCD))
- +6 IF (+$PIECE(IBREVC(I),"^",3)>1)!($PIECE(IBREVC(I),U,10)'=4)
- SET DGRCD=DGRCD_$JUSTIFY($PIECE(IBREVC(I),"^",3),3)
- +7 SET X=$SELECT($PIECE(IBREVC(I),"^",4)]"":$PIECE(IBREVC(I),"^",4),1:IBU)
- IF X'=IBU
- SET X2="2$"
- DO COMMA^%DTC
- +8 WRITE DGRCD,$JUSTIFY("",32-$LENGTH(DGRCD)),X
- +9 IF $PIECE(IBREVC(I),"^",5)]""
- IF $DATA(^DGCR(399.1,$PIECE(IBREVC(I),"^",5),0))
- WRITE ?60," ",$EXTRACT($PIECE(^DGCR(399.1,$PIECE(IBREVC(I),"^",5),0),"^"),1,16)
- +10 IF IBREVC<10
- IF $PIECE(IBREVC(I),U,9)'=""
- IF $$FT^IBCEF(IBIFN)=3
- SET X=$PIECE(IBREVC(I),U,9)
- SET X2="2$"
- DO COMMA^%DTC
- WRITE !,?50,X
- SET IBREVC=IBREVC+1
- WRITE ?64,"(Non-Covered)"
- +11 QUIT
- +12 ;
- CHARGE SET (IBCH,IBUCH)=0
- FOR I=1:1
- if '$DATA(IBREVC(I))
- QUIT
- SET IBCH=IBCH+($PIECE(IBREVC(I),U,4))
- SET IBUCH=IBUCH+$PIECE(IBREVC(I),U,9)
- +1 IF IB("U1")]""
- SET X=$PIECE(IB("U1"),"^",1)
- SET X1=$PIECE(IB("U1"),"^",2)
- SET IBCH=X
- +2 QUIT
- +3 ;
- OFFSET SET IBOFFC=""
- WRITE !?4,"OFFSET",?16,": "
- SET X=$SELECT(IB("U1")']"":0,1:+$PIECE(IB("U1"),U,2))
- SET X2="2$"
- if X
- SET IBOFFC=$PIECE(IB("U1"),U,3)
- DO COMMA^%DTC
- +1 WRITE X," [",$SELECT($LENGTH(IBOFFC):IBOFFC,'$PIECE(X,"$",2):"NO OFFSET RECORDED",1:"OFFSET DESCRIPTION UNSPECIFIED"),"]"
- +2 DO CHARGE
- WRITE !?4,"BILL TOTAL",?16,": "
- SET X=$SELECT('$DATA(IBCH):0,1:+IBCH)
- SET X2="2$"
- DO COMMA^%DTC
- WRITE X
- +3 KILL IBOFFC
- +4 QUIT
- +5 ;
- NAME(TYPE,ITEM) ; if rx or pros or DRG or unassociated return name of the item
- +1 NEW IBNAME
- SET IBNAME=""
- +2 IF $GET(TYPE)=3
- IF +$GET(ITEM)
- Begin DoDot:1
- +3 DO ZERO^IBRXUTL($PIECE($GET(^IBA(362.4,+ITEM,0)),U,4))
- +4 SET IBNAME=$GET(^TMP($JOB,"IBDRUG",+$PIECE($GET(^IBA(362.4,+ITEM,0)),U,4),.01))
- +5 KILL ^TMP($JOB,"IBDRUG")
- +6 QUIT
- End DoDot:1
- +7 IF $GET(TYPE)=5
- IF +$GET(ITEM)
- SET IBNAME=$PIECE($GET(^IBA(362.5,+ITEM,0)),U,5)
- +8 IF $GET(TYPE)=6
- IF +$GET(ITEM)
- SET IBNAME=$PIECE($$DRG^IBACSV(+ITEM),U,1)
- +9 IF $GET(TYPE)=9
- IF +$GET(ITEM)
- SET IBNAME=$PIECE($GET(^IBA(363.21,+ITEM,0)),U,1)
- +10 QUIT IBNAME
- +11 ;IBCSC61