PSDOPT2 ;BIR/JPW,LTL-Outpatient Rx Entry (cont. from PSDOPT); 9 Jan 95
;;3.0; CONTROLLED SUBSTANCES ;**30,39,48**;13 Feb 97
;References to ^PSD(58.8 are covered by DBIA #2711
;References to file 58.81 are covered by DBIA #2808
;Reference to PSRX( supported by DBIA #986
;
;lists posted cs rxs
S (PSDJJ,PSDRET,X)=0 F S X=$O(^PSD(58.81,"AOP",PSDRX,X)) Q:X'>0 I $D(^PSD(58.81,X,3)),$P(^PSD(58.81,X,3),"^")'="" S PSDRET=1
W !,!!,"Previously posted transactions for Rx #",RXNUM
I $G(PSDRET)=1 W !,"(RTS) - denotes a Returned to Stock Transaction." S PSDRET=0
W !!,"Date Posted:",?22,"Pharmacist:",?54,"Type:",?70,"Quantity:"
TRANS S PSDJJ=$O(^PSD(58.81,"AOP",PSDRX,PSDJJ)) G Q:'PSDJJ I '$D(^PSD(58.81,PSDJJ,0)) G TRANS
S NODE=^PSD(58.81,PSDJJ,0),NODE6=^PSD(58.81,PSDJJ,6),NODE3=$G(^PSD(58.81,PSDJJ,3))
S PHARM=+$P(NODE,"^",7),PHARMN="" I PHARM S PHARMN=$P($G(^VA(200,PHARM,0)),"^")
S PSDATE=+$P(NODE,"^",4) I PSDATE S Y=PSDATE X ^DD("DD") S PSDATE=Y
S VAULT=+$P(NODE,"^",3),VAULT=$P($G(^PSD(58.8,VAULT,0)),"^")
W:VAULT'=PSDSN !,"Dispensing Site: ",VAULT
W !,PSDATE,?22,PHARMN,?54,$S($P(NODE6,U,2):"Refill #"_$P(NODE6,U,2),$P(NODE6,U,4):"Partial #"_$P(NODE6,U,4),1:"Original")
RTS ;PSD*3*39 (6JUL02) - Check for returned to stock
S (PSDDATE3,PSDDATE4)=0
S PSDTYPE=$S($P($G(NODE6),"^",2)'="":"RF",$P($G(NODE6),"^",4)'="":"PR",1:"OR")
S PSDTYPE(1)=$S(PSDTYPE="RF":"Refill",PSDTYPE="PR":"Partial",1:"Original")
S PSDRETN=$S(PSDTYPE="RF":$P(NODE6,"^",2),PSDTYPE="PR":$P(NODE6,"^",4),1:0) ;fill #
S PSDDATE3=$P($G(NODE3),"^") S:$G(PSDDATE3)'="" PSDRET(PSDTYPE,PSDRETN)=PSDDATE3,Y=PSDDATE3 X ^DD("DD") S PSDDATE3(1)=Y
I $G(NODE3)'="" W " (RTS)"
I $G(PSDDATE3)="" G QTY
I $G(PSDTYPE)="OR",$P($G(^PSRX(PSDRX,2)),"^",15)="" K PSDRET("OR",PSDRETN) G QTY
I $G(PSDTYPE)="RF",$D(^PSRX(PSDRX,1,PSDRETN,0)) S PSDDATE4=$P(^PSRX(PSDRX,1,PSDRETN,0),"^") I PSDDATE4>PSDDATE3 K PSDRET("RF",PSDRETN) G QTY
I $G(PSDTYPE)="PR",$D(^PSRX(PSDRX,"P",PSDRETN,0)) S PSDDATE4=$P(^PSRX(PSDRX,"P",PSDRETN,0),"^") I PSDDATE4>PSDDATE3 K PSDRET("PR",PSDRETN) G QTY
QTY W ?70,$J($P(NODE,U,6),6)
I $P($G(PSDDATE3),".")=$G(PSDDATE4) S PSDRTSE(PSDTYPE,PSDRETN)=""
;
;
POST ;Check to see if fill has been released/posted
S PSDRX(PSDTYPE,PSDRETN)="^"_$P($G(NODE),"^",6)_"^1"
;; PSD*3*48 RJS ; CHECK TO SEE IF RELEASED.
I $G(NODE3),$G(^PSRX(PSDRX,1,PSDRETN,0)),$P(^PSRX(PSDRX,1,PSDRETN,0),"^",18)="" S $P(PSDRX(PSDTYPE,PSDRETN),"^",3)=""
G TRANS
Q W ! K DIR,DIRUT S DIR(0)="EA",DIR("A")="Press <RET> to continue " D ^DIR I 'Y S PSDOUT=1
Q
PSDRTS ;PSD*3.0*39 ; The next 10 lines are original code commented out for patch PSD*3*45 (this subroutine was duplicated then modified for testing)
;Fill data matches RTS date
W !,?10,PSDTYPE(1)_$S($G(PSDTYPE)="OR":"",1:(" #"_PSDRETN))_" was returned to stock on "_$G(PSDDATE3(1)),!?10,"The prescription shows it re-issued on"_$G(PSDDATE4(1))
ASK W !!,"Was the fill re-issued AFTER being returned to stock? YES// " R AN:DTIME G Q:AN["^" S:AN="" AN="Y" S AN=$E(AN)
I "YyNn"'[AN D G ASK
.W !!,"The issue date of the fill is the same day as the return to stock date.",!,"The program believes the fill has been re-issued since being returned to stock."
.W !,"Please confirm this.",!
I "nN"[AN W !,$G(PSDTYPE(1))_" will remain marked as returned to stock and unavailable.",! G TRANS
W !,"ok, we'll bypass the returned to stock transaction." K PSDRET(PSDTYPE,PSDRETN) G TRANS
Q
RTSDTC ;; PSD*3*48 ADDED LOGIC FOR WHEN AN RTS IS REISSUED ON THE SAMEDAY.
N AN
I (PSDRET("RF",X1)\1)'=DT D CLLDIR2^PSDOPT Q
W !,?10,PSDTYPE(1)_$S($G(PSDTYPE)="OR":"",1:(" #"_PSDRETN))_" was returned to stock on "_$G(PSDDATE3(1)),!?10,"The prescription shows it re-issued today"
W !!,"Was the fill re-issued AFTER being returned to stock? YES// "
R AN:DTIME Q:AN["^"
S:AN="" AN="Y" S AN=$E(AN)
I AN="Y"!(AN="y") D CLLDIR2^PSDOPT
Q
PSDKLL ;
K PSD,PSDA,PSDATE,PSDBAL,PSDCS,PSDDATE3,PSDDATE4,PSDERR,PSDFILL,PSDFLNO,PSDHOLDX,PSDJJ,PSDLBL,PSDLBLP,PSDNEXT,PSDNUM
K PSDNUM1,PSDOIN,PSDOUT,PSDPOST,PSDPR1,PSDQTY,PSDR,PSDREL,PSDRET,PSDRETN
K PSDRF1,PSDRN,PSDRPH,PSDRS,PSDRTS,PSDRTSE,PSDRX,PSDRXFD
K PSDRXIN,PSDS,PSDSEL,PSDSITE,PSDSN,PSDSTA,PSDSUPN,PSDT,PSDTYPE,PSDUZ
K PSDXXX,PSOCSUB,PSOVR
K QTY,RETSK,RF,RPDT,RX0,RX2,RXNUM
Q
PSDOPT2 ;BIR/JPW,LTL-Outpatient Rx Entry (cont. from PSDOPT); 9 Jan 95
+1 ;;3.0; CONTROLLED SUBSTANCES ;**30,39,48**;13 Feb 97
+2 ;References to ^PSD(58.8 are covered by DBIA #2711
+3 ;References to file 58.81 are covered by DBIA #2808
+4 ;Reference to PSRX( supported by DBIA #986
+5 ;
+6 ;lists posted cs rxs
+7 SET (PSDJJ,PSDRET,X)=0
FOR
SET X=$ORDER(^PSD(58.81,"AOP",PSDRX,X))
IF X'>0
QUIT
IF $DATA(^PSD(58.81,X,3))
IF $PIECE(^PSD(58.81,X,3),"^")'=""
SET PSDRET=1
+8 WRITE !,!!,"Previously posted transactions for Rx #",RXNUM
+9 IF $GET(PSDRET)=1
WRITE !,"(RTS) - denotes a Returned to Stock Transaction."
SET PSDRET=0
+10 WRITE !!,"Date Posted:",?22,"Pharmacist:",?54,"Type:",?70,"Quantity:"
TRANS SET PSDJJ=$ORDER(^PSD(58.81,"AOP",PSDRX,PSDJJ))
IF 'PSDJJ
GOTO Q
IF '$DATA(^PSD(58.81,PSDJJ,0))
GOTO TRANS
+1 SET NODE=^PSD(58.81,PSDJJ,0)
SET NODE6=^PSD(58.81,PSDJJ,6)
SET NODE3=$GET(^PSD(58.81,PSDJJ,3))
+2 SET PHARM=+$PIECE(NODE,"^",7)
SET PHARMN=""
IF PHARM
SET PHARMN=$PIECE($GET(^VA(200,PHARM,0)),"^")
+3 SET PSDATE=+$PIECE(NODE,"^",4)
IF PSDATE
SET Y=PSDATE
XECUTE ^DD("DD")
SET PSDATE=Y
+4 SET VAULT=+$PIECE(NODE,"^",3)
SET VAULT=$PIECE($GET(^PSD(58.8,VAULT,0)),"^")
+5 IF VAULT'=PSDSN
WRITE !,"Dispensing Site: ",VAULT
+6 WRITE !,PSDATE,?22,PHARMN,?54,$SELECT($PIECE(NODE6,U,2):"Refill #"_$PIECE(NODE6,U,2),$PIECE(NODE6,U,4):"Partial #"_$PIECE(NODE6,U,4),1:"Original")
RTS ;PSD*3*39 (6JUL02) - Check for returned to stock
+1 SET (PSDDATE3,PSDDATE4)=0
+2 SET PSDTYPE=$SELECT($PIECE($GET(NODE6),"^",2)'="":"RF",$PIECE($GET(NODE6),"^",4)'="":"PR",1:"OR")
+3 SET PSDTYPE(1)=$SELECT(PSDTYPE="RF":"Refill",PSDTYPE="PR":"Partial",1:"Original")
+4 ;fill #
SET PSDRETN=$SELECT(PSDTYPE="RF":$PIECE(NODE6,"^",2),PSDTYPE="PR":$PIECE(NODE6,"^",4),1:0)
+5 SET PSDDATE3=$PIECE($GET(NODE3),"^")
IF $GET(PSDDATE3)'=""
SET PSDRET(PSDTYPE,PSDRETN)=PSDDATE3
SET Y=PSDDATE3
XECUTE ^DD("DD")
SET PSDDATE3(1)=Y
+6 IF $GET(NODE3)'=""
WRITE " (RTS)"
+7 IF $GET(PSDDATE3)=""
GOTO QTY
+8 IF $GET(PSDTYPE)="OR"
IF $PIECE($GET(^PSRX(PSDRX,2)),"^",15)=""
KILL PSDRET("OR",PSDRETN)
GOTO QTY
+9 IF $GET(PSDTYPE)="RF"
IF $DATA(^PSRX(PSDRX,1,PSDRETN,0))
SET PSDDATE4=$PIECE(^PSRX(PSDRX,1,PSDRETN,0),"^")
IF PSDDATE4>PSDDATE3
KILL PSDRET("RF",PSDRETN)
GOTO QTY
+10 IF $GET(PSDTYPE)="PR"
IF $DATA(^PSRX(PSDRX,"P",PSDRETN,0))
SET PSDDATE4=$PIECE(^PSRX(PSDRX,"P",PSDRETN,0),"^")
IF PSDDATE4>PSDDATE3
KILL PSDRET("PR",PSDRETN)
GOTO QTY
QTY WRITE ?70,$JUSTIFY($PIECE(NODE,U,6),6)
+1 IF $PIECE($GET(PSDDATE3),".")=$GET(PSDDATE4)
SET PSDRTSE(PSDTYPE,PSDRETN)=""
+2 ;
+3 ;
POST ;Check to see if fill has been released/posted
+1 SET PSDRX(PSDTYPE,PSDRETN)="^"_$PIECE($GET(NODE),"^",6)_"^1"
+2 ;; PSD*3*48 RJS ; CHECK TO SEE IF RELEASED.
+3 IF $GET(NODE3)
IF $GET(^PSRX(PSDRX,1,PSDRETN,0))
IF $PIECE(^PSRX(PSDRX,1,PSDRETN,0),"^",18)=""
SET $PIECE(PSDRX(PSDTYPE,PSDRETN),"^",3)=""
+4 GOTO TRANS
Q WRITE !
KILL DIR,DIRUT
SET DIR(0)="EA"
SET DIR("A")="Press <RET> to continue "
DO ^DIR
IF 'Y
SET PSDOUT=1
+1 QUIT
PSDRTS ;PSD*3.0*39 ; The next 10 lines are original code commented out for patch PSD*3*45 (this subroutine was duplicated then modified for testing)
+1 ;Fill data matches RTS date
+2 WRITE !,?10,PSDTYPE(1)_$SELECT($GET(PSDTYPE)="OR":"",1:(" #"_PSDRETN))_" was returned to stock on "_$GET(PSDDATE3(1)),!?10,"The prescription shows it re-issued on"_$GET(PSDDATE4(1))
ASK WRITE !!,"Was the fill re-issued AFTER being returned to stock? YES// "
READ AN:DTIME
IF AN["^"
GOTO Q
IF AN=""
SET AN="Y"
SET AN=$EXTRACT(AN)
+1 IF "YyNn"'[AN
Begin DoDot:1
+2 WRITE !!,"The issue date of the fill is the same day as the return to stock date.",!,"The program believes the fill has been re-issued since being returned to stock."
+3 WRITE !,"Please confirm this.",!
End DoDot:1
GOTO ASK
+4 IF "nN"[AN
WRITE !,$GET(PSDTYPE(1))_" will remain marked as returned to stock and unavailable.",!
GOTO TRANS
+5 WRITE !,"ok, we'll bypass the returned to stock transaction."
KILL PSDRET(PSDTYPE,PSDRETN)
GOTO TRANS
+6 QUIT
RTSDTC ;; PSD*3*48 ADDED LOGIC FOR WHEN AN RTS IS REISSUED ON THE SAMEDAY.
+1 NEW AN
+2 IF (PSDRET("RF",X1)\1)'=DT
DO CLLDIR2^PSDOPT
QUIT
+3 WRITE !,?10,PSDTYPE(1)_$SELECT($GET(PSDTYPE)="OR":"",1:(" #"_PSDRETN))_" was returned to stock on "_$GET(PSDDATE3(1)),!?10,"The prescription shows it re-issued today"
+4 WRITE !!,"Was the fill re-issued AFTER being returned to stock? YES// "
+5 READ AN:DTIME
IF AN["^"
QUIT
+6 IF AN=""
SET AN="Y"
SET AN=$EXTRACT(AN)
+7 IF AN="Y"!(AN="y")
DO CLLDIR2^PSDOPT
+8 QUIT
PSDKLL ;
+1 KILL PSD,PSDA,PSDATE,PSDBAL,PSDCS,PSDDATE3,PSDDATE4,PSDERR,PSDFILL,PSDFLNO,PSDHOLDX,PSDJJ,PSDLBL,PSDLBLP,PSDNEXT,PSDNUM
+2 KILL PSDNUM1,PSDOIN,PSDOUT,PSDPOST,PSDPR1,PSDQTY,PSDR,PSDREL,PSDRET,PSDRETN
+3 KILL PSDRF1,PSDRN,PSDRPH,PSDRS,PSDRTS,PSDRTSE,PSDRX,PSDRXFD
+4 KILL PSDRXIN,PSDS,PSDSEL,PSDSITE,PSDSN,PSDSTA,PSDSUPN,PSDT,PSDTYPE,PSDUZ
+5 KILL PSDXXX,PSOCSUB,PSOVR
+6 KILL QTY,RETSK,RF,RPDT,RX0,RX2,RXNUM
+7 QUIT
