PROC 0                                                                -
  LISTUDDN(NULLFILE)         /* LISTUSER DDname            */         -
  DATADDN(NULLFILE)          /* DATA DDname                */         -
  DATAMBR(ALLUSERS)          /* DATA default member name   */
 
/* 11/15/2005 JL.NELSON Copied from CARC0501 for Top Secret.
/* 11/02/2005 JL.NELSON Split out ACPs from SY$ACTON
/* 11/02/2005 JL.NELSON RACF only, create list of users in DATA file
/* 11/04/2005 JL.NELSON Test for End-Of-File condition code.
/* 11/15/2005 JL.NELSON Modified next User condition to force write.
/* 11/15/2005 JL.NELSON Copied/modified for Top Secret extracts.
/* 11/18/2005 JL.NELSON Added tests for File condition codes.
/* 01/31/2006 JL.NELSON Made intermediate file a seq. was PDS.
/* 01/31/2006 JL.NELSON Changed from TSO to ISPF commands.
/* 02/15/2006 JL.NELSON Drop FACILITYs from DEPT/DIV/ZONE records.
/* 03/15/2006 JL.NELSON Made changes to avoid SUBSTR abend 920/932.
/* 03/21/2006 JL.NELSON Use NRSTR avoid abend 900 if ampersand in data.
/* 05/09/2006 JL.NELSON Added WRITE &LASTCC for debugging.
/* 02/10/2008 CL FENTON Removed unused variables and obtain trace variables.
 
SET PGMNAME = &STR(CATC0501 03/31/08)
 
NGLOBAL USRID USRNAME GRP1 GRP2 GRP3 GRP4 GRP5 GRP6 NR
NGLOBAL PGMNAME RETURN_CODE DATAID DATAMEM
 
SET SYSPROMPT = OFF                /* CONTROL NOPROMPT          */
SET SYSFLUSH  = OFF                /* CONTROL NOFLUSH           */
SET SYSASIS   = ON                 /* CONTROL ASIS - caps off   */
 
/* ERROR ROUTINE */
ERROR DO
  SET RETURN_CODE = &LASTCC          /* SAVE LAST ERROR CODE */
  IF &LASTCC GE 16 THEN +
    WRITE &PGMNAME LASTCC = &LASTCC &ZERRLM
  RETURN
  END
 
SET ZISPFRC = 0
 
/* Called from CACC0501
/* ISPEXEC VPUT (ZISPFRC) SHARED
 
SET RETURN_CODE = 0
 
ISPEXEC VGET ( +
  SYMLIST      +
  CONSLIST     +
  COMLIST      +
  TERMMSGS     +
  ACPNAME      +
  ACPVERS      +
  ) ASIS
 
IF &SUBSTR(1:3,&NRSTR(&ACPNAME   )) NE TSS THEN DO
  WRITE &PGMNAME Top Secret Job running on the wrong system.
  WRITE &PGMNAME &ACPNAME &ACPVERS
  SET RETURN_CODE = 20
  GOTO ERR_EXIT
  END
 
SET SYSSYMLIST = &SYMLIST           /* CONTROL SYMLIST/NOSYMLIST */
SET SYSCONLIST = &CONSLIST          /* CONTROL CONLIST/NOCONLIST */
SET SYSLIST    = &COMLIST           /* CONTROL LIST/NOLIST       */
SET SYSMSG     = &TERMMSGS          /* CONTROL MSG/NOMSG         */
 
/* *************************************** */
/* INITIALIZE LIBRARY MANAGEMENT           */
/* *************************************** */
 
SET RETURN_CODE = 0
 
ISPEXEC LMINIT DATAID(LISTUID) DDNAME(&LISTUDDN)
 
IF &RETURN_CODE NE 0 THEN DO
  WRITE &PGMNAME LMINIT_LISTUID_RC = &RETURN_CODE &ZERRSM
  SET RETURN_CODE = &RETURN_CODE + 16
  GOTO ERR_EXIT
  END
 
ISPEXEC LMOPEN DATAID(&LISTUID) OPTION(INPUT)
 
IF &RETURN_CODE NE 0 THEN DO
  WRITE &PGMNAME LMOPEN_LISTUID_RC = &RETURN_CODE &ZERRSM
  SET RETURN_CODE = &RETURN_CODE + 16
  GOTO ERR_EXIT
  END
 
ISPEXEC LMINIT DATAID(DATAID) DDNAME(&DATADDN)
 
IF &RETURN_CODE NE 0 THEN DO
  WRITE &PGMNAME LMINIT_DATAID_RC = &RETURN_CODE &ZERRSM
  SET RETURN_CODE = &RETURN_CODE + 16
  GOTO ERR_EXIT
  END
 
ISPEXEC LMOPEN DATAID(&DATAID) OPTION(OUTPUT)
 
IF &RETURN_CODE NE 0 THEN DO
  WRITE &PGMNAME LMOPEN_DATAID_RC = &RETURN_CODE &ZERRSM
  SET RETURN_CODE = &RETURN_CODE + 16
  GOTO ERR_EXIT
  END
 
SET DATAMEM = &DATAMBR        /* Can not be in PROC & GLOBAL  */
SET ICNT = 0
SET OCNT = 0
SET NR   = 0
SET NRM  = 6
SET BLK10 = &STR(          )
SET USRID   = &STR( )
SET USRNAME = &STR( )
DO X = 1 TO &NRM
  SET GRP&X = &STR(        )
  END
 
READRF: +
SET RETURN_CODE = 0
 
ISPEXEC LMGET DATAID(&LISTUID) MODE(INVAR) DATALOC(LISTU) +
  DATALEN(LRECL) MAXLEN(255)
 
IF &RETURN_CODE EQ 8 THEN GOTO EOF_LISTUSER
IF &RETURN_CODE NE 0 THEN DO
  WRITE &PGMNAME LMGET_LISTUID_RC = &RETURN_CODE &ZERRSM
  SET RETURN_CODE = &RETURN_CODE + 16
  GOTO ERR_EXIT
  END
 
IF &NRSTR(&LISTU) EQ &STR( ) THEN GOTO READRF
 
SET XL = &LENGTH(&NRSTR(&LISTU))
IF &XL LT 21 THEN GOTO READRF
 
IF &SYSINDEX(&STR(ACCESSORID =),&NRSTR(&LISTU)) GT 0 THEN DO
  SYSCALL PUT_DATA
  SET ICNT = &ICNT + 1
 
  SET USRID = &SUBSTR(14:21,&NRSTR(&LISTU))
  IF &XL GE 57 THEN +
    SET USRNAME = &SUBSTR(37:57,&NRSTR(&LISTU))
 
  SET USRID = &SUBSTR(1:8,&NRSTR(&USRID &BLK10))
  SET USRNAME = &SUBSTR(1:17,&NRSTR(&USRNAME &BLK10&BLK10))
  GOTO READRF
  END
 
IF &SUBSTR(1:5,&NRSTR(&LISTU)) EQ TYPE  THEN DO
  SET TYPE = &SUBSTR(14:21,&NRSTR(&LISTU))
  SELECT &NRSTR(&TYPE)
    WHEN (USER    ) SET TYPE = &STR(USER    )
    WHEN (CENTRAL ) SET TYPE = &STR(SCA     )
    WHEN (MASTER  ) SET TYPE = &STR(MSCA    )
    WHEN (LIMITED ) SET TYPE = &STR(LSCA    )
    WHEN (&STR(DEPT C/A)) SET TYPE = &STR(DCA     )
    WHEN (&STR(DIV  C/A)) SET TYPE = &STR(VCA     )
    WHEN (&STR(ZONE C/A)) SET TYPE = &STR(ZCA     )
    WHEN (GENERIC ) SET USRID = &STR( )
    WHEN (GROUP   ) SET USRID = &STR( )
    WHEN (PROFILE ) SET USRID = &STR( )
    WHEN (DEPT    ) SET USRID = &STR( )
    WHEN (DIV     ) SET USRID = &STR( )
    WHEN (DIVISION) SET USRID = &STR( )
    WHEN (ZONE    ) SET USRID = &STR( )
    OTHERWISE DO
      WRITE &PGMNAME Invalid TYPE &TYPE was found for report
      SET USRID = &STR( )
      END
    END
  IF &NRSTR(&USRID) NE &STR( ) THEN DO
    SET OCNT = &OCNT + 1
    SET NR = &NR + 1
    SET GRP&NR = &SUBSTR(14:21,&NRSTR(&LISTU))
    IF &NR EQ &NRM THEN SYSCALL PUT_DATA
    END
  GOTO READRF
  END
 
IF &SUBSTR(1:8,&NRSTR(&LISTU)) EQ FACILITY   THEN DO
  SET NR = &NR + 1
  SET GRP&NR = &SUBSTR(14:21,&NRSTR(&LISTU))
  IF &NR EQ &NRM THEN SYSCALL PUT_DATA
  GOTO READRF
  END
 
IF &SUBSTR(1:10,&NRSTR(&LISTU)) EQ ATTRIBUTES THEN DO
  SET XC = &SYSINDEX(&STR(,),&NRSTR(&LISTU),14)
  IF &XC EQ 0 THEN DO
    SET NR = &NR + 1
    SET GRP&NR = &SUBSTR(14:21,&NRSTR(&LISTU))
    IF &NR EQ &NRM THEN SYSCALL PUT_DATA
    GOTO READRF
    END
  ELSE DO
    SET XF = 14
 
    NEXT_ATTR: +
    SET RETURN_CODE = 0
 
    IF &XF GT 0 AND &XF LE &XC-1 THEN DO
      SET ATTR = &SUBSTR(&XF:&XC-1,&NRSTR(&LISTU))
      SET NR = &NR + 1
      SET GRP&NR = &SUBSTR(1:8,&NRSTR(&ATTR&BLK10))
      IF &NR EQ &NRM THEN SYSCALL PUT_DATA
      SET XF = &XC+1
      END
    SET XC = &SYSINDEX(&STR(,),&NRSTR(&LISTU),&XF)
    IF &XC-1 GT &XF THEN GOTO NEXT_ATTR
    SET XC = &SYSINDEX(&STR( ),&NRSTR(&LISTU),&XF)
    IF &XC-1 GT &XF THEN +
     IF &SUBSTR(&XF:&XC-1,&NRSTR(&LISTU)) NE &STR( ) THEN GOTO NEXT_ATTR
    GOTO READRF
    END
  END
 
IF &SUBSTR(1:8,&NRSTR(&LISTU)) EQ PROFILES  OR +
   &SUBSTR(1:6,&NRSTR(&LISTU)) EQ GROUPS    THEN DO
  DO XF = 14 TO 54 BY 10
    IF &XF+7 GT &XL THEN GOTO READRF
    SET GROUP = &SUBSTR(&XF:&XF+7,&NRSTR(&LISTU))
    IF &NRSTR(&GROUP) EQ &STR( ) THEN GOTO READRF
    SET NR = &NR + 1
    SET GRP&NR = &NRSTR(&GROUP)
    IF &NR EQ &NRM THEN SYSCALL PUT_DATA
    END
  END
 
GOTO READRF
 
 
EOF_LISTUSER: +
SET RETURN_CODE = 0
 
IF &NRSTR(&USRID) NE &STR( ) THEN SYSCALL PUT_DATA
 
SYSCALL ADD_MEMBER
 
SET RETURN_CODE = 0
 
ISPEXEC LMCLOSE DATAID(&LISTUID)
 
SET LMCLOSE_LISTUID_RC = &RETURN_CODE
SET RETURN_CODE = 0
 
ISPEXEC LMFREE DATAID(&LISTUID)
SET LMFREE_LISTCUD_RC = &RETURN_CODE
 
ISPEXEC LMCLOSE DATAID(&DATAID)
 
SET LMCLOSE_DATAID_RC = &RETURN_CODE
SET RETURN_CODE = 0
 
ISPEXEC LMFREE DATAID(&DATAID)
SET LMFREE_DATAID_RC = &RETURN_CODE
 
 
/* *************************************** */
/* END of program                          */
/* *************************************** */
 
END_EXIT: +
SET RETURN_CODE = 0
 
IF &NRSTR(&TERMMSGS) EQ ON THEN DO
WRITE ===============================================================
WRITE &PGMNAME Output member &DATAMBR
WRITE &PGMNAME Input IDs = &ICNT  Output USERS = &OCNT
WRITE &PGMNAME Top Secret Processing completed.
END
 
/* *************************************** */
/* ERROR EXIT                              */
/* *************************************** */
 
ERR_EXIT: +
IF &MAXCC GE 16 OR +
   &RETURN_CODE GT 0 THEN DO
  ISPEXEC VGET (ZISPFRC) SHARED
  IF &MAXCC GT &ZISPFRC THEN +
    SET ZISPFRC = &MAXCC
  ELSE +
    SET ZISPFRC = &RETURN_CODE
  ISPEXEC VPUT (ZISPFRC) SHARED
  WRITE &PGMNAME ZISPFRC = &ZISPFRC
  END
 
EXIT CODE(0)
 
/* *************************************** */
/*  SYSCALL SUBROUTINES                    */
/* *************************************** */
 
/*******************************************
/* Write record and clear variables        *
/*******************************************
 
PUT_DATA: PROC 0
 
IF &NRSTR(&USRID) EQ &STR( ) OR +
   &NRSTR(&GRP1) EQ &STR( ) THEN GOTO CLEAR_VARS
 
SET DATA = &NRSTR(&USRID &USRNAME &GRP1 &GRP2 +
           &GRP3 &GRP4 &GRP5 &GRP6)
 
SET RETURN_CODE = 0
 
ISPEXEC LMPUT DATAID(&DATAID) MODE(INVAR) DATALOC(DATA) +
  DATALEN(&LENGTH(&NRSTR(&DATA)))
 
IF &RETURN_CODE NE 0 THEN DO
  WRITE &PGMNAME LMPUT_DATAID_RC = &RETURN_CODE &ZERRSM
  RETURN CODE(&RETURN_CODE)
  END
 
CLEAR_VARS: +
SET RETURN_CODE = 0
 
DO X = 1 TO &NR
  SET GRP&X = &STR(        )
  END
SET NR = 0
 
RETURN CODE(&RETURN_CODE)
END
 
/* *************************************** */
/*  SYSCALL SUBROUTINES                    */
/* *************************************** */
 
ADD_MEMBER: PROC 0
 
SET RETURN_CODE = 0
 
ISPEXEC LMMADD DATAID(&DATAID) MEMBER(&DATAMEM)
 
IF &RETURN_CODE EQ 4 THEN DO          /* MEMBER ALREADY EXISTS
  SET RETURN_CODE = 0
 
  ISPEXEC LMMREP DATAID(&DATAID) MEMBER(&DATAMEM)
 
  IF &RETURN_CODE NE 0 THEN DO
    WRITE &PGMNAME LMMREP_DATA_RCODE = &RETURN_CODE &DATAMEM  &ZERRSM
    END
  END
ELSE DO
  IF &RETURN_CODE NE 0 THEN +
    WRITE &PGMNAME LMMADD_DATA_RCODE = &RETURN_CODE &DATAMEM  &ZERRSM
  END
 
RETURN CODE(&RETURN_CODE)
END