source: WorldVistAEHR/trunk/r/PAID-PRS/PRSARC06.m@ 1076

Last change on this file since 1076 was 613, checked in by George Lilly, 16 years ago

initial load of WorldVistAEHR
File size: 6.5 KB
Line 
1PRSARC06 ;WOIFO/JAH - Recess Tracking ListManger Inteface ;10/16/06
2 ;;4.0;PAID;**112**;Sep 21, 1995;Build 54
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5MAIN(LSTART,LISTI,LINE,PRSDT,PRSFYRNG) ; BUILD LIST OF CALENDER FROM PP WITH PRSDT
6 ; THROUGH PP CONTAINING SEPTEMBER 30
7 ;
8 ; PRSNMDT - date for new month
9 ;
10 ; Q:$G(PRSOUT)=1
11 N FIRSTPP,PRSNMDT,FFPPE,LFPPE,EOFYDT,OUT,PRSDY,PRSMO,PRSNXTMO,PRSYR
12 ;
13 ; Get PP with PRSDT and convert PRSDT to the 1st day of that pp
14 ;
15 S FIRSTPP=$$GETPPDY^PRSARC04(PRSDT)
16 S FFPPE=$P(FIRSTPP,U,2)
17 S (PRSDT,PRSNMDT)=$P(FIRSTPP,U,1)
18 ;
19 ; lookup which week of the fiscal year the schedule begins
20 ; this week # will be the first selectable item in the list
21 ;
22 S (LSTART,LISTI)=$G(FMWKS(PRSDT))
23 ;
24 ; Get the last PP of the fiscal year and it's last day.
25 S LFPPE=$P(PRSFYRNG,U,4)
26 S EOFYDT=$P(PRSFYRNG,U,2)
27 ;
28 ; if the first week in the AWS schedule is not both the 1st day
29 ; of a PP and the first day of the month, then we need
30 ; special code for that month, so that a partial month is used
31 ; including only the pps that are part of the schedule.
32 ;
33 S (OUT,LINE,MONTHCNT)=0
34 I $E(PRSDT,6,7)'="01" D
35 . S STARTDAY=$E(PRSDT,6,7)
36 . D ARAYMO(.LISTI,.LINE,PRSDT,MONTHCNT,STARTDAY,0)
37 . S PRSMO=$E(PRSDT,4,5),PRSYR=$E(PRSDT,1,3),PRSDY=$E(PRSDT,6,7)
38 . S PRSNXTMO=PRSMO+1 I $L(PRSNXTMO)=1 S PRSNXTMO="0"_PRSNXTMO
39 . S PRSNMDT=$S(PRSMO=12:PRSYR+1_"01"_PRSDY,1:PRSYR_PRSNXTMO_"01")
40 ;
41 ; loop through the calendar building list items for every week in
42 ; the year until we reach october. All agreements are through
43 ; the end of the fiscal year.
44 ;
45 S OUT=0
46 F D Q:OUT
47 . S MONTHCNT=MONTHCNT+1
48 . D ARAYMO(.LISTI,.LINE,PRSNMDT,MONTHCNT,1,0)
49 . S PRSMO=$E(PRSNMDT,4,5),PRSYR=$E(PRSNMDT,1,3),PRSDY=$E(PRSNMDT,6,7)
50 . S PRSNXTMO=PRSMO+1 I $L(PRSNXTMO)=1 S PRSNXTMO="0"_PRSNXTMO
51 . S PRSNMDT=$S(PRSMO=12:PRSYR+1_"01"_PRSDY,1:PRSYR_PRSNXTMO_"01")
52 . ;if we hit september 30 or october quit
53 . I PRSNXTMO=10!(PRSNMDT>EOFYDT) S OUT=1
54 ;
55 ; Include any weeks in October that are part of the PP
56 ; with September 30, thus the fiscal year spills into october by
57 ; no more than 13 days
58 ;
59 I PRSNXTMO=10&(PRSNMDT'>EOFYDT) D
60 . S MONTHCNT=MONTHCNT+1
61 . D ARAYMO(.LISTI,.LINE,PRSNMDT,MONTHCNT,1,+$E(EOFYDT,6,7))
62 Q
63 ;= = = = = = = = = = = = = = = = = = = = = = = = = = =
64 ;
65ARAYMO(LISTI,LINE,PRSDT,MONTHCNT,STARTDAY,SHORT) ;SILENT CALL TO PLACE MONTH IN ARRAY
66 ; INPUT: PRSDT - must be fileman date
67 ; SHORT - set to # of days to show if a short month
68 ; is desired. i.e. to stop listing after the
69 ; first PP then specify the # of
70 ; days to that date from the 1st of the month
71 ;
72 N X,Y,%DT,DAY1,Y,MONTH,DAYS,YEAR,FIRSTDAY,LASTDAY,COUNT,HDR
73 S X=PRSDT D ^%DT Q:Y<0
74 S MONTH=$E(PRSDT,4,5),YEAR=$E(PRSDT,1,3)+1700
75 I SHORT D
76 . S DAYS=SHORT
77 E D
78 . S DAYS=$$DAYSINMO(YEAR,MONTH)
79 S FIRSTDAY=$E(PRSDT,1,5)_"01",LASTDAY=$E(PRSDT,1,5)_DAYS
80 ;
81 ;Get day #s of pps in month
82 N PPS
83 I FIRSTDAY<3130000 D GETPPS(FIRSTDAY,LASTDAY)
84 S DAY1=$$WEEKDAY1(PRSDT)
85 S HDR=$$GETHEAD(Y)
86 S LINE=LINE+1
87 S ^TMP("PRSARC",$J,LINE,0)=" ============="_HDR_"============"
88 ;
89 D DISPMO(.LISTI,.LINE,DAY1,DAYS,1,STARTDAY)
90 ;S LINE=LINE+1
91 ;D HOLIDAY
92 Q
93 ;
94 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
95DISPMO(LISTI,LINE,DAYNO,NODAYS,SKPW1,STRTDY) ;store a month into an array
96 ;SAMPLE CALL: D DISPMO(4,30,.L,0) Produces a 30 day month with day 1
97 ; beginning on Wednesday.
98 ;SAMPLE CALL: D DISPMO(4,30,.L,1) Produces a 30 day month starting
99 ; in week 2 Sunday--day 5
100 ;
101 ;INPUT:
102 ; DAYNO : integer value of weekday (0=sun,1=mon,2=tues,...,6=sat)
103 ; NODAYS: integer value of days in month, i.e. 30 days has sept...
104 ; SKIPW1: set to true if you want to skip partial 1st week
105 ; STRTDY: set to day of month to start calendar.
106 ;
107 N DAYS,DAYPOS,I,PPOFFSET,CNTDWN,BLNKS,LEADBLNK,WRTAB
108 S PPOFFSET=" ",CNTDWN=NODAYS
109 ;
110 ; keep track of selectable items in the list (LISTI) and
111 ; lines in the list
112 ;
113 ; start with second week when SKPW1 is true and the first week
114 ; of the month isn't a full week.
115 ; also I STARTDAY is > 1 then use it (we only want a partial month)
116 I (STRTDY=1)&SKPW1&(DAYNO'=0) S STRTDY=8-DAYNO
117 F I=STRTDY:1:NODAYS D
118 . S DAYPOS=(DAYNO+I-1)#7
119 . I DAYPOS=0 D
120 .. S LINE=LINE+1
121 .. S LEADBLNK=$E(" ",1,(3-$L(LISTI)))
122 .. S BLNKS=" "
123 .. I $G(PPS(I))'="" D
124 ... ; index of items that are selectable (weeks only, no month heads)
125 ... S ^TMP("PRSLI",$J,LISTI)=LINE
126 ... ; ListManager's items
127 ... S ^TMP("PRSARC",$J,LINE,0)=LEADBLNK_LISTI_BLNKS_PPS(I)
128 .. E D
129 ... S ^TMP("PRSLI",$J,LISTI)=LINE
130 ... S ^TMP("PRSARC",$J,LINE,0)=LEADBLNK_LISTI_BLNKS_PPOFFSET
131 .. S LISTI=LISTI+1
132 . I ($G(CNTDWN)>0) D
133 .. S WRTAB=$S($L(I)=2:" ",1:" ")
134 .. S ^TMP("PRSARC",$J,LINE,0)=$G(^TMP("PRSARC",$J,LINE,0))_WRTAB_I
135 .. S CNTDWN=CNTDWN-1
136 ;
137 ; add first days of next month to the last week
138 ;
139 I DAYPOS'=6 D
140 . F I=1:1:7-(DAYPOS+1) S ^TMP("PRSARC",$J,LINE,0)=$G(^TMP("PRSARC",$J,LINE,0))_" "_I
141 Q
142 ;
143 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
144 ;
145GETPPS(FIRSTDAY,LASTDAY) ;
146 N D1,PPE,PPDAY,PPI,PP4Y
147 S D1=FIRSTDAY D PP^PRSAPPU
148 D NX^PRSAPPU
149 I D1<FIRSTDAY S PPE=$E($$NXTPP^PRSAPPU(PPE),3,7) D NX^PRSAPPU
150 S PPDAY=+$E(D1,6,7)
151 S PPS(PPDAY)=PPE
152 F D Q:D1>LASTDAY
153 . S PPE=$E($$NXTPP^PRSAPPU(PPE),3,7) D NX^PRSAPPU
154 . Q:D1>LASTDAY
155 . S PPDAY=+$E(D1,6,7)
156 . S PPS(PPDAY)=PPE
157 Q
158 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
159 ;
160GETHEAD(Y) ;
161 N YEAR,MONTH,HDR,LENOFDT
162 S HDR=$$FMTE^XLFDT(Y,"1D")
163 S MONTH=$P(HDR," ")
164 S LENOFDT=$L(HDR," ")
165 S YEAR=$P(HDR," ",LENOFDT)
166 Q MONTH_" "_YEAR
167 ;
168 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
169 ;
170WEEKDAY1(ZDATE) ;get the weekday of the 1st day of the month
171 ; INPUT: ZDATE - FileMan date, used as the month to display
172 ; OUTPUT: return - Integer corresponding to day of week
173 ; (i.e. Sunday[1], Monday[2]) for the 1st day of
174 ; the month
175 S ZDATE=$E(ZDATE,1,5)_"01"
176 Q $$DOW^XLFDT(ZDATE,1)
177 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
178 ;
179DAYSINMO(Y,M) ; Return # of days in month based on year and month
180 ; Input: Y = year in 4 digit format between 1700 and 3000
181 ; M = month expressed as an integer from 1 to 12 (Jan - Dec)
182 ;
183 N GOODY,GOODM S (GOODY,GOODM)=0
184 I Y<2700,Y>1700 S GOODY=1
185 I M>0,M<13 S GOODM=1
186 Q:'(GOODM&GOODY) 0
187 Q $P("31^"_(28+$$LEAPYR^PRSLIB00(YEAR))_"^31^30^31^30^31^31^30^31^30^31",U,MONTH)
Note: See TracBrowser for help on using the repository browser.