Option Compare Database
Option Explicit

' This class takes an HL7 message
' and transforms it into an XML representation.
' A reference to the Microsoft XML library is required

Private xmlDoc As DOMDocument
 
' Converts an HL7 message into an XML representation of the same message.
Public Function ConvertToXml(sHL7 As String) As String
   
 
   Dim sHL7Lines As Variant
   Dim sComponents As Variant
   Dim b As Integer
   Dim subComponents As Variant
   Dim c As Integer
   Dim subComponentRepetitions As Variant
   Dim d As Integer
   Dim sRepetitions As Variant
   Dim repetitionEl As IXMLDOMElement
   Dim componentEl As IXMLDOMElement
   Dim subComponentEl As IXMLDOMElement
   Dim subComponentRepEl As IXMLDOMElement
   Dim i As Integer
   Dim sFields As Variant
   Dim sHL7Line As String
   Dim fieldEl As IXMLDOMElement
   Dim el As IXMLDOMElement
       
   'Create the base XML
   Set xmlDoc = CreateXmlDoc()

   ' HL7 message segments are terminated by carriage returns,
   ' so to get an array of the message segments, split on carriage return
               
   sHL7Lines = Split(sHL7, vbLf)
       
   ' Now we want to replace any other unprintable control
   ' characters with whitespace otherwise they'll break the XML
   For i = 0 To UBound(sHL7Lines)
       sHL7Lines(i) = Replace(sHL7Lines(i), " |", "|")
       sHL7Lines(i) = Replace(sHL7Lines(i), " ^", "^")
       sHL7Lines(i) = Replace(sHL7Lines(i), " ~", "~")
       sHL7Lines(i) = Replace(sHL7Lines(i), " &", "&")
   Next i
   
   ' Go through each segment in the message
   ' and first get the fields, separated by pipe (|),
   ' then for each of those, get the field components,
   ' separated by carat (^), and check for
   ' repetition (~) and also check each component
   ' for subcomponents, and repetition within them too.
   
   For i = 0 To UBound(sHL7Lines)
       ' Don't care about empty lines
       If Len(sHL7Lines(i)) > 0 Then
           
           ' Get the line and get the line's segments
           sHL7Line = sHL7Lines(i)
           sFields = GetMessgeFields(sHL7Line)

           ' Create a new element in the XML for the line
           Set el = xmlDoc.createElement(sFields(0))
           xmlDoc.documentElement.appendChild el

           ' For each field in the line of HL7
           Dim a As Integer
         
           For a = 0 To UBound(sFields)
           
               ' Create a new element
              Set fieldEl = xmlDoc.createElement(sFields(0) & "." & CStr(a))

               ' Part of the HL7 specification is that part
               ' of the message header defines which characters
               ' are going to be used to delimit the message
               ' and since we want to capture the field that
               ' contains those characters we need
               ' to just capture them and stick them in an element.
               If sFields(a) <> "^~\&" Then
               
                   ' Get the components within this field, separated by carats (^)
                   ' If there are more than one, go through and create an element for
                   ' each, then check for subcomponents, and repetition in both.
                   
                   sComponents = GetComponents(sFields(a))
                   If UBound(sComponents) > 1 Then
                   
                       For b = 0 To UBound(sComponents)
                       
                           Set componentEl = xmlDoc.createElement(sFields(0) & _
                                      "." & CStr(a) & _
                                      "." & CStr(b))

                           subComponents = GetSubComponents(sComponents(b))
                           If UBound(subComponents) > 1 Then
                           ' There were subcomponents
                           
                               For c = 0 To UBound(subComponents)
                               
                                   ' Check for repetition
                                   subComponentRepetitions = GetRepetitions(subComponents(c))
                                   If UBound(subComponentRepetitions) > 1 Then
                                   
                                       For d = 0 To UBound(subComponentRepetitions)
                                       
                                          subComponentRepEl = xmlDoc.createElement(sFields(0) & _
                                             "." & CStr(a) & _
                                             "." & CStr(b) & _
                                             "." & CStr(c) & _
                                             "." & CStr(d))
                                          subComponentRepEl.Text = subComponentRepetitions(d)
                                          componentEl.appendChild (subComponentRepEl)
                                       Next d
                                   
                                   Else
                                   
                                       Set subComponentEl = xmlDoc.createElement(sFields(0) & _
                                       "." & CStr(a) & "." & _
                                       CStr(b) & "." & CStr(c))
                                       subComponentEl.Text = subComponents(c)
                                       componentEl.appendChild (subComponentEl)

                                   End If
                               Next c
                               fieldEl.appendChild (componentEl)
                           
                           Else ' There were no subcomponents
                           
                               sRepetitions = GetRepetitions(sComponents(b))
                               If UBound(sRepetitions) > 1 Then
                                   'Set repetitionEl = Null
                                   
                                   For c = 0 To UBound(sRepetitions)
                                   
                                       Set repetitionEl = xmlDoc.createElement(sFields(0) & "." & _
                                         CStr(a) & "." & CStr(b) & _
                                         "." & CStr(c))
                                       repetitionEl.Text = sRepetitions(c)
                                       componentEl.appendChild repetitionEl
                                   Next c
                                   fieldEl.appendChild componentEl
                                   el.appendChild fieldEl
                               
                               Else
                               
                                   componentEl.Text = sComponents(b)
                                   fieldEl.appendChild componentEl
                                   el.appendChild fieldEl
                              End If
                           End If
                           
                       Next b
                       el.appendChild fieldEl
                   Else
                       fieldEl.Text = sFields(a)
                       el.appendChild fieldEl
                   End If
               Else
                   fieldEl.Text = sFields(a)
                   el.appendChild fieldEl
               End If
           Next a
       End If
   Next i

   ConvertToXml = xmlDoc.XML
End Function


' Split a line into its component parts based on pipe.
Private Function GetMessgeFields(s) As Variant
    GetMessgeFields = Split(s, "|")
End Function

' Get the components of a string by splitting based on carat.

Private Function GetComponents(s) As Variant
   GetComponents = Split(s, "^")
End Function


' Get the subcomponents of a string by splitting on ampersand.

Private Function GetSubComponents(s) As Variant
   GetSubComponents = Split(s, "&")
End Function

' Get the repetitions within a string based on tilde.

Private Function GetRepetitions(s) As Variant
   GetRepetitions = Split(s, "~")
End Function


' Create the basic XML document that represents the HL7 message

Private Function CreateXmlDoc() As DOMDocument
   Dim output As DOMDocument
   Dim rootNode As IXMLDOMElement
   
   Set output = New DOMDocument
   
   Set rootNode = output.createElement("HL7Message")
   output.appendChild rootNode
   Set CreateXmlDoc = output
End Function