Hospital Management
Option Explicit
Private Sub MDIForm_DblClick() If LoginSucceeded = True Then frmNewReg.Show Else frmLogin.Show 1 End If End Sub Private Sub MDIForm_Load() Me.Caption = Me.Caption & App.Major & "." & App.Minor & "." & App.Revision End Sub Private Sub MDIForm_QueryUnload(Cancel As Integer, UnloadMode As Integer) If LoginSucceeded = False Then Exit Sub If MsgBox("Exiting IHMS will abort all tasks in progress. Data and files might be lost. " & vbCrLf & "Are you sure you want to exit?", vbCritical + vbYesNo) = vbYes Then Cancel = 0 End Else Cancel = 1 End If End Sub Private Sub mnuClose_Click() Unload frmOldPatient End Sub Private Sub mnuExit_Click() Unload Me End Sub Private Sub mnuHelpAbout_Click() frmAbout.Show 1 End Sub Private Sub mnuLogIn_Click() 'Check if database is available. if not, exit the app. If Dir(App.Path & "\IHMS_97.mdb") = "" Then MsgBox "Working database file not found." + vbCrLf + "Please make sure the access database file 'IHMS_97' available and try launching the application again." + vbCrLf + "The application will now exit...", , "ERROR" End End If frmLogin.Show 1 End Sub Private Sub mnuLogOut_Click() If MsgBox("Logging out will abort all tasks in progress. Data and files might be lost. " & vbCrLf & "Are you sure you want to Log Out?", vbQuestion + vbYesNo) = vbNo Then Exit Sub LoginSucceeded = False Call ConfigMenus End Sub Private Sub mnuNewPatient_Click() frmNewReg.Show mnuNewPatient.Enabled = False tbrMainToolbar.Buttons(1).Enabled = False End Sub Private Sub mnuOpen_Click() 'f3: Search for record by hospital number. patientNumberX = 0 'hosp number being sought for patientNumberX = Val(InputBox("Please enter the patient's HOSPITAL NUMBER:")) If patientNumberX = 0 Then Exit Sub 'User selects cancel Unload frmOldPatient frmWait.Show 1 End Sub Private Sub mnuToolsKnowledgeBase_Click() MsgBox "This function is still under development.", vbInformation End Sub Private Sub mnuToolsOptions_Click() MsgBox "This function is still under development.", vbInformation End Sub Private Sub mnuToolsUsers_Click() frmUserMgt.Show 1 End Sub Private Sub tbrMainToolbar_ButtonClick(ByVal Button As MSComctlLib.Button) Select Case Button.Index Case 1 'Log In/Log Out. If LoginSucceeded = False Then 'The user is currently logged out 'Check if database is available. if not, exit the app. If Dir(App.Path & "\IHMS_97.mdb") = "" Then MsgBox "Working database file not found." + vbCrLf + "Please make sure the access database file 'IHMS_97' available and try launching the application again." + vbCrLf + "The application will now exit...", , "ERROR" End End If frmLogin.Show 1 Else 'The user is currently logged in If MsgBox("Logging out will abort all tasks in progress. Data and files might be lost. " & vbCrLf & "Are you sure you want to Log Out?", vbQuestion + vbYesNo) = vbNo Then Exit Sub LoginSucceeded = False Call ConfigMenus End If Case 2 'Register New Patient. frmNewReg.Show mnuNewPatient.Enabled = False tbrMainToolbar.Buttons(2).Enabled = False Case 3 'Search DB for existing patient file. 'f3: Search for record by hospital number. patientNumberX = 0 'hosp number being sought for patientNumberX = Val(InputBox("Please enter the patient's HOSPITAL NUMBER:")) If patientNumberX = 0 Then Exit Sub 'User selects cancel Unload frmOldPatient frmWait.Show 1 Case 4 'Admit/Discharge this patient. MsgBox "This function is still under development.", vbInformation Case 5 'Diagnose this patient. MsgBox "This function is still under development.", vbInformation Case 6 'About This App. frmAbout.Show 1 End Select End Sub Option Explicit Private Sub cmdAbortAdmission_Click() If MsgBox("Abort the admission of this patient?", vbCritical + vbYesNo) = vbYes Then Unload Me End If End Sub Private Sub cmdConfirmAdmission_Click() 'On Error GoTo errHnd With Me.datHospHist.Recordset '.AddNew .Fields("Hosp_No") = somePatient.HospNo .Fields("Admission_Status") = "IN" .Fields("Date_of_Admission") = txtDateOfAdmission .Fields("Name_of_Doctor") = txtDoctorInCharge .Fields("Doctors_Diagnosis") = txtDoctorsComments .Update End With MsgBox "Patient has been ADMITTED into care.", vbInformation, "Success" Unload frmOldPatient Unload Me Exit Sub errhnd: Debug.Print Err.Number; " "; Err.Description MsgBox "An error has occured.", vbInformation, "Unhandled error!" Resume Next End Sub Private Sub Form_Load() lblHeading.Caption = lblHeading.Caption + Str(somePatient.HospNo) datHospHist.DatabaseName = App.Path & "\IHMS_97.mdb" datHospHist.RecordSource = "Patient_Hospital_History" datHospHist.Refresh datHospHist.Recordset.AddNew 'Display information that's already been collected. txtCaseRefNo = datHospHist.Recordset.Fields("Case_Ref_No") End Sub Option Explicit Private Sub cmdAdmit_Click() frmAdmitExisting.Show 1 End Sub Private Sub cmdCloseFile_Click() If MsgBox("Unload and close patient file?", vbYesNo + vbQuestion) = vbYes Then Unload Me End Sub Private Sub cmdDiagnose_Click() MsgBox "This function is still under development.", vbInformation End Sub Private Sub cmdDischarge_Click() frmDischarge.Show 1 End Sub Private Sub cmdViewContact_Click() MsgBox "This function is still under development.", vbInformation End Sub Private Sub Form_Load() 'PERSONAL INFO txtHospNo = somePatient.HospNo txtSName = somePatient.SName txtFName = somePatient.FName 'txtDOB = somePatient.DoB txtSex = somePatient.Sex txtHomeAdd = somePatient.HomeAdd txtStateOfOrigin = somePatient.StateOfOrigin txtOccupation = somePatient.Occupation 'LAB INFO txtLabRefNo = somePatient.LabRefNo txtBloodGroup = somePatient.BloodGrp txtRHFactor = somePatient.RHFactor txtAllergy = somePatient.Allergy lblHeading.Caption = lblHeading.Caption + Str(somePatient.HospNo) If somePatient.AdmissionStatus = "IN" Then 'Patient is currently admitted. therefore, the admit command is 'not available, but the discharge command is. cmdDischarge.Enabled = True Else 'Patient is currently NOT admitted. therefore, the admit command is 'available, but the discharge command is not. 'This part is also executed if no existing hospital history record is found for the patient 'i.e when somePatient.AdmissionStatus = "" cmdAdmit.Enabled = True End If End Sub Private Sub Form_Unload(Cancel As Integer) frmMain.mnuClose.Enabled = False End Sub Option Explicit Private Sub cmdAbortAdmission_Click() If MsgBox("Are you sure you want to abort the current patient admission?" & vbCrLf & "(NOTE: You will loose all information you have entered.)", vbCritical + vbYesNo) = vbYes Then Unload Me End If End Sub Private Sub cmdConfirmAdmission_Click() 'On Error GoTo errHnd With frmNewReg.datPerInfo.Recordset 'PERSONAL INFO .Fields("Hosp_No") = frmNewReg.thisNewPatient.HospNo .Fields("SName") = frmNewReg.thisNewPatient.SName .Fields("FName") = frmNewReg.thisNewPatient.FName .Fields("Sex") = frmNewReg.thisNewPatient.Sex .Fields("Home_Add") = frmNewReg.thisNewPatient.HomeAdd .Fields("State_of_Origin") = frmNewReg.thisNewPatient.StateOfOrigin .Fields("Occupation") = frmNewReg.thisNewPatient.Occupation 'NEXT OF KIN'S INFO .Fields("Name_of_NoK") = frmNewReg.thisNewPatient.NameNoK .Fields("Relationship_to_NoK") = frmNewReg.thisNewPatient.RelaNok .Fields("Add_of_NoK") = frmNewReg.thisNewPatient.AddNok 'SPONSOR'S INFO .Fields("Name_of_Sponsor") = frmNewReg.thisNewPatient.SponsorName .Fields("Add_of_Sponsor") = frmNewReg.thisNewPatient.SponsorAdd End With With frmNewReg.datLabInfo.Recordset 'LABORATORY INFO .Fields("Hosp_No") = frmNewReg.thisNewPatient.HospNo .Fields("Blood_Group") = frmNewReg.thisNewPatient.BloodGrp .Fields("RhFactor") = frmNewReg.thisNewPatient.RHFactor .Fields("Allergy") = frmNewReg.thisNewPatient.Allergy End With With Me.datHospHist.Recordset .Fields("Hosp_No") = Val(txtHospNo) .Fields("Admission_Status") = "IN" .Fields("Date_of_Admission") = txtDateOfAdmission .Fields("Name_of_Doctor") = txtDoctorInCharge .Fields("Doctors_Diagnosis") = txtDoctorsDiag End With 'update d records into the db frmNewReg.datPerInfo.Recordset.Update frmNewReg.datLabInfo.Recordset.Update Me.datHospHist.Recordset.Update MsgBox "New patient has been REGISTERED and ADMITTED into care.", vbInformation, "Success" Unload Me Exit Sub errhnd: Debug.Print Err.Number; " "; Err.Description MsgBox "An error has occured.", vbInformation, "Unhandled error!" Resume Next End Sub Private Sub Form_Load() datHospHist.DatabaseName = App.Path & "\IHMS_97.mdb" datHospHist.RecordSource = "Patient_Hospital_History" datHospHist.Refresh datHospHist.Recordset.AddNew 'Display information that's already been collected. With frmNewReg.thisNewPatient txtHospNo = .HospNo txtSName = .SName txtFName = .FName txtDOB = .DoB txtSex = .Sex txtStateOfOrigin = .StateOfOrigin txtOccupation = .Occupation txtCaseRefNo = datHospHist.Recordset.Fields("Case_Ref_No") End With End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) If UnloadMode = 1 Then Exit Sub If MsgBox("Are you sure you want to abort the current patient admission?" & vbCrLf & "(NOTE: You will loose all information you have entered.)", vbCritical + vbYesNo) = vbYes Then Cancel = 0 Else 'User selected NO button, and does not wish to abort the admission. Cancel = 1 End If End Sub Option Explicit Private Sub cmdAddUser_Click() Dim userName As String Dim passPhrase As String userName = InputBox("Enter a user name:") passPhrase = InputBox("Enter a password for the user:") If Trim(userName = "") Or Trim(passPhrase = "") Then MsgBox "User name AND password have to be of non-zero lenght. Try again", , "Error" Exit Sub End If lstUsers.AddItem UCase(userName) With datUsers.Recordset .AddNew .Fields("user") = userName .Fields("pass") = passPhrase .Update End With MsgBox "New User successfully added." End Sub Private Sub cmdChangePassword_Click() On Error GoTo errhnd Dim oldPass As String Dim newPass As String Dim confirmPass As String With datUsers.Recordset .MoveFirst Do While UCase(.Fields("user")) <> lstUsers.List(lstUsers.ListIndex) .MoveNext Loop oldPass = InputBox("Enter the old password:") newPass = InputBox("Enter the new password:") confirmPass = InputBox("Confirm new password:") If UCase(oldPass) = UCase(.Fields("pass")) Then If newPass = confirmPass Then .Edit .Fields("pass") = newPass .Update MsgBox "Password change successful!" Else MsgBox "Password change failed! Please retry", vbInformation End If Else MsgBox "Old password incorrect. Please retry" End If End With Exit Sub errhnd: Select Case Err.Number Case 3021 MsgBox "You need to select a user to update" Case Else MsgBox "Critical error" End Select End Sub Private Sub cmdClose_Click() Unload Me End Sub Private Sub cmdDeleteUser_Click() On Error GoTo errhnd If MsgBox("Sure you want to delete this user?", vbYesNo, "Confirm") = vbNo Then Exit Sub With datUsers.Recordset .MoveFirst Do While UCase(.Fields("user")) <> lstUsers.List(lstUsers.ListIndex) .MoveNext Loop If UCase(lstUsers.List(lstUsers.ListIndex)) = "DOCTOR" Then MsgBox "The DOCTOR account is an administrative account and CANNOT be deleted!" Exit Sub End If .Delete lstUsers.RemoveItem lstUsers.ListIndex End With Exit Sub errhnd: Select Case Err.Number Case 3021 MsgBox "You need to select a user to delete" Case Else MsgBox "Critical error" End Select End Sub Private Sub Form_Load() 'On Error Resume Next datUsers.DatabaseName = App.Path & "\IHMS_97.mdb" datUsers.RecordSource = "IHMS_Users" datUsers.Refresh 'populate lstUsers With datUsers.Recordset .MoveFirst Do While Not .EOF lstUsers.AddItem (UCase(.Fields("user"))) .MoveNext Loop End With End Sub Option Explicit ' Reg Key Security Options... Const READ_CONTROL = &H20000 Const KEY_QUERY_VALUE = &H1 Const KEY_SET_VALUE = &H2 Const KEY_CREATE_SUB_KEY = &H4 Const KEY_ENUMERATE_SUB_KEYS = &H8 Const KEY_NOTIFY = &H10 Const KEY_CREATE_LINK = &H20 Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _ KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _ KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL ' Reg Key ROOT Types... Const HKEY_LOCAL_MACHINE = &H80000002 Const ERROR_SUCCESS = 0 Const REG_SZ = 1 ' Unicode nul terminated string Const REG_DWORD = 4 ' 32-bit number Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location" Const gREGVALSYSINFOLOC = "MSINFO" Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO" Const gREGVALSYSINFO = "PATH" Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long Private Sub cmdSysInfo_Click() Call StartSysInfo End Sub Private Sub cmdOK_Click() Unload Me End Sub Private Sub Form_Load() Dim strDesc As String Me.Caption = "About " & App.Title lblVersion.Caption = App.Major & "." & App.Minor & "." & App.Revision 'lblTitle.Caption = App.Title strDesc = "This computer program is protected by copyright law and international treaties. " strDesc = strDesc + vbCrLf + "Unauthorized reproduction without consent of the owner is strictly prohibited, and may result in severe criminal penalties." lblDisclaimer.Caption = "Warning: " + strDesc lblDescription.Caption = "For Hospital Records Management and Patient Diagnosis." End Sub Public Sub StartSysInfo() On Error GoTo SysInfoErr Dim rc As Long Dim SysInfoPath As String ' Try To Get System Info Program Path\Name From Registry... If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then ' Try To Get System Info Program Path Only From Registry... ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then ' Validate Existance Of Known 32 Bit File Version If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then SysInfoPath = SysInfoPath & "\MSINFO32.EXE" ' Error - File Can Not Be Found... Else GoTo SysInfoErr End If ' Error - Registry Entry Can Not Be Found... Else GoTo SysInfoErr End If Call Shell(SysInfoPath, vbNormalFocus) Exit Sub SysInfoErr: MsgBox "System Information Is Unavailable At This Time", vbOKOnly End Sub Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean Dim i As Long ' Loop Counter Dim rc As Long ' Return Code Dim hKey As Long ' Handle To An Open Registry Key Dim hDepth As Long ' Dim KeyValType As Long ' Data Type Of A Registry Key Dim tmpVal As String ' Tempory Storage For A Registry Key Value Dim KeyValSize As Long ' Size Of Registry Key Variable '------------------------------------------------------------ ' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...} '------------------------------------------------------------ rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Error... tmpVal = String$(1024, 0) ' Allocate Variable Space KeyValSize = 1024 ' Mark Variable Size '------------------------------------------------------------ ' Retrieve Registry Key Value... '------------------------------------------------------------ rc = RegQueryValueEx(hKey, SubKeyRef, 0, _ KeyValType, tmpVal, KeyValSize) ' Get/Create Key Value If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Errors If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then ' Win95 Adds Null Terminated String... tmpVal = Left(tmpVal, KeyValSize - 1) ' Null Found, Extract From String Else ' WinNT Does NOT Null Terminate String... tmpVal = Left(tmpVal, KeyValSize) ' Null Not Found, Extract String Only End If '------------------------------------------------------------ ' Determine Key Value Type For Conversion... '------------------------------------------------------------ Select Case KeyValType ' Search Data Types... Case REG_SZ ' String Registry Key Data Type KeyVal = tmpVal ' Copy String Value Case REG_DWORD ' Double Word Registry Key Data Type For i = Len(tmpVal) To 1 Step -1 ' Convert Each Bit KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1))) ' Build Value Char. By Char. Next KeyVal = Format$("&h" + KeyVal) ' Convert Double Word To String End Select GetKeyValue = True ' Return Success rc = RegCloseKey(hKey) ' Close Registry Key Exit Function ' Exit GetKeyError: ' Cleanup After An Error Has Occured... KeyVal = "" ' Set Return Val To Empty String GetKeyValue = False ' Return Failure rc = RegCloseKey(hKey) ' Close Registry Key End Function Option Explicit Private Sub Form_GotFocus() Dim foundPersonalRec As Boolean Dim foundLabRec As Boolean Dim foundHospRec As Boolean Set somePatient = New CPatient 'SEARCH THE PATIENT_PERSONAL_INFO TABLE: datPerInfo.Recordset.MoveFirst With datPerInfo.Recordset Do If .Fields("Hosp_No") = patientNumberX Then foundPersonalRec = True Else .MoveNext End If Loop Until (.EOF) Or (foundPersonalRec) End With 'SEARCH THE PATIENT_LAB_INFO TABLE: datLabInfo.Recordset.MoveFirst With datLabInfo.Recordset Do If .Fields("Hosp_No") = patientNumberX Then foundLabRec = True Else .MoveNext End If Loop Until (.EOF) Or (foundLabRec) End With 'SEARCH THE PATIENT_HOSPITAL_HISTORY TABLE (for the patient's MOST RECENT record: datHospHist.Recordset.MoveLast With datHospHist.Recordset Do If .Fields("Hosp_No") = patientNumberX Then foundHospRec = True Else .MovePrevious End If Loop Until (.BOF) Or (foundHospRec) End With If (foundPersonalRec = True) Then 'The sought record was found: Display it Call GetPatientData(foundLabRec, foundHospRec) Unload Me frmOldPatient.Show frmMain.mnuClose.Enabled = True Else 'The sought record doesn't exist: so inform the user. MsgBox "No record found for the patient number you entered. Sorry!", vbInformation, "Search Failed" Unload Me End If End Sub Private Sub Form_Load() Me.MousePointer = 11 'vbHourglass datPerInfo.DatabaseName = App.Path & "\IHMS_97.mdb" datPerInfo.RecordSource = "Patient_Personal_Info" datPerInfo.Refresh datLabInfo.DatabaseName = App.Path + "\IHMS_97.mdb" datLabInfo.RecordSource = "Patient_Lab_Info" datLabInfo.Refresh datHospHist.DatabaseName = App.Path & "\IHMS_97.mdb" datHospHist.RecordSource = "Patient_Hospital_History" datHospHist.Refresh End Sub Private Sub GetPatientData(flg1 As Boolean, flg2 As Boolean) With datPerInfo.Recordset 'PERSONAL INFO 'MsgBox Str(somePatient.HospNo) somePatient.HospNo = .Fields("Hosp_No") somePatient.SName = .Fields("SName") somePatient.FName = .Fields("FName") 'somePatient.DoB = .Fields("Date_Of_Birth") somePatient.Sex = .Fields("Sex") somePatient.HomeAdd = .Fields("Home_Add") somePatient.StateOfOrigin = .Fields("State_of_Origin") somePatient.Occupation = .Fields("Occupation") somePatient.NameNoK = .Fields("Name_of_NoK") somePatient.RelaNok = .Fields("Relationship_to_NoK") somePatient.AddNok = .Fields("Add_of_NoK") somePatient.SponsorName = .Fields("Name_of_Sponsor") somePatient.SponsorAdd = .Fields("Add_of_Sponsor") somePatient.AdmissionStatus = "" End With With datLabInfo.Recordset 'LAB INFO If (flg1 = False) Then Exit Sub 'although this is highly unlikely :) somePatient.LabRefNo = .Fields("Lab_Ref_No") somePatient.BloodGrp = .Fields("Blood_Group") somePatient.RHFactor = .Fields("RhFactor") somePatient.Allergy = .Fields("Allergy") End With With datHospHist.Recordset 'HOSPITAL HISTORY INFO If (flg2 = False) Then Exit Sub 'this is possible for patients 'who have never been admitted: a hospital history record has never been created for them. somePatient.CaseRefNo = .Fields("Case_Ref_No") somePatient.AdmissionStatus = .Fields("Admission_Status") somePatient.AdmissionDate = .Fields("Date_of_Admission") somePatient.DocName = .Fields("Name_of_Doctor") somePatient.Diagnosis = .Fields("Doctors_Diagnosis") somePatient.DateDischarged = .Fields("Date_of_Discharge") somePatient.DischargeStatus = .Fields("Status_Upon_Discharge") End With End Sub |
(Software Made & Developed in Net Beans IDE 6.5.1 and MySQL)
DECLARATION
I hereby declare that his desertion entitled “HOSPITAL MANAGEMENT” embodies the documentation of my project work carried out in session 2015 to 2016 and it is correct and true to the best of my knowledge. No part of this document may be copied or distributed without prior information to the owner of this project. PUBLIC SCHOOL is the sole owner of this project. HOSPITAL MANAGEMENT(Software Made & Developed in Net Beans IDE 6.5.1 and MySQL)
SUBMITTED BY : BOARD ROLL NO. : DATE OF SUBMISSION UNDER THE SUPERVISION OF MISS. S. (IP Teacher) PUBLIC SCHOOL (Affiliated to CBSE) |