Attribute VB_Name = "modFunctions"
Option Explicit
Global objWebcamInitialized As Boolean
Global TransactionDate As Date

   
  Public Const SWP_NOMOVE = 2
  Public Const SWP_NOSIZE = 1
  Public Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
  Public Const HWND_TOPMOST = -1
  Public Const HWND_NOTOPMOST = -2

  Declare Function SetWindowPos Lib "user32" _
        (ByVal hwnd As Long, _
        ByVal hWndInsertAfter As Long, _
        ByVal x As Long, _
        ByVal y As Long, _
        ByVal cx As Long, _
        ByVal cy As Long, _
        ByVal wFlags As Long) As Long

  Public Function SetTopMostWindow(hwnd As Long, Topmost As Boolean) _
     As Long

     If Topmost = True Then 'Make the window topmost
        SetTopMostWindow = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, _
           0, FLAGS)
     Else
        SetTopMostWindow = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, _
           0, 0, FLAGS)
        SetTopMostWindow = False
     End If
  End Function
  
Public Sub ReleaseObject(ParamArray objs() As Variant)
      Dim iCount%
        
      For iCount = 0 To UBound(objs)
          Set objs(iCount) = Nothing
      Next
End Sub

Public Function GetFullName(GetHospNum As String) As String
    Dim Rec As New ADODB.Recordset
    Dim SQL As String
    
    SQL = "declare @CompleteName as varchar(100) "
    SQL = SQL + "exec @CompleteName = PAtient_data..Fn_GetCompleteName '" & GetHospNum & "' "
    SQL = SQL + "select  'PatientName' = @CompleteName"
    
    With Rec
        If .State > 0 Then .Close
        .CursorLocation = adUseClient
        .Open SQL, pclsUser.sqlconnection, adOpenDynamic, adLockReadOnly
        If Not .EOF Then
            GetFullName = !PatientName
        End If
    End With
End Function

Public Function GetFullAddress(GetHospNum As String) As String
    Dim Rec As New ADODB.Recordset
    Dim SQL As String
    
    SQL = "declare @CompleteAddress as varchar(100) "
    SQL = SQL + "exec @CompleteAddress = PAtient_data..fn_GetCompleteAddress '" & GetHospNum & "' "
    SQL = SQL + "select  'PatientAddress' = @CompleteAddress"
    
    With Rec
        If .State > 0 Then .Close
        .CursorLocation = adUseClient
        .Open SQL, pclsUser.sqlconnection, adOpenDynamic, adLockReadOnly
        If Not .EOF Then
            GetFullAddress = !PatientAddress
        End If
    End With
       
End Function

Public Function UAF(Argvalue As String) As String
'Uppercases All First letters of a word
Dim intI As Integer
Dim strResult As String

For intI = 1 To Len(Argvalue)
    If intI = 1 Then
        strResult = left$(Argvalue, 1)
    Else
        If Mid$(Argvalue, intI - 1, 1) = " " Or Mid$(Argvalue, intI - 1, 1) = "-" Or Mid$(Argvalue, intI - 1, 1) = "," Then
            strResult = strResult + UCase$(Mid$(Argvalue, intI, 1))
        Else
            strResult = strResult + LCase$(Mid$(Argvalue, intI, 1))
        End If
    End If
Next intI

UAF = strResult

End Function

Public Function Numerals() As String
'Return the Numerals string for specific use in filtering keystrokes
Numerals = "1234567890"
End Function

Public Function Alphabet() As String
'Returns the Alphabet String for specific use in filtering keystrokes
Alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
End Function

Public Function KeyStrokeFilter(ValidKeys As String, KeyAscii As Integer) As Integer
'Returns whether KeyAscii is within ValidKeys

Dim intI As Integer

Dim blnFound As Boolean   'Indicates whether KeyAscii was found within ValidKeys

'-----Lower case alphabet becomes upper case alphabet----------------------------
If KeyAscii >= 97 And KeyAscii <= 122 Then
    KeyAscii = Asc(UCase$(Chr$(KeyAscii)))
End If
                                                                                                                        '--------------------------------------------------------------------------------

'-----Search for Keyascii in ValidKeys-------------------------------------------
For intI = 1 To Len(ValidKeys)
    If Asc(Mid$(ValidKeys, intI, 1)) = KeyAscii Then
        blnFound = True
        Exit For
    End If
Next intI
                                                                                                                        '---------------------------------------------------------------------------------

'You can add here the unprintable keystores, e.g. TAB, ENTER, BACKSPACE, ESCAPE-----------
'so they can also be included-----------------------------------------------------
If blnFound = False Then
    Select Case KeyAscii
        Case 9, 13, 8, 27
            blnFound = True
    End Select
End If
                                                                                                                        '---------------------------------------------------------------------------------

'If Keyascii is within ValidKeys then pass back keyascii-------------------------
'else keyascii = 0---------------------------------------------------------------
If blnFound = True Then
    KeyStrokeFilter = KeyAscii
Else
    KeyStrokeFilter = 0
End If
                                                                                                                        '---------------------------------------------------------------------------------

End Function

Public Function NamePunctDelimiter(Argvalue As String, KeyAscii As Integer) As Integer

If Len(Trim$(Argvalue)) = 0 Then
    If Chr$(KeyAscii) = " " Or Chr$(KeyAscii) = "," Then
        NamePunctDelimiter = 0
    Else
        NamePunctDelimiter = KeyAscii
    End If
Else
    If InStr(Argvalue, ",") > 0 And Chr$(KeyAscii) = "," Then
        NamePunctDelimiter = 0
    Else
        NamePunctDelimiter = KeyAscii
    End If
End If
End Function

Public Function IsAlphabet(Argvalue As String) As Boolean
'Checks whether the passed variable is of numeric value(whole number)

Dim intI As Integer
Dim blnAlphabet As Boolean

blnAlphabet = True

If Len(Argvalue) > 0 Then
    Argvalue = left$(Argvalue, 1)
Else
    blnAlphabet = False
End If

If Len(Argvalue) = 0 Then
    blnAlphabet = False
Else
    For intI = 1 To Len(Argvalue)
        If Asc(UCase$(Mid$(Argvalue, intI, 1))) < 65 Or Asc(UCase$(Mid$(Argvalue, intI, 1))) > 90 Then
            blnAlphabet = False
        End If
    Next intI
End If

IsAlphabet = blnAlphabet

End Function

Public Function UpTrim$(Argvalue As String)
'Returns the upper-cased and trimmed format of a string variable

UpTrim$ = UCase$(Trim$(Argvalue))

End Function

Public Function GetCreditLimit(strRoomID As String) As String
    Dim Rec As New ADODB.Recordset
    Dim SQL As String
    
 
    SQL = "Select isnull(CreditLimitRate,0) CreditLimit from Build_file..tbCoRoom R Left "
    SQL = SQL + " Outer Join Build_File..tbCoAccomodation A "
    SQL = SQL + " on R.AccomodationID = A.AccomodationID where RoomID = '" & strRoomID & "'"
   
    If blnAllowCreditLine Then 'ADDED TO ENABLE/DISABLE CreditLimit, also added on RoomTransferring
        With Rec
            If .State > 0 Then .Close
            .CursorLocation = adUseClient
            .Open SQL, pclsUser.sqlconnection, adOpenDynamic, adLockReadOnly
            
            If .RecordCount > 0 Then
                GetCreditLimit = !CreditLimit
            End If
            
            
            .Close
        End With
    Else
        GetCreditLimit = 0
    End If
    Set Rec = Nothing
End Function
Function ValiText(KeyIn As Integer, ValidateString As String, Editable As Boolean) As Integer

    Dim ValidateList As String
    Dim KeyOut As Integer
    
    If Editable = True Then
        ValidateList = UCase(ValidateString) & Chr(8)
    Else
        ValidateList = UCase(ValidateString)
    End If
    
    If InStr(1, ValidateList, UCase(Chr(KeyIn)), 1) > 0 Then
        KeyOut = KeyIn
    Else
        KeyOut = 0
        Beep
    End If
    
    ValiText = KeyOut
End Function
Public Function Crypt(Action As String, Key As String, Src As String) As String
'E encrypts, D decrypts, Key is a unique string needed to en/decrypt
'(either hardcode or
'setup something for the user to enter. Src is the string to be en/decrypted.


Dim count As Integer, KeyPos As Integer, KeyLen As Integer, SrcAsc As Integer
Dim Dest As String, Offset As Integer, TmpSrcAsc, SrcPos As Integer
Const KN_OFFSET = 91

'KeyLen = Len(Key)
KeyLen = 13

If Action = "E" Then
                    'Randomize
    'Offset = (Rnd * 10000 Mod 255) + 1     'Modified by randy gadingan
    Offset = KN_OFFSET
    Dest = Hex$(Offset)

    For SrcPos = 1 To Len(Src)
        SrcAsc = (Asc(Mid$(Src, SrcPos, 1)) + Offset) Mod 255
        If KeyPos < KeyLen Then KeyPos = KeyPos + 1 Else KeyPos = 1
        'Fill Dest$ with HEX representation of Encrypted field
        'Hex used to keep nasties such as eof or lf from mangling stream
        'Use format$ to make Hex$ return " 0" instead of "0" when the same
        'values are Xor'ed together (Null) - keeps placeholder for decrypt
        SrcAsc = SrcAsc Xor Asc(Mid$(Key, KeyPos, 1))
        Dest = Dest + Format$(Hex$(SrcAsc), "@@")
        Offset = SrcAsc

    Next

ElseIf Action = "D" Then
    Offset = Val("&H" + left$(Src, 2))
    For SrcPos = 3 To Len(Src) Step 2
        SrcAsc = Val("&H" + Trim(Mid$(Src, SrcPos, 2)))
        If KeyPos < KeyLen Then KeyPos = KeyPos + 1 Else KeyPos = 1
        TmpSrcAsc = SrcAsc Xor Asc(Mid$(Key, KeyPos, 1))
        If TmpSrcAsc <= Offset Then
            TmpSrcAsc = 255 + TmpSrcAsc - Offset
        Else
            TmpSrcAsc = TmpSrcAsc - Offset
        End If
        Dest = Dest + Chr(TmpSrcAsc)
        Offset = SrcAsc
    Next

End If
Crypt = Dest
End Function



Public Function GetWord(WordGroup As String, Separator As String) As String
    Dim SepPos As Integer
    SepPos = InStr(WordGroup, Separator)
    If SepPos > 0 Then
        GetWord = Mid(WordGroup, 1, SepPos - 1)
        WordGroup = Mid(WordGroup, SepPos + Len(Separator))
    Else
        GetWord = WordGroup
        WordGroup = ""
    End If
End Function
'Public Function Is_Password_Valid(ByVal strUserID As String, _
'    ByVal strPassword As String) As Boolean
'    Dim c As New ADODB.Command
'    Dim xRetVal As Boolean
'
'
'
'    With c
'        .ActiveConnection = pclsUser.sqlconnection
'        .CommandText = "Password..SP_Check_Password"
'        .CommandType = adCmdStoredProc
'        .Parameters.Append .CreateParameter("@UserID", _
'                adVarChar, adParamInput, 10, strUserID)
'
'        .Parameters.Append .CreateParameter("@Password", _
'                adVarChar, adParamInput, 32, _
'                Crypt("E", KC_PASSWORD_KEY, strPassword))
'
'        .Parameters.Append .CreateParameter("@intOkey", adSmallInt, adParamOutput)
'
'        .Execute
'
'        xRetVal = IIf(.Parameters("@intOkey").Value = 1, True, False)
'    End With
'
'    Set c = Nothing
'
'    Is_Password_Valid = xRetVal
'
'End Function



Public Function GetOBCode(strID As String) As String
        '<EhHeader>
        On Error GoTo GetOBCode_Err
        '</EhHeader>

        Dim recOB As New ADODB.Recordset
        Dim strSQL As String

100     GetOBCode = ""

102     If GetPxType(strID) = "O" Then
104         strSQL = "SELECT ObstetCode FROM Patient_Data..tbOutPatientHistory WHERE IDNum = '" & strID & "'"
        Else
106         strSQL = "SELECT ObstetCode FROM Patient_data..tbPatientHistory WHERE IDNum = '" & strID & "'"
        End If

108     With recOB
110         If .State > 0 Then .Close
112         .Open strSQL, pclsUser.sqlconnection, adOpenDynamic, adLockOptimistic
114         If Not .EOF Then
116             GetOBCode = !ObstetCode & ""
            End If
118         .Close
        End With
120     Set recOB = Nothing

        '<EhFooter>
        Exit Function

GetOBCode_Err:
        MsgBox Err.Description & vbCrLf & _
               "in prjOPDRegistration.modFunctions.GetOBCode " & _
               "at line " & Erl, _
               vbExclamation + vbOKOnly, "Application Error"
        Resume Next
        '</EhFooter>
End Function
Public Function GetPxType(strID As String) As String
    If Right$(strID, 1) = "B" Then
        GetPxType = "O"
    Else
        GetPxType = "I"
    End If
End Function

Public Function GetLMP(strID As String) As String
        '<EhHeader>
        On Error GoTo GetLMP_Err
        '</EhHeader>
        Dim recLMP As New ADODB.Recordset
        Dim strSQL As String

100     GetLMP = ""

    '    If GetPxType(strID) = "O" Then
    '        strSQL = "SELECT LMP FROM Patient_Data..tbOutNurseProfile WHERE IDNum = '" & strID & "'"
    '    Else
102         strSQL = "SELECT LMP FROM Station..tbNurseProfile WHERE IDNum = '" & strID & "'"
    '    End If

104     With recLMP
106         If .State > 0 Then .Close
108         .Open strSQL, pclsUser.sqlconnection, adOpenDynamic, adLockOptimistic
110         If Not .EOF Then
112             GetLMP = !LMP & ""
            End If
114         .Close
        End With
116     Set recLMP = Nothing

118     If GetLMP <> "" Then
120         If IsDate(GetLMP) Then
122             GetLMP = Format(GetLMP, "mm/dd/yyyy")
            End If
        End If


        '<EhFooter>
        Exit Function

GetLMP_Err:
        MsgBox Err.Description & vbCrLf & _
               "in prjOPDRegistration.modFunctions.GetLMP " & _
               "at line " & Erl, _
               vbExclamation + vbOKOnly, "Application Error"
        Resume Next
        '</EhFooter>
End Function


Public Function Get_TransactionDate() As Date
    Dim recDate As New ADODB.Recordset
    recDate.Open "select GETDATE() AS Tdate", pclsUser.sqlconnection, adOpenForwardOnly, adLockReadOnly
    TransactionDate = recDate!Tdate
    Get_TransactionDate = recDate!Tdate
    recDate.Close 'convert(varchar(10),getdate(),101)
    Set recDate = Nothing
End Function

Public Sub DisableNewBornFrame()
    ''Disabled NewBorn Form
    With frmAdmitPatient
        .fraNewBornBaby.Enabled = False
        .lineNewBorn.BorderColor = &H808080
        .BirthTime.Enabled = False
        .lblBirthTime(70).ForeColor = &H808080
        
        .lblNewBorn1.ForeColor = &H808080
        .lblNewBorn2.ForeColor = &H808080
        .lblNewBorn3.ForeColor = &H808080
        
        .optWellBaby(0).ForeColor = &H808080
        .optWellBaby(1).ForeColor = &H808080
        .optInborn(0).ForeColor = &H808080
        .optInborn(1).ForeColor = &H808080
        .optNormal(0).ForeColor = &H808080
        .optNormal(1).ForeColor = &H808080
        
        If blnReqAdmissionDiagnosis Then
            .Frame15.ForeColor = &HFF0000
        End If
        If blnReqChiefComplaint Then
            .Frame16.ForeColor = &HFF0000
        End If
        If blnReqPrecaution Then
            .Frame21.ForeColor = &HFF0000
        End If
        If blnReqAdmittingImpression Then
            .Frame11.ForeColor = &HFF0000
        End If
    End With
End Sub