Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRPXSXRB

LRPXSXRB.m

Go to the documentation of this file. 
  1. LRPXSXRB ;VA/SLC/PKR - Build indexes for Lab Microbiology. ;1/29/04  14:36
  1.  ;;5.2;LAB SERVICE;**1030,1031**;NOV 01, 1997
  1.  ;
  1.  ;;VA LR Patch(s): 295
  1.  ;
  1.  Q
  1.  ;===============================================================
  1. MICRO ; from LRPXSXRL
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
  1.  ;       RPMS Lab does not use Clinical Reminders.
  1.  ;       None of the following code will be used.
  1.  ; Q
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1030
  1.  ; 
  1.  Q:'$$PATCH^BLRUTIL4("PXRM*1.5*12")                ; IHS/MSC/MKK - LR*5.2*1031
  1.  ; 
  1.  ;Build the indexes for LAB DATA - MICROBIOLOGY.
  1.  N AB,ABDN,ACC,ANUMS,DATE,DNUM,DFN,END,ENTRIES,ERR,GLOBAL,IND,ITEM
  1.  N LRDFN,LRIDT,NE,NERROR,NODE,NUM,ORG,ORGNUM,SPEC,START,SUB
  1.  N TB,TBDN,TEMP,TENP,TEST,TESTS,TEXT
  1.  K ANUMS,TESTS
  1.  ;Dont leave any old stuff around.
  1.  S GLOBAL=$$GET1^DID(63,"","","GLOBAL NAME")_"""MICRO"")"
  1.  S ENTRIES=$P(^LR(0),U,4)
  1.  S TENP=ENTRIES/10
  1.  S TENP=+$P(TENP,".",1)
  1.  I TENP<1 S TENP=1
  1.  D BMES^XPDUTL("Building indexes for LAB DATA - MICROBIOLOGY")
  1.  S TEXT="There are "_ENTRIES_" entries to process."
  1.  D MES^XPDUTL(TEXT)
  1.  S START=$H
  1.  S (IND,NE,NERROR)=0
  1.  K ^TMP("LRPXSXRB",$J)
  1.  S NUM=0
  1.  F  S NUM=$O(^LAB(62.06,NUM)) Q:NUM<1  D
  1.  . S DNUM=+$P($G(^LAB(62.06,NUM,0)),U,2)
  1.  . I DNUM'["2." Q
  1.  . I '$D(^TMP("LRPXSXRB",$J,"AB",DNUM)) S ^TMP("LRPXSXRB",$J,"AB",DNUM)=NUM
  1.  S NUM=2
  1.  F  S NUM=$O(^DD(63.39,NUM)) Q:NUM<1  D  ; dbia 999
  1.  . S DNUM=+$P($G(^DD(63.39,NUM,0)),U,4) ; dbia 999
  1.  . I DNUM'["2." Q
  1.  . S ^TMP("LRPXSXRB",$J,"TB",DNUM)=NUM
  1.  D AANUMS(.ANUMS)
  1.  S LRDFN=.9
  1.  F  S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1  D
  1.  . S TEMP=$G(^LR(LRDFN,0))
  1.  . I $P(TEMP,U,2)'=2 Q
  1.  . S DFN=+$P(TEMP,U,3)
  1.  . I LRDFN'=$$LRDFN^LRPXAPIU(DFN) Q
  1.  . S IND=IND+1
  1.  . I IND#TENP=0 D
  1.  .. S TEXT="Processing entry "_IND
  1.  .. D MES^XPDUTL(TEXT)
  1.  . S LRIDT=0
  1.  . F  S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1  D
  1.  .. S DATE=+$G(^LR(LRDFN,"MI",LRIDT,0))
  1.  .. I 'DATE Q
  1.  .. ; I '$$MIVER^LRPXRM(LRDFN,LRIDT) Q           ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
  1.  .. I '$$MIVER^LRPXRM(LRDFN,LRIDT) Q           ; IHS/MSC/MKK - LR*5.2*1031
  1.  .. S SPEC=+$P(^LR(LRDFN,"MI",LRIDT,0),U,5)
  1.  .. I 'SPEC Q
  1.  .. S ITEM="M;S;"_SPEC
  1.  .. S NODE=LRDFN_";MI;"_LRIDT_";0"
  1.  .. D MISET(DFN,ITEM,DATE,NODE)
  1.  .. S ACC=$P(^LR(LRDFN,"MI",LRIDT,0),U,6)
  1.  .. I $L(ACC) D
  1.  ... D ACC(.TESTS,ACC,DATE,.ANUMS,.ERR)
  1.  ... I 'ERR D
  1.  .... S TEST=0
  1.  .... F  S TEST=$O(TESTS(TEST)) Q:TEST<1  D
  1.  ..... S ITEM="M;T;"_TEST
  1.  ..... D MISET(DFN,ITEM,DATE,NODE)
  1.  .. I $G(^LR(LRDFN,"MI",LRIDT,1)) D
  1.  ... S ORGNUM=0
  1.  ... F  S ORGNUM=$O(^LR(LRDFN,"MI",LRIDT,3,ORGNUM)) Q:ORGNUM<1  D
  1.  .... S ORG=+$G(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,0))
  1.  .... I 'ORG Q
  1.  .... S ITEM="M;O;"_ORG
  1.  .... S NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";0"
  1.  .... D MISET(DFN,ITEM,DATE,NODE)
  1.  .... S ABDN=1
  1.  .... F  S ABDN=$O(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,ABDN)) Q:ABDN<1  D
  1.  ..... S AB=+$G(^TMP("LRPXSXRB",$J,"AB",ABDN))
  1.  ..... I 'AB Q
  1.  ..... S ITEM="M;A;"_AB
  1.  ..... S NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";"_ABDN
  1.  ..... D MISET(DFN,ITEM,DATE,NODE)
  1.  .. F SUB=6,9,12,17 D
  1.  ... I '$G(^LR(LRDFN,"MI",LRIDT,(SUB-1))) Q
  1.  ... S ORGNUM=0
  1.  ... F  S ORGNUM=$O(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM)) Q:ORGNUM<1  D
  1.  .... S ORG=+$G(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM,0))
  1.  .... I 'ORG Q
  1.  .... S ITEM="M;O;"_ORG
  1.  .... S NODE=LRDFN_";MI;"_LRIDT_";"_SUB_";"_ORGNUM_";0"
  1.  .... D MISET(DFN,ITEM,DATE,NODE)
  1.  .... I SUB'=12 Q
  1.  .... S TBDN=2
  1.  .... F  S TBDN=$O(^LR(LRDFN,"MI",LRIDT,12,ORGNUM,TBDN)) Q:TBDN<2  D
  1.  ..... S TB=+$G(^TMP("LRPXSXRB",$J,"TB",TBDN))
  1.  ..... I '$L(TB) Q
  1.  ..... S ITEM="M;M;"_TB
  1.  ..... S NODE=LRDFN_";MI;"_LRIDT_";12;"_ORGNUM_";"_TBDN
  1.  ..... D MISET(DFN,ITEM,DATE,NODE)
  1.  K ^TMP("LRPXSXRB",$J)
  1.  S TEXT=NE_" LAB DATA (MICRO) results indexed."
  1.  D MES^XPDUTL(TEXT)
  1.  S END=$H
  1.  ; D DETIME^PXRMSXRM(START,END) ; dbia 4113                     ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
  1.  D DETIME^PXRMSXRM(START,END) ; dbia 4113                     ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
  1.  ;If there were errors send a message.
  1.  ; I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL) ; dbia 4113      ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
  1.  I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL) ; dbia 4113      ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
  1.  ;Send a MailMan message with the results.
  1.  ; D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR) ; dbia 4113    ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
  1.  ; S ^PXRMINDX(63,"GLOBAL NAME")=$P(GLOBAL,"""",1) ; dbia 4114  ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
  1.  ; S ^PXRMINDX(63,"BUILT BY")=DUZ ; dbia 4114                   ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
  1.  ; S ^PXRMINDX(63,"DATE BUILT")=$$NOW^XLFDT ; dbia 4114         ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
  1.  D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR) ; dbia 4113    ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
  1.  S ^PXRMINDX(63,"GLOBAL NAME")=$P(GLOBAL,"""",1) ; dbia 4114  ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
  1.  S ^PXRMINDX(63,"BUILT BY")=DUZ ; dbia 4114                   ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
  1.  S ^PXRMINDX(63,"DATE BUILT")=$$NOW^XLFDT ; dbia 4114         ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
  1.  Q
  1.  ;
  1. MISET(DFN,ITEM,DATE,NODE) ;
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
  1.  ;       RPMS Lab does not use Clinical Reminders.
  1.  ;       None of the following code will be used.
  1.  ; Q
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1030
  1.  ; 
  1.  Q:'$$PATCH^BLRUTIL4("PXRM*1.5*12")                ; IHS/MSC/MKK - LR*5.2*1031
  1.  ; 
  1.  I '$P(ITEM,";",3) D
  1.  . N ETEXT
  1.  . S ETEXT=NODE_" missing test"
  1.  . ; D ADDERROR^PXRMSXRM("LR(MICRO",ETEXT,.NERROR) ; dbia 4113  ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
  1.  . D ADDERROR^PXRMSXRM("LR(MICRO",ETEXT,.NERROR) ; dbia 4113  ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
  1.  E  D
  1.  . D SLAB^LRPX(DFN,DATE,ITEM,NODE)
  1.  . S NE=NE+1
  1.  Q
  1.  ;
  1. AANUMS(ANUMS) ; from LRPXSXRA
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
  1.  ;       RPMS Lab does not use Clinical Reminders.
  1.  ;       None of the following code will be used.
  1.  ; Q
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1030
  1.  ; 
  1.  N AA,ABREV K ANUMS
  1.  S AA=0
  1.  F  S AA=$O(^LRO(68,AA)) Q:AA<1  D
  1.  . S ABREV=$P($G(^LRO(68,AA,0)),U,11)
  1.  . I $L(ABREV) S ANUMS(ABREV)=AA
  1.  Q
  1.  ;
  1. ACC(TESTS,ACC,BDN,ANUMS,ERR) ; from LRPXSXRA
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
  1.  ;       RPMS Lab does not use Clinical Reminders.
  1.  ;       None of the following code will be used.
  1.  ; Q
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1030
  1.  ; returns TESTS from micro accession, ACC, BDN required
  1.  ; BDN is beginning date number
  1.  ; ANUMS is array of accession name numbers (avoids lookup on repeated calls)
  1.  N DIC,LRAA,LRAAB,LRAD,LRAN,TEST,X,Y K DIC,TESTS
  1.  S ERR=0
  1.  I '$L($G(ACC)) S ERR=1 Q
  1.  S LRAAB=$P(ACC," ")
  1.  I LRAAB="" Q
  1.  S BDN=$E($G(BDN))
  1.  I BDN'>1 S ERR=1 Q
  1.  S LRAN=+$P(ACC," ",3)
  1.  I 'LRAN S ERR=1 Q
  1.  S LRAA=+$G(ANUMS(LRAAB))
  1.  I 'LRAA D
  1.  . S DIC=68,DIC(0)="M"
  1.  . S X=LRAAB
  1.  . D ^DIC K DIC
  1.  . S LRAA=+Y
  1.  . S ANUMS(LRAAB)=LRAA
  1.  I LRAA'>0 S ERR=1 Q
  1.  S LRAD=BDN_$P(ACC," ",2)_"0000" ; yearly acc areas are assumed
  1.  S TEST=0
  1.  F  S TEST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TEST)) Q:TEST<1  D
  1.  . S TESTS(TEST)=TEST
  1.  Q
  1.  ;