source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRPXSXRL.m@ 1604

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

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1LRPXSXRL ; SLC/PKR - Build indexes for Lab. ;9/27/03 22:37
2 ;;5.2;LAB SERVICE;**295**;Sep 27, 1994
3 Q
4 ;===============================================================
5LAB ; this entry point is called to rebuild ALL Lab indexes in ^PXRMINDX(63
6 ; dbia 4247
7 ;Build the indexes for LAB DATA.
8 N DAE,DAS,DAT,DATE,DFN,DNODE,END,ENTRIES,ETEXT,GLOBAL,IND
9 N LRDFN,LRDN,LRIDT,NE,NERROR
10 N START,TEMP,TENP,TEST,TEXT
11 K ^TMP("LRPXTEST",$J)
12 ;Dont leave any old stuff around.
13 D CLEANL
14 S GLOBAL=$$GET1^DID(63,"","","GLOBAL NAME")_"""CH"")"
15 S NERROR=0
16 S ENTRIES=$P(^LR(0),U,4)
17 S TENP=ENTRIES/10
18 S TENP=+$P(TENP,".",1)
19 I TENP<1 S TENP=1
20 D BMES^XPDUTL("Building indexes for LAB DATA - CH")
21 S TEXT="There are "_ENTRIES_" entries to process."
22 D MES^XPDUTL(TEXT)
23 S START=$H
24 S (IND,NE)=0
25 K ^TMP("LRPXSXRL",$J)
26 S TEST=0
27 F S TEST=$O(^LAB(60,TEST)) Q:TEST<1 D ; preset values (lrdn)=test#
28 . S DNODE=$P($G(^LAB(60,TEST,0)),U,5)
29 . I $P(DNODE,";")'="CH" Q
30 . I $P(DNODE,";",3)'=1 Q
31 . S LRDN=+$P(DNODE,";",2)
32 . I 'LRDN Q
33 . S ^TMP("LRPXSXRL",$J,LRDN)=TEST_U_$D(^TMP("LRPXSXRL",$J,LRDN))
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,"CH",LRIDT)) Q:LRIDT<1 D
46 .. I '$P($G(^LR(LRDFN,"CH",LRIDT,0)),U,3) Q ; check for completed
47 .. S DAT=LRDFN_";CH;"_LRIDT
48 .. S DATE=9999999-LRIDT
49 .. S LRDN=1
50 .. F S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<1 D
51 ... S DAS=DAT_";"_LRDN
52 ... S TEMP=^LR(LRDFN,"CH",LRIDT,LRDN)
53 ... S TEST=+$P($P(TEMP,U,3),"!",6) ; get test, use ^LR node
54 ... I 'TEST D ; if not available on ^LR node
55 .... I $P($G(^TMP("LRPXSXRL",$J,LRDN)),U,2) D ; if duplicates, use file 60
56 ..... S TEST=+$O(^LAB(60,"C","CH;"_$G(LRDN)_";1",0))
57 .... E S TEST=+$G(^TMP("LRPXSXRL",$J,LRDN)) ; otherwise, use preset value
58 ... I 'TEST D
59 .... S DAE=LRDFN_","_"""CH"""_","_LRIDT_","_LRDN
60 .... S ETEXT=DAE_" No lab test"
61 .... I $D(^TMP("LRPXTEST",$J,LRDN)) Q
62 .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) ; dbia 4113
63 .... S ^TMP("LRPXTEST",$J,LRDN)=""
64 ... E D
65 .... D SLAB^LRPX(DFN,DATE,TEST,DAS)
66 .... S NE=NE+1
67 K ^TMP("LRPXSXRL",$J),^TMP("LRPXTEST",$J)
68 S TEXT=NE_" LAB DATA (CH) results indexed."
69 D MES^XPDUTL(TEXT)
70 S END=$H
71 D DETIME^PXRMSXRM(START,END) ; dbia 4113
72 ;If there were errors send a message.
73 I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL) ; dbia 4113
74 ;Send a MailMan message with the results.
75 D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR) ; dbia 4113
76 ;
77 D AP^LRPXSXRA
78 D MICRO^LRPXSXRB
79 Q
80 ;
81FRESH ; deletes all Lab, Micro, and AP ^PXRMINDX(63 indexes
82 K ^PXRMINDX(63) ; dbia 4114
83 Q
84 ;
85CLEANL ;
86 D BMES^XPDUTL("Cleaning up old Lab entries")
87 D FRESH ; remove all lab indexes
88 Q
89 ;
90RESETAP ; reindex AP
91 D BMES^XPDUTL("Reindex Anatomic Pathology Data")
92 D REMOVE("A")
93 D AP^LRPXSXRA
94 Q
95 ;
96RESETMI ; reindex Micro
97 D BMES^XPDUTL("Reindex Microbiology Data")
98 D REMOVE("M")
99 D MICRO^LRPXSXRB
100 Q
101 ;
102RESETAM ; reindex AP and Micro
103 D RESETAP
104 D RESETMI
105 Q
106 ;
107REMOVE(TYPE) ; remove these types of indexes
108 N DATE,DFN,ITEM,REF,STOP
109 S STOP=TYPE_"Z"
110 S ITEM=TYPE
111 F S ITEM=$O(^PXRMINDX(63,"IP",ITEM)) Q:ITEM="" Q:ITEM]STOP D
112 . S DFN=0
113 . F S DFN=$O(^PXRMINDX(63,"IP",ITEM,DFN)) Q:DFN<1 D
114 .. S DATE=0
115 .. F S DATE=$O(^PXRMINDX(63,"IP",ITEM,DFN,DATE)) Q:DATE<1 D
116 ... S REF=""
117 ... F S REF=$O(^PXRMINDX(63,"IP",ITEM,DFN,DATE,REF)) Q:REF="" D
118 .... D KLAB^LRPX(DFN,DATE,ITEM,REF)
119 Q
Note: See TracBrowser for help on using the repository browser.