{ File: Lb:[22,311]SENDER.PAS       Last Edit: 20-OCT-1989 03:45:16 
}

PROGRAM SENDER;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Test program for MSGPACKET.TYP, MSGPACKET.PAS (CPITAS,CPSTAS,SNDMSG,RCVMSG).
  This program also doubles as a send/receive tool for sending and 
  receiving message packets. 

 History:

    20-OCT-1989 Jim Bostwick. 	Major hack for Message_rec integrated network
    				messages. INCOMPATIBLE with previous versions!
    03-Feb-89.  Philip Hannay.  Created.
    18-Mar-89.  Philip Hannay.  Updated for packet sub types    
    22-Mar-89.  Bob Thomas.     Added the "Report status" device
    04-Apr-89.  Bob Thomas.     Modified in keeping with modifications to 
			        the msgpackets.
    07-Apr-89.  Bob Thomas.     Altered the form of the program and added <25> 
				style of specifying characters to Pk_info_short.
    31-May-89.  Bob Thomas.	Added send half of Pk_synch and stubbed
				Pk_field_value.
    19-Jun-89.  Philip Hannay.  Miscellaneous modifications to accomodate
                                changes to MSGPACKET.TYP.  Includes addition
                                of PK_RECORD type, and some name changes.
     8-Aug-89.  Philip Hannay.  Fleshed out PK_BIN, add PK_CONTROL_NUMERIC
                                and PK_CONTROL_ALPHA, replacing 
                                PK_CONTROL_SHORT and PK_CONTROL_LONG.
                                Added changes for PK_SCALE and PK_RECORD.
    15-SEP-89.  Tom Trulson.    Extended Pk_comment input from 80 characters
                                to 199 characters.


~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
%include pas$ext:General.typ;
%include pas$ext:string.pkg;
%INCLUDE 'pas$ext:message.pkg';
%include pas$ext:castin.ext;
%include pas$ext:cpitas.ext;
%include pas$ext:cpstas.ext;

Var

  alpha_id: ch20;
  alpha_sub: ch20;
  escape:boolean;
  exit_requested: boolean;
  long_alpha_sub: ch80;
  med_alpha_sub: ch50;
  in_msg, out_msg: message_rec;  
  stat: integer;
  comman, old_comman, task_name, old_task_name: ch6;
  to_node, to_task: ch6;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
 PROCEDURE SCOMPARE(t:Ch20; s:Ch20; var result:Boolean);

  { Compare the source string (S) to the target string (T).  If
    S is a truncation of T, then return RESULT true. }

var
  i: integer;

begin
{ convert both strings to uppercase to make our compare case independent }
supper(t);
supper(s);
i:= 0;
result:= true;
repeat
  i:= i+1;
  if (s[i]<>chr(0)) and (s[i]<>t[i]) then result:= false;
until (result=false) or (s[i]=chr(0)) or (i=20);
end;


{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
 PROCEDURE GET_ANY_MESSAGES;

  { read and display any outstanding messages }

var
  i, len: integer;
  recv_task_name: ch6;
  

{~~~~~~~~~}
 PROCEDURE DISPLAY_MESSAGE;	{Local}

var
  i: integer;

Begin
with in_msg do
begin
case id of
  pk_misc:
    begin
    writeln('  Value is "',value,'"');
    end;
  pk_debug:
    begin
    writeln('  Debug level is "',deb_level,'" on device "',deb_device,'"');
    end;
  pk_monitor:
    begin
    writeln('  Monitor level is "',mon_level,'" on device "',mon_device,'"');
    end;
  pk_view:
    begin
    writeln('  View level is "',view_level,'" on device "',view_device,'"');
    end;
  pk_info_short:
    begin
    writeln('  Short info msg is "',sinfo,'"');
    end;
  pk_info_long:
    begin
    write('  Long info msg is "');
    swrite(output,linfo);
    writeln('"');
    end;
  pk_check_config:
    begin
    writeln('  Config file is "',config_file,'"');
    end;
  pk_orderly_abort:
    begin
    end;
  pk_wake_up_sender:
    begin
    end;
  pk_send_as_is:
    begin
    write('  Content is "');
    swrite(output,content);
    writeln('"');
    end;
  pk_ACKed_transaction:         {ack from device}
    begin
    write('  First part of transaction was "');
    swrite(output,ACK_content);
    writeln('"');
    end;  
  pk_NAKed_transaction:         {nak from device}
    begin
    write('  First part of transaction was "');
    swrite(output,NAK_content);
    writeln('"');
    end;
  pk_resource:
    begin
    writeln('  Resource name is "',resource_name,'" and owner is "',
      resource_owner,'"');
    end;
  pk_identity:
    begin
    writeln('  Identity is "',ident,'"');
    end;
  pk_gate:
    begin
    writeln('  Gate name is "',gate_name,'", status word is ',
      gate_status:-6,' octal,');
    writeln('  Requested gate opening is ',gate_set:1,
      '%, current gate opening is ',gate_current:1,'%,');
    writeln('  Maximum gate open allowed except shakeout is ',gate_max:1,
      '%, shakeout opening is ',gate_shake:1,'%');
    end;
  pk_report_status:
    begin
    writeln('  Report status to device "',device_stat,'"');
    end;
  pk_synch:
    begin
    writeln('  Synchronization text is "',synch_text,'" and number is ',
      synch_num:1);
    end;
  pk_scale:
    begin
    writeln('  Scale order type is "',scale_order_type,'",');
    writeln('  header 1 is "',scale_header1,'",');
    writeln('  header 2 is "',scale_header2,'",');
    writeln('  product is "',scale_product,'", order size is "',
         scale_order_size,'", draft_size is "',scale_draft_size,
         '" and gate open is "',scale_gate_open,'"');
    end;
  pk_control_symbol:
    begin
    writeln('  Symbol type is ',symbol_type:1,', symbol name is "',
      symbol_name,'",');
    writeln('  symbol data base is ',symbol_DB:1,', symbol offset is ',
      symbol_offset:1);
    end;
  pk_control_alpha:
    begin
    writeln('  Symbol type is ',alpha_type:1,', symbol data base is ',
      alpha_DB:1,', symbol offset is ',alpha_offset:1,',');
    writeln('  alpha length is ',ord(alpha_value[0]):1,',');
    write('  alpha value is "');
    swrite(output,alpha_value);
    writeln('"');
    writeln;
    end;
  pk_control_numeric:
    begin
    writeln('  Symbol type is ',numeric_type:1,', symbol data base is ',
      numeric_DB:1,', symbol offset is ',numeric_offset:1,',');
    writeln('  numeric value byte count is ',numeric_len:1,',');
    writeln('  numeric value (as decimal integers) is ');
    i:= 1;
    while (i <= numeric_len) do
      begin
      if (i mod 8 = 0)
        then writeln(numeric_value[i]:8)
        else write(numeric_value[i]:8,',');
      i:= i + 1;
      end;
    if ((i-1) mod 8 <> 0) then writeln;
    writeln;
    end;
  pk_bin:
    begin
    writeln('  Bin name is "',bin_name,'", status word is ',
      bin_status:-6,' octal,');
    writeln('  bin level is ',bin_level:1,
      'ft, out of max height of ',bin_height:1,'ft,');
    writeln('  bin CGRADE is "',bin_cgrade,'", GRADE is "',bin_grade,
      '" and SUBGRADE is "',bin_sgrade,'"');
    end;
  pk_field_value:
    begin
    writeln('  Field name is "',field_name,'"');
    writeln('  field status is ',field_status:1,' and terminator is ',
      field_term:1);
    write(' field value is "');
    swrite(output,field_value);
    writeln('"');
    writeln;
    end;
  pk_record:
    begin
    writeln('  Record length (2byte words) is ',record_len:1);
    writeln('  and record value (in decimal words) is');
    i:= 1;
    while i <= record_len do
      begin
      if (i mod 8) = 0 
        then writeln(record_value[i]:7)
        else write(record_value[i]:7,',');
      i:= i+1;
      end;
    if ((i-1) mod 8 <> 0) then writeln;
    writeln;
    end;
  pk_reserved9:
    begin
    end;
  pk_reserved10:
    begin
    end;
  pk_reserved11:
    begin
    end;
  pk_reserved12:
    begin
    end;
  pk_reserved13:
    begin
    end;
  pk_reserved14:
    begin
    end;
  pk_reserved15:
    begin
    end;
  pk_reserved16:
    begin
    end;
  pk_reserved17:
    begin
    end;
  pk_reserved18:
    begin
    end;
  pk_reserved19:
    begin
    end;
  pk_reserved20:
    begin
    end;
  pk_reserved21:
    begin
    end;
  pk_reserved22:
    begin
    end;
  pk_reserved23:
    begin
    end;
  pk_comment:
    begin
    write('  Comment text is "');
    swrite(output,comment);
    writeln('"');
    end;
  otherwise
    begin
    { nothing else to write }
    end
  end; {case}
  end; {with}
end; {local procedure display_message}


{~~~~~~~~~}

Begin  { procedure get_any_messages }
writeln;
msrcv(null_task_name,in_msg);
stat := $dsw;
if stat=-8 
  then begin
    { no messages }
    writeln('  no messages outstanding');
    end
  else begin
    if stat < 3
      then begin
        { Some directive error (negative), bad processing (0), or 
          incomplete task name (1) or zero length message (2).  Anything
          3 or above is normal }
        writeln('  bad receive of message, stat = ',stat:1);
        end
      else begin
       { Message in - show it. }
        len:= (stat*2)-4;  { LEN is message text length in bytes }
        cpitas(in_msg.id,alpha_id);
        supper(alpha_id);
        swrite(output,alpha_id);
        writeln(' message received, with status =',stat,'.');
        Dmphdr(output,in_msg);
        cpstas(in_msg.sub,long_alpha_sub);
        write('  sub type set is [');
        swrite(output,long_alpha_sub);
        writeln('].');
        if in_msg.id in [pk_misc..pk_comment]
          then begin
            { AMI general messages, display the contents }
            display_message;
            end
          else begin
            { site specific message, contents without interpretation }
            writeln('  site specific message - possible contents are "',
              in_msg.value,'"');
            end;
        writeln;
        end;
    end;
end;  { procedure get_any_messages }


{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
 PROCEDURE GET_ID_SELECTION(var bailout:Boolean);

  { Prompt the operator for a message packet id selection.  Provide
    help if requested.  Set BAILOUT boolean true if operator indicates
    a desire to leave without sending a message, otherwise set false.}

Var
  resp: ch20;
  match_found: boolean;


{~~~~~~~~~}
 PROCEDURE LIST_ID_NAMES;	{Local}

Var
  id: message_packet_id_type;
  short_alpha_id: ch18;
  column: integer;

begin
{ show packet list }
column:= 1;
for id:= pk_misc to pk_unknown do
  begin
  cpitas(id,short_alpha_id);
  spad(short_alpha_id,chr(0),' ');
  write('  (',ord(id):2,') ',short_alpha_id);
  if column<3
    then begin
      column:= column+1;
      end
    else begin
      writeln;
      column:= 1;
      end;
  end;
if column <> 1 then writeln;
end;   { procedure list_id_names }


{~~~~~~~~~}
 PROCEDURE MATCH_IDNUM;	{Local}

  { convert operator supplied number to an integer, and try to map it
    to a packet id type.  If found, set MATCH_FOUND true. }

var
  id: message_packet_id_type;
  pos, point: integer;
 
Begin
pos:= 1; { start conversion at beginning of string }
castin(resp,point,pos);
if (pos>1) and (pos<=4)
  then begin
    { one to three digits - could be 0 thru 255, okay so far }
    if (point>=0) and (point<=ord(pk_unknown))
      then begin
        { falls within pk_misc thru pk_unknown range, so now
          map it to an id }
        for id:= pk_misc to pk_unknown do
          begin
          if point=ord(id)
            then begin
            out_msg.id:= id;
            match_found:= true
            end;
          end; {for}
        end;
    end;
end;  { procedure match_idnum }


{~~~~~~~~~}
 PROCEDURE MATCH_ID;	{Local}

  { Compare operator entry with possible names.  If more than one 
    match found, indicate that it is not unique, and show the choices.
    If one match found, set MATCH_FOUND true and go with it. }

var
  compare_result: boolean;
  match_count: integer;
  id, last_match: message_packet_id_type;

Begin
match_count:= 0;
for id:= pk_misc to pk_unknown do
  begin
  if not(match_found)
    then begin
      cpitas(id,alpha_id);
      scompare(alpha_id,resp,compare_result);
      if compare_result = true
        then begin
          supper(alpha_id);
          supper(resp);
          if sequal(alpha_id,resp) then match_found:= true;
          match_count:= match_count+1;
          last_match:= id;
          end;
      end;
  end;
if match_count = 1
  then begin
    { unique match }
    out_msg.id:= last_match;
    match_found:= true;
    end
  else begin
    if match_count = 0
      then begin
        { no match found }
        writeln('    No match found, try again');
        end
      else begin
        { multiple matches found, list them }
        writeln('    Multiple matches found, try again.  Match list is...');
        for id:= pk_misc to pk_unknown do
          begin
          cpitas(id,alpha_id);
          scompare(alpha_id,resp,compare_result);
          if compare_result = true then writeln('      ',alpha_id);
          end;
        end;
    end;
end;   { procedure match_id }


{~~~~~~~~~}

Begin	{Get_id_selection}
match_found:= false;
bailout:= false;
repeat
  write('  Enter packet type to send (? for list, blank to quit)> ');
  sread(input,resp);
  if (resp[1] = '?') 
    then begin
      { help the user }
      list_id_names;
      end
    else begin
      { see if user wants to escape }
      if (resp[1] = ' ') or (resp[1] = chr(0))
        then begin
          bailout:= true;
          end
        else begin
          { see if its an ordinal number }
          if (resp[1]>='0') and (resp[1]<='9')
            then begin
              { it must be an ordinal value, covert to numeric and find
                it. }
              match_idnum;
              end
            else begin
              {must be alpha, see if we can find a match }
              match_id;
              end;
          end;
      end;
  until (match_found) or (bailout);
end;  { procedure get_id_selection }



{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
 PROCEDURE GET_SUB_SELECTION;

  { Prompt the operator for a message packet sub selection.  Provide
    help if requested. }

Var
  resp: ch20;
  sub_done, match_found: boolean;

{~~~~~~~~~}
 PROCEDURE LIST_SUB_NAMES;	{Local}

Var
  sub: message_packet_sub_type;
  subset: message_packet_sub_set;
  short_alpha_sub: ch18;
  column: integer;

begin      { show sub list }
column:= 1;
for sub:= ps_ack to ps_reserved11 do
  begin
  subset:= [sub];
  cpstas(subset,short_alpha_sub);
  spad(short_alpha_sub,chr(0),' ');
  write('  (',ord(sub):2,') ',short_alpha_sub);
  if column<3
    then begin
      column:= column+1;
      end
    else begin
      writeln;
      column:= 1;
      end;
  end;
if column <> 1 then writeln;
end;   { procedure list_sub_names }


{~~~~~~~~~}
 PROCEDURE MATCH_SUBNUM;	{Local}

  { convert operator supplied number to an integer, and try to map it
    to a packet sub type.  If found, set MATCH_FOUND true. }

var
  sub: message_packet_sub_type;
  pos, point: integer;
 
Begin
pos:= 1; { start conversion at beginning of string }
castin(resp,point,pos);
if (pos>1) and (pos<=4)
  then begin
    { one to three digits - could be 0 thru 255, okay so far }
    if (point>=0) and (point<=ord(ps_reserved11))
      then begin
        { falls within ps_ack thru ps_reserved11 range, so now
          map it to an sub }
        for sub:= ps_ack to ps_reserved11 do
          begin
          if point=ord(sub)
            then begin
            out_msg.sub:= out_msg.sub + [sub];
            match_found:= true
            end;
          end; {for}
        end;
    end;
end;  { procedure match_subnum }


{~~~~~~~~~}
 PROCEDURE MATCH_SUB;

  { Compare operator entry with possible names.  If more than one 
    match found, indicate that it is not unique, and show the choices.
    If one match found, set MATCH_FOUND true and go with it. }

var
  compare_result: boolean;
  match_count: integer;
  sub, last_match: message_packet_sub_type;
  subset: message_packet_sub_set;

Begin
match_count:= 0;
for sub:= ps_ack to ps_reserved11 do
  begin
  if not(match_found)
    then begin
      subset:= [sub];
      cpstas(subset,alpha_sub);
      scompare(alpha_sub,resp,compare_result);
      if compare_result = true
        then begin
          supper(alpha_sub);
          supper(resp);
          if sequal(alpha_sub,resp) then match_found:= true;
          match_count:= match_count+1;
          last_match:= sub;
          end;
      end;
  end;
if match_count = 1
  then begin
    { unique match }
    out_msg.sub:= out_msg.sub + [last_match];
    match_found:= true;
    end
  else begin
    if match_count = 0
      then begin
        { no match found }
        writeln('    No match found, try again');
        end
      else begin
        { multiple matches found, list them }
        writeln('    Multiple matches found, try again.  Match list is...');
        for sub:= ps_ack to ps_reserved11 do
          begin
          subset:= [sub];
          cpstas(subset,alpha_sub);
          scompare(alpha_sub,resp,compare_result);
          if compare_result = true then writeln('      ',alpha_sub);
          end;
        end;
    end;
end;   { procedure match_sub }

{~~~~~~~~~}

Begin	{Get_sub_selection}
sub_done:= false;
out_msg.sub:= [];
repeat
match_found:= false;
repeat
  cpstas(out_msg.sub,med_alpha_sub);
  write('    your sub type set is [');
  swrite(output,med_alpha_sub);
  writeln(']');
  write('  Enter a packet sub type to send or <CR> (type ? for list)> ');
  sread(input,resp);
  if slen(resp) <= 0
    then begin
      { blank entry - no more entries }
      match_found:= true;
      sub_done:= true;
      end
    else begin
      { non blank response, entering a sub type }
      if resp[1] = '?'
        then begin
          { help the user }
          list_sub_names;
          end
        else begin
          { see if its an ordinal number }
          if (resp[1]>='0') and (resp[1]<='9')
            then begin
              { it must be an ordinal value, covert to numeric and find
                it. }
              match_subnum;
              end
            else begin
              { must be alpha - see if we can find a match }
              match_sub;
              end;
          end;
      end;
until match_found;
until sub_done;
end;  { procedure get_sub_selection }


{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
 PROCEDURE GET_MSG_CONTENTS;

  { get any message fields needed as dictated by MSG.ID }

var
  hold70: ch70;
  resp: char;
  i, int: integer;
  holdbuff: packed array [1..100] of char;
  Done:boolean;
  err:boolean;
  info:Ch20;

{~~~~~~~~~}
 PROCEDURE TRANSLATE_CONTENTS_INTO_ASCII;	{Local}

var
   i:integer;
   h:integer;
   n:integer;
   pos:integer; 
   asc_num:ch3;
   num:integer;
 
Begin
Sclear(info);
err := False;
i := 1;
h := 1;
n := 1;
Done := true;
While h <= Slen(holdbuff) do
   Begin
   If Holdbuff[h] <> '<' 
     then 
       Begin
       Info[i] := Holdbuff[h];
       h := h + 1;
       i := i + 1;
       end
     Else    {holdbuff[h] = '<'}
       Begin
       Done := False;
       n := 1;
       If Holdbuff[h+1] = '<'
         then
           Begin    
           Info[i] := Holdbuff[h];
           h := h + 2;
           i := i + 1;
           end
         Else
          If holdbuff[h+1] = '>' 
            then
	      Begin
              Info[i] := Chr(0);
              i := i + 1;
              h := h + 2;
	      Done := true;	
              End
            Else
              Begin
	      Sclear(ASC_num);
	      n := 0;
	      While (n <= 3)and(holdbuff[h+n+1] <> '>') do
                Begin
	        n := n + 1;
 	        If holdbuff[h+n] <> '>' then ASC_num[n] := Holdbuff[h+n];
	        End;
	        If holdbuff[h+n+1] = '>' 
	          then 
 		    Begin
		    Pos := 1;
		    Castin(Asc_num,num,pos);
		    info[i] := Chr(num);
		    h := h + n + 2;
		    i := i + 1;
		    Done := true;	
                    End;
	      End;
       End;
   End;
err := Not done;

End;

{~~~~~~~~~}
Begin  {Get_msg_contents}
with out_msg do begin
case id of
  pk_misc:
    begin
    write('  Enter value> ');
    sread(input,value);
    end;
  pk_debug:
    begin
    repeat
      write('  Enter debug level (0-9)> ');
      readln(deb_level);
    until deb_level in ['0'..'9'];
    write('  Enter debug device name> ');
    sread(input,deb_device);
    end;
  pk_monitor:
    begin
    repeat
      write('  Enter monitor level (0-9)> ');
      readln(mon_level);
    until mon_level in ['0'..'9'];
    write('  Enter monitor device name> ');
    sread(input,mon_device);
    end;
  pk_view:
    begin
    repeat
      write('  Enter view level (0-9)> ');
      readln(view_level);
    until view_level in ['0'..'9'];
    write('  Enter view device name> ');
    sread(input,view_device);
    end;
  pk_info_short:
    begin
    repeat
      begin
      writeln(' You may enter a char or its decimal ordinal number in arrows');
      writeln(' so "A" and <65> are equivalent. To enter "<" double it "<<".');
      writeln(' Also note that a final null <0> will be ignored. ');
      writeln(' Enter short info text (up to 20 chars):');
      writeln(' ');
      sread(input,holdbuff);
      translate_contents_into_ASCII;
      Sassign(Sinfo,Info);
      If err then writeln('TEXT IN INVALID FORM'); 
      End;
    until not err;
    end;
  pk_info_long:
    begin
    writeln('  Enter long info text (up to 199 chars)> ');
    writeln('        ',
'         1         2         3         4         5         6         7');
    writeln('        ',
'1234567890123456789012345678901234567890123456789012345678901234567890');
    write('   1-70>');
    sread(input,hold70);
    sassign(linfo,hold70);
    writeln('        ',
'         8         9         0         1         2         3         4');
    writeln('        ',
'1234567890123456789012345678901234567890123456789012345678901234567890');
    write(' 71-140>');
    sread(input,hold70);
    sconcat(linfo,hold70);
    writeln('        ',
'         5         6         7         8         9         ');
    writeln('        ',
'12345678901234567890123456789012345678901234567890123456789');
    write('141-199>');
    sread(input,hold70);
    sconcat(linfo,hold70);
    end;
  pk_check_config:
    begin
    write('  Enter config file name> ');
    readln(config_file);
    end;
  pk_orderly_abort:
    begin
    { nothing else needed }
    end;
  pk_wake_up_sender:
    begin
    { nothing else needed }
    end;
  pk_send_as_is:
    begin
    write('  Enter content to be sent> ');
    sread(input,content);
    end;
  pk_ACKed_transaction:
    begin
    write('  Enter transaction that was acked> ');
    sread(input,ACK_content);
    end;
  pk_NAKed_transaction:
    begin
    write('  Enter transaction that was nakked> ');
    sread(input,NAK_content);
    end;
  pk_resource:
    begin
    write('  Enter resource name> ');
    readln(resource_name);
    write('  Enter resource owner> ');
    readln(resource_owner);
    write('  Enter resource detail> ');
    readln(resource_detail);
    end;
  pk_identity:
    begin
    write('  Enter identity string');
    readln(ident);
    end;
  pk_gate:
    begin
    write('  Enter gate name (1-6 char)> ');
    readln(gate_name);
    write('  Enter gate status (16 bit word)> ');
    readln(gate_status);
    write('  Enter gate requested set> ');
    readln(gate_set);
    write('  Enter gate current set> ');
    readln(gate_current);
    write('  Enter gate max set> ');
    readln(gate_max);
    write('  Enter gate shakeout set> ');
    readln(gate_shake);
    end;
  pk_report_status:
    begin
    write('  Enter status report device name> ');
    sread(input,Device_stat);
    end;
  pk_synch:
    begin
    write('  Enter synch text> ');
    readln(synch_text);
    write('  Enter synch number> ');
    readln(synch_num);
    end;
  pk_scale:
    begin
    write('  Enter order type (R,S)> ');
    readln(scale_order_type);
    write('  Enter header 1 text> ');
    readln(scale_header1);
    write('  Enter header 2 text> ');
    readln(scale_header2);
    write('  Enter product name> ');
    readln(scale_product);
    write('  Enter order size> ');
    readln(scale_order_size);
    write('  Enter draft size> ');
    readln(scale_draft_size);
    write('  Enter gate opening> ');
    readln(scale_gate_open);
    end;
  pk_control_symbol:
    begin
    write('  Enter symbol type (128-float,64-bit,32-num,20-str)> ');
    readln(symbol_type);
    write('  Enter symbol name> ');
    readln(symbol_name);
    write('  Enter symbol Database (DB)> ');
    readln(symbol_DB);
    write('  Enter symbol offset (decimal)> ');
    readln(symbol_offset);
    end;
  pk_control_alpha:
    begin
    write('  Enter value type (128-float,64-bit,32-num,20-str)> ');
    readln(alpha_type);
    write('  Enter value Database (DB)> ');
    readln(alpha_DB);
    write('  Enter value offset (decimal)> ');
    readln(alpha_offset);
    write('  Do ascii value entry or numeric) (A,N)> ');
    readln(resp);
    if resp in ['N','n']
      then begin
        write('  Enter value byte count> ');
        readln(i);
        alpha_value[0]:= chr(i);
        writeln('Enter numeric bytes (decimal), 999 to end early');
        for i:= 1 to i do
          begin
          write('Byte ',i:1,'> ');
          readln(int);
          if (int>=0) and (int<=255)
            then alpha_value[i]:= chr(int) else alpha_value[i]:= chr(0);
          end;
        end
      else begin
        write('  Enter value string> ');
        sread(input,alpha_value);
        end;
    end;
  pk_control_numeric:
    begin
    write('  Enter value type (128-float,64-bit,32-num,20-str)> ');
    readln(numeric_type);
    write('  Enter value Database (DB)> ');
    readln(numeric_DB);
    write('  Enter value offset (decimal)> ');
    readln(numeric_offset);
    write('  Enter value length(in 2byte words)> ');
    readln(numeric_len);
    for i:= 1 to numeric_len do
      begin
      write('Integer ',i:1,'> ');
      readln(numeric_value[i]);
      end;
    end;
  pk_bin:
    begin
    write('  Enter bin name> ');
    readln(bin_name);
    write('  Enter bin status word> ');
    readln(bin_status);
    write('  Enter bin level> ');
    readln(bin_level);
    write('  Enter bin height> ');
    readln(bin_height);
    write('  Enter bin certificate (official) grade> ');
    readln(bin_cgrade);
    write('  Enter bin grade name> ');
    readln(bin_grade);
    write('  Enter bin subgrade name> ');
    readln(bin_sgrade);
    write('  Enter bin priority> ');
    readln(bin_priority);
    end;
  pk_field_value:
    begin
    write('  Enter field name (1-6 chars)> ');
    readln(field_name);
    write('  Enter field status (word)> ');
    readln(field_status);
    write('  Enter field terminator> ');
    readln(field_term);
    write('  Enter field value >');
    sread(input,field_value);
    end;
  pk_record:
    begin
    write('  Enter record length (in 2byte words> ');
    readln(record_len);
    writeln('  Enter record value (integers):');
    for i:= 1 to record_len do
      begin
      write('  value[',i:1,']> ');
      readln(record_value[i]);
      end;
    end;
  pk_comment:
    begin
    writeln('  Enter comment text (up to 199 chars)> ');
    writeln('        ',
'         1         2         3         4         5         6         7');
    writeln('        ',
'1234567890123456789012345678901234567890123456789012345678901234567890');
    write('   1-70>');
    sread(input,hold70);
    sassign(comment,hold70);
    writeln('        ',
'         8         9         0         1         2         3         4');
    writeln('        ',
'1234567890123456789012345678901234567890123456789012345678901234567890');
    write(' 71-140>');
    sread(input,hold70);
    sconcat(comment,hold70);
    writeln('        ',
'         5         6         7         8         9         ');
    writeln('        ',
'12345678901234567890123456789012345678901234567890123456789');
    write('141-199>');
    sread(input,hold70);
    sconcat(comment,hold70);
    end;
  otherwise
    begin
    { all other packets need no additional text }
    end;
  end; {case}
  end; {with}
end; {procedure get_msg_contents }

{------------- Modify_Header ----------------------------------}
    
Procedure Modify_header;
    
{ this procedure prompts for destination task and node, then 
      calls MSINIT with the information. }
    
VAR
    stat: integer;
	    
BEGIN 
    Writeln(' enter a space to bug out...');
    write('destination task name [');
    SWrite(output,to_task);
    write('] ');
    Readln(to_task);
    if (to_task = '      ') 
    	then escape := TRUE
	ELSE BEGIN 
	write('Destination node name [');
	SWrite(output,to_node);
	Write('] ');
	Readln(to_node);
	if (to_node = '      ') 
            then escape := TRUE
	    ELSE BEGIN 
	    Msinit(to_node,to_task,out_msg,stat);
	    writeln('msinit status is ',stat,'.');
	    if (Stat < 1) THEN escape := true
	    END
	END
    END;




{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

Begin    { main program }
exit_requested:= false;
comman := 'H     ';   { if operator makes no entry, default is set header }
{ initialize out_msg header to empty...}
With out_msg do
  BEGIN 
  router := null_task_name;
  dest_task := null_task_name;
  src_task := null_task_name;
  dest_node := '      ';
  src_node  := '      ';
  msg_size := 0;
  flags := [];
  protocol := 0
  END;
  
repeat
  { main process loop, repeat until exit requested }
  writeln;
  writeln('Receive any outstanding messages...');
  get_any_messages;
  writeln;
  writeln('Current out-bound message header is:');
  dmpHdr(output,out_msg);
  write('Enter H (modify header), S (send), N (no send),  X (exit),  [',
    comman,']> ');
  readln(comman);
  { convert comman name to upper case if not already }
  supper(comman );
  if comman = 'X     ' then exit_requested:= true;
  if comman = '      ' then comman:= old_comman;
  old_comman:= comman;
  If comman = 'H     ' then
    BEGIN 
    escape := false;
    Modify_header;
    If escape then 
	BEGIN 
	old_comman := 'N     ';
	comman := old_comman
	END
        ELSE BEGIN 
	    Write('change message body contents? [Y/N] ');
            readln(comman);
    	    supper(comman)
	END
    END;


{** HACK WARNING! - above question will yield comman = 'N     ', meaning
   "use existing message text". However, the same value will next be
    interpreted as 'no-send'. What's worse, if we get escape back
    from modify-header, we hammer command into "N". Yuck - but it works... }

  if (not(exit_requested)) and (comman<>'N     ')
    then begin
      { Clear the message contents, get the packet id to send, 
        prompt the operator for contents, and then send the packet. }
      sclear(out_msg.value);
      get_id_selection(escape);
      if not(escape)
        then begin
          get_sub_selection;
          cpitas(out_msg.id,alpha_id);
          supper(alpha_id);
          write('  Prepare to send a "');
          swrite(output,alpha_id);
          writeln('" packet');
          write('    with sub type set of [');
          cpstas(out_msg.sub,med_alpha_sub);
          swrite(output,med_alpha_sub);
          writeln(']');
          writeln;
          get_msg_contents;
  	  out_msg.msg_size := MsSize(out_msg);
  	end;
{ now check Old_comman to see if we really want to send something...}
  If Old_comman <> 'N     ' 
     THEN BEGIN
          {now send the message}
          mssend(out_msg, f0);
    	  stat := $dsw;
          if stat=1
            then writeln('  Message sent to ',task_name)
            else writeln(chr(7),
                   '  Failed to send message, error status is ',stat:1);
          end;
      end;
  until exit_requested;
end.