Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLFNC.m

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