Bill O'Boyle
CICS Moderator
Joined: 14 Jan 2008
Posts: 2501
Location: Atlanta, Georgia, USA
|
|
|
|
Below, please find COBOL Sub-Program "COBGMTO" which returns the Local <---> GMT offset, with a format of "-/+HHMM'. It's fully re-entrant and can be used in both Batch and CICS. It's a cousin to "GETGMTO", posted in the PL/I and Assembler Forum.
| Code: |
IDENTIFICATION DIVISION.
PROGRAM-ID. COBGMTO INITIAL.
*
**** CALL SYNTAX EXAMPLE:
*
**** 03 WS-COBGMTO-PARM.
**** 05 WS-COBGMTO-VALUE
**** PIC X(05).
**** 05 FILLER REDEFINES WS-COBGMTO-VALUE.
**** 07 WS-COBGMTO-SIGN
**** PIC X(01).
**** 88 WS-COBGMTO-BEHIND-GMT VALUE '-'.
**** 07 WS-COBGMTO-HHMM
**** PIC 9(04).
**** 05 WS-COBGMTO-WKAREA
**** PIC X(80).
**** 03 WS-COBGMTO PIC X(08) VALUE 'COBGMTO'.
*
**** CALL WS-COBGMTO USING WS-COBGMTO-PARM.
*
**** THE PARM DOES NOT NEED TO BE INITIALISED.
*
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
LINKAGE SECTION.
01 LS-PARM-REC.
03 LS-PARM-OFFSET PIC X(05).
03 FILLER REDEFINES LS-PARM-OFFSET.
05 LS-PARM-OFFSET-SIGN
PIC X(01).
05 LS-PARM-OFFSET-HH
PIC 9(02).
05 LS-PARM-OFFSET-MM
PIC 9(02).
03 LS-PARM-OFFSET-WORKAREA.
05 LS-DWORD PIC 9(15) PACKED-DECIMAL.
05 LS-FWORD PIC 9(08) BINARY.
05 LS-FWORD-X REDEFINES LS-FWORD
PIC X(04).
05 LS-POINTER POINTER.
05 LS-POINTER-X REDEFINES LS-POINTER
PIC X(04).
05 LS-CVTTZ PIC S9(08) BINARY.
05 LS-CVTTZ-X REDEFINES LS-CVTTZ
PIC X(04).
05 FILLER PIC X(60).
01 LS-DUMMY-DSECT PIC X(1024).
PROCEDURE DIVISION USING LS-PARM-REC.
0000-BEGIN-COBGMTO.
*
**** IN LOW-CORE, AT FIXED-POSITION X'00000010', IS THE ADDRESS
**** OF THE 'CVT' (COMMUNICATIONS VECTOR TABLE). WE MUST MOVE THE
**** ADDRESS LOCATED AT THIS FIXED-POSITION TO A 'POINTER', WHICH
**** WILL THEN BE USED TO ESTABLISH ADDRESSABILITY TO THE
**** START OF THE 'CVT'.
*
MOVE LOW-VALUES TO LS-PARM-OFFSET-WORKAREA.
MOVE X'10' TO LS-POINTER-X (4:).
SET ADDRESS OF LS-DUMMY-DSECT
TO LS-POINTER.
MOVE LS-DUMMY-DSECT TO LS-POINTER-X.
SET ADDRESS OF LS-DUMMY-DSECT
TO LS-POINTER.
*
**** THE 'CVTTZ' IS LOCATED AT X'130' OFF THE START OF THE 'CVT',
**** FOR THIS z/OS VERSION/RELEASE. PERSONNEL SHOULD CHECK THE
**** OFFSET (CVTTZ) UPON ANY UPGRADE OF THE OPERATING SYSTEM AND
**** ENSURE THE OFFSET OF THIS FIELD HASN'T CHANGED.
*
**** WHEN ADDRESSING OFFSETS IN COBOL, WE MUST ADD 1 TO ENSURE
**** PROPER ADDRESSABILITY. IN THIS CASE, WE MUST SPECIFY X'131'
**** (305) INSTEAD OF X'130' (304).
*
**** BECAUSE OUR RECEIVING FIELD IS AN UNSIGNED-FWORD, THE
**** COMPILER ISSUES A 'LPR', TO ENSURE A POSITIVE VALUE.
*
MOVE LS-DUMMY-DSECT (305:) TO LS-CVTTZ-X.
MOVE LS-CVTTZ TO LS-FWORD.
MOVE LS-FWORD TO LS-DWORD.
*
**** NOW, CALCULATE THE OFFSET, RESULTING IN A '+/-HHMM' VALUE.
*
COMPUTE LS-DWORD = (LS-DWORD * 1048576).
COMPUTE LS-DWORD = (LS-DWORD / 1000000).
DIVIDE LS-DWORD BY 3600
GIVING LS-PARM-OFFSET-HH
REMAINDER LS-DWORD.
*
**** IF THERE'S A REMAINDER AFTER THE DIVIDE, THEN THE GMT
**** OFFSET REST'S ON A 15 OR 30 MINUTE BOUNDARY, SUCH AS
**** PAKISTAN OR INDIA, RESPECTIVELY.
*
IF LS-DWORD > 59
COMPUTE LS-DWORD = (LS-DWORD / 60)
IF LS-DWORD > 29
MOVE 30 TO LS-PARM-OFFSET-MM
ELSE
MOVE 15 TO LS-PARM-OFFSET-MM
END-IF
ELSE
MOVE ZERO TO LS-PARM-OFFSET-MM
END-IF.
*
**** IF THE 'CVTTZ' IS NEGATIVE, THEN THE OFFSET SIGN IS '-'.
**** OTHERWISE, IT'S '+'.
*
IF LS-CVTTZ-X (1:1) > X'7F'
MOVE '-' TO LS-PARM-OFFSET-SIGN
ELSE
MOVE '+' TO LS-PARM-OFFSET-SIGN
END-IF.
*
**** IF THE 'HHMM' PARM-OFFSET IS NON-ZERO, THEN SET THE RC TO
**** ZERO. OTHERWISE, SET IT TO 4 TO NOTIFY THE CALLER AS A
**** WARNING.
*
IF LS-PARM-OFFSET (2:) NOT = ZERO
MOVE ZERO TO RETURN-CODE
ELSE
MOVE 4 TO RETURN-CODE
END-IF.
*
MOVE LOW-VALUES TO LS-PARM-OFFSET-WORKAREA.
*
9999-END-COBGMTO.
*
GOBACK.
|
|
|
