Интересная задачка, заковыристая...

Var x,i,c,q,p:integer; s:string; max,min,k:char;
Begin
 readln(x);
 str(x,s);
 max:=s[1];
 min:=s[1];
 p:=1; q:=1;
 for i:=2 to length(s) do
   begin
    if s[i]>max then
      begin
       max:=s[i];
       q:=i;
      end;
    if s[i]      begin
       min:=s[i];
       p:=i;
      end;
   end;
 k:=s[p];
 s[p]:=s[q];
 s[q]:=k;
 val(s,x,c);
 writeln(x);
End.

Сработает для чисел любой значности.