PRSATE ;WCIOFO/JAH/PLT - Enter/Edit Employee (emp) Tour of Duty (ToD) ;03/15/2005
;;4.0;PAID;**8,11,27,45,55,93,112,117,121,132**;Sep 21, 1995;Build 13
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;ppi=ien of 450, ppi=ien of 458, ppe=pp (yy-mm)
;tli = ien of t&l, tlu=t&l # (nnn), prstlv=2 for timekeeper user
N PPI,PPE,PRSTLV,TLI,TLE,DFN
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,PRSDAY,PRSETD
N PRSTW,PRSTWA,PRSTWB
;
; PRSTW: employees telework type
; PRSTWA: telework eligibilty string
; PRSTWB: this pay period (PPI) telework eligibilty
;
; 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=% K %
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, telework ind.
S FLX=$$FLEXIND^PRSATE6(PPI,DFN,SRT),PRSTWA=$$TWE^PRSATE0(DFN,PPI),PRSTWB=$P(PRSTWA,U,4)="Y"
;entitled reg. scheduled is o
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.
.. I PMP="C" 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
K NOW 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,DB
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.
;
S DB=$P(C0,U,10) I FLX="C"!("KM"[PP&(DB=1)&(NH=72)) D VAR QUIT
S X=$$ASKFIXED() QUIT:X="^" I X="N" D VAR QUIT
I PRSTWB S X=$$ASKTWMF^PRSATE6() QUIT:X="^" I X="Y" D FX,VAR QUIT
D FX
QUIT
;
FX ; Fixed ToD
FX1 S DIC("A")="Select TOUR OF DUTY: "
W ! D ^DIC
Q:Y'>0
S TD=+Y
;check overlap
K PRSDAY,PRSETD
F DAY=1:1:14 S $P(PRSETD,U,DAY)=$S(DAY#7<2:1,1:TD) D
. N TOLD
. S PRSDAY(DAY)=$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),U,1,4),$P(TOLD,U,DAY)=$S(SRT="N"&($P($G(^(0)),U,3)):$P(^(0),U,4),1:$P($G(^(0)),U,2)) S:DAY#7>1 $P(PRSDAY(DAY),U,6)=$P($G(^(0)),U,13),$P(PRSDAY(DAY),U,7,999)=$G(^(4))
. D PRSDAY^PRSATE0
. QUIT
D ENT^PRSATE5 I $G(PRSERR) K PRSERR G FX1
S 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:'PRSTWB T2
. QUIT
I 'PRSTWB D HOL,RS K HRS,STR
QUIT
;
;
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)
QUIT
;
VAR ; Variable ToD
D ^PRSATE0
I SRT'="N" D T2
D HOL,RS
Q
;
NONE ; No ToD
N TYP2,UPDT,Y,TDH,PRSTWB
S PRSTWB=0
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
K PAY,ZENT Q
;
;
NX ; Set Next ToD
S Z=$G(^PRST(458,PPI,"E",DFN,"D",DAY,0))
I $P(Z,"^",2)=TD,'$P(Z,"^",3),'PRSTWB!($P($G(^PRST(458,PPI,"E",DFN,"D",DAY,8)),U)=$G(PRSTW(DAY))) QUIT
S $P(Z,"^",3,4)="2^"_TD,$P(Z,"^",10,11)=DUZ_"^"_NOW
S ^PRST(458,PPI,"E",DFN,"D",DAY,0)=Z S:PRSTWB $P(^(8),U,5)=$G(PRSTW(DAY))
S ^PRST(458,"ATC",DFN,PPI,DAY)=""
QUIT
;
;
SET ; Set ToD
N ZLASTPP,OLD,SCH,PRSTW1,PRSTW5
;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)),PRSTW1=$P($G(^(8)),U),PRSTW5=$P($G(^(8)),U,5),OLD=$P(Z,U,2),SCH=$P(Z,U,4)
S ZLASTPP=$P($G(^PRST(458,PPI-1,"E",DFN,"D",DAY,0)),U,2)'=""
;quit if old tour and its time segments/telework tour=edited one
I OLD=TD,$G(^PRST(458,PPI,"E",DFN,"D",DAY,1))=Y,PRSTW1=$G(PRSTW(DAY))!'$G(PRSTWB) QUIT
;Z is updated with new ToD info & replaces the emp ToD record.
S $P(Z,U,8)=TDH,$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,TLI'=WTL S $P(Z,U,9)=WTL
;no existing ToD on this day.
I OLD="" S $P(Z,U,1,3)=DAY_U_TD_U_TYP D S0:ZLASTPP,S1,S8($G(PRSTW(DAY)),1):$G(PRSTWB) QUIT
;clean out postings and other ToD info since ToD is changing
D CLEANTOD(PPI,DFN,DAY,TD)
I SCH="" S $P(Z,U,2,4)=TD_U_TYP_U_OLD D S0,S1 D:$G(PRSTWB) S8($G(PRSTW(DAY)),1),S8(PRSTW1,5) QUIT
S $P(Z,U,5,7)="^^"
I SCH=TD,PRSTW5=$G(PRSTW(DAY))!'$G(PRSTWB) S $P(Z,U,2,4)=TD_"^^" K ^PRST(458,"ATC",DFN,PPI,DAY) D S1 D:$G(PRSTWB) S8("",5),S8($G(PRSTW(DAY)),1) QUIT
S $P(Z,U,2,3)=TD_U_TYP D S0,S1 D:$G(PRSTWB) S8($G(PRSTW(DAY)),1)
QUIT
;
;
; 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
;
;a=telework tour reg/med, b=1 if reg/temp tour, 5 if prior/next tour
S8(A,B) ;set telework tour in node 8 of daily multiple
;prstwb=1 telework eligible
I '$G(PRSTWB) K ^PRST(458,PPI,"E",DFN,"D",DAY,8) QUIT
S $P(^PRST(458,PPI,"E",DFN,"D",DAY,8),U,B)=A
; if no telework data then clean up
I ^PRST(458,PPI,"E",DFN,"D",DAY,8)?."^" K ^PRST(458,PPI,"E",DFN,"D",DAY,8)
QUIT
;
;
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 K DUP,HOL,TT
Q
;
;
CLEANTOD(PPI,DFN,DAY,TD) ; CLEAN OUT TOUR
N PRSDT,MIEN
K ^PRST(458,PPI,"E",DFN,"D",DAY,1),^(2),^(3),^(10),^(8) 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
Q $S(Y=1:"Y",Y=0:"N",1:"^")
;
;
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"_$S($G(SRT)="X":"",1:" 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
Q $S(Y=1:"Y",Y=0:"N",1:"^")
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSATE 10454 printed Dec 13, 2024@02:24:26 Page 2
PRSATE ;WCIOFO/JAH/PLT - Enter/Edit Employee (emp) Tour of Duty (ToD) ;03/15/2005
+1 ;;4.0;PAID;**8,11,27,45,55,93,112,117,121,132**;Sep 21, 1995;Build 13
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;ppi=ien of 450, ppi=ien of 458, ppe=pp (yy-mm)
+5 ;tli = ien of t&l, tlu=t&l # (nnn), prstlv=2 for timekeeper user
+6 NEW PPI,PPE,PRSTLV,TLI,TLE,DFN
+7 SET PRSTLV=2
DO ^PRSAUTL
if TLI<1
QUIT
+8 FOR
SET DFN=$$GETEMP^PRSATE6(TLE)
if DFN<1
QUIT
Begin DoDot:1
+9 SET PPI=$PIECE(^PRST(458,0),"^",3)
SET PPE=$PIECE($GET(^PRST(458,PPI,0)),"^",1)
+10 DO TOUREDIT(DFN,PPI,PPE,TLI,TLE,PRSTLV)
End DoDot:1
+11 QUIT
+12 ;
TOUREDIT(DFN,PPI,PPE,TLI,TLE,PRSTLV) ;
+1 NEW C0,NH,FLX,PMP,PP,PB,ENT,SRT,WTL,TYP,Z,TD,ERROR,NOERROR,PRSDAY,PRSETD
+2 NEW PRSTW,PRSTWA,PRSTWB
+3 ;
+4 ; PRSTW: employees telework type
+5 ; PRSTWA: telework eligibilty string
+6 ; PRSTWB: this pay period (PPI) telework eligibilty
+7 ;
+8 ; Entitlement lookup leaks many variables. Following R used in
+9 ; this routine but may be looked up again despite the fact they R
+10 ; leaked by ^PRSAENT. See PRSAENT for further doc.
+11 ;
+12 ;
+13 ; C0=emps 0 node in file 450 NH= emps 8B normal hrs
+14 ; FLX= compressed/flextime code (0=none,C=compressed,F=flextime)
+15 ; PMP= premium pay indicator
+16 ; ( D=entitled Sun., F=entitled Sat./Sun.,
+17 ; E=entitled variable Sat./Sun. premium pay,
+18 ; G=entitled variable Sun. prem pay, X=title 5 emps
+19 ; R,C,O=different types of firefighters)
+20 ; * PP= emps pay plan
+21 ; DB = pay basis-1:full,2:part,3:intermit
+22 ; ENT= 39 char entitlement string
+23 ; Entitlement lookup.
+24 DO ^PRSAENT
IF ENT=""
DO ERROR(1)
SET OUT=1
QUIT
+25 ;
+26 ; Display header/Ask pp (NOL^PRSATE2 returns SRT = Current, Next, Last)
+27 DO NOW^%DTC
SET NOW=%
KILL %
+28 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+29 WRITE !?26,"VA TIME & ATTENDANCE SYSTEM"
+30 WRITE !?29,"EMPLOYEE TOUR OF DUTY"
+31 DO HDR^PRSADP1
DO NOL^PRSATE2
+32 if SRT="^"
QUIT
+33 IF SRT="L"
SET PPI=PPI-1
SET PPE=$PIECE($GET(^PRST(458,PPI,0)),"^",1)
+34 ;
+35 ;get emp's flexitime code, telework ind.
+36 SET FLX=$$FLEXIND^PRSATE6(PPI,DFN,SRT)
SET PRSTWA=$$TWE^PRSATE0(DFN,PPI)
SET PRSTWB=$PIECE(PRSTWA,U,4)="Y"
+37 ;entitled reg. scheduled is o
+38 IF $EXTRACT(ENT,1)="0"
Begin DoDot:1
+39 SET Z=$EXTRACT(ENT,2)
SET TD=$SELECT(Z="D":3,1:4)
DO NONE
End DoDot:1
+40 IF '$TEST
Begin DoDot:1
+41 ;
+42 ; initialize t&l for this ToD
+43 ;
+44 SET WTL=TLI
+45 IF "NL"[SRT
Begin DoDot:2
+46 SET TYP=0
End DoDot:2
+47 IF '$TEST
Begin DoDot:2
+48 SET TYP=$$ISTEMPTR()
+49 ;
+50 ; For temp ToDs--ask user for T&L ToD will be worked
+51 ; Quit if we don't get a valid T&L unit.
+52 ;
+53 IF TYP
SET WTL=$$ASKTLWRK^PRSATE6(TLE)
End DoDot:2
+54 ;
+55 ; Save current ToD in case user aborts with an unacceptable ToD.
+56 ;
+57 DO SAVETOUR^PRSATE6(PPI,DFN)
+58 ;
+59 IF WTL'<1
IF TYP'["^"
Begin DoDot:2
+60 DO A1
+61 ;
+62 ; verify firefighter ToD after compressed ind. edit. Don't accept
+63 ; ToD until its within guidlines. If TK force exits, restore old ToD.
+64 IF PMP="C"
SET NOERROR=0
FOR
Begin DoDot:3
+65 NEW ERROR
DO FFTOUR^PRSATE6(PPI,DFN,SRT,.ERROR)
+66 IF $$ISERRORS^PRSATE6(.ERROR)
Begin DoDot:4
+67 IF $$ASKTOFIX^PRSATE6()
Begin DoDot:5
+68 DO A1
End DoDot:5
+69 IF '$TEST
Begin DoDot:5
+70 DO RESTORE^PRSATE6(PPI,DFN)
SET NOERROR=1
End DoDot:5
End DoDot:4
+71 IF '$TEST
Begin DoDot:4
+72 SET NOERROR=1
End DoDot:4
End DoDot:3
if NOERROR
QUIT
End DoDot:2
End DoDot:1
+73 KILL NOW
QUIT
+74 ;
ISTEMPTR() ; IS TEMPORARY ToD ?
+1 ; Ask user if ToD is temp or perm & convert TYP to true false flag
+2 ; Permanent set TYP=0, Temporary set TYP=true (1)
+3 ;
+4 SET TYP=$$ASKTEMP^PRSATE6()
IF TYP'["^"
SET TYP=$EXTRACT(TYP,1)="T"
SET WTL=TLI
+5 QUIT TYP
+6 ;
A1 ; Set up for emps ToD look up. Screen allows Daily ToDs & days off
+1 ; for daily emps. Everyone else gets days off & all other ToDs.
+2 ; Screen further ensures ToD is available either to all t&ls
+3 ; or to t&l that this emp is working in.
+4 ;
+5 NEW DIC,X,DB
+6 SET DIC="^PRST(457.1,"
SET DIC(0)="AEQMN"
+7 SET DIC("S")="I "_$SELECT($EXTRACT(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)))"
+8 ;
+9 ; Setup a fixed or varying ToD. Compressed ToDs must be varying;
+10 ; ask TK about all others.
+11 ;
+12 SET DB=$PIECE(C0,U,10)
IF FLX="C"!("KM"[PP&(DB=1)&(NH=72))
DO VAR
QUIT
+13 SET X=$$ASKFIXED()
if X="^"
QUIT
IF X="N"
DO VAR
QUIT
+14 IF PRSTWB
SET X=$$ASKTWMF^PRSATE6()
if X="^"
QUIT
IF X="Y"
DO FX
DO VAR
QUIT
+15 DO FX
+16 QUIT
+17 ;
FX ; Fixed ToD
FX1 SET DIC("A")="Select TOUR OF DUTY: "
+1 WRITE !
DO ^DIC
+2 if Y'>0
QUIT
+3 SET TD=+Y
+4 ;check overlap
+5 KILL PRSDAY,PRSETD
+6 FOR DAY=1:1:14
SET $PIECE(PRSETD,U,DAY)=$SELECT(DAY#7<2:1,1:TD)
Begin DoDot:1
+7 NEW TOLD
+8 SET PRSDAY(DAY)=$PIECE($GET(^PRST(458,PPI,"E",DFN,"D",DAY,0)),U,1,4)
SET $PIECE(TOLD,U,DAY)=$SELECT(SRT="N"&($PIECE($GET(^(0)),U,3)):$PIECE(^(0),U,4),1:$PIECE($GET(^(0)),U,2))
if DAY#7>1
SET $PIECE(PRSDAY(DAY),U,6)=$PIECE($GET(^(0)),U,13)
SET $PIECE(PRSDAY(DAY),U,7,999)=$GET(^(4))
+9 DO PRSDAY^PRSATE0
+10 QUIT
End DoDot:1
+11 DO ENT^PRSATE5
IF $GET(PRSERR)
KILL PRSERR
GOTO FX1
+12 SET Y=$GET(^PRST(457.1,TD,1))
SET TDH=$PIECE(^(0),"^",6)
SET HRS=TDH*10
+13 SET (ZENT,STR)=""
+14 DO OT^PRSATP
DO VS^PRSATE0
+15 IF STR'=""
WRITE *7,!!,STR
GOTO FX
+16 IF '$DATA(^PRST(458,PPI,"E",DFN,"D",0))
SET ^(0)="^458.02^14^14"
+17 IF SRT="N"
Begin DoDot:1
+18 DO F1
End DoDot:1
+19 IF '$TEST
Begin DoDot:1
+20 FOR DAY=2:1:6,9:1:13
DO SET
+21 SET TD=1
SET (Y,TDH)=""
FOR DAY=1,7,8,14
DO SET
+22 WRITE " ... done"
if HRS'=NH
DO ERROR(2,NH,HRS)
+23 if 'PRSTWB
DO T2
+24 QUIT
End DoDot:1
+25 IF 'PRSTWB
DO HOL
DO RS
KILL HRS,STR
+26 QUIT
+27 ;
+28 ;
F1 FOR DAY=2:1:6,9:1:13
DO NX
+1 SET TD=1
FOR DAY=1,7,8,14
DO NX
+2 WRITE " ... done"
+3 if HRS'=NH
DO ERROR(2,NH,HRS)
+4 QUIT
+5 ;
VAR ; Variable ToD
+1 DO ^PRSATE0
+2 IF SRT'="N"
DO T2
+3 DO HOL
DO RS
+4 QUIT
+5 ;
NONE ; No ToD
+1 NEW TYP2,UPDT,Y,TDH,PRSTWB
+2 SET PRSTWB=0
+3 WRITE !!,"This is an intermittent employee with no specified tour."
+4 WRITE !!,"Time records will now be updated to indicate this."
+5 IF '$DATA(^PRST(458,PPI,"E",DFN,"D",0))
SET ^(0)="^458.02^14^14"
+6 IF '$$PERM^PRSALIB(PPI,DFN)
Begin DoDot:1
+7 WRITE !!,"Not all tour days are assigned a permanent status."
+8 IF $$UPDTQ^PRSALIB()
IF $$TMPST^PRSALIB(.TYP2)
DO UPDSTAT^PRSALIB(PPI,DFN,TYP2)
End DoDot:1
+9 SET (Y,TDH)=""
SET TYP=0
SET WTL=TLI
+10 IF SRT="N"
Begin DoDot:1
+11 FOR DAY=1:1:14
DO NX
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 FOR DAY=1:1:14
DO SET
End DoDot:1
+14 WRITE " ... done"
+15 DO HOL
DO RS
+16 QUIT
+17 ;
+18 ;
RS ; Get Comp Ind
+1 SET Y=$GET(^PRST(458,PPI,"E",DFN,0))
+2 SET FLX=$SELECT((SRT="N")&($PIECE(Y,U,7)]""):$PIECE(Y,U,7),1:$PIECE(Y,U,6))
+3 SET DIR(0)="SAM^C:Compressed;F:Flexitime;0:None"
+4 SET DIR("A")="Compressed Tour Indicator: "
+5 SET DIR("B")=$SELECT(FLX="C":"Compressed",FLX="F":"Flexitime",1:"None")
+6 DO ^DIR
KILL DIR
IF "^C^F^0^"'[(U_Y_U)
SET Y=FLX
+7 ;
+8 ; Intermittent employee cannot have compressed tour.
+9 ;
+10 IF $PIECE(C0,U,10)=3
IF Y="C"
Begin DoDot:1
+11 WRITE *7,!?5,"Compressed tour not valid for this employee."
End DoDot:1
GOTO RS
+12 ;
+13 IF Y="F"
SET Z=0
Begin DoDot:1
+14 SET PAY=$PIECE(C0,U,21)
SET PB=$PIECE(C0,U,20)
+15 IF "0123456789GU"'[PAY
SET Z=1
+16 IF PAY="G"
IF PB'=2
SET Z=1
+17 IF PAY="U"
IF "27EXT"'[PB
SET Z=1
+18 IF Z
WRITE *7,!?5,"Flexitime not valid for this employee."
+19 QUIT
End DoDot:1
IF Z
GOTO RS
+20 SET $PIECE(^PRST(458,PPI,"E",DFN,0),U,$SELECT(SRT="N":7,1:6))=Y
+21 IF $DATA(^PRST(458,"ATC",DFN))
DO UPD^PRSASAL
+22 KILL PAY,ZENT
QUIT
+23 ;
+24 ;
NX ; Set Next ToD
+1 SET Z=$GET(^PRST(458,PPI,"E",DFN,"D",DAY,0))
+2 IF $PIECE(Z,"^",2)=TD
IF '$PIECE(Z,"^",3)
IF 'PRSTWB!($PIECE($GET(^PRST(458,PPI,"E",DFN,"D",DAY,8)),U)=$GET(PRSTW(DAY)))
QUIT
+3 SET $PIECE(Z,"^",3,4)="2^"_TD
SET $PIECE(Z,"^",10,11)=DUZ_"^"_NOW
+4 SET ^PRST(458,PPI,"E",DFN,"D",DAY,0)=Z
if PRSTWB
SET $PIECE(^(8),U,5)=$GET(PRSTW(DAY))
+5 SET ^PRST(458,"ATC",DFN,PPI,DAY)=""
+6 QUIT
+7 ;
+8 ;
SET ; Set ToD
+1 NEW ZLASTPP,OLD,SCH,PRSTW1,PRSTW5
+2 ;get Zero node of emp pp rec, Old ToD, & Prior scheduled ToD.
+3 ;ZLASTPP is true if a ToD present on this day last pp.
+4 SET Z=$GET(^PRST(458,PPI,"E",DFN,"D",DAY,0))
SET PRSTW1=$PIECE($GET(^(8)),U)
SET PRSTW5=$PIECE($GET(^(8)),U,5)
SET OLD=$PIECE(Z,U,2)
SET SCH=$PIECE(Z,U,4)
+5 SET ZLASTPP=$PIECE($GET(^PRST(458,PPI-1,"E",DFN,"D",DAY,0)),U,2)'=""
+6 ;quit if old tour and its time segments/telework tour=edited one
+7 IF OLD=TD
IF $GET(^PRST(458,PPI,"E",DFN,"D",DAY,1))=Y
IF PRSTW1=$GET(PRSTW(DAY))!'$GET(PRSTWB)
QUIT
+8 ;Z is updated with new ToD info & replaces the emp ToD record.
+9 SET $PIECE(Z,U,8)=TDH
SET $PIECE(Z,U,10,11)=DUZ_U_NOW
+10 ; remove holiday flag
IF $PIECE(Z,U,12)
SET $PIECE(Z,U,12)=""
+11 ;Temp ToD, store T&L ToD will be worked if it's not emp's usual t&l.
+12 IF TYP
IF TLI'=WTL
SET $PIECE(Z,U,9)=WTL
+13 ;no existing ToD on this day.
+14 IF OLD=""
SET $PIECE(Z,U,1,3)=DAY_U_TD_U_TYP
if ZLASTPP
DO S0
DO S1
if $GET(PRSTWB)
DO S8($GET(PRSTW(DAY)),1)
QUIT
+15 ;clean out postings and other ToD info since ToD is changing
+16 DO CLEANTOD(PPI,DFN,DAY,TD)
+17 IF SCH=""
SET $PIECE(Z,U,2,4)=TD_U_TYP_U_OLD
DO S0
DO S1
if $GET(PRSTWB)
DO S8($GET(PRSTW(DAY)),1)
DO S8(PRSTW1,5)
QUIT
+18 SET $PIECE(Z,U,5,7)="^^"
+19 IF SCH=TD
IF PRSTW5=$GET(PRSTW(DAY))!'$GET(PRSTWB)
SET $PIECE(Z,U,2,4)=TD_"^^"
KILL ^PRST(458,"ATC",DFN,PPI,DAY)
DO S1
if $GET(PRSTWB)
DO S8("",5)
DO S8($GET(PRSTW(DAY)),1)
QUIT
+20 SET $PIECE(Z,U,2,3)=TD_U_TYP
DO S0
DO S1
if $GET(PRSTWB)
DO S8($GET(PRSTW(DAY)),1)
+21 QUIT
+22 ;
+23 ;
+24 ; Set up x-ref for supervisor approval of ToD change
+25 ;
S0 SET ^PRST(458,"ATC",DFN,PPI,DAY)=""
+1 QUIT
+2 ;
+3 ;
S1 ;
+1 SET ^PRST(458,PPI,"E",DFN,"D",DAY,0)=Z
if Y'=""
SET ^(1)=Y
+2 QUIT
+3 ;
+4 ;a=telework tour reg/med, b=1 if reg/temp tour, 5 if prior/next tour
S8(A,B) ;set telework tour in node 8 of daily multiple
+1 ;prstwb=1 telework eligible
+2 IF '$GET(PRSTWB)
KILL ^PRST(458,PPI,"E",DFN,"D",DAY,8)
QUIT
+3 SET $PIECE(^PRST(458,PPI,"E",DFN,"D",DAY,8),U,B)=A
+4 ; if no telework data then clean up
+5 IF ^PRST(458,PPI,"E",DFN,"D",DAY,8)?."^"
KILL ^PRST(458,PPI,"E",DFN,"D",DAY,8)
+6 QUIT
+7 ;
+8 ;
T2 ; Ask if second ToD
+1 NEW X
+2 ;
+3 ; Don't ask for Daily ToDs
+4 ;
+5 if $EXTRACT(ENT,1)="D"
QUIT
+6 ;
+7 SET X=$$ASK2NDTR()
+8 if X'="Y"
QUIT
GOTO ^PRSATE4
+9 ;
+10 ;
HOL ; Determine if Holiday within ToD
+1 NEW DAY
+2 DO ^PRSAPPH
+3 if '$DATA(HOL)
QUIT
+4 SET TT="HX"
SET DUP=1
+5 DO E^PRSAPPH
KILL DUP,HOL,TT
+6 QUIT
+7 ;
+8 ;
CLEANTOD(PPI,DFN,DAY,TD) ; CLEAN OUT TOUR
+1 NEW PRSDT,MIEN
+2 KILL ^PRST(458,PPI,"E",DFN,"D",DAY,1),^(2),^(3),^(10),^(8)
IF TD<5
KILL ^(4)
SET $PIECE(Z,U,13,15)="^^"
+3 ; if employee is PTP with active memo then reset the ESR day
+4 SET PRSDT=$PIECE($GET(^PRST(458,PPI,1)),U,DAY)
+5 SET MIEN=$$MIEN^PRSPUT1(DFN,PRSDT)
+6 IF MIEN
Begin DoDot:1
+7 NEW PRSFDA
+8 ; status = resubmit
SET PRSFDA(458.02,DAY_","_DFN_","_PPI_",",146)="3"
+9 ; remarks
SET PRSFDA(458.02,DAY_","_DFN_","_PPI_",",148)="Tour Changed"
+10 DO FILE^DIE("","PRSFDA")
DO MSG^DIALOG()
End DoDot:1
+11 QUIT
+12 ;
+13 ;
ERROR(NUM,VAR1,VAR2) ;
+1 WRITE *7,!!
+2 IF NUM=1
WRITE "Employee has no Pay Entitlement table entry."
+3 IF NUM=2
Begin DoDot:1
+4 if $GET(NH)=112
QUIT
+5 WRITE "Warning: Normal Hours are ",$GET(VAR1),"; Tour Hours are ",$GET(VAR2)
End DoDot:1
+6 QUIT
+7 ;
+8 ;
ASKFIXED() ;GET USER'S YES OR NO RESPONSE TO FIXED ToD QUESTION
+1 NEW DIR,DIRUT,Y
+2 SET DIR("A")="Do you wish to enter a fixed Mon-Fri Tour"
+3 SET DIR(0)="Y"
+4 SET DIR("?")="Answer NO to create any other type of tour."
+5 SET DIR("?",1)="Fixed tours are Monday - Friday with the same hours."
+6 DO ^DIR
+7 QUIT $SELECT(Y=1:"Y",Y=0:"N",1:"^")
+8 ;
+9 ;
ASK2NDTR() ;GET USER'S YES OR NO RESPONSE TO 2nd ToD QUESTION
+1 NEW DIR,DIRUT,Y
+2 SET DIR("A")="Do you wish to enter a Second Tour"_$SELECT($GET(SRT)="X":"",1:" for any Day")
+3 SET DIR(0)="Y"
+4 SET DIR("B")="N"
+5 SET DIR("?",1)="Answer Yes to add a second tour. No to continue."
+6 SET DIR("?")="Enter ^ to escape and cancel this tour change."
+7 DO ^DIR
+8 QUIT $SELECT(Y=1:"Y",Y=0:"N",1:"^")
+9 ;
+10 ;
