If you have a working pre-V33 program, here is all you need to change:
The call to mhdrg()
- the name of the DLL in your function delcarations to "vbdrgv33.dll"
- the name of the DRG assigner from mhdrg() to mhdrg1()
- add the POA flag: "y" means "have POA" and "n" means "no POAs"
- add the exempt flag: "y" means "this case is exempt from HAC" and "no" means "not exempt"
- the DX and Proc buffers both need to be bigger: 256, not 80
- the declaration should have this as a Sub not a Function
- the first argument is now ByVal, not ByRef
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
Please check this blog for other entries about the VB callable DLL to answer other questions.
No comments:
Post a Comment