- IBCF1 ;ALB/MJB/AAS - PRINT UB-82 BILL ;10 JUN 88 14:42
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;MAP TO DGCRP
- ;
- ZIS Q:'$D(IBAC) S:'$D(IBPNT) IBPNT=0
- ;S DGPGM="ENP^IBCF1",DGVAR="DFN^IBCIFN^IBC^IBEPAR^IBCDPT^IBCU^IBPNT" D ZIS^DGUTQ I POP G Q
- ;
- DEV S %ZIS="Q",%ZIS("A")="Output Device: "
- S %ZIS("B")=$P($G(^IBE(353,+$P($G(^DGCR(399,IBIFN,0)),"^",19),0)),"^",2)
- D ^%ZIS G:POP Q
- I $D(IO("Q")) S ZTRTN="ENP^IBCF1",ZTDESC="PRINT BILL",ZTSAVE("IB*")="",ZTSAVE("DG*")="",ZTSAVE("DFN")="" D ^%ZTLOAD K IO("Q") D HOME^%ZIS G Q
- ;
- U IO D ENP
- Q S IBKILL=1 D Q5^IBCVA
- D:'$D(ZTQUEUED) ^%ZISC
- K IBKILL Q
- ;
- Q1 K DFN,IBIFN Q
- ENP Q:'$D(DFN) D SET D:$D(IBIFN) ALL^IBCVA0 D EN1^IBCVA0,EN4^IBCVA1,EN5^IBCVA1,^IBCF12
- EN2 W @IOF I IB("I1")]"",$P(IB("I1"),U,1)]"",$P($G(^DIC(36,$P(IB("I1"),U,1),0)),U,3)=1 W "##SR"
- W ?24,$S(IBPNT=1:"",IBPNT=0:"*** COPY OF ORIGINAL BILL ***",IBPNT=2:"*** SECOND NOTICE ***",IBPNT=3:"*** THIRD NOTICE ***",1:"")
- ;
- 1 F I=1,2 W !,$S(IBEPAR(2)]"":$P(IBEPAR(2),U,I),1:"")
- W ?24,$P(IB("U1"),U,4),?57,IBBNO,?74,IBBT
- 2 I IBEPAR(2)]"" W !,$P(IBEPAR(2),U,3) S IBOPST=$P(IBEPAR(2),U,4),IBOPST=$P(^DIC(5,IBOPST,0),"^",2) W ?$X+2,IBOPST,?$X+2,$P(IBEPAR(2),U,5)
- 3 W !,$S(IBEPAR(2)]"":$P(IBEPAR(2),U,6),1:"")
- S X=$P(IBEPAR(1),"^",6) W ?24,$S($P(IB("U"),U,14)]"":$P(IB("U"),U,14),1:X),?38,$P(IBEPAR(1),U,5),?50,$P(IBEPAR(1),"^",21),?71,$P(IB("U1"),U,5)
- 4 W !!,VADM(1),?33,$S(IB("M")']"":"",$P(IB("M"),U,10)]"":$P(IB("M"),U,10),1:"")
- 5 W !!,$E($P(VADM(3),U),4,7)_$E($P(VADM(3),U),2,3),?8,$P(VADM(5),U),?10 S Y=$P(IBDPT(0),U,5) W $S(Y=1:"D",Y=2:"M",Y=4:"W",Y=5:"X",Y=6:"S",1:"U")
- W:$D(IBIP) ?14,$S($P(IBIP,U,2)'="":$E($P(IBIP,U,2),4,7)_$E($P(IBIP,U,2),2,3),1:$E(IBDT,4,7)_$E(IBDT,2,3)),?21,$S($E($P($P(IBIP,U,2),".",2),1,2)'="":$E($P($P(IBIP,U,2),".",2),1,2),1:"99")
- W:$D(IBIP) ?24,$S($P(IBIP,U,5)'="":$P(IBIP,U,5),1:9),?27,$S($P(IBIP,U,4)'="":$P(IBIP,U,4),1:9),?29,$S($P(IBIP,U,3)'="":$P(IBIP,U,3),1:"99")
- I $D(IBIP) W ?32,$S($P(IBIP,U,6)']"":"99",1:$E($P($P(IBIP,U,6),".",2),1,2)) S X=$P(IBIP,U,7) W ?36,$S($D(^DGCR(399.1,+X,0)):$P(^(0),"^",2),1:"")
- I '$D(IBIP) W ?14,$E(IBDT,4,7)_$E(IBDT,2,3),?21,"99"
- W ?40,$E($P(IB("U"),"^"),4,7)_$E($P(IB("U"),"^"),2,3),?48,$E($P(IB("U"),"^",2),4,7)_$E($P(IB("U"),"^",2),2,3),?70,$P(IB("U1"),U,6),!!
- 6 I $D(IBO(1)) W IBO(1),?3,$E(IBOCD(1),4,7)_$E(IBOCD(1),2,3) I $D(IBO(2)) W ?11,IBO(2),?14,$E(IBOCD(2),4,7)_$E(IBOCD(2),2,3) I $D(IBO(3)) W ?22,IBO(3),?25,$E(IBOCD(3),4,7)_$E(IBOCD(3),2,3)
- I $D(IBO(4)) W ?35,IBO(4),?38,$E(IBOCD(4),4,7)_$E(IBOCD(4),2,3) I $D(IBO(5)) W ?46,IBO(5),?49,$E(IBOCD(5),4,7)_$E(IBOCD(5),2,3)
- D 7^IBCF10 I DGPAG<DGTOTPAG S DGPAG=DGPAG+1 G EN2
- Q
- SET ;Set Variables
- D 2^VADPT F I=0,.11,.121,.25,.311,.36 S IBDPT(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
- F I=0,"C","I1","I2","I3","M","M1","S","U","U1" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"")
- F I=0,1,2 S IBEPAR(I)=$G(^IBE(350.9,1,I))
- S IBBT=$P(IB(0),"^",4)_$P(IB(0),"^",5)_$P(IB(0),"^",6)
- S IBU="UNSPECIFIED" Q
- ;IBCF1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCF1 3073 printed Feb 18, 2025@23:39:08 Page 2
- IBCF1 ;ALB/MJB/AAS - PRINT UB-82 BILL ;10 JUN 88 14:42
- +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 DGCRP
- +5 ;
- ZIS if '$DATA(IBAC)
- QUIT
- if '$DATA(IBPNT)
- SET IBPNT=0
- +1 ;S DGPGM="ENP^IBCF1",DGVAR="DFN^IBCIFN^IBC^IBEPAR^IBCDPT^IBCU^IBPNT" D ZIS^DGUTQ I POP G Q
- +2 ;
- DEV SET %ZIS="Q"
- SET %ZIS("A")="Output Device: "
- +1 SET %ZIS("B")=$PIECE($GET(^IBE(353,+$PIECE($GET(^DGCR(399,IBIFN,0)),"^",19),0)),"^",2)
- +2 DO ^%ZIS
- if POP
- GOTO Q
- +3 IF $DATA(IO("Q"))
- SET ZTRTN="ENP^IBCF1"
- SET ZTDESC="PRINT BILL"
- SET ZTSAVE("IB*")=""
- SET ZTSAVE("DG*")=""
- SET ZTSAVE("DFN")=""
- DO ^%ZTLOAD
- KILL IO("Q")
- DO HOME^%ZIS
- GOTO Q
- +4 ;
- +5 USE IO
- DO ENP
- Q SET IBKILL=1
- DO Q5^IBCVA
- +1 if '$DATA(ZTQUEUED)
- DO ^%ZISC
- +2 KILL IBKILL
- QUIT
- +3 ;
- Q1 KILL DFN,IBIFN
- QUIT
- ENP if '$DATA(DFN)
- QUIT
- DO SET
- if $DATA(IBIFN)
- DO ALL^IBCVA0
- DO EN1^IBCVA0
- DO EN4^IBCVA1
- DO EN5^IBCVA1
- DO ^IBCF12
- EN2 WRITE @IOF
- IF IB("I1")]""
- IF $PIECE(IB("I1"),U,1)]""
- IF $PIECE($GET(^DIC(36,$PIECE(IB("I1"),U,1),0)),U,3)=1
- WRITE "##SR"
- +1 WRITE ?24,$SELECT(IBPNT=1:"",IBPNT=0:"*** COPY OF ORIGINAL BILL ***",IBPNT=2:"*** SECOND NOTICE ***",IBPNT=3:"*** THIRD NOTICE ***",1:"")
- +2 ;
- 1 FOR I=1,2
- WRITE !,$SELECT(IBEPAR(2)]"":$PIECE(IBEPAR(2),U,I),1:"")
- +1 WRITE ?24,$PIECE(IB("U1"),U,4),?57,IBBNO,?74,IBBT
- 2 IF IBEPAR(2)]""
- WRITE !,$PIECE(IBEPAR(2),U,3)
- SET IBOPST=$PIECE(IBEPAR(2),U,4)
- SET IBOPST=$PIECE(^DIC(5,IBOPST,0),"^",2)
- WRITE ?$X+2,IBOPST,?$X+2,$PIECE(IBEPAR(2),U,5)
- 3 WRITE !,$SELECT(IBEPAR(2)]"":$PIECE(IBEPAR(2),U,6),1:"")
- +1 SET X=$PIECE(IBEPAR(1),"^",6)
- WRITE ?24,$SELECT($PIECE(IB("U"),U,14)]"":$PIECE(IB("U"),U,14),1:X),?38,$PIECE(IBEPAR(1),U,5),?50,$PIECE(IBEPAR(1),"^",21),?71,$PIECE(IB("U1"),U,5)
- 4 WRITE !!,VADM(1),?33,$SELECT(IB("M")']"":"",$PIECE(IB("M"),U,10)]"":$PIECE(IB("M"),U,10),1:"")
- 5 WRITE !!,$EXTRACT($PIECE(VADM(3),U),4,7)_$EXTRACT($PIECE(VADM(3),U),2,3),?8,$PIECE(VADM(5),U),?10
- SET Y=$PIECE(IBDPT(0),U,5)
- WRITE $SELECT(Y=1:"D",Y=2:"M",Y=4:"W",Y=5:"X",Y=6:"S",1:"U")
- +1 if $DATA(IBIP)
- WRITE ?14,$SELECT($PIECE(IBIP,U,2)'="":$EXTRACT($PIECE(IBIP,U,2),4,7)_$EXTRACT($PIECE(IBIP,U,2),2,3),1:$EXTRACT(IBDT,4,7)_$EXTRACT(IBDT,2,3)),?21,$SELECT($EXTRACT($PIECE($PIECE(IBIP,U,2),".",2),1,2)'="":$EXTRACT($PIECE($PIECE(IBIP,U,2),".",
- 2),1,2),1:"99")
- +2 if $DATA(IBIP)
- WRITE ?24,$SELECT($PIECE(IBIP,U,5)'="":$PIECE(IBIP,U,5),1:9),?27,$SELECT($PIECE(IBIP,U,4)'="":$PIECE(IBIP,U,4),1:9),?29,$SELECT($PIECE(IBIP,U,3)'="":$PIECE(IBIP,U,3),1:"99")
- +3 IF $DATA(IBIP)
- WRITE ?32,$SELECT($PIECE(IBIP,U,6)']"":"99",1:$EXTRACT($PIECE($PIECE(IBIP,U,6),".",2),1,2))
- SET X=$PIECE(IBIP,U,7)
- WRITE ?36,$SELECT($DATA(^DGCR(399.1,+X,0)):$PIECE(^(0),"^",2),1:"")
- +4 IF '$DATA(IBIP)
- WRITE ?14,$EXTRACT(IBDT,4,7)_$EXTRACT(IBDT,2,3),?21,"99"
- +5 WRITE ?40,$EXTRACT($PIECE(IB("U"),"^"),4,7)_$EXTRACT($PIECE(IB("U"),"^"),2,3),?48,$EXTRACT($PIECE(IB("U"),"^",2),4,7)_$EXTRACT($PIECE(IB("U"),"^",2),2,3),?70,$PIECE(IB("U1"),U,6),!!
- 6 IF $DATA(IBO(1))
- WRITE IBO(1),?3,$EXTRACT(IBOCD(1),4,7)_$EXTRACT(IBOCD(1),2,3)
- IF $DATA(IBO(2))
- WRITE ?11,IBO(2),?14,$EXTRACT(IBOCD(2),4,7)_$EXTRACT(IBOCD(2),2,3)
- IF $DATA(IBO(3))
- WRITE ?22,IBO(3),?25,$EXTRACT(IBOCD(3),4,7)_$EXTRACT(IBOCD(3),2,3)
- +1 IF $DATA(IBO(4))
- WRITE ?35,IBO(4),?38,$EXTRACT(IBOCD(4),4,7)_$EXTRACT(IBOCD(4),2,3)
- IF $DATA(IBO(5))
- WRITE ?46,IBO(5),?49,$EXTRACT(IBOCD(5),4,7)_$EXTRACT(IBOCD(5),2,3)
- +2 DO 7^IBCF10
- IF DGPAG<DGTOTPAG
- SET DGPAG=DGPAG+1
- GOTO EN2
- +3 QUIT
- SET ;Set Variables
- +1 DO 2^VADPT
- FOR I=0,.11,.121,.25,.311,.36
- SET IBDPT(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
- +2 FOR I=0,"C","I1","I2","I3","M","M1","S","U","U1"
- SET IB(I)=$SELECT($DATA(^DGCR(399,IBIFN,I)):^(I),1:"")
- +3 FOR I=0,1,2
- SET IBEPAR(I)=$GET(^IBE(350.9,1,I))
- +4 SET IBBT=$PIECE(IB(0),"^",4)_$PIECE(IB(0),"^",5)_$PIECE(IB(0),"^",6)
- +5 SET IBU="UNSPECIFIED"
- QUIT
- +6 ;IBCF1
