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