frmsickmanage.frm

VB6.0编写的医院影像系统

    
    sSQL = "select distinct checkdate as checkdate from sick_info "
    Set rsDate = GDB.Execute(sSQL)
    With rsDate
    Do While Not .EOF
        Set Nodx = trvSickInfo.Nodes.Add("*-1", tvwChild, "k" & rsDate!CheckDate, rsDate!CheckDate, 1)
        Nodx.Tag = rsDate!CheckDate
'        Call AddSickCode(rsDate!CheckDate)
        .MoveNext
    Loop
    End With
    
    trvSickInfo.Nodes(1).Selected = True
    
    rsDate.Close
    Set rsDate = Nothing
    
End Sub

Private Sub AddSickCode(ByVal sKey As String)
Dim sSQL As String
Dim sDate As Date
Dim tNodex As MSComctlLib.Node
Dim rsSick As ADODB.Recordset

    sDate = Mid(sKey, 1)
    sSQL = "select sick_id,sick_no,sick_name from sick_info where checkdate='" & sDate & "'"

    Set rsSick = GDB.Execute(sSQL)
    With rsSick
    Do While Not .EOF
        Set tNodex = trvSickInfo.Nodes.Add(sKey, tvwChild, "K" & CStr(rsSick!sick_id), rsSick!SICK_NO & " " & rsSick!SICK_NAME, 2)
        tNodex.Tag = rsSick!sick_id
        .MoveNext
    Loop
    End With

    rsSick.Close
    Set rsSick = Nothing
    
    If Not trvSickInfo.Nodes(1).Expanded Then trvSickInfo.Nodes(1).Expanded = True
    
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If msStatus = "New" Or msStatus = "Modify" Then
        If MsgBox("确认要退出病人信息登记吗？", vbQuestion + vbYesNo, "提示") = vbYes Then
            Cancel = False
        Else
            Cancel = True
            Exit Sub
        End If
    Else
        Cancel = False
    End If
End Sub


'**********************************************************
'功    能：响应各种操作
'**********************************************************
'Private Sub tlbToolsDO(ByVal Tool As ActiveBarLibraryCtl.Tool)
'On Error GoTo err
'Dim IsSave As Boolean
'Dim NodeX As Object
'
'    Select Case Tool.Name
'        Case gACTBAR_TOOL_ADD
'            mlSickID = 0                   '表示新增单据的序号为0
'            msStatus = "New"
'            iOldOperateStatus = iOperateStatus
'            iOperateStatus = genuTktOperate.CST_TYPE_NEWADD
'
'            Call iniTkt
'            Call SetTktLocked(msStatus)
'
'            trvSickInfo.DropHighlight = trvSickInfo.SelectedItem
'            Call SetToolEnable(tlbTools, iOperateStatus, trvSickInfo.SelectedItem)
'        Case gACTBAR_TOOL_MODIFY
'            msStatus = "Modify"
'            iOldOperateStatus = iOperateStatus
'            iOperateStatus = genuTktOperate.CST_TYPE_MODIFY
'
'            txtModifyDate.Text = Format(Date, "YYYY-MM-DD")
'            Call SetTktLocked(msStatus)
'            Call SetToolEnable(tlbTools, iOperateStatus, trvSickInfo.SelectedItem)
'        Case gACTBAR_TOOL_DELETE
''            If Not CheckCurTktValid(tvwHeader, lCurTktID, lCurNodeIndex) Then Exit Sub
''            If pMsgbox("你确认要删除单据" & tvwHeader.SelectedItem.Text & "？", vbQuestion + vbYesNo) = vbNo Then
''                Exit Sub
''            End If
''            lCurTktID = IIf(Left(tvwHeader.SelectedItem.Key, Len(TREEKEY)) <> TREEKEY, 0, CLng(tvwHeader.SelectedItem.Tag))
''            iOldOperateStatus = iOperateStatus
''            iOperateStatus = genuTktOperate.CST_TYPE_DELETE
''            If DoEditTkt(iOperateStatus, lCurTktID) Then
''                Call SaveInTkt(iOperateStatus, lCurTktID, cTkt, Me.spdDetail)
''                iOldOperateStatus = iOperateStatus
''                iOperateStatus = genuTktOperate.CST_TYPE_INIT
''                Call SetOperateTktDtl(iOperateStatus)
''            Else
''                iOperateStatus = iOldOperateStatus
''            End If
''            Call SetToolEnable(tlbTools, iOperateStatus, tvwHeader.SelectedItem)
'        Case gACTBAR_TOOL_SAVE
''            RefreshDataBeforeSave spdDetail
''            tlbTools.SetFocus
''
''            If iOperateStatus <> genuTktOperate.CST_TYPE_NEWADD Then
'            If Not CheckTktValid Then Exit Sub
''            End If
''            IsSave = False
'
'            Call SaveTktInfo
'
''            iOldOperateStatus = iOperateStatus
''            iOperateStatus = genuTktOperate.CST_TYPE_SAVE
'            Call SetTktLocked(msStatus)
'            Call SetToolEnable(tlbTools, iOperateStatus, trvSickInfo.SelectedItem)
'            trvSickInfo.Enabled = True
'
'
'        Case gACTBAR_TOOL_CANCEL
'            iOldOperateStatus = iOperateStatus
'            iOperateStatus = genuTktOperate.CST_TYPE_CANCEL
'            If Trim(txtCode.Text) <> "" Or Trim(txtName.Text) <> "" Then
'                If MsgBox("你确认要取消新增吗？", vbQuestion + vbYesNo, "取消内容") = vbNo Then
'                    Exit Sub
'                End If
'            End If
'            Call CancelOperate
'            Call SetToolEnable(tlbTools, iOperateStatus, trvSickInfo.SelectedItem)
'        Case gACTBAR_TOOL_EXIT
'            Unload Me
'    End Select
'
'
'    Exit Sub
'err:
'    iOperateStatus = iOldOperateStatus
'    Call SetToolEnable(tlbTools, iOperateStatus, trvSickInfo.SelectedItem)
'
'End Sub

Private Function CheckTktValid() As Boolean
    
    CheckTktValid = False
    If Trim(txtCode.Text) = "" Or Trim(txtName.Text) = "" Then
        Exit Function
    End If
    CheckTktValid = True

End Function
Private Sub CancelOperate()
    
    msStatus = "Init"
    iniTkt
    SetTktLocked (msStatus)
    
End Sub
''*********************************************************
''功    能：使ActiveBar上所有的Tool都可以使用（即有效）
''修改日期：2002.09.11
''**********************************************************
'Public Sub SetAllToolEnable(ByRef cActiveBar As cTktTlbControl, Optional ByVal IsEnable As Boolean = True)
'On Error GoTo err
'
'    With cActiveBar
'        .tlAddNewEnable = IsEnable
'        .tlCancelEnable = IsEnable
'        .tlDeleteEnable = IsEnable
'        .tlExitEnable = IsEnable
'        .tlModifyEnable = IsEnable
'        .tlSaveEnable = IsEnable
'        .tlFindVisible = False
'        .tlInformationVisible = False
'        .tlPreviewVisible = False
'        .tlPrintVisible = False
'    End With
'
'    Exit Sub
'err:
'    err.Raise err.Number, err.Source, err.Description
'End Sub
'
'
''**********************************************************
''功    能：设置ActiveBar 上的各个Tool的Enable的值
''参    数：gOperateType =当前操作类型
''           trvNode = 树节点
''           sRight=操作员权限,具体实现待定
''修改日期：2002.09.11
''**********************************************************
'Public Sub SetToolEnable(ByRef cActiveBar As cTktTlbControl, ByVal gOperateType As genuTktOperate, _
'                ByVal trvNode As Node, Optional ByVal sRight As String = "")
'On Error GoTo err
'
'    Call SetAllToolEnable(cActiveBar, True)
'    With cActiveBar
'        Select Case gOperateType
'            Case genuTktOperate.CST_TYPE_INIT              '单据初始化操作状态
'                .tlAddNewEnable = True
'                .tlModifyEnable = False
'                .tlDeleteEnable = False
'                .tlCancelEnable = False
'                .tlSaveEnable = False
'                .tlExitEnable = True
'            Case genuTktOperate.CST_TYPE_CANCEL             '单据取消当前操作状态
'                .tlAddNewEnable = True
'                .tlModifyEnable = False
'                .tlDeleteEnable = False
'                .tlCancelEnable = False
'                .tlSaveEnable = False
'                .tlExitEnable = True
'            Case genuTktOperate.CST_TYPE_INFO              '单据删除状态
'                .tlAddNewEnable = True
'                .tlModifyEnable = True
'                .tlDeleteEnable = True
'                .tlCancelEnable = False
'                .tlSaveEnable = False
'                .tlExitEnable = True
'            Case genuTktOperate.CST_TYPE_DELETE             '单据删除状态
'                .tlAddNewEnable = False
'                .tlModifyEnable = False
'                .tlDeleteEnable = True
'                .tlCancelEnable = False
'                .tlSaveEnable = False
'                .tlExitEnable = True
'            Case genuTktOperate.CST_TYPE_MODIFY             '单据修改状态
'                .tlAddNewEnable = False
'                .tlModifyEnable = False
'                .tlDeleteEnable = False
'                .tlCancelEnable = True
'                .tlSaveEnable = True
'                .tlExitEnable = False
'            Case genuTktOperate.CST_TYPE_NEWADD             '单据新增状态
'                .tlAddNewEnable = False
'                .tlModifyEnable = False
'                .tlDeleteEnable = False
'                .tlCancelEnable = True
'                .tlSaveEnable = True
'                .tlExitEnable = False
'             Case genuTktOperate.CST_TYPE_CANCEL              '单据新增状态
'                .tlAddNewEnable = True
'                .tlModifyEnable = False
'                .tlDeleteEnable = False
'                .tlCancelEnable = False
'                .tlSaveEnable = False
'                .tlExitEnable = True
'            Case genuTktOperate.CST_TYPE_SAVE               '单据保存当前操作状态
'                ToolEnableByStatus cActiveBar, trvNode, gACTBAR_TOOL_ADD
'                ToolEnableByStatus cActiveBar, trvNode, gACTBAR_TOOL_CANCEL
'                ToolEnableByStatus cActiveBar, trvNode, gACTBAR_TOOL_DELETE
'                ToolEnableByStatus cActiveBar, trvNode, gACTBAR_TOOL_MODIFY
'                ToolEnableByStatus cActiveBar, trvNode, gACTBAR_TOOL_SAVE
'                .tlExitEnable = True
'        End Select
'        .InitTools
'    End With
'
'    Exit Sub
'err:
'    err.Raise err.Number, err.Source, err.Description
'End Sub


Private Sub SetSickInfo(ByVal lSickID As Long)
Dim sSQL As String
Dim i As Long
Dim rsSickInfo As ADODB.Recordset

    sSQL = "select * from sick_info where sick_id=" & lSickID
    Set rsSickInfo = GDB.Execute(sSQL)
    With rsSickInfo
    Do While Not .EOF
        txtCode.Text = rsSickInfo!SICK_NO
        txtName.Text = rsSickInfo!SICK_NAME
        txtCheckDate.Text = Format(rsSickInfo!CheckDate, "YYYY-MM-DD")
        txtModifyDate.Text = Format(rsSickInfo!ModifyDate, "YYYY-MM-DD")
        DTPicker1.Value = rsSickInfo!SICK_BIRTH
        For i = 0 To Combo1.ListCount - 1
            Combo1.ListIndex = i
            If Combo1.Text = rsSickInfo!SICK_CLASS Then
                Exit For
            End If
        Next i
        
        For i = 0 To Combo2.ListCount - 1
            Combo2.ListIndex = i
            If Combo2.ItemData(i) = rsSickInfo!SICK_SEX Then
                Exit For
            End If
        Next i
        
        RichTextBox1.Text = rsSickInfo!SICK_UNIT
        RichTextBox2.Text = rsSickInfo!SICK_FAMILY
        
        .MoveNext
    Loop
    End With
    
    rsSickInfo.Close
    Set rsSickInfo = Nothing

End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)

    Select Case Button.Key
        Case "New"
            frmSetSickInfo.msStatus = "New"
            frmSetSickInfo.Show vbModal
        Case "Delete"
        
        Case "Exit"
            Unload Me
    End Select
    
End Sub

Private Sub trvSickInfo_Click()
'Dim NodeX As MSComctlLib.Node
'
'    Set NodeX = trvSickInfo.SelectedItem
'    Select Case Left(NodeX.Key, 1)
'        Case "K"
'            msStatus = "Init"
'            mlSickID = NodeX.Tag
''            iOperateStatus = genuTktOperate.CST_TYPE_INFO
'            Call SetSickInfo(mlSickID)
'            Call SetTktLocked(msStatus)
'        Case Else
''            iOperateStatus = genuTktOperate.CST_TYPE_INIT
'    End Select
'
'    trvSickInfo.DropHighlight = trvSickInfo.SelectedItem
''    Call SetToolEnable(tlbTools, iOperateStatus, NodeX)

Dim Nodex As MSComctlLib.Node
Dim rsDetail As ADODB.Recordset
Dim lsvItem As MSComctlLib.ListItem
Dim tCheckDate As Date
Dim iCount As Long
Dim sSQL As String
Dim lRow As Long
    
    trvSickInfo.DropHighlight = trvSickInfo.SelectedItem
    
    If trvSickInfo.SelectedItem.Index > 1 Then
        Set Nodex = trvSickInfo.SelectedItem
        tCheckDate = Nodex.Tag
    Else
        lsvSick.ListItems.Clear
        Exit Sub
    End If
                

    sSQL = "select * from sick_info where checkdate= '" & tCheckDate & "' order by sick_no"
    Set rsDetail = GDB.Execute(sSQL)
    
    lsvSick.ListItems.Clear
    
    iCount = 1
    With rsDetail
    Do While Not .EOF
       Set lsvItem = lsvSick.ListItems.Add(iCount, "U" & iCount)
       lsvItem.Text = rsDetail!SICK_NO
       lsvItem.SubItems(1) = rsDetail!SICK_NAME
       lsvItem.SubItems(2) = rsDetail!SICK_SEX
       lsvItem.SubItems(3) = rsDetail!SICK_BIRTH
       lsvItem.Tag = rsDetail!sick_id
       iCount = iCount + 1
       .MoveNext
    Loop
    End With
    
'    If lsvDetail.ListItems.Count >= 1 Then
'        lsvDetail.ListItems(1).Selected = True
'    End If
    
    rsDetail.Close
    Set rsDetail = Nothing

End Sub

Private Sub trvSickInfo_NodeClick(ByVal Node As MSComctlLib.Node)
    Call trvSickInfo_Click
End Sub

'Private Sub txtcode_KeyDown(KeyCode As Integer, Shift As Integer)
'
'    EnterToTab KeyCode
'
'End Sub

'Private Sub txtCode_LostFocus()
'Dim sSQL As String
'Dim sCode As String
'Dim rs As ADODB.Recordset
'
'    sCode = Trim(txtCode.Text)
'    sSQL = "select * from sick_info where sick_no='" & sCode & "'"
'    Set rs = GDB.Execute(sSQL)
'    With rs
'    If Not .EOF Then
'        MsgBox "该病人号码已存在！", vbCritical + vbOKOnly, "提示"
'    End If
'    End With
'
'    rs.Close
'    Set rs = Nothing
'
'End Sub

'Private Sub txtname_KeyDown(KeyCode As Integer, Shift As Integer)
'
'    EnterToTab KeyCode
'
'End Sub