- HLTPCK2A ;SF/RSD - Message Header Validation (Con't) ;09/24/2008 17:11
- ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,66,108,120,133,142**;Oct 13, 1995;Build 17
- ;Per VHA Directive 2004-038, this routine should not be modified.
- S ERR=""
- S HLPARAM=$$PARAM^HLCS2,HLDOM=$P(HLPARAM,U,2),HLINSTN=$P(HLPARAM,U,6)
- MT ;Validate message type
- I (ARY("MTN")="") S:(ERR="") ERR="Invalid Message Type" Q
- S ARY("MTP")=0
- S:(ARY("MTN")'="") ARY("MTP")=+$O(^HL(771.2,"B",ARY("MTN"),0))
- I ('ARY("MTP")) S:(ERR="") ERR="Invalid Message Type" Q
- ;
- AT ;Determine if message is an acknowledgement type
- I (("ACK,ADR,MCF,MFK,MFR,ORF,ORR,RRA,RRD,RRE,RRG,TBR"[ARY("MTN"))&($G(MSA)="")) S:(ERR="") ERR="MSA Segment Missing" Q
- ;commit ack, quit
- ; patch HL*1.6*142
- ; in order to get data for ien of sending application,
- ; receiving application, and subscriber protocol.
- ; I $E($G(MSA))="C" D Q
- I $E($G(MSA))="C" D
- . ;find original msg.
- . S ARY("MSAID")=$P(MSA,FS,2),ARY("MTIENS")=0
- . I ARY("MSAID")="" S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Message ID " Q
- . F S ARY("MTIENS")=+$O(^HLMA("C",ARY("MSAID"),ARY("MTIENS"))) Q:'ARY("MTIENS")!($P($G(^HLMA(ARY("MTIENS"),0)),U,3)="O")
- . I 'ARY("MTIENS") S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No message IEN in ""C"" x-ref" Q
- . Q
- AAT ;Validate accept ack type and application ack type
- I ($G(ARY("ACAT"))'="") I ("AL,NE,ER,SU"'[ARY("ACAT")) S:(ERR="") ERR="Invalid accept ack type" Q
- I ($G(ARY("APAT"))'="") I ("AL,NE,ER,SU"'[ARY("APAT")) S:(ERR="") ERR="Invalid application ack type" Q
- ;
- ;
- RA ;Validate receiving application
- I (ARY("RAN")']"") S:(ERR="") ERR="Invalid Receiving Application" Q
- S ARY("RAP")=0
- S:ARY("RAN")]"" ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN"),1,30),0))
- I 'ARY("RAP"),ARY("RAN")'="" D
- .S X=$$UPPER^HLFNC(ARY("RAN"))
- .S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN"),1,30),0))
- ;
- ; patch HL*1.6*120 start
- I ($L(ARY("RAN"),ECH(1))>1) D
- . S ARY("RAN-SUB1")=$P(ARY("RAN"),ECH(1))
- . S ARY("RAN-SUB2")=$P(ARY("RAN"),ECH(1),2)
- . S ARY("RAN-SUB3")=$P(ARY("RAN"),ECH(1),3)
- . I 'ARY("RAP"),ARY("RAN-SUB1")]"" D
- .. S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN-SUB1"),1,30),0))
- . I ARY("RAN-SUB1")[ECH(3) D
- .. S ARY("RAN-SUB1-DEESCAPE")=$$DEESCAPE(ARY("RAN-SUB1"))
- . I ARY("RAN-SUB2")[ECH(3) D
- .. S ARY("RAN-SUB2-DEESCAPE")=$$DEESCAPE(ARY("RAN-SUB2"))
- . I ARY("RAN-SUB3")[ECH(3) D
- .. S ARY("RAN-SUB3-DEESCAPE")=$$DEESCAPE(ARY("RAN-SUB3"))
- . I 'ARY("RAP"),$G(ARY("RAN-SUB1-DEESCAPE"))]"" D
- .. S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN-SUB1-DEESCAPE"),1,30),0))
- I ARY("RAN")[ECH(3) D
- . S ARY("RAN-DEESCAPE")=$$DEESCAPE(ARY("RAN"))
- I 'ARY("RAP"),$G(ARY("RAN-DEESCAPE"))]"" D
- . S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN-DEESCAPE"),1,30),0))
- ; patch HL*1.6*120 end
- ;
- I ('ARY("RAP")) S:(ERR="") ERR="Invalid Receiving Application" Q
- S X2=$G(^HL(771,ARY("RAP"),0))
- I (X2="") S:(ERR="") ERR="Invalid Receiving Application" Q
- I ($P(X2,"^",2)'="a") S:(ERR="") ERR="Receiving Application is Inactive" Q
- ;
- SA ;Validate sending application
- I (ARY("SAN")']"") S:(ERR="") ERR="Invalid Sending Application" Q
- S ARY("SAP")=0
- S:(ARY("SAN")]"") ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN"),1,30),0))
- I (('ARY("SAP"))&(ARY("SAN")'="")) D
- .S X=$$UPPER^HLFNC(ARY("SAN"))
- .S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN"),1,30),0))
- ;
- ; patch HL*1.6*120 start
- I ($L(ARY("SAN"),ECH(1))>1) D
- . S ARY("SAN-SUB1")=$P(ARY("SAN"),ECH(1))
- . S ARY("SAN-SUB2")=$P(ARY("SAN"),ECH(1),2)
- . S ARY("SAN-SUB3")=$P(ARY("SAN"),ECH(1),3)
- . I 'ARY("SAP"),ARY("SAN-SUB1")]"" D
- .. S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN-SUB1"),1,30),0))
- . I ARY("SAN-SUB1")[ECH(3) D
- .. S ARY("SAN-SUB1-DEESCAPE")=$$DEESCAPE(ARY("SAN-SUB1"))
- . I ARY("SAN-SUB2")[ECH(3) D
- .. S ARY("SAN-SUB2-DEESCAPE")=$$DEESCAPE(ARY("SAN-SUB2"))
- . I ARY("SAN-SUB3")[ECH(3) D
- .. S ARY("SAN-SUB3-DEESCAPE")=$$DEESCAPE(ARY("SAN-SUB3"))
- . I 'ARY("SAP"),$G(ARY("SAN-SUB1-DEESCAPE"))]"" D
- .. S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN-SUB1-DEESCAPE"),1,30),0))
- I ARY("SAN")[ECH(3) D
- . S ARY("SAN-DEESCAPE")=$$DEESCAPE(ARY("SAN"))
- I 'ARY("SAP"),$G(ARY("SAN-DEESCAPE"))]"" D
- . S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN-DEESCAPE"),1,30),0))
- ; patch HL*1.6*120 end
- ;
- I ('ARY("SAP")) S:(ERR="") ERR="Invalid Sending Application" Q
- ;
- VN ;Validate version number
- ; patch HL*1.6*142
- ; do not check version number of commit ACK because the batch commit ACK
- ; does not have version number in it.
- I $E($G(MSA))="C" G ET
- ;
- I (ARY("VER")="") S:(ERR="") ERR="Missing HL7 Version" Q
- S X=0
- S:(ARY("VER")'="") X=+$O(^HL(771.5,"B",ARY("VER"),0))
- S ARY("VEP")=X
- I ('X) S:(ERR="") ERR="Invalid HL7 Version" Q
- ;I (X'=$P($G(HLN(770)),"^",10)) S:(ERR="") ERR="Invalid HL7 Version for Receiving Application" Q
- ;
- ET ;Event Type Checks
- ;
- ;I ARY("ETN")="",ARY("VER")>2.1,$G(MSA)'="" D
- ;. ;N Z,ZEP,ZP
- ;. ;S Z=0 I $P(MSA,FS,2)]"" S Z=+$O(^HLMA("C",$P(MSA,FS,2),0))
- ;. ;I '$G(^HLMA(Z,0)) S:(ERR="") ERR="Original Outgoing Message not found" Q
- ;. ;S ZEP=$P(^HLMA(Z,0),U,8)
- ;. ;I 'ZEP S:(ERR="") ERR="Event Protocol pointer (field #773,8) missing" Q
- ;. ;S ZP=$G(^ORD(101,ZEP,770)),ARY("ETN")=$P($G(^HL(779.001,+$P(ZP,U,4),0)),U)
- ;
- ;Validate event type
- I (ARY("ETN")=""),ARY("VER")>2.1,$G(MSA)="" S ERR="Event Type Required" Q
- S ARY("ETP")=0
- S:(ARY("ETN")'="") ARY("ETP")=+$O(^HL(779.001,"B",ARY("ETN"),0))
- I $G(MSA)="",ARY("VER")>2.1,('ARY("ETP")) S ERR="Invalid Event Type" Q
- ;
- D ^HLTPCK2B
- Q
- DEESCAPE(INPUT) ;
- ; patch HL*1.6*120 - de-escape delimiters
- ; (assuming "\" is the escape character):
- ; - field separator (de-escape from \F\)
- ; - component separator (de-escape from \S\)
- ; - repetition separator (de-escape from \R\)
- ; - escape character (de-escape from \E\)
- ; - subcomponent separator (de-escape from \T\)
- ; \F\ will be de-escaped only if the length of FS is 1.
- ;
- ; input:
- ; INPUT - input string to be de-escaped
- ; FS - field separator
- ; ECH - encoding characters
- ;
- ; output: de-escaped string
- ;
- N HLDATA,HLESCAPE,HLI,HLCHAR,HLCHAR23,HLEN,HLOUT
- S HLDATA=$G(INPUT)
- Q:HLDATA']"" HLDATA
- ;
- ; patch HL*1.6*133
- Q:$L($G(ECH))<3 HLDATA
- ;
- S ECH(1)=$E(ECH,1)
- S ECH(2)=$E(ECH,2)
- S ECH(3)=$E(ECH,3)
- S ECH(4)=$E(ECH,4)
- ;
- S HLEN=$L(HLDATA)
- S HLOUT=""
- F HLI=1:1:HLEN D
- . S HLCHAR=$E(HLDATA,HLI)
- . I HLCHAR=ECH(3) D
- . S HLCHAR23=$E(HLDATA,HLI+1,HLI+2)
- . I $L($G(FS))=1,(HLCHAR23=("F"_ECH(3))) D Q
- .. S HLOUT=HLOUT_FS
- .. S HLI=HLI+2
- . I HLCHAR23=("S"_ECH(3)) D Q
- .. S HLOUT=HLOUT_ECH(1)
- .. S HLI=HLI+2
- . I HLCHAR23=("R"_ECH(3)) D Q
- .. S HLOUT=HLOUT_ECH(2)
- .. S HLI=HLI+2
- . I HLCHAR23=("E"_ECH(3)) D Q
- .. S HLOUT=HLOUT_ECH(3)
- .. S HLI=HLI+2
- . I $L($G(ECH))>3,(HLCHAR23=("T"_ECH(3))) D Q
- .. S HLOUT=HLOUT_ECH(4)
- .. S HLI=HLI+2
- . S HLOUT=HLOUT_HLCHAR
- ;
- Q HLOUT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLTPCK2A 6921 printed Mar 13, 2025@21:05:01 Page 2
- HLTPCK2A ;SF/RSD - Message Header Validation (Con't) ;09/24/2008 17:11
- +1 ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,66,108,120,133,142**;Oct 13, 1995;Build 17
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 SET ERR=""
- +4 SET HLPARAM=$$PARAM^HLCS2
- SET HLDOM=$PIECE(HLPARAM,U,2)
- SET HLINSTN=$PIECE(HLPARAM,U,6)
- MT ;Validate message type
- +1 IF (ARY("MTN")="")
- if (ERR="")
- SET ERR="Invalid Message Type"
- QUIT
- +2 SET ARY("MTP")=0
- +3 if (ARY("MTN")'="")
- SET ARY("MTP")=+$ORDER(^HL(771.2,"B",ARY("MTN"),0))
- +4 IF ('ARY("MTP"))
- if (ERR="")
- SET ERR="Invalid Message Type"
- QUIT
- +5 ;
- AT ;Determine if message is an acknowledgement type
- +1 IF (("ACK,ADR,MCF,MFK,MFR,ORF,ORR,RRA,RRD,RRE,RRG,TBR"[ARY("MTN"))&($GET(MSA)=""))
- if (ERR="")
- SET ERR="MSA Segment Missing"
- QUIT
- +2 ;commit ack, quit
- +3 ; patch HL*1.6*142
- +4 ; in order to get data for ien of sending application,
- +5 ; receiving application, and subscriber protocol.
- +6 ; I $E($G(MSA))="C" D Q
- +7 IF $EXTRACT($GET(MSA))="C"
- Begin DoDot:1
- +8 ;find original msg.
- +9 SET ARY("MSAID")=$PIECE(MSA,FS,2)
- SET ARY("MTIENS")=0
- +10 IF ARY("MSAID")=""
- if (ERR="")
- SET ERR="Invalid Message Control ID in MSA Segment - No Message ID "
- QUIT
- +11 FOR
- SET ARY("MTIENS")=+$ORDER(^HLMA("C",ARY("MSAID"),ARY("MTIENS")))
- if 'ARY("MTIENS")!($PIECE($GET(^HLMA(ARY("MTIENS"),0)),U,3)="O")
- QUIT
- +12 IF 'ARY("MTIENS")
- if (ERR="")
- SET ERR="Invalid Message Control ID in MSA Segment - No message IEN in ""C"" x-ref"
- QUIT
- +13 QUIT
- End DoDot:1
- AAT ;Validate accept ack type and application ack type
- +1 IF ($GET(ARY("ACAT"))'="")
- IF ("AL,NE,ER,SU"'[ARY("ACAT"))
- if (ERR="")
- SET ERR="Invalid accept ack type"
- QUIT
- +2 IF ($GET(ARY("APAT"))'="")
- IF ("AL,NE,ER,SU"'[ARY("APAT"))
- if (ERR="")
- SET ERR="Invalid application ack type"
- QUIT
- +3 ;
- +4 ;
- RA ;Validate receiving application
- +1 IF (ARY("RAN")']"")
- if (ERR="")
- SET ERR="Invalid Receiving Application"
- QUIT
- +2 SET ARY("RAP")=0
- +3 if ARY("RAN")]""
- SET ARY("RAP")=+$ORDER(^HL(771,"B",$EXTRACT(ARY("RAN"),1,30),0))
- +4 IF 'ARY("RAP")
- IF ARY("RAN")'=""
- Begin DoDot:1
- +5 SET X=$$UPPER^HLFNC(ARY("RAN"))
- +6 SET ARY("RAP")=+$ORDER(^HL(771,"B",$EXTRACT(ARY("RAN"),1,30),0))
- End DoDot:1
- +7 ;
- +8 ; patch HL*1.6*120 start
- +9 IF ($LENGTH(ARY("RAN"),ECH(1))>1)
- Begin DoDot:1
- +10 SET ARY("RAN-SUB1")=$PIECE(ARY("RAN"),ECH(1))
- +11 SET ARY("RAN-SUB2")=$PIECE(ARY("RAN"),ECH(1),2)
- +12 SET ARY("RAN-SUB3")=$PIECE(ARY("RAN"),ECH(1),3)
- +13 IF 'ARY("RAP")
- IF ARY("RAN-SUB1")]""
- Begin DoDot:2
- +14 SET ARY("RAP")=+$ORDER(^HL(771,"B",$EXTRACT(ARY("RAN-SUB1"),1,30),0))
- End DoDot:2
- +15 IF ARY("RAN-SUB1")[ECH(3)
- Begin DoDot:2
- +16 SET ARY("RAN-SUB1-DEESCAPE")=$$DEESCAPE(ARY("RAN-SUB1"))
- End DoDot:2
- +17 IF ARY("RAN-SUB2")[ECH(3)
- Begin DoDot:2
- +18 SET ARY("RAN-SUB2-DEESCAPE")=$$DEESCAPE(ARY("RAN-SUB2"))
- End DoDot:2
- +19 IF ARY("RAN-SUB3")[ECH(3)
- Begin DoDot:2
- +20 SET ARY("RAN-SUB3-DEESCAPE")=$$DEESCAPE(ARY("RAN-SUB3"))
- End DoDot:2
- +21 IF 'ARY("RAP")
- IF $GET(ARY("RAN-SUB1-DEESCAPE"))]""
- Begin DoDot:2
- +22 SET ARY("RAP")=+$ORDER(^HL(771,"B",$EXTRACT(ARY("RAN-SUB1-DEESCAPE"),1,30),0))
- End DoDot:2
- End DoDot:1
- +23 IF ARY("RAN")[ECH(3)
- Begin DoDot:1
- +24 SET ARY("RAN-DEESCAPE")=$$DEESCAPE(ARY("RAN"))
- End DoDot:1
- +25 IF 'ARY("RAP")
- IF $GET(ARY("RAN-DEESCAPE"))]""
- Begin DoDot:1
- +26 SET ARY("RAP")=+$ORDER(^HL(771,"B",$EXTRACT(ARY("RAN-DEESCAPE"),1,30),0))
- End DoDot:1
- +27 ; patch HL*1.6*120 end
- +28 ;
- +29 IF ('ARY("RAP"))
- if (ERR="")
- SET ERR="Invalid Receiving Application"
- QUIT
- +30 SET X2=$GET(^HL(771,ARY("RAP"),0))
- +31 IF (X2="")
- if (ERR="")
- SET ERR="Invalid Receiving Application"
- QUIT
- +32 IF ($PIECE(X2,"^",2)'="a")
- if (ERR="")
- SET ERR="Receiving Application is Inactive"
- QUIT
- +33 ;
- SA ;Validate sending application
- +1 IF (ARY("SAN")']"")
- if (ERR="")
- SET ERR="Invalid Sending Application"
- QUIT
- +2 SET ARY("SAP")=0
- +3 if (ARY("SAN")]"")
- SET ARY("SAP")=+$ORDER(^HL(771,"B",$EXTRACT(ARY("SAN"),1,30),0))
- +4 IF (('ARY("SAP"))&(ARY("SAN")'=""))
- Begin DoDot:1
- +5 SET X=$$UPPER^HLFNC(ARY("SAN"))
- +6 SET ARY("SAP")=+$ORDER(^HL(771,"B",$EXTRACT(ARY("SAN"),1,30),0))
- End DoDot:1
- +7 ;
- +8 ; patch HL*1.6*120 start
- +9 IF ($LENGTH(ARY("SAN"),ECH(1))>1)
- Begin DoDot:1
- +10 SET ARY("SAN-SUB1")=$PIECE(ARY("SAN"),ECH(1))
- +11 SET ARY("SAN-SUB2")=$PIECE(ARY("SAN"),ECH(1),2)
- +12 SET ARY("SAN-SUB3")=$PIECE(ARY("SAN"),ECH(1),3)
- +13 IF 'ARY("SAP")
- IF ARY("SAN-SUB1")]""
- Begin DoDot:2
- +14 SET ARY("SAP")=+$ORDER(^HL(771,"B",$EXTRACT(ARY("SAN-SUB1"),1,30),0))
- End DoDot:2
- +15 IF ARY("SAN-SUB1")[ECH(3)
- Begin DoDot:2
- +16 SET ARY("SAN-SUB1-DEESCAPE")=$$DEESCAPE(ARY("SAN-SUB1"))
- End DoDot:2
- +17 IF ARY("SAN-SUB2")[ECH(3)
- Begin DoDot:2
- +18 SET ARY("SAN-SUB2-DEESCAPE")=$$DEESCAPE(ARY("SAN-SUB2"))
- End DoDot:2
- +19 IF ARY("SAN-SUB3")[ECH(3)
- Begin DoDot:2
- +20 SET ARY("SAN-SUB3-DEESCAPE")=$$DEESCAPE(ARY("SAN-SUB3"))
- End DoDot:2
- +21 IF 'ARY("SAP")
- IF $GET(ARY("SAN-SUB1-DEESCAPE"))]""
- Begin DoDot:2
- +22 SET ARY("SAP")=+$ORDER(^HL(771,"B",$EXTRACT(ARY("SAN-SUB1-DEESCAPE"),1,30),0))
- End DoDot:2
- End DoDot:1
- +23 IF ARY("SAN")[ECH(3)
- Begin DoDot:1
- +24 SET ARY("SAN-DEESCAPE")=$$DEESCAPE(ARY("SAN"))
- End DoDot:1
- +25 IF 'ARY("SAP")
- IF $GET(ARY("SAN-DEESCAPE"))]""
- Begin DoDot:1
- +26 SET ARY("SAP")=+$ORDER(^HL(771,"B",$EXTRACT(ARY("SAN-DEESCAPE"),1,30),0))
- End DoDot:1
- +27 ; patch HL*1.6*120 end
- +28 ;
- +29 IF ('ARY("SAP"))
- if (ERR="")
- SET ERR="Invalid Sending Application"
- QUIT
- +30 ;
- VN ;Validate version number
- +1 ; patch HL*1.6*142
- +2 ; do not check version number of commit ACK because the batch commit ACK
- +3 ; does not have version number in it.
- +4 IF $EXTRACT($GET(MSA))="C"
- GOTO ET
- +5 ;
- +6 IF (ARY("VER")="")
- if (ERR="")
- SET ERR="Missing HL7 Version"
- QUIT
- +7 SET X=0
- +8 if (ARY("VER")'="")
- SET X=+$ORDER(^HL(771.5,"B",ARY("VER"),0))
- +9 SET ARY("VEP")=X
- +10 IF ('X)
- if (ERR="")
- SET ERR="Invalid HL7 Version"
- QUIT
- +11 ;I (X'=$P($G(HLN(770)),"^",10)) S:(ERR="") ERR="Invalid HL7 Version for Receiving Application" Q
- +12 ;
- ET ;Event Type Checks
- +1 ;
- +2 ;I ARY("ETN")="",ARY("VER")>2.1,$G(MSA)'="" D
- +3 ;. ;N Z,ZEP,ZP
- +4 ;. ;S Z=0 I $P(MSA,FS,2)]"" S Z=+$O(^HLMA("C",$P(MSA,FS,2),0))
- +5 ;. ;I '$G(^HLMA(Z,0)) S:(ERR="") ERR="Original Outgoing Message not found" Q
- +6 ;. ;S ZEP=$P(^HLMA(Z,0),U,8)
- +7 ;. ;I 'ZEP S:(ERR="") ERR="Event Protocol pointer (field #773,8) missing" Q
- +8 ;. ;S ZP=$G(^ORD(101,ZEP,770)),ARY("ETN")=$P($G(^HL(779.001,+$P(ZP,U,4),0)),U)
- +9 ;
- +10 ;Validate event type
- +11 IF (ARY("ETN")="")
- IF ARY("VER")>2.1
- IF $GET(MSA)=""
- SET ERR="Event Type Required"
- QUIT
- +12 SET ARY("ETP")=0
- +13 if (ARY("ETN")'="")
- SET ARY("ETP")=+$ORDER(^HL(779.001,"B",ARY("ETN"),0))
- +14 IF $GET(MSA)=""
- IF ARY("VER")>2.1
- IF ('ARY("ETP"))
- SET ERR="Invalid Event Type"
- QUIT
- +15 ;
- +16 DO ^HLTPCK2B
- +17 QUIT
- DEESCAPE(INPUT) ;
- +1 ; patch HL*1.6*120 - de-escape delimiters
- +2 ; (assuming "\" is the escape character):
- +3 ; - field separator (de-escape from \F\)
- +4 ; - component separator (de-escape from \S\)
- +5 ; - repetition separator (de-escape from \R\)
- +6 ; - escape character (de-escape from \E\)
- +7 ; - subcomponent separator (de-escape from \T\)
- +8 ; \F\ will be de-escaped only if the length of FS is 1.
- +9 ;
- +10 ; input:
- +11 ; INPUT - input string to be de-escaped
- +12 ; FS - field separator
- +13 ; ECH - encoding characters
- +14 ;
- +15 ; output: de-escaped string
- +16 ;
- +17 NEW HLDATA,HLESCAPE,HLI,HLCHAR,HLCHAR23,HLEN,HLOUT
- +18 SET HLDATA=$GET(INPUT)
- +19 if HLDATA']""
- QUIT HLDATA
- +20 ;
- +21 ; patch HL*1.6*133
- +22 if $LENGTH($GET(ECH))<3
- QUIT HLDATA
- +23 ;
- +24 SET ECH(1)=$EXTRACT(ECH,1)
- +25 SET ECH(2)=$EXTRACT(ECH,2)
- +26 SET ECH(3)=$EXTRACT(ECH,3)
- +27 SET ECH(4)=$EXTRACT(ECH,4)
- +28 ;
- +29 SET HLEN=$LENGTH(HLDATA)
- +30 SET HLOUT=""
- +31 FOR HLI=1:1:HLEN
- Begin DoDot:1
- +32 SET HLCHAR=$EXTRACT(HLDATA,HLI)
- +33 IF HLCHAR=ECH(3)
- Begin DoDot:2
- End DoDot:2
- +34 SET HLCHAR23=$EXTRACT(HLDATA,HLI+1,HLI+2)
- +35 IF $LENGTH($GET(FS))=1
- IF (HLCHAR23=("F"_ECH(3)))
- Begin DoDot:2
- +36 SET HLOUT=HLOUT_FS
- +37 SET HLI=HLI+2
- End DoDot:2
- QUIT
- +38 IF HLCHAR23=("S"_ECH(3))
- Begin DoDot:2
- +39 SET HLOUT=HLOUT_ECH(1)
- +40 SET HLI=HLI+2
- End DoDot:2
- QUIT
- +41 IF HLCHAR23=("R"_ECH(3))
- Begin DoDot:2
- +42 SET HLOUT=HLOUT_ECH(2)
- +43 SET HLI=HLI+2
- End DoDot:2
- QUIT
- +44 IF HLCHAR23=("E"_ECH(3))
- Begin DoDot:2
- +45 SET HLOUT=HLOUT_ECH(3)
- +46 SET HLI=HLI+2
- End DoDot:2
- QUIT
- +47 IF $LENGTH($GET(ECH))>3
- IF (HLCHAR23=("T"_ECH(3)))
- Begin DoDot:2
- +48 SET HLOUT=HLOUT_ECH(4)
- +49 SET HLI=HLI+2
- End DoDot:2
- QUIT
- +50 SET HLOUT=HLOUT_HLCHAR
- End DoDot:1
- +51 ;
- +52 QUIT HLOUT
