PSOCAN3N ;BIR/RTR/SAB/SJA - auto dc rxs due to death ;06/29/07 11:45am
;;7.0;OUTPATIENT PHARMACY;**225**;DEC 1997;Build 29
Q
RMP ;remove Rx if found in array PSORX("PSOL") (Label Queue)
Q:'$D(PSORX("PSOL")) S:'$G(DA) DA=$P(PSOLST(ORN),"^",2)
N I,J,FND,ST1,ST2,ST3 S I=0
F S I=$O(PSORX("PSOL",I)) Q:'I D
. S ST1=PSORX("PSOL",I) Q:ST1'[(DA_",")
. S ST3="",FND=0
. F J=1:1 S ST2=$P(ST1,",",J) Q:'ST2 D
. . I ST2=DA S FND=1 Q
. . S ST3=ST3_$S('ST3:"",1:",")_ST2
. I FND D
. . S:ST3]"" PSORX("PSOL",I)=ST3_","
. . K:ST3="" PSORX("PSOL",I)
. . D:$D(BBRX(I)) RMB^PSOCAN2(I)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCAN3N 605 printed Sep 23, 2025@20:01:30 Page 2
PSOCAN3N ;BIR/RTR/SAB/SJA - auto dc rxs due to death ;06/29/07 11:45am
+1 ;;7.0;OUTPATIENT PHARMACY;**225**;DEC 1997;Build 29
+2 QUIT
RMP ;remove Rx if found in array PSORX("PSOL") (Label Queue)
+1 if '$DATA(PSORX("PSOL"))
QUIT
if '$GET(DA)
SET DA=$PIECE(PSOLST(ORN),"^",2)
+2 NEW I,J,FND,ST1,ST2,ST3
SET I=0
+3 FOR
SET I=$ORDER(PSORX("PSOL",I))
if 'I
QUIT
Begin DoDot:1
+4 SET ST1=PSORX("PSOL",I)
if ST1'[(DA_",")
QUIT
+5 SET ST3=""
SET FND=0
+6 FOR J=1:1
SET ST2=$PIECE(ST1,",",J)
if 'ST2
QUIT
Begin DoDot:2
+7 IF ST2=DA
SET FND=1
QUIT
+8 SET ST3=ST3_$SELECT('ST3:"",1:",")_ST2
End DoDot:2
+9 IF FND
Begin DoDot:2
+10 if ST3]""
SET PSORX("PSOL",I)=ST3_","
+11 if ST3=""
KILL PSORX("PSOL",I)
+12 if $DATA(BBRX(I))
DO RMB^PSOCAN2(I)
End DoDot:2
End DoDot:1
+13 QUIT
