医院管理系统

医院管理系统：学院：计算机科学与技术班级: 计算机5班学号：0855010105姓名：刘奥系统具体编码实现编码实现说明模块化设计模块的基本目的是创建相当独立的程序单元，从根本上讲，模块可以添加给另一个工程，并且可以通过直接调用它的公用过程来使用它。

这种通用模块并不依赖于全局数据或其它模块中的过程。

当模块包含一组紧密关联的过程时，该模块可以说具有强大的内聚力。

当模块包含许多互补相关的过程时，该模块编具有较弱的内聚力。

本设计努力创建内聚力比较强的模块。

创建的模块有MdlConSQL和MdlAPIMdlConSQL用于连接数据库，其中包含了一个自动产生收费编号的全局过程CreatPrepayId，编码为：Public G_OperatorId As String '记录操作员编号Public G_InhosId As String '记录查询患者住院编号Public M_Cnn As ADODB.ConnectionPublic Function ExecuteSQL(ByVal Strsql As String)As ADODB.Recordset '连接数据库,执行SQL语句Dim Rst As ADODB.RecordsetSet M_Cnn = New ADODB.ConnectionM_Cnn.Open "dsn=LocalServer;uid=sa;pwd= "Set Rst = New ADODB.RecordsetRst.CursorLocation = adUseClientRst.Open Trim$(Strsql), M_Cnn, adOpenDynamic, adLockOptimistic Set ExecuteSQL = RstEnd FunctionMdlAPI用于引用API函数，扩充界面功能，本设计中用于引用屏蔽最大化最小化关闭按钮，编码实现：Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As_ Long, ByVal bRevert As Long) As LongPublic Declare Function DeleteMenu Lib "user32" (ByVal hMenu As _ Long, ByVal nPosition As Long, ByVal wFlags As Long) As LongDeclare Function SetWindowLong Lib "user32" Alias "SetWindowLongA"_ (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long)_ As LongDeclare Function GetWindowLong Lib "user32" Alias "GetWindowLongA"_ (ByVal hwnd As Long, ByVal nIndex As Long) As LongPublic Const SC_MINIMIZE = &HF020Public Const SC_CLOSE = &HF060&Public Const WS_MAXIMIZEBOX = &H10000Public Const MF_BYCOMMAND = &H0&Public Const GWL_STYLE = (-16)过程化设计创建专用过程有许多好处。

首先，调试将变得更加容易。

当创建专用过程时，不一定能够在查找的第一个过程中找到错误，但是可以缩短查找错误所需的时间。

创建专用过程的更重要的好处是可以按计划或者不按计划来修改代码。

创建过程时，设法将每个过程视为一个黑箱，其他例程不应该要求了解该过程的内部工作情况，该过程也不应该要求了解它外面的工程情况。

本设计尽量做到创建高度专用的过程。

创建的过程有CreatPrepayId，ShowPatientInfo，ShowPrescriptInfo等。

自动产生收费编号的全局过程CreatPrepayId，编码为：Public Function CreatPrepayId(ByVal StrPrepayNum As String)'检查编号前的日期Dim StrYear As StringDim StrMonth As StringDim StrDay As StringDim StrId As StringIf StrPrepayNum = "0001" ThenStrYear = Right(Year(Date), 2)StrMonth = Month(Date)StrDay = Day(Date)If StrMonth < 10 ThenStrMonth = "0" & StrMonthEnd IfIf StrDay < 10 ThenStrDay = "0" & StrDayEnd IfCreatPrepayId = StrYear & StrMonth & StrDay & StrPrepayNumElseCreatPrepayId = Format(StrPrepayNum + 1, "0000000000")End IfEnd Function系统登录图4.1 登录界面“登录“按钮编码：Dim Rst As New ADODB.RecordsetIf Trim(TxtUser.Text) = "" Or Trim(TxtPass.Text) = "" ThenMsgBox "用户名或密码不能为空", vbOKOnly, "登录消息"TxtUser.SetFocusExit SubEnd IfStrsql = " select * from operatorinfo where operatorpassword= "_ & TxtPass.Text & " and operatorname= '" & TxtUser.Text & " ' " Set Rst = ExecuteSQL(Strsql)If Rst.RecordCount = 0 ThenMsgBox "用户与密码不符，确认后重新登录", vbOKOnly, "登录"TxtUser.SetFocusElseG_OperatorId = Rst.Fields("operatorid")G_OperatorName = Rst.Fields("operatorname")Unload FrmLoginMDIMain.ShowFrmMenuQuick.ShowFrmMenuStream.ShowEnd If系统主界面图4.4住院收费主界面Dim SngPrescriptPay As Single'记录处方收据的费用Dim SngprescriptPayModulus As Single '记录处方收据的自付费用 Dim SngItemPay As Single '记录项目收费的费用Dim SngItemPayModulus As Single '记录项目收费的自付费用 Dim SngPrepaySum As Single '记录预交金额Dim BlnIsArrearage As Boolean '记录是否可以欠费 Dim SngInHosPayUsed As Single '记录已用金额Private Sub CmdSave_Click() '保存收费Dim Str As StringDim RstInHos As New ADODB.Recordset Dim RstInPre As New ADODB.Recordset Dim SngMkbTakeIn As SingleDim SngPrepayMoney As SingleSngPrepayMoney = 0SngMkbTakeIn = Replace(MkbTakeIn.Text, "_", 0)Str = "select prepaymoney from prepayinfo where inhosid='" & TxtInHosId & " '" Set RstInPre = ExecuteSQL(Str)If RstInPre.EOF Or RstInPre.BOF ThenSngPrepayMoney = 0ElseRstInPre.MoveFirstWhile Not RstInPre.EOFSngPrepayMoney = SngPrepayMoney + RstInPre("prepaymoney")RstInPre.MoveNextWendEnd IfSet RstInPre = NothingIf SngPrepayMoney = 0 ThenIf SngMkbTakeIn > (SngItemPayModulus + SngprescriptPayModulus) Then TxtTakeOut.Text=SngMkbTakeIn-(SngItemPayModulus+SngprescriptPayModulus) Call SaveInHosPayCall DeleteItemCall ShowPatientInfo(StrInHosId)ElseIf BlnIsArrearage ThenStr="select inhospayused from inhospitalinfo where inhosid='"& _Trim$(TxtInHosId) & " ' "Set RstInHos = ExecuteSQL(Str)RstInHos("inhospayused") = RstInHos("inhospayused") + (SngItemPayModulus + SngprescriptPayModulus) - SngMkbTakeInRstInHos.UpdateMfgPatientinfo.TextMatrix(1, 8) = RstInHos("inhospayused") - SngPrepayMoney - SngMkbTakeInSet RstInHos = NothingCall SaveInHosPay '保存收费记录Call DeleteItem '将项目和处方单置为已收费Call ShowPatientInfo(StrInHosId) '显示患者基本信息ElseMsgBox "金额不足，你不允许欠费，交足金额后再保存收费！", vbInformation, "验证"MkbTakeIn.SetFocusExit SubEnd IfEnd IfElseStr = "select inhospayused from inhospitalinfo where inhosid='" & Trim$(TxtInHosId) & " ' "Set RstInHos = ExecuteSQL(Str)If SngPrepayMoney>(SngItemPayModulus+SngprescriptPayModulus+_RstInHos("inhospayused")) ThenRstInHos("inhospayused")=RstInHos("inhospayused")+(SngItemPayModulus+_ SngprescriptPayModulus)RstInHos.UpdateSet RstInHos = NothingTxtTakeOut = MkbTakeInCall SaveInHosPayCall DeleteItemCall ShowPatientInfo(StrInHosId)ElseIf BlnIsArrearage ThenIf RstInHos("inhospayused")+ (SngItemPayModulus + SngprescriptPayModulus)_ < SngMkbTakeIn ThenTxtTakeOut.Text=SngMkbTakeIn-RstInHos("inhospayused")_-SngItemPayModulus-SngprescriptPayModulusRstInHos("inhospayused") = 0RstInHos.UpdateElseIf(SngMkbTakeIn+SngPrepayMoney)>(SngItemPayModulus+_ SngprescriptPayModulus+RstInHos("inhospayused")) ThenRstInHos("inhospayused")=RstInHos("inhospayused")+_ (SngItemPayModulus + SngprescriptPayModulus) _- SngMkbTakeInRstInHos.UpdateElseMfgPatientinfo.TextMatrix(1,8)=RstInHos("inhospayused")_+(SngItemPayModulus + SngprescriptPayModulus) _- SngMkbTakeIn - SngPrepayMoneyRstInHos("inhospayused")=RstInHos("inhospayused")+SngItemPayModulus_ + SngprescriptPayModulus - SngMkbTakeInRstInHos.UpdateEnd IfEnd IfSet RstInHos = NothingCall SaveInHosPay '保存收费记录Call DeleteItem '将项目和处方单置为已收费Call ShowPatientInfo(StrInHosId) '显示患者基本信息ElseIf SngMkbTakeIn>RstInHos("inhospayused")+SngItemPayModulus_+ SngprescriptPayModulus ThenTxtTakeOut.Text=SngMkbTakeIn-RstInHos("inhospayused")-_ SngItemPayModulus - SngprescriptPayModulusCall SaveInHosPayCall DeleteItemElseIf SngMkbTakeIn>(RstInHos("inhospayused")+SngItemPayModulus+_ SngprescriptPayModulus - SngPrepayMoney) ThenTxtTakeOut.Text=SngMkbTakeIn+SngPrepayMoney-_RstInHos("inhospayused") - SngItemPayModulus _- SngprescriptPayModulusRstInHos("inhospayused") = SngPrepayMoneyRstInHos.UpdateSet RstInHos = NothingCall SaveInHosPay '保存收费记录Call DeleteItem '将项目和处方单置为已收费Call ShowPatientInfo(StrInHosId) '显示患者基本信息ElseMfgPatientinfo.TextMatrix(1,8)=RstInHos("inhospayused")-_ SngPrepayMoney + (SngItemPayModulus + SngprescriptPayModulus)MsgBox "所交金额不足,交足后再保存！", vbInformation, "验证"MkbTakeIn.SetFocusExit SubEnd IfEnd IfEnd IfEnd IfEnd IfCmdSave.Enabled = FalseEnd SubPrivate Sub SaveInHosPay()'保存收费记录Dim Str As StringDim Rst As New ADODB.RecordsetStr = "select * from inhospayinfo"Set Rst = ExecuteSQL(Str)Rst.AddNewRst("inhospayid") = TxtPayId.TextRst("inhosid") = StrInHosIdRst("operatorid") = G_OperatorIdRst("inhostakein") = TxtSumModulusRst("inhospaytime") = DateRst.UpdateEnd SubPrivate Sub DeleteItem()'将项目和处方单置为已收费Dim RstPrescriptTemp As New ADODB.RecordsetDim RstItemTemp As New ADODB.RecordsetRstPrescriptTemp.Open "update prescriptinfo set PrescriptPayValidate='否' where inhosid='" & Txtinhosid & "'", M_Cnn, adOpenDynamicRstItemTemp.Open "update itempay set itemvalidate='否' where inhosid='" & Txtinhosid & "' ", M_Cnn, adOpenDynamicMsgBox "保存成功", vbInformation, "消息"MfgChargeItems.ClearMfgChargeItems.FormatString = "项目编号|医生|科室|项目名称|项目单价|次数|自付系数"MfgPriscription.ClearMfgPriscription.FormatString = "处方编号|医生|科室|药品名称|单价|数量|单位|类别|自付系数"End SubPrivate Sub ShowPatientInfo(StrRoot3 As String)'显示患者基本信息Dim Str As StringDim Rst As New ADODB.Recordset'患者姓名|性别|科室|床位号|住院日期|责任医生|预交款|已用款|补交款额Str = "select * from viewtrvinhos where inhosid='" & StrRoot3 & " '"Set Rst = ExecuteSQL(Str)If Rst.RecordCount <> 0 ThenWith MfgPatientinfo.TextMatrix(1, 0) = Rst("patientname").TextMatrix(1, 1) = Rst("patientsex").TextMatrix(1, 2) = Rst("deptname").TextMatrix(1, 3) = Right(Rst("bedid"), 5).TextMatrix(1, 4) = Rst("inhosindate").TextMatrix(1, 5) = Rst("docname").TextMatrix(1, 9) = Rst("inhosisarrearage")BlnIsArrearage = (Rst("inhosisarrearage") = "是")Set Rst = NothingStr = "select * from viewpatientinfo where inhosid='" & StrRoot3 & " '" Set Rst = ExecuteSQL(Str) .Col = 8 .Row = 1.CellForeColor = &HFF& If Rst.RecordCount <> 0 Then.TextMatrix(1, 6) = Rst("prepaymoney") .TextMatrix(1, 7) = Rst("inhospayused") SngPrepaySum = Rst("prepaymoney") SngInHosPayUsed = Rst("inhospayused")If Rst("inhospayused") > Rst("prepaymoney") Then.TextMatrix(1, 8) = Rst("inhospayused") - Rst("prepaymoney") Else.TextMatrix(1, 8) = 0 End IfSet Rst = Nothing Else.TextMatrix(1, 6) = 0 .TextMatrix(1, 7) = 0 .TextMatrix(1, 8) = 0 End If End With ElseExit Sub End If End Sub点击“患者查询”后进入查询界面：图4.6 患者查询Private Sub CmdQuery_Click()Dim Rst As New ADODB.RecordsetDim OptItem As IntegerDim mfgrow As Integermfgrow = 1'查询输入是否为空If Trim(TxtName.Text) = "" ThenMsgBox "输入要查询的患者姓名", vbOKOnly, "查询"Exit SubEnd If'查询初始化mfgMfgQueryPatient.ClearMfgQueryPatient.TextMatrix(0, 0) = "住院编号"MfgQueryPatient.TextMatrix(0, 1) = "患者编号"MfgQueryPatient.TextMatrix(0, 2) = "姓名"MfgQueryPatient.TextMatrix(0, 3) = "性别"MfgQueryPatient.TextMatrix(0, 4) = "所在科室"'生成SQL语句Strsql = "select * from viewquery where patientname like '%" & Trim$(TxtName.Text) & "% '"For OptItem = 0 To 2If OptOptions(OptItem).V alue = True ThenExit ForEnd IfNext OptItemSelect Case OptItemCase 0Strsql = Strsql & "and patientinfo.patientsex ='男'"Case 1Strsql = Strsql & "and patientinfo.patientsex='女'"Case 2Strsql = StrsqlEnd Select'执行查询Set Rst = ExecuteSQL(Strsql)MsgBox "查询到" & Rst.RecordCount & "条纪录", vbOKOnly, "查询"'无记录时提示If Rst.RecordCount = 0 ThenMsgBox "无此病人或输入错误，请检查后重新查询", vbOKOnly TxtName.SetFocusExit SubEnd If'在mfg中显示纪录Rst.MoveFirstDo While Not Rst.EOFMfgQueryPatient.TextMatrix(mfgrow, 0) = Rst.Fields("inhosid")MfgQueryPatient.TextMatrix(mfgrow, 1) = Rst.Fields("patientid")MfgQueryPatient.TextMatrix(mfgrow, 2) = Rst.Fields("patientname") MfgQueryPatient.TextMatrix(mfgrow, 3) = Rst.Fields("patientsex") MfgQueryPatient.TextMatrix(mfgrow, 4) = Rst.Fields("deptname") mfgrow = mfgrow + 1Rst.MoveNextLoopMfgQueryPatient.RefreshSet Rst = NothingEnd Sub4.7 收费员一日清单图4.9 收费员收入查询Private Sub CmdOutPay_Click()'出院收费Dim Str As StringDim Rst As New ADODB.RecordsetDim SngMkbTakeIn As SingleDim temp As SingleSngMkbTakeIn = Replace(MkbTakeIn.Text, "_", 0)Str = "select inhospayused from inhospitalinfo where inhosid='" & Trim(StrInHosId) & "'"Set Rst = ExecuteSQL(Str)If Rst.RecordCount = 0 ThenExit SubEnd IfIf (SngMkbTakeIn + SngPrepaySum) > (SngInHosPayUsed + SngprescriptPayModulus + SngItemPayModulus) ThenTxtTakeOut = (SngMkbTakeIn + SngPrepaySum) - (SngInHosPayUsed + SngprescriptPayModulus + SngItemPayModulus)Str = "select inhospayused from inhospitalinfo where inhosid='" & Trim(StrInHosId) & "'"Set Rst = ExecuteSQL(Str)Rst("inhospayused") = SngPrepaySumRst.UpdateSet Rst = NothingCall DeleteItemCall SaveInHosPayElsetemp = SngInHosPayUsed + SngprescriptPayModulus + SngItemPayModulus - SngPrepaySumMsgBox "所交金额不足,补交" & temp & "元后再确认收费", vbInformation, "验证"MkbTakeIn.SetFocusExit SubEnd IfCall ShowPatientInfo(StrInHosId)SngItemPay = 0SngItemPayModulus = 0SngPrescriptPay = 0SngprescriptPayModulus = 0SngPrepaySum = 0SngInHosPayUsed = 0End SubPrivate Sub SaveInHosPay()'保存收费记录Dim Str As StringDim Rst As New ADODB.RecordsetStr = "select * from inhospayinfo"Set Rst = ExecuteSQL(Str)Rst.AddNewRst("inhospayid") = TxtPayId.TextRst("inhosid") = StrInHosIdRst("operatorid") = G_OperatorIdRst("inhostakein") = TxtSumModulusRst("inhospaytime") = DateRst.UpdateEnd SubPrivate Sub DeleteItem()'将项目和处方单置为已收费Dim RstPrescriptTemp As New ADODB.RecordsetDim RstItemTemp As New ADODB.RecordsetRstPrescriptTemp.Open "update prescriptinfo set PrescriptPayValidate='否' where inhosid='" & TxtInhosId & "'", M_Cnn, adOpenDynamicRstItemTemp.Open "update itempay set itemvalidate='否' where inhosid='" & TxtInhosId & "' ", M_Cnn, adOpenDynamicMsgBox "保存成功", vbInformation, "消息"MfgChargeItems.ClearMfgChargeItems.FormatString = "项目编号|医生|科室|项目名称|项目单价|次数|自付系数"MfgPriscription.ClearMfgPriscription.FormatString = "处方编号|医生|科室|药品名称|单价|数量|单位|类别|自付系数"End Sub4.9 修改个人密码图4.11 修改个人密码Private Sub CmdChangePwd_Click()Dim Str As StringDim Rst As New ADODB.RecordsetDim BlnIsV alid As BooleanIf TxtId.Text = "" ThenMsgBox "输入你的编号！", vbInformation, "验证"TxtId.SetFocusExit SubEnd IfIf TxtOldPwd.Text = "" ThenMsgBox "输入你的旧密码！", vbInformation, "验证"TxtOldPwd.SetFocusExit SubEnd IfIf TxtNewPwd.Text = "" ThenMsgBox "输入你的新密码！", vbInformation, "验证"TxtNewPwd.SetFocusExit SubEnd IfIf TxtNewPwdAgain.Text = "" ThenMsgBox "再次输入你的新密码！", vbInformation, "验证"TxtNewPwdAgain.SetFocusExit SubEnd IfIf TxtNewPwd.Text <> TxtNewPwdAgain.Text ThenMsgBox "两次输入的新密码不一样，重新输入新密码！", vbInformation, "验证"TxtNewPwd.Text = ""TxtNewPwdAgain.Text = ""TxtNewPwd.SetFocusExit SubEnd IfStr = "select * from operatorinfo where operatorid=" & TxtId.TextSet Rst = ExecuteSQL(Str)If Rst.RecordCount <> 0 ThenIf Trim(Rst("operatorpassword")) = Trim(TxtOldPwd.Text) ThenRst("operatorpassword") = Trim(TxtNewPwd.Text)Rst.UpdateMsgBox "修改成功！", vbInformation, "消息"ElseMsgBox "你输入的旧密码有误，请重新输入！", vbInformation, "验证"TxtOldPwd.SetFocusExit SubEnd IfElseMsgBox "查无此编号，重新输入！", vbInformation, "验证"TxtId.SetFocusExit SubEnd IfSet Rst = NothingEnd Sub。