PSOARCDE.m

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

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