(* Mathematica program for OEIS sequence A088628, Ray Chandler 4/8/2014 *)
nmax = 40;
a = {11, 127};
ds = {1, 2};
sumd = 3;
Do[
  id = IntegerDigits[n];
  ds = Join[ds, id];
  sumd += Total[id];
  wds = Rest[ds]; (* drop initial 1 *)
  If[Mod[sumd, 3] == 0, AppendTo[wds, 1]];
  wds = Prepend[Sort[wds], 1]; (* restore initial 1 *)
  il = Length[wds];
  found = 0;
  k = Count[wds, Last[wds]] + 1;
  While[
   pre = Take[wds, il - k];
   post = Take[wds, -k];
   ps = Permutations[post];
   Do[ 
    c = FromDigits[Join[pre, p]];
    If[PrimeQ[c], found = 1; Break[]];
    , {p, ps}];
   If[found == 1, AppendTo[a, c]];
   found == 0,
   k++;
   ];
   , {n, 3, nmax}];
a