<%
'   $Revision$
'   $Id$
'
'   File:        Facmgttools.asp
'   Description: Hulp functies voor Facmgt
'   Parameters:
'   Context:     Via common.asp geinclude in elk Facmgt bestand
'   Note:        Controleert of je wel ingelogd bent.

jqueryver = "jquery-1.11.3" // Zie fac.header.inc
%>

<!-- #INCLUDE FILE="VBlogger.inc" -->
<%
'===============================
'  GlobalFuncs begin
' Deze worden geinclude vanuit common.asp en zijn daarmee overal
' beschikbaar
dim str_concat, to_date_f, sysdate, fnToChar, fnNVL, user_key

g_sql_prefix = "##SQL##"

' ====================================================================
If IsEmpty(Session("customerId")) Or IsEmpty(Session("user_key")) Then ' ASP-Sessie verlopen.
    Response.Redirect("../shared/expired.asp")
End If

user_key = CLng(Session("user_key"))
if Not user_key > 0 Then
    Response.Redirect("../../")
End If
' Oke, we zijn in ieder geval ingelogd.

If Request.Servervariables("HTTP_FCLT_VERSION").Count > 0 Then
    ' wordt opgepikt door FCLTAPI.DLL voor in de logging en daarna gestript. Niet in Fiddler te zien dus
    Response.AddHeader "FCLT_USERID", Session("customerId") & "\" & user_key
End If

' Zoek ons bestand terug in het menu en test de rechten daarvan
dim strPath
strPath = Request.Servervariables("SCRIPT_NAME")
arrNames = Split(strPath, "/")
strPath = arrNames(Ubound(arrNames))
' xxxrecord.asp zit nooit in het menu. Maak er xxxgrid.asp van.
if Right(strPath, 10) = "record.asp" Then
    strPath = Left(strPath, Len(strPath)-10) & "grid.asp"
End If
'Response.Write strPath
'Response.End
sql = "SELECT fac_functie_key" & _
      "  FROM fac_v_menu" & _
      " WHERE UPPER(url) LIKE '%"&UCase(replace(strPath, "'", "''"))&"%'"
openrs rsFun, sql
if rsFun.EOF Then
    ' is dit erg?
Else
    if isnull(rsFun("fac_functie_key").Value) Then
        INTERNAL_ERROR_FACMGT_ZONDER_FACFUNCTIE
    End If
    sql = "SELECT 1 FROM fac_v_webgebruiker" & _
          " WHERE prs_perslid_key = " & user_key & _
          "   AND fac_functie_key = " & rsFun("fac_functie_key").Value & _
          "   AND fac_gebruiker_prs_level_write < 9" & _
          "   AND fac_gebruiker_alg_level_write < 9"
    openrs rsRechten, sql
    if rsRechten.Eof Then
        Response.Write("Not Authorized")
        Response.End
    End If
End If

' Simpele versie van de JavaScript functie:
' *Eist* schrijfrechten op autfunction
Sub checkAutorisation(autfunction)
    sql = "SELECT * FROM fac_v_webgebruiker fvw, fac_functie ff" & _
          " WHERE fvw.prs_perslid_key = " & user_key & _
          "   AND ff.fac_functie_code = '" & autfunction & "'" & _
          "   AND fvw.fac_functie_key = ff.fac_functie_key" & _
          "   AND fvw.fac_gebruiker_prs_level_write < 9" & _
          "   AND fvw.fac_gebruiker_alg_level_write < 9"
    openrs rsRechten, sql
    if rsRechten.Eof Then
        Response.Write("Not Authorized")
        Response.End
    End If
End Sub

' ====================================================================
Function protectQS(url)
    Dim pqs
    Set pqs = GetObject("script:"&Server.MapPath("../shared/protectQS.wsc"))
    protectQS = pqs.create(url, ""&Application(Session("customerId") + "_protectsecret"), user_key, Server.MapPath("../shared/sha1.wsc"))
End Function

' ====================================================================
' AntiForgeryToken
sFormAction = GetParam("FormAction")
sFName = Request.Servervariables("SCRIPT_NAME")
arrFNames = Split(sFName, "/")
sFName = arrNames(Ubound(arrFNames))
useToken = True
' Bij ...grid.asp bestanden niet een cookie aanmaken en controleren (bij ...record?.asp bestanden wel)
if Right(sFName, 8) = "grid.asp" Then
    useToken = False
End If

sFName = Replace(sFName, ".", "")
sFName = Replace(sFName, "_", "")

Sub validateAntiForgeryToken()
  sVerificationToken = GetParam("__RequestVerificationToken")
  sCookieToken = Session("ASPFIXATION")
'  Response.Write("sVerificationToken = " & sVerificationToken)
'  Response.Write("sCookieToken = " & sCookieToken)
' // De token van het hidden inputveld valideren met de ASPFIXATION cookie
  if sVerificationToken <> sCookieToken Then
     Response.Write("Authentification Error: The input process was possibly to slow. Try again")
     Response.End
  End If
end Sub

Sub makeAntiForgeryToken()
'   Session ASPFIXATION token wordt gebruikt als cookie voor CSRF Cross Site
    dim token
    token = Session("ASPFIXATION")
%>
    <script  type="text/javascript">
      function DoMakeAFT()
      {
        for (var i = 0; i < document.forms.length; i++)
        {
            var elem = document.createElement("input");
            elem.name = '__RequestVerificationToken';
            elem.type = 'hidden';
            elem.value = '<%=token%>';
            document.forms[i].appendChild( elem );
        }
      }
    </script>
<%
' Zo laat mogelijk en voor de zekerheid via een (korte!) Timeout
setvar "Footer","<script  type=""text/javascript"">setTimeout(""DoMakeAFT()"", 100);</script>"
end Sub

Select Case sFormAction
  Case "update", "insert", "delete"
    if useToken then
      validateAntiForgeryToken
    end if
end select

' ====================================================================
' Vertaalde teksten
    Set vbLCL = Server.CreateObject("Scripting.Dictionary")

    sql = "SELECT FAC_LOCALE_MGT_LABEL, FAC_LOCALE_MGT_Module, FAC_LOCALE_MGT_Filenaam, FAC_LOCALE_MGT_TEKST" & _
          "  FROM FAC_LOCALE_MGT" & _
          " WHERE FAC_LOCALE_MGT_LANG = '"&Session("user_lang")&"'" & _
          " ORDER BY FAC_LOCALE_MGT_Filenaam, FAC_LOCALE_MGT_Module"
    openrs rsLCL, sql
    while not rsLCL.EOF
      module = rsLCL("FAC_LOCALE_MGT_Module").Value
      file = rsLCL("FAC_LOCALE_MGT_Filenaam").Value
      if Not isnull(module) AND Not vbLCL.Exists(module) then
        Set oMod = Server.CreateObject("Scripting.Dictionary")
        vbLCL.Add module, oMod
      end if
      if Not isnull(file) then
        If Not vbLCL.Item(module).Exists(file) then
            Set oFile = Server.CreateObject("Scripting.Dictionary")
            vbLCL.Item(module).Add file, oFile
        End If
      end if
      if Not isnull(file) then
        vbLCL.Item(module).Item(file).Add rsLCL("FAC_LOCALE_MGT_LABEL").Value, rsLCL("FAC_LOCALE_MGT_TEKST").Value
      ElseIf Not isnull(module) then
        vbLCL.Item(module).Add rsLCL("FAC_LOCALE_MGT_LABEL").Value, rsLCL("FAC_LOCALE_MGT_TEKST").Value
      Else
        vbLCL.Add rsLCL("FAC_LOCALE_MGT_LABEL").Value, rsLCL("FAC_LOCALE_MGT_TEKST").Value
      End If
      rsLCL.MoveNext
    wend

' ====================================================================

Function myUDLPath()
If IsEmpty(Session("customerId")) Or IsEmpty(Session("user_key")) Then ' ASP-Sessie verlopen.
    Response.Redirect("../shared/expired.asp")
End If
    myUDLPath = Server.MapPath("..\..\cust\"+Session("CustomerID")+"\oracle.udl")
End Function

'Detecteer op welke database er gewerkt wordt

' Oracle
str_concat = "||"
sysdate = "SYSDATE"
fnToChar = "TO_CHAR"
fnNVL = "NVL"
from_dual = " from dual"

function StrToTable(strTable)
	dim tmp
	tmp = strTable
	' Verwijder het einde van de string
	tmp = replace(tmp,"grid.asp","")
	tmp = replace(tmp,"record.asp","")
	StrToTable = tmp
	set tmp = Nothing
end function

function customFacDelete(strTable,value)
	dim tmp
	dim tabel
	tabel = strToTable(strTable)
	tmp = "update "+tabel+" set "+tabel+"_VERWIJDER="+sysdate+" where "+tabel+"_KEY="+CStr(value)
	customFacDelete = tmp
	set tmp = Nothing
end function

function customFacDelete1(strTable,veld,value)
	dim tmp
	dim tabel
	tabel = strToTable(strTable)
	tmp = "update "+tabel+" set "+tabel+"_VERWIJDER="+sysdate+" where "+veld+"="+CStr(value)
	customFacDelete1 = tmp
	set tmp = Nothing
end function

'Functie om string naar datum te converteren.
function toDate(datum)
if (datum="") then
  toDate = "Null"
	exit function
end if
    'Oracle
    toDate = "TO_DATE('"+datum+"','dd mm yy')"
end function

' ============================================================================
' LET OP: DEZE openrs overruled de default openrs uit Common.asp
'         hij logt eventueel de SQL
'         Let op: In de CodeCharge code wordt ook vaak een cn.execute
'                 gedaan. Deze worden niet automatisch gelogt!
' ============================================================================
sub openrs(rs, sql)
  Set rs = Server.CreateObject("ADODB.Recordset")
  rs.CursorLocation = adUseServer
VB_Log(sql)
  rs.Open sql, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
end sub

' ============================================================================
' LET OP: DEZE PrintVar overruled de default PrintVar uit TemplateObj.asp
'         A) hij injecteert jQuery
'
Function PrintVar(sName)
  tmp = ParsedBlocks(sName)
  tmp = replace(tmp,"Site.css",AddTimeStamp("../../temp/" + Session("customerId") + ".css"))
  jq = "../localscripts/" & jqueryver & ".min.js" ''
  scr = Chr(13) & "<script type='text/javascript' src='" & AddTimeStamp(jq) & "'></script>"
  tmp = replace(tmp,"</head>", scr & "</head>")
  fPath = "../localscripts/FcltMgr.js"
  scr = Chr(13) & "<script type='text/javascript' src='" & AddTimeStamp(fPath) & "'></script>"
  tmp = replace(tmp,"</head>", scr & "</head>")
  fPath = "./FacmgtTools.js"
  scr = Chr(13) & "<script type='text/javascript' src='" & AddTimeStamp(fPath) & "'></script>"
  tmp = replace(tmp,"</head>", scr & "</head>")
  fPath = "../shared/locale_facmgt.js"
  scr = Chr(13) & "<script type='text/javascript' src='" & AddTimeStamp(fPath) & "'></script>"
  tmp = replace(tmp,"</head>", scr & "</head>")
  scr = Chr(13) & "<script type='text/javascript'>var multi_language_option = " & S("multi_language_option") & "</script>"
  tmp = replace(tmp,"</head>", scr & "</head>")
  PrintVar = tmp
End function

Function AddTimeStamp(sPath)
  Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
  Set f = objFSO.GetFile(Server.MapPath(sPath))
  timeStart = "1/1/1970 12:00:00 AM"
  timeStamp = datediff("s", timeStart, f.DateLastModified)
  Set f = Nothing
  Set objFSO = Nothing
  AddTimeStamp = sPath & "?" & timeStamp
End Function

' ============================================================================
' LET OP: DEZE ProcessError overruled de default ProcessError uit Common.asp
'         hij probeert de fac_message er bij te halen
' ============================================================================
function ProcessError()
  if cn.Errors.Count > 0 then
    ProcessError = cn.Errors(0).Description ' & " (" & cn.Errors(0).Source & ")"
    xx = DLookUp("FAC_MESSAGE", "FAC_MESSAGE_TEXT", "FAC_MESSAGE_CODE = " + ToSQL(ProcessError, "Text"))
    ProcessError = ProcessError + ": " + xx
  elseif not (Err.Description = "") then
    ProcessError = Err.Description
  else
    ProcessError = ""
  end if
// VB_LOG("ProcessError found: " + ProcessError)
end Function

' ============================================================================
' LET OP: DEZE LoadTemplate overruled de default LoadTemplate uit
'         TemplateObj.asp. Deze probeert de labels te vertalen
'         Dat doen we door direct na laden van de HTML deze te 'vertalen'
'         Dan zit er nog geen klant-data in die we per ongeluk mee vertalen
' ============================================================================
Sub LoadTemplate(sPath, sName)
  Dim nName

  if not isObject(objFSO) then
    Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
    Set DBlocks = Server.CreateObject("Scripting.Dictionary")
    Set ParsedBlocks = Server.CreateObject("Scripting.Dictionary")
  end if
  if objFSO.FileExists(sPath) then
    DBlocks.Add sName, objFSO.OpenTextFile(sPath).ReadAll
    nName = NextDBlockName(sName)
    while not (nName = "")
      SetBlock sName, nName
      nName = NextDBlockName(sName)
    wend
  end if
VB_LOG("Loading file: " &  sPath)
  For Each Item in DBlocks
     VB_LOG("Translating blok " & Item)
        ' Kijk eerst of er een bestands-specifieke vertaling is
        ' Zo niet neem dan een module(eerste 3 char) vertaling
        ' Zo niet neem dan een globale vertaling
      DBlocks(Item) = TranslateBlock(sPath, Item, DBlocks(Item))
  Next

  if useToken then
    makeAntiForgeryToken
  end if

End Sub

''  We zoeken te vertalen:
' <font class="ColumnFONT">Omschrijving</font>
' <font class="DataFONT">Geen records</font>
Function TranslateBlock(sPath, blockName, sTpl)
    sTpl = TranslateFind(sPath, blockName, sTpl, "<font class=""ColumnFONT"">", "</font>")
    sTpl = TranslateFind(sPath, blockName, sTpl, "<font class=""DataFONT"">", "</font>")
    sTpl = TranslateFind(sPath, blockName, sTpl, "<font class=""FieldCaptionFONT"">", "</font>")
    ' <input type="submit" value="Verwijderen" onclick="document.KenmerkRecord.FormAction.value = 'delete';"/>
    sTpl = TranslateFind(sPath, blockName, sTpl, "<input type=""submit"" value=""", """ onclick=""")
    ' <input type="submit" value="Zoeken">
    sTpl = TranslateFind(sPath, blockName, sTpl, "<input type=""submit"" value=""", """>")
    TranslateBlock = sTpl
End Function

Function TranslateFind(sPath, blockName, sTpl, pre, post)
  Dim regEx, sMatch, oMatches, sName, sTTpl
  Dim res, b, e, isOk, begin
  Dim w(5)

  begin = 1
  b = instr(begin, sTpl, pre)
  while b > 0
      e = instr(b, sTpl, post)
      if (e > 0) then
          ' Zoek wel de binnenste:
          while instr(b+1, sTpl, pre) > b AND instr(b+1, sTpl, pre) < e
              b = instr(b+1, sTpl, pre)
          wend

          tb = b + Len(pre) 'instr(b, sTpl, "FONT"">") + 6 ' hier begint echt de tekst
          VB_LOG("b: " & b & " tb: " & tb & " e: " & e & " s=" & Server.HTMLEncode(mid(sTpl, tb)))
          res = mid(sTpl, tb, e - tb)
          VB_LOG("Tekst: x" & Server.HTMLEncode(res) & "x")
          sTpl = mid(sTpl, 1, tb-1) &  TranslateOne(sPath, blockName, res) & mid(sTpl, e)
          begin = e + 1
      else
        begin = begin + 1
      end if
    b = instr(begin, sTpl, pre)
  wend
TranslateFind = sTpl
End Function

Function matchi(msg, patrn)
   matchi = (domatchi(msg, patrn).Count > 0)
End Function

Function domatchi(strng, patrn)
   Set regEx = New RegExp   ' Create a regular expression.
   regEx.Pattern = patrn   ' Set pattern.
   regEx.IgnoreCase = True   ' Set case insensitivity.
   Set domatchi = regEx.Execute(strng)
End Function

' ============================================================================
' LET OP: DEZE SetVar overruled de default SetVar uit TemplateObj.asp
'         A) hij probeert FormTitle te vertalen
'         B) Ook probeert hij ORA- foutmeldingen te vertalen.
'         C) SetVar van een Trn_xxxx maakt hij html-safe
'' TODO: 'labels' vertalen door testen op <i>? fldVoorraad= "<i>Voorraad</i>"
Function SetVar(sName, sValue)
  Dim sv2, arr, x
  if Left(sValue, 4) = "ORA-" then ' Uit m_conncetions.inc afgeleid
    msg = sValue
    if matchi(msg, "^ORA-20000") OR matchi(msg, "^ORA-20004") OR matchi(msg, "^ORA-00001") OR matchi(msg, "^ORA-02290") then
        faccode = ""
        friendlyMsg = ""
        knownError = False

        Set RegCode = domatchi(msg, "^ORA-20000: (\w*)(.*)\nORA-") ' Zoek: ORA-20000: res_m039 ORA-06512: at "UWVA_500.ALG_T_ALG_RUIMTE_B_IU", line 71 ORA-04088: error during execution of trigger 'UWVA_500.ALG_T_ALG_RUIMTE_B_IU'
        If RegCode.count = 0 Then
            Set RegCode = domatchi(msg, "^ORA-20004: (\w*)(.*)\nORA-") ' Zoek: ORA-20004: ins_m145,Normverbruik,0, ORA-06512: at .......
        End If
        If RegCode.count = 0 Then
            Set RegCode = domatchi(msg, "^ORA-00001: .* \(.*\.(\w*)\)") ' Zoek: ORA-00001: unique constraint (UWVA_500.ALG_U_ALG_RUIMTE_UPPER_NR) violated
        End If
        if RegCode.count = 0 Then
            Set RegCode = domatchi(msg, "^ORA-02290: .* \(.*\.(\w*)\)") ' Zoek: ORA-02290: check constraint (UWVA_500.ALG_C_ALG_RUIMTE_UPPER_NR) violated
        End If

        If RegCode(0).SubMatches.count > 1 Then
            faccode = RegCode(0).SubMatches(0)
        End If
        If matchi(msg, "^ORA-20000") AND RegCode(0).SubMatches.count > 2 Then
            friendlyMsg = RegCode(0).SubMatches(1) ' een ORA-20000 met ingebouwde tekst zoals ORA-20000: alg_m999 Ruimte kan nog niet verwijderd worden. Er zijn nog lopende meldingen
            knownError = True
        End If
        // We gaan proberen de tekst er bij te zoeken
        If faccode <> "" Then
            sql2 = "select FAC_MESSAGE_TEXT from fac_message where fac_message_code = upper('"+Replace(faccode, "'", "''")+"')"
            Set oRs = cn.Execute( sql2 )
            if Not oRs.EOF Then
                knownError = True
                friendlyMsg = oRs("FAC_MESSAGE_TEXT").Value & "<br>(" & faccode & ")"
            End if
            oRs.Close()
        End If
        If knownError Then
            sValue = friendlyMsg
        else
            ' We kunnen niets
        End If
      end if
  end if
  if sName = "FormTitle" then
    sv2 = TranslateOne("\", "", sValue)
    if sv2 = sValue then ' nog geen complete vertaling gevonden
        arr=Split(sValue)
        sv2 = ""
        if UBound(arr) >= 0 then
            for each x in arr
                sv2 = sv2 & " " & TranslateOne("\", "", Ucase(Left(x, 1)) & Mid(x,2))
            next
        end if
        if sv2 = " " & sValue then ' nog geen complete vertaling gevonden
            sv2 = TranslateOne("\", "", "Details") ' dan maar generiek
        end If
    end if
    sValue = sv2
  end if
  ' Trn_ (transit) variabelen moeten wel XSS bestendig gemaakt worden
  Dim val2
  val2 = replace(replace(sValue, "{", "&#123;"), "}", "&#125;")
  if Left(sName, 4) = "Trn_" then
    val2 = Server.HTMLEncode(val2)
  end if
  if ParsedBlocks.Exists(sName) then
    ParsedBlocks(sName) = val2
  else
    ParsedBlocks.add sName, val2
  end if
End Function

' Voorkeur is altijd sPath-specifiek
' zoniet dan module (alg) specifiek
' zoniet dan generiek
Function TranslateOne(sPath, blockName, txt)
    Dim sName, arrNames, module, oModule
    TranslateOne = txt ' standaard niet vertalen
    arrNames = Split(sPath, "\")
    sName = arrNames(Ubound(arrNames))
    module = UCase(mid(sName, 1, 3))
    if vbLCL.Exists(module) then
        Set oModule = vbLCL.Item(module)
        if oModule.Exists(sname) then
            if oModule.Item(sname).Exists(txt) then
                TranslateOne = oModule.Item(sname).Item(txt)
                Exit Function
            end if
        end if
        if vbLCL.Item(module).Exists(txt) then
            TranslateOne = vbLCL.Item(module).Item(txt)
            Exit Function
        end if
    end if
    '' Generiek
    if vbLCL.Exists(txt) then
        TranslateOne = vbLCL.Item(txt)
    end if
End Function

Function FCLTLCL(txt)
    FCLTLCL = TranslateOne("\", "", txt)
    Exit Function
End Function

' Als de JScript variant maar we nemen niet de moeite te cachen
Function L(lcl)
    Dim Table, fName, sWhere
    Table = "fac_locale_xsl"
    fName = " COALESCE(fac_locale_xsl_cust, fac_locale_xsl_tekst)"
    sWhere = "    fac_locale_xsl_lang = '"&Session("user_lang")&"'" & _
             "   AND fac_locale_xsl_label = " & ToSQL(lcl, "Text") & _
             "   AND fac_locale_xsl_module = 'ASP'"
    L = DLookUp(Table, fName, sWhere)
    Exit Function
End Function

' Als de JScript variant maar we nemen niet de moeite te cachen
' Ook doen we niets met het datatype en leveren altijd string op!
Function S(sname)
    Dim Table, fName, sWhere
    Table = "fac_setting"
    fName = " coalesce(fac_setting_pvalue, fac_setting_default)"
    sWhere = "    fac_setting_name = " & ToSQL(sname, "Text")
    S = DLookUp(Table, fName, sWhere)
    Exit Function
End Function

'Deze functie vertaalt het positie autorisatieniveau naar tekst
function decode_pos_level(aut_level)
select case aut_level
  case "-1" d_pos_level = FCLTLCL("Alles")
  case "0"  d_pos_level = L("lcl_region")
  case "1"  d_pos_level = L("lcl_district")
  case "2"  d_pos_level = L("lcl_location")
  case "3"  d_pos_level = L("lcl_building")
  case "4"  d_pos_level = L("lcl_floor")
  case "5"  d_pos_level = L("lcl_room")
  case "9"  d_pos_level = FCLTLCL("Geen")
  case else d_pos_level = aut_level
end select
decode_pos_level = d_pos_level
end function

function decode_org_level(aut_level)
select case aut_level
  case "-1" d_org_level = FCLTLCL("Alles")
  case "0"  d_org_level = L("lcl_company")
  case "1"  d_org_level = L("lcl_dep_name_level1")
  case "2"  d_org_level = L("lcl_dep_name_level2")
  case "3"  d_org_level = L("lcl_dep_name_level3")
  case "4"  d_org_level = L("lcl_dep_name_level4")
  case "5"  d_org_level = L("lcl_dep_name_level5")
  case "9"  d_org_level = FCLTLCL("Geen")
  case else d_org_level = aut_level
end select
decode_org_level = d_org_level
end function

function buildName(prs_perslid_key)
if prs_perslid_key = "" then
  buildName = ""
else
  tmpsql = "select prs_perslid_naam, prs_perslid_voorletters, prs_perslid_voornaam from prs_v_aanwezigperslid where prs_perslid_key = "&prs_perslid_key
VB_Log("tmpsql")
VB_Log(tmpsql)
  openrs tmprs, tmpsql
  Voorletters = getValue(tmprs,"prs_perslid_voorletters")
  Voornaam = getValue(tmprs,"prs_perslid_voornaam")
  Naam = getValue(tmprs,"prs_perslid_naam")
  if Voorletters <> "" then
    Naam= Naam & ", "&Voorletters
  end if
  if Voornaam <> "" then
    Naam = Naam& " ("&Voornaam&")"
  end if
  tmprs.Close
  buildName = Naam
end if
end function

function decode_min_level(minlevel)
select case minlevel
  case "1" decode_min_level = "Lezen"
  case "2" decode_min_level = "Schrijven"
  case "3" decode_min_level = "Keuze"
  case else decode_min_level = ""
end select
decode_min_level = TranslateOne("\", "", decode_min_level)
end function


function buildORGRadioList()
  str = ""
  for i = -1 to CDbl(S("prs_max_dep_level"))
    str = str & i & ";" & decode_org_level(i) & ";"
  next
  str = str & "9;" & decode_org_level(9) ' Geen
  buildORGRadioList = str
end function

function buildPOSRadioList()
  ' s = "-1;Alles;0;Regio;1;District;2;Locatie;3;Gebouw;4;Verdieping;5;Ruimte;9;Geen"
  DIM s
  s = ""
  for i = -1 to 4
    s = s & i & ";" & decode_pos_level(i) & ";"
  next
  s = s & "9;" & decode_pos_level(9) ' Geen
  buildPOSRadioList = s
end function

function buildVerplichtingList()
  DIM s
  s = ";"  & FCLTLCL("Niet verplicht") & _
      ";1;" & FCLTLCL("Altijd verplicht") & _
      ";2;" & FCLTLCL("Groepsverplichting")
  buildVerplichtingList = s
end function

function buildGroepsverplichtingList()
  DIM s
  sGroepsverplichting = FCLTLCL("Groep")
  s = "0;"
  for i = 1 to 9
    s = s & ";" & i & ";" & sGroepsverplichting & " " & i
  next
  buildGroepsverplichtingList = s
end function

function buildStatusList()
  DIM statusList
  DIM sql
  '    "       SELECT 0, '"  & L("lcl_mld_pending")      & "' FROM DUAL" &_
  '    " UNION SELECT 2, '"  & L("lcl_mld_ingevoerd")    & "' FROM DUAL" &_
  '    " UNION SELECT 3, '"  & L("lcl_mld_ingezien")     & "' FROM DUAL" &_
  '    " UNION SELECT 4, '"  & L("lcl_mld_geaccepteerd") & "' FROM DUAL" &_
  '    " UNION SELECT 6, '"  & L("lcl_mld_verwerkt")     & "' FROM DUAL" &_
  '    " UNION SELECT 7, '"  & L("lcl_mld_uitgegeven")   & "' FROM DUAL" &_
  sql  = "SELECT 1, '"  & L("lcl_mld_afgewezen") & "' FROM DUAL" &_
  " UNION SELECT 6, '"  & L("lcl_mld_afgemeld")  & "' FROM DUAL" &_
  " ORDER BY 1"
  openrs rsStatus, sql
  statusList = "-1;"
  While not rsStatus.EOF
    statusList = statusList & ";" & getValue(rsStatus,0) & ";" & getValue(rsStatus,1)
    rsStatus.MoveNext
  wend
  buildStatusList = statusList
end function

function buildKenmerkTypeList(pKENMERKTYPE)
  sResult = ""
  select case pKENMERKTYPE
  case "C": sResult = "C;"& FCLTLCL("Karakter")
  case "N": sResult = "N;"& FCLTLCL("Numeriek")
  case "D": sResult = "D;"& FCLTLCL("Datum")
  case "R": sResult = "R;"& FCLTLCL("Referentie (listbox)") &";S;"& FCLTLCL("Referentie (suggest)")
  case "S": sResult = "S;"& FCLTLCL("Referentie (suggest)") &";R;"& FCLTLCL("Referentie (listbox)")
  case "X": sResult = "X;"& FCLTLCL("Bestandsnaam")
  case "F": sResult = "F;"& FCLTLCL("Bestand")
  case "E": sResult = "E;"& FCLTLCL("Encrypted Bestand")
  case "M": sResult = "M;"& FCLTLCL("Folder met bestanden")
  case "L": sResult = "L;"& FCLTLCL("Label")              &";l;"& FCLTLCL("Label (inklapbaar)")
  case "l": sResult = "l;"& FCLTLCL("Label (inklapbaar)") &";L;"& FCLTLCL("Label")
  case "Q": sResult = "Q;"& FCLTLCL("Blanco")
  case else sResult = ";" & _
  	                  ";C;"& FCLTLCL("Karakter") & _
  	                  ";N;"& FCLTLCL("Numeriek") & _
      	              ";D;"& FCLTLCL("Datum") & _
  	                  ";R;"& FCLTLCL("Referentie (listbox)") & _
  	                  ";S;"& FCLTLCL("Referentie (suggest)") & _
  	                  ";X;"& FCLTLCL("Bestandsnaam") & _
  	                  ";F;"& FCLTLCL("Bestand") & _
  	                  ";E;"& FCLTLCL("Encrypted Bestand") & _
  	                  ";M;"& FCLTLCL("Folder met bestanden") & _
  	                  ";L;"& FCLTLCL("Label") & _
  	                  ";l;"& FCLTLCL("Label (inklapbaar)") & _
  	                  ";Q;"& FCLTLCL("Blanco")
  end select
  buildKenmerkTypeList = sResult
end function

function buildKenmerkTypeSearch()
  sResult =   ";"& FCLTLCL("Alles") & _
  	        ";C;"& FCLTLCL("Karakter") & _
  	        ";N;"& FCLTLCL("Numeriek") & _
      	    ";D;"& FCLTLCL("Datum") & _
  	        ";R;"& FCLTLCL("Referentie (listbox)") & _
  	        ";S;"& FCLTLCL("Referentie (suggest)") & _
  	        ";X;"& FCLTLCL("Bestandsnaam") & _
  	        ";F;"& FCLTLCL("Bestand") & _
  	        ";E;"& FCLTLCL("Encrypted Bestand") & _
  	        ";M;"& FCLTLCL("Folder met bestanden") & _
  	        ";L;"& FCLTLCL("Label") & _
  	        ";l;"& FCLTLCL("Label (inklapbaar)") & _
  	        ";Q;"& FCLTLCL("Blanco")
  buildKenmerkTypeSearch = sResult
end function

function decodeKenmerkType(sType)
  select case sType
    case "C" sKenmerkType = FCLTLCL("Karakter")
    case "N" sKenmerkType = FCLTLCL("Numeriek")
    case "D" sKenmerkType = FCLTLCL("Datum")
    case "R" sKenmerkType = FCLTLCL("Referentie (listbox)")
    case "S" sKenmerkType = FCLTLCL("Referentie (suggest)")
    case "X" sKenmerkType = FCLTLCL("Bestandsnaam")
    case "F" sKenmerkType = FCLTLCL("Bestand")
    case "E" sKenmerkType = FCLTLCL("Encrypted bestand")
    case "M" sKenmerkType = FCLTLCL("Folder met bestanden")
    case "L" sKenmerkType = FCLTLCL("Label")
    case "l" sKenmerkType = FCLTLCL("Label (inklapbaar)")
    case "Q" sKenmerkType = FCLTLCL("Blanco")
    case else sKenmerkType = ""
  end select
  decodeKenmerkType = sKenmerkType
end function

function getFacGroepByPrsLidKey(pPRS_PERSLID_KEY)
  if isNull(pPRS_PERSLID_KEY) or isEmpty(pPRS_PERSLID_KEY) or (pPRS_PERSLID_KEY="") then
  	getFacGroepByPrsLidKey = ""
  	exit function
  end if
  groepSql = "select fg.fac_groep_omschrijving "&_
             "from fac_groep fg, fac_gebruikersgroep gg "&_
             "where fg.fac_groep_key = gg.fac_groep_key and "&_
             "gg.prs_perslid_key="& ToSQL(pPRS_PERSLID_KEY, "Number") &" "&_
             "order by fg.fac_groep_omschrijving asc "
VB_Log("groepSql")
VB_Log(groepSql)

  openrs rsGroep, groepSql
  sResult = ""
  while not rsGroep.EOF
    sResult = sResult & "<br>" & ToHTML(getValue(rsGroep,"fac_groep_omschrijving"))
    rsGroep.MoveNext
  wend
  getFacGroepByPrsLidKey = Mid(sResult,5,Len(sResult))
end function

function getWorkflowstepOmschr(pMLD_WORKFLOWSTEP_KEY)
  sResult = ""
  if pMLD_WORKFLOWSTEP_KEY <> "" then
    sqlTekst = "select w.mld_workflowstep_omschrijving "&str_concat&"' ('"&str_concat&"d.ins_discipline_omschrijving "&str_concat&" ' / ' "&str_concat&" s.mld_stdmelding_omschrijving "&str_concat&"')' as h "&_
               "from mld_discipline d, mld_stdmelding s, mld_workflowstep w "&_
               "where d.ins_discipline_verwijder is null "&_
               "  and s.mld_ins_discipline_key = d.ins_discipline_key "&_
               "  and s.mld_stdmelding_key=w.mld_stdmelding_key "&_
               "  and w.mld_workflowstep_key="& ToSQL(pMLD_WORKFLOWSTEP_KEY, "Number")
    openrs rsTekst, sqlTekst
    if not rsTekst.EOF then
      sResult = getValue(rsTekst,"h")
    end if
    rsTekst.Close
  end if
  getWorkflowstepOmschr = sResult
end function

function getWorkflowNextSteps(pMLD_WORKFLOWSTEP_KEY,pMLD_WORKFLOWRULE_RESULT)
  sResult = ""
  if (pMLD_WORKFLOWSTEP_KEY <> "") and (pMLD_WORKFLOWRULE_RESULT <> "") then
    sqlKeys = "select mld_workflowstep_next_key "&_
              "from mld_workflowrule "&_
              "where mld_workflowstep_key = "& ToSQL(pMLD_WORKFLOWSTEP_KEY, "Number") &_
              "  and mld_workflowrule_result = "& ToSQL(pMLD_WORKFLOWRULE_RESULT, "Number")
    openrs rsKeys,sqlKeys
    while not rsKeys.EOF
      sKey = getValue(rsKeys,"mld_workflowstep_next_key")
      if sResult <> "" then sResult = sResult & "<br>"
      sResult = sResult & ToHTML(getWorkflowstepOmschr(sKey))
      rsKeys.MoveNext
    wend
  end if
  getWorkflowNextSteps = sResult
end function

'Zoekt de omschrijving van een vakgroeptype op bij een discipline_key
function getSrtDisciplineOmschr(pINS_DISCIPLINE_KEY)
  if pINS_DISCIPLINE_KEY = "" or isNull(pINS_DISCIPLINE_KEY) then
    getSrtDisciplineOmschr = ""
    exit function
  end if
  sResult = ""
  sqlSrtDiscipline = "select ins_srtdiscipline_omschrijving "&_
                     "from ins_srtdiscipline s, ins_tab_discipline t "&_
                     "where s.ins_srtdiscipline_key = t.ins_srtdiscipline_key "&_
                     "  and t.ins_discipline_key="& ToSQL(pINS_DISCIPLINE_KEY, "Number")
  openrs rsSrtDiscipline, sqlSrtDiscipline
  if not rsSrtDiscipline.EOF then
    sResult = ToHTML(getValue(rsSrtDiscipline,"ins_srtdiscipline_omschrijving"))
  end if
  getSrtDisciplineOmschr = sResult
end function



' Genereer een legenda aan de hand van voorkomende waarden
Function GenereerLegenda(fldCAD_THEMA_VIEW, fldCAD_THEMA_OMSCHRIJVING)
    rndSQL = "to_char(dbms_utility.get_hash_value(WAARDE,0,power(2,24)), '0XXXXX')"
    'rndSQL = "to_char(trunc(dbms_random.value(0, POWER(2,24))),'0XXXXX')"
    ' wordt soms te lang legName = "Legenda_" & fldCAD_THEMA_OMSCHRIJVING & "_" & Timer
    legName = "Legenda_" & Timer
    sSql = "INSERT INTO CAD_LEGENDA (CAD_LEGENDA_OMSCHRIJVING, CAD_LEGENDA_DISCREET) VALUES (" + ToSQL(legName, "Text") + ", 1)"
    cn.execute sSQL
    sSql = "SELECT CAD_LEGENDA_KEY FROM CAD_LEGENDA WHERE CAD_LEGENDA_OMSCHRIJVING = " + ToSQL(legName, "Text")
    openrs rsLegenda, sSql
    iKey = getValue(rsLegenda,"CAD_LEGENDA_KEY")
    sSql = "INSERT INTO CAD_LEGENDAWAARDE"&_
           " (CAD_LEGENDA_KEY, CAD_LEGENDAWAARDE_VALUE,"&_
           "  CAD_LEGENDAWAARDE_RGB, CAD_LEGENDAWAARDE_OMSCHR)"&_
           " SELECT DISTINCT " & iKey & ", WAARDE, "&rndSQL&", WAARDE"&_
           " FROM " & fldCAD_THEMA_VIEW
    cn.execute sSQL
    GenereerLegenda = iKey
End Function


' Breidt een legenda uit aan de hand van voorkomende nieuwe waarden
Sub UpdateLegenda(fldCAD_THEMA_VIEW, fldCAD_LEGENDA_KEY)
    rndSQL = "to_char(dbms_utility.get_hash_value(WAARDE,0,power(2,24)), '0XXXXX')"
    sSql = "INSERT INTO CAD_LEGENDAWAARDE"&_
           " (CAD_LEGENDA_KEY, CAD_LEGENDAWAARDE_VALUE,"&_
           "  CAD_LEGENDAWAARDE_RGB, CAD_LEGENDAWAARDE_OMSCHR)"&_
           " SELECT DISTINCT " & ToSQL(fldCAD_LEGENDA_KEY, "Number") & ", WAARDE, "&rndSQL&", WAARDE"&_
           " FROM " & fldCAD_THEMA_VIEW & " thv " &_
           " WHERE WAARDE IS NOT NULL " &_
           "   AND NOT EXISTS (SELECT cl.CAD_LEGENDAWAARDE_VALUE FROM CAD_LEGENDAWAARDE cl "&_
                               "WHERE cl.CAD_LEGENDAWAARDE_VALUE = thv.WAARDE "&_
                               "  AND cl.CAD_LEGENDA_KEY="&ToSQL(fldCAD_LEGENDA_KEY, "Number") & ")"
    cn.execute sSQL
End Sub

' Accepteer zowel komma als punten in strDbl zodat later CDbl goed werkt
Function SafeToDouble(strDbl)
    If Instr(CStr(1.5), ",")  > 1 Then ' Het moeten komma's zijn
        SafeToDouble = replace(strDbl, ".", ",")
    Else
        SafeToDouble = replace(strDbl, ",", ".")
    End If
End Function

' Kopieer de rechten van een functie/groep/discipline naar een andere discipline
' We ondersteunen geen kopie naar een andere functie of groep
Sub KopieRechten (FunctieKey, GroepKey, DiscKeyVan , DiscKeyNaar)
    VB_Log("Kopie: " & FunctieKey & "," & GroepKey & "," & DiscKeyVan & "," & DiscKeyNaar)
    sqlVan =  "SELECT * FROM FAC_GROEPRECHTEN" & _
              " WHERE FAC_FUNCTIE_KEY = " & FunctieKey & _
              "   AND FAC_GROEP_KEY = " & GroepKey & _
              "   AND INS_DISCIPLINE_KEY = " & DiscKeyVan
    whrNaar = " WHERE FAC_FUNCTIE_KEY = " & FunctieKey & _
              "   AND FAC_GROEP_KEY = " & GroepKey & _
              "   AND INS_DISCIPLINE_KEY = " & DiscKeyNaar
    openrs rsVan, sqlVan
    if rsVan.EOF Then
        sql = "DELETE FROM FAC_GROEPRECHTEN " + whrNaar
        VB_Log(sql)
        cn.execute sql
    Else
        openrs rsNaar, "SELECT FAC_GROEPRECHTEN_KEY FROM FAC_GROEPRECHTEN " + whrNaar
        if rsNaar.EOF Then
            sql = "insert into FAC_GROEPRECHTEN (" & _
                  "FAC_FUNCTIE_KEY,FAC_GROEP_KEY,INS_DISCIPLINE_KEY," & _
                  "FAC_GEBRUIKER_PRS_LEVEL_READ,FAC_GEBRUIKER_PRS_LEVEL_WRITE," & _
                  "FAC_GEBRUIKER_ALG_LEVEL_READ,FAC_GEBRUIKER_ALG_LEVEL_WRITE" & _
                  ")" & _
                  " values (" & FunctieKey & "," & GroepKey  & "," & DiscKeyNaar & "," & _
                    rsVan("FAC_GEBRUIKER_PRS_LEVEL_READ") & "," & _
                    rsVan("FAC_GEBRUIKER_PRS_LEVEL_WRITE") & "," & _
                    rsVan("FAC_GEBRUIKER_ALG_LEVEL_READ")  & "," & _
                    rsVan("FAC_GEBRUIKER_ALG_LEVEL_WRITE") & _
                  ")"
        Else
            sql = "UPDATE FAC_GROEPRECHTEN SET " & _
                      "FAC_GEBRUIKER_PRS_LEVEL_READ="&rsVan("FAC_GEBRUIKER_PRS_LEVEL_READ")&"," & _
                      "FAC_GEBRUIKER_PRS_LEVEL_WRITE="&rsVan("FAC_GEBRUIKER_PRS_LEVEL_WRITE")&"," & _
                      "FAC_GEBRUIKER_ALG_LEVEL_READ="&rsVan("FAC_GEBRUIKER_ALG_LEVEL_READ")&"," & _
                      "FAC_GEBRUIKER_ALG_LEVEL_WRITE="&rsVan("FAC_GEBRUIKER_ALG_LEVEL_WRITE") & _
                    whrNaar
        End If
        VB_Log(sql)
        rsNaar.Close
        cn.execute sql
    End If
    rsVan.Close
End Sub
%>
