Search code examples
delphisyntax-highlightinghl7edisynedit

Synedit syntax-highlighter for HL7 v2.x messages

I am looking at contributing to the Delphi SynEdit project with a syntax-highlighter for the Health Level 7 (HL7) v2 messaging Standard. I have no experience of creating a highlighter from scratch and there are two quirks that I have stumbled upon that differ from existing highlighters:

  • Fixed position keywords - first three characters of every line
  • Delimiters are defined in the begining of the message

Is there anyone out there who has any SynEdit experice with HL7 or similar syntaxes e.g. Edifact, X12?

Prototype

I've created a crude prototype using the OnPaintTransient event-handler which in fact works better than I anticipated :-) Basically it does the following:

  • Highlight each Segment ID navy-blue - first three characters on ever line. No checking done if the value is a valid segment.
  • Highlight all field delimiters grey - defined as the fourth character in MSH segment
  • Highlight all other delimiters blue - defined in the field called Encoding Characters, which is the first field after the MSH segment ID.
  • The delimiter values used in the MSH segment are the delimiter values used throughout the entire message.
  • skip highlighting if underlying text is selected - looks prettier in my implementation.

Below is a screen-dump of the results when inserting the example message found at Wikipedia http://en.wikipedia.org/wiki/Health_Level_7 into a TSynMemo component.

Screen-dump SynEdit HL7 syntax-highlighting

Code OnPaintTransient

procedure TFormMain.SynMemoMsgPaintTransient(Sender: TObject; Canvas: TCanvas;
  TransientType: TTransientType);
var
  i, j: Integer;

  DP: TDisplayCoord;
  SelStartCoord, SelEndCoord, BC : TBufferCoord;
  Pt: TPoint;

  FieldDelimiter : char;  // MSH|
  Delimiters : string;    // All message delimiters (including field delimiter)
  IsSelected : boolean;
begin
  //Avoid drawing twice - Only enter if TransientType = ttAfter.
  if TransientType = ttBefore then exit;

  //Exit if no text
  if SynMemoMsg.Lines.Count = 0 then exit;

  //Exit if message does not start with MSH (Message header segment)
  if not AnsiStartsText('MSH', SynMemoMsg.Lines[0]) then exit;

  //Get the message's delimiters specified as the characters directly after MSH
  FieldDelimiter := Copy(SynMemoMsg.Lines[0], 4, 1)[1];
  Delimiters :=  Copy(SynMemoMsg.Lines[0], 4, 5);

  //Find out if any text is selected by the user - we will exclude this text from highlighting
  SelStartCoord := SynMemoMsg.CharIndexToRowCol(SynMemoMsg.SelStart);
  SelEndCoord := SynMemoMsg.CharIndexToRowCol(SynMemoMsg.SelEnd);

  //parse evry visible line
  for i := SynMemoMsg.TopLine to ((SynMemoMsg.TopLine + SynMemoMsg.LinesInWindow )-1) do
  begin
    //Highlight Segment ID, i.e. in this implementation the first 3 chars in each line
    BC.Char := 1;
    BC.Line := i;

    //If whole line is selected then continue to next line without highlighting current
    if (SelStartCoord.Line < BC.Line) and (SelEndCoord.Line > BC.Line) then continue;

    DP := SynMemoMsg.BufferToDisplayPos(BC);
    Pt := SynMemoMsg.RowColumnToPixels(DP);

    if ((SelStartCoord.Line = BC.Line) and (SelStartCoord.Char > 3))
       or ((SelStartCoord.Line <> BC.Line) and (SelEndCoord.Line <> BC.Line))
       or (SynMemoMsg.SelLength = 0) then
    begin
      Canvas.Font.Color := clNavy;
      Canvas.Font.Style := [fsBold];
      Canvas.TextOut (Pt.X - 1, Pt.Y, Copy(SynMemoMsg.Lines[i - 1], 1, 3)); //Move the Bold text one pixel left to get space i.e. Pt.X - 1)
    end;

    //Highlight Delimiters - parse each charachter and check if delimiter and not selected
    for j := 4 to Length(SynMemoMsg.Lines[i - 1]) do
    begin
      if IsDelimiter(Delimiters, SynMemoMsg.Lines[i - 1], j) then
      begin
        BC.Char := j;
        BC.Line := i;

        //Don't highlight delimiter if selected
        if (SynMemoMsg.SelLength > 0) and ((SelStartCoord.Line = BC.Line)or (SelEndCoord.Line = BC.Line)) then
        begin

          if (SelStartCoord.Line = BC.Line) and (SelEndCoord.Line = BC.Line) then
            IsSelected := (SelStartCoord.Char <= BC.Char) and (SelEndCoord.Char > BC.Char)
          else if (SelStartCoord.Line = BC.Line) then
            IsSelected := SelStartCoord.Char <= BC.Char
          else if (SelEndCoord.Line = BC.Line) then
            IsSelected := SelEndCoord.Char > BC.Char;
        end
        else
          IsSelected := false;

        if not IsSelected then begin
          DP := SynMemoMsg.BufferToDisplayPos(BC);
          Pt := SynMemoMsg.RowColumnToPixels(DP);

          if FieldDelimiter = SynMemoMsg.Lines[i - 1][j] then
            Canvas.Font.Color := clGray
          else
            Canvas.Font.Color := clBlue;

          Canvas.TextOut (Pt.X, Pt.Y, Copy(SynMemoMsg.Lines[i - 1], j, 1));
        end;
      end;
    end;
  end;
end;
Solution

  • Well I ended up making my own SynEdit syntax-highlighter for HL7 v2.x messaging. It may not have all the bells and whistles but it’s a good start. My implementation uses Delphi XE3.

    Usage:

    1. Copy the SynHighlighterHL7.pas unit found below to your synedit project source folder.
    2. Add SynHighlighterHL7.pas to your project and to the Uses clause.
    3. Add a TSynEdit or TSynMemo component to a form
    4. Add the following code to the form's OnCreate event handler:

    Code:

    fSynHL7Syn := TSynHL7Syn.Create(Self);
SynMemoMsg.Highlighter := fSynHL7Syn;

    SynHighlighterHL7.pas unit:

    unit SynHighlighterHL7;

{$I SynEdit.inc}

interface

uses
    Classes,
    Graphics,
    StrUtils,
    SynEditTypes,
    SynEditHighlighter,
    SynUnicode;

const
  DEF_FIELD_DELIM   = '|'; //Filed seperator
  DEF_COMP_DELIM    = '^'; //Component seperator
  DEF_SUBCOMP_DELIM = '&'; //Sub-component seperator
  DEF_ESC_DELIM     = '\'; //Escape seperator
  DEF_REP_DELIM     = '~'; //Repetition seperator

type
  TtkTokenKind = (tkSegmentID, tkFieldDelim, tkCompDelim, tkSubCompDelim,
                  tkEscDelim, tkRepDelim, tkText, tkSpace, tkNull, tkUnknown);

  //Keeps track if we're in a message with properly defined delimiters
  TRangeState = (rsUnknown, rsMshDelim, rsDefDelim);

type
  TSynHL7Syn = class(TSynCustomHighlighter)
  private
    fRange : TRangeState;
    fFieldDelim : char;
    fCompDelim : char;
    fSubCompDelim : char;
    fEscDelim : char;
    fRepDelim : char;

    FTokenID: TtkTokenKind;

    fSegmentIDAttri: TSynHighlighterAttributes;
    fFieldDelimAttri: TSynHighlighterAttributes;
    fCompDelimAttri: TSynHighlighterAttributes;
    fSubCompDelimAttri: TSynHighlighterAttributes;
    fEscDelimAttri: TSynHighlighterAttributes;
    fRepDelimAttri: TSynHighlighterAttributes;
    fUnknownAttri: TSynHighlighterAttributes;
    fSpaceAttri : TSynHighlighterAttributes;
    fTextAttri: TSynHighlighterAttributes;
    procedure SegmentIDProc;
    procedure UnknownProc;

    procedure CRProc;
    procedure TextProc;
    procedure LFProc;
    procedure NullProc;
    procedure SpaceProc;
    procedure FieldDelimProc;
    procedure CompDelimProc;
    procedure EscDelimProc;
    procedure RepDelimProc;
    procedure SubCompDelimProc;
    procedure SetRangeState(const Line: string);
  protected
    function GetSampleSource: UnicodeString; override;
    function IsFilterStored: Boolean; override;
  public
    function GetRange: Pointer; override;
    procedure ResetRange; override;
    procedure SetRange(Value: Pointer); override;

    class function GetLanguageName: string; override;
    class function GetFriendlyLanguageName: UnicodeString; override;
  public
    constructor Create(AOwner: TComponent); override;
    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;
      override;
    function GetEol: Boolean; override;
    function GetTokenID: TtkTokenKind;
    function GetTokenAttribute: TSynHighlighterAttributes; override;
    function GetTokenKind: integer; override;
    procedure Next; override;
  published
    property SegmentIDAttri: TSynHighlighterAttributes read fSegmentIDAttri
      write fSegmentIDAttri;
    property TextAttri: TSynHighlighterAttributes read fTextAttri
      write fTextAttri;

  end;

implementation

uses
  SynEditStrConst;

constructor TSynHL7Syn.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  fCaseSensitive := true;

  fSegmentIDAttri := TSynHighlighterAttributes.Create('Seg ID', 'Segment ID');
  fSegmentIDAttri.Style := [fsBold];
  fSegmentIDAttri.Foreground := clNavy;
  AddAttribute(fSegmentIDAttri);


  fFieldDelimAttri := TSynHighlighterAttributes.Create('Field Sep', 'Field Seperator (|)');
  fFieldDelimAttri.Foreground := clGray;
  AddAttribute(fFieldDelimAttri);

  fCompDelimAttri := TSynHighlighterAttributes.Create('Comp Sep', 'Component Seperator (^)');
  fCompDelimAttri.Foreground := clBlue;
  AddAttribute(fCompDelimAttri);

  fSubCompDelimAttri := TSynHighlighterAttributes.Create('Sub-Comp Sep', 'Sub-Component Seperator (&)');
  fSubCompDelimAttri.Foreground := clBlue;
  AddAttribute(fSubCompDelimAttri);

  fRepDelimAttri := TSynHighlighterAttributes.Create('Rep Sep', 'Repeat Seperator (&)');
  fRepDelimAttri.Foreground := clBlue;
  AddAttribute(fRepDelimAttri);

  fEscDelimAttri := TSynHighlighterAttributes.Create('Esc Sep', 'Escape Seperator (\)');
  fEscDelimAttri.Style := [fsBold];
  fEscDelimAttri.Foreground := clGreen;
  AddAttribute(fEscDelimAttri);

  fUnknownAttri := TSynHighlighterAttributes.Create('Unknown', 'Non HL7 message i.e arbitary text');
  fUnknownAttri.Style := [fsItalic];
  fUnknownAttri.Foreground := clRed;
  AddAttribute(fUnknownAttri);

  fTextAttri := TSynHighlighterAttributes.Create(SYNS_AttrText, SYNS_FriendlyAttrText);
  AddAttribute(fTextAttri);

  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);
  AddAttribute(fSpaceAttri);
  SetAttributesOnChange(DefHighlightChange);

  fDefaultFilter := SYNS_FilterINI;
end; { Create }

procedure TSynHL7Syn.FieldDelimProc;
begin
  inc(Run);
  fTokenID := tkFieldDelim;
end;

procedure TSynHL7Syn.CompDelimProc;
begin
  inc(Run);
  fTokenID := tkCompDelim;
end;

procedure TSynHL7Syn.SubCompDelimProc;
begin
  inc(Run);
  fTokenID := tkSubCompDelim;
end;

procedure TSynHL7Syn.EscDelimProc;
begin
  fTokenID := tkEscDelim;

  //If current position is not the first MSH field then expand token untill
  //closing Escape delimiter is found on current line
  if not((Run = 6) and StartsStr('MSH', fLine)) then begin
     inc(run);
     while (FLine[Run] <> fEscDelim) and (FLine[Run] <> #0) do
       inc(Run);

  end;
  if FLine[Run] <> #0 then
     inc(Run);

end;

procedure TSynHL7Syn.RepDelimProc;
begin
  inc(Run);
  fTokenID := tkRepDelim;
end;

procedure TSynHL7Syn.SetRangeState(const Line : string);
  function IsValidSegmentIDChar(c : char): Boolean;
  begin
    case c of
      'A'..'Z', '0'..'9':
        Result := True;
      else
        Result := False;
    end;
  end;
var SegID : string;
    OK : boolean;
    i : integer;
begin
  //Decide if valid segment or arbitary text
  if AnsiStartsStr('MSH', Line) and (Length(Line) > 8) then begin
    fRange := rsMshDelim;

    fFieldDelim   := Line[4];
    fCompDelim    := Line[5];
    fRepDelim     := Line[6];

    //If no escape characters are used in a message, this character may be omitted.
    //However, it must be present if subcomponents are used in the message.
    if Line[7] <> fFieldDelim then
       fEscDelim     := Line[7]
    else
       fEscDelim := DEF_ESC_DELIM;

    //If there are no subcomponents in message then this seperator may not be present (use default then)
    if Line[8] <> fFieldDelim then
       fSubCompDelim     := Line[8]
    else
       fEscDelim := DEF_SUBCOMP_DELIM;
  end
  else begin

    SegID := Copy(FLine, run + 1, 3);
    OK := Length(SegID) = 3;
    for i := 1 to Length(SegID) do
        OK := OK and IsValidSegmentIDChar(SegID[i]);

    if OK then begin
       case fRange of
          rsUnknown : if (Copy(Line, 4, 1) = '|') then fRange := rsDefDelim;
          rsMshDelim : if (Copy(Line, 4, 1) <> fFieldDelim) then fRange := rsUnknown;
          rsDefDelim : if (Copy(Line, 4, 1) <> '|') then fRange := rsUnknown;
       end;
    end
    else
      fRange := rsUnknown;
  end;
end;

procedure TSynHL7Syn.ResetRange;
begin
  fRange:= rsUnknown;
end;

procedure TSynHL7Syn.SegmentIDProc;
  function IsValidSegmentIDChar(c : char): Boolean;
  begin
    case c of
      'A'..'Z', '0'..'9':
        Result := True;
      else
        Result := False;
    end;
  end;

var OK : boolean;
    SegID : String;
    i : integer;
begin
  // if it is not column 0-2 mark as tkText and get out of here
  if Run > 0 then
  begin
    fTokenID := tkText;
    inc(Run);
    Exit;
  end;

  case fRange of
    rsMshDelim, rsDefDelim : begin
                               fTokenID := tkSegmentID;
                               Run := 3;
                             end;
    rsUnknown : begin
                  fTokenID := tkUnknown;
                  Inc(Run);
                end;
  end;
end;

procedure TSynHL7Syn.CRProc;
begin
  fTokenID := tkSpace;
  case FLine[Run + 1] of
    #10: inc(Run, 2);
    else inc(Run);
  end;
end;

procedure TSynHL7Syn.TextProc;

  function IsTextChar: Boolean;
  begin
    case fLine[Run] of
      'a'..'z', 'A'..'Z', '0'..'9':
        Result := True;
      else
        Result := False;
    end;
  end;

begin
  if Run = 0 then
    SegmentIDProc
  else
  begin
    fTokenID := tkText;
    inc(Run);
    while FLine[Run] <> #0 do
      if IsTextChar then
        inc(Run)
      else
        break;
  end;
end;

procedure TSynHL7Syn.UnknownProc;
begin
  if Run = 0 then
    Self.SetRangeState(fLine);

  // this is column 0 ok it is a comment
  fTokenID := tkUnknown;
  inc(Run);
  while FLine[Run] <> #0 do
    case FLine[Run] of
      #10: break;
      #13: break;
      else inc(Run);
    end;
end;

procedure TSynHL7Syn.LFProc;
begin
  fTokenID := tkSpace;
  inc(Run);
end;


procedure TSynHL7Syn.SetRange(Value: Pointer);
begin
  fRange := TRangeState(Value);
end;

procedure TSynHL7Syn.SpaceProc;
begin
  inc(Run);
  fTokenID := tkSpace;
  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);
end;

procedure TSynHL7Syn.Next;
begin
  //Decide range state by checking first char in line
  fTokenPos := Run;
  if Run = 0 then SetRangeState(fLine);

  case fRange of
    rsUnknown :  case fLine[Run] of
                    #0: NullProc;
                    #10: LFProc;
                    #13: CRProc;
                 else
                    UnknownProc;
                 end;

    rsMshDelim : begin
                   if fLine[Run] = Self.fFieldDelim then
                      FieldDelimProc
                   else if fLine[Run] = Self.fCompDelim then
                      CompDelimProc
                   else if fLine[Run] = Self.fSubCompDelim then
                      SubCompDelimProc
                   else if fLine[Run] = Self.fEscDelim then
                      EscDelimProc
                   else if fLine[Run] = Self.fRepDelim then
                      RepDelimProc
                   else begin

                      case fLine[Run] of
                                      #0: NullProc;
                                      #10: LFProc;
                                      #13: CRProc;
                                      #1..#9, #11, #12, #14..#32: SpaceProc;
                                      else TextProc;
                                    end;
                    end
                  end;
    rsDefDelim : case fLine[Run] of
                        #0: NullProc;
                        #10: LFProc;
                        #13: CRProc;
                        #1..#9, #11, #12, #14..#32: SpaceProc;
                        DEF_FIELD_DELIM : FieldDelimProc;
                        DEF_COMP_DELIM : CompDelimProc;
                        DEF_SUBCOMP_DELIM : SubCompDelimProc;
                        DEF_ESC_DELIM : EscDelimProc;
                        DEF_REP_DELIM : RepDelimProc;
                        else TextProc;
                      end;
  end;
  inherited;
end;

procedure TSynHL7Syn.NullProc;
begin
  fTokenID := tkNull;
  inc(Run);
end;

function TSynHL7Syn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;
begin
  case Index of
    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;
  else
    Result := nil;
  end;
end;

function TSynHL7Syn.GetEol: Boolean;
begin
  Result := Run = fLineLen + 1;
end;

function TSynHL7Syn.GetTokenID: TtkTokenKind;
begin
  Result := fTokenId;
end;

function TSynHL7Syn.GetTokenAttribute: TSynHighlighterAttributes;
begin
  case fTokenID of
    tkSegmentID: Result := fSegmentIDAttri;
    tkFieldDelim: Result := fFieldDelimAttri;
    tkCompDelim: Result := fCompDelimAttri;
    tkSubCompDelim: Result := fSubCompDelimAttri;
    tkRepDelim: Result := fRepDelimAttri;
    tkEscDelim: Result := fEscDelimAttri;

    tkText: Result := fTextAttri;
    tkSpace: Result := fSpaceAttri;
    tkUnknown: Result := fUnknownAttri;
    else Result := nil;
  end;
end;

function TSynHL7Syn.GetTokenKind: integer;
begin
  Result := Ord(fTokenId);
end;

function TSynHL7Syn.IsFilterStored: Boolean;
begin
  Result := fDefaultFilter <> SYNS_FilterINI;
end;

class function TSynHL7Syn.GetLanguageName: string;
begin
  Result := SYNS_LangINI;
end;

function TSynHL7Syn.GetRange: Pointer;
begin
  Result := Pointer(fRange);
end;

function TSynHL7Syn.GetSampleSource: UnicodeString;
begin
  Result := 'MSH|^&\~|123|123'#13#10+
            'PID|123|1234'
end;

{$IFNDEF SYN_CPPB_1}
class function TSynHL7Syn.GetFriendlyLanguageName: UnicodeString;
begin
  Result := SYNS_FriendlyLangINI;
end;

initialization
  RegisterPlaceableHighlighter(TSynHL7Syn);
{$ENDIF}
end.