- 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 Mar 13, 2025@21:24:12 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 ;
