source: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRAR04.m

Last change on this file was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.7 KB
Line 
1LRAR04 ;SLC/RWF/DAL/HOAK - REMOVE OLD DATA FROM PT. FILE ; 12/12/96 10:16 ;
2 ;;5.2;LAB SERVICE;**111**;Sep 27, 1994
3 ;
4 ; Rewrite 11/96 Hoak --------------->
5 ;
6 Q ;LRC2=NUMBER OF PT, LRC3=NUMBER OF DATES
7MOVE ;
8 ; This is where we make the copies to be archived <----------
9 ;
10 ; Move data from ^LR to ^LAR------>arcive global----------|
11 ; |
12 S LRCNT=$P(^LR(LRDFN,LRSS,0),U,3,4) ; |
13 S:LRSS="CH" ^LAR("Z",LRDFN,LRSS,0)="^63.999904D^"_LRCNT ; |
14 S:LRSS="MI" ^LAR("Z",LRDFN,LRSS,0)="^63.999905DA^"_LRCNT ; |
15 S %X="^LR(LRDFN,LRSS,LRIDT," ; |
16 S %Y="^LAR(""Z"",LRDFN,LRSS,LRIDT," ; |
17 ; |
18 D %XY^%RCR ; <-------------------------------------------------/
19 ;
20 ;
21 S:LRC1 LRC2=LRC2+1,LRC1=0
22 S ^LAR("Z",LRDFN,0)=^LR(LRDFN,0)
23 S ^LAR("Z","B",LRDFN,LRDFN)=""
24 S ^LAR("NAME",PNM,LRDFN)=""
25 S ^LAR("SSN",SSN,LRDFN)=""
26 S LRC3=LRC3+1
27 QUIT
28 ;
29PT ;
30 S PNM="unk",SSN="unk"
31 Q:LRDPF<1 D DEM^LRX
32 S:SSN="" SSN="unk" S:PNM="" PNM="unk"
33 QUIT
34 ;
35 ;
36DFN ;
37 ;from LRARCHIV
38 ;
39 ;
40 S LRI=0
41 S LRJT0=$P(^LR(0),U,4)
42 I '$G(LRDT7) S LRDT7=LR(1)
43 ;
44CONTROL ;
45 S LRDFN=0
46 Q
47 ;
48 ;
49QUERY ;
50 D DFN
51 D NOW^%DTC S ^TMP("LR9","ENDX")=%
52 S LRDFN=0
53 K ^TMP("LR9")
54 D NOW^%DTC S ^TMP("LR9","START")=%
55 S LRQCNT=0
56 ;
57 ; ^LR(13,"CH",7038789.916,0)
58 ;
59 ; This block builds a TMP global of data relevant for the date
60 ; range LRSDTX to LREDT
61 ;
62 ;--->New concept employed; gather only LRDFN(s) in date range
63 ; archive only these
64 ;
65 S LRV7=LREDT
66 S LRSDTX=9999999-LR(1)
67 S LREDT=9999999-LRV7 I $E(LREDT,1,1)=2 S LREDT=LRV7
68 S LRDFN="^LR(1,0)"
69 S ^TMP("LR9","RANGE")=LRSDTX_U_LREDT
70 ;
71 F S LRDFN=$Q(@LRDFN) Q:$P(LRDFN,",")'["LR(" S LR9=$P(LRDFN,",",3) D
72 . Q:$P(LRDFN,",",2)'["CH"
73 . S LR8=+$P(LRDFN,"LR(",2) Q:LR8'>0
74 . I LR9>LRSDTX,LR9<LREDT D
75 .. I $P(^LR(LR8,0),U,2)=2 S ^TMP("LR9",LR8)=^LR(LR8,0)_U_LR9_U_LREDT_U_+^LR(LR8,"CH",LR9,0) D
76 ... S $P(LRDFN,"LR(",2)=LR8+.1_","_$P(LRDFN,LR8_",",2)
77 ... S LRQCNT=LRQCNT+1
78 .. S LR5=$L(LRDFN)
79 .. I $E(LRDFN,LR5,LR5)'=")" S LRDFN=LRDFN_")"
80 D NOW^%DTC S ^TMP("LR9","END0")=%
81 Q
82DISPLAY ;
83 W !,"My preliminary screening process reveals ",$G(LRQCNT)," LRDFN(s)."
84 Q
85 ;
86 ;
87LR ;
88 D DQ1^LRARCHIV
89 D QUERY
90 S LRWHICH="CH"
91 K ^TMP("LRT2")
92 S LRDFN=0
93 ;
94 ;********************************************************************
95 ; *
96 ; Leave Micro question for next go-round *
97 ; *
98 ;********************************************************************
99 ;
100 F S LRDFN=$O(^TMP("LR9",LRDFN)) Q:+LRDFN'>0 D I LRDFN'>0 D TEND QUIT
101 . S LRDPF=$P(^TMP("LR9",LRDFN),U,2) S DFN=$P(^(LRDFN),U,3)
102 . I +LRDPF=2 S RC1=1 D PT
103 . I +LRDPF'=2 QUIT
104 . S LRIDT=$P(^TMP("LR9",LRDFN),U,7)
105 . S LRSS="CH" D LAB
106 D LST^LRARCHIV
107 D QUIT^LRARCHIV
108 Q
109LAB ;
110 S LRJTX=$P(^LR(0),U,4)
111 S LRIDT=LRIDT-.1
112 F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:+LRIDT'>0!(LRIDT>LREDT) D
113 . I $D(^LR(LRDFN,LRSS,LRIDT,0)) S LRDT7=+^(0)
114 . S LRI=$G(LRI)+1
115 . ;D JOBTIME^LRAC12
116 . W "."
117 . D LAB1
118 Q
119 ;
120LAB1 ;
121 D I LRIDT<1 D UPDT Q
122 . Q:'LRIDT
123 . I '$D(PNM) D PT
124 . IF '$D(^LR(LRDFN,LRSS,LRIDT,0)) D QUIT
125 .. S ^TMP("LRBAD",LRDFN,LRSS,LRIDT)=PNM_" "_LRIDT
126 . S LRDAT=^LR(LRDFN,LRSS,LRIDT,0)
127 . IF LRSS="CH",'$P(LRDAT,U,3) D QUIT
128 .. S ^TMP("LRUNV",LRDFN,LRSS,LRIDT)=PNM_" "_LRIDT
129 . IF $O(^LR(LRDFN,LRSS,LRIDT,0))=""!('+$O(^(0))) D QUIT
130 .. S ^TMP("LRNOD",LRDFN,LRSS,LRIDT)=PNM_" "_LRIDT
131 ;
132 I $L($P(LRDAT,U,9)) D CHECKX
133 ;
134 QUIT
135 ;
136 ;----------------------------------------------------------------------
137 ;------Here is where we check the major header and force to perm.
138 ;
139CHECKX S LRMH=$P($P(LRDAT,U,9),":") ;Major Header
140 S LRFG=$P($P(LRDAT,U,9),":",2) ;PAGE
141 ;
142 ; Checking all the test for different major header
143 ;
144 ;
145 S TEST=.5
146 F S TEST=$O(^LR(LRDFN,"CH",LRIDT,TEST)) Q:+TEST'>0 D
147 . Q:$D(^TMP("LRT2",TEST))#2
148 . D ^LRAR02
149 ;--------------------------------------------------------------------
150 ;
151 D MOVE
152 Q
153 ;
154TEND ;
155 W @IOF
156 W !!,"The SEARCH process is complete."
157 W !!,$P(LRI/LRJT0*100,".")," Percent of ^LR was searched"
158 D STAMP^LRX
159 W !,"Total patient count: ",LRC2,". Specimen count: ",LRC3,! K LRDFN
160 QUIT
161 ;
162UPDT ;
163 S X=0,LRCNT=0
164 F I=0:0 S X=$O(^LR(LRDFN,LRSS,X)) Q:X<1 S LRCNT=LRCNT+1
165 ;--------------------------------------------CH-----------MICRO NO BB?
166 I LRCNT=0 S ^LR(LRDFN,LRSS,0)=$S(LRSS="CH":"^63.04D",1:"^63.05DA") Q
167 S $P(^LR(LRDFN,LRSS,0),U,4)=LRCNT
168 Q
169RCC ;
170 ;REMOVE CONTROL CHAR.
171 S X=LRDAT
172 S LRDAT=""
173 F I=1:1:$L(X) S LRDAT=LRDAT_$S($A(X,I)>126:"",$A(X,I)>31:$E(X,I),1:"")
174 S ^LR(LRDFN,LRSS,LRIDT,I1)=LRDAT
175 QUIT
Note: See TracBrowser for help on using the repository browser.