Routine: IBCF11

IBCF11	;ALB/MJB - PRINT UB-82 BILL (CONT.)  ;25 JAN 89 12:54

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;;Per VHA Directive 10-93-142, this routine should not be modified.

	;MAP TO DGCRP1

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

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)  S X=$G(@(U_$P($P(IBPROC(J),"^"),";",2)_+IBPROC(J)_",0)")),Y=$E($P(IBPROC(J),"^",2),4,7) D

	.I I=1 W ?3,$S(IBPROC(J)["ICD":$E($P(X,"^",4),1,30),1:$E($P(X,"^",2),1,30))

	.W ?(TAB+(I-1*11)),$P(X,"^"),?(TAB+6+(I-1*11)),Y

	;IBCF11

IBCF11    ;ALB/MJB - PRINT UB-82 BILL (CONT.)  ;25 JAN 89 12:54

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 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

               SET X=$GET(@(U_$PIECE($PIECE(IBPROC(J),"^"),";",2)_+IBPROC(J)_",0)"))

               SET Y=$EXTRACT($PIECE(IBPROC(J),"^",2),4,7)

               Begin DoDot:1

 +3                IF I=1

                       WRITE ?3,$SELECT(IBPROC(J)["ICD":$EXTRACT($PIECE(X,"^",4),1,30),1:$EXTRACT($PIECE(X,"^",2),1,30))

 +4                WRITE ?(TAB+(I-1*11)),$PIECE(X,"^"),?(TAB+6+(I-1*11)),Y

               End DoDot:1

 +5        QUIT

 +6       ;IBCF11

IBCF11.m