HLFNC ;AISC/SAW/OAK-OIFO/RBN-Routine of Functions and Other Calls Used for HL7 Messages ;03/26/2008 11:34
;;1.6;HEALTH LEVEL SEVEN;**38,42,51,66,141**;Oct 13, 1995;Build 11
;Per VHA Directive 2004-038, this routine should not be modified.
;
HLNAME(X,HLECDE) ;Convert a name in DHCP format to HL7 format
; INPUT: X - Name in DHCP format
; Optional - HLECDE - HL7 encoding chars
;**** NOTE: ****
;If this function is called without HLECDE as parameter than HLECH
;must be define.
;
Q:'$D(X) "" Q:X="" ""
I '$D(HLECH),'$D(HLECDE) Q ""
I $D(HLECDE) N HLECH S HLECH=HLECDE
I '$D(HLECH) Q ""
N %,X1,X2,Y
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," ",%)
Q Y
;
FMNAME(X,HLECDE) ;Convert a name in HL7 format to DHCP format
; INPUT: X - Name in HL7 format
; Optional - HLECDE - HL7 encoding chars
;**** NOTE: ****
;If this function is called without HLECDE as parameter than HLECH
;must be define.
;
Q:'$D(X) "" Q:X="" ""
I '$D(HLECH),'$D(HLECDE) Q ""
I $D(HLECDE) N HLECH S HLECH=HLECDE
I '$D(HLECH) Q ""
N %,X1 S X1=$L(X,$E(HLECH)),Y="" F %=1:1:X1 D
.I $P(X,$E(HLECH),%)]"",$P(X,$E(HLECH),%)'="""""" D
..;Only last name,first name.
..I %<3 S Y=Y_$P(X,$E(HLECH),%)_$S(%=1:",",1:"") Q
..S Y=Y_" "_$P(X,$E(HLECH),%)
Q Y
;
HLDATE(X,Y) ;Convert date, date/time or time only in FM format to HL7 format
;Optional Variables:
;Y = The type of format to be returned if you want to force return of a
; specific format. Y must be equal to one of the following:
; DT - Date only
; TM - Time only
; TS - Date and time
I X="" Q ""
S Y=$G(Y)
N %,Z
I $L(X)<7 D Q % ;Time input
. S %=$S(X=2400:"0000",$L(X)<4:$E(X_"000",1,4),1:X) S:$L(%)=5 %=%_0
. Q
I Y="TM" D Q % ;Only time
. S %=$P(X,".",2),%=$S(%="":"",$E(%,1,2)=24:"0000",$L(%)<4:$E(%_"000",1,4),1:%) S:$L(%)=5 %=%_0
. Q
S %=$$FMTHL7^XLFDT(X)
Q $S(Y="DT":$E(%,1,8),1:%)
;
FMDATE(X) ; Convert a date, date/time or time only in HL7 format to FM format
I X="" Q ""
N %
S %=$P($TR(X,"+-","^"),"^")
I $L(X)<7 Q %
Q $$HL7TFM^XLFDT(X)
;
M10(X,HLECDE) ; M10 check digit scheme
; INPUT : X - ID number
; Optional HLECDE - Encoding chars
;**** NOTE: ****
;If this function is called without HLECDE as parameter then HLECH
;must be defined.
;Return X if encoding character is not defined
;Return X with encoding characters concatenated if X is alphanumeric
;
N HLCNT,HLODD,HLEVEN,HLX1,HLDIGIT
Q:'$D(X) ""
I $D(HLECDE) N HLECH S HLECH=HLECDE
;Return X if encoding character is not defined
I '$D(HLECH) Q X
;Return X with encoding characters concatenated if X is alphanumeric
I '(X?1.N) Q X_$E(HLECH)_$E(HLECH)
;
S HLX1=+X
S HLODD=""
F HLCNT=$L(HLX1):-2:1 S HLODD=HLODD_$E(HLX1,HLCNT)
S HLODD=HLODD*2
S HLEVEN=""
F HLCNT=($L(HLX1)-1):-2:1 S HLEVEN=HLEVEN_$E(HLX1,HLCNT)
S HLX1=HLEVEN_HLODD
S HLDIGIT=0
F HLCNT=1:1:$L(HLX1) S HLDIGIT=HLDIGIT+$E(HLX1,HLCNT)
S HLDIGIT=((HLDIGIT\10+1)*10-HLDIGIT)#10
Q X_$E(HLECH)_HLDIGIT_$E(HLECH)_"M10"
;
M11(X,HLECDE) ; M11 check digit scheme
; INPUT : X - ID number
; Optional HLECDE - Encoding chars
;**** NOTE: ****
;If this function is called without HLECDE as parameter then HLECH
;must be defined.
;Return X if encoding character is not defined
;Return X with encoding characters concatenated if X is alphanumeric
;
N HLX1,HLCNT,HLWT,HLDIGIT
Q:'$D(X) ""
I $D(HLECDE) N HLECH S HLECH=HLECDE
;Return X if encoding character is not defined
I '$D(HLECH) Q X
;Return X with encoding characters concatenated if X is alphanumeric
I '(X?1N.N) Q X_$E(HLECH)_$E(HLECH)
;
S HLX1=+X
S HLDIGIT=0,HLWT=2
F HLCNT=$L(HLX1):-1:1 D
. I HLWT>7 S HLWT=2
. S HLDIGIT=HLDIGIT+($E(HLX1,HLCNT)*HLWT)
. S HLWT=HLWT+1
S HLDIGIT=HLDIGIT#11
I HLDIGIT=0 S HLDIGIT=1
S HLDIGIT=(11-HLDIGIT)#10
Q X_$E(HLECH)_HLDIGIT_$E(HLECH)_"M11"
;
OLDM10(X,HLECDE) ;Calculate M10 checksum
; INPUT : X - String to calc checksum
; Optional HLECDE - Encoding chars
;**** NOTE: ****
;If this function is called without HLECDE as parameter than HLECH
;must be define.
;
Q:'$D(X) ""
I '$D(HLECH),'$D(HLECDE) Q ""
I $D(HLECDE) N HLECH S HLECH=HLECDE
I '$D(HLECH) Q ""
N %,Y
S Y=0 F %=1:1:$L(X) S Y=Y+$E(X,%)
Q X_$E(HLECH)_(Y#10)_$E(HLECH)_"M10"
;
OLDM11(X,HLECDE) ;Calculate M11 checksum
; INPUT : X - String to calc checksum
; Optional HLECDE - Encoding chars
;**** NOTE: ****
;If this function is called without HLECDE as parameter than HLECH
;must be define.
;
Q:'$D(X) ""
I '$D(HLECH),'$D(HLECDE) Q ""
I $D(HLECDE) N HLECH S HLECH=HLECDE
I '$D(HLECH) Q ""
N %,Y S Y=0 F %=1:1:$L(X) S Y=Y+$E(X,%)
Q X_$E(HLECH)_(Y#11)_$E(HLECH)_"M11"
UPPER(X) ;Convert lowercase letters to uppercase
Q:'$D(X) ""
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
HLPHONE(X,B,C) ;Convert DHCP Phone Number to HL7 Format
;Required parameters:
;X = Seven digit phone number at a minimum. Optionally, in addition,
; a three digit area code, two digit country code and other
; formatting characters (e.g., dashes)
;Optional Variables:
;B = Beeper number
;C = Comments
Q:'$D(X) "" Q:$L(X)<7 ""
N I,Y,Y1,Z S B=$S('$D(B):"",1:"B"_B),C=$S('$D(C):"",1:"C"_C)
;
; patch HL*1.6*141 start
; 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=""
N CH
S Y=""
F I=1:1:$L(X) D
. S CH=$E(X,I)
. ; Next line modified by RBN
. ;S Y=Y_$S(CH?1N:CH,"Xx"[CH&('$D(Z)):"X",1:"")
. S Y=Y_$S(CH?1N:CH,"Xx,*"[CH&('$D(Z)):"X",1:"")
. I "Xx"[CH S Z=""
;
; the number, following "X" character, should be greater than 0
I Y["X",+$P(Y,"X",2)<1 S Y=$P(Y,"X")
; patch HL*1.6*141 end
;
I $L(Y)<7 Q ""
S Y1=$S(Y["X":"X"_$P(Y,"X",2),1:""),Y=$P(Y,"X") I $L(Y)<7 Q ""
I $L(Y)=8,189[$E(Y) S Y=$E(Y,2,8)
I $L(Y)=11,189[$E(Y) S Y=$E(Y,2,11)
I $L(Y)=7 Q $E($E(Y,1,3)_"-"_$E(Y,4,7)_Y1_B_C,1,40)
I $L(Y)=10 Q $E("("_$E(Y,1,3)_")"_$E(Y,4,6)_"-"_$E(Y,7,10)_Y1_B_C,1,40)
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)
Q ""
HLADDR(AD,GL,HLECDE) ;Convert DHCP address fields to HL7 address format
;Required parameters:
;AD = One to four street address lines separated by uparrows (^).
;GL = Three to four geographic location components separated by
; uparrows (^). City^State or Province^Zip Code^Country Code.
; If the fourth component is not defined, it will be set to 'USA'.
; The second component must be null or an IEN in the
; State file (#5). The third component must be null or pattern
; match 5N, 9N or 5N1"-"4N.
;
; Optional HLECDE - Encoding chars
;**** NOTE: ****
;If this function is called without HLECDE as parameter than HLECH
;must be define.
;
;
;A string will be returned with six components separated by the HL7
;component separator. The length of the string (including separators)
;may exceed 106 characters.
;
Q:'$D(AD) "" Q:'$D(GL) ""
I '$D(HLECH),'$D(HLECDE) Q ""
I $D(HLECDE) N HLECH S HLECH=HLECDE
I '$D(HLECH) Q ""
I $D(XRTL) D T0^%ZOSV
N I,X,Y
I $P(GL,"^",4)="" S $P(GL,"^",4)="USA"
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:"")
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:"")
S Y=$E(HLECH)_$P(GL,"^")_$E(HLECH)_$P(GL,"^",2)_$E(HLECH)_$P(GL,"^",3)_$E(HLECH)_$P(GL,"^",4)
S X=$P(AD,"^",1,4) F I=1,2 I X["^^" S X=$P(X,"^^")_"^"_$P(X,"^^",2,3)
I $E(X,$L(X))="^" S X=$E(X,1,($L(X)-1))
I $D(XRT0) S XRTN="HLFNC" D T1^%ZOSV
I $L(X,"^")=1 Q $P(X,"^")_$E(HLECH)_Y
I $L(X,"^")=2 Q $P(X,"^")_$E(HLECH)_$P(X,"^",2)_Y
I $L(X,"^")=3 Q $P(X,"^")_", "_$P(X,"^",2)_$E(HLECH)_$P(X,"^",3)_Y
I $L(X,"^")=4 Q $P(X,"^")_", "_$P(X,"^",2)_$E(HLECH)_$P(X,"^",3)_", "_$P(X,"^",4)_Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLFNC 8069 printed Sep 23, 2025@19:34:14 Page 2
HLFNC ;AISC/SAW/OAK-OIFO/RBN-Routine of Functions and Other Calls Used for HL7 Messages ;03/26/2008 11:34
+1 ;;1.6;HEALTH LEVEL SEVEN;**38,42,51,66,141**;Oct 13, 1995;Build 11
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
HLNAME(X,HLECDE) ;Convert a name in DHCP format to HL7 format
+1 ; INPUT: X - Name in DHCP format
+2 ; Optional - HLECDE - HL7 encoding chars
+3 ;**** NOTE: ****
+4 ;If this function is called without HLECDE as parameter than HLECH
+5 ;must be define.
+6 ;
+7 if '$DATA(X)
QUIT ""
if X=""
QUIT ""
+8 IF '$DATA(HLECH)
IF '$DATA(HLECDE)
QUIT ""
+9 IF $DATA(HLECDE)
NEW HLECH
SET HLECH=HLECDE
+10 IF '$DATA(HLECH)
QUIT ""
+11 NEW %,X1,X2,Y
+12 SET X1=$PIECE(X,",",2)
SET X2=$LENGTH(X1," ")
SET Y=$PIECE(X,",")_$EXTRACT(HLECH)_$PIECE(X1," ")
IF X2
FOR %=2:1:X2
if $PIECE(X1," ",%)']""
QUIT
SET Y=Y_$EXTRACT(HLECH)_$PIECE(X1," ",%)
+13 QUIT Y
+14 ;
FMNAME(X,HLECDE) ;Convert a name in HL7 format to DHCP format
+1 ; INPUT: X - Name in HL7 format
+2 ; Optional - HLECDE - HL7 encoding chars
+3 ;**** NOTE: ****
+4 ;If this function is called without HLECDE as parameter than HLECH
+5 ;must be define.
+6 ;
+7 if '$DATA(X)
QUIT ""
if X=""
QUIT ""
+8 IF '$DATA(HLECH)
IF '$DATA(HLECDE)
QUIT ""
+9 IF $DATA(HLECDE)
NEW HLECH
SET HLECH=HLECDE
+10 IF '$DATA(HLECH)
QUIT ""
+11 NEW %,X1
SET X1=$LENGTH(X,$EXTRACT(HLECH))
SET Y=""
FOR %=1:1:X1
Begin DoDot:1
+12 IF $PIECE(X,$EXTRACT(HLECH),%)]""
IF $PIECE(X,$EXTRACT(HLECH),%)'=""""""
Begin DoDot:2
+13 ;Only last name,first name.
+14 IF %<3
SET Y=Y_$PIECE(X,$EXTRACT(HLECH),%)_$SELECT(%=1:",",1:"")
QUIT
+15 SET Y=Y_" "_$PIECE(X,$EXTRACT(HLECH),%)
End DoDot:2
End DoDot:1
+16 QUIT Y
+17 ;
HLDATE(X,Y) ;Convert date, date/time or time only in FM format to HL7 format
+1 ;Optional Variables:
+2 ;Y = The type of format to be returned if you want to force return of a
+3 ; specific format. Y must be equal to one of the following:
+4 ; DT - Date only
+5 ; TM - Time only
+6 ; TS - Date and time
+7 IF X=""
QUIT ""
+8 SET Y=$GET(Y)
+9 NEW %,Z
+10 ;Time input
IF $LENGTH(X)<7
Begin DoDot:1
+11 SET %=$SELECT(X=2400:"0000",$LENGTH(X)<4:$EXTRACT(X_"000",1,4),1:X)
if $LENGTH(%)=5
SET %=%_0
+12 QUIT
End DoDot:1
QUIT %
+13 ;Only time
IF Y="TM"
Begin DoDot:1
+14 SET %=$PIECE(X,".",2)
SET %=$SELECT(%="":"",$EXTRACT(%,1,2)=24:"0000",$LENGTH(%)<4:$EXTRACT(%_"000",1,4),1:%)
if $LENGTH(%)=5
SET %=%_0
+15 QUIT
End DoDot:1
QUIT %
+16 SET %=$$FMTHL7^XLFDT(X)
+17 QUIT $SELECT(Y="DT":$EXTRACT(%,1,8),1:%)
+18 ;
FMDATE(X) ; Convert a date, date/time or time only in HL7 format to FM format
+1 IF X=""
QUIT ""
+2 NEW %
+3 SET %=$PIECE($TRANSLATE(X,"+-","^"),"^")
+4 IF $LENGTH(X)<7
QUIT %
+5 QUIT $$HL7TFM^XLFDT(X)
+6 ;
M10(X,HLECDE) ; M10 check digit scheme
+1 ; INPUT : X - ID number
+2 ; Optional HLECDE - Encoding chars
+3 ;**** NOTE: ****
+4 ;If this function is called without HLECDE as parameter then HLECH
+5 ;must be defined.
+6 ;Return X if encoding character is not defined
+7 ;Return X with encoding characters concatenated if X is alphanumeric
+8 ;
+9 NEW HLCNT,HLODD,HLEVEN,HLX1,HLDIGIT
+10 if '$DATA(X)
QUIT ""
+11 IF $DATA(HLECDE)
NEW HLECH
SET HLECH=HLECDE
+12 ;Return X if encoding character is not defined
+13 IF '$DATA(HLECH)
QUIT X
+14 ;Return X with encoding characters concatenated if X is alphanumeric
+15 IF '(X?1.N)
QUIT X_$EXTRACT(HLECH)_$EXTRACT(HLECH)
+16 ;
+17 SET HLX1=+X
+18 SET HLODD=""
+19 FOR HLCNT=$LENGTH(HLX1):-2:1
SET HLODD=HLODD_$EXTRACT(HLX1,HLCNT)
+20 SET HLODD=HLODD*2
+21 SET HLEVEN=""
+22 FOR HLCNT=($LENGTH(HLX1)-1):-2:1
SET HLEVEN=HLEVEN_$EXTRACT(HLX1,HLCNT)
+23 SET HLX1=HLEVEN_HLODD
+24 SET HLDIGIT=0
+25 FOR HLCNT=1:1:$LENGTH(HLX1)
SET HLDIGIT=HLDIGIT+$EXTRACT(HLX1,HLCNT)
+26 SET HLDIGIT=((HLDIGIT\10+1)*10-HLDIGIT)#10
+27 QUIT X_$EXTRACT(HLECH)_HLDIGIT_$EXTRACT(HLECH)_"M10"
+28 ;
M11(X,HLECDE) ; M11 check digit scheme
+1 ; INPUT : X - ID number
+2 ; Optional HLECDE - Encoding chars
+3 ;**** NOTE: ****
+4 ;If this function is called without HLECDE as parameter then HLECH
+5 ;must be defined.
+6 ;Return X if encoding character is not defined
+7 ;Return X with encoding characters concatenated if X is alphanumeric
+8 ;
+9 NEW HLX1,HLCNT,HLWT,HLDIGIT
+10 if '$DATA(X)
QUIT ""
+11 IF $DATA(HLECDE)
NEW HLECH
SET HLECH=HLECDE
+12 ;Return X if encoding character is not defined
+13 IF '$DATA(HLECH)
QUIT X
+14 ;Return X with encoding characters concatenated if X is alphanumeric
+15 IF '(X?1N.N)
QUIT X_$EXTRACT(HLECH)_$EXTRACT(HLECH)
+16 ;
+17 SET HLX1=+X
+18 SET HLDIGIT=0
SET HLWT=2
+19 FOR HLCNT=$LENGTH(HLX1):-1:1
Begin DoDot:1
+20 IF HLWT>7
SET HLWT=2
+21 SET HLDIGIT=HLDIGIT+($EXTRACT(HLX1,HLCNT)*HLWT)
+22 SET HLWT=HLWT+1
End DoDot:1
+23 SET HLDIGIT=HLDIGIT#11
+24 IF HLDIGIT=0
SET HLDIGIT=1
+25 SET HLDIGIT=(11-HLDIGIT)#10
+26 QUIT X_$EXTRACT(HLECH)_HLDIGIT_$EXTRACT(HLECH)_"M11"
+27 ;
OLDM10(X,HLECDE) ;Calculate M10 checksum
+1 ; INPUT : X - String to calc checksum
+2 ; Optional HLECDE - Encoding chars
+3 ;**** NOTE: ****
+4 ;If this function is called without HLECDE as parameter than HLECH
+5 ;must be define.
+6 ;
+7 if '$DATA(X)
QUIT ""
+8 IF '$DATA(HLECH)
IF '$DATA(HLECDE)
QUIT ""
+9 IF $DATA(HLECDE)
NEW HLECH
SET HLECH=HLECDE
+10 IF '$DATA(HLECH)
QUIT ""
+11 NEW %,Y
+12 SET Y=0
FOR %=1:1:$LENGTH(X)
SET Y=Y+$EXTRACT(X,%)
+13 QUIT X_$EXTRACT(HLECH)_(Y#10)_$EXTRACT(HLECH)_"M10"
+14 ;
OLDM11(X,HLECDE) ;Calculate M11 checksum
+1 ; INPUT : X - String to calc checksum
+2 ; Optional HLECDE - Encoding chars
+3 ;**** NOTE: ****
+4 ;If this function is called without HLECDE as parameter than HLECH
+5 ;must be define.
+6 ;
+7 if '$DATA(X)
QUIT ""
+8 IF '$DATA(HLECH)
IF '$DATA(HLECDE)
QUIT ""
+9 IF $DATA(HLECDE)
NEW HLECH
SET HLECH=HLECDE
+10 IF '$DATA(HLECH)
QUIT ""
+11 NEW %,Y
SET Y=0
FOR %=1:1:$LENGTH(X)
SET Y=Y+$EXTRACT(X,%)
+12 QUIT X_$EXTRACT(HLECH)_(Y#11)_$EXTRACT(HLECH)_"M11"
UPPER(X) ;Convert lowercase letters to uppercase
+1 if '$DATA(X)
QUIT ""
+2 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
HLPHONE(X,B,C) ;Convert DHCP Phone Number to HL7 Format
+1 ;Required parameters:
+2 ;X = Seven digit phone number at a minimum. Optionally, in addition,
+3 ; a three digit area code, two digit country code and other
+4 ; formatting characters (e.g., dashes)
+5 ;Optional Variables:
+6 ;B = Beeper number
+7 ;C = Comments
+8 if '$DATA(X)
QUIT ""
if $LENGTH(X)<7
QUIT ""
+9 NEW I,Y,Y1,Z
SET B=$SELECT('$DATA(B):"",1:"B"_B)
SET C=$SELECT('$DATA(C):"",1:"C"_C)
+10 ;
+11 ; patch HL*1.6*141 start
+12 ; 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=""
+13 NEW CH
+14 SET Y=""
+15 FOR I=1:1:$LENGTH(X)
Begin DoDot:1
+16 SET CH=$EXTRACT(X,I)
+17 ; Next line modified by RBN
+18 ;S Y=Y_$S(CH?1N:CH,"Xx"[CH&('$D(Z)):"X",1:"")
+19 SET Y=Y_$SELECT(CH?1N:CH,"Xx,*"[CH&('$DATA(Z)):"X",1:"")
+20 IF "Xx"[CH
SET Z=""
End DoDot:1
+21 ;
+22 ; the number, following "X" character, should be greater than 0
+23 IF Y["X"
IF +$PIECE(Y,"X",2)<1
SET Y=$PIECE(Y,"X")
+24 ; patch HL*1.6*141 end
+25 ;
+26 IF $LENGTH(Y)<7
QUIT ""
+27 SET Y1=$SELECT(Y["X":"X"_$PIECE(Y,"X",2),1:"")
SET Y=$PIECE(Y,"X")
IF $LENGTH(Y)<7
QUIT ""
+28 IF $LENGTH(Y)=8
IF 189[$EXTRACT(Y)
SET Y=$EXTRACT(Y,2,8)
+29 IF $LENGTH(Y)=11
IF 189[$EXTRACT(Y)
SET Y=$EXTRACT(Y,2,11)
+30 IF $LENGTH(Y)=7
QUIT $EXTRACT($EXTRACT(Y,1,3)_"-"_$EXTRACT(Y,4,7)_Y1_B_C,1,40)
+31 IF $LENGTH(Y)=10
QUIT $EXTRACT("("_$EXTRACT(Y,1,3)_")"_$EXTRACT(Y,4,6)_"-"_$EXTRACT(Y,7,10)_Y1_B_C,1,40)
+32 IF $LENGTH(Y)=12
QUIT $EXTRACT($EXTRACT(Y,1,2)_" ("_$EXTRACT(Y,3,5)_")"_$EXTRACT(Y,6,8)_"-"_$EXTRACT(Y,9,12)_Y1_B_C,1,40)
+33 QUIT ""
HLADDR(AD,GL,HLECDE) ;Convert DHCP address fields to HL7 address format
+1 ;Required parameters:
+2 ;AD = One to four street address lines separated by uparrows (^).
+3 ;GL = Three to four geographic location components separated by
+4 ; uparrows (^). City^State or Province^Zip Code^Country Code.
+5 ; If the fourth component is not defined, it will be set to 'USA'.
+6 ; The second component must be null or an IEN in the
+7 ; State file (#5). The third component must be null or pattern
+8 ; match 5N, 9N or 5N1"-"4N.
+9 ;
+10 ; Optional HLECDE - Encoding chars
+11 ;**** NOTE: ****
+12 ;If this function is called without HLECDE as parameter than HLECH
+13 ;must be define.
+14 ;
+15 ;
+16 ;A string will be returned with six components separated by the HL7
+17 ;component separator. The length of the string (including separators)
+18 ;may exceed 106 characters.
+19 ;
+20 if '$DATA(AD)
QUIT ""
if '$DATA(GL)
QUIT ""
+21 IF '$DATA(HLECH)
IF '$DATA(HLECDE)
QUIT ""
+22 IF $DATA(HLECDE)
NEW HLECH
SET HLECH=HLECDE
+23 IF '$DATA(HLECH)
QUIT ""
+24 IF $DATA(XRTL)
DO T0^%ZOSV
+25 NEW I,X,Y
+26 IF $PIECE(GL,"^",4)=""
SET $PIECE(GL,"^",4)="USA"
+27 IF $PIECE(GL,"^",4)="USA"
SET X=$PIECE(GL,"^",3)
if X?9N
SET X=$EXTRACT(X,1,5)_"-"_$EXTRACT(X,6,9)
SET $PIECE(GL,"^",3)=$SELECT(X?5N!(X?5N1"-"4N):X,1:"")
+28 SET X=+$PIECE(GL,"^",2)
SET $PIECE(GL,"^",2)=$SELECT('X:"",$PIECE($GET(^DIC(5,X,0)),"^",2)]"":$EXTRACT($PIECE(^(0),"^",2),1,2),1:"")
+29 SET Y=$EXTRACT(HLECH)_$PIECE(GL,"^")_$EXTRACT(HLECH)_$PIECE(GL,"^",2)_$EXTRACT(HLECH)_$PIECE(GL,"^",3)_$EXTRACT(HLECH)_$PIECE(GL,"^",4)
+30 SET X=$PIECE(AD,"^",1,4)
FOR I=1,2
IF X["^^"
SET X=$PIECE(X,"^^")_"^"_$PIECE(X,"^^",2,3)
+31 IF $EXTRACT(X,$LENGTH(X))="^"
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+32 IF $DATA(XRT0)
SET XRTN="HLFNC"
DO T1^%ZOSV
+33 IF $LENGTH(X,"^")=1
QUIT $PIECE(X,"^")_$EXTRACT(HLECH)_Y
+34 IF $LENGTH(X,"^")=2
QUIT $PIECE(X,"^")_$EXTRACT(HLECH)_$PIECE(X,"^",2)_Y
+35 IF $LENGTH(X,"^")=3
QUIT $PIECE(X,"^")_", "_$PIECE(X,"^",2)_$EXTRACT(HLECH)_$PIECE(X,"^",3)_Y
+36 IF $LENGTH(X,"^")=4
QUIT $PIECE(X,"^")_", "_$PIECE(X,"^",2)_$EXTRACT(HLECH)_$PIECE(X,"^",3)_", "_$PIECE(X,"^",4)_Y
