IBCF10.m

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 ---IBCF10   3919     printed  Feb 18, 2025@23:39:09                                                                                                                                                                                                      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