unit MedProcLib;
   // для медучреждений
interface

uses SysUtils, SVAProcLib;

function ControlDs(d:string):boolean;
function CorrDs(var s:string):boolean;
procedure DivFIO(FIO:string; var F,I,O:string);
function Control_FIO(var s:string):boolean;
function ControlFIO(var s:string; Style:byte; Digit:boolean):boolean;
function OtToPol(s:string):string;
function ControlSNILS(var s:string):boolean;
function CheckSNILS(s:string):boolean;
function FullControlSNILS(s:string):boolean;
function ControlINN(s:string):boolean;

implementation

   { ----- Контроль (строгий) кода диагноза ----- }

function ControlDs(d:string):boolean;
var j:integer;
begin
  Result:= false;
  if d = '' then exit;
  if not (d[1] in ['A'..'Z']) then exit;
  j:= 2;
  if d[2] = ' ' then j:= 3; // отс. нач-ся 1-я пара цифр
  try
    StrToInt(Copy(d,j,2));  // 1-я пара цифр
  except
    exit
  end;
  if length(d) = j+1 then begin
    Result:= true; exit
  end;
  if d[j+2] <> '.' then exit;
  inc(j,3);
  if length(d) < j then begin
    Result:= true; exit
  end;
  try
    StrToInt(Copy(d, j, length(d)+1-j));  // второе число
    Result:= true;
  except
  end;
end;

   { --- Контроль и авто-корректировка КОДА ДИАГНОЗА --- }

function CorrDs(var s:string):boolean;
var d: string[7];
begin
  Result:= false;  // автокорректировке не поддается
  if s = '' then exit;
  d:= AnsiUpperCase(s);
  if not (d[1] in ['A'..'Z','А','В','Е','К','М','Н','О','Р','С','Т','У','Х'])
    then exit;  { - совсем некорректные буквы }
  if not(d[1] in ['A'..'Z']) then
    { рус --> lat }
    case  d[1] of
      'А': d[1]:='A';
      'В': d[1]:='B';
      'Е': d[1]:='E';
      'К': d[1]:='K';
      'М': d[1]:='M';
      'Н': d[1]:='H';
      'О': d[1]:='O';
      'Р': d[1]:='P';
      'С': d[1]:='C';
      'Т': d[1]:='T';
      'У': d[1]:='Y';
      'Х': d[1]:='X';
    end;
  s[1]:= d[1];  { - с буквой разобрались }
  if length(s) = 1 then exit;
  if s[2] = ' ' then
    delete(s,2,1);  { - убрали необязательный пробел }
  if length(s) = 2 then insert('0',s,2);
  if not ControlNumber(Copy(s,2,2), 2) then exit;
  if length(s)= 3 then begin
    Result:= true;
    exit;  { A99 }
  end;
  if s[4] <> '.' then
    if (s[4] in ['0'..'9']) then exit
    else s[4]:= '.';
  if length(s) = 4 then begin
    SetLength(s,3);
    Result:= true;
    exit { A99.-> A99 - точку удаляем ! }
  end;
  if length(s) > 6 then exit;
  if length(s) > 4 then
    if not ControlNumber(Copy(s,5,2), 0) then exit;
  Result:= true  // автокорректировка удалась
end; { CorrDs }

   { ------ Извлечение Ф. И. О. из строки FIO ------ }
   // для простого случая - когда фамилия (имя) без пробелов внутри
procedure DivFIO(FIO:string; var F,I,O:string);
var s: string; k,p: integer;
begin
  F:= ''; I:= ''; O:= '';
  s:= Trim(FIO);
  Del2Space(s);
    // поверим, чтобы после точки был пробел (или вставим его)
  k:= pos('.', s);
  while (k > 0) and (k < length(s)) do begin
    p:= k+1;
    if not(s[p] in [' ', '-']) then insert(' ', s, p);
    k:= Find('.', s, p);
  end;
  k:= pos(' ', s);
  if k > 0 then begin
    F:= Copy(s, 1, k-1);
    delete(s,1,k);
    k:= pos(' ', s);
    if k > 0 then begin
      I:= Copy(s, 1, k-1);
      delete(s,1,k);
      O:= s
    end
    else I:= s;
  end
  else F:= s
end;

   { ---- Ищем 1-й из 3-х символов в строке ---- }

function Pos3(c1,c2,c3:char; s:string; var c:char):integer; // local
var k1, k2, k3: integer;
begin
  Result:= 0;
  k1:= pos(c1, s);
  k2:= pos(c2, s);
  k3:= pos(c3, s);
  if (k1 = 0) and (k2 = 0) and (k3 = 0) then exit;
  if (k1 > 0) and (k2 = 0) and (k3 = 0) then Result:= k1
  else if (k1 = 0) and (k2 > 0) and (k3 = 0) then Result:= k2
  else if (k1 = 0) and (k2 = 0) and (k3 > 0) then Result:= k3
  else if k1 = 0 then Result:= Min2(k2, k3)
  else if k2 = 0 then Result:= Min2(k1, k3)
  else if k3 = 0 then Result:= Min2(k1, k2)
  else Result:= Min2(Min2(k1,k2), k3);
  if Result = k1 then c:= c1
  else if Result = k2 then c:= c2
  else if Result = k3 then c:= c3
end;

   { ---- Ищем 1-й из 2-х символов в строке ---- }

function Pos2(c1,c2:char; s:string; var c:char):integer; // local
var k1, k2: integer;
begin
  Result:= 0;
  k1:= pos(c1, s);
  k2:= pos(c2, s);
  if (k1 = 0) and (k2 = 0) then exit;
  if (k1 > 0) and (k2 = 0) then Result:= k1
  else if (k1 = 0) and (k2 > 0) then Result:= k2
  else Result:= Min2(k1, k2);
  if Result = k1 then c:= c1
  else if Result = k2 then c:= c2
end;

     { =======  Контроль Ф.И.О.  ======== }

function Control_FIO(var s:string):boolean;
 // допускаются внутри "-" и " " (пробел)
var
  ff,f,st: string; k: integer; c: char;

  function f1(var f:string):boolean; // одиночное имя
  var
    i: integer; a: string;
  begin
    if f = '' then begin
      Result:= true;  exit
    end;
    Result:= false;
    a:= AnsiUpperCase(f);
    for i:= 1 to length(a) do
      if not(a[i] in ['А'..'Я','Ё']) then exit;
    f:= AnsiLowerCase(f);
    f[1]:= a[1];
    if f[1] = ' ' then f[2]:= a[2];
    Result:= true;
  end;

begin { ControlFIO }

  Result:= false;
  s:= Trim(s);
  if s = '' then begin
    Result:= true; exit;  // пустое не проверяем
  end;
  Del2Space(s);
  Del2Minus(s);
     // ' - ', '- ', ' -'  => '-'
  while pos(' -', s) > 0 do delete(s, pos(' -',s), 1);
  while pos('- ', s) > 0 do delete(s, pos('- ',s) + 1, 1);
  f:= s;  // рабочая (изменяемая часть)
  ff:= '';  // готовая часть (в конце ff => s )
  k:= pos2('-', ' ', f, c);
  try
    while k > 0 do begin
      st:= Copy(f, 1, k-1);
      if not f1(st) then exit; // часть имени до "-"
      if ff = '' then ff:= st + c  // это первая часть имени
      else ff:= ff + st + c;
      delete(f,1,k);      // удаляем проверенную часть
      k:= pos2('-', ' ', f, c);
    end;
    if not f1(f) then exit;
    if ff = '' then ff:= f  // было одиночное имя
    else ff:= ff + f;
    k:= pos('-Оглы', ff);  if k > 0 then ff[k+1]:='о';
    k:= pos('-Кызы', ff);  if k > 0 then ff[k+1]:='к';
  except
    exit;
  end;
  s:= ff;
  Result:=true
end;

     { -------  Контроль Ф.И.О.  -------- }

        // к "-" добавлено ".", " ", "'"
function ControlFIO(var s:string; Style:byte; Digit:boolean):boolean;
  // Style: 0 - удобные (Фам Имя Отч), 1 - Прописные, 2 - Не изменять
  // если Digit=true - разрешается использовать цифры
var ff,f,st: string; k: integer; c:char;

  function f1(var f:string):boolean; // одиночное имя
  var
    i: integer; a,b: string;
    GoodChar: set of char;
  begin
    if f = '' then begin
      Result:= true;  exit
    end;
    Result:= false;
    b:= f;
    a:= AnsiUpperCase(f);
    GoodChar:= [#39,'А'..'Я','Ё'];
    if Digit then GoodChar:= GoodChar + ['0'..'9'];
    for i:= 1 to length(a) do
      if not(a[i] in GoodChar) then exit;
    Result:= true;
    if Style = 2 then exit;  // ничего не измен. - только провер.
    if Style = 1 then begin
      f:= a; exit   // все буквы прописные
    end;
    f:= AnsiLowerCase(f);
    f[1]:= a[1];
    if f[1] = ' ' then f[2]:= a[2];
    i:= pos(#39, a);
    if (i > 0) and (i < length(f)) then begin
      if f[i+1] <> #39 then f[i+1]:= b[i+1]
      else if i+2 <= length(f) then f[i+2]:= b[i+2];
    end;
    if i > 1 then f[i-1]:= b[i-1];
    Result:= true;
  end;

begin
  Result:= false;
  s:= Trim(s);
  if s = '' then begin
    Result:= true; exit;  // пустое не проверяем
  end;
  Del2Space(s);
  Del2Minus(s);
     // ' - ', '- ', ' -'  => '-'
  while pos(' -', s) > 0 do delete(s, pos(' -',s), 1);
  while pos('- ', s) > 0 do delete(s, pos('- ',s) + 1, 1);
  while pos(' .', s) > 0 do delete(s, pos(' .',s), 1);
  k:= pos(' '' ', s);   // O ' Hen => O'Hen
  while k > 0 do begin
    delete(s, k, 1);
    delete(s, k+1, 1);
    k:= pos(' '' ', s);
  end;
  f:= s;  // рабочая (изменяемая часть)
  ff:= '';  // готовая часть (в конце ff => s )
  if Digit then k:= pos3('-', '.', ' ', f, c)  // там где цифры, там и точка
  else k:= pos2('-', ' ', f, c);
  try
    while k > 0 do begin
      st:= Copy(f, 1, k-1);
      if not f1(st) then exit; // часть имени до "-"
      if ff = '' then ff:= st + c  // это первая часть имени
      else ff:= ff + st + c;
      delete(f,1,k);      // удаляем проверенную часть
      if Digit then k:= pos3('-', '.', ' ', f, c)
      else k:= pos2('-', ' ', f, c);
    end;
    if not f1(f) then exit;
    if ff = '' then ff:= f  // было одиночное имя
    else ff:= ff + f;
    if Style = 0 then begin
      k:= pos('-Оглы', ff);  if k > 0 then ff[k+1]:='о';
      k:= pos('-Кызы', ff);  if k > 0 then ff[k+1]:='к';
    end;
  except
    exit;
  end;
  s:= ff;
  Result:=true
end;

   { --- По отчеству определить пол --- }

function OtToPol(s:string):string;
var so: string;
begin
  Result:= '';
  if length(s) < 3 then exit;
  so:= Copy(s, length(s)-1, 2);
  if (so = 'ич') or (so = 'лы') then Result:='М'
  else begin
    so:= Copy(s, length(s)-2, 3);
    if (so = 'вна') or (so = 'чна') or (so = 'ызы') then Result:='Ж';
  end
end;

     { =======  Контроль формата СНИЛСа  ======== }

function ControlSNILS(var s:string):boolean;
var i:integer;
begin
  Result:= false;
  if length(s) <> 14 then exit;
  for i:= 1 to 14 do
    case i of
        4,8: if s[i] in ['0'..'9'] then exit
             else s[i]:= '-';
         12: if s[i] in ['0'..'9'] then exit
             else s[i]:= ' ';
       else  if not(s[i] in ['0'..'9']) then exit;
    end; { case }
  Result:= true;
end;

     { =======  Контроль кода СНИЛСа  ======== }
               { после ControlSNILS }
function CheckSNILS(s:string):boolean;
var i,sum:integer; sNum: string;
begin
  sNum:= Copy(s,1,11); Delete(sNum,8,1); Delete(sNum,4,1);
  sum:= 0;
  for i:= 1 to 9 do
    sum:= sum + (ord(sNum[i]) - 48) * (10 - i);
  Result:= (sum mod 101) mod 100 = StrToInt(Copy(s,13,2));
end;

     { =======  Полный контроль СНИЛСа  ======== }

function FullControlSNILS(s:string):boolean;
begin
  Result:= false;
  if ControlSNILS(s) then
    Result:= CheckSNILS(s)
end;

     { =======  Контроль ИНН  ======== }

function ControlINN(s:string):boolean;
begin
  if not(length(s) in [10,12]) then Result:=false
  else Result:= ControlNumber(s, length(s))
end;

end.