Return to the RPG Tips
Two ways of Retrieving System Name with an API
1st way:
D/COPY QSYSINC/QRPGLESRC,QUSEC
D RtvNetAttr PR ExtPgm('QWCRNETA')
D Receiver 128 Options(*VarSize)
D SizeReceiver 10I 0 Const
D NbrAttrs 10I 0 Const
D AttrNames 10 Const
D ErrorStruct Const Like(QUSEC)
D NetAttrs DS
D NbrOffsets 10I 0
D OffsetTable 10I 0 Dim(1)
D RoomForMore 120
D pNetAttr S *
D NetAttrTable DS Based(pNetAttr)
D NetAttrName 10
D NetAttrDtaTyp 1
D NetAttrInfSts 1
D NetAttrDtaLen 10I 0
D NetAttrValue 32
QUSBPRV = %Size(QUSEC) ;
RtvNetAttr(NetAttrs: %Size(NetAttrs): 1: 'SYSNAME': QUSEC) ;
If (QUSBAVL = 0) ;
pNetAttr = %Addr(NetAttrs) + OffsetTable(1);
EndIF ;
If QUSBAVL > 0 or NetAttrName = 'SYSNAME' ;
SystemName = %Subst(NetAttrValue: 1: NetAttrDtaLen) ;
EndIF ;
Thank you to Dennis Lovelady for sending me this routine.
Second way:
Sure, I know a way in RPG IV... :) Of course, its not nearly as simple as calling the CL RTVNETA command, it actually involves calling an API.
But, if you wanted to make a service program, you could make it just as easy to use as the CL command...
The API you need to use is called QWCRNETA and its documented in the
Work Management API manual.
As an example, I created a subprocedure (designed to be easily made into a service program) that illustrates using this API to get the system
name. Hope you find it useful. Here it is:
** Note: To do this right, we should put this prototype into
* a /COPY member. (but will work okay as-is)
D RtvSysName PR 10I 0
D SystemName 8A
C if RtvSysName(MyName) < 0
c eval Msg = 'RtvSysName ended in error!'
c dsply Msg 50
c else
c dsply MyName 8
c endif
c eval *inlr = *on
** Note: If we wanted to do this right, the code below should
* be seperated into a service program (but will work
* okay as-is)
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* Retrieve System Name procedure: RtvSysName
*
* Parm: SysName = name of system returned.
*
* Returns: 0 = Success
* negative value if an error occurred. See below
* for a list of possible negative values.
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P RtvSysName B Export
D RtvSysName PI 10I 0
D SysName 8A
D QWCRNETA PR ExtPgm('QWCRNETA')
D RcvVar 32766A OPTIONS(*VARSIZE)
D RcvVarLen 10I 0 const
D NbrNetAtr 10I 0 const
D AttrNames 10A const
D ErrorCode 256A
D* Error code structure
D EC DS
D* Bytes Provided (size of struct)
D EC_BytesP 1 4B 0 INZ(256)
D* Bytes Available (returned by API)
D EC_BytesA 5 8B 0 INZ(0)
D* Msg ID of Error Msg Returned
D EC_MsgID 9 15
D* Reserved
D EC_Reserve 16 16
D* Msg Data of Error Msg Returned
D EC_MsgDta 17 256
D* Receiver variable for QWCRNETA with only one attribute
D RV ds
D* Number of Attrs returned
D RV_Attrs 10I 0
D* Offset to first attribute
D RV_Offset 10I 0
D* Add'l data returned.
D RV_Data 1A DIM(1000)
D* Network attribute structure
D p_NA S *
D NA ds based(p_NA)
D* Attribute Name
D NA_Attr 10A
D* Type of Data. C=Char, B=Binary
D NA_Type 1A
D* Status. L=Locked, Blank=Normal
D NA_Status 1A
D* Length of Data
D NA_Length 10I 0
D* Actual Data (in character)
D NA_DataChr 1000A
D* Actual Data (in binary)
D NA_DataInt 10I 0 overlay(NA_DataChr:1)
C* Call API to get system name
C* -1 = API returned an error
C callp QWCRNETA(RV: %size(RV): 1: 'SYSNAME': EC)
c if EC_BytesA > 0
c return -1
c endif
C* -2 = RcvVar contained data that we
C* dont understand :(
c if RV_Attrs <> 1
c or RV_Offset < 8
c or RV_Offset > 1000
c return -2
c endif
C* Attach NetAttr structure
c eval RV_Offset = RV_Offset - 7
c eval p_NA = %addr(RV_Data(RV_Offset))
C* -3 = NetAttr structure had data
C* that we don't understand :(
c if NA_Attr <> 'SYSNAME'
c or NA_Length < 1
c or NA_Length > 8
c return -3
c endif
C* -4 = Network attributes are locked
c if NA_Status = 'L'
c return -4
c endif
C* Ahhh... we got it!
c eval SysName = %subst(NA_DataChr:1:NA_Length)
c return 0
P E
[report a broken link by clicking here]