|
midrange.com
David,
I have a utility that I wrote about 10 years ago to do just that. As it
turns out, I only needed to use it once, so I never bothered updating
the code when RPG IV was released. It has a number of different
features, such as:
1) Check a generic list of objects for valid service data and generate a
printout of results.
2) Check a generic list of objects against up to 10 source files to find
a matching source member & print results.
3) Change existing service data by specifying where the source member is
now located.
4) Change existing service data by specifying up to 10 source files to
be searched for a matching source member (by name).
You might need to make some changes to the CLP member, because it relies
upon two sub-programs (MOVPGMMSG & RSNESCMSG) which I'm not at liberty
to distribute. Those two programs were published in News/400 by Ernie
Malaga, and I'm pretty sure you'd still be able to download them if
you're an iSeries Network subscriber. However, it would be easy to
modify the message handling such that those utilities are no longer
needed.
The code follows below.
Regards,
John Taylor
/*************************************************************/
/* Command CHGSVCDTA */
/* Author: John Taylor */
/* */
/*************************************************************/
CMD 'Change Service Data'
PARM obj qual1 +
MIN( 1 ) +
PROMPT( 'Object name' )
PARM objtype *CHAR 10 +
RSTD( *YES ) +
DFT( *PGM ) +
VALUES( *CMD *FILE *MODULE *PGM *PNLGRP *PRTIMG +
*TBL ) +
PROMPT( 'Object type' )
PARM objattr *GENERIC 10 +
DFT( *ALL ) +
SPCVAL( ( *ALL ) ) +
PROMPT( 'Object attribute' )
PARM srcfiles qual2 +
MAX( 10 ) +
PROMPT( 'Source file' )
PARM member *CHAR 10 +
SPCVAL( ( *OBJ ) ) +
DFT( *OBJ ) +
PROMPT( 'Source member' ) +
PARM action *CHAR 6 +
RSTD( *YES ) +
SPCVAL( ( *NOCHG ) ( *CHG ) ) +
DFT( *NOCHG ) +
PROMPT( 'Action for valid service data' )
PARM output *CHAR 6 +
RSTD( *YES ) +
SPCVAL( ( *PRINT ) ( *NONE ) ) +
DFT( *PRINT ) +
PROMPT( 'Output' ) +
PMTCTL( *PMTRQS )
DEP CTL( obj ) +
PARM( srcfiles ) +
MSGID( DOC0001 )
QUAL1: +
QUAL *GENERIC 10 +
SPCVAL( *ALL )
QUAL *NAME 10 +
DFT( *LIBL ) +
SPCVAL( *ALL *ALLUSR *CURLIB *LIBL *USRLIBL ) +
PROMPT( 'Library name' )
QUAL2: +
QUAL *NAME 10
QUAL *NAME 10 +
DFT( *LIBL ) +
SPCVAL( ( *LIBL ) ) +
PROMPT( 'Library name' )
/*==================================================================*/
/* Program : CHGSVCDTAC */
/* Abstract: CPP for command CHGSVCDTA. */
/* */
/* By John Taylor */
/*==================================================================*/
PGM PARM( +
&i_obj /* INPUT - Qualified object name */+
&i_objtyp /* INPUT - Object type */+
&i_objattr /* INPUT - Object attribute */+
&i_srcfiles /* INPUT - Source file(s) */+
&i_member /* INPUT - Source member */+
&i_action /* INPUT - Action for valid service data */+
&i_output /* INPUT - Output option */+
)
/* Command variables */
DCL &i_obj *CHAR 20
DCL &i_objtyp *CHAR 8
DCL &i_objattr *CHAR 10
DCL &i_srcfiles *CHAR 202
DCL &i_member *CHAR 10
DCL &i_action *CHAR 6
DCL &i_output *CHAR 6
DCL &srcfct *DEC 3 0
DCL &srcf1 *CHAR 20
DCL &srcf2 *CHAR 20
DCL &srcf3 *CHAR 20
DCL &srcf4 *CHAR 20
DCL &srcf5 *CHAR 20
DCL &srcf6 *CHAR 20
DCL &srcf7 *CHAR 20
DCL &srcf8 *CHAR 20
DCL &srcf9 *CHAR 20
DCL &srcf10 *CHAR 20
/* General work variables */
DCL &objname *CHAR 10
DCL &objlib *CHAR 10
DCL &outfile *CHAR 10 VALUE('DSPOBJOF')
DCL &msg_flag *LGL 1 VALUE('0')
DCL &file_exist *LGL 1 VALUE('0')
/* Work variables for defining mnemonics */
DCL &blank *CHAR 1 VALUE(' ')
DCL &false *LGL 1 VALUE('0')
DCL &true *LGL 1 VALUE('1')
/* Program-level monitor message */
MONMSG CPF9999 EXEC(GOTO GLOBAL_ERR)
/*==================================================================*/
/* Retrieve service data from file object(s) */
/*==================================================================*/
CHGVAR &objname (%SST(&i_obj 1 10))
CHGVAR &objlib (%SST(&i_obj 11 10))
DSPOBJD OBJ(&objlib/&objname) OBJTYPE(&i_objtyp) DETAIL(*SERVICE) +
OUTPUT(*OUTFILE) OUTFILE(QTEMP/&outfile)
MONMSG CPF2123 EXEC(DO) /* No matching objects found */
CHGVAR &msg_flag &true
GOTO CLEAN_UP
ENDDO
CHGVAR &file_exist &true
/*==================================================================*/
/* Program level MONMSG detected; flag for messages. */
/*==================================================================*/
GLOBAL_ERR:
IF (&msg_flag) DO /* To protect from error looping */
SNDPGMMSG MSGID(CPF9898) +
MSGF(QSYS/QCPFMSG) +
MSGDTA('Error in message handling process ' *CAT +
'detected during a program failure.' *TCAT +
'See joblog for details') +
MSGTYPE(*ESCAPE)
MONMSG CPF0000 EXEC(RETURN)
ENDDO
CHGVAR &msg_flag &true
/*===================================================================*/
/* Perform any program cleanup operations */
/*===================================================================*/
CLEAN_UP:
IF (&file_exist) DO
DLTF QTEMP/&outfile
MONMSG CPF0000
ENDDO
/*===================================================================*/
/* Error handling - resend messages to calling program. */
/* IF &msg_flag, then error messages are in queue to be sent. */
/*===================================================================*/
IF (&msg_flag) DO
MOVPGMMSG
MONMSG CPF0000
RSNESCMSG
MONMSG CPF0000
ENDDO
RETURN
ENDPGM
************************************************************************
**
* CHGSVCDTA - Change Service Data
*
* Parameters Type Use Notes
*
* OBJ@I CHAR 20 I Qualified object(s)
* OBTP@I CHAR 10 I Object type
* OBAT@I CHAR 10 I Object attribute
* SCFL@I CHAR 202 I Source file(s)
* SCMB@I CHAR 10 I Source member
* ACTN@I CHAR 6 I Action for valid service data
* OUTP@I CHAR 6 I Output option
*
*
************************************************************************
**
*
FQPRINT O F 198 OF PRINTER UC
*
* Array loaded at compile time with commands for QCLEXC
E CMD 1 1 80
* Array loaded at compile time with misc messages
E AMS 1 3 80
* Array of qualified source files mapped from DS SCFL
E SFA 10 20
*
* User space API data structures
I/COPY INCLUDE/QRPGSRC,USPDS
*
* DS for the User Space Generic Header.
IUSHDR DS
I 1 64 QUSBPB
* User Area
I B 65 680QUSBPC
* Size Generic Header
I 69 72 QUSBPD
* Structure Release
Level
I 73 80 QUSBPF
* Format Name
I 81 90 QUSBPG
* Api Used
I 91 103 QUSBPH
* Date Time Created
I 104 104 QUSBPJ
* Information Status
I B 105 1080QUSBPK
* Size User Space
I B 109 1120QUSBPL
* Offset Input
Parameter
I B 113 1160QUSBPM
* Size Input Parameter
I B 117 1200QUSBPN
* Offset Header
Section
I B 121 1240QUSBPP
* Size Header Section
I B 125 1280QUSBPQ
* Offset List Data
I B 129 1320QUSBPR
* Size List Data
I B 133 1360QUSBPS
* Number List Entries
I B 137 1400QUSBPT
* Size Each Entry
*
* DS for the OBJL0400 format created by QUSLOBJ
IQUSDQ DS
* Qus OBJL0400
I 1 10 QUSDQB
* Object Name Used
I 11 20 QUSDQC
* Object Lib Name Used
I 21 30 QUSDQD
* Object Type Used
I 31 31 QUSDQF
* Information Status
I 32 41 QUSDQG
* Extended Obj Attr
I 42 91 QUSDQH
* Text Description
I 92 101 QUSDQJ
* User Defined Attr
I 102 108 QUSDQK
* Reserved
I B 109 1120QUSDQL
* Aux Storage Pool
I 113 122 QUSDQM
* Object Owner
I 123 124 QUSDQN
* Object Domain
I 125 132 QUSDQP
* Create Date Time
I 133 140 QUSDQQ
* Change Date Time
I 141 150 QUSDQR
* Storage
I 151 151 QUSDQS
* Object Compress
Status
I 152 152 QUSDQT
* Allow Change
I 153 153 QUSDQV
* Changed By Program
I 154 163 QUSDQW
* Object Audit Value
I 164 172 QUSDQX
* Reserved2
I 173 182 QUSDQY
* Source File Name
I 183 192 QUSDQZ
* Source File Lib Name
I 193 202 QUSDQ0
* Source File Mbr Name
I 203 215 QUSDQ1
* Source File Update
Date Time
I 216 225 QUSDQ2
* Creator User Profile
I 226 233 QUSDQ3
* System Object
Creation
I 234 242 QUSDQ4
* System Level
I 243 258 QUSDQ5
* Compiler
I 259 266 QUSDQ6
* Object Level
I 267 267 QUSDQ7
* User Changed
I 268 283 QUSDQ8
* Licensed Program
I 284 293 QUSDQ9
* PTF
I 294 303 QUSDRB
* APAR
I 304 313 QUSDRC
* Primary Group
I 314 324 QUSDRD
* Reserved3
*
*Record structure for QUSRMBRD MBRD0100 format
IQUSCP DS
* Qdb Mbrd0100
I B 1 40QUSCPB
* Bytes Returned
I B 5 80QUSCPC
* Bytes Available
I 9 18 QUSCPD
* Db File Name
I 19 28 QUSCPF
* Db File Lib
I 29 38 QUSCPG
* Member Name
I 39 48 QUSCPH
* File Attr
I 49 58 QUSCPJ
* Src Type
I 59 71 QUSCPK
* Crt Date
I 72 84 QUSCPL
* Change Date
I 85 134 QUSCPM
* Text Desc
I 135 135 QUSCPN
* Src File
*
* API Error Return DS
I@ERRDS IDS
* Qus EC
I B 1 40QUSBNB
* Bytes Provided
I B 5 80QUSBNC
* Bytes Available
I 9 15 QUSBND
* Exception Id
I 16 16 QUSBNF
* Reserved
I 17 144 QUSBNG
* 128 bytes Of
Exception Data
* Qualified names of up to 10 source files
ISCFL DS
I B 1 20SRCCN
* #of files passed by
caller
I 3 22 SRC01
I 23 42 SRC02
I 43 62 SRC03
I 63 82 SRC04
I 83 102 SRC05
I 103 122 SRC06
I 123 142 SRC07
I 143 162 SRC08
I 163 182 SRC09
I 183 202 SRC10
I 3 202 SFA
*
*
* Change Information Data Structure for API QLICOBJD
*
* The field KEY being initialized with a value of 1
* informs the API that we want to change the
* source file information.
* The DATA field contains the information the API
* will use to replace the current values.
*
ICHGSCF DS
I I 1 B 1 40NBRRCD
I I 1 B 5 80KEY
I I 30 B 9 120LENDTA
I 13 43 DATA
I 13 32 SRCF
I 13 22 SRCFN
I 23 32 SRCFL
I 33 42 MBRNAM
*
* The field KEY being initialized with a value of 2
* informs the API that we want to change the
* source file change date information.
* The DATA field contains the information the API
* will use to replace the current values.
*
ICHGSDT DS
I I 1 B 1 40NBRRC2
I I 2 B 5 80KEY2
I I 13 B 9 120LENDT2
I 13 25 CHGDAT
*
* Object name/library from input parameter
IQOBJ DS
I 1 10 OBNAME
I 11 20 OBLIB
*
* Character date & time structure for QWCCVTDT
I@DTOVL IDS
I 1 1 @DTCY
I 2 7 @DTDT
I 8 13 @DTTM
I 14 16 @DTMS
I 1 13 CHDTTM
*
* Miscellaneous Binary Variables
I@MISC DS
I I 4 B 1 40@MNTYP
I I 1 B 5 80@MPSTK
I I 80 B 9 120@SDTAL
I I 1 B 13 160@SPSTK
I I 0 B 17 200@RPSTK
I I 256 B 21 240@RMSIL
I I 0 B 25 280@RWAIT
I I 180 B 29 320@2RCLN
I I 0 B 33 360STRPOS
I I 0 B 37 400DTALEN
I I 135 B 41 440@MDRLN
*
* All Message Type String.
IALLTYP DS
I I '*INFO ' 1 10 ALTYP1
I I '*DIAG ' 11 20 ALTYP2
I I '*COMP ' 21 30 ALTYP3
I I '*ESCAPE ' 31 40 ALTYP4
*
* Qualified QCPFMSG *LIBL
IQCPFMS DS
I I 'QCPFMSG ' 1 10 QCPFMF
I I '*LIBL ' 11 20 QCPFML
*
* Message data DS
IWRK30 DS
I 11 20 @M1120
I 21 30 @M2130
*
* Miscellaneous Constants
I 'CHGSVCDTA' C CMDNAM
I 'XXXXXXXXXX' C #FIL10
*
* Receive parameters
C *ENTRY PLIST
C QOBJ PARM OBJ@I
C PARM OBTP@I
C PARM OBAT@I
C SCFL PARM SCFL@I
C PARM SCMB@I
C PARM ACTN@I
C PARM OUTP@I
*
************************************************************************
**
* M A I N B L O C K
************************************************************************
**
*
* Create a user space in QTEMP to receive data from QUSLOBJ
C MOVEL'USLOBJ' USPNAM P
C MOVEL'QTEMP' USPLIB P
C CALL 'QUSCRTUS' 80
C PARM USRSPC Qualified
name
C PARM 'USRSPC' USPEAT Extended
Attribute
C PARM 1024 USPISZ Initial Size
C PARM X'00' USPIVL Initial Value
C PARM '*EXCLUDE'USPAUT Public
Authority
C PARM *BLANKS USPTXT Text
Description
C PARM '*YES' USPRPL Replace
Existing Spac
C PARM @ERRDS Error
Structure
*
* If any errors encountered by the API,
C *IN80 CASEQ*ON ERROR
C ENDCS
*
* Run QUSLOBJ, writing information to the user space
C RESET@ERRDS
C CALL 'QUSLOBJ' 80
C PARM USRSPC User Space
C PARM 'OBJL0400'LSTFMT 8 Format Name
C PARM OBJ@I Object(s)
C PARM OBTP@I Object Type
C PARM @ERRDS Error
Structure
*
* If any errors encountered by the API,
C *IN80 CASEQ*ON ERROR
C ENDCS
*
*
* Get user space header information
C RESET@ERRDS
C CALL 'QUSRTVUS' 80
C PARM USRSPC User Space
C PARM 1 STRPOS Starting
Position
C PARM 140 DTALEN Data Length
C PARM USHDR Data
Structure
C PARM @ERRDS Error
Structure
*
* If any errors encountered by the API,
C *IN80 CASEQ*ON ERROR
C ENDCS
*
* IF no entries exist in user space
* Send an Escape message to caller.
* CPF0001 is:
* No objects of specified name or type exist in
* library &2.
C QUSBPS IFEQ 0
C MOVE 'CPF2123' @SMID
C MOVEL'*ESCAPE '@SMTYP
C MOVEL#FIL10 @SMDTA P
C CAT OBLIB:0 @SMDTA P
C EXSR @SNMSG
C ENDIF
*
* The program terminates here because an Escape
* message was sent to the caller.
*
* IF printed output was requested
* override QPRINT to CPI(15) PAGESIZE(66 198)
C OUTP@I IFEQ '*PRINT'
C MOVELCMD,1 CMDSTR256
C CALL 'QCMDEXC'
C PARM CMDSTR
C PARM 45 CMDLEN 155
*
* If any errors encountered by the API,
C *IN80 CASEQ*ON ERROR
C ENDCS
*
* open the printer file
* output the report header
C OPEN QPRINT
C EXCPTHEADER
C ENDIF
*
* Move attribute parameter to work var
* IF subset on attribute required
* calculate length of attribute
C MOVE OBAT@I OBAT
C OBAT@I IFNE '*ALL'
C ' ' CHEKROBAT X
C 10 SUB X X
* check for generic name
C '*' CHEKROBAT GNLEN
* IF generic name
* adjust length of attribute
* strip special char '*' from attribute
C GNLEN IFNE 0
C SUB 1 X
C X SUBSTOBAT@I OBAT
C ENDIF
C ENDIF
*
* Read each list data section entry
* The starting byte number is the list data section's offset plus
1.
* The length of the data to retrieve (each entry) equals QUSBPT.
C QUSBPQ ADD 1 STRPOS
C Z-ADDQUSBPT DTALEN
* Repeat the process QUSBPS times
C 1 DO QUSBPS
* Read the user space. The length of data being retreived
* is 324 (the length of the QUSDQ data structure).
C RESET@ERRDS
C CALL 'QUSRTVUS' 80
C PARM USRSPC User Space
C PARM STRPOS Starting
Position
C PARM 324 DTALEN Data Length
C PARM QUSDQ Data
Structure
C PARM @ERRDS Error
Structure
* If any errors encountered by the API,
C *IN80 CASEQ*ON ERROR
C ENDCS
* Increment the number of the first byte read by QUSBPT in
* preparation for next read. This allows us to ITER past
entries.
C ADD QUSBPT STRPOS
* IF subset on attribute required
* fetch substring for comparison
C OBAT@I IFNE '*ALL'
C X SUBSTQUSDQG USDQG
* IF object attribute <> specified attribute
* skip this entry
C OBAT IFNE USDQG
C ITER
C ENDIF
C ENDIF
* Process the entry
C EXSR PROCSS
C ENDDO
*
* IF printed output was requested
* output the report summary
* close the printer file
C OUTP@I IFEQ '*PRINT'
C OF EXCPTHEADER
C EXCPTTOTALS
C CLOSEQPRINT
C ENDIF
*
* Delete the user space
C RESET@ERRDS
C CALL 'QUSDLTUS' 80
C PARM USRSPC User Space
C PARM @ERRDS Error
Structure
*
* End of job....
C ENDPGM TAG
C MOVE *ON *INLR
C RETRN
*
************************************************************************
**
* Subroutines
*
************************************************************************
**
* PROCSS - Process a single entry
C PROCSS BEGSR
*
* Increment number of objects analyzed
C ADD 1 ANZCNT
*
* Move object name & type to report fields
C MOVELQUSDQB OUOBNM
C MOVELQUSDQD OUOBTP
*
* IF information status field is 'A'
* (not enough authority to object)
* IF report is being printed
* output an error message
* branch to end of routine
C QUSDQF IFEQ 'A'
C OUTP@I IFEQ '*PRINT'
C MOVELAMS,1 MSCDTA190 P
C CAT QUSDQB:1 MSCDTA
C CAT 'in':1 MSCDTA
C CAT 'lib':1 MSCDTA
C CAT QUSDQC:1 MSCDTA
C CAT '.':0 MSCDTA
C OF EXCPTHEADER
C EXCPTDETAIL
C OF EXCPTHEADER
C EXCPTMSCLIN
C ENDIF
C GOTO PROCS9
C ENDIF
*
* IF information status field is 'D'
* OR information status field is 'P'
* (object is damaged)
* IF report is being printed
* output an error message
* branch to end of routine
C QUSDQF IFEQ 'D'
C QUSDQF OREQ 'P'
C OUTP@I IFEQ '*PRINT'
C MOVEL'Object' MSCDTA P
C CAT QUSDQB:1 MSCDTA
C CAT 'in':1 MSCDTA
C CAT 'lib':1 MSCDTA
C CAT QUSDQC:1 MSCDTA
C CAT 'is dam':1MSCDTA
C CAT 'aged.':0 MSCDTA
C OF EXCPTHEADER
C EXCPTMSCLIN
C ENDIF
C GOTO PROCS9
C ENDIF
*
* IF information status field is 'L'
* (object is locked)
* IF report is being printed
* output an error message
* branch to end of routine
C QUSDQF IFEQ 'D'
C OUTP@I IFEQ '*PRINT'
C MOVEL'Object' MSCDTA P
C CAT QUSDQB:1 MSCDTA
C CAT 'in':1 MSCDTA
C CAT 'lib':1 MSCDTA
C CAT QUSDQC:1 MSCDTA
C CAT 'is loc':1MSCDTA
C CAT 'ked.':0 MSCDTA
C OF EXCPTHEADER
C EXCPTDETAIL
C OF EXCPTHEADER
C EXCPTMSCLIN
C ENDIF
C GOTO PROCS9
C ENDIF
*
* Append object attribute to object type
C CAT QUSDQG:1 OUOBTP
*
* Format creation date & move to report field
C QUSDQP IFNE *BLANKS
C RESET@ERRDS
C CALL 'QWCCVTDT' 80
C PARM '*DTS' @DTIFM 10 Input format
C PARM QUSDQP @DTIVL 13 Create
date/time
C PARM '*MDY' @DTOFM 10 Output format
C PARM *BLANKS @DTOVL Output value
C PARM @ERRDS Error
Structure
* If any errors encountered by the API
C *IN80 CASEQ*ON ERROR
C ENDCS
C MOVE @DTDT OUOBCD
C ENDIF
*
* Move object text to report field
C MOVELQUSDQH OUOBTX
*
* Retrieve member description of original source
C MOVELQUSDQY SRCF P
C MOVE QUSDQZ SRCF
C MOVE QUSDQ0 MBRNAM
C EXSR RTMBD
*
* IF service data exists
* AND source change date/time doesn't match
* we have bad service data
C SVCFLG IFEQ '1'
C QUSCPL ANDNEQUSDQ1
C MOVE '0' SVCFLG
C ENDIF
*
* Move service data to report fields
C MOVELQUSDQY OUOSFN
C MOVELQUSDQZ OUOSFL
C MOVELQUSDQ0 OUOSFM
*
* IF valid service data
* AND no action required for valid service data
* branch around changes to service data
C SVCFLG IFEQ '1'
C ACTN@I ANDEQ'*NOCHG'
C GOTO PROCS8
C ENDIF
*
* Check each source file passed by caller (up to 10) for
* the first matching member name.
*
* Setup member name
C SCMB@I IFEQ '*OBJ'
C MOVELQUSDQB MBRNAM
C ELSE
C MOVELSCMB@I MBRNAM
C ENDIF
*
* Repeat the process SRCCN times
C DO SRCCN X
* Check source file 'X' for matching member
C MOVELSFA,X SRCF P
C EXSR RTMBD
* IF usable service data was found
* change the service data for the object
* exit loop processing
C SVCFLG IFEQ '1'
C EXSR CHOBD
C LEAVE
C ENDIF
C ENDDO
*
C PROCS8 TAG
*
* IF printed output was requested
* output a detail line
C OUTP@I IFEQ '*PRINT'
C OF EXCPTHEADER
C EXCPTDETAIL
* IF pending error message from routine CHOBD
* output the error message
C CHGERR IFEQ '1'
C OF EXCPTHEADER
C EXCPTMSCLIN
C ENDIF
* IF no usable service data found
* output an error message
C SVCFLG IFEQ '0'
C MOVELAMS,3 MSCDTA P
C OF EXCPTHEADER
C EXCPTMSCLIN
C ENDIF
C ENDIF
*
C PROCS9 ENDSR
*-----------------------------------------------------------------------
-*
* RTMBD - Retrieve Member Description
CSR RTMBD BEGSR
*
* Retrieve member description of object source
C RESET@ERRDS
C Z-ADD128 QUSBNB
C CALL 'QUSRMBRD' 80
C PARM QUSCP
C PARM @MDRLN
C PARM 'MBRD0100'@MDFMN 8
C PARM SRCF @MDFLQ 20
C PARM MBRNAM @MDMBR 10
C PARM '0' @MDOVP 1
C PARM @ERRDS
*
* The following errors returned by API indicate bad service data
* CPF32DE - Value &1 for find member parameter is not valid.
* CPF32DF - Member &3 not found.
* CPF3C23 - Object &1 is not a database file
* CPF3C26 - File &1 has no members.
* CPF3C27 - Cannot get information about member &3 from file &1.
* CPF9810 - Library &1 not found.
* CPF9812 - File &1 in library &2 not found.
* CPF9815 - Member &5 file &2 in library &3 not found.
C MOVE '1' SVCFLG
C QUSBND IFNE *BLANKS
C QUSBND IFEQ 'CPF32DE'
C QUSBND OREQ 'CPF32DF'
C QUSBND OREQ 'CPF3C23'
C QUSBND OREQ 'CPF3C26'
C QUSBND OREQ 'CPF3C27'
C QUSBND OREQ 'CPF9810'
C QUSBND OREQ 'CPF9812'
C QUSBND OREQ 'CPF9815'
C MOVE '0' SVCFLG
C ELSE
*
* Any other API error is unexpected and should be sent
* to the caller as an exception error.
C MOVE QUSBND @SMID
C MOVEL'*ESCAPE '@SMTYP
C MOVELQUSBNG @SMDTA P
C EXSR @SNMSG
* The program terminates here because an Escape
* message was sent to the caller.
C ENDIF
C ENDIF
*
* IF the file specified is not a source file,
* we have bad service data
C QUSCPN IFNE '1'
C MOVE '0' SVCFLG
C ENDIF
*
CSR ENDSR
*-----------------------------------------------------------------------
-*
* CHOBD - Change Object Description
CSR CHOBD BEGSR
*
* Assume no error
C MOVE '0' CHGERR
*
* Call "Change Object Description" API
* to change the source file name
C MOVELQUSDQB OBJLIB 20 P
C MOVE QUSDQC OBJLIB
C RESET@ERRDS
C CALL 'QLICOBJD' 80
C PARM RTNLIB 10
C PARM OBJLIB
C PARM QUSDQD OBJTYP 10
C PARM CHGSCF
C PARM @ERRDS
*
* IF an error was generated by API
* move errors to caller
C *IN80 IFEQ *ON
C EXSR MOVERR
* Setup a message for output on report
* Branch to end of sub-routine
C MOVE '1' CHGERR
C MOVELAMS,2 MSCDTA P
C GOTO RTMBD9
C ENDIF
*
* Move new service data to report fields
C MOVELSRCF OUNSCF P
C MOVELMBRNAM OUNSFM P
*
* Call "Change Object Description" API
* to change the source changed date & time
C MOVE QUSCPL CHGDAT P
C RESET@ERRDS
C CALL 'QLICOBJD' 80
C PARM RTNLIB 10
C PARM OBJLIB
C PARM QUSDQD OBJTYP 10
C PARM CHGSDT
C PARM @ERRDS
*
* IF an error was generated by API
* move errors to caller
C *IN80 IFEQ *ON
C EXSR MOVERR
* Setup a message for output on report
* Branch to end of sub-routine
C MOVE '1' CHGERR
C MOVELAMS,2 MSCDTA P
C GOTO RTMBD9
C ENDIF
*
* Increment number of objects changed
C ADD 1 CHGCNT
*
CSR RTMBD9 ENDSR
*-----------------------------------------------------------------------
-*
* ERROR - General Error Handler
CSR ERROR BEGSR
*
* Receive PGM Message & Move To Caller
C EXSR MOVERR
*
* Send an Escape message to caller.
* CPF0001 is:
* Error found on &1 command.
C MOVE 'CPF0001' @SMID
C MOVEL'*ESCAPE '@SMTYP
C MOVELCMDNAM @SMDTA P
*
C EXSR @SNMSG
*
* The program terminates here because an Escape
* message was sent to the caller.
*
CSR ENDSR
*-----------------------------------------------------------------------
-*
* MOVERR - Move All Messages To Caller
CSR MOVERR BEGSR
*
* Call "Receive Program Message" API
* to remove the RPG999, Message received.
C RESET@ERRDS
C CALL 'QMHRCVPM'
C PARM @RMINF256
C PARM 256 @RMSIL
C PARM 'RCVM0200'@RFMT 8
C PARM '*' @RPGMQ 10
C PARM 0 @RPSTK
C PARM '*LAST '@RMTYP 10
C PARM ' ' @RMKEY 4
C PARM 0 @RWAIT
C PARM '*REMOVE '@RMACT 10
C PARM @ERRDS
*
* Call "Move Program Message" API
* to redirect all messages to caller
C RESET@ERRDS
C CALL 'QMHMOVPM'
C PARM ' ' @MKEY 4
C PARM ALLTYP @MTYPE 40
C PARM 4 @MNTYP
C PARM '*' @MPGMQ 10
C PARM 1 @MPSTK
C PARM @ERRDS
*
CSR ENDSR
*-----------------------------------------------------------------------
-*
* @SNMSG - Send Program Message
CSR @SNMSG BEGSR
* Call "Send Program Message" API
* to send messages to caller.
C RESET@ERRDS
C CALL 'QMHSNDPM'
C PARM @SMID 7
C PARM QCPFMS @SMSGF 20
C PARM @SMDTA 80
C PARM 80 @SDTAL
C PARM @SMTYP 10
C PARM '*' @SPGMQ 10
C PARM 1 @SPSTK
C PARM @SMKEY 4
C PARM @ERRDS
CSR ENDSR
******************* Program Initialization
*****************************
CSR *INZSR BEGSR
*
* Define data types
C MOVE *BLANKS $C1 1 Char(1)
C MOVE *BLANKS $C6 6 Char(6)
C MOVE *BLANKS $C10 10 Char(10)
C MOVE *BLANKS $C20 20 Char(20)
C MOVE *BLANKS $C202 202 Char(202)
*
* Define parameters
C *LIKE DEFN $C20 OBJ@I
C *LIKE DEFN $C10 OBTP@I
C *LIKE DEFN $C10 OBAT@I
C *LIKE DEFN $C202 SCFL@I
C *LIKE DEFN $C10 SCMB@I
C *LIKE DEFN $C6 ACTN@I
C *LIKE DEFN $C6 OUTP@I
*
* Define report output variables
C *LIKE DEFN $C10 OUOSFN
C *LIKE DEFN $C10 OUOSFL
C *LIKE DEFN $C10 OUOSFM
C *LIKE DEFN $C10 OUOBNM
C *LIKE DEFN $C10 OUOBTP
C *LIKE DEFN QUSDQH OUOBTX
C *LIKE DEFN $C20 OUNSCF
C *LIKE DEFN $C10 OUNSFM
C Z-ADD0 OUOBCD 60
C Z-ADD0 ANZCNT 40 No. Analyzed
C Z-ADD0 CHGCNT 40 No. Changed
*
* Define misc work variables
C *LIKE DEFN OBAT@I OBAT
C *LIKE DEFN QUSDQG USDQG
C MOVE *BLANKS CHGERR 1
C MOVE *BLANKS SVCFLG 1
*
C Z-ADD0 X 40
C Z-ADD0 GNLEN 40
*
* Convert source file count from binary to decimal
C Z-ADDSRCCN SRCCNT 30
*
* Fetch system time
C TIME CLOCK 60
*
CSR ENDSR
******************* Output Specifications
*****************************
* Header Specifications
OQPRINT E 2 1 HEADER
O UDATE Y 8
O CLOCK + 1 ' : : '
O 78 'Change Service Data'
O 125 'Page:'
O PAGE Z 132
O E 1 HEADER
O 17 'Object name . . :'
O OBNAME + 1
O E 1 HEADER
O 17 'Object type . . :'
O OBTP@I + 1
O + 2 'Attribute:'
O OBAT@I + 1
O E 2 HEADER
O 17 'Object library :'
O OBLIB + 1
O E 1 HEADER
O 10 'Object '
O + 1 'Type '
O + 1 'Src File '
O + 1 'Src Lib '
O + 1 'Src Member'
O + 1 'Creation'
O + 1 'New Source'
O + 22 'Object Text'
*
* Detail Specifications
OQPRINT E 1 DETAIL
O OUOBNM B 10
* Object name
O OUOBTP B+ 1
* Object type w/attribute
O OUOSFN B+ 1
* Original source file name
O OUOSFL B+ 1
* Original source file lib
O OUOSFM B+ 1
* Original source file member
O OUOBCDYB+ 1
* Object creation date (mm/dd/yy)
O OUNSCF B+ 1
* New source file name
O OUNSFM B+ 1
* New source file member
O OUOBTX B+ 1
* Object text
*
* Report totals
OQPRINT E 2 TOTALS
O ANZCNTJ 8
O + 1 'Objects analyzed'
O CHGCNTJ + 10
O + 1 'Objects changed'
*
* 190 Column Misc Line
OQPRINT E 1 MSCLIN
O 3 '*'
O MSCDTA B+ 1
*
** Command Definitions For QCMDEXC
OVRPRTF FILE(QPRINT) CPI(15) PAGESIZE(66 198)
** Misc Messages
Not authorized to object
An error occurred while trying to update service data. See job log.
Could not find corresponding source member in specified list of files.
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2024 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
