uses dvcrt, dvwin;
var arq, arqsai: text;
    s, dirDest: string;
    primeira, lidos, geradas: integer;
    quantas, serial: integer;
    nomeArqOrig, origem: string;

{--------------------------------------------------------}
{            remove acentos de uma cadeia
{--------------------------------------------------------}

function semAcentos (s: string): string;
const
    tabMaiuscPC: array [#$80..#$ff] of char = (

    'C','U','E','A','A','A','A','C','E','E','E','I','I','I','A','A',
    'E','þ','þ','O','O','O','U','U','Y','O','U','þ','þ','þ','þ','þ',
    'A','I','O','U','N','N','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ',
    'þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ',
    'A','A','A','A','A','A','‘','C','E','E','E','E','I','I','I','I',
    'þ','N','O','O','O','O','O','X','þ','U','U','U','U','Y','þ','þ',
    'A','A','A','A','A','A','‘','C','E','E','E','E','I','I','I','I',
    'þ','N','O','O','O','O','O','X','þ','U','U','U','U','Y','þ','þ');

var
    s2: string;
    i: integer;

begin
    move (s, s2, length(s)+1);
    for i := 1 to length (s2) do
        if s2[i] in ['a'..'z'] then
            s2[i] := upcase (s2[i])
        else
        if s2[i] >= #$80 then
            s2[i] := tabMaiuscPC [s2[i]];

    for i := 1 to length (s2) do
         if not (s2[i] in ['A'..'Z', '0'..'9']) then
             s2[i] := '_';

    semAcentos := s2;
end;

{--------------------------------------------------------}
{                 gera nome do arquivo
{--------------------------------------------------------}

function geraNomeArqNovo (semente, extensao: string): string;
var nome, s: string;
    arq: file;
    p, i, valor: integer;
    achou: boolean;
begin
    repeat
        p := pos (' ', semente);
        if p <> 0 then delete (semente, p, 1);
    until p = 0;
    semente := semAcentos (copy (semente, 1, 3));

    achou := false;
    repeat
        valor := serial;
        serial := serial + 1;

        str (valor, s);
        while length (s) < 5 do
            s := '0' + s;

        nome := s+semente + '.' + extensao;
        assign (arq, nome);
        writeln (nome);
        {$I-}  reset (arq);  {$I+}
        achou := ioresult = 0;
        if achou then close (arq);
    until not achou;

    geraNomeArqNovo := nome;
end;

function geraArquivo (s: string): boolean;
var
    p: integer;
    nomeSai: string;
    Nome, endereco, bairro, telefone, representante, corretor: string;

    procedure trim (var s: string);
    begin
        while (s <> '') and (s[length(s)] = ' ') do
            delete (s, length (s), 1);
    end;

begin
    geraArquivo := false;

    p := pos (^i, s);
    nome := copy (s, 1, p-1);
    delete (s, 1, p);
    trim (nome);
    if nome = '' then exit;

    p := pos (^i, s);
    endereco := copy (s, 1, p-1);
    delete (s, 1, p);
    trim (endereco);

    p := pos (^i, s);
    bairro := copy (s, 1, p-1);
    delete (s, 1, p);
    trim (bairro);

    p := pos (^i, s);
    telefone := copy (s, 1, p-1);
    delete (s, 1, p);
    trim (telefone);

    p := pos (^i, s);
    representante := copy (s, 1, p-1);
    delete (s, 1, p);
    trim (representante);

    p := pos (^i, s);
    corretor := copy (s, 1, p-1);
    delete (s, 1, p);
    trim (corretor);

    nomeSai := dirDest+ '\' + geraNomeArqNovo (nome, 'FIC');
    assign (arqsai, nomeSai);
    {$I-}  rewrite (arqSai);   {$I+}
    if ioresult <> 0 then
        begin
            sintWriteln ('Erro ao escrever no diretório destino.');
            readln;
            doneWinCrt;
        end;

    writeln (arqSai, '[Dados pessoais]');
    writeln (arqSai, 'Nome=', Nome);
    writeln (arqSai, 'Telefone=', Telefone);
    writeln (arqSai, 'Origem da listagem=', origem);
    writeln (arqSai, 'Endereço=', Endereco);
    writeln (arqSai, 'Bairro=', Bairro);
    if corretor = '' then
        writeln (arqSai, 'Quem indicou=', representante)
    else
        writeln (arqSai, 'Quem indicou=', representante + ' - ' + corretor);

    close (arqSai);

    geraArquivo := true;
end;

begin
    sintinic (2, '');
    sintWriteln ('Programa de captura de novas fichas');
    writeln;
    sintWriteln ('Qual o nome do arquivo de listagem');
    sintReadln (nomeArqOrig);
    sintWriteln ('Informe um código que represente a origem da listagem');
    sintReadln (origem);
    sintWriteln ('Número da primeira ficha');
    sintReadint (primeira);
    sintWriteln ('Quantas fichas ? ');
    sintReadint (quantas);
    sintWriteln ('Serial da primeira ficha');
    sintReadint (serial);
    sintWriteln ('Qual o diretorio de destino');
    sintReadln (dirDest);

    {$I-} mkdir (dirDest);  {$I+}
    if ioresult = 0 then
        sintWriteln ('Diretório novo foi criado');

    assign (arq, nomeArqOrig);
    {$I-}  reset (arq);  {$I+}
    if ioresult <> 0 then
        begin
            sintWriteln ('Arquivo não foi encontrado');
            readkey;
            doneWinCrt;
        end;

    while not eof (arq) and (geradas < quantas) do
        begin
            readln (arq, s);
            if s <> '' then
                begin
                    lidos := lidos + 1;
                    if lidos >= primeira then
                        begin
                            if geraArquivo (s) then
                                geradas := geradas + 1;
                        end;
                end;
        end;
    close (arq);

    sintWriteln ('ok');
    sintFim;
    doneWinCrt;
end.
