C
C		FON.FTN
C
C  BE SURE AND CHANGE THE LINE BELOW BEGINNING WITH CALL ASSIGN TO
C
C  DESCRIPTION DATA FOR EACH RECORD
C
C  BYTE	INTEGER
C  1-20	         1-10	NAME OF PERSON
C  21-44	11-22	COMPANY NAME OR ADDRESS
C  45-50	23-25	PHONE NUMBER
C
C  TASK BUILD WITH THE FOLLOWING OPTIONS
C
C  LIBR=FORRES:RO   --  USE ONLY IF YOU HAVE A FORTRAN RESIDENT COMMON REGION
C  ACTFIL=2
C  TASK=...FON
C
	BYTE	MASTER(50)
	BYTE	BUF(80)		! BUFFER PICKED UP BY MCR
	BYTE	BUFFER(50)	! PORTION OF BUF WE NEED
	BYTE	PHONE(20)
	INTEGER	MOTHER(3)
	BYTE	SPA
	BYTE	OPT1(3),OPT2(3),OPT3(4)
	BYTE	ZER
	INTEGER	PHON1,PHON2,PHON3,FLAG, END
	INTEGER	REC		! RECORD WHERE THIS NO. WILL BE STORED
	INTEGER	POSI		! SUBROUTINE TO FIND POSITION OF STRING
	INTEGER	ANS		!  ANSWER TO QUESTION ABOUT RIGHT NAME
	INTEGER	LEN
	EQUIVALENCE (MOTHER(1),MASTER(45))
	EQUIVALENCE (BUF(5),BUFFER(1))
	DATA	SPA,ZER/' ','0'/
	DATA	OPT1(1),OPT1(2)/'I','N'/
	DATA	OPT2(1),OPT2(2)/'X','X'/
	DATA	OPT3(1),OPT3(2),OPT3(3)/'C','H','A'/
C
C  		GENERAL TECHNIQUE OF THE PROGRAM
C	FON IN		! ENTER A NEW NAME INTO DIRECTORY
C	FON NAME	! GET PHONE NO. FOR THIS NAME
C	FON XX		! REMOVE A NAME FROM DIRECTORY
C	FON CHA		! MAKE A CHANGE
C
C  COME HERE TO ENTER NAMES INTO THE DIRECTORY
C
	CALL GETMCR(BUF,IBS)
	CALL TRIM(BUFFER,50)	! GET RID OF CR AT END OF LINE
C
C  BE SURE AND CHANGE THE LINE BELOW TO REPRESENT YOUR SITUATION.
C  ALSO MAKE SURE THE DATA FILE IS PRIVILEGED FOR ALL THE WORLD AND THE
C  DIRECTORY FOR THAT ACCOUNT AS STORED IN THE UIC 0,0 IS PRIVILEGED FOR
C  ALL THE WORLD
C
	CALL ASSIGN(2,'FON.DAT')
	CALL FDBSET (2,'OLD','SHARE')
	DEFINE FILE 2(1000,25,U,NEXT)
	IF((POSI(BUFFER,OPT1,1).EQ.1).AND.(LEN(BUFFER).EQ.2))GO TO 140
C  						! ENTER A NEW NAME
	IF(POSI(BUFFER,OPT2,1).EQ.1)GO TO 400	! DELETE A NAME
	IF((POSI(BUFFER,OPT3,1).EQ.1).AND.(LEN(BUFFER).EQ.3))GO TO 450
C  						! MAKE A CHANGE
	GO TO 350	! IF GET THIS FAR, ASSUME READING A NAME
10	FORMAT(I4)
20	FORMAT(20A1)
C
C  COME HERE TO INPUT A NAME
C
140	WRITE(5,150)	! GET THE NAME
150	FORMAT('$NAME:  ')
	READ(5,20,END=1000)(MASTER(J),J=1,20)
	IF(MASTER(1).EQ.SPA)GO TO 1000
	WRITE(5,160)	! GET THE PHONE NO.
160	FORMAT('$PHONE NO.  ')
	READ(5,165,END=1000)NCHR,PHONE
165	FORMAT(Q,20A1)
	CALL DEC3(PHON1,PHON2,PHON3,FLAG,PHONE,NCHR)
	IF(FLAG.GT.2)GO TO 200	! GAVE AN AREA CODE
	PHON3=PHON2		! DIDN'T GIVE AN AREA CODE
	PHON2=PHON1
	PHON1=312
200	IF(FLAG.GT.1)GOTO 210	! GAVE AN EXCHANGE
	PHON3=PHONE2		! DIDN'T GIVE AN EXCHANGE
	PHON2=791
210	MOTHER(1)=PHON1
	MOTHER(2)=PHON2
	MOTHER(3)=PHON3
	WRITE(5,270)
270	FORMAT('$NAME OF COMPANY:  ')
	READ(5,280,END=1000)(MASTER(J),J=21,43)
280	FORMAT(23A1)
	WRITE(5,290)(MASTER(J),J=1,20),PHON1,PHON2,PHON3,(MASTER(J),
	1 J=21,44)
290	FORMAT(1X,20A1,I5,I4,I5,2X,24A1)
291	FORMAT(1X,20A1,I5,I4,' 0',I3,2X,24A1)
292	FORMAT(1X,20A1,'     ',I4,I5,2X,24A1)
293	FORMAT(1X,20A1,'     ',I4,' 0',I3,2X,24A1)
294	FORMAT(1X,20A1,'         ',I5,2X,24A1)
295	FORMAT(1X,20A1,'         ',' 0',I3,2X,24A1)
	IF(ANS.EQ.1)GO TO 500	! WE WERE JUST MAKING A CHANGE
	READ(2'1)REC		! GET THE NEXT AVAILABLE REC
	WRITE(2'REC)MASTER	! WRITE THIS RECORD
	WRITE(5,300)REC
300	FORMAT(' RESULTS STORED IN RECORD # ',I4)
	REC=REC+1
	WRITE(2'1)REC
	GO TO 140
C
C  COME HERE TO READ A PHONE NUMBER
C
350	WRITE(5,355)            ! DO ONE LINE FEED
355   FORMAT(' ')
	READ(2'1)REC
	DO 380 I=2,REC-1
	READ(2'I)MASTER
	CALL TRIM(MASTER,44)
	IF(POSI(MASTER,BUFFER,1,44).EQ.0)GO TO 380
	IF (MOTHER(1).EQ.312.OR.MOTHER(1).LT.100) GOTO 360
C	LIST INCLUDING AREA CODE
	IF (MOTHER(3).GT.999) WRITE(5,290)(MASTER(J),J=1,20),
	1(MOTHER(J),J=1,3),(MASTER(J),J=21,44)
	IF (MOTHER(3).LE.999) WRITE(5,291)(MASTER(J),J=1,20),
	1(MOTHER(J),J=1,3),(MASTER(J),J=21,44)
	GOTO 380
C	LIST WITHOUT AREA CODE
360	IF (MOTHER(2).LT.100.OR.MOTHER(2).EQ.791) GOTO 370
	IF (MOTHER(3).GT.999) WRITE(5,292)(MASTER(J),J=1,20),
	1(MOTHER(J),J=2,3),(MASTER(J),J=21,44)
	IF (MOTHER(3).LE.999) WRITE(5,293)(MASTER(J),J=1,20),
	1(MOTHER(J),J=2,3),(MASTER(J),J=21,44)
	GOTO 380
C	LIST IN-HOUSE 4-DIGIT NUMBER
370	IF (MOTHER(3).GT.999) WRITE(5,294)(MASTER(J),J=1,20),
	1MOTHER(3),(MASTER(J),J=21,44)
	IF (MOTHER(3).LE.999) WRITE(5,295)(MASTER(J),J=1,20),
	1MOTHER(3),(MASTER(J),J=21,44)
380	CONTINUE
	GO TO 1000
C
C  COME HERE TO THROW OUT THIS LIST OF NAMES AND START OVER
C
400   WRITE(5,405)
405   FORMAT(/,'$WHAT IS THE NAME YOU WANT TO DELETE ')
      READ(5,465,END=1000)BUFFER
      IF(BUFFER(1).EQ.SPA)GO TO 1000
      CALL TRIM(BUFFER,50)             ! GET RID OF TRAILING BLANKS
      READ(2'1)END
      END=END-1
      DO 420 I=2,END
      READ(2'I)MASTER
      IF(POSI(MASTER, BUFFER, 1, 44).EQ.0) GO TO 420 ! NO MATCH FOUND
	IF (MOTHER(3).GT.999) WRITE(5,290)(MASTER(J),J=1,20),
	1(MOTHER(J),J=1,3),(MASTER(J),J=21,44)
	IF (MOTHER(3).LE.999) WRITE(5,291)(MASTER(J),J=1,20),
	1(MOTHER(J),J=1,3),(MASTER(J),J=21,44)
      WRITE(5,471)I                    ! ASK IF THIS IS RIGHT ONE
      WRITE(5,470)
      READ(5,10,END=1000)ANS
      IF(ANS.EQ.1) GO TO 430
420   CONTINUE
      WRITE(5,490)
      GO TO 400
430   IF(I.GE.END) GO TO 445
      DO 440 J=I+1,END
      READ(2'J)MASTER
      WRITE(2'J-1)MASTER
440   CONTINUE
445   WRITE(2'1)END                    ! END IS 1 LESS NOW, STORE IT
      GO TO 400
C
C  COME HERE TO MAKE A CHANGE
C
450	WRITE(5,460)
460	FORMAT(/,'$WHAT NAME DO YOU WANT TO CHANGE  ')
	READ(5,465,END=1000)BUFFER
465	FORMAT(50A1)
	IF(BUFFER(1).EQ.SPA)GO TO 1000	! ENTERED A BLANK
	CALL TRIM (BUFFER,50)	! GET RID OF TRAILING BLANKS
	READ(2'1)END
	DO 480 I=2,END-1
	READ(2'I)MASTER
	IF(POSI(MASTER,BUFFER,1,44).EQ.0)GO TO 480
	IF (MOTHER(3).GT.999) WRITE(5,290)(MASTER(J),J=1,20),
	1(MOTHER(J),J=1,3),(MASTER(J),J=21,44)
	IF (MOTHER(3).LE.999) WRITE(5,291)(MASTER(J),J=1,20),
	1(MOTHER(J),J=1,3),(MASTER(J),J=21,44)
	WRITE(5,471)I
471	FORMAT(' REC ',I4)
	WRITE(5,470)
470	FORMAT('$IF THIS IS THE RIGHT ENTRY, ENTER 1:  ')
	READ(5,10,END=1000)ANS		! GET THEIR ANSWER
	IF(ANS.NE.1)GO TO 480	! THIS WASN'T RIGHT ONE
	CALL LOA(MASTER,50,0)	! ERASE WHAT WAS THERE
	GO TO 140
480	CONTINUE
	WRITE(5,490)
490	FORMAT(' FAILED TO FIND THIS NAME')
	GO TO 450
500	WRITE(2'I)MASTER	! STORE THE RESULTS
	WRITE(5,510)I
510	FORMAT(' WRITTEN IN REC ',I4)
	GO TO 450
1000	CALL CLOSE(2)
	CALL EXIT
	END
