VERSION 5.00
Begin VB.Form frmMain 
   Caption         =   "HL7 Import"
   ClientHeight    =   4980
   ClientLeft      =   3336
   ClientTop       =   1728
   ClientWidth     =   8016
   LinkTopic       =   "Form1"
   ScaleHeight     =   4980
   ScaleWidth      =   8016
   WindowState     =   2  'Maximized
   Begin VB.ListBox List3 
      Height          =   6384
      Left            =   3600
      TabIndex        =   7
      Top             =   900
      Width           =   3192
   End
   Begin VB.ListBox List2 
      Height          =   6384
      Left            =   396
      TabIndex        =   6
      Top             =   900
      Width           =   2988
   End
   Begin VB.CommandButton Command3 
      Caption         =   "Review Array"
      Height          =   468
      Left            =   9672
      TabIndex        =   5
      Top             =   7620
      Width           =   2124
   End
   Begin VB.CommandButton Command2 
      Caption         =   "Parse File"
      Height          =   492
      Left            =   7764
      TabIndex        =   4
      Top             =   7656
      Width           =   1464
   End
   Begin VB.ListBox List1 
      Height          =   6384
      Left            =   6972
      TabIndex        =   3
      Top             =   888
      Width           =   4968
   End
   Begin VB.CommandButton Command1 
      Caption         =   ":"
      Height          =   300
      Left            =   5796
      TabIndex        =   2
      Top             =   372
      Width           =   144
   End
   Begin VB.TextBox Text1 
      Height          =   288
      Left            =   2076
      TabIndex        =   1
      Top             =   360
      Width           =   3732
   End
   Begin VB.Label Label1 
      Caption         =   "File to import from"
      Height          =   204
      Left            =   396
      TabIndex        =   0
      Top             =   384
      Width           =   1380
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim Mystring
Dim lcharpost As Long
Dim sHeaderName As String 'eg PID = patient PV1 = practitioner OBR = request OBX() = result
Dim sAddThis As String
Dim sLastHeaderName As String
Dim sCurrentHeaderName As String
Dim iNumTests As Integer ' number of tests requested
Dim iTestComponentResult As Integer
Dim Db As Database
Dim Rs As Recordset

Private Sub Command2_Click()
Dim sString As String
Dim sAddress As String
Dim sDOB
Command2.Enabled = False
Command3.Enabled = False
Screen.MousePointer = vbHourglass
Set Db = OpenDatabase(sMEDREC_MDB)
          Set Q = Db.QueryDefs("MrQ_Hl7_Match_PatientNameAndAddress")
  '--------------------
  'Read in the HL7 File
  '--------------------
  iNumTests = -1
 Open Text1.Text For Input As #1
 List1.Clear
 Do While Not EOF(1) ' Loop until end of file.
    '-------------------------------
    'Input a single line of HL7 text
    '-------------------------------
    Line Input #1, Mystring  'if file head contains FHS BHS and MSH lines
    'MsgBox Mystring
    sAddThis = ""
    If InStr(Mystring, "MSH") Then
       Mystring = Right(Mystring, Len(Mystring) - InStr(Mystring, "MSH") + 1)
    End If
    'MsgBox Mystring
    '-------------------------------
    'Strip of the header to the line
    '-------------------------------
    sHeaderName = Left(Mystring, InStr(Mystring, "|") - 1)
    '-------------------------------------------------------
    'Forget the LAB specific stuff, parse out the patient ID
    '-------------------------------------------------------
    Select Case sHeaderName
    Case "MSH"
         ' sAddThis = "Message Header"
          sCurrentHeaderName = sHeaderName
         
          If sCurrentHeaderName <> sLastHeaderName Then
                iNumTests = iNumTests + 1
                iTestComponentResult = -1
                ReDim Preserve gtCrudeHL7Results(iNumTests)
                gtCrudeHL7Results(iNumTests).MSH = Mystring
                 sLastHeaderName = sHeaderName
          End If
    Case "PID"
         '------------------------------------------------------------------------
         'when a patient identification header encountered, redimension test array
         '------------------------------------------------------------------------
          sAddThis = "Patient ID "
          sString = Mystring
          '--------------------------------------------------------------------------
          'Now attempt to match the patient details to a real patient in the database
          '--------------------------------------------------------------------------
          Split sString, "|"
          sAddress = sArray(11)
          sDOB = Right(sArray(7), 2) & "/" & Mid$(sArray(7), 5, 2) & "/" & Left(sArray(7), 4)
          sString = sArray(5)
          Split sString, "^"
         ' MsgBox "Patient    : " & sArray(4) & " " & sArray(1) & " " & sArray(0) & " " & sDOB
          
           Q("Enter Firstname") = sArray(1)
           Q("Enter Surname") = sArray(0)
          ' Q("Enter Suburb") = sArray(1)
          ' Q("Enter Postcode") = sArray(1)
           Q("Enter DOB") = sDOB
           Set Rs = Q.OpenRecordset()
           With Rs
                  If Not .EOF Then
                   'MsgBox "Found:" & !Firstname & " " & !Surname & " " & sDOB
                    gtCrudeHL7Results(iNumTests).Patient_ID = !PatientNo
                  Else
                    'MsgBox "Did not find:" & sArray(1) & " " & sArray(0) & " " & sDOB
                    List2.AddItem "Did not find:" & sArray(1) & " " & sArray(0) & " " & sDOB
                  End If
           End With
          gtCrudeHL7Results(iNumTests).PID = Mystring
          sLastHeaderName = sHeaderName
        '  End If
    Case "OBR"
          sAddThis = "Request:"
          gtCrudeHL7Results(iNumTests).OBR = Mystring
           sLastHeaderName = sHeaderName
    Case "OBX"
           iTestComponentResult = iTestComponentResult + 1
          sAddThis = "Result"
          ReDim Preserve gtCrudeHL7Results(iNumTests).OBX(iTestComponentResult)
          gtCrudeHL7Results(iNumTests).OBX(iTestComponentResult) = Mystring
          sLastHeaderName = sHeaderName
    Case "PV1"
           sAddThis = "Practitioner"
           gtCrudeHL7Results(iNumTests).PV1 = Mystring
            sLastHeaderName = sHeaderName
    End Select
    If sAddThis <> "" Then
       List1.AddItem sAddThis & " " & Mystring
       'DoEvents
   End If
Loop

 Close #1
 Set Q = Db.QueryDefs("MRQ_HL7_Import_RawDataCrude_Add")
 For iX = 0 To UBound(gtCrudeHL7Results())
    
    Q("Enter Patient_ID") = gtCrudeHL7Results(iX).Patient_ID
    Q("Enter ProviderType_ID") = mrRequest_Pathology
    Q("Enter Hl7Text") = gtCrudeHL7Results(iX).PID
    Q.Execute
    'Set Q = Db.QueryDefs("MRQ_HL7_Import_RawDataCrude_Add")
    Q("Enter Patient_ID") = gtCrudeHL7Results(iX).Patient_ID
    Q("Enter Hl7Text") = gtCrudeHL7Results(iX).OBR
    Q.Execute
    For iY = 0 To UBound(gtCrudeHL7Results(iY).OBX())
     '  Set Q = Db.QueryDefs("MRQ_HL7_Import_RawDataCrude_Add")
       Q("Enter Patient_ID") = gtCrudeHL7Results(iX).Patient_ID
       Q("Enter Hl7Text") = gtCrudeHL7Results(iX).OBX(iY)
       Q.Execute
    Next iY
    
   ' Set Q = Db.QueryDefs("MRQ_HL7_Import_RawDataCrude_Add")
    Q("Enter Patient_ID") = gtCrudeHL7Results(iX).Patient_ID
    Q("Enter Hl7Text") = gtCrudeHL7Results(iX).PIT
    Q.Execute
 
Next iX
Db.Close
Screen.MousePointer = vbArrow
Command2.Enabled = True
Command3.Enabled = True
End Sub
Sub Old_ReadFileIN()
  iNumTests = -1
 Open Text1.Text For Input As #1
 List1.Clear
 Do While Not EOF(1) ' Loop until end of file.
    '-------------------------------
    'Input a single line of HL7 text
    '-------------------------------
    Line Input #1, Mystring  'if file head contains FHS BHS and MSH lines
    'MsgBox Mystring
    sAddThis = ""
    If InStr(Mystring, "MSH") Then
       Mystring = Right(Mystring, Len(Mystring) - InStr(Mystring, "MSH") + 1)
    End If
    'MsgBox Mystring
    '-------------------------------
    'Strip of the header to the line
    '-------------------------------
    sHeaderName = Left(Mystring, InStr(Mystring, "|") - 1)
    '-------------------------------------------------------
    'Forget the LAB specific stuff, parse out the patient ID
    '-------------------------------------------------------
    Select Case sHeaderName
    Case "MSH"
         ' sAddThis = "Message Header"
          sCurrentHeaderName = sHeaderName
         
          If sCurrentHeaderName <> sLastHeaderName Then
                iNumTests = iNumTests + 1
                iTestComponentResult = -1
                ReDim Preserve gtCrudeHL7Results(iNumTests)
                gtCrudeHL7Results(iNumTests).MSH = Mystring
                 sLastHeaderName = sHeaderName
          End If
    Case "PID"
         '------------------------------------------------------------------------
         'when a patient identification header encountered, redimension test array
         '------------------------------------------------------------------------
          sAddThis = "Patient ID "
        '  sCurrentHeaderName = sHeaderName
         
        '  If sCurrentHeaderName <> sLastHeaderName Then
        '        iNumTests = iNumTests + 1
        '        iTestComponentResult = -1
        '        ReDim Preserve gtCrudeHL7Results(iNumTests)
                gtCrudeHL7Results(iNumTests).PID = Mystring
                 sLastHeaderName = sHeaderName
        '  End If
    Case "OBR"
          sAddThis = "Request:"
          gtCrudeHL7Results(iNumTests).OBR = Mystring
           sLastHeaderName = sHeaderName
    Case "OBX"
           iTestComponentResult = iTestComponentResult + 1
          sAddThis = "Result"
          ReDim Preserve gtCrudeHL7Results(iNumTests).OBX(iTestComponentResult)
          gtCrudeHL7Results(iNumTests).OBX(iTestComponentResult) = Mystring
          sLastHeaderName = sHeaderName
    Case "PV1"
           sAddThis = "Practitioner"
           gtCrudeHL7Results(iNumTests).PV1 = Mystring
            sLastHeaderName = sHeaderName
    End Select
    If sAddThis <> "" Then
       List1.AddItem sAddThis & " " & Mystring
   End If
Loop

 Close #1

End Sub
Private Sub Command3_Click()
    Dim iX As Integer
    Dim iY As Integer
    Dim iZ As Integer
    Dim sString As String
    Dim lcharpos As Long
    Dim topos As Integer
    Dim lfirstpos As Long
    Dim sSTring1 As String
    Dim sMsg As String
    Dim DOB As String
    Dim iR As Integer
    Dim iLineOrder As Integer
    Dim sCurrentPatient As String
    Dim sLastPatient As String
    Dim sPatientDetails As String 'name + street + DOB hopefully should be unique
    Dim sAddress As String
    List1.Clear
    List2.Clear
    Dim iP As Integer
    iR = -1
    iP = -1
    For iX = 0 To UBound(gtCrudeHL7Results())
        '-----------------------------
        'Add the patients name to list
        '-----------------------------
        'MsgBox gtCrudeHL7Results(iX).PID
        sString = gtCrudeHL7Results(iX).PID
        Split sString, "|"
        sAddress = sArray(11)
        DOB = Right(sArray(7), 2) & "/" & Mid$(sArray(7), 5, 2) & "/" & Left(sArray(7), 4)
        sString = sArray(5)
        Split sString, "^"
        List1.AddItem "Patient    : " & sArray(4) & " " & sArray(1) & " " & sArray(0) & " " & DOB
        '---------------------------------------------
        'If this is the next patient, add to the array
        '---------------------------------------------
        sCurrentPatient = sArray(4) & " " & sArray(1) & " " & sArray(0) & " " & DOB
        If sCurrentPatient <> sLastPatient Then
            sPatientDetails = sArray(4) & " " & sArray(1) & " " & sArray(0) & " " & DOB
            
            iP = iP + 1
            iR = -1
            iLineOrder = -1
            ReDim Preserve gtPatient(iP)
            gtPatient(iP).Surname = sArray(0)
            gtPatient(iP).Firstname = sArray(1)
            gtPatient(iP).Title = sArray(4)
            gtPatient(iP).Date_of_Birth = DOB
            List2.AddItem gtPatient(iP).Surname & " " & LCase(gtPatient(iP).Firstname) & " " & gtPatient(iP).Date_of_Birth
            List2.ItemData(List2.NewIndex) = iP
            sLastPatient = sPatientDetails
            
            Split sAddress, "^"
            gtPatient(iP).Street1 = sArray(0)
            gtPatient(iP).Street2 = sArray(1)
            gtPatient(iP).suburb = sArray(2)
            gtPatient(iP).Postcode = sArray(4)
            gtPatient(iP).State = sArray(3)
            
        End If
        '--------------------------------
        'Add the request name to the list
        '--------------------------------
        sString = gtCrudeHL7Results(iX).OBR
        Split sString, "|"
        sString = sArray(4)
        Split sString, "^"
        List1.AddItem "Request : " & " " & sArray(1)
        iR = iR + 1
        ReDim Preserve gtPatient(iP).result(iR)
        gtPatient(iP).result(iR).RequestName = sArray(1)
        '---------------------------------------------------
        'Get the date of the request from the message header
        '---------------------------------------------------
        sString = gtCrudeHL7Results(iX).MSH
        Split sString, "|"
        sString = sArray(6)
        sString = Left(sArray(6), 8)
        gtPatient(iP).result(iR).RequestDate = Right(sString, 2) & "/" & Mid$(sString, 5, 2) & "/" & Left(sString, 4)
 
        '-------------------------------
        'Now add the results to the list
        '-------------------------------
        For iY = 0 To UBound(gtCrudeHL7Results(iX).OBX())
            
            sString = gtCrudeHL7Results(iX).OBX(iY)
          '  MsgBox sString
            Split sString, "|"
           If InStr(gtCrudeHL7Results(iX).OBX(iY), ".nf") And InStr(gtCrudeHL7Results(iX).OBX(iY), "PIT") = False Then
             List1.AddItem "Result: REPORT"
             gtPatient(iP).result(iR).ReportType = "Report"
             sString = sArray(5)
             Split sString, "\"
             iLineOrder = -1
             For iZ = 0 To UBound(sArray())
                 If sArray(iZ) <> ".nf" And sArray(iZ) <> ".br" Then
                    'If InStr(Trim(sArray(iZ)), ".nf") = 0 Xor InStr(Trim(sArray(iZ)), ".bf") = 0 Then
                        iLineOrder = iLineOrder + 1
                        ReDim Preserve gtPatient(iP).result(iR).Line_Text(iLineOrder)
                        gtPatient(iP).result(iR).Line_Text(iLineOrder) = sArray(iZ)
                        List1.AddItem sArray(iZ)
                 End If
                 'End Select
              Next iZ
            ElseIf InStr(gtCrudeHL7Results(iX).OBX(iY), "PIT") = False Then
              
              ' sString = sArray(3)
               sSTring1 = sArray(3)
               'lcharpos = InStr(sString, "^")
              ' LastDelimiterPosition sString, "^"
               
               Split sSTring1, "^"
               sMsg = sArray(1)
               'Split sString, "|"
               'sSTring1 = sArray(5)
               sString = gtCrudeHL7Results(iX).OBX(iY)
               Split sString, "|"
               sMsg = sMsg & "    " & sArray(5)
               If sArray(7) <> "" Then
                 sMsg = sMsg & " (" & sArray(7) & ")"
               End If
               'Split sSTring1
               If sMsg <> "" Then
               List1.AddItem sMsg
               iLineOrder = iLineOrder + 1
               ReDim Preserve gtPatient(iP).result(iR).Line_Text(iLineOrder)
               gtPatient(iP).result(iR).Line_Text(iLineOrder) = sMsg
              End If
           End If
            
            '& gtCrudeHL7Results(ix).OBX(iY)
        Next
        
    Next
    
End Sub

Private Sub Form_Load()
Text1 = "h:\data\hl7\terry.HL7"
Text1 = "h:\data\hl7\2001-09-21 17-56.HL7"
Text1 = "h:\data\pathology\hl7\2001-11-27-50540.18.pit"

End Sub

Private Sub List2_Click()
           On Error Resume Next
           Dim iP As Integer
           Dim iX As Integer
           Dim il As Integer
           iP = List2.ItemData(List2.ListIndex)
           List3.Clear
           For iX = 0 To UBound(gtPatient(iP).result())
               List3.AddItem gtPatient(iP).result(iX).RequestName
               List3.ItemData(List3.NewIndex) = iX
                          Next
          List3.ListIndex = 0
          
           
End Sub

Private Sub List3_Click()
                Dim iP As Integer
           Dim iX As Integer
           Dim il As Integer
           List1.Clear
                iP = List2.ItemData(List2.ListIndex)
                iX = List3.ItemData(List3.ListIndex)
               For il = 0 To UBound(gtPatient(iP).result(iX).Line_Text())
                    If gtPatient(iP).result(iX).Line_Text(il) <> "" Then
                        List1.AddItem gtPatient(iP).result(iX).Line_Text(il)
                    End If
               Next
               List1.AddItem ""

End Sub
Sub Hl7Data_Save()
   
   Dim iP As Integer
   Dim iR As Integer
   Dim iX As Integer
   Dim sLastPatient As String
   Dim sCurrentPatient As String
   Dim sNextPatient As String
    Dim ws As Workspace
    '--------------------------------------------------------------------------------
    'Save inital HL7 Data to a tempory database table prior to matching to patient_ID
    '--------------------------------------------------------------------------------
    Set Db = ws.OpenDatabase(sMEDREC_MDB, False)
    
    Set Q = Db.QueryDefs("MRQ_HL7_Import_RawData_Add")
      For iX = 0 To UBound(gtPatient())
            Q("Enter ProviderType_ID") = mrRequestType_Pathology
            Q("Enter Firstname") = gtPatient(iX).Firstname
            Q("Enter Surname") = gtPatient(iX).Surname
            Q("Enter Street1") = gtPatient(iX).Street1
            Q("Enter Street2") = gtPatient(iX).Street2
            Q("Enter suburb") = gtPatient(iX).suburb
            Q("Enter Postcode") = gtPatient(iX).Postcode
            Q("Enter HL7Text") = gtPatient(iX).result(iY).Gap
            Q.Execute
       Next
     Db.Close
     ws.CommitTrans

    
End Sub

Sub GroupPatients()
      
   Dim iP As Integer
   Dim iR As Integer
   Dim iX As Integer
   Dim sLastPatient As String
   Dim sCurrentPatient As String
   Dim sNextPatient As String
   '---------------------------------------------------------------
   'Takes the gtpatient(n) array and runs through it re-creating
   'it with all patients results on different days grouped together
   '---------------------------------------------------------------
   iP = -1
   Dim gtPatientSorted() As tPatient
   For iX = 0 To UBound(gtPatient())
       sCurrentPatient = gtPatient(iX).Firstname & " " & gtPatient(iX).Surname _
        & gtPatient(iX).Date_of_Birth
       For iY = 0 To UBound(gtPatient())
          sNextPatient = gtPatient(iY).Firstname & " " & gtPatient(iY).Surname _
        & gtPatient(iY).Date_of_Birth
           If sNextPatient = sCurrentPatient Then
             ReDim Preserve gtPatientSorted(iP)
            gtPatientSorted(iP).Firstname = gtPatient(iY).Firstname
            gtPatientSorted(iP).Surname = gtPatient(iY).Surname
            gtPatientSorted(iP).Title = gtPatient(iY).Title
            gtPatientSorted(iP).Date_of_Birth = gtPatient(iY).Date_of_Birth
            gtPatientSorted(iP).Street1 = gtPatient(iY).Street1
            gtPatientSorted(iP).Street2 = gtPatient(iY).Street2
            gtPatientSorted(iP).suburb = gtPatient(iY).suburb
            gtPatientSorted(iP).State = gtPatient(iY).State
            gtPatientSorted(iP).Postcode = gtPatient(iY).Postcode
            sCurrentPatient = sLastPatient
        End If
        
       Next
   Next
  
End Sub