frmdrreg.frm

1、以DLL形式提供医生工作站 2、 根据【检查项目】

'                rsParts.Update
'
'                rsParts.MoveNext
'            Next
''        End If
'
    
    End If
    
    If Err.Number = 0 Then
        myConn.CommitTrans '---提交事務
        MsgBox "保存成功!", vbExclamation, "提示"
    Else
        myConn.RollbackTransaction
        MsgBox "保存失败!", vbExclamation, "提示"
    End If
    '===事务处理结束====================================================
    
    
    txtCheckNumber.Text = ""
    txtPatientName.Text = ""
    txtMachineCheckNumber.Text = ""
    cmbPatientSex.ListIndex = 0
    txtPatientAge.Text = ""
    cmbAgeWeigh.ListIndex = 0
    cmbCheckPart1.ListIndex = -1
    cmbCheckPart2.ListIndex = -1
    'cmbCheckMethod.ListIndex = -1
    txtFee.Text = "0.00"
    lstCheck.Clear
    txtHospitalNumber.Text = ""
    txtBedNumber.Text = ""
    cmbApplyDepartment.ListIndex = -1
    cmbApplyDoctorName.ListIndex = -1
    
    
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbAbortRetryIgnore, "提示"
    Unload Me
End Sub


Private Sub cmbApplyDepartment_Click()
On Error GoTo ErrHandler
    If cmbApplyDepartment.ListIndex = -1 Then
        Exit Sub
    Else
        cmbApplyDepartmentID.ListIndex = cmbApplyDepartment.ListIndex
    End If
    
    Call InitApplyDoctor(cmbApplyDepartment.Text)
    Exit Sub
ErrHandler:

End Sub



Private Sub cmbCharge_KeyPress(KeyAscii As Integer)
On Error GoTo ErrHandler
    '只允许退格键和数字键
    If KeyAscii <> 8 And KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
        KeyAscii = 0
    End If
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub



Private Sub cmbCharge_KeyUp(KeyCode As Integer, Shift As Integer)
On Error GoTo ErrHandler
    upDownFee.Value = CLng(cmbCharge.Text)
    Exit Sub
ErrHandler:
End Sub




Private Sub cmbCheckMethod_Click()
On Error GoTo ErrHandler
    upDownFee.Enabled = True
    cmbCharge.Enabled = True
     upDownFee.Enabled = True
     If Trim(cmbCharge.Text) = "" Then
        upDownFee.Value = 0
    Else
        upDownFee.Value = CLng(cmbCharge.Text)
    End If
    If Trim(cmbCheckMethod.Text) = "平扫" Then
        cmbAgensName.Text = ""
        cmbGosage.Text = ""
        txtFee.Text = ""
        cmbGosage.Enabled = False
        cmbAgensName.Enabled = False
        txtFee.Enabled = False
    Else
        cmbGosage.Enabled = True
        cmbAgensName.Enabled = True
        txtFee.Enabled = True
    End If


    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

'Private Sub cmbCheckMethod_Click()
'On Error GoTo ErrHandler
'    If lstCheck.ListCount >= nCheckPartCount Then
'        MsgBox "该患者登记部位已满!", vbExclamation, "提示"
'
'        Exit Sub
'    End If
'
'    cmbCharge.ListIndex = cmbCheckMethod.ListIndex
'    upDownFee.Value = cmbCharge.Text
'    If Trim(cmbCheckMethod.Text) = "平扫" Then
'        cmbGosage.Enabled = False
'        cmbAgensName.Enabled = False
'        txtFee.Enabled = False
'    Else
'        cmbGosage.Enabled = True
'        cmbAgensName.Enabled = True
'        txtFee.Enabled = True
'    End If
'
'
'Exit Sub
'ErrHandler:
'End Sub

'主部位--单击事件
Private Sub cmbCheckPart1_Click()
On Error GoTo ErrHandler
    If cmbCheckPart1.ListIndex = -1 Then
        Exit Sub
    End If
    Call InitSubCheck(Trim(cmbCheckPart1.Text))
    
    Exit Sub
ErrHandler:
    
End Sub


'子部位--单击事件
Private Sub cmbCheckPart2_Click()
On Error GoTo ErrHandler
    If cmbCheckPart2.ListIndex = -1 Then
        Exit Sub
    End If
    Call InitCheckMethod(Trim(cmbCheckPart1.Text), Trim(cmbCheckPart2.Text))
    
    Exit Sub
ErrHandler:
    
End Sub


Private Sub Command1_Click()
On Error GoTo ErrHandler
    txtCheckNumber.Text = ""
    txtPatientName.Text = ""
    txtMachineCheckNumber.Text = ""
    cmbPatientSex.ListIndex = 0
    txtPatientAge.Text = ""
    cmbAgeWeigh.ListIndex = 0
    cmbCheckPart1.ListIndex = -1
    cmbCheckPart2.ListIndex = -1
    'cmbCheckMethod.ListIndex = -1
    txtFee.Text = "0.00"
    lstCheck.Clear
    txtHospitalNumber.Text = ""
    txtBedNumber.Text = ""
    cmbApplyDepartment.ListIndex = -1
    cmbApplyDoctorName.ListIndex = -1
    
    Exit Sub
ErrHandler:
End Sub

Private Sub dtBirthday_Click()
On Error Resume Next
    
    Call GetAgeByDate
    
End Sub
Private Sub GetAgeByDate()
On Error GoTo ErrHandler
    
    If Trim(dtBirthday.Value) = "" Then
        Exit Sub
    End If
    
    Dim dtDiff As Long
    
    '年的比较---------------------------------------------------------------------------------
    '该函数实际操作为now-dtBirthday.Value
    'MSDN
    'DateDiff("yyyy", date1, date2)
    '如果 date1 比 date2 来得晚，则 DateDiff 函数的返回值为负数
    dtDiff = DateDiff("yyyy", dtBirthday.Value, Now)
    If dtDiff < 0 Then
        dtBirthday.UpDown = False
        dtBirthday.Value = Now
        txtPatientAge.Text = ""
        MsgBox "出生日期不可迟于当前日期, 请重新选择!", vbExclamation, "提示"
        Exit Sub
    End If
    
    '选择的日期早于当前日期
    If dtDiff > 0 Then
        txtPatientAge.Text = dtDiff
        cmbAgeWeigh.ListIndex = 0    '"年"
        Exit Sub
    End If
    
    'dtDiff = 0
    '月的比较---------------------------------------------------------------------------------
    dtDiff = DateDiff("m", dtBirthday.Value, Now)
    If dtDiff < 0 Then
        dtBirthday.UpDown = False
        dtBirthday.Value = Now
        txtPatientAge.Text = ""
        MsgBox "出生日期不可迟于当前日期, 请重新选择!", vbExclamation, "提示"
        Exit Sub
    End If
    
    '选择的日期早于当前日期
    If dtDiff > 0 Then
        txtPatientAge.Text = dtDiff
        cmbAgeWeigh.ListIndex = 1     '   "月"
        Exit Sub
    End If
    
    '天的比较---------------------------------------------------------------------------------
    dtDiff = DateDiff("d", dtBirthday.Value, Now)
    If dtDiff < 0 Then
        dtBirthday.UpDown = False
        dtBirthday.Value = Now
        txtPatientAge.Text = ""
        MsgBox "出生日期不可迟于当前日期, 请重新选择!", vbExclamation, "提示"
        Exit Sub
    End If
    
    '选择的日期早于当前日期
    If dtDiff >= 0 Then
        txtPatientAge.Text = dtDiff
        cmbAgeWeigh.ListIndex = 2 '"天"
        Exit Sub
    End If
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub


Private Sub dtBirthday_LostFocus()
On Error GoTo ErrHandler
    Call GetAgeByDate
    Exit Sub
ErrHandler:
End Sub

Private Sub Form_Activate()
On Error GoTo ErrHandler
    With upDownFee
        .BuddyControl = cmbCharge
        .Min = 0
        .Max = 100000
        .Increment = 1
        .Wrap = True
    End With
    cmbCharge.Text = 0
    cmbAgensName.ListIndex = -1
    cmbGosage.ListIndex = -1
    'CHECK_LIST_ID = CStr(frmCheckList.curList_ID)
    
    '初始患者信息
    'Call InitPatientInfo
    
    '初始化患者检查部位个数及各部位
    'Call GetCheckPart(Trim(txtCheckPart.Text), nCheckPartCount, CheckParts)
    nCheckPartCount = CHECKPARTCOUNT
    
    '初始化检查主部位
    Call InitCheckPart
    cmbCheckMethod.ListIndex = 0
    
    
    '初始化患者状态
    Call InitializeState
    
    '初始化申请科室
    Call InitApplyDepartment
    
    cmbPatientSex.ListIndex = 0
    cmbAgeWeigh.ListIndex = 0
    lblRegisterDoctor.Caption = USER_DISPLAY_NAME
    Exit Sub
ErrHandler:
End Sub

Private Sub Form_Load()
    On Error GoTo ErrHandler
    
    Exit Sub
ErrHandler:
    
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    '回车键
    If KeyAscii = 13 Then
        btnSave_Click
    End If
End Sub


Private Sub Form_Resize()
On Error GoTo ErrHandler
    '**自身调整****************************************************************
    Me.Top = frmSubTop.Top + frmSubTop.Height
    Me.left = frmSubLeft.Width + frmSubLeft.left
    Me.Width = RIGHT_WINDOW_WIDTH
    Me.Height = RIGHT_WINDOW_HEIGHT
    
    '************************************************************************
    Me.frmResult.Width = RIGHT_WINDOW_WIDTH - 2 * Me.frmResult.left
    Me.frmResult.Height = RIGHT_WINDOW_HEIGHT - 80
 
    
    Me.frmPatientInfo.Width = Me.Width - 2 * Me.frmPatientInfo.left
 
    Me.frmCheck.Width = Me.Width - 2 * Me.frmCheck.left
    Me.frmCheck.Height = Me.Height - Me.frmPatientInfo.Height - 2 * Me.frmPatientInfo.Top
    
    
    


Exit Sub
ErrHandler:

End Sub


'根据检查部位组合，获取检查部位及个数
Private Function GetCheckPart(ByVal p_strCheckPart As String, ByRef p_nCheckPartCount As Long, ByRef p_strCheckParts() As String) As Boolean
On Error GoTo ErrHandler
    'SPLIT_SIGN
    
    '===获取检查部位个数===================================================
    Dim nCheckCount As Long
    nCheckCount = 0
    
    Dim strCheckPart As String
    strCheckPart = p_strCheckPart
    
    
    Dim nPos As Long
    nPos = InStr(strCheckPart, SPLIT_SIGN)
    While nPos > 0
        nCheckCount = nCheckCount + 1
        strCheckPart = right(strCheckPart, Len(strCheckPart) - nPos)
        
        
        nPos = InStr(strCheckPart, SPLIT_SIGN)
    Wend
    p_nCheckPa