C..	 MAILPURGE.FTN   BOHDEN K. CMAYLO   DEC 81
C..
C..  PROGRAM PURGES ALL MAILER DEFINED INBOXES 30 OR /PRM=#
C..
	COMMON /INPUTX/ INPUT(512)
	DOUBLE PRECISION TNAME,DBLANK,DXLPT,X1MP(2),O1MP(2),N1MP(2)
	BYTE IZERO,ASTER,IBLANK,INPUT,X1MPB(16),O1MPB(16)
     1,N1MPB(16),INFROM(4),INRECE(4),INDEXA(132),IDOCX(3),IDUM,INFR
	DOUBLE PRECISION ALL,TEMP,NAMES(50),INBOX(8,100)
	EQUIVALENCE (N1MP,N1MPB),(X1MPB,X1MP),(O1MPB,O1MP)
	DATA
     1N1MP,X1MP,O1MP/'SY:N1.MP',' ','SY:X1.MP',' ','SY:O1.MP',' '/
	DATA N1MPB(9),X1MPB(9),O1MPB(9)/0,0,0/
	DATA ALL,IZERO,ASTER,IBLANK/'ALL     ','0','*',' '/
	DATA INRECE/'R','E','C','E'/
	DATA DBLANK,MAXGRP,INFROM /'        ',8,'F','R','O','M'/
	DATA DXLPT/'LP,LP'/
C.. 
C..      SET NO SUCH FILE COUNT (ERR=#29) TO OK)
C..
       CALL ERRSET(29,.TRUE.,.FALSE.,.TRUE.,.FALSE.,10000)
C..
C..  INITIALIZE
C..
	IN1X1=1
	IN2O1=2
	IN3N1=3
C..  SET MAX RETENTION DATE
	CALL GETMCR(INPUT,IQ)
	MAXDAY=32
	IQ=IQ-4
	IF(IQ.GT.0) DECODE(IQ,42,INPUT(5))MAXDAY
	IDALL=0
	CALL DATE(INPUT(1))
	CALL TIME(INPUT(10))
C..DECODE DATE INTO DAYS SINCE JAN 0, 1900
	CALL DECDAT(INDAY,INPUT)
	TYPE 1,(INPUT(I),I=1,17),MAXDAY
1	FORMAT(10(/)'0* MAILPURGE *   DATE:',9A1,'  TIME:',8A1,' *'/
     1 '   >',I4,' DAYS'//)
C..
C..	DELETE TEMPORARY DATA FILES 
C..
	IENC=45
	ENCODE(IENC,47,INPUT)X1MP(1),O1MP(1),N1MP(1)
47	FORMAT('PIP ',A8,';*/DE/NM,',A8,';*,',A8,';*!  ')
	CALL XSPAWN(INPUT)
C..
C..ASSIGN INBOX FILE TO UNIT 1
	IENC=23
	ENCODE(IENC,11,INPUT)
11	FORMAT('LB:[201,201]DOC005.W11 ')
	TYPE 101
101	FORMAT('0* IN BOX DEFINITIONS ENTERED *'/)
C..DO OVER INBOX 
	CALL INDOC(IN1X1,INPUT,X1MP)
5	KIN=0
6	READ(IN1X1,22,END=7) IQ,(INPUT(I),I=1,IQ)
	KIN=KIN+1
C.. SET UP INBOX UIC
	LST=-1
	CALL INPUTC(INPUT,IQ,IST,LST)
	IF(LST.LT.0) GO TO 91
	CALL INPUTC(INPUT,IQ,IST,LST)
	IF(LST.LT.0) GO TO 91
	TEMP=DBLANK
	ENCODE(LST,9,TEMP)(INPUT(I),I=1,LST)
	INBOX(1,KIN)=TEMP
C.. SET UP INBOX FIRST REQUIRED NAME FOR IDENTIFICATION
	CALL INPUTC(INPUT,IQ,IST,LST)
	IF(LST.LT.0) GO TO 90
	TEMP=DBLANK
	IENC=LST-IST+1
	ENCODE(IENC,9,TEMP)(INPUT(I),I=IST,LST)
	INBOX(2,KIN)=TEMP
9	FORMAT(132A1)
	GO TO 6
90	CALL ERROR(INPUT,IQ,'BAD INBOX NAME ENTERED.')
	GO TO 6
91	CALL ERROR(INPUT,IQ,'BAD INBOX UIC ENTERED.')
	GO TO 6
C.. END OF FILE
7	INBXS=KIN
	CALL CLOSE(IN1X1)
C**TYPE 63,(JJ,(INBOX(II,JJ),II=1,MAXGRP),JJ=1,INBXS)
63	FORMAT(1X,'INBOX(',I3,')=',8A8)
C..
C..	BITMAP READS FOR GETTING NUMBER OF DOCS
C..
	DO 20 JIN=1,INBXS
	IF(INBOX(1,JIN).EQ.DXLPT) GO TO 20
C**TYPE 105,(INBOX(I,JIN),I=1,2)
105	FORMAT(' * CHECKING INBOX ',A7,1X,A8,' FOR PURGE *')
	CALL BITRED(IN1X1,INBOX(1,JIN),NUMDOC,INDOC1)
C.. LESS THAN TWO DOCUMENTS OR NO DOC 1, GO TO NEXT INBOX
	IF(NUMDOC.LT.2.OR.INDOC1.LE.0) GO TO 20
C..	SET UP READ FOR DOC 1
	IENC=23
	ENCODE(IENC,62,INPUT)INBOX(1,JIN)
62	FORMAT('WP:[',A7,']DOC001.W11 ')
	CALL RIDBLK(INPUT,IENC)
C..COPY DOC001 TO TEMP FILE O1MPB AND READ FROM IT
	CALL INDOC(IN2O1,INPUT,O1MP)
C**TYPE 103,(INBOX(I,JIN),I=1,2)
103	FORMAT('0* PURGING OF INBOX ',A7,1X,A8,' STARTED *')
C..GET DATES FOR ALL .W11 FILES WITH SRD
	IENC=39
	ENCODE(IENC,71,INPUT)X1MP(1),INBOX(1,JIN)
71	FORMAT('SRD ',A8,'=WP:[',A7,']DOC*.W11/LI!  ')
	CALL XSPAWN(INPUT)
C..	OPEN SRD AND NEW DOC1 FILE
	CALL ASSIGN(IN1X1,X1MP)
C.. OPEN FILE FOR NEW DOC1 FOR NON DELETED FILES
	OPEN(UNIT=IN3N1,NAME=N1MP,CARRIAGECONTROL='LIST')
	IDEL=0
C..READ IN DOC1 AND CHECK FOR RECEIPT INFO
26	READ(IN2O1,22,END=27)IQ,(INPUT(I),I=1,80)
22	FORMAT(Q,132A1)
C..  SET TO COPY INDEX
	IF(IQ.LE.0) GO TO 26
	IF(IQ.GT.80) IQ=80
	CALL BYTEDO(INDEXA(1),INDEXA(IQ),INPUT(1))
	INDEXQ=IQ
	DO 4 INF=1,4
	INFR=INPUT(3+INF)
	IF(INFR.NE.INFROM(INF).AND.INFR.NE.INRECE(INF)) GO TO 44
4	CONTINUE
C.. DOUBLE CHECK FOR "FROM " AND "RECEIPT "
	IF(INPUT(8).NE.' '.AND.INPUT(11).NE.' ') GO TO 44
C**TYPE 107,(INPUT(I),I=1,IQ),IBLANK,ASTER
107	FORMAT('0*',80A1)
C.. GET NUMBER OF DOCUMENT TO BE PURGED
	CALL DOCNAM(INBOX(1,JIN),INPUT,IQ,NUMDOC,NUMNAM,NAMES)
	IF(NUMDOC.LE.1.OR.NUMNAM.LE.0) GO TO 44
C..CHECK WITH SRD IF DOCUMENT MORE THAN 2 MONTHS OLD
	ENCODE(3,42,IDOCX)NUMDOC
42	FORMAT(I3)
	IF(IDOCX(1).EQ.IBLANK) IDOCX(1)=IZERO
	IF(IDOCX(2).EQ.IBLANK) IDOCX(2)=IZERO
43	READ(IN1X1,22,END=44)IQ,(INPUT(I),I=1,80)
C..CHECK FOR DOCUMENT NUMBER
	DO 45 I=1,3
	IF(IDOCX(I).NE.INPUT(5+I)) GO TO 43
45	CONTINUE
C..FOUND DOC, CHECK DATE
	CALL DECDAT(NDAY,INPUT(28))
C**TYPE 4433,INDAY,NDAY,MAXDAY,IDOCX
4433	FORMAT(' INDAY=',I6,'  NDAY=',I6,'  MAXDAY=',I3,'   #=',3A1)
	IF(INDAY-NDAY.LE.MAXDAY) GO TO 44
C..DATE READY FOR PURGE, DELETE FILE AND CORRECT DOC1
	IF(IDEL.EQ.0) TYPE 103,(INBOX(I,JIN),I=1,2)
	IENC=35
	ENCODE(IENC,33,INPUT)INBOX(1,JIN),IDOCX
33	FORMAT('PIP WP:[',A7,']DOC',3A1,'.W11;*/DE!! ')
	CALL XSPAWN(INPUT)
	IDEL=IDEL+1
	IDALL=IDALL+1
	GO TO 46
C..
C..	FINISHED, REWIND SRD INPUT AND CHECK FOR NEXT DOC
C..
44	CONTINUE
C.. WRITE OUT NEW INDEX
	WRITE(IN3N1,9)(INDEXA(I),I=1,INDEXQ)
46	CONTINUE
	REWIND IN1X1
	GO TO 26
C..
C..	FINISHED WITH INBOX, CHECK NEXT INBOX
C..
27	CALL CLOSE(IN1X1)
	CALL CLOSE(IN2O1)
	WRITE(IN3N1,9)IBLANK
	ENDFILE IN3N1
	CALL CLOSE(IN3N1)
C..	SEE IF ANY FILES DELETED, IF NOT, GO TO NEXT INBOX
	IF(IDEL.LE.0) GO TO 29
	IENC=46
	ENCODE(IENC,49,INPUT)INBOX(1,JIN),N1MP(1)
49	FORMAT('DXF WP:[',A7,']DOC001.W11=',A8,'/TYPE:PM!  ')
	CALL XSPAWN(INPUT)
	IENC=19
	ENCODE(IENC,48,INPUT)INBOX(1,JIN)
48	FORMAT('BMP WP:[',A7,']!  ')
	CALL XSPAWN(INPUT)
29	CONTINUE
20	CONTINUE
	IENC=45
	ENCODE(IENC,47,INPUT)X1MP(1),O1MP(1),N1MP(1)
	CALL XSPAWN(INPUT)
	TYPE 444,IDALL
444	FORMAT(///' DOCUMENTS DELETED = ',I6)
	CALL EXIT
	END