Routine: IBCF11

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

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)  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

 ;IBCF11

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCF11   2451     printed  Mar 13, 2025@21:17:35                                                                                                                                                                                                      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

IBCF11.m