source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRORDB.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: 5.9 KB
Line 
1LRORDB ;DALOI/FHS - ORDER LEDI TEST USING BARCODE FROM 69.6 ; 12/3/1997
2 ;;5.2;LAB SERVICE;**153,222,286**;Sep 27, 1994
3 ;
4EN(LRRUID,LRSSMP) ;
5 ;
6 N I,LRSTATUS,LRX
7 ;
8 K LROT
9 ;
10 S (LROT,LRSTATUS)=""
11 ;
12 Q:'$L($G(LRRUID))!('$L($G(LRSSMP)))
13 S LR696=$O(^LRO(69.6,"AD",LRSSMP,LRRUID,0)) Q:'LR696
14 Q:'$D(^LRO(69.6,LR696,0))#2
15 ;
16 S LRX=+$P(^LRO(69.6,LR696,0),U,10)
17 I LRX S LRSTATUS=$$GET1^DIQ(64.061,LRX_",",.01)
18 I LRSTATUS'="",LRSTATUS'="In-Transit" D
19 . S I=0
20 . F S I=$O(^LRO(69.6,LR696,2,I)) Q:'I D Q:LRSTATUS="In-Transit"
21 . . S X=$P(^LRO(69.6,LR696,2,I,0),"^",6) Q:'X
22 . . I $$GET1^DIQ(64.061,X_",",.01)="In-Transit" S LRSTATUS="In-Transit"
23 ;
24 I LRSTATUS'="",LRSTATUS'="In-Transit" D Q
25 . N DIR
26 . S DIR("A",1)="This order has a status of [ "_LRSTATUS_" ]"
27 . S DIR("A",2)="No test selected."
28 . D DISPLO
29 ;
30 ; Display any comments that accompanied order
31 I $D(^LRO(69.6,LR696,99)) D
32 . N LRWP
33 . S LRWP=$$GET1^DIQ(69.6,LR696_",",99,"","LRWP")
34 . S LRWP(.5)="Collecting site order comments:",LRWP(.5,"F")="!!"
35 . D EN^DDIOL(.LRWP)
36 ;
37 D LROT(LR696)
38 ;
39 I $O(LROT(0)) D LL3^LROW3
40 I '$O(LROT(0)) D Q
41 . N DIR
42 . S DIR("A",1)="NO tests found on Shipping Manifest "_$G(LRRSITE("SMID"))
43 . S DIR("A",2)="For UID "_$G(LRRUID)
44 . D DISPLO
45 ;
46 S $P(^LRO(69.6,LR696,0),U,11)=$G(LRSD("RIEN"))
47 Q
48 ;
49 ;
50LROT(LR696) ;
51 ;
52 N LR60,LR6205,LR6964,LRATG,LRMICHK,LRNLT,LRX,LRY,X
53 ;
54 K LROT
55 ;
56 S LR696(0)=$G(^LRO(69.6,LR696,0))
57 S LRSPEC=+$P(LR696(0),U,7),LRSAMP=+$P(LR696(0),U,8)
58 ;Q:'LRSPEC!('$D(^LAB(61,LRSPEC,0)))
59 S (LR6964,LRMICHK)=0
60 F S LR6964=+$O(^LRO(69.6,LR696,2,LR6964)) Q:LR6964<1 D
61 . S LR6964(0)=$G(^LRO(69.6,LR696,2,LR6964,0))
62 . I LR6964(0)="" Q
63 . I $P(LR6964(0),"^",6),$$GET1^DIQ(64.061,$P(LR6964(0),"^",6)_",",.01)'="In-Transit" Q
64 . S LR60=$P(LR6964(0),U,11) ; Lab test to order
65 . S LR6205=$P(LR6964(0),U,12) ; Urgency
66 . I 'LRMICHK,LR60>0,$P(^LAB(60,LR60,0),U,4)="MI" D MICHECK
67 . S LRATG=0
68 . ; If have everything, then don't check accession test group.
69 . I LR60,LRSPEC,LRSAMP,LR6205 D Q:LRATG
70 . . S LR64=+$G(^LAB(60,LR60,64))
71 . . I 'LR64 Q
72 . . S LRNLT=$P($G(^LAM(LR64,0)),U,2),LRNLT(2)=$P($G(^LAM(LR64,0)),U)
73 . . ; Find available spot.
74 . . F LRATG=LRWPC+1:1 I '$D(LROT(LRSAMP,LRSPEC,LRATG)) S LRWPC=LRATG Q
75 . . D CHKURG,SETLROT
76 . S LRNLT=$P(LR6964(0),U,2) Q:'LRNLT
77 . S LRNLT(1)=+$O(^LAM("C",LRNLT_" ",0))
78 . I 'LRNLT(1)!('$D(^LAM(LRNLT(1),0))) Q
79 . S LRNLT(2)=$P(^LAM(LRNLT(1),0),U),LR60=0
80 . F S LR60=+$O(^LAB(60,"AC",LRNLT(1),LR60)) Q:'LR60 D
81 . . S LRATG=+$O(^TMP("LRSTIK",$J,"C",LR60,0)) Q:LRATG<1
82 . . S LRATG(1)=$G(^TMP("LRSTIK",$J,LRATG)) Q:'LRATG(1)!('$P(LRATG(1),U,3))
83 . . S:'$G(LRSAMP) LRSAMP=$P(LRATG(1),U,3)
84 . . D CHKURG
85 . . I LR60,LRSPEC,LRSAMP,LR6205 D SETLROT
86 Q
87 ;
88 ;
89SETLROT ; Setup LROT array
90 ;
91 S LROT(LRSAMP,LRSPEC,LRATG)=LR60
92 S LROT(LRSAMP,LRSPEC,LRATG,1)=LR6205
93 S LROT(LRSAMP,LRSPEC,LRATG,"B",LR60)=LR6964_U_LRNLT_U_LRNLT(2)
94 ;
95 ; Required comment
96 S:$P($G(^LAB(60,LR60,0)),U,19) LROT(LRSAMP,LRSPEC,LRATG,2)=$P(^(0),U,19)
97 ;
98 Q
99 ;
100 ;
101CHKURG ; Check for forced, highest allowed and missing urgency on this test
102 ;
103 N X
104 ;
105 ; Forced urgency
106 I +$P(^LAB(60,LR60,0),U,18) S LR6205=+$P(^LAB(60,LR60,0),U,18)
107 ;
108 ; If missing urgency then look above workload urgencies for last urgency
109 ; that matches on HL7 urgency othewise use site's default for routine.
110 I 'LR6205 D
111 . S X=$P(LR6964(0),U,5)
112 . I $L(X) S LR6205=+$O(^LAB(62.05,"HL7",X,50),-1)
113 . S LR6205=$S(LR6205>0:LR6205,1:LROUTINE)
114 ;
115 ; Highest urgency allowed, reset if higher than highest allowed.
116 S X=+$P(^LAB(60,LR60,0),U,16)
117 I LR6205<X S LR6205=X
118 ;
119 Q
120 ;
121 ;
122MICHECK ; Check "MI" subscript test for missing topography and collection sample
123 ;
124 N DA,DIE,DR,X,Y
125 S DA=LR696,DIE=69.6,DR="",LRMICHK=1
126 I LRSPEC'>0 S DR=4_";"
127 I LRSAMP'>0 S DR=DR_5
128 I LRSPEC D
129 . S LRX=$$GET1^DIQ(61,LRSPEC_",",".09:2")
130 . I LRX="XXX"!(LRX="ORH") S DR="4;5"
131 I DR="" Q
132 D EN^DDIOL("Update missing order information for:",,"!!")
133 D EN^DDIOL("",,"!")
134 D ^DIE
135 S LR696(0)=$G(^LRO(69.6,LR696,0))
136 S LRSPEC=+$P(LR696(0),U,7),LRSAMP=+$P(LR696(0),U,8)
137 ;
138 Q
139 ;
140 ;
141SMID ; Call to get shipping manifest ID (manual selection)
142 N CNT,DA,DIR,LRSMID,LRY,X,Y
143 S LREND=0,LRSMID=""
144 S DIR(0)="69.6,18" D ^DIR
145 I $D(DTOUT)!($D(DUOUT)) S LREND=1 Q
146 I $D(DIRUT) Q
147 S LRY=Y
148 I LRY'="",$D(^LRO(69.6,"D",LRY)) S LRSMID=LRY
149 I LRSMID="" D
150 . D SHOW
151 . K ^TMP("LR",$J,"SMID")
152 ;
153 I LRSMID="" D Q
154 . N DIR
155 . S DIR(0)="YO",DIR("A")="Use manifest '"_LRY_"' anyway",DIR("B")="NO"
156 . W ! D ^DIR
157 . I Y S LRRSITE("SMID")=LRY
158 ;
159 S LRRSITE("SMID")=LRSMID
160 S LRY=$O(^LRO(69.6,"D",LRSMID,0))
161 I LRY S LRRSITE("SDT")=$$GET1^DIQ(69.6,LRY_",",14,"I")
162 K DIR
163 ;
164 ; Flag to determine if this shipping manfiest should be used to
165 ; look up orders when manually accessioning.
166 S DIR(0)="YO",DIR("A")="Lookup orders using this manifest",DIR("B")="YES"
167 D ^DIR
168 I $D(DIRUT) S LREND=1 Q
169 S LRRSITE("SMID-OK")=Y
170 Q
171 ;
172 ;
173SHOW ; Gather a list of possible SMID to select from
174 N CNT,DIR,IEN,LEN,SMID,VAL
175 K ^TMP("LR",$J,"SMID")
176 S SMID=LRY,LEN=$L(LRY),CNT=0
177 I SMID?1.N S SMID=SMID_" "
178 F S SMID=$O(^LRO(69.6,"D",SMID)) Q:$E(SMID,1,LEN)'=LRY D
179 . S IEN=+$O(^LRO(69.6,"D",SMID,0))
180 . I $P($G(^LRO(69.6,IEN,0)),"^",5)'=+$G(LRRSITE("RSITE")) Q
181 . S CNT=CNT+1
182 . S ^TMP("LR",$J,"SMID",CNT)=SMID
183 I 'CNT W !,"No manifest '",LRY,"' found on file." Q
184 I CNT=1 S LRSMID=^TMP("LR",$J,"SMID",CNT) Q
185 ;
186 ; Select SMID from List
187 D DISPL
188 S DIR(0)="NO^1:"_CNT,DIR("A")="Select Manifest Number"
189 D ^DIR
190 I $D(DIRUT) W !,"No manifest selected." Q
191 S LRSMID=$G(^TMP("LR",$J,"SMID",Y))
192 Q
193 ;
194 ;
195DISPL ;
196 N CNT,DIR,DIRUT
197 W @IOF
198 S CNT=0
199 F S CNT=$O(^TMP("LR",$J,"SMID",CNT)) Q:'CNT D Q:$D(DIRUT)
200 . I CNT#3=1 D Q:$D(DIRUT)
201 . . I '(CNT#(IOSL-3)) S DIR(0)="E" D ^DIR Q:$D(DIRUT)
202 . . W !
203 . W $$LJ^XLFSTR(CNT_". "_^TMP("LR",$J,"SMID",CNT),26)
204 Q
205 ;
206 ;
207DISPLO ; Display the order from #69.6
208 N DA,DIC,DIRUT,DTOUT,DUOUT,DX,S,X,Y
209 S DIR("A")="Would you like a display of the Order"
210 S DIR(0)="Y" D ^DIR K DIR
211 I $D(DIROUT)!(Y'=1) W ! Q
212 S DA=LR696,DIC="^LRO(69.6,",S=0 W @IOF D EN^DIQ W !
213 Q
Note: See TracBrowser for help on using the repository browser.