source: FOIAVistA/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7PCFG.m@ 1484

Last change on this file since 1484 was 628, checked in by George Lilly, 16 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1LA7PCFG ;DALOI/JMC - Configrure Lab Point of Care Interface; Jan 12, 2004
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**67**;Sep 27, 1994
3 ;
4 ; Reference to DIV4^XUSER supported by DBIA #2533
5 Q
6 ;
7EN ; Configure files #62.48, #62.4 and #68.2
8 N DIR,DIROUT,DIRUT,DUOUT,LA7QUIT,LRLL,X,Y
9 S LRLL=0
10 F D Q:$D(DIRUT)
11 . S DIR(0)="SO^1:LA7 MESSAGE PARAMETER (#62.48);2:LOAD/WORK LIST (#68.2);3:AUTO INSTRUMENT (#62.4);4:Print POC Test Code Mapping"
12 . S DIR("A")="Select which file to setup"
13 . D ^DIR
14 . I $D(DIRUT) Q
15 . I Y=1 D E6248 Q
16 . I Y=2 D E682 Q
17 . I Y=3 D E624 Q
18 . I Y=4 D PRINT Q
19 Q
20 ;
21 ;
22E6248 ; Setup/edit file #62.48
23 ;
24 N DA,DIC,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,LA76248,LA7TYP,X,Y
25 D EN^DDIOL("","","!!")
26 S DIC="^LAHM(62.48,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,9)=20!($P(^(0),U,9)=21)"
27 D ^DIC
28 I Y<1 Q
29 S (DA,LA76248)=+Y
30 L +^LAHM(62.48,LA76248):0
31 I '$T D EN^DDIOL("Another user is editing this entry.","","!?5") Q
32 D EN^DDIOL("","","!!")
33 S DIR(0)="YO"
34 S DIR("A")="Does this POC interface want to receive VistA ADT messages"
35 S DIR("B")=$S($P($G(^LAHM(62.48,LA76248,0)),"^",9)=21:"YES",1:"NO")
36 D ^DIR
37 I $D(DIRUT) Q
38 S LA7TYP=$S(Y=1:21,1:20)
39 I LA7TYP=21 D
40 . D EN^DDIOL("Remember to add the LA7POC ADT RTR event protocol to the appropriate","","!!")
41 . D EN^DDIOL("ADT event protocols as specified in the Lab POC User Guide","","!")
42 . D EN^DDIOL("","","!!")
43 S DIE=DIC,DR="11///"_LA7TYP_";2;3;4///ON;20"
44 D ^DIE
45 L -^LAHM(62.48,LA76248)
46 Q
47 ;
48 ;
49E624 ; Setup/edit file #62.4
50 ;
51 N DA,DIC,DIE,DR,LA7624,LA76248,LA7ERR,LRNLT,LRX,LRY,X,Y
52 ;
53 D EN^DDIOL("","","!")
54 S DIC="^LAB(62.4,",DIC(0)="AEMQ",DIC("S")="I $E($P(^(0),U),1,6)=""LA7POC"""
55 D ^DIC
56 I Y<1 Q
57 S (DA,LA7624)=+Y
58 L +^LAB(62.4,LA7624):0
59 I '$T D EN^DDIOL("Another user is editing this entry.","","!?5") Q
60 S DIE=DIC
61 S DR="3"_$S(LRLL>0:"//"_$$GET1^DIQ(68.2,LRLL_",",.01),1:"")_";8;10;11;12////0;18;30;107"
62 S DR(2,62.41)=".01;S LRNLT=$$GET1^DIQ(64,+$P($G(^LAB(60,X,64)),U,2)_"","",1);2;6////^S X=LRNLT;8R;12;13;14;17;18;19;21//YES"
63 D ^DIE
64 ;
65 ; Check if loadlist type = POC
66 I $P(^LAB(62.4,LA7624,0),"^",4) D
67 . S LRLL=$P(^LAB(62.4,LA7624,0),"^",4)
68 . I $P(^LRO(68.2,LRLL,0),"^",3)'=2 D EN^DDIOL("**WARNING-Associated Load/Work List "_$$GET1^DIQ(68.2,LRLL_",",.01)_" is not TYPE: POINT OF CARE**","","!?2")
69 ;
70 ; Check if 62.4 name matches 62.48 name
71 I $P(^LAB(62.4,LA7624,0),"^",8) D
72 . S LRX=$$GET1^DIQ(62.48,$P(^LAB(62.4,LA7624,0),"^",8)_",",.01)
73 . S LRY=$$GET1^DIQ(62.4,LA7624_",",.01)
74 . I LRX'=LRY D EN^DDIOL("**WARNING-Name of entry in AUTO INSTRUMENT file should match name of MESSAGE CONFIGURATION**","","!?2")
75 ;
76 L -^LAB(62.4,LA7624)
77 Q
78 ;
79 ;
80E682 ; Setup/edit file #68.2
81 N DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DUOUT,I
82 N LA7ERR,LR60,LR61,LRAA,LRDIV,LRMSG,LRPROF,LRX,LRY,X,Y
83 ;
84 D EN^DDIOL("","","!")
85 S DIC="^LRO(68.2,",DIC(0)="AELMQ"
86 I LRLL>0 S DIC("B")=$$GET1^DIQ(68.2,LRLL_",",.01)
87 D ^DIC
88 I Y<1 Q
89 S (DA,LRLL)=+Y
90 L +^LRO(68.2,LRLL):0
91 I '$T D EN^DDIOL("Another user is editing this entry.","","!?5") Q
92 S DIE=DIC
93 S DR=".01;.02///UNIVERSAL;.03///2;.08///ACCESSION;.14;1;1.5;1.7;50"
94 S DR(2,68.23)=".01;2;2.2;1"
95 S DR(3,68.24)=".01;I ""IB""'[$P(^LAB(60,X,0),""^"",3) S Y=2;1R;3;4;2///NO"
96 D ^DIE
97 L -^LRO(68.2,LRLL)
98 W !
99 ;
100 S LRPROF=$O(^LRO(68.2,LRLL,10,0))
101 I LRPROF<1 D Q
102 . D EN^DDIOL($C(7)_"*** Need at least one profile for POC interface ***","","!!")
103 ;
104 I $O(^LRO(68.2,LRLL,10,LRPROF)) D Q
105 . D EN^DDIOL($C(7)_"*** Only one profile should exist for POC interface ***","","!!")
106 ;
107 S LRAA=$P($G(^LRO(68.2,LRLL,10,LRPROF,0)),U,2)
108 I 'LRAA Q
109 ;
110 ; Check tests on profile for specimen/collection sample
111 S I=0
112 F S I=$O(^LRO(68.2,LRLL,10,LRPROF,1,I)) Q:'I D
113 . S LRX=$G(^LRO(68.2,LRLL,10,LRPROF,1,I,0))
114 . S LR60=$P(LRX,"^"),LR61=$P(LRX,"^",2)
115 . S LR60(0)=^LAB(60,LR60,0)
116 . I "IB"[$P(LR60(0),"^",3) D
117 . . I 'LR61 D Q
118 . . . S LRMSG(I)=$P(LR60(0),"^")_" missing specimen"
119 . . I '$P(LRX,"^",5) D
120 . . . S LRMSG(I)=$P(LR60(0),"^")_" missing collection sample for specimen "_$P(^LAB(61,LR61,0),"^")
121 I $D(LRMSG) D EN^DDIOL(.LRMSG,"","")
122 ;
123 D EN^DDIOL("Now edit the associated division for accession area "_$$GET1^DIQ(68,LRAA_",",.01)_".","","!!")
124 S DA=LRAA,DIE="^LRO(68,",DR=".091"
125 D ^DIE
126 ;
127 S LRDIV=$O(^LRO(68,LRAA,3,0))
128 I 'LRDIV D Q
129 . D EN^DDIOL("*** A division needs to be associated with this POC accession area ***","","!!")
130 ;
131 I $O(^LRO(68,LRAA,3,LRDIV)) D
132 . D EN^DDIOL($C(7)_"*** Lab POC software will use "_$P($$NS^XUAF4(LRDIV),"^"),"","!!")
133 . D EN^DDIOL("as the default division with this accession area ***","","!?4")
134 ;
135 S LRX=$$FIND1^DIC(200,"","OX","LRLAB,POC","B","")
136 I LRX<1 D EN^DDIOL($C(7)_"*** Unable to identify user 'LRLAB,POC' in NEW PERSON file ***","","!!")
137 I LRX>0 D
138 . K LRY
139 . S LRY=$$DIV4^XUSER(.LRY,LRX)
140 . I $D(LRY(LRDIV)) Q
141 . D EN^DDIOL($C(7)_"*** Have IRM assign division "_$P($$NS^XUAF4(LRDIV),"^")_" to user 'LRLAB,POC' ***","","!!")
142 Q
143 ;
144 ;
145PRINT ; Print test code mappings for POC setup
146 N %ZIS,DIC,LA7624,ZTDTH,ZTSK,ZTRTN,ZTIO,ZTSAVE,X,Y
147 ;
148 D EN^DDIOL("","","!")
149 S DIC="^LAB(62.4,",DIC(0)="AEMQ",DIC("S")="I $E($P(^(0),U),1,6)=""LA7POC"""
150 D ^DIC
151 I Y<1 Q
152 S LA7624=+Y
153 ;
154 S %ZIS="MQ" D ^%ZIS
155 I POP D HOME^%ZIS Q
156 I $D(IO("Q")) D Q
157 . S ZTRTN="DQP^LA7PCFG",ZTSAVE("LA7624")="",ZTDESC="Print POC Setup"
158 . D ^%ZTLOAD,^%ZISC
159 . D EN^DDIOL("Request "_$S($G(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued"),"","!")
160 ;
161DQP ; entry point from above and TaskMan
162 ;
163 N I,X,Y
164 N LA7EXIT,LA7INTYP,LA7LINE,LA7LINE2,LA7NOW,LA7PAGE,LA7CODE
165 N LA76248,LR60,LR61,LR62,LR64,LR642,LRLL,LRPROF
166 S LA7NOW=$$HTE^XLFDT($H,"1D"),(LA7EXIT,LA7PAGE)=0
167 S LA7624(0)=$G(^LAB(62.4,LA7624,0))
168 S LA76248=$P(LA7624(0),"^",8)
169 S LA7INTYP=$P(^LAHM(62.48,LA76248,0),"^",9)
170 S LRLL=$P(LA7624(0),"^",4)
171 S LRPROF=$O(^LRO(68.2,LRLL,10,0))
172 S LA7LINE=$$REPEAT^XLFSTR("=",IOM)
173 S LA7LINE2=$$REPEAT^XLFSTR("-",IOM)
174 D HDR
175 W !!,"VistA ADT feed enabled: ",$S(LA7INTYP=21:"YES",LA7INTYP=20:"NO",1:"UNKNOWN"),!!
176 D SH1
177 ;
178 S I=0
179 F S I=$O(^LRO(68.2,LRLL,10,LRPROF,1,I)) Q:'I D Q:LA7EXIT
180 . I ($Y+6)>IOSL D HDR Q:LA7EXIT D SH1 Q:LA7EXIT
181 . S X=^LRO(68.2,LRLL,10,LRPROF,1,I,0)
182 . S LR60=+X,LR64=+$G(^LAB(60,LR60,64)),LR64(0)=$G(^LAM(LR64,0))
183 . S LR61=$P(X,"^",2),LR642=$P(X,"^",4),LR62=0
184 . I LR61 S LR62=$P(X,"^",5)
185 . I 'LR62,LR61 S LR62=$$GET1^DIQ(61,LR61_",",4.1,"I")
186 . W !,$J(I,2),?3,$E($P(^LAB(60,LR60,0),"^"),1,25)
187 . S X=$P(LR64(0),"^",2)
188 . W ?30,$S(X'="":X,1:"<Missing>")
189 . I LR61 D
190 . . S X="("_LR61_")"
191 . . S X=$E($P(^LAB(61,LR61,0),"^"),1,19-$L(X))_X
192 . E S X="<Missing>"
193 . W ?50,X
194 . S X=$S(LR61:$E($$GET1^DIQ(61,LR61_",","LEDI HL7:HL7 ABBR"),1,14),1:" ")
195 . W ?70,$S(X'="":X,1:"<Missing>")
196 . W !,?30,$P(LR64(0),"^")
197 . W ?50,$S(LR62:$P(^LAB(62,LR62,0),"^"),'LR61:"",1:"<Missing>")
198 . S X=$S(LR642:$P($G(^LAB(64.2,LR642,0)),"^",2),1:"")
199 . W ?70,$S(X'="":X,1:"No Mapping"),!
200 . I LR64<1 W ?3,"Warning - test does not have NATIONAL VA LAB CODE assigned.",!
201 ;
202 I LA7EXIT D CLEAN Q
203 I ($Y+6)>IOSL D HDR
204 I LA7EXIT D CLEAN Q
205 D SH2
206 S I=0
207 F S I=$O(^LAB(62.4,LA7624,3,I)) Q:'I D Q:LA7EXIT
208 . I ($Y+6)>IOSL D HDR Q:LA7EXIT D SH2 Q:LA7EXIT
209 . S X=^LAB(62.4,LA7624,3,I,0),X(2)=$G(^LAB(62.4,LA7624,3,I,2))
210 . S LR60=+X,LR61=$P(X(2),"^",13)
211 . W !,$J(I,2),?3,$E($P(^LAB(60,LR60,0),"^"),1,25)
212 . S LA7CODE=$P(X,"^",6)
213 . W ?30,$S(LA7CODE'="":LA7CODE,1:"<Missing>")
214 . I LR61 S X=$P(^LAB(61,LR61,0),"^")_"("_LR61_")"
215 . E S X="<Missing>"
216 . W ?55,X
217 . S X="("_$P($$GET1^DIQ(60,LR60_",",5),";",2)_")"
218 . W !,?3,$E($$GET1^DIQ(60,LR60_",",400),1,25-$L(X))_X
219 . I LA7CODE?5N1"."4N D
220 . . S Y=$O(^LAM("C",LA7CODE_" ",0))
221 . . I Y W ?30,$E($P(^LAM(Y,0),"^"),1,20)
222 . S X=$S(LR61:$E($$GET1^DIQ(61,LR61_",","LEDI HL7:HL7 ABBR"),1,14),1:" ")
223 . W ?55,$S(X'="":X,1:"<Missing>"),!
224 . S LR64=+$P($G(^LAB(60,LR60,64)),"^",2),LR64(0)=$G(^LAM(LR64,0))
225 . I LR64<1 W ?3,"Warning - test does not have RESULT NLT CODE assigned.",!
226 . I LR64>0,$P(LR64(0),"^",2)'=LA7CODE W ?3,"Warning - RESULT NLT CODE does not match UI TEST CODE."
227 ;
228 I '$D(ZTQUEUED),'LA7EXIT,$E(IOST,1,2)="C-" D TERM
229 D CLEAN
230 Q
231 ;
232 ;
233CLEAN ; Clean up and quit
234 I $E(IOST,1,2)'="C-" W @IOF
235 I '$D(ZTQUEUED) D ^%ZISC
236 E S ZTREQ="@"
237 Q
238 ;
239 ;
240HDR ; Header for test code mapping
241 I '$D(ZTQUEUED),LA7PAGE,$E(IOST,1,2)="C-" D TERM Q:$G(LA7EXIT)
242 W @IOF S $X=0
243 S LA7PAGE=LA7PAGE+1
244 W !,"Point of Care Test Code Mapping",?IOM-20," Page: ",LA7PAGE
245 W !," for interface: ",$P(LA7624(0),"^"),?IOM-23," Printed: ",LA7NOW
246 W !,LA7LINE,!
247 Q
248 ;
249 ;
250SH1 ; Sub header #1
251 W !,"POC Order Test Codes using Load/Work List: ",$P(^LRO(68.2,LRLL,0),"^")
252 W !,"# Lab Test",?30,"Order NLT Code",?50,"Specimen(IEN)",?70,"HL7 Spec"
253 W !,?30,"Order NLT Name",?50,"Collection Sample",?70,"WKLD Code"
254 W !,LA7LINE2,!
255 Q
256 ;
257 ;
258SH2 ; Sub head #2
259 W !,"POC Result Test Codes using Auto Instrument: ",$P(LA7624(0),"^")
260 W !,"# Lab Test",?30,"Result NLT Code",?55,"Specimen(IEN)"
261 W !," Dataname(IEN)",?30,"Result NLT Name",?55,"HL7 Spec"
262 W !,LA7LINE2,!
263 Q
264 ;
265 ;
266TERM ;
267 N DIR,DIRUT,DTOUT,DUOUT,X,Y
268 S DIR(0)="E" D ^DIR S:$D(DIRUT) LA7EXIT=1
269 Q
Note: See TracBrowser for help on using the repository browser.