PSOHLD ;BIR/SAB - hold unhold functionality ; OCT 04, 2023@11:10:12
;;7.0;OUTPATIENT PHARMACY;**1,16,21,24,27,32,55,82,114,130,166,148,268,281,298,358,353,385,386,370,488,562,441,712,780**;DEC 1997;Build 3
;
; Reference to ^DD(52 in ICR #999
; Reference to L, UL, PSOL, and PSOUL^PSSLOCK in ICR #2789
;
UHLD ; Rx Unhold
N REASON,RXIEN
S PSOFROM="UNHOLD" ;*488
I '$D(PSOPAR) D ^PSOLSET G:'$D(PSOPAR) EX
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
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=16 S VALMSG="Placed on HOLD by Provider!" K Y,STA D PSOUL^PSSLOCK(DA) D ULP S VALMBCK="" Q
I STA'=3!(('$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
S REASON=$$GET1^DIQ(52,DA,99,"I")
I ('$D(^XUSEC("PSORPH",DUZ))),",1,7,8,98,"'[(","_REASON_",") D K Y,STA D PSOUL^PSSLOCK(DA) D ULP Q
. S VALMSG="The HOLD can only be removed by a pharmacist",VALMBCK=""
D FULL^VALM1 K DIR,DTOUT,DUOUT,DIRUT D NOOR I $D(DIRUT) D ULP G EX
I DT>$P(^PSRX(DA,2),"^",6) D D ULP G EX
.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) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11
.S ^PSRX(DA,"H")="",COMM="Medication Expired on "_$E($P(^(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
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 RXIEN=DA
; - Asking for UNHOLD Comments
N HLDCOM
S HLDCOM=$$GET1^DIQ(52,RXIEN,99.1)_" (REASON: "_$$GET1^DIQ(52,RXIEN,99)_") on "_$$GET1^DIQ(52,RXIEN,99.2)
W !!,"HOLD COMMENTS: " F I=1:1 Q:HLDCOM="" W ?15,$E(HLDCOM,1,65),! S HLDCOM=$E(HLDCOM,66,999)
K DIR,DUOUT,DTOUT S DIR(0)="FO^3:200",DIR("A")="UNHOLD COMMENTS" D ^DIR I $D(DTOUT)!$D(DUOUT) D ULP G EX
S OTHCOM=X
;
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,",PSOUNHLD=1
.S RLDT=$P(^PSRX(DA(1),1,DA,0),"^",18)
.I 'RLDT D
..I RSDT<DT D ;353 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
..S DR=".01R"
..D ^DIE
..I $D(Y) D Q ;User quit the UNHOLD 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
..D MWPR I $D(DIRUT) K DIRUT D Q
...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 DR="2////"_Y D ^DIE
.I $E($$GET1^DIQ(52.1,RXF_","_RXIEN,2))="P" S PSOTOPK=1 ;441
.I $$GET1^DIQ(52.1,RXF_","_RXIEN,2)["W" S BINGRTE="W",BINGCRT=1 ;*488
.S ZD(RXIEN)=$P(^PSRX(DA(1),1,DA,0),"^")
.K PSOUNHLD Q:$D(Y) S PSORX("FILL DATE")=$P(^PSRX(DA(1),1,DA,0),"^"),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),1:DT)
S RLDT=$P(^PSRX(RXIEN,2),"^",13),DR="",RLDTP1=$P(RLDT,".",1)
N MWPR S MWPR=0 I 'RXF&'RLDT S DR="22R//^S X=FDT;Q;" S MWPR=1
I RLDT&($P(^PSRX(RXIEN,2),"^",2)="") S DR="22R//^S X=RLDTP1;Q;" S MWPR=1
D ^DIE K FDT I $D(Y) S VALMBCK="R" D ULP G EX
I MWPR D I $D(DIRUT) K DIRUT S VALMBCK="R" D ULP G EX
.D MWPR Q:$D(DIRUT)
.S DR="11////"_Y D ^DIE
S 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 'RXF,$E($$GET1^DIQ(52,RXIEN,11))="P" S PSOTOPK=1 ;441
I 'RXF,$$GET1^DIQ(52,RXIEN,11)["W" S BINGRTE="W",BINGCRT=1 ;*488
;
; - Saving UNHOLD COMMENTS in the Refill REMARKS field.
I $G(OTHCOM)'="" D
. N DA,DIE,DR S DA(1)=RXIEN,DA=RXF,DIE="^PSRX("_DA(1)_",1,",DR="3///"_$E($TR(OTHCOM,";",","),1,60) D ^DIE
; - Logging Rx Activity Log
D RXACT(RXIEN,"U",,$G(OTHCOM))
;
S COMM="Medication Removed from Hold by Pharmacy" D EN^PSOHLSN1(RXIEN,"OE","",COMM,PSONOOR) K COMM,PSONOOR
S PSORX("FILL DATE")=$S('RXF:$P(^PSRX(RXIEN,2),"^",2),1:ZD(RXIEN)) I $G(^PSRX(RXIEN,"H")) K ^PSRX("AH",$P(^PSRX(RXIEN,"H"),"^"),DA)
S ^PSRX(RXIEN,"H")=""
;D ACT^PSOHLDA
S (NEW1,NEW11)="^^"
S (RXF,RXFL(RXIEN))=0 F JJ=0:0 S JJ=$O(^PSRX(RXIEN,1,JJ)) Q:'JJ S (RXFL(RXIEN),RXF)=JJ
I $G(PSXSYS) D UNHOLD^PSOCMOPA I $G(XFLAG) D ULP G EX
I $G(RXIEN) D RELC I $G(PSOHRL) D ULP G EX
I PSORX("FILL DATE")>DT,$P(PSOPAR,"^",6) D S^PSORXL,EX,ULP Q
S PCOMH(RXIEN)="Medication Removed from Hold by Pharmacy"
I $G(RXIEN) S RXRH(RXIEN)=RXIEN
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) ; MARK PRESCRIPTION AND LABEL AS BEING REPRINTED WHEN UNHOLDING A RETURNED TO STOCK PRESCRIPTION
I $G(PSOTOPK) D PRK^PSOPRK(RXIEN) D ULP G EX ;441
;
; - 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,943","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(RXIEN)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXIEN_","
E S PSORX("PSOL",PSOX2+1)=RXIEN_","
;
D ULP
EX 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,RFDATE,DI,DQ,%,RFN,XFLAG
K HRX,PSHLD,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ,PSOTOPK Q
;
HLD ;
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 '$D(^XUSEC("PSORPH",DUZ))&'$D(^XUSEC("PSO TECH ADV",DUZ)) S VALMSG="Invalid Action Selection!",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 D NOOR I $D(DIRUT) D ULP G D1
D HLD^PSOCMOPA I $G(XFLAG) K XFLAG D ULP G D1
K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99"
; A reduced set of HOLD REASON CODEs is available for Pharmacy Techs
I '$D(^XUSEC("PSORPH",DUZ)) D
. S DIR(0)="S^1:INSUFFICIENT QTY IN STOCK;7:BAD ADDRESS;8:PER PATIENT REQUEST;98:OTHER/TECH (NON-CLINICAL)"
. S DIR("L",1)="Enter reason medication is placed in a 'Hold' status."
. S DIR("L",2)="Choose from:"
. S DIR("L",3)="1 INSUFFICIENT QTY IN STOCK"
. S DIR("L",4)="7 BAD ADDRESS"
. S DIR("L",5)="8 PER PATIENT REQUEST"
. S DIR("L")="98 OTHER/TECH (NON-CLINICAL)"
;
D ^DIR S FLD(99)=Y I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,DIR D ULP G D1
I ($G(FLD(99))=98!($G(FLD(99))=99)) K DIR S DIR("A")=$P(^DD(52,99.1,0),"^"),DIR(0)="52,99.1" D ^DIR S FLD(99.1)=Y G AR
E K DIR S DIR(0)="FO^10:100",DIR("A")="HOLD COMMENTS" D ^DIR S FLD(99.1)=Y
AR I $D(DUOUT)!($D(DTOUT)) K DIRUT,DUOUT,DIR S VALMBCK="R" D ULP G D1
F PI=1:1 Q:$P(PPL,",",PI)="" S DA=$P(PPL,",",PI) D H S DA=PSDA K PSDA D:$D(PSORX("PSOL")) RMP^PSOHLDA
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
;
H ; - Rx HOLD update
D HOLD^PSOHLDA
Q
;
FLD N DA K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99" D
.; A reduced set of HOLD REASON CODEs is available for Pharmacy Techs ;*370
.I $D(^XUSEC("PSORPH",DUZ)) Q
.S DIR(0)="S^1:INSUFFICIENT QTY IN STOCK;7:BAD ADDRESS;8:PER PATIENT REQUEST;98:OTHER/TECH (NON-CLINICAL)"
.S DIR("L",1)="Enter reason medication is placed in a 'Hold' status."
.S DIR("L",2)="Choose from:"
.S DIR("L",3)="1 INSUFFICIENT QTY IN STOCK"
.S DIR("L",4)="7 BAD ADDRESS"
.S DIR("L",5)="8 PER PATIENT REQUEST"
.S DIR("L")="98 OTHER/TECH (NON-CLINICAL)"
D ^DIR Q:$D(DUOUT)!($D(DIRUT)) S FLD(99)=Y
S COMM=Y(0)
I $G(FLD(99))=99 K DIR S DIR("A")=$P(^DD(52,99.1,0),"^"),DIR(0)="52,99.1" D ^DIR Q:$D(DUOUT)!($D(DIRUT)) S (FLD(99.1),COMM)=Y Q
E S FLD(99.1)=""
Q
NOOR ;ask nature of order
K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D Q
.S PSONOOR=$$NA^ORX1("W",0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))
.I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q
.S DIRUT=1 K PSONOOR
S DIR("A")="Nature of Order: ",DIR("B")="WRITTEN"
S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
NOORX D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT) S PSONOOR=Y
Q
ULP ;
D UL^PSSLOCK(+$G(PSODFN))
Q
RELC ;
S (PSOHRL,PSOHTX)=0 F PSOHT=0:0 S PSOHT=$O(^PSRX(DA,1,PSOHT)) Q:'PSOHT S:$D(^PSRX(DA,1,PSOHT,0)) PSOHTX=PSOHT
I $G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,1,PSOHTX,0)),"^",18):1,1:0)
I '$G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,2)),"^",13):1,1:0)
K PSOHTX,PSOHT
Q
RXACT(RX,ACTION,REASON,OTHCOM,SUS) ; Adds HOLD/UNHOLD comments to the Rx Activity Log
N RFL,X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO,COMM
S RFL=$$LSTRFL^PSOBPSU1(RX)
I ACTION="H" S COMM="Rx placed on HOLD (Reason: "_REASON_")"_$S(+$G(SUS):" and removed from SUSPENSE",1:"")
I ACTION="U" S COMM="Rx removed from HOLD"
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///"_ACTION_";.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
Q
;
MWPR ;
N RESULTS,PSOPARKX,DV K DIR,DUOUT,DTOUT,DIRUT
S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
;PSO*7*780 Do not allow Park when DEA handling contains D
S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW"
I $G(PSOPARKX(0))="YES" D
. I $P(^PSDRUG($P(^PSRX(RXIEN,0),"^",6),0),"^",3)'["D" S DIR(0)="S^M:MAIL;W:WINDOW;P:PARK",DIR("A")="MAIL/WINDOW/PARK"
S DV=$S(RXF:$$GET1^DIQ(52.1,RXF_","_RXIEN,2),1:$$GET1^DIQ(52,RXIEN,11))
S:$E(DV)="P" DV="PARK"
I $E(DV)="P",DIR(0)'["P:" S DV=""
S DIR("B")=DV
D ^DIR K DIR,DUOUT,DTOUT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLD 11910 printed Sep 23, 2025@20:06:05 Page 2
PSOHLD ;BIR/SAB - hold unhold functionality ; OCT 04, 2023@11:10:12
+1 ;;7.0;OUTPATIENT PHARMACY;**1,16,21,24,27,32,55,82,114,130,166,148,268,281,298,358,353,385,386,370,488,562,441,712,780**;DEC 1997;Build 3
+2 ;
+3 ; Reference to ^DD(52 in ICR #999
+4 ; Reference to L, UL, PSOL, and PSOUL^PSSLOCK in ICR #2789
+5 ;
UHLD ; Rx Unhold
+1 NEW REASON,RXIEN
+2 ;*488
SET PSOFROM="UNHOLD"
+3 IF '$DATA(PSOPAR)
DO ^PSOLSET
if '$DATA(PSOPAR)
GOTO EX
+4 IF $GET(PSOBEDT)
WRITE $CHAR(7),$CHAR(7)
SET VALMSG="Invalid Action at this time !"
SET VALMBCK=""
QUIT
+5 IF $GET(PSONACT)
WRITE $CHAR(7),$CHAR(7)
SET VALMSG="No Pharmacy Orderable Item !"
SET VALMBCK=""
QUIT
+6 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
+7 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
+8 SET Y(0)=^PSRX(DA,0)
SET STA=+$GET(^("STA"))
+9 IF STA=16
SET VALMSG="Placed on HOLD by Provider!"
KILL Y,STA
DO PSOUL^PSSLOCK(DA)
DO ULP
SET VALMBCK=""
QUIT
+10 IF STA'=3!(('$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
+11 SET REASON=$$GET1^DIQ(52,DA,99,"I")
+12 IF ('$DATA(^XUSEC("PSORPH",DUZ)))
IF ",1,7,8,98,"'[(","_REASON_",")
Begin DoDot:1
+13 SET VALMSG="The HOLD can only be removed by a pharmacist"
SET VALMBCK=""
End DoDot:1
KILL Y,STA
DO PSOUL^PSSLOCK(DA)
DO ULP
QUIT
+14 DO FULL^VALM1
KILL DIR,DTOUT,DUOUT,DIRUT
DO NOOR
IF $DATA(DIRUT)
DO ULP
GOTO EX
+15 IF DT>$PIECE(^PSRX(DA,2),"^",6)
Begin DoDot:1
+16 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)
IF $PIECE(^PSRX(DA,"STA"),"^")<11
SET $PIECE(^PSRX(DA,"STA"),"^")=11
+17 SET ^PSRX(DA,"H")=""
SET COMM="Medication Expired on "_$EXTRACT($PIECE(^(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: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 RXIEN=DA
+2 ; - Asking for UNHOLD Comments
+3 NEW HLDCOM
+4 SET HLDCOM=$$GET1^DIQ(52,RXIEN,99.1)_" (REASON: "_$$GET1^DIQ(52,RXIEN,99)_") on "_$$GET1^DIQ(52,RXIEN,99.2)
+5 WRITE !!,"HOLD COMMENTS: "
FOR I=1:1
if HLDCOM=""
QUIT
WRITE ?15,$EXTRACT(HLDCOM,1,65),!
SET HLDCOM=$EXTRACT(HLDCOM,66,999)
+6 KILL DIR,DUOUT,DTOUT
SET DIR(0)="FO^3:200"
SET DIR("A")="UNHOLD COMMENTS"
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
DO ULP
GOTO EX
+7 SET OTHCOM=X
+8 ;
+9 KILL Y
IF RXF
Begin DoDot:1
+10 NEW DA,DIE
SET DA(1)=RXIEN
SET DA=RXF
SET DIE="^PSRX("_DA(1)_",1,"
SET PSOUNHLD=1
+11 SET RLDT=$PIECE(^PSRX(DA(1),1,DA,0),"^",18)
+12 IF 'RLDT
Begin DoDot:2
+13 ;353 Do not display a past date for refill date'
IF RSDT<DT
Begin DoDot:3
+14 NEW Y,TD
SET Y=DT
XECUTE ^DD("DD")
SET TD=Y
+15 SET DR=".01R///^S X=TD"
+16 DO ^DIE
End DoDot:3
+17 SET DR=".01R"
+18 DO ^DIE
+19 ;User quit the UNHOLD process
IF $DATA(Y)
Begin DoDot:3
+20 ;reset refill date
IF RSDT<DT
Begin DoDot:4
+21 NEW Y,TD
SET Y=RSDT
XECUTE ^DD("DD")
SET TD=Y
+22 SET DR=".01R///^S X=TD"
+23 DO ^DIE
End DoDot:4
End DoDot:3
QUIT
+24 DO MWPR
IF $DATA(DIRUT)
KILL DIRUT
Begin DoDot:3
+25 ;reset refill date
IF RSDT<DT
Begin DoDot:4
+26 NEW Y,TD
SET Y=RSDT
XECUTE ^DD("DD")
SET TD=Y
+27 SET DR=".01R///^S X=TD"
+28 DO ^DIE
End DoDot:4
End DoDot:3
QUIT
+29 SET DR="2////"_Y
DO ^DIE
End DoDot:2
+30 ;441
IF $EXTRACT($$GET1^DIQ(52.1,RXF_","_RXIEN,2))="P"
SET PSOTOPK=1
+31 ;*488
IF $$GET1^DIQ(52.1,RXF_","_RXIEN,2)["W"
SET BINGRTE="W"
SET BINGCRT=1
+32 SET ZD(RXIEN)=$PIECE(^PSRX(DA(1),1,DA,0),"^")
+33 KILL PSOUNHLD
if $DATA(Y)
QUIT
SET PSORX("FILL DATE")=$PIECE(^PSRX(DA(1),1,DA,0),"^")
SET DA=PSDA
KILL DA(1)
End DoDot:1
IF $DATA(Y)
DO ULP
GOTO EX
+34 ;
+35 ;PSO*7*298 Require an entry into fill date
+36 SET ACT=1
SET DIE="^PSRX("
SET FDT=$SELECT($PIECE(^PSRX(RXIEN,2),"^",2):$PIECE(^PSRX(RXIEN,2),"^",2),1:DT)
+37 SET RLDT=$PIECE(^PSRX(RXIEN,2),"^",13)
SET DR=""
SET RLDTP1=$PIECE(RLDT,".",1)
+38 NEW MWPR
SET MWPR=0
IF 'RXF&'RLDT
SET DR="22R//^S X=FDT;Q;"
SET MWPR=1
+39 IF RLDT&($PIECE(^PSRX(RXIEN,2),"^",2)="")
SET DR="22R//^S X=RLDTP1;Q;"
SET MWPR=1
+40 DO ^DIE
KILL FDT
IF $DATA(Y)
SET VALMBCK="R"
DO ULP
GOTO EX
+41 IF MWPR
Begin DoDot:1
+42 DO MWPR
if $DATA(DIRUT)
QUIT
+43 SET DR="11////"_Y
DO ^DIE
End DoDot:1
IF $DATA(DIRUT)
KILL DIRUT
SET VALMBCK="R"
DO ULP
GOTO EX
+44 SET DR="100///0;101///^S X=$S(RXF:$G(ZD(RXIEN)),1:$P(^PSRX(RXIEN,2),""^"",2))"
+45 DO ^DIE
KILL FDT
IF $DATA(Y)
SET VALMBCK="R"
DO ULP
GOTO EX
+46 ;441
IF 'RXF
IF $EXTRACT($$GET1^DIQ(52,RXIEN,11))="P"
SET PSOTOPK=1
+47 ;*488
IF 'RXF
IF $$GET1^DIQ(52,RXIEN,11)["W"
SET BINGRTE="W"
SET BINGCRT=1
+48 ;
+49 ; - Saving UNHOLD COMMENTS in the Refill REMARKS field.
+50 IF $GET(OTHCOM)'=""
Begin DoDot:1
+51 NEW DA,DIE,DR
SET DA(1)=RXIEN
SET DA=RXF
SET DIE="^PSRX("_DA(1)_",1,"
SET DR="3///"_$EXTRACT($TRANSLATE(OTHCOM,";",","),1,60)
DO ^DIE
End DoDot:1
+52 ; - Logging Rx Activity Log
+53 DO RXACT(RXIEN,"U",,$GET(OTHCOM))
+54 ;
+55 SET COMM="Medication Removed from Hold by Pharmacy"
DO EN^PSOHLSN1(RXIEN,"OE","",COMM,PSONOOR)
KILL COMM,PSONOOR
+56 SET PSORX("FILL DATE")=$SELECT('RXF:$PIECE(^PSRX(RXIEN,2),"^",2),1:ZD(RXIEN))
IF $GET(^PSRX(RXIEN,"H"))
KILL ^PSRX("AH",$PIECE(^PSRX(RXIEN,"H"),"^"),DA)
+57 SET ^PSRX(RXIEN,"H")=""
+58 ;D ACT^PSOHLDA
+59 SET (NEW1,NEW11)="^^"
+60 SET (RXF,RXFL(RXIEN))=0
FOR JJ=0:0
SET JJ=$ORDER(^PSRX(RXIEN,1,JJ))
if 'JJ
QUIT
SET (RXFL(RXIEN),RXF)=JJ
+61 IF $GET(PSXSYS)
DO UNHOLD^PSOCMOPA
IF $GET(XFLAG)
DO ULP
GOTO EX
+62 IF $GET(RXIEN)
DO RELC
IF $GET(PSOHRL)
DO ULP
GOTO EX
+63 IF PSORX("FILL DATE")>DT
IF $PIECE(PSOPAR,"^",6)
DO S^PSORXL
DO EX
DO ULP
QUIT
+64 SET PCOMH(RXIEN)="Medication Removed from Hold by Pharmacy"
+65 IF $GET(RXIEN)
SET RXRH(RXIEN)=RXIEN
+66 ; MARK PRESCRIPTION AND LABEL AS BEING REPRINTED WHEN UNHOLDING A RETURNED TO STOCK PRESCRIPTION
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)
+67 ;441
IF $GET(PSOTOPK)
DO PRK^PSOPRK(RXIEN)
DO ULP
GOTO EX
+68 ;
+69 ; - Submitting Rx to ECME
+70 NEW ACTION
+71 IF $$SUBMIT^PSOBPSUT(RXIEN,+$GET(RXFL(RXIEN)))
Begin DoDot:1
+72 NEW RX,RFL
SET RX=RXIEN
SET RFL=+$GET(RXFL(RXIEN))
+73 NEW DA
SET ACTION=""
+74 DO ECMESND^PSOBPSU1(RX,RFL,,$SELECT(RFL:"RF",1:"OF"))
+75 ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358
+76 IF $$PSOET^PSOREJP3(RX,RFL)
SET ACTION="Q"
QUIT
+77 IF $$FIND^PSOREJUT(RX,RFL)
Begin DoDot:2
+78 SET ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88,943","ED","IOQ","Q")
End DoDot:2
End DoDot:1
IF ACTION="Q"!(ACTION="^")
DO ULP
GOTO EX
+79 ;
+80 IF $GET(PSORX("PSOL",1))']""
SET PSORX("PSOL",1)=RXIEN_","
DO ULP
GOTO EX
+81 FOR PSOX1=0:0
SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
if 'PSOX1
QUIT
SET PSOX2=PSOX1
+82 IF $LENGTH(PSORX("PSOL",PSOX2))+$LENGTH(RXIEN)<220
SET PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXIEN_","
+83 IF '$TEST
SET PSORX("PSOL",PSOX2+1)=RXIEN_","
+84 ;
+85 DO ULP
EX DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
DO ^PSOBUILD
+1 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,RFDATE,DI,DQ,%,RFN,XFLAG
+2 KILL HRX,PSHLD,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ,PSOTOPK
QUIT
+3 ;
HLD ;
+1 IF $GET(PSOBEDT)
WRITE $CHAR(7),$CHAR(7)
SET VALMSG="Invalid Action at this time !"
SET VALMBCK=""
QUIT
+2 IF $GET(PSONACT)
WRITE $CHAR(7),$CHAR(7)
SET VALMSG="No Pharmacy Orderable Item !"
SET VALMBCK=""
QUIT
+3 IF '$DATA(^XUSEC("PSORPH",DUZ))&'$DATA(^XUSEC("PSO TECH ADV",DUZ))
SET VALMSG="Invalid Action Selection!"
SET VALMBCK=""
QUIT
+4 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
+5 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
+6 SET Y(0)=^PSRX(DA,0)
SET STA=+$GET(^("STA"))
IF DT>$PIECE(^PSRX(DA,2),"^",6)
Begin DoDot:1
+7 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"
+8 IF $PIECE(^PSRX(DA,"STA"),"^")<11
SET $PIECE(^PSRX(DA,"STA"),"^")=11
Begin DoDot:2
+9 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
+10 SET ST=$PIECE("ERROR^ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUED (EDIT)^PROVIDER HOLD^","^",STA+2)
+11 IF STA
IF STA'>4!(STA>11)
Begin DoDot:1
+12 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
+13 DO FULL^VALM1
DO NOOR
IF $DATA(DIRUT)
DO ULP
GOTO D1
+14 DO HLD^PSOCMOPA
IF $GET(XFLAG)
KILL XFLAG
DO ULP
GOTO D1
+15 KILL DIR
SET DIR("A")=$PIECE(^DD(52,99,0),"^")
SET DIR(0)="52,99"
+16 ; A reduced set of HOLD REASON CODEs is available for Pharmacy Techs
+17 IF '$DATA(^XUSEC("PSORPH",DUZ))
Begin DoDot:1
+18 SET DIR(0)="S^1:INSUFFICIENT QTY IN STOCK;7:BAD ADDRESS;8:PER PATIENT REQUEST;98:OTHER/TECH (NON-CLINICAL)"
+19 SET DIR("L",1)="Enter reason medication is placed in a 'Hold' status."
+20 SET DIR("L",2)="Choose from:"
+21 SET DIR("L",3)="1 INSUFFICIENT QTY IN STOCK"
+22 SET DIR("L",4)="7 BAD ADDRESS"
+23 SET DIR("L",5)="8 PER PATIENT REQUEST"
+24 SET DIR("L")="98 OTHER/TECH (NON-CLINICAL)"
End DoDot:1
+25 ;
+26 DO ^DIR
SET FLD(99)=Y
IF $DATA(DUOUT)!($DATA(DIRUT))
KILL DIRUT,DUOUT,DIR
DO ULP
GOTO D1
+27 IF ($GET(FLD(99))=98!($GET(FLD(99))=99))
KILL DIR
SET DIR("A")=$PIECE(^DD(52,99.1,0),"^")
SET DIR(0)="52,99.1"
DO ^DIR
SET FLD(99.1)=Y
GOTO AR
+28 IF '$TEST
KILL DIR
SET DIR(0)="FO^10:100"
SET DIR("A")="HOLD COMMENTS"
DO ^DIR
SET FLD(99.1)=Y
AR IF $DATA(DUOUT)!($DATA(DTOUT))
KILL DIRUT,DUOUT,DIR
SET VALMBCK="R"
DO ULP
GOTO D1
+1 FOR PI=1:1
if $PIECE(PPL,",",PI)=""
QUIT
SET DA=$PIECE(PPL,",",PI)
DO H
SET DA=PSDA
KILL PSDA
if $DATA(PSORX("PSOL"))
DO RMP^PSOHLDA
+2 KILL PI
DO ^PSOBUILD
+3 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 ;
H ; - Rx HOLD update
+1 DO HOLD^PSOHLDA
+2 QUIT
+3 ;
FLD NEW DA
KILL DIR
SET DIR("A")=$PIECE(^DD(52,99,0),"^")
SET DIR(0)="52,99"
Begin DoDot:1
+1 ; A reduced set of HOLD REASON CODEs is available for Pharmacy Techs ;*370
+2 IF $DATA(^XUSEC("PSORPH",DUZ))
QUIT
+3 SET DIR(0)="S^1:INSUFFICIENT QTY IN STOCK;7:BAD ADDRESS;8:PER PATIENT REQUEST;98:OTHER/TECH (NON-CLINICAL)"
+4 SET DIR("L",1)="Enter reason medication is placed in a 'Hold' status."
+5 SET DIR("L",2)="Choose from:"
+6 SET DIR("L",3)="1 INSUFFICIENT QTY IN STOCK"
+7 SET DIR("L",4)="7 BAD ADDRESS"
+8 SET DIR("L",5)="8 PER PATIENT REQUEST"
+9 SET DIR("L")="98 OTHER/TECH (NON-CLINICAL)"
End DoDot:1
+10 DO ^DIR
if $DATA(DUOUT)!($DATA(DIRUT))
QUIT
SET FLD(99)=Y
+11 SET COMM=Y(0)
+12 IF $GET(FLD(99))=99
KILL DIR
SET DIR("A")=$PIECE(^DD(52,99.1,0),"^")
SET DIR(0)="52,99.1"
DO ^DIR
if $DATA(DUOUT)!($DATA(DIRUT))
QUIT
SET (FLD(99.1),COMM)=Y
QUIT
+13 IF '$TEST
SET FLD(99.1)=""
+14 QUIT
NOOR ;ask nature of order
+1 KILL DIR,DTOUT,DTOUT,DIRUT
IF $TEXT(NA^ORX1)]""
Begin DoDot:1
+2 SET PSONOOR=$$NA^ORX1("W",0,"B","Nature of Order",0,"WPSDIVR"_$SELECT(+$GET(^VA(200,DUZ,"PS")):"E",1:""))
+3 IF +PSONOOR
SET PSONOOR=$PIECE(PSONOOR,"^",3)
QUIT
+4 SET DIRUT=1
KILL PSONOOR
End DoDot:1
QUIT
+5 SET DIR("A")="Nature of Order: "
SET DIR("B")="WRITTEN"
+6 SET DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$SELECT(+$GET(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
NOORX DO ^DIR
KILL DIR,DTOUT,DTOUT
if $DATA(DIRUT)
QUIT
SET PSONOOR=Y
+1 QUIT
ULP ;
+1 DO UL^PSSLOCK(+$GET(PSODFN))
+2 QUIT
RELC ;
+1 SET (PSOHRL,PSOHTX)=0
FOR PSOHT=0:0
SET PSOHT=$ORDER(^PSRX(DA,1,PSOHT))
if 'PSOHT
QUIT
if $DATA(^PSRX(DA,1,PSOHT,0))
SET PSOHTX=PSOHT
+2 IF $GET(PSOHTX)
SET PSOHRL=$SELECT($PIECE($GET(^PSRX(DA,1,PSOHTX,0)),"^",18):1,1:0)
+3 IF '$GET(PSOHTX)
SET PSOHRL=$SELECT($PIECE($GET(^PSRX(DA,2)),"^",13):1,1:0)
+4 KILL PSOHTX,PSOHT
+5 QUIT
RXACT(RX,ACTION,REASON,OTHCOM,SUS) ; Adds HOLD/UNHOLD comments to the Rx Activity Log
+1 NEW RFL,X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO,COMM
+2 SET RFL=$$LSTRFL^PSOBPSU1(RX)
+3 IF ACTION="H"
SET COMM="Rx placed on HOLD (Reason: "_REASON_")"_$SELECT(+$GET(SUS):" and removed from SUSPENSE",1:"")
+4 IF ACTION="U"
SET COMM="Rx removed from HOLD"
+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///"_ACTION_";.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 QUIT
+9 ;
MWPR ;
+1 NEW RESULTS,PSOPARKX,DV
KILL DIR,DUOUT,DTOUT,DIRUT
+2 SET RESULTS="PSOPARKX"
DO GETPARK^PSORPC01()
+3 ;PSO*7*780 Do not allow Park when DEA handling contains D
+4 SET DIR(0)="S^M:MAIL;W:WINDOW"
SET DIR("A")="MAIL/WINDOW"
+5 IF $GET(PSOPARKX(0))="YES"
Begin DoDot:1
+6 IF $PIECE(^PSDRUG($PIECE(^PSRX(RXIEN,0),"^",6),0),"^",3)'["D"
SET DIR(0)="S^M:MAIL;W:WINDOW;P:PARK"
SET DIR("A")="MAIL/WINDOW/PARK"
End DoDot:1
+7 SET DV=$SELECT(RXF:$$GET1^DIQ(52.1,RXF_","_RXIEN,2),1:$$GET1^DIQ(52,RXIEN,11))
+8 if $EXTRACT(DV)="P"
SET DV="PARK"
+9 IF $EXTRACT(DV)="P"
IF DIR(0)'["P:"
SET DV=""
+10 SET DIR("B")=DV
+11 DO ^DIR
KILL DIR,DUOUT,DTOUT
+12 QUIT
