PSOARCDE ;BHAM ISC/SAB - Purge Rx from ^PSRX & ^PS(55 ; 12/08/94
;;7.0;OUTPATIENT PHARMACY;;DEC 1997
EN ;N DIK,DA
Q:'$D(^PSRX(RX)) S PSOSUSPA=1 D EN^PSOHLSN1(RX,"Z@","","Purge order.","") S PAT=$P(^PSRX(RX,0),"^",2),DIK="^PSRX(",DA=RX D ^DIK K PSOSUSPA
I $D(^PS(55,PAT,0)) S DA(1)=PAT,DIK="^PS(55,"_DA(1)_",""P""," F X=0:0 S X=$O(^PS(55,PAT,"P",X)) Q:'X I ^PS(55,PAT,"P",X,0)=RX S DA=X D ^DIK K DA,DIK
S DIK="^PS(52.4,",DA=RX D ^DIK K DA,DIK
SUS S DA=$O(^PS(52.5,"B",RX,"")) Q:DA']"" S DIK="^PS(52.5," D ^DIK K DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOARCDE 533 printed Dec 13, 2024@02:24:10 Page 2
PSOARCDE ;BHAM ISC/SAB - Purge Rx from ^PSRX & ^PS(55 ; 12/08/94
+1 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
EN ;N DIK,DA
+1 if '$DATA(^PSRX(RX))
QUIT
SET PSOSUSPA=1
DO EN^PSOHLSN1(RX,"Z@","","Purge order.","")
SET PAT=$PIECE(^PSRX(RX,0),"^",2)
SET DIK="^PSRX("
SET DA=RX
DO ^DIK
KILL PSOSUSPA
+2 IF $DATA(^PS(55,PAT,0))
SET DA(1)=PAT
SET DIK="^PS(55,"_DA(1)_",""P"","
FOR X=0:0
SET X=$ORDER(^PS(55,PAT,"P",X))
if 'X
QUIT
IF ^PS(55,PAT,"P",X,0)=RX
SET DA=X
DO ^DIK
KILL DA,DIK
+3 SET DIK="^PS(52.4,"
SET DA=RX
DO ^DIK
KILL DA,DIK
SUS SET DA=$ORDER(^PS(52.5,"B",RX,""))
if DA']""
QUIT
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
+1 QUIT
