LRAPU.m

LRAPU ;AVAMC/REG - PATH UTILITY ;8/11/95  08:59 ;

 ;;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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRAPU   524     printed  Apr 09, 2024@21:07:16                                                                                                                                                                                                        Page 2

LRAPU     ;AVAMC/REG - PATH UTILITY ;8/11/95  08:59 ;

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

 +2        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

 +3       ;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 

 +4        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 

 +5        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