source: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRWRKLST.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: 5.4 KB
Line 
1LRWRKLST ;DALOI/CJS/DRH-LONG ACCESSION LIST ;2/19/91 11:46
2 ;;5.2;LAB SERVICE;**1,17,38,153,185,221,268,362**;Sep 27, 1994;Build 11
3 ;
4 N LRDICS
5 ;
6 ; Save and restore DIC("S") if micro long form accession option (LRMIACC1).
7 I $D(DIC("S")) S LRDICS=DIC("S")
8 D LREND
9 I $D(LRDICS) S DIC("S")=LRDICS
10 ;
11 S LRDT=$$FMTE^XLFDT($$NOW^XLFDT,"5MZ")
12 ;
13 S LREND=0
14 S DIC="^LRO(68,",DIC(0)="AEMOQ"
15 D ^DIC S LRAA=+Y,LRNAME=$P(Y,U,2)
16 I LRAA<1 D LREND Q
17 ;
18 ; Ask if list by date rather than accession number
19 I $P(^LRO(68,LRAA,0),U,3)="Y" D STAR^LRWU3 S LRLAST=$G(LAST)
20 I LREND D LREND Q
21 ; List by acccession number
22 I '$D(LRSTAR) D PHD
23 I LREND D LREND Q
24 ;
25W ;from LRVER, LRVR
26 ;
27 N DIR,DTOUT,DIRUT,DIROUT
28 I '$D(^LRO(68,LRAA,1,LRAD,1,0)),'$D(LRSTAR) D LREND Q
29 ;
30 S (LRUNC,LRTSE)=0
31 S:'$D(LRNAME) LRNAME=$P(^LRO(68,LRAA,0),U,1)
32 ;
33 S DIR(0)="YO",DIR("A")="Do you want a specific test",DIR("B")="NO"
34 D ^DIR
35 I $D(DIRUT) D LREND Q
36 I Y=1 D
37 . N DIC,X,Y
38 . S DIC="^LAB(60,",DIC(0)="AEZOQ"
39 . D ^DIC
40 . I Y>0 S LRTSE=+Y
41 ;
42 K DIR
43 S DIR(0)="YO",DIR("A")="Do you want only incomplete entries",DIR("B")="YES"
44 D ^DIR
45 I $D(DIRUT) D LREND Q
46 S LRUNC=Y
47 ;
48 S %ZIS="Q" D ^%ZIS
49 I POP D ^%ZISC,LREND Q
50 ;
51 ; Queue report via Taskman
52 I $D(IO("Q")) D Q
53 . N ZTDESC,ZTSK,ZTRTN,ZTIO,ZTSAVE,%T
54 . S ZTRTN="ENT^LRWRKLST",ZTDESC="Long form accession list",ZTSAVE("LR*")=""
55 . D ^%ZTLOAD,^%ZISC
56 . W !,"Task ",$S($G(ZTSK):ZTSK,1:"NOT")," Queued"
57 . D LREND K IO("Q")
58 ;
59ENT ;
60 ;
61 N LRTST
62 ;
63 I $D(ZTQUEUED) S ZTREQ="@"
64 S (LREND,LRSTOP)=0
65 ;
66 ;
67 U IO
68 D HED,URG^LRX
69 ;
70 ; Process by accession date
71 I '$D(LRSTAR) D
72 . S LRAN=LRFAN-1
73 . F S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)) Q:'LRAN!(LRAN>LRLAN) D Q:LRSTOP
74 . . S LREND=0 D TD
75 . . I LREND Q
76 . . D LST,TESTS
77 ;
78 ; Process by date received in lab - yearly accession area
79 I $D(LRSTAR) D
80 . F S LRAD=$O(^LRO(68,LRAA,1,LRAD)) Q:LRAD<1!(LRAD>LRWDTL) D AC Q:LRSTOP
81 ;
82 D ^%ZISC,LREND
83 Q
84 ;
85 ;
86TD ; Check tests on accession to determine if meets criteria to display.
87 ; If incomplete only (LRUNC=1) and complete date then skip
88 ; If not specific test selected (LRTSE=file #60 ien) then skip
89 ; Otherwise set LRTST array with file #60 ien.
90 ;
91 K LRTST
92 ;
93 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LREND=1 Q
94 S LRSN=+$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5),LRDAT=+$P(^(0),U,4)
95 S LRI=0
96 F S LRI=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI)) Q:LRI<.5 D
97 . I LRTSE,LRTSE'=+^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0) Q
98 . I LRUNC,$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0),"^",5) Q
99 . S LRTST(LRI)=""
100 ;
101 I '$D(LRTST) S LREND=1
102 Q
103 ;
104 ;
105TESTS ;
106 N S1,S2
107 ;
108 D CHKPAGE^LRWRKLS1
109 Q:LRSTOP!LREND
110 ;
111 Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
112 ;
113 S LRSPEC=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)),LRSAMP=$S(LRSPEC:$P(^(0),U,2),1:"")
114 S S1=$P($G(^LAB(61,+LRSPEC,0)),U,1)
115 S S2=$P($G(^LAB(62,+LRSAMP,0)),U,1)
116 ;
117 W !," SAMPLE: ",S1_$S(S1'=S2:" "_S2,1:"")
118 S LN=LN+1
119 ;
120 S LRLO69=$G(^LRO(69,LRDAT,1,LRSN,0))
121 I $L(LRLO69),$D(^LRO(69,LRDAT,1,LRSN,1)),$L($P(^(1),U,6)) W !,$P(^(1),U,6) S LN=LN+1
122 ;
123 K LRNAC
124 S LRI=0
125 F S LRI=$O(LRTST(LRI)) Q:'LRI D TS2
126 ;
127 I '$D(LRNAC),$L($P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,4)) D
128 . W !,"ALL COMPLETED",!!
129 . S LN=LN+3
130 Q
131 ;
132 ;
133TS2 ;
134 ;
135 D CHKPAGE^LRWRKLS1
136 Q:LRSTOP!LREND
137 ;
138 S LRXXX=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0)),LRURG=+$P(LRXXX,U,2)
139 W !," TEST: ",$P($G(^LAB(60,+LRXXX,0),"deleted test"),"^")
140 S LN=LN+1
141 ;
142 W ?40,$S($D(LRURG(LRURG)):LRURG(LRURG),1:"")
143 W:$L($P(LRXXX,U,3)) ?55," LIST: ",$P($G(^LRO(68.2,+$P(LRXXX,U,3),0)),U,1)," ",$P($P(LRXXX,U,3),";",2,3)
144 ;
145 I $D(^LRO(69,LRDAT,1,LRSN,2,"B",LRI)) D
146 . N I,X
147 . S X=$O(^LRO(69,LRDAT,1,LRSN,2,"B",LRI,0))
148 . I X,$O(^LRO(69,LRDAT,1,LRSN,2,X,1,0)) D
149 . . S I=0
150 . . F S I=$O(^LRO(69,LRDAT,1,LRSN,2,X,1,I)) Q:I<1 W !?3,": "_^(I,0)
151 ;
152 D REF
153 ;
154 I $P(LRXXX,U,5) W !," COMPLETED: ",$$FMTE^XLFDT($P(LRXXX,U,5),"5MZ") S LN=LN+1
155 E S LRNAC=""
156 Q
157 ;
158 ;
159REF ; if referred test, display status and manifest
160 ;
161 N LREVNT,LRUID,LRMAN
162 ;
163 S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") Q:LRUID=""
164 S LRMAN=$P(LRXXX,"^",10)
165 I LRMAN S LRMAN=$P($G(^LAHM(62.8,LRMAN,0)),"^")
166 S LREVNT=$$STATUS^LREVENT(LRUID,+LRXXX,LRMAN)
167 I LREVNT'="" D
168 . W !,?5,"REFERRAL STATUS: "_$P(LREVNT,"^")_" ("_$P(LREVNT,"^",2)_")"
169 . W !,?8,"SHIPPING MANIFEST: "_$P(LREVNT,"^",3)
170 . S LN=LN+2
171 Q
172 ;
173 ;
174PHD ;
175 Q:LREND
176 S LREND=0,U="^"
177 D ADATE^LRWU Q:LREND
178 D LRAN^LRWU3
179 Q
180 ;
181LST ;
182 D HED:($E(IOST)="P"&($Y+11>IOSL)),LST1^LRWRKLS1
183 Q
184 ;
185HED ;
186 W @IOF,!,"LONG FORM",?30,"NOT FOR WARD USE",!
187 W "Accession Area: ",LRNAME,?40,LRDT,!!
188 S LN=4
189 Q
190 ;
191AC ;
192 I LRSTOP!LREND Q
193 ;
194 S LRTK=LRSTAR-.00001
195 F S LRTK=$O(^LRO(68,LRAA,1,LRAD,1,"E",LRTK)) Q:LRTK<1!(LRTK\1>LRLAST) D Q:LRSTOP
196 . S LRAN=0
197 . F S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,"E",LRTK,LRAN)) Q:LRAN<1!(LRSTOP) D
198 . . I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) Q
199 . . S LREND=0 D TD
200 . . I LREND Q
201 . . D LST,TESTS
202 Q
203 ;
204 ;
205LREND ;
206 D KVAR^VADPT
207 K %,%DT,%ZIS
208 K LN,LRA,AGE,DFN,DIC,DIR,DIRUT,DOB,DTOUT,DUOUT,K,LAST
209 K LRACC,LRDLA,LRDLC,LRDX,LRI,LRLO69,LRSAMP,LRSPEC
210 K LRURG,LRWRD,LRACO,DIC,LRUNC,LRDAT,LRAA,LRAD
211 K LRNAC,LRAN,LRCE,LRDPF,LRSN,LRDTO,LRLAST,LRPRAC,LRSTAR,LRXXX
212 K LRB,LRLAN,LRDT,LREND,LRFAN,LRIX,LRNAME,LRTSE,LRTST
213 K LRDFN,LREDT,LRLLOC,LRSDT,LRTK,LRWDTL,POP,LRSTOP
214 K PNM,SEX,SSN,X,X1,X2,Y,Z,ZTSK
215 Q
216 ;
217EN ;
218SINGLE ;
219 ;
220 N LRACC,LREND,LRSTOP,LRTSE,LRUNC,LRURG
221 ;
222 D URG^LRX
223 ;
224 F D Q:LREND!LRSTOP
225 . S (LREND,LRUNC,LRSTOP,LRTSE)=0
226 . S LRACC="" D ^LRWU4
227 . I LRAN<1 S LREND=1 Q
228 . I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"Doesn't exist." Q
229 . D TD,LST1^LRWRKLS1,TESTS
230 . W !
231 ;
232 D LREND
233 Q
Note: See TracBrowser for help on using the repository browser.