PRSADP2 ; HISC/REL-Display Employee Pay Period ;7/22/97
;;4.0;PAID;**21,28,46,114,132**;Sep 21, 1995;Build 13
;;Per VHA Directive 2004-038, this routine should not be modified.
PAY ; Payroll Entry
N PPERIOD
S PRSTLV=7
D TOP ; print header
P1 K DIC S DIC("A")="Select EMPLOYEE: ",DIC(0)="AEQM",DIC="^PRSPC("
W ! D ^DIC S DFN=+Y K DIC G:DFN<1 EX
S TLE=$P($G(^PRSPC(DFN,0)),"^",8)
S DIC="^PRST(458,",DIC(0)="AEQM",DIC("A")="Select PAY PERIOD: "
W ! D ^DIC K DIC G:Y<1 EX
S PPI=+Y
; 1st put pay period in YY-PP format 4 call 2 lookup old T&L.
S PPERIOD=$S(Y["-":$P(Y,"^",2),1:$P(^PRST(458,$P(Y,"^"),0),"^"))
D CHECKTLE(PPERIOD,DFN,.TLE) ;verify that T&L unit hasn't changed
D L1 ;ask device
G P1 ;ask for employee again
;====================================================================
TK ; TimeKeeper Entry
S PRSTLV=2 G T0
;====================================================================
SUP ; Supervisor Entry
S PRSTLV=3
T0 D TOP ; print header
D ^PRSAUTL G:TLI<1 EX
N PPERIOD
T1 K DIC S DIC("A")="Select EMPLOYEE: ",DIC(0)="AEQM",DIC="^PRSPC("
S DIC("S")="I $P(^(0),""^"",8)=TLE" S D="ATL"_TLE W ! D IX^DIC
S DFN=+Y K DIC G:DFN<1 EX
S %DT="AEPX",%DT("A")="Posting Date: ",%DT(0)=-DT W ! D ^%DT
G:Y<1 EX S D1=Y S Y=$G(^PRST(458,"AD",D1)),PPI=$P(Y,"^",1) G EX:PPI<1
; 1st put pay period in YY-PP format 4 call 2 lookup old T&L.
S PPERIOD=$S(Y["-":$P(Y,"^",2),1:$P(^PRST(458,$P(Y,"^"),0),"^"))
;
; Save T&L unit 4 use in DIC("S"), cause we might change TLE
; for display if this employee was in a different T&L during
; the selected pay period.
S TLSCREEN=TLE
;
D CHECKTLE(PPERIOD,DFN,.TLE) ;verify that T&L unit hasn't changed
D L1 ;ask device
;restore TLE variable to the one originally selected.
S TLE=TLSCREEN
;
G T1 ;ask for employee again
;====================================================================
EMP ; Employee Entry
N PPERIOD,OLDTLE
S PRSTLV=1 D TOP S DFN="",SSN=$P($G(^VA(200,DUZ,1)),"^",9)
I SSN'="" S DFN=$O(^PRSPC("SSN",SSN,0))
I 'DFN W !!,*7,"Your SSN was not found in both the New Person & Employee File!" G EX
S TLE=$P($G(^PRSPC(DFN,0)),"^",8)
S %DT="AEPX",%DT("A")="Posting Date: ",%DT(0)=-DT W ! D ^%DT
G:Y<1 EX S D1=Y S Y=$G(^PRST(458,"AD",D1)),PPI=$P(Y,"^",1) G EX:PPI<1
; 1st put pay period in YY-PP format 4 call 2 lookup old T&L.
S PPERIOD=$S(Y["-":$P(Y,"^",2),1:$P(^PRST(458,$P(Y,"^"),0),"^"))
D CHECKTLE(PPERIOD,DFN,.TLE) ;verify that T&L unit hasn't changed
D L1 G EX
;====================================================================
TOP W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM"
W !?27,"EMPLOYEE PAY PERIOD DATA" Q
L1 W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP Q:POP
I $D(IO("Q")) S PRSAPGM="DIS^PRSADP2",PRSALST="DFN^TLE^PPI" D QUE^PRSAUTL Q
U IO D DIS
; pause screen when employee to prevent scroll (other users prompted)
I $E(IOST,1,2)="C-",'QT,PRSTLV=1 S PG=PG+1 D H1
D ^%ZISC K %ZIS,IOP Q
;====================================================================
DIS ; Display 14 days
S PDT=$G(^PRST(458,PPI,2)),STAT=$P($G(^PRST(458,PPI,"E",DFN,0)),"^",2)
S (PG,QT)=0 D HDR
W !!,?7,"Date",?17,"TW",?21,"Scheduled Tour",?46,"Tour Exceptions"
W !?3,"------------------------------------------------------------------------"
F DAY=1:1:14 S DTE=$P(PDT,"^",DAY) D:$Y>(IOSL-5) HDR G:QT D1 D F0^PRSADP1
S Z=$G(^PRST(458,PPI,"E",DFN,2)) I Z'="" D:$Y>(IOSL-10) HDR Q:QT D VCS^PRSASR1
S Z=$G(^PRST(458,PPI,"E",DFN,4)) I Z'="" D:$Y>(IOSL-8) HDR Q:QT D ED^PRSASR1
S (X9,XF)=0 F DAY=1:1:14 D ^PRSATPE I $D(ER) S:FATAL XF=1 F K=0:0 S K=$O(ER(K)) Q:K<1 D:$Y>(IOSL-4) HDR G:QT D1 W:X9 ! W !?5,$P(PDT,"^",DAY)," " W:$P(ER(K),"^",2)'="" $P(ER(K),"^",2) W ?28,$P(ER(K),"^",1) S X9=0
D1 I PRSTLV>5 S Z=$G(^PRST(458,PPI,"E",DFN,5)) W:Z'="" !!,"8B Codes: ",Z
Q:QT W ! I $D(^PRST(458,PPI,"E",DFN,"X",0)) D ^PRSAUDP
Q
;====================================================================
HDR ; Display Header
D H1 Q:QT W:'($E(IOST,1,2)'="C-"&'PG) @IOF
N A
S PG=PG+1,A=$$TWE^PRSATE0(DFN,$S($G(PPI)]"":PPI,1:""))
S X=$G(^PRSPC(DFN,0)) ;employees (partial) master record.
W ! W:$E(IOST,1,2)="C-" @IOF
W ?3,$P(X,"^",1),?36,"T&L ",$S($G(TLE):TLE,1:$P(X,"^",8)),?45,"Telework Ind: ",$S($P(A,U,3)]"":$P(A,U,3),$P(A,U)]""&($G(PPI)=""):$P(A,U),1:"None")
S X=$P(X,"^",9)
I '$G(PRSTLV)!($G(PRSTLV)=1) W ?68,"XXX-XX-",$E(X,6,9) W:PG>1 ! Q
I PRSTLV=2!(PRSTLV=3) W ?68,$E(X),"XX-XX-",$E(X,6,9) W:PG>1 ! Q
I PRSTLV=7 W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9) W:PG>1 ! Q
H1 I PG,$E(IOST,1,2)="C-" R !!,"Press RETURN to Continue.",X:DTIME S:'$T!(X["^") QT=1
Q
EX G KILL^XUSCLEAN
Q
;=============J.Heiges===============================================
CHECKTLE(PAYPRD,EMPLOYEE,TLE) ;
; In cases where Time keepers, Payroll or employees are viewing
;an old pay period, make sure employee being viewed was not in
;a different T&L unit.
; This routine calls function that checks an old pay plan and
;populates OLDPP() array with T&L Unit.
; To handle cases when we're dealing with the current pay period,
;ignore cases when the lookup fails, since the current pay period
;will not be in the Pay Run download file. If old T&L unit not found,
;display current.
;
;VARS:
; PAYPRD= Pay period in file 458, .01 field, in the
; form YY-PP (year-pay period). i.e 96-02
; EMPLOYEE= employees internal entry number in file 450.
;
N PPLOLD,PPL,OLDPP
; call old pay plan lookup to also return old T&L unit.
S PPLOLD=$$OLDPP^PRS8UT(PAYPRD,+EMPLOYEE) ;pay plan from PAYPDTMP.
;
; Did lookup find legitimate T&L unit ? If so, is it different
; than the employees current T&L? If so, return old value.
I $L($G(OLDPP("TLUNIT")))>2 D
. I OLDPP("TLUNIT")'=TLE S TLE=OLDPP("TLUNIT")
;
Q
;===================================================================
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSADP2 5961 printed Oct 16, 2024@18:24:07 Page 2
PRSADP2 ; HISC/REL-Display Employee Pay Period ;7/22/97
+1 ;;4.0;PAID;**21,28,46,114,132**;Sep 21, 1995;Build 13
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
PAY ; Payroll Entry
+1 NEW PPERIOD
+2 SET PRSTLV=7
+3 ; print header
DO TOP
P1 KILL DIC
SET DIC("A")="Select EMPLOYEE: "
SET DIC(0)="AEQM"
SET DIC="^PRSPC("
+1 WRITE !
DO ^DIC
SET DFN=+Y
KILL DIC
if DFN<1
GOTO EX
+2 SET TLE=$PIECE($GET(^PRSPC(DFN,0)),"^",8)
+3 SET DIC="^PRST(458,"
SET DIC(0)="AEQM"
SET DIC("A")="Select PAY PERIOD: "
+4 WRITE !
DO ^DIC
KILL DIC
if Y<1
GOTO EX
+5 SET PPI=+Y
+6 ; 1st put pay period in YY-PP format 4 call 2 lookup old T&L.
+7 SET PPERIOD=$SELECT(Y["-":$PIECE(Y,"^",2),1:$PIECE(^PRST(458,$PIECE(Y,"^"),0),"^"))
+8 ;verify that T&L unit hasn't changed
DO CHECKTLE(PPERIOD,DFN,.TLE)
+9 ;ask device
DO L1
+10 ;ask for employee again
GOTO P1
+11 ;====================================================================
TK ; TimeKeeper Entry
+1 SET PRSTLV=2
GOTO T0
+2 ;====================================================================
SUP ; Supervisor Entry
+1 SET PRSTLV=3
T0 ; print header
DO TOP
+1 DO ^PRSAUTL
if TLI<1
GOTO EX
+2 NEW PPERIOD
T1 KILL DIC
SET DIC("A")="Select EMPLOYEE: "
SET DIC(0)="AEQM"
SET DIC="^PRSPC("
+1 SET DIC("S")="I $P(^(0),""^"",8)=TLE"
SET D="ATL"_TLE
WRITE !
DO IX^DIC
+2 SET DFN=+Y
KILL DIC
if DFN<1
GOTO EX
+3 SET %DT="AEPX"
SET %DT("A")="Posting Date: "
SET %DT(0)=-DT
WRITE !
DO ^%DT
+4 if Y<1
GOTO EX
SET D1=Y
SET Y=$GET(^PRST(458,"AD",D1))
SET PPI=$PIECE(Y,"^",1)
if PPI<1
GOTO EX
+5 ; 1st put pay period in YY-PP format 4 call 2 lookup old T&L.
+6 SET PPERIOD=$SELECT(Y["-":$PIECE(Y,"^",2),1:$PIECE(^PRST(458,$PIECE(Y,"^"),0),"^"))
+7 ;
+8 ; Save T&L unit 4 use in DIC("S"), cause we might change TLE
+9 ; for display if this employee was in a different T&L during
+10 ; the selected pay period.
+11 SET TLSCREEN=TLE
+12 ;
+13 ;verify that T&L unit hasn't changed
DO CHECKTLE(PPERIOD,DFN,.TLE)
+14 ;ask device
DO L1
+15 ;restore TLE variable to the one originally selected.
+16 SET TLE=TLSCREEN
+17 ;
+18 ;ask for employee again
GOTO T1
+19 ;====================================================================
EMP ; Employee Entry
+1 NEW PPERIOD,OLDTLE
+2 SET PRSTLV=1
DO TOP
SET DFN=""
SET SSN=$PIECE($GET(^VA(200,DUZ,1)),"^",9)
+3 IF SSN'=""
SET DFN=$ORDER(^PRSPC("SSN",SSN,0))
+4 IF 'DFN
WRITE !!,*7,"Your SSN was not found in both the New Person & Employee File!"
GOTO EX
+5 SET TLE=$PIECE($GET(^PRSPC(DFN,0)),"^",8)
+6 SET %DT="AEPX"
SET %DT("A")="Posting Date: "
SET %DT(0)=-DT
WRITE !
DO ^%DT
+7 if Y<1
GOTO EX
SET D1=Y
SET Y=$GET(^PRST(458,"AD",D1))
SET PPI=$PIECE(Y,"^",1)
if PPI<1
GOTO EX
+8 ; 1st put pay period in YY-PP format 4 call 2 lookup old T&L.
+9 SET PPERIOD=$SELECT(Y["-":$PIECE(Y,"^",2),1:$PIECE(^PRST(458,$PIECE(Y,"^"),0),"^"))
+10 ;verify that T&L unit hasn't changed
DO CHECKTLE(PPERIOD,DFN,.TLE)
+11 DO L1
GOTO EX
+12 ;====================================================================
TOP if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
WRITE !?26,"VA TIME & ATTENDANCE SYSTEM"
+1 WRITE !?27,"EMPLOYEE PAY PERIOD DATA"
QUIT
L1 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select Device: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
QUIT
+1 IF $DATA(IO("Q"))
SET PRSAPGM="DIS^PRSADP2"
SET PRSALST="DFN^TLE^PPI"
DO QUE^PRSAUTL
QUIT
+2 USE IO
DO DIS
+3 ; pause screen when employee to prevent scroll (other users prompted)
+4 IF $EXTRACT(IOST,1,2)="C-"
IF 'QT
IF PRSTLV=1
SET PG=PG+1
DO H1
+5 DO ^%ZISC
KILL %ZIS,IOP
QUIT
+6 ;====================================================================
DIS ; Display 14 days
+1 SET PDT=$GET(^PRST(458,PPI,2))
SET STAT=$PIECE($GET(^PRST(458,PPI,"E",DFN,0)),"^",2)
+2 SET (PG,QT)=0
DO HDR
+3 WRITE !!,?7,"Date",?17,"TW",?21,"Scheduled Tour",?46,"Tour Exceptions"
+4 WRITE !?3,"------------------------------------------------------------------------"
+5 FOR DAY=1:1:14
SET DTE=$PIECE(PDT,"^",DAY)
if $Y>(IOSL-5)
DO HDR
if QT
GOTO D1
DO F0^PRSADP1
+6 SET Z=$GET(^PRST(458,PPI,"E",DFN,2))
IF Z'=""
if $Y>(IOSL-10)
DO HDR
if QT
QUIT
DO VCS^PRSASR1
+7 SET Z=$GET(^PRST(458,PPI,"E",DFN,4))
IF Z'=""
if $Y>(IOSL-8)
DO HDR
if QT
QUIT
DO ED^PRSASR1
+8 SET (X9,XF)=0
FOR DAY=1:1:14
DO ^PRSATPE
IF $DATA(ER)
if FATAL
SET XF=1
FOR K=0:0
SET K=$ORDER(ER(K))
if K<1
QUIT
if $Y>(IOSL-4)
DO HDR
if QT
GOTO D1
if X9
WRITE !
WRITE !?5,$PIECE(PDT,"^",DAY)," "
if $PIECE(ER(K),"^",2)'=""
WRITE $PIECE(ER(K),"^",2)
WRITE ?28,$PIECE(ER(K),"^",1)
SET X9=0
D1 IF PRSTLV>5
SET Z=$GET(^PRST(458,PPI,"E",DFN,5))
if Z'=""
WRITE !!,"8B Codes: ",Z
+1 if QT
QUIT
WRITE !
IF $DATA(^PRST(458,PPI,"E",DFN,"X",0))
DO ^PRSAUDP
+2 QUIT
+3 ;====================================================================
HDR ; Display Header
+1 DO H1
if QT
QUIT
if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
+2 NEW A
+3 SET PG=PG+1
SET A=$$TWE^PRSATE0(DFN,$SELECT($GET(PPI)]"":PPI,1:""))
+4 ;employees (partial) master record.
SET X=$GET(^PRSPC(DFN,0))
+5 WRITE !
if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+6 WRITE ?3,$PIECE(X,"^",1),?36,"T&L ",$SELECT($GET(TLE):TLE,1:$PIECE(X,"^",8)),?45,"Telework Ind: ",$SELECT($PIECE(A,U,3)]"":$PIECE(A,U,3),$PIECE(A,U)]""&($GET(PPI)=""):$PIECE(A,U),1:"None")
+7 SET X=$PIECE(X,"^",9)
+8 IF '$GET(PRSTLV)!($GET(PRSTLV)=1)
WRITE ?68,"XXX-XX-",$EXTRACT(X,6,9)
if PG>1
WRITE !
QUIT
+9 IF PRSTLV=2!(PRSTLV=3)
WRITE ?68,$EXTRACT(X),"XX-XX-",$EXTRACT(X,6,9)
if PG>1
WRITE !
QUIT
+10 IF PRSTLV=7
WRITE ?68,$EXTRACT(X,1,3),"-",$EXTRACT(X,4,5),"-",$EXTRACT(X,6,9)
if PG>1
WRITE !
QUIT
H1 IF PG
IF $EXTRACT(IOST,1,2)="C-"
READ !!,"Press RETURN to Continue.",X:DTIME
if '$TEST!(X["^")
SET QT=1
+1 QUIT
EX GOTO KILL^XUSCLEAN
+1 QUIT
+2 ;=============J.Heiges===============================================
CHECKTLE(PAYPRD,EMPLOYEE,TLE) ;
+1 ; In cases where Time keepers, Payroll or employees are viewing
+2 ;an old pay period, make sure employee being viewed was not in
+3 ;a different T&L unit.
+4 ; This routine calls function that checks an old pay plan and
+5 ;populates OLDPP() array with T&L Unit.
+6 ; To handle cases when we're dealing with the current pay period,
+7 ;ignore cases when the lookup fails, since the current pay period
+8 ;will not be in the Pay Run download file. If old T&L unit not found,
+9 ;display current.
+10 ;
+11 ;VARS:
+12 ; PAYPRD= Pay period in file 458, .01 field, in the
+13 ; form YY-PP (year-pay period). i.e 96-02
+14 ; EMPLOYEE= employees internal entry number in file 450.
+15 ;
+16 NEW PPLOLD,PPL,OLDPP
+17 ; call old pay plan lookup to also return old T&L unit.
+18 ;pay plan from PAYPDTMP.
SET PPLOLD=$$OLDPP^PRS8UT(PAYPRD,+EMPLOYEE)
+19 ;
+20 ; Did lookup find legitimate T&L unit ? If so, is it different
+21 ; than the employees current T&L? If so, return old value.
+22 IF $LENGTH($GET(OLDPP("TLUNIT")))>2
Begin DoDot:1
+23 IF OLDPP("TLUNIT")'=TLE
SET TLE=OLDPP("TLUNIT")
End DoDot:1
+24 ;
+25 QUIT
+26 ;===================================================================
