|
|
The DDS for a Pop-up Calendar
* http://www.400times.com/FrameData/Pop-up_Calendar.htm *
A*%%TS SD 20020727 132400 BOOTH REL-V4R4M0 5769-PW1
A*
A*%%EC
A DSPSIZ(24 80 *DS3)
A CHGINPDFT
A PRINT
A ENTFLDATR((*COLOR RED) (*DSPATR RI))
A R FMT001
A*%%TS SD 20020727 132400 BOOTH REL-V4R4M0 5769-PW1
A CA03(03 'Exit')
A CA07(07 'Exit')
A CA12(12 'Exit')
A CF04(84)
A CF05(85)
A PAGEUP(84)
A PAGEDOWN(85)
A KEEP
A RTNCSRLOC(&CSRRCD &CSRFLD &CSRPOS)
A 05 CSRLOC(ROW COL)
A OVERLAY
A WINDOW(*DFT 9 21 *NOMSGLIN)
A WDWTITLE((*TEXT ' F3=Cancel, PgUp/D-
A own ') *BOTTOM)
A MOUBTN(*ULD ENTER)
A @DAY01 1A P
A @DAY02 1A P
A @DAY03 1A P
A @DAY04 1A P
A @DAY05 1A P
A @DAY06 1A P
A @DAY07 1A P
A @DAY08 1A P
A @DAY09 1A P
A @DAY10 1A P
A @DAY11 1A P
A @DAY12 1A P
A @DAY13 1A P
A @DAY14 1A P
A @DAY15 1A P
A @DAY16 1A P
A @DAY17 1A P
A @DAY18 1A P
A @DAY19 1A P
A @DAY20 1A P
A @DAY21 1A P
A @DAY22 1A P
A @DAY23 1A P
A @DAY24 1A P
A @DAY25 1A P
A @DAY26 1A P
A @DAY27 1A P
A @DAY28 1A P
A @DAY29 1A P
A @DAY30 1A P
A @DAY31 1A P
A @DAY32 1A P
A @DAY33 1A P
A @DAY34 1A P
A @DAY35 1A P
A @DAY36 1A P
A @DAY37 1A P
A @DAY38 1A P
A @DAY39 1A P
A @DAY40 1A P
A @DAY41 1A P
A @DAY42 1A P
A CSRRCD 10A H
A CSRFLD 10A H
A CSRPOS 4S 0H
A ROW 3S 0H
A COL 3S 0H
A MTHNAME 10A O 1 1DSPATR(HI)
A YEARNUM 4S 0O 1 17DSPATR(HI)
A 3 2'S'
A COLOR(RED)
A 3 5'M'
A COLOR(BLU)
A 3 8'T'
A COLOR(BLU)
A 3 11'W'
A COLOR(BLU)
A 3 14'T'
A COLOR(BLU)
A 3 17'F'
A COLOR(BLU)
A 3 20'S'
A COLOR(RED)
A DAY01 2A B 4 1DSPATR(&@DAY01)
A DAY02 2A B 4 4DSPATR(&@DAY02)
A DAY03 2A B 4 7DSPATR(&@DAY03)
A DAY04 2A B 4 10DSPATR(&@DAY04)
A DAY05 2A B 4 13DSPATR(&@DAY05)
A DAY06 2A B 4 16DSPATR(&@DAY06)
A DAY07 2A B 4 19DSPATR(&@DAY07)
A DAY08 2A B 5 1DSPATR(&@DAY08)
A DAY09 2A B 5 4DSPATR(&@DAY09)
A DAY10 2A B 5 7DSPATR(&@DAY10)
A DAY11 2A B 5 10DSPATR(&@DAY11)
A DAY12 2A B 5 13DSPATR(&@DAY12)
A DAY13 2A B 5 16DSPATR(&@DAY13)
A DAY14 2A B 5 19DSPATR(&@DAY14)
A DAY15 2A B 6 1DSPATR(&@DAY15)
A DAY16 2A B 6 4DSPATR(&@DAY16)
A DAY17 2A B 6 7DSPATR(&@DAY17)
A DAY18 2A B 6 10DSPATR(&@DAY18)
A DAY19 2A B 6 13DSPATR(&@DAY19)
A DAY20 2A B 6 16DSPATR(&@DAY20)
A DAY21 2A B 6 19DSPATR(&@DAY21)
A DAY22 2A B 7 1DSPATR(&@DAY22)
A DAY23 2A B 7 4DSPATR(&@DAY23)
A DAY24 2A B 7 7DSPATR(&@DAY24)
A DAY25 2A B 7 10DSPATR(&@DAY25)
A DAY26 2A B 7 13DSPATR(&@DAY26)
A DAY27 2A B 7 16DSPATR(&@DAY27)
A DAY28 2A B 7 19DSPATR(&@DAY28)
A DAY29 2A B 8 1DSPATR(&@DAY29)
A DAY30 2A B 8 4DSPATR(&@DAY30)
A DAY31 2A B 8 7DSPATR(&@DAY31)
A DAY32 2A B 8 10DSPATR(&@DAY32)
A DAY33 2A B 8 13DSPATR(&@DAY33)
A DAY34 2A B 8 16DSPATR(&@DAY34)
A DAY35 2A B 8 19DSPATR(&@DAY35)
A DAY36 2A B 9 1DSPATR(&@DAY36)
A DAY37 2A B 9 4DSPATR(&@DAY37)
A DAY38 2A B 9 7DSPATR(&@DAY38)
A DAY39 2A B 9 10DSPATR(&@DAY39)
A DAY40 2A B 9 13DSPATR(&@DAY40)
A DAY41 2A B 9 16DSPATR(&@DAY41)
A DAY42 2A B 9 19DSPATR(&@DAY42)
A R DUMMY
A*
A KEEP
A ASSUME
A 1 3' '
|
The RPG for the Pop-Up Calendar
* http://www.400times.com/FrameData/Pop-up_Calendar.htm *
*************************************************************
* A program to show a pop-up calendar *
* 7/02 Booth M. *
* (Uses mouse button click) *
* http://www.400times.com/FrameData/Pop-up_Calendar.htm *
*************************************************************
FUTLCALD cf e workstn INFDS(INFDS)
d StartDate s d INZ(*SYS)
d BlankDate s d
d firstdate s d datfmt(*iso) inz(d'1899-12-31')
d lowestdate s d datfmt(*iso) inz(d'1900-01-01')
d xdate s d
d today s 6 0
d day# s 2 0
d @p s 3 0
d work s 5 0
d pddath# s 5 0
d Count s 5 0
d ix s 3 0
d day s 2
d curmnth s 2 0
d curyear s 4 0
d InFds ds
dcursor 370 371b 0
d ArrayX ds
d Array 2 dim(42)
d PdmDS ds
d pdm 2 0 dim(13)
d MonthNames ds
d 9 inz('January ')
d 9 inz('February ')
d 9 inz('March ')
d 9 inz('April ')
d 9 inz('May ')
d 9 inz('June ')
d 9 inz('July ')
d 9 inz('August ')
d 9 inz('September')
d 9 inz('October ')
d 9 inz('November ')
d 9 inz('December ')
d MthNam 9 dim(12) overlay(MonthNames)
d DspAtribs ds
d @DAY01 1 inz(Normal)
d @DAY02 1 inz(Normal)
d @DAY03 1 inz(Normal)
d @DAY04 1 inz(Normal)
d @DAY05 1 inz(Normal)
d @DAY06 1 inz(Normal)
d @DAY07 1 inz(Normal)
d @DAY08 1 inz(Normal)
d @DAY09 1 inz(Normal)
d @DAY10 1 inz(Normal)
d @DAY11 1 inz(Normal)
d @DAY12 1 inz(Normal)
d @DAY13 1 inz(Normal)
d @DAY14 1 inz(Normal)
d @DAY15 1 inz(Normal)
d @DAY16 1 inz(Normal)
d @DAY17 1 inz(Normal)
d @DAY18 1 inz(Normal)
d @DAY19 1 inz(Normal)
d @DAY20 1 inz(Normal)
d @DAY21 1 inz(Normal)
d @DAY22 1 inz(Normal)
d @DAY23 1 inz(Normal)
d @DAY24 1 inz(Normal)
d @DAY25 1 inz(Normal)
d @DAY26 1 inz(Normal)
d @DAY27 1 inz(Normal)
d @DAY28 1 inz(Normal)
d @DAY29 1 inz(Normal)
d @DAY30 1 inz(Normal)
d @DAY31 1 inz(Normal)
d @DAY32 1 inz(Normal)
d @DAY33 1 inz(Normal)
d @DAY34 1 inz(Normal)
d @DAY35 1 inz(Normal)
d @DAY36 1 inz(Normal)
d @DAY37 1 inz(Normal)
d @DAY38 1 inz(Normal)
d @DAY39 1 inz(Normal)
d @DAY40 1 inz(Normal)
d @DAY41 1 inz(Normal)
d @DAY42 1 inz(Normal)
d DayAtr 1 dim(42) overlay(DspAtribs)
* RI=Reverse Image, HI=Hi Intensity, BL=blink, UL=Underline
* ND=Non Display
* NON Protect fields
d Normal c const(x'20')
d RI c const(x'21')
d HI c const(x'22')
d HIRI c const(x'23')
d UL c const(x'24')
d ULRI c const(x'25')
d ULHI c const(x'26')
d ND c const(x'27')
d BL c const(x'28')
d BLRI c const(x'29')
d BLHI c const(x'2A')
d BLHIRI c const(x'2B')
d BLUL c const(x'2C')
d BLULRI c const(x'2D')
d BLULHI c const(x'2E')
* Protect field
d PRNormal c const(x'A0')
d PRRI c const(x'A1')
d PRHI c const(x'A2')
d PRHIRI c const(x'A3')
d PRUL c const(x'A4')
d PRULRI c const(x'A5')
d PRULHI c const(x'A6')
d PRND c const(x'A7')
d PRBL c const(x'A8')
d PRBLRI c const(x'A9')
d PRBLHI c const(x'AA')
d PRBLHIRI c const(x'AB')
d PRBLUL c const(x'AC')
d PRBLULRI c const(x'AD')
d PRBLULHI c const(x'AE')
c again tag
c yearnum div 4 work4 4 0
c mvr leap 3 0
c if leap = *zero
c eval pdm(2) = 29
c else
c eval pdm(2) = 28
c endif
c clear DspAtribs
*===================================================================
* Find day of the week
*===================================================================
c startdate subdur firstdate pddath#:*d
c pddath# div 7 work
c mvr @p
c eval day# = @p + 1
c
c eval mthname = mthnam(mthnum)
c eval count = 0
c eval array = *blanks
c eval out = *blanks
* Fill array with date numbers
c do pdm(mthnum)
c eval count = count + 1
c move count out 2
c eval array(day#) = out
c eval day# = day# +1
c enddo
* Unprotect all fields that could be blank
c movea '0000000' *in(01)
c movea '0000000' *in(29)
c movea '0000000' *in(36)
* Fill screen fields
c eval day01 = array(01)
c eval day02 = array(02)
c eval day03 = array(03)
c eval day04 = array(04)
c eval day05 = array(05)
c eval day06 = array(06)
c eval day07 = array(07)
c eval day08 = array(08)
c eval day09 = array(09)
c eval day10 = array(10)
c eval day11 = array(11)
c eval day12 = array(12)
c eval day13 = array(13)
c eval day14 = array(14)
c eval day15 = array(15)
c eval day16 = array(16)
c eval day17 = array(17)
c eval day18 = array(18)
c eval day19 = array(19)
c eval day20 = array(20)
c eval day21 = array(21)
c eval day22 = array(22)
c eval day23 = array(23)
c eval day24 = array(24)
c eval day25 = array(25)
c eval day26 = array(26)
c eval day27 = array(27)
c eval day28 = array(28)
c eval day29 = array(29)
c eval day30 = array(30)
c eval day31 = array(31)
c eval day32 = array(32)
c eval day33 = array(33)
c eval day34 = array(34)
c eval day35 = array(35)
c eval day36 = array(36)
c eval day37 = array(37)
c eval day38 = array(38)
c eval day39 = array(39)
c eval day40 = array(40)
c eval day41 = array(41)
c eval day42 = array(42)
* Reverse image today's/selected date
c if mthnum = curmnth and yearnum = curyear
c move daynum day
c eval ix = 1
c day lookup array(ix) 80
c 80 eval DayAtr(ix) = RI
c endif
* Protect Blank fields
c day01 comp *blanks 01
c 01 eval @DAY01 = PRNormal
c day02 comp *blanks 02
c 02 eval @DAY01 = PRNormal
c day03 comp *blanks 03
c 03 eval @DAY01 = PRNormal
c day04 comp *blanks 04
c 04 eval @DAY01 = PRNormal
c day05 comp *blanks 05
c 05 eval @DAY01 = PRNormal
c day06 comp *blanks 06
c 06 eval @DAY01 = PRNormal
c day07 comp *blanks 07
c 07 eval @DAY01 = PRNormal
c day29 comp *blanks 29
c 29 eval @DAY01 = PRNormal
c day30 comp *blanks 30
c 30 eval @DAY01 = PRNormal
c day31 comp *blanks 31
c 31 eval @DAY01 = PRNormal
c day32 comp *blanks 32
c 32 eval @DAY01 = PRNormal
c day33 comp *blanks 33
c 33 eval @DAY01 = PRNormal
c day34 comp *blanks 34
c 34 eval @DAY01 = PRNormal
c day35 comp *blanks 35
c 35 eval @DAY01 = PRNormal
c day36 comp *blanks 36
c 36 eval @DAY01 = PRNormal
c day37 comp *blanks 37
c 37 eval @DAY01 = PRNormal
c day38 comp *blanks 38
c 38 eval @DAY01 = PRNormal
c day39 comp *blanks 39
c 39 eval @DAY01 = PRNormal
c day40 comp *blanks 40
c 40 eval @DAY01 = PRNormal
c day41 comp *blanks 41
c 41 eval @DAY01 = PRNormal
c day42 comp *blanks 42
c 42 eval @DAY01 = PRNormal
c doW Not *inLR
c exfmt fmt001
*
*
C Select
c When *inkc Or *INKG Or *INKL
c Eval *INLR = *On
*
* Go forward one month (F4)
c When *inkd or *IN84
c eval mthnum = mthnum + 1
c if mthnum = 13
c eval mthnum = 1
c eval yearnum = yearnum + 1
c endif
c clear startdate
c eval yearnum = yearnum - 1
c eval mthnum = mthnum - 1
c adddur yearnum:*y startdate
c adddur mthnum:*m startdate
c eval yearnum = yearnum + 1
c eval mthnum = mthnum + 1
c goto again
*
* Go back one month (F5)
c When *inke or *IN85
c eval mthnum = mthnum - 1
c if mthnum = 00
c eval mthnum = 12
c eval yearnum = yearnum - 1
c endif
c clear startdate
c eval yearnum = yearnum - 1
c eval mthnum = mthnum - 1
c adddur yearnum:*y startdate
c adddur mthnum:*m startdate
c eval yearnum = yearnum + 1
c eval mthnum = mthnum + 1
c if startdate <= firstdate
c eval startdate = lowestdate
c eval yearnum = 1900
c eval mthnum = 01
c eval daynum = 01
c endif
c goto again
*
C Other
* Fill return fields
c move *blanks out 2
c select
c when csrfld = 'DAY01'
c eval out = array(01)
c when csrfld = 'DAY02'
c eval out = array(02)
c when csrfld = 'DAY03'
c eval out = array(03)
c when csrfld = 'DAY04'
c eval out = array(04)
c when csrfld = 'DAY05'
c eval out = array(05)
c when csrfld = 'DAY06'
c eval out = array(06)
c when csrfld = 'DAY07'
c eval out = array(07)
c when csrfld = 'DAY08'
c eval out = array(08)
c when csrfld = 'DAY09'
c eval out = array(09)
c when csrfld = 'DAY10'
c eval out = array(10)
c when csrfld = 'DAY11'
c eval out = array(11)
c when csrfld = 'DAY12'
c eval out = array(12)
c when csrfld = 'DAY13'
c eval out = array(13)
c when csrfld = 'DAY14'
c eval out = array(14)
c when csrfld = 'DAY15'
c eval out = array(15)
c when csrfld = 'DAY16'
c eval out = array(16)
c when csrfld = 'DAY17'
c eval out = array(17)
c when csrfld = 'DAY18'
c eval out = array(18)
c when csrfld = 'DAY19'
c eval out = array(19)
c when csrfld = 'DAY20'
c eval out = array(20)
c when csrfld = 'DAY21'
c eval out = array(21)
c when csrfld = 'DAY22'
c eval out = array(22)
c when csrfld = 'DAY23'
c eval out = array(23)
c when csrfld = 'DAY24'
c eval out = array(24)
c when csrfld = 'DAY25'
c eval out = array(25)
c when csrfld = 'DAY26'
c eval out = array(26)
c when csrfld = 'DAY27'
c eval out = array(27)
c when csrfld = 'DAY28'
c eval out = array(28)
c when csrfld = 'DAY29'
c eval out = array(29)
c when csrfld = 'DAY30'
c eval out = array(30)
c when csrfld = 'DAY31'
c eval out = array(31)
c when csrfld = 'DAY32'
c eval out = array(32)
c when csrfld = 'DAY33'
c eval out = array(33)
c when csrfld = 'DAY34'
c eval out = array(34)
c when csrfld = 'DAY35'
c eval out = array(35)
c when csrfld = 'DAY36'
c eval out = array(36)
c when csrfld = 'DAY37'
c eval out = array(37)
c when csrfld = 'DAY38'
c eval out = array(38)
c when csrfld = 'DAY39'
c eval out = array(39)
c when csrfld = 'DAY40'
c eval out = array(40)
c when csrfld = 'DAY41'
c eval out = array(41)
c when csrfld = 'DAY42'
c eval out = array(42)
c endsl
c if out <> *blanks
c move mthnum outmth 2
c move yearnum outyear 4
c eval *inlr = *on
c endif
c endsl
c enddo
* End of routine:
c exit tag
c If %Parms = 3
c Eval p_outyear = outyear
c Eval p_outmth = outmth
c Eval p_out = out
c endIf
* ===============================================================
* == Sub Routines ==
* ===============================================================
c *inzsr begsr
c *entry plist
c parm p_outyear 4
c parm p_outmth 2
c parm p_out 2
c If %Parms = 3
c Eval Outyear = p_outyear
c Eval Outmth = p_outmth
c Eval Out = p_out
c end
c eval pdm(01) = 31
c eval pdm(02) = 28
c eval pdm(03) = 31
c eval pdm(04) = 30
c eval pdm(05) = 31
c eval pdm(06) = 30
c eval pdm(07) = 31
c eval pdm(08) = 31
c eval pdm(09) = 30
c eval pdm(10) = 31
c eval pdm(11) = 30
c eval pdm(12) = 31
c eval pdm(13) = 01
c if outyear = *blanks
c move *month mthnum 2 0
c move *year yearnum
c move *day daynum 2 0
* Get First Day of the month
c daynum sub 1 daynumw 2 0
c if daynumw <> 0
c startdate subdur daynumw:*d startdate
c endif
c else
c move out daynum
c move outmth mthnum
c move outyear yearnum
c eval yearnum = yearnum - 1
c eval mthnum = mthnum - 1
c adddur yearnum:*y blankdate
c adddur mthnum:*m blankdate
c eval startdate = blankdate
c eval yearnum = yearnum + 1
c eval mthnum = mthnum + 1
c endif
c eval curmnth = mthnum
c eval curyear = yearnum
c endsr
*-------------------------------------------------------------------
|
|
|
|
|
|
