IBCF11 ;ALB/MJB - PRINT UB-82 BILL (CONT.) ;25 JAN 89 12:54
;;2.0;INTEGRATED BILLING;**133,210**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;MAP TO DGCRP1
;
Q
13 ;I $D(IBIP),$D(IBPR) W !!,$S($P(IB(0),"^",9)]"":$P(IB(0),"^",9),1:9)
W !!,$P(IB(0),"^",9)
;I '$D(IBCPT),'$D(IBICD),'$D(IBHC) G 14
;G:$D(IBCPT) CPT G:$D(IBICD) ICD G:$D(IBHC) HCFA
CPT ;W !!,"4"
;S I=0 F Z=1:1 S I=$O(IBCPT(I)) Q:'I S X=$S($D(IB("C")):$E($P(IB("C"),U,(I+10)),4,7),1:"") S IBCPTN=$P(^ICPT(IBCPT(I),0),"^") W:Z=1 ?3,$P(^(0),"^",2),?43,IBCPTN,?49,X W:Z=2 ?54,IBCPTN,?60,X W:Z=3 ?65,IBCPTN,?71,X
;G 14
ICD ;W !!,"9"
;F I=4:1:6 I $D(IBICD(I)) S X=$E($P(IB("C"),U,(I+7)),4,5)_$E($P(IB("C"),U,(I+7)),6,7),Y=$S($D(^ICD0(IBICD(I),0)):^(0),1:"") W:I=4 ?3,$P(^ICD0(IBICD(I),0),U,4),?43,$P(Y,U,1),?49,X W:I=5 ?54,$P(Y,U,1),?60,X W:I=6 ?65,$P(Y,U,1),?71,X
;G 14
HCFA ;W !!,"5"
;F I=7:1:9 I $D(IBHC(I)) S X=$E($P(IB("C"),U,(I+4)),4,5)_$E($P(IB("C"),U,(I+4)),6,7) W:I=7 ?3,$P(^ICPT(IBHC(I),0),"^",2),?43,IBHCN(I),?49,X W:I=8 ?54,IBHCN(I),?60,X W:I=9 ?65,IBHCN(I),?71,X
D PROC
14 F I=1:1 Q:$Y>55 W !
W ! W:$P(IB("U"),U,13)]"" ?22,$P(IB("U"),U,13) W ?33,$S($P(IB("U1"),U,13)="":"Dept. Veterans Affairs",1:$P(IB("U1"),U,13)),?56,$P(IB("U1"),U,14)
S IBRATY=$P(^DGCR(399,IBIFN,0),U,7),IBRATY=$P(^DGCR(399.3,IBRATY,0),U,2)
15 W !!,"Patient ID: ",$P(VADM(2),"^"),!,"Bill Type: ",$S(IBRATY]"":IBRATY,1:"UNSPECIFIED")
I $D(IBEPAR(1)),$P(IBEPAR(1),U,4)'="" W !,$P(IBEPAR(1),U,4)
I IB("U1")]"",$P(IB("U1"),"^",8)]"" W !,"**",$P(IB("U1"),"^",8),"**"
16 F I=1:1 Q:$Y>61 W !
I $D(IBEPAR(1)),$P(IBEPAR(1),U,1)'="" W ?46,$P(IBEPAR(1),U,1) W:$P(IBEPAR(1),U,2)'="" !,?46,$P(IBEPAR(1),U,2)
S IBXDT=$S(IBPNT:DT,$P(IB("S"),U,12)]"":$P(IB("S"),U,12),1:DT) W ?69,$E(IBXDT,4,5)_"-"_$E(IBXDT,6,7)_"-"_$E(IBXDT,2,3)
W ! S (DIC,DIE)=399,IBYY=$S($P(^DGCR(399,IBIFN,"S"),"^",12)="":"@92",1:"@94"),DA=IBIFN,DR="[IB STATUS]" D ^DIE K DIC,DIE,IBYY
D BSTAT^IBCDC(IBIFN) ; remove from auto biller list
K IBXDT,IBMA
Q
;
PROC ; -print first 3-5 procedure codes
S TAB=43
S J=0 F I=1:1 S J=$O(IBPROC(J)) Q:'J!(I>3) D
. I IBPROC(J)["ICD" S X=$$ICD0^IBACSV(+IBPROC(J),+$P(IBPROC(J),U,2))
. I IBPROC(J)["ICPT" S X=$$CPT^IBACSV(+IBPROC(J),+$P(IBPROC(J),U,2))
. S Y=$E($P(IBPROC(J),U,2),4,7)
. ;
. I I=1 W ?3,$E($P(X,U,$S(IBPROC(J)["ICD":4,1:2)),1,30)
. W ?(TAB+(I-1*11)),$P(X,U),?(TAB+6+(I-1*11)),Y
Q
;IBCF11
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCF11 2451 printed Oct 16, 2024@18:13:26 Page 2
IBCF11 ;ALB/MJB - PRINT UB-82 BILL (CONT.) ;25 JAN 89 12:54
+1 ;;2.0;INTEGRATED BILLING;**133,210**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRP1
+5 ;
+6 QUIT
13 ;I $D(IBIP),$D(IBPR) W !!,$S($P(IB(0),"^",9)]"":$P(IB(0),"^",9),1:9)
+1 WRITE !!,$PIECE(IB(0),"^",9)
+2 ;I '$D(IBCPT),'$D(IBICD),'$D(IBHC) G 14
+3 ;G:$D(IBCPT) CPT G:$D(IBICD) ICD G:$D(IBHC) HCFA
CPT ;W !!,"4"
+1 ;S I=0 F Z=1:1 S I=$O(IBCPT(I)) Q:'I S X=$S($D(IB("C")):$E($P(IB("C"),U,(I+10)),4,7),1:"") S IBCPTN=$P(^ICPT(IBCPT(I),0),"^") W:Z=1 ?3,$P(^(0),"^",2),?43,IBCPTN,?49,X W:Z=2 ?54,IBCPTN,?60,X W:Z=3 ?65,IBCPTN,?71,X
+2 ;G 14
ICD ;W !!,"9"
+1 ;F I=4:1:6 I $D(IBICD(I)) S X=$E($P(IB("C"),U,(I+7)),4,5)_$E($P(IB("C"),U,(I+7)),6,7),Y=$S($D(^ICD0(IBICD(I),0)):^(0),1:"") W:I=4 ?3,$P(^ICD0(IBICD(I),0),U,4),?43,$P(Y,U,1),?49,X W:I=5 ?54,$P(Y,U,1),?60,X W:I=6 ?65,$P(Y,U,1),?71,X
+2 ;G 14
HCFA ;W !!,"5"
+1 ;F I=7:1:9 I $D(IBHC(I)) S X=$E($P(IB("C"),U,(I+4)),4,5)_$E($P(IB("C"),U,(I+4)),6,7) W:I=7 ?3,$P(^ICPT(IBHC(I),0),"^",2),?43,IBHCN(I),?49,X W:I=8 ?54,IBHCN(I),?60,X W:I=9 ?65,IBHCN(I),?71,X
+2 DO PROC
14 FOR I=1:1
if $Y>55
QUIT
WRITE !
+1 WRITE !
if $PIECE(IB("U"),U,13)]""
WRITE ?22,$PIECE(IB("U"),U,13)
WRITE ?33,$SELECT($PIECE(IB("U1"),U,13)="":"Dept. Veterans Affairs",1:$PIECE(IB("U1"),U,13)),?56,$PIECE(IB("U1"),U,14)
+2 SET IBRATY=$PIECE(^DGCR(399,IBIFN,0),U,7)
SET IBRATY=$PIECE(^DGCR(399.3,IBRATY,0),U,2)
15 WRITE !!,"Patient ID: ",$PIECE(VADM(2),"^"),!,"Bill Type: ",$SELECT(IBRATY]"":IBRATY,1:"UNSPECIFIED")
+1 IF $DATA(IBEPAR(1))
IF $PIECE(IBEPAR(1),U,4)'=""
WRITE !,$PIECE(IBEPAR(1),U,4)
+2 IF IB("U1")]""
IF $PIECE(IB("U1"),"^",8)]""
WRITE !,"**",$PIECE(IB("U1"),"^",8),"**"
16 FOR I=1:1
if $Y>61
QUIT
WRITE !
+1 IF $DATA(IBEPAR(1))
IF $PIECE(IBEPAR(1),U,1)'=""
WRITE ?46,$PIECE(IBEPAR(1),U,1)
if $PIECE(IBEPAR(1),U,2)'=""
WRITE !,?46,$PIECE(IBEPAR(1),U,2)
+2 SET IBXDT=$SELECT(IBPNT:DT,$PIECE(IB("S"),U,12)]"":$PIECE(IB("S"),U,12),1:DT)
WRITE ?69,$EXTRACT(IBXDT,4,5)_"-"_$EXTRACT(IBXDT,6,7)_"-"_$EXTRACT(IBXDT,2,3)
+3 WRITE !
SET (DIC,DIE)=399
SET IBYY=$SELECT($PIECE(^DGCR(399,IBIFN,"S"),"^",12)="":"@92",1:"@94")
SET DA=IBIFN
SET DR="[IB STATUS]"
DO ^DIE
KILL DIC,DIE,IBYY
+4 ; remove from auto biller list
DO BSTAT^IBCDC(IBIFN)
+5 KILL IBXDT,IBMA
+6 QUIT
+7 ;
PROC ; -print first 3-5 procedure codes
+1 SET TAB=43
+2 SET J=0
FOR I=1:1
SET J=$ORDER(IBPROC(J))
if 'J!(I>3)
QUIT
Begin DoDot:1
+3 IF IBPROC(J)["ICD"
SET X=$$ICD0^IBACSV(+IBPROC(J),+$PIECE(IBPROC(J),U,2))
+4 IF IBPROC(J)["ICPT"
SET X=$$CPT^IBACSV(+IBPROC(J),+$PIECE(IBPROC(J),U,2))
+5 SET Y=$EXTRACT($PIECE(IBPROC(J),U,2),4,7)
+6 ;
+7 IF I=1
WRITE ?3,$EXTRACT($PIECE(X,U,$SELECT(IBPROC(J)["ICD":4,1:2)),1,30)
+8 WRITE ?(TAB+(I-1*11)),$PIECE(X,U),?(TAB+6+(I-1*11)),Y
End DoDot:1
+9 QUIT
+10 ;IBCF11
