LRUBYDIV.m

LRUBYDIV ;TOGUS/CYM  --ACCESSION BY DIVISION UTILITY ;7/24/96  20:47 ;

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

 ;gets accessions based on users DUZ(2)

 D END,CK G:Y=-1 END D LRDICS G:Y B

 S DIC=68,DIC(0)="AEOQMZ",DIC("S")="I LRDICS[$P(^(0),U,2),$P(^(0),U,2)]"""",$G(^(3,DUZ(2),0))" D ^DIC K DIC,LRDICS G:Y<1 END

B S X=$P(Y,U,2) D ^LRUTL G:Y=-1 END Q

CK S Y=1 S:'$D(DUZ(2)) DUZ(2)=0 S LRAA(4)=$P($G(^DIC(4,+DUZ(2),0)),U) I LRAA(4)="" W $C(7),!!,"Must have DIVISION VARIABLE 'DUZ(2)' defined." S Y=-1 Q

 W !!?20,LRAA(4),! Q

 ;

LRDICS S Y=0,X=$G(LRDICS) I $L(X)=2,"SPCYEMAUBBCHMI"[X D C I Y K LRDICS Q

 S LRDICS=$S($L($G(LRDICS)):LRDICS,1:"SPCYEMAUBBCHMI") Q

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

 I B=1 S Y=B(1)_U_$P(^LRO(68,B(1),0),U) K A,B Q

 I B>1,$D(LRDICS(1)) S Y=B(1)_U_$P(^LRO(68,B(1),0),U) K A,B

 Q

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

 I B=1 S Y=B(1)_U_$P(^LRO(68,B(1),0),U) K A,B

 Q

 ;

END D V^LRU Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRUBYDIV   1074     printed  Apr 09, 2024@21:20:35                                                                                                                                                                                                    Page 2

LRUBYDIV  ;TOGUS/CYM  --ACCESSION BY DIVISION UTILITY ;7/24/96  20:47 ;

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

 +2       ;gets accessions based on users DUZ(2)

 +3        DO END

           DO CK

           if Y=-1

               GOTO END

           DO LRDICS

           if Y

               GOTO B

 +4        SET DIC=68

           SET DIC(0)="AEOQMZ"

           SET DIC("S")="I LRDICS[$P(^(0),U,2),$P(^(0),U,2)]"""",$G(^(3,DUZ(2),0))"

           DO ^DIC

           KILL DIC,LRDICS

           if Y<1

               GOTO END

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

           DO ^LRUTL

           if Y=-1

               GOTO END

           QUIT 

CK         SET Y=1

           if '$DATA(DUZ(2))

               SET DUZ(2)=0

           SET LRAA(4)=$PIECE($GET(^DIC(4,+DUZ(2),0)),U)

           IF LRAA(4)=""

               WRITE $CHAR(7),!!,"Must have DIVISION VARIABLE 'DUZ(2)' defined."

               SET Y=-1

               QUIT 

 +1        WRITE !!?20,LRAA(4),!

           QUIT 

 +2       ;

LRDICS     SET Y=0

           SET X=$GET(LRDICS)

           IF $LENGTH(X)=2

               IF "SPCYEMAUBBCHMI"[X

                   DO C

                   IF Y

                       KILL LRDICS

                       QUIT 

 +1        SET LRDICS=$SELECT($LENGTH($GET(LRDICS)):LRDICS,1:"SPCYEMAUBBCHMI")

           QUIT 

C          if $DATA(LRDICS(2))

               GOTO CC

           SET (A,B)=0

           FOR 

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

               if 'A

                   QUIT 

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

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

                       SET B=B+1

                       SET B(B)=A

 +1        IF B=1

               SET Y=B(1)_U_$PIECE(^LRO(68,B(1),0),U)

               KILL A,B

               QUIT 

 +2        IF B>1

               IF $DATA(LRDICS(1))

                   SET Y=B(1)_U_$PIECE(^LRO(68,B(1),0),U)

                   KILL A,B

 +3        QUIT 

CC         SET (A,B)=0

           FOR 

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

               if 'A

                   QUIT 

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

                   SET B=B+1

                   SET B(B)=A

                   QUIT 

 +1        IF B=1

               SET Y=B(1)_U_$PIECE(^LRO(68,B(1),0),U)

               KILL A,B

 +2        QUIT 

 +3       ;

END        DO V^LRU

           QUIT