unit em5250io; {Full Screen Manager and 5250 Emulator Interface Routines}
{$V-}

Interface
Uses dos,crt,printer;

Type
  indicatorarray = array[1..100] of char;
  cmdarray       = array[1..12]  of char;
  rtnstring      = string[80];
  formatpointer  = ^formatswork;
  fpointer       = ^screenfields;
  fmtnamestring  =  string[8];
  filenamestring =  string[12];
  formatswork = record             {format header information Array record}
   wformatname:          string[8];{format name}
   wscreenrow:           integer;  {starting row of format}
   wscreencol:           integer;  {starting column of format}
   wbkintcolor:          integer;  {initial background color}
   wtxintcolor:          integer;  {initial text color}
   wclrline:             integer;  {number of lines on screen to clear}
                                   {from first used line of this format}
   wputovr:              integer;  {indicator-rewrite panel without constants}
                                   {and without erasing input only type fields}
   weraseinp:            integer;  {indicator-erase input only type fields on}
                                   {if putovr indicator is on (1)}
   whelpname:            string[8];{Name of Help Format For This Format}
   wcommandkeymask:      cmdarray; {Valid Commandkeys This FMT}
   nextformat:           formatpointer;
   firstconstant:        fpointer;
   firstfield:           fpointer;
  end;

 screenfields = record             {field description on heap record}
  screenrow:            integer;   {row starting location of field}
  screencol:            integer;   {column starting location of field}
  fieldlen:             byte;      {Length Of Field Including Decimals If Any}
  fill1:                byte;
  fielddec:             byte;      {Number Of Decimal Positions In Field}
  lowercas:             char;      {Allow Lower Case If None Blank}
  datatype:             char;      {C=Character or String,N=Integer or Real}
  iotype:               char;      {I=Input Only, O=Output Only, B=Both}
  fieldnam:             string[8];
  fmtname:              string[8]; {Name Of This Format(Screen Panel)}
  screenname:           string[8]; {Name Of File Containing Panel Descriptions}
  bkcolor:              byte;      {Background color}
  position:             byte;
  txcolor:              byte;      {Text Display Color}
  protect:              byte;
  rvrsimg:              byte;      {Indicator 01-99 if 1 Colors Are Reversed}
  blink:                byte;      {Field Will Blink If Indicator Is On}
  errorind:             byte;      {Indicator 01-99 if 1 Error Msg. Displayed}
                                   {error message stored in constandata}
  fill4:                byte;
  constantdata:         string[80];
  nextfield:            fpointer;
  prvfield:             fpointer;
  fieldoffset:          word;
 end;

Const
 entercode:         byte = $68;    {5250 enter key scan code}
 systemrequestcode: byte = $7C;    {5250 System Request Scan Code}
 commandcode:       byte = $6F;    {5250 CMD key. PC F2 key}
 commandkey:        char = ' ';    {commandkey indicator}
 block38:           char = ' ';    {move fields without field exit if not ' '}
 fieldexitcode:     byte = $2D;    {5250 Field Exit Key PC Enter Key}
 _In: indicatorarray =
 ('0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0',
  '0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0',
  '0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0',
  '0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0',
  '0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0');

procedure seton(indicatornum:shortint);
procedure setof(indicatornum:shortint);
procedure resetind;
procedure openscreenfile(var firstscreenseg,firstscreenofs:word;
                             screenfilename:filenamestring);
procedure screenio(usezfmtname: fmtnamestring);
procedure writescreen(usefmtname: fmtnamestring);
procedure readscreen(usefmtname: fmtnamestring);
procedure checkinputinhibit;
procedure read38(idrow,idcol,idlen:shortint);
procedure sendfieldexit(sendendoffield: byte);
procedure sendcommandkey(commandkeyx:char);
procedure write38(idrow,idcol,idlen:shortint);
procedure copyscreen(startrow,startcolumn,endrow,endcolumn:shortint);
procedure check38(startrow,startcol,lengthx:shortint; var rtnformat:rtnstring);
procedure autohotkey(hotkeyrow,hotkeycolumn: shortint; hotkeychar:char);

Implementation

Const
 inzscreen:             char    = ' ';   {screen specs read from disk flag}
 displayadaptersegment: word    = $B000; {color display segment address}
 helplevel:             shortint= 0;     {Depth Of Help Screens Displayed}
 bottomlinebackground:  shortint= 0;
 bottomlineforeground:  shortint= 0;
 backgroundcolortable:  array[1..16] of byte =($00,$10,$20,$30,$40,$50,$60,$70,
                                              $00,$10,$20,$30,$40,$50,$60,$70);
 textcolortable:        array[1..16] of byte =($00,$01,$02,$03,$04,$05,$06,$07,
                                              $08,$09,$0A,$0B,$0C,$0D,$0E,$0F);
  errormsg:             array[1..11] of string[64] =  {keyboard error messages}
    ('Attempt To Advance Cursor Off The Screen. Use Tab or Field Exit',
     'Cursor Advanced Past Start/End Of Field. Use Tab or Field Exit',
     'Unidentified Character Entered. Re-enter.',
     'Attempt To Enter Info Past End Of Field. Use Tab or Field Exit',
     'Field Requires Numbers Only, Other Characters Not Allowed',
     'Field Is Full. Insertion Cannot Be Performed',
     'No HELP Screen Is Defined For This Screen',
     'Command Key Is Not Valid For This Format',
     'Numeric Field Conversion Error',
     'Invalid Command Key Pressed. Command Key Is Cancelled',
     'Requested Format Was Not Found. Program Aborted. ');
 firsthelp:     integer=0;
 secondhelp:    integer=0;
 thirdhelp:     integer=0;
 fourthhelp:    integer=0;
 fifthhelp:     integer=0;
 sixthhelp:     integer=0;
 format1:       integer=0;
 format2:       integer=0;
 fieldpointer:  fpointer=nil;
 currentformat: formatpointer=nil;
 charoutbuffer:        string[80]=' ';  {output data field character buffer}
 inpbuffer:            string[80]=' ';  {input field keyboard buffer}
 previousformatname:   string[8] =' ';  {name of last panel read from disk}
 zformatname:          string[8] =' ';  {format name holding variable}
 inputbufferlength:    byte = $00;  {length of current field as a byte}
 charin:               char = ' ';  {current character from keyboard}
 insertmodeflag:       char = ' ';  {Flag For F3 Press }
 inputfieldonlyflag:   char = ' ';  {Eraseinput Key Screenwrite Control}
 kbderrorflag:         char = ' ';  {keyboard error occurred flag}
 keyboardstatuschange: char = ' ';  {detect numlock press and save}
 searchflag:           char = ' ';
 charvalue:            integer = 0; {ordinal value of field charin }
 clrlimit:             shortint= 0; {last line to be cleared on panel}
 column:               shortint= 0; {screen column address}
 columncount:          shortint= 0; {screen column counter}
 currentoffset:        word    = 0; {memory loc. field start on screen}
 cvtresult:            integer = 0; {character to number conversion }
                                    {error result checker}
 datasegment:          word= $0000; {segment address for data segment}
 decimalcount:         shortint= 0; {working field for no. of decimals}
 endrow:               shortint= 0; {last row number of field}
 endcolumn:            shortint= 0; {last column in field}
 errornumber:          shortint= 0; {index to keyboard error array}
 maxfields:            integer = 0; {number of data fields in a format}
 multiplier:           longint = 0; {factor or 10 to remove or insert }
                                    {decimals in screen field}
 offset:               shortint= 0; {cursor movement offset from }
                                    {current location negative value}
                                    {means move left,positive=right}
 row:                  shortint= 0; {screen field row address}
 scolumn:              shortint= 0; {screen field column address}
 displayadapteroffset: word =$0000; {start of display memory offset}
 srow:                 shortint= 0; {screen field row address}
 workindex:            integer = 0; {index to array of data fields or}
                                    {constant fields}
 { work areas for input/output conversion routines}
 workaddress:       word = 0;
 workinteger:       integer = 0;
 workshortint:      shortint= 0;
 worklongint:       longint = 0;
 workreal:          real    = 0.0;
 blanktest:         string[80]='';{test input or both types for blanks}
 cursorrightcode:   byte = $73;   {5250 Cursor Right Scan Code}
 errorresetcode:    byte = $7E;   {5250 Error Reset Scan Code}
 fieldadvancecode:  byte = $20;   {5250 Field Advance Key PC Tab Key}
 fieldminuscode:    byte = $4E;   {5250 Field Minus Key PC Minus Key}
 homecursorcode:    byte = $6D;   {5250 Home Cursor Scan Code}
 em5250segment:     word = $0000; {emulator segment address}
 screenoffset:      word = $0000; {address offset of emulated screen}
 ebcdictableoffset: word = $0000; {address offset of start of ebcdic to
                                   ascii translate table}
 inpbuffersegment:  word = $0000; {segment address of input buffer string}
 inpbufferoffset:   word = $0000; {offset address of input buffer string}
 inputinhibit:      word = $013E; {offset to input inhibited indicator byte}
 inhibithistory:    word = $013F; {offset to inhibit indicator history byte}
 inz38flag:         char    = ' ';{s38 emulator variables established flag}
 keyo:              word = $0151; {address to send scan codes to}
 surx:              word = $0164; {Emulator EBCDIC Display Change Indicator}
 systemavailable:   word = $015B; {address of system available ind. byte}
 hotkey:            word = $0178; {address of hot-key indicator}
 hkcol:             word = $017B; {address auto hot-key char.5250 column}
 hkrow:             word = $017C; {address auto hot-key char 5250 row}
 hkchar:            word = $017D; {address containing auto hot-key char}
 hotkeychar:        char = ' ';   {character on s38 format forces DOS hot key}
 statusmessage:     string[70]='';{System Available & Input Inhibit Message}
 zerorealtest:      real = 0.0;   {test input or both types for zero.}
 asciitranslatetable: array[1..128] of byte =
  ($00,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,
   $40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,
   $40,$40,$40,$40,$40,$40,$40,$4F,$7F,
   $7B,$5B,$6C,$50,$7D,$4D,$5D,$5C,$4E,$6B,$60,$4B,$61,
   $F0,$F1,$F2,$F3,$F4,$F5,$F6,$F7,$F8,$F9,$7A,$5E,$4C,
   $7E,$6E,$6F,$7C,$C1,$C2,$C3,$C4,$C5,$C6,$C7,$C8,$C9,
   $D1,$D2,$D3,$D4,$D5,$D6,$D7,$D8,$D9,$E2,$E3,$E4,$E5,
   $E6,$E7,$E8,$E9,$4A,$E0,$5A,$5F,$6D,$79,$81,$82,$83,
   $84,$85,$86,$87,$88,$89,$91,$92,$93,$94,$95,$96,$97,
   $98,$99,$A2,$A3,$A4,$A5,$A6,$A7,$A8,$A9,$C0,$6A,$D0,
   $A1,$8F); {ascii to ebcdic translate table}
 scancode5250table:  array[1..128] of byte =
  ($00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
   $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
   $00,$00,$00,$00,$00,$00,$0F,$2B,$1B,
   $33,$34,$35,$37,$1B,$39,$3A,$38,$3C,$08,$3B,$09,$0A,
   $40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$1A,$1A,$0E,
   $3C,$0E,$0A,$32,$11,$05,$03,$13,$23,$14,$15,$16,$28,
   $17,$18,$19,$07,$06,$29,$28,$21,$24,$12,$25,$27,$04,
   $22,$02,$26,$01,$2B,$2C,$2B,$36,$3B,$3E,$11,$05,$03,
   $13,$23,$14,$15,$16,$28,$17,$18,$19,$07,$06,$29,$2A,
   $21,$24,$12,$25,$27,$04,$22,$02,$26,$01,$1C,$2C,$1C,
   $3E,$31); {ascii to 5250 scan code table}
Type
  fixstringz      =  string[80];
  screenpointer   =  ^screenrecord;
  screenrecord    =  record
    savescreenarea:  array[1..4000] of byte;
    prevscreen:      screenpointer;
    saveindex:       fpointer;
    savebuffer:      string[80];
    saveformatcount: formatpointer;
  end;

 formatrecord = record               {field description disk & array record}
    screenrow:            integer;   {row starting location of field}
    screencol:            integer;   {column starting location of field}
    fieldlen:             byte;      {Length Of Field Including Decimals If Any}
    fill2:                byte;
    fielddec:             byte;      {Number Of Decimal Positions In Field}
    lowercas:             char;      {Allow Lower Case Entry If NonBlank}
    datatype:             char;      {C=Character or String,N=Integer or Real}
    iotype:               char;      {I=Input Only, O=Output Only, B=Both}
    fieldnam:             string[8];
    fmtname:              string[8]; {Name Of This Format(Screen Panel)}
    screenname:           string[8]; {Name Of File Containing Panel Description}
    bkcolor:              byte;      {Background color}
    position:             byte;      {Position Cursor To Field Indicator}
    txcolor:              byte;      {Text Display Color}
    protect:              byte;      {Protect Field From Input Indicator}
    rvrsimg:              byte;      {Indicator 01-99 if 1 Colors Are Reversed}
    blink:                byte;      {Field Will Blink If Indicator Is On}
    errorind:             byte;      {Indicator 01-99 if 1 Error Msg. Displayed}
                                     {error message stored in constandata}
    fill4:                byte;
    constantdata:  string[80];
   end;

  formatheader = record         {format header information disk record}
   bkintcol:         integer;   {initial background color}
   txintcol:         integer;   {initial text color}
   putovr:           integer;   {rewrite screen inidicator}
   eraseinp:         integer;   {erase input fields if on & putovr on ind}
   hfmtname:         string[8]; {name of format}
   screenname:       string[8]; {name of screen file}
   clrline:          integer;   {number of lines to clear from 1st line}
   helpname:         string[8]; {Name Of Help Format}
   commandkeymask:   cmdarray;  {Valid Command Keys This Format}
   reservedarea:     string[32];{Reserved For Future Use}
  end;
var
  screensaveheap:  screenrecord;
const
  firsthelpscreen: screenpointer=nil;
  lasthelpscreen:  screenpointer=nil;
  newhelpscreen:   screenpointer=nil;

procedure setstatusline(messagecolor,delaytime:integer);
  begin
    gotoxy(1,25);
    textcolor(messagecolor);
    textbackground(1);
    delay(delaytime);
    clreol;
  end;

procedure emulatorstatusmessage;
  begin
    setstatusline(4,0);
    write(statusmessage);
    setstatusline(15,50);
  end;

procedure checkinputinhibit;
  begin
   statusmessage:='Input Inhibited';
   emulatorstatusmessage;
   while ((mem[em5250segment:inputinhibit] and 2) = 0) or
         ((mem[em5250segment:inhibithistory] and 2) =2) do
         emulatorstatusmessage;
  end;

procedure calculateoffset (rowloc,columnloc: integer);
begin
 currentoffset:=((rowloc * 80) - 81) + columnloc;
end;

procedure Savescreen(fieldpointer: fpointer);
  begin
    getmem(newhelpscreen,(sizeof(screensaveheap)));
    if firsthelpscreen=nil then begin
       firsthelpscreen:=newhelpscreen;
       lasthelpscreen:=nil;
    end;
    move(mem[displayadaptersegment:displayadapteroffset],
         newhelpscreen^.savescreenarea,4000);
    newhelpscreen^.prevscreen:=lasthelpscreen;
    newhelpscreen^.saveindex:=fieldpointer;
    newhelpscreen^.savebuffer:=inpbuffer;
    newhelpscreen^.saveformatcount:=currentformat;
    lasthelpscreen:=newhelpscreen;
    helplevel:=helplevel+1;
  end;

procedure Restorescreen(var fieldpointer:fpointer);
 var savelast: screenpointer;
 begin
   helplevel:=helplevel-1;
   move(lasthelpscreen^.savescreenarea,
        mem[displayadaptersegment:displayadapteroffset],4000);
   fieldpointer:=lasthelpscreen^.saveindex;
   if lasthelpscreen^.prevscreen=nil then begin
      inpbuffer:=lasthelpscreen^.savebuffer;
      gotoxy(scolumn,srow);
      firsthelpscreen:=nil;
   end;
   if lasthelpscreen<>nil then begin
      savelast:=lasthelpscreen^.prevscreen;
      currentformat:=lasthelpscreen^.saveformatcount;
      freemem(lasthelpscreen,(sizeof(screensaveheap)));
      lasthelpscreen:=savelast;
   end;
  end;

procedure autohotkey;
  var
    hotkeyrowbyte,hotkeycolumnbyte: byte;
    regs: registers;
  begin
    checkinputinhibit;
    while mem[em5250segment:surx]=$00 do begin end;
    delay(400);
    checkinputinhibit;
    hotkeyrowbyte:=hotkeyrow;
    hotkeycolumnbyte:=hotkeycolumn;
    mem[em5250segment:hkrow]:=hotkeyrowbyte;
    mem[em5250segment:hkcol]:=hotkeycolumnbyte;
    mem[em5250segment:hkchar]:=asciitranslatetable[(ord(hotkeychar)+1)];
    if (mem[em5250segment:hotkey] and 1)<>1 then
       mem[em5250segment:hotkey]:=mem[em5250segment:hotkey] xor $01;
    with regs do intr(9,regs);
    if (mem[em5250segment:hotkey] and 1)=1 then
       mem[em5250segment:hotkey]:=mem[em5250segment:hotkey] xor $01;
    mem[em5250segment:hkrow]:=$00;
    mem[em5250segment:hkcol]:=$00;
    mem[em5250segment:hkchar]:=$00;
  end;

procedure sendfieldexit;
  begin
    if (sendendoffield=entercode) or (sendendoffield=commandcode) then begin
       checkinputinhibit;
       mem[em5250segment:inputinhibit]:=$00;
       mem[em5250segment:inhibithistory]:=$FF;
    end;
    while mem[em5250segment:keyo]<>$00 do begin end;
    mem[em5250segment:keyo]:=sendendoffield;
    mem[em5250segment:surx]:=$00; {set screen change ind. to zero to allow}
  end;                           {detection of a change in the emulator screen}

procedure systemrequest;
  var dummy: char;
      cursorx: shortint;
      cursory: shortint;
  begin
    cursorx:=wherex;
    cursory:=wherey;
    sound(500);
    statusmessage:='System Req./ATTN Pressed--Press ESC To Exit, Any Other Key Continue';
    emulatorstatusmessage;
    nosound;
    while not keypressed do emulatorstatusmessage;
    charin:=readkey;
    if keypressed then dummy:=readkey;
    gotoxy(cursorx,cursory);
    if ord(charin)<>$1B then begin
       checkinputinhibit;
       if charvalue>59 then sendfieldexit($57);
       sendfieldexit(systemrequestcode);
       autohotkey(0,0,#0);
    end;
  end;

procedure seton;
 begin
   _in[indicatornum]:='1';
 end;

procedure setof;
 begin
   _in[indicatornum]:='0';
 end;

procedure resetind; {reset all indicators in indicator array}
   begin
     fillchar(_in[1],100,'0');
   end;

procedure errorsound(freq,wait:integer);
 begin
  sound(freq);
  delay(wait);
  nosound;
 end;

procedure clearbottomline;
  begin
    gotoxy(1,25);
    if (bottomlinebackground=0) and (bottomlineforeground<>4) and
    (bottomlineforeground<>12) then bottomlinebackground:=4;
    textcolor(bottomlineforeground);
    textbackground(bottomlinebackground);
    clreol;
  end;

procedure keyboarderror(errornumber: integer);
 begin
   clearbottomline;
   write(errormsg[errornumber]);
   errorsound(500,600);
   gotoxy(scolumn,srow);
   kbderrorflag:='1';
 end;

procedure fixstring(address:word;fieldlen:integer;siotype,sdatatype,ioflag:char);
 var
   blankloc:    integer;   {position of first blank character}
   sfieldlen:   integer;   {defined field length}
   workseg:     word;
 begin
  if (ioflag='U') or (ioflag='I') then begin
     workaddress:=ofs(inpbuffer);
     workseg:=seg(inpbuffer);
 end;
 case ioflag of
 'O': begin
       workaddress:=ofs(charoutbuffer);
       workseg:=seg(charoutbuffer);
       blankloc:=ord(mem[datasegment:address]);
       mem[datasegment:address]:=ord(chr(fieldlen));
       if blankloc>fieldlen then blankloc:=0;
       while blankloc<fieldlen do begin
          blankloc:=blankloc+1;
          mem[datasegment:address + blankloc]:=$20;
       end;
       move(mem[datasegment:address],mem[workseg:workaddress],(fieldlen+1));
       if (siotype='I') then fillchar(mem[datasegment:(address + 1)],
          fieldlen,' ');
     end;
 'U': begin
        inpbuffer:='';
        blankloc:=(ord(mem[datasegment:address]))+1;
        move(mem[datasegment:address],mem[workseg:workaddress],blankloc);
        while length(inpbuffer)<fieldlen do begin
          if sdatatype='C' then inpbuffer:=inpbuffer + ' '
          else inpbuffer:=' ' + inpbuffer;
        end;
        move(inpbuffer,mem[datasegment:address],(length(inpbuffer)+1));
      end;
 'I': begin
        if sdatatype='R' then begin
           blankloc:=pos(' ',inpbuffer);
           sfieldlen:=length(inpbuffer);
           if blankloc>1 then begin
              inpbuffer:=copy(inpbuffer,1,(blankloc-1));
              for blankloc:=blankloc to sfieldlen do inpbuffer:=' ' + inpbuffer;
          end;
        end;
        sfieldlen:=length(inpbuffer)+1;
        move(mem[workseg:workaddress],mem[datasegment:address],sfieldlen);
      end;
   end;
 end;

procedure fixreal (address:word;rfieldlen,rfielddec: integer;
                   riotype,rdatatype,ioflag: char);
var savesign: char;

procedure ofixreal(address:word;orfieldlen,orfielddec: integer;
                  oriotype,ordatatype,ioflag:char);
 var workseg: word;
 begin
   workaddress:=ofs(workreal);
   workseg:=seg(workreal);
   move(mem[datasegment:address],mem[workseg:workaddress],6);
   if workreal<0 then begin
      savesign:='-';
      workreal:=abs(workreal);
   end
   else savesign:=' ';
   if ordatatype<>'E' then begin
      workreal:=workreal*multiplier;
      orfielddec:=0;
   end
   else orfieldlen:=orfieldlen + 1;
   str(workreal:orfieldlen:orfielddec,inpbuffer);
   if ordatatype<>'N' then inpbuffer:=inpbuffer + savesign;
   if ioflag='O' then begin
      charoutbuffer:=inpbuffer;
      if (oriotype='I') then begin
         workreal:=0;
         move(mem[workseg:workaddress],mem[datasegment:address],6);
      end;
   end;
 end;

procedure ifixreal(address:word;irfieldlen,irfielddec: integer;
                  iriotype,irdatatype,ioflag:char);
  var workseg: word;
  begin
    savesign:=' ';
    workaddress:=ofs(workreal);
    workseg:=seg(workreal);
    if irdatatype='E' then irfieldlen:=irfieldlen + 1;
    if irdatatype<>'N' then begin
       savesign:=inpbuffer[irfieldlen + 1];
       inpbuffer:=copy(inpbuffer,1,irfieldlen);
    end;
    val(inpbuffer,workreal,cvtresult);
    if cvtresult<>0 then keyboarderror(9);
    if irdatatype<>'E' then workreal:=workreal/multiplier;
    if savesign='-' then workreal:=0-workreal;
    move(mem[workseg:workaddress],mem[datasegment:address],6);
    if irdatatype<>'N' then inpbuffer:=inpbuffer+savesign;
  end;

   begin
     case ioflag of
    'U','O': ofixreal (address,rfieldlen,rfielddec,riotype,rdatatype,ioflag);
        'I': ifixreal (address,rfieldlen,rfielddec,riotype,rdatatype,ioflag);
     end;
   end;

procedure fixinteger (address:word;ifieldlen,ifielddec:
                      integer; iiotype,idatatype,ioflag: char);
  var
    savesign:    char;
    workcounter: longint;
    targetsize:  shortint;
    workseg:     word;
    workofs:     word;
procedure ofixinteger(address:word;oifieldlen,oifielddec:
                      integer; oiiotype,oidatatype,ioflag:char);
begin
   move(mem[datasegment:address],mem[(seg(workinteger)):workofs],targetsize);
   case targetsize of
    1: worklongint:=workshortint;
    2: worklongint:=workinteger;
   end;
   if worklongint<0 then savesign:='-';
   worklongint:=abs(worklongint);
   str(worklongint:oifieldlen,inpbuffer);
   if oidatatype<>'N' then inpbuffer:=inpbuffer + savesign;
   if ioflag='O' then begin
      charoutbuffer:=inpbuffer;
      if oiiotype='I' then begin
         workcounter:=0;
         move(workcounter,mem[datasegment:address],targetsize);
      end;
   end;
 end;

procedure ifixinteger(address:word; iifieldlen,iifielddec:
                      integer; iiiotype,iidatatype,ioflag:char);
  begin
    if iidatatype<>'N' then begin
       savesign:=inpbuffer[iifieldlen + 1];
       inpbuffer:=copy(inpbuffer,1,iifieldlen);
    end;
    val(inpbuffer,worklongint,cvtresult);
    if savesign='-' then worklongint:=0-worklongint;
    if iidatatype<>'N' then inpbuffer:=inpbuffer + savesign;
    if targetsize=4 then move(worklongint,mem[datasegment:address],4)
    else begin
      workinteger:=worklongint;
      move(workinteger,mem[datasegment:address],targetsize);
    end;
  end;

 begin
  savesign:=' ';
  case  ifieldlen of
   1..2: begin
           targetsize:=1;
           workofs:=ofs(workshortint);
         end;
   3..4: begin
           targetsize:=2;
           workofs:=ofs(workinteger);
         end;
   5..9: begin
           targetsize:=4;
           workofs:=ofs(worklongint);
         end;
  end;
  case ioflag of
  'U','O': ofixinteger (address,ifieldlen,ifielddec,iiotype,idatatype,ioflag);
  'I':     ifixinteger (address,ifieldlen,ifielddec,iiotype,idatatype,ioflag);
   end;
 end;

 Procedure Checknumeric(address: word; iotype,datatype: char; fieldlen,
                        fielddec: integer; ioflag:char);
    begin
      if (fieldlen>9) or (fielddec>0)
      then fixreal(address,fieldlen,fielddec,iotype,datatype,ioflag)
      else fixinteger(address,fieldlen,fielddec,iotype,datatype,ioflag);
    end;

Procedure Checkfield(ioflag: char; fieldpointer:fpointer);
Begin
multiplier:=1;
for decimalcount:=1 to fieldpointer^.fielddec do multiplier:=multiplier * 10;
datasegment:=dseg;
case fieldpointer^.datatype of
 'C','R': fixstring(fieldpointer^.fieldoffset,fieldpointer^.fieldlen,
                    fieldpointer^.iotype,fieldpointer^.datatype,ioflag);
 else  checknumeric(fieldpointer^.fieldoffset,fieldpointer^.iotype,
                    fieldpointer^.datatype,fieldpointer^.fieldlen,
                    fieldpointer^.fielddec,ioflag);
end;
end;

procedure positioncursor;
  begin
    if srow>24 then srow:=1;
    if srow<1  then srow:=24;
    gotoxy(scolumn,srow);
  end;

  procedure toggleinsertmode;
    begin
      clearbottomline;
      if insertmodeflag='1' then insertmodeflag:=' '
      else begin
        gotoxy(30,25);
        write('Insert Mode');
        Insertmodeflag:='1';
      end;
      offset:=1;
      positioncursor;
    end;

procedure checkind(var indicatornumber:byte);
  begin
   if (indicatornumber<1) or (indicatornumber>99) then indicatornumber:=100;
  end;

procedure openscreenfile;
var
 keyboardstatus:         byte absolute $0040:$0017;
 capslockstatus:         byte absolute $0040:$0018;
 screenfile:             file of formatrecord;
 zformatcontrl:          file of formatheader;
 formatheaderwork:       formatheader;
 firstformat:            formatpointer absolute format1;
 lastformat:             formatpointer;
 firstfield:             fpointer;
 cfield:                 fpointer;
 firstconstant:          fpointer;
 ccons:                  fpointer;
 lastconstant:           fpointer;
 lastfield:              fpointer;
 screenwork:             formatrecord;
 screenheap:             screenfields;
 formatheap:             formatswork;
 segment:                integer;
 offsetp:                integer;
 ioerr:                  integer;
 testbyte:               byte;
begin
{$I+}
{check and ensure numlock is set}
if (keyboardstatus and $20)=0 then keyboardstatus:=keyboardstatus xor $20;
keyboardstatuschange:=' ';
assign(screenfile,screenfilename);
assign(zformatcontrl,(screenfilename + '.hdr'));
reset(screenfile);
reset(zformatcontrl);
resetind;
firstformat:=nil;
firstfield:=nil;
firstconstant:=nil;
textcolor(1);
textbackground(1);
clrscr;
mem[displayadaptersegment:$0000]:=ord('A');
testbyte:=mem[displayadaptersegment:$0000];
if testbyte=ord('A') then displayadapteroffset:=$0000
else displayadapteroffset:=$8000;
mem[displayadaptersegment:$8000]:=ord('A');
testbyte:=mem[displayadaptersegment:$8000];
if testbyte=ord('A') then displayadapteroffset:=$8000
else displayadapteroffset:=$0000;
textcolor(15);
previousformatname:='';
while not eof(screenfile) do begin
  with screenwork do begin
     read(screenfile,screenwork);
     if displayadapteroffset=$0000 then begin
        txcolor:=15;
        bkcolor:=1;
     end;
     if fieldnam='Constant' then getmem(ccons,(sizeof(screenheap)))
     else getmem(cfield,(sizeof(screenheap)));
     if previousformatname<>fmtname then begin
        getmem(currentformat,(sizeof(formatheap)));
        if firstformat=nil then firstformat:=currentformat
        else lastformat^.nextformat:=currentformat;
        with formatheaderwork do begin
          read(zformatcontrl,formatheaderwork);
          previousformatname:=fmtname;
          currentformat^.firstconstant:=nil;
          currentformat^.firstfield:=nil;
          if displayadapteroffset=$0000 then begin
             bkintcol:=1;
             txintcol:=15;
          end;
          currentformat^.wformatname:=fmtname;
          currentformat^.wscreenrow:=screenrow;
          currentformat^.wscreencol:=screencol;
          currentformat^.wbkintcolor:=bkintcol;
          currentformat^.wtxintcolor:=txintcol;
          currentformat^.wputovr:=putovr;
          currentformat^.weraseinp:=eraseinp;
          currentformat^.wclrline:=clrline;
          currentformat^.wcommandkeymask:=commandkeymask;
          currentformat^.whelpname:=helpname;
          if (currentformat^.wputovr<1) or (currentformat^.wputovr>99)
             then currentformat^.wputovr:=100;
          if (currentformat^.weraseinp<1) or (currentformat^.weraseinp>99)
             then currentformat^.weraseinp:=100;
          if fieldnam='Constant' then begin
             currentformat^.firstconstant:=ccons;
             firstconstant:=nil;
          end
          else begin
            currentformat^.firstfield:=cfield;
            firstfield:=nil;
         end;
         lastformat:=currentformat;
         currentformat^.nextformat:=nil;
       end;
    end
    else begin
      if (currentformat^.firstconstant=nil) and (fieldnam='Constant')
         then begin
           currentformat^.firstconstant:=ccons;
           firstconstant:=nil;
      end;
      if (currentformat^.firstfield=nil) and (fieldnam<>'Constant')
         then begin
          currentformat^.firstfield:=cfield;
          firstfield:=nil;
      end;
    end;
    if fieldnam='Constant' then begin
       if firstconstant=nil then begin
          firstconstant:=ccons;
          lastconstant:=nil;
       end
       else lastconstant^.nextfield:=ccons;
       segment:=seg(ccons^);
       offsetp:=ofs(ccons^);
       move(screenwork,mem[segment:offsetp],(sizeof(screenwork)));
       ccons^.nextfield:=nil;
       lastconstant:=ccons;
       checkind(ccons^.rvrsimg);
       checkind(ccons^.blink);
    end
    else begin
     if firstfield=nil then begin
        firstfield:=cfield;
        lastfield:=nil;
     end
     else lastfield^.nextfield:=cfield;
     segment:=seg(cfield^);
     offsetp:=ofs(cfield^);
     move(screenwork,mem[segment:offsetp],(sizeof(screenwork)));
     checkind(cfield^.rvrsimg);
     checkind(cfield^.errorind);
     checkind(cfield^.protect);
     checkind(cfield^.position);
     checkind(cfield^.blink);
     cfield^.nextfield:=nil;
     cfield^.prvfield:=lastfield;
     lastfield:=cfield;
    end;
  end;
 end;
 inzscreen:='1';
 firstscreenseg:=seg(firstformat^);
 firstscreenofs:=ofs(firstformat^);
 close(screenfile);
 close(zformatcontrl);
end;

procedure calculatescreenoffset(rowaddress,columnaddress: integer);
 begin
  currentoffset:=((rowaddress*160) -162) + columnaddress + columnaddress;
 end;

procedure defaultcolor(var dbkcolor,dtxcolor:byte; dbkint,dtxint:integer);
  begin
    if dbkcolor=0 then dbkcolor:=dbkint;
    if dtxcolor=0 then dtxcolor:=dtxint;
  end;

procedure findformat(firstformat: formatpointer; usefmtname:fmtnamestring);
  begin
    currentformat:=firstformat;
    searchflag:=' ';
    repeat
      if currentformat^.wformatname=usefmtname then searchflag:='1'
      else currentformat:=currentformat^.nextformat;
      if currentformat=nil then begin
         keyboarderror(11);
         halt;
      end;
    until (searchflag='1') or (currentformat=nil);
    bottomlineforeground:=currentformat^.wtxintcolor;
    bottomlinebackground:=currentformat^.wbkintcolor;
 end;

procedure writescreen;
 var
  bytecount:    integer;
  zscreenrow:   integer;
  inputwork:    string[80];
  wxformat:     string[8];
 firstformat:   formatpointer absolute format1;
 workpointer:   fpointer;

procedure screenoutput(dataout: fixstringz;
          outputlength,bkcol,txcol,rvrs,blink: byte);
var
 setcolor:      byte;
 outputword:    array[1..2] of byte;
 paramoffset:   word;
 paramsegment:  word;
 savescroffset: word;
begin
   savescroffset:=displayadapteroffset + currentoffset;
   paramoffset:=ofs(dataout) + 1;
   paramsegment:=seg(dataout);
   if bkcol>15 then bkcol:=1;
   if txcol>15 then txcol:=1;
   if rvrs=0 then rvrs:=100;
   if (_in[rvrs]<>'1') and (_in[rvrs]<>'0') then _in[rvrs]:='0';
   if _in[rvrs]='0' then outputword[2]:=
      backgroundcolortable[(bkcol + 1)] + textcolortable[(txcol + 1)]
   else outputword[2]:=
      backgroundcolortable[txcol + 1] + textcolortable[bkcol + 1];
   if _in[blink]='1' then outputword[2]:=outputword[2]+$80;
   for paramoffset:=paramoffset to (paramoffset + outputlength - 1) do begin
      outputword[1]:=mem[paramsegment:paramoffset];
      move(outputword,mem[displayadaptersegment:savescroffset],2);
      savescroffset:=savescroffset + 2;
   end;
 end;

begin
 commandkey:=' ';
 searchflag:=' ';
 if currentformat^.wformatname<>usefmtname then
    findformat(firstformat,usefmtname);
 if (currentformat^.wbkintcolor=0) and (currentformat^.wtxintcolor=0) then
    currentformat^.wtxintcolor:=15;
 if (_in[currentformat^.wputovr]='0') and (inputfieldonlyflag<>'1') then begin
   textcolor(currentformat^.wtxintcolor);
   textbackground(currentformat^.wbkintcolor);
   if currentformat^.wclrline=0 then clrscr
   else begin
     clrlimit:=currentformat^.wscreenrow + currentformat^.wclrline;
     if clrlimit>25 then clrlimit:=25;
     for zscreenrow:=currentformat^.wscreenrow to clrlimit do begin
       gotoxy(1,zscreenrow);
       clreol;
     end;
   end;
   fieldpointer:=currentformat^.firstconstant;
   while fieldpointer<>nil do begin
    calculatescreenoffset(fieldpointer^.screenrow,fieldpointer^.screencol);
    defaultcolor(fieldpointer^.bkcolor,fieldpointer^.txcolor,
      currentformat^.wbkintcolor,currentformat^.wtxintcolor);
    screenoutput(fieldpointer^.constantdata,fieldpointer^.fieldlen,
      fieldpointer^.bkcolor,fieldpointer^.txcolor,fieldpointer^.rvrsimg,
      fieldpointer^.blink);
    fieldpointer:=fieldpointer^.nextfield;
   end;
  end;
  fieldpointer:=currentformat^.firstfield;
  if fieldpointer<>nil then begin
     repeat
      calculatescreenoffset(fieldpointer^.screenrow,fieldpointer^.screencol);
      defaultcolor(fieldpointer^.bkcolor,fieldpointer^.txcolor,
           currentformat^.wbkintcolor,currentformat^.wtxintcolor);
      if ((fieldpointer^.iotype='I') and (_in[currentformat^.wputovr]='0')) or
         ((fieldpointer^.iotype='I') and (_in[currentformat^.wputovr]='1') and
         (_in[currentformat^.weraseinp]='1')) then begin
         inpbuffer:='';
         fillchar(inpbuffer,(fieldpointer^.fieldlen+1),'.');
         inpbuffer[0]:=chr(fieldpointer^.fieldlen);
         screenoutput(inpbuffer,fieldpointer^.fieldlen,fieldpointer^.bkcolor,
         fieldpointer^.txcolor,fieldpointer^.rvrsimg,fieldpointer^.blink);
         if (fieldpointer^.datatype='C') or (fieldpointer^.datatype='R') then
            fillchar(inpbuffer,(fieldpointer^.fieldlen + 1),' ')
         else fillchar(inpbuffer,(fieldpointer^.fieldlen + 1),'0');
         inpbuffer[0]:=chr(fieldpointer^.fieldlen);
      end;
      if (fieldpointer^.iotype='I') and (_in[currentformat^.wputovr]='1') and
         (_in[currentformat^.weraseinp]='0') then begin
         fieldpointer^.iotype:='B';
         checkfield('O',fieldpointer);
         fieldpointer^.iotype:='I';
      end
      else checkfield('O',fieldpointer);
      if (fieldpointer^.iotype<>'I') or ((fieldpointer^.iotype='I') and
         (_in[currentformat^.wputovr]='1') and
         (_in[currentformat^.weraseinp]='0')) then begin
         if (fieldpointer^.datatype = 'S') or (fieldpointer^.datatype = 'E')
         then fieldpointer^.fieldlen:=fieldpointer^.fieldlen + 1;
         if (fieldpointer^.datatype='E') and (fieldpointer^.fielddec>0) then
            fieldpointer^.fieldlen:=fieldpointer^.fieldlen+1;
         repeat
           if length(charoutbuffer)<fieldpointer^.fieldlen then
              charoutbuffer:=charoutbuffer + ' ';
         until length(charoutbuffer)>=fieldpointer^.fieldlen;
         screenoutput(charoutbuffer,fieldpointer^.fieldlen,
            fieldpointer^.bkcolor,fieldpointer^.txcolor,fieldpointer^.rvrsimg,
            fieldpointer^.blink);
         if (fieldpointer^.datatype = 'S') or (fieldpointer^.datatype = 'E')
            then fieldpointer^.fieldlen:=fieldpointer^.fieldlen-1;
         if (fieldpointer^.datatype='E') and (fieldpointer^.fielddec>0)
            then fieldpointer^.fieldlen:=fieldpointer^.fieldlen-1;
      end;
      if _in[fieldpointer^.errorind]='1' then begin
         calculatescreenoffset(25,2);
         screenoutput(fieldpointer^.constantdata,
            (length(fieldpointer^.constantdata)),fieldpointer^.bkcolor,
            fieldpointer^.txcolor,fieldpointer^.rvrsimg,fieldpointer^.blink);
          errorsound(450,350);
      end;
      fieldpointer:=fieldpointer^.nextfield;
      zformatname:=fieldpointer^.fmtname;
     until (currentformat^.wformatname<>zformatname) or (fieldpointer=nil);
     end;
end;

procedure Help(var fieldpointer:fpointer);  {Help Format Display Routine}
  var
    helpnamez:    fmtnamestring;
    counter:      integer;
    firstformat:  formatpointer absolute format1;

  procedure writehelplevel;
    begin
      if helplevel<>0 then begin
         clearbottomline;
         write('Help Level --> ',helplevel:2,' -- Press Any Key To Continue');
         while not keypressed do begin end;
         charin:=readkey;
         if (charin=#0) and (keypressed) then begin
            charin:=readkey;
            if ord(charin)=64 then begin
               if helpnamez<>'        ' then
                  findformat(firstformat,helpnamez);
               help(fieldpointer);
            end;
         end;
      end;
    end;

 begin  {Main Line Of HELP Procedure}
  bottomlinebackground:=currentformat^.wbkintcolor;
  bottomlineforeground:=currentformat^.wtxintcolor;
  helpnamez:=currentformat^.whelpname;
  if helpnamez<>'        ' then begin
     counter:=pos(' ',helpnamez);
     helpnamez[0]:=chr(counter-1);
     savescreen(fieldpointer);
     writescreen(helpnamez);
     writehelplevel;
     restorescreen(fieldpointer);
     writehelplevel;
  end
  else begin
     keyboarderror(7);
     if helplevel>0 then writehelplevel;
  end;
 end;

 procedure setinputcolor(bkcol,txcol,datalength: byte; datatype:char;
           blink:byte);
  var
   setcolor:    byte;
   colorindex:  integer;
   savscroffset: word;
  begin
    savscroffset:=displayadapteroffset+currentoffset;
    setcolor:=backgroundcolortable[txcol + 1] + textcolortable[bkcol + 1];
    if _in[blink]='1' then setcolor:=setcolor+$80;
    if datatype='E' then datalength:=datalength+1;
    for colorindex:=1 to datalength do begin
       savscroffset:=savscroffset + 2;
       mem[displayadaptersegment:savscroffset-1]:=setcolor;
   end;
  end;

 procedure readscreen;
 label fieldloop;
 var
  firstformat: formatpointer absolute format1;

 procedure checktab;
  var
   workpointer: fpointer;
  begin
   if charvalue=15 then begin
      workpointer:=fieldpointer^.prvfield;
      if workpointer=nil then begin
         workpointer:=fieldpointer^.nextfield;
         repeat
           if workpointer<>nil then begin
              fieldpointer:=workpointer;
              workpointer:=workpointer^.nextfield;
           end;
         until workpointer=nil;
         fieldpointer:=fieldpointer^.prvfield;
      end
      else fieldpointer:=workpointer^.prvfield;
   end;
   if (charvalue=9) and (fieldpointer^.nextfield=nil) then fieldpointer:=nil;
 end;

 procedure endoffield;
   begin
    if insertmodeflag='1' then toggleinsertmode;
    if (fieldpointer^.datatype='E') and (fieldpointer^.fielddec>0)
       then fieldpointer^.fieldlen:=fieldpointer^.fieldlen + 1;
    if (columncount=1) and (charvalue=13) then begin
       if (fieldpointer^.datatype='C') or (fieldpointer^.datatype='R')
          then charin:=' '
       else charin:='0';
       inpbuffer:='';
       fillchar(inpbuffer,(fieldpointer^.fieldlen+1),charin);
       inputbufferlength:=fieldpointer^.fieldlen;
       inpbuffer[0]:=chr(inputbufferlength);
    end;
    if ((columncount>1) and (charvalue=13)) or
       ((columncount>1) and (charvalue<>13) and
       (fieldpointer^.datatype<>'C')) then begin
         columncount:=columncount-1;
         inpbuffer:=copy(inpbuffer,1,columncount);
         repeat
          if columncount<fieldpointer^.fieldlen then begin
             columncount:=columncount+1;
             if fieldpointer^.datatype='C' then inpbuffer:=inpbuffer+' '
             else begin
               if fieldpointer^.datatype<>'R' then inpbuffer:='0'+inpbuffer
               else inpbuffer:=' ' + inpbuffer;
             end;
          end;
        until columncount>=fieldpointer^.fieldlen;
       if (fieldpointer^.datatype = 'S') or (fieldpointer^.datatype = 'E')
          then begin
          if ord(charin) = 45 then inpbuffer:=inpbuffer + '-'
          else inpbuffer:=inpbuffer + ' ';
       end;
    end;
    if (columncount=1) and (fieldpointer^.datatype<>'C') and (charvalue<>13)
       and (fieldpointer^.datatype<>'R') then begin
       columncount:=0;
       repeat
         columncount:=columncount+1;
         if inpbuffer[columncount]=' ' then inpbuffer[columncount]:='0';
       until columncount=fieldpointer^.fieldlen;
    end;
    if (fieldpointer^.datatype='E') and (fieldpointer^.fielddec>0)
       then fieldpointer^.fieldlen:=fieldpointer^.fieldlen-1;
    checkfield('I',fieldpointer);
    gotoxy(fieldpointer^.screencol,fieldpointer^.screenrow);
    textcolor(fieldpointer^.txcolor);
    textbackground(fieldpointer^.bkcolor);
    columncount:=0;
    if (fieldpointer^.datatype<>'C') and
       ((fieldpointer^.fielddec +1)<fieldpointer^.fieldlen) then begin
     repeat
       columncount:=columncount+1;
       if inpbuffer[columncount]='0' then inpbuffer[columncount]:=' ';
     until (inpbuffer[columncount]>'0') or
           (columncount=fieldpointer^.fieldlen-(fieldpointer^.fielddec+1));
    end;
    if (fieldpointer^.datatype = 'S') or (fieldpointer^.datatype = 'E')
       then fieldpointer^.fieldlen:=fieldpointer^.fieldlen + 1;
    if fieldpointer^.datatype = 'E' then
       fieldpointer^.fieldlen:=fieldpointer^.fieldlen + 1;
    write(copy(inpbuffer,1,fieldpointer^.fieldlen));
    if (fieldpointer^.datatype = 'S') or (fieldpointer^.datatype = 'E')
       then fieldpointer^.fieldlen:=fieldpointer^.fieldlen-1;
    if fieldpointer^.datatype = 'E' then
       fieldpointer^.fieldlen:=fieldpointer^.fieldlen - 1;
       case charvalue of
         09: checktab;
         15: checktab;
       end;
   end;

 procedure endofline;
   begin
    scolumn:=1;
    srow:=srow+1;
    if srow>24 then begin
       srow:=24;
       scolumn:=80;
       keyboarderror(1);
    end;
   end;

 procedure checkrow;
   begin
    if scolumn>80 then begin
       scolumn:=1;
       srow:=srow+1;
    end
    else begin
      if scolumn<1 then begin
         scolumn:=80;
         srow:=srow-1;
      end;
    end;
   end;

 procedure cursorerror;
   begin
    keyboarderror(2);
    scolumn:=scolumn-offset;
    checkrow;
    gotoxy(scolumn,srow);
   end;

 procedure columnadvance;
    begin
     scolumn:=scolumn+offset;
     checkrow;
     if ((scolumn<fieldpointer^.screencol) and (srow=fieldpointer^.screenrow))
        or ((scolumn>endcolumn) and (srow=endrow)) then cursorerror
     else begin
       if (fieldpointer^.datatype<>'C') and (fieldpointer^.datatype<>'R') and
          (inpbuffer[columncount]=' ') then inpbuffer[columncount]:='0';
       columncount:=columncount+offset;
     end;
     positioncursor;
   end;

 procedure movecursor;
   begin
     if (charvalue=75) or (charvalue=8) or (charvalue=67)
        or (charvalue=92) then offset:=-1;
     if (charvalue=77) or (charvalue=68) or (charvalue=93) then offset:=1;
     columnadvance;
     if (charvalue=92) or (charvalue=93) then columnadvance;
   end;

 procedure enterscreen;  {if capslock or commandkey is pressed end screen}
   begin
     charvalue:=09;
     endoffield;
     if fieldpointer=nil then fieldpointer:=currentformat^.firstfield;
     repeat
       if (fieldpointer<>nil) and (fieldpointer^.nextfield<>nil) then
          fieldpointer:=fieldpointer^.nextfield;
     until fieldpointer^.nextfield=nil;
   end;

 procedure commandkeyproc;
   var cmdindex: integer;
   begin
    { F2--simulated 5250 command key pressed read subsequent command value}
     while not keypressed do begin end;
     commandkey:=readkey;
    {Check For Valid Command Key. Numbers 1-0 and - and =}
     if ((commandkey >= '0') and (commandkey <= '9'))
        or (commandkey = '-') or
        (commandkey = '=') or (ord(commandkey) = 27) then begin
    {Check if escape pressed if yes then ignore command. Esc is CMD reset }
        if ord(commandkey)<>27 then begin
        {setup as though last field had been keyed.}
          cmdindex:=0;
    {Check For Valid Commandkey For This Format}
          repeat
            cmdindex:=cmdindex + 1;
          until (commandkey=currentformat^.wcommandkeymask[cmdindex]) or
                (cmdindex=13);
          if cmdindex=13 then begin
             keyboarderror(8);
             commandkey:=' ';
          end
          else enterscreen;
        end
        else begin
          commandkey:=' ';
          columnadvance;
        end;
     end
     else begin
       commandkey:=' ';
       keyboarderror(10);
       offset:=0;
       columnadvance;
     end;
 end;

  procedure Home; {Set Cursor And counters To 1st Field On Screen}
     begin
       charvalue:=09;
       if inputfieldonlyflag<>'1' then endoffield;
       fieldpointer:=nil;
       columncount:=1;
     end;

  procedure Eraseinput;   {Set Input Field Rewrite Flag & Call Writescreen}
     begin
       inputfieldonlyflag:='1';
       charvalue:=09;
       endoffield;
       writescreen(currentformat^.wformatname);
       Home;
     end;

  procedure Printscreen;
     var
        bytecount: shortint;
        linecount: shortint;
        memloc:    word;
     begin
       memloc:=displayadapteroffset;
       for linecount:=1 to 25 do begin
           for bytecount:=1 to 80 do begin
             write(lst,(chr(mem[displayadaptersegment:memloc])));
             memloc:=memloc + 2;
           end;
           write(lst,(chr(13)),(chr(10)));
       end;
       write(lst,(chr(12)));
     end;

  procedure InsertDeleteWrite;
    begin
      gotoxy(scolumn,srow);
      textcolor(fieldpointer^.bkcolor);
      textbackground(fieldpointer^.txcolor);
      write((copy(inpbuffer,columncount,
            (fieldpointer^.fieldlen+1-columncount))));
      gotoxy(scolumn,srow);
    end;

  procedure Deletechar;
    begin
      delete(inpbuffer,columncount,1);
      inpbuffer:=inpbuffer + ' ';
      insertdeletewrite;
    end;

  procedure Insertchar;
     var   charwork: string[1];
     begin
      if inpbuffer[fieldpointer^.fieldlen]<>' ' then keyboarderror(6)
      else begin
        charwork:=charin;
        inpbuffer:=copy(inpbuffer,1,(fieldpointer^.fieldlen-1));
        insert(charwork,inpbuffer,columncount);
        insertdeletewrite;
        offset:=1;
        columnadvance;
      end;
     end;

 procedure Escape;
   var
     validfunction:   char;
    { Check Characters Following Escape Character And Select An Action}
   begin
     if (charvalue=27) or (charvalue=$00) then begin
        charin:=readkey;
        charvalue:=ord(charin);
     end;
     validfunction:=' ';
     case charvalue of
      15: endoffield;
      67,68: movecursor;     {cursor left on F9 cursor right on F10}
      60: commandkeyproc;    {command key request on F2}
      61: toggleinsertmode;  {F3 Set Insert Mode}
      62: Home;              {F4 ReSet Cursor}
      63: Printscreen;       {F5 Print The Screen}
      64: Help(fieldpointer);{F6 Execute Help Routine}
      85: Commandkeyproc;    {Shift and F2 same as F2}
      86: Deletechar;        {Shift F3 Delete Character At Cursor}
      87: Eraseinput;        {Shift F4 Rewrite Screen Input Fields}
      92,93: movecursor;     {double speed cursor on shift F9/F10}
      59,84: systemrequest;  {system request valid for emulator interface only}
     end;
   end;

 procedure managekeyboardstatus;  {check and/or set keyboard status byte}
   var
    keyboardstatus:         byte absolute $0040:$0017;
    capslockstatus:         byte absolute $0040:$0018;
   begin
     {check for Alt key pressed and reset insertmode}
     if (keyboardstatus and $08)<>0 then begin
        if insertmodeflag='1' then toggleinsertmode;
        keyboardstatus:=keyboardstatus xor $08;
     end;
     {check for capslock and end screen and reset caps state if pressed}
     if (capslockstatus and $40)<>0 then begin
        enterscreen;
        keyboardstatus:=keyboardstatus xor $40;
     end;
     {check if numlock pressed. if yes treat as field back (back tab)}
     if (capslockstatus and $20)<> 0 then begin
        charvalue:=15;
        keyboardstatuschange:='1';
        capslockstatus:=capslockstatus xor $20;
     end;
     {check control key if pressed toggle caps lock state and reset ctrl}
     if ((keyboardstatus and $04)<>0) then
         keyboardstatus:=keyboardstatus xor $44;
     {check and ensure numlock is set}
     if (keyboardstatus and $20)=0 then keyboardstatus:=keyboardstatus xor $20;
   end;

 procedure checkforpositioncursor;
   begin
     fieldpointer:=currentformat^.firstfield;
     while (fieldpointer<>nil) and (_in[fieldpointer^.position]<>'1') do
       fieldpointer:=fieldpointer^.nextfield;
       if (fieldpointer<>nil) and (_in[fieldpointer^.position]='1') then
          fieldpointer:=fieldpointer^.prvfield;
   end;

 begin  { Main Line Of Read Screen Procedure }
   if currentformat^.wformatname<>usefmtname then
      findformat(firstformat,usefmtname);
   fieldpointer:=nil;
   checkforpositioncursor;
   fieldloop: inputfieldonlyflag:=' ';
   if fieldpointer<>nil then fieldpointer:=fieldpointer^.nextfield
   else fieldpointer:=currentformat^.firstfield;
   if fieldpointer<>nil then begin
      if (fieldpointer^.iotype='O') or (_in[fieldpointer^.protect]='1')
        then begin
         if (charvalue=15) or (charvalue=09) then checktab;
         goto fieldloop;
      end;
      charvalue:=0;
      srow:=fieldpointer^.screenrow;
      scolumn:=fieldpointer^.screencol;
      endrow:=fieldpointer^.screenrow;
      endcolumn:=scolumn+fieldpointer^.fieldlen;
      if (fieldpointer^.datatype='E') and (fieldpointer^.fielddec>0)
         then endcolumn:=endcolumn + 1;
      if endcolumn>80 then begin
         endcolumn:=endcolumn-80;
         endrow:=endrow+1;
      end;
      columncount:=1;
      checkfield('U',fieldpointer);
      calculatescreenoffset(fieldpointer^.screenrow,fieldpointer^.screencol);
      setinputcolor(fieldpointer^.bkcolor,fieldpointer^.txcolor,
        fieldpointer^.fieldlen,fieldpointer^.datatype,fieldpointer^.blink);
      gotoxy(fieldpointer^.screencol,fieldpointer^.screenrow);
      repeat
        _in[100]:='0';
        managekeyboardstatus;
        if (keypressed) or (keyboardstatuschange='1') then begin
           if kbderrorflag='1' then begin  {reset default colors after}
              textcolor(currentformat^.wtxintcolor);
              {writing error message and }
              textbackground(currentformat^.wbkintcolor);
              {clear error message text}
              clearbottomline;
              kbderrorflag:=' ';
            end;
            textcolor(fieldpointer^.txcolor);
            textbackground(fieldpointer^.bkcolor);
            if keypressed then begin
               charin:=readkey;
               charvalue:=ord(charin);
               if fieldpointer^.lowercas<>'Y' then charin:=upcase(charin);
            end;
            keyboardstatuschange:=' ';
            case charvalue of
               0,27: escape;
                 08: movecursor;  {cursor left}
           09,13,15: endoffield;  {horizontal tab,return,tabback/numlock}
           else
              if ((fieldpointer^.datatype<>'C') and (charvalue=43)) or
                 ((fieldpointer^.datatype<>'C') and
                 (fieldpointer^.datatype<>'N') and (charvalue = 45))
                 then begin
                   charvalue:=13;
                   endoffield;
               end
               else begin
                  gotoxy(scolumn,srow);
                  if (scolumn=endcolumn) and (srow>=endrow) then begin
                     keyboarderror(4);
                     setinputcolor(fieldpointer^.bkcolor,fieldpointer^.txcolor,
                                   1,fieldpointer^.datatype,100);
                     write(' ');
                     gotoxy(scolumn,srow);
                  end
                  else begin
                    if ((fieldpointer^.datatype<>'C') and
                        (fieldpointer^.datatype<>'R')) and ((charin<'0') or
                        (charin>'9')) then begin
                       if (fieldpointer^.datatype='N') or
                          (fieldpointer^.datatype='S') then _In[100]:='1';
                       if (fieldpointer^.datatype='E') and (charin<>'.') then
                          _In[100]:='1';
                    end;
                    if _in[100]='1' then keyboarderror(5)
                    else begin
                      if insertmodeflag='1' then insertchar
                      else begin
                        write(charin);
                        inpbuffer[columncount]:=charin;
                        offset:=1;
                        columnadvance;
                      end;
                    end;
                  end;
                end;
              end;
           end; {end of if key pressed}
     until (charvalue=13) or (charvalue=09) or (charvalue=15);
     charin:=' ';
     goto fieldloop;
     end;
    end;  {end of fields to be processed}

procedure screenio;
begin
writescreen(usezfmtname);
firsthelpscreen:=nil;
readscreen(usezfmtname);
end;

procedure initialize38;
 begin
  if inzscreen<>'1' then begin
     statusmessage:='Screen File Not Opened. Job Aborted';
     emulatorstatusmessage;
     halt
  end;
 end;

procedure copyfield (bytecount,nofield: integer; fieldpointer:fpointer);
  var
    index:          integer;
    inpworkoffset:  integer;
    numericinput:   char;
  begin
    numericinput:=' ';
    if nofield=1 then begin
       if fieldpointer^.datatype='E' then begin
          bytecount:=bytecount + 2;
          numericinput:='Y';
       end;
       if fieldpointer^.datatype='S' then begin
          bytecount:=bytecount + 1;
          numericinput:='Y';
       end;
       if fieldpointer^.datatype='N' then numericinput:='Y';
    end;
    inpworkoffset:=inpbufferoffset;
    currentoffset:=(currentoffset + screenoffset) - 1;
    for index:=1 to bytecount do begin
      mem[inpbuffersegment:inpworkoffset]:=
      mem[em5250segment:(ebcdictableoffset + mem[em5250segment:currentoffset +
      index])];
      if mem[inpbuffersegment:inpworkoffset]=$FF then
      mem[inpbuffersegment:inpworkoffset]:=$20;
      if (numericinput='Y') and (mem[inpbuffersegment:inpworkoffset]=$20) then
         mem[inpbuffersegment:inpworkoffset]:=$30;
      inpworkoffset:=inpworkoffset + 1;
    end;
    currentoffset:=(currentoffset - screenoffset) + 1;
    inpbuffer[0]:=chr(bytecount);
  end;

procedure select38format (selectrow,selectcolumn,idlen: shortint);

  var
   blanks:           string[8];
   firstformat:      formatpointer absolute format1;
   errorcount:       integer;
   dummyptr:         fpointer;
  begin
    blanks:='        ';
    blanks[0]:=chr(idlen);
    if inz38flag<>'1' then initialize38; {initialize emulator card variables}
    checkinputinhibit;                   {check emulator input inhibited ind.}
    calculateoffset(selectrow,selectcolumn); {calculate offset to screen id.}
    copyfield(idlen,0,dummyptr);         {copy in emulator screen id }
    findformat(firstformat,(copy(inpbuffer,1,idlen)));
    if (currentformat=nil) or (copy(inpbuffer,1,idlen)=blanks) then begin
       statusmessage:='PC To S/38 I/O Error - No Format Match';
       for errorcount:=1 to 25 do emulatorstatusmessage;
       halt;
    end;
  end;

procedure setio (setioflag: char; fieldpointer: fpointer);
   begin
     calculateoffset(fieldpointer^.screenrow,fieldpointer^.screencol);
     if setioflag='I' then copyfield(fieldpointer^.fieldlen,1,fieldpointer);
     checkfield(setioflag,fieldpointer);
   end;

procedure read38;
 {determine s38 format id, retrieve format & read variables}
  var
    firstformat:    formatpointer absolute format1;
  begin
    currentformat:=firstformat;
    select38format(idrow,idcol,idlen); {locate PC format}
    fieldpointer:=currentformat^.firstfield;
    repeat
     if fieldpointer^.iotype<>'I' then setio('I',fieldpointer);
     fieldpointer:=fieldpointer^.nextfield;
    until fieldpointer=nil;
  end;

procedure sendcommandkey;
  var
    saveinteger,index: integer;
    savebyte: byte;
  begin
    sendfieldexit(commandcode);
    case commandkeyx of
     '0': saveinteger:=10;
     '-': saveinteger:=11;
     '=': saveinteger:=12;
     else val(commandkeyx,saveinteger,index);
     end;
     savebyte:=saveinteger + $30;
     sendfieldexit(savebyte);
  end;

procedure write38;
  {write variables to emulator screen buffer and send the enter scan code}
 var
  savebyte:      byte;
  saveinteger:   integer;
  signsave:      char;
  index:         integer;
  teststring:    string[10];
  datatype:      char;
 begin
  select38format (idrow,idcol,idlen);
  fieldpointer:=currentformat^.firstfield;
  sendfieldexit(fieldadvancecode); {miss position 5250 cursor so}
  sendfieldexit(cursorrightcode);  {that home key will work }
  sendfieldexit(homecursorcode); {ensure 5250 cursor is in 1st Field}
  repeat
    if fieldpointer^.iotype<>'O' then begin
      datatype:=fieldpointer^.datatype;
      setio ('U',fieldpointer);
      signsave:=' ';
      if (datatype='N') or (datatype='S') or (datatype='E') then begin
        if (datatype<>'N') then begin
          if inpbuffer[(length(inpbuffer))]='-' then begin
             signsave:='-';
             inpbuffer:=copy(inpbuffer,1,(length(inpbuffer)-1));
          end;
        end;
        for index:=1 to (length(inpbuffer)) do
          if inpbuffer[index]=' ' then inpbuffer[index]:='0';
        if (datatype='N') and (fieldpointer^.fielddec>0) then begin
          saveinteger:=fieldpointer^.fieldlen-fieldpointer^.fielddec;
          teststring:=copy(inpbuffer,(saveinteger + 1),fieldpointer^.fielddec);
          inpbuffer:=(copy(inpbuffer,1,(saveinteger))) + '.';
          inpbuffer:=inpbuffer + teststring;
        end;
      end;
      calculateoffset(fieldpointer^.screenrow,fieldpointer^.screencol);
      for index:=1 to length(inpbuffer) do begin
         savebyte:=ord(inpbuffer[index]) + 1;
         if signsave<>'-' then begin
            mem[em5250segment:(screenoffset + currentoffset)]:=
            asciitranslatetable[savebyte];
            currentoffset:=currentoffset + 1;
         end
         else sendfieldexit(scancode5250table[savebyte]);
      end;
      if block38=' ' then begin
        if signsave<>'-' then sendfieldexit(fieldadvancecode)
        else sendfieldexit(fieldminuscode);
      end;
    end;
    fieldpointer:=fieldpointer^.nextfield;
  until fieldpointer=nil;
  while mem[em5250segment:keyo]<>$00 do begin end; {wait for keyboard available}
  if commandkey=' ' then sendfieldexit(entercode)
  else sendcommandkey(commandkey);
 end;

 procedure copyscreen;
 {copies emulated 5250 screen buffer character for character from
 the starting row/column through and including the ending row column
 attribute bytes in the emulated screen are checked for and dropped}
 var
  endaddress:    word;
  bufferindex:   integer;
  bytecount:     integer;
  dummyptr:      fpointer;
 const
  screensegment: word = $B000;
  coloroffset:   word = $8000;
 begin
   coloroffset:=displayadapteroffset;
   if inz38flag<>'1' then initialize38;
   checkinputinhibit;
   calculateoffset(endrow,endcolumn);
   endaddress:=currentoffset;
   calculateoffset(startrow,startcolumn);
   textcolor(15);
   textbackground(1);
   coloroffset:=currentoffset + currentoffset + coloroffset;
   bytecount:=(endaddress-currentoffset) + 1;
   if bytecount>80 then bytecount:=80;
   repeat
     copyfield(bytecount,0,dummyptr);
     for bufferindex:=1 to bytecount do begin
       mem[screensegment:coloroffset]:=
       mem[inpbuffersegment:inpbufferoffset + (bufferindex-1)];
       coloroffset:=coloroffset + 2;
     end;
     currentoffset:=currentoffset + bytecount;
   until currentoffset>=endaddress;
   coloroffset:=displayadapteroffset;
 end;

procedure check38;
 var endrow,endcol: shortint;
 begin
   endrow:=startrow;
   endcol:=startcol+lengthx-1;
   if endcol>80 then begin
      endrow:=endrow + 1;
      endcol:=endcol-80;
   end;
   copyscreen(startrow,startcol,endrow,endcol);
   rtnformat:=copy(inpbuffer,1,lengthx);
 end;

begin
  inpbuffersegment:=seg(inpbuffer);
  inpbufferoffset:=ofs(inpbuffer) + 1;
  inz38flag:='1';
  em5250segment:=memw[0000:$0036];
  screenoffset:=memw[em5250segment:$0146];
  ebcdictableoffset:=memw[em5250segment:$0140];
  fillchar(blanktest,81,' ');
  blanktest[0]:=chr(80);
  while mem[em5250segment:systemavailable]=0 do begin
    statusmessage:='Waiting For System Available';
    emulatorstatusmessage;
  end;
end.