- 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 Jan 18, 2025@02:59:24 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