Option Explicit

Private Declare Function mhdllver Lib "vbdrgv33.dll" (ByVal Buf As String, _
    ByVal BufLen As Integer) As Integer
Private Declare Function mhdrg1 Lib "vbdrgv33.dll" (drg As Integer, _
    ByVal DRGVersion As String, ByVal MasksPath As String, ByVal DischStat As String, _
    ByVal PtAge As String, ByVal PtGender As String, ByVal DXList As String, _
    ByVal ProcList As String, ByVal POAPresent As String, ByVal ExemptFlag As String) As Integer
Private Declare Sub mhinfo Lib "vbdrgv33.dll" (ByVal drg As Integer, _
    ByVal DRGVersion As String, ByVal MasksPath As String, ByRef mdc As Integer, _
    weight As Double, los As Double, ByVal Desc As String, ByVal DescLen As Integer)
Private Declare Function mhdrgver Lib "vbdrgv33.dll" (ByVal MPath As String, _
    ByVal Buf As String, ByVal BufLen As Integer) As Integer
Private Declare Sub mherrdesc Lib "vbdrgv33.dll" (ByVal errBuffer As String, ByVal errLength As Integer)

Public Function AssignDRG()

On Error GoTo Err_Group

    Dim ReturnCode As Integer
    Dim drg As Integer, mdc As Integer
    Dim Desc As String * 80
    Dim weight As Double, los As Double
    Dim masksdir As String
    Dim myver As String, mydstat As String, myage As String, mysex As String, myexempt As String, mypoa As String
    Dim mydxbuf As String * 256
    Dim mypxbuf As String * 256
    Dim tempStr As String
    Dim N As Integer, needcomma As Integer
    Dim Val As String
    Dim NumRecords As Long, NumErrors As Long
    Dim LastRow As Long
    Dim MyID As Long                                    'user's record number
    Dim myWS As Object
        
    Application.ScreenUpdating = False
    Application.Cursor = xlWait
    'start in first row, DRG column
    Range("CE2").Select
    NumRecords = 0
    NumErrors = 0
    
    'get the path to the masks directory out of the registry, if you can
    masksdir = "C:\Program Files\MandH\Masks\"          'default
    Set myWS = CreateObject("WScript.Shell")
    tempStr = myWS.RegRead("HKLM\Software\MandH\BaseDir")
    If Len(tempStr) > 0 Then
        masksdir = tempStr & "\Masks\"
    End If
    
    'loop through records making sure DRG info is blank
    'first, find last row
    Do Until IsEmpty(ActiveCell.Offset(0, -81).Range("A1").Value) = True
        ActiveCell.Offset(1, 0).Range("A1").Select
    Loop
    
    'select DRG columns and all populated rows
    LastRow = ActiveCell.Row
    LastRow = LastRow - 1
    Range("CE2:CJ" & LastRow).Select
    
    'clear selection
    Selection.ClearContents
    
    Range("CE2").Select
    'loop through records assigning drg info
    Do Until IsEmpty(ActiveCell.Offset(0, -82).Range("A1").Value) = True
        myver = ActiveCell.Offset(0, -2).Range("A1").Value
        MyID = ActiveCell.Offset(0, -82).Value
    
        'abort if version is blank
        If myver = "" Then
            MyID = ActiveCell.Offset(0, -82).Value
            MsgBox "Version is empty for record # " & MyID & ". Cannot group.", vbOKOnly, "Missing Version"
            NumErrors = NumErrors + 1
            GoTo NextOne
        End If
        
        myexempt = ActiveCell.Offset(0, -79).Range("A1").Value
        mydstat = ActiveCell.Offset(0, -78).Range("A1").Value
        mysex = ActiveCell.Offset(0, -80).Range("A1").Value
        myage = ActiveCell.Offset(0, -81).Range("A1").Value
        mypoa = ActiveCell.Offset(0, -1).Range("A1").Value
        
        'Loop through controls, getting their current values
    
        'make string out of the diagnosis codes
        tempStr = ""
        needcomma = 0
        For N = -77 To -53
            Val = ActiveCell.Offset(0, N).Range("A1").Value
            If Len(Val) > 0 Then
                'append POA flag, if present
                If ActiveCell.Offset(0, N + 25).Value <> "" Then
                    Val = Val & "~" & ActiveCell.Offset(0, N + 25).Range("A1").Value
                End If
                If needcomma <> 0 Then
                    tempStr = tempStr & ","
                End If
                needcomma = 1
                tempStr = tempStr & Val
            End If
        Next N
        mydxbuf = tempStr & "^" ' explicit end-of-data marker
        
        'make string out of the procedure codes
        tempStr = ""
        needcomma = 0
        For N = -27 To -3
            Val = ActiveCell.Offset(0, N).Range("A1").Value
            If Len(Val) > 0 Then
                If needcomma <> 0 Then
                    tempStr = tempStr & ","
                End If
                needcomma = 1
                tempStr = tempStr & Val
            End If
        Next N
        mypxbuf = tempStr & "^" ' explicit end-of-data marker
        
        'call the M+H grouper with what you got
        ReturnCode = mhdrg1(drg, myver, masksdir, mydstat, myage, mysex, mydxbuf, mypxbuf, mypoa, myexempt)
        ActiveCell.Offset(0, 2).Range("A1").Value = ReturnCode
    
        If ReturnCode <> 0 Then          'drg assignment failed, alas!
            Call mherrdesc(Desc, 80)
            ActiveCell.Offset(0, 0).Range("A1").Value = drg
            ActiveCell.Offset(0, 1).Range("A1").Value = Desc
            NumErrors = NumErrors + 1
        Else                            'drg assignment worked, hurray!
            'get the particulars of this DRG from M+H dll
            Call mhinfo(drg, myver, masksdir, mdc, weight, los, Desc, 80)
            ActiveCell.Offset(0, 0).Range("A1").Value = drg
            ActiveCell.Offset(0, 1).Range("A1").Value = Desc
            ActiveCell.Offset(0, 3).Range("A1").Value = mdc
            ActiveCell.Offset(0, 4).Range("A1").Value = weight
            ActiveCell.Offset(0, 5).Range("A1").Value = los
        End If
NextOne:
        ActiveCell.Offset(1, 0).Range("A1").Select
        NumRecords = NumRecords + 1
    Loop
    Application.ScreenUpdating = True
    Application.Cursor = xlDefault
    Range("CE2").Select
    
    Beep
    MsgBox NumRecords & " records were grouped with " & NumErrors & " error(s)."

Exit_Group:
   Exit Function
   
Err_Group:
    Application.Cursor = xlDefault
    MsgBox Err.Number & "-" & Err.Description
    Range("CE2").Select
    Resume Exit_Group

End Function