LRAPU.m

LRAPU ; IHS/DIR/AAB - PATH UTILITY 8/11/95 08:59 ;

 ;;5.2;LR;**1002**;JUN 01, 1998

 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 S (A,B)=0 F  S A=$O(^LRO(68,A)) Q:'A  I $P($G(^LRO(68,A,0)),"^",2)=LRSS,$G(^(3,DUZ(2),0)) S B=B+1,B(B)=A

 I B=0 S Y=-1 Q  ;W $C(7),!!,"There are no accession areas for ",LRSS,!,"Please have responsible person enter one in Accession File (#68)."

 I B=1!($D(LR("M"))) S Y(0)=^LRO(68,B(B),0),X=$P(Y(0),U),Y=B(B)_U_X K A,B Q

 S DIC=68,DIC(0)="AEQMZ",DIC("S")="I $P(^(0),U,2)=LRSS&(+$G(^(3,+DUZ(2),0)))" D ^DIC K DIC S X=$P(Y,U,2) Q

LRAPU     ; IHS/DIR/AAB - PATH UTILITY 8/11/95 08:59 ;

 +1       ;;5.2;LR;**1002**;JUN 01, 1998

 +2       ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 +3        SET (A,B)=0

           FOR 

               SET A=$ORDER(^LRO(68,A))

               IF 'A

                   QUIT 

               IF $PIECE($GET(^LRO(68,A,0)),"^",2)=LRSS

                   IF $GET(^(3,DUZ(2),0))

                       SET B=B+1

                       SET B(B)=A

 +4       ;W $C(7),!!,"There are no accession areas for ",LRSS,!,"Please have responsible person enter one in Accession File (#68)."

           IF B=0

               SET Y=-1

               QUIT 

 +5        IF B=1!($DATA(LR("M")))

               SET Y(0)=^LRO(68,B(B),0)

               SET X=$PIECE(Y(0),U)

               SET Y=B(B)_U_X

               KILL A,B

               QUIT 

 +6        SET DIC=68

           SET DIC(0)="AEQMZ"

           SET DIC("S")="I $P(^(0),U,2)=LRSS&(+$G(^(3,+DUZ(2),0)))"

           DO ^DIC

           KILL DIC

           SET X=$PIECE(Y,U,2)

           QUIT