PRSATE1 ; HISC/REL-Display Tour Change ;5/5/93 10:40
;;4.0;PAID;**115,132**;Sep 21, 1995;Build 13
;;Per VHA Directive 2004-038, this routine should not be modified.
LST ; Display Change
N PRSDAYN,X,X1,X2,PRSD1,PRSD2,PRSDNP1,PRSDNP2,PRSDW,PRSNXT,PRSWREC
W !?34,"Tour Change",!," Date",?14,"TW",?18,"Scheduled Tour",?45,"TW",?49,"Permanent Tour",?75,"Type"
S PRSD1=$G(^PRST(458,PPI,1)),PRSD2=$G(^PRST(458,PPI,2))
S PRSDNP1=$G(^PRST(458,PPI+1,1)),PRSDNP2=$G(^PRST(458,PPI+1,2))
S PRSNXT=0
F DAY=0:0 S DAY=$O(^PRST(458,"ATC",DFN,PPI,DAY)) Q:DAY=""!PRSNXT D
. I $P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),U,3)=2 S PRSNXT=1
. Q
F DAY=0:0 S DAY=$O(^PRST(458,"ATC",DFN,PPI,DAY)) Q:DAY="" D L1
Q
L1 N PRSTW,PRSTD2,PRSTD4
S PRSWREC=$G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),TD=$P(PRSWREC,U,2),PRSTW=$G(^(8))
S PRSDW=$P(PRSD2,U,DAY)
I PRSNXT D
. I $P(PRSDNP1,U,DAY) S PRSDW=$P(PRSDNP2,U,DAY) Q
. S PRSDW=$P(PRSD1,U,DAY),X1=PRSDW,X2=14 D C^%DTC S PRSDW=X
. D DW^%DTC S PRSDAYN=X S X=PRSDW D DTP^PRSAPPU
. S PRSDW=$E(PRSDAYN,1,3)_" "_Y
. QUIT
S PRSTD2=$P($G(^PRST(457.1,+TD,0)),U),X=$L(PRSTD2)
S TD=$P(PRSWREC,U,4),PRSTD4=$P($G(^PRST(457.1,+TD,0)),U),Y=$L(PRSTD4)
W !,PRSDW,?14,$P(PRSTW,U),?18,$S(X<26:PRSTD2,1:$P(PRSTD2," "))
W ?45,$P(PRSTW,U,5),?49,$S(Y<26:PRSTD4,1:$P(PRSTD4," "))
S TYP=$P(PRSWREC,U,3) W ?75,$S(TYP:"Temp",1:"Perm")
I X>25!(Y>25) W ! W:X>25 ?18,$P(PRSTD2," ",2,999) W:Y>25 ?49,$P(PRSTD4," ",2,999)
S TD=$P(PRSWREC,U,13) Q:'TD W !?18,$P($G(^PRST(457.1,+TD,0)),U,1),?75,"Temp" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSATE1 1541 printed Sep 23, 2025@20:00:51 Page 2
PRSATE1 ; HISC/REL-Display Tour Change ;5/5/93 10:40
+1 ;;4.0;PAID;**115,132**;Sep 21, 1995;Build 13
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
LST ; Display Change
+1 NEW PRSDAYN,X,X1,X2,PRSD1,PRSD2,PRSDNP1,PRSDNP2,PRSDW,PRSNXT,PRSWREC
+2 WRITE !?34,"Tour Change",!," Date",?14,"TW",?18,"Scheduled Tour",?45,"TW",?49,"Permanent Tour",?75,"Type"
+3 SET PRSD1=$GET(^PRST(458,PPI,1))
SET PRSD2=$GET(^PRST(458,PPI,2))
+4 SET PRSDNP1=$GET(^PRST(458,PPI+1,1))
SET PRSDNP2=$GET(^PRST(458,PPI+1,2))
+5 SET PRSNXT=0
+6 FOR DAY=0:0
SET DAY=$ORDER(^PRST(458,"ATC",DFN,PPI,DAY))
if DAY=""!PRSNXT
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(^PRST(458,PPI,"E",DFN,"D",DAY,0)),U,3)=2
SET PRSNXT=1
+8 QUIT
End DoDot:1
+9 FOR DAY=0:0
SET DAY=$ORDER(^PRST(458,"ATC",DFN,PPI,DAY))
if DAY=""
QUIT
DO L1
+10 QUIT
L1 NEW PRSTW,PRSTD2,PRSTD4
+1 SET PRSWREC=$GET(^PRST(458,PPI,"E",DFN,"D",DAY,0))
SET TD=$PIECE(PRSWREC,U,2)
SET PRSTW=$GET(^(8))
+2 SET PRSDW=$PIECE(PRSD2,U,DAY)
+3 IF PRSNXT
Begin DoDot:1
+4 IF $PIECE(PRSDNP1,U,DAY)
SET PRSDW=$PIECE(PRSDNP2,U,DAY)
QUIT
+5 SET PRSDW=$PIECE(PRSD1,U,DAY)
SET X1=PRSDW
SET X2=14
DO C^%DTC
SET PRSDW=X
+6 DO DW^%DTC
SET PRSDAYN=X
SET X=PRSDW
DO DTP^PRSAPPU
+7 SET PRSDW=$EXTRACT(PRSDAYN,1,3)_" "_Y
+8 QUIT
End DoDot:1
+9 SET PRSTD2=$PIECE($GET(^PRST(457.1,+TD,0)),U)
SET X=$LENGTH(PRSTD2)
+10 SET TD=$PIECE(PRSWREC,U,4)
SET PRSTD4=$PIECE($GET(^PRST(457.1,+TD,0)),U)
SET Y=$LENGTH(PRSTD4)
+11 WRITE !,PRSDW,?14,$PIECE(PRSTW,U),?18,$SELECT(X<26:PRSTD2,1:$PIECE(PRSTD2," "))
+12 WRITE ?45,$PIECE(PRSTW,U,5),?49,$SELECT(Y<26:PRSTD4,1:$PIECE(PRSTD4," "))
+13 SET TYP=$PIECE(PRSWREC,U,3)
WRITE ?75,$SELECT(TYP:"Temp",1:"Perm")
+14 IF X>25!(Y>25)
WRITE !
if X>25
WRITE ?18,$PIECE(PRSTD2," ",2,999)
if Y>25
WRITE ?49,$PIECE(PRSTD4," ",2,999)
+15 SET TD=$PIECE(PRSWREC,U,13)
if 'TD
QUIT
WRITE !?18,$PIECE($GET(^PRST(457.1,+TD,0)),U,1),?75,"Temp"
QUIT
