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

PRSADP2.m

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