GETCHAR:  PROC(PROMPT_STRING,CHARS_NEEDED,VERIFY_STRING)
          RETURNS(CHAR(*) VARYING);

/* PROCEDURE PROMPTS FOR A CHARACTER STRING.
   IF VERIFY_STRING IS NOT NULL PROCEDURES CHECKS TO
   MAKE SURE THAT ALL CHARACTERS ENTERED ARE CONTAINED
   IN THE STRING.  CONVERSION TO UPPER CASE IS ALSO PERFORMED
   DIRECT CALLS TO QIOW ARE USED RATHER THAN RMS.
   AUTHOR:  AL JAWORSKI
   DATE:    2/24/82 */

DCL (VERIFY_STRING,PROMPT_STRING) CHAR(*) VARYING;
DCL CHARS_NEEDED FIXED BINARY(31);
DCL (P,Q) POINTER;
DCL RETURN_STRING CHAR(CHARS_NEEDED) VARYING BASED(P);
ALLOC RETURN_STRING SET(P);
DCL CHAR_BUF CHAR(CHARS_NEEDED) BASED(Q);
ALLOC CHAR_BUF SET(Q);
DCL GOT_CHAR BIT(1);

DCL TTCHAN FIXED BINARY(15) GLOBALREF;
DCL (IO$_READLBLK,IO$M_TRMNOECHO) FIXED BINARY(31) GLOBALREF VALUE;

DCL 1 IOSB,
      2 VALUE FIXED(15),
      2 BYTES_RECEIVED FIXED(15),
      2 NOT_USED FIXED(31);

DCL IO_SUCCESS BIT(1) ALIGNED BASED(ADDR(IOSB));

%INCLUDE $STSDEF;
%INCLUDE TESTCHAN;
%INCLUDE UPPER;
%INCLUDE SYS$QIOW;

CALL TESTCHAN;

GOT_CHAR='0'B;

DO WHILE(^GOT_CHAR);

  CHAR_BUF=' ';
  PUT EDIT(PROMPT_STRING)(SKIP,A);
  STS$VALUE=SYS$QIOW(,TTCHAN,IO$_READLBLK+IO$M_TRMNOECHO
                     ,IOSB,,,Q,CHARS_NEEDED,,,,);
  IF STS$SUCCESS THEN DO;
    RETURN_STRING=SUBSTR(CHAR_BUF,1,BYTES_RECEIVED);
    RETURN_STRING=UPPER(RETURN_STRING);
  END;
  ELSE DO;
    PUT EDIT('Please reenter response')(SKIP,A);
    RETURN_STRING='';
  END;

  IF VERIFY_STRING='' | VERIFY(RETURN_STRING,UPPER(VERIFY_STRING))=0
    THEN GOT_CHAR='1'B;
  ELSE PUT EDIT(COPY(BYTE(7),3),'Invalid response--',RETURN_STRING)
               (SKIP,3 A);

END;

RETURN(RETURN_STRING);

END GETCHAR;