mdiform1.frm

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

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.MDIForm MDIForm1 
   BackColor       =   &H8000000C&
   Caption         =   "秉泰健康体检系统设置"
   ClientHeight    =   10710
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   15240
   Icon            =   "MDIForm1.frx":0000
   LinkTopic       =   "MDIForm1"
   Picture         =   "MDIForm1.frx":0CCA
   StartUpPosition =   3  '窗口缺省
   WindowState     =   2  'Maximized
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   7380
      Top             =   5130
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Menu mnuQF_XTSZ 
      Caption         =   "系统设置(&S)"
      Begin VB.Menu mnuQF_CSSZTJKS 
         Caption         =   "科室与组合设置(&K)"
         Shortcut        =   ^K
      End
      Begin VB.Menu mnuQF_CSSZTJXM 
         Caption         =   "项目设置(&M)"
         Shortcut        =   ^M
      End
      Begin VB.Menu mnuQF_XMZH 
         Caption         =   "项目组合(&A)"
         Shortcut        =   ^A
      End
      Begin VB.Menu mnuQF_XMDC 
         Caption         =   "项目导出"
      End
      Begin VB.Menu mnuQF_CSSZTJTC 
         Caption         =   "体检套餐"
      End
      Begin VB.Menu mnuSystem_Split1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuQF_CSSZSJMB 
         Caption         =   "数据字典(&D)"
         Shortcut        =   ^D
      End
      Begin VB.Menu mnuQF_ZYBSJZDWH 
         Caption         =   "职业病数据字典"
      End
      Begin VB.Menu mnuQF_TJJYWH 
         Caption         =   "体检建议维护(&S)"
         Shortcut        =   ^S
      End
      Begin VB.Menu mnuQF_TJJBJY 
         Caption         =   "体检疾病及建议维护"
      End
      Begin VB.Menu mnuQF_TJBZ 
         Caption         =   "体检标准维护(R)"
         Shortcut        =   ^R
      End
      Begin VB.Menu mnuQF_BBMBWH 
         Caption         =   "体检报告设置"
      End
      Begin VB.Menu mnuSystem_Split2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuQF_XTCS 
         Caption         =   "系统参数"
      End
      Begin VB.Menu mnuSystem_Split3 
         Caption         =   "-"
      End
      Begin VB.Menu mnuQF_JSDY 
         Caption         =   "权限设置"
      End
      Begin VB.Menu mnuQF_RYGL 
         Caption         =   "操作员管理"
      End
      Begin VB.Menu mnuSystem_Split4 
         Caption         =   "-"
      End
      Begin VB.Menu mnuQF_SJKQK 
         Caption         =   "数据库初始化"
      End
      Begin VB.Menu mnuSystem_Split5 
         Caption         =   "-"
      End
      Begin VB.Menu mnuQF_Exit 
         Caption         =   "退出(&X)"
         Shortcut        =   ^X
      End
   End
End
Attribute VB_Name = "MDIForm1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub MDIForm_Load()
    '处理所有菜单的访问权限
  '  With
    
        mnuQF_CSSZTJKS.Enabled = g_clsAuthority.CheckMenuAuthority("mnuQF_CSSZTJKS")
        mnuQF_CSSZTJXM.Enabled = g_clsAuthority.CheckMenuAuthority("mnuQF_CSSZTJXM")
        mnuQF_XMZH.Enabled = g_clsAuthority.CheckMenuAuthority("mnuQF_XMZH")
        mnuQF_XMDC.Enabled = g_clsAuthority.CheckMenuAuthority("mnuQF_XMDC")
        mnuQF_CSSZTJTC.Enabled = g_clsAuthority.CheckMenuAuthority("mnuQF_CSSZTJTC")
        
        mnuQF_CSSZSJMB.Enabled = g_clsAuthority.CheckMenuAuthority("mnuQF_CSSZSJMB")
        mnuQF_ZYBSJZDWH.Enabled = g_clsAuthority.CheckMenuAuthority("mnuQF_ZYBSJZDWH")
        mnuQF_TJJYWH.Enabled = g_clsAuthority.CheckMenuAuthority("mnuQF_TJJYWH")
        mnuQF_TJBZ.Enabled = g_clsAuthority.CheckMenuAuthority("mnuQF_TJBZ")
        mnuQF_BBMBWH.Enabled = g_clsAuthority.CheckMenuAuthority("mnuQF_BBMBWH")
        
        mnuQF_XTCS.Enabled = g_clsAuthority.CheckMenuAuthority("mnuQF_XTCS")
        
        mnuQF_JSDY.Enabled = g_clsAuthority.CheckMenuAuthority("mnuQF_JSDY")
        mnuQF_RYGL.Enabled = g_clsAuthority.CheckMenuAuthority("mnuQF_RYGL")
        mnuQF_SJKQK.Enabled = g_clsAuthority.CheckMenuAuthority("mnuQF_SJKQK")
   ' End With
End Sub

Private Sub MDIForm_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If MsgBox("您确认要退出本系统吗？", vbQuestion + vbYesNo + vbDefaultButton2, "询问") = vbNo Then Cancel = 1
End Sub

Private Sub mnuQF_BBMBWH_Click()
    FrmMBWH.ShowForm "FrmMBWH"
    Set FrmMBWH = Nothing
End Sub

Private Sub mnuQF_CSSZSJMB_Click()
    frmDictionary.ShowForm "mnuQF_CSSZSJMB"
    Set frmDictionary = Nothing
End Sub

Private Sub mnuQF_CSSZTJKS_Click()
    frmKeShi.ShowForm "mnuQF_CSSZTJKS"
    Set frmKeShi = Nothing
End Sub

Private Sub mnuQF_CSSZTJTC_Click()
    frmFormula.ShowForm "mnuQF_CSSZTJTC"
    Set frmFormula = Nothing
End Sub

Private Sub mnuQF_CSSZTJXM_Click()
    frmXiangMu.ShowForm "mnuQF_CSSZTJXM"
    Set frmXiangMu = Nothing
End Sub

Private Sub mnuQF_Exit_Click()
    Unload Me
End Sub

Private Sub mnuQF_JSDY_Click()
    frmAuthority.ShowForm "mnuQF_JSDY"
    Set frmAuthority = Nothing
End Sub

Private Sub mnuQF_RYGL_Click()
    frmManager.ShowForm "mnuQF_RYGL"
    Set frmManager = Nothing
End Sub

Private Sub mnuQF_SJKQK_Click()
    Call InitializeSystem
End Sub

Private Sub mnuQF_TJBZ_Click()
    frmStandardSet.ShowForm "mnuQF_RYGL"
    Set frmStandardSet = Nothing
End Sub

Private Sub mnuQF_TJJBJY_Click()
    frmJBJY.ShowForm "mnuQF_TJJBJY"
     Set frmJBJY = Nothing
End Sub

Private Sub mnuQF_TJJYWH_Click()
    frmSuggestion.ShowForm "mnuQF_TJJYWH"
    Set frmSuggestion = Nothing
End Sub

Private Sub mnuQF_XMDC_Click()
    Call ExportXiangMu(Me.CommonDialog1)
End Sub

Private Sub mnuQF_XMZH_Click()
    frmXMZH.ShowForm "mnuQF_XMZH"
    Set frmXMZH = Nothing
End Sub

Private Sub mnuQF_XTCS_Click()
    dlgXTCS.ShowForm "mnuQF_XTCS"
    Set dlgXTCS = Nothing
End Sub

'数据库初始化
Private Sub InitializeSystem()
On Error GoTo ErrMsg
    Dim Status
    Dim cmdTemp As ADODB.Command
    Dim rsTemp As ADODB.Recordset
    Dim strSQL As String
    
    If MsgBox("该操作将删除数据库中所有历史数据，您确认要清空吗？", vbCritical + vbOKCancel + vbDefaultButton2, "警告") = vbOK Then
        If MsgBox("该操作将被写入系统日志，您确认要继续吗？", vbCritical + vbOKCancel + vbDefaultButton2, "警告") = vbCancel Then GoTo ExitLab
        
        Me.MousePointer = vbHourglass
        
        '写入操作日志
        Call WriteToLog("清空数据库！")
        
        Set cmdTemp = New ADODB.Command
        Set cmdTemp.ActiveConnection = GCon
        '删除SET_GRXX中的数据
        strSQL = "delete from SET_GRXX"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除SET_DW中的数据
        strSQL = "delete from SET_DW"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
    
        '***************************20040428 加入 闻*****************************
        '删除SET_DW_APPEND中的数据
        strSQL = "delete from SET_DW_APPEND"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
    
        '删除SET_DW_HT中的数据
        strSQL = "delete from SET_DW_HT"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        '***************************20040428 加入完 闻***************************
    
        '初始化SET_GUID中的数据
        strSQL = "delete from SET_GUID"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        strSQL = "insert SET_GUID(GUID) values(0)"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除YY_SJDJ中的数据
        strSQL = "delete from YY_SJDJ"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute

        '删除YY_SJDJDX中的数据
        strSQL = "delete from YY_SJDJDX"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        DoEvents
        
        '删除YY_TJDJ中的数据
        strSQL = "delete from YY_TJDJ"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除YY_TJDJDX中的数据
        strSQL = "delete from YY_TJDJDX"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除YY_TJDJTC中的数据
        strSQL = "delete from YY_TJDJTC"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除YY_XLH中的数据
        strSQL = "delete from YY_XLH"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除YY_QRXLH中的数据
        strSQL = "delete from YY_QRXLH"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除JKDA_Basic中的数据
        strSQL = "delete from JKDA_Basic"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除JKDA_XYS中的数据
        strSQL = "delete from JKDA_XYS"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除JKDA_YJS中的数据
        strSQL = "delete from JKDA_YJS"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        DoEvents
        
        '删除FZ_FZSY中的数据
        strSQL = "delete from FZ_FZSY"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除FZ_FZSJ中的数据
        strSQL = "delete from FZ_FZSJ"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除DATA_ZJJL中的数据
        strSQL = "delete from DATA_ZJJL"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '在总检结论表中插入一条记录,否则在清空数据库后,登记一个人后,会出现从录入界面中看不到的情况
'        MsgBox Year(Date)
        strSQL = "insert into DATA_ZJJL(GUID,JLSJ,JLValue) Values(0," & Year(Date) & "-" & Month(Date) & "-" & Day(Date) & ",'预设结论')"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除DATA_ZJJY中的数据
        strSQL = "delete from DATA_ZJJY"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '在总检建议表中插入一条记录,道理同总检结论表
        strSQL = "insert into DATA_ZJJY(GUID,JLSJ,JYValue) Values(0," & Date & ",'预设建议')"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除DATA_KSXJ中的数据
        strSQL = "delete from DATA_KSXJ"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除DATA_KSJY中的数据
        strSQL = "delete from DATA_KSJY"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        DoEvents
        
        '删除所有数据表中的数据
        strSQL = "select * from SET_DX"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenDynamic, adLockOptimistic
        rsTemp.MoveFirst
        If Not rsTemp.EOF Then
            Do While Not rsTemp.EOF
                strSQL = "delete from [DATA_" & rsTemp("DXPYSX") & "]"
                cmdTemp.CommandText = strSQL
                cmdTemp.Execute
                
                DoEvents
                rsTemp.MoveNext
            Loop
            
            rsTemp.Close
        End If
        
        '删除所有自定义建议表中的数据
        strSQL = "select JYPYSX from SET_JY_INDEX" _
                & " where not (JYMC is null)"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If Not rsTemp.EOF Then
            Do While Not rsTemp.EOF
                strSQL = "delete from [DATA_" & rsTemp("JYPYSX") & "]"
                cmdTemp.CommandText = strSQL
                cmdTemp.Execute
                
                rsTemp.MoveNext
            Loop
            rsTemp.Close
        End If
        
        '删除SET_ICKGL_DT中的数据
        strSQL = "delete from SET_ICKGL_DT"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除SET_ICKGL_Index中的数据
        strSQL = "delete from SET_ICKGL_Index"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除SET_SELFID中的数据
        strSQL = "delete from SET_SELFID"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除SET_MONEYCARD中的数据
        strSQL = "delete from SET_MONEYCARD"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除SET_MONEYCARD_CONSUME中的数据
        strSQL = "delete from SET_MONEYCARD_CONSUME"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        '删除SET_GRXX.VIDEO中的数据
        strSQL = "delete from SET_GRXX_VIDEO"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        
        Me.MousePointer = vbDefault
        MsgBox "数据库初始化完毕！", vbInformation, "提示"
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
    Resume Next
ExitLab:
    '
End Sub

Private Sub mnuQF_ZYBSJZDWH_Click()
    FrmZYBSSZ.ShowForm "mnuQF_ZYBSJZDWH"
    Set FrmZYBSSZ = Nothing
End Sub