source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRPXSXRB.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.6 KB
Line 
1LRPXSXRB ; SLC/PKR - Build indexes for Lab Microbiology. ;1/29/04 14:36
2 ;;5.2;LAB SERVICE;**295**;Sep 27, 1994
3 Q
4 ;===============================================================
5MICRO ; from LRPXSXRL
6 ;Build the indexes for LAB DATA - MICROBIOLOGY.
7 N AB,ABDN,ACC,ANUMS,DATE,DNUM,DFN,END,ENTRIES,ERR,GLOBAL,IND,ITEM
8 N LRDFN,LRIDT,NE,NERROR,NODE,NUM,ORG,ORGNUM,SPEC,START,SUB
9 N TB,TBDN,TEMP,TENP,TEST,TESTS,TEXT
10 K ANUMS,TESTS
11 ;Dont leave any old stuff around.
12 S GLOBAL=$$GET1^DID(63,"","","GLOBAL NAME")_"""MICRO"")"
13 S ENTRIES=$P(^LR(0),U,4)
14 S TENP=ENTRIES/10
15 S TENP=+$P(TENP,".",1)
16 I TENP<1 S TENP=1
17 D BMES^XPDUTL("Building indexes for LAB DATA - MICROBIOLOGY")
18 S TEXT="There are "_ENTRIES_" entries to process."
19 D MES^XPDUTL(TEXT)
20 S START=$H
21 S (IND,NE,NERROR)=0
22 K ^TMP("LRPXSXRB",$J)
23 S NUM=0
24 F S NUM=$O(^LAB(62.06,NUM)) Q:NUM<1 D
25 . S DNUM=+$P($G(^LAB(62.06,NUM,0)),U,2)
26 . I DNUM'["2." Q
27 . I '$D(^TMP("LRPXSXRB",$J,"AB",DNUM)) S ^TMP("LRPXSXRB",$J,"AB",DNUM)=NUM
28 S NUM=2
29 F S NUM=$O(^DD(63.39,NUM)) Q:NUM<1 D ; dbia 999
30 . S DNUM=+$P($G(^DD(63.39,NUM,0)),U,4) ; dbia 999
31 . I DNUM'["2." Q
32 . S ^TMP("LRPXSXRB",$J,"TB",DNUM)=NUM
33 D AANUMS(.ANUMS)
34 S LRDFN=.9
35 F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D
36 . S TEMP=$G(^LR(LRDFN,0))
37 . I $P(TEMP,U,2)'=2 Q
38 . S DFN=+$P(TEMP,U,3)
39 . I LRDFN'=$$LRDFN^LRPXAPIU(DFN) Q
40 . S IND=IND+1
41 . I IND#TENP=0 D
42 .. S TEXT="Processing entry "_IND
43 .. D MES^XPDUTL(TEXT)
44 . S LRIDT=0
45 . F S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1 D
46 .. S DATE=+$G(^LR(LRDFN,"MI",LRIDT,0))
47 .. I 'DATE Q
48 .. I '$$MIVER^LRPXRM(LRDFN,LRIDT) Q
49 .. S SPEC=+$P(^LR(LRDFN,"MI",LRIDT,0),U,5)
50 .. I 'SPEC Q
51 .. S ITEM="M;S;"_SPEC
52 .. S NODE=LRDFN_";MI;"_LRIDT_";0"
53 .. D MISET(DFN,ITEM,DATE,NODE)
54 .. S ACC=$P(^LR(LRDFN,"MI",LRIDT,0),U,6)
55 .. I $L(ACC) D
56 ... D ACC(.TESTS,ACC,DATE,.ANUMS,.ERR)
57 ... I 'ERR D
58 .... S TEST=0
59 .... F S TEST=$O(TESTS(TEST)) Q:TEST<1 D
60 ..... S ITEM="M;T;"_TEST
61 ..... D MISET(DFN,ITEM,DATE,NODE)
62 .. I $G(^LR(LRDFN,"MI",LRIDT,1)) D
63 ... S ORGNUM=0
64 ... F S ORGNUM=$O(^LR(LRDFN,"MI",LRIDT,3,ORGNUM)) Q:ORGNUM<1 D
65 .... S ORG=+$G(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,0))
66 .... I 'ORG Q
67 .... S ITEM="M;O;"_ORG
68 .... S NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";0"
69 .... D MISET(DFN,ITEM,DATE,NODE)
70 .... S ABDN=1
71 .... F S ABDN=$O(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,ABDN)) Q:ABDN<1 D
72 ..... S AB=+$G(^TMP("LRPXSXRB",$J,"AB",ABDN))
73 ..... I 'AB Q
74 ..... S ITEM="M;A;"_AB
75 ..... S NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";"_ABDN
76 ..... D MISET(DFN,ITEM,DATE,NODE)
77 .. F SUB=6,9,12,17 D
78 ... I '$G(^LR(LRDFN,"MI",LRIDT,(SUB-1))) Q
79 ... S ORGNUM=0
80 ... F S ORGNUM=$O(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM)) Q:ORGNUM<1 D
81 .... S ORG=+$G(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM,0))
82 .... I 'ORG Q
83 .... S ITEM="M;O;"_ORG
84 .... S NODE=LRDFN_";MI;"_LRIDT_";"_SUB_";"_ORGNUM_";0"
85 .... D MISET(DFN,ITEM,DATE,NODE)
86 .... I SUB'=12 Q
87 .... S TBDN=2
88 .... F S TBDN=$O(^LR(LRDFN,"MI",LRIDT,12,ORGNUM,TBDN)) Q:TBDN<2 D
89 ..... S TB=+$G(^TMP("LRPXSXRB",$J,"TB",TBDN))
90 ..... I '$L(TB) Q
91 ..... S ITEM="M;M;"_TB
92 ..... S NODE=LRDFN_";MI;"_LRIDT_";12;"_ORGNUM_";"_TBDN
93 ..... D MISET(DFN,ITEM,DATE,NODE)
94 K ^TMP("LRPXSXRB",$J)
95 S TEXT=NE_" LAB DATA (MICRO) results indexed."
96 D MES^XPDUTL(TEXT)
97 S END=$H
98 D DETIME^PXRMSXRM(START,END) ; dbia 4113
99 ;If there were errors send a message.
100 I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL) ; dbia 4113
101 ;Send a MailMan message with the results.
102 D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR) ; dbia 4113
103 S ^PXRMINDX(63,"GLOBAL NAME")=$P(GLOBAL,"""",1) ; dbia 4114
104 S ^PXRMINDX(63,"BUILT BY")=DUZ ; dbia 4114
105 S ^PXRMINDX(63,"DATE BUILT")=$$NOW^XLFDT ; dbia 4114
106 Q
107 ;
108MISET(DFN,ITEM,DATE,NODE) ;
109 I '$P(ITEM,";",3) D
110 . N ETEXT
111 . S ETEXT=NODE_" missing test"
112 . D ADDERROR^PXRMSXRM("LR(MICRO",ETEXT,.NERROR) ; dbia 4113
113 E D
114 . D SLAB^LRPX(DFN,DATE,ITEM,NODE)
115 . S NE=NE+1
116 Q
117 ;
118AANUMS(ANUMS) ; from LRPXSXRA
119 N AA,ABREV K ANUMS
120 S AA=0
121 F S AA=$O(^LRO(68,AA)) Q:AA<1 D
122 . S ABREV=$P($G(^LRO(68,AA,0)),U,11)
123 . I $L(ABREV) S ANUMS(ABREV)=AA
124 Q
125 ;
126ACC(TESTS,ACC,BDN,ANUMS,ERR) ; from LRPXSXRA
127 ; returns TESTS from micro accession, ACC, BDN required
128 ; BDN is beginning date number
129 ; ANUMS is array of accession name numbers (avoids lookup on repeated calls)
130 N DIC,LRAA,LRAAB,LRAD,LRAN,TEST,X,Y K DIC,TESTS
131 S ERR=0
132 I '$L($G(ACC)) S ERR=1 Q
133 S LRAAB=$P(ACC," ")
134 I LRAAB="" Q
135 S BDN=$E($G(BDN))
136 I BDN'>1 S ERR=1 Q
137 S LRAN=+$P(ACC," ",3)
138 I 'LRAN S ERR=1 Q
139 S LRAA=+$G(ANUMS(LRAAB))
140 I 'LRAA D
141 . S DIC=68,DIC(0)="M"
142 . S X=LRAAB
143 . D ^DIC K DIC
144 . S LRAA=+Y
145 . S ANUMS(LRAAB)=LRAA
146 I LRAA'>0 S ERR=1 Q
147 S LRAD=BDN_$P(ACC," ",2)_"0000" ; yearly acc areas are assumed
148 S TEST=0
149 F S TEST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TEST)) Q:TEST<1 D
150 . S TESTS(TEST)=TEST
151 Q
152 ;
Note: See TracBrowser for help on using the repository browser.