source: FOIAVistA/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VHLU4.m@ 1540

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

initial load of FOIAVistA 6/30/08 version
File size: 6.1 KB
Line 
1LA7VHLU4 ;DALOI/JMC - HL7 segment builder utility ; 11-25-1998
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64**;Sep 27, 1994
3 ;
4 ; Reference to ^XMB global supported by DBIA #10091
5 ;
6INST(LA74,LA7FS,LA7ECH) ; Build institution field
7 ; Call with LA74 = ien of institution in file #4
8 ; if null/undefined then use Kernel Site file.
9 ; LA7FS = HL field separator
10 ; LA7ECH = HL encoding characters
11 ;
12 ; Returns facility that performed the testing (ID^text^99VA4)
13 ;
14 N LA7NVAF,LA7X,LA7Y,LA7Z
15 ;
16 S LA74=$G(LA74),LA7ECH=$G(LA7ECH),LA7Y=""
17 ;
18 ; If no institution, use Kernel Site default
19 I LA74="" S LA74=+$P($G(^XMB(1,1,"XUS")),U,17)
20 ;
21 ; Value passed not a pointer - only build 2nd component
22 I LA74'="",LA74'=+LA74 D
23 . S $P(LA7Y,$E(LA7ECH,1),2)=$$CHKDATA^LA7VHLU3(LA74,LA7FS_LA7ECH)
24 ;
25 I LA74>0,LA74=+LA74 D
26 . S LA7NVAF=$$NVAF^LA7VHLU2(LA74)
27 . ; Build id - VA station #/DMIS code
28 . I LA7NVAF<2 S LA7Y=$$ID^XUAF4($S(LA7NVAF=1:"DMIS",1:"VASTANUM"),LA74)
29 . ; Build name using field #100, otherwise #.01
30 . S LA7Z=$$NAME^XUAF4(LA74)
31 . S $P(LA7Y,$E(LA7ECH,1),2)=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
32 . ;
33 . S $P(LA7Y,$E(LA7ECH,1),3)="99VA4"
34 ;
35 Q LA7Y
36 ;
37XCN(LA7DUZ,LA7DIV,LA7FS,LA7ECH) ; Build composite ID and name for person
38 ; Call with LA7DUZ = DUZ of person
39 ; If not pointer to #200, then use as literal
40 ; LA7DIV = Institution of user
41 ; LA7FS = HL field separator
42 ; LA7ECH = HL encoding characters
43 ;
44 ;
45 N LA7SITE,LA7VAF,LA7X,LA7Y,LA7Z,NAME
46 ;
47 S LA7Z=""
48 ;
49 ; Build from file #200
50 I LA7DUZ>0,LA7DUZ?1.N D
51 . S NAME("FILE")=200,NAME("FIELD")=.01,NAME("IENS")=LA7DUZ
52 . S LA7Z=$$HLNAME^XLFNAME(.NAME,"S",$E(LA7ECH))
53 . ; Commented out following lines, trying standardized name API above
54 . ;S LA7X=$$GET1^DIQ(200,LA7DUZ_",",.01)
55 . ;S LA7X=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)
56 . ;S LA7Z=$$HLNAME^HLFNC(LA7X,LA7ECH)
57 . ; If no institution, use Kernel Site default
58 . I LA7DIV="" S LA7DIV=+$P($G(^XMB(1,1,"XUS")),U,17)
59 . S LA7SITE=$$RETFACID^LA7VHLU2(LA7DIV,0,1)
60 . I $L(LA7SITE) D
61 . . S LA7VAF=$$GET1^DIQ(4,LA7DIV_",","AGENCY CODE","I")
62 . . I LA7VAF="V" S LA7SITE="VA"_LA7SITE
63 . . S LA7DUZ=LA7DUZ_"-"_LA7SITE
64 . S $P(LA7Y,$E(LA7ECH))=LA7DUZ
65 ;
66 ; If only name passed
67 I 'LA7DUZ D
68 . S LA7DUZ=$$CHKDATA^LA7VHLU3(LA7DUZ,LA7FS_LA7ECH)
69 . S LA7Z=$$HLNAME^HLFNC(LA7DUZ,LA7ECH)
70 ;
71 S $P(LA7Y,$E(LA7ECH),2,7)=LA7Z
72 ;
73 Q LA7Y
74 ;
75 ;
76XAD(LA7FN,LA7DA,LA7DT,LA7FS,LA7ECH) ; Build extended address
77 ; Call with LA7FN = Source File number
78 ; Presently file #2 (PATIENT), #4 (INSTITUTION) or #200 (NEW PERSON)
79 ; LA7DA = Entry in source file
80 ; LA7DT = As of date in FileMan format
81 ; LA7FS = HL field separator
82 ; LA7ECH = HL encoding characters
83 ;
84 ; Returns extended address
85 ;
86 N LA7X,LA7Y,LA7Z
87 ;
88 S LA7Y=""
89 ;
90 ; Build from file #2
91 I LA7FN=2,LA7DA D
92 . N DFN,VAHOW,VAPA,VAERR,VAROOT,VATEST
93 . S DFN=LA7DA
94 . I LA7DT S (VATEST("ADD",9),VATEST("ADD",10))=LA7DT
95 . D ADD^VADPT
96 . I VAERR Q
97 . S $P(LA7Y,$E(LA7ECH),1)=$$CHKDATA^LA7VHLU3(VAPA(1),LA7FS_LA7ECH)
98 . S $P(LA7Y,$E(LA7ECH),2)=$$CHKDATA^LA7VHLU3(VAPA(2),LA7FS_LA7ECH)
99 . S $P(LA7Y,$E(LA7ECH),3)=$$CHKDATA^LA7VHLU3(VAPA(4),LA7FS_LA7ECH)
100 . S $P(LA7Y,$E(LA7ECH),4)=$$CHKDATA^LA7VHLU3($P(VAPA(5),"^",2),LA7FS_LA7ECH)
101 . S $P(LA7Y,$E(LA7ECH),5)=$$CHKDATA^LA7VHLU3(VAPA(11),LA7FS_LA7ECH)
102 . I VAPA(9) S $P(LA7Y,$E(LA7ECH),7)="C"
103 . E S $P(LA7Y,$E(LA7ECH),7)="P"
104 . S $P(LA7Y,$E(LA7ECH),9)=$$CHKDATA^LA7VHLU3($P(VAPA(7),"^",2),LA7FS_LA7ECH)
105 ;
106 I LA7FN=4,LA7DA D
107 . Q
108 ;
109 I LA7FN=200,LA7DA D
110 . Q
111 ;
112 Q LA7Y
113 ;
114 ;
115XON(LA7FN,LA7DA,LA7FS,LA7ECH) ; Build extended composite name/id for organization
116 ; Call with LA7FN = Source File number
117 ; Presently #4 (INSTITUTION)
118 ; LA7DA = Entry in source file
119 ; LA7FS = HL field separator
120 ; LA7ECH = HL encoding characters
121 ;
122 ;
123 N LA7X,LA7Y,LA7Z
124 ;
125 S LA7Y=""
126 ;
127 I LA7FN=4,LA7DA D
128 . Q
129 ;
130 Q LA7Y
131 ;
132 ;
133XTN(LA7FN,LA7DA,LA7FS,LA7ECH) ; Build extended telecommunication number
134 ; Call with LA7FN = Source File number
135 ; Presently #4 (INSTITUTION)
136 ; LA7DA = Entry in source file
137 ; LA7FS = HL field separator
138 ; LA7ECH = HL encoding characters
139 ;
140 ;
141 N LA7X,LA7Y,LA7Z
142 ;
143 S LA7Y=""
144 ;
145 I LA7FN=4,LA7DA D
146 . Q
147 ;
148 Q LA7Y
149 ;
150 ;
151XCNTFM(LA7X,LA7ECH) ; Resolve XCN data type to FileMan (last name, first name, mi [id])
152 ; Call with LA7X = HL7 field containing name
153 ; LA7ECH = HL7 encoding characters
154 ;
155 ; Returns LA7Y = ID code^DUZ^FileMan name (DUZ=0 if name not found on local system).
156 ;
157 N LA7DUZ,LA7IDC,LA7Y,LA7Z,X
158 ;
159 ; Check for coding that indicates DUZ from a VA facility
160 S LA7DUZ=0
161 S (LA7IDC,LA7Z)=$P(LA7X,$E(LA7ECH))
162 I LA7Z?.(1.N1"-VA"3N,1.N1"-VA"3N2U) D
163 . N LA7J,LA7K
164 . S LA7Z(1)=$P(LA7Z,"-"),LA7Z(2)=$P(LA7Z,"-",2)
165 . S LA7K=$$FINDSITE^LA7VHLU2(LA7Z(2),1,1)
166 . S LA7J=$$DIV4^XUSER(.LA7J,LA7Z(1))
167 . I LA7K,$D(LA7J(LA7K)) S LA7DUZ=LA7Z(1)
168 ;
169 ; Check if code resolves to a valid user.
170 I 'LA7DUZ,LA7Z=+LA7Z D
171 . S X=$$ACTIVE^XUSER(LA7Z)
172 . I X,$P(X,"^",2)'="" S LA7DUZ=LA7Z
173 ;
174 S LA7Y=$$FMNAME^HLFNC($P(LA7X,$E(LA7ECH),2,6),LA7ECH)
175 ; HL function sometimes returns trailing "," on name
176 S LA7Y=$$TRIM^XLFSTR(LA7Y,"R",",")
177 ;
178 ; Put identifying code at end of name in "[]".
179 I $P(LA7X,$E(LA7ECH))'="",LA7Y'="" S LA7Y=LA7Y_" ["_$P(LA7X,$E(LA7ECH))_"]"
180 ;
181 Q LA7IDC_"^"_LA7DUZ_"^"_LA7Y
182 ;
183 ;
184PLTFM(LA7PL,LA7ECH) ; Resolve location from PL (person location) data type.
185 ; Call with LA7PL = HL7 field containing person location
186 ; LA7ECH = HL7 encoding characters
187 ;
188 ; Returns LA7Y = file #44 ien^name field (#.01)^division(institution)
189 ;
190 N LA7X,LA7Y,X,Y
191 S LA7X=$P(LA7PL,$E(LA7ECH)),(LA7Y,Y)=""
192 I LA7X?1.N S Y=$$GET1^DIQ(44,LA7X_",",.01)
193 ; If not ien try as name
194 I Y="" D
195 . S X=$$FIND1^DIC(44,"","X",LA7X,"B")
196 . I X S Y=LA7X,LA7X=X
197 I Y'="" S LA7Y=LA7X_"^"_Y
198 E I $P(LA7PL,$E(LA7ECH),2)'="" S LA7Y="^"_$P(LA7PL,$E(LA7ECH),2)
199 ;
200 ; Process division (institution)
201 S LA7X=$P(LA7PL,$E(LA7ECH),4),Y=""
202 I LA7X'="" S Y=$$FINDSITE^LA7VHLU2(LA7X,1,1)
203 S $P(LA7Y,"^",3)=Y
204 ;
205 Q LA7Y
Note: See TracBrowser for help on using the repository browser.