Function VSAM146: Tier Aware Subroutines with List Parameters
Name: VSAM146
Description: The following RDML function demonstrates programming techniques that can be used in tier aware subroutines that use lists as arguments or return values.
Special Notes: You should check this function into your iSeries server system and compile it there as well as in your Visual LANSA environment.
********** COMMENT(This an example of a smart);
********** COMMENT(subroutine that returns a);
********** COMMENT(list of employees, details);
********** COMMENT(of the department and section);
********** COMMENT(they work in and a count);
********** COMMENT(of their skills. The caller);
********** COMMENT(provides a generic name in);
********** COMMENT(#SRCHNAME and an operation);
********** COMMENT(in #RETN_RQST and a list of);
********** COMMENT(the details of all matching);
********** COMMENT(employees is returned. This);
********** COMMENT(routine is tier sensitive.);
FUNCTION OPTIONS(*DIRECT *MLOPTIMIZE *HEAVYUSAGE *DBOPTIMIZE) RCV_LIST(#RETN_LIST);
********** COMMENT(Define the list that is to be passed about);
DEFINE FIELD(#XXX_COUNT) TYPE(*DEC) LENGTH(7) DECIMALS(0);
DEFINE FIELD(#TOTSKILLS) REFFLD(#XXX_COUNT);
GROUP_BY NAME(#XG_LIST) FIELDS(#EMPNO #GIVENAME #SURNAME #DEPTMENT #DEPTDESC #SECTION #SECDESC #TOTSKILLS);
********** COMMENT(Standard definition and exchange);
********** COMMENT(of arguments.);
DEFINE FIELD(#RETN_RQST) TYPE(*CHAR) LENGTH(10);
DEFINE FIELD(#SRCHNAME) REFFLD(#SURNAME);
EXCHANGE FIELDS(#RETN_RQST #SRCHNAME) OPTION(*ALWAYS);
********** COMMENT(Return list definitions);
DEFINE FIELD(#RETN_ETOT) REFFLD(#XXX_COUNT) DESC('Total entries in Retn__LIST');
DEFINE FIELD(#WORK_ETOT) REFFLD(#XXX_COUNT) DESC('Total entries in WORK_LIST');
DEFINE FIELD(#WORK_POSN) REFFLD(#XXX_COUNT) DESC('Current position in WORK_LIST');
DEFINE FIELD(#RETN_EMAX) REFFLD(#XXX_COUNT) DESC('Max entries allowed in RETN_LIST') DEFAULT(50);
DEF_LIST NAME(#RETN_LIST) FIELDS(#XG_LIST) COUNTER(#RETN_ETOT) TYPE(*WORKING);
DEFINE FIELD(#WORK_EMAX) REFFLD(#XXX_COUNT) DESC('Max entries allowed in WORK_LIST') DEFAULT(9999);
DEF_LIST NAME(#WORK_LIST) FIELDS(#XG_LIST) COUNTER(#WORK_ETOT) TYPE(*WORKING) ENTRYS(9999);
DEFINE FIELD(#RETN_RETC) TYPE(*CHAR) LENGTH(2);
********** COMMENT(On any tier clear the return list now);
CLR_LIST NAMED(#RETN_LIST);
********** COMMENT(===================================);
********** COMMENT(If on application tier then);
********** COMMENT(return the list values now);
********** COMMENT(else If not on application tier);
********** COMMENT(then invoke on the application tier);
********** COMMENT(===================================);
********** COMMENT(On any tier clear the return list now);
IF COND('*Appl_Tier = YES');
EXECUTE SUBROUTINE(RETURNLIST);
ELSE;
EXECUTE SUBROUTINE(INVOKELIST);
ENDIF;
********** COMMENT(Finished);
RETURN;
********** COMMENT(====================================);
********** COMMENT(Invoke this function on another tier);
********** COMMENT(====================================);
SUBROUTINE NAME(INVOKELIST);
USE BUILTIN(CALL_SERVER_FUNCTION) WITH_ARGS(*APPL_TIER *FUNCTION Y Y #RETN_LIST) TO_GET(#RETN_RETC);
IF COND('#RETN_RETC *NE OK');
CHANGE FIELD(#RETN_RQST) TO(END);
ENDIF;
ENDROUTINE;
********** COMMENT(===============================);
********** COMMENT(Return the parameter list );
********** COMMENT(===============================);
SUBROUTINE NAME(RETURNLIST);
********** COMMENT(If the request is to select);
********** COMMENT(then build up a WORK_LIST);
********** COMMENT(with all matching details);
IF COND('#RETN_RQST = Select');
CHANGE FIELD(#STD_OBJ) TO(*DATA_TIER);
CLR_LIST NAMED(#WORK_LIST);
CHANGE FIELD(#WORK_POSN) TO(0);
SELECT FIELDS(#EMPNO #SURNAME #GIVENAME #DEPTMENT #SECTION) FROM_FILE(PSLMST2) WITH_KEY(#SRCHNAME) GENERIC(*YES);
IF COND('#WORK_ETOT = #WORK_EMAX');
MESSAGE MSGTXT('Too many employee found. Search was stopped at maximum value');
LEAVE;
ELSE;
CHANGE FIELD(#DEPTDESC #SECDESC) TO(*NAVAIL);
FETCH FIELDS(#DEPTDESC) FROM_FILE(DEPTAB) WITH_KEY(#DEPTMENT) KEEP_LAST(50);
FETCH FIELDS(#SECDESC) FROM_FILE(SECTAB) WITH_KEY(#DEPTMENT #SECTION) KEEP_LAST(50);
CHANGE FIELD(#TOTSKILLS) TO(0);
SELECT FIELDS(#SKILCODE) FROM_FILE(PSLSKL) WITH_KEY(#EMPNO);
CHANGE FIELD(#TOTSKILLS) TO('#TOTSKILLS + 1');
ENDSELECT;
ADD_ENTRY TO_LIST(#WORK_LIST);
ENDIF;
ENDSELECT;
ENDIF;
********** COMMENT(Put as much of the WORK_LIST as);
********** COMMENT(will fit it into the RETN_LIST);
DOWHILE COND('(#WORK_POSN < #WORK_ETOT) and (#RETN_ETOT < #RETN_EMAX)');
CHANGE FIELD(#WORK_POSN) TO('#WORK_Posn + 1');
GET_ENTRY NUMBER(#WORK_POSN) FROM_LIST(#WORK_LIST);
ADD_ENTRY TO_LIST(#RETN_LIST);
ENDWHILE;
********** COMMENT(Set the return request value);
********** COMMENT(to MORE to do or END of);
********** COMMENT(list encountered as required );
IF COND('#WORK_POSN < #WORK_ETOT');
CHANGE FIELD(#RETN_RQST) TO(MORE);
ELSE;
CHANGE FIELD(#RETN_RQST) TO(END);
ENDIF;
********** COMMENT(Finished);
ENDROUTINE;
Name: VSAM146
Description: The following RDML function demonstrates programming techniques that can be used in tier aware subroutines that use lists as arguments or return values.
Special Notes: You should check this function into your iSeries server system and compile it there as well as in your Visual LANSA environment.
********** COMMENT(This an example of a smart);
********** COMMENT(subroutine that returns a);
********** COMMENT(list of employees, details);
********** COMMENT(of the department and section);
********** COMMENT(they work in and a count);
********** COMMENT(of their skills. The caller);
********** COMMENT(provides a generic name in);
********** COMMENT(#SRCHNAME and an operation);
********** COMMENT(in #RETN_RQST and a list of);
********** COMMENT(the details of all matching);
********** COMMENT(employees is returned. This);
********** COMMENT(routine is tier sensitive.);
FUNCTION OPTIONS(*DIRECT *MLOPTIMIZE *HEAVYUSAGE *DBOPTIMIZE) RCV_LIST(#RETN_LIST);
********** COMMENT(Define the list that is to be passed about);
DEFINE FIELD(#XXX_COUNT) TYPE(*DEC) LENGTH(7) DECIMALS(0);
DEFINE FIELD(#TOTSKILLS) REFFLD(#XXX_COUNT);
GROUP_BY NAME(#XG_LIST) FIELDS(#EMPNO #GIVENAME #SURNAME #DEPTMENT #DEPTDESC #SECTION #SECDESC #TOTSKILLS);
********** COMMENT(Standard definition and exchange);
********** COMMENT(of arguments.);
DEFINE FIELD(#RETN_RQST) TYPE(*CHAR) LENGTH(10);
DEFINE FIELD(#SRCHNAME) REFFLD(#SURNAME);
EXCHANGE FIELDS(#RETN_RQST #SRCHNAME) OPTION(*ALWAYS);
********** COMMENT(Return list definitions);
DEFINE FIELD(#RETN_ETOT) REFFLD(#XXX_COUNT) DESC('Total entries in Retn__LIST');
DEFINE FIELD(#WORK_ETOT) REFFLD(#XXX_COUNT) DESC('Total entries in WORK_LIST');
DEFINE FIELD(#WORK_POSN) REFFLD(#XXX_COUNT) DESC('Current position in WORK_LIST');
DEFINE FIELD(#RETN_EMAX) REFFLD(#XXX_COUNT) DESC('Max entries allowed in RETN_LIST') DEFAULT(50);
DEF_LIST NAME(#RETN_LIST) FIELDS(#XG_LIST) COUNTER(#RETN_ETOT) TYPE(*WORKING);
DEFINE FIELD(#WORK_EMAX) REFFLD(#XXX_COUNT) DESC('Max entries allowed in WORK_LIST') DEFAULT(9999);
DEF_LIST NAME(#WORK_LIST) FIELDS(#XG_LIST) COUNTER(#WORK_ETOT) TYPE(*WORKING) ENTRYS(9999);
DEFINE FIELD(#RETN_RETC) TYPE(*CHAR) LENGTH(2);
********** COMMENT(On any tier clear the return list now);
CLR_LIST NAMED(#RETN_LIST);
********** COMMENT(===================================);
********** COMMENT(If on application tier then);
********** COMMENT(return the list values now);
********** COMMENT(else If not on application tier);
********** COMMENT(then invoke on the application tier);
********** COMMENT(===================================);
********** COMMENT(On any tier clear the return list now);
IF COND('*Appl_Tier = YES');
EXECUTE SUBROUTINE(RETURNLIST);
ELSE;
EXECUTE SUBROUTINE(INVOKELIST);
ENDIF;
********** COMMENT(Finished);
RETURN;
********** COMMENT(====================================);
********** COMMENT(Invoke this function on another tier);
********** COMMENT(====================================);
SUBROUTINE NAME(INVOKELIST);
USE BUILTIN(CALL_SERVER_FUNCTION) WITH_ARGS(*APPL_TIER *FUNCTION Y Y #RETN_LIST) TO_GET(#RETN_RETC);
IF COND('#RETN_RETC *NE OK');
CHANGE FIELD(#RETN_RQST) TO(END);
ENDIF;
ENDROUTINE;
********** COMMENT(===============================);
********** COMMENT(Return the parameter list );
********** COMMENT(===============================);
SUBROUTINE NAME(RETURNLIST);
********** COMMENT(If the request is to select);
********** COMMENT(then build up a WORK_LIST);
********** COMMENT(with all matching details);
IF COND('#RETN_RQST = Select');
CHANGE FIELD(#STD_OBJ) TO(*DATA_TIER);
CLR_LIST NAMED(#WORK_LIST);
CHANGE FIELD(#WORK_POSN) TO(0);
SELECT FIELDS(#EMPNO #SURNAME #GIVENAME #DEPTMENT #SECTION) FROM_FILE(PSLMST2) WITH_KEY(#SRCHNAME) GENERIC(*YES);
IF COND('#WORK_ETOT = #WORK_EMAX');
MESSAGE MSGTXT('Too many employee found. Search was stopped at maximum value');
LEAVE;
ELSE;
CHANGE FIELD(#DEPTDESC #SECDESC) TO(*NAVAIL);
FETCH FIELDS(#DEPTDESC) FROM_FILE(DEPTAB) WITH_KEY(#DEPTMENT) KEEP_LAST(50);
FETCH FIELDS(#SECDESC) FROM_FILE(SECTAB) WITH_KEY(#DEPTMENT #SECTION) KEEP_LAST(50);
CHANGE FIELD(#TOTSKILLS) TO(0);
SELECT FIELDS(#SKILCODE) FROM_FILE(PSLSKL) WITH_KEY(#EMPNO);
CHANGE FIELD(#TOTSKILLS) TO('#TOTSKILLS + 1');
ENDSELECT;
ADD_ENTRY TO_LIST(#WORK_LIST);
ENDIF;
ENDSELECT;
ENDIF;
********** COMMENT(Put as much of the WORK_LIST as);
********** COMMENT(will fit it into the RETN_LIST);
DOWHILE COND('(#WORK_POSN < #WORK_ETOT) and (#RETN_ETOT < #RETN_EMAX)');
CHANGE FIELD(#WORK_POSN) TO('#WORK_Posn + 1');
GET_ENTRY NUMBER(#WORK_POSN) FROM_LIST(#WORK_LIST);
ADD_ENTRY TO_LIST(#RETN_LIST);
ENDWHILE;
********** COMMENT(Set the return request value);
********** COMMENT(to MORE to do or END of);
********** COMMENT(list encountered as required );
IF COND('#WORK_POSN < #WORK_ETOT');
CHANGE FIELD(#RETN_RQST) TO(MORE);
ELSE;
CHANGE FIELD(#RETN_RQST) TO(END);
ENDIF;
********** COMMENT(Finished);
ENDROUTINE;