LRPXSXRB ; SLC/PKR - Build indexes for Lab Microbiology. ;1/29/04 14:36
;;5.2;LAB SERVICE;**295**;Sep 27, 1994
Q
;===============================================================
MICRO ; from LRPXSXRL
;Build the indexes for LAB DATA - MICROBIOLOGY.
N AB,ABDN,ACC,ANUMS,DATE,DNUM,DFN,END,ENTRIES,ERR,GLOBAL,IND,ITEM
N LRDFN,LRIDT,NE,NERROR,NODE,NUM,ORG,ORGNUM,SPEC,START,SUB
N TB,TBDN,TEMP,TENP,TEST,TESTS,TEXT
K ANUMS,TESTS
;Dont leave any old stuff around.
S GLOBAL=$$GET1^DID(63,"","","GLOBAL NAME")_"""MICRO"")"
S ENTRIES=$P(^LR(0),U,4)
S TENP=ENTRIES/10
S TENP=+$P(TENP,".",1)
I TENP<1 S TENP=1
D BMES^XPDUTL("Building indexes for LAB DATA - MICROBIOLOGY")
S TEXT="There are "_ENTRIES_" entries to process."
D MES^XPDUTL(TEXT)
S START=$H
S (IND,NE,NERROR)=0
K ^TMP("LRPXSXRB",$J)
S NUM=0
F S NUM=$O(^LAB(62.06,NUM)) Q:NUM<1 D
. S DNUM=+$P($G(^LAB(62.06,NUM,0)),U,2)
. I DNUM'["2." Q
. I '$D(^TMP("LRPXSXRB",$J,"AB",DNUM)) S ^TMP("LRPXSXRB",$J,"AB",DNUM)=NUM
S NUM=2
F S NUM=$O(^DD(63.39,NUM)) Q:NUM<1 D ; dbia 999
. S DNUM=+$P($G(^DD(63.39,NUM,0)),U,4) ; dbia 999
. I DNUM'["2." Q
. S ^TMP("LRPXSXRB",$J,"TB",DNUM)=NUM
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 DFN=+$P(TEMP,U,3)
. I LRDFN'=$$LRDFN^LRPXAPIU(DFN) Q
. S IND=IND+1
. I IND#TENP=0 D
.. S TEXT="Processing entry "_IND
.. D MES^XPDUTL(TEXT)
. 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
.. I '$$MIVER^LRPXRM(LRDFN,LRIDT) Q
.. S SPEC=+$P(^LR(LRDFN,"MI",LRIDT,0),U,5)
.. I 'SPEC Q
.. S ITEM="M;S;"_SPEC
.. S NODE=LRDFN_";MI;"_LRIDT_";0"
.. D MISET(DFN,ITEM,DATE,NODE)
.. 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 ITEM="M;T;"_TEST
..... D MISET(DFN,ITEM,DATE,NODE)
.. 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 ITEM="M;O;"_ORG
.... S NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";0"
.... D MISET(DFN,ITEM,DATE,NODE)
.... 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 ITEM="M;A;"_AB
..... S NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";"_ABDN
..... D MISET(DFN,ITEM,DATE,NODE)
.. 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 ITEM="M;O;"_ORG
.... S NODE=LRDFN_";MI;"_LRIDT_";"_SUB_";"_ORGNUM_";0"
.... D MISET(DFN,ITEM,DATE,NODE)
.... 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 ITEM="M;M;"_TB
..... S NODE=LRDFN_";MI;"_LRIDT_";12;"_ORGNUM_";"_TBDN
..... D MISET(DFN,ITEM,DATE,NODE)
K ^TMP("LRPXSXRB",$J)
S TEXT=NE_" LAB DATA (MICRO) results indexed."
D MES^XPDUTL(TEXT)
S END=$H
D DETIME^PXRMSXRM(START,END) ; dbia 4113
;If there were errors send a message.
I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL) ; dbia 4113
;Send a MailMan message with the results.
D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR) ; dbia 4113
S ^PXRMINDX(63,"GLOBAL NAME")=$P(GLOBAL,"""",1) ; dbia 4114
S ^PXRMINDX(63,"BUILT BY")=DUZ ; dbia 4114
S ^PXRMINDX(63,"DATE BUILT")=$$NOW^XLFDT ; dbia 4114
Q
;
MISET(DFN,ITEM,DATE,NODE) ;
I '$P(ITEM,";",3) D
. N ETEXT
. S ETEXT=NODE_" missing test"
. D ADDERROR^PXRMSXRM("LR(MICRO",ETEXT,.NERROR) ; dbia 4113
E D
. D SLAB^LRPX(DFN,DATE,ITEM,NODE)
. S NE=NE+1
Q
;
AANUMS(ANUMS) ; from LRPXSXRA
N AA,ABREV K ANUMS
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) ; from LRPXSXRA
; 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[HLRPXSXRB 4892 printed Sep 23, 2025@19:55:22 Page 2
LRPXSXRB ; SLC/PKR - Build indexes for Lab Microbiology. ;1/29/04 14:36
+1 ;;5.2;LAB SERVICE;**295**;Sep 27, 1994
+2 QUIT
+3 ;===============================================================
MICRO ; from LRPXSXRL
+1 ;Build the indexes for LAB DATA - MICROBIOLOGY.
+2 NEW AB,ABDN,ACC,ANUMS,DATE,DNUM,DFN,END,ENTRIES,ERR,GLOBAL,IND,ITEM
+3 NEW LRDFN,LRIDT,NE,NERROR,NODE,NUM,ORG,ORGNUM,SPEC,START,SUB
+4 NEW TB,TBDN,TEMP,TENP,TEST,TESTS,TEXT
+5 KILL ANUMS,TESTS
+6 ;Dont leave any old stuff around.
+7 SET GLOBAL=$$GET1^DID(63,"","","GLOBAL NAME")_"""MICRO"")"
+8 SET ENTRIES=$PIECE(^LR(0),U,4)
+9 SET TENP=ENTRIES/10
+10 SET TENP=+$PIECE(TENP,".",1)
+11 IF TENP<1
SET TENP=1
+12 DO BMES^XPDUTL("Building indexes for LAB DATA - MICROBIOLOGY")
+13 SET TEXT="There are "_ENTRIES_" entries to process."
+14 DO MES^XPDUTL(TEXT)
+15 SET START=$HOROLOG
+16 SET (IND,NE,NERROR)=0
+17 KILL ^TMP("LRPXSXRB",$JOB)
+18 SET NUM=0
+19 FOR
SET NUM=$ORDER(^LAB(62.06,NUM))
if NUM<1
QUIT
Begin DoDot:1
+20 SET DNUM=+$PIECE($GET(^LAB(62.06,NUM,0)),U,2)
+21 IF DNUM'["2."
QUIT
+22 IF '$DATA(^TMP("LRPXSXRB",$JOB,"AB",DNUM))
SET ^TMP("LRPXSXRB",$JOB,"AB",DNUM)=NUM
End DoDot:1
+23 SET NUM=2
+24 ; dbia 999
FOR
SET NUM=$ORDER(^DD(63.39,NUM))
if NUM<1
QUIT
Begin DoDot:1
+25 ; dbia 999
SET DNUM=+$PIECE($GET(^DD(63.39,NUM,0)),U,4)
+26 IF DNUM'["2."
QUIT
+27 SET ^TMP("LRPXSXRB",$JOB,"TB",DNUM)=NUM
End DoDot:1
+28 DO AANUMS(.ANUMS)
+29 SET LRDFN=.9
+30 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
if LRDFN<1
QUIT
Begin DoDot:1
+31 SET TEMP=$GET(^LR(LRDFN,0))
+32 IF $PIECE(TEMP,U,2)'=2
QUIT
+33 SET DFN=+$PIECE(TEMP,U,3)
+34 IF LRDFN'=$$LRDFN^LRPXAPIU(DFN)
QUIT
+35 SET IND=IND+1
+36 IF IND#TENP=0
Begin DoDot:2
+37 SET TEXT="Processing entry "_IND
+38 DO MES^XPDUTL(TEXT)
End DoDot:2
+39 SET LRIDT=0
+40 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"MI",LRIDT))
if LRIDT<1
QUIT
Begin DoDot:2
+41 SET DATE=+$GET(^LR(LRDFN,"MI",LRIDT,0))
+42 IF 'DATE
QUIT
+43 IF '$$MIVER^LRPXRM(LRDFN,LRIDT)
QUIT
+44 SET SPEC=+$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,5)
+45 IF 'SPEC
QUIT
+46 SET ITEM="M;S;"_SPEC
+47 SET NODE=LRDFN_";MI;"_LRIDT_";0"
+48 DO MISET(DFN,ITEM,DATE,NODE)
+49 SET ACC=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,6)
+50 IF $LENGTH(ACC)
Begin DoDot:3
+51 DO ACC(.TESTS,ACC,DATE,.ANUMS,.ERR)
+52 IF 'ERR
Begin DoDot:4
+53 SET TEST=0
+54 FOR
SET TEST=$ORDER(TESTS(TEST))
if TEST<1
QUIT
Begin DoDot:5
+55 SET ITEM="M;T;"_TEST
+56 DO MISET(DFN,ITEM,DATE,NODE)
End DoDot:5
End DoDot:4
End DoDot:3
+57 IF $GET(^LR(LRDFN,"MI",LRIDT,1))
Begin DoDot:3
+58 SET ORGNUM=0
+59 FOR
SET ORGNUM=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGNUM))
if ORGNUM<1
QUIT
Begin DoDot:4
+60 SET ORG=+$GET(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,0))
+61 IF 'ORG
QUIT
+62 SET ITEM="M;O;"_ORG
+63 SET NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";0"
+64 DO MISET(DFN,ITEM,DATE,NODE)
+65 SET ABDN=1
+66 FOR
SET ABDN=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,ABDN))
if ABDN<1
QUIT
Begin DoDot:5
+67 SET AB=+$GET(^TMP("LRPXSXRB",$JOB,"AB",ABDN))
+68 IF 'AB
QUIT
+69 SET ITEM="M;A;"_AB
+70 SET NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";"_ABDN
+71 DO MISET(DFN,ITEM,DATE,NODE)
End DoDot:5
End DoDot:4
End DoDot:3
+72 FOR SUB=6,9,12,17
Begin DoDot:3
+73 IF '$GET(^LR(LRDFN,"MI",LRIDT,(SUB-1)))
QUIT
+74 SET ORGNUM=0
+75 FOR
SET ORGNUM=$ORDER(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM))
if ORGNUM<1
QUIT
Begin DoDot:4
+76 SET ORG=+$GET(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM,0))
+77 IF 'ORG
QUIT
+78 SET ITEM="M;O;"_ORG
+79 SET NODE=LRDFN_";MI;"_LRIDT_";"_SUB_";"_ORGNUM_";0"
+80 DO MISET(DFN,ITEM,DATE,NODE)
+81 IF SUB'=12
QUIT
+82 SET TBDN=2
+83 FOR
SET TBDN=$ORDER(^LR(LRDFN,"MI",LRIDT,12,ORGNUM,TBDN))
if TBDN<2
QUIT
Begin DoDot:5
+84 SET TB=+$GET(^TMP("LRPXSXRB",$JOB,"TB",TBDN))
+85 IF '$LENGTH(TB)
QUIT
+86 SET ITEM="M;M;"_TB
+87 SET NODE=LRDFN_";MI;"_LRIDT_";12;"_ORGNUM_";"_TBDN
+88 DO MISET(DFN,ITEM,DATE,NODE)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+89 KILL ^TMP("LRPXSXRB",$JOB)
+90 SET TEXT=NE_" LAB DATA (MICRO) results indexed."
+91 DO MES^XPDUTL(TEXT)
+92 SET END=$HOROLOG
+93 ; dbia 4113
DO DETIME^PXRMSXRM(START,END)
+94 ;If there were errors send a message.
+95 ; dbia 4113
IF NERROR>0
DO ERRMSG^PXRMSXRM(NERROR,GLOBAL)
+96 ;Send a MailMan message with the results.
+97 ; dbia 4113
DO COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
+98 ; dbia 4114
SET ^PXRMINDX(63,"GLOBAL NAME")=$PIECE(GLOBAL,"""",1)
+99 ; dbia 4114
SET ^PXRMINDX(63,"BUILT BY")=DUZ
+100 ; dbia 4114
SET ^PXRMINDX(63,"DATE BUILT")=$$NOW^XLFDT
+101 QUIT
+102 ;
MISET(DFN,ITEM,DATE,NODE) ;
+1 IF '$PIECE(ITEM,";",3)
Begin DoDot:1
+2 NEW ETEXT
+3 SET ETEXT=NODE_" missing test"
+4 ; dbia 4113
DO ADDERROR^PXRMSXRM("LR(MICRO",ETEXT,.NERROR)
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 DO SLAB^LRPX(DFN,DATE,ITEM,NODE)
+7 SET NE=NE+1
End DoDot:1
+8 QUIT
+9 ;
AANUMS(ANUMS) ; from LRPXSXRA
+1 NEW AA,ABREV
KILL ANUMS
+2 SET AA=0
+3 FOR
SET AA=$ORDER(^LRO(68,AA))
if AA<1
QUIT
Begin DoDot:1
+4 SET ABREV=$PIECE($GET(^LRO(68,AA,0)),U,11)
+5 IF $LENGTH(ABREV)
SET ANUMS(ABREV)=AA
End DoDot:1
+6 QUIT
+7 ;
ACC(TESTS,ACC,BDN,ANUMS,ERR) ; from LRPXSXRA
+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 ;
