Bill O'Boyle
CICS Moderator
Joined: 14 Jan 2008
Posts: 2501
Location: Atlanta, Georgia, USA
|
|
|
|
Below, please find Assembler Sub-Program "GETGMTO", which returns the Local <---> GMT Offset, with a format of "+/-HHMM". It is fully re-entrant and can be used in both Batch and CICS.
For those who prefer a COBOL version, please refer to "COBGMTO" in the Mainframe COBOL Forum.
| Code: |
*PROCESS RENT PROGRAM IS RE-ENTRANT
***********************************************************************
*---------------------------------------------------------------------*
* *
* THIS SUB-PROGRAM RETURNS THE CURRENT GMT-OFFSET TO LOCAL *
* TIME, WITH A FORMAT OF C'-/+HHMM' AND CAN BE USED IN BOTH *
* CICS AND BATCH. IN CICS, THE PPT EXECUTION-KEY CAN BE USER *
* OR IT CAN BE STATICALLY CALLED (NO PPT-ENTRY REQUIRED). *
* *
* EG: EASTERN STANDARD TIME = '-0500' (GMT-0500). *
* *
* MINUTES ARE RETURNED (WHEN APPLICABLE) AND WILL ONLY BE A *
* VALUE OF 30 OR 15. AREAS OF THE WORLD, SUCH AS INDIA AND *
* PAKISTAN, RESPECTIVELY. *
* *
* R15 WILL CONTAIN THE RETURN-CODE (KNOWN AS THE RETURN-CODE *
* SPECIAL-REGISTER IN COBOL), WITH VALUES OF: *
* *
* 0000 (OFFSET IS NON-ZERO --- ALL IS WELL) *
* 0004 (OFFSET IS ZERO --- WARNING TO CALLER) *
* *
* CALL SYNTAX: *
* *
* 03 WS-GETGMTO-PARM. *
* 05 WS-GETGMTO-VALUE PIC X(05). *
* 05 FILLER REDEFINES WS-GETGMTO-VALUE. *
* 07 WS-GETGMTO-SIGN *
* PIC X(01). *
* 88 WS-GETGMTO-BEHIND-GMT VALUE '-'. *
* 07 WS-GETGMTO-HHMM *
* PIC 9(04). *
* 05 WS-GETGMTO-WKAREA PIC X(80). *
* 03 WS-GETGMTO PIC X(08) VALUE 'GETGMTO'. *
* *
* CALL WS-GETGMTO USING WS-GETGMTO-PARM. *
* *
*---------------------------------------------------------------------*
***********************************************************************
PRINT NOGEN SUPPRESS MACRO EXPANSION
CVT DSECT=YES,LIST=YES CVT-DSECT (PREFIX=NO)
PRINT GEN ACTIVATE MACRO EXPANSION
PARMAREA DSECT PARMAREA (R7)
USING *,R7 INFORM ASSEMBLER
PARMOFST DS CL5 GMT-OFFSET (FORMAT=+/-HHMM)
WORKAREA DSECT WORK-AREA (FROM CALLER)
USING *,R9 INFORM ASSEMBLER
DWORD DS D ALIGNED-DBLWORD WORKAREA
REGSAVEA DS XL72 REGISTER-SAVEAREA (18F)
WORKLGTH EQU *-WORKAREA WORK-AREA LGTH
GETGMTO CSECT BEGIN CSECT (R3)
USING *,R3 INFORM ASSEMBLER
SAVE (14,12) SAVE REGISTERS
LR R3,R15 CSECT ADDRESSABIITY
B ADDRPLST ADDRESS PARMLIST
EYECTCHR DS 0CL48 PROGRAM EYECATCHER
DC PL2'407' X'407C'
DC CL10'EYECATCHER' EYECATCHER-LITERAL
DC PL1'7' X'7C'
DC CL6' ===>'
PROGNAME DC CL8'GETGMTO'
DC CL2','
DC CL8'&SYSDATC' ASSEMBLY-DATE AS C'CCYYMMDD'
DC CL2','
DC CL9'&SYSTIME..00' ASSEMBLY-TIME AS C'HH.MM.00'
ADDRPLST DS 0H ENSURE ALIGNMENT
L R7,0(,R1) PARMAREA ADDRESSABILITY
LA R9,L'PARMOFST(,R7) WORK-AREA ADDRESSABLITY
XC WORKAREA(WORKLGTH),WORKAREA
LA R15,REGSAVEA POINT TO OUR SAVEAREA
ST R13,4(,R15) BACKWARD CHAIN
ST R15,8(,R13) FORWARD CHAIN
LR R13,R15 POINT TO OUR SAVEAREA
L R15,CVTPTR CVT-ADDRESSABILITY
L R10,CVTTZ-CVT(,R15) LOAD WITH 'CVTTZ' AS-IS
LPR R15,R10 ENSURE POSITIVE VALUE
CVD R15,DWORD PREPARE FOR DECIMAL-MULTIPLICATN
MP DWORD,=P'1048576' CALCULATE NBR-OF-SECONDS
SRP DWORD,(64-6),0 DIVIDE BY 1000000/NO ROUNDING
CVB R14,DWORD PREPARE FOR BINARY-DIVIDE
SRDA R14,32 ALGEBRAICALLY SHIFT INTO R15
DL R14,=F'3600' CALCULATE NBR-OF-HOURS
CVD R15,DWORD MAKE IT DECIMAL (FMT=00HH)
SRP DWORD,2,0 MULTIPLY BY 100 (FMT=HH00)
OI DWORD+L'DWORD-1,X'0F' ENSURE 'F' SIGN-NIBBLE
UNPK PARMOFST,DWORD UNPACK AS C'0HH00'
CHI R14,60 ANY MINUTES REMAINING?
BL CHKCVTTZ NO, CHECK CVTTZ-SIGN
SRDA R14,32 ALGEBRAICALLY SHIFT INTO R15
DL R14,=F'60' CALCULATE NBR-OF-MINUTES
LA R14,30 ENSURE 30-MINUTES
CHI R15,30 30-MINUTE BOUNDARY?
BNL UNPKMINS YES, UNPACK OFFSET-MINUTES
LA R14,15 ENSURE 15-MINUTES
UNPKMINS EQU *
CVD R14,DWORD MAKE IT DECIMAL
OI DWORD+L'DWORD-1,X'0F' ENSURE 'F' SIGN-NIBBLE
UNPK PARMOFST+3(2),DWORD UNPACK OFFSET-MINUTES
CHKCVTTZ EQU *
MVI PARMOFST,C'-' SET NEGATIVE-SIGN (DEFAULT)
CHI R10,0 NEGATIVE 'CVTTZ'?
BL SETRTNCD YES, SET RETURN-CODE
MVI PARMOFST,C'+' RESET TO POSITIVE-SIGN
SETRTNCD EQU *
XR R15,R15 SET 'ALL IS WELL' RC
CLC =CL4'0000',PARMOFST+1 OFFSET IS NON-ZERO?
BNE RTN2CLLR YES, RETURN TO CALLLER
LA R15,4 SET 'WARNING' RC
RTN2CLLR EQU *
L R13,4(,R13) RESTORE CALLER'S R13
XC WORKAREA(WORKLGTH),WORKAREA
RETURN (14,12),RC=(15) RESTORE REGISTERS AND RETURN
LTORG ,
YREGS , MVS REGISTER-EQUATE
GETGMTO AMODE 31 ,
GETGMTO RMODE ANY ,
END , END 'GETGMTO'
|
|
|
