frmmain

医院门诊医生工作站,vb6 SqlServer

      End
      Begin VB.Menu settimeout 
         Caption         =   "设置查询超时"
      End
      Begin VB.Menu mnuLineM 
         Caption         =   "-"
      End
      Begin VB.Menu Msseg 
         Caption         =   "发送、接收信息"
      End
      Begin VB.Menu mnuLines 
         Caption         =   "-"
      End
      Begin VB.Menu mnuM_Exit 
         Caption         =   "退出系统"
      End
   End
   Begin VB.Menu help 
      Caption         =   "帮助"
      Begin VB.Menu Maul 
         Caption         =   "使用说明"
      End
      Begin VB.Menu Aort 
         Caption         =   "关于YHRP2000"
      End
      Begin VB.Menu helpl 
         Caption         =   "-"
         Visible         =   0   'False
      End
      Begin VB.Menu WWWAddr 
         Caption         =   "友恒通网站"
         Visible         =   0   'False
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private mblProcess As Boolean
Private WithEvents FigObj As frmWorkStationFig
Attribute FigObj.VB_VarHelpID = -1
Private WithEvents WorkStationObj As frmWorkStationReg
Attribute WorkStationObj.VB_VarHelpID = -1
Private ActForm As Form
Public Sub RaiseRight()
    Call gpdRaiseRight
End Sub
Public Property Get Note() As String
    Note = LblNote.Caption
End Property

Public Property Let Note(Vdata As String)
    If Vdata = "" Then
        LblNote = Vdata
        Label1.Visible = False
    Else
        LblNote = Vdata
        Label1.Visible = True
    End If
End Property

Private Sub Aort_Click()
    frmsplash.SysName = "医院HIS系统"
    frmsplash.Command1.Visible = True
    frmsplash.Show
End Sub

Private Sub FigObj_ChangeFig()
    Fresh
End Sub

Private Sub FirstAcc_Click()
    If gtydSysConfig.Status < 2 Then
        frmFirstAcc.Show
    Else
        MsgBox "正式运行后不允许在初始库存！如需调整库存请盘点", vbCritical
    End If
End Sub

Private Sub Maul_Click()
    frmHelp.Show
End Sub

Private Sub mnuA_Back_Click()
    frmBackBus.Show
End Sub

Private Sub mnuA_Fetch_Click()
    If gtydSysConfig.IfFetchList Then
        frmFecthList.Top = 500
        frmFecthList.Left = 0
        frmFecthList.Show
        frmFetchBus.Top = 500
        frmFetchBus.Left = frmFecthList.Width
    Else
        Call hisFormToCenter(frmFetchBus, frmMain)
    
    End If
    frmFetchBus.Show
End Sub

Private Sub mnuA_Figure_Click()
    frmFigureBus.mItemType = 0
    frmFigureBus.Show
End Sub

Private Sub mnuB_BackDrug_Click()
    frmBackDrug.isHouse = True
    frmBackDrug.Show
End Sub

Private Sub mnuB_CatiFairBySick_Click()
    frmFairBySick.QueryType = 0
    frmFairBySick.Show
End Sub

Private Sub mnuB_DetailFairBySick_Click()
    frmFairBySick.QueryType = 1
    frmFairBySick.Show
End Sub

Private Sub mnuB_GetDrugByDepart_Click()
    frmGetDrugCondition.Show
End Sub

Private Sub mnuB_GetDrugQuery_Click()
    frmGetDrugQuery.Show
End Sub

Private Sub mnuB_OpMark_Click()
    frmOpGetDrugCondition.Show
End Sub

Private Sub mnuB_OutDrugGet_Click()
    frmInpatiDrugGet.Show
End Sub

Private Sub mnuB_OutDrugMark_Click()
    frmKeep.isHouse = True
    frmKeep.Show
End Sub

Private Sub mnuB_PrePayBySick_Click()
   frmPrePayBySick.Show
End Sub

Private Sub mnuB_SerialFairBySick_Click()
    frmFairBySick.QueryType = 2
    frmFairBySick.Show
End Sub

Private Sub mnuB_SickInfo_Click()
    frmSickInfo.Show
End Sub

Private Sub mnuC_AskForStore_Click()
    frmHouseAsk.Show
End Sub

Private Sub mnuC_BackByDepart_Click()
    frmHouseBus.MDtType = tsH_DEPART_IN
    frmHouseBus.Show

End Sub

Private Sub mnuC_Check_Click()
    frmHouseCheck.Show
End Sub

Private Sub mnuC_Drump_Click()
    frmHouseBus.MDtType = tsA_DRUMP_OUT
    frmHouseBus.Show

End Sub

Private Sub mnuC_GetDrugDepart_Click()
    frmHouseBus.MDtType = tsH_DEPART_OUT
    frmHouseBus.Show

End Sub

Private Sub mnuC_TranIn_Click()
    frmHouseAskForTran.Show
End Sub

Private Sub mnuC_TranOut_Click()
'    frmAskList.Show
    frmHouseTranOut.Show
End Sub

Private Sub mnuD_Limit_Click()
    frmDrugProperty.Show
End Sub

Private Sub mnuD_MonthFoot_Click()
    If gtydSysConfig.IFFoot Then frmMonthFoot.Show
End Sub

Private Sub mnuE_Drug_Click()
    frmHouseDrug.Show
End Sub

Private Sub mnuE_DrugAmountAlert_Click()
    frmDrugAmountAlert.Show
End Sub

Private Sub mnuE_Standand_Click()
    frmQueryList.Show
End Sub

Private Sub mnuE_Transact_Click()
    frmTransact.Show
End Sub

Private Sub mnuM_ChangePasswd_Click()
    frmChangePasswd.Show
End Sub

Private Sub mnuM_SmRefresh_Click()
    Dim TmpObj As Object
    Dim Class As Integer
    
On Error GoTo Errlbl
    If MsgBox("本选项动作可能影响操作员权限,是否继续?", vbYesNo) = vbYes Then
        Me.MousePointer = vbHourglass
        If gDbObj.GetRs("SELECT Class FROM f_sysModule WHERE SmID = '" & gstrMODULEID & "'") > 0 Then
            Class = gDbObj.Rs!Class
        End If
        gDbObj.CNExe.BeginTrans
        If Not Update_f_SysModule(DbOpType.HISDBdelete, UpdateCondition:= _
            " SmID Like '" & gstrMODULEID & "%' AND flag & 1 = 0") Then
            GoTo Errlbl
        End If
        For Each TmpObj In frmMain.Controls
            If TypeName(TmpObj) = "Menu" Then
                If TmpObj.Caption <> "-" Then
                    If Not Update_f_SysModule(HISDbInsert, _
                        gstrMODULEID & Right(TmpObj.Name, Len(TmpObj.Name) - 3), _
                        TmpObj.Caption, IIf(Len(TmpObj.Name) = 4, Class + 1, Class + 2), _
                        IIf(Len(TmpObj.Name) = 4, 0, 1), Flag:=0) Then
                        
                        GoTo Errlbl
                    End If
                End If
            End If
        Next
        gDbObj.CNExe.CommitTrans
        Me.MousePointer = vbDefault
        MsgBox "更新成功!", vbInformation
    End If
    Exit Sub
Errlbl:
    gDbObj.CNExe.RollbackTrans
    MsgBox "更新失败!", vbCritical
    Me.MousePointer = vbDefault


End Sub

Private Sub mnuM_WSfig_Click()
    If UCase(gtydSysConfig.HdCode) <> "SA" Then
        MsgBox "对不起！只有系统管理员才能进行此操作！", vbInformation
        Exit Sub
    End If
    Set FigObj = New frmWorkStationFig
    
    FigObj.WsID = gstrWSID
    FigObj.WsName = gstrWSName
    FigObj.SmName = gstrMODULEName
    
    FigObj.Show
End Sub

Private Sub mnuM_ChangeWS_Click()
    Set WorkStationObj = New frmWorkStationReg
    WorkStationObj.Show

End Sub

Private Sub MDIForm_Load()
    Me.Caption = MainCap
    Note = ""
    lblOperID = ""
    Select Case gtydSysConfig.HandleType
        Case 0
            mnuB.Visible = False
        Case 1
            mnuA.Visible = False
    End Select
'    If gtydSysConfig.ConFigureRev Then
'        mnuA_Figure.Visible = False
'    End If
    If Not gtydSysConfig.IfMark Then
        mnuB_OutDrugMark.Visible = False
    End If
    If gtydSysConfig.IFMarkFetch Then
        mnuB_OutDrugGet.Visible = False
        mnuB_OutDrugMark.Caption = "住院取药记帐"
    End If
    
End Sub

Private Sub MDIForm_Unload(Cancel As Integer)
    Set frmMain = Nothing
    Call gDbObj.DBExec("Update f_Loginlog set outDate='" & Format(Now, "yyyy/mm/dd hh:mm:ss") & "' " _
               & "where hdcode='" & gtydSysConfig.HdCode & "' and outdate is null and wsid='" & gstrWSID & "'")
    
    End
End Sub

Private Sub mnuM_ReLogin_Click()
    frmLogin.FirstLogin = False
    frmLogin.Show
End Sub

Private Sub mnuM_Exit_Click()
    Unload Me
End Sub

Private Sub Msseg_Click()
    frmMsseging.Show
End Sub

Private Sub settimeout_Click()
    frmTimeOut.Show
End Sub

Private Sub Timer1_Timer()
    Static MCnt As Long
    Dim TmpStr As String
    

    If MCnt = 36000 Then     '一个小时
        MCnt = 0
    End If
    If MCnt = 0 Then
        TmpStr = gfnGetServerTime
        Date = CDate(TmpStr)
        Time = CDate(TmpStr)
    End If
    MCnt = MCnt + 1
    Me.lblDate = Format(Date, "yyyy-mm-dd ") & Format(Time, "HH:NN:SS")
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As msComctlLib.Button)
    Select Case Button.Index
    Case 1
        If mnuB_GetDrugByDepart.Enabled Then mnuB_GetDrugByDepart_Click
    Case 3
        If mnuB_OutDrugMark.Enabled Then mnuB_OutDrugMark_Click
        
    Case 5
        If mnuA_Figure.Enabled Then mnuA_Figure_Click
        
    Case 7
        If mnuC_AskForStore.Enabled Then mnuC_AskForStore_Click
    Case 9
        mnuE_Standand_Click
    Case 11
        If mnuA_Fetch.Enabled Then mnuA_Fetch_Click
    Case 13
        End
    End Select
    
End Sub

Private Sub WorkStationObj_ChangeWorkStation()
   Fresh
End Sub
Private Sub Fresh()
    gfnGetFig
    Select Case gtydSysConfig.HandleType
        Case 0
            mnuB.Visible = False
             mnuA.Visible = True
        Case 1
            mnuA.Visible = False
            mnuB.Visible = True
        Case 2
            mnuA.Visible = True
            mnuB.Visible = True
    End Select
    Me.Caption = MainCap
End Sub

Private Sub WWWAddr_Click()
    On Error GoTo IeErr
    Shell "c:\Program Files\Internet Explorer\IEXPLORE.EXE http://www.yhrp2000.com.cn", vbMaximizedFocus
IeErr:

End Sub