source: FOIAVistA/tag/r/PAID-PRS/PRSATE.m

PRSATE ;WCIOFO/JAH - Enter/Edit Employee (emp) Tour of Duty (ToD) ;03/15/2005
 ;;4.0;PAID;**8,11,27,45,55,93**;Sep 21, 1995;Build 7
 ;;Per VHA Directive 2004-038, this routine should not be modified.
 N PPI,PPE,PRSTLV,TLI,TLE,DFN
 ;
 ;    PPI =  pay period (pp) internal #.
 ;    PPE = pp external form (99-06).
 ;    PRSTLV = flag indicates timekeeper (TK) in T&L lookup ^PRSAUTL.
 ;    TLI = T&L unit internal #.
 ;    TLU = T&L unit # 3-digit
 ;
 ;  -Get current pp-internal & external.  -Ask user for T&L.
 ;  -Loop to ask for emp until TK is done.
 ;  --Emp lookup screens emps not in T&L returned by PRSAUTL call.
 ;
 S PRSTLV=2 D ^PRSAUTL Q:TLI<1
 F  S DFN=$$GETEMP^PRSATE6(TLE) Q:DFN<1  D
 .    S PPI=$P(^PRST(458,0),"^",3),PPE=$P($G(^PRST(458,PPI,0)),"^",1)
 .    D TOUREDIT(DFN,PPI,PPE,TLI,TLE,PRSTLV)
 Q
 ;=======================
 ;
TOUREDIT(DFN,PPI,PPE,TLI,TLE,PRSTLV) ;
 ;
 N C0,NH,FLX,PMP,PP,PB,ENT,SRT,WTL,TYP,Z,TD,ERROR,NOERROR
 ;
 ;   Entitlement lookup leaks many variables.  Following R used in 
 ;   this routine but may be looked up again despite the fact they R 
 ;   leaked by ^PRSAENT.  See PRSAENT for further doc.
 ;
 ;    C0=emps 0 node in file 450    NH= emps 8B normal hrs
 ;    FLX= compressed/flextime code (0=none,C=compressed,F=flextime)
 ;    PMP= premium pay indicator 
 ;      ( D=entitled Sun., F=entitled Sat./Sun.,
 ;        E=entitled variable Sat./Sun. premium pay,
 ;        G=entitled variable Sun. prem pay, X=title 5 emps
 ;        R,C,O=different types of firefighters)
 ;  * PP= emps pay plan
 ;    DB = pay basis-1:full,2:part,3:intermit
 ;    ENT= 39 char entitlement string
 ;
 ;  Entitlement lookup.
 ;
 D ^PRSAENT I ENT="" D ERROR(1) S OUT=1 Q
 ;
 ; Display header/Ask pp (NOL^PRSATE2 returns SRT = Current, Next, Last)
 ;
 D NOW^%DTC S NOW=%
 W:$E(IOST,1,2)="C-" @IOF
 W !?26,"VA TIME & ATTENDANCE SYSTEM"
 W !?29,"EMPLOYEE TOUR OF DUTY"
 D HDR^PRSADP1,NOL^PRSATE2
 Q:SRT="^"
 I SRT="L" S PPI=PPI-1,PPE=$P($G(^PRST(458,PPI,0)),"^",1)
 ;
 ;  Get emp's flexitime code
 ;
 S FLX=$$FLEXIND^PRSATE6(PPI,DFN,SRT)
 ;
 ;  Is emp entitled reg. shed. hrs.?
 ;
 I $E(ENT,1)="0" D
 .  S Z=$E(ENT,2),TD=$S(Z="D":3,1:4) D NONE
 E  D
 .;
 .;    initialize t&l for this ToD
 .;
 .  S WTL=TLI
 .  I "NL"[SRT D
 ..    S TYP=0
 .  E  D
 ..    S TYP=$$ISTEMPTR()
 ..;
 ..;  For temp ToDs--ask user for T&L ToD will be worked
 ..;  Quit if we don't get a valid T&L unit.
 ..;
 ..    I TYP S WTL=$$ASKTLWRK^PRSATE6(TLE)
 .;
 .;  Save current ToD in case user aborts with an unacceptable ToD.
 .;
 .   D SAVETOUR^PRSATE6(PPI,DFN)
 .;
 .  I WTL'<1,TYP'["^" D 
 ..    D A1
 ..;
 ..; verify firefighter ToD after compressed ind. edit.  Don't accept 
 ..; ToD until its within guidlines. If TK force exits, restore old ToD.
 ..;
 ..  S NOERROR=0
 ..  F  D  Q:NOERROR
 ...    N ERROR D FFTOUR^PRSATE6(PPI,DFN,SRT,.ERROR)
 ...    I $$ISERRORS^PRSATE6(.ERROR) D
 ....      I $$ASKTOFIX^PRSATE6() D
 .....        D A1
 ....      E  D
 .....        D RESTORE^PRSATE6(PPI,DFN) S NOERROR=1
 ...    E  D
 ....      S NOERROR=1
 Q
 ;=======================
 ;
ISTEMPTR() ; IS TEMPORARY ToD ?
 ; Ask user if ToD is temp or perm & convert TYP to true false flag
 ;    Permanent set TYP=0,  Temporary set TYP=true (1)
 ; 
 S TYP=$$ASKTEMP^PRSATE6() I TYP'["^" S TYP=$E(TYP,1)="T",WTL=TLI
 Q TYP
 ;=======================
 ;
A1 ; Set up for emps ToD look up. Screen allows Daily ToDs & days off 
 ; for daily emps.  Everyone else gets days off & all other ToDs.
 ; Screen further ensures ToD is available either to all t&ls 
 ; or to t&l that this emp is working in.
 ;
 N DIC,X
 S DIC="^PRST(457.1,",DIC(0)="AEQMN"
 S DIC("S")="I "_$S($E(ENT,1)="D":"Y<3",1:"Y>5!(Y=1)")_",$P(^PRST(457.1,+Y,0),U,4)!($D(^PRST(457.1,+Y,""T"",""B"",WTL)))"
 ;
 ; Setup a fixed or varying ToD.  Compressed ToDs must be varying;
 ; ask TK about all others.
 ;
 I FLX="C" D
 .   D VAR
 E  D
 .  S X=$$ASKFIXED()
 .  Q:X="^"
 .  I X="N" D
 ..    D VAR
 .  E  D FX
 Q
 ;=======================
 ;
FX ; Fixed ToD
 S DIC("A")="Select TOUR OF DUTY: "
 W ! D ^DIC
 Q:Y'>0
 S TD=+Y,Y=$G(^PRST(457.1,TD,1)),TDH=$P(^(0),"^",6),HRS=TDH*10
 S (ZENT,STR)=""
 D OT^PRSATP,VS^PRSATE0
 I STR'="" W *7,!!,STR G FX
 I '$D(^PRST(458,PPI,"E",DFN,"D",0)) S ^(0)="^458.02^14^14"
 I SRT="N" D
 .  D F1
 E  D
 .  F DAY=2:1:6,9:1:13 D SET
 .  S TD=1,(Y,TDH)="" F DAY=1,7,8,14 D SET
 .  W "  ... done" D:HRS'=NH ERROR(2,NH,HRS)
 .  D T2,^PRSATE5
 D HOL,RS
 Q
 ;=======================
 ;
F1 F DAY=2:1:6,9:1:13 D NX
 S TD=1 F DAY=1,7,8,14 D NX
 W "  ... done"
 D:HRS'=NH ERROR(2,NH,HRS)
 Q
 ;=======================
 ;
VAR ; Variable ToD
 D ^PRSATE0
 I SRT'="N" D T2,^PRSATE5
 D HOL,RS
 Q
 ;=======================
 ;
NONE ; No ToD
 N TYP2,UPDT,Y,TDH
 W !!,"This is an intermittent employee with no specified tour."
 W !!,"Time records will now be updated to indicate this."
 I '$D(^PRST(458,PPI,"E",DFN,"D",0)) S ^(0)="^458.02^14^14"
 I '$$PERM^PRSALIB(PPI,DFN) D
 .  W !!,"Not all tour days are assigned a permanent status."
 .  I $$UPDTQ^PRSALIB(),$$TMPST^PRSALIB(.TYP2) D UPDSTAT^PRSALIB(PPI,DFN,TYP2)
 S (Y,TDH)="",TYP=0,WTL=TLI
 I SRT="N" D
 .  F DAY=1:1:14 D NX
 E  D
 .  F DAY=1:1:14 D SET
 W "  ... done"
 D HOL,RS
 Q
 ;=======================
 ;
RS ; Get Comp Ind
 S Y=$G(^PRST(458,PPI,"E",DFN,0))
 S FLX=$S((SRT="N")&($P(Y,U,7)]""):$P(Y,U,7),1:$P(Y,U,6))
 S DIR(0)="SAM^C:Compressed;F:Flexitime;0:None"
 S DIR("A")="Compressed Tour Indicator: "
 S DIR("B")=$S(FLX="C":"Compressed",FLX="F":"Flexitime",1:"None")
 D ^DIR K DIR I "^C^F^0^"'[(U_Y_U) S Y=FLX
 ;
 ;  Intermittent employee cannot have compressed tour.
 ;
 I $P(C0,U,10)=3,Y="C" D  G RS
 .   W *7,!?5,"Compressed tour not valid for this employee."
 ;
 I Y="F" S Z=0 D  I Z G RS
 .S PAY=$P(C0,U,21),PB=$P(C0,U,20)
 .I "0123456789GU"'[PAY S Z=1
 .I PAY="G",PB'=2 S Z=1
 .I PAY="U","27EXT"'[PB S Z=1
 .I Z W *7,!?5,"Flexitime not valid for this employee."
 .Q
 S $P(^PRST(458,PPI,"E",DFN,0),U,$S(SRT="N":7,1:6))=Y
 I $D(^PRST(458,"ATC",DFN)) D UPD^PRSASAL
 Q
 ;=======================
 ;
NX ; Set Next ToD
 S Z=$G(^PRST(458,PPI,"E",DFN,"D",DAY,0))
 Q:$P(Z,"^",2)=TD&('$P(Z,"^",3))
 ;
 S $P(Z,"^",3,4)="2^"_TD,$P(Z,"^",10,11)=DUZ_"^"_NOW
 S ^PRST(458,PPI,"E",DFN,"D",DAY,0)=Z,^PRST(458,"ATC",DFN,PPI,DAY)=""
 Q
 ;=======================
 ;
SET ; Set ToD
 N ZLASTPP
 S U="^"
 ;
 ; Get Zero node of emp pp rec, Old ToD, & Prior scheduled ToD.
 ; ZLASTPP is true if a ToD present on this day last pp.
 ;
 S Z=$G(^PRST(458,PPI,"E",DFN,"D",DAY,0))
 S ZLASTPP=$P($G(^PRST(458,PPI-1,"E",DFN,"D",DAY,0)),U,2)'=""
 S OLD=$P(Z,U,2),SCH=$P(Z,U,4)
 ;
 ; Quit if old ToD=this ToD & emp rec start/stop=ToD file start/stop.
 ;
 Q:(OLD=TD)&($G(^PRST(458,PPI,"E",DFN,"D",DAY,1))=Y)
 ;
 ; Z is updated with new ToD info & replaces the emp ToD record.
 ;
 S $P(Z,U,8)=TDH
 S $P(Z,U,10,11)=DUZ_U_NOW
 I $P(Z,U,12) S $P(Z,U,12)="" ; remove holiday flag
 ;
 ; Temp ToD, store T&L ToD will be worked if it's not emp's usual t&l.
 ;
 I TYP S:TLI'=WTL $P(Z,U,9)=WTL
 ;
 ; No existing ToD on this day.
 ;
 I OLD="" D
 .  S $P(Z,U,1,3)=DAY_U_TD_U_TYP
 .  I ZLASTPP D S0
 E  D
 .;
 .;  clean out postings and other ToD info since ToD is changing
 .;
 .  D CLEANTOD(PPI,DFN,DAY,TD)
 .;
 .;
 .;
 .  S:SCH $P(Z,U,5,7)="^^"
 .  I SCH="" D
 ..    S $P(Z,U,2,4)=TD_U_TYP_U_OLD
 ..    D S0
 .  E  D
 ..    I SCH=TD D
 ...      S $P(Z,U,2,4)=TD_"^^"
 ...      K ^PRST(458,"ATC",DFN,PPI,DAY)
 ..    E  D
 ...      S $P(Z,U,2,3)=TD_U_TYP
 ...      D S0
 ;
 D S1
 Q
 ;=======================
 ;
 ; Set up x-ref for supervisor approval of ToD change
 ;
S0 S ^PRST(458,"ATC",DFN,PPI,DAY)=""
 Q
 ;=======================
 ;
S1 ;
 S ^PRST(458,PPI,"E",DFN,"D",DAY,0)=Z S:Y'="" ^(1)=Y
 Q
 ;=======================
 ;
T2 ; Ask if second ToD
 N X
 ;
 ;  Don't ask for Daily ToDs
 ;
 Q:$E(ENT,1)="D"
 ;
 S X=$$ASK2NDTR()
 Q:X'="Y"  G ^PRSATE4
 ;=======================
 ;
HOL ; Determine if Holiday within ToD
 N DAY
 D ^PRSAPPH
 Q:'$D(HOL)
 S TT="HX",DUP=1
 D E^PRSAPPH
 Q
 ;=======================
 ;
CLEANTOD(PPI,DFN,DAY,TD) ; CLEAN OUT TOUR
 N PRSDT,MIEN
 K ^PRST(458,PPI,"E",DFN,"D",DAY,1),^(2),^(3),^(10) I TD<5 K ^(4) S $P(Z,U,13,15)="^^"
 ; if employee is PTP with active memo then reset the ESR day
 S PRSDT=$P($G(^PRST(458,PPI,1)),U,DAY)
 S MIEN=$$MIEN^PRSPUT1(DFN,PRSDT)
 I MIEN D
 . N PRSFDA
 . S PRSFDA(458.02,DAY_","_DFN_","_PPI_",",146)="3" ; status = resubmit
 . S PRSFDA(458.02,DAY_","_DFN_","_PPI_",",148)="Tour Changed" ; remarks
 . D FILE^DIE("","PRSFDA"),MSG^DIALOG()
 Q
 ;=======================
 ;
ERROR(NUM,VAR1,VAR2) ;
 W *7,!!
 I NUM=1 W "Employee has no Pay Entitlement table entry."
 I NUM=2 D
 .  Q:$G(NH)=112
 .  W "Warning: Normal Hours are ",$G(VAR1),"; Tour Hours are ",$G(VAR2)
 Q
 ;=======================
 ;
ASKFIXED() ;GET USER'S YES OR NO RESPONSE TO FIXED ToD QUESTION
 N DIR,DIRUT,Y
 S DIR("A")="Do you wish to enter a fixed Mon-Fri Tour"
 S DIR(0)="Y"
 S DIR("?")="Answer NO to create any other type of tour."
 S DIR("?",1)="Fixed tours are Monday - Friday with the same hours."
 D ^DIR
 S RESP=$S(Y=1:"Y",Y=0:"N",1:"^")
 Q RESP
 ;=======================
 ;
ASK2NDTR() ;GET USER'S YES OR NO RESPONSE TO 2nd ToD QUESTION
 N DIR,DIRUT,Y
 S DIR("A")="Do you wish to enter a Second Tour for any Day"
 S DIR(0)="Y"
 S DIR("B")="N"
 S DIR("?",1)="Answer Yes to add a second tour.  No to continue."
 S DIR("?")="Enter ^ to escape and cancel this tour change."
 D ^DIR
 S RESP=$S(Y=1:"Y",Y=0:"N",1:"^")
 Q RESP
 ;=======================
 ;