PSORXRPT ;BIR/SAB-reprint of a prescription label ;Feb 13, 2019@14:45:06
;;7.0;OUTPATIENT PHARMACY;**3,21,27,34,120,138,156,148,280,367,441**;DEC 1997;Build 208
;External reference to ^PSDRUG supported by DBIA 221
;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
BCK I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
N PSODISP,PSOMGREP S PSORPLRX=$P(PSOLST(ORN),"^",2)
I $G(^PSRX(PSORPLRX,"PARK")),+$P($G(^PSRX(PSORPLRX,"STA")),"^")=0 S VALMSG="Cannot Reprint! Medication is currently PARKED.",VALMBCK="" Q ;441 PAPI
I $$LMREJ^PSOREJU1(PSORPLRX,,.VALMSG,.VALMBCK) Q
D PSOL^PSSLOCK(PSORPLRX) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG Q
I $G(POERR) K QFLG D I $G(QFLG) D ULR G KILL
.D FULL^VALM1 S X=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),Y=$P(PSOLST(ORN),"^",2)_"^"_X,Y(0)=$G(^PSRX($P(PSOLST(ORN),"^",2),0))
.I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial Rx has been requested!",QFLG=1 Q
.I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!",QFLG=1 Q
.I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!",QFLG=1 Q
.S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 S:$G(QFLG) VALMBCK="",VALMSG="A New Label has been requested already!"
S (PPL,DA,RX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA"))
I $P(^PSRX(RX,"STA"),"^")=14 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued by Provider.",QFLG=1 D ULR,KILL Q
I $P(^PSRX(RX,"STA"),"^")=15 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued due to editing.",QFLG=1 D ULR,KILL Q
I $P(^PSRX(RX,"STA"),"^")=16 S VALMBCK="",VALMSG="Cannot Reprint! Placed on HOLD by Provider.",QFLG=1 D ULR,KILL Q
I DT>$P(^PSRX(RX,2),"^",6) D G PAUSE
.W !,$C(7),"Medication Expired on "_$E($P(^PSRX(RX,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
..S COMM="Medication Expired on "_$E($P(^PSRX(RX,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 DFN=$P(PDA,"^",2) D DEM^VADPT I $P(VADM(6),"^",2)]"" D G PAUSE
.W $C(7),!!,$P(^DPT($P(PDA,"^",2),0),"^")_" Died "_$P(VADM(6),"^",2)_".",!
.S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A")
.D ACT1,ULR,KILL
S X=$O(^PS(52.5,"B",DA,0)) I X,'$G(^PS(52.5,X,"P")) W !,$C(7),"RX MAY NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options." K X G PAUSE
S PSX=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J S PSX=J
K X
I $D(^PS(52.4,DA)) W !,"Prescription is Non-Verified",!! G PAUSE
S DFN=$P(^PSRX(DA,0),"^",2) I $D(^PS(52.4,"AREF",DFN,DA)) W !,"Prescription is waiting for others to be verified",!! G PAUSE
I $G(PSODIV),$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA G:$G(POERR)&(PSPOP) PAUSE G:PSPOP PAUSE
I STA=3 W !?3,"Prescription is on Hold" G PAUSE
I STA=4 W !?3,"Prescription is Pending Due to Drug Interactions" G PAUSE
I STA=12 W !?3,"Prescription is Discontinued" G PAUSE
S COPIES=$S($P(PDA,"^",18)]"":$P(PDA,"^",18),1:1)
K DIR S DIR("A")="Number of Copies? ",DIR("B")=COPIES,DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 to 99)"
D ^DIR K DIR I $D(DIRUT) D ULR G KILL
S COPIES=Y
K DIR S DIR("A")="Print adhesive portion of label only",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default."
S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR I $D(DUOUT) D ULR,KILL G PAUSE
I $D(DIRUT) D ULR G KILL
S SIDE=Y
;
; Dispensing System Device Resend
I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D
.I $S($P(PSOPAR,"^",30)=3:1,$P(PSOPAR,"^",30)=4:1,1:0),'$$GET1^DIQ(50,$P(PDA,"^",6),28,"I") Q
.K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No"
.D ^DIR K DIR Q:$D(DIRUT) S PSODISP=$S(Y:0,1:1)
I $D(DIRUT) D ULR G KILL
;
; FDA Medication Guide Reprint
I $$GET1^DIQ(59,PSOSITE,134)'="",$$MGONFILE^PSOFDAUT($P(PSOLST(ORN),"^",2)) D I $D(DIRUT) D ULR,KILL G PAUSE
. K DIR,DIRUT S DIR("A")="Reprint the FDA Medication Guide",DIR(0)="Y",DIR("B")="No"
. D ^DIR K DIR Q:$D(DIRUT) S PSOMGREP=Y
;
D ACT I $D(DIRUT) D ULR,KILL G PAUSE
Q:$G(POERR)&($D(PCOM)) G PAUSE:$D(PCOM)
F I=1,2,4,6,7,9,13,16 S P(I)=$P(PDA,"^",I)
S P(6)=+P(6) I $D(^PSRX(DA,"TN")),^("TN")]"" S P(6)=^("TN")
W !!,"Rx # "_P(1),?23,$E(P(13),4,5)_"/"_$E(P(13),6,7)_"/"_$E(P(13),2,3),!,$S($D(^DPT(+P(2),0)):$P(^(0),"^"),1:"Not on File"),?30,"#"_P(7),!
I $P($G(^PSRX(DA,"SIG")),"^",2) S D=0 D K D,FSIG
.D FSIG^PSOUTLA("R",DA,75) F S D=$O(FSIG(D)) W !,FSIG(D) Q:'$O(FSIG(D))
E D EN3^PSOUTLA1(DA,75) S D=0 F S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D))
K D,BSIG
;PSO*7*280 If trade name is used Stop the DRUG Lookup.
W !!,$S($G(^PSRX(DA,"TN"))]"":P(6),(P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS
W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9))
I $G(RX) S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ S RXFL(RX)=ZZZ
K PSOELSE I '$G(POERR) S PSOELSE=1 D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL")
I '$G(PSOELSE) D
.S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE
.I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1
.I $G(PSOMGREP)=1 S RXRP($P(PSOLST(ORN),"^",2),"MG")=1
.I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," Q
.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)_DA_","
.E S PSORX("PSOL",PSOX2+1)=DA_","
K PCOMX,PSPOP,PPL,COPIES,SIDE,PCOM,IOP,PSL,PSNP,PSOELSE,ZZZ
PAUSE K RX,PPL,ZD(+$G(DA)),DA I $G(POERR) K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E",DIR("A",1)=" ",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DUOUT,DTOUT S VALMBCK="R"
D ULR K PSORPLRX
Q
;
ACT K DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX)
D ^DIR K DIR Q:$D(DIRUT)!($D(DIROUT)) S (PCOM,PCOMX)=X
I '$D(PSOCLC) S PSOCLC=DUZ
ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J S RXF=J S:J>5 RXF=J+1
S IR=0 F J=0:0 S J=$O(^PSRX(DA,"A",J)) Q:'J S IR=J
S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF
S:$P(^PSRX(DA,2),"^",15)&($G(ST)'="C") $P(^PSRX(DA,2),"^",14)=1
Q
;
KILL K QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOMSG,PSORPLRX D KVA^VADPT Q
;
ULR ;
I $G(PSORPLRX) D PSOUL^PSSLOCK(PSORPLRX)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORXRPT 7064 printed Sep 23, 2025@20:11:06 Page 2
PSORXRPT ;BIR/SAB-reprint of a prescription label ;Feb 13, 2019@14:45:06
+1 ;;7.0;OUTPATIENT PHARMACY;**3,21,27,34,120,138,156,148,280,367,441**;DEC 1997;Build 208
+2 ;External reference to ^PSDRUG supported by DBIA 221
+3 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
BCK IF $GET(PSOBEDT)
WRITE $CHAR(7),$CHAR(7)
SET VALMSG="Invalid Action at this time !"
SET VALMBCK=""
QUIT
+1 NEW PSODISP,PSOMGREP
SET PSORPLRX=$PIECE(PSOLST(ORN),"^",2)
+2 ;441 PAPI
IF $GET(^PSRX(PSORPLRX,"PARK"))
IF +$PIECE($GET(^PSRX(PSORPLRX,"STA")),"^")=0
SET VALMSG="Cannot Reprint! Medication is currently PARKED."
SET VALMBCK=""
QUIT
+3 IF $$LMREJ^PSOREJU1(PSORPLRX,,.VALMSG,.VALMBCK)
QUIT
+4 DO PSOL^PSSLOCK(PSORPLRX)
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
QUIT
+5 IF $GET(POERR)
KILL QFLG
Begin DoDot:1
+6 DO FULL^VALM1
SET X=$PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),0),"^")
SET Y=$PIECE(PSOLST(ORN),"^",2)_"^"_X
SET Y(0)=$GET(^PSRX($PIECE(PSOLST(ORN),"^",2),0))
+7 IF $DATA(RXPR($PIECE(PSOLST(ORN),"^",2)))
SET VALMBCK=""
SET VALMSG="A Partial Rx has been requested!"
SET QFLG=1
QUIT
+8 IF $DATA(RXRP($PIECE(PSOLST(ORN),"^",2)))
SET VALMBCK=""
SET VALMSG="A Reprint Label has been requested!"
SET QFLG=1
QUIT
+9 IF $DATA(RXRS($PIECE(PSOLST(ORN),"^",2)))
SET VALMBCK=""
SET VALMSG="Rx is being pulled from suspense!"
SET QFLG=1
QUIT
+10 SET RX=$PIECE(PSOLST(ORN),"^",2)
DO VALID^PSORXRP1
if $GET(QFLG)
SET VALMBCK=""
SET VALMSG="A New Label has been requested already!"
End DoDot:1
IF $GET(QFLG)
DO ULR
GOTO KILL
+11 SET (PPL,DA,RX)=+Y
SET PDA=Y(0)
SET RXF=0
SET ZD(DA)=DT
SET REPRINT=1
SET STA=+$GET(^PSRX(+Y,"STA"))
+12 IF $PIECE(^PSRX(RX,"STA"),"^")=14
SET VALMBCK=""
SET VALMSG="Cannot Reprint! Discontinued by Provider."
SET QFLG=1
DO ULR
DO KILL
QUIT
+13 IF $PIECE(^PSRX(RX,"STA"),"^")=15
SET VALMBCK=""
SET VALMSG="Cannot Reprint! Discontinued due to editing."
SET QFLG=1
DO ULR
DO KILL
QUIT
+14 IF $PIECE(^PSRX(RX,"STA"),"^")=16
SET VALMBCK=""
SET VALMSG="Cannot Reprint! Placed on HOLD by Provider."
SET QFLG=1
DO ULR
DO KILL
QUIT
+15 IF DT>$PIECE(^PSRX(RX,2),"^",6)
Begin DoDot:1
+16 WRITE !,$CHAR(7),"Medication Expired on "_$EXTRACT($PIECE(^PSRX(RX,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
Begin DoDot:2
+17 SET COMM="Medication Expired on "_$EXTRACT($PIECE(^PSRX(RX,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
GOTO PAUSE
+18 SET DFN=$PIECE(PDA,"^",2)
DO DEM^VADPT
IF $PIECE(VADM(6),"^",2)]""
Begin DoDot:1
+19 WRITE $CHAR(7),!!,$PIECE(^DPT($PIECE(PDA,"^",2),0),"^")_" Died "_$PIECE(VADM(6),"^",2)_".",!
+20 SET $PIECE(^PSRX(RX,"STA"),"^")=12
SET PCOM="Patient Expired "_$PIECE(VADM(6),"^",2)
SET ST="C"
DO EN^PSOHLSN1(RX,"OD","",PCOM,"A")
+21 DO ACT1
DO ULR
DO KILL
End DoDot:1
GOTO PAUSE
+22 SET X=$ORDER(^PS(52.5,"B",DA,0))
IF X
IF '$GET(^PS(52.5,X,"P"))
WRITE !,$CHAR(7),"RX MAY NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options."
KILL X
GOTO PAUSE
+23 SET PSX=0
FOR J=0:0
SET J=$ORDER(^PSRX(DA,1,J))
if 'J
QUIT
SET PSX=J
+24 KILL X
+25 IF $DATA(^PS(52.4,DA))
WRITE !,"Prescription is Non-Verified",!!
GOTO PAUSE
+26 SET DFN=$PIECE(^PSRX(DA,0),"^",2)
IF $DATA(^PS(52.4,"AREF",DFN,DA))
WRITE !,"Prescription is waiting for others to be verified",!!
GOTO PAUSE
+27 IF $GET(PSODIV)
IF $DATA(^PSRX(DA,2))
IF +$PIECE(^(2),"^",9)
IF +$PIECE(^(2),"^",9)'=PSOSITE
SET PSPOP=0
SET PSPRXN=DA
DO CHK1^PSOUTLA
if $GET(POERR)&(PSPOP)
GOTO PAUSE
if PSPOP
GOTO PAUSE
+28 IF STA=3
WRITE !?3,"Prescription is on Hold"
GOTO PAUSE
+29 IF STA=4
WRITE !?3,"Prescription is Pending Due to Drug Interactions"
GOTO PAUSE
+30 IF STA=12
WRITE !?3,"Prescription is Discontinued"
GOTO PAUSE
+31 SET COPIES=$SELECT($PIECE(PDA,"^",18)]"":$PIECE(PDA,"^",18),1:1)
+32 KILL DIR
SET DIR("A")="Number of Copies? "
SET DIR("B")=COPIES
SET DIR(0)="N^1:99:0"
SET DIR("?")="Enter the number of copies you want (1 to 99)"
+33 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO ULR
GOTO KILL
+34 SET COPIES=Y
+35 KILL DIR
SET DIR("A")="Print adhesive portion of label only"
SET DIR(0)="Y"
SET DIR("B")="No"
SET DIR("?",1)="If entire label, including trailers are to print press RETURN for default."
+36 SET DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
DO ULR
DO KILL
GOTO PAUSE
+37 IF $DATA(DIRUT)
DO ULR
GOTO KILL
+38 SET SIDE=Y
+39 ;
+40 ; Dispensing System Device Resend
+41 IF $PIECE(PSOPAR,"^",30)
IF $$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4
Begin DoDot:1
+42 IF $SELECT($PIECE(PSOPAR,"^",30)=3:1,$PIECE(PSOPAR,"^",30)=4:1,1:0)
IF '$$GET1^DIQ(50,$PIECE(PDA,"^",6),28,"I")
QUIT
+43 KILL DIR,DIRUT
SET DIR("A")="Do you want to resend to Dispensing System Device"
SET DIR(0)="Y"
SET DIR("B")="No"
+44 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET PSODISP=$SELECT(Y:0,1:1)
End DoDot:1
+45 IF $DATA(DIRUT)
DO ULR
GOTO KILL
+46 ;
+47 ; FDA Medication Guide Reprint
+48 IF $$GET1^DIQ(59,PSOSITE,134)'=""
IF $$MGONFILE^PSOFDAUT($PIECE(PSOLST(ORN),"^",2))
Begin DoDot:1
+49 KILL DIR,DIRUT
SET DIR("A")="Reprint the FDA Medication Guide"
SET DIR(0)="Y"
SET DIR("B")="No"
+50 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET PSOMGREP=Y
End DoDot:1
IF $DATA(DIRUT)
DO ULR
DO KILL
GOTO PAUSE
+51 ;
+52 DO ACT
IF $DATA(DIRUT)
DO ULR
DO KILL
GOTO PAUSE
+53 if $GET(POERR)&($DATA(PCOM))
QUIT
if $DATA(PCOM)
GOTO PAUSE
+54 FOR I=1,2,4,6,7,9,13,16
SET P(I)=$PIECE(PDA,"^",I)
+55 SET P(6)=+P(6)
IF $DATA(^PSRX(DA,"TN"))
IF ^("TN")]""
SET P(6)=^("TN")
+56 WRITE !!,"Rx # "_P(1),?23,$EXTRACT(P(13),4,5)_"/"_$EXTRACT(P(13),6,7)_"/"_$EXTRACT(P(13),2,3),!,$SELECT($DATA(^DPT(+P(2),0)):$PIECE(^(0),"^"),1:"Not on File"),?30,"#"_P(7),!
+57 IF $PIECE($GET(^PSRX(DA,"SIG")),"^",2)
SET D=0
Begin DoDot:1
+58 DO FSIG^PSOUTLA("R",DA,75)
FOR
SET D=$ORDER(FSIG(D))
WRITE !,FSIG(D)
if '$ORDER(FSIG(D))
QUIT
End DoDot:1
KILL D,FSIG
+59 IF '$TEST
DO EN3^PSOUTLA1(DA,75)
SET D=0
FOR
SET D=$ORDER(BSIG(D))
WRITE !,BSIG(D)
if '$ORDER(BSIG(D))
QUIT
+60 KILL D,BSIG
+61 ;PSO*7*280 If trade name is used Stop the DRUG Lookup.
+62 WRITE !!,$SELECT($GET(^PSRX(DA,"TN"))]"":P(6),(P(6)=+P(6))&$DATA(^PSDRUG(P(6),0)):$PIECE(^(0),"^"),1:P(6)),!
SET PHYS=$SELECT($DATA(^VA(200,+P(4),0)):$PIECE(^(0),"^"),1:"Unknown")
WRITE PHYS
KILL PHYS
+63 WRITE ?25,$SELECT($DATA(^VA(200,+P(16),0)):$PIECE(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$GET(P(9))
+64 IF $GET(RX)
SET RXFL(RX)=0
FOR ZZZ=0:0
SET ZZZ=$ORDER(^PSRX(RX,1,ZZZ))
if 'ZZZ
QUIT
SET RXFL(RX)=ZZZ
+65 KILL PSOELSE
IF '$GET(POERR)
SET PSOELSE=1
DO @$SELECT($PIECE($GET(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL")
+66 IF '$GET(PSOELSE)
Begin DoDot:1
+67 SET RXRP($PIECE(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE
+68 IF $GET(PSODISP)=1
SET RXRP($PIECE(PSOLST(ORN),"^",2),"RP")=1
+69 IF $GET(PSOMGREP)=1
SET RXRP($PIECE(PSOLST(ORN),"^",2),"MG")=1
+70 IF $GET(PSORX("PSOL",1))']""
SET PSORX("PSOL",1)=DA_","
QUIT
+71 FOR PSOX1=0:0
SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
if 'PSOX1
QUIT
SET PSOX2=PSOX1
+72 IF $LENGTH(PSORX("PSOL",PSOX2))+$LENGTH(DA)<220
SET PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_","
+73 IF '$TEST
SET PSORX("PSOL",PSOX2+1)=DA_","
End DoDot:1
+74 KILL PCOMX,PSPOP,PPL,COPIES,SIDE,PCOM,IOP,PSL,PSNP,PSOELSE,ZZZ
PAUSE KILL RX,PPL,ZD(+$GET(DA)),DA
IF $GET(POERR)
KILL DIR,DIRUT,DUOUT,DTOUT
SET DIR(0)="E"
SET DIR("A",1)=" "
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR,DIRUT,DUOUT,DTOUT
SET VALMBCK="R"
+1 DO ULR
KILL PSORPLRX
+2 QUIT
+3 ;
ACT KILL DIR
SET DIR("A")="Comments: "
SET DIR(0)="FA^5:60"
SET DIR("?")="5-60 characters input required for activity log."
if $GET(PCOMX)]""
SET DIR("B")=$GET(PCOMX)
+1 DO ^DIR
KILL DIR
if $DATA(DIRUT)!($DATA(DIROUT))
QUIT
SET (PCOM,PCOMX)=X
+2 IF '$DATA(PSOCLC)
SET PSOCLC=DUZ
ACT1 SET RXF=0
FOR J=0:0
SET J=$ORDER(^PSRX(DA,1,J))
if 'J
QUIT
SET RXF=J
if J>5
SET RXF=J+1
+1 SET IR=0
FOR J=0:0
SET J=$ORDER(^PSRX(DA,"A",J))
if 'J
QUIT
SET IR=J
+2 SET IR=IR+1
SET ^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
+3 DO NOW^%DTC
SET ^PSRX(DA,"A",IR,0)=%_"^"_$SELECT($GET(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$SELECT($GET(ST)'="C":" ("_COPIES_" COPIES)",1:"")
SET PCOMX=PCOM
KILL PC,IR,PS,PCOM,XX,%,%H,%I,RXF
+4 if $PIECE(^PSRX(DA,2),"^",15)&($GET(ST)'="C")
SET $PIECE(^PSRX(DA,2),"^",14)=1
+5 QUIT
+6 ;
KILL KILL QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOMSG,PSORPLRX
DO KVA^VADPT
QUIT
+1 ;
ULR ;
+1 IF $GET(PSORPLRX)
DO PSOUL^PSSLOCK(PSORPLRX)
+2 QUIT
