IBCSC5A ;ALB/ARH - ADD/ENTER PRESCRIPTION REFILLS ; 12/27/93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
EN ;add/edit prescription refills for a bill, IBIFN required
S IBX=$$BILL(IBIFN) Q:'IBIFN S DFN=+IBX,IBDT1=$P(IBX,U,2),IBDT2=$P(IBX,U,3),IBRXNEW=0
D SET(IBIFN,.IBRXA,"") S IBRXOLD=+$P(IBRXA,U,2)
D RXDISP^IBCSC5C(DFN,IBDT1,IBDT2,.IBPR,.IBPRO,.IBRXA) I +$P($G(IBPRO),U,2) D NEWRX^IBCSC5C(+IBPRO) I +$G(IBLIST) D ADDNEW^IBCSC5C(IBIFN,IBLIST,.IBPR,.IBPRO) S DGRVRCAL=1,IBRXNEW=1
S IBRXAP=+$G(IBPRO) D SET(IBIFN,.IBRXA,.IBRXAP),DISP(.IBRXA,.IBRXAP)
E1 S IBPIFN=0,IBRX=$$ASKRX(.IBRXAP,.IBPRO) G:IBRX="" EXIT S IBDT=$P(IBRX,U,2),IBRX=$P(IBRX,U,1),DGRVRCAL=1
I 'IBDT S IBDT=$O(IBRXA(IBRX,0)) S:'IBDT IBDT=$O(IBPR(IBRX,0)) S IBDT=$$ASKDT(IBDT1,IBDT2,IBDT) G:'IBDT E1
I +$$RXDUP^IBCU3(IBRX,IBDT,IBIFN,1),'$D(IBRXA(IBRX,IBDT)) G E1
I '$D(IBPR(IBRX,IBDT)) W !,"This rx refill does not exist in Pharmacy for this patient!",!
S IBPIFN=$G(IBRXA(IBRX,IBDT)),IBDRG=$P(IBPIFN,U,2)
I 'IBPIFN S IBX=$G(IBPR(IBRX,IBDT)),IBPIFN=$$ADD(IBRX,IBIFN,IBDT,$P(IBX,U,3),$P(IBX,U,1),$P(IBX,U,4,6)) S:+IBPIFN IBRXNEW=1 W:+IBPIFN " ... ADDED" I 'IBPIFN W " ??" G E1
D EDIT(+IBPIFN) S IBRXAP=+$G(IBPRO) D SET(IBIFN,.IBRXA,.IBRXAP) G E1
;
EXIT I 'IBRXOLD,+IBRXNEW D DEFAULT^IBCSC5C(IBIFN)
K IBPIFN,IBRX,IBDRG,IBX,IBDT1,IBDT2,IBRXA,IBPR,IBDT,IBRXNEW,IBRXOLD,IBLIST,IBPRO,IBRXAP
Q
;
ASKRX(IBRXAP,IBPRO) ;
N X,Y,IBY,IBX W ! S IBX=""
I +$G(IBIFN) S DIR("?")="The prescription number for the refill",DIR("??")="^D HELP^IBCSC5A("_IBIFN_")"
S DIR("A")="Select RX REFILL",DIR(0)="FO^1:11^K:X'?.UN X" D ^DIR I $D(DIRUT)!(Y'?.AN) S Y="" K DIR,DIRUT G ARX1E
S IBX=Y I $D(IBRXAP)<10,$D(IBPRO)<10 G ARX1E
;
S IBY=$G(IBRXAP(IBX)) S:IBY="" IBY=$G(IBPRO(IBX)) I IBY="" G ARX1E
W ! S DIR(0)="YO",DIR("A")="ADD/EDIT RX REFILL "_$P(IBY,U,1)_" FOR "_$$FMTE^XLFDT($P(IBY,U,2))_" CORRECT",DIR("B")="YES"
D ^DIR K DIR I Y=1,'$D(DIRUT) S IBX=IBY
ARX1E Q IBX
;
ASKDT(IBDT1,IBDT2,IBDT) ;
S DIR("A")="Select RX REFILL DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX",DIR("B")=$$FMTE^XLFDT(IBDT) D ^DIR K DIR,DTOUT,DIRUT
Q $S(Y?7N:Y,1:0)
;
ADD(RX,IFN,IBDT,DRUG,PIFN,OTHER) ;
N IBX S IBX=0 S DRUG=$$DRUG($G(DRUG)) G:'DRUG ADDE
S DIC="^IBA(362.4,",DIC(0)="AQL",X=RX K DA,DO D FILE^DICN K DA,DO,X
I Y>0 S DIE=DIC,(IBX,DA)=+Y,DR=".02////"_IFN_";.03////"_IBDT_";.04////"_DRUG_";.05////"_+PIFN_";.06////"_$P(OTHER,U,1)_";.07////"_$P(OTHER,U,2)_";.08////"_$P(OTHER,U,3) D ^DIE K DIE,DIC,DA,DR
ADDE Q IBX
;
EDIT(PIFN) ;
S DIDEL=362.4,DIE="^IBA(362.4,",DR=".01;.03;.04;.06;.07;.08",DA=PIFN D ^DIE K DIE,DR,DA,DIC,DIDEL
Q
;
SET(IFN,RXARR,RXARRP) ;setup array of all rx refills for bill, array name should be passed by reference
;returns: RXARR(RX #, REFILL DT)=RX IFN (362.4) ^ DRUG ^ DAYS SUPPLY ^ QTY ^ NDC #, RXARR=BILL IFN ^ RX count
N CNT,IBX,IBY,IBZ,PIFN,IBC,IBCNT S IBCNT=+$G(RXARRP),IBC="AIFN"_$G(IFN) K RXARR,RXARRP
S (CNT,IBX)=0 F S IBX=$O(^IBA(362.4,IBC,IBX)) Q:IBX="" S PIFN=0 F S PIFN=$O(^IBA(362.4,IBC,IBX,PIFN)) Q:'PIFN D
. S IBY=$G(^IBA(362.4,PIFN,0)) Q:IBY="" S CNT=CNT+1,RXARR($P(IBY,U,1),+$P(IBY,U,3))=PIFN_U_$P(IBY,U,4)_U_$P(IBY,U,6,8)
S RXARR=$G(IFN)_"^"_CNT
S IBX=0 F S IBX=$O(RXARR(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(RXARR(IBX,IBY)) Q:'IBY S IBCNT=IBCNT+1,RXARRP(IBCNT)=IBX_"^"_IBY
Q
;
DISP(RXARR,RXARRP) ;screen display of existing refills for a bill,
;input should be print order array returned by SET^IBCSC5A: RXARR(RX,DT)=RX IFN (362.4) ^ DRUG, passed by reference
N IBX,IBY,IBZ
W !!,?5,"----------------- Existing Rx Refills for Bill -----------------",!
S IBI=0 F S IBI=$O(RXARRP(IBI)) Q:IBI="" S IBX=$P(RXARRP(IBI),U,1),IBY=$P(RXARRP(IBI),U,2) I $D(RXARR(IBX,IBY)) D
. S IBZ=$P($G(^PSDRUG(+$P(RXARR(IBX,IBY),U,2),0)),U,1)
. W !,$J(IBI,2),")",?7,IBX,?20,$E(IBZ,1,38),?60,$$FMTE^XLFDT(IBY)
W !
Q
;
HELP(IFN) ;called for help from rx enter to display existing rx, displays rx' from 52 and 399
I +$G(IFN) N IBX,IBRXA S IBX=$$BILL(IFN) I +IBX D SET(IFN,.IBRXA,""),RXDISP^IBCSC5C($P(IBX,U,1),$P(IBX,U,2),$P(IBX,U,3),.IBPR,.IBPRO,.IBRXA) S IBRXAP=+IBPRO D SET(IFN,.IBRXA,.IBRXAP),DISP(.IBRXA,.IBRXAP)
Q
;
BILL(IBIFN) ; display all existing prescription refills (52) for a patient and date range
; (call is a short cut to calling rxdisp if have bill number)
N IBX,IBY S IBX=$G(^DGCR(399,+$G(IBIFN),0)),IBY=$P(IBX,U,2)
S IBX=$G(^DGCR(399,+IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2)
Q IBY
;
DRUG(IBD) ; get drug
N X,Y S IBD=+$G(IBD) I '$D(^PSDRUG(IBD,0)) S IBD=0,DIC="^PSDRUG(",DIC(0)="AEQ" D ^DIC K DIC I +Y>0 S IBD=+Y
Q IBD
IBCSC5A ;ALB/ARH - ADD/ENTER PRESCRIPTION REFILLS ; 12/27/93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
EN ;add/edit prescription refills for a bill, IBIFN required
+1 SET IBX=$$BILL(IBIFN)
IF 'IBIFN
QUIT
SET DFN=+IBX
SET IBDT1=$PIECE(IBX,U,2)
SET IBDT2=$PIECE(IBX,U,3)
SET IBRXNEW=0
+2 DO SET(IBIFN,.IBRXA,"")
SET IBRXOLD=+$PIECE(IBRXA,U,2)
+3 DO RXDISP^IBCSC5C(DFN,IBDT1,IBDT2,.IBPR,.IBPRO,.IBRXA)
IF +$PIECE($GET(IBPRO),U,2)
DO NEWRX^IBCSC5C(+IBPRO)
IF +$GET(IBLIST)
DO ADDNEW^IBCSC5C(IBIFN,IBLIST,.IBPR,.IBPRO)
SET DGRVRCAL=1
SET IBRXNEW=1
+4 SET IBRXAP=+$GET(IBPRO)
DO SET(IBIFN,.IBRXA,.IBRXAP)
DO DISP(.IBRXA,.IBRXAP)
E1 SET IBPIFN=0
SET IBRX=$$ASKRX(.IBRXAP,.IBPRO)
IF IBRX=""
GOTO EXIT
SET IBDT=$PIECE(IBRX,U,2)
SET IBRX=$PIECE(IBRX,U,1)
SET DGRVRCAL=1
+1 IF 'IBDT
SET IBDT=$ORDER(IBRXA(IBRX,0))
IF 'IBDT
SET IBDT=$ORDER(IBPR(IBRX,0))
SET IBDT=$$ASKDT(IBDT1,IBDT2,IBDT)
IF 'IBDT
GOTO E1
+2 IF +$$RXDUP^IBCU3(IBRX,IBDT,IBIFN,1)
IF '$DATA(IBRXA(IBRX,IBDT))
GOTO E1
+3 IF '$DATA(IBPR(IBRX,IBDT))
WRITE !,"This rx refill does not exist in Pharmacy for this patient!",!
+4 SET IBPIFN=$GET(IBRXA(IBRX,IBDT))
SET IBDRG=$PIECE(IBPIFN,U,2)
+5 IF 'IBPIFN
SET IBX=$GET(IBPR(IBRX,IBDT))
SET IBPIFN=$$ADD(IBRX,IBIFN,IBDT,$PIECE(IBX,U,3),$PIECE(IBX,U,1),$PIECE(IBX,U,4,6))
IF +IBPIFN
SET IBRXNEW=1
IF +IBPIFN
WRITE " ... ADDED"
IF 'IBPIFN
WRITE " ??"
GOTO E1
+6 DO EDIT(+IBPIFN)
SET IBRXAP=+$GET(IBPRO)
DO SET(IBIFN,.IBRXA,.IBRXAP)
GOTO E1
+7 ;
EXIT IF 'IBRXOLD
IF +IBRXNEW
DO DEFAULT^IBCSC5C(IBIFN)
+1 KILL IBPIFN,IBRX,IBDRG,IBX,IBDT1,IBDT2,IBRXA,IBPR,IBDT,IBRXNEW,IBRXOLD,IBLIST,IBPRO,IBRXAP
+2 QUIT
+3 ;
ASKRX(IBRXAP,IBPRO) ;
+1 NEW X,Y,IBY,IBX
WRITE !
SET IBX=""
+2 IF +$GET(IBIFN)
SET DIR("?")="The prescription number for the refill"
SET DIR("??")="^D HELP^IBCSC5A("_IBIFN_")"
+3 SET DIR("A")="Select RX REFILL"
SET DIR(0)="FO^1:11^K:X'?.UN X"
DO ^DIR
IF $DATA(DIRUT)!(Y'?.AN)
SET Y=""
KILL DIR,DIRUT
GOTO ARX1E
+4 SET IBX=Y
IF $DATA(IBRXAP)<10
IF $DATA(IBPRO)<10
GOTO ARX1E
+5 ;
+6 SET IBY=$GET(IBRXAP(IBX))
IF IBY=""
SET IBY=$GET(IBPRO(IBX))
IF IBY=""
GOTO ARX1E
+7 WRITE !
SET DIR(0)="YO"
SET DIR("A")="ADD/EDIT RX REFILL "_$PIECE(IBY,U,1)_" FOR "_$$FMTE^XLFDT($PIECE(IBY,U,2))_" CORRECT"
SET DIR("B")="YES"
+8 DO ^DIR
KILL DIR
IF Y=1
IF '$DATA(DIRUT)
SET IBX=IBY
ARX1E QUIT IBX
+1 ;
ASKDT(IBDT1,IBDT2,IBDT) ;
+1 SET DIR("A")="Select RX REFILL DATE"
SET DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX"
SET DIR("B")=$$FMTE^XLFDT(IBDT)
DO ^DIR
KILL DIR,DTOUT,DIRUT
+2 QUIT $SELECT(Y?7N:Y,1:0)
+3 ;
ADD(RX,IFN,IBDT,DRUG,PIFN,OTHER) ;
+1 NEW IBX
SET IBX=0
SET DRUG=$$DRUG($GET(DRUG))
IF 'DRUG
GOTO ADDE
+2 SET DIC="^IBA(362.4,"
SET DIC(0)="AQL"
SET X=RX
KILL DA,DO
DO FILE^DICN
KILL DA,DO,X
+3 IF Y>0
SET DIE=DIC
SET (IBX,DA)=+Y
SET DR=".02////"_IFN_";.03////"_IBDT_";.04////"_DRUG_";.05////"_+PIFN_";.06////"_$PIECE(OTHER,U,1)_";.07////"_$PIECE(OTHER,U,2)_";.08////"_$PIECE(OTHER,U,3)
DO ^DIE
KILL DIE,DIC,DA,DR
ADDE QUIT IBX
+1 ;
EDIT(PIFN) ;
+1 SET DIDEL=362.4
SET DIE="^IBA(362.4,"
SET DR=".01;.03;.04;.06;.07;.08"
SET DA=PIFN
DO ^DIE
KILL DIE,DR,DA,DIC,DIDEL
+2 QUIT
+3 ;
SET(IFN,RXARR,RXARRP) ;setup array of all rx refills for bill, array name should be passed by reference
+1 ;returns: RXARR(RX #, REFILL DT)=RX IFN (362.4) ^ DRUG ^ DAYS SUPPLY ^ QTY ^ NDC #, RXARR=BILL IFN ^ RX count
+2 NEW CNT,IBX,IBY,IBZ,PIFN,IBC,IBCNT
SET IBCNT=+$GET(RXARRP)
SET IBC="AIFN"_$GET(IFN)
KILL RXARR,RXARRP
+3 SET (CNT,IBX)=0
FOR
SET IBX=$ORDER(^IBA(362.4,IBC,IBX))
IF IBX=""
QUIT
SET PIFN=0
FOR
SET PIFN=$ORDER(^IBA(362.4,IBC,IBX,PIFN))
IF 'PIFN
QUIT
Begin DoDot:1
+4 SET IBY=$GET(^IBA(362.4,PIFN,0))
IF IBY=""
QUIT
SET CNT=CNT+1
SET RXARR($PIECE(IBY,U,1),+$PIECE(IBY,U,3))=PIFN_U_$PIECE(IBY,U,4)_U_$PIECE(IBY,U,6,8)
End DoDot:1
+5 SET RXARR=$GET(IFN)_"^"_CNT
+6 SET IBX=0
FOR
SET IBX=$ORDER(RXARR(IBX))
IF IBX=""
QUIT
SET IBY=0
FOR
SET IBY=$ORDER(RXARR(IBX,IBY))
IF 'IBY
QUIT
SET IBCNT=IBCNT+1
SET RXARRP(IBCNT)=IBX_"^"_IBY
+7 QUIT
+8 ;
DISP(RXARR,RXARRP) ;screen display of existing refills for a bill,
+1 ;input should be print order array returned by SET^IBCSC5A: RXARR(RX,DT)=RX IFN (362.4) ^ DRUG, passed by reference
+2 NEW IBX,IBY,IBZ
+3 WRITE !!,?5,"----------------- Existing Rx Refills for Bill -----------------",!
+4 SET IBI=0
FOR
SET IBI=$ORDER(RXARRP(IBI))
IF IBI=""
QUIT
SET IBX=$PIECE(RXARRP(IBI),U,1)
SET IBY=$PIECE(RXARRP(IBI),U,2)
IF $DATA(RXARR(IBX,IBY))
Begin DoDot:1
+5 SET IBZ=$PIECE($GET(^PSDRUG(+$PIECE(RXARR(IBX,IBY),U,2),0)),U,1)
+6 WRITE !,$JUSTIFY(IBI,2),")",?7,IBX,?20,$EXTRACT(IBZ,1,38),?60,$$FMTE^XLFDT(IBY)
End DoDot:1
+7 WRITE !
+8 QUIT
+9 ;
HELP(IFN) ;called for help from rx enter to display existing rx, displays rx' from 52 and 399
+1 IF +$GET(IFN)
NEW IBX,IBRXA
SET IBX=$$BILL(IFN)
IF +IBX
DO SET(IFN,.IBRXA,"")
DO RXDISP^IBCSC5C($PIECE(IBX,U,1),$PIECE(IBX,U,2),$PIECE(IBX,U,3),.IBPR,.IBPRO,.IBRXA)
SET IBRXAP=+IBPRO
DO SET(IFN,.IBRXA,.IBRXAP)
DO DISP(.IBRXA,.IBRXAP)
+2 QUIT
+3 ;
BILL(IBIFN) ; display all existing prescription refills (52) for a patient and date range
+1 ; (call is a short cut to calling rxdisp if have bill number)
+2 NEW IBX,IBY
SET IBX=$GET(^DGCR(399,+$GET(IBIFN),0))
SET IBY=$PIECE(IBX,U,2)
+3 SET IBX=$GET(^DGCR(399,+IBIFN,"U"))
SET $PIECE(IBY,U,2)=+IBX
SET $PIECE(IBY,U,3)=+$PIECE(IBX,U,2)
+4 QUIT IBY
+5 ;
DRUG(IBD) ; get drug
+1 NEW X,Y
SET IBD=+$GET(IBD)
IF '$DATA(^PSDRUG(IBD,0))
SET IBD=0
SET DIC="^PSDRUG("
SET DIC(0)="AEQ"
DO ^DIC
KILL DIC
IF +Y>0
SET IBD=+Y
+2 QUIT IBD
