frmadddoctorappointments.frm

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

      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   435
      Left            =   4080
      TabIndex        =   20
      Top             =   240
      Width           =   5790
   End
End
Attribute VB_Name = "frmAddDocAppointments"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim flex As Integer
Dim co, del_i  As Integer
Dim dupid As String
Dim rgrid, COUNT1, rs As Integer
Dim ch, ch1 As Integer




Private Sub Calendar1_Click()
DTPDate1.Value = Calendar1.Value
End Sub

Private Sub cmbDoctorID_Change()
cmdDocSched_Click


Dim rsDocPat As Recordset
Set rsDocPat = New ADODB.Recordset

flex = 20
fra.Visible = True
cmdPatSel.Visible = False
cmdDocIDSel.Visible = True

If ch = 0 Then

If Trim(cmbDoctorID.Text) = "" Or Len(cmbDoctorID.Text) = 0 Then
    rsDocPat.Open "select * from Doctor_Details", cnPatients, adOpenDynamic, adLockPessimistic
Else
    rsDocPat.Open "select * from Doctor_Details where Doctor_ID like '" & UCase(Trim(cmbDoctorID.Text)) & "%'", cnPatients, adOpenDynamic, adLockPessimistic
End If

If rsDocPat.RecordCount > 0 Then
    rsDocPat.MoveFirst
    fdata.clear
    fdata.FixedRows = 1
    fdata.Rows = 2
    fdata.FormatString = "Doctor ID" & vbTab & "First Name" & vbTab & "Last Name" & vbTab & "Specialization" & vbTab & "Qualification"
   fdata.ColWidth(0) = 1500
fdata.ColWidth(1) = 1800
fdata.ColWidth(2) = 1800
fdata.ColWidth(3) = 1500
fdata.ColWidth(4) = 2000
    fdata.TextMatrix(1, 0) = rsDocPat.Fields(0)
    fdata.TextMatrix(1, 1) = rsDocPat.Fields(1)
    fdata.TextMatrix(1, 2) = rsDocPat.Fields(2)
    fdata.TextMatrix(1, 3) = rsDocPat.Fields(9)
    fdata.TextMatrix(1, 4) = rsDocPat.Fields(10)
    rsDocPat.MoveNext
    
    While Not rsDocPat.EOF
        fdata.AddItem rsDocPat.Fields(0) & vbTab & rsDocPat.Fields(1) & vbTab & rsDocPat.Fields(2) & vbTab & rsDocPat.Fields(9) & vbTab & rsDocPat.Fields(10)
        rsDocPat.MoveNext
    Wend
Else
MsgBox "Name/ID Doesn't Exist", vbCritical + vbOKOnly, "Invalid Name/ID"
fdata.clear
fdata.FixedRows = 1
fdata.Rows = 2
fdata.FormatString = "Doctor ID" & vbTab & "First Name" & vbTab & "Last Name" & vbTab & "Specialization" & vbTab & "Qualification"
fdata.ColWidth(0) = 1500
fdata.ColWidth(1) = 1800
fdata.ColWidth(2) = 1800
fdata.ColWidth(3) = 1500
fdata.ColWidth(4) = 2000
End If
rsDocPat.Close
End If

End Sub

Private Sub cmbDoctorID_Click()
cmbDoctorID_Change
cmdDocSched_Click
End Sub

Private Sub cmbDoctorID_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
  fdata.SetFocus
  frameAppointment.Enabled = False
End If
End Sub

Private Sub cmbPatientID_Change()


Dim rsDocPat As Recordset
Set rsDocPat = New ADODB.Recordset

flex = 10
fra.Visible = True
cmdPatSel.Visible = True
cmdDocIDSel.Visible = False



If ch = 0 Then

If Trim(cmbPatientID.Text) = "" Or Len(cmbPatientID.Text) = 0 Then
    rsDocPat.Open "select * from Patient_Details", cnPatients, adOpenDynamic, adLockPessimistic
Else
    rsDocPat.Open "select * from Patient_Details where Patient_ID like '" & UCase(Trim(cmbPatientID.Text)) & "%'", cnPatients, adOpenDynamic, adLockPessimistic
End If

If rsDocPat.RecordCount > 0 Then
    rsDocPat.MoveFirst
    fdata.clear
    fdata.FixedRows = 1
    fdata.Rows = 2
    fdata.FormatString = "Patient ID" & vbTab & "First Name" & vbTab & "Last Name" & vbTab & "Gender" & vbTab & "Address"
    fdata.ColWidth(0) = 1500
    fdata.ColWidth(1) = 1800
    fdata.ColWidth(2) = 1800
    fdata.ColWidth(3) = 1600
    fdata.ColWidth(4) = 1600
    fdata.TextMatrix(1, 0) = rsDocPat.Fields(0)
    fdata.TextMatrix(1, 1) = rsDocPat.Fields(1)
    fdata.TextMatrix(1, 2) = rsDocPat.Fields(2)
    fdata.TextMatrix(1, 3) = rsDocPat.Fields(3)
    fdata.TextMatrix(1, 4) = rsDocPat.Fields(4)
    rsDocPat.MoveNext
    
    While Not rsDocPat.EOF
        fdata.AddItem rsDocPat.Fields(0) & vbTab & rsDocPat.Fields(1) & vbTab & rsDocPat.Fields(2) & vbTab & rsDocPat.Fields(3) & vbTab & rsDocPat.Fields(4)
        rsDocPat.MoveNext
    Wend
Else
MsgBox "Patient ID Doesn't Exist", vbCritical + vbOKOnly, "Invalid Name/ID"
fdata.clear
fdata.FixedRows = 1
fdata.Rows = 2
fdata.FormatString = "Patient ID" & vbTab & "First Name" & vbTab & "Last Name" & vbTab & "Gender" & vbTab & "Address"
fdata.ColWidth(0) = 1500
fdata.ColWidth(1) = 1800
fdata.ColWidth(2) = 1800
fdata.ColWidth(3) = 1000
fdata.ColWidth(4) = 1100
End If
rsDocPat.Close
End If



End Sub

Private Sub cmbPatientID_Click()
cmbPatientID_Change
End Sub

Private Sub cmbPatientID_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then
  fdata.SetFocus
  frameAppointment.Enabled = False
End If








End Sub

Private Sub cmdAddApointment_Click()
'On Error GoTo AddErr

Dim rsAddBill As Recordset
Dim rsAddAppointment As Recordset
Dim rsInfo As New Recordset
Dim rsSched As Recordset
Dim rsPrevApp As Recordset

Dim StrDoctorID As String
Dim StrServiceID As String
Dim PID As String
Dim strTime As String
Dim BID As String
Dim strAvailDays As String
Dim strDocIn As String
Dim strDocOut As String
Dim strDate As String
Dim strAll As String
Dim strDIn() As String
Dim strDOut() As String
Dim arrDays() As String

Dim ID As Boolean
Dim flag As Boolean
Dim proceed As Boolean
Dim AppPos As Boolean

Dim i As Integer
Dim NoOfSchedules As Integer
Dim fl As Integer

Dim newTime As Double
Dim newTime2 As Double
Dim strInTime As Date
Dim strOutTime As Date
Dim lastAppTime As Date




Set rsAddAppointment = New ADODB.Recordset
Set rsInfo = New ADODB.Recordset
Set rsSched = New ADODB.Recordset
Set rsAddBill = New ADODB.Recordset
Set rsPrevApp = New ADODB.Recordset





 If cnPatients.State = adStateOpen Then
    'cnPatients.BeginTrans
    
    
        ' Adding data to the Appointment_Bill table
        strTime = DTPTime1.Value
        
                
        BID = Functions.UID(6, "OPBID_")    'Generate random Bill ID
        rsAddBill.Open "Select * from Appointment_Bill", cnPatients, adOpenKeyset, adLockPessimistic
        While rsAddBill.EOF = False
            If rsAddBill(0) = BID Then  ' If Bill ID found Generate Another Bill ID
                BID = Functions.UID(6, "OPBID_")
                rsAddBill.MoveFirst
            End If
            rsAddBill.MoveNext
        Wend
        
       
           
            StrDoctorID = cmbDoctorID.Text
                          
            ' Doctor Channeling Charges
            rsInfo.Open "Select * from Doctor_Details where Doctor_ID='" & StrDoctorID & "'", cnPatients, adOpenKeyset, adLockPessimistic
            If rsInfo.EOF = False Then
                strAmount = rsInfo![Doctor_CCharge]
            End If
            
                    ' Assigning temporary Values
                    HospitalCharge = 200
                    Discount = 20
                    GrandTotal = HospitalCharge + strAmount
                    NetValue = GrandTotal - Discount
                    AppBillID = BID
                    BillPatientID = cmbPatientID
        
                    ' End of BillData
            
            
            PID = Functions.UID(6, "DApp_") 'Generate Random Appointment ID
            'Generate Random Appointment ID
            rsAddAppointment.Open "Select * from Doctor_Appointment", cnPatients, adOpenKeyset, adLockPessimistic
            
            While rsAddAppointment.EOF = False
                If rsAddAppointment(0) = PID Then
                    PID = Functions.UID(6, "DApp_")
                    rsAddAppointment.MoveFirst
                End If
                rsAddAppointment.MoveNext
            Wend

            
             
            
           ' Possible Data Validation (If data is invalid it will exit the sub)
             
           ' If the Appointment date is less than the current date
            If cmbPatientID = "" Then
                MsgBox "Please enter a valid patient ID", vbCritical, "Out Patient Details"
            rsAddBill.Close
            rsAddAppointment.Close
            rsInfo.Close
            
                Exit Sub
            End If
            If cmbDoctorID = "" Then
                MsgBox "Please enter a valid Doctor ID", vbCritical, "Out Patient Details"
                Exit Sub
            End If
            
            
            If DTPDate1.Value < Date Then
                MsgBox "Appointment Date Should Be Greater Than Current Date", vbCritical, "Invalid Date"
                rsAddBill.Close
                rsAddAppointment.Close
                rsInfo.Close
           
                Exit Sub
            End If
                       
            If DTPDate1.Value = Date And strTime < Time Then
                MsgBox "Appointment Time Should Be Greater Than Current Time", vbCritical, "Invalid Date"
                rsAddBill.Close
                rsAddAppointment.Close
                rsInfo.Close
                Exit Sub
            End If
             
         
            
            rsSched.Open "Select * from Doctor_Schedule_Details where Doctor_ID='" & StrDoctorID & "'", cnPatients, adOpenDynamic, adLockPessimistic
            
            ' Retreive Doctor Available days from the table
            While rsSched.EOF = False
                strAvailDays = strAvailDays & rsSched![Doctor_AvaiDate] & "..."
                strDocIn = strDocIn & rsSched![Doctor_In] & "..."
                strDocOut = strDocOut & rsSched![Doctor_Out] & "..."
                rsSched.MoveNext
            Wend
            
            arrDays() = Split(strAvailDays, "...")
            strDIn() = Split(strDocIn, "...")
            strDOut() = Split(strDocOut, "...")
            
                   
            
            strDate = Left(Format(DTPDate1.Value, "dddd"), 3)
                       
            For i = 0 To UBound(arrDays)
                If InStr(1, arrDays(i), Left(Format(DTPDate1.Value, "dddd"), 3)) > 0 Then
                    AppPos = True ' Doctor is available on the selected date
                End If
            Next i
            
   

            fl = 1
            
            
            Debug.Print strTime
            For i = 0 To UBound(strDIn)
                Debug.Print "In : " & strDIn(i) & "    " & "Out : " & strDOut(i)
            Next
            

            For i = 0 To UBound(strDIn)
                If InStr(1, arrDays(i), strDate) > 0 Then
                    If strTime >= strDIn(i) And strTime <= strDOut(i) Then
                        strInTime = Format(strDIn(i), "short time")
                        strOutTime = Format(strDOut(i), "short time")
                        newTime = DateDiff("s", strDIn(i), strDOut(i)) / 60
                        newTime2 = newTime / 60
                        
                        Debug.Print "Total Time in Minutes : " & newTime & " Minutes"
                        Debug.Print "Total Time in hours   : " & newTime2 & " Hours"
                        Debug.Print "Possible Appointments : " & newTime / 15
                        Debug.Print "Docotor In            : " & strInTime
                        Debug.Print "Doctor Out            : " & strOutTime
                        fl = 0
                        Exit For
                    Else
                        fl = 1
                    End If
                End If
                
            Next i
            
                       
            
            If fl = 0 Then
                Debug.Print "Appointment Possible (Time and Date)"
            Else
                MsgBox "The Appointment Date or Time does not valid", vbInformation, "Out Patient Apointment"
            rsAddBill.Close
            rsAddAppointment.Close
            rsInfo.Close
            rsSched.Close