IBCF4 ;ALB/ARH - PRINT BILL ADDENDUM ; 12-JAN-94
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
PRXA ;get bill number then print rx refill addendums for bills
;S DIR("??")="^D RXDISP^IBCF4",DIR("?")="Enter the bill number of a bill with prescription refills or prosthetic items",DIR("A")="Select BILL NUMBER",DIR(0)="FO^0:15" D ^DIR K DIR I Y=""!$D(DIRUT) G EXIT
;S IBIFN=$O(^DGCR(399,"B",Y,0)) I 'IBIFN W " ??" G PRXA
;I '$D(^IBA(362.4,"AIFN"_+IBIFN)) W " bill has no Rx Refills..." G PRXA
S DIC("S")="I $D(^IBA(362.4,""AIFN""_+Y))!($D(^IBA(362.5,""AIFN""_+Y)))"
S DIC="^DGCR(399,",DIC(0)="AEMQ" D ^DIC K DIC G:+Y'>0 EXIT S IBBILL=$P(Y,U,2),IBIFN=+Y
DEV ;get the device
W !!,"Report requires 132 columns."
S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS G:POP EXIT
I $D(IO("Q")) S ZTRTN="EN^IBCF4",ZTDESC="BILL ADDENDUM FOR "_IBBILL,ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q"),ZTSK G EXIT
U IO D EN
;
EXIT ;clean up and quit
I $D(ZTQUEUED) S ZTREQ="@" Q
K IBQUIT,IBIFN,IBBILL,X,Y,DTOUT,DUOUT,DIRUT,DIROUT D ^%ZISC
Q
;
EN ;ENTRY POINT IF QUEUED, print all rx refills for a bill
S IBY=$G(^DGCR(399,+IBIFN,0)) Q:IBY="" S IBXREF="AIFN"_IBIFN
S (IBQUIT,IBPGN,IBRX)=0,IBHDR="BILL ADDENDUM FOR "_$P($G(^DPT(+$P(IBY,U,2),0)),U,1)_" - "_$P(IBY,U,1) D HDR
RX I '$D(^IBA(362.4,IBXREF)) G PROS
W !!,"PRESCRIPTION REFILLS:",!
S IBRX=0 F S IBRX=$O(^IBA(362.4,IBXREF,IBRX)) Q:IBRX=""!IBQUIT S IBRIFN=0 F S IBRIFN=$O(^IBA(362.4,IBXREF,IBRX,IBRIFN)) Q:'IBRIFN!IBQUIT D
. S IBY=$G(^IBA(362.4,IBRIFN,0)) Q:IBY=""
. W !,$P(IBY,U,1),?13,$$FMTE^XLFDT(+$P(IBY,U,3)),?28,$P($G(^PSDRUG(+$P(IBY,U,4),0)),U,1)
. I $P(IBY,U,6)'="" W ?70,"QTY: ",$P(IBY,U,7)
. I $P(IBY,U,7)'="" W ?80,"DAYS SUPPLY: ",$P(IBY,U,6)
. I $P(IBY,U,8)'="" W ?100,"NDC #: ",$P(IBY,U,8)
. S IBLN=IBLN+1 I IBLN>(IOSL-7) D PAUSE,HDR
;
PROS I '$D(^IBA(362.5,IBXREF)) G END
W !!!,"PROSTHETIC ITEMS:",!
S IBPI=0 F S IBPI=$O(^IBA(362.5,IBXREF,IBPI)) Q:IBPI=""!IBQUIT S IBPIFN=0 F S IBPIFN=$O(^IBA(362.5,IBXREF,IBPI,IBPIFN)) Q:'IBPIFN!IBQUIT D
. S IBY=$G(^IBA(362.5,IBPIFN,0)) Q:IBY=""
. W !,$$FMTE^XLFDT(+$P(IBY,U,1)),?15,$P($$PIN^IBCSC5B(+$P(IBY,U,3)),U,2)
. S IBLN=IBLN+1 I IBLN>(IOSL-7) D PAUSE,HDR
D:'IBQUIT PAUSE
END K IBX,IBY,IBPGN,IBRX,IBHDR,IBRIFN,IBLN,IBCDT,IBI,IBXREF,IBPI,IBPIFN
Q
;
;
HDR ;print the report header
S IBQUIT=$$STOP Q:IBQUIT S IBPGN=IBPGN+1,IBLN=5
D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S IBCDT=$P(Y,"@",1)_" "_$P(Y,"@",2)
I IBPGN>1!($E(IOST,1,2)["C-") W @IOF
W IBHDR W:IOM<85 ! W ?(IOM-30),IBCDT,?(IOM-8),"PAGE ",IBPGN,!
;W !,"RX #",?13,"REFILL DATE",?28,"DRUG",?70,"DAYS SUPPLY",?83,"QTY",?90,"NDC #",!
F IBI=1:1:IOM W "-"
W !
Q
;
PAUSE ;pause at end of screen if beeing displayed on a terminal
Q:$E(IOST,1,2)'["C-"
S DIR(0)="E" D ^DIR K DIR
I $D(DUOUT)!($D(DIRUT)) S IBQUIT=1
Q
;
STOP() ;determine if user has requested the queued report to stop
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !,"***TASK STOPPED BY USER***"
Q +$G(ZTSTOP)
;
RXDISP ;displays all rx refills bills
;N IBX,IBY,IBZ,IBC,X,Y S Y=1,IBC=0,IBX="AIFN"
;F S IBX=$O(^IBA(362.4,IBX)) Q:IBX="" S IBY=$E(IBX,5,999),IBZ=$G(^DGCR(399,+IBY,0)) I IBZ'="" D Q:'Y
;. W !,$P(IBZ,U,1),?10,$E($P($G(^DPT(+$P(IBZ,U,2),0)),U,1),1,20),?32,$$DATE(+$P(IBZ,U,3)),?42,$S(+$P(IBZ,U,5)<3:"INPT",1:"OUTPT")
;. W ?49,$P($G(^DGCR(399.3,+$P(IBZ,U,7),0)),U,4),?59,$E($$EXSET^IBEFUNC(+$P(IBZ,U,13),399,.13),1,7),?68,$E($P($G(^IBE(353,+$P(IBZ,U,19),0)),U,1),1,11)
;. S IBC=IBC+1 I '(IBC#10) S DIR(0)="E" D ^DIR K DIR
;Q
;
DATE(X) Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
;
BILLAD(IFN) ;returns true if bill has either rx refills or prosthetics so addendum should print
N IBX S IBX=0,IFN=+$G(IFN) S:+$O(^IBA(362.4,"AIFN"_IFN,0)) IBX=1 S:+$O(^IBA(362.5,"AIFN"_IFN,0)) IBX=IBX+2
Q IBX
IBCF4 ;ALB/ARH - PRINT BILL ADDENDUM ; 12-JAN-94
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
PRXA ;get bill number then print rx refill addendums for bills
+1 ;S DIR("??")="^D RXDISP^IBCF4",DIR("?")="Enter the bill number of a bill with prescription refills or prosthetic items",DIR("A")="Select BILL NUMBER",DIR(0)="FO^0:15" D ^DIR K DIR I Y=""!$D(DIRUT) G EXIT
+2 ;S IBIFN=$O(^DGCR(399,"B",Y,0)) I 'IBIFN W " ??" G PRXA
+3 ;I '$D(^IBA(362.4,"AIFN"_+IBIFN)) W " bill has no Rx Refills..." G PRXA
+4 SET DIC("S")="I $D(^IBA(362.4,""AIFN""_+Y))!($D(^IBA(362.5,""AIFN""_+Y)))"
+5 SET DIC="^DGCR(399,"
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
IF +Y'>0
GOTO EXIT
SET IBBILL=$PIECE(Y,U,2)
SET IBIFN=+Y
DEV ;get the device
+1 WRITE !!,"Report requires 132 columns."
+2 SET %ZIS="QM"
SET %ZIS("A")="OUTPUT DEVICE: "
DO ^%ZIS
IF POP
GOTO EXIT
+3 IF $DATA(IO("Q"))
SET ZTRTN="EN^IBCF4"
SET ZTDESC="BILL ADDENDUM FOR "_IBBILL
SET ZTSAVE("IB*")=""
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
GOTO EXIT
+4 USE IO
DO EN
+5 ;
EXIT ;clean up and quit
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+2 KILL IBQUIT,IBIFN,IBBILL,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
DO ^%ZISC
+3 QUIT
+4 ;
EN ;ENTRY POINT IF QUEUED, print all rx refills for a bill
+1 SET IBY=$GET(^DGCR(399,+IBIFN,0))
IF IBY=""
QUIT
SET IBXREF="AIFN"_IBIFN
+2 SET (IBQUIT,IBPGN,IBRX)=0
SET IBHDR="BILL ADDENDUM FOR "_$PIECE($GET(^DPT(+$PIECE(IBY,U,2),0)),U,1)_" - "_$PIECE(IBY,U,1)
DO HDR
RX IF '$DATA(^IBA(362.4,IBXREF))
GOTO PROS
+1 WRITE !!,"PRESCRIPTION REFILLS:",!
+2 SET IBRX=0
FOR
SET IBRX=$ORDER(^IBA(362.4,IBXREF,IBRX))
IF IBRX=""!IBQUIT
QUIT
SET IBRIFN=0
FOR
SET IBRIFN=$ORDER(^IBA(362.4,IBXREF,IBRX,IBRIFN))
IF 'IBRIFN!IBQUIT
QUIT
Begin DoDot:1
+3 SET IBY=$GET(^IBA(362.4,IBRIFN,0))
IF IBY=""
QUIT
+4 WRITE !,$PIECE(IBY,U,1),?13,$$FMTE^XLFDT(+$PIECE(IBY,U,3)),?28,$PIECE($GET(^PSDRUG(+$PIECE(IBY,U,4),0)),U,1)
+5 IF $PIECE(IBY,U,6)'=""
WRITE ?70,"QTY: ",$PIECE(IBY,U,7)
+6 IF $PIECE(IBY,U,7)'=""
WRITE ?80,"DAYS SUPPLY: ",$PIECE(IBY,U,6)
+7 IF $PIECE(IBY,U,8)'=""
WRITE ?100,"NDC #: ",$PIECE(IBY,U,8)
+8 SET IBLN=IBLN+1
IF IBLN>(IOSL-7)
DO PAUSE
DO HDR
End DoDot:1
+9 ;
PROS IF '$DATA(^IBA(362.5,IBXREF))
GOTO END
+1 WRITE !!!,"PROSTHETIC ITEMS:",!
+2 SET IBPI=0
FOR
SET IBPI=$ORDER(^IBA(362.5,IBXREF,IBPI))
IF IBPI=""!IBQUIT
QUIT
SET IBPIFN=0
FOR
SET IBPIFN=$ORDER(^IBA(362.5,IBXREF,IBPI,IBPIFN))
IF 'IBPIFN!IBQUIT
QUIT
Begin DoDot:1
+3 SET IBY=$GET(^IBA(362.5,IBPIFN,0))
IF IBY=""
QUIT
+4 WRITE !,$$FMTE^XLFDT(+$PIECE(IBY,U,1)),?15,$PIECE($$PIN^IBCSC5B(+$PIECE(IBY,U,3)),U,2)
+5 SET IBLN=IBLN+1
IF IBLN>(IOSL-7)
DO PAUSE
DO HDR
End DoDot:1
+6 IF 'IBQUIT
DO PAUSE
END KILL IBX,IBY,IBPGN,IBRX,IBHDR,IBRIFN,IBLN,IBCDT,IBI,IBXREF,IBPI,IBPIFN
+1 QUIT
+2 ;
+3 ;
HDR ;print the report header
+1 SET IBQUIT=$$STOP
IF IBQUIT
QUIT
SET IBPGN=IBPGN+1
SET IBLN=5
+2 DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
DO DD^%DT
SET IBCDT=$PIECE(Y,"@",1)_" "_$PIECE(Y,"@",2)
+3 IF IBPGN>1!($EXTRACT(IOST,1,2)["C-")
WRITE @IOF
+4 WRITE IBHDR
IF IOM<85
WRITE !
WRITE ?(IOM-30),IBCDT,?(IOM-8),"PAGE ",IBPGN,!
+5 ;W !,"RX #",?13,"REFILL DATE",?28,"DRUG",?70,"DAYS SUPPLY",?83,"QTY",?90,"NDC #",!
+6 FOR IBI=1:1:IOM
WRITE "-"
+7 WRITE !
+8 QUIT
+9 ;
PAUSE ;pause at end of screen if beeing displayed on a terminal
+1 IF $EXTRACT(IOST,1,2)'["C-"
QUIT
+2 SET DIR(0)="E"
DO ^DIR
KILL DIR
+3 IF $DATA(DUOUT)!($DATA(DIRUT))
SET IBQUIT=1
+4 QUIT
+5 ;
STOP() ;determine if user has requested the queued report to stop
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ZTREQ
IF +$GET(IBPGN)
WRITE !,"***TASK STOPPED BY USER***"
+2 QUIT +$GET(ZTSTOP)
+3 ;
RXDISP ;displays all rx refills bills
+1 ;N IBX,IBY,IBZ,IBC,X,Y S Y=1,IBC=0,IBX="AIFN"
+2 ;F S IBX=$O(^IBA(362.4,IBX)) Q:IBX="" S IBY=$E(IBX,5,999),IBZ=$G(^DGCR(399,+IBY,0)) I IBZ'="" D Q:'Y
+3 ;. W !,$P(IBZ,U,1),?10,$E($P($G(^DPT(+$P(IBZ,U,2),0)),U,1),1,20),?32,$$DATE(+$P(IBZ,U,3)),?42,$S(+$P(IBZ,U,5)<3:"INPT",1:"OUTPT")
+4 ;. W ?49,$P($G(^DGCR(399.3,+$P(IBZ,U,7),0)),U,4),?59,$E($$EXSET^IBEFUNC(+$P(IBZ,U,13),399,.13),1,7),?68,$E($P($G(^IBE(353,+$P(IBZ,U,19),0)),U,1),1,11)
+5 ;. S IBC=IBC+1 I '(IBC#10) S DIR(0)="E" D ^DIR K DIR
+6 ;Q
+7 ;
DATE(X) QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+1 ;
BILLAD(IFN) ;returns true if bill has either rx refills or prosthetics so addendum should print
+1 NEW IBX
SET IBX=0
SET IFN=+$GET(IFN)
IF +$ORDER(^IBA(362.4,"AIFN"_IFN,0))
SET IBX=1
IF +$ORDER(^IBA(362.5,"AIFN"_IFN,0))
SET IBX=IBX+2
+2 QUIT IBX
