program:  PROC   options(main);

  %replace onn by '0';     /* Make a field visible. */
  %replace off by '1';     /* Make a field invisible. */
  %replace lst_sz by 50;     /* size of parts list */

  /* Include the Display Manager runtime library definitions. */
  %include 'dmextr.pli';
                         /*     12345678901234  */
dcl  tabs static char(14) init('              '); /*tabs for output */

dcl
    (phone_order,
     order_no,
     page,
     part_fb15,
     cnt,
     CLRSCR_ret,
     ret,
     ret_err,
     helpf)	fixed;

dcl
    (qty_dec,     /* quantity of each item */
     price_ea_dec)      /* normal price output, but there may be a sale */
          fixed dec (6,2);  /* max is 9,999.99  */
dcl
     total_dec(0:4)         /* QTY times PRICE_EA */
         fixed dec (7,2);     /* max is 99,999.99 */
dcl 
     sale_dec  fixed dec (8,2);   /* max is 999,999.99  */

dcl term250_str  char (250) var;
 
dcl putf132_str char(132) var;

dcl
    (initdm_str,
     temp,
     retf60_str,
     dispd_str,
     opndis_str,
     posf_str,
     nxtf_str,
     putf_str,
     cur_str,
     CLSDIS_str,
     customer,   /* customer name */
     address,
     city,
     state,
     zip, 	/* validated for numerical value */
     phone,        /* numerical */
     payment(0:1),    /* method of payment and account no. */
     qty(0:4),     /* quantity of each item */
     price_ea(0:4),      /* normal price output, but there may be a sale */
     total(0:4),         /* QTY times PRICE_EA */
     sale,   /* max is 999,999.99  */
     description(0:4),    /* brief written description */
     part_no_chr60(0:4),      /* 5-digit number, checked for validity */
     part_lst(0:lst_sz,0:1),
     price(lst_sz))		char(60) var;     /* All data entered w/ GETF &
						     UPDF is in string form. */

 dcl 
    (prm_off,
     prm_on,
     retf16_str,     
     avail_attr)
                char(16) var;

dcl
    curstat char(1) var ;

dcl  
    (file_1,
     file_2)			file;



/*****************************************************************************/
/* The following corresponds to lines  34- 64 in the CB-80 sample program.   */
/*****************************************************************************/

  /* Get the screen-handling control code from the installation file. */
  on undefinedfile (file_1) 
      go to err1;   /* no term file, abort */
  on endfile (file_1) go to err1;
  open file (file_1) stream input title('current.trm');
  get file (file_1) edit(term250_str) (a);
  close file (file_1);

  /* Set up the list of part numbers. */
  on undefinedfile (file_2) go to err2;   /* no input file, abort */
  open file(file_2) stream input title('parts.lst');
  on endfile (file_2) go to s_ls;
  do cnt=0 to lst_sz-1;
    get file(file_2) list(part_lst(cnt,0),part_lst(cnt,1),price(cnt));
 end;

s_ls:
  part_lst(cnt+1,0)='';    /* indicates end of list */
  close file(file_2);

  /* Assign display numbers. These can be changed as needed. */
  phone_order=1;     /* main display */
  helpf=2;	/* main part number reference */

  /* Set error output messages for fatal Display Manager errors. */
  initdm_str='ERROR: Initialization failure';
  opndis_str='ERROR: Display file not found';
  dispd_str='ERROR: Display not found';
  posf_str='ERROR: Field missing';
  nxtf_str='ERROR: Next field missing';
  putf_str='ERROR: Write to field failure';
  cur_str='ERROR: Cursor On/Off failure';
  CLSDIS_str='ERROR: Can''t close display file';



/*****************************************************************************/
/* The following corresponds to lines  65-122 in the CB-80 sample program.   */
/*****************************************************************************/

  /* Most DM functions return -1 if there is an error. */
  /* They are fatal, so abort. */
  dm_err:  PROC  (f_ret,err_type);
    dcl
      err_type char(60) var,
      f_ret fixed;
    if f_ret>=0 then
      return;           /* not an error */
    put skip(2) list(err_type);
    stop;     /* It's fatal, so abort. */
  end dm_err;

  /* If the part number exists, return it. */
  search:  PROC  (part_no_chr60) returns(fixed);
    dcl
      part_no_chr60  char(60) var;
    do cnt=0 to lst_sz-1;   /* returns the array index */
      if part_lst(cnt,0)=part_no_chr60 then
        return(cnt);
      if part_lst(cnt,0)='' then
        go to elst;
    end;
    elst:
    return(-1);
  end search;
 
  /* Move relative to the next input field, turn on the prompt, & get input. */
  get_entry:    PROC   returns(char(60) var);
    dcl inp60_local   char(60) var;
    ret_err=nxtf(2);    /* next input field */
    call dm_err(ret_err,nxtf_str);
    avail_attr=setf(prm_on);     /* Turn on the prompt. */
    inp60_local=getf();     /* Input from the field. */
    cont:
    if endf()=27 then     /* escape key to exit */
      do;
        CLRSCR_ret = CLRSCR();    /*added11-8*/ 
        ret_err=CLSDIS();
        call dm_err(ret_err,CLSDIS_str);
        stop;
      end;
    if endf()^=0 & endf()^=26 then    /* control character, not ctrl-Z */
      go to retr;	/* Ignore the character and continue. */
    avail_attr=setf(prm_off);      /* Turn off the prompt. */
    return(inp60_local);
  retr:
    retf60_str=resf(-1);    /* Save the position. */
    inp60_local=resf(1);    /* Resume input. */
    go to cont;     /* Continue. */
  end get_entry;

  err_msg:  PROC  (pos,onoff);
    dcl
      pos fixed,
      onoff char(1);
    ret=posf(0);    /* Store the current position. */
    ret_err=posf(pos);
    call dm_err(ret_err,posf_str);
    avail_attr=setf(onoff);	/* Turn the message on/off. */
    ret_err=posf(ret);    /* Return to the original position. */
    call dm_err(ret_err,posf_str);
  end err_msg;

/*****************************************************************************/
/*     S T A R T           P R O G R A M            H E R E                  */
/*****************************************************************************/


/*****************************************************************************/
/* The following corresponds to lines 123-232 in the CB-80 sample program.   */
/*****************************************************************************/


  ret_err=initdm(term250_str);    /* Initialize the library. */
  call dm_err(ret_err,initdm_str);
  avail_attr=retdm();      /* Which CRT attributes are available? */
  if substr(avail_attr,3,1)^='0' then    /* If inverse video is supported */
    do;
      prm_on='031';
      prm_off='330';    /* then use it for prompts */
    end;
  else
    do;
      prm_on='0';
      prm_off='3';    /* just initials */
    end;


  /* Open the display file, show it, and move to the first field. */
  ret_err=opndis('ORDERS.DIS');      /* Open the file. */
  call dm_err(ret_err,opndis_str);
loop:
  ret_err=dispd(phone_order);		/* Show the display. */
  call dm_err(ret_err,dispd_str);
  ret_err=nxtf(-10);		   /* 1st field */
  call dm_err(ret_err,nxtf_str);

  /* All prompts are inverse video if possible, or underlined otherwise. */
  customer=get_entry();		/* Use relative movement */
  address=get_entry();		/* and GETF */
  city=get_entry();
  state=get_entry();        /* alphabetic only */
  zip=get_entry();	/* numerical validation by DM */
  phone=get_entry();
paym:
  payment(0)=get_entry();    /* A, B, or C only */
				/* A null string is also not a valid entry. */
  if index('ABC',payment(0))=0 ! payment(0)='' then
    do;
      call err_msg(100,onn);
      ret_err=nxtf(-2);
      call dm_err(ret_err,nxtf_str);    /* Output an error message */
      go to paym;			/* and re-try. */
    end;
  else
    do;
      ret_err=nxtf(3);
      call dm_err(ret_err,nxtf_str);    /* Go to next column. */
    end;
  if payment(0)='A' then
    do;  /* It's a personal credit account. */
      putf132_str = 'CCOUNT';  
      ret_err=putf(putf132_str);   /* Show the rest of the word. */
      payment(1)=get_entry();    /* Get the account number. */
    end;
  else
    if payment(0)='B' then    /* bank credit card */
      do;
        putf132_str = 'ANK CARD';
        ret_err=putf(putf132_str);
        call dm_err(ret_err,putf_str);
        payment(1)=get_entry();
      end;
    else
      if payment(0)='C' then    /* cash on delivery */
        do;
          putf132_str = '.O.D.';
          ret_err=putf(putf132_str);
          call dm_err(ret_err,putf_str);
        end;
  call err_msg(100,off);     /* Turn it off. */

  /* Take the order now. */
  ret_err=posf(75);	/* Turn on the message */
  call dm_err(ret_err,posf_str);     /* about the ending entry. */
  avail_attr=setf('0');
  order_no=0;    /* up to 5 */
ordr:
  qty(order_no)=get_entry();    /* quantity of items */
  if qty(order_no)='0' then	/* Stop entry. */
    go to ttls;
  description(order_no)=get_entry();
  call err_msg(76,onn);     /* control-Z reference message */
part_lbl:
  part_no_chr60(order_no)=get_entry();      /* only for this input */
hret:
  if endf()=26 then    /* control-z for part number refernce display */
    call help();
  part_fb15 = search(part_no_chr60(order_no));   /* complete input */
  if part_fb15 =-1 then    /* not a valid part number */
    do;
      call err_msg(101,onn);
      ret_err=nxtf(-2);
      call dm_err(ret_err,nxtf_str);
      go to part_lbl;  /* Re-try. */
    end;
  call err_msg(101,off);  /* Turn off the error message. */
  call err_msg(76,off);  /* Turn off the control-z message. */
  ret_err=nxtf(2);     /* Write the normal price. */
  call dm_err(ret_err,nxtf_str);
  putf132_str = price(part_fb15);
  ret_err=putf(putf132_str);
  call dm_err(ret_err,putf_str);
  avail_attr=setf(prm_on);
 ptry:
  price_ea(order_no)=updf();    /* If it's a CR, get the initial value. */
  avail_attr=setf(prm_off);
  ret_err=nxtf(3);      /* the field for the total */
  call dm_err(ret_err,nxtf_str);
  qty_dec = qty(order_no);
  price_ea_dec = price_ea(order_no);
  total_dec(order_no) = qty_dec * price_ea_dec;
  total(order_no) = total_dec(order_no);
  total(order_no) = substr(total(order_no),3);
  putf132_str = total(order_no);
  ret_err=putf(putf132_str);
  call dm_err(ret_err,putf_str);
  order_no=order_no+1;    /* Only 5 are allowed. */
  if order_no < 5 then		/* can break w/QTY = 0 */
    go to ordr;
  order_no=4;	/* Only 0 to 4 are allowed. */
 ttls:
  sale_dec =0;
  do cnt=0 to order_no;     /* Calculate the total bill. */
    sale_dec = sale_dec + total_dec(cnt);
  end;
  sale = sale_dec;
  sale = substr(sale,3); 
  ret_err=posf(26);
  call dm_err(ret_err,posf_str);
  putf132_str = sale;
  ret_err=putf(putf132_str);              /* Write the total sale. */
  do cnt= 0 to order_no;
     total_dec(cnt) = 0;                /* zero out intermediate totals */
     end;
  call dm_err(ret_err,putf_str);
  ret_err=nxtf(20);		/* wait until ready */
  call dm_err(ret_err,nxtf_str);
  avail_attr=setf('0');		/* Turn on the prompt. */
  retf60_str=getf();		/* Wait for a carriage return. */
  if endf()=27 then
    go to done;

  /* output data to file */
  go to loop;       /* next order */

/*****************************************************************************/
/* The following corresponds to lines 233-249 in the CB-80 sample program.   */
/*****************************************************************************/

  writef:  PROC  (out);
    dcl
      out char(60) var;
    ret_err=nxtf(2);	/* Go to input field. */
    call dm_err(ret_err,nxtf_str);
    avail_attr=setf('0');	/* Turn on the field. */
    putf132_str = out;
    ret_err=putf(putf132_str);	/* Put in the old data. */
    call dm_err(ret_err,putf_str);
    retf16_str=retf();		/* Check if it's a payment. */
    if posf(0) = 8 then        /* Output the rest in the adjoining
					 field. */
      do;
        ret_err=nxtf(3);
        call dm_err(ret_err,nxtf_str);
        putf132_str = substr(out,2,length(out));
        ret_err=putf(putf132_str);
        call dm_err(ret_err,putf_str);
      end;
  end writef;




/*****************************************************************************/
/* The following corresponds to lines 250-310 in the CB-80 sample program.   */
/*****************************************************************************/

help:  PROC  ;		/* Save your place. */
    retf60_str=resf(-1);	/* Show the part number list. */
    curstat = curs(off);
    ret_err=dispd(helpf);
    call dm_err(ret_err,dispd_str);
  firs:
    cnt=0;
    page=22;	/* Write out the list. */
  nxtl:        
    ret_err=posf(cnt+1);
    call dm_err(ret_err,posf_str);
    if part_lst(cnt,0) ^= '' then         /* Output to the end of the list. */
      do;
        temp=part_lst(cnt,0)||tabs||part_lst(cnt,1);
        putf132_str = temp;
        ret_err=putf(putf132_str);
        call dm_err(ret_err,putf_str);
        avail_attr =  setf('0');
      end;
    else
      cnt=-1;
    cnt=cnt+1;
    if cnt ^= 0 & cnt < 22 then
      go to nxtl;
ret_err=posf(100);     /* next page, or exit */
    call dm_err(ret_err,posf_str);
    retf60_str=getf();
    if retf60_str=ascii(27) then
      go to reds;    /* escape, return */
    if retf60_str=ascii(26) then
      if cnt=0 then    /* control-Z, next with wrap */
        go to firs;
    page=page+21;    /* next page */
    cnt = 0;
    go to nxtl;
  reds:      /* bring back old display */
    ret_err=dispd(phone_order);
    call dm_err(ret_err,dispd_str);
    ret_err=nxtf(-10);                 /* 1st field, then 1st */
    call dm_err(ret_err,nxtf_str);     /* in field to write   */
    call writef(customer);             /* old data to         */
    call writef(address);
    call writef(city);
    call writef(state);
    call writef(zip);
    call writef(phone);
    
    if payment(0)  = 'A' then 
      go to acct;
    else if payment(0)  = 'B' then go to bank  ;
         else if payment(0)   = 'C' then 
            go to pcod  ;

acct:
    call writef('ACCOUNT');       /* special handling */
    call writef(payment(1));      /* done in writef   */
    go to hcon;
  bank:
    call writef('BANK CARD');
    call writef(payment(1));
    go to hcon;
  pcod:
    call writef('C.O.D.');
    ret_err=nxtf(2);                 /* pass acount number */
    call dm_err(ret_err,nxtf_str);
hcon:
    call err_msg(75,onn);  /* QTY exit message */
    do cnt=0 to order_no-1;	/* Write any       */
      call writef(qty(cnt));    /* previous items. */
      call writef(description(cnt));
      call writef(part_no_chr60(cnt));
      call writef(price_ea(cnt));
      ret_err=nxtf(3);            /* total is output -- */
      call dm_err(ret_err,nxtf_str);  /* field, not input   */
      putf132_str = total(cnt);       
      ret_err=putf(putf132_str);
    end;
    call writef(qty(order_no));         /* line in progress */
    call writef(description(order_no));
    call writef(part_no_chr60(order_no));
    avail_attr = setf(prm_on);
    curstat =  curs(onn);
    part_no_chr60(order_no) = resf(1);
    avail_attr = setf(prm_off);
    goto hret;
  end help;


/*****************************************************************************/
/* The following corresponds to lines 311-319 in the CB-80 sample program.   */
/*****************************************************************************/

  err1:
  put list('ERROR: No current terminal file');
  put list('(put control code in "CURRENT.TRM")');
  stop;     /* no terminal codes */
  err2:
  put list('ERROR: No part no. reference file');
  stop;     /* no price list -- */
  done:
  CLRSCR_ret =  CLRSCR();
  ret_err=CLSDIS();     /* close display file */
  call dm_err(ret_err,CLSDIS_str);
  stop;

end program;