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/HLCSHDR1.m

    r613 r623  
    1 HLCSHDR1        ;SFIRMFO/RSD - Make HL7 header for TCP ;04/17/2007
    2         ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93,120,133,122**;Oct 13, 1995;Build 14
    3         ;Per VHA Directive 2004-038, this routine should not be modified.
    4 HEADER(IEN,CLIENT,HLERROR)      ; Create an HL7 MSH segment
    5         ;
    6         ;Input  : IEN - Pointer to entry in Message Administration file (#773)
    7         ;               that HL7 MSH segment is being built for
    8         ;         CLIENT - IEN of the receiving application
    9         ;         HLERROR - Variable to return possible error text in
    10         ;                   (pass by reference - only used when needed)
    11         ;
    12         ;Output : HLHDR(1) - HL7 MSH segment
    13         ;         HLHDR(2) - Continuation of HL7 MSH segment (if needed)
    14         ;         HLHDR(3) - Continuation of HL7 MSH segment (if needed)
    15         ;
    16         ;Notes  : HLERROR will only be defined [on output] if an error occurs
    17         ;       : HLHDR() will not be defined [on output] if an error occurs
    18         ;       : HLHDR(2) & HLHDR(3) are continuation [or roll-over] nodes
    19         ;         and will only be used/defined when needed
    20         ;
    21         N ACKTO,ACCACK,APPACK,CHILD,CLNTAPP,CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID,MSGTYPE,PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X,MSGEVN
    22         N COMFLAG ; patch HL*1.6*120
    23         S HLERROR=""
    24         S HLPARAM=$$PARAM^HLCS2
    25         D VAR Q:$G(HLERROR)]""
    26         ; The following line commented by HL*1.6*72
    27         ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE)
    28         ;Append event type
    29         I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_EVNTYPE
    30         ;Append message structure component
    31         I $G(EVNTYPE)]"",$G(MSGEVN)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_MSGEVN
    32         ;Build MSH array
    33         D RESET^HLCSHDR3 ;HL*1.6*93
    34         ;
    35         ; patch HL*1.6*120 start
    36         ; escape delimiters for SERAPP and CLNTAPP
    37         ; escape component separator if the field is not consisted
    38         ; of 3 components
    39         S EC(1)=$E(EC,1)
    40         S EC(2)=$E(EC,2)
    41         S EC(3)=$E(EC,3)
    42         S EC(4)=$E(EC,4)
    43         S COMFLAG=1
    44         I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0
    45         I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D
    46         . S SERAPP=$$ESCAPE(SERAPP,COMFLAG)
    47         S COMFLAG=1
    48         I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0
    49         I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D
    50         . S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG)
    51         ; patch HL*1.6*120 end
    52         ;
    53         S HLHDRI=1,HLHDR(1)="MSH"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1))
    54         F X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D MSH(X)
    55         ;in preceeding line, "" is for sequence number - not supported
    56         Q
    57         ;
    58 MSH(X)  ;add X to HLHDR
    59         S:HLHDRL+$L(X)>245 HLHDRI=HLHDRI+1,HLHDR(HLHDRI)=""
    60         S HLHDR(HLHDRI)=HLHDR(HLHDRI)_FS_X,HLHDRL=$L(HLHDR(HLHDRI))
    61         Q
    62 BHSHDR(IEN,CLIENT,HLERROR)      ; Create Batch Header Segment
    63         ; The BHS has 12 segments, of which 4 are blank.
    64         ; INPUT: IEN - IEN of entry in file #772
    65         ; OUTPUT: HLHDR(1) and HLHDR(2) - the two lines with the 12 segs.
    66         ;   ready for adding to a message directly.
    67         N ACKTO,ACCACK,ACKMID,APPACK,BNAME,BSTATUS,BTACK,CHILD,CLNTAPP ;HL*1.6*80
    68         N CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID ;HL*1.6*80 - added HLPID
    69         N PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X ;HL*1.6*80
    70         N COMFLAG ; patch HL*1.6*120
    71         S HLERROR=""
    72         ;
    73         S HLPARAM=$$PARAM^HLCS2
    74         D VAR Q:$G(HLERROR)]""
    75         ; The following line commented by HL*1.6*72
    76         ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE)
    77         ;
    78         ;Append event type
    79         I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,2)_EVNTYPE,(ACKMID,BTACK)=""
    80         ;batch/name/id/type(#9)=null~process ID~msg type|evnt type~version~CA~AA
    81         S BNAME=$E(EC,1)_HLPID_$E(EC,1)_MSGTYPE_$E(EC,1)_$P(PROT,U,9)_$E(EC,1)_ACCACK_$E(EC,1)_APPACK ;HL*1.6*80
    82         ;for batch ACK
    83         I ACKTO D  S BTACK=X_$E(EC,1)_$P(BSTATUS,U,3)
    84         . ;get msg id and status of message that is being ACKed
    85         . S ACKMID=$P($G(^HLMA(ACKTO,0)),U,2),BSTATUS=$G(^HLMA(ACKTO,"P")) ;HL*1.6*80
    86         . ;set type of ACK based on status
    87         . S X=$S(ACKMID="":"AR",(BSTATUS>3)&(BSTATUS<8):"AE",1:"AA")
    88         ;
    89         D RESET^HLCSHDR3 ;HL*1.6*93
    90         ;
    91         ; patch HL*1.6*120 start
    92         ; escape delimiters for SERAPP and CLNTAPP
    93         ; escape component separator if the field is not consisted
    94         ; of 3 components
    95         S EC(1)=$E(EC,1)
    96         S EC(2)=$E(EC,2)
    97         S EC(3)=$E(EC,3)
    98         S EC(4)=$E(EC,4)
    99         S COMFLAG=1
    100         I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0
    101         I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D
    102         . S SERAPP=$$ESCAPE(SERAPP,COMFLAG)
    103         S COMFLAG=1
    104         I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0
    105         I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D
    106         . S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG)
    107         ; patch HL*1.6*120 end
    108         ;
    109         S HLHDRI=1,HLHDR(1)="BHS"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1))
    110         F X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,BNAME,BTACK,HLID,ACKMID D MSH(X)
    111         Q
    112 VAR     ;Check input
    113         N APPPRM,HLPROTS,HLPROT
    114         S IEN=+$G(IEN)
    115         I '$G(^HLMA(IEN,0)) S HLERROR="Valid pointer to Message Administration file (#772) not passed" Q
    116         I '$G(CLIENT) S HLERROR="Could not determine receiving application" Q
    117         ;Get child, text pointer,text entry, and sending app.
    118         S CHILD=$G(^HLMA(IEN,0)),SEND=+$P($G(^(0)),U,11),TXTP=+CHILD,TXTP0=$G(^HL(772,TXTP,0))
    119         I ('SEND) S HLERROR="Could not determine sending application" Q
    120         ;Get info for sending & receiving applications
    121         D APPPRM^HLUTIL2(CLIENT),APPPRM^HLUTIL2(SEND)
    122         ;Get name of sending application, facility, and country
    123         S SERAPP=$P(APPPRM(SEND,0),U),SERFAC=$P(APPPRM(SEND,0),U,2),CNTRY=$P(APPPRM(SEND,0),U,3)
    124         ;Get name of receiving application and facility
    125         S CLNTAPP=$P(APPPRM(CLIENT,0),U),CLNTFAC=$P(APPPRM(CLIENT,0),U,2)
    126         ;
    127         ; patch HL*1.6*120
    128         ; for dynamic addressing, overide the receiving facility from the
    129         ; 3rd component of HLL("LINKS") array
    130         I $G(HLP("REC-FACILITY"))]"" S CLNTFAC=HLP("REC-FACILITY")
    131         ;
    132         ;Get field separator & encoding characters
    133         S FS=APPPRM(SEND,"FS"),EC=APPPRM(SEND,"EC")
    134         S:(EC="") EC="~|\&" S:(FS="") FS="^"
    135         ;Determine if it's a response/ACK to another message
    136         S ACKTO=+$P(CHILD,U,10)
    137         ;subscriber protocol is from child (file 773)
    138         ;If response, get MType from subscriber
    139         S HLPROTS=+$P(CHILD,U,8)
    140         S PROTS=$$TYPE^HLUTIL2(HLPROTS)
    141         I ACKTO S MSGTYPE=$P(PROTS,U,10),EVNTYPE=$P(PROTS,U,3),MSGEVN=$P(PROTS,U,4)
    142         ;Get accept ack & application ack type (based on server protocol) it
    143         ; is always in file 772, TXPT0
    144         ;If original message, get MT from Event Driver Protocol
    145         S HLPROT=+$P(TXTP0,U,10)
    146         S PROT=$$TYPE^HLUTIL2(HLPROT)
    147         S:'ACKTO MSGTYPE=$P(PROT,U,2),EVNTYPE=$P(PROT,U,3),MSGEVN=$P(PROT,U,4)
    148         S ACCACK=$P(PROT,U,7),APPACK=$P(PROT,U,8)
    149         ;
    150         ; patch HL*1.6*122
    151         ; setting the MSH-15 and MSH-16 from subscriber protocol
    152         I HLPROTS,$P($G(^ORD(101,HLPROTS,773)),"^",5) D
    153         . S ACCACK=$P(PROTS,U,7)
    154         . S APPACK=$P(PROTS,U,8)
    155         ;
    156 PID     ;Processing ID
    157         ;I PID not 'debug' get from site params
    158         ;If event driver set to 'debug' get from protocol
    159         ;'production' or 'training' comes from site params
    160         S HLPID=$P(PROT,U,5)
    161         I $G(HLPID)'="D" S HLPID=$P(HLPARAM,U,3)
    162         ;
    163         ; patch HL*1.6*120: to include processing mode
    164         I $G(HLP("PMOD"))]"",($G(HLTYPE)="M") D
    165         . S HLPID=HLPID_$E($G(EC),1)_HLP("PMOD")
    166         ;
    167         I $G(HLPID)="" S HLERROR="Missing processing ID Site parameter."
    168         ;acknowledgements have no application ack, link open no commit ack
    169         I ACKTO S:APPACK]"" APPACK="NE" S:ACCACK]""&$G(HLTCPO) ACCACK="NE"
    170         ;Get date/time, Message ID, and security
    171         S HLDATE=+TXTP0,HLDATE=$$FMTHL7^XLFDT(HLDATE),HLID=$P(CHILD,U,2),SECURITY=$P(CHILD,U,9)
    172 HDR23   ;generate extended facility field info based on 'facility required'
    173         ;default format is INSTITUTION_HLCS_DOMAIN_HLCS_'DNS'
    174         ;application parameter entry overrides default
    175         N HLEP773,HLS773
    176         S SERFAC=$G(SERFAC),CLNTFAC=$G(CLNTFAC)
    177         S HLEP773=+$G(^ORD(101,HLPROTS,773))
    178         S HLS773=+$P($G(^ORD(101,HLPROTS,773)),U,2)
    179         Q:'HLEP773&('HLS773)
    180         D GEN^HLCSHDR2
    181         I ACKTO D  Q
    182         .;Find original message
    183         .S X=$G(^HLMA(ACKTO,"MSH",1,0)) ;Find header in TCP nodes
    184         .I X["MSH" D
    185         ..;
    186         ..; patch HL*1.6*120 start
    187         .. N HLEC
    188         ..S HLFS=$E(X,4),HLEC=$E(X,5)
    189         ..S SENDFAC=$P(X,HLFS,4),RECFAC=$P(X,HLFS,6) ;from original msg
    190         ..S CLNTFAC=SENDFAC,SERFAC=RECFAC ;reverse facility info
    191         ..S EC("COMPONENT")=$E($G(EC),1)
    192         ..I $L(EC("COMPONENT"))=1,$L(HLEC)=1,EC("COMPONENT")'=HLEC D
    193         ... ; change the the component separator in the sending and
    194         ... ; receiving facilities for the outgoing message
    195         ... S CLNTFAC=$TR(CLNTFAC,HLEC,EC("COMPONENT"))
    196         ... S SERFAC=$TR(SERFAC,HLEC,EC("COMPONENT"))
    197         ; patch HL*1.6*120 end
    198         ;
    199         I HLEP773,SERFAC="" D EP^HLCSHDR2
    200         I HLS773,CLNTFAC="" D S^HLCSHDR2
    201         Q
    202         ;
    203 ESCAPE(INPUT,COMPONET)  ;
    204         ; patch HL*1.6*120 - escape delimiters:
    205         ; - field separator
    206         ; - component separator
    207         ; - repetition separator
    208         ; - escape character
    209         ; - subcomponent separator
    210         ;
    211         ; input:
    212         ;     INPUT - string data to be escaped
    213         ;  COMPONET - if 1, escape component separator
    214         ;             if 0, do not escape component separator
    215         ;        FS - field separator character
    216         ;        EC - encoding characters
    217         ; result: return the escaped string
    218         ;
    219         N HLDATA,HLESCAPE,HLI,HLCHAR,HLEN,HLOUT,COMFLAG
    220         S HLDATA=$G(INPUT)
    221         S COMFLAG=$G(COMPONET)
    222         Q:$L($G(FS))'=1 HLDATA
    223         ;
    224         ; patch HL*1.6*133
    225         ; Q:$L($G(EC))'=4 HLDATA
    226         Q:($L($G(EC))<3) HLDATA
    227         Q:HLDATA']"" HLDATA
    228         ;
    229         S HLESCAPE=FS_EC
    230         S HLESCAPE("F")=FS
    231         S HLESCAPE("S")=$E(EC,1)
    232         S HLESCAPE("R")=$E(EC,2)
    233         S HLESCAPE("E")=$E(EC,3)
    234         S HLESCAPE("T")=$E(EC,4)
    235         S HLEN=$L(HLDATA)
    236         S HLOUT=""
    237         F HLI=1:1:HLEN D
    238         . S HLCHAR=$E(HLDATA,HLI)
    239         . I HLESCAPE[HLCHAR D  Q
    240         .. I HLCHAR=HLESCAPE("F") S HLOUT=HLOUT_HLESCAPE("E")_"F"_HLESCAPE("E") Q
    241         .. I HLCHAR=HLESCAPE("S") D  Q
    242         ... I COMFLAG=1 S HLOUT=HLOUT_HLESCAPE("E")_"S"_HLESCAPE("E") Q
    243         ... S HLOUT=HLOUT_HLCHAR
    244         .. I HLCHAR=HLESCAPE("R") S HLOUT=HLOUT_HLESCAPE("E")_"R"_HLESCAPE("E") Q
    245         .. I HLCHAR=HLESCAPE("E") S HLOUT=HLOUT_HLESCAPE("E")_"E"_HLESCAPE("E") Q
    246         .. I HLCHAR=HLESCAPE("T") S HLOUT=HLOUT_HLESCAPE("E")_"T"_HLESCAPE("E") Q
    247         . ;
    248         . S HLOUT=HLOUT_HLCHAR
    249         Q HLOUT
     1HLCSHDR1 ;SFIRMFO/RSD - Make HL7 header for TCP ;09/13/2006
     2 ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93,120,133**;Oct 13, 1995;Build 13
     3 ;Per VHA Directive 2004-038, this routine should not be modified.
     4HEADER(IEN,CLIENT,HLERROR) ; Create an HL7 MSH segment
     5 ;
     6 ;Input  : IEN - Pointer to entry in Message Administration file (#773)
     7 ;               that HL7 MSH segment is being built for
     8 ;         CLIENT - IEN of the receiving application
     9 ;         HLERROR - Variable to return possible error text in
     10 ;                   (pass by reference - only used when needed)
     11 ;
     12 ;Output : HLHDR(1) - HL7 MSH segment
     13 ;         HLHDR(2) - Continuation of HL7 MSH segment (if needed)
     14 ;         HLHDR(3) - Continuation of HL7 MSH segment (if needed)
     15 ;
     16 ;Notes  : HLERROR will only be defined [on output] if an error occurs
     17 ;       : HLHDR() will not be defined [on output] if an error occurs
     18 ;       : HLHDR(2) & HLHDR(3) are continuation [or roll-over] nodes
     19 ;         and will only be used/defined when needed
     20 ;
     21 N ACKTO,ACCACK,APPACK,CHILD,CLNTAPP,CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID,MSGTYPE,PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X,MSGEVN
     22 N COMFLAG ; patch HL*1.6*120
     23 S HLERROR=""
     24 S HLPARAM=$$PARAM^HLCS2
     25 D VAR Q:$G(HLERROR)]""
     26 ; The following line commented by HL*1.6*72
     27 ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE)
     28 ;Append event type
     29 I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_EVNTYPE
     30 ;Append message structure component
     31 I $G(EVNTYPE)]"",$G(MSGEVN)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_MSGEVN
     32 ;Build MSH array
     33 D RESET^HLCSHDR3 ;HL*1.6*93
     34 ;
     35 ; patch HL*1.6*120 start
     36 ; escape delimiters for SERAPP and CLNTAPP
     37 ; escape component separator if the field is not consisted
     38 ; of 3 components
     39 S EC(1)=$E(EC,1)
     40 S EC(2)=$E(EC,2)
     41 S EC(3)=$E(EC,3)
     42 S EC(4)=$E(EC,4)
     43 S COMFLAG=1
     44 I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0
     45 I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D
     46 . S SERAPP=$$ESCAPE(SERAPP,COMFLAG)
     47 S COMFLAG=1
     48 I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0
     49 I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D
     50 . S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG)
     51 ; patch HL*1.6*120 end
     52 ;
     53 S HLHDRI=1,HLHDR(1)="MSH"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1))
     54 F X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D MSH(X)
     55 ;in preceeding line, "" is for sequence number - not supported
     56 Q
     57 ;
     58MSH(X) ;add X to HLHDR
     59 S:HLHDRL+$L(X)>245 HLHDRI=HLHDRI+1,HLHDR(HLHDRI)=""
     60 S HLHDR(HLHDRI)=HLHDR(HLHDRI)_FS_X,HLHDRL=$L(HLHDR(HLHDRI))
     61 Q
     62BHSHDR(IEN,CLIENT,HLERROR) ; Create Batch Header Segment
     63 ; The BHS has 12 segments, of which 4 are blank.
     64 ; INPUT: IEN - IEN of entry in file #772
     65 ; OUTPUT: HLHDR(1) and HLHDR(2) - the two lines with the 12 segs.
     66 ;   ready for adding to a message directly.
     67 N ACKTO,ACCACK,ACKMID,APPACK,BNAME,BSTATUS,BTACK,CHILD,CLNTAPP ;HL*1.6*80
     68 N CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID ;HL*1.6*80 - added HLPID
     69 N PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X ;HL*1.6*80
     70 N COMFLAG ; patch HL*1.6*120
     71 S HLERROR=""
     72 ;
     73 S HLPARAM=$$PARAM^HLCS2
     74 D VAR Q:$G(HLERROR)]""
     75 ; The following line commented by HL*1.6*72
     76 ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE)
     77 ;
     78 ;Append event type
     79 I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,2)_EVNTYPE,(ACKMID,BTACK)=""
     80 ;batch/name/id/type(#9)=null~process ID~msg type|evnt type~version~CA~AA
     81 S BNAME=$E(EC,1)_HLPID_$E(EC,1)_MSGTYPE_$E(EC,1)_$P(PROT,U,9)_$E(EC,1)_ACCACK_$E(EC,1)_APPACK ;HL*1.6*80
     82 ;for batch ACK
     83 I ACKTO D  S BTACK=X_$E(EC,1)_$P(BSTATUS,U,3)
     84 . ;get msg id and status of message that is being ACKed
     85 . S ACKMID=$P($G(^HLMA(ACKTO,0)),U,2),BSTATUS=$G(^HLMA(ACKTO,"P")) ;HL*1.6*80
     86 . ;set type of ACK based on status
     87 . S X=$S(ACKMID="":"AR",(BSTATUS>3)&(BSTATUS<8):"AE",1:"AA")
     88 ;
     89 D RESET^HLCSHDR3 ;HL*1.6*93
     90 ;
     91 ; patch HL*1.6*120 start
     92 ; escape delimiters for SERAPP and CLNTAPP
     93 ; escape component separator if the field is not consisted
     94 ; of 3 components
     95 S EC(1)=$E(EC,1)
     96 S EC(2)=$E(EC,2)
     97 S EC(3)=$E(EC,3)
     98 S EC(4)=$E(EC,4)
     99 S COMFLAG=1
     100 I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0
     101 I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D
     102 . S SERAPP=$$ESCAPE(SERAPP,COMFLAG)
     103 S COMFLAG=1
     104 I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0
     105 I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D
     106 . S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG)
     107 ; patch HL*1.6*120 end
     108 ;
     109 S HLHDRI=1,HLHDR(1)="BHS"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1))
     110 F X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,BNAME,BTACK,HLID,ACKMID D MSH(X)
     111 Q
     112VAR ;Check input
     113 N APPPRM,HLPROTS,HLPROT
     114 S IEN=+$G(IEN)
     115 I '$G(^HLMA(IEN,0)) S HLERROR="Valid pointer to Message Administration file (#772) not passed" Q
     116 I '$G(CLIENT) S HLERROR="Could not determine receiving application" Q
     117 ;Get child, text pointer,text entry, and sending app.
     118 S CHILD=$G(^HLMA(IEN,0)),SEND=+$P($G(^(0)),U,11),TXTP=+CHILD,TXTP0=$G(^HL(772,TXTP,0))
     119 I ('SEND) S HLERROR="Could not determine sending application" Q
     120 ;Get info for sending & receiving applications
     121 D APPPRM^HLUTIL2(CLIENT),APPPRM^HLUTIL2(SEND)
     122 ;Get name of sending application, facility, and country
     123 S SERAPP=$P(APPPRM(SEND,0),U),SERFAC=$P(APPPRM(SEND,0),U,2),CNTRY=$P(APPPRM(SEND,0),U,3)
     124 ;Get name of receiving application and facility
     125 S CLNTAPP=$P(APPPRM(CLIENT,0),U),CLNTFAC=$P(APPPRM(CLIENT,0),U,2)
     126 ;
     127 ; patch HL*1.6*120
     128 ; for dynamic addressing, overide the receiving facility from the
     129 ; 3rd component of HLL("LINKS") array
     130 I $G(HLP("REC-FACILITY"))]"" S CLNTFAC=HLP("REC-FACILITY")
     131 ;
     132 ;Get field separator & encoding characters
     133 S FS=APPPRM(SEND,"FS"),EC=APPPRM(SEND,"EC")
     134 S:(EC="") EC="~|\&" S:(FS="") FS="^"
     135 ;Determine if it's a response/ACK to another message
     136 S ACKTO=+$P(CHILD,U,10)
     137 ;subscriber protocol is from child (file 773)
     138 ;If response, get MType from subscriber
     139 S HLPROTS=+$P(CHILD,U,8)
     140 S PROTS=$$TYPE^HLUTIL2(HLPROTS)
     141 I ACKTO S MSGTYPE=$P(PROTS,U,10),EVNTYPE=$P(PROTS,U,3),MSGEVN=$P(PROTS,U,4)
     142 ;Get accept ack & application ack type (based on server protocol) it
     143 ; is always in file 772, TXPT0
     144 ;If original message, get MT from Event Driver Protocol
     145 S HLPROT=+$P(TXTP0,U,10)
     146 S PROT=$$TYPE^HLUTIL2(HLPROT)
     147 S:'ACKTO MSGTYPE=$P(PROT,U,2),EVNTYPE=$P(PROT,U,3),MSGEVN=$P(PROT,U,4)
     148 S ACCACK=$P(PROT,U,7),APPACK=$P(PROT,U,8)
     149PID ;Processing ID
     150 ;I PID not 'debug' get from site params
     151 ;If event driver set to 'debug' get from protocol
     152 ;'production' or 'training' comes from site params
     153 S HLPID=$P(PROT,U,5)
     154 I $G(HLPID)'="D" S HLPID=$P(HLPARAM,U,3)
     155 ;
     156 ; patch HL*1.6*120: to include processing mode
     157 I $G(HLP("PMOD"))]"",($G(HLTYPE)="M") D
     158 . S HLPID=HLPID_$E($G(EC),1)_HLP("PMOD")
     159 ;
     160 I $G(HLPID)="" S HLERROR="Missing processing ID Site parameter."
     161 ;acknowledgements have no application ack, link open no commit ack
     162 I ACKTO S:APPACK]"" APPACK="NE" S:ACCACK]""&$G(HLTCPO) ACCACK="NE"
     163 ;Get date/time, Message ID, and security
     164 S HLDATE=+TXTP0,HLDATE=$$FMTHL7^XLFDT(HLDATE),HLID=$P(CHILD,U,2),SECURITY=$P(CHILD,U,9)
     165HDR23 ;generate extended facility field info based on 'facility required'
     166 ;default format is INSTITUTION_HLCS_DOMAIN_HLCS_'DNS'
     167 ;application parameter entry overrides default
     168 N HLEP773,HLS773
     169 S SERFAC=$G(SERFAC),CLNTFAC=$G(CLNTFAC)
     170 S HLEP773=+$G(^ORD(101,HLPROTS,773))
     171 S HLS773=+$P($G(^ORD(101,HLPROTS,773)),U,2)
     172 Q:'HLEP773&('HLS773)
     173 D GEN^HLCSHDR2
     174 I ACKTO D  Q
     175 .;Find original message
     176 .S X=$G(^HLMA(ACKTO,"MSH",1,0)) ;Find header in TCP nodes
     177 .I X["MSH" D
     178 ..;
     179 ..; patch HL*1.6*120 start
     180 .. N HLEC
     181 ..S HLFS=$E(X,4),HLEC=$E(X,5)
     182 ..S SENDFAC=$P(X,HLFS,4),RECFAC=$P(X,HLFS,6) ;from original msg
     183 ..S CLNTFAC=SENDFAC,SERFAC=RECFAC ;reverse facility info
     184 ..S EC("COMPONENT")=$E($G(EC),1)
     185 ..I $L(EC("COMPONENT"))=1,$L(HLEC)=1,EC("COMPONENT")'=HLEC D
     186 ... ; change the the component separator in the sending and
     187 ... ; receiving facilities for the outgoing message
     188 ... S CLNTFAC=$TR(CLNTFAC,HLEC,EC("COMPONENT"))
     189 ... S SERFAC=$TR(SERFAC,HLEC,EC("COMPONENT"))
     190 ; patch HL*1.6*120 end
     191 ;
     192 I HLEP773,SERFAC="" D EP^HLCSHDR2
     193 I HLS773,CLNTFAC="" D S^HLCSHDR2
     194 Q
     195 ;
     196ESCAPE(INPUT,COMPONET) ;
     197 ; patch HL*1.6*120 - escape delimiters:
     198 ; - field separator
     199 ; - component separator
     200 ; - repetition separator
     201 ; - escape character
     202 ; - subcomponent separator
     203 ;
     204 ; input:
     205 ;     INPUT - string data to be escaped
     206 ;  COMPONET - if 1, escape component separator
     207 ;             if 0, do not escape component separator
     208 ;        FS - field separator character
     209 ;        EC - encoding characters
     210 ; result: return the escaped string
     211 ;
     212 N HLDATA,HLESCAPE,HLI,HLCHAR,HLEN,HLOUT,COMFLAG
     213 S HLDATA=$G(INPUT)
     214 S COMFLAG=$G(COMPONET)
     215 Q:$L($G(FS))'=1 HLDATA
     216 ;
     217 ; patch HL*1.6*133
     218 ; Q:$L($G(EC))'=4 HLDATA
     219 Q:($L($G(EC))<3) HLDATA
     220 Q:HLDATA']"" HLDATA
     221 ;
     222 S HLESCAPE=FS_EC
     223 S HLESCAPE("F")=FS
     224 S HLESCAPE("S")=$E(EC,1)
     225 S HLESCAPE("R")=$E(EC,2)
     226 S HLESCAPE("E")=$E(EC,3)
     227 S HLESCAPE("T")=$E(EC,4)
     228 S HLEN=$L(HLDATA)
     229 S HLOUT=""
     230 F HLI=1:1:HLEN D
     231 . S HLCHAR=$E(HLDATA,HLI)
     232 . I HLESCAPE[HLCHAR D  Q
     233 .. I HLCHAR=HLESCAPE("F") S HLOUT=HLOUT_HLESCAPE("E")_"F"_HLESCAPE("E") Q
     234 .. I HLCHAR=HLESCAPE("S") D  Q
     235 ... I COMFLAG=1 S HLOUT=HLOUT_HLESCAPE("E")_"S"_HLESCAPE("E") Q
     236 ... S HLOUT=HLOUT_HLCHAR
     237 .. I HLCHAR=HLESCAPE("R") S HLOUT=HLOUT_HLESCAPE("E")_"R"_HLESCAPE("E") Q
     238 .. I HLCHAR=HLESCAPE("E") S HLOUT=HLOUT_HLESCAPE("E")_"E"_HLESCAPE("E") Q
     239 .. I HLCHAR=HLESCAPE("T") S HLOUT=HLOUT_HLESCAPE("E")_"T"_HLESCAPE("E") Q
     240 . ;
     241 . S HLOUT=HLOUT_HLCHAR
     242 Q HLOUT
Note: See TracChangeset for help on using the changeset viewer.