- PRSATE0 ;WCIOFO/PLT - Data Validate for Edit Variable Tours ;7/18/08 14:37
- ;;4.0;PAID;**112,117,132**;Sep 21, 1995;Build 13
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- N PRSTWO
- S TOLD="" F K=1:1:14 S Z=$P($G(^PRST(458,PPI,"E",DFN,"D",K,0)),"^",2),$P(TOLD,"^",K)=Z S:SRT="N"&$P($G(^(0)),"^",3) $P(TOLD,"^",K)=$P(^(0),"^",4) S:PRSTWB (PRSTW(K),PRSTWO(K))=$P($G(^(8)),U,$S(SRT="N"&$P($G(^(0)),"^",3):5,1:1))
- K K S ^PRST(458,PPI,"E",DFN,"T")=TOLD D DT^PRSATE2
- N DDSFILE,DA,DR,PRSAERR,DDSBR
- S DDSFILE=458,DDSFILE(1)=458.01,DA(1)=PPI,DA=DFN
- S DR="[PRSA TE EDIT]" D ^DDS K DS Q:$D(PRSAERR)
- S TNEW=$G(^PRST(458,PPI,"E",DFN,"T")) K ^PRST(458,PPI,"E",DFN,"T")
- I '$D(^PRST(458,PPI,"E",DFN,"D",0)) S ^(0)="^458.02^14^14"
- F DAY=1:1:14 S TD=$P(TNEW,"^",DAY) I TD>0 D S1
- K TNEW,TOLD
- QUIT
- ;
- S1 ; Set Tour if necessary
- I '$G(PRSTWB),$D(^PRST(458,PPI,"E",DFN,"D",DAY,8)) K ^PRST(458,PPI,"E",DFN,"D",DAY,8)
- I TD=$P(TOLD,"^",DAY),$G(^PRST(457.1,+TD,1))=$G(^PRST(457.1,+$P(TOLD,"^",DAY),1)),$G(PRSTW(DAY))=$G(PRSTWO(DAY))!'$G(PRSTWB) QUIT
- I SRT'="N" S Y=$G(^PRST(457.1,TD,1)),TDH=$P(^(0),"^",6) D SET^PRSATE QUIT
- D NX^PRSATE
- QUIT
- ;
- VS ; Validate tour segments
- S TRG=0 F K=1:3:19 Q:$P(Y,"^",K)="" S Z=$P(Y,"^",K+2) S:'Z TRG=1 I Z D
- . S Z=$P($G(^PRST(457.2,Z,0)),"^",2) I Z="RG" S TRG=1 Q
- . I ZENT'[Z S STR="Tour Indicator contains type of time to which employee is not entitled."
- . QUIT
- QUIT
- ;
- VAL ; Validate Tour
- K PRSETD,PRSDAY
- F DAY=1:1:14 S $P(PRSETD,U,DAY)=$$GET^DDSVAL(DIE,.DA,DAY+200)
- G:TOLD=PRSETD VAL2
- ;tour overlap validate
- ;load prsday(day) before save
- F DAY=1:1:14 S PRSDAY(DAY)=$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),U,1,4),$P(PRSDAY(DAY),U,6)=$P($G(^(0)),U,13),$P(PRSDAY(DAY),U,7,999)=$G(^(4)) D PRSDAY
- ;check tour overlap
- D ENT^PRSATE5 I $G(PRSERR) S DDSERROR=1,DDSBR=PRSERR+10_"^1^1" K PRSERR QUIT
- ;
- VAL2 N NAWS,SNAWS,TDT S (ZENT,STR)="" K PRSAERR D OT^PRSATP S DB=$P(C0,U,10) I "KM"[PP,DB=1,NH=72 S NAWS=1
- S (HRS,TRS,TDT)=0 F DAY=1:1:14 D QUIT:STR'=""
- . S TD=$P(PRSETD,U,DAY),Z=$P($G(^PRST(457.1,+TD,0)),"^",6) S:Z HRS=HRS+Z S Y=$G(^(1))
- . I DAY=7!(DAY=14)&'TDT S TDT=$P($G(^PRST(457.1,+TD,0)),U,5)="Y"
- . I $D(NAWS) S:Z'=12&Z NAWS=0 S $P(SNAWS,U,DAY)=TD I Z=12 S NAWS(DAY-1\7+1)=$G(NAWS(DAY-1\7+1))+1
- . D VS S:TRG TRS=TRS+1
- . QUIT
- G:STR'="" V1
- I FLX="C",TRS>9 S STR="Warning: Compressed Schedule has more than 9 Tours!" D HLP^DDSUTL(.STR)
- I NH'=HRS,NH'=112 S STR="Warning: Normal Hours are "_NH_"; Tour Hours are "_HRS D HLP^DDSUTL(.STR)
- I $D(NAWS) D
- .I $G(NAWS(1))'=3!($G(NAWS(2))'=3)!'NAWS S STR=$P($T(NAWS1),";",3) D HLP^DDSUTL(.STR)
- .D TOURHRS^PRSARC07(.HRS,PPI,DFN,SNAWS)
- .I $G(HRS("W1"))'=36!($G(HRS("W2"))'=36) S STR=$P($T(NAWS2),";",3) D HLP^DDSUTL(.STR)
- .I $G(TDT) S STR=$P($T(NAWS3),";",3) D HLP^DDSUTL(.STR)
- K K,STR,TRG,TRS QUIT
- ;
- PRSDAY ;update prsday with new data (like codes in label set of prsate)
- I $P(PRSDAY(DAY),U,2)="" S $P(PRSDAY(DAY),U,1,3)=DAY_U_$P(PRSETD,U,DAY)_U_TYP QUIT:SRT'="N"
- I SRT="N" S $P(PRSDAY(DAY),"^",3,4)="2^"_$P(PRSETD,U,DAY) QUIT
- I $P(TOLD,U,DAY)=$P(PRSETD,U,DAY),$P($$TOUR^PRSATE5($P(PRSETD,U,DAY)),"~",2)=$G(^PRST(458,PPI,"E",DFN,"D",DAY,1)) QUIT
- I $P(PRSDAY(DAY),U,4)="" S $P(PRSDAY(DAY),U,2,4)=$P(PRSETD,U,DAY)_U_TYP_U_$P(PRSDAY(DAY),U,2)
- E I $P(PRSDAY(DAY),U,4)=$P(PRSETD,U,DAY) S $P(PRSDAY(DAY),U,2,4)=$P(PRSETD,U,DAY)_"^^"
- E S $P(PRSDAY(DAY),U,2,3)=$P(PRSETD,U,DAY)_U_TYP
- QUIT
- ;
- ;allow to file, ddserror is kill after set = 1, all other checks are aborted
- V1 S (DDSERROR,PRSAERR)=1 D HLP^DDSUTL(.STR) K DDSERROR Q
- NAWS1 ;;Warning: There are not three 12 hour tours in week 1 and/or week 2 for this AWS 36/40 Nurse
- NAWS2 ;;Warning: Hours in week 1 and/or week 2 are not 36 for this AWS 36/40 Nurse.
- NAWS3 ;;Warning: Tour overlaps two administrative work weeks for this 36/40 Nurse.
- ;
- ;a=ien of 450, b=[ien of 458], c=[ien (day # 1 to 14) of 458.02]
- ;d=[1 if pp/tem tour of dute, 5 if prior/next]
- TWE(A,B,C,D) ;ef=^1-emp 450 tw indicator, ^2=emp eligible code, ^3-emp pp 458 tw
- ; ^4 emp pp eliglble code, ^5-daily tw tour
- N E
- S:'$G(D) D=1 S E=$$TWP($P($G(^PRSPC(A,1)),U,45))
- QUIT:'$G(B) E
- QUIT E_U_$S("PX"[$P($G(^PRST(458,B,"E",A,0)),U,2):$$TWP($P($G(^(0)),U,8)),1:E)_$S($G(C):U_$P($G(^PRST(458,B,"E",A,"D",C,8)),U,D),1:"")
- ;
- ;a=telework paid code of file#454, [b=1 for return with description]
- TWP(A,B) ;ef=^1-telework code, ^2-eligible code, ^3-description
- QUIT:A="" U
- S A=$O(^PRSP(454,1,"TW","B",A,0)) QUIT:'A U
- S A=^PRSP(454,1,"TW",A,0)
- QUIT $P(A,U)_U_$P(A,U,3)_$S($G(B):U_$P(A,U,2),1:"")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSATE0 4631 printed Feb 18, 2025@23:50:58 Page 2
- PRSATE0 ;WCIOFO/PLT - Data Validate for Edit Variable Tours ;7/18/08 14:37
- +1 ;;4.0;PAID;**112,117,132**;Sep 21, 1995;Build 13
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 NEW PRSTWO
- +5 SET TOLD=""
- FOR K=1:1:14
- SET Z=$PIECE($GET(^PRST(458,PPI,"E",DFN,"D",K,0)),"^",2)
- SET $PIECE(TOLD,"^",K)=Z
- if SRT="N"&$PIECE($GET(^(0)),"^",3)
- SET $PIECE(TOLD,"^",K)=$PIECE(^(0),"^",4)
- if PRSTWB
- SET (PRSTW(K),PRSTWO(K))=$PIECE($GET(^(8)),U,$SELECT(SRT="N"&$PIECE($GET(^(0)),"^",3):5,1:1))
- +6 KILL K
- SET ^PRST(458,PPI,"E",DFN,"T")=TOLD
- DO DT^PRSATE2
- +7 NEW DDSFILE,DA,DR,PRSAERR,DDSBR
- +8 SET DDSFILE=458
- SET DDSFILE(1)=458.01
- SET DA(1)=PPI
- SET DA=DFN
- +9 SET DR="[PRSA TE EDIT]"
- DO ^DDS
- KILL DS
- if $DATA(PRSAERR)
- QUIT
- +10 SET TNEW=$GET(^PRST(458,PPI,"E",DFN,"T"))
- KILL ^PRST(458,PPI,"E",DFN,"T")
- +11 IF '$DATA(^PRST(458,PPI,"E",DFN,"D",0))
- SET ^(0)="^458.02^14^14"
- +12 FOR DAY=1:1:14
- SET TD=$PIECE(TNEW,"^",DAY)
- IF TD>0
- DO S1
- +13 KILL TNEW,TOLD
- +14 QUIT
- +15 ;
- S1 ; Set Tour if necessary
- +1 IF '$GET(PRSTWB)
- IF $DATA(^PRST(458,PPI,"E",DFN,"D",DAY,8))
- KILL ^PRST(458,PPI,"E",DFN,"D",DAY,8)
- +2 IF TD=$PIECE(TOLD,"^",DAY)
- IF $GET(^PRST(457.1,+TD,1))=$GET(^PRST(457.1,+$PIECE(TOLD,"^",DAY),1))
- IF $GET(PRSTW(DAY))=$GET(PRSTWO(DAY))!'$GET(PRSTWB)
- QUIT
- +3 IF SRT'="N"
- SET Y=$GET(^PRST(457.1,TD,1))
- SET TDH=$PIECE(^(0),"^",6)
- DO SET^PRSATE
- QUIT
- +4 DO NX^PRSATE
- +5 QUIT
- +6 ;
- VS ; Validate tour segments
- +1 SET TRG=0
- FOR K=1:3:19
- if $PIECE(Y,"^",K)=""
- QUIT
- SET Z=$PIECE(Y,"^",K+2)
- if 'Z
- SET TRG=1
- IF Z
- Begin DoDot:1
- +2 SET Z=$PIECE($GET(^PRST(457.2,Z,0)),"^",2)
- IF Z="RG"
- SET TRG=1
- QUIT
- +3 IF ZENT'[Z
- SET STR="Tour Indicator contains type of time to which employee is not entitled."
- +4 QUIT
- End DoDot:1
- +5 QUIT
- +6 ;
- VAL ; Validate Tour
- +1 KILL PRSETD,PRSDAY
- +2 FOR DAY=1:1:14
- SET $PIECE(PRSETD,U,DAY)=$$GET^DDSVAL(DIE,.DA,DAY+200)
- +3 if TOLD=PRSETD
- GOTO VAL2
- +4 ;tour overlap validate
- +5 ;load prsday(day) before save
- +6 FOR DAY=1:1:14
- SET PRSDAY(DAY)=$PIECE($GET(^PRST(458,PPI,"E",DFN,"D",DAY,0)),U,1,4)
- SET $PIECE(PRSDAY(DAY),U,6)=$PIECE($GET(^(0)),U,13)
- SET $PIECE(PRSDAY(DAY),U,7,999)=$GET(^(4))
- DO PRSDAY
- +7 ;check tour overlap
- +8 DO ENT^PRSATE5
- IF $GET(PRSERR)
- SET DDSERROR=1
- SET DDSBR=PRSERR+10_"^1^1"
- KILL PRSERR
- QUIT
- +9 ;
- VAL2 NEW NAWS,SNAWS,TDT
- SET (ZENT,STR)=""
- KILL PRSAERR
- DO OT^PRSATP
- SET DB=$PIECE(C0,U,10)
- IF "KM"[PP
- IF DB=1
- IF NH=72
- SET NAWS=1
- +1 SET (HRS,TRS,TDT)=0
- FOR DAY=1:1:14
- Begin DoDot:1
- +2 SET TD=$PIECE(PRSETD,U,DAY)
- SET Z=$PIECE($GET(^PRST(457.1,+TD,0)),"^",6)
- if Z
- SET HRS=HRS+Z
- SET Y=$GET(^(1))
- +3 IF DAY=7!(DAY=14)&'TDT
- SET TDT=$PIECE($GET(^PRST(457.1,+TD,0)),U,5)="Y"
- +4 IF $DATA(NAWS)
- if Z'=12&Z
- SET NAWS=0
- SET $PIECE(SNAWS,U,DAY)=TD
- IF Z=12
- SET NAWS(DAY-1\7+1)=$GET(NAWS(DAY-1\7+1))+1
- +5 DO VS
- if TRG
- SET TRS=TRS+1
- +6 QUIT
- End DoDot:1
- if STR'=""
- QUIT
- +7 if STR'=""
- GOTO V1
- +8 IF FLX="C"
- IF TRS>9
- SET STR="Warning: Compressed Schedule has more than 9 Tours!"
- DO HLP^DDSUTL(.STR)
- +9 IF NH'=HRS
- IF NH'=112
- SET STR="Warning: Normal Hours are "_NH_"; Tour Hours are "_HRS
- DO HLP^DDSUTL(.STR)
- +10 IF $DATA(NAWS)
- Begin DoDot:1
- +11 IF $GET(NAWS(1))'=3!($GET(NAWS(2))'=3)!'NAWS
- SET STR=$PIECE($TEXT(NAWS1),";",3)
- DO HLP^DDSUTL(.STR)
- +12 DO TOURHRS^PRSARC07(.HRS,PPI,DFN,SNAWS)
- +13 IF $GET(HRS("W1"))'=36!($GET(HRS("W2"))'=36)
- SET STR=$PIECE($TEXT(NAWS2),";",3)
- DO HLP^DDSUTL(.STR)
- +14 IF $GET(TDT)
- SET STR=$PIECE($TEXT(NAWS3),";",3)
- DO HLP^DDSUTL(.STR)
- End DoDot:1
- +15 KILL K,STR,TRG,TRS
- QUIT
- +16 ;
- PRSDAY ;update prsday with new data (like codes in label set of prsate)
- +1 IF $PIECE(PRSDAY(DAY),U,2)=""
- SET $PIECE(PRSDAY(DAY),U,1,3)=DAY_U_$PIECE(PRSETD,U,DAY)_U_TYP
- if SRT'="N"
- QUIT
- +2 IF SRT="N"
- SET $PIECE(PRSDAY(DAY),"^",3,4)="2^"_$PIECE(PRSETD,U,DAY)
- QUIT
- +3 IF $PIECE(TOLD,U,DAY)=$PIECE(PRSETD,U,DAY)
- IF $PIECE($$TOUR^PRSATE5($PIECE(PRSETD,U,DAY)),"~",2)=$GET(^PRST(458,PPI,"E",DFN,"D",DAY,1))
- QUIT
- +4 IF $PIECE(PRSDAY(DAY),U,4)=""
- SET $PIECE(PRSDAY(DAY),U,2,4)=$PIECE(PRSETD,U,DAY)_U_TYP_U_$PIECE(PRSDAY(DAY),U,2)
- +5 IF '$TEST
- IF $PIECE(PRSDAY(DAY),U,4)=$PIECE(PRSETD,U,DAY)
- SET $PIECE(PRSDAY(DAY),U,2,4)=$PIECE(PRSETD,U,DAY)_"^^"
- +6 IF '$TEST
- SET $PIECE(PRSDAY(DAY),U,2,3)=$PIECE(PRSETD,U,DAY)_U_TYP
- +7 QUIT
- +8 ;
- +9 ;allow to file, ddserror is kill after set = 1, all other checks are aborted
- V1 SET (DDSERROR,PRSAERR)=1
- DO HLP^DDSUTL(.STR)
- KILL DDSERROR
- QUIT
- NAWS1 ;;Warning: There are not three 12 hour tours in week 1 and/or week 2 for this AWS 36/40 Nurse
- NAWS2 ;;Warning: Hours in week 1 and/or week 2 are not 36 for this AWS 36/40 Nurse.
- NAWS3 ;;Warning: Tour overlaps two administrative work weeks for this 36/40 Nurse.
- +1 ;
- +2 ;a=ien of 450, b=[ien of 458], c=[ien (day # 1 to 14) of 458.02]
- +3 ;d=[1 if pp/tem tour of dute, 5 if prior/next]
- TWE(A,B,C,D) ;ef=^1-emp 450 tw indicator, ^2=emp eligible code, ^3-emp pp 458 tw
- +1 ; ^4 emp pp eliglble code, ^5-daily tw tour
- +2 NEW E
- +3 if '$GET(D)
- SET D=1
- SET E=$$TWP($PIECE($GET(^PRSPC(A,1)),U,45))
- +4 if '$GET(B)
- QUIT E
- +5 QUIT E_U_$SELECT("PX"[$PIECE($GET(^PRST(458,B,"E",A,0)),U,2):$$TWP($PIECE($GET(^(0)),U,8)),1:E)_$SELECT($GET(C):U_$PIECE($GET(^PRST(458,B,"E",A,"D",C,8)),U,D),1:"")
- +6 ;
- +7 ;a=telework paid code of file#454, [b=1 for return with description]
- TWP(A,B) ;ef=^1-telework code, ^2-eligible code, ^3-description
- +1 if A=""
- QUIT U
- +2 SET A=$ORDER(^PRSP(454,1,"TW","B",A,0))
- if 'A
- QUIT U
- +3 SET A=^PRSP(454,1,"TW",A,0)
- +4 QUIT $PIECE(A,U)_U_$PIECE(A,U,3)_$SELECT($GET(B):U_$PIECE(A,U,2),1:"")