frmdrreg.frm

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

        
        
Exit Sub
ErrHandler:
    


End Sub



Private Sub btnAddParts_Click()
On Error GoTo ErrHandler
    
    If Trim(cmbCheckPart1.Text) = "" Then
        MsgBox "请选择检查分类！", vbExclamation, "提示"
        Exit Sub
    End If
    
    If Trim(cmbCheckPart2.Text) = "" Then
        MsgBox "请选择检查部位！", vbExclamation, "提示"
        Exit Sub
    End If
    
    If Trim(cmbCheckMethod.Text) = "" Then
        MsgBox "请选择检查方式！", vbExclamation, "提示"
        Exit Sub
    End If
    
    If cmbAgensName.Enabled = True Then
        If Trim(cmbAgensName.Text) = "" Then
            MsgBox "请选择造影剂名！", vbExclamation, "提示"
            Exit Sub
        End If
    End If
    
    If cmbGosage.Enabled = True Then
        If Trim(cmbGosage.Text) = "" Then
            MsgBox "请选择造影剂量！", vbExclamation, "提示"
            Exit Sub
        End If
    End If
    
    
    If Len(Trim(cmbCheckPart1.Text)) <= 0 Or Len(Trim(cmbCheckPart2.Text)) <= 0 _
        Or Len(Trim(cmbCheckMethod.Text)) <= 0 Then
        Exit Sub
    Else
        Dim strAddCheck As String
        strAddCheck = Trim(cmbCheckPart1.Text) + "_" + Trim(cmbCheckPart2.Text) _
        + "_" + Trim(cmbCheckMethod.Text) ' + "_" + Trim(cmbCharge.Text)
        
        lstCheck.AddItem strAddCheck
    End If
    
    
    
    Exit Sub
ErrHandler:
End Sub

Private Sub btnExit_Click()
    On Error GoTo ErrHandler
    Unload Me
    
    Exit Sub
ErrHandler:
    Unload Me
End Sub



'按钮事件----保存修改后的患者信息
Private Sub btnSave_Click()
On Error GoTo ErrHandler
    '病人姓名判断
    If Trim(txtCheckNumber.Text) = "" Then
        MsgBox "请输入就诊者编号!", vbExclamation, "提示"
        Exit Sub
    End If
    
    Dim strSql As String
    strSql = "SELECT ID FROM CHECK_LIST WHERE FILM_NO = '" _
        + Trim(txtCheckNumber.Text) + "'"
    If GetRecordNumber(strSql) > 0 Then
        MsgBox "该就诊者编号已存在, 请重新添加!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If stringCheck(Trim(txtCheckNumber.Text)) = False Then
        Exit Sub
    End If
    
    If Trim(txtPatientName.Text) = "" Then
        MsgBox "请输入就诊者姓名!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If stringCheck(Trim(txtPatientName.Text)) = False Then
        Exit Sub
    End If
    
    If Trim(txtPatientAge.Text) = "" Then
        MsgBox "请输入就诊者年龄!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If lstCheck.ListCount <= 0 Then
        MsgBox "请添加部位信息！", vbExclamation, "提示"
        Exit Sub
    End If
    
    
    If Trim(cmbApplyDepartment.Text) = "" Then
        MsgBox "请选择申请科室！", vbExclamation, "提示"
        Exit Sub
    End If
    
    If Trim(cmbApplyDoctorName.Text) = "" Then
        MsgBox "请选择申请医生！", vbExclamation, "提示"
        Exit Sub
    End If
    
    If stringCheck(Trim(txtHospitalNumber.Text)) = False Then
        Exit Sub
    End If
    
    If stringCheck(Trim(txtBedNumber.Text)) = False Then
        Exit Sub
    End If
    
    Dim rsInsert As New ADODB.Recordset
    
    If rsInsert.State = adStateOpen Then
        rsInsert.Close
    End If
    
    
        
    '===事务处理开始====================================================
    Dim myConn As New ADODB.Connection
    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
    
    myConn.BeginTrans '开始
    
'    rsInsert.Open "Select * from CHECK_LIST WHERE  APPLY_DOCT_ID = '" + USER_DISPLAY_NAME + "'", myConn, adOpenDynamic, adLockOptimistic
rsInsert.Open "Select * from CHECK_LIST WHERE  1 =0 ", myConn, adOpenDynamic, adLockOptimistic
    If rsInsert.EOF = True Then
        rsInsert.AddNew
    
    strSql = "SELECT CHECKLIST_SEQUENCE.NEXTVAL FROM DUAL"
        Dim rsGetID As New ADODB.Recordset
        If rsGetID.State = adStateOpen Then
            rsGetID.Close
        End If

        rsGetID.Open strSql, myConn
        CHECK_LIST_ID = rsGetID.Fields(0)
        rsInsert.Fields("ID") = rsGetID.Fields(0)
        rsInsert.Fields("PATIENT_ID") = Trim(txtCheckNumber.Text)
        rsInsert.Fields("PATIENT_NAME") = Trim(txtPatientName.Text)
        If Trim(cmbPatientSex.Text) <> "" Then
            rsInsert.Fields("PATIENT_SEX") = Trim(cmbPatientSex.Text)
        Else
            rsInsert.Fields("PATEINT_SEX") = "不详"
        End If
        
        If Trim(txtPatientAge.Text) <> "" Then
            rsInsert.Fields("PATIENT_AGE") = Trim(txtPatientAge.Text)
        Else
            rsInsert.Fields("PATIENT_AGE") = 0
        End If
        
        If Trim(cmbAgeWeigh.Text) <> "" Then
            rsInsert.Fields("AGE_WEIGHT") = Trim(cmbAgeWeigh.Text)
        Else
            rsInsert.Fields("AGE_WEIGHT") = "岁"
        End If
        
        If CStr(dtBirthday.Value) <> "" Then
            rsInsert.Fields("PATIENT_BIRTHDAY") = dtBirthday.Value
        Else
            rsInsert.Fields("PATIENT_BIRTHDAY") = Now
        End If
        
        
        If cmbState.Text <> "" Then
            rsInsert.Fields("STATE") = Trim(cmbState.Text)
        End If
                
        If CStr(Trim(DEPARTMENT_ID)) <> "" Then
            rsInsert.Fields("PHOTO_DEPT_ID") = CStr(Trim(DEPARTMENT_ID))
        End If
        
        If Trim(USER_DISPLAY_NAME) <> "" Then
            rsInsert.Fields("PHOTO_DOCT_ID") = Trim(USER_DISPLAY_NAME)
        End If
        
'        If Trim(txtFee.Text) <> "" Then
'            rsInsert.Fields("CHECK_FEE") = Trim(txtFee.Text)
'        End If
        
        If Trim(txtHospitalNumber.Text) <> "" Then
            rsInsert.Fields("HOSPITAL_NUM") = Trim(txtHospitalNumber.Text)
        End If
        If Trim(txtBedNumber.Text) <> "" Then
            rsInsert.Fields("BED_NUM") = Trim(txtBedNumber.Text)
        End If
        If cmbApplyDepartmentID.Text <> "" Then
            rsInsert.Fields("APPLY_DEPT_ID") = Trim(cmbApplyDepartmentID.Text)
        End If
        If cmbApplyDoctorName.Text <> "" Then
            rsInsert.Fields("APPLY_DOCT_ID") = Trim(cmbApplyDoctorName.Text)
        End If
        rsInsert.Fields("APPLY_DATE") = Now
        If lblRegisterDoctor.Caption <> "" Then
            rsInsert.Fields("REG_DOCT_ID") = Trim(lblRegisterDoctor.Caption)
        End If
        
        rsInsert.Fields("REG_DATE") = Now
        If STATION_NAME <> "" Then
            rsInsert.Fields("MACHINE_NAME") = Trim(STATION_NAME)
        End If
        
        rsInsert.Fields("FILM_NO") = Trim(txtCheckNumber.Text)
        rsInsert.Update
        
    End If
    
    '若部位列表框不为空，还需更新登记部位
    If lstCheck.ListCount > 0 Then
        Dim i As Integer
        Dim strCheckMainPart As String
        Dim strCheckSubPart As String
        Dim strCheckMothod As String
        Dim strSubPart As String
        Dim nStart As Long
        Dim nLeng As Long
        
        For i = 0 To lstCheck.ListCount - 1
       
            lstCheck.ListIndex = i
            nStart = InStr(lstCheck.Text, "_")  '第1个下划线位置
            strCheckMainPart = Trim(left(lstCheck.Text, nStart - 1))
            strSubPart = Trim(Mid(lstCheck.Text, nStart + 1, Len(lstCheck.Text) - nStart))

            '第2个下划线位置
            nStart = InStr(strSubPart, "_")
            strCheckSubPart = Trim(left(strSubPart, nStart - 1))
            strCheckMothod = Trim(right(strSubPart, Len(strSubPart) - nStart))
            
            If Trim(txtFee.Text) = "" Then
                txtFee.Text = "0"
            End If
            
            Dim strAgensName As String
            Dim strgosage As String
            If Trim(cmbAgensName.Text) <> "" And Trim(cmbGosage.Text) <> "" Then
                'zlj 20080916
                If (Trim(cmbCharge.Text) <> "") Then
                    cmbCharge.Text = CStr(CLng(cmbCharge.Text))  ' + CLng(Trim(txtFee.Text)))
                Else
                    cmbCharge.Text = "0"
                End If
                strAgensName = Trim(cmbAgensName.Text)
                strgosage = Trim(cmbGosage.Text)
            Else
                strAgensName = "未知"
                strgosage = "未知"
            End If
            
            If Trim(cmbCharge.Text) = "" Then
                cmbCharge.Text = "0"
            End If
            
            If Trim(txtFee.Text) = "" Then
                txtFee.Text = "0"
            End If
            
            strSql = "INSERT INTO CHECK_PART ( ID,PATIENT_ID,EXAM_CLASS,EXAM_SUB_CLASS, METHOD," _
                + " IS_PHOTO_DELETED,PERFORMED_DATE,CHECK_LIST_ID,CHARGES,ZYJMC,ZYJJL,GOSAGE_FEE)" _
               + " VALUES (CHECK_PART_SEQUENCE.NEXTVAL,'" + Trim(txtCheckNumber.Text) + "' " _
                + " ,'" + strCheckMainPart + "','" + strCheckSubPart + "','" + strCheckMothod + "' " _
                + " ,'否','" + CStr(Now) + "','" + CStr(Trim(CHECK_LIST_ID)) + "'" _
                + " ,'" + CStr(Trim(cmbCharge.Text)) + "','" + Trim(cmbAgensName.Text) + "" _
                + " ','" + Trim(cmbGosage.Text) + "','" + Trim(txtFee.Text) + "')"
            
            If myConn.State = adStateClosed Then
                myConn.Open modGlobalDbConnect.GetConnectionString
            End If
            
            
            If myConn.State = adStateClosed Then
                MsgBox "数据库连接错误，请查看网络状态！", vbExclamation, "提示"
                Exit Sub
            End If
    
            If rsInsert.State = adStateOpen Then
                rsInsert.Close
            End If
            
            rsInsert.Open strSql, myConn
                
    Next
    
'
'
'
'
'
'            For i = 0 To lstCheck.ListCount - 1
'                If lstCheck.ListCount > i Then
'                    lstCheck.ListIndex = i
'                End If
'
'                nStart = InStr(lstCheck.Text, "_")  '第1个下划线位置
'                strCheckMainPart = Left(lstCheck.Text, nStart - 1)
'                strSubPart = Mid(lstCheck.Text, nStart + 1, Len(lstCheck.Text) - nStart)
'
'                '第2个下划线位置
'                nStart = InStr(strSubPart, "_")
'                strCheckSubPart = Left(strSubPart, nStart - 1)
'                strCheckMothod = Right(strSubPart, Len(strSubPart) - nStart)
'
'                strSql = "SELECT *  FROM CHECK_PART " _
'                    + " WHERE CHECK_LIST_ID ='" + CStr(CHECK_LIST_ID) + "'"
'                Dim rsParts As New ADODB.Recordset
'                If rsParts.State = adStateOpen Then
'                    rsParts.Close
'                End If
'
'                rsParts.Open strSql, myConn, adOpenKeyset, adLockOptimistic
'                If rsParts.EOF = True Then
'                    rsParts.AddNew
'
'                    strSql = "SELECT CHECK_PART_SEQUENCE.NEXTVAL FROM DUAL"
'                        If rsGetID.State = adStateOpen Then
'                            rsGetID.Close
'                        End If
'
'                rsGetID.Open strSql, myConn
'                rsParts.Fields("ID") = rsGetID.Fields(0)
'
'
'
'                If Trim(txtCheckNumber.Text) <> "" Then
'                    rsParts.Fields("PATIENT_ID") = Trim(txtCheckNumber.Text)
'                Else
'                    Exit Sub
'                End If
'
'
'                If Trim(strCheckMainPart) <> "" Then
'                    rsParts.Fields("EXAM_CLASS") = strCheckMainPart
'                End If
'
'                If Trim(strCheckSubPart) <> "" Then
'                    rsParts.Fields("EXAM_SUB_CLASS") = strCheckSubPart
'                End If
'
'                If Trim(strCheckMothod) <> "" Then
'                    rsParts.Fields("METHOD") = strCheckSubPart
'                End If
'
'                rsParts.Fields("IS_PHOTO_DELETED") = "否"
'                rsParts.Fields("PERFORMED_DATE") = Now
'                rsParts.Fields("CHECK_LIST_ID") = CHECK_LIST_ID
'