 
| Subject: | |
| From: | |
| Reply To: | |
| Date: | Wed, 19 Jan 2000 16:35:25 -0500 |
| Content-Type: | text/plain |
| Parts/Attachments: |
|
|
Attached is sample COBOL source program that illustrates the use of some of
the various date routines that are Y2K-compliant.
Please note that the $CONTROL POST85 is required to enable use of some of
the features used in the sample program.
001000$CONTROL POST85
001100 IDENTIFICATION DIVISION.
001200 PROGRAM-ID. y2ktst.
001300 REMARKS. Test date routines (MPE/iX only).
001400 AUTHOR. Gilles Schipper.
001500 DATE-WRITTEN. August 1998, Updated November 1998.
001600 DATE-COMPILED.
001700 ENVIRONMENT DIVISION.
001800 CONFIGURATION SECTION.
001900 SOURCE-COMPUTER. HP3000.
002000 OBJECT-COMPUTER. HP3000.
002100 SPECIAL-NAMES.
002200 CONDITION-CODE IS cond-code
002300 TOP IS new-page.
002400 INPUT-OUTPUT SECTION.
002500 DATA DIVISION.
002600 WORKING-STORAGE SECTION.
002700 01 flags-and-counters COMP.
002800 05 eoj-flag PIC 9(04) VALUE ZERO.
002900 88 eoj VALUE 1 THRU
003000 9999.
003100 88 normal-eoj VALUE 9999.
003200 01 full-date PIC X(21).
003300 01 FILLER REDEFINES full-date.
003400 05 yyyy PIC 9(04).
003500 05 mm PIC 9(02).
003600 05 dd PIC 9(02).
003700 05 hh PIC 9(02).
003800 05 min PIC 9(02).
003900 05 ss PIC 9(02).
004000 05 centiss PIC 9(02).
004100 05 gmt PIC X.
004200 88 gmt-minus VALUE "-".
004300 88 gmt-plus VALUE "+".
004400 05 gmt-hh PIC 9(02).
004500 05 gmt-min PIC 9(02).
004600 01 intrinsic-parms.
004700 05 hpdateconv-parms.
004800 10 inputcode PIC S9(09) COMP.
004900 10 inputdate PIC X(08).
005000 10 outputcode PIC S9(09) COMP.
005100 10 outputdate PIC X(08).
005200 10 parmstatus.
005300 15 parmstatus1 PIC S9(04) COMP.
005400 15 parmstatus2 PIC S9(04) COMP.
005500 10 cutoff PIC S9(09) COMP.
005600 05 hpdatediff-parms.
005700 10 datecode PIC S9(09) COMP.
005800 10 firstdate PIC X(08).
005900 10 seconddate PIC X(08).
006000 10 diffdays PIC S9(09) COMP.
006100 10 parmstatus.
006200 15 parmstatus1 PIC S9(04) COMP.
006300 15 parmstatus2 PIC S9(04) COMP.
006400 10 cutoff PIC S9(09) COMP.
006500 05 hpdateoffset-parms.
006600 10 datecode PIC S9(09) COMP.
006700 10 inputdate PIC X(08).
006800 10 offset PIC S9(09) COMP.
006900 10 outputdate PIC X(08).
007000 10 parmstatus.
007100 15 parmstatus1 PIC S9(04) COMP.
007200 15 parmstatus2 PIC S9(04) COMP.
007300 10 cutoff PIC S9(09) COMP.
007400 01 misc-items.
007500 05 display-diffdays PIC ----,---,--9.
007600 05 display-date PIC X(20).
007700 05 accept-data PIC X(08).
007800 05 accept-days PIC 9(05)-.
007900 PROCEDURE DIVISION.
008000 a-control.
008100 DISPLAY "Y2KTST Date Intrinsics Test".
008200 MOVE FUNCTION CURRENT-DATE TO full-date.
008300 DISPLAY "FUNCTION CURRENT-DATE (YYYYMMDDHHMMSSCC-HHMM): "
008400 full-date.
008500 MOVE 0 TO eoj-flag.
008600 PERFORM b0-dateconv UNTIL eoj.
008700 MOVE 0 TO eoj-flag.
008800 PERFORM b1-datediff UNTIL eoj.
008900 MOVE 0 TO eoj-flag.
009000 PERFORM b2-dateoffset UNTIL eoj.
009100 DISPLAY "Y2KTST Program End".
009200 GOBACK.
009300 b0-dateconv.
009400 MOVE -1 TO cutoff OF hpdateconv-parms.
009500 MOVE 38 TO inputcode OF hpdateconv-parms
009600 outputcode OF hpdateconv-parms.
009700 DISPLAY "Enter the date in YYYYMMDD format (// to exit)".
009800 MOVE SPACE TO accept-data.
009900 ACCEPT accept-data.
010000 IF accept-data = "//"
010100 MOVE 9999 TO eoj-flag
010200 ELSE
010300 MOVE accept-data TO inputdate OF hpdateconv-parms
010400 CALL INTRINSIC "HPDATECONVERT" USING
010500 \inputcode OF hpdateconv-parms\
010600 inputdate OF hpdateconv-parms
010700 \outputcode OF hpdateconv-parms\
010800 outputdate OF hpdateconv-parms
010900 parmstatus OF hpdateconv-parms
011000 \cutoff OF hpdateconv-parms\
011100 IF parmstatus1 OF hpdateconv-parms = 0
011200 DISPLAY "Converted date is: "
011300 outputdate OF hpdateconv-parms
011400 ELSE
011500 DISPLAY "Invalid YYYYMMDD Format - Please try again".
011600 b1-datediff.
011700 MOVE -1 TO cutoff OF hpdateconv-parms.
011800 MOVE 38 TO datecode OF hpdatediff-parms.
011900 MOVE SPACE TO accept-data.
012000 DISPLAY "Enter First Date in YYYYMMDD Format (// to quit)".
012100 ACCEPT accept-data.
012200 IF accept-data = "//"
012300 MOVE 9999 TO eoj-flag
012400 ELSE
012500 MOVE accept-data TO firstdate OF hpdatediff-parms
012600 MOVE SPACE TO accept-data
012700 DISPLAY "Enter Second Date in YYYYMMDD Format"
012800 ACCEPT accept-data
012900 MOVE accept-data TO seconddate OF hpdatediff-parms
013000 CALL INTRINSIC "HPDATEDIFF" USING
013100 \datecode OF hpdatediff-parms\
013200 firstdate OF hpdatediff-parms
013300 seconddate OF hpdatediff-parms
013400 diffdays OF hpdatediff-parms
013500 parmstatus OF hpdatediff-parms
013600 \cutoff OF hpdatediff-parms\
013700 IF parmstatus1 OF hpdatediff-parms = 0
013800 MOVE diffdays OF hpdatediff-parms TO display-diffdays
013900 DISPLAY "Days Difference is: "
014000 display-diffdays
014100 ELSE
014200 DISPLAY "Invalid date(s) - Please try again".
014300 b2-dateoffset.
014400 MOVE -1 TO cutoff OF hpdateoffset-parms.
014500 MOVE 38 TO datecode OF hpdateoffset-parms.
014600 MOVE SPACE TO accept-data.
014700 DISPLAY "Enter Date in YYYYMMDD Format (// to quit)".
014800 ACCEPT accept-data.
014900 IF accept-data = "//"
015000 MOVE 9999 TO eoj-flag
015100 ELSE
015200 MOVE accept-data TO inputdate OF hpdateoffset-parms
015300 MOVE 0 TO accept-days
015400 DISPLAY "Enter offset-days (up to 5 digits)"
015500 ACCEPT accept-days FREE
015600 MOVE accept-days TO offset OF hpdateoffset-parms
015700 CALL INTRINSIC "hpdateoffset" USING
015800 \datecode OF hpdateoffset-parms\
015900 inputdate OF hpdateoffset-parms
016000 \offset OF hpdateoffset-parms\
016100 outputdate OF hpdateoffset-parms
016200 parmstatus OF hpdateoffset-parms
016300 \cutoff OF hpdateoffset-parms\
016400 IF parmstatus1 OF hpdateoffset-parms = 0
016500 MOVE outputdate OF hpdateoffset-parms TO display-date
016600 MOVE accept-days TO display-diffdays
016700 DISPLAY "Offset date is: "
016800 display-date
016900 DISPLAY "Days difference is:"
017000 display-diffdays
017100 ELSE
017200 DISPLAY "Invalid date - Please try again".
---------------------------------------------------------------------------
Gilles Schipper
GSA Inc.
HP3000 & HP9000 System Administration Specialists
300 John Street, Box 87651 Thornhill, ON Canada L3T 7R4
Voice: 905.889.3000 Fax: 905.889.3001
Internet: [log in to unmask]
---------------------------------------------------------------------------
|
|
|
