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

PRSATE.m

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