- PRSATPH ; HISC/REL-Exception Utilities ;12/9/93 09:53
- ;;4.0;PAID;;Sep 21, 1995
- NX ; Determine first start time of next day
- I DAY<14 S TC1=$P($G(^PRST(458,PPI,"E",DFN,"D",DAY+1,0)),"^",2),TC2=$P($G(^(0)),"^",13) G N1
- I $D(^PRST(458,PPI+1,"E",DFN,"D",1,0)) S TC1=$P(^(0),"^",2),TC2=$P($G(^(0)),"^",13) G N1
- S ZPX=$G(^PRST(458,PPI,"E",DFN,"D",1,0)),TC1=$P(ZPX,"^",2),TC2=""
- S:$P(ZPX,"^",3) TC1=$P(ZPX,"^",4)
- N1 S TC1=$G(^PRST(457.1,+TC1,1)),Z9=""
- F KK=1:3 Q:$P(TC1,"^",KK)="" S Z=$P(TC1,"^",KK+2) I $S('Z:1,1:$P($G(^PRST(457.2,Z,0)),"^",2)="RG") S Z9=$P(TC1,"^",KK) Q
- S TC1=Z9 G:'TC2 N2
- S TC2=$G(^PRST(457.1,TC2,1)),Z9=""
- F KK=1:3 Q:$P(TC2,"^",KK)="" S Z=$P(TC2,"^",KK+2) I $S('Z:1,1:$P($G(^PRST(457.2,Z,0)),"^",2)="RG") S Z9=$P(TC2,"^",KK) Q
- S TC2=Z9
- N2 N X,Y S X=TC1,Y=0 D MIL^PRSATIM S TC1=Y
- I TC2'="" S X=TC2,Y=0 D MIL^PRSATIM S:Y<TC1 TC1=Y
- S TC1=TC1\100*60+(TC1#100) I $P(Y0,"^",2)>TC1 S ERR=10 D ERR^PRSATPE
- Q
- PR ; Determine last end time of previous day
- I DAY>1 S TC1=$P($G(^PRST(458,PPI,"E",DFN,"D",DAY-1,0)),"^",2),TC2=$P($G(^(0)),"^",13)
- E Q:'$D(^PRST(458,PPI-1,"E",DFN,"D",14,0)) S TC1=$P(^(0),"^",2),TC2=$P($G(^(0)),"^",13)
- I $P($G(^PRST(457.1,+TC1,0)),"^",5)="Y" S ZPX=$G(^(1))
- E Q:$P($G(^PRST(457.1,+TC2,0)),"^",5)'="Y" S ZPX=$G(^(1))
- N X,Y S Z="",DY2=1 F KK=1:3:19 S X=$P(ZPX,"^",KK,KK+1) Q:"^"[X D CNV^PRSATIM S:$P(Y,"^",2)'>$P(Y,"^",1) DY2=2 I DY2=2 S Z9=$P(ZPX,"^",KK+2) I $S('Z9:1,1:$P($G(^PRST(457.2,Z9,0)),"^",2)="RG") S Z=$P(Y,"^",2)
- Q:Z="" I Z>$P(Y0,"^",1) S ERR=11 D ERR^PRSATPE
- Q
- UN ; Check UN against OT CT ON SB in tour
- K TUN F KK=1:3 Q:$P(X1,"^",KK)="" S Z=$P(X1,"^",KK+2) I $S('Z:0,1:$P($G(^PRST(457.2,Z,0)),"^",2)'="RG") D
- .S X=$P(X1,"^",KK,KK+1) D CNV^PRSATIM S Z1=$P(Y,"^",1),Z2=$P(Y,"^",2) D V0
- .I Z1'="",$G(TUN(Z1))="*" K TUN(Z1) S TUN(Z2)="*" Q
- .S TUN(Z1)="",TUN(Z2)="*" Q
- I X4'="" F KK=1:3 Q:$P(X4,"^",KK)="" S Z=$P(X4,"^",KK+2) I $S('Z:0,1:$P($G(^PRST(457.2,Z,0)),"^",2)'="RG") D
- .S X=$P(X4,"^",KK,KK+1) D CNV^PRSATIM S Z1=$P(Y,"^",1),Z2=$P(Y,"^",2) D V0
- .I Z1'="",$G(TUN(Z1))="*" K TUN(Z1) S TUN(Z2)="*" Q
- .S TUN(Z1)="",TUN(Z2)="*" Q
- S Z1=$P(Y0,"^",1),Z2=$P(Y0,"^",2) D V0
- S Z1=$O(TUN(Z1)) S:Z1'="" Z1=TUN(Z1)
- S Z2=$O(TUN(Z2-1)) S:Z2'="" Z2=TUN(Z2)
- I Z1'="*"!(Z2'="*") S ERR=12 D ERR^PRSATPE
- Q
- V0 I Z2>Z1 S:$O(TUN(""))'<Z2 Z1=Z1+1440,Z2=Z2+1440 Q
- S Z2=Z2+1440 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSATPH 2383 printed Jan 18, 2025@03:26 Page 2
- PRSATPH ; HISC/REL-Exception Utilities ;12/9/93 09:53
- +1 ;;4.0;PAID;;Sep 21, 1995
- NX ; Determine first start time of next day
- +1 IF DAY<14
- SET TC1=$PIECE($GET(^PRST(458,PPI,"E",DFN,"D",DAY+1,0)),"^",2)
- SET TC2=$PIECE($GET(^(0)),"^",13)
- GOTO N1
- +2 IF $DATA(^PRST(458,PPI+1,"E",DFN,"D",1,0))
- SET TC1=$PIECE(^(0),"^",2)
- SET TC2=$PIECE($GET(^(0)),"^",13)
- GOTO N1
- +3 SET ZPX=$GET(^PRST(458,PPI,"E",DFN,"D",1,0))
- SET TC1=$PIECE(ZPX,"^",2)
- SET TC2=""
- +4 if $PIECE(ZPX,"^",3)
- SET TC1=$PIECE(ZPX,"^",4)
- N1 SET TC1=$GET(^PRST(457.1,+TC1,1))
- SET Z9=""
- +1 FOR KK=1:3
- if $PIECE(TC1,"^",KK)=""
- QUIT
- SET Z=$PIECE(TC1,"^",KK+2)
- IF $SELECT('Z:1,1:$PIECE($GET(^PRST(457.2,Z,0)),"^",2)="RG")
- SET Z9=$PIECE(TC1,"^",KK)
- QUIT
- +2 SET TC1=Z9
- if 'TC2
- GOTO N2
- +3 SET TC2=$GET(^PRST(457.1,TC2,1))
- SET Z9=""
- +4 FOR KK=1:3
- if $PIECE(TC2,"^",KK)=""
- QUIT
- SET Z=$PIECE(TC2,"^",KK+2)
- IF $SELECT('Z:1,1:$PIECE($GET(^PRST(457.2,Z,0)),"^",2)="RG")
- SET Z9=$PIECE(TC2,"^",KK)
- QUIT
- +5 SET TC2=Z9
- N2 NEW X,Y
- SET X=TC1
- SET Y=0
- DO MIL^PRSATIM
- SET TC1=Y
- +1 IF TC2'=""
- SET X=TC2
- SET Y=0
- DO MIL^PRSATIM
- if Y<TC1
- SET TC1=Y
- +2 SET TC1=TC1\100*60+(TC1#100)
- IF $PIECE(Y0,"^",2)>TC1
- SET ERR=10
- DO ERR^PRSATPE
- +3 QUIT
- PR ; Determine last end time of previous day
- +1 IF DAY>1
- SET TC1=$PIECE($GET(^PRST(458,PPI,"E",DFN,"D",DAY-1,0)),"^",2)
- SET TC2=$PIECE($GET(^(0)),"^",13)
- +2 IF '$TEST
- if '$DATA(^PRST(458,PPI-1,"E",DFN,"D",14,0))
- QUIT
- SET TC1=$PIECE(^(0),"^",2)
- SET TC2=$PIECE($GET(^(0)),"^",13)
- +3 IF $PIECE($GET(^PRST(457.1,+TC1,0)),"^",5)="Y"
- SET ZPX=$GET(^(1))
- +4 IF '$TEST
- if $PIECE($GET(^PRST(457.1,+TC2,0)),"^",5)'="Y"
- QUIT
- SET ZPX=$GET(^(1))
- +5 NEW X,Y
- SET Z=""
- SET DY2=1
- FOR KK=1:3:19
- SET X=$PIECE(ZPX,"^",KK,KK+1)
- if "^"[X
- QUIT
- DO CNV^PRSATIM
- if $PIECE(Y,"^",2)'>$PIECE(Y,"^",1)
- SET DY2=2
- IF DY2=2
- SET Z9=$PIECE(ZPX,"^",KK+2)
- IF $SELECT('Z9:1,1:$PIECE($GET(^PRST(457.2,Z9,0)),"^",2)="RG")
- SET Z=$PIECE(Y,"^",2)
- +6 if Z=""
- QUIT
- IF Z>$PIECE(Y0,"^",1)
- SET ERR=11
- DO ERR^PRSATPE
- +7 QUIT
- UN ; Check UN against OT CT ON SB in tour
- +1 KILL TUN
- FOR KK=1:3
- if $PIECE(X1,"^",KK)=""
- QUIT
- SET Z=$PIECE(X1,"^",KK+2)
- IF $SELECT('Z:0,1:$PIECE($GET(^PRST(457.2,Z,0)),"^",2)'="RG")
- Begin DoDot:1
- +2 SET X=$PIECE(X1,"^",KK,KK+1)
- DO CNV^PRSATIM
- SET Z1=$PIECE(Y,"^",1)
- SET Z2=$PIECE(Y,"^",2)
- DO V0
- +3 IF Z1'=""
- IF $GET(TUN(Z1))="*"
- KILL TUN(Z1)
- SET TUN(Z2)="*"
- QUIT
- +4 SET TUN(Z1)=""
- SET TUN(Z2)="*"
- QUIT
- End DoDot:1
- +5 IF X4'=""
- FOR KK=1:3
- if $PIECE(X4,"^",KK)=""
- QUIT
- SET Z=$PIECE(X4,"^",KK+2)
- IF $SELECT('Z:0,1:$PIECE($GET(^PRST(457.2,Z,0)),"^",2)'="RG")
- Begin DoDot:1
- +6 SET X=$PIECE(X4,"^",KK,KK+1)
- DO CNV^PRSATIM
- SET Z1=$PIECE(Y,"^",1)
- SET Z2=$PIECE(Y,"^",2)
- DO V0
- +7 IF Z1'=""
- IF $GET(TUN(Z1))="*"
- KILL TUN(Z1)
- SET TUN(Z2)="*"
- QUIT
- +8 SET TUN(Z1)=""
- SET TUN(Z2)="*"
- QUIT
- End DoDot:1
- +9 SET Z1=$PIECE(Y0,"^",1)
- SET Z2=$PIECE(Y0,"^",2)
- DO V0
- +10 SET Z1=$ORDER(TUN(Z1))
- if Z1'=""
- SET Z1=TUN(Z1)
- +11 SET Z2=$ORDER(TUN(Z2-1))
- if Z2'=""
- SET Z2=TUN(Z2)
- +12 IF Z1'="*"!(Z2'="*")
- SET ERR=12
- DO ERR^PRSATPE
- +13 QUIT
- V0 IF Z2>Z1
- if $ORDER(TUN(""))'<Z2
- SET Z1=Z1+1440
- SET Z2=Z2+1440
- QUIT
- +1 SET Z2=Z2+1440
- QUIT