From:	CSBVAX::MRGATE!MRL%PFC-VAX.MIT.EDU%XX.LCS.MIT.EDU@EDDIE.MIT.EDU@SMTP 16-AUG-1988 12:49
To:	ARISIA::EVERHART
Subj:	BULLETIN9.FOR


Received: from deep-thought.mit.edu by EDDIE.MIT.EDU via Chaosnet with MAIL with sendmail-5.45/4.7 id <AA05597@EDDIE.MIT.EDU>; Tue, 16 Aug 8
8 10:45:42 EDT
Message-Id: <8808161445.AA05597@EDDIE.MIT.EDU>
Received: from PFC-VAX.MIT.EDU by DEEP-THOUGHT.MIT.EDU via Chaosnet; 16 Aug 88 10:45-EDT
Date: 16 Aug 88 10:44:52 EDT
From: MRL%PFC-VAX.MIT.EDU%XX.LCS.MIT.EDU@EDDIE.MIT.EDU
To: TENCATI@VLSI.JPL.NASA.GOV@EE, MHG@MITRE-BEDFORD.ARPA@EE,
        EVERHART%ARISIA.DECNET@GE-CRD.ARPA@EE, GAYMAN@ARI-HQ1.ARPA@EE
Subject: BULLETIN9.FOR

C
C  BULLETIN9.FOR, Version 6/22/88
C  Purpose: Contains subroutines for the bulletin board utility program.
C  Environment: MIT PFC VAX-11/780, VMS
C  Programmer: Mark R. London
C
	SUBROUTINE CRELNM(INPUT,OUTPUT)
	
	IMPLICIT INTEGER (A-Z)

	INCLUDE '($PSLDEF)'

	INCLUDE '($LNMDEF)'

	CHARACTER*(*) INPUT,OUTPUT

	CALL INIT_ITMLST
	CALL ADD_2_ITMLST(LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT))
	CALL END_ITMLST(CRELNM_ITMLST)

	IER = SYS$CRELNM(,'LNM$PROCESS',INPUT,PSL$C_USER,
     &		%VAL(CRELNM_ITMLST))

	RETURN
	END



	SUBROUTINE GETPRIV
C
C  SUBROUTINE GETPRIV
C
C  FUNCTION:
C	To get process privileges.
C  OUTPUTS:
C	PROCPRIV - Returned privileges
C

	IMPLICIT INTEGER (A-Z)

	COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2)

	INCLUDE '($JPIDEF)'

	CALL INIT_ITMLST	! Initialize item list
	CALL ADD_2_ITMLST(8,JPI$_PROCPRIV,%LOC(PROCPRIV))
	CALL END_ITMLST(GETJPI_ITMLST)	! Get address of itemlist

	IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info

	RETURN
	END




	LOGICAL FUNCTION SETPRV_PRIV
	IMPLICIT INTEGER (A-Z)

	COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2)
	DATA NEEDPRIV/0,0/

	INCLUDE '($PRVDEF)'

	INCLUDE 'BULLUSER.INC'

	IF (NEEDPRIV(1).EQ.0.AND.NEEDPRIV(2).EQ.0) THEN
	   CALL OPEN_FILE_SHARED(4)		! Get BULLUSER.DAT file
	   CALL READ_USER_FILE_HEADER(IER)
	   CALL CLOSE_FILE(4)
	   NEEDPRIV(1) = USERPRIV(1)
	   NEEDPRIV(2) = USERPRIV(2)
	END IF

	IF ((PROCPRIV(1).AND.NEEDPRIV(1)).GT.0.OR.
     &	    (PROCPRIV(2).AND.NEEDPRIV(2)).GT.0) THEN
	   SETPRV_PRIV = .TRUE.
	ELSE
	   SETPRV_PRIV = .FALSE.
	END IF

	RETURN
	END



	LOGICAL FUNCTION OPER_PRIV
	IMPLICIT INTEGER (A-Z)
	COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2)
	INCLUDE '($PRVDEF)'
	OPER_PRIV = BTEST(PROCPRIV(1),PRV$V_OPER)
	RETURN
	END



 
	SUBROUTINE GETUSER(USERNAME)
C
C  SUBROUTINE GETUSER
C
C  FUNCTION:
C	To get username of present process.
C  OUTPUTS:
C	USERNAME   -   Username owner of present process.
C

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) USERNAME		! Limit is 12 characters

	INCLUDE '($JPIDEF)'

	CALL INIT_ITMLST	! Initialize item list
	CALL ADD_2_ITMLST(LEN(USERNAME),JPI$_USERNAME,%LOC(USERNAME))
	CALL END_ITMLST(GETJPI_ITMLST)	! Get address of itemlist

	IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info

	RETURN
	END



	SUBROUTINE GETACC(ACCOUNT)
C
C  SUBROUTINE GETACC
C
C  FUNCTION:
C	To get account of present process.
C  OUTPUTS:
C	ACCOUNT   -   ACCOUNT owner of present process.
C

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) ACCOUNT		! Limit is 12 characters

	INCLUDE '($JPIDEF)'

	CALL INIT_ITMLST	! Initialize item list
	CALL ADD_2_ITMLST(LEN(ACCOUNT),JPI$_ACCOUNT,%LOC(ACCOUNT))
	CALL END_ITMLST(GETJPI_ITMLST)	! Get address of itemlist

	IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info

	RETURN
	END




	SUBROUTINE GETSTS(STS)
C
C  SUBROUTINE GETSTS
C
C  FUNCTION:
C	To get status of present process. This tells if its a batch process.
C  OUTPUTS:
C	STS   -   Status word of present process.
C

	IMPLICIT INTEGER (A-Z)

	INCLUDE '($JPIDEF)'

	CALL INIT_ITMLST	! Initialize item list
	CALL ADD_2_ITMLST(4,JPI$_STS,%LOC(STS))
	CALL END_ITMLST(GETJPI_ITMLST)	! Get address of itemlist

	IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info

	RETURN
	END




	SUBROUTINE HELP(LIBRARY)

	IMPLICIT INTEGER (A-Z)
	EXTERNAL LIB$PUT_OUTPUT,LIB$GET_INPUT
	CHARACTER*(*) LIBRARY

	COMMON /BULLPAR/ BULL_PARAMETER,LEN_P
	CHARACTER*64 BULL_PARAMETER

	INCLUDE '($HLPDEF)'

	IER = CLI$GET_VALUE('HELP_FOLDER',BULL_PARAMETER,LEN_P)

	CALL LBR$OUTPUT_HELP(LIB$PUT_OUTPUT,,BULL_PARAMETER(1:LEN_P)
     &		,LIBRARY,HLP$M_HELP.OR.HLP$M_PROMPT,LIB$GET_INPUT)

	RETURN
	END



	INTEGER FUNCTION LNM_MODE_EXEC(FAB,RAB,LUN)

	IMPLICIT INTEGER (A-Z)

	INCLUDE '($FABDEF)'
	INCLUDE '($RABDEF)'

	RECORD /FABDEF/ FAB
	RECORD /RABDEF/ RAB

	FAB.FAB$B_ACMODES = ISHFT(1,FAB$V_LNM_MODE)

	STATUS = SYS$OPEN(FAB)
	IF (STATUS) STATUS = SYS$CONNECT(RAB)

	LNM_MODE_EXEC = STATUS

	END



	INTEGER FUNCTION REC_LOCK(IER)

	INCLUDE '($FORIOSDEF)'

	DATA INIT /.TRUE./

	IF (INIT) THEN
	   REC_LOCK = 1
	   INIT = .FALSE.
	ELSE
	   IF (IER.EQ.FOR$IOS_SPERECLOC) THEN
	      REC_LOCK = 1
	   ELSE
	      REC_LOCK = 0
	      INIT = .TRUE.
	   END IF
	END IF

	RETURN
	END

	INTEGER FUNCTION TRIM(INPUT)
	CHARACTER*(*) INPUT
	DO TRIM=LEN(INPUT),1,-1
	 IF (INPUT(TRIM:TRIM).NE.' '.AND.INPUT(TRIM:TRIM).NE.CHAR(0)) RETURN
	END DO
	RETURN
	END

	SUBROUTINE SYS_GETMSG(IER)

	IMPLICIT INTEGER (A-Z)

	CHARACTER*80 MESSAGE

	CALL LIB$SYS_GETMSG(IER,,MESSAGE)
	WRITE (6,'(A)') MESSAGE

	RETURN
	END



	SUBROUTINE GET_NODE_INFO
C
C  SUBROUTINE GET_NODE_INFO
C
C  FUNCTION: Gets local node name and obtains node names from
C	command line.
C

	IMPLICIT INTEGER (A-Z)

	EXTERNAL CLI$_ABSENT

	COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM,
     &				NODE_ERROR,POINT_NODE
	CHARACTER*32 NODES(10)
	LOGICAL LOCAL_NODE_FOUND,NODE_ERROR

	CHARACTER LOCAL_NODE*32,NODE_TEMP*256

	NODE_ERROR = .FALSE.

	LOCAL_NODE_FOUND = .FALSE.
	CALL LIB$SYS_TRNLOG('SYS$NODE',L_NODE,LOCAL_NODE)
	L_NODE = L_NODE - 2			! Remove '::'
	IF (LOCAL_NODE(1:1).EQ.'_') THEN
	   LOCAL_NODE = LOCAL_NODE(2:)
	   L_NODE = L_NODE - 1
	END IF

	NODE_NUM = 0				! Initialize number of nodes
	IF (CLI$PRESENT('NODES')) THEN		! Decnet nodes specified?
	   DO WHILE (CLI$GET_VALUE('NODES',NODE_TEMP)
     &	    .NE.%LOC(CLI$_ABSENT))		! Get the specified nodes
	    IER = SYS_TRNLNM(NODE_TEMP,NODE_TEMP)
	    DO WHILE (TRIM(NODE_TEMP).GT.0)
	      NODE_NUM = NODE_NUM + 1
	      COMMA = INDEX(NODE_TEMP,',')
	      IF (COMMA.GT.0) THEN
		 NODES(NODE_NUM) = NODE_TEMP(1:COMMA-1)
		 NODE_TEMP = NODE_TEMP(COMMA+1:)
	      ELSE
		 NODES(NODE_NUM) = NODE_TEMP
		 NODE_TEMP = ' '
	      END IF
	      NLEN = TRIM(NODES(NODE_NUM))
	      IF (INDEX(NODES(NODE_NUM),'::').GT.0) THEN   ! Remove :: if
		 NLEN = INDEX(NODES(NODE_NUM),'::') - 1	   ! addedd
	      END IF
	      IF (LOCAL_NODE(1:L_NODE).EQ.NODES(NODE_NUM)(1:NLEN)) THEN
	       NODE_NUM = NODE_NUM - 1
	       LOCAL_NODE_FOUND = .TRUE.
	      ELSE
	       POINT_NODE = NODE_NUM
	       OPEN (UNIT=9+NODE_NUM,NAME=NODES(NODE_NUM)(1:NLEN)//'""::'
     &	       //'"TASK=BULLETIN"',ACCESS='SEQUENTIAL',FORM='FORMATTED',
     &	       CARRIAGECONTROL='NONE',TYPE='NEW',IOSTAT=IER)
	       IF (IER.NE.0) THEN
		  DO WHILE (NODE_NUM.GT.0)
		     CLOSE(UNIT=9+NODE_NUM)
		     NODE_NUM = NODE_NUM - 1
		  END DO
		  NODE_ERROR = .TRUE.
		  RETURN
	       END IF
	      END IF
	    END DO
	   END DO
	ELSE
	   LOCAL_NODE_FOUND = .TRUE.
	END IF

	RETURN
	END




	SUBROUTINE DELETE_NODE
C
C  SUBROUTINE DELETE_NODE
C
C  FUNCTION: Deletes files sent via ADD/NODES at remote hosts.
C

	IMPLICIT INTEGER (A-Z)

	INCLUDE 'BULLUSER.INC'

	INCLUDE 'BULLDIR.INC'

	COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM,
     &				NODE_ERROR,POINT_NODE
	CHARACTER*32 NODES(10)
	LOGICAL LOCAL_NODE_FOUND,NODE_ERROR

    	CHARACTER PASSWORD*31,INLINE*80,DEFAULT_USER*12

	CALL GET_NODE_INFO

 	IF (NODE_ERROR) GO TO 940

	IF (NODE_NUM.EQ.0.OR.LOCAL_NODE_FOUND) THEN
	   WRITE (6,'('' ERROR: Cannot specify local node.'')')
	   GO TO 999X
	END IF.

	IER = CLI$GET_VALUE('USERNAME',DEFAULT_USER)S
	IF (.NOT.IER) DEFAULT_USER = USERNAME
	IER = CLI$GET_VALUE('SUBJECT',DESCRIP)D

	DO POINT_NODE=1,NODE_NUM	   	! Write out command to nodes
	   SEMI = INDEX(NODES(POINT_NODE),'::')	! Look for semicolon after node
	   NLEN = TRIM(NODES(POINT_NODE))	! Length of node name
	   IF (SEMI.GT.0) THEN			! Is semicolon present?:
	      IF (NLEN.GT.SEMI+1) THEN		! Yes, is username after node?X
	         TEMP_USER = NODES(POINT_NODE)(SEMI+2:)	! Yes, set username
	         NLEN = SEMI - 1		! Remove semicolonN
	      ELSE				! No username after nodenameu
		 TEMP_USER = DEFAULT_USER	! Set username to default/
	         NLEN = SEMI - 1		! Remove semicolone
		 SEMI = 0			! Indicate no username
	      END IF 
	   ELSE					! No semicolon presentM
	      TEMP_USER = DEFAULT_USER		! Set username to default
	   END IF
	   INLINE = 'DELETE/SUBJECT="'//DESCRIP(:TRIM(DESCRIP))//
     &      '"/USERNAME='//TEMP_USER(:TRIM(TEMP_USER))
	   IF (CLI$PRESENT('USERNAME').OR.SEMI.GT.0) THEN  ! If username wasT
	      IER = 1				! specified, prompt for password
	      DO WHILE (IER.NE.0)
	         WRITE(6,'('' Enter password for node '',2A)') 
     &			NODES(POINT_NODE),CHAR(10)
	         CALL GET_INPUT_NOECHO(PASSWORD)e
	         IF (TRIM(PASSWORD).EQ.0) GO TO 910
	         OPEN (UNIT=10+NODE_NUM,NAME=NODES(POINT_NODE)(:NLEN)
     &		   //'"'//TEMP_USER(1:TRIM(TEMP_USER))//' '//N
     &		   PASSWORD(1:TRIM(PASSWORD))//'"::',T
     &		   TYPE='SCRATCH',IOSTAT=IER)C
	         CLOSE (UNIT=10+NODE_NUM)
	         IF (IER.NE.0) THEN
		    WRITE (6,'('' ERROR: Password is invalid.'')')
	         END IF
	      END DOL
	   END IF
	   WRITE (POINT_NODE+9,'(A)',ERR=940) INLINE 
	   READ (POINT_NODE+9,'(A)',ERR=940,END=940) INLINE
	   IF (INLINE.EQ.'END') THEN
	      WRITE (6,'('' Message successfully deleted from node '',A)')0
     &				NODES(POINT_NODE)A
	   ELSE
	      WRITE (6,'('' Error while deleting message to node '',A)')A
     &				NODES(POINT_NODE)V
	      WRITE (6,'(A)') INLINEV
	   END IF
	END DOE

	GO TO 999

910	WRITE (6,1010)
	GO TO 999

940	WRITE (6,1015) NODES(POINT_NODE)

999	DO WHILE (NODE_NUM.GT.0)
	   CLOSE(UNIT=9+NODE_NUM)
	   NODE_NUM = NODE_NUM - 1I
	END DOT

	RETURN

1010	FORMAT (' ERROR: Deletion aborted.') 
1015	FORMAT (' ERROR: Unable to reach node ',A)N

	END




	SUBROUTINE SET_FOLDER_FLAG(SETTING,FLAG,FLAGNAME)
CO
C  SUBROUTINE SET_FOLDER_FLAG
CB
C  FUNCTION: Sets or clears specified flag for folder
C
	IMPLICIT INTEGER (A-Z)e

	INCLUDE 'BULLFOLDER.INC' 

	INCLUDE 'BULLUSER.INC' 

	INCLUDE 'BULLFILES.INC'

	CHARACTER*(*) FLAGNAMEN

	IF (FOLDER_OWNER.EQ.USERNAME.OR.SETPRV_PRIV()) THEN
	   CALL OPEN_FILE(7)		! Open folder file 

	   CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER)T

	   IF (SETTING) THENS
	      FOLDER_FLAG = IBSET(FOLDER_FLAG,FLAG)
	   ELSE
	      FOLDER_FLAG = IBCLR(FOLDER_FLAG,FLAG)
	   END IF

	   CALL REWRITE_FOLDER_FILE

	   CALL CLOSE_FILE(7)

	   WRITE (6,'(1X,A,'' has been modified for folder.'')')F
     &		FLAGNAME
	ELSEt
	   WRITE (6,'(1X,A,'' You are not authorized to modify.'')')e
     &		FLAGNAME
	END IF

	RETURN 
	END




	SUBROUTINE SET_FOLDER_EXPIRE_LIMIT(LIMIT)
Cc
C  SUBROUTINE SET_FOLDER_EXPIRE_LIMITN
CI
C  FUNCTION: Sets folder expiration limit.
CT
	IMPLICIT INTEGER (A-Z)T

	INCLUDE 'BULLFOLDER.INC'T

	INCLUDE 'BULLUSER.INC'd

	INCLUDE 'BULLFILES.INC'

	IF (LIMIT.LT.0) THENP
	   WRITE (6,'('' ERROR: Invalid expiration length specified.'')')
	ELSE IF (FOLDER_OWNER.EQ.USERNAME.OR.SETPRV_PRIV()) THENo
	   CALL OPEN_FILE(7)		! Open folder filei

	   CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) 

	   F_EXPIRE_LIMIT = LIMIT

	   CALL REWRITE_FOLDER_FILE

	   CALL CLOSE_FILE(7)
	   WRITE (6,'('' Folder expiration date modified.'')')_
	ELSE4
	   WRITE (6,'('' You are not allowed to modify folder.'')')
	END IFi

	RETURN
	END





	SUBROUTINE MERGET

	IMPLICIT INTEGER (A-Z)R

	INCLUDE 'BULLFOLDER.INC'T

	INCLUDE 'BULLDIR.INC'

	CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY_SAVET

	ENTRY INITIALIZE_MERGE(IER1)

	DO WHILE (FILE_LOCK(IER1,IER2))
	   OPEN (UNIT=13,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))
     &		//'.TMPDIR',STATUS='NEW',FORM='UNFORMATTED',
     &		RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4,
     &		ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE',$
     &		KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED')
	END DO(

	IF (IER1.NE.0) RETURN

	NBULL = 0

	WRITE(13,IOSTAT=IER1) BULLDIR_HEADERD
	CALL CONVERT_HEADER_FROMBIN

	TO_POINTER = 1B

	RETURNB

	ENTRY ADD_MERGE_TO(IER1)M
 D
	IER1 = 0U

	DO WHILE (IER1.EQ.0)S

	   BULLDIR_ENTRY_SAVE = BULLDIR_ENTRY

	   CALL READDIR(TO_POINTER,IER)

	   DIFF = COMPARE_BTIM(%REF(BULLDIR_ENTRY_SAVE),MSG_BTIM)
	   IF (DIFF.LT.0.OR.TO_POINTER+1.NE.IER) THEN
	      BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE 
	      CALL CONVERT_ENTRY_FROMBIN
	      RETURN 
	   END IF

	   NBULL = NBULL + 1
	   MSG_NUM = NBULL

	   CALL GET_MSGKEY(MSG_BTIM,MSG_KEY)
	   WRITE(13,IOSTAT=IER1) BULLDIR_ENTRYR

	   NEWEST_DATE = DATE
	   NEWEST_TIME = TIME

	   TO_POINTER = TO_POINTER + 1I

	   BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE
	END DO

	CLOSE (UNIT=13)

	RETURN

	ENTRY ADD_MERGE_FROM(IER1)A

	NEWEST_DATE = DATEC
	NEWEST_TIME = TIMER

	DIFF = COMPARE_DATE(NEWEST_EXDATE,EXDATE)
	IF (DIFF.GT.0) THEN
	   NEWEST_EXDATE = EXDATE
	   NEWEST_EXTIME = EXTIME
	ELSE IF (DIFF.EQ.0) THEN 
	   DIFF = COMPARE_TIME(NEWEST_EXTIME,EXTIME)n
	   IF (DIFF.GT.0) NEWEST_EXTIME = EXTIME
	END IF 

	IF ((SYSTEM.AND.4).EQ.4) THEN
	   SHUTDOWN = SHUTDOWN + 1_
	   SHUTDOWN_DATE = DATE
	   SHUTDOWN_TIME = TIME
	END IF0

	BLOCK = NBLOCK - LENGTH

	NBULL = NBULL + 1
	MSG_NUM = NBULL

	CALL GET_MSGKEY(MSG_BTIM,MSG_KEY)
	WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY

	RETURN_

	ENTRY ADD_MERGE_REST(IER1)N

	CALL UPDATE_LOGIN(.TRUE.)

	DO WHILE (IER1.EQ.0)N

	   CALL READDIR(TO_POINTER,IER)
	   IF (TO_POINTER+1.NE.IER) THENL
	      READ (13,KEYID=0,KEY=0,IOSTAT=IER1)
	      CALL CONVERT_HEADER_TOBIN
	      REWRITE(13,IOSTAT=IER1) BULLDIR_HEADERf
	      IF (IER1.EQ.0) THEN
	         CLOSE (UNIT=13,DISPOSE='KEEP')
	         CALL LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//
     &		  '.TMPDIR',FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLDIR')
	      ELSE 
		 CLOSE (UNIT=13)
	      END IFN
	      RETURN
	   END IF

	   NBULL = NBULL + 1S
	   MSG_NUM = NBULLP

	   CALL GET_MSGKEY(MSG_BTIM,MSG_KEY)M
	   WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY=

	   NEWEST_DATE = DATE
	   NEWEST_TIME = TIME

	   TO_POINTER = TO_POINTER + 1
	END DO 

	CLOSE (UNIT=13)

	RETURN.
	END




	SUBROUTINE SET_NOKEYPAD

	IMPLICIT INTEGER (A-Z)	

	COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID

	INCLUDE '($SMGDEF)'

	TERM = SMG$M_KEY_TERMINATE 

	IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,0)_

	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2',,TERM,'SET KEYPAD',)

	RETURNP
	END





	SUBROUTINE SET_KEYPAD

	IMPLICIT INTEGER (A-Z) 

	COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID

	INCLUDE '($SMGDEF)'

	TERM = SMG$M_KEY_TERMINATEN

	IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,1)E

	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF1',,,,'GOLD')
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2',,TERM,'HELP',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2','GOLD',TERM,'SET NOKEYPAD',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF3',,,'EXTRACT ',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF3','GOLD',,'FILE ',)E
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4',,TERM,'SHOW KEYPAD',)f
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4','GOLD',TERM,
     &		'SHOW KEYPAD/PRINT',)U
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP0',,TERM,
     &		'SHOW FOLDER/FULL',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP0','GOLD',TERM,'SHOW FLAGS',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP1',,TERM,'BACK',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP1','GOLD',TERM,'NEXT',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP2',,TERM,'PRINT',)O
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP2','GOLD',TERM,'PRINT/NONOTIFY',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP3',,TERM,'DIR',)S
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP3','GOLD',TERM,'DIR/FOLDER',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP4',,TERM,'CURRENT',)U
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP4','GOLD',TERM,'CURRENT/EDIT ',):
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP5',,TERM,'RESPOND',)N
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP5','GOLD',TERM,'RESP/EDIT/TEXT',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP6',,TERM,'LAST',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP7',,TERM,'ADD',)(
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP7','GOLD',TERM,'ADD/EDIT',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP8',,TERM,'REPLY',)T
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP8','GOLD',TERM,'REPL/EDIT/TEXT',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP9',,TERM,'MAIL',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP9','GOLD',TERM,'MAIL/NOHEAD',)_
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'MINUS',,TERM,'READ/NEW',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'MINUS','GOLD',TERM,'SHOW NEW',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'COMMA',,TERM,'DIR/NEW',)U
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'COMMA','GOLD',TERM,'INDEX',)	
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD',,TERM,'DELETE',) 
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD','GOLD',TERM,'UNDELETE',)P
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'ENTER','GOLD',,'SELECT ',)

	RETURNF
	END



	SUBROUTINE SHOW_KEYPAD(LIBRARY)

	IMPLICIT INTEGER (A-Z)O
	EXTERNAL LIB$PUT_OUTPUT,PRINT_OUTPUT'
	CHARACTER*(*) LIBRARY

	INCLUDE '($HLPDEF)'

	IF (CLI$PRESENT('PRINT')) THEN'
	   OPEN (UNIT=8,STATUS='NEW',FILE='SYS$PRINT:KEYPAD.DAT',
     &			IOSTAT=IER)
	   IF (IER.NE.0) THEN
	      WRITE (6,'('' ERROR WHILE OPENING FILE TO PRINTER.'')')
	   ELSE
	      CALL LBR$OUTPUT_HELP(PRINT_OUTPUT,,'KEYPAD'
     &		,LIBRARY,HLP$M_HELP)
	      CLOSE (UNIT=8)'
	   END IF
	ELSEN
	   CALL LBR$OUTPUT_HELP(LIB$PUT_OUTPUT,,'KEYPAD'(
     &		,LIBRARY,HLP$M_HELP)
	END IFm

	RETURN'
	END

	INTEGER FUNCTION PRINT_OUTPUT(INPUT) 
	IMPLICIT INTEGER (A-Z)i
	CHARACTER*(*) INPUT
	WRITE (8,'(1X,A)',IOSTAT=IER) INPUT(:TRIM(INPUT))
	IF (IER.EQ.0) PRINT_OUTPUT = 1 
	RETURND
	END
