PSORESK ;BIR/SAB-return to stock ; 8/12/11 12:34pm
;;7.0;OUTPATIENT PHARMACY;**15,9,27,40,47,55,85,130,185,184,196,148,201,259,261,368,332,374,408**;DEC 1997;Build 100
;
;REF/IA
;^PSDRUG/221
;^PS(59.7/694
;L, UL, PSOL, and PSOUL^PSSLOCK/2789
;^PS(55/2228
;PSDRTS^PSDOPT0/3064
;
;External reference ^XTMP("PSA" supported by DBIA 1036
;
;*259 - if refill was Not deleted, then stop RTS from continuing
;
AC I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W !!,"Outpatient Pharmacy Site Parameters are required!" Q
S RESK=1 K PSODEF,^UTILITY($J,"PSOPCE") S PSOPCECT=1
BC K PSOWHERE,PSODEFLG,PSOINVTX,XTYPE W !! S DIR("A")="Enter/Wand PRESCRIPTION number",DIR("?")="^D HP^PSORESK1",DIR(0)="FO" D ^DIR K DIR I $D(DIRUT) K PSODEF G EX
I X'["-" D BCI W:'$G(RXP) !,"INVALID Rx" G:'$G(RXP) BC G BC1
I X["-" D I $P(X,"-")'=$G(PSORESST) W !,$C(7),$C(7)," INVALID STATION NUMBER !!",$C(7),$C(7),! K PSORESST G BC
.K PSORESST S PSORESSX=$G(X) K PSORESAR S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DIQ="PSORESAR",DR="99" D EN^DIQ1 S PSORESST=$G(PSORESAR(4,DA,99,"I")) K PSORESAR,DIQ,DA,DR S X=$G(PSORESSX) K PSORESSX
I X["-" S RXP=$P(X,"-",2) I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !,$C(7),$C(7),$C(7)," NON-EXISTENT Rx" G BC
G:$D(^PSRX(RXP,0)) BC1 W !,$C(7),$C(7),$C(7)," IMPROPER BARCODE FORMAT" G BC
BC1 ;
S PSORRDFN=+$P($G(^PSRX(RXP,0)),"^",2)
D ICN^PSODPT(PSORRDFN)
S PSOPLCK=$$L^PSSLOCK(PSORRDFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY K PSOPLCK G BC
K PSOPLCK D PSOL^PSSLOCK(RXP) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),! K PSOMSG D UL^PSSLOCK(+$G(PSORRDFN)) G BC
S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(RXP,0),"^",2)) K PSOLOUD
I $S('+$P($G(^PSRX(+RXP,"STA")),"^"):0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,$P(^("STA"),"^")=14:0,$P(^("STA"),"^")=15:0,1:1) D STAT^PSORESK1 D UL G BC
S COPAYFLG=1,QDRUG=$P($G(^PSRX(RXP,0)),"^",6),QTY=$P($G(^(0)),"^",7) I $O(^PSRX(RXP,1,0)) G REF
S Y="O" I $O(^PSRX(RXP,"P",0)) D I $D(DUOUT)!($D(DTOUT)) D UL G BC
.S DIR(0)="SA^O:ORIGINAL;P:PARTIAL",DIR("B")="ORIGINAL",DIR("A",1)="",DIR("A",2)="There are Partials for this Rx.",DIR("A")="Which are you Returning To Stock? "
.S DIR("?")=" Press return for Original. Enter 'P' for Partial" D ^DIR K DIR
S XTYPE=$S(Y="O":"O",1:"P") G:Y="P" PAR
I $P($G(^PSRX(RXP,2)),"^",15) D G BC
.W !,$C(7),$C(7),"Original fill for Rx # "_$P(^PSRX(RXP,0),"^")_" was Returned to Stock." D UL
I '$P($G(^PSRX(RXP,2)),"^",13) W !,$C(7),$C(7),"Rx # "_$P(^PSRX(RXP,0),"^")_" was NOT released !" D UL G BC
S PSOLOCRL=$P($G(^PSRX(RXP,2)),"^",13),PSOWHERE=$S($D(^PSRX("AR",+$G(PSOLOCRL),RXP,0)):1,1:0)
W ! S DIR("B")="YES",DIR("A",1)="Are you sure you want to RETURN TO STOCK Rx # "_$P(^PSRX(RXP,0),"^")
S DIR("A",2)="for "_$P(^DPT($P(^PSRX(RXP,0),"^",2),0),"^")_" ("_$E($P(^(0),"^",9),6,9)_")",DIR("A")="Drug: "_$P(^PSDRUG($P(^PSRX(RXP,0),"^",6),0),"^")
I $G(PSOWHERE) S DIR("A",3)=" ",DIR("A",4)=" *** This prescription was filled at the CMOP *** ",DIR("A",5)=" "
S DIR(0)="YO" D ^DIR K DIR I Y=0!($D(DIRUT)) D UL G BC
;ORI
D D UL,EX S (RESK,PSOPCECT)=1 G BC
.;PSO*7*374 - Prompt user about copay before updating the vault
.I +$G(^PSRX(RXP,"IB"))!($P($G(^PSRX(RXP,"PFS")),"^",2)) N PSOPFS S:$P($G(^PSRX(RXP,"PFS")),"^",2) PSOPFS="1^"_$P(^PSRX(RXP,"PFS"),"^",1,2) D CP^PSORESK1 Q:'$G(COPAYFLG)
.K PSOINVTX,PSODEFLG I $G(PSOWHERE),$G(^PSDRUG(QDRUG,660.1)) D INVT^PSORXDL I $G(PSODEFLG) W !!?5,"Prescription Not Returned to Stock!",! Q
.;VMP OIFO BAY PINES;PSO*7.0*196;KILL PSDS
.I $T(PSDRTS^PSDOPT0)]"" D PSDRTS^PSDOPT0(RXP,"O^"_0,$P(^PSRX(RXP,2),"^",9),$P(^PSRX(RXP,0),"^",7)) D MSG K PSDS
.Q:$G(RETSK)
.;
.;Ask comments until answered, do not allow exiting.
.F D I '$D(DIRUT) Q
..K DIR,DUOUT,DTOUT,DIRUT,X,Y
..S DIR(0)="F0^10:75",DIR("A")="Comments",DIR("?")="Comments are required, 10-75 characters."
..S DIR("B")=$S($D(PSODEF):PSODEF,1:"Per Pharmacy Request")
..D ^DIR I $D(DIRUT) W !?5,"Comments are required, 10-75 characters.",! Q
..S (PSODEF,COM)=$G(Y) K DIR,X,Y
..Q
.I $G(^PSDRUG(QDRUG,660.1)) D
..I $G(PSOWHERE),'$G(PSOINVTX) Q
..S ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)+QTY
.I $G(PSOWHERE) K ^PSRX("AR",+$G(PSOLOCRL),RXP,0)
.; - Preserving Original Fill data on the Return To Stock Log multiple
.D LOGRTS^PSORTSUT(RXP,0)
.;
.D NOW^%DTC S DA=RXP,DIE="^PSRX(",DR="31///@;32.1///"_% D ^DIE K DIE,DR,DA Q:$D(Y)
.D ACT^PSORESK1 S DA=$O(^PS(52.5,"B",RXP,0)) I DA S DIK="^PS(52.5," D ^DIK
.D REVERSE^PSOBPSU1(RXP,0,"RS",4,,1)
.D EN^PSOHDR("PRES",RXP) ;*332
.D EN^PSOHLSN1(RXP,"ZD")
.S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT ;PSO*7*368
.S ^XTMP("PSA",PSOSITE,+QDRUG,+DT)=$G(^XTMP("PSA",PSOSITE,+QDRUG,+DT))-QTY ;PSO*7*368
.W !,"Rx # "_$P(^PSRX(RXP,0),"^")_" Returned to Stock.",!
.Q
;
REF I $O(^PSRX(RXP,1,0)),$O(^PSRX(RXP,"P",0)) D I $D(DTOUT)!($D(DUOUT)) D UL G BC
.S DIR(0)="SA^R:REFILL;P:PARTIAL",DIR("B")="REFILL",DIR("A",1)="",DIR("A",2)="There are Refills and Partials for this Rx.",DIR("A")="Which are you Returning To Stock? "
.S DIR("?")=" Press return for Refill. Enter 'P' for Partial" D ^DIR K DIR
I $O(^PSRX(RXP,1,0)),$O(^PSRX(RXP,"P",0)) S XTYPE=$S(Y="R":1,1:"P")
PAR S:$G(XTYPE)']"" XTYPE=1 S TYPE=0 F YY=0:0 S YY=$O(^PSRX(RXP,XTYPE,YY)) Q:'YY S TYPE=YY
I 'TYPE D UL,EX S (RESK,PSOPCECT)=1 G BC
I $P($G(^PSRX(RXP,XTYPE,TYPE,0)),"^",16) W $C(7),!!,"Last Fill Already Returned to Stock !",! D UL,EX S (RESK,PSOPCECT)=1 G BC
I '$P(^PSRX(RXP,XTYPE,TYPE,0),"^",$S(XTYPE:18,1:19)) W !!,$C(7),$C(7),$S(XTYPE:"Refill",1:"PARTIAL")_" #"_TYPE_" was NOT released !",! D UL G BC
W ! K DIR,DUOUT,DTOUT
K PSOLOCRL,PSOWHERE I $G(XTYPE) S PSOLOCRL=$P($G(^PSRX(RXP,XTYPE,+$G(TYPE),0)),"^",18),PSOWHERE=$S($D(^PSRX("AR",+$G(PSOLOCRL),RXP,+$G(TYPE))):1,1:0)
W ! S DIR("B")="YES",DIR("A",1)="Are you sure you want to RETURN TO STOCK Rx # "_$P(^PSRX(RXP,0),"^")_$S(XTYPE:" Refill ",1:" Partial ")_"# "_TYPE,DIR(0)="Y"
S DIR("A",2)="for "_$P(^DPT($P(^PSRX(RXP,0),"^",2),0),"^")_" ("_$E($P(^(0),"^",9),6,9)_")",DIR("A")="Drug: "_$P(^PSDRUG($P(^PSRX(RXP,0),"^",6),0),"^")
I $G(PSOWHERE) S DIR("A",3)=" ",DIR("A",4)=" *** This prescription was filled at the CMOP *** ",DIR("A",5)=" "
D ^DIR K DIR I 'Y!($D(DUOUT))!($D(DTOUT)) D UL G BC
;
;PSO*7*374 - Prompt user about copay before updating the vault
I XTYPE I +$G(^PSRX(RXP,"IB"))!($P($G(^PSRX(RXP,1,TYPE,"PFS")),"^",2)) N PSOPFS S:$P($G(^PSRX(RXP,1,TYPE,"PFS")),"^",2) PSOPFS="1^"_$P(^PSRX(RXP,1,TYPE,"PFS"),"^",1,2) D CP^PSORESK1 I '$G(COPAYFLG) D UL G BC
K PSOINVTX,PSODEFLG I $G(PSOWHERE),$G(^PSDRUG(QDRUG,660.1)) D INVT^PSORXDL I $G(PSODEFLG) W !!?5,"Prescription Not Returned to Stock!",! D UL G BC
I $T(PSDRTS^PSDOPT0)]"" D
.;VMP OIFO BAY PINES;PSO*7.0*196;KILL PSDS
.I XTYPE D PSDRTS^PSDOPT0(RXP,"R^"_TYPE,$P(^PSRX(RXP,1,TYPE,0),"^",9),$P(^(0),"^",4)) D MSG K PSDS Q
.D PSDRTS^PSDOPT0(RXP,"P^"_TYPE,$P(^PSRX(RXP,"P",TYPE,0),"^",9),$P(^(0),"^",4)) D MSG K PSDS
I $G(RETSK) D UL,EX G BC
;Ask comments until answered, do not allow exiting.
F D I '$D(DIRUT) Q
.K DIR,DIRUT,DTOUT,DUOUT,X,Y
.S DIR(0)="F0^10:75",DIR("A")="Comments",DIR("?")="Comments are required, 10-75 characters."
.S DIR("B")=$S($D(PSODEF):PSODEF,1:"Per Pharmacy Request")
.D ^DIR K DIR I $D(DIRUT) W !?5,"Comments are required, 10-75 characters.",! Q
.Q
S (PSODEF,COM)=$G(Y) K X,Y
D NOW^%DTC S QTY=$P(^PSRX(RXP,XTYPE,TYPE,0),"^",4) I $G(^PSDRUG(QDRUG,660.1)) D
.I $G(PSOWHERE),'$G(PSOINVTX) Q
.S ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)+$G(QTY)
I $G(PSOWHERE) K ^PSRX("AR",+$G(PSOLOCRL),RXP,$G(TYPE))
I XTYPE D REVERSE^PSOBPSU1(RXP,TYPE,"RS",4,,1)
;
; - Preserving Refill/Partial data on the Return To Stock Log multiple
D LOGRTS^PSORTSUT(RXP,$S(XTYPE:TYPE,1:"P"_TYPE))
;
;save release dates in case can't perform the delete of .01 *259
S:XTYPE SVRELDT=$P(^PSRX(RXP,XTYPE,TYPE,0),"^",18)
S:'XTYPE SVRELDT=$P(^PSRX(RXP,XTYPE,TYPE,0),"^",19)
;
;del rel date 1st and then attempt to del .01 field
S DA(1)=RXP,DA=TYPE,DIE="^PSRX("_DA(1)_","_$S(XTYPE:1,1:"""P""")_",",DR=$S(XTYPE:"17////@",1:"8////@")_";.01///@"
W ! D ^DIE
;
;if node still exists then fileman could not delete .01 *259
I $D(^PSRX(RXP,XTYPE,TYPE,0)) D G BC
. W " - Not Returned!"
. S DA(1)=RXP,DA=TYPE,DIE="^PSRX("_DA(1)_","_$S(XTYPE:1,1:"""P""")_","
. S DR=$S(XTYPE:"17////",1:"8////")_SVRELDT ;put back saved rel dte
. D ^DIE,UL
;
;fall thru and perform RTS for refills/partials
D:XTYPE'="P" NPF D ACT^PSORESK1
S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT ;PSO*7*368
S ^XTMP("PSA",PSOSITE,+QDRUG,+DT)=$G(^XTMP("PSA",PSOSITE,+QDRUG,+DT))-QTY ;PSO*7*368
W !!,"Rx # "_$P(^PSRX(RXP,0),"^")_$S(XTYPE:" REFILL",1:" PARTIAL")_" #"_TYPE_" Returned to Stock" S DA=$O(^PS(52.5,"B",RXP,0)) I DA S DIK="^PS(52.5," D ^DIK
K PSODISPP S:'XTYPE PSODISPP=1 D EN^PSOHDR("PRES",RXP) D EN^PSOHLSN1(RXP,"ZD") K PSODISPP ;*332
D UL G BC
EX ;
K DA,DR,DIE,X,X1,X2,Y,RXP,REC,DIR,XDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,YY,QDRUG,QTY,TYPE,XTYPE,I,%,DIRUT,COPAYFLG,PSOINVTX,RESK,PSOPCECT,COM,PSOWHERE,PSOLOCRL,PSODEFLG,PSORRDFN,PSOMSG,PSOPLCK,PSDCS,PSDRS,RETSK
K DIC,DIK,PSOPFS
Q
MSG I $G(PSDCS),'$G(PSDRS) W !!,"The PSDMGR key is required to return a CONTROLLED SUBSTANCE Rx to stock and",!,"update corresponding vault balances." S RETSK=1
Q
BCI S RXP=0
RXP S RXP=$O(^PSRX("B",X,RXP)) I $P($G(^PSRX(+RXP,"STA")),"^")=13 G RXP
Q
UL ;
I $G(RXP) D PSOUL^PSSLOCK(RXP)
D UL^PSSLOCK(+$G(PSORRDFN))
Q
NPF N PSOY I $G(TYPE)-1>0,+$P(^PSRX(RXP,1,TYPE-1,0),"^") D
.S X1=+$P(^PSRX(RXP,1,$G(TYPE)-1,0),"^"),X2=$P(^PSRX(RXP,0),"^",8)-10\1
.D C^%DTC S PSOY=X,X1=$P(^PSRX(RXP,2),"^",2),X2=TYPE*$P(^PSRX(RXP,0),"^",8)-10\1
.D C^%DTC S X=$S(PSOY<X:X,1:PSOY)
I $G(TYPE)-1<1 D
.S X1=$P(^PSRX(RXP,2),"^",2),X2=$P(^PSRX(RXP,0),"^",8)-10\1
.D C^%DTC S:$P(^PSRX(RXP,3),"^",8) X=""
I $G(X) S DA=RXP,DIE=52,DR="102///"_X D ^DIE K DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORESK 10090 printed Dec 13, 2024@02:33:50 Page 2
PSORESK ;BIR/SAB-return to stock ; 8/12/11 12:34pm
+1 ;;7.0;OUTPATIENT PHARMACY;**15,9,27,40,47,55,85,130,185,184,196,148,201,259,261,368,332,374,408**;DEC 1997;Build 100
+2 ;
+3 ;REF/IA
+4 ;^PSDRUG/221
+5 ;^PS(59.7/694
+6 ;L, UL, PSOL, and PSOUL^PSSLOCK/2789
+7 ;^PS(55/2228
+8 ;PSDRTS^PSDOPT0/3064
+9 ;
+10 ;External reference ^XTMP("PSA" supported by DBIA 1036
+11 ;
+12 ;*259 - if refill was Not deleted, then stop RTS from continuing
+13 ;
AC IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE !!,"Outpatient Pharmacy Site Parameters are required!"
QUIT
+1 SET RESK=1
KILL PSODEF,^UTILITY($JOB,"PSOPCE")
SET PSOPCECT=1
BC KILL PSOWHERE,PSODEFLG,PSOINVTX,XTYPE
WRITE !!
SET DIR("A")="Enter/Wand PRESCRIPTION number"
SET DIR("?")="^D HP^PSORESK1"
SET DIR(0)="FO"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
KILL PSODEF
GOTO EX
+1 IF X'["-"
DO BCI
if '$GET(RXP)
WRITE !,"INVALID Rx"
if '$GET(RXP)
GOTO BC
GOTO BC1
+2 IF X["-"
Begin DoDot:1
+3 KILL PSORESST
SET PSORESSX=$GET(X)
KILL PSORESAR
SET DA=$PIECE($$SITE^VASITE(),"^")
IF $GET(DA)
SET DIC=4
SET DIQ(0)="I"
SET DIQ="PSORESAR"
SET DR="99"
DO EN^DIQ1
SET PSORESST=$GET(PSORESAR(4,DA,99,"I"))
KILL PSORESAR,DIQ,DA,DR
SET X=$GET(PSORESSX)
KILL PSORESSX
End DoDot:1
IF $PIECE(X,"-")'=$GET(PSORESST)
WRITE !,$CHAR(7),$CHAR(7)," INVALID STATION NUMBER !!",$CHAR(7),$CHAR(7),!
KILL PSORESST
GOTO BC
+4 IF X["-"
SET RXP=$PIECE(X,"-",2)
IF '$DATA(^PSRX(+$GET(RXP),0))!($GET(RXP)']"")
WRITE !,$CHAR(7),$CHAR(7),$CHAR(7)," NON-EXISTENT Rx"
GOTO BC
+5 if $DATA(^PSRX(RXP,0))
GOTO BC1
WRITE !,$CHAR(7),$CHAR(7),$CHAR(7)," IMPROPER BARCODE FORMAT"
GOTO BC
BC1 ;
+1 SET PSORRDFN=+$PIECE($GET(^PSRX(RXP,0)),"^",2)
+2 DO ICN^PSODPT(PSORRDFN)
+3 SET PSOPLCK=$$L^PSSLOCK(PSORRDFN,0)
IF '$GET(PSOPLCK)
DO LOCK^PSOORCPY
KILL PSOPLCK
GOTO BC
+4 KILL PSOPLCK
DO PSOL^PSSLOCK(RXP)
IF '$GET(PSOMSG)
WRITE !!,$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order."),!
KILL PSOMSG
DO UL^PSSLOCK(+$GET(PSORRDFN))
GOTO BC
+5 SET PSOLOUD=1
if $PIECE($GET(^PS(55,+$PIECE(^PSRX(RXP,0),"^",2),0)),"^",6)'=2
DO EN^PSOHLUP($PIECE(^PSRX(RXP,0),"^",2))
KILL PSOLOUD
+6 IF $SELECT('+$PIECE($GET(^PSRX(+RXP,"STA")),"^"):0,$PIECE(^("STA"),"^")=11:0,$PIECE(^("STA"),"^")=12:0,$PIECE(^("STA"),"^")=14:0,$PIECE(^("STA"),"^")=15:0,1:1)
DO STAT^PSORESK1
DO UL
GOTO BC
+7 SET COPAYFLG=1
SET QDRUG=$PIECE($GET(^PSRX(RXP,0)),"^",6)
SET QTY=$PIECE($GET(^(0)),"^",7)
IF $ORDER(^PSRX(RXP,1,0))
GOTO REF
+8 SET Y="O"
IF $ORDER(^PSRX(RXP,"P",0))
Begin DoDot:1
+9 SET DIR(0)="SA^O:ORIGINAL;P:PARTIAL"
SET DIR("B")="ORIGINAL"
SET DIR("A",1)=""
SET DIR("A",2)="There are Partials for this Rx."
SET DIR("A")="Which are you Returning To Stock? "
+10 SET DIR("?")=" Press return for Original. Enter 'P' for Partial"
DO ^DIR
KILL DIR
End DoDot:1
IF $DATA(DUOUT)!($DATA(DTOUT))
DO UL
GOTO BC
+11 SET XTYPE=$SELECT(Y="O":"O",1:"P")
if Y="P"
GOTO PAR
+12 IF $PIECE($GET(^PSRX(RXP,2)),"^",15)
Begin DoDot:1
+13 WRITE !,$CHAR(7),$CHAR(7),"Original fill for Rx # "_$PIECE(^PSRX(RXP,0),"^")_" was Returned to Stock."
DO UL
End DoDot:1
GOTO BC
+14 IF '$PIECE($GET(^PSRX(RXP,2)),"^",13)
WRITE !,$CHAR(7),$CHAR(7),"Rx # "_$PIECE(^PSRX(RXP,0),"^")_" was NOT released !"
DO UL
GOTO BC
+15 SET PSOLOCRL=$PIECE($GET(^PSRX(RXP,2)),"^",13)
SET PSOWHERE=$SELECT($DATA(^PSRX("AR",+$GET(PSOLOCRL),RXP,0)):1,1:0)
+16 WRITE !
SET DIR("B")="YES"
SET DIR("A",1)="Are you sure you want to RETURN TO STOCK Rx # "_$PIECE(^PSRX(RXP,0),"^")
+17 SET DIR("A",2)="for "_$PIECE(^DPT($PIECE(^PSRX(RXP,0),"^",2),0),"^")_" ("_$EXTRACT($PIECE(^(0),"^",9),6,9)_")"
SET DIR("A")="Drug: "_$PIECE(^PSDRUG($PIECE(^PSRX(RXP,0),"^",6),0),"^")
+18 IF $GET(PSOWHERE)
SET DIR("A",3)=" "
SET DIR("A",4)=" *** This prescription was filled at the CMOP *** "
SET DIR("A",5)=" "
+19 SET DIR(0)="YO"
DO ^DIR
KILL DIR
IF Y=0!($DATA(DIRUT))
DO UL
GOTO BC
+20 ;ORI
+21 Begin DoDot:1
+22 ;PSO*7*374 - Prompt user about copay before updating the vault
+23 IF +$GET(^PSRX(RXP,"IB"))!($PIECE($GET(^PSRX(RXP,"PFS")),"^",2))
NEW PSOPFS
if $PIECE($GET(^PSRX(RXP,"PFS")),"^",2)
SET PSOPFS="1^"_$PIECE(^PSRX(RXP,"PFS"),"^",1,2)
DO CP^PSORESK1
if '$GET(COPAYFLG)
QUIT
+24 KILL PSOINVTX,PSODEFLG
IF $GET(PSOWHERE)
IF $GET(^PSDRUG(QDRUG,660.1))
DO INVT^PSORXDL
IF $GET(PSODEFLG)
WRITE !!?5,"Prescription Not Returned to Stock!",!
QUIT
+25 ;VMP OIFO BAY PINES;PSO*7.0*196;KILL PSDS
+26 IF $TEXT(PSDRTS^PSDOPT0)]""
DO PSDRTS^PSDOPT0(RXP,"O^"_0,$PIECE(^PSRX(RXP,2),"^",9),$PIECE(^PSRX(RXP,0),"^",7))
DO MSG
KILL PSDS
+27 if $GET(RETSK)
QUIT
+28 ;
+29 ;Ask comments until answered, do not allow exiting.
+30 FOR
Begin DoDot:2
+31 KILL DIR,DUOUT,DTOUT,DIRUT,X,Y
+32 SET DIR(0)="F0^10:75"
SET DIR("A")="Comments"
SET DIR("?")="Comments are required, 10-75 characters."
+33 SET DIR("B")=$SELECT($DATA(PSODEF):PSODEF,1:"Per Pharmacy Request")
+34 DO ^DIR
IF $DATA(DIRUT)
WRITE !?5,"Comments are required, 10-75 characters.",!
QUIT
+35 SET (PSODEF,COM)=$GET(Y)
KILL DIR,X,Y
+36 QUIT
End DoDot:2
IF '$DATA(DIRUT)
QUIT
+37 IF $GET(^PSDRUG(QDRUG,660.1))
Begin DoDot:2
+38 IF $GET(PSOWHERE)
IF '$GET(PSOINVTX)
QUIT
+39 SET ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)+QTY
End DoDot:2
+40 IF $GET(PSOWHERE)
KILL ^PSRX("AR",+$GET(PSOLOCRL),RXP,0)
+41 ; - Preserving Original Fill data on the Return To Stock Log multiple
+42 DO LOGRTS^PSORTSUT(RXP,0)
+43 ;
+44 DO NOW^%DTC
SET DA=RXP
SET DIE="^PSRX("
SET DR="31///@;32.1///"_%
DO ^DIE
KILL DIE,DR,DA
if $DATA(Y)
QUIT
+45 DO ACT^PSORESK1
SET DA=$ORDER(^PS(52.5,"B",RXP,0))
IF DA
SET DIK="^PS(52.5,"
DO ^DIK
+46 DO REVERSE^PSOBPSU1(RXP,0,"RS",4,,1)
+47 ;*332
DO EN^PSOHDR("PRES",RXP)
+48 DO EN^PSOHLSN1(RXP,"ZD")
+49 ;PSO*7*368
if '$PIECE($GET(^XTMP("PSA",0)),U,2)
SET $PIECE(^(0),U,2)=DT
+50 ;PSO*7*368
SET ^XTMP("PSA",PSOSITE,+QDRUG,+DT)=$GET(^XTMP("PSA",PSOSITE,+QDRUG,+DT))-QTY
+51 WRITE !,"Rx # "_$PIECE(^PSRX(RXP,0),"^")_" Returned to Stock.",!
+52 QUIT
End DoDot:1
DO UL
DO EX
SET (RESK,PSOPCECT)=1
GOTO BC
+53 ;
REF IF $ORDER(^PSRX(RXP,1,0))
IF $ORDER(^PSRX(RXP,"P",0))
Begin DoDot:1
+1 SET DIR(0)="SA^R:REFILL;P:PARTIAL"
SET DIR("B")="REFILL"
SET DIR("A",1)=""
SET DIR("A",2)="There are Refills and Partials for this Rx."
SET DIR("A")="Which are you Returning To Stock? "
+2 SET DIR("?")=" Press return for Refill. Enter 'P' for Partial"
DO ^DIR
KILL DIR
End DoDot:1
IF $DATA(DTOUT)!($DATA(DUOUT))
DO UL
GOTO BC
+3 IF $ORDER(^PSRX(RXP,1,0))
IF $ORDER(^PSRX(RXP,"P",0))
SET XTYPE=$SELECT(Y="R":1,1:"P")
PAR if $GET(XTYPE)']""
SET XTYPE=1
SET TYPE=0
FOR YY=0:0
SET YY=$ORDER(^PSRX(RXP,XTYPE,YY))
if 'YY
QUIT
SET TYPE=YY
+1 IF 'TYPE
DO UL
DO EX
SET (RESK,PSOPCECT)=1
GOTO BC
+2 IF $PIECE($GET(^PSRX(RXP,XTYPE,TYPE,0)),"^",16)
WRITE $CHAR(7),!!,"Last Fill Already Returned to Stock !",!
DO UL
DO EX
SET (RESK,PSOPCECT)=1
GOTO BC
+3 IF '$PIECE(^PSRX(RXP,XTYPE,TYPE,0),"^",$SELECT(XTYPE:18,1:19))
WRITE !!,$CHAR(7),$CHAR(7),$SELECT(XTYPE:"Refill",1:"PARTIAL")_" #"_TYPE_" was NOT released !",!
DO UL
GOTO BC
+4 WRITE !
KILL DIR,DUOUT,DTOUT
+5 KILL PSOLOCRL,PSOWHERE
IF $GET(XTYPE)
SET PSOLOCRL=$PIECE($GET(^PSRX(RXP,XTYPE,+$GET(TYPE),0)),"^",18)
SET PSOWHERE=$SELECT($DATA(^PSRX("AR",+$GET(PSOLOCRL),RXP,+$GET(TYPE))):1,1:0)
+6 WRITE !
SET DIR("B")="YES"
SET DIR("A",1)="Are you sure you want to RETURN TO STOCK Rx # "_$PIECE(^PSRX(RXP,0),"^")_$SELECT(XTYPE:" Refill ",1:" Partial ")_"# "_TYPE
SET DIR(0)="Y"
+7 SET DIR("A",2)="for "_$PIECE(^DPT($PIECE(^PSRX(RXP,0),"^",2),0),"^")_" ("_$EXTRACT($PIECE(^(0),"^",9),6,9)_")"
SET DIR("A")="Drug: "_$PIECE(^PSDRUG($PIECE(^PSRX(RXP,0),"^",6),0),"^")
+8 IF $GET(PSOWHERE)
SET DIR("A",3)=" "
SET DIR("A",4)=" *** This prescription was filled at the CMOP *** "
SET DIR("A",5)=" "
+9 DO ^DIR
KILL DIR
IF 'Y!($DATA(DUOUT))!($DATA(DTOUT))
DO UL
GOTO BC
+10 ;
+11 ;PSO*7*374 - Prompt user about copay before updating the vault
+12 IF XTYPE
IF +$GET(^PSRX(RXP,"IB"))!($PIECE($GET(^PSRX(RXP,1,TYPE,"PFS")),"^",2))
NEW PSOPFS
if $PIECE($GET(^PSRX(RXP,1,TYPE,"PFS")),"^",2)
SET PSOPFS="1^"_$PIECE(^PSRX(RXP,1,TYPE,"PFS"),"^",1,2)
DO CP^PSORESK1
IF '$GET(COPAYFLG)
DO UL
GOTO BC
+13 KILL PSOINVTX,PSODEFLG
IF $GET(PSOWHERE)
IF $GET(^PSDRUG(QDRUG,660.1))
DO INVT^PSORXDL
IF $GET(PSODEFLG)
WRITE !!?5,"Prescription Not Returned to Stock!",!
DO UL
GOTO BC
+14 IF $TEXT(PSDRTS^PSDOPT0)]""
Begin DoDot:1
+15 ;VMP OIFO BAY PINES;PSO*7.0*196;KILL PSDS
+16 IF XTYPE
DO PSDRTS^PSDOPT0(RXP,"R^"_TYPE,$PIECE(^PSRX(RXP,1,TYPE,0),"^",9),$PIECE(^(0),"^",4))
DO MSG
KILL PSDS
QUIT
+17 DO PSDRTS^PSDOPT0(RXP,"P^"_TYPE,$PIECE(^PSRX(RXP,"P",TYPE,0),"^",9),$PIECE(^(0),"^",4))
DO MSG
KILL PSDS
End DoDot:1
+18 IF $GET(RETSK)
DO UL
DO EX
GOTO BC
+19 ;Ask comments until answered, do not allow exiting.
+20 FOR
Begin DoDot:1
+21 KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
+22 SET DIR(0)="F0^10:75"
SET DIR("A")="Comments"
SET DIR("?")="Comments are required, 10-75 characters."
+23 SET DIR("B")=$SELECT($DATA(PSODEF):PSODEF,1:"Per Pharmacy Request")
+24 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
WRITE !?5,"Comments are required, 10-75 characters.",!
QUIT
+25 QUIT
End DoDot:1
IF '$DATA(DIRUT)
QUIT
+26 SET (PSODEF,COM)=$GET(Y)
KILL X,Y
+27 DO NOW^%DTC
SET QTY=$PIECE(^PSRX(RXP,XTYPE,TYPE,0),"^",4)
IF $GET(^PSDRUG(QDRUG,660.1))
Begin DoDot:1
+28 IF $GET(PSOWHERE)
IF '$GET(PSOINVTX)
QUIT
+29 SET ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)+$GET(QTY)
End DoDot:1
+30 IF $GET(PSOWHERE)
KILL ^PSRX("AR",+$GET(PSOLOCRL),RXP,$GET(TYPE))
+31 IF XTYPE
DO REVERSE^PSOBPSU1(RXP,TYPE,"RS",4,,1)
+32 ;
+33 ; - Preserving Refill/Partial data on the Return To Stock Log multiple
+34 DO LOGRTS^PSORTSUT(RXP,$SELECT(XTYPE:TYPE,1:"P"_TYPE))
+35 ;
+36 ;save release dates in case can't perform the delete of .01 *259
+37 if XTYPE
SET SVRELDT=$PIECE(^PSRX(RXP,XTYPE,TYPE,0),"^",18)
+38 if 'XTYPE
SET SVRELDT=$PIECE(^PSRX(RXP,XTYPE,TYPE,0),"^",19)
+39 ;
+40 ;del rel date 1st and then attempt to del .01 field
+41 SET DA(1)=RXP
SET DA=TYPE
SET DIE="^PSRX("_DA(1)_","_$SELECT(XTYPE:1,1:"""P""")_","
SET DR=$SELECT(XTYPE:"17////@",1:"8////@")_";.01///@"
+42 WRITE !
DO ^DIE
+43 ;
+44 ;if node still exists then fileman could not delete .01 *259
+45 IF $DATA(^PSRX(RXP,XTYPE,TYPE,0))
Begin DoDot:1
+46 WRITE " - Not Returned!"
+47 SET DA(1)=RXP
SET DA=TYPE
SET DIE="^PSRX("_DA(1)_","_$SELECT(XTYPE:1,1:"""P""")_","
+48 ;put back saved rel dte
SET DR=$SELECT(XTYPE:"17////",1:"8////")_SVRELDT
+49 DO ^DIE
DO UL
End DoDot:1
GOTO BC
+50 ;
+51 ;fall thru and perform RTS for refills/partials
+52 if XTYPE'="P"
DO NPF
DO ACT^PSORESK1
+53 ;PSO*7*368
if '$PIECE($GET(^XTMP("PSA",0)),U,2)
SET $PIECE(^(0),U,2)=DT
+54 ;PSO*7*368
SET ^XTMP("PSA",PSOSITE,+QDRUG,+DT)=$GET(^XTMP("PSA",PSOSITE,+QDRUG,+DT))-QTY
+55 WRITE !!,"Rx # "_$PIECE(^PSRX(RXP,0),"^")_$SELECT(XTYPE:" REFILL",1:" PARTIAL")_" #"_TYPE_" Returned to Stock"
SET DA=$ORDER(^PS(52.5,"B",RXP,0))
IF DA
SET DIK="^PS(52.5,"
DO ^DIK
+56 ;*332
KILL PSODISPP
if 'XTYPE
SET PSODISPP=1
DO EN^PSOHDR("PRES",RXP)
DO EN^PSOHLSN1(RXP,"ZD")
KILL PSODISPP
+57 DO UL
GOTO BC
EX ;
+1 KILL DA,DR,DIE,X,X1,X2,Y,RXP,REC,DIR,XDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,YY,QDRUG,QTY,TYPE,XTYPE,I,%,DIRUT,COPAYFLG,PSOINVTX,RESK,PSOPCECT,COM,PSOWHERE,PSOLOCRL,PSODEFLG,PSORRDFN,PSOMSG,PSOPLCK,PSDCS,PSDRS,RETSK
+2 KILL DIC,DIK,PSOPFS
+3 QUIT
MSG IF $GET(PSDCS)
IF '$GET(PSDRS)
WRITE !!,"The PSDMGR key is required to return a CONTROLLED SUBSTANCE Rx to stock and",!,"update corresponding vault balances."
SET RETSK=1
+1 QUIT
BCI SET RXP=0
RXP SET RXP=$ORDER(^PSRX("B",X,RXP))
IF $PIECE($GET(^PSRX(+RXP,"STA")),"^")=13
GOTO RXP
+1 QUIT
UL ;
+1 IF $GET(RXP)
DO PSOUL^PSSLOCK(RXP)
+2 DO UL^PSSLOCK(+$GET(PSORRDFN))
+3 QUIT
NPF NEW PSOY
IF $GET(TYPE)-1>0
IF +$PIECE(^PSRX(RXP,1,TYPE-1,0),"^")
Begin DoDot:1
+1 SET X1=+$PIECE(^PSRX(RXP,1,$GET(TYPE)-1,0),"^")
SET X2=$PIECE(^PSRX(RXP,0),"^",8)-10\1
+2 DO C^%DTC
SET PSOY=X
SET X1=$PIECE(^PSRX(RXP,2),"^",2)
SET X2=TYPE*$PIECE(^PSRX(RXP,0),"^",8)-10\1
+3 DO C^%DTC
SET X=$SELECT(PSOY<X:X,1:PSOY)
End DoDot:1
+4 IF $GET(TYPE)-1<1
Begin DoDot:1
+5 SET X1=$PIECE(^PSRX(RXP,2),"^",2)
SET X2=$PIECE(^PSRX(RXP,0),"^",8)-10\1
+6 DO C^%DTC
if $PIECE(^PSRX(RXP,3),"^",8)
SET X=""
End DoDot:1
+7 IF $GET(X)
SET DA=RXP
SET DIE=52
SET DR="102///"_X
DO ^DIE
KILL DIE
+8 QUIT
