From:	CRDGW2::CRDGW2::MRGATE::"SMTP::PFCVAX.PFC.MIT.EDU::BULLETIN" 21-JUL-1989 11:06
To:	MRGATE::"ARISIA::EVERHART"
Subj:	BULLETIN9.FOR

Message-Id:  <8907211347.AA23762@crdgw1.ge.com>
Received: from PFCVAX.PFC.MIT.EDU by mitvma.mit.edu (IBM VM SMTP R1.2.1MX) with TCP; Fri, 21 Jul 89 09:01:24 EDT
Date: Fri, 21 Jul 89 08:39 EDT
From: BULLETIN@PFCVAX.PFC.MIT.EDU
Subject: BULLETIN9.FOR
To: EVERHART@ARISIA.DECNET
X-Vms-To: IN%"EVERHART%ARISIA.DECNET@CRDGW1.GE.COM"

C
C  BULLETIN9.FOR, Version 6/1/89
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 HELP(LIBRARY)

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) LIBRARY

	COMMON /BULLPAR/ BULL_PARAMETER,LEN_P
	CHARACTER*64 BULL_PARAMETER

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

	CALL OUTPUT_HELP(BULL_PARAMETER(1:LEN_P),LIBRARY)

	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 999
	END IF

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

	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?
	         TEMP_USER = NODES(POINT_NODE)(SEMI+2:)	! Yes, set username
	         NLEN = SEMI - 1		! Remove semicolon
	      ELSE				! No username after nodename
		 TEMP_USER = DEFAULT_USER	! Set username to default
	         NLEN = SEMI - 1		! Remove semicolon
		 SEMI = 0			! Indicate no username
	      END IF
	   ELSE					! No semicolon present
	      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 was
	      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)
	         IF (TRIM(PASSWORD).EQ.0) GO TO 910
	         OPEN (UNIT=10+NODE_NUM,NAME=NODES(POINT_NODE)(:NLEN)
     &		   //'"'//TEMP_USER(1:TRIM(TEMP_USER))//' '//
     &		   PASSWORD(1:TRIM(PASSWORD))//'"::',
     &		   TYPE='SCRATCH',IOSTAT=IER)
	         CLOSE (UNIT=10+NODE_NUM)
	         IF (IER.NE.0) THEN
		    WRITE (6,'('' ERROR: Password is invalid.'')')
	         END IF
	      END DO
	   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)')
     &				NODES(POINT_NODE)
	   ELSE
	      WRITE (6,'('' Error while deleting message to node '',A)')
     &				NODES(POINT_NODE)
	      WRITE (6,'(A)') INLINE
	   END IF
	END DO

	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 - 1
	END DO

	RETURN

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

	END




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

	INCLUDE 'BULLFOLDER.INC'

	INCLUDE 'BULLUSER.INC'

	INCLUDE 'BULLFILES.INC'

	CHARACTER*(*) FLAGNAME

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

	   CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER)

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

	   CALL REWRITE_FOLDER_FILE

	   CALL CLOSE_BULLFOLDER

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

	RETURN
	END




	SUBROUTINE SET_FOLDER_EXPIRE_LIMIT(LIMIT)
C
C  SUBROUTINE SET_FOLDER_EXPIRE_LIMIT
C
C  FUNCTION: Sets folder expiration limit.
C
	IMPLICIT INTEGER (A-Z)

	INCLUDE 'BULLFOLDER.INC'

	INCLUDE 'BULLUSER.INC'

	INCLUDE 'BULLFILES.INC'

	IF (LIMIT.LT.0) THEN
	   WRITE (6,'('' ERROR: Invalid expiration length specified.'')')
	ELSE IF (FOLDER_OWNER.EQ.USERNAME.OR.SETPRV_PRIV()) THEN
	   CALL OPEN_BULLFOLDER		! Open folder file

	   CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER)

	   F_EXPIRE_LIMIT = LIMIT

	   CALL REWRITE_FOLDER_FILE

	   CALL CLOSE_BULLFOLDER
	   WRITE (6,'('' Folder expiration date modified.'')')
	ELSE
	   WRITE (6,'('' You are not allowed to modify folder.'')')
	END IF

	RETURN
	END





	SUBROUTINE MERGE

	IMPLICIT INTEGER (A-Z)

	INCLUDE 'BULLFOLDER.INC'

	INCLUDE 'BULLDIR.INC'

	CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY_SAVE

	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 DO2

	IF (IER1.NE.0) RETURN

	NBULL = 0

	WRITE(13,IOSTAT=IER1) BULLDIR_HEADER-
	CALL CONVERT_HEADER_FROMBIN

	TO_POINTER = 1d

	RETURNA

	ENTRY ADD_MERGE_TO(IER1)d

	IER1 = 0P

	DO WHILE (IER1.EQ.0) 

	   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_FROMBINn
	      RETURNe
	   END IF

	   NBULL = NBULL + 1n
	   MSG_NUM = NBULL7

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

	   NEWEST_DATE = DATE
	   NEWEST_TIME = TIME

	   TO_POINTER = TO_POINTER + 1

	   BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE
	END DOE

	CLOSE (UNIT=13)

	RETURNE

	ENTRY ADD_MERGE_FROM(IER1)E

	NEWEST_DATE = DATEP
	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) THENb
	   DIFF = COMPARE_TIME(NEWEST_EXTIME,EXTIME)
	   IF (DIFF.GT.0) NEWEST_EXTIME = EXTIMEA
	END IF

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

	BLOCK = NBLOCK - LENGTH

	NBULL = NBULL + 1
	MSG_NUM = NBULL

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

	RETURNE

	ENTRY ADD_MERGE_REST(IER1) 

	CALL UPDATE_LOGIN(.TRUE.)

	DO WHILE (IER1.EQ.0))

	   CALL READDIR(TO_POINTER,IER)
	   IF (TO_POINTER+1.NE.IER) THEND
	      READ (13,KEYID=0,KEY=0,IOSTAT=IER1)
	      CALL CONVERT_HEADER_TOBIN
	      REWRITE(13,IOSTAT=IER1) BULLDIR_HEADERI
	      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 IF
	      RETURNA
	   END IF

	   NBULL = NBULL + 1D
	   MSG_NUM = NBULL	

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

	   NEWEST_DATE = DATE
	   NEWEST_TIME = TIME

	   TO_POINTER = TO_POINTER + 1X
	END DOD

	CLOSE (UNIT=13)

	RETURNo
	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)R

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

	RETURN_
	END





	SUBROUTINE SET_KEYPAD

	IMPLICIT INTEGER (A-Z)L

	COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID

	INCLUDE '($SMGDEF)'

	TERM = SMG$M_KEY_TERMINATEO

	IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,1)O

	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 ',)S
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4',,TERM,'SHOW KEYPAD',)D
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4','GOLD',TERM,
     &		'SHOW KEYPAD/PRINT',)
	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',) 
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP2','GOLD',TERM,'PRINT/NONOTIFY',)
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP3',,TERM,'DIR',)_
	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 ',)e
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP5',,TERM,'RESPOND',)t
	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',)U
	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',)U
	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',)M
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'COMMA','GOLD',TERM,'INDEX',)o
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD',,TERM,'DELETE',),
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD','GOLD',TERM,'UNDELETE',)(
	IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'ENTER','GOLD',,'SELECT ',)R

	RETURN)
	END



	SUBROUTINE SHOW_KEYPAD(LIBRARY)

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

	INCLUDE '($HLPDEF)'

	IF (CLI$PRESENT('PRINT')) THENT
	   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)0
	   END IF
	ELSEN
	   CALL LBR$OUTPUT_HELP(LIB$PUT_OUTPUT,,'KEYPAD's
     &		,LIBRARY,HLP$M_HELP)
	END IF

	RETURNO
	END

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



	SUBROUTINE OUTPUT_HELP(PARAMETER,LIBRARY)
CD
C  SUBROUTINE OUTPUT_HELPI
C(
C  FUNCTION:
C	To create interactive help session.  Prompting is enabled.
C  INPUTS:
C	PARAMETER - Character string. Optional input parameter
C		    containing a list of help keys.
C	LIBRARY   - Character string. Name of help library.N
CL
	IMPLICIT INTEGER (A-Z)O

	INCLUDE '($LBRDEF)'

	COMMON /HELP/ HELP_PAGE,DISPLAY_ID,HELP_INPUT,HELP_INPUT_LENI
	COMMON /HELP/ NEED_ERASE,KEYBOARD_ID,KEY_TABLE_ID
	CHARACTER*80 HELP_INPUT

	COMMON /LEVELS/ KEY,KEYL,NKEY,OLD_NKEY,EXACTF
	CHARACTER*20 KEY(10)_
	DIMENSION KEYL(10)S

	COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING

	EXTERNAL PUT_OUTPUT

	CHARACTER*(*) LIBRARY,PARAMETER

	CHARACTER*80 PROMPT

	DATA DISPLAY_ID/0/,KEYBOARD_ID/0/

	IER = SMG$CREATE_PASTEBOARD(PASTEBOARD_ID)	! Initialize terminalA
	IF (DISPLAY_ID.EQ.0) THEN
	   IER = SMG$CREATE_VIRTUAL_DISPLAY(PAGE_LENGTH,
     &					PAGE_WIDTH,DISPLAY_ID)i
	END IFf
	IER = SMG$PASTE_VIRTUAL_DISPLAY(DISPLAY_ID,PASTEBOARD_ID,1,1)

	IF (KEYBOARD_ID.EQ.0) THEN'
	   IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,20)
	   IER = SMG$CREATE_KEY_TABLE(KEY_TABLE_ID)
	END IF

	CALL STR$TRIM(HELP_INPUT,PARAMETER,HELP_INPUT_LEN)	! Trim input

	CALL LBR$INI_CONTROL(LINDEX,LBR$C_READ)		! Init library readU
	CALL LBR$OPEN(LINDEX,LIBRARY)			! Specify library nameU

	DO I=1,10					! Initialize key lengths 
	   KEYL(I) = 0O
	END DOd

	NKEY = 0					! Number of help keysS

	DO WHILE (1)		! Do until CTRL-Z entered or no more keys

	   HELP_PAGE = 0				! Init line counter
	   NEED_ERASE = .TRUE.				! Need to erase screen 

	   OLD_NKEY = NKEY				! Save old key countL
	   EXACT = .TRUE.				! Exact key match 

	   DO WHILE (NKEY.LT.10.AND.HELP_INPUT_LEN.GT.0.AND.E
     &					   HELP_INPUT(:1).NE.'?')
							! Break input into keys
	      NKEY = NKEY + 1				! Increment key counterG

	      DO WHILE (HELP_INPUT(1:1).EQ.' '.AND.HELP_INPUT_LEN.GT.0)
		 HELP_INPUT = HELP_INPUT(2:HELP_INPUT_LEN)	! Strip spacesE
		 HELP_INPUT_LEN = HELP_INPUT_LEN - 1	! at start of input
	      END DOE

	      NEXT_KEY = 2,

	      DO WHILE (NEXT_KEY.LE.HELP_INPUT_LEN		! Search forT
     &		  .AND.HELP_INPUT(NEXT_KEY:NEXT_KEY).NE.' '	! space or
     &		  .AND.HELP_INPUT(NEXT_KEY:NEXT_KEY).NE.'/')	! backslash
		 NEXT_KEY = NEXT_KEY + 1	! indicating start of next keyE
	      END DOD

	      IF (NEXT_KEY.GT.HELP_INPUT_LEN) THEN	! Found the last key
		 KEY(NKEY) = HELP_INPUT(:HELP_INPUT_LEN)	! Key string
		 KEYL(NKEY) = HELP_INPUT_LEN			! Key lengthR
		 HELP_INPUT_LEN = 0 
	      ELSE					! Found the next key
		 KEY(NKEY) = HELP_INPUT(:NEXT_KEY-1)
		 HELP_INPUT = HELP_INPUT(NEXT_KEY:HELP_INPUT_LEN)I
		 KEYL(NKEY) = NEXT_KEY - 1
		 HELP_INPUT_LEN = HELP_INPUT_LEN - NEXT_KEY + 1H
	      END IFD
	   END DO
	   HELP_INPUT_LEN = 0
	   IER = LBR$GET_HELP(LINDEX,,PUT_OUTPUT,,	! Display help
     &		   KEY(1)(:KEYL(1)),KEY(2)(:KEYL(2)),
     &		   KEY(3)(:KEYL(3)),KEY(4)(:KEYL(4)),KEY(5)(:KEYL(5)),
     &		   KEY(6)(:KEYL(6)),KEY(7)(:KEYL(7)),KEY(8)(:KEYL(8)),
     &		   KEY(9)(:KEYL(9)),KEY(10)(:KEYL(10)))U

	   IF (IER.EQ.0.AND.HELP_INPUT_LEN.GT.0) IER = 1(
		! IER = 0 special case means input given to full screen prompt

	   IF (KEY(NKEY).EQ.'*'.OR..NOT.EXACT) THEN	! If not exact matchE
	      DO I=OLD_NKEY+1,NKEY			! then don't update 
		 KEYL(I) = 0				! new keys
	      END DO(
	      NKEY = OLD_NKEY
	   END IF

	   DO WHILE (HELP_INPUT_LEN.EQ.0.AND.IER.AND.NKEY.GE.0)
	      IF (NKEY.EQ.0) THEN	! If top level, prompt for topic 
	         IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID,
     &		   HELP_INPUT,'Topic? ',HELP_INPUT_LEN)
	      ELSE			! If not top level, prompt for subtopicK
		 LPROMPT = 0		! Create subtopic prompt lineL
		 DO I=1,NKEY		! Put spaces in between keys
		    PROMPT = PROMPT(:LPROMPT)//KEY(I)(:KEYL(I))//' '
		    LPROMPT = LPROMPT + KEYL(I) + 1,
		 END DOF
		 PROMPT = PROMPT(:LPROMPT)//'Subtopic? '
		 LPROMPT = LPROMPT + 10)
	         IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID,
     &		   HELP_INPUT,PROMPT(:LPROMPT),HELP_INPUT_LEN)
	      END IFD
	      CALL STR$TRIM(HELP_INPUT,HELP_INPUT,HELP_INPUT_LEN)
	      IF (IER.AND.HELP_INPUT_LEN.EQ.0) THEN	! If RETURN entered
		 KEYL(NKEY) = 0				! Back up one key level
		 NKEY = NKEY - 1
	      END IFT
	   END DO

	   IF (.NOT.IER.OR.NKEY.LT.0) THEN	! If CTRL-Z above top level,
	      CALL LBR$CLOSE(LINDEX)		! then close library,
	      CALL SMG$UNPASTE_VIRTUAL_DISPLAY(DISPLAY_ID,PASTEBOARD_ID)
						! remove virtual display
	      RETURN				! and end help session.
	   END IF

	END DOT

	END



	INTEGER FUNCTION PUT_OUTPUT(INPUT,INFO,DATA,LEVEL)A
CI
C  FUNCTION PUT_OUTPUT
C'
C  FUNCTION:
C	Output routine for input from LBR$GET_HELP.  DisplaysE
C	help text on terminal with full screen prompting.I
C  INPUTS:
C	INPUT - Character string.  Line of input text.
C	INFO  - Longword.  Contains help flag bits.
C	DATA  - Longword.  Not presently used.
C	LEVEL - Longword.  Contains current key level.
CO
	IMPLICIT INTEGER (A-Z)_

	INCLUDE '($HLPDEF)'

	COMMON /LEVELS/ KEY,KEYL,NKEY,OLD_NKEY,EXACTD
	CHARACTER*20 KEY(10)D
	DIMENSION KEYL(10),

	COMMON /HELP/ HELP_PAGE,DISPLAY_ID,HELP_INPUT,HELP_INPUT_LENT
	COMMON /HELP/ NEED_ERASE,KEYBOARD_ID,KEY_TABLE_ID
	CHARACTER*80 HELP_INPUT

	COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING

	CHARACTER INPUT*(*)

	CHARACTER SPACES*20
	DATA SPACES /' '/

	IF ((INFO.AND.HLP$M_NOHLPTXT).NE.0) THEN	! Key cannot be found,
	   NEED_ERASE = .FALSE.				! Don't erase screen
	   IF (HELP_PAGE.EQ.0) THEN		! If first line of help text
	      DO I=OLD_NKEY+1,NKEY		! remove any new keys that,
		 KEYL(I) = 0			! were inputted, as they areE
	      END DO				! not valid, as no matchY
	      NKEY = OLD_NKEY			! could be found.
	   END IF
	ELSE IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0.AND.NKEY.GT.0.AND.
     &		 LEVEL.GT.OLD_NKEY.AND.KEY(NKEY)(:KEYL(NKEY)).NE.'*'.AND.=
     &		 %LOC(INPUT).NE.0) THEN		! If text contains key namesA
			! Update if not wildcard search and they are new keys
	   IF (KEYL(LEVEL).GT.0) THEN		! If key already updated
	      EXACT = .FALSE.		! Must be more than one match possible
	   END IF			! so indicate not exact match.E
	   START_KEY = 1		! String preceeding spaces.
	   DO WHILE (INPUT(START_KEY:START_KEY).EQ.' ')
	      START_KEY = START_KEY + 1
	   END DO
	   KEY(LEVEL) = INPUT(START_KEY:)			! Store new key
	   CALL STR$TRIM(KEY(LEVEL),KEY(LEVEL),KEYL(LEVEL))	! & key length'
	ELSE IF (HELP_PAGE.EQ.0) THEN		! If first line of text,
	   DO I=OLD_NKEY+1,NKEY			! remove any new keys thatI
	      KEYL(I) = 0			! were just inputted, allowingD
	   END DO				! this routine to fill them.
	END IFG

	IF (NEED_ERASE) THEN			! Need to erase screen?O
	   IER = SMG$ERASE_DISPLAY(DISPLAY_ID)	! i.e. start of new topic.
	   NEED_ERASE = .FALSE.
	END IFB

	HELP_PAGE = HELP_PAGE + 1		! Increment screen counter
	IF (PAGING.AND.HELP_PAGE.GT.PAGE_LENGTH-2) THEN		! End of page?
	   HELP_PAGE = 0			! Reinitialize screen counterR
	   CALL LIB$PUT_OUTPUT(' ')	! Skip line and prompt for next screenG
	   IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID,
     &		HELP_INPUT,'Press RETURN to continue ... ',HELP_INPUT_LEN)
	   CALL STR$TRIM(HELP_INPUT,HELP_INPUT,HELP_INPUT_LEN)	! Trim input
	   IF (.NOT.IER.OR.HELP_INPUT_LEN.GT.0) THEN	! CTRL-Z or Text input?L
	      EXACT = .TRUE.	! If more than one match was found and being
				! displayed, text input specifies that the
				! current displayed match is desired.E
	      PUT_OUTPUT = 0	! Stop any more of current help display.
	   ELSE					! Else if RETURN entered$
	      IER = SMG$ERASE_DISPLAY(DISPLAY_ID)	! Erase display
	      NSPACES = LEVEL*2		! Number of spaces to indent outputO
	      IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0) NSPACES = NSPACES - 2
		! Key name lines are indented 2 less than help description.P
	      IF (NSPACES.GT.0) THEN	! Add spaces if present to output(
		 PUT_OUTPUT =  LIB$PUT_OUTPUT(SPACES(:NSPACES)//INPUT)
	      ELSE			! Else just output text.
		 PUT_OUTPUT =  LIB$PUT_OUTPUT(INPUT)
	      END IFT
	      HELP_PAGE = 1		! Increment page counter.n
	   END IF
	ELSE				! Else if not end of page
	   NSPACES = LEVEL*2		! Just output text line
	   IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0) NSPACES = NSPACES - 2
	   IF (NSPACES.GT.0) THEN
	      PUT_OUTPUT = LIB$PUT_OUTPUT(SPACES(:NSPACES)//INPUT)C
	   ELSE
	      PUT_OUTPUT = LIB$PUT_OUTPUT(INPUT)I
	   END IF
	END IFU

	RETURNM
	END




	SUBROUTINE SHOW_VERSION

	IMPLICIT INTEGER (A-Z)I

	CHARACTER VERSION*10,DATE*23,

	CALL READ_HEADER(VERSION,DATE) 

	WRITE (6,'(A)') ' BULLETIN Version '//VERSION(:TRIM(VERSION))

	WRITE (6,'(A)') ' Linked on '//DATE(:TRIM(DATE)))

	RETURNR
	END






	SUBROUTINE TAG(ADD_OR_DEL)_

	IMPLICIT INTEGER (A-Z)R

	INCLUDE 'BULLDIR.INC'

	COMMON /TAGS/ BULL_TAG,READ_TAG
	DATA BULL_TAG /.FALSE./,READ_TAG /.FALSE./R

	COMMON /POINT/ BULL_POINT

	COMMON /BULLPAR/ BULL_PARAMETER,LEN_P
	CHARACTER*64 BULL_PARAMETER

	EXTERNAL CLI$_ABSENTA

	IF (.NOT.BULL_TAG) THEN
	   CALL OPEN_NEW_TAG(IER)
	   IF (.NOT.IER) RETURN
	END IFB

	IF (.NOT.CLI$PRESENT('NUMBER')) THENT
	   IF (BULL_POINT.EQ.0) THEN	! No.  Have we just read a bulletin?
	      WRITE(6,1010)		! No, then error.$
	      RETURND
	   ELSE IF (ADD_OR_DEL) THENr
	      CALL ADD_TAG(IER)
	   ELSE
	      CALL DEL_TAG(IER)
	      IF (IER.NE.0) THENl
		 WRITE (6,'('' ERROR: Message was not marked.'')')
	      END IFr
	   END IF
	   RETURN
	END IF!

	CALL OPEN_BULLDIR_SHAREDo

	IER1 = 0
	DO WHILE (CLI$GET_VALUE('NUMBER',BULL_PARAMETER,LEN_P)=
     &	    .NE.%LOC(CLI$_ABSENT).AND.IER1.EQ.0) ! Get the specified messages

	   DECODE(LEN_P,'(I<LEN_P>)',BULL_PARAMETER) MESSAGE_NUMBER

	   CALL READDIR(MESSAGE_NUMBER,IER)	! Get info for bulletin

	   IF (IER.NE.MESSAGE_NUMBER+1) THEN	! Was bulletin found?K
	      WRITE(6,1030)			! If not, then error outH
	   ELSE IF (ADD_OR_DEL) THEN.
	      CALL ADD_TAG(IER1)L
	   ELSE
	      CALL DEL_TAG(IER)
	      IF (IER.NE.0) THEN_
		 WRITE (6,'('' ERROR: Message '',I,r
     &				'' was not marked.'')') MESSAGE_NUMBER
	      END IFH
	   END IF
	END DO_

	CALL CLOSE_BULLDIRT

	RETURN 

1010	FORMAT(' ERROR: You have not read any message.') 
1030	FORMAT(' ERROR: Message was not found.'))

	END



	SUBROUTINE ADD_TAG(IER)

	IMPLICIT INTEGER (A-Z) 

	INCLUDE '($FORIOSDEF)' 

	INCLUDE 'BULLDIR.INC'

	INCLUDE 'BULLFOLDER.INC't

	CHARACTER*12 TAG_KEY_

	WRITE (13,IOSTAT=IER) TAG_KEY(FOLDER_NUMBER,MSG_KEY)P

	IF (IER.EQ.FOR$IOS_INCKEYCHG) THENU
	   WRITE (6,'('' Message was already marked.'')')
 	ELSE IF (IER.NE.0) THENX
	   WRITE (6,'('' ERROR: Unable to add mark.'')')I
	   CALL ERRSNS(IDUMMY,IER1)
	   IF (IER1.EQ.0) THEN_
	      WRITE (6,'('' IOSTAT error = '',I)') IERI
	   ELSE
	      CALL SYS_GETMSG(IER1)
	   END IF
	END IFP

	RETURNT
	END




	SUBROUTINE DEL_TAG(IER)

	IMPLICIT INTEGER (A-Z)2

	INCLUDE 'BULLDIR.INC'

	INCLUDE 'BULLFOLDER.INC'5

	CHARACTER*12 TAG_KEYK

	DO WHILE (REC_LOCK(IER))7
	   READ (13,KEYEQ=TAG_KEY(FOLDER_NUMBER,MSG_KEY),IOSTAT=IER)(
	END DO
	IF (IER.NE.0) RETURNL

	DELETE (UNIT=13,IOSTAT=IER)

	IF (IER.NE.0) THENa
	   WRITE (6,'('' ERROR: Unable to delete mark.'')')
	   CALL ERRSNS(IDUMMY,IER1)
	   IF (IER1.EQ.0) THEN 
	      WRITE (6,'('' IOSTAT error = '',I)') IER
	   ELSE
	      CALL SYS_GETMSG(IER1)
	   END IF
	END IFL

	RETURN 
	END





	SUBROUTINE OPEN_OLD_TAG

	IMPLICIT INTEGER (A-Z) 

	INCLUDE '($FORIOSDEF)'I

	INCLUDE 'BULLUSER.INC'i

	COMMON /TAGS/ BULL_TAG,READ_TAG

	COMMON /BULLPAR/ BULL_PARAMETER,LEN_P
	CHARACTER*64 BULL_PARAMETER

	IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER)m
	IF (.NOT.IER) RETURNR

	NTRIES = 0a

	DO WHILE (FILE_LOCK(IER,IER1).AND.NTRIES.LE.30)
	   OPEN (UNIT=13,FILE='BULL_MARK:'//P
     &	     USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='OLD',
     &	     ACCESS='KEYED',RECORDTYPE='FIXED',SHARED,b
     &	     ORGANIZATION='INDEXED',IOSTAT=IER,
     &	     KEY=(1:12:CHARACTER))R
	   NTRIES = NTRIES + 1&
	END DO_

	IF (IER.NE.0.AND.IER.NE.FOR$IOS_FILNOTFOU) THEN
	   WRITE (6,'('' Unable to open mark file.'')')
	   IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1)E
	   IF (IER1.EQ.0) THENe
	      WRITE (6,'('' IOSTAT error = '',I)') IERv
	   ELSE
	      CALL SYS_GETMSG(IER1)
	   END IF
	   RETURN
	END IF.

	IF (IER.EQ.0) BULL_TAG = .TRUE.

	RETURN 
	END




	SUBROUTINE OPEN_NEW_TAG(IER)r

	IMPLICIT INTEGER (A-Z)T

	INCLUDE 'BULLUSER.INC'D

	COMMON /TAGS/ BULL_TAG,READ_TAG

	COMMON /BULLPAR/ BULL_PARAMETER,LEN_P
	CHARACTER*64 BULL_PARAMETER

	CHARACTER*64 BULL_MARKG

	IER = SYS_TRNLNM('BULL_MARK',BULL_MARK)
	IF (.NOT.IER) THENU
	   WRITE (6,'('' ERROR: BULL_MARK must be defined.'',
     &		''  See HELP MARK.'')')e
	   RETURN
	ELSE 
	   IER1 = SYS_TRNLNM_SYSTEM('BULL_MARK',BULL_PARAMETER)
	   IF (.NOT.IER1.OR.BULL_MARK.NE.BULL_PARAMETER) THEN
	      IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER)e
	      CALL DISABLE_PRIVSg
	      IER1 = 0u
	   END IF
	   OPEN (UNIT=13,FILE='BULL_MARK:'//I
     &	        USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='NEW',
     &	        ACCESS='KEYED',RECORDTYPE='FIXED',SHARED,
     &	        RECORDSIZE=3,
     &	        FORM='UNFORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER,
     &	        KEY=(1:12:CHARACTER))
	   IF (.NOT.IER1) CALL ENABLE_PRIVS
	   IF (IER.NE.0) THEN
	      WRITE (6,'('' Cannot create mark file.'')')
	      CALL ERRSNS(IDUMMY,IER1))
	      IF (IER1.EQ.0) THEN
	         WRITE (6,'('' IOSTAT error = '',I)') IER
		 IER = 0
	      ELSEH
	         CALL SYS_GETMSG(IER1)
		 IER = IER1_
	      END IFr
	   ELSE
	      BULL_TAG = .TRUE.
	      IER = 1
	   END IF
	END IF

	RETURND
	END



	CHARACTER*12 FUNCTION TAG_KEY(FOLDER_NUMBER,MSG_KEY) 

	IMPLICIT INTEGER (A-Z)F

	CHARACTER*(*) MSG_KEY

	CALL LIB$MOVC3(4,FOLDER_NUMBER,%REF(TAG_KEY))

	CALL GET_MSGKEY(%REF(MSG_KEY),TAG_KEY(5:)) 

	RETURN(
	END




	SUBROUTINE GET_FIRST_TAG(FOLDER_NUMBER,IER,MESSAGE)

	IMPLICIT INTEGER (A-Z)r

	INCLUDE 'BULLDIR.INC'

	COMMON /TAGS/ BULL_TAG,READ_TAG

	CHARACTER*12 TAG_KEY,INPUT_KEYu

	IF (.NOT.BULL_TAG) THEN
	   CALL OPEN_NEW_TAG(IER)
	   IF (.NOT.IER) RETURN
	END IF_

	MSG_KEY = BULLDIR_HEADERs

	HEADER = .TRUE.
	GO TO 10R

	ENTRY GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE)

	I = 1
	DO WHILE (I.LT.9)
	   ITEST = ICHAR(MSG_KEY(I:I))k
	   IF (ITEST.GT.0) THEN
	      MSG_KEY(I:I) = CHAR(ITEST-1)y
	      I = 9
	   ELSE
	      I = I + 1
	   END IF
	END DOx

	ENTRY GET_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE)

	HEADER = .FALSE.(

10	DO WHILE (1)t
	   DO WHILE (REC_LOCK(IER))
	      READ (13,KEYGT=TAG_KEY(FOLDER_NUMBER,MSG_KEY),IOSTAT=IER)
     &					INPUT_KEY
	   END DO

	   IF (IER.EQ.0) THEN
	      CALL GET_MSGKEY(%REF(INPUT_KEY(5:)),MSG_KEY)E
	      CALL LIB$MOVC3(4,%REF(INPUT_KEY),FOLDER1_NUMBER)r
	   END IF

	   IF (FOLDER1_NUMBER.NE.FOLDER_NUMBER.OR.IER.NE.0) THEN 
	      IER = 1
	      UNLOCK 13
	      RETURNs
	   ELSE
	      I = 1
	      DO WHILE (I.LT.9)
		 ITEST = ICHAR(MSG_KEY(I:I))
	         IF (ITEST.GT.0) THEN
		    MSG_KEY(I:I) = CHAR(ITEST-1)
		    I = 9T
		 ELSEE
		    I = I + 1.
		 END IFN
	      END DOA
	      CALL GET_MSGKEY(MSG_BTIM,MSG_KEY)
	      CALL OPEN_BULLDIR
	      CALL READDIR_KEYGE(IER)
	      CALL CLOSE_BULLDIRi
	      CALL GET_MSGKEY(%REF(INPUT_KEY(5:)),INPUT_KEY(5:))f
	      IF (IER.NE.0.AND.MSG_KEY.EQ.INPUT_KEY(5:)) THEN
	         UNLOCK 13 
		 MESSAGE = MSG_NUM
		 IF (HEADER) THENT
		    MESSAGE = MESSAGE - 1r
		    MSG_KEY = BULLDIR_HEADER
		 END IFR
		 IER = 0
	         RETURN
	      ELSEL
		 DELETE (UNIT=13)e
		 IER = 1
	      END IFL
	   END IF

	END DOc

	END






	SUBROUTINE FULL_DIR(INDEX_COUNT)L
C.
C	Add INDEX command to BULLETIN, display directories of ALL 
C	folders. Added per request of a faculty member for his private
C	board. Changes to BULLETIN.FOR should be fairly obvious.
C(
C	Brian Nelson, Brian@uoft02.bitnet (or .ccnet, node 8.2)t
C.
	IMPLICIT INTEGER (A-Z)T

	INCLUDE 'BULLDIR.INC'
	INCLUDE 'BULLFILES.INC'
	INCLUDE 'BULLFOLDER.INC'n
	INCLUDE 'BULLUSER.INC'E

	COMMON /POINT/ BULL_POINT

	COMMON /TAGS/ BULL_TAG,READ_TAG

	DATA FOLDER_Q1/0/

	BULL_POINT = 0N

	IF (NUM_FOLDERS.GT.0.AND..NOT.CLI$PRESENT('RESTART') 
     &		.AND.INDEX_COUNT.EQ.1) THENE
	   INDEX_COUNT = 2
	   DIR_COUNT = 0T
	END IF 

	IF (INDEX_COUNT.EQ.1) THEN 
	  CALL INIT_QUEUE(FOLDER_Q1,FOLDER1_COM)B

	  FOLDER_Q = FOLDER_Q1P
	  CALL OPEN_BULLFOLDER_SHARED		 ! Get folder file

	  NUM_FOLDERS = 0
	  IER = 0
	  DO WHILE (IER.EQ.0)			! Copy all bulletins from fileR
	    CALL READ_FOLDER_FILE_TEMP(IER)
	    IF (IER.EQ.0) THEN)
	      IF (BTEST(FOLDER1_FLAG,0).AND..NOT.SETPRV_PRIV()) THEN
		 FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))O
     &					//FOLDER1
	         CALL CHECK_ACCESS/
     &		  (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',O
     &		   USERNAME,READ_ACCESS,-1)A
	      ELSEL
		 READ_ACCESS = 1
	      END IFA
	      IF (READ_ACCESS) THEN
	         NUM_FOLDERS = NUM_FOLDERS + 1I
	         CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) 
	      END IFT
	    END IF 
	  END DOe

	  CALL CLOSE_BULLFOLDER			 ! We don't need file anymore

	  FOLDER_Q = FOLDER_Q1			! Init queue pointer to header
	  WRITE (6,1000)
	  WRITE (6,1020)L
	  DO J = 1,NUM_FOLDERS 
	   CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM)
	   WRITE (6,1030) FOLDER1(:15),F1_NBULL, 
     &		FOLDER1_DESCRIP(:MIN(TRIM(FOLDER1_DESCRIP),59)) 
	  END DOH
	  WRITE (6,1060)'
	  FOLDER_Q = FOLDER_Q1			! Init queue pointer to header
	  INDEX_COUNT = 2
	  DIR_COUNT = 0
	  READ_TAG = .FALSE.O
	  IF (CLI$PRESENT('MARKED')) READ_TAG = .TRUE.B
	  RETURNA
	ELSE IF (INDEX_COUNT.EQ.2) THEN
	 IF (DIR_COUNT.EQ.0) THEN
	  F1_NBULL = 0E
	  DO WHILE (NUM_FOLDERS.GT.0.AND.F1_NBULL.EQ.0)
	     NUM_FOLDERS = NUM_FOLDERS - 1H
	     CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM)
	     IF (F1_NBULL.GT.0) THEN(
	      FOLDER_NUMBER = -1T
	      CALL SELECT_FOLDER(.FALSE.,IER)
	      IF (.NOT.IER) F1_NBULL = 0'
	     END IF
	  END DO 

	  IF (F1_NBULL.EQ.0) THEN
	     WRITE (6,1050)
	     INDEX_COUNT = 0F
	     RETURN
	  END IFo
	 END IF
     e
	 IF (READ_TAG) THEN
	    CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT)N
	 END IF

	 CALL DIRECTORY(DIR_COUNT) 
	 IF (DIR_COUNT.GT.0) RETURN

	 IF (NUM_FOLDERS.GT.0) THEN
	    WRITE (6,1040)t
	 ELSE
	    INDEX_COUNT = 0
	 END IF
	END IFE

	RETURNF

1000	FORMAT (' The following folders are present'/))
1020	FORMAT (' Name	       Count Description'/)k
1030	FORMAT (1X,A15,I5,1X,A)
1040	FORMAT (' Type Return to continue to the next folder...')
1050	FORMAT (' End of folder search.')
1060	FORMAT (' Type Return to continue...') 

	END




	SUBROUTINE SHOW_USERY
CE
C  SUBROUTINE SHOW_USERE
CI
C  FUNCTION: Shows information for specified users.)
C
	IMPLICIT INTEGER (A-Z)

	INCLUDE 'BULLFOLDER.INC'I

	INCLUDE 'BULLUSER.INC'

	DIMENSION NOLOGIN_BTIM(2)

	CHARACTER*17 DATETIME

	ALL = CLI$PRESENT('NOLOGIN').OR.CLI$PRESENT('ALL')I
     &				.OR.CLI$PRESENT('LOGIN')
	IF (.NOT.ALL) THEN3
	   IER = CLI$GET_VALUE('USERNAME',TEMP_USER) 
	   IF (.NOT.IER) TEMP_USER = USERNAME
	END IFA

	IF (.NOT.SETPRV_PRIV().AND.(ALL.OR.USERNAME.NE.TEMP_USER)) THEN
	   WRITE (6,'('' ERROR: No privs to user command.'')')_
	   RETURN
	END IF 

	CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM)O

	CALL OPEN_BULLUSER_SHARED

	IF (.NOT.ALL) THENI
	   CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER)
	   IF (IER.EQ.0) THEN
	      IF (COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THENL
	         WRITE (6,'('' NOLOGIN set for specified user.'')')
	      ELSE)
	         CALL SYS$ASCTIM(,DATETIME,LOGIN_BTIM,)
	         WRITE (6,'('' User last logged in at '',A,''.'')')
     &						DATETIME
	      END IFN
	   ELSE
	      WRITE (6,'('' Entry for specified user not found.'')')F
	   END IF
	ELSE 
	   CALL READ_USER_FILE(IER)
	   DO WHILE (IER.EQ.0) 
	      CALL READ_USER_FILE(IER)S
	      IF (IER.EQ.0.AND.TEMP_USER(:1).NE.':'.AND.E
     &				TEMP_USER(:1).NE.'*') THEN
		 IER1 = COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM)1
		 IF (.NOT.CLI$PRESENT('LOGIN').AND.IER1.GE.0) THEN
	            WRITE (6,'('' NOLOGIN set for '',A,''.'')')
     &					TEMP_USER(:TRIM(TEMP_USER))
		 ELSE IF (.NOT.CLI$PRESENT('NOLOGIN').AND.IER1.LT.0) THENT
	            CALL SYS$ASCTIM(,DATETIME,LOGIN_BTIM,)T
	            WRITE (6,'(1X,A,'' last logged in at '',A,''.'')')
     &				TEMP_USER(:TRIM(TEMP_USER)),DATETIME
		 END IFL
	      END IFP
	   END DO
	END IFP

	CALL CLOSE_BULLUSER

	RETURNG
	END



	SUBROUTINE INIT_MESSAGE_ADD(IN_FOLDER,IN_FROM,IN_DESCRIP,IER)
C6
C  SUBROUTINE INIT_MESSAGE_ADD
Cn
C  FUNCTION:  Opens specified folder in order to add message. 
CE
C  INPUTS:
C	IN_FOLDER  - Character string containing folder name
C	IN_FROM	   - Character string containing name of owner of message.
C		     If empty, the default is the owner of the process.
C	IN_DESCRIP - Character string containing subject of message.
C		     If empty, the message is searched for a line
C		     which starts with "Subj:" or "Subject:".
C  OUTPUTS:S
C	IER - Error status.  True if properly connected to folder.
C		False if folder not found.'
CS
	IMPLICIT INTEGER (A - Z)Y

	INCLUDE 'BULLFILES.INC'

	INCLUDE 'BULLFOLDER.INC'

	INCLUDE 'BULLDIR.INC'

	COMMON /BCP/ BULLCP
	LOGICAL BULLCPe

	COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO
	CHARACTER*12 PROTOCOL
	DATA LPRO/0/R

	COMMON /DIGEST/ LDESCR,FIRST_BREAK

	CHARACTER*(*) IN_FOLDER,IN_FROM,IN_DESCRIPT

	COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRPA
	CHARACTER*(LINE_LENGTH) INFROM,INDESCRIPD

	COMMON /TEXT_PRESENT/ TEXTC

	BULLCP = 1			! Inhibit folder cleanup subprocess

	CALL OPEN_BULLFOLDER			! Get folder fileM

	CALL READ_FOLDER_FILE_KEYNAME(IN_FOLDER(:TRIM(IN_FOLDER)),IER)E

	CALL CLOSE_BULLFOLDER

	IF (IER.NE.0) THEN
	   CALL ERRSNS(IDUMMY,IER)_
	   RETURN
	ELSEM
	   IER = 1G
	END IFP

	ENTRY INIT_MESSAGE_ADD_BBOARD(IN_FROM,IN_DESCRIP,IER)

	TEXT = .FALSE.			! No text written, as of yet

	FIRST_BREAK = .TRUE.U

	IF (FOLDER_NUMBER.EQ.0) THEN	! If GENERAL folderT
	   FOLDER_SET = .FALSE.		! indicate itD
	ELSE				! Else it's another folderO
	   FOLDER_SET = .TRUE.		! indicate it
	END IF,

	FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//
     &		FOLDER			! set folder file names

	ENTRY INIT_MESSAGE_ADD_DIGEST(IN_FROM,IN_DESCRIP,IER)

	CALL OPEN_BULLDIR		! Open directory file

	CALL OPEN_BULLFIL		! Open data file

	CALL READDIR(0,IER1)		! Get NBLOCKH
	IF (IER1.EQ.0) NBLOCK = 0	! If new file, NBLOCK is 0,

	NBLOCK = NBLOCK + 1
	LENGTH = NBLOCK			! Initialize line count

	LEN_FROM = TRIM(IN_FROM).
	IF (LEN_FROM.EQ.0) THEN
	   CALL GETUSER(FROM)
	   INFROM = FROM 
	   LEN_FROM = TRIM(INFROM)T
	ELSEO
	   INFROM = IN_FROM
	   IF (.NOT.BTEST(FOLDER_FLAG,5)) THENN
	      CALL STORE_FROM(INFROM,LEN_FROM)
	   ELSE	IF (INDEX(INFROM,'%"').GT.0) THEN	! Store any protocolD
	      LPRO = INDEX(INFROM,'%"') + 1
	      PROTOCOL = INFROM(:LPRO)T
	   END IF
	END IFE

	LEN_DESCRP = TRIM(IN_DESCRIP)
	IF (LEN_DESCRP.GT.0) THEN
	   INDESCRIP = IN_DESCRIP
	   IF (.NOT.BTEST(FOLDER_FLAG,5)) THENE
	      CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP)
	   END IF
	ELSE 
	   DESCRIP = ' 'i
	END IFC

	CALL STRIP_HEADER(INPUT,0,IER1)

	RETURN)
	END




	SUBROUTINE WRITE_MESSAGE_LINE(BUFFER)
CN
C  SUBROUTINE WRITE_MESSAGE_LINE
CM
C  FUNCTION:  Writes one line of message into folder. 
C
C  INPUTS:
C	BUFFER - Character string containing line to be put into message.E
CL

	IMPLICIT INTEGER (A-Z)I

	INCLUDE 'BULLDIR.INC'

	INCLUDE 'BULLFOLDER.INC'

	COMMON /MAIL_PROTOCOL/ PROTOCOL,LPROU
	CHARACTER*12 PROTOCOL

	COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRPr
	CHARACTER*(LINE_LENGTH) INFROM,INDESCRIPe

	COMMON /DIGEST/ LDESCR,FIRST_BREAKl
	DATA FIRST_BREAK/.TRUE./	

	COMMON /STRIP_HEADER/ STRIP
	DATA STRIP/.TRUE./2

	COMMON /TEXT_PRESENT/ TEXTT

	CHARACTER*(*) BUFFER'

	LEN_BUFFER = TRIM(BUFFER)

	IF (BTEST(FOLDER_FLAG,5)) THEN'
	   IF (INDEX(BUFFER,'-------------').EQ.1) THEN
	      BREAK = .TRUE.E
	      DO I=1,LEN_BUFFER
		 IF (BUFFER(I:I).NE.'-') BREAK = .FALSE.
	      END DOI
	   ELSE
	      BREAK = .FALSE.
	   END IF
	   IF (BREAK) THENE
	      IF (.NOT.FIRST_BREAK) THENE
		 CALL FINISH_MESSAGE_ADD
	         CALL INIT_MESSAGE_ADD_DIGEST(INFROM,INDESCRIP,IER)
	      ELSED
		 FIRST_BREAK = .FALSE.
	      END IF!
	      LFROM = 0
	      LDESCR = 00
	      RETURN 
	   ELSE IF (.NOT.FIRST_BREAK) THENl
	      IF (LDESCR.EQ.0) THEN
	         IF (BUFFER(:9).EQ.'Subject: ') THENE
		    LDESCR = LEN_BUFFER - 9A
	            CALL STORE_DESCRP(BUFFER(10:),LDESCR)
		    IF (LFROM.EQ.0) THEN
		       LFROM = LEN_FROM	
	               CALL STORE_FROM(INFROM,LFROM)&
		    END IF
		 ELSE IF (BUFFER(:6).EQ.'From: ') THEN
		    LFROM = LEN_BUFFER - 6
		    IF (LPRO.GT.0) THEN_
		       LFROM = LFROM + LPRO + 1I
	               CALL STORE_FROM(PROTOCOL(:LPRO)//O
     &			BUFFER(7:LEN_BUFFER)//'"',LFROM)(
		    ELSE
	               CALL STORE_FROM(BUFFER(7:),LFROM)
		    END IF
		 END IFS
		 RETURNR
	      END IFn
	   ELSE
	      RETURNL
	   END IF
	END IF 

	IF (LEN_BUFFER.EQ.0) THEN		! If empty line
	   IF (.NOT.STRIP) THEN
	      CALL STORE_BULL(1,' ',NBLOCK)	! just store one spaceE
	   ELSE
	      STRIP = .FALSE.
	   END IF
	ELSEN
	   IF (LEN_DESCRP.EQ.0) THEN(
	      IF (BUFFER(:9).EQ.'Subject: ') THEN
		 DESCRIP = BUFFER(INDEX(BUFFER,' ')+1:)Q
		 LEN_DESCRP = LEN_BUFFER
	      END IFX
	   END IF
	   IF (STRIP) THENR
	      CALL STRIP_HEADER(BUFFER,LEN_BUFFER,IER) 
	      IF (IER) THEN
	         RETURN
	      ELSE.
	         STRIP = .FALSE..
	      END IFF
	   END IF
	   CALL STORE_BULL(MIN(LEN_BUFFER,LINE_LENGTH),BUFFER,NBLOCK)
	   TEXT = .TRUE. 
	END IF 

	RETURN_
	END




	SUBROUTINE FINISH_MESSAGE_ADD
C 
C  SUBROUTINE FINISH_MESSAGE_ADD
CE
C  FUNCTION:  Writes message entry into directory file and closes folder
CF
C  NOTE:  Only should be run if INIT_MESSAGE_ADD was successful.
C

	IMPLICIT INTEGER (A-Z) 

	INCLUDE 'BULLDIR.INC'

	INCLUDE 'BULLFOLDER.INC' 

	COMMON /DIGEST/ LDESCR,FIRST_BREAKE

	COMMON /STRIP_HEADER/ STRIP

	COMMON /TEXT_PRESENT/ TEXTD

	STRIP = .TRUE.				! Reset strip flag0

	CALL FLUSH_BULL(NBLOCK)

	CALL CLOSE_BULLFIL			! Finished adding bulletin

	IF ((BTEST(FOLDER_FLAG,5).AND.LDESCR.EQ.0).OR.	! End of digest msgo
     &				.NOT.TEXT) THEN	! or no message text found
	   CALL CLOSE_BULLDIR			! then don't add message entry0
	   RETURN
	END IFu

	IF (FOLDER_BBEXPIRE.EQ.-1) THEN		! Folder has expiration time?r
	   EXDATE = '5-NOV-2000'		! no, so set date far in future
	   SYSTEM = 2				! indicate permanent message
	ELSE					! Else set expiration date
	   CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE)I
	   SYSTEM = 0
	END IF
	EXTIME = '00:00:00.00'I

	LENGTH = NBLOCK - LENGTH + 1		! Number of records

	CALL ADD_ENTRY				! Add the new directory entry

	CALL CLOSE_BULLDIR			! Totally finished with add$

	CALL UPDATE_FOLDER.

	RETURNE
	END



	SUBROUTINE STORE_FROM(IFROM,LEN_INFROM)

	IMPLICIT INTEGER (A-Z) 

	INCLUDE 'BULLDIR.INC'

	CHARACTER*(*) IFROM

	CHARACTER*(LINE_LENGTH) INFROMN

	INFROM = IFROM 

	CALL STORE_BULL(6+LEN_INFROM,'From: '//INFROM(:LEN_INFROM),
     &		NBLOCK)'

	IF (INDEX(INFROM,'%"').GT.0)		! Strip off protocol programH
     &		INFROM = INFROM(INDEX(INFROM,'%"')+2:)

	IF (INDEX(INFROM,'::').GT.0)		! Strip off node name
     &		INFROM = INFROM(INDEX(INFROM,'::')+2:)	! I.e. HOST::USER

	DO WHILE (INDEX(INFROM,'!').GT.0.AND.	! Unix address go backwards. 
     &		INDEX(INFROM,'!').LT.INDEX(INFROM,'@')) 
	   INFROM = INFROM(INDEX(INFROM,'!')+1:)	! I.e. host!user
	END DO	

	IF (INDEX(INFROM,'<').GT.0) THEN	! Name may be of formE
	   INFROM = INFROM(INDEX(INFROM,'<'):)	! personal-name <net-name>
	END IFS

	IF (INDEX(INFROM,'(').GT.0.AND.		! personal-name (net-name)
     &		INDEX(INFROM,'@').GT.INDEX(INFROM,'(')) THEN
	   INFROM = INFROM(INDEX(INFROM,'(')+1:)N
	END IF 

	I = 1	! Trim username to start at first alpha character
	DO WHILE (I.LE.LEN_INFROM.AND.(INFROM(I:I).EQ.' '.OR.
     &		INFROM(I:I).EQ.'%'.OR.INFROM(I:I).EQ.'.'.OR.
     &		INFROM(I:I).EQ.'@'.OR.INFROM(I:I).EQ.'<'.OR.
     &		INFROM(I:I).EQ.'"'))
	   I = I + 1C
	END DOS
	INFROM = INFROM(I:)

	I = 1		! Trim username to end at a alpha charactera
	DO WHILE (I.LE.12.AND.INFROM(I:I).NE.' '.AND.
     &		INFROM(I:I).NE.'%'.AND.INFROM(I:I).NE.'.'.AND.
     &		INFROM(I:I).NE.'@'.AND.INFROM(I:I).NE.'<'.AND.
     &		INFROM(I:I).NE.'"')A
	   I = I + 1_
	END DOE
	FROM = INFROM(:I-1)

	DO J=2,I-1S
	   IF ((FROM(J:J).GE.'A'.AND.FROM(J:J).LE.'Z').AND.
     &	       ((FROM(J-1:J-1).GE.'A'.AND.FROM(J-1:J-1).LE.'Z').OR.
     &	        (FROM(J-1:J-1).GE.'a'.AND.FROM(J-1:J-1).LE.'z'))) THENn
	      FROM(J:J) = CHAR(ICHAR(FROM(J:J))-ICHAR('A')+ICHAR('a'))n
	   END IF
	END DO	

	RETURN-
	END




	SUBROUTINE STORE_DESCRP(INDESCRIP,LEN_DESCRP)

	IMPLICIT INTEGER (A-Z)e

	INCLUDE 'BULLDIR.INC'

	CHARACTER*(*) INDESCRIP

	DO WHILE (LEN_DESCRP.GT.0.AND.INDESCRIP(:1).EQ.' ')
	   INDESCRIP = INDESCRIP(2:)	
	   LEN_DESCRP = LEN_DESCRP - 1
	END DO 

	DO I=1,LEN_DESCRP			! Remove control characters
	   IF (INDESCRIP(I:I).LT.' ') INDESCRIP(I:I) = ' 'C
	END DOP
	IF (LEN_DESCRP.GT.LEN(DESCRIP)) THENM
				! Is length > allowable subject length?R
	   CALL STORE_BULL(6+LEN_DESCRP,'Subj: '//E
     &		INDESCRIP(:LEN_DESCRP),NBLOCK)
	END IFR

	DESCRIP = INDESCRIP(:MIN(LEN_DESCRP,LEN(DESCRIP)))E

	RETURNR
	END




	SUBROUTINE STRIP_HEADER(BUFFER,BLEN,IER)D
C
C  SUBROUTINE STRIP_HEADER
C
C  FUNCTION:  Indicates whether line is part of mail message header.
CE
C  INPUTS:
C	BUFFER	- Character string containing input line of message._
C	BLEN	- Length of character string.  If = 0, initialize subroutine.
CL
C  OUTPUTS:Y
C	IER	- If true, line should be stripped.  Else, end of header._
CS
	IMPLICIT INTEGER (A - Z)E

	CHARACTER*(*) BUFFERL

	INCLUDE 'BULLFOLDER.INC'f

	IF (.NOT.BTEST(FOLDER_FLAG,4).OR.TRIM(BUFFER).EQ.0) THENE
			! If STRIP not set for folder or empty line
	   IER = .FALSE.E
	   CONT_LINE = .FALSE.r
	   RETURN
	END IFS

	IF (BLEN.EQ.0) CONT_LINE = .FALSE.

	IER = .TRUE.L

	IF (CONT_LINE.AND.(BUFFER(:1).EQ.' '.OR.   ! If line is continuationi
     &		BUFFER(:1).EQ.CHAR(9))) RETURN	   ! of previous header line

	I = 1
	DO WHILE (I.LE.BLEN.AND.BUFFER(I:I).NE.' ')
	   IF (BUFFER(I:I).EQ.':') THEN	! Header line found
	      CONT_LINE = .TRUE.	! Next line might be continuationK
	      RETURNC
	   ELSE
	      I = I + 1
	   END IF
	END DOi

	IER = .FALSE.
	CONT_LINE = .FALSE.

	RETURNO
	END
