PXRMLABS ; SLC/PKR - Estimate of lab entries to set up. ;8/5/03 16:20
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;===============================================================
NELR() ;.
N LRDFN,LRDN,LRIDT,NE,TEMP
;DBIA #4179
S NE=0
S LRDFN=.9
F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D
. S TEMP=$G(^LR(LRDFN,0))
. I $P(TEMP,U,2)'=2 Q
. S LRIDT=0
. F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1 D
.. I '$P($G(^LR(LRDFN,"CH",LRIDT,0)),U,3) Q ; check for completed
.. S LRDN=1
.. F S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<1 D
... S NE=NE+1
D AP(.NE)
D MICRO(.NE)
Q NE
;
;===============================================================
AP(NE) ;
N ETIOL,I,II,III,ICD,ICDX
N LRDFN,ORGAN,SNOMED,SPEC,SUB,SUBS,TEMP
;DBIA #4179
K ANUMS
D AANUMS(.ANUMS)
S LRDFN=.9
F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D
. S TEMP=$G(^LR(LRDFN,0))
. I $P(TEMP,U,2)'=2 Q
. D CYEMSP(LRDFN,.ANUMS,.NE) ; cytology, electron microscopy, sugrical path
. I '+$G(^LR(LRDFN,"AU")) Q ; date of autopsy
. S NE=NE+1
. S SPEC=0
. F S SPEC=$O(^LR(LRDFN,33,SPEC)) Q:SPEC<1 D
.. I '$L($P($G(^LR(LRDFN,33,SPEC,0)),U)) Q
.. S NE=NE+1
. S ICD=0
. F S ICD=$O(^LR(LRDFN,80,ICD)) Q:ICD<1 D
.. S ICDX=+$G(^LR(LRDFN,80,ICD,0))
.. I 'ICDX Q
.. S NE=NE+1
. S I=0
. F S I=$O(^LR(LRDFN,"AY",I)) Q:I<1 D
.. S ORGAN=+$G(^LR(LRDFN,"AY",I,0))
.. I 'ORGAN Q
.. S NE=NE+1
.. F SUBS="1D","2M","3F","4P" D
... S SUB=+SUBS
... S II=0
... F S II=$O(^LR(LRDFN,"AY",I,SUB,II)) Q:II<1 D
.... S SNOMED=+$G(^LR(LRDFN,"AY",I,SUB,II,0))
.... I 'SNOMED Q
.... S NE=NE+1
.... I SUB'=2 Q
.... S III=0
.... F S III=$O(^LR(LRDFN,"AY",I,SUB,II,1,III)) Q:III<1 D
..... S ETIOL=+$G(^LR(LRDFN,"AY",I,SUB,II,1,III,0))
..... I 'ETIOL Q
..... S NE=NE+1
Q
;
CYEMSP(LRDFN,ANUMS,NE) ;
N ACC,APSUB,DATE,ERR,I,ICD,ICDX,LRIDT,NODE,ORGAN,PREP,SPEC
N TEST,TESTS K TESTS
;DBIA #4179
F APSUB="CY","EM","SP" D
. I '$D(^LR(LRDFN,APSUB,0)) Q
. S LRIDT=0
. F S LRIDT=$O(^LR(LRDFN,APSUB,LRIDT)) Q:LRIDT<1 D
.. S DATE=+$G(^LR(LRDFN,APSUB,LRIDT,0))
.. I 'DATE Q
.. I '($P(^LR(LRDFN,APSUB,LRIDT,0),U,3)&($P(^(0),U,11))) Q
.. S SPEC=0
.. F S SPEC=$O(^LR(LRDFN,APSUB,LRIDT,.1,SPEC)) Q:SPEC<1 D
... I '$L($P($G(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,0)),U)) Q
... S NE=NE+1
... S PREP=0
... F S PREP=$O(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP)) Q:PREP<1 D
.... S TEST=0
.... F S TEST=$O(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP,1,TEST)) Q:TEST<1 D
..... I '$L($P($G(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP,1,TEST,0)),U)) Q
..... S NE=NE+1
.. S ACC=$P(^LR(LRDFN,APSUB,LRIDT,0),U,6)
.. I $L(ACC) D
... S NODE=LRDFN_";"_APSUB_";"_LRIDT_";0"
... D ACC(.TESTS,ACC,DATE,.ANUMS,.ERR)
... I 'ERR D
.... S TEST=0
.... F S TEST=$O(TESTS(TEST)) Q:TEST<1 D
..... S NE=NE+1
.. S ICD=0
.. F S ICD=$O(^LR(LRDFN,APSUB,LRIDT,3,ICD)) Q:ICD<1 D
... S ICDX=+$G(^LR(LRDFN,APSUB,LRIDT,3,ICD,0))
... I 'ICDX Q
... S NE=NE+1
.. S I=0
.. F S I=$O(^LR(LRDFN,APSUB,LRIDT,2,I)) Q:I<1 D
... S ORGAN=+$G(^LR(LRDFN,APSUB,LRIDT,2,I,0))
... I 'ORGAN Q
... S NE=NE+1
... D SNOMED(LRDFN,LRIDT,DATE,APSUB,I,.NE)
Q
;
SNOMED(LRDFN,LRIDT,DATE,APSUB,I,NE) ;
N ETIOL,II,III,SNOMED,SUB,SUBS
;DBIA #4179
F SUBS="1D","2M","3F","4P" D
. S SUB=+SUBS
. S II=0
. F S II=$O(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II)) Q:II<1 D
.. S SNOMED=+$G(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,0))
.. I 'SNOMED Q
.. S NE=NE+1
.. I SUB'=2 Q
.. S III=0
.. F S III=$O(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,1,III)) Q:III<1 D
... S ETIOL=+$G(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,1,III,0))
... I 'ETIOL Q
... S NE=NE+1
Q
;
;===============================================================
MICRO(NE) ;
N AB,ABDN,ACC,ANUMS,DATE,ERR
N LRDFN,LRIDT,ORG,ORGNUM,SPEC,SUB
N TB,TBDN,TEMP,TEST,TESTS
;DBIA #4179
K ANUMS,TESTS
D AANUMS(.ANUMS)
S LRDFN=.9
F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D
. S TEMP=$G(^LR(LRDFN,0))
. I $P(TEMP,U,2)'=2 Q
. S LRIDT=0
. F S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1 D
.. S DATE=+$G(^LR(LRDFN,"MI",LRIDT,0))
.. I 'DATE Q
.. S SPEC=+$P(^LR(LRDFN,"MI",LRIDT,0),U,5)
.. I 'SPEC Q
.. S NE=NE+1
.. S ACC=$P(^LR(LRDFN,"MI",LRIDT,0),U,6)
.. I $L(ACC) D
... D ACC(.TESTS,ACC,DATE,.ANUMS,.ERR)
... I 'ERR D
.... S TEST=0
.... F S TEST=$O(TESTS(TEST)) Q:TEST<1 D
..... S NE=NE+1
.. I $G(^LR(LRDFN,"MI",LRIDT,1)) D
... S ORGNUM=0
... F S ORGNUM=$O(^LR(LRDFN,"MI",LRIDT,3,ORGNUM)) Q:ORGNUM<1 D
.... S ORG=+$G(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,0))
.... I 'ORG Q
.... S NE=NE+1
.... S ABDN=1
.... F S ABDN=$O(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,ABDN)) Q:ABDN<1 D
..... S AB=+$G(^TMP("LRPXSXRB",$J,"AB",ABDN))
..... I 'AB Q
..... S NE=NE+1
.. F SUB=6,9,12,17 D
... I '$G(^LR(LRDFN,"MI",LRIDT,(SUB-1))) Q
... S ORGNUM=0
... F S ORGNUM=$O(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM)) Q:ORGNUM<1 D
.... S ORG=+$G(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM,0))
.... I 'ORG Q
.... S NE=NE+1
.... I SUB'=12 Q
.... S TBDN=2
.... F S TBDN=$O(^LR(LRDFN,"MI",LRIDT,12,ORGNUM,TBDN)) Q:TBDN<2 D
..... S TB=+$G(^TMP("LRPXSXRB",$J,"TB",TBDN))
..... I '$L(TB) Q
..... S NE=NE+1
Q
;
AANUMS(ANUMS) ;
N AA,ABREV K ANUMS
;DBIA #4185
S AA=0
F S AA=$O(^LRO(68,AA)) Q:AA<1 D
. S ABREV=$P($G(^LRO(68,AA,0)),U,11)
. I $L(ABREV) S ANUMS(ABREV)=AA
Q
;
ACC(TESTS,ACC,BDN,ANUMS,ERR) ;
; returns TESTS from micro accession, ACC, BDN required
; BDN is beginning date number
; ANUMS is array of accession name numbers (avoids lookup on repeated calls)
N DIC,LRAA,LRAAB,LRAD,LRAN,TEST,X,Y K DIC,TESTS
S ERR=0
I '$L($G(ACC)) S ERR=1 Q
S LRAAB=$P(ACC," ")
I LRAAB="" Q
S BDN=$E($G(BDN))
I BDN'>1 S ERR=1 Q
S LRAN=+$P(ACC," ",3)
I 'LRAN S ERR=1 Q
S LRAA=+$G(ANUMS(LRAAB))
I 'LRAA D
. S DIC=68,DIC(0)="M"
. S X=LRAAB
. D ^DIC K DIC
. S LRAA=+Y
. S ANUMS(LRAAB)=LRAA
I LRAA'>0 S ERR=1 Q
S LRAD=BDN_$P(ACC," ",2)_"0000" ; yearly acc areas are assumed
S TEST=0
F S TEST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TEST)) Q:TEST<1 D
. S TESTS(TEST)=TEST
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMLABS 6132 printed Apr 09, 2024@20:49:44 Page 2
PXRMLABS ; SLC/PKR - Estimate of lab entries to set up. ;8/5/03 16:20
+1 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+2 ;===============================================================
NELR() ;.
+1 NEW LRDFN,LRDN,LRIDT,NE,TEMP
+2 ;DBIA #4179
+3 SET NE=0
+4 SET LRDFN=.9
+5 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
if LRDFN<1
QUIT
Begin DoDot:1
+6 SET TEMP=$GET(^LR(LRDFN,0))
+7 IF $PIECE(TEMP,U,2)'=2
QUIT
+8 SET LRIDT=0
+9 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
if LRIDT<1
QUIT
Begin DoDot:2
+10 ; check for completed
IF '$PIECE($GET(^LR(LRDFN,"CH",LRIDT,0)),U,3)
QUIT
+11 SET LRDN=1
+12 FOR
SET LRDN=$ORDER(^LR(LRDFN,"CH",LRIDT,LRDN))
if LRDN<1
QUIT
Begin DoDot:3
+13 SET NE=NE+1
End DoDot:3
End DoDot:2
End DoDot:1
+14 DO AP(.NE)
+15 DO MICRO(.NE)
+16 QUIT NE
+17 ;
+18 ;===============================================================
AP(NE) ;
+1 NEW ETIOL,I,II,III,ICD,ICDX
+2 NEW LRDFN,ORGAN,SNOMED,SPEC,SUB,SUBS,TEMP
+3 ;DBIA #4179
+4 KILL ANUMS
+5 DO AANUMS(.ANUMS)
+6 SET LRDFN=.9
+7 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
if LRDFN<1
QUIT
Begin DoDot:1
+8 SET TEMP=$GET(^LR(LRDFN,0))
+9 IF $PIECE(TEMP,U,2)'=2
QUIT
+10 ; cytology, electron microscopy, sugrical path
DO CYEMSP(LRDFN,.ANUMS,.NE)
+11 ; date of autopsy
IF '+$GET(^LR(LRDFN,"AU"))
QUIT
+12 SET NE=NE+1
+13 SET SPEC=0
+14 FOR
SET SPEC=$ORDER(^LR(LRDFN,33,SPEC))
if SPEC<1
QUIT
Begin DoDot:2
+15 IF '$LENGTH($PIECE($GET(^LR(LRDFN,33,SPEC,0)),U))
QUIT
+16 SET NE=NE+1
End DoDot:2
+17 SET ICD=0
+18 FOR
SET ICD=$ORDER(^LR(LRDFN,80,ICD))
if ICD<1
QUIT
Begin DoDot:2
+19 SET ICDX=+$GET(^LR(LRDFN,80,ICD,0))
+20 IF 'ICDX
QUIT
+21 SET NE=NE+1
End DoDot:2
+22 SET I=0
+23 FOR
SET I=$ORDER(^LR(LRDFN,"AY",I))
if I<1
QUIT
Begin DoDot:2
+24 SET ORGAN=+$GET(^LR(LRDFN,"AY",I,0))
+25 IF 'ORGAN
QUIT
+26 SET NE=NE+1
+27 FOR SUBS="1D","2M","3F","4P"
Begin DoDot:3
+28 SET SUB=+SUBS
+29 SET II=0
+30 FOR
SET II=$ORDER(^LR(LRDFN,"AY",I,SUB,II))
if II<1
QUIT
Begin DoDot:4
+31 SET SNOMED=+$GET(^LR(LRDFN,"AY",I,SUB,II,0))
+32 IF 'SNOMED
QUIT
+33 SET NE=NE+1
+34 IF SUB'=2
QUIT
+35 SET III=0
+36 FOR
SET III=$ORDER(^LR(LRDFN,"AY",I,SUB,II,1,III))
if III<1
QUIT
Begin DoDot:5
+37 SET ETIOL=+$GET(^LR(LRDFN,"AY",I,SUB,II,1,III,0))
+38 IF 'ETIOL
QUIT
+39 SET NE=NE+1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+40 QUIT
+41 ;
CYEMSP(LRDFN,ANUMS,NE) ;
+1 NEW ACC,APSUB,DATE,ERR,I,ICD,ICDX,LRIDT,NODE,ORGAN,PREP,SPEC
+2 NEW TEST,TESTS
KILL TESTS
+3 ;DBIA #4179
+4 FOR APSUB="CY","EM","SP"
Begin DoDot:1
+5 IF '$DATA(^LR(LRDFN,APSUB,0))
QUIT
+6 SET LRIDT=0
+7 FOR
SET LRIDT=$ORDER(^LR(LRDFN,APSUB,LRIDT))
if LRIDT<1
QUIT
Begin DoDot:2
+8 SET DATE=+$GET(^LR(LRDFN,APSUB,LRIDT,0))
+9 IF 'DATE
QUIT
+10 IF '($PIECE(^LR(LRDFN,APSUB,LRIDT,0),U,3)&($PIECE(^(0),U,11)))
QUIT
+11 SET SPEC=0
+12 FOR
SET SPEC=$ORDER(^LR(LRDFN,APSUB,LRIDT,.1,SPEC))
if SPEC<1
QUIT
Begin DoDot:3
+13 IF '$LENGTH($PIECE($GET(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,0)),U))
QUIT
+14 SET NE=NE+1
+15 SET PREP=0
+16 FOR
SET PREP=$ORDER(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP))
if PREP<1
QUIT
Begin DoDot:4
+17 SET TEST=0
+18 FOR
SET TEST=$ORDER(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP,1,TEST))
if TEST<1
QUIT
Begin DoDot:5
+19 IF '$LENGTH($PIECE($GET(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP,1,TEST,0)),U))
QUIT
+20 SET NE=NE+1
End DoDot:5
End DoDot:4
End DoDot:3
+21 SET ACC=$PIECE(^LR(LRDFN,APSUB,LRIDT,0),U,6)
+22 IF $LENGTH(ACC)
Begin DoDot:3
+23 SET NODE=LRDFN_";"_APSUB_";"_LRIDT_";0"
+24 DO ACC(.TESTS,ACC,DATE,.ANUMS,.ERR)
+25 IF 'ERR
Begin DoDot:4
+26 SET TEST=0
+27 FOR
SET TEST=$ORDER(TESTS(TEST))
if TEST<1
QUIT
Begin DoDot:5
+28 SET NE=NE+1
End DoDot:5
End DoDot:4
End DoDot:3
+29 SET ICD=0
+30 FOR
SET ICD=$ORDER(^LR(LRDFN,APSUB,LRIDT,3,ICD))
if ICD<1
QUIT
Begin DoDot:3
+31 SET ICDX=+$GET(^LR(LRDFN,APSUB,LRIDT,3,ICD,0))
+32 IF 'ICDX
QUIT
+33 SET NE=NE+1
End DoDot:3
+34 SET I=0
+35 FOR
SET I=$ORDER(^LR(LRDFN,APSUB,LRIDT,2,I))
if I<1
QUIT
Begin DoDot:3
+36 SET ORGAN=+$GET(^LR(LRDFN,APSUB,LRIDT,2,I,0))
+37 IF 'ORGAN
QUIT
+38 SET NE=NE+1
+39 DO SNOMED(LRDFN,LRIDT,DATE,APSUB,I,.NE)
End DoDot:3
End DoDot:2
End DoDot:1
+40 QUIT
+41 ;
SNOMED(LRDFN,LRIDT,DATE,APSUB,I,NE) ;
+1 NEW ETIOL,II,III,SNOMED,SUB,SUBS
+2 ;DBIA #4179
+3 FOR SUBS="1D","2M","3F","4P"
Begin DoDot:1
+4 SET SUB=+SUBS
+5 SET II=0
+6 FOR
SET II=$ORDER(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II))
if II<1
QUIT
Begin DoDot:2
+7 SET SNOMED=+$GET(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,0))
+8 IF 'SNOMED
QUIT
+9 SET NE=NE+1
+10 IF SUB'=2
QUIT
+11 SET III=0
+12 FOR
SET III=$ORDER(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,1,III))
if III<1
QUIT
Begin DoDot:3
+13 SET ETIOL=+$GET(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,1,III,0))
+14 IF 'ETIOL
QUIT
+15 SET NE=NE+1
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
+18 ;===============================================================
MICRO(NE) ;
+1 NEW AB,ABDN,ACC,ANUMS,DATE,ERR
+2 NEW LRDFN,LRIDT,ORG,ORGNUM,SPEC,SUB
+3 NEW TB,TBDN,TEMP,TEST,TESTS
+4 ;DBIA #4179
+5 KILL ANUMS,TESTS
+6 DO AANUMS(.ANUMS)
+7 SET LRDFN=.9
+8 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
if LRDFN<1
QUIT
Begin DoDot:1
+9 SET TEMP=$GET(^LR(LRDFN,0))
+10 IF $PIECE(TEMP,U,2)'=2
QUIT
+11 SET LRIDT=0
+12 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"MI",LRIDT))
if LRIDT<1
QUIT
Begin DoDot:2
+13 SET DATE=+$GET(^LR(LRDFN,"MI",LRIDT,0))
+14 IF 'DATE
QUIT
+15 SET SPEC=+$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,5)
+16 IF 'SPEC
QUIT
+17 SET NE=NE+1
+18 SET ACC=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,6)
+19 IF $LENGTH(ACC)
Begin DoDot:3
+20 DO ACC(.TESTS,ACC,DATE,.ANUMS,.ERR)
+21 IF 'ERR
Begin DoDot:4
+22 SET TEST=0
+23 FOR
SET TEST=$ORDER(TESTS(TEST))
if TEST<1
QUIT
Begin DoDot:5
+24 SET NE=NE+1
End DoDot:5
End DoDot:4
End DoDot:3
+25 IF $GET(^LR(LRDFN,"MI",LRIDT,1))
Begin DoDot:3
+26 SET ORGNUM=0
+27 FOR
SET ORGNUM=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGNUM))
if ORGNUM<1
QUIT
Begin DoDot:4
+28 SET ORG=+$GET(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,0))
+29 IF 'ORG
QUIT
+30 SET NE=NE+1
+31 SET ABDN=1
+32 FOR
SET ABDN=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,ABDN))
if ABDN<1
QUIT
Begin DoDot:5
+33 SET AB=+$GET(^TMP("LRPXSXRB",$JOB,"AB",ABDN))
+34 IF 'AB
QUIT
+35 SET NE=NE+1
End DoDot:5
End DoDot:4
End DoDot:3
+36 FOR SUB=6,9,12,17
Begin DoDot:3
+37 IF '$GET(^LR(LRDFN,"MI",LRIDT,(SUB-1)))
QUIT
+38 SET ORGNUM=0
+39 FOR
SET ORGNUM=$ORDER(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM))
if ORGNUM<1
QUIT
Begin DoDot:4
+40 SET ORG=+$GET(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM,0))
+41 IF 'ORG
QUIT
+42 SET NE=NE+1
+43 IF SUB'=12
QUIT
+44 SET TBDN=2
+45 FOR
SET TBDN=$ORDER(^LR(LRDFN,"MI",LRIDT,12,ORGNUM,TBDN))
if TBDN<2
QUIT
Begin DoDot:5
+46 SET TB=+$GET(^TMP("LRPXSXRB",$JOB,"TB",TBDN))
+47 IF '$LENGTH(TB)
QUIT
+48 SET NE=NE+1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+49 QUIT
+50 ;
AANUMS(ANUMS) ;
+1 NEW AA,ABREV
KILL ANUMS
+2 ;DBIA #4185
+3 SET AA=0
+4 FOR
SET AA=$ORDER(^LRO(68,AA))
if AA<1
QUIT
Begin DoDot:1
+5 SET ABREV=$PIECE($GET(^LRO(68,AA,0)),U,11)
+6 IF $LENGTH(ABREV)
SET ANUMS(ABREV)=AA
End DoDot:1
+7 QUIT
+8 ;
ACC(TESTS,ACC,BDN,ANUMS,ERR) ;
+1 ; returns TESTS from micro accession, ACC, BDN required
+2 ; BDN is beginning date number
+3 ; ANUMS is array of accession name numbers (avoids lookup on repeated calls)
+4 NEW DIC,LRAA,LRAAB,LRAD,LRAN,TEST,X,Y
KILL DIC,TESTS
+5 SET ERR=0
+6 IF '$LENGTH($GET(ACC))
SET ERR=1
QUIT
+7 SET LRAAB=$PIECE(ACC," ")
+8 IF LRAAB=""
QUIT
+9 SET BDN=$EXTRACT($GET(BDN))
+10 IF BDN'>1
SET ERR=1
QUIT
+11 SET LRAN=+$PIECE(ACC," ",3)
+12 IF 'LRAN
SET ERR=1
QUIT
+13 SET LRAA=+$GET(ANUMS(LRAAB))
+14 IF 'LRAA
Begin DoDot:1
+15 SET DIC=68
SET DIC(0)="M"
+16 SET X=LRAAB
+17 DO ^DIC
KILL DIC
+18 SET LRAA=+Y
+19 SET ANUMS(LRAAB)=LRAA
End DoDot:1
+20 IF LRAA'>0
SET ERR=1
QUIT
+21 ; yearly acc areas are assumed
SET LRAD=BDN_$PIECE(ACC," ",2)_"0000"
+22 SET TEST=0
+23 FOR
SET TEST=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TEST))
if TEST<1
QUIT
Begin DoDot:1
+24 SET TESTS(TEST)=TEST
End DoDot:1
+25 QUIT
+26 ;
