A-CDATE
00000000
w(b+
[A-CDATE] System Returned Date 19902050011231[A-CDATE] Something's wrong with the system date![A-CDATE] CENTURY-DATE reported: 2[A-CDATE] Returned Year  != User-Year [A-CDATE] Returned Month  != User-Month [A-CDATE] Returned Day  != User-Day 
A-CDAT
TEST-DATA
RETURN-CODE
TEST-DATA
TEST-RESULT-CODE
TEST-PASSED
TEST-FAILED
USER-DATE
USER-YEAR
VALID-USER-YEAR
USER-MONTH
VALID-USER-MONTH
USER-DAY
VALID-USER-DAY
USER-DAY-OF-YEAR
VALID-USER-DAY-OF-YEAR
USER-DAY-OF-WEEK
VALID-USER-DAY-OF-WEEK
SYSTEM-DATE
SYSTEM-YEAR
VALID-SYSTEM-YEAR
SYSTEM-MONTH
VALID-SYSTEM-MONTH
SYSTEM-DAY
VALID-SYSTEM-DAY
RETURN-CODE
MAIN-LOGIC
IDENTIFICATION DIVISION. '
PROGRAM-ID. A-CDATE IS INITIAL.'
AUTHOR. Chris Adams.
DATE-WRITTEN. 19980801.
* Tests the date returned by ACCEPT FROM CENTURY-DATE=-
* Copyright 
 1996-1998 Acucorp, Inc.-A
* $Id: A-CDATE.CBL,v 1.1 1998/07/09 22:52:33 cadams Exp $A
* Format 3 (ACCEPT FROM CENTURY-DATE)-
* 32. The Format 3 ACCEPT statement causes information to be transferred toSF
*     dest-item according to the rules for the MOVE statement.FX
* 35. ACCEPT FROM CENTURY-DATE returns the current date in the format "YYYYMMDD"XX
*     (year/month/day).  ACCEPT FROM CENTURY-DAY returns the current date in theXU
*     format "YYYYDDD" (year/day-of-year).  These are the same as ACCEPT FROMUV
*     DATE and ACCEPT FROM DAY, except that the year field is 4 digits insteadV
*     of 2 digits.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-PC.  
OBJECT-COMPUTER. IBM-PC. 
WORKING-STORAGE SECTION. 
COPY "testsum.def".
* Data structure for passing info between test program and manager.K
01 Test-Data EXTERNAL.
03 Test-Result-Code             PIC 9(1).10
88 Test-Passed                  VALUE 1.00
88 Test-Failed                  VALUE 2.0
03 User-Date.          | ISO8601(/
05 User-Year                  PIC 9(4)./D
88 Valid-User-Year                 VALUES 1990 THROUGH 2050.D/
05 User-Month                 PIC 9(2)./?
88 Valid-User-Month                VALUES 1 THROUGH 12.?/
05 User-Day                   PIC 9(2)./?
88 Valid-User-Day                  VALUES 1 THROUGH 31.?
03 User-Day-Of-Year             PIC 9(3).1B
88 Valid-User-Day-Of-Year            VALUES 1 THROUGH 366.B1
03 User-Day-Of-Week             PIC 9(1).1@
88 Valid-User-Day-Of-Week            VALUES 1 THROUGH 7.@
01 System-Date.
03 System-Year                  PIC 9(4) VALUE 0.9F
88 Valid-System-Year                 VALUES 1990 THROUGH 2050.F9
03 System-Month                 PIC 9(2) VALUE 0.9A
88 Valid-System-Month                VALUES 1 THROUGH 12.A9
03 System-Day                   PIC 9(2) VALUE 0.9A
88 Valid-System-Day                  VALUES 1 THROUGH 31.A
PROCEDURE DIVISION.
DECLARATIVES.
END DECLARATIVES.
Main-Logic.
INITIALIZE System-Date.
ACCEPT System-Date FROM CENTURY-DATE.-J
DISPLAY "[A-CDATE] System Returned Date " System-Date UPON SYSERR.J
IF NOT (Valid-System-Year AND Valid-System-Month AND Valid-System-Day) THENSO
DISPLAY "[A-CDATE] Something's wrong with the system date!" UPON SYSERROK
DISPLAY "[A-CDATE] CENTURY-DATE reported: " System-Date UPON SYSERRK
SET Test-Failed TO TRUE
END-IF.
IF NOT (System-Year = User-Year) THEN-]
DISPLAY "[A-CDATE] Returned Year " System-Year " != User-Year " User-Year UPON SYSERR]
SET Test-Failed TO TRUE
ELSE
IF NOT Test-Failed THEN SET Test-Passed TO TRUE7
END-IF.
IF NOT (System-Month = User-Month) THEN/a
DISPLAY "[A-CDATE] Returned Month " System-Month " != User-Month " User-Month UPON SYSERRa
SET Test-Failed TO TRUE
ELSE
IF NOT Test-Failed THEN SET Test-Passed TO TRUE7
END-IF.
IF NOT (System-Day = User-Day) THEN+Y
DISPLAY "[A-CDATE] Returned Day " System-Day " != User-Day " User-Day UPON SYSERRY
SET Test-Failed TO TRUE
ELSE
IF NOT Test-Failed THEN SET Test-Passed TO TRUE7
END-IF.
GOBACK 0.
<<EOF>>
A-CDAY
0000000
[A-CDAY] User-Day-Of-Year != Returned-Century-Day-Of-Year 2[A-CDAY] User-Year != Returned-Century-Day-Of-Year 
A-CDAY
TEST-DATA
RETURN-CODE
TEST-DATA
TEST-RESULT-CODE
TEST-PASSED
TEST-FAILED
USER-DATE
USER-YEAR
VALID-USER-YEAR
USER-MONTH
VALID-USER-MONTH
USER-DAY
VALID-USER-DAY
USER-DAY-OF-YEAR
VALID-USER-DAY-OF-YEAR
USER-DAY-OF-WEEK
VALID-USER-DAY-OF-WEEK
RETURNED-CENTURY-DAY-OF-YEAR
RETURN-CODE
MAIN-LOGIC
IDENTIFICATION DIVISION. &
PROGRAM-ID. A-CDAY IS INITIAL.&
AUTHOR. Chris Adams.
DATE-WRITTEN. 19970801.
* Tests the date returned by ACCEPT FROM DATE5-
* Copyright 
 1996-1998 Acucorp, Inc.-@
* $Id: A-CDAY.CBL,v 1.1 1998/07/09 22:52:33 cadams Exp $@
* Format 3 (ACCEPT FROM  )"S
* 32. The Format 3 ACCEPT statement causes information to be transferred toSF
*     dest-item according to the rules for the MOVE statement.F
* 34. The DAY option causes the current date to be moved to dest-item.  TheSR
*     format of the date is the year of the century (2 digits) followed byRQ
*     the day of the year (3 digits).  For example, December 25, 1998, isQR
*     "98359".  DAY acts as if it were described by a PICTURE 9(5) clause.R
* 35. ACCEPT FROM CENTURY-DATE returns the current date in the format "YYYYMMDD"XX
*     (year/month/day).  ACCEPT FROM CENTURY-DAY returns the current date in theXU
*     format "YYYYDDD" (year/day-of-year).  These are the same as ACCEPT FROMUY
*     DATE and ACCEPT FROM DAY, except that the year field is 4 digits instead ofY
*     2 digits.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-PC.  
OBJECT-COMPUTER. IBM-PC. 
WORKING-STORAGE SECTION. 
COPY "testsum.def".
* Data structure for passing info between test program and manager.K
01 Test-Data EXTERNAL.
03 Test-Result-Code             PIC 9(1).10
88 Test-Passed                  VALUE 1.00
88 Test-Failed                  VALUE 2.0
03 User-Date.          | ISO8601(/
05 User-Year                  PIC 9(4)./D
88 Valid-User-Year                 VALUES 1990 THROUGH 2050.D/
05 User-Month                 PIC 9(2)./?
88 Valid-User-Month                VALUES 1 THROUGH 12.?/
05 User-Day                   PIC 9(2)./?
88 Valid-User-Day                  VALUES 1 THROUGH 31.?
03 User-Day-Of-Year             PIC 9(3).1B
88 Valid-User-Day-Of-Year            VALUES 1 THROUGH 366.B1
03 User-Day-Of-Week             PIC 9(1).1@
88 Valid-User-Day-Of-Week            VALUES 1 THROUGH 7.@
01 Returned-Century-Day-Of-Year         PIC 9(7) VALUE 0.A
PROCEDURE DIVISION.
DECLARATIVES.
END DECLARATIVES.
Main-Logic.
INITIALIZE Returned-Century-Day-Of-Year.0=
ACCEPT Returned-Century-Day-Of-Year FROM Century-Day.=
IF NOT (User-Day-Of-Year = Returned-Century-Day-Of-Year(5:3)) THENJu
DISPLAY "[A-CDAY] User-Day-Of-Year != Returned-Century-Day-Of-Year " Returned-Century-Day-Of-Year UPON SYSERRu
SET Test-Failed TO TRUE
ELSE
IF NOT Test-Failed THEN SET Test-Passed TO TRUE7
END-IF.
IF NOT (User-Year = Returned-Century-Day-Of-Year(1:4)) THENCn
DISPLAY "[A-CDAY] User-Year != Returned-Century-Day-Of-Year " Returned-Century-Day-Of-Year UPON SYSERRn
SET Test-Failed TO TRUE
ELSE
IF NOT Test-Failed THEN SET Test-Passed TO TRUE7
END-IF.
GOBACK 0.
<<EOF>>
A-DATE
000000
w b#
w+b.
[A-DATE] Returned Date 90990050011231[A-DATE] Something's wrong with the system date![A-DATE] DATE reported: 2[A-DATE] Returned Year  != User-Year [A-DATE] Returned Month  != User-Month [A-DATE] Returned Day  != User-Day 
A-DATE
TEST-DATA
RETURN-CODE
TEST-DATA
TEST-RESULT-CODE
TEST-PASSED
TEST-FAILED
USER-DATE
USER-YEAR
VALID-USER-YEAR
USER-MONTH
VALID-USER-MONTH
USER-DAY
VALID-USER-DAY
USER-DAY-OF-YEAR
VALID-USER-DAY-OF-YEAR
USER-DAY-OF-WEEK
VALID-USER-DAY-OF-WEEK
SYSTEM-DATE
SYSTEM-YEAR
VALID-SYSTEM-YEAR
SYSTEM-MONTH
VALID-SYSTEM-MONTH
SYSTEM-DAY
VALID-SYSTEM-DAY
RETURN-CODE
MAIN-LOGIC
IDENTIFICATION DIVISION. &
PROGRAM-ID. A-DATE IS INITIAL.&
AUTHOR. Chris Adams.
DATE-WRITTEN. 19970801.
* Tests the date returned by ACCEPT FROM DATE5-
* Copyright 
 1996-1998 Acucorp, Inc.-@
* $Id: A-DATE.CBL,v 1.1 1998/07/09 22:52:34 cadams Exp $@
* Format 3 (ACCEPT FROM DATE)%
* 32. The Format 3 ACCEPT statement causes information to be transferred toSF
*     dest-item according to the rules for the MOVE statement.FT
* 33. The DATE option causes the current date to be moved to dest-item.  TheTU
*     date is composed of the year of the century, the month of the year, andUT
*     the day of the month.  Each element occupies two digits.  For example,TT
*     December 25, 1998, would be expressed "981225".  DATE is treated as ifT9
*     it were described by a PICTURE 9(6) clause.9
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-PC.  
OBJECT-COMPUTER. IBM-PC. 
WORKING-STORAGE SECTION. 
COPY "testsum.def".
* Data structure for passing info between test program and manager.K
01 Test-Data EXTERNAL.
03 Test-Result-Code             PIC 9(1).10
88 Test-Passed                  VALUE 1.00
88 Test-Failed                  VALUE 2.0
03 User-Date.          | ISO8601(/
05 User-Year                  PIC 9(4)./D
88 Valid-User-Year                 VALUES 1990 THROUGH 2050.D/
05 User-Month                 PIC 9(2)./?
88 Valid-User-Month                VALUES 1 THROUGH 12.?/
05 User-Day                   PIC 9(2)./?
88 Valid-User-Day                  VALUES 1 THROUGH 31.?
03 User-Day-Of-Year             PIC 9(3).1B
88 Valid-User-Day-Of-Year            VALUES 1 THROUGH 366.B1
03 User-Day-Of-Week             PIC 9(1).1@
88 Valid-User-Day-Of-Week            VALUES 1 THROUGH 7.@
01 System-Date.
03 System-Year                  PIC 9(2) VALUE 0.9P
88 Valid-System-Year                 VALUES 90 THROUGH 99, 0 THROUGH 50.P9
03 System-Month                 PIC 9(2) VALUE 0.9A
88 Valid-System-Month                VALUES 1 THROUGH 12.A9
03 System-Day                   PIC 9(2) VALUE 0.9A
88 Valid-System-Day                  VALUES 1 THROUGH 31.A
PROCEDURE DIVISION.
DECLARATIVES.
END DECLARATIVES.
Main-Logic.
INITIALIZE System-Date.
ACCEPT System-Date FROM DATE.%B
DISPLAY "[A-DATE] Returned Date " System-Date UPON SYSERR.B
IF NOT (Valid-System-Year AND Valid-System-Month AND Valid-System-Day) THENSN
DISPLAY "[A-DATE] Something's wrong with the system date!" UPON SYSERRNB
DISPLAY "[A-DATE] DATE reported: " System-Date UPON SYSERRB
SET Test-Failed TO TRUE
END-IF.
IF NOT (System-Year = User-Year(3:2)) THEN2\
DISPLAY "[A-DATE] Returned Year " System-Year " != User-Year " User-Year UPON SYSERR\
SET Test-Failed TO TRUE
ELSE
IF NOT Test-Failed THEN SET Test-Passed TO TRUE7
END-IF.
IF NOT (System-Month = User-Month) THEN/`
DISPLAY "[A-DATE] Returned Month " System-Month " != User-Month " User-Month UPON SYSERR`
SET Test-Failed TO TRUE
ELSE
IF NOT Test-Failed THEN SET Test-Passed TO TRUE7
END-IF.
IF NOT (System-Day = User-Day) THEN+X
DISPLAY "[A-DATE] Returned Day " System-Day " != User-Day " User-Day UPON SYSERRX
SET Test-Failed TO TRUE
ELSE
IF NOT Test-Failed THEN SET Test-Passed TO TRUE7
END-IF.
GOBACK 0.
<<EOF>>
A-DAY
00000
[A-DOW] User-Day-Of-Year  != Returned-Day-Of-Year 2
A-DAY
TEST-DATA
RETURN-CODE
TEST-DATA
TEST-RESULT-CODE
TEST-PASSED
TEST-FAILED
USER-DATE
USER-YEAR
VALID-USER-YEAR
USER-MONTH
VALID-USER-MONTH
USER-DAY
VALID-USER-DAY
USER-DAY-OF-YEAR
VALID-USER-DAY-OF-YEAR
USER-DAY-OF-WEEK
VALID-USER-DAY-OF-WEEK
RETURNED-DAY-OF-YEAR
RETURN-CODE
MAIN-LOGIC
IDENTIFICATION DIVISION. %
PROGRAM-ID. A-DAY IS INITIAL.%
AUTHOR. Chris Adams.
DATE-WRITTEN. 19970801.
* Tests the date returned by ACCEPT FROM DATE5-
* Copyright 
 1996-1998 Acucorp, Inc.-?
* $Id: A-DAY.CBL,v 1.1 1998/07/09 22:52:34 cadams Exp $?
* Format 3 (ACCEPT FROM DAY)$
* 32. The Format 3 ACCEPT statement causes information to be transferred toSF
*     dest-item according to the rules for the MOVE statement.FS
* 34. The DAY option causes the current date to be moved to dest-item.  TheSR
*     format of the date is the year of the century (2 digits) followed byRQ
*     the day of the year (3 digits).  For example, December 25, 1998, isQR
*     "98359".  DAY acts as if it were described by a PICTURE 9(5) clause.R
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-PC.  
OBJECT-COMPUTER. IBM-PC. 
WORKING-STORAGE SECTION. 
COPY "testsum.def".
* Data structure for passing info between test program and manager.K
01 Test-Data EXTERNAL.
03 Test-Result-Code             PIC 9(1).10
88 Test-Passed                  VALUE 1.00
88 Test-Failed                  VALUE 2.0
03 User-Date.          | ISO8601(/
05 User-Year                  PIC 9(4)./D
88 Valid-User-Year                 VALUES 1990 THROUGH 2050.D/
05 User-Month                 PIC 9(2)./?
88 Valid-User-Month                VALUES 1 THROUGH 12.?/
05 User-Day                   PIC 9(2)./?
88 Valid-User-Day                  VALUES 1 THROUGH 31.?
03 User-Day-Of-Year             PIC 9(3).1B
88 Valid-User-Day-Of-Year            VALUES 1 THROUGH 366.B1
03 User-Day-Of-Week             PIC 9(1).1@
88 Valid-User-Day-Of-Week            VALUES 1 THROUGH 7.@
01 Returned-Day-Of-Year         PIC 9(5) VALUE 0.9
PROCEDURE DIVISION.
DECLARATIVES.
END DECLARATIVES.
Main-Logic.
INITIALIZE Returned-Day-Of-Year.(-
ACCEPT Returned-Day-Of-Year FROM DAY.-
IF NOT (User-Day-Of-Year = Returned-Day-Of-Year(3:3)) THENBy
DISPLAY "[A-DOW] User-Day-Of-Year " User-Day-Of-Year " != Returned-Day-Of-Year " Returned-Day-Of-Year UPON SYSERRy
SET Test-Failed TO TRUE
ELSE
SET Test-Passed TO TRUE
END-IF.
GOBACK 0.
<<EOF>>
A-DOW
[A-DOW] User-Day-Of-Week != Returned-Day-Of-Week2
A-DOW
TEST-DATA
RETURN-CODE
TEST-DATA
TEST-RESULT-CODE
TEST-PASSED
TEST-FAILED
USER-DATE
USER-YEAR
VALID-USER-YEAR
USER-MONTH
VALID-USER-MONTH
USER-DAY
VALID-USER-DAY
USER-DAY-OF-YEAR
VALID-USER-DAY-OF-YEAR
USER-DAY-OF-WEEK
VALID-USER-DAY-OF-WEEK
RETURNED-DAY-OF-WEEK
RETURN-CODE
MAIN-LOGIC
IDENTIFICATION DIVISION. %
PROGRAM-ID. A-DOW IS INITIAL.%
AUTHOR. Chris Adams.
DATE-WRITTEN. 19970801.
* Tests the date returned by ACCEPT FROM DAY-OF-WEEK<-
* Copyright 
 1996-1998 Acucorp, Inc.-?
* $Id: A-DOW.CBL,v 1.2 1998/07/28 22:05:05 cadams Exp $?
* Format 3 (ACCEPT FROM DAY-OF-WEEK),
* 32. The Format 3 ACCEPT statement causes information to be transferred toSF
*     dest-item according to the rules for the MOVE statement.FS
* 37. The DAY-OF-WEEK option causes the current day of the week to be movedSN
*     to dest-item.  The format of this item is a single digit where 1NO
*     represents Monday, 2 represents Tuesday, up through 7 for Sunday.OM
*     DAY-OF-WEEK acts as if it were described by a PICTURE 9 clause.M
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-PC.  
OBJECT-COMPUTER. IBM-PC. 
WORKING-STORAGE SECTION. 
COPY "testsum.def".
* Data structure for passing info between test program and manager.K
01 Test-Data EXTERNAL.
03 Test-Result-Code             PIC 9(1).10
88 Test-Passed                  VALUE 1.00
88 Test-Failed                  VALUE 2.0
03 User-Date.          | ISO8601(/
05 User-Year                  PIC 9(4)./D
88 Valid-User-Year                 VALUES 1990 THROUGH 2050.D/
05 User-Month                 PIC 9(2)./?
88 Valid-User-Month                VALUES 1 THROUGH 12.?/
05 User-Day                   PIC 9(2)./?
88 Valid-User-Day                  VALUES 1 THROUGH 31.?
03 User-Day-Of-Year             PIC 9(3).1B
88 Valid-User-Day-Of-Year            VALUES 1 THROUGH 366.B1
03 User-Day-Of-Week             PIC 9(1).1@
88 Valid-User-Day-Of-Week            VALUES 1 THROUGH 7.@
01 Returned-Day-Of-Week         PIC 9(1) VALUE 0.9
PROCEDURE DIVISION.
DECLARATIVES.
END DECLARATIVES.
Main-Logic.
INITIALIZE Returned-Day-Of-Week.(
ACCEPT Returned-Day-Of-Week FROM DAY-OF-WEEK.5
IF NOT (User-Day-Of-Week = Returned-Day-Of-Week) THEN=c
DISPLAY "[A-DOW] User-Day-Of-Week != Returned-Day-Of-Week" Returned-Day-Of-Week UPON SYSERRc
SET Test-Failed TO TRUE
ELSE
SET Test-Passed TO TRUE
END-IF.
GOBACK 0.
<<EOF>>
DAYWEEK
Sun  Mon  Tues Wed  ThursFri  Sat
intdate7
DAYWEE
DAY-1
DAY-2
DAY-INDEX
DAY-TABLE
DAYS-TO-NAME-TABLE
DAYS-TO-NAME
DATE-1
DAY-NAME
MAIN-LOGIC
identification division. 
program-id.  dayweek.
* Copyright (c) 1996 - 1997 by Acucobol, Inc.55
* Users of ACUCOBOL may freely use this file.5
remarks.
This program takes a date (in the form YYYYMMDD) and returnsD
the day of the week.
It assumes that the program "intdate.cbl" has been compiled withH,
the object module name of "intdate".,
This program is designed to be called by another program.A*
For an example, see "dgetday.cbl".*
See the caveats in intdate.cbl.'
data division.
working-storage section. 1
01  day-1                       pic 9(8).11
01  day-2                       pic 9(8).1.
01  day-index                   pic 9..
01  day-table.
03  pic x(5)  value "Sun  ".$$
03  pic x(5)  value "Mon  ".$$
03  pic x(5)  value "Tues ".$$
03  pic x(5)  value "Wed  ".$$
03  pic x(5)  value "Thurs".$$
03  pic x(5)  value "Fri  ".$$
03  pic x(5)  value "Sat  ".$
01  days-to-name-table redefines day-table.3
03  days-to-name
occurs 7 times              pic x(5).-
LINKAGE SECTION.
01  date-1                      pic x(8).11
01  day-name                    pic x(5).1
procedure division using date-1, day-name.2
main-logic.
call "intdate" using date-1, day-1.+:
divide day-1 by 7 giving day-2 remainder day-index:5
move days-to-name(day-index + 1) to day-name.5
exit program.
<<EOF>>
DGETDAY
Date (mmddyyyy):   /  /    (enter '0' to quit)    
L'P*
T7^"T:
T7^"T:
T7^"T:
LCP*^2
0112311601090406113002028129dayweek41Day of week is : 6Press enter to continue: 00010040023invalid date entered.  Press <RETURN>
DGETDA
DAY-1
DAY-BREAKDOWN
DAY-YYYY
DAY-MM
DAY-DD
DAY-NAME
LEAP-YEAR
MOD-REM
TMP-DIV
DATE-SCREEN
MAIN-LOGIC
CONVERT-DATE
LEAP-YEAR-CHECK
BAD-DATE
identification division. 
program-id.  dgetday.
* Copyright (c) 1996 - 1997 by Acucobol, Inc.55
* Users of ACUCOBOL may freely use this file.5
remarks.
This program takes a date (in the form MMDDYY) from the userD?
and, after converting it to the form YYYYMMDD, displays?D
the day of the week for that day.  This program requires theD@
programs 'dayweek' and 'intdate' to run.  It is designed@2
to demonstrate how to call those programs.2
See the caveats in intdate.cbl.'
data division.
working-storage section. 1
01  day-1                       pic 9(8).1*
01  day-breakdown redefines day-1.*)
03 day-yyyy             pic 9(4).))
03 day-mm               pic 9(2).))
03 day-dd               pic 9(2).)1
01  day-name                    pic x(5).1
01  leap-year                   pic 9..0
01  mod-rem                     pic 999.0.
01  tmp-div                     pic 9..
screen section.
01  date-screen.
03  "Date (mmddyyyy): ", line 2 column 1.1
03  to day-mm, auto.
03  "/".
03  to day-dd, auto.
03  "/".
03  to day-yyyy, auto.
03  "(enter '0' to quit)", column 30.-
procedure division.
main-logic.
perform convert-date, with test after, until day-mm = zeroB
stop run.
convert-date.
display window erase.
display date-screen.
accept date-screen.
if day-mm = zero
exit paragraph.
if day-mm < 1 or day-mm > 12 or day-dd < 1 or day-dd > 31 orD
day-yyyy < 1601
go to bad-date.
if (day-mm = 9 or day-mm = 4 or day-mm = 6 or day-mm = 11) andF
day-dd > 30
go to bad-date.
perform leap-year-check. =
if day-mm = 2 and ((leap-year = 0 and day-dd > 28) or=(
(leap-year = 1 and day-dd > 29))(
go to bad-date.
call "dayweek" using day-1, day-name.-8
display "Day of week is : ", line 4 column 1 no.8
display day-name.
display "Press enter to continue: ", line 6.4
accept omitted.
leap-year-check.
move 0 to leap-year
divide day-yyyy by 4 giving tmp-div remainder mod-rem=
if mod-rem = 0
move 1 to leap-year
divide day-yyyy by 100 giving tmp-div remainder mod-rem?
if mod-rem = 0
move 0 to leap-year
divide day-yyyy by 400 giving tmp-div remainder mod-rem?
if mod-rem = 0
move 1 to leap-year
end-if
end-if
end-if.
bad-date.
display "invalid date entered.  Press <RETURN>",8%
line 23, column 1, bold, beep%
accept omitted
go to main-logic
<<EOF>>
FILEINFO
 00000000
2000C$FILEINFO200001012[FILEINFO] FAIL Files with dates > 1999203820380101[FILEINFO] FAIL Files with dates in 2038
FILEIN
TEST-DATA
RETURN-CODE
FILEINFO-DATA
FILE-NAME
FILE-INFO
XFILE-SIZE
XFILE-DATE
XFILE-TIME
STATUS-CODE
FILE-EXISTS
DISPLAY-VARIABLES
FILE-DATE
TEST-DATA
TEST-RESULT-CODE
TEST-PASSED
TEST-FAILED
USER-DATE
USER-YEAR
VALID-USER-YEAR
USER-MONTH
VALID-USER-MONTH
USER-DAY
VALID-USER-DAY
USER-DAY-OF-YEAR
VALID-USER-DAY-OF-YEAR
USER-DAY-OF-WEEK
VALID-USER-DAY-OF-WEEK
RETURN-CODE
MAIN-LOGIC
IDENTIFICATION DIVISION. (
PROGRAM-ID. FILEINFO IS INITIAL.(
AUTHOR. Chris Adams.
DATE-WRITTEN. 19980707.
* Tests the date returned by C$FILEINFO/-
* Copyright 
 1996-1998 Acucorp, Inc.-B
* $Id: FILEINFO.CBL,v 1.1 1998/07/09 22:52:35 cadams Exp $B
* C$FILEINFO Routine
* Book 4:  Appendices
* C$FILEINFO retrieves some operating system information about a given file.T
* Usage
* CALL "C$FILEINFO"
*   USING FILE-NAME, FILE-INFO,'
*   GIVING STATUS-CODE
* Parameters
* FILE-NAME PIC X(n)
* Contains the name of the file to check.  This should either be a full path nameY6
* or a name relative to the current directory.6
* FILE-INFO Group item
* Group item to receive returned information.  Must have this structure:P
* 01  FILE-INFO.
*     02  FILE-SIZE  PIC X(8) COMP-X.--
*     02  FILE-DATE  PIC 9(8) COMP-X.--
*     02  FILE-TIME  PIC 9(8) COMP-X.-
* STATUS-CODE Any numeric data item+
* This receives the return status.  It will be zero if successful, or "1" if the file]7
* does not exist or is not a regular disk file.7
* Comments
* This routine checks to see if the passed file exists and is a regular disk file.  If^]
* it is, then FILE-INFO is filled in with the appropriate information.  The FILE-SIZE]^
* field is the size of the file in bytes.  The FILE-DATE and FILE-TIME fields indicate^b
* the time the file was last modified.  FILE-DATE has the form "YYYYMMDD" (year/month/day,bF
* note the 4-digit year) and FILE-TIME has the form "HHMMSShh"F[
* (hours/minutes/seconds/hundredths -- just like ACCEPT FROM TIME).  On all current[F
* implementations, the hundredths field is always set to zero.F
* Note that this routine provides a handy way to see if a file exists.N
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-PC.  
OBJECT-COMPUTER. IBM-PC. 
WORKING-STORAGE SECTION. 
01 FileInfo-Data.
03 FILE-NAME              PIC X(32) VALUE SPACES.9
03  FILE-INFO.
05  XFILE-SIZE        PIC X(8) VALUE SPACES.4k
05  XFILE-DATE        PIC 9(8) COMP-X VALUE 0. | FILE-DATE has the form "YYYYMMDD" (year/month/day)k}
05  XFILE-TIME        PIC 9(8) COMP-X VALUE 0. | FILE-TIME has the form "HHMMSShh" (hours/minutes/seconds/hundredths)}:
03 STATUS-CODE            PIC 9(1) COMP-X VALUE 0.:*
88 File-Exists            VALUE 0.*
01 Display-Variables.
03 File-Date              PIC 9(8) USAGE DISPLAY VALUE 0.A
COPY "testsum.def".
* Data structure for passing info between test program and manager.K
01 Test-Data EXTERNAL.
03 Test-Result-Code             PIC 9(1).10
88 Test-Passed                  VALUE 1.00
88 Test-Failed                  VALUE 2.0
03 User-Date.          | ISO8601(/
05 User-Year                  PIC 9(4)./D
88 Valid-User-Year                 VALUES 1990 THROUGH 2050.D/
05 User-Month                 PIC 9(2)./?
88 Valid-User-Month                VALUES 1 THROUGH 12.?/
05 User-Day                   PIC 9(2)./?
88 Valid-User-Day                  VALUES 1 THROUGH 31.?
03 User-Day-Of-Year             PIC 9(3).1B
88 Valid-User-Day-Of-Year            VALUES 1 THROUGH 366.B1
03 User-Day-Of-Week             PIC 9(1).1@
88 Valid-User-Day-Of-Week            VALUES 1 THROUGH 7.@
PROCEDURE DIVISION.
DECLARATIVES.
END DECLARATIVES.
Main-Logic.
INITIALIZE FileInfo-Data.!
MOVE "2000" TO File-Name.!I
CALL "C$FILEINFO" USING FILE-NAME, FILE-INFO, GIVING STATUS-CODE.I$
SET File-Date TO XFile-Date.$
IF File-Date = 20000101 THEN$*
SET Test-Passed TO TRUE  | Pass it*
ELSE
SET Test-Failed TO TRUE  | Fail it*E
DISPLAY "[FILEINFO] FAIL Files with dates > 1999" UPON SYSERRE
END-IF.
* 1/1/2038 is before time_t overflows a 32-bit integer. It should be safe...T!
MOVE "2038" TO File-Name.!I
CALL "C$FILEINFO" USING FILE-NAME, FILE-INFO, GIVING STATUS-CODE.I$
SET File-Date TO XFile-Date.$
IF File-Date = 20380101 THEN$*
SET Test-Passed TO TRUE  | Pass it*
ELSE
SET Test-Failed TO TRUE  | Fail it*F
DISPLAY "[FILEINFO] FAIL Files with dates in 2038" UPON SYSERRF
END-IF.
* 1/1/2039 is not safe as time_t will overflow a 32-bit integer. This mayQR
* cause crashes on many platforms. Compile with -Si 2039 to test anyway...RX
*    MOVE "2039" TO File-Name.                                             |2039XX
*    CALL "C$FILEINFO" USING FILE-NAME, FILE-INFO, GIVING STATUS-CODE.     |2039XX
*    SET File-Date TO XFile-Date.                                          |2039X
K|2039
*    IF File-Date = 20390101 THEN                                          |2039XU
*      SET Test-Passed TO TRUE  | Pass it                               |2039UX
*    ELSE                                                                  |2039XU
*      SET Test-Failed TO TRUE  | Fail it                               |2039UX
*      DISPLAY "[FILEINFO] FAIL Files with dates 2039" UPON SYSERR         |2039XX
*    END-IF.                                                               |2039X
GOBACK 0.
<<EOF>>
INTDATE
000031059090120151181212243273304334
.R/#%
R5#%
T9^"T<
T9^"T<
T9^"T<
00000000160141004003651020000
INTDAT
MONTH-TABLE
DAYS-TO-MONTH-TABLE
DAYS-TO-MONTH
THIS-YEAR
LEAP-DAYS
LEAP-4
LEAP-100
LEAP-400
LEAP-YEAR
MOD-REM
TMP-DIV
DATE-IN
DATE-YEAR
DATE-MONTH
DATE-DAY
INT-OUT
MAIN-LOGIC
LEAP-YEAR-CHECK
identification division. 
program-id.  intdate.
* Copyright 
 1996-1998 Acucorp, Inc.-5
* Users of ACUCOBOL may freely use this file.5
remarks.
This routine simulates the new ANSI INTEGER-OF-DATE intrinsicE@
function.  It converts a date in the form YYYYMMDD to an@D
integer value that is the number of days since Dec 31, 1600.DI
This can be used to compute the number of days between two dates.I
This program is designed to be called by another program.A*
For an example, see "dayweek.cbl".*
Caveats:
- This program doesn't agree with the output of the UNIX programHF
"cal" prior to September 14, 1752.  "cal" says that 1700 was aFI
leap year.  "cal" also accounts for the missing days in SeptemberIJ
1752.  This program merely projects the current calendar structureJ@
back to 1601 without regard for these historical quirks.@
data division.
working-storage section. 
01  month-table.
03  pic 999 value zero.
03  pic 999 value 31.
03  pic 999 value 59.
03  pic 999 value 90.
03  pic 999 value 120.
03  pic 999 value 151.
03  pic 999 value 181.
03  pic 999 value 212.
03  pic 999 value 243.
03  pic 999 value 273.
03  pic 999 value 304.
03  pic 999 value 334.
01  days-to-month-table redefines month-table.6
03  days-to-month
occurs 12 times   pic 999."
01  this-year       pic 9(4).%%
01  leap-days       pic 9(4).%#
01  leap-4        pic 9(4).#%
01  leap-100        pic 9(4).%%
01  leap-400        pic 9(4).%
01  leap-year       pic 9.""
01  mod-rem       pic 999." 
01  tmp-div       pic 9. 
linkage section.
01  date-in.
03  date-year     pic 9(4).#%
03  date-month      pic 9(2).%#
03  date-day      pic 9(2).#
01  int-out       pic 9(8).#
procedure division using date-in, int-out.2
main-logic.
move zero to int-out.
* compute # of days to passed year.+6
subtract 1601 from date-year giving this-year.6'
compute leap-4 = this-year / 4.'+
compute leap-100 = this-year / 100.++
compute leap-400 = this-year / 400.+9
compute leap-days = leap-4 - leap-100 + leap-400.96
compute int-out = this-year * 365 + leap-days.6
* add in # of days in preceeding months/3
add days-to-month( date-month ) to int-out.3
* is this a leap year?
perform leap-year-check. +
if leap-year = 1 and date-month > 2+
add 1 to int-out.
* add in day within month! 
add date-day to int-out. 
exit program.
leap-year-check.
move 0 to leap-year
divide date-year by 4 giving tmp-div remainder mod-rem>
if mod-rem = 0
move 1 to leap-year
divide date-year by 100 giving tmp-div remainder mod-rem@
if mod-rem = 0
move 0 to leap-year
divide date-year by 400 giving tmp-div remainder mod-rem@
if mod-rem = 0
move 1 to leap-year
end-if
end-if
end-if.
<<EOF>>
T-DAYWEEK
Monday
 Tuesday
.Wednesday
<Thursday
JFriday
XSaturday
fSunday
dayweek[T-DAYWEEK] User-Day-Of-Week != Day-Name 2
T-DAYW
TEST-DATA
RETURN-CODE
TEST-DATA
TEST-RESULT-CODE
TEST-PASSED
TEST-FAILED
USER-DATE
USER-YEAR
VALID-USER-YEAR
USER-MONTH
VALID-USER-MONTH
USER-DAY
VALID-USER-DAY
USER-DAY-OF-YEAR
VALID-USER-DAY-OF-YEAR
USER-DAY-OF-WEEK
VALID-USER-DAY-OF-WEEK
DATE-1
DAY-NAME
DAY-NAMES
WEEKDAYS
WEEKDAY-POINTER
RETURN-CODE
MAIN-LOGIC
IDENTIFICATION DIVISION. )
PROGRAM-ID. T-DAYWEEK IS INITIAL.)
AUTHOR. Chris Adams.
DATE-WRITTEN. 19980707.
* Tests the date returned by DAYWEEK.CBL0.
* Copyright (c) 1997 by Acucobol, Inc..C
* $Id: t-dayweek.cbl,v 1.1 1998/07/09 22:52:37 cadams Exp $C
* [DAYWEEK.CBL notes]
*   This program takes a date (in the form YYYYMMDD) and returnsH 
*   the day of the week. 
*   It assumes that the program "intdate.cbl" has been compiled withL0
*   the object module name of "intdate".0
*   This program is designed to be called by another program.E.
*   For an example, see "dgetday.cbl"..
*   See the caveats in intdate.cbl.+
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-PC.  
OBJECT-COMPUTER. IBM-PC. 
WORKING-STORAGE SECTION. 
COPY "testsum.def".
* Data structure for passing info between test program and manager.K
01 Test-Data EXTERNAL.
03 Test-Result-Code             PIC 9(1).10
88 Test-Passed                  VALUE 1.00
88 Test-Failed                  VALUE 2.0
03 User-Date.          | ISO8601(/
05 User-Year                  PIC 9(4)./D
88 Valid-User-Year                 VALUES 1990 THROUGH 2050.D/
05 User-Month                 PIC 9(2)./?
88 Valid-User-Month                VALUES 1 THROUGH 12.?/
05 User-Day                   PIC 9(2)./?
88 Valid-User-Day                  VALUES 1 THROUGH 31.?
03 User-Day-Of-Year             PIC 9(3).1B
88 Valid-User-Day-Of-Year            VALUES 1 THROUGH 366.B1
03 User-Day-Of-Week             PIC 9(1).1@
88 Valid-User-Day-Of-Week            VALUES 1 THROUGH 7.@
01  Date-1        PIC 9(8).##
01  Day-Name      PIC X(5).#
01 Day-Names.
03 PIC X(14) VALUE "Monday".$%
03 PIC X(14) VALUE "Tuesday".%'
03 PIC X(14) VALUE "Wednesday".'&
03 PIC X(14) VALUE "Thursday".&$
03 PIC X(14) VALUE "Friday".$&
03 PIC X(14) VALUE "Saturday".&$
03 PIC X(14) VALUE "Sunday".$
01 Weekdays
REDEFINES Day-Names,
OCCURS 7 TIMES INDEXED BY Weekday-Pointer     PIC X(14).@
PROCEDURE DIVISION.
DECLARATIVES.
END DECLARATIVES.
Main-Logic.
INITIALIZE Day-Name, Date-1, Test-Result-Code.6
MOVE User-Date TO Date-1.!.
CALL "dayweek" USING Date-1, Day-Name..
IF NOT (Weekdays(User-Day-Of-Week)(1:2) = Day-Name(1:2) ) THENFP
DISPLAY "[T-DAYWEEK] User-Day-Of-Week != Day-Name " Day-Name UPON SYSERRP
SET Test-Failed TO TRUE
ELSE
SET Test-Passed TO TRUE
END-IF.
GOBACK 0.
<<EOF>>
T-INTDATE
0000000000000000000000000000000000000000000000000000000000000000
w,\/^
w2b5
intdate200001018812[T-INTDATE] INTDATE says Y2K is  days away365-[T-INTDATE] INTDATE says Y2K was  days ago20000228200002291[T-INTDATE] INTDATE says Feb 29 was  days after Feb 28...
T-INTD
TEST-DATA
RETURN-CODE
TEST-DATA
TEST-RESULT-CODE
TEST-PASSED
TEST-FAILED
USER-DATE
USER-YEAR
VALID-USER-YEAR
USER-MONTH
VALID-USER-MONTH
USER-DAY
VALID-USER-DAY
USER-DAY-OF-YEAR
VALID-USER-DAY-OF-YEAR
USER-DAY-OF-WEEK
VALID-USER-DAY-OF-WEEK
DATE-OUT
USER-DATE-NUM
USER-DATE-INT
JAN2K-INT
USER-Y2K-DELTA
Y2K-DELTA-TOO-LOW
Y2K-DELTA-TOO-HIGH
FEB28-Y2K
FEB29-Y2K
FEB29-DELTA
RETURN-CODE
MAIN-LOGIC
IDENTIFICATION DIVISION. )
PROGRAM-ID. T-INTDATE IS INITIAL.)
AUTHOR. Chris Adams.
DATE-WRITTEN. 19970804.
* Tests the date returned by INTDATE,.
* Copyright (c) 1997 by Acucobol, Inc..C
* $Id: t-intdate.cbl,v 1.1 1998/07/09 22:52:37 cadams Exp $C
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-PC.  
OBJECT-COMPUTER. IBM-PC. 
WORKING-STORAGE SECTION. 
COPY "testsum.def".
* Data structure for passing info between test program and manager.K
01 Test-Data EXTERNAL.
03 Test-Result-Code             PIC 9(1).10
88 Test-Passed                  VALUE 1.00
88 Test-Failed                  VALUE 2.0
03 User-Date.          | ISO8601(/
05 User-Year                  PIC 9(4)./D
88 Valid-User-Year                 VALUES 1990 THROUGH 2050.D/
05 User-Month                 PIC 9(2)./?
88 Valid-User-Month                VALUES 1 THROUGH 12.?/
05 User-Day                   PIC 9(2)./?
88 Valid-User-Day                  VALUES 1 THROUGH 31.?
03 User-Day-Of-Year             PIC 9(3).1B
88 Valid-User-Day-Of-Year            VALUES 1 THROUGH 366.B1
03 User-Day-Of-Week             PIC 9(1).1@
88 Valid-User-Day-Of-Week            VALUES 1 THROUGH 7.@
01  Date-Out                PIC 9(8) VALUE 0.5
01  User-Date-Num           PIC 9(8) VALUE 0.55
01  User-Date-Int           PIC 9(8) VALUE 0.55
01  Jan2K-Int               PIC 9(8) VALUE 0.56
01  User-Y2K-Delta          PIC S9(8) VALUE 0.6.
88 Y2K-Delta-too-low        VALUE 881../
88 Y2K-Delta-too-high       VALUE -365./
01  Feb28-Y2k               PIC 9(8) VALUE 0.55
01  Feb29-Y2k               PIC 9(8) VALUE 0.56
01  Feb29-Delta             PIC S9(8) VALUE 0.6
PROCEDURE DIVISION.
DECLARATIVES.
END DECLARATIVES.
Main-Logic.
INITIALIZE Date-Out, User-Date-Int, Jan2K-Int, User-Y2K-Delta.F
MOVE User-Date TO User-Date-Num.(
SET Date-Out TO User-Date-Num.&5
CALL "intdate" USING Date-Out, User-Date-Int.5
SET Date-Out TO 20000101.!1
CALL "intdate" USING Date-Out, Jan2k-Int.1
SUBTRACT User-Date-Int FROM Jan2k-Int GIVING User-Y2K-Delta.D
IF Y2k-Delta-Too-Low THEN!
SET Test-Failed TO TRUE
DISPLAY "[T-INTDATE] INTDATE says Y2K is " User-Y2k-Delta " days away" UPON SYSERRZ
ELSE
IF NOT Test-Failed THEN SET Test-Passed TO TRUE7
END-IF
IF Y2k-Delta-Too-High THEN"
SET Test-Failed TO TRUE
DISPLAY "[T-INTDATE] INTDATE says Y2K was " User-Y2k-Delta " days ago" UPON SYSERRZ
ELSE
IF NOT Test-Failed THEN SET Test-Passed TO TRUE7
END-IF
SET Date-Out TO 20000228.!1
CALL "intdate" USING Date-Out, Feb28-Y2k.1!
SET Date-Out TO 20000229.!1
CALL "intdate" USING Date-Out, Feb29-Y2k.1
SUBTRACT Feb28-Y2k FROM Feb29-Y2k GIVING Feb29-Delta.=
IF NOT (Feb29-Delta = 1) THEN%
SET Test-Failed TO TRUE
DISPLAY "[T-INTDATE] INTDATE says Feb 29 was " Feb29-Delta " days after Feb 28..." UPON SYSERRf
ELSE
IF NOT Test-Failed THEN SET Test-Passed TO TRUE7
END-IF
GOBACK 0.
<<EOF>>
0TST2000
00001 (Monday)    2 (Tuesday)   3 (Wednesday) 4 (Thursday)  5 (Friday)    6 (Saturday)  7 (Sunday)
00000000
000031059090120151181212243273304334
\&Run Tests100E&xit10151-102-
U>V>SATA
U>V>SG1
U>(6
U>(6
6SG1
U>(l
U>(l
lSG1
DSG6
zSG6
RSG6
vYYYYMMDDToday is: &OK13
SQTQ
S]T]
SiTi
SuTu
DM0~
rR0~
8*Qf
1*Qd
**]f0
#*]d
*if0
*if0
*ib3
P0^2
*]f0
*]b3
P0^2
*Qb3
P0^2
#*]d
101QUIT_MODEYesUSE_MOUSE1513840256Year 2000 Tests201000101
1????0PassFAIL4801060Enter Current Date4098
4097199020501231719902050011231[TESTBED] Something's wrong with the system date![TESTBED] CENTURY-DATE reported: [TESTBED] System Year  != User-Year [TESTBED] System Month  != User-Month [TESTBED] System Day  != User-Day Day must be between 1 and 31
Month must be between 1 and 12
Year must be 4-digits between 1990 and 2010C$FILEINFO DATEfileinfoINTDATET-INTDATEDAYWEEKt-dayweekACCEPT FROM DATEa-dateACCEPT FROM DAYa-dayACCEPT FROM CENTURY-DATEa-cdateACCEPT FROM CENTURY-DAYa-cdayACCEPT FROM DAY-OF-WEEKa-dow4000400[TESTBED]  is a leap year; adding 366[TESTBED] Calculated Day of Year is invalid [TESTBED] System Day of Year != Calculated Day of Year
TST200
TEST-DATA
RETURN-CODE
GET-DATE-WINDOW
MOUSE-INFO
MOUSE-ROW
MOUSE-OFF-SCREEN
MOUSE-COL
LBUTTON-STATUS
LBUTTON-DOWN
MBUTTON-STATUS
MBUTTON-DOWN
RBUTTON-STATUS
RBUTTON-DOWN
MENU-CONFIGURATION
MENU-STYLE
MENU-IS-STATIC
MENU-IS-POPUP
MENU-CHECK-MARK
MENU-SUBMENU-MARK
MENU-COLOR-ATTRIBUTES
MENU-NORMAL-COLOR-ATTRIBUTES
MENU-NORMAL-COLOR
MENU-NORMAL-COLOR-KEY-1
MENU-NORMAL-COLOR-KEY-2
MENU-SELECTED-COLOR-ATTRIBUTES
MENU-SELECTED-COLOR
MENU-SELECTED-COLOR-KEY-1
MENU-SELECTED-COLOR-KEY-2
MENU-DISABLED-COLOR-ATTRIBUTES
MENU-DISABLED-COLOR
MENU-DISABLED-COLOR-KEY-1
MENU-DISABLED-COLOR-KEY-2
MENU-MONO-ATTRIBUTES
MENU-NORMAL-MONO-ATTRIBUTES
MENU-NORMAL-MONO
MENU-NORMAL-MONO-KEY-1
MENU-NORMAL-MONO-KEY-2
MENU-SELECTED-MONO-ATTRIBUTES
MENU-SELECTED-MONO
MENU-SELECTED-MONO-KEY-1
MENU-SELECTED-MONO-KEY-2
MENU-DISABLED-MONO-ATTRIBUTES
MENU-DISABLED-MONO
MENU-DISABLED-MONO-KEY-1
MENU-DISABLED-MONO-KEY-2
MENU-HANDLE
SUB-HANDLE-1
SUB-HANDLE-2
SUB-HANDLE-3
SUB-HANDLE-4
TEXTSIZE-DATA
TEXTSIZE-FONT
TEXTSIZE-WINDOW
TEXTSIZE-SIZE-X
TEXTSIZE-CELLS-X
TEXTSIZE-BASE-X
TEXTSIZE-SIZE-Y
TEXTSIZE-CELLS-Y
TEXTSIZE-BASE-Y
TEXTSIZE-FLAGS
TEXTSIZE-STRIP-SPACES
TERMINAL-ABILITIES
TERMINAL-NAME
HAS-REVERSE
HAS-BLINK
HAS-UNDERLINE
HAS-DUAL-INTENSITY
HAS-132-COLUMN-MODE
HAS-COLOR
HAS-LINE-DRAWING
NUMBER-OF-SCREEN-LINES
NUMBER-OF-SCREEN-COLUMNS
HAS-LOCAL-PRINTER
HAS-VISIBLE-ATTRIBUTES
HAS-GRAPHICAL-INTERFACE
USABLE-SCREEN-HEIGHT
USABLE-SCREEN-WIDTH
PHYSICAL-SCREEN-HEIGHT
PHYSICAL-SCREEN-WIDTH
SYSTEM-INFORMATION
OPERATING-SYSTEM
OS-IS-MSDOS
OS-IS-OS2
OS-IS-VMS
OS-IS-UNIX
OS-IS-AOS
OS-IS-WINDOWS
OS-IS-WIN-NT
OS-IS-WIN-FAMILY
OS-IS-AMOS
USER-ID
STATION-ID
HAS-INDEXED-READ-PREVIOUS
HAS-RELATIVE-READ-PREVIOUS
CAN-TEST-INPUT-STATUS
IS-MULTI-TASKING
RUNTIME-VERSION
VERSION-PRIOR-TO-2-2
RUNTIME-MAJOR-VERSION
RUNTIME-MINOR-VERSION
RUNTIME-RELEASE
IS-PLUGIN
BROWSERINFO-DATA
USER-AGENT-STRING
BROWSER-MAJOR-VERSION
BROWSER-MINOR-VERSION
FILESYSTEM
EVENT-STATUS
EVENT-TYPE
EVENT-WINDOW-HANDLE
EVENT-CONTROL-HANDLE
EVENT-CONTROL-ID
EVENT-DATA-1
EVENT-DATA-2
EVENT-ACTION
SCREEN-CONTROL
ACCEPT-CONTROL
CONTROL-VALUE
CONTROL-HANDLE
CONTROL-ID
EXC-VAL
RUN-TESTS
EXIT-TESTBED
DAY-NAMES
WEEKDAYS
SELECTED-DOW
TESTS
TEST-NAME
RUN-TEST
TEST-RESULT
TEST-PRESENT
TEST-PROGRAM
SYSTEM-DATE
SYSTEM-YEAR
VALID-SYSTEM-YEAR
SYSTEM-MONTH
VALID-SYSTEM-MONTH
SYSTEM-DAY
VALID-SYSTEM-DAY
SYSTEM-DOY
SYSTEM-DAY-OF-YEAR
VALID-SYSTEM-DAY-OF-YEAR
SYSTEM-DAY-OF-WEEK
VALID-SYSTEM-DAY-OF-WEEK
LEAP-YEAR
TMP-DIV
MOD-REM
MONTH-TABLE
DAYS-TO-MONTH-TABLE
DAYS-TO-MONTH
TEST-DATA
TEST-RESULT-CODE
TEST-PASSED
TEST-FAILED
USER-DATE
USER-YEAR
VALID-USER-YEAR
USER-MONTH
VALID-USER-MONTH
USER-DAY
VALID-USER-DAY
USER-DAY-OF-YEAR
VALID-USER-DAY-OF-YEAR
USER-DAY-OF-WEEK
VALID-USER-DAY-OF-WEEK
WEEKDAY-POINTER
TEST-POINTER
MAIN-SCREEN
PROGRAM-CONTROLS
TESTS
TEST-RESULT-LB
GET-DATE-SCREEN
DOW-COMBO
RETURN-CODE
MAIN-LOGIC
RUN-SELECTED-TESTS
GET-USER-DATE
GET-DATE-AFTER-PROC
USER-DAY-AFTER-PROC
USER-MONTH-AFTER-PROC
USER-YEAR-AFTER-PROC
INITIALIZE-MAIN-SCREEN
CALCULATE-USER-DOY
IDENTIFICATION DIVISION. '
PROGRAM-ID. TST2000 IS INITIAL.'
AUTHOR. Chris Adams.
DATE-WRITTEN. 19980707.
* Main program; allows users to launch Y2K tests from convenient GUI.M.
* Copyright (c) 1997 by Acucobol, Inc..B
* $Id: Y2KCHECK.CBL,v 1.2 1998/07/28 22:05:08 cadams Exp $B
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-PC.  
OBJECT-COMPUTER. IBM-PC. 
INPUT-OUTPUT SECTION.
FILE-CONTROL.
DATA DIVISION.
FILE SECTION.
WORKING-STORAGE SECTION. C
77 Get-Date-Window                        HANDLE OF WINDOW.C
COPY "ACUGUI.DEF".
* ACUGUI.DEF - useful definitions for graphical systems.@)
* Last modified: 29-Aug-97 - TDC.)
* Copyright (c) 1992 - 1998 by Acucorp, Inc.  Users of ACUCOBOLGB
* may freely include this file in their COBOL source code.B
* Mouse handling variables":
* Structure and opcodes for W$MOUSE system routine:
78  TEST-MOUSE-PRESENCE                 VALUE 0.88
78  GET-MOUSE-STATUS                    VALUE 1.88
78  GET-MOUSE-SCREEN-STATUS             VALUE 2.88
78  SET-MOUSE-POSITION                  VALUE 3.88
78  SET-MOUSE-SCREEN-POSITION           VALUE 4.88
78  SET-MOUSE-SHAPE                     VALUE 5.88
78  SET-DELAYED-MOUSE-SHAPE             VALUE 6.88
78  GET-MOUSE-SHAPE                     VALUE 7.88
78  CAPTURE-MOUSE                       VALUE 8.88
78  RELEASE-MOUSE                       VALUE 9.89
78  ENABLE-MOUSE                        VALUE 10.99
78  SET-MOUSE-HELP                      VALUE 19.9
01  MOUSE-INFO.
03  MOUSE-ROW                       PIC 9(4) COMP-1.<3
88  MOUSE-OFF-SCREEN            VALUE ZERO.3<
03  MOUSE-COL                       PIC 9(4) COMP-1.<2
03  LBUTTON-STATUS                  PIC 9.20
88  LBUTTON-DOWN                VALUE 1.02
03  MBUTTON-STATUS                  PIC 9.20
88  MBUTTON-DOWN                VALUE 1.02
03  RBUTTON-STATUS                  PIC 9.20
88  RBUTTON-DOWN                VALUE 1.0
78  ARROW-POINTER                       VALUE 1.88
78  BAR-POINTER                         VALUE 2.88
78  CROSS-POINTER                       VALUE 3.88
78  WAIT-POINTER                        VALUE 4.88
78  HELP-POINTER                        VALUE 5.8
* MOUSE-FLAGS settings
78  AUTO-MOUSE-HANDLING                 VALUE 1.88
78  ALLOW-LEFT-DOWN                     VALUE 2.88
78  ALLOW-LEFT-UP                       VALUE 4.88
78  ALLOW-LEFT-DOUBLE                   VALUE 8.89
78  ALLOW-MIDDLE-DOWN                   VALUE 16.99
78  ALLOW-MIDDLE-UP                     VALUE 32.99
78  ALLOW-MIDDLE-DOUBLE                 VALUE 64.9:
78  ALLOW-RIGHT-DOWN                    VALUE 128.::
78  ALLOW-RIGHT-UP                      VALUE 256.::
78  ALLOW-RIGHT-DOUBLE                  VALUE 512.:;
78  ALLOW-MOUSE-MOVE                    VALUE 1024.;;
78  ALWAYS-ARROW-CURSOR                 VALUE 2048.;<
78  ALLOW-ALL-SCREEN-ACTIONS            VALUE 16384.<
* Menu handling variables!
* W$MENU opcodes
78  WMENU-NEW                           VALUE 1.88
78  WMENU-DESTROY                       VALUE 2.88
78  WMENU-ADD                           VALUE 3.88
78  WMENU-CHANGE                        VALUE 4.88
78  WMENU-DELETE                        VALUE 5.88
78  WMENU-CHECK                         VALUE 6.88
78  WMENU-UNCHECK                       VALUE 7.88
78  WMENU-ENABLE                        VALUE 8.88
78  WMENU-DISABLE                       VALUE 9.89
78  WMENU-SHOW                          VALUE 10.99
78  WMENU-GET-MENU                      VALUE 11.99
78  WMENU-INPUT                         VALUE 12.99
78  WMENU-BLOCK                         VALUE 13.99
78  WMENU-UNBLOCK                       VALUE 14.99
78  WMENU-GET-BLOCK                     VALUE 15.99
78  WMENU-SET-BLOCK                     VALUE 16.99
78  WMENU-RELEASE                       VALUE 17.99
78  WMENU-GET-CONFIGURATION             VALUE 18.99
78  WMENU-SET-CONFIGURATION             VALUE 19.99
78  WMENU-REFRESH                       VALUE 20.99
78  WMENU-DESTROY-DELAYED               VALUE 21.99
78  WMENU-GET-DELAYED-FLAG              VALUE 22.99
78  WMENU-SET-DELAYED-FLAG              VALUE 23.99
78  WMENU-NEW-POPUP                     VALUE 26.99
78  WMENU-POPUP                         VALUE 27.9
* W$MENU flags
78  W-UNCHECKED                         VALUE 0.88
78  W-CHECKED                           VALUE 1.88
78  W-ENABLED                           VALUE 0.89
78  W-DISABLED                          VALUE 16.9:
78  W-SEPARATOR                         VALUE 256.:
01  MENU-CONFIGURATION.
03  MENU-STYLE                         PIC 9 COMP-X.<3
88  MENU-IS-STATIC                 VALUE 0.33
88  MENU-IS-POPUP                  VALUE 1.35
03  MENU-CHECK-MARK                    PIC X.55
03  MENU-SUBMENU-MARK                  PIC X.5"
03  MENU-COLOR-ATTRIBUTES.")
05  MENU-NORMAL-COLOR-ATTRIBUTES.)7
07  MENU-NORMAL-COLOR          PIC 9(4) COMP-X.77
07  MENU-NORMAL-COLOR-KEY-1    PIC 9(4) COMP-X.77
07  MENU-NORMAL-COLOR-KEY-2    PIC 9(4) COMP-X.7+
05  MENU-SELECTED-COLOR-ATTRIBUTES.+7
07  MENU-SELECTED-COLOR        PIC 9(4) COMP-X.77
07  MENU-SELECTED-COLOR-KEY-1  PIC 9(4) COMP-X.77
07  MENU-SELECTED-COLOR-KEY-2  PIC 9(4) COMP-X.7+
05  MENU-DISABLED-COLOR-ATTRIBUTES.+7
07  MENU-DISABLED-COLOR        PIC 9(4) COMP-X.77
07  MENU-DISABLED-COLOR-KEY-1  PIC 9(4) COMP-X.77
07  MENU-DISABLED-COLOR-KEY-2  PIC 9(4) COMP-X.7!
03  MENU-MONO-ATTRIBUTES.!(
05  MENU-NORMAL-MONO-ATTRIBUTES.(7
07  MENU-NORMAL-MONO           PIC 9(4) COMP-X.77
07  MENU-NORMAL-MONO-KEY-1     PIC 9(4) COMP-X.77
07  MENU-NORMAL-MONO-KEY-2     PIC 9(4) COMP-X.7*
05  MENU-SELECTED-MONO-ATTRIBUTES.*7
07  MENU-SELECTED-MONO         PIC 9(4) COMP-X.77
07  MENU-SELECTED-MONO-KEY-1   PIC 9(4) COMP-X.77
07  MENU-SELECTED-MONO-KEY-2   PIC 9(4) COMP-X.7*
05  MENU-DISABLED-MONO-ATTRIBUTES.*7
07  MENU-DISABLED-MONO         PIC 9(4) COMP-X.77
07  MENU-DISABLED-MONO-KEY-1   PIC 9(4) COMP-X.77
07  MENU-DISABLED-MONO-KEY-2   PIC 9(4) COMP-X.7
* Variables used by menu code created by GENMENU.9
77  MENU-HANDLE                         PIC S9(9) COMP-4.AA
77  SUB-HANDLE-1                        PIC S9(9) COMP-4.AA
77  SUB-HANDLE-2                        PIC S9(9) COMP-4.AA
77  SUB-HANDLE-3                        PIC S9(9) COMP-4.AA
77  SUB-HANDLE-4                        PIC S9(9) COMP-4.A
* MESSAGE BOX types
78  MB-OK                               VALUE 1.88
78  MB-YES-NO                           VALUE 2.88
78  MB-OK-CANCEL                        VALUE 3.88
78  MB-YES-NO-CANCEL                    VALUE 4.8
* MESSAGE BOX responses (MB-OK is both a type and a response)E
78  MB-YES                              VALUE 1.88
78  MB-NO                               VALUE 2.88
78  MB-CANCEL                           VALUE 3.8
* MESSAGE BOX icons
78  MB-DEFAULT-ICON                     VALUE 1.88
78  MB-WARNING-ICON                     VALUE 2.88
78  MB-ERROR-ICON                       VALUE 3.8
* W$BITMAP opcodes
78  WBITMAP-DISPLAY                     VALUE 1.88
78  WBITMAP-DESTROY                     VALUE 2.88
78  WBITMAP-LOAD                        VALUE 3.8
* W$BITMAP option flags
78  WBITMAP-NO-FILL                     VALUE 1.8
* W$BITMAP error values
78  WBERR-UNSUPPORTED                   VALUE 0.89
78  WBERR-FILE-ERROR                    VALUE -1.99
78  WBERR-NO-MEMORY                     VALUE -2.99
78  WBERR-NOT-BITMAP                    VALUE -3.9
* W$TEXTSIZE library routine$
01  TEXTSIZE-DATA.
03  TEXTSIZE-FONT                   HANDLE OF FONT,;
/VALUE NULL.
03  TEXTSIZE-WINDOW                 HANDLE OF WINDOW<
/VALUE NULL.
03  TEXTSIZE-SIZE-X                 PIC 9(7)V99 COMP-4.??
03  TEXTSIZE-CELLS-X                PIC 9(7)V99 COMP-4.?<
03  TEXTSIZE-BASE-X                 PIC 9(9) COMP-4.<=
03  TEXTSIZE-SIZE-Y                 PIC 99V99 COMP-4.==
03  TEXTSIZE-CELLS-Y                PIC 99V99 COMP-4.=<
03  TEXTSIZE-BASE-Y                 PIC 9(4) COMP-4.<E
03  TEXTSIZE-FLAGS                  PIC X COMP-X, VALUE ZERO.E<
88  TEXTSIZE-STRIP-SPACES       VALUE 1, FALSE ZERO.<
* EVENT-ACTION values
78  EVENT-ACTION-NORMAL                 VALUE ZERO.;8
78  EVENT-ACTION-TERMINATE              VALUE 1.88
78  EVENT-ACTION-CONTINUE               VALUE 2.88
78  EVENT-ACTION-IGNORE                 VALUE 3.8
* Reserved for future use!8
78  EVENT-ACTION-FAIL                   VALUE 4.8
* Standard exception values from the windowing system=
78  W-TIMEOUT                           VALUE 99.99
78  W-CONVERSION-ERROR                  VALUE 98.99
78  W-NO-FIELDS                         VALUE 97.99
78  W-EVENT                             VALUE 96.99
78  W-MESSAGE                           VALUE 95.9
* Command events
78  CMD-CLOSE                           VALUE 1.88
78  CMD-GOTO                            VALUE 3.88
78  CMD-CLICKED                         VALUE 4.88
78  CMD-DBLCLICK                        VALUE 5.88
78  CMD-ACTIVATE                        VALUE 6.88
78  CMD-TABCHANGED                      VALUE 7.88
78  CMD-HELP                            VALUE 8.8
* Notification events
78  NTF-SELCHANGE                       VALUE 4099.;;
78  NTF-CHANGED                         VALUE 4100.;3
* The next 7 apply to paged list-boxes only3;
78  NTF-PL-NEXT                         VALUE 4101.;;
78  NTF-PL-PREV                         VALUE 4102.;;
78  NTF-PL-NEXTPAGE                     VALUE 4103.;;
78  NTF-PL-PREVPAGE                     VALUE 4104.;;
78  NTF-PL-FIRST                        VALUE 4105.;;
78  NTF-PL-LAST                         VALUE 4106.;;
78  NTF-PL-SEARCH                       VALUE 4107.;;
78  NTF-RESIZED                         VALUE 4114.;
* Message-style events
78  MSG-SB-NEXT                         VALUE 16385.<<
78  MSG-SB-PREV                         VALUE 16386.<<
78  MSG-SB-NEXTPAGE                     VALUE 16387.<<
78  MSG-SB-PREVPAGE                     VALUE 16388.<<
78  MSG-SB-THUMB                        VALUE 16389.<<
78  MSG-SB-THUMBTRACK                   VALUE 16390.<<
78  MSG-VALIDATE                        VALUE 16391.<<
78  MSG-BEGIN-ENTRY                     VALUE 16392.<<
78  MSG-FINISH-ENTRY                    VALUE 16393.<<
78  MSG-CANCEL-ENTRY                    VALUE 16394.<<
78  MSG-GOTO-CELL                       VALUE 16395.<<
78  MSG-GOTO-CELL-MOUSE                 VALUE 16396.<<
78  MSG-MENU-INPUT                      VALUE 16397.<<
78  MSG-INIT-MENU                       VALUE 16398.<<
78  MSG-END-MENU                        VALUE 16399.<<
78  MSG-BITMAP-CLICKED                  VALUE 16400.<<
78  MSG-BITMAP-DBLCLICK                 VALUE 16401.<<
78  MSG-HEADING-CLICKED                 VALUE 16402.<<
78  MSG-HEADING-DBLCLICK                VALUE 16403.<<
78  MSG-GOTO-CELL-DRAG                  VALUE 16404.<<
78  MSG-HEADING-DRAGGED                 VALUE 16405.<<
78  MSG-BEGIN-DRAG                      VALUE 16406.<<
78  MSG-END-DRAG                        VALUE 16407.<<
78  MSG-BEGIN-HEADING-DRAG              VALUE 16408.<<
78  MSG-END-HEADING-DRAG                VALUE 16409.<<
78  MSG-COL-WIDTH-CHANGED               VALUE 16410.<
* Entry Field ACTION values#8
78  ACTION-CUT                          VALUE 1.88
78  ACTION-COPY                         VALUE 2.88
78  ACTION-PASTE                        VALUE 3.88
78  ACTION-DELETE                       VALUE 4.88
78  ACTION-UNDO                         VALUE 5.8
* Flags for win$playsound!
78  SND-SYNC                            VALUE 0.88
78  SND-ASYNC                           VALUE 1.88
78  SND-LOOP                            VALUE 8.89
78  SND-NOSTOP                          VALUE 16.9
* Paged list sort-order values&8
78  PL-SORT-DEFAULT                     VALUE 0.88
78  PL-SORT-NONE                        VALUE 1.88
78  PL-SORT-NATIVE                      VALUE 2.88
78  PL-SORT-NATIVE-IGNORE-CASE          VALUE 3.8
* end of acugui.def
COPY "ACUCOBOL.DEF".
* ACUCOBOL.DEF - Some useful ACUCOBOL definitions.:'
* Last modified: 28-Mar-97 TDC.'
* Copyright (c) 1996 - 1998 by Acucorp, Inc.  Users of ACUCOBOLGB
* may freely include this file in their COBOL source code.B
01  TERMINAL-ABILITIES.
03  TERMINAL-NAME                   PIC X(10).62
03  FILLER                          PIC X.22
88  HAS-REVERSE                 VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-BLINK                   VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-UNDERLINE               VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-DUAL-INTENSITY          VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-132-COLUMN-MODE         VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-COLOR                   VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-LINE-DRAWING            VALUE "Y".25
03  NUMBER-OF-SCREEN-LINES          PIC 9(3).55
03  NUMBER-OF-SCREEN-COLUMNS        PIC 9(3).52
03  FILLER                          PIC X.22
88  HAS-LOCAL-PRINTER           VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-VISIBLE-ATTRIBUTES      VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-GRAPHICAL-INTERFACE     VALUE "Y".2<
03  USABLE-SCREEN-HEIGHT            PIC X(2) COMP-X.<<
03  USABLE-SCREEN-WIDTH             PIC X(2) COMP-X.<<
03  PHYSICAL-SCREEN-HEIGHT          PIC X(2) COMP-X.<<
03  PHYSICAL-SCREEN-WIDTH           PIC X(2) COMP-X.<
01  SYSTEM-INFORMATION.
03  OPERATING-SYSTEM                PIC X(10).67
88  OS-IS-MSDOS                 VALUE "MS-DOS".75
88  OS-IS-OS2                   VALUE "OS/2".55
88  OS-IS-VMS                   VALUES "VMS",5
/"VAX/VMS".
88  OS-IS-UNIX                  VALUES "Unix-V",8
/"Unix-4", "UNOS".
88  OS-IS-AOS                   VALUE "AOS/VS".78
88  OS-IS-WINDOWS               VALUE "WINDOWS".87
88  OS-IS-WIN-NT                VALUE "WIN/NT".79
88  OS-IS-WIN-FAMILY            VALUES "WINDOWS",9
6"WIN/NT".
88  OS-IS-AMOS                  VALUE "AMOS".56
03  USER-ID                         PIC X(12).66
03  STATION-ID                      PIC X(12).62
03  FILLER                          PIC X.22
88  HAS-INDEXED-READ-PREVIOUS   VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-RELATIVE-READ-PREVIOUS  VALUE "Y".22
03  FILLER                          PIC X.22
88  CAN-TEST-INPUT-STATUS       VALUE "Y".22
03  FILLER                          PIC X.22
88  IS-MULTI-TASKING            VALUE "Y".2
03  RUNTIME-VERSION.
88  VERSION-PRIOR-TO-2-2        VALUE SPACES.5/
05  RUNTIME-MAJOR-VERSION       PIC 99.//
05  RUNTIME-MINOR-VERSION       PIC 99.//
05  RUNTIME-RELEASE             PIC 99./2
03  FILLER                          PIC X.22
88  IS-PLUGIN                   VALUE "Y".2
01  BROWSERINFO-DATA.
03  USER-AGENT-STRING               PIC X(50).69
03  BROWSER-MAJOR-VERSION           PIC X COMP-X.99
03  BROWSER-MINOR-VERSION           PIC X COMP-X.9
78  BLACK                               VALUE 1.88
78  BLUE                                VALUE 2.88
78  GREEN                               VALUE 3.88
78  CYAN                                VALUE 4.88
78  RED                                 VALUE 5.88
78  MAGENTA                             VALUE 6.88
78  BROWN                               VALUE 7.88
78  WHITE                               VALUE 8.88
78  DARK-GRAY                           VALUE 9.89
78  BRIGHT-BLUE                         VALUE 10.99
78  BRIGHT-GREEN                        VALUE 11.99
78  BRIGHT-CYAN                         VALUE 12.99
78  BRIGHT-RED                          VALUE 13.99
78  BRIGHT-MAGENTA                      VALUE 14.99
78  YELLOW                              VALUE 15.99
78  BRIGHT-WHITE                        VALUE 16.99
78  BCKGRND-BLACK                       VALUE 32.99
78  BCKGRND-BLUE                        VALUE 64.99
78  BCKGRND-GREEN                       VALUE 96.9:
78  BCKGRND-CYAN                        VALUE 128.::
78  BCKGRND-RED                         VALUE 160.::
78  BCKGRND-MAGENTA                     VALUE 192.::
78  BCKGRND-BROWN                       VALUE 224.::
78  BCKGRND-WHITE                       VALUE 256.::
78  BCKGRND-DARK-GRAY                   VALUE 288.::
78  BCKGRND-BRIGHT-BLUE                 VALUE 320.::
78  BCKGRND-BRIGHT-GREEN                VALUE 352.::
78  BCKGRND-BRIGHT-CYAN                 VALUE 384.::
78  BCKGRND-BRIGHT-RED                  VALUE 416.::
78  BCKGRND-BRIGHT-MAGENTA              VALUE 448.::
78  BCKGRND-YELLOW                      VALUE 480.::
78  BCKGRND-BRIGHT-WHITE                VALUE 512.:;
78  COLOR-REVERSE                       VALUE 1024.;;
78  FRGRND-LOW                          VALUE 2048.;;
78  FRGRND-HIGH                         VALUE 4096.;;
78  COLOR-UNDERLINE                     VALUE 8192.;<
78  COLOR-BLINK                         VALUE 16384.<<
78  COLOR-PROTECTED                     VALUE 32768.<<
78  BCKGRND-LOW                         VALUE 65536.<=
78  BCKGRND-HIGH                        VALUE 131072.==
78  WINDOW-BRIGHT-WHITE                 VALUE 131328.=
78  GET-FILE-STATUS                     VALUE 1.88
78  GET-TRANSACTION-STATUS              VALUE 2.8
*  Opcodes for C$FILESYS 
78  START-FILESYSTEM-LIST               VALUE 0.88
78  CONTINUE-FILESYSTEM-LIST            VALUE 1.88
78  CHECK-FOR-FILESYSTEM                VALUE 2.88
78  NUMBER-OF-FILESYSTEMS               VALUE 3.8
77  FILESYSTEM                          PIC X(5).9
* end of acucobol.def
COPY "CRTVARS.DEF".
* CRTVARS.DEF - definitions of commonly needed screen handling variablesP(
* Date written: 27-Aug-96 - TDC.(
* Copyright (c) 1996 - 1998 by Acucorp, Inc.  Users of ACUCOBOLGB
* may freely include this file in their COBOL source code.B
01  EVENT-STATUS
IS SPECIAL-NAMES EVENT STATUS.&<
03  EVENT-TYPE                      PIC X(4) COMP-X.<=
03  EVENT-WINDOW-HANDLE             HANDLE OF WINDOW.=3
03  EVENT-CONTROL-HANDLE            HANDLE.3:
03  EVENT-CONTROL-ID                PIC XX COMP-X.:9
03  EVENT-DATA-1                    SIGNED-SHORT.98
03  EVENT-DATA-2                    SIGNED-LONG.89
03  EVENT-ACTION                    PIC X COMP-X.9
01  SCREEN-CONTROL
IS SPECIAL-NAMES SCREEN CONTROL.(2
03  ACCEPT-CONTROL                  PIC 9.24
03  CONTROL-VALUE                   PIC 999.43
03  CONTROL-HANDLE                  HANDLE.3:
03  CONTROL-ID                      PIC XX COMP-X.:
* End of CRTVARS.DEF
01 exc-val IS SPECIAL-NAMES  CRT STATUS   PIC 9(4)  VALUE   0.FD
88 Run-tests                                      VALUE 100.DD
88 Exit-testbed                                   VALUE 101.D
01 Day-Names.
03 PIC X(14) VALUE "1 (Monday)".()
03 PIC X(14) VALUE "2 (Tuesday)".)+
03 PIC X(14) VALUE "3 (Wednesday)".+*
03 PIC X(14) VALUE "4 (Thursday)".*(
03 PIC X(14) VALUE "5 (Friday)".(*
03 PIC X(14) VALUE "6 (Saturday)".*(
03 PIC X(14) VALUE "7 (Sunday)".(
01 Weekdays
REDEFINES Day-Names,
OCCURS 7 TIMES INDEXED BY Weekday-Pointer     PIC X(14).@
01 Selected-DOW                                   PIC X(14) VALUE SPACES.Q
78 Number-Of-Tests                                        VALUE 15.K
01 Tests OCCURS Number-Of-Tests TIMES INDEXED BY Test-Pointer.FO
03 Test-Name                                    PIC X(32) VALUE SPACES.OI
03 Run-Test                                     PIC 9(1) VALUE 0.IO
03 Test-Result                                  PIC X(8)  VALUE SPACES.OI
03 Test-Present                                 PIC 9(1) VALUE 0.IO
03 Test-Program                                 PIC X(12) VALUE SPACES.O
01 System-Date.          | ISO8601*9
03 System-Year                  PIC 9(4) VALUE 0.9F
88 Valid-System-Year                 VALUES 1990 THROUGH 2050.F9
03 System-Month                 PIC 9(2) VALUE 0.9A
88 Valid-System-Month                VALUES 1 THROUGH 12.A9
03 System-Day                   PIC 9(2) VALUE 0.9A
88 Valid-System-Day                  VALUES 1 THROUGH 31.A
03 System-DOY.
05 FILLER                     PIC 9(2).//
05 System-Day-Of-Year         PIC 9(3)./B
88 Valid-System-Day-Of-Year          VALUES 1 THROUGH 366.B1
03 System-Day-Of-Week           PIC 9(1).1@
88 Valid-System-Day-Of-Week          VALUES 1 THROUGH 7.@
01 Leap-Year                      PIC 9(1) VALUE 0.;0
01 TMP-DIV                        PIC 9.02
01 MOD-REM                        PIC 999.2
01  Month-Table.
03  PIC 999 VALUE ZERO.
03  PIC 999 VALUE 31.
03  PIC 999 VALUE 59.
03  PIC 999 VALUE 90.
03  PIC 999 VALUE 120.
03  PIC 999 VALUE 151.
03  PIC 999 VALUE 181.
03  PIC 999 VALUE 212.
03  PIC 999 VALUE 243.
03  PIC 999 VALUE 273.
03  PIC 999 VALUE 304.
03  PIC 999 VALUE 334.
01  Days-To-Month-Table REDEFINES Month-Table.6
03  Days-To-Month
OCCURS 12 TIMES             PIC 999.,
COPY "TESTSUM.DEF".
* Data structure for passing info between test program and manager.K
01 Test-Data EXTERNAL.
03 Test-Result-Code             PIC 9(1).10
88 Test-Passed                  VALUE 1.00
88 Test-Failed                  VALUE 2.0
03 User-Date.          | ISO8601(/
05 User-Year                  PIC 9(4)./D
88 Valid-User-Year                 VALUES 1990 THROUGH 2050.D/
05 User-Month                 PIC 9(2)./?
88 Valid-User-Month                VALUES 1 THROUGH 12.?/
05 User-Day                   PIC 9(2)./?
88 Valid-User-Day                  VALUES 1 THROUGH 31.?
03 User-Day-Of-Year             PIC 9(3).1B
88 Valid-User-Day-Of-Year            VALUES 1 THROUGH 366.B1
03 User-Day-Of-Week             PIC 9(1).1@
88 Valid-User-Day-Of-Week            VALUES 1 THROUGH 7.@
SCREEN SECTION.
01 Main-Screen.
03 Program-Controls.
05 FRAME |TITLE "Date Tests",%
LINE 1.5 COL 1.5,
LINES 25 CELLS SIZE 80 CELLS,%
RAISED VERY-HEAVY.
05 PUSH-BUTTON TITLE "&Run Tests",*
LINE 2.5 COL 12,
LINES 2 CELLS SIZE 10 CELLS,$!
OK-BUTTON DEFAULT-BUTTON,!%
SELF-ACT EXCEPTION-VALUE 100.%%
05 PUSH-BUTTON TITLE "E&xit",%
COL PLUS 2
LINES 2 CELLS SIZE 10 CELLS,$
CANCEL-BUTTON,
SELF-ACT EXCEPTION-VALUE 101.%
05 BAR
LINE PLUS 2.5 COL 2,
SIZE 38.5 CELLS WIDTH = 5,"
COLOR Green,
SHADING = (-1, 1, 0, 0, -2).$.
03 Tests OCCURS Number-of-Tests TIMES..4
05 CHECK-BOX TITLE Test-Name VALUE Run-Test,4
LINE PLUS 1.3 COL 3,
LINES 1.5 CELLS SIZE 32 CELLS,&
SELF-ACT
ENABLED Test-Present,
VISIBLE Test-Present.
05 Test-Result-LB LABEL VALUE Test-Result,2
ENABLED Test-Present
VISIBLE Test-Present.
01 Get-Date-Screen AFTER PROCEDURE IS Get-Date-After-Proc.B
03 LABEL TITLE "YYYY"
LINE 1 COL 3.
03 ENTRY-FIELD USING User-Year,'
LINE 2.5 COL 3,
3-D NUMERIC AUTO,
AFTER PROCEDURE IS User-Year-After-Proc.0
03 LABEL TITLE "MM"
LINE 1 COL 10.
03 ENTRY-FIELD USING User-Month,(
LINE 2.5 COL 10
3-D NUMERIC AUTO,
AFTER PROCEDURE IS User-Month-After-Proc.1
03 LABEL TITLE "DD"
LINE 1 COL 15.
03 ENTRY-FIELD USING User-Day,&
LINE 2.5 COL 15,
3-D NUMERIC AUTO,
AFTER PROCEDURE IS User-Day-After-Proc./
03 LABEL TITLE "Today is: "#
LINE 5 COL 3.
03 DOW-Combo Combo-box DROP-LIST USING Selected-DOW,<
COL PLUS 2,
3-D AFTER PROCEDURE IS Get-Date-After-Proc.3
03 PUSH-BUTTON "&OK",
SELF-ACT EXCEPTION-VALUE 13,$
LINE 7 COL 7.5
SIZE 10.
PROCEDURE DIVISION.
DECLARATIVES.
END DECLARATIVES.
Main-Logic.
SET ENVIRONMENT "QUIT_MODE" TO "101".--
SET ENVIRONMENT "USE_MOUSE" TO "Yes".-
DISPLAY INITIAL WINDOW,
LINES 8 + Number-Of-Tests * 1.3 SIZE 40,0>
COLOR black + bckgrnd-white, BACKGROUND-LOW USER-GRAY,> 
TITLE "Year 2000 Tests", $
WITH NO WRAP WITH NO SCROLL,$
ERASE SCREEN,
WITH SYSTEM MENU.
PERFORM Initialize-Main-Screen.'
PERFORM UNTIL 1=0
DISPLAY Main-Screen
ACCEPT Main-Screen
ON EXCEPTION
EVALUATE TRUE
WHEN Run-Tests
PERFORM Run-Selected-Tests"
WHEN Exit-Testbed
EXIT PERFORM
END-EVALUATE
END-ACCEPT
END-PERFORM.
GOBACK 0.
Run-Selected-Tests.
INITIALIZE Test-Pointer. 
PERFORM Get-User-Date.
PERFORM VARYING Test-Pointer FROM 1 BY 1 UNTIL Test-Pointer > Number-Of-TestsU
DISPLAY Main-Screen
IF (Test-Present(Test-Pointer) = 1) THEN0,
INITIALIZE Test-Result(Test-Pointer),,
IF (Run-Test(Test-Pointer) = 1) THEN,#
INITIALIZE Test-Result-Code#U
\D        DISPLAY "[TESTBED] Calling " Test-Program(Test-Pointer) UPON SYSERRU'
CALL Test-Program(Test-Pointer)'
ON EXCEPTION
\D            DISPLAY "[TESTBED] Exception on CALL of " Test-Program(Test-Pointer) UPON SYSERRf0
MOVE "????" TO Test-Result(Test-Pointer)0,
MOVE 0 TO Test-Present(Test-Pointer),(
MOVE 0 TO Run-Test(Test-Pointer)(
NOT ON EXCEPTION
\D            DISPLAY "[TESTBED] CALL of " Test-Program(Test-Pointer) " successful" UPON SYSERRg
IF Test-Passed THEN
MOVE "Pass" TO Test-Result(Test-Pointer)08
MODIFY Test-Result-LB(Test-Pointer), COLOR Black8
ELSE
MOVE "FAIL" TO Test-Result(Test-Pointer)0N
MODIFY Test-Result-LB(Test-Pointer), COLOR Bright-Red + BckGrnd-YellowN
END-IF
END-CALL
END-IF
END-IF
END-PERFORM.
Get-User-Date.
INITIALIZE System-Date, User-Date.*
DISPLAY FLOATING WINDOW
HANDLE IN Get-Date-Window!
LINES 10 SIZE 60,
COLOR black + bckgrnd-white, BACKGROUND-LOW USER-GRAY,>#
TITLE "Enter Current Date",#$
WITH NO WRAP WITH NO SCROLL,$
BOXED
ERASE SCREEN.
DISPLAY Get-Date-Screen. 
ACCEPT User-Date FROM CENTURY-DATE.+1
ACCEPT User-Day-Of-Week FROM DAY-OF-WEEK.1
MODIFY DOW-Combo, Reset-List = 1.)M
PERFORM VARYING Weekday-Pointer FROM 1 BY 1 UNTIL Weekday-Pointer > 7MA
MODIFY DOW-Combo, Item-To-Add = Weekdays(Weekday-Pointer)A
END-PERFORM.
MOVE Weekdays(User-Day-Of-Week) TO Selected-DOW.8
PERFORM WITH TEST AFTER UNTIL (Valid-User-Year AND Valid-User-Month AND Valid-User-Day AND Valid-User-Day-Of-Week)z
DISPLAY Get-Date-Screen
ACCEPT Get-Date-Screen
END-PERFORM
DESTROY Get-Date-Window. 
ACCEPT System-Date FROM CENTURY-DATE.-
IF NOT (Valid-System-Year AND Valid-System-Month AND Valid-System-Day) THENSO
DISPLAY "[TESTBED] Something's wrong with the system date!" UPON SYSERROK
DISPLAY "[TESTBED] CENTURY-DATE reported: " System-Date UPON SYSERRK
END-IF.
IF NOT (System-Year = User-Year) THEN-[
DISPLAY "[TESTBED] System Year " System-Year " != User-Year " User-Year UPON SYSERR[
END-IF.
IF NOT (System-Month = User-Month) THEN/_
DISPLAY "[TESTBED] System Month " System-Month " != User-Month " User-Month UPON SYSERR_
END-IF.
IF NOT (System-Day = User-Day) THEN+W
DISPLAY "[TESTBED] System Day " System-Day " != User-Day " User-Day UPON SYSERRW
END-IF.
PERFORM Calculate-User-DOY.#
Get-Date-After-Proc.
PERFORM User-Year-After-Proc.%&
PERFORM User-Month-After-Proc.&$
PERFORM User-Day-After-Proc.$
User-Day-After-Proc.
IF (NOT Valid-User-Day) OR (User-Day = 0) THEN6I
DISPLAY "Day must be between 1 and 31" AT LINE 10 COL 1 WITH BEEPI
SET Accept-Control TO 1
SET Control-Id TO 3
ELSE
DISPLAY OMITTED AT LINE 10 COL 1 ERASE TO END OF LINE=
END-IF.
User-Month-After-Proc.
IF NOT Valid-User-Month OR (User-Month = 0) THEN8K
DISPLAY "Month must be between 1 and 12" AT LINE 10 COL 1 WITH BEEPK
SET Accept-Control TO 1
SET Control-Id TO 2
ELSE
DISPLAY OMITTED AT LINE 10 COL 1 ERASE TO END OF LINE=
END-IF.
User-Year-After-Proc.
IF NOT Valid-User-Year OR (User-Year = 0)THEN5X
DISPLAY "Year must be 4-digits between 1990 and 2010" AT LINE 10 COL 1 WITH BEEPX
SET Accept-Control TO 1
SET Control-Id TO 1
ELSE
DISPLAY OMITTED AT LINE 10 COL 1 ERASE TO END OF LINE=
END-IF.
Initialize-Main-Screen.
SET Test-Pointer TO 1.
MOVE "C$FILEINFO DATE"  TO Test-Name(Test-Pointer).;6
MOVE "fileinfo" TO Test-Program(Test-Pointer).6
ADD 1 TO Test-Pointer.
MOVE "INTDATE" TO Test-Name(Test-Pointer).27
MOVE "T-INTDATE" TO Test-Program(Test-Pointer).7
ADD 1 TO Test-Pointer.
MOVE "DAYWEEK" TO Test-Name(Test-Pointer).27
MOVE "t-dayweek" TO Test-Program(Test-Pointer).7
ADD 1 TO Test-Pointer.
MOVE "ACCEPT FROM DATE" TO Test-Name(Test-Pointer).;4
MOVE "a-date" TO Test-Program(Test-Pointer).4
ADD 1 TO Test-Pointer.
MOVE "ACCEPT FROM DAY" TO Test-Name(Test-Pointer).:3
MOVE "a-day" TO Test-Program(Test-Pointer).3
ADD 1 TO Test-Pointer.
MOVE "ACCEPT FROM CENTURY-DATE" TO Test-Name(Test-Pointer).C5
MOVE "a-cdate" TO Test-Program(Test-Pointer).5
ADD 1 TO Test-Pointer.
MOVE "ACCEPT FROM CENTURY-DAY" TO Test-Name(Test-Pointer).B4
MOVE "a-cday" TO Test-Program(Test-Pointer).4
ADD 1 TO Test-Pointer.
MOVE "ACCEPT FROM DAY-OF-WEEK" TO Test-Name(Test-Pointer).B3
MOVE "a-dow" TO Test-Program(Test-Pointer).3
PERFORM VARYING Test-Pointer FROM 1 BY 1 UNTIL Test-Pointer > Number-Of-TestsU;
IF Test-Program(Test-Pointer) NOT EQUAL SPACES THEN;,
MOVE 1 TO Test-Present(Test-Pointer),(
MOVE 1 TO Run-Test(Test-Pointer)(
ELSE
INITIALIZE Test-Present(Test-Pointer)-)
INITIALIZE Run-Test(Test-Pointer))
END-IF
END-PERFORM.
Calculate-User-DOY.
INITIALIZE User-Day-Of-Year.$)
SET User-Day-Of-Year TO User-Day.)
SET Leap-Year TO 0.
DIVIDE User-Year BY 4 GIVING Tmp-Div REMAINDER Mod-Rem>
IF Mod-Rem = 0 THEN
MOVE 1 TO Leap-Year
INITIALIZE Mod-Rem
DIVIDE User-Year BY 100 GIVING Tmp-Div REMAINDER Mod-Rem@
IF Mod-Rem = 0 THEN
MOVE 0 TO Leap-Year
INITIALIZE Mod-Rem
DIVIDE User-Year BY 400 GIVING Tmp-Div REMAINDER Mod-Rem@
IF Mod-Rem = 0 THEN
MOVE 1 TO Leap-Year
END-IF
END-IF
END-IF.
ADD Days-To-Month(User-Month) TO User-Day-Of-Year.:
IF (Leap-Year > 0) AND (User-Month > 2) THEN4)
ADD Leap-Year TO User-Day-Of-Year)W
DISPLAY "[TESTBED] " User-Year " is a leap year; adding " Leap-Year UPON SYSERRW
END-IF.
IF NOT Valid-User-Day-Of-Year THEN*[
DISPLAY "[TESTBED] Calculated Day of Year is invalid " User-Day-Of-Year UPON SYSERR[
END-IF.
ACCEPT System-DOY FROM DAY.#
IF NOT User-Day-Of-Year = System-Day-Of-Year THEN9T
DISPLAY "[TESTBED] System Day of Year != Calculated Day of Year" UPON SYSERRT
END-IF.
<<EOF>>
0Y2KCHECK
00001 (Monday)    2 (Tuesday)   3 (Wednesday) 4 (Thursday)  5 (Friday)    6 (Saturday)  7 (Sunday)
00000000
000031059090120151181212243273304334
\&Run Tests100E&xit10151-102-
U>V>SATA
U>V>SG1
U>(6
U>(6
6SG1
U>(l
U>(l
lSG1
DSG6
zSG6
RSG6
vYYYYMMDDToday is: &OK13
SQTQ
S]T]
SiTi
SuTu
DM0~
rR0~
8*Qf
1*Qd
**]f0
#*]d
*if0
*if0
*ib3
P0^2
*]f0
*]b3
P0^2
*Qb3
P0^2
#*]d
101QUIT_MODEYesUSE_MOUSE1513840256Year 2000 Tests201000101
1????0PassFAIL4801060Enter Current Date4098
4097199020501231719902050011231[TESTBED] Something's wrong with the system date![TESTBED] CENTURY-DATE reported: [TESTBED] System Year  != User-Year [TESTBED] System Month  != User-Month [TESTBED] System Day  != User-Day Day must be between 1 and 31
Month must be between 1 and 12
Year must be 4-digits between 1990 and 2010C$FILEINFO DATEfileinfoINTDATET-INTDATEDAYWEEKt-dayweekACCEPT FROM DATEa-dateACCEPT FROM DAYa-dayACCEPT FROM CENTURY-DATEa-cdateACCEPT FROM CENTURY-DAYa-cdayACCEPT FROM DAY-OF-WEEKa-dow4000400[TESTBED]  is a leap year; adding 366[TESTBED] Calculated Day of Year is invalid [TESTBED] System Day of Year != Calculated Day of Year
Y2KCHE
TEST-DATA
RETURN-CODE
GET-DATE-WINDOW
MOUSE-INFO
MOUSE-ROW
MOUSE-OFF-SCREEN
MOUSE-COL
LBUTTON-STATUS
LBUTTON-DOWN
MBUTTON-STATUS
MBUTTON-DOWN
RBUTTON-STATUS
RBUTTON-DOWN
MENU-CONFIGURATION
MENU-STYLE
MENU-IS-STATIC
MENU-IS-POPUP
MENU-CHECK-MARK
MENU-SUBMENU-MARK
MENU-COLOR-ATTRIBUTES
MENU-NORMAL-COLOR-ATTRIBUTES
MENU-NORMAL-COLOR
MENU-NORMAL-COLOR-KEY-1
MENU-NORMAL-COLOR-KEY-2
MENU-SELECTED-COLOR-ATTRIBUTES
MENU-SELECTED-COLOR
MENU-SELECTED-COLOR-KEY-1
MENU-SELECTED-COLOR-KEY-2
MENU-DISABLED-COLOR-ATTRIBUTES
MENU-DISABLED-COLOR
MENU-DISABLED-COLOR-KEY-1
MENU-DISABLED-COLOR-KEY-2
MENU-MONO-ATTRIBUTES
MENU-NORMAL-MONO-ATTRIBUTES
MENU-NORMAL-MONO
MENU-NORMAL-MONO-KEY-1
MENU-NORMAL-MONO-KEY-2
MENU-SELECTED-MONO-ATTRIBUTES
MENU-SELECTED-MONO
MENU-SELECTED-MONO-KEY-1
MENU-SELECTED-MONO-KEY-2
MENU-DISABLED-MONO-ATTRIBUTES
MENU-DISABLED-MONO
MENU-DISABLED-MONO-KEY-1
MENU-DISABLED-MONO-KEY-2
MENU-HANDLE
SUB-HANDLE-1
SUB-HANDLE-2
SUB-HANDLE-3
SUB-HANDLE-4
TEXTSIZE-DATA
TEXTSIZE-FONT
TEXTSIZE-WINDOW
TEXTSIZE-SIZE-X
TEXTSIZE-CELLS-X
TEXTSIZE-BASE-X
TEXTSIZE-SIZE-Y
TEXTSIZE-CELLS-Y
TEXTSIZE-BASE-Y
TEXTSIZE-FLAGS
TEXTSIZE-STRIP-SPACES
TERMINAL-ABILITIES
TERMINAL-NAME
HAS-REVERSE
HAS-BLINK
HAS-UNDERLINE
HAS-DUAL-INTENSITY
HAS-132-COLUMN-MODE
HAS-COLOR
HAS-LINE-DRAWING
NUMBER-OF-SCREEN-LINES
NUMBER-OF-SCREEN-COLUMNS
HAS-LOCAL-PRINTER
HAS-VISIBLE-ATTRIBUTES
HAS-GRAPHICAL-INTERFACE
USABLE-SCREEN-HEIGHT
USABLE-SCREEN-WIDTH
PHYSICAL-SCREEN-HEIGHT
PHYSICAL-SCREEN-WIDTH
SYSTEM-INFORMATION
OPERATING-SYSTEM
OS-IS-MSDOS
OS-IS-OS2
OS-IS-VMS
OS-IS-UNIX
OS-IS-AOS
OS-IS-WINDOWS
OS-IS-WIN-NT
OS-IS-WIN-FAMILY
OS-IS-AMOS
USER-ID
STATION-ID
HAS-INDEXED-READ-PREVIOUS
HAS-RELATIVE-READ-PREVIOUS
CAN-TEST-INPUT-STATUS
IS-MULTI-TASKING
RUNTIME-VERSION
VERSION-PRIOR-TO-2-2
RUNTIME-MAJOR-VERSION
RUNTIME-MINOR-VERSION
RUNTIME-RELEASE
IS-PLUGIN
BROWSERINFO-DATA
USER-AGENT-STRING
BROWSER-MAJOR-VERSION
BROWSER-MINOR-VERSION
FILESYSTEM
EVENT-STATUS
EVENT-TYPE
EVENT-WINDOW-HANDLE
EVENT-CONTROL-HANDLE
EVENT-CONTROL-ID
EVENT-DATA-1
EVENT-DATA-2
EVENT-ACTION
SCREEN-CONTROL
ACCEPT-CONTROL
CONTROL-VALUE
CONTROL-HANDLE
CONTROL-ID
EXC-VAL
RUN-TESTS
EXIT-TESTBED
DAY-NAMES
WEEKDAYS
SELECTED-DOW
TESTS
TEST-NAME
RUN-TEST
TEST-RESULT
TEST-PRESENT
TEST-PROGRAM
SYSTEM-DATE
SYSTEM-YEAR
VALID-SYSTEM-YEAR
SYSTEM-MONTH
VALID-SYSTEM-MONTH
SYSTEM-DAY
VALID-SYSTEM-DAY
SYSTEM-DOY
SYSTEM-DAY-OF-YEAR
VALID-SYSTEM-DAY-OF-YEAR
SYSTEM-DAY-OF-WEEK
VALID-SYSTEM-DAY-OF-WEEK
LEAP-YEAR
TMP-DIV
MOD-REM
MONTH-TABLE
DAYS-TO-MONTH-TABLE
DAYS-TO-MONTH
TEST-DATA
TEST-RESULT-CODE
TEST-PASSED
TEST-FAILED
USER-DATE
USER-YEAR
VALID-USER-YEAR
USER-MONTH
VALID-USER-MONTH
USER-DAY
VALID-USER-DAY
USER-DAY-OF-YEAR
VALID-USER-DAY-OF-YEAR
USER-DAY-OF-WEEK
VALID-USER-DAY-OF-WEEK
WEEKDAY-POINTER
TEST-POINTER
MAIN-SCREEN
PROGRAM-CONTROLS
TESTS
TEST-RESULT-LB
GET-DATE-SCREEN
DOW-COMBO
RETURN-CODE
MAIN-LOGIC
RUN-SELECTED-TESTS
GET-USER-DATE
GET-DATE-AFTER-PROC
USER-DAY-AFTER-PROC
USER-MONTH-AFTER-PROC
USER-YEAR-AFTER-PROC
INITIALIZE-MAIN-SCREEN
CALCULATE-USER-DOY
IDENTIFICATION DIVISION. (
PROGRAM-ID. Y2KCheck IS INITIAL.(
AUTHOR. Chris Adams.
DATE-WRITTEN. 19980707.
* Main program; allows users to launch Y2K tests from convenient GUI.M.
* Copyright (c) 1997 by Acucobol, Inc..B
* $Id: Y2KCHECK.CBL,v 1.2 1998/07/28 22:05:08 cadams Exp $B
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-PC.  
OBJECT-COMPUTER. IBM-PC. 
INPUT-OUTPUT SECTION.
FILE-CONTROL.
DATA DIVISION.
FILE SECTION.
WORKING-STORAGE SECTION. C
77 Get-Date-Window                        HANDLE OF WINDOW.C
COPY "ACUGUI.DEF".
* ACUGUI.DEF - useful definitions for graphical systems.@)
* Last modified: 29-Aug-97 - TDC.)
* Copyright (c) 1992 - 1998 by Acucorp, Inc.  Users of ACUCOBOLGB
* may freely include this file in their COBOL source code.B
* Mouse handling variables":
* Structure and opcodes for W$MOUSE system routine:
78  TEST-MOUSE-PRESENCE                 VALUE 0.88
78  GET-MOUSE-STATUS                    VALUE 1.88
78  GET-MOUSE-SCREEN-STATUS             VALUE 2.88
78  SET-MOUSE-POSITION                  VALUE 3.88
78  SET-MOUSE-SCREEN-POSITION           VALUE 4.88
78  SET-MOUSE-SHAPE                     VALUE 5.88
78  SET-DELAYED-MOUSE-SHAPE             VALUE 6.88
78  GET-MOUSE-SHAPE                     VALUE 7.88
78  CAPTURE-MOUSE                       VALUE 8.88
78  RELEASE-MOUSE                       VALUE 9.89
78  ENABLE-MOUSE                        VALUE 10.99
78  SET-MOUSE-HELP                      VALUE 19.9
01  MOUSE-INFO.
03  MOUSE-ROW                       PIC 9(4) COMP-1.<3
88  MOUSE-OFF-SCREEN            VALUE ZERO.3<
03  MOUSE-COL                       PIC 9(4) COMP-1.<2
03  LBUTTON-STATUS                  PIC 9.20
88  LBUTTON-DOWN                VALUE 1.02
03  MBUTTON-STATUS                  PIC 9.20
88  MBUTTON-DOWN                VALUE 1.02
03  RBUTTON-STATUS                  PIC 9.20
88  RBUTTON-DOWN                VALUE 1.0
78  ARROW-POINTER                       VALUE 1.88
78  BAR-POINTER                         VALUE 2.88
78  CROSS-POINTER                       VALUE 3.88
78  WAIT-POINTER                        VALUE 4.88
78  HELP-POINTER                        VALUE 5.8
* MOUSE-FLAGS settings
78  AUTO-MOUSE-HANDLING                 VALUE 1.88
78  ALLOW-LEFT-DOWN                     VALUE 2.88
78  ALLOW-LEFT-UP                       VALUE 4.88
78  ALLOW-LEFT-DOUBLE                   VALUE 8.89
78  ALLOW-MIDDLE-DOWN                   VALUE 16.99
78  ALLOW-MIDDLE-UP                     VALUE 32.99
78  ALLOW-MIDDLE-DOUBLE                 VALUE 64.9:
78  ALLOW-RIGHT-DOWN                    VALUE 128.::
78  ALLOW-RIGHT-UP                      VALUE 256.::
78  ALLOW-RIGHT-DOUBLE                  VALUE 512.:;
78  ALLOW-MOUSE-MOVE                    VALUE 1024.;;
78  ALWAYS-ARROW-CURSOR                 VALUE 2048.;<
78  ALLOW-ALL-SCREEN-ACTIONS            VALUE 16384.<
* Menu handling variables!
* W$MENU opcodes
78  WMENU-NEW                           VALUE 1.88
78  WMENU-DESTROY                       VALUE 2.88
78  WMENU-ADD                           VALUE 3.88
78  WMENU-CHANGE                        VALUE 4.88
78  WMENU-DELETE                        VALUE 5.88
78  WMENU-CHECK                         VALUE 6.88
78  WMENU-UNCHECK                       VALUE 7.88
78  WMENU-ENABLE                        VALUE 8.88
78  WMENU-DISABLE                       VALUE 9.89
78  WMENU-SHOW                          VALUE 10.99
78  WMENU-GET-MENU                      VALUE 11.99
78  WMENU-INPUT                         VALUE 12.99
78  WMENU-BLOCK                         VALUE 13.99
78  WMENU-UNBLOCK                       VALUE 14.99
78  WMENU-GET-BLOCK                     VALUE 15.99
78  WMENU-SET-BLOCK                     VALUE 16.99
78  WMENU-RELEASE                       VALUE 17.99
78  WMENU-GET-CONFIGURATION             VALUE 18.99
78  WMENU-SET-CONFIGURATION             VALUE 19.99
78  WMENU-REFRESH                       VALUE 20.99
78  WMENU-DESTROY-DELAYED               VALUE 21.99
78  WMENU-GET-DELAYED-FLAG              VALUE 22.99
78  WMENU-SET-DELAYED-FLAG              VALUE 23.99
78  WMENU-NEW-POPUP                     VALUE 26.99
78  WMENU-POPUP                         VALUE 27.9
* W$MENU flags
78  W-UNCHECKED                         VALUE 0.88
78  W-CHECKED                           VALUE 1.88
78  W-ENABLED                           VALUE 0.89
78  W-DISABLED                          VALUE 16.9:
78  W-SEPARATOR                         VALUE 256.:
01  MENU-CONFIGURATION.
03  MENU-STYLE                         PIC 9 COMP-X.<3
88  MENU-IS-STATIC                 VALUE 0.33
88  MENU-IS-POPUP                  VALUE 1.35
03  MENU-CHECK-MARK                    PIC X.55
03  MENU-SUBMENU-MARK                  PIC X.5"
03  MENU-COLOR-ATTRIBUTES.")
05  MENU-NORMAL-COLOR-ATTRIBUTES.)7
07  MENU-NORMAL-COLOR          PIC 9(4) COMP-X.77
07  MENU-NORMAL-COLOR-KEY-1    PIC 9(4) COMP-X.77
07  MENU-NORMAL-COLOR-KEY-2    PIC 9(4) COMP-X.7+
05  MENU-SELECTED-COLOR-ATTRIBUTES.+7
07  MENU-SELECTED-COLOR        PIC 9(4) COMP-X.77
07  MENU-SELECTED-COLOR-KEY-1  PIC 9(4) COMP-X.77
07  MENU-SELECTED-COLOR-KEY-2  PIC 9(4) COMP-X.7+
05  MENU-DISABLED-COLOR-ATTRIBUTES.+7
07  MENU-DISABLED-COLOR        PIC 9(4) COMP-X.77
07  MENU-DISABLED-COLOR-KEY-1  PIC 9(4) COMP-X.77
07  MENU-DISABLED-COLOR-KEY-2  PIC 9(4) COMP-X.7!
03  MENU-MONO-ATTRIBUTES.!(
05  MENU-NORMAL-MONO-ATTRIBUTES.(7
07  MENU-NORMAL-MONO           PIC 9(4) COMP-X.77
07  MENU-NORMAL-MONO-KEY-1     PIC 9(4) COMP-X.77
07  MENU-NORMAL-MONO-KEY-2     PIC 9(4) COMP-X.7*
05  MENU-SELECTED-MONO-ATTRIBUTES.*7
07  MENU-SELECTED-MONO         PIC 9(4) COMP-X.77
07  MENU-SELECTED-MONO-KEY-1   PIC 9(4) COMP-X.77
07  MENU-SELECTED-MONO-KEY-2   PIC 9(4) COMP-X.7*
05  MENU-DISABLED-MONO-ATTRIBUTES.*7
07  MENU-DISABLED-MONO         PIC 9(4) COMP-X.77
07  MENU-DISABLED-MONO-KEY-1   PIC 9(4) COMP-X.77
07  MENU-DISABLED-MONO-KEY-2   PIC 9(4) COMP-X.7
* Variables used by menu code created by GENMENU.9
77  MENU-HANDLE                         PIC S9(9) COMP-4.AA
77  SUB-HANDLE-1                        PIC S9(9) COMP-4.AA
77  SUB-HANDLE-2                        PIC S9(9) COMP-4.AA
77  SUB-HANDLE-3                        PIC S9(9) COMP-4.AA
77  SUB-HANDLE-4                        PIC S9(9) COMP-4.A
* MESSAGE BOX types
78  MB-OK                               VALUE 1.88
78  MB-YES-NO                           VALUE 2.88
78  MB-OK-CANCEL                        VALUE 3.88
78  MB-YES-NO-CANCEL                    VALUE 4.8
* MESSAGE BOX responses (MB-OK is both a type and a response)E
78  MB-YES                              VALUE 1.88
78  MB-NO                               VALUE 2.88
78  MB-CANCEL                           VALUE 3.8
* MESSAGE BOX icons
78  MB-DEFAULT-ICON                     VALUE 1.88
78  MB-WARNING-ICON                     VALUE 2.88
78  MB-ERROR-ICON                       VALUE 3.8
* W$BITMAP opcodes
78  WBITMAP-DISPLAY                     VALUE 1.88
78  WBITMAP-DESTROY                     VALUE 2.88
78  WBITMAP-LOAD                        VALUE 3.8
* W$BITMAP option flags
78  WBITMAP-NO-FILL                     VALUE 1.8
* W$BITMAP error values
78  WBERR-UNSUPPORTED                   VALUE 0.89
78  WBERR-FILE-ERROR                    VALUE -1.99
78  WBERR-NO-MEMORY                     VALUE -2.99
78  WBERR-NOT-BITMAP                    VALUE -3.9
* W$TEXTSIZE library routine$
01  TEXTSIZE-DATA.
03  TEXTSIZE-FONT                   HANDLE OF FONT,;
/VALUE NULL.
03  TEXTSIZE-WINDOW                 HANDLE OF WINDOW<
/VALUE NULL.
03  TEXTSIZE-SIZE-X                 PIC 9(7)V99 COMP-4.??
03  TEXTSIZE-CELLS-X                PIC 9(7)V99 COMP-4.?<
03  TEXTSIZE-BASE-X                 PIC 9(9) COMP-4.<=
03  TEXTSIZE-SIZE-Y                 PIC 99V99 COMP-4.==
03  TEXTSIZE-CELLS-Y                PIC 99V99 COMP-4.=<
03  TEXTSIZE-BASE-Y                 PIC 9(4) COMP-4.<E
03  TEXTSIZE-FLAGS                  PIC X COMP-X, VALUE ZERO.E<
88  TEXTSIZE-STRIP-SPACES       VALUE 1, FALSE ZERO.<
* EVENT-ACTION values
78  EVENT-ACTION-NORMAL                 VALUE ZERO.;8
78  EVENT-ACTION-TERMINATE              VALUE 1.88
78  EVENT-ACTION-CONTINUE               VALUE 2.88
78  EVENT-ACTION-IGNORE                 VALUE 3.8
* Reserved for future use!8
78  EVENT-ACTION-FAIL                   VALUE 4.8
* Standard exception values from the windowing system=
78  W-TIMEOUT                           VALUE 99.99
78  W-CONVERSION-ERROR                  VALUE 98.99
78  W-NO-FIELDS                         VALUE 97.99
78  W-EVENT                             VALUE 96.99
78  W-MESSAGE                           VALUE 95.9
* Command events
78  CMD-CLOSE                           VALUE 1.88
78  CMD-GOTO                            VALUE 3.88
78  CMD-CLICKED                         VALUE 4.88
78  CMD-DBLCLICK                        VALUE 5.88
78  CMD-ACTIVATE                        VALUE 6.88
78  CMD-TABCHANGED                      VALUE 7.88
78  CMD-HELP                            VALUE 8.8
* Notification events
78  NTF-SELCHANGE                       VALUE 4099.;;
78  NTF-CHANGED                         VALUE 4100.;3
* The next 7 apply to paged list-boxes only3;
78  NTF-PL-NEXT                         VALUE 4101.;;
78  NTF-PL-PREV                         VALUE 4102.;;
78  NTF-PL-NEXTPAGE                     VALUE 4103.;;
78  NTF-PL-PREVPAGE                     VALUE 4104.;;
78  NTF-PL-FIRST                        VALUE 4105.;;
78  NTF-PL-LAST                         VALUE 4106.;;
78  NTF-PL-SEARCH                       VALUE 4107.;;
78  NTF-RESIZED                         VALUE 4114.;
* Message-style events
78  MSG-SB-NEXT                         VALUE 16385.<<
78  MSG-SB-PREV                         VALUE 16386.<<
78  MSG-SB-NEXTPAGE                     VALUE 16387.<<
78  MSG-SB-PREVPAGE                     VALUE 16388.<<
78  MSG-SB-THUMB                        VALUE 16389.<<
78  MSG-SB-THUMBTRACK                   VALUE 16390.<<
78  MSG-VALIDATE                        VALUE 16391.<<
78  MSG-BEGIN-ENTRY                     VALUE 16392.<<
78  MSG-FINISH-ENTRY                    VALUE 16393.<<
78  MSG-CANCEL-ENTRY                    VALUE 16394.<<
78  MSG-GOTO-CELL                       VALUE 16395.<<
78  MSG-GOTO-CELL-MOUSE                 VALUE 16396.<<
78  MSG-MENU-INPUT                      VALUE 16397.<<
78  MSG-INIT-MENU                       VALUE 16398.<<
78  MSG-END-MENU                        VALUE 16399.<<
78  MSG-BITMAP-CLICKED                  VALUE 16400.<<
78  MSG-BITMAP-DBLCLICK                 VALUE 16401.<<
78  MSG-HEADING-CLICKED                 VALUE 16402.<<
78  MSG-HEADING-DBLCLICK                VALUE 16403.<<
78  MSG-GOTO-CELL-DRAG                  VALUE 16404.<<
78  MSG-HEADING-DRAGGED                 VALUE 16405.<<
78  MSG-BEGIN-DRAG                      VALUE 16406.<<
78  MSG-END-DRAG                        VALUE 16407.<<
78  MSG-BEGIN-HEADING-DRAG              VALUE 16408.<<
78  MSG-END-HEADING-DRAG                VALUE 16409.<<
78  MSG-COL-WIDTH-CHANGED               VALUE 16410.<
* Entry Field ACTION values#8
78  ACTION-CUT                          VALUE 1.88
78  ACTION-COPY                         VALUE 2.88
78  ACTION-PASTE                        VALUE 3.88
78  ACTION-DELETE                       VALUE 4.88
78  ACTION-UNDO                         VALUE 5.8
* Flags for win$playsound!
78  SND-SYNC                            VALUE 0.88
78  SND-ASYNC                           VALUE 1.88
78  SND-LOOP                            VALUE 8.89
78  SND-NOSTOP                          VALUE 16.9
* Paged list sort-order values&8
78  PL-SORT-DEFAULT                     VALUE 0.88
78  PL-SORT-NONE                        VALUE 1.88
78  PL-SORT-NATIVE                      VALUE 2.88
78  PL-SORT-NATIVE-IGNORE-CASE          VALUE 3.8
* end of acugui.def
COPY "ACUCOBOL.DEF".
* ACUCOBOL.DEF - Some useful ACUCOBOL definitions.:'
* Last modified: 28-Mar-97 TDC.'
* Copyright (c) 1996 - 1998 by Acucorp, Inc.  Users of ACUCOBOLGB
* may freely include this file in their COBOL source code.B
01  TERMINAL-ABILITIES.
03  TERMINAL-NAME                   PIC X(10).62
03  FILLER                          PIC X.22
88  HAS-REVERSE                 VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-BLINK                   VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-UNDERLINE               VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-DUAL-INTENSITY          VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-132-COLUMN-MODE         VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-COLOR                   VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-LINE-DRAWING            VALUE "Y".25
03  NUMBER-OF-SCREEN-LINES          PIC 9(3).55
03  NUMBER-OF-SCREEN-COLUMNS        PIC 9(3).52
03  FILLER                          PIC X.22
88  HAS-LOCAL-PRINTER           VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-VISIBLE-ATTRIBUTES      VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-GRAPHICAL-INTERFACE     VALUE "Y".2<
03  USABLE-SCREEN-HEIGHT            PIC X(2) COMP-X.<<
03  USABLE-SCREEN-WIDTH             PIC X(2) COMP-X.<<
03  PHYSICAL-SCREEN-HEIGHT          PIC X(2) COMP-X.<<
03  PHYSICAL-SCREEN-WIDTH           PIC X(2) COMP-X.<
01  SYSTEM-INFORMATION.
03  OPERATING-SYSTEM                PIC X(10).67
88  OS-IS-MSDOS                 VALUE "MS-DOS".75
88  OS-IS-OS2                   VALUE "OS/2".55
88  OS-IS-VMS                   VALUES "VMS",5
/"VAX/VMS".
88  OS-IS-UNIX                  VALUES "Unix-V",8
/"Unix-4", "UNOS".
88  OS-IS-AOS                   VALUE "AOS/VS".78
88  OS-IS-WINDOWS               VALUE "WINDOWS".87
88  OS-IS-WIN-NT                VALUE "WIN/NT".79
88  OS-IS-WIN-FAMILY            VALUES "WINDOWS",9
6"WIN/NT".
88  OS-IS-AMOS                  VALUE "AMOS".56
03  USER-ID                         PIC X(12).66
03  STATION-ID                      PIC X(12).62
03  FILLER                          PIC X.22
88  HAS-INDEXED-READ-PREVIOUS   VALUE "Y".22
03  FILLER                          PIC X.22
88  HAS-RELATIVE-READ-PREVIOUS  VALUE "Y".22
03  FILLER                          PIC X.22
88  CAN-TEST-INPUT-STATUS       VALUE "Y".22
03  FILLER                          PIC X.22
88  IS-MULTI-TASKING            VALUE "Y".2
03  RUNTIME-VERSION.
88  VERSION-PRIOR-TO-2-2        VALUE SPACES.5/
05  RUNTIME-MAJOR-VERSION       PIC 99.//
05  RUNTIME-MINOR-VERSION       PIC 99.//
05  RUNTIME-RELEASE             PIC 99./2
03  FILLER                          PIC X.22
88  IS-PLUGIN                   VALUE "Y".2
01  BROWSERINFO-DATA.
03  USER-AGENT-STRING               PIC X(50).69
03  BROWSER-MAJOR-VERSION           PIC X COMP-X.99
03  BROWSER-MINOR-VERSION           PIC X COMP-X.9
78  BLACK                               VALUE 1.88
78  BLUE                                VALUE 2.88
78  GREEN                               VALUE 3.88
78  CYAN                                VALUE 4.88
78  RED                                 VALUE 5.88
78  MAGENTA                             VALUE 6.88
78  BROWN                               VALUE 7.88
78  WHITE                               VALUE 8.88
78  DARK-GRAY                           VALUE 9.89
78  BRIGHT-BLUE                         VALUE 10.99
78  BRIGHT-GREEN                        VALUE 11.99
78  BRIGHT-CYAN                         VALUE 12.99
78  BRIGHT-RED                          VALUE 13.99
78  BRIGHT-MAGENTA                      VALUE 14.99
78  YELLOW                              VALUE 15.99
78  BRIGHT-WHITE                        VALUE 16.99
78  BCKGRND-BLACK                       VALUE 32.99
78  BCKGRND-BLUE                        VALUE 64.99
78  BCKGRND-GREEN                       VALUE 96.9:
78  BCKGRND-CYAN                        VALUE 128.::
78  BCKGRND-RED                         VALUE 160.::
78  BCKGRND-MAGENTA                     VALUE 192.::
78  BCKGRND-BROWN                       VALUE 224.::
78  BCKGRND-WHITE                       VALUE 256.::
78  BCKGRND-DARK-GRAY                   VALUE 288.::
78  BCKGRND-BRIGHT-BLUE                 VALUE 320.::
78  BCKGRND-BRIGHT-GREEN                VALUE 352.::
78  BCKGRND-BRIGHT-CYAN                 VALUE 384.::
78  BCKGRND-BRIGHT-RED                  VALUE 416.::
78  BCKGRND-BRIGHT-MAGENTA              VALUE 448.::
78  BCKGRND-YELLOW                      VALUE 480.::
78  BCKGRND-BRIGHT-WHITE                VALUE 512.:;
78  COLOR-REVERSE                       VALUE 1024.;;
78  FRGRND-LOW                          VALUE 2048.;;
78  FRGRND-HIGH                         VALUE 4096.;;
78  COLOR-UNDERLINE                     VALUE 8192.;<
78  COLOR-BLINK                         VALUE 16384.<<
78  COLOR-PROTECTED                     VALUE 32768.<<
78  BCKGRND-LOW                         VALUE 65536.<=
78  BCKGRND-HIGH                        VALUE 131072.==
78  WINDOW-BRIGHT-WHITE                 VALUE 131328.=
78  GET-FILE-STATUS                     VALUE 1.88
78  GET-TRANSACTION-STATUS              VALUE 2.8
*  Opcodes for C$FILESYS 
78  START-FILESYSTEM-LIST               VALUE 0.88
78  CONTINUE-FILESYSTEM-LIST            VALUE 1.88
78  CHECK-FOR-FILESYSTEM                VALUE 2.88
78  NUMBER-OF-FILESYSTEMS               VALUE 3.8
77  FILESYSTEM                          PIC X(5).9
* end of acucobol.def
COPY "CRTVARS.DEF".
* CRTVARS.DEF - definitions of commonly needed screen handling variablesP(
* Date written: 27-Aug-96 - TDC.(
* Copyright (c) 1996 - 1998 by Acucorp, Inc.  Users of ACUCOBOLGB
* may freely include this file in their COBOL source code.B
01  EVENT-STATUS
IS SPECIAL-NAMES EVENT STATUS.&<
03  EVENT-TYPE                      PIC X(4) COMP-X.<=
03  EVENT-WINDOW-HANDLE             HANDLE OF WINDOW.=3
03  EVENT-CONTROL-HANDLE            HANDLE.3:
03  EVENT-CONTROL-ID                PIC XX COMP-X.:9
03  EVENT-DATA-1                    SIGNED-SHORT.98
03  EVENT-DATA-2                    SIGNED-LONG.89
03  EVENT-ACTION                    PIC X COMP-X.9
01  SCREEN-CONTROL
IS SPECIAL-NAMES SCREEN CONTROL.(2
03  ACCEPT-CONTROL                  PIC 9.24
03  CONTROL-VALUE                   PIC 999.43
03  CONTROL-HANDLE                  HANDLE.3:
03  CONTROL-ID                      PIC XX COMP-X.:
* End of CRTVARS.DEF
01 exc-val IS SPECIAL-NAMES  CRT STATUS   PIC 9(4)  VALUE   0.FD
88 Run-tests                                      VALUE 100.DD
88 Exit-testbed                                   VALUE 101.D
01 Day-Names.
03 PIC X(14) VALUE "1 (Monday)".()
03 PIC X(14) VALUE "2 (Tuesday)".)+
03 PIC X(14) VALUE "3 (Wednesday)".+*
03 PIC X(14) VALUE "4 (Thursday)".*(
03 PIC X(14) VALUE "5 (Friday)".(*
03 PIC X(14) VALUE "6 (Saturday)".*(
03 PIC X(14) VALUE "7 (Sunday)".(
01 Weekdays
REDEFINES Day-Names,
OCCURS 7 TIMES INDEXED BY Weekday-Pointer     PIC X(14).@
01 Selected-DOW                                   PIC X(14) VALUE SPACES.Q
78 Number-Of-Tests                                        VALUE 15.K
01 Tests OCCURS Number-Of-Tests TIMES INDEXED BY Test-Pointer.FO
03 Test-Name                                    PIC X(32) VALUE SPACES.OI
03 Run-Test                                     PIC 9(1) VALUE 0.IO
03 Test-Result                                  PIC X(8)  VALUE SPACES.OI
03 Test-Present                                 PIC 9(1) VALUE 0.IO
03 Test-Program                                 PIC X(12) VALUE SPACES.O
01 System-Date.          | ISO8601*9
03 System-Year                  PIC 9(4) VALUE 0.9F
88 Valid-System-Year                 VALUES 1990 THROUGH 2050.F9
03 System-Month                 PIC 9(2) VALUE 0.9A
88 Valid-System-Month                VALUES 1 THROUGH 12.A9
03 System-Day                   PIC 9(2) VALUE 0.9A
88 Valid-System-Day                  VALUES 1 THROUGH 31.A
03 System-DOY.
05 FILLER                     PIC 9(2).//
05 System-Day-Of-Year         PIC 9(3)./B
88 Valid-System-Day-Of-Year          VALUES 1 THROUGH 366.B1
03 System-Day-Of-Week           PIC 9(1).1@
88 Valid-System-Day-Of-Week          VALUES 1 THROUGH 7.@
01 Leap-Year                      PIC 9(1) VALUE 0.;0
01 TMP-DIV                        PIC 9.02
01 MOD-REM                        PIC 999.2
01  Month-Table.
03  PIC 999 VALUE ZERO.
03  PIC 999 VALUE 31.
03  PIC 999 VALUE 59.
03  PIC 999 VALUE 90.
03  PIC 999 VALUE 120.
03  PIC 999 VALUE 151.
03  PIC 999 VALUE 181.
03  PIC 999 VALUE 212.
03  PIC 999 VALUE 243.
03  PIC 999 VALUE 273.
03  PIC 999 VALUE 304.
03  PIC 999 VALUE 334.
01  Days-To-Month-Table REDEFINES Month-Table.6
03  Days-To-Month
OCCURS 12 TIMES             PIC 999.,
COPY "TESTSUM.DEF".
* Data structure for passing info between test program and manager.K
01 Test-Data EXTERNAL.
03 Test-Result-Code             PIC 9(1).10
88 Test-Passed                  VALUE 1.00
88 Test-Failed                  VALUE 2.0
03 User-Date.          | ISO8601(/
05 User-Year                  PIC 9(4)./D
88 Valid-User-Year                 VALUES 1990 THROUGH 2050.D/
05 User-Month                 PIC 9(2)./?
88 Valid-User-Month                VALUES 1 THROUGH 12.?/
05 User-Day                   PIC 9(2)./?
88 Valid-User-Day                  VALUES 1 THROUGH 31.?
03 User-Day-Of-Year             PIC 9(3).1B
88 Valid-User-Day-Of-Year            VALUES 1 THROUGH 366.B1
03 User-Day-Of-Week             PIC 9(1).1@
88 Valid-User-Day-Of-Week            VALUES 1 THROUGH 7.@
SCREEN SECTION.
01 Main-Screen.
03 Program-Controls.
05 FRAME |TITLE "Date Tests",%
LINE 1.5 COL 1.5,
LINES 25 CELLS SIZE 80 CELLS,%
RAISED VERY-HEAVY.
05 PUSH-BUTTON TITLE "&Run Tests",*
LINE 2.5 COL 12,
LINES 2 CELLS SIZE 10 CELLS,$!
OK-BUTTON DEFAULT-BUTTON,!%
SELF-ACT EXCEPTION-VALUE 100.%%
05 PUSH-BUTTON TITLE "E&xit",%
COL PLUS 2
LINES 2 CELLS SIZE 10 CELLS,$
CANCEL-BUTTON,
SELF-ACT EXCEPTION-VALUE 101.%
05 BAR
LINE PLUS 2.5 COL 2,
SIZE 38.5 CELLS WIDTH = 5,"
COLOR Green,
SHADING = (-1, 1, 0, 0, -2).$.
03 Tests OCCURS Number-of-Tests TIMES..4
05 CHECK-BOX TITLE Test-Name VALUE Run-Test,4
LINE PLUS 1.3 COL 3,
LINES 1.5 CELLS SIZE 32 CELLS,&
SELF-ACT
ENABLED Test-Present,
VISIBLE Test-Present.
05 Test-Result-LB LABEL VALUE Test-Result,2
ENABLED Test-Present
VISIBLE Test-Present.
01 Get-Date-Screen AFTER PROCEDURE IS Get-Date-After-Proc.B
03 LABEL TITLE "YYYY"
LINE 1 COL 3.
03 ENTRY-FIELD USING User-Year,'
LINE 2.5 COL 3,
3-D NUMERIC AUTO,
AFTER PROCEDURE IS User-Year-After-Proc.0
03 LABEL TITLE "MM"
LINE 1 COL 10.
03 ENTRY-FIELD USING User-Month,(
LINE 2.5 COL 10
3-D NUMERIC AUTO,
AFTER PROCEDURE IS User-Month-After-Proc.1
03 LABEL TITLE "DD"
LINE 1 COL 15.
03 ENTRY-FIELD USING User-Day,&
LINE 2.5 COL 15,
3-D NUMERIC AUTO,
AFTER PROCEDURE IS User-Day-After-Proc./
03 LABEL TITLE "Today is: "#
LINE 5 COL 3.
03 DOW-Combo Combo-box DROP-LIST USING Selected-DOW,<
COL PLUS 2,
3-D AFTER PROCEDURE IS Get-Date-After-Proc.3
03 PUSH-BUTTON "&OK",
SELF-ACT EXCEPTION-VALUE 13,$
LINE 7 COL 7.5
SIZE 10.
PROCEDURE DIVISION.
DECLARATIVES.
END DECLARATIVES.
Main-Logic.
SET ENVIRONMENT "QUIT_MODE" TO "101".--
SET ENVIRONMENT "USE_MOUSE" TO "Yes".-
DISPLAY INITIAL WINDOW,
LINES 8 + Number-Of-Tests * 1.3 SIZE 40,0>
COLOR black + bckgrnd-white, BACKGROUND-LOW USER-GRAY,> 
TITLE "Year 2000 Tests", $
WITH NO WRAP WITH NO SCROLL,$
ERASE SCREEN,
WITH SYSTEM MENU.
PERFORM Initialize-Main-Screen.'
PERFORM UNTIL 1=0
DISPLAY Main-Screen
ACCEPT Main-Screen
ON EXCEPTION
EVALUATE TRUE
WHEN Run-Tests
PERFORM Run-Selected-Tests"
WHEN Exit-Testbed
EXIT PERFORM
END-EVALUATE
END-ACCEPT
END-PERFORM.
GOBACK 0.
Run-Selected-Tests.
INITIALIZE Test-Pointer. 
PERFORM Get-User-Date.
PERFORM VARYING Test-Pointer FROM 1 BY 1 UNTIL Test-Pointer > Number-Of-TestsU
DISPLAY Main-Screen
IF (Test-Present(Test-Pointer) = 1) THEN0,
INITIALIZE Test-Result(Test-Pointer),,
IF (Run-Test(Test-Pointer) = 1) THEN,#
INITIALIZE Test-Result-Code#U
\D        DISPLAY "[TESTBED] Calling " Test-Program(Test-Pointer) UPON SYSERRU'
CALL Test-Program(Test-Pointer)'
ON EXCEPTION
\D            DISPLAY "[TESTBED] Exception on CALL of " Test-Program(Test-Pointer) UPON SYSERRf0
MOVE "????" TO Test-Result(Test-Pointer)0,
MOVE 0 TO Test-Present(Test-Pointer),(
MOVE 0 TO Run-Test(Test-Pointer)(
NOT ON EXCEPTION
\D            DISPLAY "[TESTBED] CALL of " Test-Program(Test-Pointer) " successful" UPON SYSERRg
IF Test-Passed THEN
MOVE "Pass" TO Test-Result(Test-Pointer)08
MODIFY Test-Result-LB(Test-Pointer), COLOR Black8
ELSE
MOVE "FAIL" TO Test-Result(Test-Pointer)0N
MODIFY Test-Result-LB(Test-Pointer), COLOR Bright-Red + BckGrnd-YellowN
END-IF
END-CALL
END-IF
END-IF
END-PERFORM.
Get-User-Date.
INITIALIZE System-Date, User-Date.*
DISPLAY FLOATING WINDOW
HANDLE IN Get-Date-Window!
LINES 10 SIZE 60,
COLOR black + bckgrnd-white, BACKGROUND-LOW USER-GRAY,>#
TITLE "Enter Current Date",#$
WITH NO WRAP WITH NO SCROLL,$
BOXED
ERASE SCREEN.
DISPLAY Get-Date-Screen. 
ACCEPT User-Date FROM CENTURY-DATE.+1
ACCEPT User-Day-Of-Week FROM DAY-OF-WEEK.1
MODIFY DOW-Combo, Reset-List = 1.)M
PERFORM VARYING Weekday-Pointer FROM 1 BY 1 UNTIL Weekday-Pointer > 7MA
MODIFY DOW-Combo, Item-To-Add = Weekdays(Weekday-Pointer)A
END-PERFORM.
MOVE Weekdays(User-Day-Of-Week) TO Selected-DOW.8
PERFORM WITH TEST AFTER UNTIL (Valid-User-Year AND Valid-User-Month AND Valid-User-Day AND Valid-User-Day-Of-Week)z
DISPLAY Get-Date-Screen
ACCEPT Get-Date-Screen
END-PERFORM
DESTROY Get-Date-Window. 
ACCEPT System-Date FROM CENTURY-DATE.-
IF NOT (Valid-System-Year AND Valid-System-Month AND Valid-System-Day) THENSO
DISPLAY "[TESTBED] Something's wrong with the system date!" UPON SYSERROK
DISPLAY "[TESTBED] CENTURY-DATE reported: " System-Date UPON SYSERRK
END-IF.
IF NOT (System-Year = User-Year) THEN-[
DISPLAY "[TESTBED] System Year " System-Year " != User-Year " User-Year UPON SYSERR[
END-IF.
IF NOT (System-Month = User-Month) THEN/_
DISPLAY "[TESTBED] System Month " System-Month " != User-Month " User-Month UPON SYSERR_
END-IF.
IF NOT (System-Day = User-Day) THEN+W
DISPLAY "[TESTBED] System Day " System-Day " != User-Day " User-Day UPON SYSERRW
END-IF.
PERFORM Calculate-User-DOY.#
Get-Date-After-Proc.
PERFORM User-Year-After-Proc.%&
PERFORM User-Month-After-Proc.&$
PERFORM User-Day-After-Proc.$
User-Day-After-Proc.
IF (NOT Valid-User-Day) OR (User-Day = 0) THEN6I
DISPLAY "Day must be between 1 and 31" AT LINE 10 COL 1 WITH BEEPI
SET Accept-Control TO 1
SET Control-Id TO 3
ELSE
DISPLAY OMITTED AT LINE 10 COL 1 ERASE TO END OF LINE=
END-IF.
User-Month-After-Proc.
IF NOT Valid-User-Month OR (User-Month = 0) THEN8K
DISPLAY "Month must be between 1 and 12" AT LINE 10 COL 1 WITH BEEPK
SET Accept-Control TO 1
SET Control-Id TO 2
ELSE
DISPLAY OMITTED AT LINE 10 COL 1 ERASE TO END OF LINE=
END-IF.
User-Year-After-Proc.
IF NOT Valid-User-Year OR (User-Year = 0)THEN5X
DISPLAY "Year must be 4-digits between 1990 and 2010" AT LINE 10 COL 1 WITH BEEPX
SET Accept-Control TO 1
SET Control-Id TO 1
ELSE
DISPLAY OMITTED AT LINE 10 COL 1 ERASE TO END OF LINE=
END-IF.
Initialize-Main-Screen.
SET Test-Pointer TO 1.
MOVE "C$FILEINFO DATE"  TO Test-Name(Test-Pointer).;6
MOVE "fileinfo" TO Test-Program(Test-Pointer).6
ADD 1 TO Test-Pointer.
MOVE "INTDATE" TO Test-Name(Test-Pointer).27
MOVE "T-INTDATE" TO Test-Program(Test-Pointer).7
ADD 1 TO Test-Pointer.
MOVE "DAYWEEK" TO Test-Name(Test-Pointer).27
MOVE "t-dayweek" TO Test-Program(Test-Pointer).7
ADD 1 TO Test-Pointer.
MOVE "ACCEPT FROM DATE" TO Test-Name(Test-Pointer).;4
MOVE "a-date" TO Test-Program(Test-Pointer).4
ADD 1 TO Test-Pointer.
MOVE "ACCEPT FROM DAY" TO Test-Name(Test-Pointer).:3
MOVE "a-day" TO Test-Program(Test-Pointer).3
ADD 1 TO Test-Pointer.
MOVE "ACCEPT FROM CENTURY-DATE" TO Test-Name(Test-Pointer).C5
MOVE "a-cdate" TO Test-Program(Test-Pointer).5
ADD 1 TO Test-Pointer.
MOVE "ACCEPT FROM CENTURY-DAY" TO Test-Name(Test-Pointer).B4
MOVE "a-cday" TO Test-Program(Test-Pointer).4
ADD 1 TO Test-Pointer.
MOVE "ACCEPT FROM DAY-OF-WEEK" TO Test-Name(Test-Pointer).B3
MOVE "a-dow" TO Test-Program(Test-Pointer).3
PERFORM VARYING Test-Pointer FROM 1 BY 1 UNTIL Test-Pointer > Number-Of-TestsU;
IF Test-Program(Test-Pointer) NOT EQUAL SPACES THEN;,
MOVE 1 TO Test-Present(Test-Pointer),(
MOVE 1 TO Run-Test(Test-Pointer)(
ELSE
INITIALIZE Test-Present(Test-Pointer)-)
INITIALIZE Run-Test(Test-Pointer))
END-IF
END-PERFORM.
Calculate-User-DOY.
INITIALIZE User-Day-Of-Year.$)
SET User-Day-Of-Year TO User-Day.)
SET Leap-Year TO 0.
DIVIDE User-Year BY 4 GIVING Tmp-Div REMAINDER Mod-Rem>
IF Mod-Rem = 0 THEN
MOVE 1 TO Leap-Year
INITIALIZE Mod-Rem
DIVIDE User-Year BY 100 GIVING Tmp-Div REMAINDER Mod-Rem@
IF Mod-Rem = 0 THEN
MOVE 0 TO Leap-Year
INITIALIZE Mod-Rem
DIVIDE User-Year BY 400 GIVING Tmp-Div REMAINDER Mod-Rem@
IF Mod-Rem = 0 THEN
MOVE 1 TO Leap-Year
END-IF
END-IF
END-IF.
ADD Days-To-Month(User-Month) TO User-Day-Of-Year.:
IF (Leap-Year > 0) AND (User-Month > 2) THEN4)
ADD Leap-Year TO User-Day-Of-Year)W
DISPLAY "[TESTBED] " User-Year " is a leap year; adding " Leap-Year UPON SYSERRW
END-IF.
IF NOT Valid-User-Day-Of-Year THEN*[
DISPLAY "[TESTBED] Calculated Day of Year is invalid " User-Day-Of-Year UPON SYSERR[
END-IF.
ACCEPT System-DOY FROM DAY.#
IF NOT User-Day-Of-Year = System-Day-Of-Year THEN9T
DISPLAY "[TESTBED] System Day of Year != Calculated Day of Year" UPON SYSERRT
END-IF.
<<EOF>>
