PSORESK ;BIR/SAB-return to stock ;14-Nov-2017 14:48;DU
;;7.0;OUTPATIENT PHARMACY;**15,9,27,40,47,55,85,130,1002,1006,1007,185,184,196,148,201,259,261,1014,1015,1018,1022**;DEC 1997;Build 20
;
; Modified - IHS/CIA/PLS - 03/31/04 - Lines BC1+35 and PAR+30
; 12/07/04 - New RXLKUP entry point
; Line RXP
; IHS/MSC/PLS - 10/18/07 - BC1+1 -Outside Pharmacy
; 08/21/08 - Added additional parameter to CALLPOS calls.
; 04/06/12 - Line RXLKUP+2
; IHS/MSC/PB 03/26/13 - Added lines BC1+43 and BC1+44 to update expiration date to the issue date
; IHS/MSC/MGH 01/07/14 - Added call to $$CHECK^PSORESK1
; IHS/MSC/PLS 10/02/17 - Added logic to set STATUS to active if expiration date exceeds today
;REF/IA
;^PSDRUG/221
;^PS(59.7/694
;L, UL, PSOL, and PSOUL^PSSLOCK/2789
;^PS(55/2228
;PSDRTS^PSDOPT0/3064
;
;*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 ;
;IHS/MSC/PLS - 10/18/07
I $P($G(^PSRX(RXP,999999921)),U,3) D G BC
.W !,"Outside Pharmacy prescriptions can't be returned to stock!"
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
.;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)
.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
.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)
.;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)
.;MSC/IHS/PB - 3/1/13 Added the next two lines to update the expiration date to the issue date if the rts is an original
.;IHS/MSC/MGH - 01/07/13 - Change the call to get expiration date
.S ISDT=$P(^PSRX(RXP,0),"^",13)
.I $G(ISDT)'="" D NOW^%DTC S DA=RXP,DIE="^PSRX(",DR="26////"_$$CHECK^PSORESK1(RXP)_";31///@;32.1///"_% D ^DIE K DIE,DR,DA ;Q:$D(Y)
.D NOW^%DTC S DA=RXP,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
.I $$GET1^DIQ(52,RXP,26,"I")>$G(DT) D ;IHS/MSC/PLS - 10/2/2017 P1022
..N STATUS
..S STATUS=+$P($G(^PSRX(RXP,"STA")),U)
..Q:STATUS=0 ;Already active
..Q:STATUS'=11 ;Must be expired
..N DIE,DA,DR
..S DA=RXP,DIE="^PSRX(",DR="100///0" D ^DIE
.D CALLPOS^APSPFUNC(RXP,"","D","Returned to stock.") ; IHS/CIA/PLS - 03/31/04
.D REVERSE^PSOBPSU1(RXP,0,"RS",4,,1)
.D EN^PSOHLSN1(RXP,"ZD") 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
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
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 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
;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)
;
;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
N ISDT
S ISDT=$P(^PSRX(RXP,0),"^",13)
I $G(ISDT)'="" D
.S DA=RXP,DIE="^PSRX(",DR="26///"_$$CHECK^PSORESK1(RXP) D ^DIE K DIE,DR,DA ;IHS/MSC/MGH - 01/07/14 - Change the expiration date if necessary
I $$GET1^DIQ(52,RXP,26,"I")>$G(DT) D ;IHS/MSC/PLS - 10/2/2017 P1022
.N STATUS
.S STATUS=+$P($G(^PSRX(RXP,"STA")),U)
.Q:STATUS=0 ;Already active
.Q:STATUS'=11 ;Must be expired
.N DIE,DA,DR
.S DA=RXP,DIE="^PSRX(",DR="100///0" D ^DIE
D CALLPOS^APSPFUNC(RXP,$S(TYPE:TYPE,1:""),"D","Returned to stock.") ; IHS/CIA/PLS - 03/31/04 - Call POS Hook
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:XTYPE EN^PSOHDR("PRES",RXP) D EN^PSOHLSN1(RXP,"ZD") K PSODISPP
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
; IHS/CIA/PLS - 12/07/04 - Change lookup to Extrinsic call
RXP ;S RXP=$O(^PSRX("B",X,RXP)) I $P($G(^PSRX(+RXP,"STA")),"^")=13 G RXP
S RXP=$$RXLKUP(X)
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
; IHS/CIA/PLS - 12/07/04
; IHS/MSC/PLS - 04/06/12 - Added parameter and condition
; Perform lookup given partial or full prescription number.
; Screen allows non-deleted scripts and scripts for user selected division.
RXLKUP(X) ; EP
N DIC,Y
I $$GET^XPAR("ALL","APSP ALLOW RTS FROM ANY RX DIV") D
.S DIC("S")="I $P($G(^(""STA"")),U)'=13"
E S DIC("S")="I $P($G(^(2)),U,9)=PSOSITE&($P($G(^(""STA"")),""^"")'=13)"
S DIC(0)="EMQZ",DIC="^PSRX(" D ^DIC
Q $S(+Y>0:+Y,1:0)
PSORESK ;BIR/SAB-return to stock ;14-Nov-2017 14:48;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**15,9,27,40,47,55,85,130,1002,1006,1007,185,184,196,148,201,259,261,1014,1015,1018,1022**;DEC 1997;Build 20
+2 ;
+3 ; Modified - IHS/CIA/PLS - 03/31/04 - Lines BC1+35 and PAR+30
+4 ; 12/07/04 - New RXLKUP entry point
+5 ; Line RXP
+6 ; IHS/MSC/PLS - 10/18/07 - BC1+1 -Outside Pharmacy
+7 ; 08/21/08 - Added additional parameter to CALLPOS calls.
+8 ; 04/06/12 - Line RXLKUP+2
+9 ; IHS/MSC/PB 03/26/13 - Added lines BC1+43 and BC1+44 to update expiration date to the issue date
+10 ; IHS/MSC/MGH 01/07/14 - Added call to $$CHECK^PSORESK1
+11 ; IHS/MSC/PLS 10/02/17 - Added logic to set STATUS to active if expiration date exceeds today
+12 ;REF/IA
+13 ;^PSDRUG/221
+14 ;^PS(59.7/694
+15 ;L, UL, PSOL, and PSOUL^PSSLOCK/2789
+16 ;^PS(55/2228
+17 ;PSDRTS^PSDOPT0/3064
+18 ;
+19 ;*259 - if refill was Not deleted, then stop RTS from continuing
+20 ;
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 ;IHS/MSC/PLS - 10/18/07
+2 IF $PIECE($GET(^PSRX(RXP,999999921)),U,3)
Begin DoDot:1
+3 WRITE !,"Outside Pharmacy prescriptions can't be returned to stock!"
End DoDot:1
GOTO BC
+4 SET PSORRDFN=+$PIECE($GET(^PSRX(RXP,0)),"^",2)
+5 DO ICN^PSODPT(PSORRDFN)
+6 SET PSOPLCK=$$L^PSSLOCK(PSORRDFN,0)
IF '$GET(PSOPLCK)
DO LOCK^PSOORCPY
KILL PSOPLCK
GOTO BC
+7 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
+8 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
+9 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
+10 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
+11 SET Y="O"
IF $ORDER(^PSRX(RXP,"P",0))
Begin DoDot:1
+12 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? "
+13 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
+14 SET XTYPE=$SELECT(Y="O":"O",1:"P")
IF Y="P"
GOTO PAR
+15 IF $PIECE($GET(^PSRX(RXP,2)),"^",15)
Begin DoDot:1
+16 WRITE !,$CHAR(7),$CHAR(7),"Original fill for Rx # "_$PIECE(^PSRX(RXP,0),"^")_" was Returned to Stock."
DO UL
End DoDot:1
GOTO BC
+17 IF '$PIECE($GET(^PSRX(RXP,2)),"^",13)
WRITE !,$CHAR(7),$CHAR(7),"Rx # "_$PIECE(^PSRX(RXP,0),"^")_" was NOT released !"
DO UL
GOTO BC
+18 SET PSOLOCRL=$PIECE($GET(^PSRX(RXP,2)),"^",13)
SET PSOWHERE=$SELECT($DATA(^PSRX("AR",+$GET(PSOLOCRL),RXP,0)):1,1:0)
+19 WRITE !
SET DIR("B")="YES"
SET DIR("A",1)="Are you sure you want to RETURN TO STOCK Rx # "_$PIECE(^PSRX(RXP,0),"^")
+20 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),"^")
+21 IF $GET(PSOWHERE)
SET DIR("A",3)=" "
SET DIR("A",4)=" *** This prescription was filled at the CMOP *** "
SET DIR("A",5)=" "
+22 SET DIR(0)="YO"
DO ^DIR
KILL DIR
IF Y=0!($DATA(DIRUT))
DO UL
GOTO BC
+23 ;ORI
+24 Begin DoDot:1
+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 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
+29 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
+30 ;Ask comments until answered, do not allow exiting.
+31 FOR
Begin DoDot:2
+32 KILL DIR,DUOUT,DTOUT,DIRUT,X,Y
+33 SET DIR(0)="F0^10:75"
SET DIR("A")="Comments"
SET DIR("?")="Comments are required, 10-75 characters."
+34 SET DIR("B")=$SELECT($DATA(PSODEF):PSODEF,1:"Per Pharmacy Request")
+35 DO ^DIR
IF $DATA(DIRUT)
WRITE !?5,"Comments are required, 10-75 characters.",!
QUIT
+36 SET (PSODEF,COM)=$GET(Y)
KILL DIR,X,Y
+37 QUIT
End DoDot:2
IF '$DATA(DIRUT)
QUIT
+38 IF $GET(^PSDRUG(QDRUG,660.1))
Begin DoDot:2
+39 IF $GET(PSOWHERE)
IF '$GET(PSOINVTX)
QUIT
+40 SET ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)+QTY
End DoDot:2
+41 IF $GET(PSOWHERE)
KILL ^PSRX("AR",+$GET(PSOLOCRL),RXP,0)
+42 ;MSC/IHS/PB - 3/1/13 Added the next two lines to update the expiration date to the issue date if the rts is an original
+43 ;IHS/MSC/MGH - 01/07/13 - Change the call to get expiration date
+44 SET ISDT=$PIECE(^PSRX(RXP,0),"^",13)
+45 ;Q:$D(Y)
IF $GET(ISDT)'=""
DO NOW^%DTC
SET DA=RXP
SET DIE="^PSRX("
SET DR="26////"_$$CHECK^PSORESK1(RXP)_";31///@;32.1///"_%
DO ^DIE
KILL DIE,DR,DA
+46 DO NOW^%DTC
SET DA=RXP
SET DA=RXP
SET DIE="^PSRX("
SET DR="31///@;32.1///"_%
DO ^DIE
KILL DIE,DR,DA
IF $DATA(Y)
QUIT
+47 DO ACT^PSORESK1
SET DA=$ORDER(^PS(52.5,"B",RXP,0))
IF DA
SET DIK="^PS(52.5,"
DO ^DIK
+48 ;IHS/MSC/PLS - 10/2/2017 P1022
IF $$GET1^DIQ(52,RXP,26,"I")>$GET(DT)
Begin DoDot:2
+49 NEW STATUS
+50 SET STATUS=+$PIECE($GET(^PSRX(RXP,"STA")),U)
+51 ;Already active
IF STATUS=0
QUIT
+52 ;Must be expired
IF STATUS'=11
QUIT
+53 NEW DIE,DA,DR
+54 SET DA=RXP
SET DIE="^PSRX("
SET DR="100///0"
DO ^DIE
End DoDot:2
+55 ; IHS/CIA/PLS - 03/31/04
DO CALLPOS^APSPFUNC(RXP,"","D","Returned to stock.")
+56 DO REVERSE^PSOBPSU1(RXP,0,"RS",4,,1)
+57 DO EN^PSOHLSN1(RXP,"ZD")
WRITE !,"Rx # "_$PIECE(^PSRX(RXP,0),"^")_" Returned to Stock.",!
+58 QUIT
End DoDot:1
DO UL
DO EX
SET (RESK,PSOPCECT)=1
GOTO BC
+59 ;
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 IF $TEXT(PSDRTS^PSDOPT0)]""
Begin DoDot:1
+11 ;VMP OIFO BAY PINES;PSO*7.0*196;KILL PSDS
+12 IF XTYPE
DO PSDRTS^PSDOPT0(RXP,"R^"_TYPE,$PIECE(^PSRX(RXP,1,TYPE,0),"^",9),$PIECE(^(0),"^",4))
DO MSG
KILL PSDS
QUIT
+13 DO PSDRTS^PSDOPT0(RXP,"P^"_TYPE,$PIECE(^PSRX(RXP,"P",TYPE,0),"^",9),$PIECE(^(0),"^",4))
DO MSG
KILL PSDS
End DoDot:1
+14 IF $GET(RETSK)
DO UL
DO EX
GOTO BC
+15 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
+16 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
+17 ;Ask comments until answered, do not allow exiting.
+18 FOR
Begin DoDot:1
+19 KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
+20 SET DIR(0)="F0^10:75"
SET DIR("A")="Comments"
SET DIR("?")="Comments are required, 10-75 characters."
+21 SET DIR("B")=$SELECT($DATA(PSODEF):PSODEF,1:"Per Pharmacy Request")
+22 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
WRITE !?5,"Comments are required, 10-75 characters.",!
QUIT
+23 QUIT
End DoDot:1
IF '$DATA(DIRUT)
QUIT
+24 SET (PSODEF,COM)=$GET(Y)
KILL X,Y
+25 DO NOW^%DTC
SET QTY=$PIECE(^PSRX(RXP,XTYPE,TYPE,0),"^",4)
IF $GET(^PSDRUG(QDRUG,660.1))
Begin DoDot:1
+26 IF $GET(PSOWHERE)
IF '$GET(PSOINVTX)
QUIT
+27 SET ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)+$GET(QTY)
End DoDot:1
+28 IF $GET(PSOWHERE)
KILL ^PSRX("AR",+$GET(PSOLOCRL),RXP,$GET(TYPE))
+29 IF XTYPE
DO REVERSE^PSOBPSU1(RXP,TYPE,"RS",4,,1)
+30 ;
+31 ;save release dates in case can't perform the delete of .01 *259
+32 IF XTYPE
SET SVRELDT=$PIECE(^PSRX(RXP,XTYPE,TYPE,0),"^",18)
+33 IF 'XTYPE
SET SVRELDT=$PIECE(^PSRX(RXP,XTYPE,TYPE,0),"^",19)
+34 ;
+35 ;del rel date 1st and then attempt to del .01 field
+36 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///@"
+37 WRITE !
DO ^DIE
+38 ;
+39 ;if node still exists then fileman could not delete .01 *259
+40 IF $DATA(^PSRX(RXP,XTYPE,TYPE,0))
Begin DoDot:1
+41 WRITE " - Not Returned!"
+42 SET DA(1)=RXP
SET DA=TYPE
SET DIE="^PSRX("_DA(1)_","_$SELECT(XTYPE:1,1:"""P""")_","
+43 ;put back saved rel dte
SET DR=$SELECT(XTYPE:"17////",1:"8////")_SVRELDT
+44 DO ^DIE
DO UL
End DoDot:1
GOTO BC
+45 ;
+46 ;fall thru and perform RTS for refills/partials
+47 IF XTYPE'="P"
DO NPF
DO ACT^PSORESK1
+48 NEW ISDT
+49 SET ISDT=$PIECE(^PSRX(RXP,0),"^",13)
+50 IF $GET(ISDT)'=""
Begin DoDot:1
+51 ;IHS/MSC/MGH - 01/07/14 - Change the expiration date if necessary
SET DA=RXP
SET DIE="^PSRX("
SET DR="26///"_$$CHECK^PSORESK1(RXP)
DO ^DIE
KILL DIE,DR,DA
End DoDot:1
+52 ;IHS/MSC/PLS - 10/2/2017 P1022
IF $$GET1^DIQ(52,RXP,26,"I")>$GET(DT)
Begin DoDot:1
+53 NEW STATUS
+54 SET STATUS=+$PIECE($GET(^PSRX(RXP,"STA")),U)
+55 ;Already active
IF STATUS=0
QUIT
+56 ;Must be expired
IF STATUS'=11
QUIT
+57 NEW DIE,DA,DR
+58 SET DA=RXP
SET DIE="^PSRX("
SET DR="100///0"
DO ^DIE
End DoDot:1
+59 ; IHS/CIA/PLS - 03/31/04 - Call POS Hook
DO CALLPOS^APSPFUNC(RXP,$SELECT(TYPE:TYPE,1:""),"D","Returned to stock.")
+60 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
+61 KILL PSODISPP
IF 'XTYPE
SET PSODISPP=1
IF XTYPE
DO EN^PSOHDR("PRES",RXP)
DO EN^PSOHLSN1(RXP,"ZD")
KILL PSODISPP
+62 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
+1 ; IHS/CIA/PLS - 12/07/04 - Change lookup to Extrinsic call
RXP ;S RXP=$O(^PSRX("B",X,RXP)) I $P($G(^PSRX(+RXP,"STA")),"^")=13 G RXP
+1 SET RXP=$$RXLKUP(X)
+2 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
+9 ; IHS/CIA/PLS - 12/07/04
+10 ; IHS/MSC/PLS - 04/06/12 - Added parameter and condition
+11 ; Perform lookup given partial or full prescription number.
+12 ; Screen allows non-deleted scripts and scripts for user selected division.
RXLKUP(X) ; EP
+1 NEW DIC,Y
+2 IF $$GET^XPAR("ALL","APSP ALLOW RTS FROM ANY RX DIV")
Begin DoDot:1
+3 SET DIC("S")="I $P($G(^(""STA"")),U)'=13"
End DoDot:1
+4 IF '$TEST
SET DIC("S")="I $P($G(^(2)),U,9)=PSOSITE&($P($G(^(""STA"")),""^"")'=13)"
+5 SET DIC(0)="EMQZ"
SET DIC="^PSRX("
DO ^DIC
+6 QUIT $SELECT(+Y>0:+Y,1:0)
