- 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)
