Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping
Routine: PRSAPPU

# PRSAPPU.m

Go to the documentation of this file.
```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
```