перевод из 2-ичной в 16-ичную с.с., прога нехо работать правильно :( Опции

[MiX]

Вообщем нужна перевести из 2 в 16 с.с. из Double Word-a в Double Word.
Я вот силами несилами вот такое склеил, но она недоконца работает. Мне препод говорит что бя ввел тридцать две единицы а она непашет правильно. Помогите пожалуста, может ее можно както упростить.

Код

uses crt;
var s:string;
b,c,d,h,i,t:longint;   a:word;
n:array [1..255] of longint;
f:Boolean;
begin
  clrscr;
  writeln('vvetite chislo v formate DOUBLE WORD ');
  readln(s);
  if length(s) > 32  then
  writeln('4islo bolwe Double word')
  else
  f:=true;
  for i:=1 to length(s) do
    if (s[i]<>'1') and (s[i]<>'0') then
    begin
      clrscr;
      writeln('ERROR');
     f:=false;
     readkey;
  end;
  if f then begin
  a:=0; b:=1;
  for i:=length(s) downto 1 do
    begin
      a:=a+((ord(s[i]))-ord('0'))*b;
      b:=b*2;
    end;
   writeln('desyatkove chislo  ',a);
   write('16 chislo- ');
   if (a<=9) and (a>=1) then writeln(a) else
      case a of
      10:write('A');
      11:write('B');
      12:write('C');
      13:write('D');
      14:write('E');
      15:write('F');
      end;
   while a>=16 do
   begin
     d:=a div 16;
     h:=a mod 16;
     n[i]:=h;
     i:=i+1;
     if d<16 then
     begin
       n[i]:=d;
       i:=i+1;
       a:=d;
     end
     else
       a:=d;
        end;
        for i:=i-1 downto 1 do
        begin
          a:=n[i];
          if (a>=0)and(a<=9) then
          write(a)
          else
            begin
              case a of
              10:write('A');
              11:write('B');
              12:write('C');
              13:write('D');
              14:write('E');
              15:write('F');
             end
             end;
end;
writeln;
readln;
end;
end.