📄 frmchecklist.frm
字号:
Top = 743
Width = 975
End
Begin VB.Label lblDiagnoseCue
BackColor = &H00E0E0E0&
BackStyle = 0 'Transparent
Caption = "诊断提示"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 255
Left = 5760
TabIndex = 16
Top = 720
Visible = 0 'False
Width = 975
End
Begin VB.Label lblCheckPartName
BackColor = &H00E0E0E0&
BackStyle = 0 'Transparent
Caption = "拍片部位"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Left = 7560
TabIndex = 15
Top = 480
Visible = 0 'False
Width = 975
End
Begin VB.Label lblCheckNumber
BackColor = &H00E0E0E0&
BackStyle = 0 'Transparent
Caption = "患者编号"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 255
Left = 240
TabIndex = 14
Top = 263
Width = 975
End
End
End
Begin MSHierarchicalFlexGridLib.MSHFlexGrid dgResult
Height = 3615
Left = 240
TabIndex = 42
Top = 5040
Visible = 0 'False
Width = 4215
_ExtentX = 7435
_ExtentY = 6376
_Version = 393216
BackColor = 14737632
BackColorFixed = 16777215
BackColorBkg = 16777215
BackColorUnpopulated= 16777215
FocusRect = 2
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 11.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BeginProperty FontFixed {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 11.25
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
_NumberOfBands = 1
_Band(0).Cols = 2
End
End
End
Attribute VB_Name = "frmCheckList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'------------------------------------------------------------------------------------
'文件：frmCheckList.frm
'作者：刘辉
'时间：2008-4-9
'说明：检查清单--子窗体
'------------------------------------------------------------------------------------
Option Explicit
'当前记录ID
Public strCurCheckListID As String
'当前病人ID
Public curCheckNumber As String
'当前病人姓名
Public curPatientName As String
'当前病人登记日期
Public curPatient_Reg_Date As String
Public DEFAULT_CHECK_LIST As String
Dim CHECK_LIST_SQL As String
Const SQL_CHECKLIST = "SELECT " + modCheckList.CHECK_LIST_FILELDS _
+ " From CHECK_LIST "
Dim WithEvents myDgCheckList As MSHFlexGrid
Attribute myDgCheckList.VB_VarHelpID = -1
Dim DATAGRID_WIDTH As Long
Dim rsRegister As New ADODB.Recordset
Dim myConn As New ADODB.Connection
Private Sub btnRefurbish_Click()
On Error GoTo ErrHandler
tmrCheckPart.Enabled = True
tmrCheckPart.Interval = 1000 * 30
Call Activate(DEFAULT_CHECK_LIST)
Exit Sub
ErrHandler:
End Sub
Private Sub btnReportEdit_Click()
On Error GoTo ErrHandler
If myDgCheckList.Row < 1 Then
MsgBox "请选择一名患者!", vbInformation, "提示"
Exit Sub
End If
'1 ID,2 编号，3设备检查序号，4 姓名，5姓名拼音，6 性别，7 年龄，8 拍片部位，9 状态，
'10 住院号，11 登记日期，12 检查医生，13 已出报告，14 检查日期。
strCurCheckListID = myDgCheckList.TextMatrix(myDgCheckList.Row, 1)
curCheckNumber = myDgCheckList.TextMatrix(myDgCheckList.Row, 2)
curPatientName = myDgCheckList.TextMatrix(myDgCheckList.Row, 4)
curPatient_Reg_Date = CStr(myDgCheckList.TextMatrix(myDgCheckList.Row, 11))
If Trim(curCheckNumber) = "" Then
MsgBox "检查编号不正确!", vbExclamation, "提示"
Exit Sub
End If
Dim strSql As String
strSql = "SELECT ID ,Photo_Path from CHECK_PART WHERE CHECK_LIST_ID = '" _
+ Me.strCurCheckListID + "' AND IS_PHOTO_DELETED ='否'"
Dim rsPhotoPath As New ADODB.Recordset
myConn.CursorLocation = adUseClient
If myConn.State = adStateClosed Then
myConn.Open modGlobalDbConnect.GetConnectionString
End If
If myConn.State = adStateClosed Then
MsgBox "数据库连接错误，请查看网络状态！", vbExclamation, "提示"
Exit Sub
End If
rsPhotoPath.Open strSql, myConn
If rsPhotoPath.RecordCount <= 0 Then
MsgBox "该患者尚未拍照!", vbExclamation, "提示"
Exit Sub
End If
Dim strInfo As String
strInfo = " " + frmCheckList.curCheckNumber
strInfo = strInfo + " " + frmCheckList.curPatientName
strInfo = strInfo + " " + frmCheckList.curPatient_Reg_Date
Exit Sub
ErrHandler:
MsgBox "生成报告单出错！请与管理员联系", vbExclamation, "提示"
End Sub
'部门下拉框--索引改变事件
Private Sub cmbDepartments_Click()
On Error GoTo ErrHandler
If cmbDepartments.ListCount <= 0 Then
Exit Sub
End If
If Len(Trim(cmbDepartments.Text)) <= 0 Then
Exit Sub
End If
Dim strSql As String
strSql = "SELECT ID FROM Department WHERE NAME = '" + Trim(cmbDepartments.Text) + "'"
Dim rsCmbDepartment As New ADODB.Recordset
If myConn.State <> adStateClosed Then
myConn.Close
End If
myConn.Open modGlobalDbConnect.GetConnectionString
If myConn.State = adStateClosed Then
MsgBox "数据库连接错误，请查看网络状态！", vbExclamation, "提示"
Exit Sub
End If
rsCmbDepartment.Open strSql, myConn
If rsCmbDepartment.RecordCount <> 1 Then
MsgBox "获取部门ID失败, 请与系统管理员联系!", vbExclamation, "提示"
Exit Sub
End If
'ZLJ 20081017
' If Not IsNull(rsCmbDepartment.Fields("ID")) Then
' DEPARTMENT_ID = Trim(rsCmbDepartment.Fields("ID"))
' End If
cmbUsers.Clear
Call InitCmbUsers(DEPARTMENT_ID)
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation, "提示"
End Sub
'根据部门ID初始化用户COMBOBOX
Private Function InitCmbUsers(ByVal DepartmentID As Long) As Boolean
On Error GoTo ErrHandler
Dim strSql As String
Dim rsCmbUsers As New ADODB.Recordset
'id = ""
'If id = "" Then
' strSql = "select "
'End If
strSql = "SELECT ID,NAME FROM Doctor WHERE DepartmentId = '" + CStr(DepartmentID) + "'" + " AND ISDELETE ='否'"
If myConn.State <> adStateClosed Then
myConn.Close
End If
myConn.Open modGlobalDbConnect.GetConnectionString
If myConn.State = adStateClosed Then
MsgBox "数据库连接错误，请查看网络状态！", vbExclamation, "提示"
Exit Function
End If
rsCmbUsers.Open strSql, myConn
If rsCmbUsers.RecordCount <= 0 Then
InitCmbUsers = False
Exit Function
End If
Dim i As Integer
cmbUserId.Clear
cmbUsers.Clear
For i = 0 To rsCmbUsers.RecordCount - 1
cmbUserId.AddItem rsCmbUsers.Fields("ID")
cmbUsers.AddItem rsCmbUsers.Fields("Name")
rsCmbUsers.MoveNext
Next
If cmbUsers.ListCount > 0 And cmbUserId.ListCount > 0 Then
cmbUsers.ListIndex = 0
cmbUserId.ListIndex = 0
End If
InitCmbUsers = True
Exit Function
ErrHandler:
Debug.Print Err.Description
InitCmbUsers = False
End Function
Private Sub cmbUsers_Click()
On Error GoTo ErrHandler
If cmbUserId.ListCount > cmbUsers.ListIndex Then
cmbUserId.ListIndex = cmbUsers.ListIndex
End If
Exit Sub
ErrHandler:
'msgbox "",vbExclamation,"提示"
End Sub
'清空 操作
Private Sub cmdClear_Click()
On Error GoTo ErrHandler
txtCheckNumber.Text = ""
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -