IBCF10 ;ALB/MJB - PRINT UB-82 BILL (CONT.) ;13 JUN 88 12:39
;;2.0;INTEGRATED BILLING;**133,210**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;MAP TO DGCRP0
;
Q
7 W ! I IB("M")]"",$P(IB("M"),"^",4)]"" S IBMA=IB("M"),IBPST=$S($P(IBMA,U,8)']"":"",$D(^DIC(5,+$P(IBMA,U,8),0)):$P(^(0),U,2),1:"")
I $D(IBMA),IBMA'="" W $P(IBMA,"^",4),! W:$P(IBMA,"^",5)]"" $P(IBMA,"^",5) W:$D(IBCC(1)) ?30,IBCC(1) W:$D(IBCC(2)) ?33,IBCC(2) W:$D(IBCC(3)) ?36,IBCC(3) W:$D(IBCC(4)) ?39,IBCC(4) W:$D(IBCC(5)) ?42,IBCC(5)
W:$P(IB("U1"),U,7)]"" ?61,$P(IB("U1"),U,7) I $D(IBMA) W:$P(IBMA,"^",6)]"" !,$P(IBMA,"^",6) W:$P(IB("M1"),"^",1)]"" !,$P(IB("M1"),"^",1) W !,$P(IBMA,"^",7),?$X+2,IBPST,?$X+2,$P(IBMA,"^",9)
8 F I=1:1 Q:$Y>15 W !
D NWREVC
I DGPAG'=DGTOTPAG W " (page ",DGPAG," of ",DGTOTPAG,")"
F I=1:1 Q:$Y>29 W !
K IB01 D Q1^IBCVA,Q4^IBCVA,EN3^IBCVA0
9 F I=1:1 Q:$Y>39 W !
;PAYER
W ! I '$D(^DGCR(399,IBIFN,"AIC")),$P(IB(0),"^",7),$P(^DGCR(399.3,$P(IB(0),"^",7),0),"^")["ESRD" W "MEDICARE ESRD"
I '$D(^DGCR(399,IBIFN,"AIC")) W ?24,$S($P(IB("U"),U,5)=0:"Y",1:"R"),?27,$S($P(IB("U"),U,6)["N":"N",$P(IB("U"),U,6)["n":"N",$P(IB("U"),U,6)=0:"N",1:"Y") D Q3^IBCVA,EN2^IBCVA0 G 11
I $D(IBDD) F I=1:1 S IBIN=$O(IBDD(I)) Q:'$D(IBDD(I,0)) S X=$P($G(^DIC(36,($P(IBDD(I,0),U,1)),0)),U,1),M=$P(IB("U"),U,6) W !,$E(X,1,23),?24,$S($P(IB("U"),U,5)=0:"Y",1:"R"),?27,$S(M["N":"N",M["n":"N",M=0:"N",1:"Y")
10 F I=1:1 Q:$Y>44 W !
;INSURED
I $D(IBDD) F I=1:1 S IBIN=$O(IBDD(I)) Q:'$D(IBDD(I,0)) W !,$P(IBDD(I,0),U,17),?23,$E(IBISEX(I),1),?26,IBIRN(I),?29,$P(IBDD(I,0),U,2),?46,$E($P(IBDD(I,0),U,15),1,14),?61,$P(IBDD(I,0),U,3)
D Q3^IBCVA,EN2^IBCVA0
11 I '$D(^DGCR(399,IBIFN,"AIC")),$P(IB(0),"^",7),$P(^DGCR(399.3,$P(IB(0),"^",7),0),"^")["ESRD" X "F I=1:1 Q:$Y>44 W !" W !,VADM(1),?23,$P(VADM(5),"^"),?26,"01",?29,$P(VADM(2),"^")
F I=1:1 Q:$Y>49 W !
;EMPLOYMENT INFO
S IBROI="" I $D(^DGCR(399,IBIFN,"I1")) S IBROI=$P(^("I1"),U,6)
I IBROI="s" W "S" I $D(^DPT(DFN,.25)) S IBSPEM=^(.25) W " 9",?4,$P(IBSPEM,U),?42,$P(IBSPEM,U,5),?$X+2,$S($P(IBSPEM,U,6)'="":$P(^DIC(5,$P(IBSPEM,U,6),0),U,2),1:""),?$X+2,$P(IBSPEM,U,7) K IBSPEM
I IBROI="v" W "P" I $D(IBEMPD),IBEMPD]"" W ?2,$S('$D(IBEC):9,IBEC:IBEC,1:9),?4,$P(IBEMPD,U),?42,$P(IBEMPD,U,2),?$X+2,$S($P(IBEMPD,U,7)'="":$P(^DIC(5,$P(IBEMPD,U,7),0),U,2),1:""),?$X+2,$P(IBEMPD,U,8)
K IBROI
D Q2^IBCVA,EN4^IBCVA1,EN5^IBCVA1
12 F I=1:1 Q:$Y>52 W !
;I IB("C")]"" W:$P(IB("C"),U,14)'="" $P(^ICD9($P(IB("C"),U,14),0),U,3) K X2 S X=$P(IB("C"),U,14) D ICW W ?44,X S X2=44 F I=15:1:18 Q:'$D(IBDIN(I)) S X=IBDIN(I) D ICW W ?X2,X
N IBINDXX,IBEVDT
D SET^IBCSC4D(IBIFN,"",.IBINDXX) I $D(IBINDXX)>2 D
. S IBEVDT=$$BDATE^IBACSV(IBIFN) ; Event Date
. S I=$O(IBINDXX(0)) Q:'I
. W $P($$ICD9^IBACSV(+IBINDXX(I),IBEVDT),U,3)
. S X2=37,I=0 F S I=$O(IBINDXX(I)) Q:'I S X=IBINDXX(I) D ICW W ?X2,X
D 13^IBCF11
Q
ICW S X=$P($$ICD9^IBACSV(+X),U) S:$D(X2) X2=X2+7
Q
NWREVC ;print for mult bedsections/rev codes
F I=0:0 S DGCNT=$O(^UTILITY($J,"IB-RC",DGCNT)) Q:'DGCNT!(DGCNT>(DGPAG*23)) S DGTEXT=^(DGCNT) D NWREVC1
S DGCNT=DGCNT-1
Q
NWREVC1 ;
I DGTEXT="" W ! Q
I $P(DGTEXT,"^",5,99)]"" X $P(DGTEXT,"^",5,99) Q
I $P(DGTEXT,"^")]"" W !,$P(DGTEXT,"^") Q
I $P(DGTEXT,"^",4)="C" W ! S:$L($P(DGTEXT,"^",3)) DGTEXT1=$P(DGTEXT,"^",2) W:$L(DGTEXT1) +$E(DGTEXT1,4,5)_"/"_+$E(DGTEXT1,6,7)_"/"_$E(DGTEXT1,2,3) D ADDCOD Q
I $P(DGTEXT,"^",2),$D(^DGCR(399,IBIFN,"RC",$P(DGTEXT,"^",2),0)) S DGREVC=^(0) D NWREVC2 Q
Q
NWREVC2 W !,$E($P(^DGCR(399.2,+DGREVC,0),"^",2),1,22),?22,$J($P(DGREVC,"^",2),7,2),?31,$P(^(0),"^"),?35,$J($P(DGREVC,"^",3),3),?39,$J($P(DGREVC,"^",4),9,2)
Q
ADDCOD ;Additional Procedures Print
Q:'$P(DGTEXT,U,3) S IBCPT=""
I DGTEXT["ICD" S IBCPT=$$ICD0^IBACSV(+$P(DGTEXT,U,3),$G(DGTEXT1))
I DGTEXT["ICPT" S IBCPT=$$CPT^IBACSV(+$P(DGTEXT,U,3),$G(DGTEXT1))
W ?11,$P(IBCPT,U)
Q
;IBCF10
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCF10 3919 printed Apr 09, 2024@21:07:23 Page 2
IBCF10 ;ALB/MJB - PRINT UB-82 BILL (CONT.) ;13 JUN 88 12:39
+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 DGCRP0
+5 ;
+6 QUIT
7 WRITE !
IF IB("M")]""
IF $PIECE(IB("M"),"^",4)]""
SET IBMA=IB("M")
SET IBPST=$SELECT($PIECE(IBMA,U,8)']"":"",$DATA(^DIC(5,+$PIECE(IBMA,U,8),0)):$PIECE(^(0),U,2),1:"")
+1 IF $DATA(IBMA)
IF IBMA'=""
WRITE $PIECE(IBMA,"^",4),!
if $PIECE(IBMA,"^",5)]""
WRITE $PIECE(IBMA,"^",5)
if $DATA(IBCC(1))
WRITE ?30,IBCC(1)
if $DATA(IBCC(2))
WRITE ?33,IBCC(2)
if $DATA(IBCC(3))
WRITE ?36,IBCC(3)
if $DATA(IBCC(4))
WRITE ?39,IBCC(4)
if $DATA(IBCC(5))
WRITE ?42,IBCC(5)
+2 if $PIECE(IB("U1"),U,7)]""
WRITE ?61,$PIECE(IB("U1"),U,7)
IF $DATA(IBMA)
if $PIECE(IBMA,"^",6)]""
WRITE !,$PIECE(IBMA,"^",6)
if $PIECE(IB("M1"),"^",1)]""
WRITE !,$PIECE(IB("M1"),"^",1)
WRITE !,$PIECE(IBMA,"^",7),?$X+2,IBPST,?$X+2,$PIECE(IBMA,"^",9)
8 FOR I=1:1
if $Y>15
QUIT
WRITE !
+1 DO NWREVC
+2 IF DGPAG'=DGTOTPAG
WRITE " (page ",DGPAG," of ",DGTOTPAG,")"
+3 FOR I=1:1
if $Y>29
QUIT
WRITE !
+4 KILL IB01
DO Q1^IBCVA
DO Q4^IBCVA
DO EN3^IBCVA0
9 FOR I=1:1
if $Y>39
QUIT
WRITE !
+1 ;PAYER
+2 WRITE !
IF '$DATA(^DGCR(399,IBIFN,"AIC"))
IF $PIECE(IB(0),"^",7)
IF $PIECE(^DGCR(399.3,$PIECE(IB(0),"^",7),0),"^")["ESRD"
WRITE "MEDICARE ESRD"
+3 IF '$DATA(^DGCR(399,IBIFN,"AIC"))
WRITE ?24,$SELECT($PIECE(IB("U"),U,5)=0:"Y",1:"R"),?27,$SELECT($PIECE(IB("U"),U,6)["N":"N",$PIECE(IB("U"),U,6)["n":"N",$PIECE(IB("U"),U,6)=0:"N",1:"Y")
DO Q3^IBCVA
DO EN2^IBCVA0
GOTO 11
+4 IF $DATA(IBDD)
FOR I=1:1
SET IBIN=$ORDER(IBDD(I))
if '$DATA(IBDD(I,0))
QUIT
SET X=$PIECE($GET(^DIC(36,($PIECE(IBDD(I,0),U,1)),0)),U,1)
SET M=$PIECE(IB("U"),U,6)
WRITE !,$EXTRACT(X,1,23),?24,$SELECT($PIECE(IB("U"),U,5)=0:"Y",1:"R"),?27,$SELECT(M["N":"N",M["n":"N",M=0:"N",1:"Y")
10 FOR I=1:1
if $Y>44
QUIT
WRITE !
+1 ;INSURED
+2 IF $DATA(IBDD)
FOR I=1:1
SET IBIN=$ORDER(IBDD(I))
if '$DATA(IBDD(I,0))
QUIT
WRITE !,$PIECE(IBDD(I,0),U,17),?23,$EXTRACT(IBISEX(I),1),?26,IBIRN(I),?29,$PIECE(IBDD(I,0),U,2),?46,$EXTRACT($PIECE(IBDD(I,0),U,15),1,14),?61,$PIECE(IBDD(I,0),U,3)
+3 DO Q3^IBCVA
DO EN2^IBCVA0
11 IF '$DATA(^DGCR(399,IBIFN,"AIC"))
IF $PIECE(IB(0),"^",7)
IF $PIECE(^DGCR(399.3,$PIECE(IB(0),"^",7),0),"^")["ESRD"
XECUTE "F I=1:1 Q:$Y>44 W !"
WRITE !,VADM(1),?23,$PIECE(VADM(5),"^"),?26,"01",?29,$PIECE(VADM(2),"^")
+1 FOR I=1:1
if $Y>49
QUIT
WRITE !
+2 ;EMPLOYMENT INFO
+3 SET IBROI=""
IF $DATA(^DGCR(399,IBIFN,"I1"))
SET IBROI=$PIECE(^("I1"),U,6)
+4 IF IBROI="s"
WRITE "S"
IF $DATA(^DPT(DFN,.25))
SET IBSPEM=^(.25)
WRITE " 9",?4,$PIECE(IBSPEM,U),?42,$PIECE(IBSPEM,U,5),?$X+2,$SELECT($PIECE(IBSPEM,U,6)'="":$PIECE(^DIC(5,$PIECE(IBSPEM,U,6),0),U,2),1:""),?$X+2,$PIECE(IBSPEM,U,7)
KILL IBSPEM
+5 IF IBROI="v"
WRITE "P"
IF $DATA(IBEMPD)
IF IBEMPD]""
WRITE ?2,$SELECT('$DATA(IBEC):9,IBEC:IBEC,1:9),?4,$PIECE(IBEMPD,U),?42,$PIECE(IBEMPD,U,2),?$X+2,$SELECT($PIECE(IBEMPD,U,7)'="":$PIECE(^DIC(5,$PIECE(IBEMPD,U,7),0),U,2),1:""),?$X+2,$PIECE(IBEMPD,U,8)
+6 KILL IBROI
+7 DO Q2^IBCVA
DO EN4^IBCVA1
DO EN5^IBCVA1
12 FOR I=1:1
if $Y>52
QUIT
WRITE !
+1 ;I IB("C")]"" W:$P(IB("C"),U,14)'="" $P(^ICD9($P(IB("C"),U,14),0),U,3) K X2 S X=$P(IB("C"),U,14) D ICW W ?44,X S X2=44 F I=15:1:18 Q:'$D(IBDIN(I)) S X=IBDIN(I) D ICW W ?X2,X
+2 NEW IBINDXX,IBEVDT
+3 DO SET^IBCSC4D(IBIFN,"",.IBINDXX)
IF $DATA(IBINDXX)>2
Begin DoDot:1
+4 ; Event Date
SET IBEVDT=$$BDATE^IBACSV(IBIFN)
+5 SET I=$ORDER(IBINDXX(0))
if 'I
QUIT
+6 WRITE $PIECE($$ICD9^IBACSV(+IBINDXX(I),IBEVDT),U,3)
+7 SET X2=37
SET I=0
FOR
SET I=$ORDER(IBINDXX(I))
if 'I
QUIT
SET X=IBINDXX(I)
DO ICW
WRITE ?X2,X
End DoDot:1
+8 DO 13^IBCF11
+9 QUIT
ICW SET X=$PIECE($$ICD9^IBACSV(+X),U)
if $DATA(X2)
SET X2=X2+7
+1 QUIT
NWREVC ;print for mult bedsections/rev codes
+1 FOR I=0:0
SET DGCNT=$ORDER(^UTILITY($JOB,"IB-RC",DGCNT))
if 'DGCNT!(DGCNT>(DGPAG*23))
QUIT
SET DGTEXT=^(DGCNT)
DO NWREVC1
+2 SET DGCNT=DGCNT-1
+3 QUIT
NWREVC1 ;
+1 IF DGTEXT=""
WRITE !
QUIT
+2 IF $PIECE(DGTEXT,"^",5,99)]""
XECUTE $PIECE(DGTEXT,"^",5,99)
QUIT
+3 IF $PIECE(DGTEXT,"^")]""
WRITE !,$PIECE(DGTEXT,"^")
QUIT
+4 IF $PIECE(DGTEXT,"^",4)="C"
WRITE !
if $LENGTH($PIECE(DGTEXT,"^",3))
SET DGTEXT1=$PIECE(DGTEXT,"^",2)
if $LENGTH(DGTEXT1)
WRITE +$EXTRACT(DGTEXT1,4,5)_"/"_+$EXTRACT(DGTEXT1,6,7)_"/"_$EXTRACT(DGTEXT1,2,3)
DO ADDCOD
QUIT
+5 IF $PIECE(DGTEXT,"^",2)
IF $DATA(^DGCR(399,IBIFN,"RC",$PIECE(DGTEXT,"^",2),0))
SET DGREVC=^(0)
DO NWREVC2
QUIT
+6 QUIT
NWREVC2 WRITE !,$EXTRACT($PIECE(^DGCR(399.2,+DGREVC,0),"^",2),1,22),?22,$JUSTIFY($PIECE(DGREVC,"^",2),7,2),?31,$PIECE(^(0),"^"),?35,$JUSTIFY($PIECE(DGREVC,"^",3),3),?39,$JUSTIFY($PIECE(DGREVC,"^",4),9,2)
+1 QUIT
ADDCOD ;Additional Procedures Print
+1 if '$PIECE(DGTEXT,U,3)
QUIT
SET IBCPT=""
+2 IF DGTEXT["ICD"
SET IBCPT=$$ICD0^IBACSV(+$PIECE(DGTEXT,U,3),$GET(DGTEXT1))
+3 IF DGTEXT["ICPT"
SET IBCPT=$$CPT^IBACSV(+$PIECE(DGTEXT,U,3),$GET(DGTEXT1))
+4 WRITE ?11,$PIECE(IBCPT,U)
+5 QUIT
+6 ;IBCF10
