source: FOIAVistA/tag/r/PAID-PRS/PRSAPPU.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.8 KB
Line 
1PRSAPPU ; HISC/REL,WIRMFO/JAH - Calculate Pay Period; 22-JAN-1998
2 ;;4.0;PAID;**19,22,35**;Sep 21, 1995
3 ;====================================================================
4PP ;Calculate Pay Period from a FileMan date.
5 ;
6 ; Input : D1 = FileMan Date
7 ; Output : D1 - unchanged
8 ; PPI = internal entry of pay period if available else undef.
9 ; PPE = Pay period that D1 falls in, formatted yy-pp.
10 ; PP4Y = Pay period with 4 digit year: yyyy-pp.
11 ; DAY = Day # of D1 within PPE
12 ;
13 ; 1. Get 1st day of leave year (X2) that the date D1 falls in.
14 ; 2. Reserve 2 and 4 digit year to build pay period.
15 ; 3. Find # of days between 1st day & D1 and divide by 14
16 ; to determine pay period #. Mod to find day w/in pp.
17 ; 4. Build Pay period with year and pay period #.
18 ;
19 N Y,K,X1,X2,X
20 ;
21 S Y=$P($T(DAT),";;",2)
22 F K=1:1:23 Q:D1<$P(Y,",",K)
23 S X2=$P(Y,",",K-1)
24 ;
25 S PPE=$E(X2,2,3),PP4Y=$E(X2,1,3)+1700
26 ;
27 S X1=D1
28 D ^%DTC
29 S Y=X\14+1,DAY=X#14+1
30 ;
31 S PPE=PPE_"-"_$S(Y<10:"0"_Y,1:Y)
32 S PPI=$O(^PRST(458,"B",PPE,0))
33 S PP4Y=PP4Y_"-"_$P(PPE,"-",2)
34 ;
35 Q
36 ;====================================================================
37NX ; Calculate Date of 1st day of Pay Period.
38 ;
39 ; INPUT: PPE = Pay Period formatted YY-PP.
40 ; OUTPUT: D1 = FileMan Date of 1st day of pay period.
41 ;
42 N Y,K,X1,X2
43 ;
44 S Y=$P($T(DAT),";;",2)
45 F K=1:1:23 Q:$E($P(Y,",",K),2,3)=$E(PPE,1,2)
46 S X1=$P(Y,",",K),X2=14*($E(PPE,4,5)-1) D C^%DTC
47 S D1=X Q
48 ;====================================================================
49DTP ; Printable Date
50 S %=X,Y=$J(+$E(X,6,7),2)_"-"_$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(X,4,5))_"-"_$E(X,2,3)
51 K % Q
52 ;====================================================================
53 ;These FileMan dates correspond to 1st day of pay period #1
54 ;of respective years.
55 ;
56DAT ;;2910113,2920112,2930110,2940109,2950108,2960107,2970105,2980104,2990103,3000102,3010114,3020113,3030112,3040111,3050109,3060108,3070107,3080106,3090104,3100103,3110102,3120101,3130113
57 ;
58 ;====================================================================
59PREP(CURP) ;given a pay period, return the previous pay period.
60 ; WARNING: This call only valid for years that are in the seed
61 ; range of the FileMan dates on the DAT^PRSAPPU line.
62 ; If pay period passed is out of this range then
63 ; 0 is returned.
64 ;
65 ;Input: CURP = Pay period, passed in format YY-PP or YYYY-PP
66 ;Output: function returns previous pay period in YYYY-PP format.
67 ;
68 N PPE,PPI,D1,DAY,INYR,RANGE,FIRSTPP,INPP
69 ;
70 ;validate input - pay period and year
71 ;
72 Q:'$$VALIDPP(CURP) 0
73 S INPP=$P(CURP,"-",2)
74 S INYR=$P(CURP,"-")
75 S INYR=$E(INYR,$L(INYR)-1,$L(INYR))
76 S PPE=INYR_"-"_INPP
77 ;
78 ; Handle special case of 1ST PAY PERIOD iN the VALID RANGE
79 S RANGE=$P($T(DAT),";;",2)
80 S FIRSTPP=$E($P(RANGE,","),2,3)_"-01"
81 Q:(PPE=FIRSTPP) $E($P(RANGE,","),1,3)+1700_"-26"
82 ;
83 ;Get 1st date of input pay period.
84 ;
85 D NX
86 ;
87 ;Subtract 14 days from current to get 1st day of previous pay period.
88 S X1=D1,X2=-14 D C^%DTC S D1=X
89 D PP
90 Q PP4Y
91 ;
92 ;====================================================================
93NXTPP(CURP) ;given a payperiod, return the NEXT payperiod. YYYY-PP
94 ; WARNING: This call only valid for years that are in the seed
95 ; range of the FileMan dates on the DAT^PRSAPPU line.
96 ; If pay period passed is out of this range then
97 ; 0 is returned.
98 ;
99 ;Input: CURP = Pay period, passed in format YY-PP or YYYY-PP
100 ;Output: function returns previous pay period in YYYY-PP format.
101 ;
102 N PPE,PPI,D1,X1,X2,INPP,INYR,D1
103 ;
104 Q:'$$VALIDPP(CURP) 0
105 ;
106 ;Get 1st date of current pay period.
107 S INPP=$P(CURP,"-",2)
108 S INYR=$P(CURP,"-")
109 S INYR=$E(INYR,$L(INYR)-1,$L(INYR))
110 S PPE=INYR_"-"_INPP
111 D NX
112 ;
113 ;Add 14 days to current to get 1st day of next pay period.
114 S X1=D1,X2=14 D C^%DTC S D1=X
115 D PP
116 Q PP4Y
117 ;====================================================================
118VALIDPP(PP) ;Valid pay period must be in form YY-PP or YYYY-PP where
119 ; pp is pay periods 01-26 and
120 ; yy or yyyy are years in the FileMan dates at DAT^PRSAPPU
121 ;
122 N VALID,INVALID,VALYRS,RANGE,INCR,INPP,INYR,TESTYR
123 S VALID=1,INVALID=0
124 ;
125 ;validate input - year and pay period
126 ;
127 S VALYRS=","
128 S RANGE=$P($T(DAT),";;",2)
129 F INCR=1:1:$L(RANGE,",") S VALYRS=VALYRS_$E($P(RANGE,",",INCR),2,3)_","
130 S INYR=$P(PP,"-")
131 I '(($L(INYR)=2)!($L(INYR)=4)) Q INVALID
132 S INYR=$E(INYR,$L(INYR)-1,$L(INYR))
133 S TESTYR=","_INYR_","
134 I VALYRS'[TESTYR Q INVALID
135 ;
136 S INPP=$P(PP,"-",2)
137 ;
138 S VALPPS=",01,02,03,04,05,06,07,08,09,"
139 S TESTINPP=","_INPP_","
140 I '((VALPPS[TESTINPP)!((INPP>9)&(INPP<28))) Q INVALID
141 ;
142 ; pay period 27 is not always valid.
143 ;
144 I INPP=27 I $P($$NXTPP(INYR_"-26"),"-",2)'=27 Q INVALID
145 Q VALID
146 ;
147 ;====================================================================
148PPRANGE(STARTPP,ENDPP,STPP4Y,ENDPP4Y) ;get a pay period range from input.
149 ; INPUT: none
150 ; OUTPUT: STARTPP = 1st pay period in range. 0 on abnormal exit.
151 ; ENDPP = 2ND pay period in range. 0 on abnormal exit.
152 ;
153 ; -Ask user to select beginning and ending pay periods from the
154 ; pay periods that are on file.
155 ; -Compare dates of 1st day of each of the input pay periods
156 ; to ensure that the beginning pay period input is LESS THAN OR = TO
157 ; the ending pay period input.
158 ;
159 N OUT,OK
160 S (OUT,OK)=0
161 ;
162 F I=0:0 Q:(OK!OUT) D
163 .N DIC,FR,X,Y,TO,DAY,PPE,PPI,PP4Y,D1,STRTDAY1,ENDDAY1
164 .S (STARTPP,ENDPP)=0
165 .;
166 .S D1=DT D PP S DIC("B")=$E($$PREP(PPE),3,7)
167 .S DIC="^PRST(458,"
168 .S DIC(0)="AEQZ",DIC("A")="Enter Beginning Pay Period: "
169 .D ^DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S OUT=1
170 .Q:OUT
171 .S STARTPP=Y(0,0)
172 .;
173 .; ask user for 2nd pay period in range. Use default of
174 .; the pay period they selected for the 1st pp.
175 .;
176 .S DIC("B")=STARTPP,DIC("A")="Enter Ending Pay Period: "
177 .D ^DIC I $D(DTOUT)!$D(DUOUT) S OUT=1
178 .Q:OUT
179 .S ENDPP=Y(0,0)
180 .;
181 .;Get 1st day of selected pay periods. Compare the dates to ensure
182 .;that a valid range has been entered.
183 .;
184 .S PPE=STARTPP D NX S STRTDAY1=D1
185 .S PPE=ENDPP D NX S ENDDAY1=D1
186 .I ENDDAY1-STRTDAY1<0 D
187 .. W !,"Invalid pay period range."
188 .. W !,"Ending pay period should be later than or equal to beginning pay period."
189 .E D
190 .. S D1=STRTDAY1 D PP^PRSAPPU S STPP4Y=PP4Y
191 .. S D1=ENDDAY1 D PP S ENDPP4Y=PP4Y
192 .. S OK=1
193 I OUT S (STARTPP,ENDPP,ENDPP4Y,STPP4Y)=0
194 ;
195 Q
196 ;==============================================================
197IC(YY,FMT,FW,BDT) ;Infer Century from 2-digit year
198 ; YY - 2 digit year
199 ; FMT - (optional) format of returned value (DEFAULT 3)
200 ; 3 for YYY (fileman year .i.e. first numbers of fileman date)
201 ; 4 for YYYY (standard year)
202 ; FW - (optional) # of future years from base in window (DEFAULT 20)
203 ; BDT - (optional) base date (fileman) for sliding window (DEFAULT DT)
204 ;
205 N FMY
206 I YY'?2N Q "" ; invalid 2-digit year - return null value
207 I $G(FMT)'=3&($G(FMT)'=4) S FMT=3
208 I $G(FW)'?1.2N S FW=20
209 I $G(BDT)'?7N S BDT=DT
210 I BDT'>1000000 Q "" ; invalid base date
211 ; start with century of base date and adjust if necessary
212 S FMY=$E(BDT)+$S($E(BDT,2,3)-YY>(99-FW):1,$E(BDT,2,3)-YY<-FW:-1,1:0)_YY
213 Q $S(FMT=4:FMY+1700,1:FMY)
214 ;
215 ;PRSZ
216 ;==============================================================
217P35POST ;PRS*4.0*35 post install - execute set logic on new AB x-ref.
218 ;
219 I $$PATCH^XPDUTL("PRS*4.0*35") D MSSG(0) Q
220 N FILE D MSSG(1) F FILE=458,459 D XREF4YR(FILE)
221 Q
222 ;==============================================================
223MSSG(FLAG) ;PRS*4.0*35 - OUTPUT POST INSTALLATION MESSAGE.
224 N MSSG
225 I FLAG S MSSG="Updating AB cross reference in Files 458 and 459."
226 E S MSSG="AB X-ref NOT built. Built during earlier PRS*4.0*35 install."
227 D MES^XPDUTL(" "_MSSG)
228 Q
229 ;==============================================================
230XREF4YR(F) ;SET AB 4DIGIT YEAR XREF OF FILE 458 OR 459.
231 ;
232 Q:'((F=458)!(F=459))
233 N DIK S DIK="^PRST("_F_",",DIK(1)=".01^AB" D ENALL^DIK
234 Q
Note: See TracBrowser for help on using the repository browser.