frmadmissiondetails.frm

This file came from Planet-Source-Code.com...the home millions of lines of source code You can view

    Set oText.DataSource = adoPrimaryRS
    oText.Locked = True
    oText.Appearance = 0
  Next

  mbDataChanged = False
End Sub


Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  If mbEditFlag Or mbAddNewFlag Then Exit Sub

  Select Case KeyCode
    Case vbKeyEscape
      cmdClose_Click
    Case vbKeyEnd
      cmdLast_Click
    Case vbKeyHome
      cmdFirst_Click
    Case vbKeyUp, vbKeyPageUp
      If Shift = vbCtrlMask Then
        cmdFirst_Click
      Else
        cmdPrevious_Click
      End If
    Case vbKeyDown, vbKeyPageDown
      If Shift = vbCtrlMask Then
        cmdLast_Click
      Else
        cmdNext_Click
      End If
  End Select
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Screen.MousePointer = vbDefault
  Call Functions.EnableMenu
   
End Sub

Private Sub adoPrimaryRS_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  'This will display the current record position for this recordset
  lblStatus.Caption = "Record: " & CStr(adoPrimaryRS.AbsolutePosition)
End Sub

Private Sub adoPrimaryRS_WillChangeRecord(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  'This is where you put validation code
  'This event gets called when the following actions occur
  Dim bCancel As Boolean

  Select Case adReason
  Case adRsnAddNew
  Case adRsnClose
  Case adRsnDelete
  Case adRsnFirstChange
  Case adRsnMove
  Case adRsnRequery
  Case adRsnResynch
  Case adRsnUndoAddNew
  Case adRsnUndoDelete
  Case adRsnUndoUpdate
  Case adRsnUpdate
  End Select

  If bCancel Then adStatus = adStatusCancel
End Sub

Public Sub cmdAdd_Click()
  On Error GoTo AddErr
  
Dim oText As TextBox
  'Bind the text boxes to the data provider
  For Each oText In Me.txtFields
    oText.Locked = False
Next
  txtFields(0).Locked = True

  
  
  
    Dim rsAdmit As Recordset
    Dim AdmID As String
    
    
    AdmID = Functions.UID(6, "AdmID_")
    Set rsAdmit = New ADODB.Recordset
    rsAdmit.Open "Select * from Admission_Details", cnPatients, adOpenKeyset, adLockPessimistic
              
            While rsAdmit.EOF = False
                If rsAdmit(0) = RoomID Then
                    AdmID = Functions.UID(6, "AdmID_")
                    rsAdmit.MoveFirst
                End If
                rsAdmit.MoveNext
            Wend
            rsAdmit.Close
            

   
  With adoPrimaryRS
    If Not (.BOF And .EOF) Then
      mvBookMark = .Bookmark
    End If
    .AddNew
    txtFields(0) = AdmID
    lblStatus.Caption = "Add record"
    mbAddNewFlag = True
    SetButtons False
  End With

  Exit Sub
AddErr:
  MsgBox Err.Description
End Sub

Private Sub cmdDelete_Click()
  On Error GoTo DeleteErr
  
  Dim rsDelBed As Recordset
  Set rsDelBed = New ADODB.Recordset
  
  If MsgBox("Are you sure you want to delete this record?", vbQuestion + vbYesNo, "Delete Admission Record") = vbYes Then
  
    rsDelBed.Open "select * from Bed_Details where Bed_ID = '" & txtFields(8) & "'", cnPatients, adOpenDynamic, adLockOptimistic
  
  If rsDelBed.EOF = False Then
    
    rsDelBed(2) = True ' Bed availability true
    rsDelBed(3) = ""
    rsDelBed.Update
    rsDelBed.Close
  
  With adoPrimaryRS
    .Delete
    .MoveNext
    If .EOF Then .MoveLast
  End With
  
  Exit Sub
  End If
  
  
  Else
    Exit Sub
  End If
  
  
  
DeleteErr:
  MsgBox Err.Description
End Sub

Private Sub cmdRefresh_Click()
  'This is only needed for multi user apps
  On Error GoTo RefreshErr
  adoPrimaryRS.Requery
  Exit Sub
RefreshErr:
  MsgBox Err.Description
End Sub

Private Sub cmdEdit_Click()
  On Error GoTo EditErr
  Dim oText As TextBox
  'Bind the text boxes to the data provider
  For Each oText In Me.txtFields
    
    oText.Locked = False
  Next
   txtFields(0).Locked = True
  
  
  
  
  lblStatus.Caption = "Edit record"
  mbEditFlag = True
  SetButtons False
  Exit Sub

EditErr:
  MsgBox Err.Description
End Sub
Private Sub cmdCancel_Click()
  On Error Resume Next
  
  Dim oText As TextBox
  'Bind the text boxes to the data provider
  For Each oText In Me.txtFields
    
    oText.Locked = True
  Next
   txtFields(0).Locked = True

  SetButtons True
  mbEditFlag = False
  mbAddNewFlag = False
  adoPrimaryRS.CancelUpdate
  rsAddBedMng.CancelUpdate
  If mvBookMark > 0 Then
    adoPrimaryRS.Bookmark = mvBookMark
  Else
    adoPrimaryRS.MoveFirst
  End If
  mbDataChanged = False

End Sub

Private Sub cmdUpdate_Click()
  On Error GoTo UpdateErr
  Dim oText As TextBox
  Dim rsAdmit As Recordset
  Set rsAdmit = New ADODB.Recordset
  Dim rsDis As Recordset
  Set rsDis = New ADODB.Recordset
  
  rsAdmit.Open "Select * from Admission_Details where Patient_ID= '" & cmbPatientID & "'", cnPatients, adOpenDynamic, adLockReadOnly

        rsDis.Open "Select * from In_Patient_Discharge where Patient_ID = '" & cmbPatientID & "'", cnPatients, adOpenDynamic, adLockReadOnly
        If rsAdmit.RecordCount > rsDis.RecordCount Then
            MsgBox "Patient has already admitted to the hospital", vbCritical
            Exit Sub
        End If
        If rsDis.RecordCount > rsAdmit.RecordCount Then
            MsgBox "Database Error.. Patient has discharged with out addmitting " & vbCrLf & "Please contact the database administrator", vbCritical
            Exit Sub
        End If
    
  rsAdmit.Close
 
  Dim rsRoom_Ward_ID As Recordset
  Dim strRoom_Ward_ID
  Set rsRoom_Ward_ID = New ADODB.Recordset
  
  rsRoom_Ward_ID.Open "select Room_Ward_ID from Bed_Details where Bed_ID= '" & cmbBedID & "' ", cnPatients, adOpenDynamic, adLockPessimistic
  
  If rsRoom_Ward_ID.EOF = True Then
    MsgBox "Room or Ward ID Not Found"
    Exit Sub
  Else
  strRoom_Ward_ID = rsRoom_Ward_ID(0)
  End If
  
  rsRoom_Ward_ID.Close
  
  
  txtFields(1) = cmbPatientID.Text
  txtFields(2) = cmbGuardianID.Text
  txtFields(3) = DTPDate.Value
  txtFields(4) = Format(DTPTime.Value, "short time")
  txtFields(6) = cmbDoctorID
  txtFields(7) = strRoom_Ward_ID
  txtFields(8) = cmbBedID

  ' Add Data to admission table and bed_details table
  
  Dim result As Boolean
  
  result = ChkBedAvailability(cmbBedID)
  If result = True Then
    'MsgBox "Bed is Available... , Continue the Admission Process"
  ElseIf result = False Then
    MsgBox "Bed is Not Available... , Please Select a different Bed"
   Exit Sub
  End If
  
  Dim rsAddBed As Recordset
  Set rsAddBed = New ADODB.Recordset
  
  rsAddBed.Open "select * from Bed_Details where Bed_ID = '" & cmbBedID & "'", cnPatients, adOpenDynamic, adLockOptimistic
  
  If rsAddBed.EOF = False Then
    adoPrimaryRS.UpdateBatch adAffectAll
    rsAddBed(2) = False
    rsAddBed(3) = txtFields(0)
    rsAddBed.Update
    rsAddBed.Close
  
  If mbAddNewFlag Then
    adoPrimaryRS.MoveLast              'move to the new record
  End If

  mbEditFlag = False
  mbAddNewFlag = False
  SetButtons True
  mbDataChanged = False
  
  
  'Bind the text boxes to the data provider
  For Each oText In Me.txtFields
    oText.Locked = False
  Next
  txtFields(0).Locked = True

  Exit Sub
  
  End If
  
  
  'Bind the text boxes to the data provider
  For Each oText In Me.txtFields
    oText.Locked = False
  Next
    txtFields(0).Locked = True
  Exit Sub


UpdateErr:
  MsgBox Err.Description
End Sub

Private Sub cmdClose_Click()
  Unload Me
End Sub

Private Sub cmdFirst_Click()
  On Error GoTo GoFirstError

  adoPrimaryRS.MoveFirst
  mbDataChanged = False

  Exit Sub

GoFirstError:
  MsgBox Err.Description
End Sub

Private Sub cmdLast_Click()
  On Error GoTo GoLastError

  adoPrimaryRS.MoveLast
  mbDataChanged = False

  Exit Sub

GoLastError:
  MsgBox Err.Description
End Sub

Private Sub cmdNext_Click()
  On Error GoTo GoNextError

  If Not adoPrimaryRS.EOF Then adoPrimaryRS.MoveNext
  If adoPrimaryRS.EOF And adoPrimaryRS.RecordCount > 0 Then
    Beep
     'moved off the end so go back
    adoPrimaryRS.MoveLast
  End If
  'show the current record
  mbDataChanged = False

  Exit Sub
GoNextError:
  MsgBox Err.Description
End Sub

Private Sub cmdPrevious_Click()
  On Error GoTo GoPrevError

  If Not adoPrimaryRS.BOF Then adoPrimaryRS.MovePrevious
  If adoPrimaryRS.BOF And adoPrimaryRS.RecordCount > 0 Then
    Beep
    'moved off the end so go back
    adoPrimaryRS.MoveFirst
  End If
  'show the current record
  mbDataChanged = False

  Exit Sub

GoPrevError:
  MsgBox Err.Description
End Sub

Private Sub SetButtons(bVal As Boolean)
  cmdAdd.Visible = bVal
  cmdEdit.Visible = bVal
  cmdUpdate.Visible = Not bVal
  cmdCancel.Visible = Not bVal
  cmdDelete.Visible = bVal
  cmdClose.Visible = bVal
  cmdRefresh.Visible = bVal
  cmdNext.Enabled = bVal
  cmdFirst.Enabled = bVal
  cmdLast.Enabled = bVal
  cmdPrevious.Enabled = bVal
  
  cmbPatientID.Visible = Not bVal
  cmbGuardianID.Visible = Not bVal
  cmbDoctorID.Visible = Not bVal
  cmbRoomID.Visible = Not bVal
  cmbWardID.Visible = Not bVal
  cmbBedID.Visible = Not bVal
  
  cmdInGuardianID.Visible = Not bVal
  cmdInPatientID.Visible = Not bVal
  cmdRefDoc.Visible = Not bVal
  Frame3.Visible = Not bVal
  Option1(0).Visible = Not bVal
  Option1(1).Visible = Not bVal
  
  DTPDate.Visible = Not bVal
  DTPTime.Visible = Not bVal
  
  txtFields(1).Visible = bVal
  txtFields(2).Visible = bVal
  txtFields(3).Visible = bVal
  txtFields(4).Visible = bVal
  txtFields(6).Visible = bVal
  txtFields(7).Visible = bVal
  
  txtBedAvail.Visible = Not bVal
  lblBedStat.Visible = Not bVal
  
  cmdView.Visible = bVal
  
  
End Sub

Private Sub Option1_Click(Index As Integer)
Dim rsRoom As Recordset
Dim rsWard As Recordset

Set rsRoom = New ADODB.Recordset
Set rsWard = New ADODB.Recordset
cmbRoomID.clear
cmbWardID.clear


Select Case (Index)
        
        Case "0" ' Room ID's
            cmbRoomID.Enabled = True
            cmbWardID.Enabled = False
            rsRoom.Open "select distinct(Room_type) from Room_Types", cnPatients, adOpenDynamic, adLockPessimistic
            While rsRoom.EOF = False
                cmbRoomID.AddItem (rsRoom(0))
                rsRoom.MoveNext
            Wend
            rsRoom.MoveFirst
            cmbRoomID.Text = rsRoom(0)
            rsRoom.Close
            cmbRoomID_Click
        
        Case "1" ' Ward ID
            
            cmbRoomID.Enabled = False
            cmbWardID.Enabled = True
          
            rsWard.Open "select distinct(Ward_Name) from Ward_Details", cnPatients, adOpenDynamic, adLockPessimistic
            While rsWard.EOF = False
                cmbWardID.AddItem (rsWard(0))
                rsWard.MoveNext
            Wend
            rsWard.MoveFirst
            cmbWardID.Text = rsWard(0)
            rsWard.Close
            cmbWardID_Click
            

        Case Else 'None
            
End Select

End Sub