source: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLFNC.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 7.7 KB
Line 
1HLFNC ;AISC/SAW/OAK-OIFO/RBN-Routine of Functions and Other Calls Used for HL7 Messages ;03/26/2008 11:34
2 ;;1.6;HEALTH LEVEL SEVEN;**38,42,51,66,141**;Oct 13, 1995;Build 11
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5HLNAME(X,HLECDE) ;Convert a name in DHCP format to HL7 format
6 ; INPUT: X - Name in DHCP format
7 ; Optional - HLECDE - HL7 encoding chars
8 ;**** NOTE: ****
9 ;If this function is called without HLECDE as parameter than HLECH
10 ;must be define.
11 ;
12 Q:'$D(X) "" Q:X="" ""
13 I '$D(HLECH),'$D(HLECDE) Q ""
14 I $D(HLECDE) N HLECH S HLECH=HLECDE
15 I '$D(HLECH) Q ""
16 N %,X1,X2,Y
17 S X1=$P(X,",",2),X2=$L(X1," "),Y=$P(X,",")_$E(HLECH)_$P(X1," ") I X2 F %=2:1:X2 Q:$P(X1," ",%)']"" S Y=Y_$E(HLECH)_$P(X1," ",%)
18 Q Y
19 ;
20FMNAME(X,HLECDE) ;Convert a name in HL7 format to DHCP format
21 ; INPUT: X - Name in HL7 format
22 ; Optional - HLECDE - HL7 encoding chars
23 ;**** NOTE: ****
24 ;If this function is called without HLECDE as parameter than HLECH
25 ;must be define.
26 ;
27 Q:'$D(X) "" Q:X="" ""
28 I '$D(HLECH),'$D(HLECDE) Q ""
29 I $D(HLECDE) N HLECH S HLECH=HLECDE
30 I '$D(HLECH) Q ""
31 N %,X1 S X1=$L(X,$E(HLECH)),Y="" F %=1:1:X1 D
32 .I $P(X,$E(HLECH),%)]"",$P(X,$E(HLECH),%)'="""""" D
33 ..;Only last name,first name.
34 ..I %<3 S Y=Y_$P(X,$E(HLECH),%)_$S(%=1:",",1:"") Q
35 ..S Y=Y_" "_$P(X,$E(HLECH),%)
36 Q Y
37 ;
38HLDATE(X,Y) ;Convert date, date/time or time only in FM format to HL7 format
39 ;Optional Variables:
40 ;Y = The type of format to be returned if you want to force return of a
41 ; specific format. Y must be equal to one of the following:
42 ; DT - Date only
43 ; TM - Time only
44 ; TS - Date and time
45 I X="" Q ""
46 S Y=$G(Y)
47 N %,Z
48 I $L(X)<7 D Q % ;Time input
49 . S %=$S(X=2400:"0000",$L(X)<4:$E(X_"000",1,4),1:X) S:$L(%)=5 %=%_0
50 . Q
51 I Y="TM" D Q % ;Only time
52 . S %=$P(X,".",2),%=$S(%="":"",$E(%,1,2)=24:"0000",$L(%)<4:$E(%_"000",1,4),1:%) S:$L(%)=5 %=%_0
53 . Q
54 S %=$$FMTHL7^XLFDT(X)
55 Q $S(Y="DT":$E(%,1,8),1:%)
56 ;
57FMDATE(X) ; Convert a date, date/time or time only in HL7 format to FM format
58 I X="" Q ""
59 N %
60 S %=$P($TR(X,"+-","^"),"^")
61 I $L(X)<7 Q %
62 Q $$HL7TFM^XLFDT(X)
63 ;
64M10(X,HLECDE) ; M10 check digit scheme
65 ; INPUT : X - ID number
66 ; Optional HLECDE - Encoding chars
67 ;**** NOTE: ****
68 ;If this function is called without HLECDE as parameter then HLECH
69 ;must be defined.
70 ;Return X if encoding character is not defined
71 ;Return X with encoding characters concatenated if X is alphanumeric
72 ;
73 N HLCNT,HLODD,HLEVEN,HLX1,HLDIGIT
74 Q:'$D(X) ""
75 I $D(HLECDE) N HLECH S HLECH=HLECDE
76 ;Return X if encoding character is not defined
77 I '$D(HLECH) Q X
78 ;Return X with encoding characters concatenated if X is alphanumeric
79 I '(X?1.N) Q X_$E(HLECH)_$E(HLECH)
80 ;
81 S HLX1=+X
82 S HLODD=""
83 F HLCNT=$L(HLX1):-2:1 S HLODD=HLODD_$E(HLX1,HLCNT)
84 S HLODD=HLODD*2
85 S HLEVEN=""
86 F HLCNT=($L(HLX1)-1):-2:1 S HLEVEN=HLEVEN_$E(HLX1,HLCNT)
87 S HLX1=HLEVEN_HLODD
88 S HLDIGIT=0
89 F HLCNT=1:1:$L(HLX1) S HLDIGIT=HLDIGIT+$E(HLX1,HLCNT)
90 S HLDIGIT=((HLDIGIT\10+1)*10-HLDIGIT)#10
91 Q X_$E(HLECH)_HLDIGIT_$E(HLECH)_"M10"
92 ;
93M11(X,HLECDE) ; M11 check digit scheme
94 ; INPUT : X - ID number
95 ; Optional HLECDE - Encoding chars
96 ;**** NOTE: ****
97 ;If this function is called without HLECDE as parameter then HLECH
98 ;must be defined.
99 ;Return X if encoding character is not defined
100 ;Return X with encoding characters concatenated if X is alphanumeric
101 ;
102 N HLX1,HLCNT,HLWT,HLDIGIT
103 Q:'$D(X) ""
104 I $D(HLECDE) N HLECH S HLECH=HLECDE
105 ;Return X if encoding character is not defined
106 I '$D(HLECH) Q X
107 ;Return X with encoding characters concatenated if X is alphanumeric
108 I '(X?1N.N) Q X_$E(HLECH)_$E(HLECH)
109 ;
110 S HLX1=+X
111 S HLDIGIT=0,HLWT=2
112 F HLCNT=$L(HLX1):-1:1 D
113 . I HLWT>7 S HLWT=2
114 . S HLDIGIT=HLDIGIT+($E(HLX1,HLCNT)*HLWT)
115 . S HLWT=HLWT+1
116 S HLDIGIT=HLDIGIT#11
117 I HLDIGIT=0 S HLDIGIT=1
118 S HLDIGIT=(11-HLDIGIT)#10
119 Q X_$E(HLECH)_HLDIGIT_$E(HLECH)_"M11"
120 ;
121OLDM10(X,HLECDE) ;Calculate M10 checksum
122 ; INPUT : X - String to calc checksum
123 ; Optional HLECDE - Encoding chars
124 ;**** NOTE: ****
125 ;If this function is called without HLECDE as parameter than HLECH
126 ;must be define.
127 ;
128 Q:'$D(X) ""
129 I '$D(HLECH),'$D(HLECDE) Q ""
130 I $D(HLECDE) N HLECH S HLECH=HLECDE
131 I '$D(HLECH) Q ""
132 N %,Y
133 S Y=0 F %=1:1:$L(X) S Y=Y+$E(X,%)
134 Q X_$E(HLECH)_(Y#10)_$E(HLECH)_"M10"
135 ;
136OLDM11(X,HLECDE) ;Calculate M11 checksum
137 ; INPUT : X - String to calc checksum
138 ; Optional HLECDE - Encoding chars
139 ;**** NOTE: ****
140 ;If this function is called without HLECDE as parameter than HLECH
141 ;must be define.
142 ;
143 Q:'$D(X) ""
144 I '$D(HLECH),'$D(HLECDE) Q ""
145 I $D(HLECDE) N HLECH S HLECH=HLECDE
146 I '$D(HLECH) Q ""
147 N %,Y S Y=0 F %=1:1:$L(X) S Y=Y+$E(X,%)
148 Q X_$E(HLECH)_(Y#11)_$E(HLECH)_"M11"
149UPPER(X) ;Convert lowercase letters to uppercase
150 Q:'$D(X) ""
151 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
152HLPHONE(X,B,C) ;Convert DHCP Phone Number to HL7 Format
153 ;Required parameters:
154 ;X = Seven digit phone number at a minimum. Optionally, in addition,
155 ; a three digit area code, two digit country code and other
156 ; formatting characters (e.g., dashes)
157 ;Optional Variables:
158 ;B = Beeper number
159 ;C = Comments
160 Q:'$D(X) "" Q:$L(X)<7 ""
161 N I,Y,Y1,Z S B=$S('$D(B):"",1:"B"_B),C=$S('$D(C):"",1:"C"_C)
162 ;
163 ; patch HL*1.6*141 start
164 ; S Y="" F I=1:1:$L(X) S Y=Y_$S($E(X,I)?1N:$E(X,I),"X,x"[$E(X,I)&('$D(Z)):"X",1:"") I "X,x"[$E(X,I) S Z=""
165 N CH
166 S Y=""
167 F I=1:1:$L(X) D
168 . S CH=$E(X,I)
169 . ; Next line modified by RBN
170 . ;S Y=Y_$S(CH?1N:CH,"Xx"[CH&('$D(Z)):"X",1:"")
171 . S Y=Y_$S(CH?1N:CH,"Xx,*"[CH&('$D(Z)):"X",1:"")
172 . I "Xx"[CH S Z=""
173 ;
174 ; the number, following "X" character, should be greater than 0
175 I Y["X",+$P(Y,"X",2)<1 S Y=$P(Y,"X")
176 ; patch HL*1.6*141 end
177 ;
178 I $L(Y)<7 Q ""
179 S Y1=$S(Y["X":"X"_$P(Y,"X",2),1:""),Y=$P(Y,"X") I $L(Y)<7 Q ""
180 I $L(Y)=8,189[$E(Y) S Y=$E(Y,2,8)
181 I $L(Y)=11,189[$E(Y) S Y=$E(Y,2,11)
182 I $L(Y)=7 Q $E($E(Y,1,3)_"-"_$E(Y,4,7)_Y1_B_C,1,40)
183 I $L(Y)=10 Q $E("("_$E(Y,1,3)_")"_$E(Y,4,6)_"-"_$E(Y,7,10)_Y1_B_C,1,40)
184 I $L(Y)=12 Q $E($E(Y,1,2)_" ("_$E(Y,3,5)_")"_$E(Y,6,8)_"-"_$E(Y,9,12)_Y1_B_C,1,40)
185 Q ""
186HLADDR(AD,GL,HLECDE) ;Convert DHCP address fields to HL7 address format
187 ;Required parameters:
188 ;AD = One to four street address lines separated by uparrows (^).
189 ;GL = Three to four geographic location components separated by
190 ; uparrows (^). City^State or Province^Zip Code^Country Code.
191 ; If the fourth component is not defined, it will be set to 'USA'.
192 ; The second component must be null or an IEN in the
193 ; State file (#5). The third component must be null or pattern
194 ; match 5N, 9N or 5N1"-"4N.
195 ;
196 ; Optional HLECDE - Encoding chars
197 ;**** NOTE: ****
198 ;If this function is called without HLECDE as parameter than HLECH
199 ;must be define.
200 ;
201 ;
202 ;A string will be returned with six components separated by the HL7
203 ;component separator. The length of the string (including separators)
204 ;may exceed 106 characters.
205 ;
206 Q:'$D(AD) "" Q:'$D(GL) ""
207 I '$D(HLECH),'$D(HLECDE) Q ""
208 I $D(HLECDE) N HLECH S HLECH=HLECDE
209 I '$D(HLECH) Q ""
210 I $D(XRTL) D T0^%ZOSV
211 N I,X,Y
212 I $P(GL,"^",4)="" S $P(GL,"^",4)="USA"
213 I $P(GL,"^",4)="USA" S X=$P(GL,"^",3) S:X?9N X=$E(X,1,5)_"-"_$E(X,6,9) S $P(GL,"^",3)=$S(X?5N!(X?5N1"-"4N):X,1:"")
214 S X=+$P(GL,"^",2) S $P(GL,"^",2)=$S('X:"",$P($G(^DIC(5,X,0)),"^",2)]"":$E($P(^(0),"^",2),1,2),1:"")
215 S Y=$E(HLECH)_$P(GL,"^")_$E(HLECH)_$P(GL,"^",2)_$E(HLECH)_$P(GL,"^",3)_$E(HLECH)_$P(GL,"^",4)
216 S X=$P(AD,"^",1,4) F I=1,2 I X["^^" S X=$P(X,"^^")_"^"_$P(X,"^^",2,3)
217 I $E(X,$L(X))="^" S X=$E(X,1,($L(X)-1))
218 I $D(XRT0) S XRTN="HLFNC" D T1^%ZOSV
219 I $L(X,"^")=1 Q $P(X,"^")_$E(HLECH)_Y
220 I $L(X,"^")=2 Q $P(X,"^")_$E(HLECH)_$P(X,"^",2)_Y
221 I $L(X,"^")=3 Q $P(X,"^")_", "_$P(X,"^",2)_$E(HLECH)_$P(X,"^",3)_Y
222 I $L(X,"^")=4 Q $P(X,"^")_", "_$P(X,"^",2)_$E(HLECH)_$P(X,"^",3)_", "_$P(X,"^",4)_Y
Note: See TracBrowser for help on using the repository browser.