Mathematica program that generates A377193.
Michael Thomas De Vlieger, Saint Louis, Missouri, 202410192230.

Nota bene: This program employs 2 abbreviated sets to function:
  This program is calibrated for 2^14 terms.
  a. Primorials: P(k), k is set to k = 1..2^10.
     The upper limit well exceeds the anticipated requirement for 2^14 terms.
  b. regs (row n of A162306): generate all terms m <= 2^40.
     Prime powers are managed by multiplicity m rather than regs.
     We anticipate that 2^40 is sufficient to generate 2^14 terms,
     but one may increase the limit.
     The program consumes terms in row n of A162306.
  c. We have set PrimeNu[t] = 2 so that we only generate regular lineages
     R_r = { m : rad(m) | r }, since these are memory intensive.
     At some point it might be helpful to set PrimeNu[t] = 3 
     to speed the program at the expense of memory.
Program:
--------
regs[x_, y_ : 0] := 
 Block[{m, n, nn, j, k, p, s, t, v, z}, n = Abs[x]; 
  nn = If[y == 0, n, Abs[y] ]; s = Boole[x <= 0];
  If[n == 1, {1}, 
   z = Length@
     MapIndexed[Set[{p[#2], m[#2]}, {#1, s}] & @@ {#1, First[#2]} &, 
      FactorInteger[n][[All, 1]]]; k = Times @@ Array[p[#]^m[#] &, z];
    Set[{v, t}, {1, False}];
   Union@
    Reap[Do[Set[t, k > nn]; 
       If[t, k /= p[v]^(m[v] - s); m[v] = s; v++; If[v > z, Break[]], 
        v = 1; Sow[k] ]; m[v]++; k *= p[v], {i, Infinity}] ][[-1, 1]] ] ];
nn = 2^10;
c[_] := False; m[_] := 0; r[_] := {}; 
f[x_] := FactorInteger[x][[All, 1]];
MapIndexed[Set[P[First[#2] ], #1] &, 
  FoldList[Times, Prime@ Range[2^10]]];
Array[Set[{a[#], c[#]}, {#, True}] &, 2]; j = 2; u = v = 3;
Monitor[Do[
  If[Or[IntegerQ@ Log2[j], 
      And[EvenQ[j], Union@ Differences@ PrimePi[#] == {1}] ],
     k = v,
     t = P[PrimePi[#[[-1]]]]/rad[j]; 
     Which[PrimePowerQ[t], Set[p, FactorInteger[t][[1, 1]] ]; 
       While[c[p^m[p]], m[p]++]; k = p^m[p],
       PrimeNu[t] == 2, 
       If[Length@ r[t] == 0, Set[r[t], Rest@ regs[t, 2^40] ] ]; i = 1; 
       While[c[r[t][[i]]], i++]; k = r[t][[i]]; 
       r[t] = Drop[r[t], i],
       True, k = u;
       While[Or[c[k], ! CoprimeQ[j, k], f[k][[-1]] >= #[[-1]] ], 
         k++]] ] &[f[j] ];
  Set[{a[n], c[k], j}, {k, True, k}];
  If[k == u, While[c[u], u++]];
  If[k == v, While[c[v], v = NextPrime[v] ] ], {n, 3, nn}], n];
Array[a, nn]