0010 ************************************************************************
0020 *  Program       : FU2000N1 - Copied from FU2000N
0030 *  Author        : Adrian Carter
0040 *  Date          : July  1993
0050 *  System        : EPSOM
0060 *  Sub-System    : External
0070 *  Function      : Update a file ( Security Code & ASCOT Xrefs only)
0080 *  Modifications :
0090 * 09/05/1994  CYL180  ADDITIONAL PARM PASSED TO KW0001N
0100 * 11/05/1994  CYL190  REMOVE REDUNDANT PARMS TO XR0099N
0110 * 21/07/1994  #HEC01  NEW PARAMETER #APPLIC-ID IN FU2000N SINCE SOME
0120 *                     ASCOT CREATED ACTIVITIES USED *APPLIC-ID OF ASCOT
0130 *                     INSTEAD OF AMS FOR CROSS REFERENCES
0140 * 25/08/1994  #HEC02  FIX BUG WITH FILE NUMBER WHICH CAUSED PROBLEMS
0150 *                     IN VOCAB CONTROL
0160 * 15/09/94    #HEC03  IF ASCTEC ACTIVITY HAS NO SUBJECT, AND RELATION
0170 *                     WITH EPSOM FILE IS 1:1, THEN UPDATE EPSOM TITLE
0180 *                     IF THE ASCTEC TITLE CHANGES - #REASON = 'I'
0190 * 28/11/94    CYL217  SET ERROR-TA TO ER0000P AND FETCH RETURN WHOFF
0200 * 01/06/95    RJM218  INPUT PARAMETER CHANGE FOR ACTION-OFFICER
0210 *                     & #REASON = 'F'
0220 * 08/11/96   #KAY01   LOCATION CANNOT BE CHANGE IF FILE IS BATCHED
0230 *                     BUT OUTPUT A EXCEPTION REPORT
0240 * 22/01/97   #KAY02   Stop printing unnecessary labels
0250 * 14/02/98   #PJT01   Change to allow RPC's to pass UserId
0260 * 04/04/2000 #ABC1    Trace ASCOT doc reproc downgrading security.
0270 * 28/12/2000 #ABC2    Enforce min security level for certain prefixes.
0280 ************************************************************************
0290 DEFINE DATA
0300 PARAMETER USING FU2000A1              /* #PJT01
0310 *
0320 LOCAL
0330 *
0340 * Files
0350 *
0360 01 FILE-VIEW VIEW OF REG-DETAILS
0370   02 FILE-NUMBER
0380   02 REDEFINE FILE-NUMBER
0390     03 #PREFIX   (A3)
0400   02 SECURITY-CODE
0410   02 FILE-TITLE (4)
0420   02 INDEX-LINE (2)
0430   02 KEYWORD (36)
0440   02 REDEFINE KEYWORD
0450     03 #KEYWORD (A15/36)
0460   02 REVERSE-KEYWORD(36)
0470   02 REDEFINE REVERSE-KEYWORD
0480     03 #REVERSE-KEYWORD (A15/36)
0490   02 VOCAB-CNTL-IND
0500   02 ASCTEC-ACTIVITY
0510   02 CURRENT-LOCATION
0520   02 C*MOVEMENT-TO                                             /* RJM218
0530   02 MOVEMENT-TO (6)                                           /* RJM218
0540   02 MOVE-TIMESTAMP (6)                                        /* RJM218
0550   02 REDEFINE MOVE-TIMESTAMP                                   /* RJM218
0560     03 #MOVE-TIMESTAMP-T (T/6)                                 /* RJM218
0570   02 CONSIGNMENT-NBR
0580   02 BATCH-NBR
0590   02 BOX-NBR
0600 *
0610 01 LOCATION VIEW OF REG-LOCATION
0620   02 LOC-ID
0630   02 USERID
0640   02 STATUS
0650 01 ORG-VIEW VIEW OF ASC-ORGANISATION
0660   02 ORG-END
0670 01 PERS-VIEW VIEW OF ASC-PERSON
0680   02 PERSON-END
0690 01 PRINT-REQUEST VIEW OF REG-LABEL-PRINT
0700   02 FILE-NUMBER
0710   02 STATUS
0720   02 PRINT-DATE
0730   02 REQUEST-DATE
0740   02 REDEFINE REQUEST-DATE
0750     03 #REQUEST-DATE  (D)
0760   02 REQUEST-USERID
0770   02 REQUEST-TYPE
0780   02 INTER-LABEL-TEXT
0790 01 XREF VIEW OF REG-XREF
0800   02 FILE-NUMBER
0810   02 SOURCE-ID
0820   02 USER-ID
0830   02 TIMESTAMP
0840   02 REDEFINE TIMESTAMP
0850     03 #TIMESTAMP  (T)
0860   02 APPLIC-ID
0870 01 SYNONYMS VIEW OF REG-WORD-CONTROL
0880   02 SYNONYM (1)
0890 1  AMS-ACTIVITY VIEW OF AMS-ACTIVITY
0900   2 ACTIVE-IND
0910   2 ACTIVITY-ID
0920   2 EPSOM-FILE
0930   2 SECURITY-LEVEL
0940 *
0950 1 USER-NAME VIEW OF ASC-USER-PROFILE /* #KAY01........
0960   2 USER-ID
0970   2 USER-LOCN                        /* ........#KAY01
0980 *
0990 01 AMS-EXCEP-REPT VIEW OF AMS-EXCEP-REPT
1000   02 ACTIVITY-ID
1010   02 REPT-TYPE
1020   02 EPSOM-FILE
1030   02 COMMENTS
1040   02 REDEFINE COMMENTS
1050     03 CONSIGNMENT-NBR     (N3)
1060     03 BATCH-NBR           (N6)
1070     03 BOX-NBR             (N6)
1080     03 FROM-LOCATION       (A4) /* #KAY01
1090     03 TO-LOCATION         (A4) /* #KAY01
1100   02 REPT-SEQN
1110   02 REDEFINE REPT-SEQN
1120     03 LOCN            (A3)
1130   02 DATE-PROCESSED
1140   02 UPD-TIME
1150   02 UPD-USERID
1160   02 TIMESTMP
1170 *
1180 1 #ACTIVE-EPSOM (A14)
1190 1 REDEFINE #ACTIVE-EPSOM
1200   2 #EPSOM-FILE-NO (A13)
1210   2 #ACTIVE-IND (A1)
1220 *
1230 * Program variables
1240 *
1250 01 #A-ISN  (P10)
1260 01 #CURRENT-LOCATION (A4)
1270 01 #DETAIL (A40)
1280 01 REDEFINE #DETAIL
1290   02 #TAB-PREFIX   (A3)
1300   02 #1X1(A1)
1310   02 #TAB-SECURITY (A3)
1320   02 #1X2 (A1)
1330   02 #TAB-UPRIGHTS (N1)
1340 01 #DESCRIPTION (A60/6)
1350 01 REDEFINE #DESCRIPTION
1360   02 #DESC-TITLE (A60/4)
1370   02 #DESC-INDEX (A60/2)
1380 01 #FILE-SOURCE    (A23)
1390 01 #HIGHEST-VALUE (N2)
1400 01 #HIGHEST-LEVEL (A2)
1410 01 #I              (P3)
1420 01 #INDICATOR (A1/36)
1430 01 #ISN            (P10)
1440 01 #J              (P3)
1450 01 #L-USERID       (A8)
1460 01 #LAB-STAT       (A1) INIT <'A'>
1470 01 #LOC-ID         (A4)
1480 01 #NW (P3)
1490 01 #OFFENDING-LINE (P3)
1500 01 #ORG-KEY (B13)
1510 01 REDEFINE #ORG-KEY
1520   02 #ORG-KEY1 (N9)
1530   02 #ORG-KEY2 (P6)
1540 01 #ORG-FOUND (L)
1550 01 #PERS-KEY (B13)
1560 01 REDEFINE #PERS-KEY
1570   02 #PERS-KEY1 (N9)
1580   02 #PERS-KEY2 (P6)
1590 01 #PERS-FOUND   (L)
1600 01 #PRT-REQ-SUPER  (A14)
1610 01 #PRETAB-KEY2 (A8)
1620 01 #PTAB-KEY-1 (A8) INIT <'PREFLOCN'>
1630 01 #PTAB-KEY-2 (A8)
1640 01 REDEFINE #PTAB-KEY-2
1650   02 #PTAB-KEY2P (A3)
1660   02 #PTAB-KEY-FILLER (A1)
1670   02 #PTAB-KEY2L (A4)
1680 01 #RETURN-CODE (N1)
1690 01 #REINPUT-MESS (A78)
1700 01 #SOURCE      (A10)
1710 01 REDEFINE #SOURCE
1720   02 FILLER      1X
1730   02 #SOURCE-NO (N9)
1740 01 #STORE-ISN (P8)
1750 01 #SYN-COUNT (P3)
1760 01 #TAB-KEY  (A8)
1770 01 #TAB-KEY1 (A8) INIT <'FILEPREF'>
1780 01 #TAB-KEY2 (A8)
1790 01 #TAB-TYPE-KEY (A16)
1800 **#PJT01 01 #USER-ID      (A8)
1810 01 #USERID (A8)
1820 01 #VALUE  (N9)
1830 01 #Z      (N2)
1840 01 #F      (A1)
1850 01 #T      (P1)                                                /* RJM218
1860 01 #PREV-LOCATION (A4) /* #KAY01
1870 *
1880 1 #REC-USER           (A13) INIT<'USERS'> /* #KAY01........
1890 1 REDEFINE #REC-USER
1900   2 #ID-PREFIX        (A5)
1910   2 #ID-USER          (A8)                /* ........#KAY01
1920 *
1930 * GU0025N Parameters
1940 *
1950 01 #TITLE-PROTECTED (L)
1960 01 #ASCTEC-LINKS    (P5)
1970 *
1980 *  Security levels
1990 *
2000 01 #DUMMY-A3    (A3)          /*   #ABC2
2010 01 #FILE-LEVEL  (N1)
2020 01 #MAX-LEVEL   (N1)
2030 01 #NEW-LEVEL   (N1)
2040 01 #USER-LEVEL  (N1)
2050 *
2060 *  Booleans
2070 *
2080 01 #XREF-LIST-UPDATED  (L)  INIT <FALSE>
2090 *
2100 * KW0001N parameters (dummies ans others)
2110 *
2120 *
2130 01 #DUMMY-A5         (A5)
2140 01 #COPY-FILE-NO     (A13)                         /* #HEC02..
2150 01 REDEFINE #COPY-FILE-NO
2160   02 FILLER         (A3)
2170   02 #DUMMY-N4      (N4)
2180   02 #DUMMY-N6      (N6)                          /* ..#HEC02
2190 01 #DUMMY-A8         (A8)
2200 01 #DUMMY-D          (D)
2210 01 #DUMMY-A15        (A15)
2220 01 #DUMMY-A19-X4     (A19/4)                                  /* CYL180
2230 01 #DUMMY-A18        (A18)
2240 01 #DUMMY-A40        (A40)
2250 01 #NUNREC           (P3)
2260 01 #WORDS-ACCEPTED   (L)
2270 *
2280 *  Constants
2290 *
2300 01 #NO-SOURCES   (P3) INIT  <10>
2310 01 #PREFLOCN     (A8) CONST <'PREFLOCN'>
2320 01 #SECUCLAS     (A8) CONST <'SECUCLAS'>
2330 01 #THIS-ROUTINE (A8) INIT <*PROGRAM>
2340 **  #ABC1
2350 01 #K           (P2)
2360 01 #INITMSG     (A3)
2370 01 #LEN         (P2)
2380 01 #NAMES       (A08/10)
2390 01 #LEVEL       (P03/10)
2400 END-DEFINE
2410 *
2420 IF SUBSTRING(FU2000A1.#MESSAGE,1,2) = '$$'
2430   MOVE SUBSTRING(FU2000A1.#MESSAGE,1,3) TO #INITMSG
2440 END-IF
2450 *
2460 **    PRINT
2470 **    / '=' #ASCTEC-ACTIVITY-ID
2480 **    / '=' #FILE-NUMBER
2490 **    / '=' #SECURITY-CODE
2500 **    / '=' #SOURCE-ID (*)
2510 **    / '=' #SUBJ-CHECKED (*)
2520 **    / '=' #SOURCE-INDIC (*)
2530 **    / '=' #WORK-AREA
2540 **    / '=' #DELETE-SUBJ
2550 **    / '=' #REASON
2560 **    / '=' #UPDATE-TITLE
2570 **    / '=' #FILE-TITLE (*)
2580 **    / '=' #UPDATE-SUBJECTS
2590 **    / '=' #MESSAGE
2600 **    / '=' #APPLIC-ID
2610 **    / '=' #USER-ID
2620 **    / '=' #FILE-LOCATION-USERID
2630 **    / '=' #DATE-FILE-LOC-CHANGED
2640 **    / '=' #LOCAL-ID
2650 IF FU2000A1.#APPLIC-ID = ' '                        /* #HEC01
2660   MOVE 'AMS' TO FU2000A1.#APPLIC-ID                 /* #HEC01
2670 END-IF                                             /* #HEC01
2680 FETCH RETURN 'WHOFF'                                         /* CYL217
2690 RESET FU2000A1.#MESSAGE     /* LT 29/7/93
2700 **#PJT01 MOVE *INIT-USER TO #USERID
2710 MOVE FU2000A1.#USER-ID TO #USERID         /* #PJT01
2720 MOVE 'F' TO #F
2730 MOVE 'ERR000P' TO *ERROR-TA                                  /* CYL217
2740 FIND (1) LOCATION WITH USERID = #USERID
2750   IF NO RECORD FOUND
2760     COMPRESS ':' #USERID 'You are not a registered EPSOM user'
2770       INTO #MESSAGE
2780     ESCAPE ROUTINE
2790   END-NOREC
2800   IF LOCATION.STATUS NE 'A'
2810     MOVE 'YOUR EPSOM AUTHORISATION HAS BEEN SUSPENDED' TO #MESSAGE
2820     ESCAPE ROUTINE
2830   END-IF
2840   MOVE LOCATION.LOC-ID TO #LOC-ID
2850 END-FIND
2860 *
2870 ** PRINT '=' #FILE-NUMBER
2880 F1. FIND (1) FILE-VIEW WITH FILE-NUMBER = #FILE-NUMBER
2890   IF NO RECORD FOUND
2900     COMPRESS 'Invalid file number (' #FILE-NUMBER ')'
2910       INTO #MESSAGE LEAVING NO SPACE
2920     ESCAPE ROUTINE
2930   END-NOREC
2940   MOVE #FILE-NUMBER TO #COPY-FILE-NO                    /* #HEC02
2950   IF FILE-VIEW.ASCTEC-ACTIVITY NE #ASCTEC-ACTIVITY-ID
2960     IF FILE-VIEW.ASCTEC-ACTIVITY = 0
2970       ASSIGN #A-ISN = *ISN(F1.)
2980     END-IF
2990   END-IF
3000 ***                                       /* START OF AMENDMENT : RJM218
3010 * IF #FILE-LOCATION-USERID = ' ' /*JY218
3020 *   MOVE 'FILE LOCATION USERID SHOULD BE SUPPLIED' TO #MESSAGE /*JY218
3030 *   ESCAPE ROUTINE  /*JY218
3040 * ELSE /*JY218
3050   IF #FILE-LOCATION-USERID NE ' '
3060     FIND (1) LOCATION WITH USERID = #FILE-LOCATION-USERID
3070       IF NO RECORDS FOUND
3080         MOVE 'YOU DO NOT HAVE ACCESS TO THIS PREFIX ' TO #MESSAGE
3090         ESCAPE ROUTINE
3100       END-NOREC
3110       IF STATUS NE 'A'
3120         MOVE 'FILE LOCATION RECORD IS INACTIVE' TO #MESSAGE
3130         ESCAPE ROUTINE
3140       END-IF
3150       MOVE LOCATION.USERID TO #L-USERID
3160 *
3170       MOVE LOCATION.LOC-ID TO #PTAB-KEY2L
3180       MOVE '-'      TO #PTAB-KEY-FILLER
3190       MOVE #PREFIX  TO #PTAB-KEY2P
3200       CALLNAT 'GU0007N' #PTAB-KEY-1 #PTAB-KEY-2
3210         #DETAIL #VALUE #RETURN-CODE
3220       IF #RETURN-CODE NE 0
3230         MOVE 'FILE LOCATION USERID NOT ON FILE  ' TO #MESSAGE
3240         ESCAPE ROUTINE
3250       END-IF
3260       IF #TAB-UPRIGHTS LE 0
3270      MOVE 'FILE LOCATION USERID IS INVALID UPRIGHTS NOT > 0' TO #MESSAGE
3280         ESCAPE ROUTINE
3290       END-IF
3300 *
3310       MOVE LOCATION.LOC-ID TO #CURRENT-LOCATION
3320     END-FIND
3330 **  END-IF /*JY218
3340   END-IF
3350 ***                                       /* END OF AMENDMENT   : RJM218
3360   IF FILE-VIEW.SECURITY-CODE = #SECURITY-CODE
3370     ESCAPE BOTTOM
3380   END-IF
3390 **
3400   IF FILE-VIEW.SECURITY-CODE NE #SECURITY-CODE
3410     IF #SECURITY-CODE = ' '                         /*   #ABC1
3420       OR (FILE-VIEW.SECURITY-CODE NE ' '            /*   #ABC1
3430           AND (#SECURITY-CODE = 'U' OR= 'UC'))      /*   #ABC1
3440       CALLNAT 'USR0600N' #NAMES (*) #LEVEL (*)      /*   #ABC1
3450       MOVE 'Illegal attempt downgrade security.'    /*   #ABC1
3460         TO #MESSAGE                                 /*   #ABC1
3470       COMPRESS #INITMSG #MESSAGE INTO #MESSAGE      /*   #ABC1
3480       FOR #K = 1 TO 10                              /*   #ABC1
3490         IF #NAMES(#K) = ' '                         /*   #ABC1
3500           ESCAPE BOTTOM                             /*   #ABC1
3510         END-IF                                      /*   #ABC1
3520         COMPRESS #MESSAGE #NAMES(#K) INTO #MESSAGE  /*   #ABC1
3530         EXAMINE #MESSAGE FOR #MESSAGE               /*   #ABC1
3540           GIVING LENGTH #LEN                        /*   #ABC1
3550         IF #LEN > 74                                /*   #ABC1
3560           ESCAPE BOTTOM                             /*   #ABC1
3570         END-IF                                      /*   #ABC1
3580       END-FOR                                       /*   #ABC1
3590       ESCAPE ROUTINE                                /*   #ABC1
3600     END-IF                                          /*   #ABC1
3610 **  Begin  #ABC2
3620     CALLNAT 'GU0021N' #PREFIX #SECURITY-CODE #DUMMY-A3 #MESSAGE
3630     IF #MESSAGE NE ' '
3640       ESCAPE ROUTINE
3650     END-IF
3660 **  End  #ABC2
3670     IF FILE-VIEW.SECURITY-CODE = ' '
3680       ASSIGN #FILE-LEVEL = 0
3690     ELSE
3700       MOVE FILE-VIEW.SECURITY-CODE TO #TAB-KEY
3710       CALLNAT 'GU0007N' #SECUCLAS #TAB-KEY #DETAIL #VALUE #RETURN-CODE
3720       IF #RETURN-CODE NE 0
3730         MOVE 'FILE SECURITY CODE NOT FOUND IN TABLE' TO #MESSAGE
3740         ESCAPE ROUTINE
3750       END-IF
3760       ASSIGN #FILE-LEVEL = #VALUE
3770     END-IF
3780     IF #SECURITY-CODE = ' '
3790       ASSIGN #NEW-LEVEL = 0
3800     ELSE
3810       MOVE #SECURITY-CODE TO #TAB-KEY
3820       CALLNAT 'GU0007N' #SECUCLAS #TAB-KEY #DETAIL #VALUE #RETURN-CODE
3830       IF #RETURN-CODE NE 0
3840         MOVE 'NEW SECURITY CODE NOT FOUND IN TABLE' TO #MESSAGE
3850         ESCAPE ROUTINE
3860       END-IF
3870       ASSIGN #NEW-LEVEL = #VALUE
3880     END-IF
3890     COMPRESS #PREFIX '-' #LOC-ID INTO #TAB-KEY LEAVING NO SPACE
3900     CALLNAT 'GU0007N' #PREFLOCN #TAB-KEY #DETAIL #VALUE #RETURN-CODE
3910     IF #RETURN-CODE NE 0
3920       COMPRESS 'YOU ARE NOT AUTHORISED TO UPDATE' #PREFIX 'FILES'
3930         INTO #MESSAGE
3940       ESCAPE ROUTINE
3950     END-IF
3960     IF #TAB-SECURITY = ' '
3970       ASSIGN #USER-LEVEL = 0
3980     ELSE
3990       MOVE #TAB-SECURITY TO #TAB-KEY
4000       CALLNAT 'GU0007N' #SECUCLAS #TAB-KEY #DETAIL #VALUE #RETURN-CODE
4010       IF #RETURN-CODE NE 0
4020         MOVE 'USER SECURITY RATING CODE NOT FOUND IN TABLE' TO #MESSAGE
4030         ESCAPE ROUTINE
4040       END-IF
4050       ASSIGN #USER-LEVEL = #VALUE
4060     END-IF
4070 *
4080     DECIDE FOR FIRST CONDITION
4090       WHEN #USER-LEVEL < #FILE-LEVEL
4100         MOVE 'USER SECURITY RATING INSUFFICIENT TO ACCESS FILE'
4110           TO #MESSAGE
4120       WHEN #USER-LEVEL < #NEW-LEVEL
4130         MOVE 'USER SECURITY RATING INSUFFICIENT TO UPGRADE FILE RATING'
4140           TO #MESSAGE
4150       WHEN ANY
4160         ESCAPE ROUTINE
4170       WHEN NONE
4180         IGNORE
4190     END-DECIDE
4200 **
4210 **  ASSIGN #ISN = *ISN(2870)         /* #KAY02
4220   END-IF
4230 END-FIND
4240 *
4250 #T := C*MOVEMENT-TO                                            /* RJM218
4260 IF (#FILE-LOCATION-USERID ^= ' '                 ) AND         /* RJM218
4270    (C*MOVEMENT-TO          =  0              OR                /* RJM218
4280     MOVEMENT-TO (#T)      ^= LOCATION.LOC-ID     )             /* RJM218
4290   GET FILE-VIEW *ISN (F1.)                                    /* RJM218
4300   MOVE FILE-VIEW.CURRENT-LOCATION TO #PREV-LOCATION /* #KAY01
4310   MOVE LOCATION.LOC-ID TO FILE-VIEW.CURRENT-LOCATION           /* RJM218
4320   IF C*MOVEMENT-TO < 6                    /* POINT TO NEXT MU  /* RJM218
4330     #T := C*MOVEMENT-TO + 1                                    /* RJM218
4340   ELSE                                    /* DROP OLDEST MU    /* RJM218
4350     FOR #T 2 TO 6                         /* SHUFFLE LASTEST 5 /* RJM218
4360       MOVE MOVEMENT-TO    (#T) TO MOVEMENT-TO    (#T - 1)      /* RJM218
4370       MOVE MOVE-TIMESTAMP (#T) TO MOVE-TIMESTAMP (#T - 1)      /* RJM218
4380     END-FOR                                                    /* RJM218
4390     #T := 6                               /* POINT TO 6TH MU   /* RJM218
4400   END-IF                                                       /* RJM218
4410   MOVE LOCATION.LOC-ID         TO MOVEMENT-TO       (#T)       /* RJM218
4420   IF #DATE-FILE-LOC-CHANGED > 0                                /* RJM218
4430     MOVE #DATE-FILE-LOC-CHANGED  TO #MOVE-TIMESTAMP-T (#T)     /* RJM218
4440   ELSE                                                         /* RJM218
4450     MOVE *TIMX                   TO #MOVE-TIMESTAMP-T (#T)     /* RJM218
4460   END-IF                                                       /* RJM218
4470   IF FILE-VIEW.CONSIGNMENT-NBR = 0 /* #KAY01
4480       AND FILE-VIEW.BATCH-NBR = 0  /* #KAY01
4490       AND FILE-VIEW.BOX-NBR = 0    /* #KAY01
4500     UPDATE (4290)                                              /* RJM218
4510   ELSE                 /* #KAY01........
4520     MOVE #FILE-LOCATION-USERID    TO #ID-USER
4530     FIND (1) USER-NAME WITH REC-USER EQ #REC-USER
4540     END-FIND
4550     MOVE BY NAME FILE-VIEW       TO AMS-EXCEP-REPT
4560     MOVE 'EPSOMBTH'              TO AMS-EXCEP-REPT.REPT-TYPE
4570     MOVE *DATX                   TO AMS-EXCEP-REPT.DATE-PROCESSED
4580     MOVE USER-NAME.USER-LOCN     TO AMS-EXCEP-REPT.LOCN
4590     MOVE FU2000A1.#ASCTEC-ACTIVITY-ID TO AMS-EXCEP-REPT.ACTIVITY-ID
4600     MOVE FILE-VIEW.FILE-NUMBER   TO AMS-EXCEP-REPT.EPSOM-FILE
4610     MOVE *TIMX                   TO AMS-EXCEP-REPT.UPD-TIME
4620 **#PJT01    MOVE *USER                   TO AMS-EXCEP-REPT.UPD-USERID
4630     MOVE FU2000A1.#USER-ID TO AMS-EXCEP-REPT.UPD-USERID    /* #PJT01
4640     MOVE #PREV-LOCATION          TO FROM-LOCATION
4650     MOVE FILE-VIEW.CURRENT-LOCATION TO TO-LOCATION
4660     STORE AMS-EXCEP-REPT
4670   END-IF               /* ........#KAY01
4680 END-IF                                                         /* RJM218
4690 *
4700 IF #REASON EQ 'T' AND #UPDATE-TITLE EQ 'Y'
4710     OR #REASON EQ 'P' AND #UPDATE-TITLE EQ 'Y'
4720     OR #REASON EQ 'A' AND #UPDATE-TITLE EQ 'Y'
4730     OR #REASON EQ 'I' AND #UPDATE-TITLE EQ 'Y'      /* #HEC03
4740     OR #REASON EQ 'F' /* Regardless of #UPDATE-TITLE VALUE     /* RJM218
4750     OR #REASON EQ 'S' /* Regardless of #UPDATE-TITLE VALUE /* #KAY02
4760   ASSIGN #ISN = *ISN(F1.)
4770 END-IF
4780 *
4790 IF FU2000A1.#UPDATE-SUBJECTS NE ' '
4800   IF #SOURCE-ID(*) NE ' '
4810     FOR #I = 2 TO #NO-SOURCES
4820       IF #SOURCE-ID(#I) = ' '
4830         ESCAPE TOP
4840       END-IF
4850       IF #SOURCE-ID(#I) = #SOURCE-ID(1 : #I - 1)
4860        COMPRESS 'SOURCE ID' #SOURCE-ID(#I) 'IS DUPLICATED' INTO #MESSAGE
4870         ESCAPE ROUTINE
4880       END-IF
4890     END-FOR
4900     FOR #I = 1 TO #NO-SOURCES
4910       DECIDE FOR FIRST CONDITION
4920         WHEN #SOURCE-ID(#I) = ' '
4930           ESCAPE TOP
4940         WHEN #SOURCE-ID(#I) = MASK('O'999999999)
4950           MOVE #SOURCE-ID(#I) TO #SOURCE
4960           ASSIGN #ORG-KEY1 = #SOURCE-NO
4970           ASSIGN #ORG-KEY2 = 999999
4980           ASSIGN #ORG-FOUND = FALSE
4990           HISTOGRAM ORG-VIEW FOR ORG-END
5000               STARTING FROM #ORG-KEY ENDING AT #ORG-KEY
5010             ASSIGN #ORG-FOUND = TRUE
5020           END-HISTOGRAM
5030           IF NOT #ORG-FOUND
5040            COMPRESS 'INVALID ORG SOURCE ID' #SOURCE-ID(#I) INTO #MESSAGE
5050             ESCAPE ROUTINE
5060           END-IF
5070         WHEN #SOURCE-ID(#I) = MASK('P'999999999)
5080           MOVE #SOURCE-ID(#I) TO #SOURCE
5090           ASSIGN #PERS-KEY1 = #SOURCE-NO
5100           ASSIGN #PERS-KEY2 = 999999
5110           ASSIGN #PERS-FOUND = FALSE
5120           HISTOGRAM PERS-VIEW FOR PERSON-END
5130               STARTING FROM #PERS-KEY ENDING AT #PERS-KEY
5140             ASSIGN #PERS-FOUND = TRUE
5150           END-HISTOGRAM
5160           IF NOT #PERS-FOUND
5170             COMPRESS 'INVALID PERSON SOURCE ID' #SOURCE-ID(#I)
5180               INTO #MESSAGE
5190             ESCAPE ROUTINE
5200           END-IF
5210         WHEN ANY  /*  Add new xrefs & mark any which already exist
5220           COMPRESS #FILE-NUMBER #SOURCE-ID(#I) INTO #FILE-SOURCE
5230             LEAVING NO SPACE
5240           FIND (1) XREF WITH FILE-SOURCE = #FILE-SOURCE
5250             IF NO RECORD FOUND
5260               MOVE #FILE-NUMBER TO XREF.FILE-NUMBER
5270               MOVE #SOURCE-ID(#I) TO XREF.SOURCE-ID
5280 **#PJT01      MOVE *INIT-USER     TO XREF.USER-ID
5290               MOVE FU2000A1.#USER-ID TO XREF.USER-ID    /* #PJT01
5300               MOVE *TIMX          TO #TIMESTAMP
5310 **            MOVE *APPLIC-ID     TO XREF.APPLIC-ID    /* #HEC01
5320               MOVE FU2000A1.#APPLIC-ID TO XREF.APPLIC-ID    /* #HEC01
5330               STORE XREF
5340               ASSIGN #XREF-LIST-UPDATED = TRUE
5350               ESCAPE BOTTOM
5360             END-NOREC
5370 **          MOVE *APPLIC-ID     TO XREF.APPLIC-ID       /* #HEC01
5380             MOVE FU2000A1.#APPLIC-ID TO XREF.APPLIC-ID   /* #HEC01
5390             UPDATE (5240)
5400           END-FIND
5410         WHEN NONE
5420         COMPRESS 'INVALID SOURCE ID FORMAT' #SOURCE-ID(#I) INTO #MESSAGE
5430           ESCAPE ROUTINE
5440       END-DECIDE
5450     END-FOR
5460   END-IF
5470 *
5480 *** BRIAN DECIDED THAT WE SHOULD TAKE THE FOLLOWING LINES OUT BECAUSE OF
5490 ** MULTIPLE ASCTECACTIVITIES REFERING TO ONE EPSOM FILE NUMBER
5500 **  Clobber any xrefs marked to this application
5510 **  and not mentioned in #SOURCE-ID(*).
5520 *
5530   READ XREF BY FILE-SOURCE STARTING FROM #FILE-NUMBER
5540     IF XREF.FILE-NUMBER NE #FILE-NUMBER
5550       ESCAPE BOTTOM
5560     END-IF
5570 **  IF XREF.APPLIC-ID = *APPLIC-ID
5580     IF XREF.APPLIC-ID = FU2000A1.#APPLIC-ID                 /* #HEC01
5590 **    IF NOT (#SOURCE-ID(*) = XREF.SOURCE-ID)
5600       FOR #Z = 1 TO 10
5610         IF #SUBJ-CHECKED(#Z) EQ XREF.SOURCE-ID
5620             AND #SOURCE-INDIC(#Z) EQ 'Y'
5630           GET XREF *ISN(5530)
5640           DELETE (5630)
5650           ASSIGN #XREF-LIST-UPDATED = TRUE
5660         END-IF
5670       END-FOR
5680     END-IF
5690   END-READ
5700 *
5710 * TO HERE
5720 END-IF
5730 *
5740 IF #A-ISN > 0
5750   GET FILE-VIEW #A-ISN
5760   MOVE #ASCTEC-ACTIVITY-ID TO FILE-VIEW.ASCTEC-ACTIVITY
5770   UPDATE (5750)
5780 END-IF
5790 *
5800 IF #ISN > 0           /*   Update security
5810   GET FILE-VIEW #ISN
5820   IF #SECURITY-CODE = 'U'          /*    Belt & braces
5830     RESET FILE-VIEW.SECURITY-CODE  /*  - in case U passed instead of ' '
5840   ELSE
5850     MOVE #FILE-NUMBER TO #EPSOM-FILE-NO
5860     RESET #HIGHEST-VALUE
5870     MOVE ' ' TO #HIGHEST-LEVEL
5880       FND.
5890     FIND AMS-ACTIVITY WITH ACTIVE-EPSOM = #ACTIVE-EPSOM
5900       IF AMS-ACTIVITY.ACTIVITY-ID EQ #ASCTEC-ACTIVITY-ID
5910         ESCAPE TOP
5920       END-IF
5930       MOVE AMS-ACTIVITY.SECURITY-LEVEL TO #TAB-KEY
5940       CALLNAT 'GU0007N' #SECUCLAS #TAB-KEY #DETAIL #VALUE #RETURN-CODE
5950       IF #RETURN-CODE EQ 0
5960         IF #VALUE GT #HIGHEST-VALUE
5970           MOVE #VALUE TO #HIGHEST-VALUE
5980           IF AMS-ACTIVITY.SECURITY-LEVEL EQ 'U'
5990             MOVE ' ' TO #HIGHEST-LEVEL
6000           ELSE
6010             MOVE AMS-ACTIVITY.SECURITY-LEVEL TO #HIGHEST-LEVEL
6020           END-IF
6030         END-IF
6040       END-IF
6050     END-FIND
6060     IF *NUMBER(FND.) EQ 1
6070         AND AMS-ACTIVITY.ACTIVITY-ID EQ #ASCTEC-ACTIVITY-ID
6080         OR *NUMBER(FND.) EQ 0
6090       MOVE #SECURITY-CODE TO FILE-VIEW.SECURITY-CODE
6100     ELSE
6110 *     IF #NEW-LEVEL GT #FILE-LEVEL
6120 *       MOVE #SECURITY-CODE TO FILE-VIEW.SECURITY-CODE
6130       IF #NEW-LEVEL > #HIGHEST-VALUE
6140         MOVE #SECURITY-CODE TO #HIGHEST-LEVEL
6150       END-IF
6160       IF #NEW-LEVEL NE #FILE-LEVEL
6170         MOVE #HIGHEST-LEVEL TO FILE-VIEW.SECURITY-CODE
6180       ELSE
6190         IF #REASON EQ 'S'
6200           RESET #REASON
6210         END-IF
6220       END-IF
6230     END-IF
6240   END-IF
6250 *                                                              /* RJM218
6260 *                                                              /* RJM218
6270   UPDATE (5810)
6280 * END-IF
6290 *  TO UPDATE THE FILE TITLE
6300   IF #UPDATE-TITLE EQ 'Y'
6310 **
6320 *
6330 * GET KEYWORDS AND REVERSE KEYWORDS
6340 *
6350     EXAMINE FU2000A1.#FILE-TITLE(*) TRANSLATE INTO UPPER CASE
6360     MOVE FU2000A1.#FILE-TITLE(*)TO #DESC-TITLE(*)
6370     MOVE FILE-VIEW.INDEX-LINE(*) TO #DESC-INDEX(*)
6380     MOVE FU2000A1.#FILE-TITLE(*)TO FILE-VIEW.FILE-TITLE(*)
6390     EXAMINE #DESCRIPTION(*) TRANSLATE INTO UPPER CASE
6400 *
6410     CALLNAT 'GU0002N' #DESCRIPTION(*) #F #FILE-NUMBER #SOURCE-ID(*)
6420       #NO-SOURCES #KEYWORD(*) #REVERSE-KEYWORD(*) #INDICATOR(*) #NW
6430       #REINPUT-MESS #OFFENDING-LINE
6440 ** PRINT '=' #DESCRIPTION(*) '=' #F
6450 ** PRINT '=' #FILE-NUMBER
6460 ** PRINT '=' #SOURCE-ID(*)
6470 ** PRINT '=' #NO-SOURCES
6480 ** PRINT '=' #KEYWORD(*)
6490 ** PRINT '=' #REVERSE-KEYWORD(*)
6500 ** PRINT '=' #INDICATOR(*)
6510 ** PRINT '=' #NW
6520 ** PRINT '='   #REINPUT-MESS
6530 ** PRINT '=' #OFFENDING-LINE
6540     IF #REINPUT-MESS NE ' '
6550       MOVE #REINPUT-MESS TO #MESSAGE
6560       ESCAPE ROUTINE
6570     END-IF
6580     IF #NW = 0
6590       MOVE 'FILE TITLE HAS NO USEFUL INDEXING WORDS' TO #MESSAGE
6600       ESCAPE ROUTINE
6610     END-IF
6620 *
6630     CALLNAT 'KW0001N' #PREFIX #DUMMY-A5 #DUMMY-N4 #DUMMY-A8 #DUMMY-N6
6640       #PREFIX #DUMMY-N4 #DUMMY-N6 #DUMMY-D #DUMMY-A15 #DUMMY-A19-X4(*)
6650 * #FILE-TITLE(*) #INDEX-LINE(*) #SOURCE-ID(*) #NO-SOURCES #KEYWORD(*)
6660       #FILE-TITLE(*) FILE-VIEW.INDEX-LINE(*) #SOURCE-ID(*) #NO-SOURCES
6670       #KEYWORD(*) #NW #NUNREC #WORDS-ACCEPTED #INDICATOR(*)
6680       #DUMMY-A18 #DUMMY-A40 #DUMMY-A40
6690       #MESSAGE #THIS-ROUTINE
6700 *
6710     IF #INDICATOR(*) NE ' '
6720       ASSIGN FILE-VIEW.VOCAB-CNTL-IND = 1
6730     ELSE
6740       ASSIGN FILE-VIEW.VOCAB-CNTL-IND = 0
6750     END-IF
6760 *
6770     IF #INDICATOR(*) NE ' '
6780       CALLNAT 'KW0010N' #FILE-NUMBER #KEYWORD(*) #INDICATOR(*) #NW
6790     END-IF
6800 *
6810 *
6820     FOR #I = 1 TO #NW
6830       HISTOGRAM SYNONYMS FOR SYNONYM
6840           STARTING FROM #KEYWORD(#I) ENDING AT #KEYWORD(#I)
6850         COMPUTE #SYN-COUNT = #SYN-COUNT + 1
6860       END-HISTOGRAM
6870       IF #SYN-COUNT > 0
6880         ESCAPE BOTTOM
6890       END-IF
6900     END-FOR
6910     IF #SYN-COUNT > 0
6920       MOVE #ISN TO #STORE-ISN
6930       CALLNAT 'KW0020N' #STORE-ISN
6940     END-IF
6950     UPDATE (5810)
6960   END-IF
6970 *
6980 **      Now generate a new label print request
6990   COMPRESS 'A' #FILE-NUMBER INTO #PRT-REQ-SUPER LEAVING NO SPACE
7000   FIND NUMBER PRINT-REQUEST WITH STATUS-FILE-NUMBER = #PREQ-SUPER
7010   FIND PRINT-REQUEST WITH STATUS-FILE-NUMBER = #PRT-REQ-SUPER
7020 *   IF *NUMBER(7010) = 0
7030     IF NO RECORD FOUND
7040       COMPRESS 'P' #FILE-NUMBER INTO #PRT-REQ-SUPER LEAVING NO SPACE
7050       FIND (1) PRINT-REQUEST WITH STATUS-FILE-NUMBER = #PRT-REQ-SUPER
7060         IF NO RECORD FOUND
7070           MOVE 'A' TO PRINT-REQUEST.STATUS
7080           MOVE 'R' TO PRINT-REQUEST.REQUEST-TYPE
7090           MOVE *DATX TO #REQUEST-DATE
7100 **#PJT01          MOVE *INIT-USER TO PRINT-REQUEST.REQUEST-USERID
7110     MOVE FU2000A1.#USER-ID TO PRINT-REQUEST.REQUEST-USERID  /* #PJT01
7120           MOVE #FILE-NUMBER TO PRINT-REQUEST.FILE-NUMBER
7130           IF #REASON EQ 'T'
7140             MOVE 'ASCTEC ACTIVITY TYPE CHANGED'
7150               TO  PRINT-REQUEST.INTER-LABEL-TEXT
7160           END-IF
7170           IF #REASON EQ 'S'
7180             MOVE 'ASCTEC ACTIVITY SECURITY CHANGED'
7190               TO  PRINT-REQUEST.INTER-LABEL-TEXT
7200           END-IF
7210           IF #REASON EQ 'A'
7220             MOVE 'ASCTEC ACTIVITY SUBJECTS CHANGED'
7230               TO  PRINT-REQUEST.INTER-LABEL-TEXT
7240           END-IF
7250           IF #REASON EQ 'I'                                /* #HEC03..
7260             MOVE 'ASCTEC ACTIVITY TITLE CHANGED'
7270               TO  PRINT-REQUEST.INTER-LABEL-TEXT
7280           END-IF                                           /* ..#HEC03
7290           IF #REASON EQ 'F'                                    /* RJM218
7300             MOVE 'EPSOM extra line modified'                   /* RJM218
7310               TO  PRINT-REQUEST.INTER-LABEL-TEXT               /* RJM218
7320           END-IF                                               /* RJM218
7330           STORE PRINT-REQUEST
7340           ESCAPE BOTTOM
7350         END-NOREC
7360         MOVE 'A' TO PRINT-REQUEST.STATUS
7370         MOVE 'R' TO PRINT-REQUEST.REQUEST-TYPE
7380         MOVE *DATX TO #REQUEST-DATE
7390         IF #REASON EQ 'T'
7400           MOVE 'ASCTEC ACTIVITY TYPE CHANGED'
7410             TO  PRINT-REQUEST.INTER-LABEL-TEXT
7420         END-IF
7430         IF #REASON EQ 'S'
7440           MOVE 'ASCTEC ACTIVITY SECURITY CHANGED'
7450             TO  PRINT-REQUEST.INTER-LABEL-TEXT
7460         END-IF
7470         IF #REASON EQ 'A'
7480           MOVE 'ASCTEC ACTIVITY SUBJECTS CHANGED'
7490             TO  PRINT-REQUEST.INTER-LABEL-TEXT
7500         END-IF
7510         IF #REASON EQ 'I'                                   /* #HEC03..
7520           MOVE 'ASCTEC ACTIVITY TITLE CHANGED'
7530             TO  PRINT-REQUEST.INTER-LABEL-TEXT
7540         END-IF                                              /* ..#HEC03
7550         IF #REASON EQ 'F'                                      /* RJM218
7560           MOVE 'EPSOM extra line modified'                     /* RJM218
7570             TO  PRINT-REQUEST.INTER-LABEL-TEXT                 /* RJM218
7580         END-IF                                                 /* RJM218
7590         RESET PRINT-REQUEST.PRINT-DATE
7600 **#PJT01        MOVE *INIT-USER TO PRINT-REQUEST.REQUEST-USERID
7610     MOVE FU2000A1.#USER-ID TO PRINT-REQUEST.REQUEST-USERID  /* #PJT01
7620         UPDATE (7050)
7630       END-FIND
7640       ESCAPE BOTTOM
7650     END-NOREC
7660     MOVE *DATX TO #REQUEST-DATE
7670     IF #REASON EQ 'T'
7680       MOVE 'ASCTEC ACTIVITY TYPE CHANGED'
7690         TO  PRINT-REQUEST.INTER-LABEL-TEXT
7700     END-IF
7710     IF #REASON EQ 'S'
7720       MOVE 'ASCTEC ACTIVITY SECURITY CHANGED'
7730         TO  PRINT-REQUEST.INTER-LABEL-TEXT
7740     END-IF
7750     IF #REASON EQ 'A'
7760       MOVE 'ASCTEC ACTIVITY SUBJECTS CHANGED'
7770         TO  PRINT-REQUEST.INTER-LABEL-TEXT
7780     END-IF
7790     IF #REASON EQ 'F'                                          /* RJM218
7800       MOVE 'EPSOM extra line modified'                         /* RJM218
7810         TO  PRINT-REQUEST.INTER-LABEL-TEXT                     /* RJM218
7820     END-IF                                                     /* RJM218
7830     RESET PRINT-REQUEST.PRINT-DATE
7840     MOVE *NUMBER(7000) TO #REQUEST-USERID  /* Just testing NATLABEL
7850     MOVE FU2000A1.#USER-ID TO PRINT-REQUEST.REQUEST-USERID  /* #PJT01
7860     UPDATE(7010)
7870   END-FIND
7880 END-IF
7890 *
7900 IF #XREF-LIST-UPDATED
7910   CALLNAT 'XR0099N' #FILE-NUMBER                              /* CYL190
7920 END-IF
7930 *
7940 CALL FILE
7950   TEST THIS(7940)
7960 END-FILE
7970 *
7980 CALL LOOP
7990   TEST THIS TOO(7980)
8000 END-LOOP
8010 *
8020 PRINT *ISN(7330)  /*  test referback to store statement
8030 *
8040 END