- 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 Feb 18, 2025@23:49:47 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 ;===================================================================