dlgfzmaintain.frm

本系统可用于医院和专业体检中心的健康体检管理

            rstemp.MoveNext
        Loop
        rstemp.Close
    End If
    
    '显示个人信息
    If enuOperation = Modify Then
        strSQL = "select SET_GRXX.*,FZ_FZSJ.*" _
                & " from SET_GRXX,FZ_FZSJ" _
                & " where SET_GRXX.GUID=" & lngGUID _
                & " and SET_GRXX.GUID=FZ_FZSJ.GUID"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If Not rstemp.EOF Then
            mstrHealthID = rstemp("HealthID")
            txtSelfBH.Text = rstemp("SelfBH") & ""
            txtGYYRXM.Text = rstemp("YYRXM")
            '分组
            For i = 0 To CmbFZ.ListCount - 1
                If CmbFZ.ItemData(i) = rstemp("FZID") Then
                    CmbFZ.ListIndex = i
                    Exit For
                End If
            Next i
            
            '性别
            For i = 0 To cmbGSEX.ListCount - 1
                If cmbGSEX.List(i) = rstemp("SEX") Then
                    cmbGSEX.ListIndex = i
                    Exit For
                End If
            Next
            If Not IsNull(rstemp("AGE")) Then
                txtGAGE.Text = rstemp("AGE") & ""
            End If
            txtGYYRJTDH.Text = rstemp("YYRJTDH") & ""
            txtGYYRBGDH.Text = rstemp("YYRBGDH") & ""
            txtGYYRYDDH.Text = rstemp("YYRYDDH") & ""
            
            rstemp.Close
        End If
    Else
        '默认选择男
        cmbGSEX.ListIndex = 0
        '是否自动生成编号
        If GSelfNumberAuto.Auto And g_blnSelfID Then
            txtSelfBH.Text = GetMaxSelfID()
        End If
    End If
    
    '显示自己
    Screen.MousePointer = vbDefault
    Me.Show vbModal
    
    If mblnOK Then
        
    End If
    ShowFZPersonInfo = mblnOK
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

Private Sub cmdOK_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strHealthID As String
    Dim strOldHealthID As String
    Dim datDate As Date
    Dim intFZID As Integer
    Dim intTJXH As Integer
    Dim strSelfBH As String
    Dim strName As String
    
    Me.MousePointer = vbHourglass
    '是否输入了姓名
    strName = Trim(txtGYYRXM.Text)
    If strName = "" Then
        MsgBox "请输入姓名！", vbInformation, "提示"
        txtGYYRXM.SetFocus
        GoTo ExitLab
    End If
    
    
    '自定义档案号是否存在
    strSelfBH = Trim(txtSelfBH.Text)
    If strSelfBH <> "" Then
        strSQL = "select HealthID,YYRXM from SET_GRXX" _
                & " where SelfBH='" & strSelfBH & "'"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If Not rstemp.EOF Then
            '存在记录
            '检查与当前输入的是否同一人
            If rstemp("YYRXM") <> strName Then
                '错误，需要退出
                MsgBox "卡号“" & strSelfBH & "”已被客户“" & rstemp("YYRXM") _
                        & "”持有，请核对后重新输入！" _
                        & vbCrLf & "可能的原因是卡号录入错误或者姓名录入错误。", _
                        vbExclamation, "提示"
                GoTo ExitLab
            Else
                '卡号与姓名属于同一人
                '只有在添加的时候才提示
                If menuOperation = Add Then
                    '提示是否复查
                    If MsgBox("在数据库中检索到您输入的卡号和姓名已经存在，如果单击“是”" _
                            & "将把该客户视为复查！" _
                            & vbCrLf & "您确认要继续吗？", _
                            vbQuestion + vbYesNo + vbDefaultButton1, "提示") = vbNo Then
                        GoTo ExitLab
                    Else
                        '当成复查处理
                        strOldHealthID = rstemp("HealthID")
                    End If
                End If
            End If
            
            rstemp.Close
        End If
    End If
    
    '是否选择了分组
    If CmbFZ.ListIndex < 0 Then
        MsgBox "请选择客户“" & txtGYYRXM.Text & "”所属的分组", vbInformation, "提示"
        CmbFZ.SetFocus
        GoTo ExitLab
    Else
        intFZID = CInt(Val(CmbFZ.ItemData(CmbFZ.ListIndex)))
    End If
    '获取当前分组的体检日期
    strSQL = "select FZTJRQ from FZ_FZSY" _
            & " where YYID='" & mstrYYID & "'" _
            & " and FZID=" & intFZID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    datDate = rstemp("FZTJRQ")
    rstemp.Close
    
    '年龄
    txtGAGE.Text = CInt(Val(txtGAGE.Text))
    
    '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
    '                               开始事务
    '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
    GCon.BeginTrans
    '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
    On Error GoTo RollBack
    If menuOperation = Add Then
        '新建一个HealthID
        strHealthID = GetMaxHealthID(datDate, NOTAFFIRM_TABLE)
        '截取体检序号
        intTJXH = CInt(Right(strHealthID, 4))
        
        '是否复查
        If strOldHealthID <> "" Then strHealthID = strOldHealthID
        
        '生成一个GUID
        mlngGUID = GetGUID()
'        '发卡
'        strSQL = "insert into SET_ICKGL_Index(ICKNum,HealthID,FKRQ,Status) values(" _
'                & "'" & Trim(ObjSheet.Cells(i, 2)) & "'" _
'                & ",'" & Mid(strHealthID, 1, 12) & "'" _
'                & ",'" & Date & "'" _
'                & ",0)" '0表示在用
'        GCon.Execute strSQL
        '填入新生成的HealthID的健康档案记录
        strSQL = "insert into JKDA_BASIC(HealthID) values('" & strHealthID & "')"
        GCon.Execute strSQL
        strSQL = "insert into JKDA_XYS(HealthID) values('" & strHealthID & "')"
        GCon.Execute strSQL
        strSQL = "insert into JKDA_YJS(HealthID) values('" & strHealthID & "')"
        GCon.Execute strSQL
        '在表SET_GRXX里面插入一条空记录
        strSQL = "insert into SET_GRXX(GUID) values(" & mlngGUID & ")"
        GCon.Execute strSQL
        '插入一条空记录到分组数据表
        strSQL = "insert into FZ_FZSJ(GUID,YYID) values(" & mlngGUID & ",'" & mstrYYID & "')"
        GCon.Execute strSQL
    Else
        strHealthID = mstrHealthID
        '删除可能已经存在的选择
        strSQL = "delete from YY_SJDJDX" _
                & " where GUID=" & mlngGUID
        GCon.Execute strSQL
    End If
    '更新基本信息
    strSQL = "update SET_GRXX set" _
            & " HealthID='" & strHealthID & "'" _
            & ",SelfBH='" & strSelfBH & "'" _
            & ",TJSerialNum=" & intTJXH _
            & ",YYID='" & mstrYYID & "'" _
            & ",TJRQ='" & datDate & "'" _
            & ",YYRXM='" & strName & "'" _
            & ",Sex='" & cmbGSEX.Text & "'" _
            & ",Age=" & CInt(Val(txtGAGE.Text)) _
            & ",YYRJTDH='" & txtGYYRJTDH.Text & "'" _
            & ",YYRBGDH='" & txtGYYRBGDH.Text & "'" _
            & ",YYRYDDH='" & txtGYYRYDDH.Text & "'" _
            & ",LisAccept=0,Export=0,QRDJ=0" _
            & " where GUID=" & mlngGUID
    GCon.Execute strSQL
    '更新分组数据表
    strSQL = "update FZ_FZSJ set" _
            & " YYID='" & mstrYYID & "'" _
            & ",FZID=" & intFZID _
            & ",SFTJ=0" _
            & " where GUID=" & mlngGUID
    GCon.Execute strSQL
    '更新项目选择表
    strSQL = "insert into YY_SJDJDX(GUID,DXID,SFTJ)" _
            & " select GUID=" & mlngGUID & ",DXID,SFTJ=0 from YY_TJDJDX" _
            & " where YYID='" & mstrYYID & "'" _
            & " and FZID=" & intFZID
    GCon.Execute strSQL
    
    '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
    '                               提交事务
    '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
    GCon.CommitTrans
    '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
    
    '成功返回
    mblnOK = True
    Unload Me
    GoTo ExitLab
RollBack:
    '回退事务
    GCon.RollbackTrans
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Activate()
    If GSelfNumberAuto.Auto And g_blnSelfID Then
        txtSelfBH.SetFocus
    Else
        txtGYYRXM.SetFocus
    End If
End Sub

Private Sub txtGAGE_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub txtGYYRBGDH_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub txtGYYRJTDH_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub txtGYYRXM_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub txtGYYRYDDH_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        cmdOK_Click
    End If
End Sub

Private Sub txtSelfBH_GotFocus()
    txtSelfBH.SelStart = 0
    txtSelfBH.SelLength = Len(txtSelfBH.Text)
End Sub

Private Sub txtSelfBH_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub