PRSAPPU ; HISC/REL,WIRMFO/JAH - Calculate Pay Period; 22-JAN-1998
;;4.0;PAID;**19,22,35,136,150**;Sep 21, 1995;Build 1
;;Per VA Directive 6402, this routine should not be modified
;====================================================================
PP ;Calculate Pay Period from a FileMan date.
;
; Input : D1 = FileMan Date
; Output : D1 - unchanged
; PPI = internal entry of pay period if available else undef.
; PPE = Pay period that D1 falls in, formatted yy-pp.
; PP4Y = Pay period with 4 digit year: yyyy-pp.
; DAY = Day # of D1 within PPE
;
; 1. Get 1st day of leave year (X2) that the date D1 falls in.
; 2. Reserve 2 and 4 digit year to build pay period.
; 3. Find # of days between 1st day & D1 and divide by 14
; to determine pay period #. Mod to find day w/in pp.
; 4. Build Pay period with year and pay period #.
;
N Y,K,X1,X2,X
;
S Y=$P($T(DAT),";;",2)
F K=1:1:28 Q:D1<$P(Y,",",K)
S X2=$P(Y,",",K-1)
;
S PPE=$E(X2,2,3),PP4Y=$E(X2,1,3)+1700
;
S X1=D1
D ^%DTC
S Y=X\14+1,DAY=X#14+1
;
S PPE=PPE_"-"_$S(Y<10:"0"_Y,1:Y)
S PPI=$O(^PRST(458,"B",PPE,0))
S PP4Y=PP4Y_"-"_$P(PPE,"-",2)
;
Q
;====================================================================
NX ; Calculate Date of 1st day of Pay Period.
;
; INPUT: PPE = Pay Period formatted YY-PP.
; OUTPUT: D1 = FileMan Date of 1st day of pay period.
;
N Y,K,X1,X2
;
S Y=$P($T(DAT),";;",2)
F K=1:1:28 Q:$E($P(Y,",",K),2,3)=$E(PPE,1,2)
S X1=$P(Y,",",K),X2=14*($E(PPE,4,5)-1) D C^%DTC
S D1=X Q
;====================================================================
DTP ; Printable Date
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)
K % Q
;====================================================================
;These FileMan dates correspond to 1st day of pay period #1
;of respective years. *150 - updated to extend to 2023
;
DAT ;;2960107,2970105,2980104,2990103,3000102,3010114,3020113,3030112,3040111,3050109,3060108,3070107,3080106,3090104,3100103,3110102,3120101,3130113,3140112,3150111,3160110,3170108,3180107,3190106,3200105,3210103,3220102,3230101
;
;====================================================================
PREP(CURP) ;given a pay period, return the previous pay period.
; WARNING: This call only valid for years that are in the seed
; range of the FileMan dates on the DAT^PRSAPPU line.
; If pay period passed is out of this range then
; 0 is returned.
;
;Input: CURP = Pay period, passed in format YY-PP or YYYY-PP
;Output: function returns previous pay period in YYYY-PP format.
;
N PPE,PPI,D1,DAY,INYR,RANGE,FIRSTPP,INPP
;
;validate input - pay period and year
;
Q:'$$VALIDPP(CURP) 0
S INPP=$P(CURP,"-",2)
S INYR=$P(CURP,"-")
S INYR=$E(INYR,$L(INYR)-1,$L(INYR))
S PPE=INYR_"-"_INPP
;
; Handle special case of 1ST PAY PERIOD iN the VALID RANGE
S RANGE=$P($T(DAT),";;",2)
S FIRSTPP=$E($P(RANGE,","),2,3)_"-01"
Q:(PPE=FIRSTPP) $E($P(RANGE,","),1,3)+1700_"-26"
;
;Get 1st date of input pay period.
;
D NX
;
;Subtract 14 days from current to get 1st day of previous pay period.
S X1=D1,X2=-14 D C^%DTC S D1=X
D PP
Q PP4Y
;
;====================================================================
NXTPP(CURP) ;given a payperiod, return the NEXT payperiod. YYYY-PP
; WARNING: This call only valid for years that are in the seed
; range of the FileMan dates on the DAT^PRSAPPU line.
; If pay period passed is out of this range then
; 0 is returned.
;
;Input: CURP = Pay period, passed in format YY-PP or YYYY-PP
;Output: function returns previous pay period in YYYY-PP format.
;
N PPE,PPI,D1,X1,X2,INPP,INYR,D1
;
Q:'$$VALIDPP(CURP) 0
;
;Get 1st date of current pay period.
S INPP=$P(CURP,"-",2)
S INYR=$P(CURP,"-")
S INYR=$E(INYR,$L(INYR)-1,$L(INYR))
S PPE=INYR_"-"_INPP
D NX
;
;Add 14 days to current to get 1st day of next pay period.
S X1=D1,X2=14 D C^%DTC S D1=X
D PP
Q PP4Y
;====================================================================
VALIDPP(PP) ;Valid pay period must be in form YY-PP or YYYY-PP where
; pp is pay periods 01-26 and
; yy or yyyy are years in the FileMan dates at DAT^PRSAPPU
;
N VALID,INVALID,VALYRS,RANGE,INCR,INPP,INYR,TESTYR
S VALID=1,INVALID=0
;
;validate input - year and pay period
;
S VALYRS=","
S RANGE=$P($T(DAT),";;",2)
F INCR=1:1:$L(RANGE,",") S VALYRS=VALYRS_$E($P(RANGE,",",INCR),2,3)_","
S INYR=$P(PP,"-")
I '(($L(INYR)=2)!($L(INYR)=4)) Q INVALID
S INYR=$E(INYR,$L(INYR)-1,$L(INYR))
S TESTYR=","_INYR_","
I VALYRS'[TESTYR Q INVALID
;
S INPP=$P(PP,"-",2)
;
S VALPPS=",01,02,03,04,05,06,07,08,09,"
S TESTINPP=","_INPP_","
I '((VALPPS[TESTINPP)!((INPP>9)&(INPP<28))) Q INVALID
;
; pay period 27 is not always valid.
;
I INPP=27 I $P($$NXTPP(INYR_"-26"),"-",2)'=27 Q INVALID
Q VALID
;
;====================================================================
PPRANGE(STARTPP,ENDPP,STPP4Y,ENDPP4Y) ;get a pay period range from input.
; INPUT: none
; OUTPUT: STARTPP = 1st pay period in range. 0 on abnormal exit.
; ENDPP = 2ND pay period in range. 0 on abnormal exit.
;
; -Ask user to select beginning and ending pay periods from the
; pay periods that are on file.
; -Compare dates of 1st day of each of the input pay periods
; to ensure that the beginning pay period input is LESS THAN OR = TO
; the ending pay period input.
;
N OUT,OK
S (OUT,OK)=0
;
F I=0:0 Q:(OK!OUT) D
.N DIC,FR,X,Y,TO,DAY,PPE,PPI,PP4Y,D1,STRTDAY1,ENDDAY1
.S (STARTPP,ENDPP)=0
.;
.S D1=DT D PP S DIC("B")=$E($$PREP(PPE),3,7)
.S DIC="^PRST(458,"
.S DIC(0)="AEQZ",DIC("A")="Enter Beginning Pay Period: "
.D ^DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S OUT=1
.Q:OUT
.S STARTPP=Y(0,0)
.;
.; ask user for 2nd pay period in range. Use default of
.; the pay period they selected for the 1st pp.
.;
.S DIC("B")=STARTPP,DIC("A")="Enter Ending Pay Period: "
.D ^DIC I $D(DTOUT)!$D(DUOUT) S OUT=1
.Q:OUT
.S ENDPP=Y(0,0)
.;
.;Get 1st day of selected pay periods. Compare the dates to ensure
.;that a valid range has been entered.
.;
.S PPE=STARTPP D NX S STRTDAY1=D1
.S PPE=ENDPP D NX S ENDDAY1=D1
.I ENDDAY1-STRTDAY1<0 D
.. W !,"Invalid pay period range."
.. W !,"Ending pay period should be later than or equal to beginning pay period."
.E D
.. S D1=STRTDAY1 D PP^PRSAPPU S STPP4Y=PP4Y
.. S D1=ENDDAY1 D PP S ENDPP4Y=PP4Y
.. S OK=1
I OUT S (STARTPP,ENDPP,ENDPP4Y,STPP4Y)=0
;
Q
;==============================================================
IC(YY,FMT,FW,BDT) ;Infer Century from 2-digit year
; YY - 2 digit year
; FMT - (optional) format of returned value (DEFAULT 3)
; 3 for YYY (fileman year .i.e. first numbers of fileman date)
; 4 for YYYY (standard year)
; FW - (optional) # of future years from base in window (DEFAULT 20)
; BDT - (optional) base date (fileman) for sliding window (DEFAULT DT)
;
N FMY
I YY'?2N Q "" ; invalid 2-digit year - return null value
I $G(FMT)'=3&($G(FMT)'=4) S FMT=3
I $G(FW)'?1.2N S FW=20
I $G(BDT)'?7N S BDT=DT
I BDT'>1000000 Q "" ; invalid base date
; start with century of base date and adjust if necessary
S FMY=$E(BDT)+$S($E(BDT,2,3)-YY>(99-FW):1,$E(BDT,2,3)-YY<-FW:-1,1:0)_YY
Q $S(FMT=4:FMY+1700,1:FMY)
;
;PRSZ
;==============================================================
P35POST ;PRS*4.0*35 post install - execute set logic on new AB x-ref.
;
I $$PATCH^XPDUTL("PRS*4.0*35") D MSSG(0) Q
N FILE D MSSG(1) F FILE=458,459 D XREF4YR(FILE)
Q
;==============================================================
MSSG(FLAG) ;PRS*4.0*35 - OUTPUT POST INSTALLATION MESSAGE.
N MSSG
I FLAG S MSSG="Updating AB cross reference in Files 458 and 459."
E S MSSG="AB X-ref NOT built. Built during earlier PRS*4.0*35 install."
D MES^XPDUTL(" "_MSSG)
Q
;==============================================================
XREF4YR(F) ;SET AB 4DIGIT YEAR XREF OF FILE 458 OR 459.
;
Q:'((F=458)!(F=459))
N DIK S DIK="^PRST("_F_",",DIK(1)=".01^AB" D ENALL^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSAPPU 8344 printed Dec 13, 2024@02:23:58 Page 2
PRSAPPU ; HISC/REL,WIRMFO/JAH - Calculate Pay Period; 22-JAN-1998
+1 ;;4.0;PAID;**19,22,35,136,150**;Sep 21, 1995;Build 1
+2 ;;Per VA Directive 6402, this routine should not be modified
+3 ;====================================================================
PP ;Calculate Pay Period from a FileMan date.
+1 ;
+2 ; Input : D1 = FileMan Date
+3 ; Output : D1 - unchanged
+4 ; PPI = internal entry of pay period if available else undef.
+5 ; PPE = Pay period that D1 falls in, formatted yy-pp.
+6 ; PP4Y = Pay period with 4 digit year: yyyy-pp.
+7 ; DAY = Day # of D1 within PPE
+8 ;
+9 ; 1. Get 1st day of leave year (X2) that the date D1 falls in.
+10 ; 2. Reserve 2 and 4 digit year to build pay period.
+11 ; 3. Find # of days between 1st day & D1 and divide by 14
+12 ; to determine pay period #. Mod to find day w/in pp.
+13 ; 4. Build Pay period with year and pay period #.
+14 ;
+15 NEW Y,K,X1,X2,X
+16 ;
+17 SET Y=$PIECE($TEXT(DAT),";;",2)
+18 FOR K=1:1:28
if D1<$PIECE(Y,",",K)
QUIT
+19 SET X2=$PIECE(Y,",",K-1)
+20 ;
+21 SET PPE=$EXTRACT(X2,2,3)
SET PP4Y=$EXTRACT(X2,1,3)+1700
+22 ;
+23 SET X1=D1
+24 DO ^%DTC
+25 SET Y=X\14+1
SET DAY=X#14+1
+26 ;
+27 SET PPE=PPE_"-"_$SELECT(Y<10:"0"_Y,1:Y)
+28 SET PPI=$ORDER(^PRST(458,"B",PPE,0))
+29 SET PP4Y=PP4Y_"-"_$PIECE(PPE,"-",2)
+30 ;
+31 QUIT
+32 ;====================================================================
NX ; Calculate Date of 1st day of Pay Period.
+1 ;
+2 ; INPUT: PPE = Pay Period formatted YY-PP.
+3 ; OUTPUT: D1 = FileMan Date of 1st day of pay period.
+4 ;
+5 NEW Y,K,X1,X2
+6 ;
+7 SET Y=$PIECE($TEXT(DAT),";;",2)
+8 FOR K=1:1:28
if $EXTRACT($PIECE(Y,",",K),2,3)=$EXTRACT(PPE,1,2)
QUIT
+9 SET X1=$PIECE(Y,",",K)
SET X2=14*($EXTRACT(PPE,4,5)-1)
DO C^%DTC
+10 SET D1=X
QUIT
+11 ;====================================================================
DTP ; Printable Date
+1 SET %=X
SET Y=$JUSTIFY(+$EXTRACT(X,6,7),2)_"-"_$PIECE("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$EXTRACT(X,4,5))_"-"_$EXTRACT(X,2,3)
+2 KILL %
QUIT
+3 ;====================================================================
+4 ;These FileMan dates correspond to 1st day of pay period #1
+5 ;of respective years. *150 - updated to extend to 2023
+6 ;
DAT ;;2960107,2970105,2980104,2990103,3000102,3010114,3020113,3030112,3040111,3050109,3060108,3070107,3080106,3090104,3100103,3110102,3120101,3130113,3140112,3150111,3160110,3170108,3180107,3190106,3200105,3210103,3220102,3230101
+1 ;
+2 ;====================================================================
PREP(CURP) ;given a pay period, return the previous pay period.
+1 ; WARNING: This call only valid for years that are in the seed
+2 ; range of the FileMan dates on the DAT^PRSAPPU line.
+3 ; If pay period passed is out of this range then
+4 ; 0 is returned.
+5 ;
+6 ;Input: CURP = Pay period, passed in format YY-PP or YYYY-PP
+7 ;Output: function returns previous pay period in YYYY-PP format.
+8 ;
+9 NEW PPE,PPI,D1,DAY,INYR,RANGE,FIRSTPP,INPP
+10 ;
+11 ;validate input - pay period and year
+12 ;
+13 if '$$VALIDPP(CURP)
QUIT 0
+14 SET INPP=$PIECE(CURP,"-",2)
+15 SET INYR=$PIECE(CURP,"-")
+16 SET INYR=$EXTRACT(INYR,$LENGTH(INYR)-1,$LENGTH(INYR))
+17 SET PPE=INYR_"-"_INPP
+18 ;
+19 ; Handle special case of 1ST PAY PERIOD iN the VALID RANGE
+20 SET RANGE=$PIECE($TEXT(DAT),";;",2)
+21 SET FIRSTPP=$EXTRACT($PIECE(RANGE,","),2,3)_"-01"
+22 if (PPE=FIRSTPP)
QUIT $EXTRACT($PIECE(RANGE,","),1,3)+1700_"-26"
+23 ;
+24 ;Get 1st date of input pay period.
+25 ;
+26 DO NX
+27 ;
+28 ;Subtract 14 days from current to get 1st day of previous pay period.
+29 SET X1=D1
SET X2=-14
DO C^%DTC
SET D1=X
+30 DO PP
+31 QUIT PP4Y
+32 ;
+33 ;====================================================================
NXTPP(CURP) ;given a payperiod, return the NEXT payperiod. YYYY-PP
+1 ; WARNING: This call only valid for years that are in the seed
+2 ; range of the FileMan dates on the DAT^PRSAPPU line.
+3 ; If pay period passed is out of this range then
+4 ; 0 is returned.
+5 ;
+6 ;Input: CURP = Pay period, passed in format YY-PP or YYYY-PP
+7 ;Output: function returns previous pay period in YYYY-PP format.
+8 ;
+9 NEW PPE,PPI,D1,X1,X2,INPP,INYR,D1
+10 ;
+11 if '$$VALIDPP(CURP)
QUIT 0
+12 ;
+13 ;Get 1st date of current pay period.
+14 SET INPP=$PIECE(CURP,"-",2)
+15 SET INYR=$PIECE(CURP,"-")
+16 SET INYR=$EXTRACT(INYR,$LENGTH(INYR)-1,$LENGTH(INYR))
+17 SET PPE=INYR_"-"_INPP
+18 DO NX
+19 ;
+20 ;Add 14 days to current to get 1st day of next pay period.
+21 SET X1=D1
SET X2=14
DO C^%DTC
SET D1=X
+22 DO PP
+23 QUIT PP4Y
+24 ;====================================================================
VALIDPP(PP) ;Valid pay period must be in form YY-PP or YYYY-PP where
+1 ; pp is pay periods 01-26 and
+2 ; yy or yyyy are years in the FileMan dates at DAT^PRSAPPU
+3 ;
+4 NEW VALID,INVALID,VALYRS,RANGE,INCR,INPP,INYR,TESTYR
+5 SET VALID=1
SET INVALID=0
+6 ;
+7 ;validate input - year and pay period
+8 ;
+9 SET VALYRS=","
+10 SET RANGE=$PIECE($TEXT(DAT),";;",2)
+11 FOR INCR=1:1:$LENGTH(RANGE,",")
SET VALYRS=VALYRS_$EXTRACT($PIECE(RANGE,",",INCR),2,3)_","
+12 SET INYR=$PIECE(PP,"-")
+13 IF '(($LENGTH(INYR)=2)!($LENGTH(INYR)=4))
QUIT INVALID
+14 SET INYR=$EXTRACT(INYR,$LENGTH(INYR)-1,$LENGTH(INYR))
+15 SET TESTYR=","_INYR_","
+16 IF VALYRS'[TESTYR
QUIT INVALID
+17 ;
+18 SET INPP=$PIECE(PP,"-",2)
+19 ;
+20 SET VALPPS=",01,02,03,04,05,06,07,08,09,"
+21 SET TESTINPP=","_INPP_","
+22 IF '((VALPPS[TESTINPP)!((INPP>9)&(INPP<28)))
QUIT INVALID
+23 ;
+24 ; pay period 27 is not always valid.
+25 ;
+26 IF INPP=27
IF $PIECE($$NXTPP(INYR_"-26"),"-",2)'=27
QUIT INVALID
+27 QUIT VALID
+28 ;
+29 ;====================================================================
PPRANGE(STARTPP,ENDPP,STPP4Y,ENDPP4Y) ;get a pay period range from input.
+1 ; INPUT: none
+2 ; OUTPUT: STARTPP = 1st pay period in range. 0 on abnormal exit.
+3 ; ENDPP = 2ND pay period in range. 0 on abnormal exit.
+4 ;
+5 ; -Ask user to select beginning and ending pay periods from the
+6 ; pay periods that are on file.
+7 ; -Compare dates of 1st day of each of the input pay periods
+8 ; to ensure that the beginning pay period input is LESS THAN OR = TO
+9 ; the ending pay period input.
+10 ;
+11 NEW OUT,OK
+12 SET (OUT,OK)=0
+13 ;
+14 FOR I=0:0
if (OK!OUT)
QUIT
Begin DoDot:1
+15 NEW DIC,FR,X,Y,TO,DAY,PPE,PPI,PP4Y,D1,STRTDAY1,ENDDAY1
+16 SET (STARTPP,ENDPP)=0
+17 ;
+18 SET D1=DT
DO PP
SET DIC("B")=$EXTRACT($$PREP(PPE),3,7)
+19 SET DIC="^PRST(458,"
+20 SET DIC(0)="AEQZ"
SET DIC("A")="Enter Beginning Pay Period: "
+21 DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
SET OUT=1
+22 if OUT
QUIT
+23 SET STARTPP=Y(0,0)
+24 ;
+25 ; ask user for 2nd pay period in range. Use default of
+26 ; the pay period they selected for the 1st pp.
+27 ;
+28 SET DIC("B")=STARTPP
SET DIC("A")="Enter Ending Pay Period: "
+29 DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)
SET OUT=1
+30 if OUT
QUIT
+31 SET ENDPP=Y(0,0)
+32 ;
+33 ;Get 1st day of selected pay periods. Compare the dates to ensure
+34 ;that a valid range has been entered.
+35 ;
+36 SET PPE=STARTPP
DO NX
SET STRTDAY1=D1
+37 SET PPE=ENDPP
DO NX
SET ENDDAY1=D1
+38 IF ENDDAY1-STRTDAY1<0
Begin DoDot:2
+39 WRITE !,"Invalid pay period range."
+40 WRITE !,"Ending pay period should be later than or equal to beginning pay period."
End DoDot:2
+41 IF '$TEST
Begin DoDot:2
+42 SET D1=STRTDAY1
DO PP^PRSAPPU
SET STPP4Y=PP4Y
+43 SET D1=ENDDAY1
DO PP
SET ENDPP4Y=PP4Y
+44 SET OK=1
End DoDot:2
End DoDot:1
+45 IF OUT
SET (STARTPP,ENDPP,ENDPP4Y,STPP4Y)=0
+46 ;
+47 QUIT
+48 ;==============================================================
IC(YY,FMT,FW,BDT) ;Infer Century from 2-digit year
+1 ; YY - 2 digit year
+2 ; FMT - (optional) format of returned value (DEFAULT 3)
+3 ; 3 for YYY (fileman year .i.e. first numbers of fileman date)
+4 ; 4 for YYYY (standard year)
+5 ; FW - (optional) # of future years from base in window (DEFAULT 20)
+6 ; BDT - (optional) base date (fileman) for sliding window (DEFAULT DT)
+7 ;
+8 NEW FMY
+9 ; invalid 2-digit year - return null value
IF YY'?2N
QUIT ""
+10 IF $GET(FMT)'=3&($GET(FMT)'=4)
SET FMT=3
+11 IF $GET(FW)'?1.2N
SET FW=20
+12 IF $GET(BDT)'?7N
SET BDT=DT
+13 ; invalid base date
IF BDT'>1000000
QUIT ""
+14 ; start with century of base date and adjust if necessary
+15 SET FMY=$EXTRACT(BDT)+$SELECT($EXTRACT(BDT,2,3)-YY>(99-FW):1,$EXTRACT(BDT,2,3)-YY<-FW:-1,1:0)_YY
+16 QUIT $SELECT(FMT=4:FMY+1700,1:FMY)
+17 ;
+18 ;PRSZ
+19 ;==============================================================
P35POST ;PRS*4.0*35 post install - execute set logic on new AB x-ref.
+1 ;
+2 IF $$PATCH^XPDUTL("PRS*4.0*35")
DO MSSG(0)
QUIT
+3 NEW FILE
DO MSSG(1)
FOR FILE=458,459
DO XREF4YR(FILE)
+4 QUIT
+5 ;==============================================================
MSSG(FLAG) ;PRS*4.0*35 - OUTPUT POST INSTALLATION MESSAGE.
+1 NEW MSSG
+2 IF FLAG
SET MSSG="Updating AB cross reference in Files 458 and 459."
+3 IF '$TEST
SET MSSG="AB X-ref NOT built. Built during earlier PRS*4.0*35 install."
+4 DO MES^XPDUTL(" "_MSSG)
+5 QUIT
+6 ;==============================================================
XREF4YR(F) ;SET AB 4DIGIT YEAR XREF OF FILE 458 OR 459.
+1 ;
+2 if '((F=458)!(F=459))
QUIT
+3 NEW DIK
SET DIK="^PRST("_F_","
SET DIK(1)=".01^AB"
DO ENALL^DIK
+4 QUIT
