PSOCAN ;BIR/JMB - Rx discontinue and reinstate ;12/03/18 10:47
;;7.0;OUTPATIENT PHARMACY;**11,21,24,27,32,37,88,117,131,185,253,251,375,379,390,413,372,416,508,477,617**;DEC 1997;Build 110
;External reference to File #55 supported by DBIA 2228
;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
START N PSOODOSP,PSOREINF,PSOONOFC S WARN=0,(DAYS360,SPCANC)=1 D KCAN1^PSOCAN3 W !! S DIR("A")="Discontinue/Reinstate by Rx# or patient name",DIR(0)="SBO^R:RX NUMBER;P:PATIENT NAME"
S DIR("?")="Enter 'R' to discontinue/reinstate by Rx#. Enter 'P' to discontinue/reinstate by patient name." D ^DIR K DIR
G:$G(DIRUT) KILL^PSOCAN1 K RP S RP=Y G:RP="P" PAT^PSOCAN1
NUM D DCORD^PSONEW2
K PSOTECCK,RXSP,PSINV,PSOWUN,PSOULRX,PSORX("DFLG") D KCAN1^PSOCAN3 S:'$D(PSOCLC) PSOCLC=DUZ S PS="Discontinue" W ! S DIR("A")="Discontinue/Reinstate Prescription(s)#"
S DIR(0)="FO^1:245",DIR("?")="Wand/enter barcode or enter Rx number(s) to discontinued/reinstated. If more than one, separate with commas. Do not exceed 245 characters including commas"
D ^DIR K DIR G:$G(DIRUT) START S OUT=0 I Y["-" D PSOINST^PSOSUPAT G:OUT NUM S (IN,X)=$P(^PSRX($P(Y,"-",2),0),"^") G NO
S IN=Y G RX:Y[","
NO I '$O(^PSRX("B",Y,0)) W " Rx Not Found!",! G NUM
S PSPOP=0,DIC=52,DIC(0)="QEMZ" D ^DIC K DIC Q:$G(POERR)&(Y<0)
G:Y<0 NUM S (DA,IFN,PSOULRX)=+Y,RXNUM=Y(0,0),PSODFN=+$P(^PSRX(DA,0),"^",2) I PSODFN'=$G(PSOODOSP) K PSORX("DOSING OFF"),PSOREINF S PSOODOSP=PSODFN
S PSOWUN=1 S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY K PSOPLCK G NUM
K PSOPLCK D PSOL^PSSLOCK(IFN) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order.") K PSOMSG D ULP G NUM
I $P($G(^PSRX(+$G(IFN),"STA")),"^")=12,$P($G(^("PKI")),"^")!$P($G(^("PKI")),"^",3) W !!,"Cannot be Reinstated - Digitally Signed" D ULP G NUM
I $P($G(^PSRX(+$G(IFN),"STA")),"^")=12 S PSOCANRZ=1
E S PSOCANRD=+$P($G(^PSRX(+$G(IFN),0)),"^",4)
D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN)
LMNO D CHK S:'$G(DA)&($G(IFN)) DA=IFN
I DEAD S PSINV($P(^PSRX(DA,0),"^"))="" D:$G(PSOWUN) ULP,ULRX G EP1
I $P(^PSRX(DA,"STA"),"^")'<13,$P(^("STA"),"^")'=16 S PSINV($P(^PSRX(DA,0),"^"))="" D:$G(PSOWUN) ULP,ULRX G EP1
I $G(PSODIV),$P($G(^PSRX(DA,2)),"^",9),$P(^(2),"^",9)'=$G(PSOSITE) S RXREC=DA D DIV D:$G(POERR)&(PSPOP) ULP,ULRX Q:$G(POERR)&(PSPOP) D:$G(PSOWUN)&($G(PSPOP)) ULP,ULRX G:PSPOP NUM
D ICN^PSODPT(PSODFN)
N PSTS S PSTS=$S($P(^PSRX(DA,"STA"),"^")=12:1,$P(^PSRX(DA,"STA"),"^")=14:1,$P(^PSRX(DA,"STA"),"^")=15:1,1:0)
S PS=$S($G(PSTS):"Reinstate",1:"Discontinue")
I PS="Reinstate",$$CONJ^PSOUTL(DA) W !!,"Cannot be Reinstated - dosage contains an invalid Except conjunction",! D PAUSE^VALM1,ULP,ULRX G EP1
;S PS=$S($P(^PSRX(DA,"STA"),"^")=12:"Reinstate",1:"Discontinue")
I '$G(POERR) N PKIR D
.I $P(^PSRX(DA,"STA"),"^")=1,$P($G(^("PKI")),"^") S PKIR=""
.D ^PSORXPR
D:$G(PSORX("DFLG")) ULP,ULRX
Q:$G(POERR)&($G(PSORX("DFLG")))
G NUM:$G(PSORX("DFLG"))
D YN S:PS="Reinstate" PS="Discontinue" Q:$G(POERR)&('%)
I '% D ULP,ULRX G NUM
D REA D:'$D(REA)&($G(PSOWUN)) ULP,ULRX Q:'$D(REA)
D COM^PSOCAN1 Q:$G(POERR)&('$D(INCOM))!($D(DIRUT)) I '$D(INCOM)!($D(DIRUT)) D ULP,ULRX G NUM
S RX=$P(^PSRX(DA,0),"^"),PSCAN(RX)=DA_"^"_REA
D:REA="R" REINS^PSOCAN2 Q:$G(PSOQUIT)&($G(PSOREINS))
I REA="R",'$G(PSORX("DFLG")) D DCORD^PSONEW2
K PSOTECCK
D:REA="C" CAN
Q:$G(POERR)
D ULP,ULRX G NUM
YN D EN^PSOCMOPA I $G(XFLAG)]"" S %=0 K XFLAG Q
; PSO*7*508 - if this is an eRx auto DC, set the flag to prevent prompt and quit
I $G(ERXDCIEN) S %=1 Q
W ! S DIR("A")="Are you sure you want to "_PS,DIR(0)="Y",DIR("B")="NO" D ^DIR S %=Y K DIR,DUOUT,DTOUT I 'Y!$D(DIRUT) S VALMBCK="R"
K DIRUT Q
REA ;
;PSO*7*508 - if this is an eRx, we are cancelling only. Set REA and quit
I $G(ERXDCIEN) D Q
.I +$P(^PSRX(DA,"STA"),U)=12 Q
.S REA="C"
S REA=+$P(^PSRX(DA,"STA"),"^") I REA=12 S REA="R" Q
I REA,REA'=11 W !?5,$C(7) D
.W "Rx# "_RXNUM_" was"_$S(REA=1:" Non-Verified",REA=13:" Deleted",REA=11:" Expired",REA=5:" Suspended",REA=4:" Pending Due to Drug Interactions",REA=3:" On Hold",REA=14!(REA=15):" Discontinued",REA=16:" Provider Held",1:" In Fill Status")_"."
I REA,REA'=1,REA'=3,REA'=5,REA'=11,REA'<13,REA'=16 D Q
.K REA W !?10,"Rx Cannot Be Discontinued/Reinstated!" H 2
.S VALMSG="Rx# "_RXNUM_" Cannot Be "_$S($G(PSTS):"Reinstated",1:"Discontinued")_"."
S REA="C" Q
CAN N PSODRUG D CAN1^PSOCAN3 Q
DIV I '$P($G(PSOSYS),"^",2) W !?10,$C(7),"RX# ",$P(^PSRX(DA,0),"^")," is not a valid choice. (Different Division)" S PSPOP=1 Q
I $P($G(PSOSYS),"^",3) W !?10,$C(7) S DIR("A")="RX# "_$P(^PSRX(DA,0),"^")_" is from another division. Continue",DIR(0)="Y",DIR("B")="Y" D ^DIR K DIR S:$G(DIRUT)!('Y) PSPOP=1
Q
CHK K VADM,DEAD S DFN=PSODFN D DEM^VADPT I $G(VADM(6))="" S DEAD=0 Q
S (PSODEATH,DEAD)=1 W !!,?10,VADM(1)_" DIED "_$P($G(VADM(6)),"^",2) D CAN^PSOCAN3 K PSODEATH
Q
RX N PKI S RXCNT=0,RXSP=1 D TESTRP D COM^PSOCAN1 G:'$D(INCOM)!($D(DIRUT)) NUM K PSINV,PSCAN F II=1:1 S (EN,X)=$P(IN,",",II) Q:$P(IN,",",II)']"" S DIC=52,DIC(0)="QMZ" D ^DIC K DIC S:Y'>0 PSINV(X)="" D:Y>0
.S YY=Y,YY(0,0)=Y(0,0),(PSODFN,DFN)=$P(Y(0),"^",2) D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN)
.D:$G(DFN)>0 CHK I DEAD!($P(^PSRX(+YY,"STA"),"^")=13)!($P(^("STA"),"^")=14) S PSINV(EN)="" Q
.I $P(^PSRX(+YY,"STA"),"^")=12,$P($G(^("PKI")),"^") S PKI=1,PSINV(EN)="" Q
.S DA=+YY I $P($G(^PSRX(DA,"STA")),"^")=11!($P($G(^(2)),"^",6)<DT) D EXP
.S RX=YY(0,0) D:$D(^PSRX(DA,0)) SPEED1^PSOCAN1
.;S DA=+YY I $P($G(^PSRX(DA,"STA")),"^")=11!($P($G(^(2)),"^",6)<DT) D EXP Q
.;E S RX=YY(0,0) D:$D(^PSRX(DA,0)) SPEED1^PSOCAN1
K YY G:'$D(PSCAN) INVALD^PSOCAN1 S RX="",RXCNT=0 F S RX=$O(PSCAN(RX)) Q:RX="" S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),RXCNT=RXCNT+1 D SHOW^PSOCAN1
ASK Q:'$D(PSCAN) W ! S DIR("A")="OK to "_$S($G(RXCNT)>1:"Change Status",REA="C":"Discontinued",1:"Reinstate"),DIR(0)="Y",DIR("B")="N"
N PSOCNRXV S PSOCNRXV=0
D ^DIR K DIR Q:$G(DIRUT) I 'Y K PSCAN D INVALD^PSOCAN1 G NUM
K PSOPLCKZ S RX="" F S RX=$O(PSCAN(RX)) Q:'RX D
.S PSODFN=+$P($G(^PSRX(+PSCAN(RX),0)),"^",2)
.S PSOPLCK=$$L^PSSLOCK(+$G(PSODFN),0) D:'$G(PSOPLCK)&('$D(PSOPLCKZ(PSODFN))) LOCK^PSOORCPY I '$G(PSOPLCK) S PSOPLCKZ(PSODFN)=PSODFN Q
.D PSOL^PSSLOCK(+PSCAN(RX)) I '$G(PSOMSG) D D UL^PSSLOCK(PSODFN) Q
..I $P($G(PSOMSG),"^",2)'="" W !,$P($G(PSOMSG),"^",2),!,"Order "_$P($G(^PSRX(+PSCAN(RX),0)),"^")_"." Q
..W !,"Another person is editing order "_$P($G(^PSRX(+PSCAN(RX),0)),"^")_"."
.D ACT D PSOUL^PSSLOCK(+PSCAN(RX)),UL^PSSLOCK(PSODFN)
.S PSOCNRXV=1
K PSOPLCKZ W:$G(PSOCNRXV) !,$S($G(RXCNT)>1:"Statuses Changed",REA="C":"Prescription Discontinued",1:"Prescription Reinstated") D INVALD^PSOCAN1 G NUM
ACT S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),II=RX,PSODFN=$P(^PSRX(DA,0),"^",2) I REA="R" D REINS^PSOCAN2 Q
D CAN Q
EXP ;S PSINV($P(^PSRX(DA,0),"^"))=""
Q:$P(^PSRX(DA,"STA"),"^")=12
S $P(^PSRX(DA,"STA"),"^")=11 D ECAN^PSOUTL(DA)
S STAT="SC",PHARMST="ZE",COMM="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"/"_$E($P(^(2),"^",6),6,7)_"/"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,STAT,PHARMST,COMM) K COMM,STAT,PHARMST
EP1 I '$G(RXSP) D INVALD^PSOCAN1 Q:$G(POERR) G NUM
Q
PSD ;Called from Controlled Subs, PSDRX is internal Rx number
S PSDRFDEL=0
I '$G(PSDRX)!('$D(^PSRX(+$G(PSDRX),0))) Q
I $P($G(^PSRX(PSDRX,"STA")),"^")<12 Q
N DA,NODE,RF,PSOPSDAL,PSODRX,PSODTE,PSODL,SFN,RIFN,PSOSXP,PSOFILDL
S PSODRX=0 F PSODLP=0:0 S PSODLP=$O(^PSRX(PSDRX,1,PSODLP)) Q:'PSODLP S:$D(^PSRX(PSDRX,1,PSODLP,0)) PSODRX=PSODLP
I 'PSODRX Q
I $P($G(^PSRX(PSDRX,1,PSODRX,0)),"^",18) Q
D PSDREF I $G(PSOFILDL) K PSOFILDL Q
K PSOFILDL,DIE S NODE=0,PSOPSDAL=1,DA(1)=PSDRX,DA=PSODRX,DIE="^PSRX("_DA(1)_",1,",DR=".01///@" D ^DIE K DIE
S PSDRFDEL=1
Q
PSDREF ;
N PRDL,PSOCNODE
S PSOFILDL=0
F PRDL=0:0 S PRDL=$O(^PSRX(PSDRX,4,PRDL)) Q:'PRDL I $G(PSODRX)=$P($G(^PSRX(PSDRX,4,PRDL,0)),"^",3) S PSOCNODE=$G(^(0))
I $G(PSOCNODE)="" Q
I +$P(PSOCNODE,"^",4)<3 S PSOFILDL=1
Q
TESTRP ;
N PIIN,PIINFLAG S PIINFLAG=0 F PIIN=1:1 S X=$P(IN,",",PIIN) Q:$P(IN,",",PIIN)']"" K DIC S DIC=52,DIC(0)="QMZ" D ^DIC K DIC I +$G(Y) D
.I $P($G(^PSRX(+Y,"STA")),"^")'=12,'$G(PIINFLAG) S PSOCANRD=+$P($G(^PSRX(+Y,0)),"^",4) S PIINFLAG=1
I '$G(PIINFLAG) S PSOCANRZ=1
Q
ULP ;
D UL^PSSLOCK(+$G(PSODFN))
Q
ULRX ;
I $G(PSOULRX) D PSOUL^PSSLOCK(PSOULRX)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCAN 8480 printed Apr 09, 2024@21:35:18 Page 2
PSOCAN ;BIR/JMB - Rx discontinue and reinstate ;12/03/18 10:47
+1 ;;7.0;OUTPATIENT PHARMACY;**11,21,24,27,32,37,88,117,131,185,253,251,375,379,390,413,372,416,508,477,617**;DEC 1997;Build 110
+2 ;External reference to File #55 supported by DBIA 2228
+3 ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
START NEW PSOODOSP,PSOREINF,PSOONOFC
SET WARN=0
SET (DAYS360,SPCANC)=1
DO KCAN1^PSOCAN3
WRITE !!
SET DIR("A")="Discontinue/Reinstate by Rx# or patient name"
SET DIR(0)="SBO^R:RX NUMBER;P:PATIENT NAME"
+1 SET DIR("?")="Enter 'R' to discontinue/reinstate by Rx#. Enter 'P' to discontinue/reinstate by patient name."
DO ^DIR
KILL DIR
+2 if $GET(DIRUT)
GOTO KILL^PSOCAN1
KILL RP
SET RP=Y
if RP="P"
GOTO PAT^PSOCAN1
NUM DO DCORD^PSONEW2
+1 KILL PSOTECCK,RXSP,PSINV,PSOWUN,PSOULRX,PSORX("DFLG")
DO KCAN1^PSOCAN3
if '$DATA(PSOCLC)
SET PSOCLC=DUZ
SET PS="Discontinue"
WRITE !
SET DIR("A")="Discontinue/Reinstate Prescription(s)#"
+2 SET DIR(0)="FO^1:245"
SET DIR("?")="Wand/enter barcode or enter Rx number(s) to discontinued/reinstated. If more than one, separate with commas. Do not exceed 245 characters including commas"
+3 DO ^DIR
KILL DIR
if $GET(DIRUT)
GOTO START
SET OUT=0
IF Y["-"
DO PSOINST^PSOSUPAT
if OUT
GOTO NUM
SET (IN,X)=$PIECE(^PSRX($PIECE(Y,"-",2),0),"^")
GOTO NO
+4 SET IN=Y
if Y[","
GOTO RX
NO IF '$ORDER(^PSRX("B",Y,0))
WRITE " Rx Not Found!",!
GOTO NUM
+1 SET PSPOP=0
SET DIC=52
SET DIC(0)="QEMZ"
DO ^DIC
KILL DIC
if $GET(POERR)&(Y<0)
QUIT
+2 if Y<0
GOTO NUM
SET (DA,IFN,PSOULRX)=+Y
SET RXNUM=Y(0,0)
SET PSODFN=+$PIECE(^PSRX(DA,0),"^",2)
IF PSODFN'=$GET(PSOODOSP)
KILL PSORX("DOSING OFF"),PSOREINF
SET PSOODOSP=PSODFN
+3 SET PSOWUN=1
SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)
IF '$GET(PSOPLCK)
DO LOCK^PSOORCPY
KILL PSOPLCK
GOTO NUM
+4 KILL PSOPLCK
DO PSOL^PSSLOCK(IFN)
IF '$GET(PSOMSG)
WRITE !!,$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order.")
KILL PSOMSG
DO ULP
GOTO NUM
+5 IF $PIECE($GET(^PSRX(+$GET(IFN),"STA")),"^")=12
IF $PIECE($GET(^("PKI")),"^")!$PIECE($GET(^("PKI")),"^",3)
WRITE !!,"Cannot be Reinstated - Digitally Signed"
DO ULP
GOTO NUM
+6 IF $PIECE($GET(^PSRX(+$GET(IFN),"STA")),"^")=12
SET PSOCANRZ=1
+7 IF '$TEST
SET PSOCANRD=+$PIECE($GET(^PSRX(+$GET(IFN),0)),"^",4)
+8 if $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2
DO EN^PSOHLUP(PSODFN)
LMNO DO CHK
if '$GET(DA)&($GET(IFN))
SET DA=IFN
+1 IF DEAD
SET PSINV($PIECE(^PSRX(DA,0),"^"))=""
if $GET(PSOWUN)
DO ULP
DO ULRX
GOTO EP1
+2 IF $PIECE(^PSRX(DA,"STA"),"^")'<13
IF $PIECE(^("STA"),"^")'=16
SET PSINV($PIECE(^PSRX(DA,0),"^"))=""
if $GET(PSOWUN)
DO ULP
DO ULRX
GOTO EP1
+3 IF $GET(PSODIV)
IF $PIECE($GET(^PSRX(DA,2)),"^",9)
IF $PIECE(^(2),"^",9)'=$GET(PSOSITE)
SET RXREC=DA
DO DIV
if $GET(POERR)&(PSPOP)
DO ULP
DO ULRX
if $GET(POERR)&(PSPOP)
QUIT
if $GET(PSOWUN)&($GET(PSPOP))
DO ULP
DO ULRX
if PSPOP
GOTO NUM
+4 DO ICN^PSODPT(PSODFN)
+5 NEW PSTS
SET PSTS=$SELECT($PIECE(^PSRX(DA,"STA"),"^")=12:1,$PIECE(^PSRX(DA,"STA"),"^")=14:1,$PIECE(^PSRX(DA,"STA"),"^")=15:1,1:0)
+6 SET PS=$SELECT($GET(PSTS):"Reinstate",1:"Discontinue")
+7 IF PS="Reinstate"
IF $$CONJ^PSOUTL(DA)
WRITE !!,"Cannot be Reinstated - dosage contains an invalid Except conjunction",!
DO PAUSE^VALM1
DO ULP
DO ULRX
GOTO EP1
+8 ;S PS=$S($P(^PSRX(DA,"STA"),"^")=12:"Reinstate",1:"Discontinue")
+9 IF '$GET(POERR)
NEW PKIR
Begin DoDot:1
+10 IF $PIECE(^PSRX(DA,"STA"),"^")=1
IF $PIECE($GET(^("PKI")),"^")
SET PKIR=""
+11 DO ^PSORXPR
End DoDot:1
+12 if $GET(PSORX("DFLG"))
DO ULP
DO ULRX
+13 if $GET(POERR)&($GET(PSORX("DFLG")))
QUIT
+14 if $GET(PSORX("DFLG"))
GOTO NUM
+15 DO YN
if PS="Reinstate"
SET PS="Discontinue"
if $GET(POERR)&('%)
QUIT
+16 IF '%
DO ULP
DO ULRX
GOTO NUM
+17 DO REA
if '$DATA(REA)&($GET(PSOWUN))
DO ULP
DO ULRX
if '$DATA(REA)
QUIT
+18 DO COM^PSOCAN1
if $GET(POERR)&('$DATA(INCOM))!($DATA(DIRUT))
QUIT
IF '$DATA(INCOM)!($DATA(DIRUT))
DO ULP
DO ULRX
GOTO NUM
+19 SET RX=$PIECE(^PSRX(DA,0),"^")
SET PSCAN(RX)=DA_"^"_REA
+20 if REA="R"
DO REINS^PSOCAN2
if $GET(PSOQUIT)&($GET(PSOREINS))
QUIT
+21 IF REA="R"
IF '$GET(PSORX("DFLG"))
DO DCORD^PSONEW2
+22 KILL PSOTECCK
+23 if REA="C"
DO CAN
+24 if $GET(POERR)
QUIT
+25 DO ULP
DO ULRX
GOTO NUM
YN DO EN^PSOCMOPA
IF $GET(XFLAG)]""
SET %=0
KILL XFLAG
QUIT
+1 ; PSO*7*508 - if this is an eRx auto DC, set the flag to prevent prompt and quit
+2 IF $GET(ERXDCIEN)
SET %=1
QUIT
+3 WRITE !
SET DIR("A")="Are you sure you want to "_PS
SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
SET %=Y
KILL DIR,DUOUT,DTOUT
IF 'Y!$DATA(DIRUT)
SET VALMBCK="R"
+4 KILL DIRUT
QUIT
REA ;
+1 ;PSO*7*508 - if this is an eRx, we are cancelling only. Set REA and quit
+2 IF $GET(ERXDCIEN)
Begin DoDot:1
+3 IF +$PIECE(^PSRX(DA,"STA"),U)=12
QUIT
+4 SET REA="C"
End DoDot:1
QUIT
+5 SET REA=+$PIECE(^PSRX(DA,"STA"),"^")
IF REA=12
SET REA="R"
QUIT
+6 IF REA
IF REA'=11
WRITE !?5,$CHAR(7)
Begin DoDot:1
+7 WRITE "Rx# "_RXNUM_" was"_$SELECT(REA=1:" Non-Verified",REA=13:" Deleted",REA=11:" Expired",REA=5:" Suspended",REA=4:" Pending Due to Drug Interactions",REA=3:" On Hold",REA=14!(REA=15):" Discontinued",REA=16:" Provider Held",1:" In
Fill Status")_"."
End DoDot:1
+8 IF REA
IF REA'=1
IF REA'=3
IF REA'=5
IF REA'=11
IF REA'<13
IF REA'=16
Begin DoDot:1
+9 KILL REA
WRITE !?10,"Rx Cannot Be Discontinued/Reinstated!"
HANG 2
+10 SET VALMSG="Rx# "_RXNUM_" Cannot Be "_$SELECT($GET(PSTS):"Reinstated",1:"Discontinued")_"."
End DoDot:1
QUIT
+11 SET REA="C"
QUIT
CAN NEW PSODRUG
DO CAN1^PSOCAN3
QUIT
DIV IF '$PIECE($GET(PSOSYS),"^",2)
WRITE !?10,$CHAR(7),"RX# ",$PIECE(^PSRX(DA,0),"^")," is not a valid choice. (Different Division)"
SET PSPOP=1
QUIT
+1 IF $PIECE($GET(PSOSYS),"^",3)
WRITE !?10,$CHAR(7)
SET DIR("A")="RX# "_$PIECE(^PSRX(DA,0),"^")_" is from another division. Continue"
SET DIR(0)="Y"
SET DIR("B")="Y"
DO ^DIR
KILL DIR
if $GET(DIRUT)!('Y)
SET PSPOP=1
+2 QUIT
CHK KILL VADM,DEAD
SET DFN=PSODFN
DO DEM^VADPT
IF $GET(VADM(6))=""
SET DEAD=0
QUIT
+1 SET (PSODEATH,DEAD)=1
WRITE !!,?10,VADM(1)_" DIED "_$PIECE($GET(VADM(6)),"^",2)
DO CAN^PSOCAN3
KILL PSODEATH
+2 QUIT
RX NEW PKI
SET RXCNT=0
SET RXSP=1
DO TESTRP
DO COM^PSOCAN1
if '$DATA(INCOM)!($DATA(DIRUT))
GOTO NUM
KILL PSINV,PSCAN
FOR II=1:1
SET (EN,X)=$PIECE(IN,",",II)
if $PIECE(IN,",",II)']""
QUIT
SET DIC=52
SET DIC(0)="QMZ"
DO ^DIC
KILL DIC
if Y'>0
SET PSINV(X)=""
if Y>0
Begin DoDot:1
+1 SET YY=Y
SET YY(0,0)=Y(0,0)
SET (PSODFN,DFN)=$PIECE(Y(0),"^",2)
if $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2
DO EN^PSOHLUP(PSODFN)
+2 if $GET(DFN)>0
DO CHK
IF DEAD!($PIECE(^PSRX(+YY,"STA"),"^")=13)!($PIECE(^("STA"),"^")=14)
SET PSINV(EN)=""
QUIT
+3 IF $PIECE(^PSRX(+YY,"STA"),"^")=12
IF $PIECE($GET(^("PKI")),"^")
SET PKI=1
SET PSINV(EN)=""
QUIT
+4 SET DA=+YY
IF $PIECE($GET(^PSRX(DA,"STA")),"^")=11!($PIECE($GET(^(2)),"^",6)<DT)
DO EXP
+5 SET RX=YY(0,0)
if $DATA(^PSRX(DA,0))
DO SPEED1^PSOCAN1
+6 ;S DA=+YY I $P($G(^PSRX(DA,"STA")),"^")=11!($P($G(^(2)),"^",6)<DT) D EXP Q
+7 ;E S RX=YY(0,0) D:$D(^PSRX(DA,0)) SPEED1^PSOCAN1
End DoDot:1
+8 KILL YY
if '$DATA(PSCAN)
GOTO INVALD^PSOCAN1
SET RX=""
SET RXCNT=0
FOR
SET RX=$ORDER(PSCAN(RX))
if RX=""
QUIT
SET DA=+PSCAN(RX)
SET REA=$PIECE(PSCAN(RX),"^",2)
SET RXCNT=RXCNT+1
DO SHOW^PSOCAN1
ASK if '$DATA(PSCAN)
QUIT
WRITE !
SET DIR("A")="OK to "_$SELECT($GET(RXCNT)>1:"Change Status",REA="C":"Discontinued",1:"Reinstate")
SET DIR(0)="Y"
SET DIR("B")="N"
+1 NEW PSOCNRXV
SET PSOCNRXV=0
+2 DO ^DIR
KILL DIR
if $GET(DIRUT)
QUIT
IF 'Y
KILL PSCAN
DO INVALD^PSOCAN1
GOTO NUM
+3 KILL PSOPLCKZ
SET RX=""
FOR
SET RX=$ORDER(PSCAN(RX))
if 'RX
QUIT
Begin DoDot:1
+4 SET PSODFN=+$PIECE($GET(^PSRX(+PSCAN(RX),0)),"^",2)
+5 SET PSOPLCK=$$L^PSSLOCK(+$GET(PSODFN),0)
if '$GET(PSOPLCK)&('$DATA(PSOPLCKZ(PSODFN)))
DO LOCK^PSOORCPY
IF '$GET(PSOPLCK)
SET PSOPLCKZ(PSODFN)=PSODFN
QUIT
+6 DO PSOL^PSSLOCK(+PSCAN(RX))
IF '$GET(PSOMSG)
Begin DoDot:2
+7 IF $PIECE($GET(PSOMSG),"^",2)'=""
WRITE !,$PIECE($GET(PSOMSG),"^",2),!,"Order "_$PIECE($GET(^PSRX(+PSCAN(RX),0)),"^")_"."
QUIT
+8 WRITE !,"Another person is editing order "_$PIECE($GET(^PSRX(+PSCAN(RX),0)),"^")_"."
End DoDot:2
DO UL^PSSLOCK(PSODFN)
QUIT
+9 DO ACT
DO PSOUL^PSSLOCK(+PSCAN(RX))
DO UL^PSSLOCK(PSODFN)
+10 SET PSOCNRXV=1
End DoDot:1
+11 KILL PSOPLCKZ
if $GET(PSOCNRXV)
WRITE !,$SELECT($GET(RXCNT)>1:"Statuses Changed",REA="C":"Prescription Discontinued",1:"Prescription Reinstated")
DO INVALD^PSOCAN1
GOTO NUM
ACT SET DA=+PSCAN(RX)
SET REA=$PIECE(PSCAN(RX),"^",2)
SET II=RX
SET PSODFN=$PIECE(^PSRX(DA,0),"^",2)
IF REA="R"
DO REINS^PSOCAN2
QUIT
+1 DO CAN
QUIT
EXP ;S PSINV($P(^PSRX(DA,0),"^"))=""
+1 if $PIECE(^PSRX(DA,"STA"),"^")=12
QUIT
+2 SET $PIECE(^PSRX(DA,"STA"),"^")=11
DO ECAN^PSOUTL(DA)
+3 SET STAT="SC"
SET PHARMST="ZE"
SET COMM="Medication Expired on "_$EXTRACT($PIECE(^PSRX(DA,2),"^",6),4,5)_"/"_$EXTRACT($PIECE(^(2),"^",6),6,7)_"/"_$EXTRACT($PIECE(^(2),"^",6),2,3)
DO EN^PSOHLSN1(DA,STAT,PHARMST,COMM)
KILL COMM,STAT,PHARMST
EP1 IF '$GET(RXSP)
DO INVALD^PSOCAN1
if $GET(POERR)
QUIT
GOTO NUM
+1 QUIT
PSD ;Called from Controlled Subs, PSDRX is internal Rx number
+1 SET PSDRFDEL=0
+2 IF '$GET(PSDRX)!('$DATA(^PSRX(+$GET(PSDRX),0)))
QUIT
+3 IF $PIECE($GET(^PSRX(PSDRX,"STA")),"^")<12
QUIT
+4 NEW DA,NODE,RF,PSOPSDAL,PSODRX,PSODTE,PSODL,SFN,RIFN,PSOSXP,PSOFILDL
+5 SET PSODRX=0
FOR PSODLP=0:0
SET PSODLP=$ORDER(^PSRX(PSDRX,1,PSODLP))
if 'PSODLP
QUIT
if $DATA(^PSRX(PSDRX,1,PSODLP,0))
SET PSODRX=PSODLP
+6 IF 'PSODRX
QUIT
+7 IF $PIECE($GET(^PSRX(PSDRX,1,PSODRX,0)),"^",18)
QUIT
+8 DO PSDREF
IF $GET(PSOFILDL)
KILL PSOFILDL
QUIT
+9 KILL PSOFILDL,DIE
SET NODE=0
SET PSOPSDAL=1
SET DA(1)=PSDRX
SET DA=PSODRX
SET DIE="^PSRX("_DA(1)_",1,"
SET DR=".01///@"
DO ^DIE
KILL DIE
+10 SET PSDRFDEL=1
+11 QUIT
PSDREF ;
+1 NEW PRDL,PSOCNODE
+2 SET PSOFILDL=0
+3 FOR PRDL=0:0
SET PRDL=$ORDER(^PSRX(PSDRX,4,PRDL))
if 'PRDL
QUIT
IF $GET(PSODRX)=$PIECE($GET(^PSRX(PSDRX,4,PRDL,0)),"^",3)
SET PSOCNODE=$GET(^(0))
+4 IF $GET(PSOCNODE)=""
QUIT
+5 IF +$PIECE(PSOCNODE,"^",4)<3
SET PSOFILDL=1
+6 QUIT
TESTRP ;
+1 NEW PIIN,PIINFLAG
SET PIINFLAG=0
FOR PIIN=1:1
SET X=$PIECE(IN,",",PIIN)
if $PIECE(IN,",",PIIN)']""
QUIT
KILL DIC
SET DIC=52
SET DIC(0)="QMZ"
DO ^DIC
KILL DIC
IF +$GET(Y)
Begin DoDot:1
+2 IF $PIECE($GET(^PSRX(+Y,"STA")),"^")'=12
IF '$GET(PIINFLAG)
SET PSOCANRD=+$PIECE($GET(^PSRX(+Y,0)),"^",4)
SET PIINFLAG=1
End DoDot:1
+3 IF '$GET(PIINFLAG)
SET PSOCANRZ=1
+4 QUIT
ULP ;
+1 DO UL^PSSLOCK(+$GET(PSODFN))
+2 QUIT
ULRX ;
+1 IF $GET(PSOULRX)
DO PSOUL^PSSLOCK(PSOULRX)
+2 QUIT
