This is a VBA port of a C# class that takes an HL7 message and converts it to an XML document object and returns the resulting xml as a string.

The original article can be found here: http://www.codeproject.com/Articles/29670/Converting-HL7-to-XML

The port was triggered by this UA discussion: http://www.utteraccess.com/forum/Hl7-Messaging-Class-t1985123.html

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