- 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 Feb 18, 2025@23:47:09 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
