PRSATE5 ;WCIOFO/PLT-Check for Tour Overlap ;7/8/08 14:34
;;4.0;PAID;**117,121**;Sep 21, 1995;Build 2
;;Per VHA Directive 2004-038, this routine should not be modified.
;
ENT ;tour overlap check for all 14 days in file of a pp and an employee
N DAY
K PRSERR F DAY=1:1:14 D PPTDOL(SRT,PPI,DFN,DAY,.PRSDAY,1) QUIT:$G(PRSERR)
QUIT
;
;srt=l for last pp, c for current, n for next, x for transmitted pp
;ppi=ien for file # 458
;dfn=ien of file #450
;day=day number 1, 2,...14
;.prsday(day) pass by '.' - local pp tour data retrived if defined
;^1=day #, ^2= tour ien of 457.1, ^3=temporary tour? 0,1,2 (next pp),
;^4= prior tour ien of 457.1
;^5=1 if secondary tour overlapped, ^6=secondary ien of 471.1
;^7,999=secondary tour hour segment
;prsc=1 check day-1 only (used all days check in pp)
; >1 check day-1 and day+1 (used one day check)
PPTDOL(SRT,PPI,DFN,DAY,PRSDAY,PRSC) ;tour check for one day in a pp, define prserr=day if overlapped
N A,B,C,I,PRS0,PRS1,PRS4,PRS71
I '$G(PRSDAY(DAY)) S PRS0=$G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),PRS1=$G(^(1)),PRS4=$G(^(4))
E S PRS0=PRSDAY(DAY),PRS1=$P($$TOUR($P(PRS0,U,2)),"~",2,999),PRS4=$P($$TOUR($P(PRS0,U,6)),"~",2,999)
D:SRT="N" NPP D:"LCX"[SRT LCPP:PRS1]""
QUIT
;
NPP ;next pp (no secondary tour)
S PRS71=$S($P(PRS0,U,3):$P(PRS0,U,4),1:$P(PRS0,U,2)),A=$$TOUR(PRS71),B=$$DAYT(PPI,DFN,SRT,DAY-1,.PRSDAY)
;if day-1 is a two-day tour
I $P(B,"~")="Y",$$TOUROL($P(A,"~",2),$P(B,"~",2),4) D ERR(DAY,DAY-1,1) G:$G(PRSERR)=DAY NEXIT
I DAY=1,$P(B,"~",3)="Y",$$TOUROL($P(A,"~",2),$P(B,"~",4),4) D ERR(DAY,DAY-1,3) G:$G(PRSERR)=DAY NEXIT
;if day is a two-day tour
I $P(A,"~")="Y",DAY=14!(PRSC>1) S C=$$DAYT(PPI,DFN,SRT,DAY+1,.PRSDAY) I $$TOUROL($P(A,"~",2),$P(C,"~",2),3) D ERR(DAY,DAY+1,1) G:$G(PRSERR)=DAY NEXIT
NEXIT QUIT
;
LCPP ;last, current or transmitted pp
;check tour and secondary tours for the day
I PRS4]"",$$TOUROL(PRS1,PRS4,"") D ERR(DAY,DAY,"") G:$G(PRSERR)=DAY LCEXIT
;day-1 tour or secondary is two-day tour
S B=$$DAYT(PPI,DFN,SRT,DAY-1,.PRSDAY)
F I=1,3 I $P(B,"~",I)="Y",$$TOUROL(PRS1,$P(B,"~",I+1),4) D ERR(DAY,DAY-1,I) G:$G(PRSERR)=DAY LCEXIT
I PRS4]"" F I=1,3 I $P(B,"~",I)="Y",$$TOUROL(PRS4,$P(B,"~",I+1),4) D ERR(DAY,DAY-1,I+1) G:$G(PRSERR)=DAY LCEXIT
QUIT:DAY'=14&(PRSC=1)
;day tour or secondary is two day tour
S PRS71=$P(PRS0,U,2),A=$$TOUR(PRS71),PRS71=$P(PRS0,U,$S($G(PRSDAY(DAY)):6,1:13)),B=$$TOUR(PRS71)
QUIT:$P(A,"~")'="Y"&($P(B,"~")'="Y")
;check day+1 including day 14
S C=$$DAYT(PPI,DFN,SRT,DAY+1,.PRSDAY) QUIT:$P(C,"~",2)=""
I $P(A,"~")="Y" F I=2,4 I $P(C,"~",I)]"",$$TOUROL(PRS1,$P(C,"~",I),3) D ERR(DAY,DAY+1,I-1) G:$G(PRSERR)=DAY LCEXIT
I $P(B,"~")="Y" F I=2,4 I $P(C,"~",I)]"",$$TOUROL(PRS4,$P(C,"~",I),3) D ERR(DAY,DAY+1,I) G:$G(PRSERR)=DAY LCEXIT
LCEXIT QUIT
;
;a= ien of file #457.1
TOUR(A) ;ef: ~1=y if two day tour, ~2,999 =tour string
QUIT:A<1 "~"
QUIT $P($G(^PRST(457.1,A,0)),U,5)_"~"_$G(^(1))
;
;ppi= ien of 458, dfn= ien of 458
;a=l(ast), c(urrent), n(ext), x(transmit) pp
;b=day # (0,1,2,...13,14,15) of the pp
;.prsday = pass by '.'
DAYT(PPI,DFN,A,B,PRSDAY) ;ef: ~1=y if two-day tour, ~2 - tour string, ~3=y if two-day tour of secondary, ~4=secondary tour
N C,D,E,F,G
S C=$S(B=0&(A'="N"):PPI-1,B=15&("LX"[A):PPI+1,1:PPI),D=$S(B=0:14,B=15:1,1:B)
I PPI=C,$G(PRSDAY(D)) S E=$G(PRSDAY(D)) QUIT:A="N"&B!(A="C"&(B=15)) $$TOUR($S($P(E,U,3):$P(E,U,4),1:$P(E,U,2))) QUIT $$TOUR($P(E,U,2))_"~"_$P($$TOUR($P(E,U,6)),"~")_"~"_$P(E,U,7,999)
S E=$G(^PRST(458,C,"E",DFN,"D",D,0)),F=$G(^(1))_"~"_$G(^(4)),G=$P(E,U,13)
QUIT:A="N"&B!(A="C"&(B=15)) $$TOUR($S($P(E,U,3):$P(E,U,4),1:$P(E,U,2)))
QUIT $P($$TOUR($P(E,U,2)),"~")_"~"_$P(F,"~")_$S(G:"~"_$P($$TOUR(G),"~")_"~"_$P(F,"~",2),1:"")
;
;
;tour of duty overlap check
;a=string of tour of duty, b=string of dour of duty
;string of tour of duty = start time^end time^special code^start time^...
;c - parameter is for checking tour string b against string a with options
;c = "" check tour string b against a
;c = 1 checked for first day tour of b only, 2 for second day only
;c = 3 checked for first day tour of b as second day, 4 for second day as first day
;c = 2 and 4 are only for b tour string with two-day tour
TOUROL(A,B,C) ;ef: =0 if not overlapped, =1 if overlapped
N D,E,F,G,I,X,Y,Z
;connect hour segments in a and set start/end militay time in array d
S Z=0,E=0 F I=1:1 S X=$P(A,U,I) QUIT:$P(A,U,I,999)="" I I#3'=0 S Y=I>1 D MIL^PRSATIM S:Y<Z!(Y=Z&(I#3=2)) E=E+2400 S Z=Y,Y=E+Y,D(Y)=$G(D(Y))_(I#3) K:$G(D(Y))=21 D(Y)
;set hour segments in b to f with military time
S (Z,E,G)=0,F="" F I=1:1 S X=$P(B,U,I) QUIT:$P(B,U,I,999)="" I I#3'=0 S Y=I>1 D MIL^PRSATIM S:Y<Z!(Y=Z&(I#3=2)) E=E+2400 S Z=Y,Y=E+Y,G=G+1,$P(F,U,G)=Y
;connect hour segments, that is remove same end/start time
F I=2:2 QUIT:$P(F,U,I)="" S:$P(F,U,I)=$P(F,U,I+1) $P(F,U,I,I+2)=$P(F,U,I+2),I=I-2
;select first day hour segments from f and put in d if c#2=1, second day hour segmentd from f to d if c#2=0
S D=F I C S:C#2=0 D="" F I=1:2 QUIT:$P(F,U,I)="" I C#2=1&($P(F,U,I)>2359)!(C#2=0&($P(F,U,I+1)>2400)) S:C#2=1 D=$P(F,U,1,I-1) S:C#2=0 D=$P(F,U,I,999) QUIT
;add 2400 to hour segment of first day tour if c=3 and -2400 to hour segment of second day tour if c=4
I C>2 F I=1:1 QUIT:$P(D,U,I)="" S $P(D,U,I)=$S(C=4:-2400,1:2400)+$P(D,U,I) S:D<0&(I=1)&(C=4) $P(D,U,1)=0 I $P(D,U,I)>4800 S $P(D,U,I)=4800 QUIT
;check overlap
S C=0 F I=1:2 S E=$P(D,U,I) QUIT:E=""!C S G=$O(D(E)),C=$S(G'=$O(D($P(D,U,I+1)-1)):1,'G:0,D(G)'=1:1,1:0)
QUIT C
;
;a = day number, b=day number
;c="" if a=b a's primary, a's secondary
;c=1 a's primary, b's primary tour, =3 a's primary, b's secondary
;c=2 a's secondary, b's primary, =4 a's secondary, b's secondary
ERR(A,B,C) ;define prserr=a
N D,E,F,PPID
S F=PPE S:SRT="N" F=$P($$DTPP^PRSU1B2($P($$PPDT^PRSU1B2(PPE,1),U,4)+14,"H"),U,2)
S PPID=$S(SRT="X":"Xmitted",SRT="C":"Current",SRT="N":"Next",1:"Last")
I A'=B S D(1)="ERROR: "_PPID_"-PP "_F_", Day "_A_" "_$S(C#2=1:"Primary",1:"Secondary")_" overlaps Day "_$S(B=0:14,B=15:1,1:B)_" "_$S(C<3:"Primary",1:"Secondary")_$S(A=1&(B=0):" of prior PP",A=14&(B=15):" of next PP",1:"")
E S D(1)="ERROR: "_PPID_"-PP "_F_", Day "_A_" Secondary Tour overlaps Primary Tour"
S PRSERR=A I '$D(DDSFILE) D EN^DDIOL(.D) QUIT
D HLP^DDSUTL(.D)
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSATE5 6399 printed Dec 13, 2024@02:24:31 Page 2
PRSATE5 ;WCIOFO/PLT-Check for Tour Overlap ;7/8/08 14:34
+1 ;;4.0;PAID;**117,121**;Sep 21, 1995;Build 2
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
ENT ;tour overlap check for all 14 days in file of a pp and an employee
+1 NEW DAY
+2 KILL PRSERR
FOR DAY=1:1:14
DO PPTDOL(SRT,PPI,DFN,DAY,.PRSDAY,1)
if $GET(PRSERR)
QUIT
+3 QUIT
+4 ;
+5 ;srt=l for last pp, c for current, n for next, x for transmitted pp
+6 ;ppi=ien for file # 458
+7 ;dfn=ien of file #450
+8 ;day=day number 1, 2,...14
+9 ;.prsday(day) pass by '.' - local pp tour data retrived if defined
+10 ;^1=day #, ^2= tour ien of 457.1, ^3=temporary tour? 0,1,2 (next pp),
+11 ;^4= prior tour ien of 457.1
+12 ;^5=1 if secondary tour overlapped, ^6=secondary ien of 471.1
+13 ;^7,999=secondary tour hour segment
+14 ;prsc=1 check day-1 only (used all days check in pp)
+15 ; >1 check day-1 and day+1 (used one day check)
PPTDOL(SRT,PPI,DFN,DAY,PRSDAY,PRSC) ;tour check for one day in a pp, define prserr=day if overlapped
+1 NEW A,B,C,I,PRS0,PRS1,PRS4,PRS71
+2 IF '$GET(PRSDAY(DAY))
SET PRS0=$GET(^PRST(458,PPI,"E",DFN,"D",DAY,0))
SET PRS1=$GET(^(1))
SET PRS4=$GET(^(4))
+3 IF '$TEST
SET PRS0=PRSDAY(DAY)
SET PRS1=$PIECE($$TOUR($PIECE(PRS0,U,2)),"~",2,999)
SET PRS4=$PIECE($$TOUR($PIECE(PRS0,U,6)),"~",2,999)
+4 if SRT="N"
DO NPP
if "LCX"[SRT
if PRS1]""
DO LCPP
+5 QUIT
+6 ;
NPP ;next pp (no secondary tour)
+1 SET PRS71=$SELECT($PIECE(PRS0,U,3):$PIECE(PRS0,U,4),1:$PIECE(PRS0,U,2))
SET A=$$TOUR(PRS71)
SET B=$$DAYT(PPI,DFN,SRT,DAY-1,.PRSDAY)
+2 ;if day-1 is a two-day tour
+3 IF $PIECE(B,"~")="Y"
IF $$TOUROL($PIECE(A,"~",2),$PIECE(B,"~",2),4)
DO ERR(DAY,DAY-1,1)
if $GET(PRSERR)=DAY
GOTO NEXIT
+4 IF DAY=1
IF $PIECE(B,"~",3)="Y"
IF $$TOUROL($PIECE(A,"~",2),$PIECE(B,"~",4),4)
DO ERR(DAY,DAY-1,3)
if $GET(PRSERR)=DAY
GOTO NEXIT
+5 ;if day is a two-day tour
+6 IF $PIECE(A,"~")="Y"
IF DAY=14!(PRSC>1)
SET C=$$DAYT(PPI,DFN,SRT,DAY+1,.PRSDAY)
IF $$TOUROL($PIECE(A,"~",2),$PIECE(C,"~",2),3)
DO ERR(DAY,DAY+1,1)
if $GET(PRSERR)=DAY
GOTO NEXIT
NEXIT QUIT
+1 ;
LCPP ;last, current or transmitted pp
+1 ;check tour and secondary tours for the day
+2 IF PRS4]""
IF $$TOUROL(PRS1,PRS4,"")
DO ERR(DAY,DAY,"")
if $GET(PRSERR)=DAY
GOTO LCEXIT
+3 ;day-1 tour or secondary is two-day tour
+4 SET B=$$DAYT(PPI,DFN,SRT,DAY-1,.PRSDAY)
+5 FOR I=1,3
IF $PIECE(B,"~",I)="Y"
IF $$TOUROL(PRS1,$PIECE(B,"~",I+1),4)
DO ERR(DAY,DAY-1,I)
if $GET(PRSERR)=DAY
GOTO LCEXIT
+6 IF PRS4]""
FOR I=1,3
IF $PIECE(B,"~",I)="Y"
IF $$TOUROL(PRS4,$PIECE(B,"~",I+1),4)
DO ERR(DAY,DAY-1,I+1)
if $GET(PRSERR)=DAY
GOTO LCEXIT
+7 if DAY'=14&(PRSC=1)
QUIT
+8 ;day tour or secondary is two day tour
+9 SET PRS71=$PIECE(PRS0,U,2)
SET A=$$TOUR(PRS71)
SET PRS71=$PIECE(PRS0,U,$SELECT($GET(PRSDAY(DAY)):6,1:13))
SET B=$$TOUR(PRS71)
+10 if $PIECE(A,"~")'="Y"&($PIECE(B,"~")'="Y")
QUIT
+11 ;check day+1 including day 14
+12 SET C=$$DAYT(PPI,DFN,SRT,DAY+1,.PRSDAY)
if $PIECE(C,"~",2)=""
QUIT
+13 IF $PIECE(A,"~")="Y"
FOR I=2,4
IF $PIECE(C,"~",I)]""
IF $$TOUROL(PRS1,$PIECE(C,"~",I),3)
DO ERR(DAY,DAY+1,I-1)
if $GET(PRSERR)=DAY
GOTO LCEXIT
+14 IF $PIECE(B,"~")="Y"
FOR I=2,4
IF $PIECE(C,"~",I)]""
IF $$TOUROL(PRS4,$PIECE(C,"~",I),3)
DO ERR(DAY,DAY+1,I)
if $GET(PRSERR)=DAY
GOTO LCEXIT
LCEXIT QUIT
+1 ;
+2 ;a= ien of file #457.1
TOUR(A) ;ef: ~1=y if two day tour, ~2,999 =tour string
+1 if A<1
QUIT "~"
+2 QUIT $PIECE($GET(^PRST(457.1,A,0)),U,5)_"~"_$GET(^(1))
+3 ;
+4 ;ppi= ien of 458, dfn= ien of 458
+5 ;a=l(ast), c(urrent), n(ext), x(transmit) pp
+6 ;b=day # (0,1,2,...13,14,15) of the pp
+7 ;.prsday = pass by '.'
DAYT(PPI,DFN,A,B,PRSDAY) ;ef: ~1=y if two-day tour, ~2 - tour string, ~3=y if two-day tour of secondary, ~4=secondary tour
+1 NEW C,D,E,F,G
+2 SET C=$SELECT(B=0&(A'="N"):PPI-1,B=15&("LX"[A):PPI+1,1:PPI)
SET D=$SELECT(B=0:14,B=15:1,1:B)
+3 IF PPI=C
IF $GET(PRSDAY(D))
SET E=$GET(PRSDAY(D))
if A="N"&B!(A="C"&(B=15))
QUIT $$TOUR($SELECT($PIECE(E,U,3):$PIECE(E,U,4),1:$PIECE(E,U,2)))
QUIT $$TOUR($PIECE(E,U,2))_"~"_$PIECE($$TOUR($PIECE(E,U,6)),"~")_"~"_$PIECE(E,U,7,999)
+4 SET E=$GET(^PRST(458,C,"E",DFN,"D",D,0))
SET F=$GET(^(1))_"~"_$GET(^(4))
SET G=$PIECE(E,U,13)
+5 if A="N"&B!(A="C"&(B=15))
QUIT $$TOUR($SELECT($PIECE(E,U,3):$PIECE(E,U,4),1:$PIECE(E,U,2)))
+6 QUIT $PIECE($$TOUR($PIECE(E,U,2)),"~")_"~"_$PIECE(F,"~")_$SELECT(G:"~"_$PIECE($$TOUR(G),"~")_"~"_$PIECE(F,"~",2),1:"")
+7 ;
+8 ;
+9 ;tour of duty overlap check
+10 ;a=string of tour of duty, b=string of dour of duty
+11 ;string of tour of duty = start time^end time^special code^start time^...
+12 ;c - parameter is for checking tour string b against string a with options
+13 ;c = "" check tour string b against a
+14 ;c = 1 checked for first day tour of b only, 2 for second day only
+15 ;c = 3 checked for first day tour of b as second day, 4 for second day as first day
+16 ;c = 2 and 4 are only for b tour string with two-day tour
TOUROL(A,B,C) ;ef: =0 if not overlapped, =1 if overlapped
+1 NEW D,E,F,G,I,X,Y,Z
+2 ;connect hour segments in a and set start/end militay time in array d
+3 SET Z=0
SET E=0
FOR I=1:1
SET X=$PIECE(A,U,I)
if $PIECE(A,U,I,999)=""
QUIT
IF I#3'=0
SET Y=I>1
DO MIL^PRSATIM
if Y<Z!(Y=Z&(I#3=2))
SET E=E+2400
SET Z=Y
SET Y=E+Y
SET D(Y)=$GET(D(Y))_(I#3)
if $GET(D(Y))=21
KILL D(Y)
+4 ;set hour segments in b to f with military time
+5 SET (Z,E,G)=0
SET F=""
FOR I=1:1
SET X=$PIECE(B,U,I)
if $PIECE(B,U,I,999)=""
QUIT
IF I#3'=0
SET Y=I>1
DO MIL^PRSATIM
if Y<Z!(Y=Z&(I#3=2))
SET E=E+2400
SET Z=Y
SET Y=E+Y
SET G=G+1
SET $PIECE(F,U,G)=Y
+6 ;connect hour segments, that is remove same end/start time
+7 FOR I=2:2
if $PIECE(F,U,I)=""
QUIT
if $PIECE(F,U,I)=$PIECE(F,U,I+1)
SET $PIECE(F,U,I,I+2)=$PIECE(F,U,I+2)
SET I=I-2
+8 ;select first day hour segments from f and put in d if c#2=1, second day hour segmentd from f to d if c#2=0
+9 SET D=F
IF C
if C#2=0
SET D=""
FOR I=1:2
if $PIECE(F,U,I)=""
QUIT
IF C#2=1&($PIECE(F,U,I)>2359)!(C#2=0&($PIECE(F,U,I+1)>2400))
if C#2=1
SET D=$PIECE(F,U,1,I-1)
if C#2=0
SET D=$PIECE(F,U,I,999)
QUIT
+10 ;add 2400 to hour segment of first day tour if c=3 and -2400 to hour segment of second day tour if c=4
+11 IF C>2
FOR I=1:1
if $PIECE(D,U,I)=""
QUIT
SET $PIECE(D,U,I)=$SELECT(C=4:-2400,1:2400)+$PIECE(D,U,I)
if D<0&(I=1)&(C=4)
SET $PIECE(D,U,1)=0
IF $PIECE(D,U,I)>4800
SET $PIECE(D,U,I)=4800
QUIT
+12 ;check overlap
+13 SET C=0
FOR I=1:2
SET E=$PIECE(D,U,I)
if E=""!C
QUIT
SET G=$ORDER(D(E))
SET C=$SELECT(G'=$ORDER(D($PIECE(D,U,I+1)-1)):1,'G:0,D(G)'=1:1,1:0)
+14 QUIT C
+15 ;
+16 ;a = day number, b=day number
+17 ;c="" if a=b a's primary, a's secondary
+18 ;c=1 a's primary, b's primary tour, =3 a's primary, b's secondary
+19 ;c=2 a's secondary, b's primary, =4 a's secondary, b's secondary
ERR(A,B,C) ;define prserr=a
+1 NEW D,E,F,PPID
+2 SET F=PPE
if SRT="N"
SET F=$PIECE($$DTPP^PRSU1B2($PIECE($$PPDT^PRSU1B2(PPE,1),U,4)+14,"H"),U,2)
+3 SET PPID=$SELECT(SRT="X":"Xmitted",SRT="C":"Current",SRT="N":"Next",1:"Last")
+4 IF A'=B
SET D(1)="ERROR: "_PPID_"-PP "_F_", Day "_A_" "_$SELECT(C#2=1:"Primary",1:"Secondary")_" overlaps Day "_$SELECT(B=0:14,B=15:1,1:B)_" "_$SELECT(C<3:"Primary",1:"Secondary")_$SELECT(A=1&(B=0):" of prior PP",A=14&(B=15):" of next PP",1:"")
+5 IF '$TEST
SET D(1)="ERROR: "_PPID_"-PP "_F_", Day "_A_" Secondary Tour overlaps Primary Tour"
+6 SET PRSERR=A
IF '$DATA(DDSFILE)
DO EN^DDIOL(.D)
QUIT
+7 DO HLP^DDSUTL(.D)
+8 QUIT
