PSOPRK ;BIR/EJW - park/unpark functionality ; May 17, 2023@18:30:42
;;7.0;OUTPATIENT PHARMACY;**441,712**;DEC 1997;Build 20
;
; Reference to ^DD(52 in ICR #999
; Reference to ^PSDRUG( in ICR #221
; Reference to $$L^PSSLOCK,PSOL^PSSLOCK,PSOUL^PSSLOCK,UL^PSSLOCK in ICR #2789
;
UNPARK ;
N RXIEN,PSOOLDFILLDT
I '$D(PSOPAR) D ^PSOLSET G:'$D(PSOPAR) EX
I $G(PSOBEDT),$G(PSOREJCT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" Q
S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
K PSOPLCK D PSOL^PSSLOCK(DA) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULP Q
S Y(0)=^PSRX(DA,0),STA=+$G(^("STA"))
I STA!('$G(^PSRX(DA,"PARK"))) S VALMSG="Cannot unpark. Prescription is not parked.",VALMBCK="" Q
I STA'=0!(('$D(^XUSEC("PSORPH",DUZ)))&('$D(^XUSEC("PSO TECH ADV",DUZ)))) S VALMSG="Invalid Action Selection!",VALMBCK="" K Y,STA D PSOUL^PSSLOCK(DA) D ULP Q
D FULL^VALM1 K DIR,DTOUT,DUOUT,DIRUT
I DT>$P(^PSRX(DA,2),"^",6) D D ULP G EX
.S (VALMSG,COMM)="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11
.D KILLPARK(DA) D EN^PSOHLSN1(DA,"SC","ZE",COMM,"") K COMM
EN S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I,RSDT=$P(^(I,0),"^")
S PSOOLDFILLDT=$S(RXF:$P(^PSRX(DA,1,RXF,0),U,1),1:$P(^PSRX(DA,2),U,2))
S RXIEN=DA
K Y I RXF D I $D(Y) D ULP G EX
.N DA,DIE S DA(1)=RXIEN,DA=RXF,DIE="^PSRX("_DA(1)_",1,",PSOUNPRK=1
.S RLDT=$P(^PSRX(DA(1),1,DA,0),"^",18)
.I 'RLDT D
..I RSDT<DT D ;Do not display a past date for refill date
...N Y,TD S Y=DT X ^DD("DD") S TD=Y
...S DR=".01R///^S X=TD"
...D ^DIE
..I $D(Y) D ;User quit the UNPARK process
...I RSDT<DT D ;reset refill date
....N Y,TD S Y=RSDT X ^DD("DD") S TD=Y
....S DR=".01R///^S X=TD"
....D ^DIE
.S ZD(RXIEN)=$P(^PSRX(DA(1),1,DA,0),"^")
.K PSOUNPRK Q:$D(Y) S PSORX("FILL DATE")=ZD(RXIEN),DA=PSDA K DA(1)
;
;PSO*7*298 Require an entry into fill date
S ACT=1,DIE="^PSRX(",FDT=$S($P(^PSRX(RXIEN,2),"^",2):$P(^PSRX(RXIEN,2),"^",2),$P(^PSRX(RXIEN,3),"^",2):$P(^PSRX(RXIEN,3),"^",2),1:DT)
I FDT<DT S FDT=DT
S RLDT=$P(^PSRX(DA,2),"^",13),DR="",RLDTP1=$P(RLDT,".",1)
I 'RXF&'RLDT S DR="22R//^S X=FDT;Q;"
; DON'T INCLUDE PROMPT FOR PARK IF UNPARKING
I RLDT&($P(^PSRX(DA,2),"^",2)="") S DR="22R//^S X=RLDTP1;Q;"
S DR=DR_"100///0;101///^S X=$S(RXF:$G(ZD(RXIEN)),1:$P(^PSRX(RXIEN,2),""^"",2))"
;
D ^DIE K FDT I $D(Y) S VALMBCK="R" D ULP G EX
I $G(PSOFRPK) D KILLPARK(DA) G UMSG
N PRKMW D MW I PRKMW="" S VALMBCK="R" D ULP G EX
D KILLPARK(DA)
I 'RXF S $P(^PSRX(DA,0),"^",11)=PRKMW
I RXF,$D(^PSRX(DA,1,RXF,0)) S $P(^PSRX(DA,1,RXF,0),"^",2)=PRKMW
UMSG S VALMSG="RX# "_$P(^PSRX(DA,0),"^")_" unparked"
D RXACT(DA,"UPK")
N PSONOOR,COMM S PSONOOR="I" ; Default to POLICY
S COMM="Medication Removed from Park by Pharmacy" D EN^PSOHLSN1(RXIEN,"SC","",COMM,PSONOOR) K COMM
S PSORX("FILL DATE")=$S('RXF:$P(^PSRX(DA,2),"^",2),1:ZD(RXIEN)) D KILLPARK(DA)
S (NEW1,NEW11)="^^"
S (RXF,RXFL(DA))=0 F JJ=0:0 S JJ=$O(^PSRX(DA,1,JJ)) Q:'JJ S (RXFL(RXIEN),RXF)=JJ
I $G(PSXSYS) D UNPARK^PSOCMOPA I $G(XFLAG) D ULP G EX
I $G(RXIEN) N REFCK S REFCK=0 D REFCK I $G(REFCK) D D ULP G EX
. I $$TITRX^PSOUTL(RXIEN)="t" S VALMSG=VALMSG_" - Cannot Refill Titration Rx" Q
. I $O(^PS(52.41,"ARF",RXIEN,0)) S VALMSG=VALMSG_" - Refill request exists" Q
. N X,Y,DIC,JJ
. S X=$G(PSORX("PATIENT STATUS")) S:'X X=$P(RX0,"^",3)
. S DIC=53,DIC(0)="QXZ" D ^DIC
. S JJ=$$MAXNUMRF^PSOUTIL(+$G(PSODRUG("IEN")),$P(RX0,"^",8),+Y,.CLOZPAT) I 'JJ S VALMSG=VALMSG_" - Not Refillable" Q
. K X,Y,DIC,JJ
. N PSOREF S PSOREF("MAIL/WINDOW")=$G(PRKMW),PSOREF("IRXN")=RXIEN D ^PSOREF0 ; create a refill
; IF FUTURE DATE, PUT ON SUSPENSE WHEN UNPARKED
I PSORX("FILL DATE")>DT,$P(PSOPAR,"^",6) D S^PSORXL,EX,ULP Q
S PCOMH(RXIEN)="Medication Removed from Park by Pharmacy"
I $G(RXIEN) S RXRH(RXIEN)=RXIEN
; MARK PRESCRIPTION AND LABEL AS BEING REPRINTED WHEN UNPARKING A RETURNED TO STOCK PRESCRIPTION
I $P($G(^PSRX(RXIEN,2)),"^",15)'="" S $P(^PSRX(RXIEN,2),"^",14)=1,RXRP(RXIEN)=1,$P(RXRP(RXIEN),"^",2)=$P($G(^PSRX(RXIEN,0)),"^",18)
;
; - Submitting Rx to ECME
N ACTION
I $$SUBMIT^PSOBPSUT(RXIEN,+$G(RXFL(RXIEN))) D I ACTION="Q"!(ACTION="^") D ULP G EX
. N RX,RFL S RX=RXIEN,RFL=+$G(RXFL(RXIEN))
. N DA S ACTION=""
. D ECMESND^PSOBPSU1(RX,RFL,,$S(RFL:"RF",1:"OF"))
. ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358
. I $$PSOET^PSOREJP3(RX,RFL) S ACTION="Q" Q
. I $$FIND^PSOREJUT(RX,RFL) D
.. S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q")
;
I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RXIEN_"," D ULP G EX
F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXIEN_","
E S PSORX("PSOL",PSOX2+1)=RXIEN_","
;
D ULP
EX ;
; If called from edit (changed to or from Park), don't unlock/kill
I $G(PSOTOPK) K DR Q
I $G(PSOFRPK) K DR Q
D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) D ^PSOBUILD
K PSOHRL,PSOMSG,PSOPLCK,ST,PSL,PSNP,IR,NOW,DR,NEW1,NEW11,RTN,DA,PPL,RXN,RX0,RXS,DIK,RXP,FLD,ACT,DIE,DIC,DIR,DIE,X,Y,DIRUT,DUOUT,SUSPT,C,D0,LFD,I,PSDA,RFDATE,DI,DQ,%,RFN,XFLAG
K HRX,PSPRK,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ Q
;
PARK(DA) ;
N PSODRUG
S PSODRUG("DEA")=$P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^",3)
N RESULTS,PSOPARKX
S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
I $G(PSOPARKX(0))'="YES" S VALMSG="Park a Prescription is turned off, Invalid Action !",VALMBCK="" Q
I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" Q
I $G(PSODRUG("DEA"))["D" W $C(7),$C(7) S VALMSG="This drug is not allowed to be parked!",VALMBCK="" Q
I $P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^")["CLOZAPINE" W $C(7),$C(7) S VALMSG="This drug is not allowed to be parked!",VALMBCK="" Q
I '$D(^XUSEC("PSORPH",DUZ))&'$D(^XUSEC("PSO TECH ADV",DUZ)) S VALMSG="Invalid Action Selection!",VALMBCK="" Q
I $G(^PSRX(DA,"PARK")),+$G(^PSRX(DA,"STA"))=0 S VALMSG="Already parked!",VALMBCK="" Q
S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient."),VALMBCK="" K PSOPLCK Q
K PSOPLCK D PSOL^PSSLOCK(DA) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULP Q
S Y(0)=^PSRX(DA,0),STA=+$G(^("STA")) I DT>$P(^PSRX(DA,2),"^",6) D D ULP G D1
.S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3),VALMBCK="R"
.I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D
..S 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,"SC","ZE",COMM) K COMM
S ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUED (EDIT)^PROVIDER HOLD^","^",STA+2)
I STA,STA'>4!(STA>11) D D ULP G D1
.S VALMSG="Rx: "_$P(Y(0),"^")_" is currently in a status of "_ST,VALMBCK="R" K ST,Y Q
D FULL^VALM1
S PSOFROM="PARK" D EN^PSOCMOPA K PSOFROM I $G(XFLAG) K XFLAG D ULP G D1
AR ;
D:$D(PSORX("PSOL")) RMP^PSOPRKA(DA)
F PI=1:1 Q:$P(PPL,",",PI)="" S DA=$P(PPL,",",PI) D PRK(DA) S DA=PSDA K PSDA D:$D(PSORX("PSOL")) RMP^PSOPRKA(DA)
K PI D ^PSOBUILD
D ULP
D1 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) K PSOMSG,PSOPLCK,RFN,DIR,RSDT,FLD,DA,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
Q
;
PRK(DA) ; - Rx Park update
; Recheck DEA code in case called from somewhere else
N PSODRUG
S PSODRUG("DEA")=$P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^",3)
I PSODRUG("DEA")["D" Q ; DRUG MARKED AS NOT PARKABLE
D PARK^PSOPRKA(DA)
Q
;
ULP ;
D UL^PSSLOCK(+$G(PSODFN))
Q
;
KILLPARK(RX) ; KILL PARK level and APARK xref
K ^PSRX(RX,"PARK"),^PSRX("APARK",1,RX)
Q
;
RXACT(RX,ACTION,REASON,OTHCOM,SUS) ; Adds PARK/UNPARK info to the Rx Activity Log
N RFL,X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO,COMM,PSOFILLDT,PSOFLDNM
S RFL=$$LSTRFL^PSOBPSU1(RX)
I ACTION="PK" S COMM="Rx placed in Parked status"_$S(+$G(SUS):" and removed from SUSPENSE",1:"")_" ("_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_")"_"("_$G(BPMW)_")"
I ACTION="UPK" S COMM="Rx removed from Parked status ("_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_")"
S DA(1)=RX,DIC="^PSRX("_RX_",""A"",",DLAYGO=52.3,DIC(0)="L" S:$G(OTHCOM)'="" OTHCOM=$TR(OTHCOM,";",","),COMM=COMM_" -"
S DIC("DR")=".02////E;.03////"_DUZ_";.04///"_$S((RFL>5):RFL+1,1:RFL)_";.05///"_COMM_$S($G(OTHCOM)'="":";4///"_OTHCOM,1:"")
S X=$$NOW^XLFDT() D FILE^DICN
;
I $G(PSOFRPK)!($G(PSOTOPK)) Q ;if park/unpark called from EDIT, that process should update Activity log
S COMM=$P($G(^DD(52,11,0)),"^")_" ("_$S(ACTION="UPK":"P",1:$G(BPMW))_"),"
S PSOFILLDT=$S(RFL:$P($G(^PSRX(RX,1,RFL,0)),U,1),1:$P($G(^PSRX(RX,2)),U,2))
I $D(PSOOLDFILLDT),PSOFILLDT'=PSOOLDFILLDT D
. N ZZ S ZZ=PSOOLDFILLDT S:ZZ ZZ=$E(ZZ,4,5)_"-"_$E(ZZ,6,7)_"-"_$E(ZZ,2,3)
. S PSOFLDNM=$P($G(^DD(52,22,0)),U,1)
. I RFL S PSOFLDNM=$P($G(^DD(52.1,.01,0)),U,1)
. S COMM=COMM_PSOFLDNM_" ("_ZZ_")"
S DIC("DR")=".02////E;.03////"_DUZ_";.04///"_$S((RFL>5):RFL+1,1:RFL)_";.05///"_COMM
D FILE^DICN
;
Q
;
MW ; WHEN UNPARKING, DON'T PROMPT FOR PARK
I $G(PSOFRPK) Q ; If unpark called from EDIT, already prompted for this field
K DIR
S PRKMW=""
S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW"
S DIR("B")="MAIL"
D ^DIR
I X[U!($G(DIRUT)) K Y Q
S PRKMW=Y
MWX K DIR,X,Y
Q
;
MWP(PSODA,PREVMWP,REFILL) ; UNHOLD;EDIT ROUTE - CHECK TO SEE IF SHOULD ALSO PROMPT FOR PARK
N PSODRUG,PARK,PREVMWP1
K PSOTOPK,PSOFRPK
I $G(PREVMWP)="" S PREVMWP="M" ; SAVE "BEFORE" PICKUP ROUTE
S PREVMWP1=$S(PREVMWP="W":"WINDOW",PREVMWP="P":"PARK",1:"MAIL")
S PARK=0 ; SEE WHETHER TO PROMPT FOR PARK
;I $P($G(PSOPAR),"^",34) S PARK=1
N RESULTS,PSOPARKX
S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
I $G(PSOPARKX(0))="YES" S PARK=1
I $P(^PSDRUG($P(^PSRX(PSODA,0),"^",6),0),"^")["CLOZAPINE" S PARK=0 ;*712
S PSODRUG("DEA")=$P(^PSDRUG($P(^PSRX(PSODA,0),"^",6),0),"^",3) I PSODRUG("DEA")["D" S PARK=0
K DIR,DIC
S PRKMW=""
S DIR(0)="S^M:MAIL;W:WINDOW;P:PARK",DIR("A")="MAIL/WINDOW/PARK"
I 'PARK S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW"
S DIR("B")=PREVMWP1
D ^DIR
I X[U!($G(DIRUT)) K Y Q
S PRKMW=Y
I PRKMW="P",PREVMWP'="P" S PSOTOPK=1 ; SET VARIABLE FOR CALLING ROUTINE TO FILE PARK LEVEL,"APARK" XREF, AND REMOVE FROM SUSPENSE AND UPDT ACT. LOG RELATED TO PARKING
I PREVMWP="P",PRKMW'="P" S PSOFRPK=1 ; CHANGED "FROM" PARK
K X,Y
Q
;
REFCK ;
N RSDT,LBLP
S (RSDT,LBLP)=0
D GETRELDT^PSOPRKA(DA)
I 'RSDT D CHKLBL^PSOPRKA(DA,RXF)
I 'RSDT,'LBLP D ^PSOCMOPA
I RSDT!(LBLP)!($D(PSOCMOP)) S REFCK=1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPRK 11430 printed Apr 09, 2024@21:25:50 Page 2
PSOPRK ;BIR/EJW - park/unpark functionality ; May 17, 2023@18:30:42
+1 ;;7.0;OUTPATIENT PHARMACY;**441,712**;DEC 1997;Build 20
+2 ;
+3 ; Reference to ^DD(52 in ICR #999
+4 ; Reference to ^PSDRUG( in ICR #221
+5 ; Reference to $$L^PSSLOCK,PSOL^PSSLOCK,PSOUL^PSSLOCK,UL^PSSLOCK in ICR #2789
+6 ;
UNPARK ;
+1 NEW RXIEN,PSOOLDFILLDT
+2 IF '$DATA(PSOPAR)
DO ^PSOLSET
if '$DATA(PSOPAR)
GOTO EX
+3 IF $GET(PSOBEDT)
IF $GET(PSOREJCT)
WRITE $CHAR(7),$CHAR(7)
SET VALMSG="Invalid Action at this time !"
SET VALMBCK=""
QUIT
+4 IF $GET(PSONACT)
WRITE $CHAR(7),$CHAR(7)
SET VALMSG="No Pharmacy Orderable Item !"
SET VALMBCK=""
QUIT
+5 SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)
IF '$GET(PSOPLCK)
DO LOCK^PSOORCPY
SET VALMSG=$SELECT($PIECE($GET(PSOPLCK),"^",2)'="":$PIECE($GET(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.")
KILL PSOPLCK
SET VALMBCK=""
QUIT
+6 KILL PSOPLCK
DO PSOL^PSSLOCK(DA)
IF '$GET(PSOMSG)
SET VALMSG=$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order.")
SET VALMBCK=""
KILL PSOMSG
DO ULP
QUIT
+7 SET Y(0)=^PSRX(DA,0)
SET STA=+$GET(^("STA"))
+8 IF STA!('$GET(^PSRX(DA,"PARK")))
SET VALMSG="Cannot unpark. Prescription is not parked."
SET VALMBCK=""
QUIT
+9 IF STA'=0!(('$DATA(^XUSEC("PSORPH",DUZ)))&('$DATA(^XUSEC("PSO TECH ADV",DUZ))))
SET VALMSG="Invalid Action Selection!"
SET VALMBCK=""
KILL Y,STA
DO PSOUL^PSSLOCK(DA)
DO ULP
QUIT
+10 DO FULL^VALM1
KILL DIR,DTOUT,DUOUT,DIRUT
+11 IF DT>$PIECE(^PSRX(DA,2),"^",6)
Begin DoDot:1
+12 SET (VALMSG,COMM)="Medication Expired on "_$EXTRACT($PIECE(^PSRX(DA,2),"^",6),4,5)_"-"_$EXTRACT($PIECE(^(2),"^",6),6,7)_"-"_$EXTRACT($PIECE(^(2),"^",6),2,3)
IF $PIECE(^PSRX(DA,"STA"),"^")<11
SET $PIECE(^PSRX(DA,"STA"),"^")=11
+13 DO KILLPARK(DA)
DO EN^PSOHLSN1(DA,"SC","ZE",COMM,"")
KILL COMM
End DoDot:1
DO ULP
GOTO EX
EN SET RXF=0
FOR I=0:0
SET I=$ORDER(^PSRX(DA,1,I))
if 'I
QUIT
SET RXF=I
SET RSDT=$PIECE(^(I,0),"^")
+1 SET PSOOLDFILLDT=$SELECT(RXF:$PIECE(^PSRX(DA,1,RXF,0),U,1),1:$PIECE(^PSRX(DA,2),U,2))
+2 SET RXIEN=DA
+3 KILL Y
IF RXF
Begin DoDot:1
+4 NEW DA,DIE
SET DA(1)=RXIEN
SET DA=RXF
SET DIE="^PSRX("_DA(1)_",1,"
SET PSOUNPRK=1
+5 SET RLDT=$PIECE(^PSRX(DA(1),1,DA,0),"^",18)
+6 IF 'RLDT
Begin DoDot:2
+7 ;Do not display a past date for refill date
IF RSDT<DT
Begin DoDot:3
+8 NEW Y,TD
SET Y=DT
XECUTE ^DD("DD")
SET TD=Y
+9 SET DR=".01R///^S X=TD"
+10 DO ^DIE
End DoDot:3
+11 ;User quit the UNPARK process
IF $DATA(Y)
Begin DoDot:3
+12 ;reset refill date
IF RSDT<DT
Begin DoDot:4
+13 NEW Y,TD
SET Y=RSDT
XECUTE ^DD("DD")
SET TD=Y
+14 SET DR=".01R///^S X=TD"
+15 DO ^DIE
End DoDot:4
End DoDot:3
End DoDot:2
+16 SET ZD(RXIEN)=$PIECE(^PSRX(DA(1),1,DA,0),"^")
+17 KILL PSOUNPRK
if $DATA(Y)
QUIT
SET PSORX("FILL DATE")=ZD(RXIEN)
SET DA=PSDA
KILL DA(1)
End DoDot:1
IF $DATA(Y)
DO ULP
GOTO EX
+18 ;
+19 ;PSO*7*298 Require an entry into fill date
+20 SET ACT=1
SET DIE="^PSRX("
SET FDT=$SELECT($PIECE(^PSRX(RXIEN,2),"^",2):$PIECE(^PSRX(RXIEN,2),"^",2),$PIECE(^PSRX(RXIEN,3),"^",2):$PIECE(^PSRX(RXIEN,3),"^",2),1:DT)
+21 IF FDT<DT
SET FDT=DT
+22 SET RLDT=$PIECE(^PSRX(DA,2),"^",13)
SET DR=""
SET RLDTP1=$PIECE(RLDT,".",1)
+23 IF 'RXF&'RLDT
SET DR="22R//^S X=FDT;Q;"
+24 ; DON'T INCLUDE PROMPT FOR PARK IF UNPARKING
+25 IF RLDT&($PIECE(^PSRX(DA,2),"^",2)="")
SET DR="22R//^S X=RLDTP1;Q;"
+26 SET DR=DR_"100///0;101///^S X=$S(RXF:$G(ZD(RXIEN)),1:$P(^PSRX(RXIEN,2),""^"",2))"
+27 ;
+28 DO ^DIE
KILL FDT
IF $DATA(Y)
SET VALMBCK="R"
DO ULP
GOTO EX
+29 IF $GET(PSOFRPK)
DO KILLPARK(DA)
GOTO UMSG
+30 NEW PRKMW
DO MW
IF PRKMW=""
SET VALMBCK="R"
DO ULP
GOTO EX
+31 DO KILLPARK(DA)
+32 IF 'RXF
SET $PIECE(^PSRX(DA,0),"^",11)=PRKMW
+33 IF RXF
IF $DATA(^PSRX(DA,1,RXF,0))
SET $PIECE(^PSRX(DA,1,RXF,0),"^",2)=PRKMW
UMSG SET VALMSG="RX# "_$PIECE(^PSRX(DA,0),"^")_" unparked"
+1 DO RXACT(DA,"UPK")
+2 ; Default to POLICY
NEW PSONOOR,COMM
SET PSONOOR="I"
+3 SET COMM="Medication Removed from Park by Pharmacy"
DO EN^PSOHLSN1(RXIEN,"SC","",COMM,PSONOOR)
KILL COMM
+4 SET PSORX("FILL DATE")=$SELECT('RXF:$PIECE(^PSRX(DA,2),"^",2),1:ZD(RXIEN))
DO KILLPARK(DA)
+5 SET (NEW1,NEW11)="^^"
+6 SET (RXF,RXFL(DA))=0
FOR JJ=0:0
SET JJ=$ORDER(^PSRX(DA,1,JJ))
if 'JJ
QUIT
SET (RXFL(RXIEN),RXF)=JJ
+7 IF $GET(PSXSYS)
DO UNPARK^PSOCMOPA
IF $GET(XFLAG)
DO ULP
GOTO EX
+8 IF $GET(RXIEN)
NEW REFCK
SET REFCK=0
DO REFCK
IF $GET(REFCK)
Begin DoDot:1
+9 IF $$TITRX^PSOUTL(RXIEN)="t"
SET VALMSG=VALMSG_" - Cannot Refill Titration Rx"
QUIT
+10 IF $ORDER(^PS(52.41,"ARF",RXIEN,0))
SET VALMSG=VALMSG_" - Refill request exists"
QUIT
+11 NEW X,Y,DIC,JJ
+12 SET X=$GET(PSORX("PATIENT STATUS"))
if 'X
SET X=$PIECE(RX0,"^",3)
+13 SET DIC=53
SET DIC(0)="QXZ"
DO ^DIC
+14 SET JJ=$$MAXNUMRF^PSOUTIL(+$GET(PSODRUG("IEN")),$PIECE(RX0,"^",8),+Y,.CLOZPAT)
IF 'JJ
SET VALMSG=VALMSG_" - Not Refillable"
QUIT
+15 KILL X,Y,DIC,JJ
+16 ; create a refill
NEW PSOREF
SET PSOREF("MAIL/WINDOW")=$GET(PRKMW)
SET PSOREF("IRXN")=RXIEN
DO ^PSOREF0
End DoDot:1
DO ULP
GOTO EX
+17 ; IF FUTURE DATE, PUT ON SUSPENSE WHEN UNPARKED
+18 IF PSORX("FILL DATE")>DT
IF $PIECE(PSOPAR,"^",6)
DO S^PSORXL
DO EX
DO ULP
QUIT
+19 SET PCOMH(RXIEN)="Medication Removed from Park by Pharmacy"
+20 IF $GET(RXIEN)
SET RXRH(RXIEN)=RXIEN
+21 ; MARK PRESCRIPTION AND LABEL AS BEING REPRINTED WHEN UNPARKING A RETURNED TO STOCK PRESCRIPTION
+22 IF $PIECE($GET(^PSRX(RXIEN,2)),"^",15)'=""
SET $PIECE(^PSRX(RXIEN,2),"^",14)=1
SET RXRP(RXIEN)=1
SET $PIECE(RXRP(RXIEN),"^",2)=$PIECE($GET(^PSRX(RXIEN,0)),"^",18)
+23 ;
+24 ; - Submitting Rx to ECME
+25 NEW ACTION
+26 IF $$SUBMIT^PSOBPSUT(RXIEN,+$GET(RXFL(RXIEN)))
Begin DoDot:1
+27 NEW RX,RFL
SET RX=RXIEN
SET RFL=+$GET(RXFL(RXIEN))
+28 NEW DA
SET ACTION=""
+29 DO ECMESND^PSOBPSU1(RX,RFL,,$SELECT(RFL:"RF",1:"OF"))
+30 ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358
+31 IF $$PSOET^PSOREJP3(RX,RFL)
SET ACTION="Q"
QUIT
+32 IF $$FIND^PSOREJUT(RX,RFL)
Begin DoDot:2
+33 SET ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q")
End DoDot:2
End DoDot:1
IF ACTION="Q"!(ACTION="^")
DO ULP
GOTO EX
+34 ;
+35 IF $GET(PSORX("PSOL",1))']""
SET PSORX("PSOL",1)=RXIEN_","
DO ULP
GOTO EX
+36 FOR PSOX1=0:0
SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
if 'PSOX1
QUIT
SET PSOX2=PSOX1
+37 IF $LENGTH(PSORX("PSOL",PSOX2))+$LENGTH(DA)<220
SET PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXIEN_","
+38 IF '$TEST
SET PSORX("PSOL",PSOX2+1)=RXIEN_","
+39 ;
+40 DO ULP
EX ;
+1 ; If called from edit (changed to or from Park), don't unlock/kill
+2 IF $GET(PSOTOPK)
KILL DR
QUIT
+3 IF $GET(PSOFRPK)
KILL DR
QUIT
+4 DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
DO ^PSOBUILD
+5 KILL PSOHRL,PSOMSG,PSOPLCK,ST,PSL,PSNP,IR,NOW,DR,NEW1,NEW11,RTN,DA,PPL,RXN,RX0,RXS,DIK,RXP,FLD,ACT,DIE,DIC,DIR,DIE,X,Y,DIRUT,DUOUT,SUSPT,C,D0,LFD,I,PSDA,RFDATE,DI,DQ,%,RFN,XFLAG
+6 KILL HRX,PSPRK,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ
QUIT
+7 ;
PARK(DA) ;
+1 NEW PSODRUG
+2 SET PSODRUG("DEA")=$PIECE(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0),"^",3)
+3 NEW RESULTS,PSOPARKX
+4 SET RESULTS="PSOPARKX"
DO GETPARK^PSORPC01()
+5 IF $GET(PSOPARKX(0))'="YES"
SET VALMSG="Park a Prescription is turned off, Invalid Action !"
SET VALMBCK=""
QUIT
+6 IF $GET(PSOBEDT)
WRITE $CHAR(7),$CHAR(7)
SET VALMSG="Invalid Action at this time !"
SET VALMBCK=""
QUIT
+7 IF $GET(PSONACT)
WRITE $CHAR(7),$CHAR(7)
SET VALMSG="No Pharmacy Orderable Item !"
SET VALMBCK=""
QUIT
+8 IF $GET(PSODRUG("DEA"))["D"
WRITE $CHAR(7),$CHAR(7)
SET VALMSG="This drug is not allowed to be parked!"
SET VALMBCK=""
QUIT
+9 IF $PIECE(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0),"^")["CLOZAPINE"
WRITE $CHAR(7),$CHAR(7)
SET VALMSG="This drug is not allowed to be parked!"
SET VALMBCK=""
QUIT
+10 IF '$DATA(^XUSEC("PSORPH",DUZ))&'$DATA(^XUSEC("PSO TECH ADV",DUZ))
SET VALMSG="Invalid Action Selection!"
SET VALMBCK=""
QUIT
+11 IF $GET(^PSRX(DA,"PARK"))
IF +$GET(^PSRX(DA,"STA"))=0
SET VALMSG="Already parked!"
SET VALMBCK=""
QUIT
+12 SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)
IF '$GET(PSOPLCK)
DO LOCK^PSOORCPY
SET VALMSG=$SELECT($PIECE($GET(PSOPLCK),"^",2)'="":$PIECE($GET(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.")
SET VALMBCK=""
KILL PSOPLCK
QUIT
+13 KILL PSOPLCK
DO PSOL^PSSLOCK(DA)
IF '$GET(PSOMSG)
SET VALMSG=$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order.")
SET VALMBCK=""
KILL PSOMSG
DO ULP
QUIT
+14 SET Y(0)=^PSRX(DA,0)
SET STA=+$GET(^("STA"))
IF DT>$PIECE(^PSRX(DA,2),"^",6)
Begin DoDot:1
+15 SET VALMSG="Medication Expired on "_$EXTRACT($PIECE(^PSRX(DA,2),"^",6),4,5)_"-"_$EXTRACT($PIECE(^(2),"^",6),6,7)_"-"_$EXTRACT($PIECE(^(2),"^",6),2,3)
SET VALMBCK="R"
+16 IF $PIECE(^PSRX(DA,"STA"),"^")<11
SET $PIECE(^PSRX(DA,"STA"),"^")=11
Begin DoDot:2
+17 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,"SC","ZE",COMM)
KILL COMM
End DoDot:2
End DoDot:1
DO ULP
GOTO D1
+18 SET ST=$PIECE("ERROR^ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUED (EDIT)^PROVIDER HOLD^","^",STA+2)
+19 IF STA
IF STA'>4!(STA>11)
Begin DoDot:1
+20 SET VALMSG="Rx: "_$PIECE(Y(0),"^")_" is currently in a status of "_ST
SET VALMBCK="R"
KILL ST,Y
QUIT
End DoDot:1
DO ULP
GOTO D1
+21 DO FULL^VALM1
+22 SET PSOFROM="PARK"
DO EN^PSOCMOPA
KILL PSOFROM
IF $GET(XFLAG)
KILL XFLAG
DO ULP
GOTO D1
AR ;
+1 if $DATA(PSORX("PSOL"))
DO RMP^PSOPRKA(DA)
+2 FOR PI=1:1
if $PIECE(PPL,",",PI)=""
QUIT
SET DA=$PIECE(PPL,",",PI)
DO PRK(DA)
SET DA=PSDA
KILL PSDA
if $DATA(PSORX("PSOL"))
DO RMP^PSOPRKA(DA)
+3 KILL PI
DO ^PSOBUILD
+4 DO ULP
D1 DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
KILL PSOMSG,PSOPLCK,RFN,DIR,RSDT,FLD,DA,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
+1 QUIT
+2 ;
PRK(DA) ; - Rx Park update
+1 ; Recheck DEA code in case called from somewhere else
+2 NEW PSODRUG
+3 SET PSODRUG("DEA")=$PIECE(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0),"^",3)
+4 ; DRUG MARKED AS NOT PARKABLE
IF PSODRUG("DEA")["D"
QUIT
+5 DO PARK^PSOPRKA(DA)
+6 QUIT
+7 ;
ULP ;
+1 DO UL^PSSLOCK(+$GET(PSODFN))
+2 QUIT
+3 ;
KILLPARK(RX) ; KILL PARK level and APARK xref
+1 KILL ^PSRX(RX,"PARK"),^PSRX("APARK",1,RX)
+2 QUIT
+3 ;
RXACT(RX,ACTION,REASON,OTHCOM,SUS) ; Adds PARK/UNPARK info to the Rx Activity Log
+1 NEW RFL,X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO,COMM,PSOFILLDT,PSOFLDNM
+2 SET RFL=$$LSTRFL^PSOBPSU1(RX)
+3 IF ACTION="PK"
SET COMM="Rx placed in Parked status"_$SELECT(+$GET(SUS):" and removed from SUSPENSE",1:"")_" ("_$EXTRACT(DT,4,5)_"-"_$EXTRACT(DT,6,7)_"-"_$EXTRACT(DT,2,3)_")"_"("_$GET(BPMW)_")"
+4 IF ACTION="UPK"
SET COMM="Rx removed from Parked status ("_$EXTRACT(DT,4,5)_"-"_$EXTRACT(DT,6,7)_"-"_$EXTRACT(DT,2,3)_")"
+5 SET DA(1)=RX
SET DIC="^PSRX("_RX_",""A"","
SET DLAYGO=52.3
SET DIC(0)="L"
if $GET(OTHCOM)'=""
SET OTHCOM=$TRANSLATE(OTHCOM,";",",")
SET COMM=COMM_" -"
+6 SET DIC("DR")=".02////E;.03////"_DUZ_";.04///"_$SELECT((RFL>5):RFL+1,1:RFL)_";.05///"_COMM_$SELECT($GET(OTHCOM)'="":";4///"_OTHCOM,1:"")
+7 SET X=$$NOW^XLFDT()
DO FILE^DICN
+8 ;
+9 ;if park/unpark called from EDIT, that process should update Activity log
IF $GET(PSOFRPK)!($GET(PSOTOPK))
QUIT
+10 SET COMM=$PIECE($GET(^DD(52,11,0)),"^")_" ("_$SELECT(ACTION="UPK":"P",1:$GET(BPMW))_"),"
+11 SET PSOFILLDT=$SELECT(RFL:$PIECE($GET(^PSRX(RX,1,RFL,0)),U,1),1:$PIECE($GET(^PSRX(RX,2)),U,2))
+12 IF $DATA(PSOOLDFILLDT)
IF PSOFILLDT'=PSOOLDFILLDT
Begin DoDot:1
+13 NEW ZZ
SET ZZ=PSOOLDFILLDT
if ZZ
SET ZZ=$EXTRACT(ZZ,4,5)_"-"_$EXTRACT(ZZ,6,7)_"-"_$EXTRACT(ZZ,2,3)
+14 SET PSOFLDNM=$PIECE($GET(^DD(52,22,0)),U,1)
+15 IF RFL
SET PSOFLDNM=$PIECE($GET(^DD(52.1,.01,0)),U,1)
+16 SET COMM=COMM_PSOFLDNM_" ("_ZZ_")"
End DoDot:1
+17 SET DIC("DR")=".02////E;.03////"_DUZ_";.04///"_$SELECT((RFL>5):RFL+1,1:RFL)_";.05///"_COMM
+18 DO FILE^DICN
+19 ;
+20 QUIT
+21 ;
MW ; WHEN UNPARKING, DON'T PROMPT FOR PARK
+1 ; If unpark called from EDIT, already prompted for this field
IF $GET(PSOFRPK)
QUIT
+2 KILL DIR
+3 SET PRKMW=""
+4 SET DIR(0)="S^M:MAIL;W:WINDOW"
SET DIR("A")="MAIL/WINDOW"
+5 SET DIR("B")="MAIL"
+6 DO ^DIR
+7 IF X[U!($GET(DIRUT))
KILL Y
QUIT
+8 SET PRKMW=Y
MWX KILL DIR,X,Y
+1 QUIT
+2 ;
MWP(PSODA,PREVMWP,REFILL) ; UNHOLD;EDIT ROUTE - CHECK TO SEE IF SHOULD ALSO PROMPT FOR PARK
+1 NEW PSODRUG,PARK,PREVMWP1
+2 KILL PSOTOPK,PSOFRPK
+3 ; SAVE "BEFORE" PICKUP ROUTE
IF $GET(PREVMWP)=""
SET PREVMWP="M"
+4 SET PREVMWP1=$SELECT(PREVMWP="W":"WINDOW",PREVMWP="P":"PARK",1:"MAIL")
+5 ; SEE WHETHER TO PROMPT FOR PARK
SET PARK=0
+6 ;I $P($G(PSOPAR),"^",34) S PARK=1
+7 NEW RESULTS,PSOPARKX
+8 SET RESULTS="PSOPARKX"
DO GETPARK^PSORPC01()
+9 IF $GET(PSOPARKX(0))="YES"
SET PARK=1
+10 ;*712
IF $PIECE(^PSDRUG($PIECE(^PSRX(PSODA,0),"^",6),0),"^")["CLOZAPINE"
SET PARK=0
+11 SET PSODRUG("DEA")=$PIECE(^PSDRUG($PIECE(^PSRX(PSODA,0),"^",6),0),"^",3)
IF PSODRUG("DEA")["D"
SET PARK=0
+12 KILL DIR,DIC
+13 SET PRKMW=""
+14 SET DIR(0)="S^M:MAIL;W:WINDOW;P:PARK"
SET DIR("A")="MAIL/WINDOW/PARK"
+15 IF 'PARK
SET DIR(0)="S^M:MAIL;W:WINDOW"
SET DIR("A")="MAIL/WINDOW"
+16 SET DIR("B")=PREVMWP1
+17 DO ^DIR
+18 IF X[U!($GET(DIRUT))
KILL Y
QUIT
+19 SET PRKMW=Y
+20 ; SET VARIABLE FOR CALLING ROUTINE TO FILE PARK LEVEL,"APARK" XREF, AND REMOVE FROM SUSPENSE AND UPDT ACT. LOG RELATED TO PARKING
IF PRKMW="P"
IF PREVMWP'="P"
SET PSOTOPK=1
+21 ; CHANGED "FROM" PARK
IF PREVMWP="P"
IF PRKMW'="P"
SET PSOFRPK=1
+22 KILL X,Y
+23 QUIT
+24 ;
REFCK ;
+1 NEW RSDT,LBLP
+2 SET (RSDT,LBLP)=0
+3 DO GETRELDT^PSOPRKA(DA)
+4 IF 'RSDT
DO CHKLBL^PSOPRKA(DA,RXF)
+5 IF 'RSDT
IF 'LBLP
DO ^PSOCMOPA
+6 IF RSDT!(LBLP)!($DATA(PSOCMOP))
SET REFCK=1
+7 QUIT
+8 ;
