RPGIV @ Work

A unique site for RPG and System i Lovers

Welcome!

Hi, this site will provide all what you need in System i and RPG developments.

My Name is Chamara Withanachchi, System i Expert and RPG Developer. And in the field for last 11 years.

I hope you will find lot of valuable information from this site

Calender Program Print E-mail
User Rating: / 1
PoorBest 

Written by Chamara Withanachchi   
 H DATEDIT(*YMD) INDENT('| ')  DECEDIT(*JOBRUN)                             
H option(*NODEBUGIO)
*-------------------------------------------------------------------------
*
* Program Id : IDHLPCAL
* Title : ID Prompt for Calendar
* Author : Chamara Withanachchi
* Date : 2008/07/22
*
* NOTE:
*-------------------------------------------------------------------------

FIDHLPCAL 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 *-------------------------------------------------------------------
User Comments

Please login or register to add comments

<Previous   Next>