HLTPCK2A ;SF/RSD - Message Header Validation (Con't) ;09/13/2006
;;1.6;HEALTH LEVEL SEVEN;**19,57,59,66,108,120,133**;Oct 13, 1995;Build 13
;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
I $E($G(MSA))="C" D Q
. ;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
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
HLTPCK2A ;SF/RSD - Message Header Validation (Con't) ;09/13/2006
+1 ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,66,108,120,133**;Oct 13, 1995;Build 13
+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 IF $EXTRACT($GET(MSA))="C"
Begin DoDot:1
+4 ;find original msg.
+5 SET ARY("MSAID")=$PIECE(MSA,FS,2)
SET ARY("MTIENS")=0
+6 IF ARY("MSAID")=""
IF (ERR="")
SET ERR="Invalid Message Control ID in MSA Segment - No Message ID "
QUIT
+7 FOR
SET ARY("MTIENS")=+$ORDER(^HLMA("C",ARY("MSAID"),ARY("MTIENS")))
IF 'ARY("MTIENS")!($PIECE($GET(^HLMA(ARY("MTIENS"),0)),U,3)="O")
QUIT
+8 IF 'ARY("MTIENS")
IF (ERR="")
SET ERR="Invalid Message Control ID in MSA Segment - No message IEN in ""C"" x-ref"
QUIT
+9 QUIT
End DoDot:1
QUIT
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 IF (ARY("VER")="")
IF (ERR="")
SET ERR="Missing HL7 Version"
QUIT
+2 SET X=0
+3 IF (ARY("VER")'="")
SET X=+$ORDER(^HL(771.5,"B",ARY("VER"),0))
+4 SET ARY("VEP")=X
+5 IF ('X)
IF (ERR="")
SET ERR="Invalid HL7 Version"
QUIT
+6 ;I (X'=$P($G(HLN(770)),"^",10)) S:(ERR="") ERR="Invalid HL7 Version for Receiving Application" Q
+7 ;
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
