DSN8FPRC
.
&SYSPARM TITLE 'SAMPLE FIELD PROCEDURE'
&SYSPARM AMODE 31 ADDRESS IN 31 BITS
&SYSPARM RMODE ANY RESIDE ANYWHERE
&SYSPARM START 0
***********************************************************************
* MODULE NAME = DSN8FPRC *
* DESCRIPTIVE NAME = FIELD PROCEDURE *
* LICENSED MATERIALS - PROPERTY OF IBM *
* 5635-DB2 *
* (C) COPYRIGHT 1995, 2006 IBM CORP. ALL RIGHTS RESERVED. *
* *
* STATUS = VERSION 9 *
***********************************************************************
* PURPOSE OF THE MODULE *
* --------------------- *
* CHANGE THE SORTING ORDER OF A CHAR(6) FIELD FROM *
* EBCDIC TO ASCII SEQUENCE. *
***********************************************************************
* RESTRICTIONS *
* ------------ *
* THIS FIELD PROCEDURE WAS DESIGNED TO WORK WITH *
* NUMBERS AND UPPER AND LOWER CASE LETTERS ONLY. *
* SPECIAL CHARACTERS ARE NOT TRANSLATED, AND WILL *
* APPEAR AS BLANKS. A CHARACTER LENGTH OF SIX (6) *
* IS USED, BUT THIS CAN BE CHANGED TO SOME *
* LENGTH 'N' BY CHANGING THE '6' TO 'N' IN THE *
* 'COLLEN' EQUATE STATEMENT WHERE 'N' <= 254. *
***********************************************************************
* IMPLEMENTATION NOTES *
* -------------------- *
* THIS SAMPLE USES THE FOLLOWING PARAMETERS WHICH ARE *
* SPECIFIED WHEN THE PROGRAM IS ASSEMBLED: *
* RENT - CHECK FOR POSSIBLE CODING VIOLATIONS OF *
* PROGRAM REENTERABILITY *
* OBJECT - PLACE THE GENERATED OBJECT MODULE IN THE *
* FILE DEFINED BY THE 'SYSLIN DD' STATEMENT *
* NODECK - DO NOT PLACE THE GENERATED OBJECT MODULE IN *
* THE FILE DEFINED BY THE 'SYSPUNCH DD' STATEMENT *
* SYSPARM(NAME) - SPECIFIES 'NAME' TO BE USED AS THE *
* THE VALUE OF THE '&SYSPARM' SYSTEM *
* VARIABLE SYMBOL *
***********************************************************************
DSNTIACN REGISTER DEFINITIONS
USING &SYSPARM,R3 FIELD PROCEDURE BASE REGISTER
USING FPIB,R9 COMMON INFORMATION BLOCK BASE RG
USING FPVD,R10 VALUE DESCRIPTOR BASE REGISTER
USING FPPL,R11 PARAMETER LIST BASE REGISTER
USING WA,R12 WORK AREA BASE REGISTER
SPACE 3
***********************************************************************
* SET UP MAIN LINE RETURN R14 *
***********************************************************************
SPACE 3
SAVE (14,12),,'''&SYSPARM &SYSDATE &SYSTIME'''
LR R3,R15 SET CODE ADDRESSIBILITY
LR R11,R1 PARAMETER LIST POINTER
L R12,FPPWORK GET WORK AREA ADDRESS
XC WASAVE,WASAVE CLEAR SAVE AREA
MVC WANAME,=C'&SYSPARM' FLD PROC WORK AREA NAME
ST R13,WASAVE+4 SAVE CALLER'S SAVE AREA ADDR
LA R0,WASAVE GET OWN SAVE AREA ADDR
ST R0,8(,R13) SAVE IN CALLER'S SAVE AREA
LR R13,R0 PUT OWN SAVE AREA ADDR IN R13
L R4,=A(&SYSPARM.$) GET CONSTANT AREA ADDRESS
USING &SYSPARM.$,R4 ESTABLISH ADDRESSIBILITY
L R9,FPPFPIB COMMON INFO BLOCK POINTER
MVC FPBRTNC,=AL2(FPBRC0) SET RETURN CODE = 0
LH R2,FPBFCODE GET THE EXIT FUNCTION CODE
L R15,FDLFC(R2) SELECT APPROPRIATE ROUTINE
BASR R14,R15 0-ENCODE,4-DECODE,8-DEFINE
PACK WADW,FPBRTNC GET RETURN CODE FROM FUNCTION
CLI FPBRTNC+L'FPBRTNC-1,C' ' 2ND CHAR BLANK?
BNE *+10 NO-PASS BACK WHOLE RC
PACK WADW,FPBRTNC(L'FPBRTNC-1) YES-ONLY 1ST BYTE IS
* MEANINGFUL SO ONLY PASS IT
CVB R15,WADW SET BINARY RETURN CODE
L R13,4(,R13) CALLER'S SAVE AREA ADDRESS
RETURN (14,12),T,RC=(15) RESTORE REGISTERS AND RETURN
LTORG
TITLE 'SAMPLE FIELD PROCEDURE: ENCODE FIELD'
&SYSPARM.0 RMODE ANY RESIDE ANYWHERE
&SYSPARM.0 CSECT
USING &SYSPARM.0,R3 SET CODE ADDRESSIBILITY
SAVE (14,12),,'''&SYSPARM.0 &SYSDATE &SYSTIME'''
LR R3,R15 SET CODE BASE REGISTER
L R10,FPPCVD INPUT COLUMN VALUE DESCRIPTOR
BAS R5,ENCCVD CHECK INPUT VALUE
L R2,FPPCVD INPUT COLUMN VALUE DESCRIPTOR
L R10,FPPFVD OUTPUT VALUE DESCRIPTOR
BAS R5,ENCSET DO THE ENCODE
RETURN (14,12),T,RC=0 RETURN TO MAIN MODULE
SPACE 3
***********************************************************************
* CHECK INPUT VALUE RETURN R5 *
***********************************************************************
SPACE 3
ENCCVD DS 0H CHECK INPUT VALUE
CLC =Y(FPVDTCHR),FPVDTYPE IF FIXED LENGTH CHAR
BNE ENCCVD4 AND
CLC =Y(COLLEN),FPVDVLEN LENGTH IS CORRECT
BER R5 THEN OK SO LEAVE
ENCCVD4 DS 0H ELSE SET FIELD INVALID
L R9,FPPFPIB FPIB POINTER
MVC FPBRTNC,=AL2(FPBRC4) INVALID COLUMN DESCRIPTION
MVC FPBRSNC,=C'1234' LENGTH NOT CORRECT
BR R5 RETURN TO ENCODE MODULE
SPACE 3
***********************************************************************
* ENCODE TO PRODUCE ASCII SORTING SEQUENCE RETURN R5 *
***********************************************************************
SPACE 3
ENCSET DS 0H SET OUTPUT VALUES
MVC FPVDTYPE,FPVDTYPE-FPVD(R2) GET THE DATA TYPE
MVC FPVDVLEN,FPVDVLEN-FPVD(R2) IF FIXED LENGTH CHAR
LH R15,FPVDVLEN GET THE LENGTH
LA R14,FPVDVALE ADDRESS OF VALUE
LR R1,R15 LENGTH OF THE VALUE
LA R0,FPVDVALE-FPVD(,R2) ADDRESS OF VALUE
MVCL R14,R0 PUT VALUE IN OUTPUT AREA
TR 0+FPVDVALE(COLLEN),$TRANS0 ENCODE THE VALUE
BR R5 RETURN TO ENCODE MODULE
LTORG
TITLE 'SAMPLE FIELD PROCEDURE: DECODE FIELD'
&SYSPARM.4 RMODE ANY RESIDE ANYWHERE
&SYSPARM.4 CSECT
USING &SYSPARM.4,R3 SET CODE ADDRESSIBILITY
SAVE (14,12),,'''&SYSPARM.4 &SYSDATE &SYSTIME'''
LR R3,R15 SET BASE REGISTER
L R10,FPPFVD INPUT FIELD VALUE DESCRIPTOR
BAS R5,DECCVD CHECK INPUT VALUE
L R10,FPPCVD OUTPUT COLUMN VALUE DESCRIPTOR
L R2,FPPFVD INPUT VALUE DESCRIPTOR
BAS R5,DECSET DO THE DECODE
RETURN (14,12),T,RC=0 RETURN TO MAIN MODULE
SPACE 3
***********************************************************************
* CHECK INPUT VALUE RETURN R5 *
***********************************************************************
SPACE 3
DECCVD DS 0H CHECK INPUT VALUE
CLC =Y(FPVDTCHR),FPVDTYPE IF FIXED LENGTH CHAR
BNE DECCVD4 AND
CLC =Y(COLLEN),FPVDVLEN LENGTH IS CORRECT
BER R5 THEN OK SO LEAVE
DECCVD4 DS 0H ELSE SET FIELD INVALID
L R9,FPPFPIB FPIB POINTER
MVC FPBRTNC,=AL2(FPBRC4) INVALID COLUMN DESCRIPTION
MVC FPBRSNC,=C'2345' FIELD NOT CORRECT
BR R5 RETURN TO DECODE MODULE
SPACE 3
***********************************************************************
* DECODE TO DISPLAY ORIGINAL VALUES RETURN R5 *
***********************************************************************
SPACE 3
DECSET DS 0H SET OUTPUT VALUES
MVC FPVDTYPE,FPVDTYPE-FPVD(R2) GET THE DATA TYPE
MVC FPVDVLEN,FPVDVLEN-FPVD(R2) IF FIXED LENGTH CHAR
LH R15,FPVDVLEN GET THE LENGTH
LA R14,FPVDVALE ADDRESS OF VALUE
LR R1,R15 LENGTH OF VALUE
LA R0,FPVDVALE-FPVD(,R2) ADDRESS OF VALUE
MVCL R14,R0 PUT VALUE IN OUTPUT AREA
TR 0+FPVDVALE(COLLEN),$TRANS4 DECODE THE VALUE
BR R5 RETURN TO DECODE MODULE
LTORG
TITLE 'SAMPLE FIELD PROCEDURE: FIELD DEFINITION'
&SYSPARM.8 RMODE ANY RESIDE ANYWHERE
&SYSPARM.8 CSECT
USING &SYSPARM.8,R15 ESTABLISH ADDRESSIBILITY
SAVE (14,12),,'''&SYSPARM.8 &SYSDATE &SYSTIME'''
BAS R5,DEFWL SET WORK AREA LENGTH
BAS R5,DEFCVD CHECK COLUMN VALUE DESCRIPTOR
BAS R5,DEFFVD SET UP FIELD VALUE DESCRIPTOR
BAS R5,DEFPVL DISABLE PARAMETER FIELD
RETURN (14,12),T,RC=0 RETURN TO MAIN MODULE
SPACE 3
***********************************************************************
* SET WORK AREA LENGTH RETURN R5 *
***********************************************************************
SPACE 3
DEFWL DS 0H
L R9,FPPFPIB FPIB POINTER
CLC =Y(WAEND-WA),FPBWKLN CORRECT LENGTH?
BNH *+12 YES - BRANCH TO SET WA LNGTH
MVC FPBRTNC,=AL2(FPBRC12) INVALID LENGTH
BR R5 RETURN AND EXIT
MVC FPBWKLN,=Y(WAEND-WA) CORRECT WORK AREA LENGTH
BR R5 RETURN TO DEFINE MODULE
SPACE 3
***********************************************************************
* CHECK COLUMN VALUE DESCRIPTOR RETURN R5 *
***********************************************************************
SPACE 3
DEFCVD DS 0H
L R10,FPPCVD COLUMN VALUE DESCRIPTORS
CLC =Y(FPVDTCHR),FPVDTYPE IF FIXED LENGTH CHAR
BNE DEFCVD4 AND
CLC =Y(COLLEN),FPVDVLEN CORRECT LENGTH
BER R5 RETURN TO DEFINE MODULE
DEFCVD4 DS 0H ELSE SET FIELD INVALID
L R9,FPPFPIB FPIB POINTER
MVC FPBRTNC,=AL2(FPBRC4) INVALID COLUMN DESCRIPTION
MVC FPBRSNC,=C'3456' FIELD NOT CORRECT
BR R5 RETURN TO DEFINE MODULE
SPACE 3
***********************************************************************
* SET UP FIELD VALUE DESCRIPTOR RETURN R5 *
***********************************************************************
SPACE 3
DEFFVD DS 0H
L R10,FPPFVD FIELD VALUE DESCRIPTORS
MVC FPVDTYPE,=Y(FPVDTCHR) SET FIXED LENGTH CHAR
MVC FPVDVLEN,=Y(COLLEN) SET THE LENGTH
BR R5 RETURN TO DEFINE MODULE
SPACE 3
***********************************************************************
* FIELD PROCEDURE PARAMETER VALUE LIST RETURN R5 *
***********************************************************************
SPACE 3
DEFPVL DS 0H
L R10,FPPPVL FIELD PROC PARM VALUES
MVC FPPVLEN-FPPVL(,R10),=Y(0) FLAG FIELD PROCEDURE PARAM.
BR R5 RETURN TO DEFINE MODULE
LTORG
TITLE 'SAMPLE FIELD PROCEDURE: CONSTANTS'
&SYSPARM.$ RMODE ANY RESIDE ANYWHERE
&SYSPARM.$ CSECT
FDLFC DC A(&SYSPARM.0,&SYSPARM.4,&SYSPARM.8) MODULE SELECTION
COLLEN EQU 6 COLUMN LENGTH
**********************************************************************
* THIS TRANSLATE TABLE IS USED BY THE ENCODING FUNCTION. IT *
* CAUSES ALPHANUMERIC CHARACTERS TO SORT IN THE ASCII SORTING *
* SEQUENCE. *
**********************************************************************
$TRANS0 DC 256AL1(*-$TRANS0)
ORG $TRANS0+X'0'
DC X'20202020202020202020202020202020'
DC X'20202020202020202020202020202020'
DC X'20202020202020202020202020202020'
DC X'20202020202020202020202020202020'
DC X'20202020202020202020202020202020'
DC X'20202020202020202020202020202020'
DC X'20202020202020202020202020202020'
DC X'20202020202020202020202020202020'
DC X'20616263646566676869202020202020'
DC X'206A6B6C6D6E6F707172202020202020'
DC X'2020737475767778797A202020202020'
DC X'20202020202020202020202020202020'
DC X'20414243444546474849202020202020'
DC X'204A4B4C4D4E4F505152202020202020'
DC X'2020535455565758595A202020202020'
DC X'30313233343536373839202020202020'
ORG $TRANS0+256
**********************************************************************
* THIS TRANSLATE TABLE IS USED BY THE DECODING FUNCTION. IT *
* RETURNS ALPHANUMERIC CHARACTERS TO THEIR ORIGINAL VALUES FOR *
* OUTPUT. *
**********************************************************************
$TRANS4 DC 256AL1(*-$TRANS4)
ORG $TRANS4+X'0'
DC X'40404040404040404040404040404040'
DC X'40404040404040404040404040404040'
DC X'40404040404040404040404040404040'
DC X'F0F1F2F3F4F5F6F7F8F9404040404040'
DC X'40C1C2C3C4C5C6C7C8C9D1D2D3D4D5D6'
DC X'D7D8D9E2E3E4E5E6E7E8E94040404040'
DC X'40818283848586878889919293949596'
DC X'979899A2A3A4A5A6A7A8A94040404040'
DC X'40404040404040404040404040404040'
DC X'40404040404040404040404040404040'
DC X'40404040404040404040404040404040'
DC X'40404040404040404040404040404040'
DC X'40404040404040404040404040404040'
DC X'40404040404040404040404040404040'
DC X'40404040404040404040404040404040'
DC X'40404040404040404040404040404040'
ORG $TRANS4+256
TITLE 'SAMPLE FIELD PROCEDURE: WORK AREA'
DSNDFPPB FIELD PROCEDURE DEFINITIONS
WA DSECT WORK AREA
WANAME DS CL8 IDENTIFIER OF USER
WASAVE DS 72F SAVE AREA
WADW DS D WORK FIELD
WAEND EQU * END OF WORK AREA
* *
&SYSPARM.$ CSECT
END &SYSPARM END OF FIELD PROCEDURE