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 ---[H[J[2J[HLRUBYDIV 1074 printed Dec 13, 2024@02:21:17 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
