PRS8VW1 ;HISC/MRL-DECOMPOSITION, VIEW RESULTS, CONT. ;01/23/07
;;4.0;PAID;**6,35,45,69,112**;Sep 21, 1995;Build 54
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;This routine is used to view the results of the decomposition.
;It is a continuation of routine ^PRS8VW.
;
;See routine PRS8VW2 at label TYP for type of time
;text displayed from this routine.
;
;Called by Routines: PRS8VW1
;
S CHECK=0
;
EN ; --- entry point from PRS8CK1
S E=E(1),W="Wk-1",LOC=1 D SHOW
S E=E(2),W="Wk-2",LOC=2 D SHOW
S E=E(3),W="Misc",LOC=0 D SHOW
I 'CHECK,"C"'[$E(IOST) D
.W !,DASH1
.W !,TR
K %,CHECK,D,E,I,L,LOC,USED,W,X,Y Q
;
SHOW ; --- show information
F I=1:2 S X=$E(E,I,I+1) Q:X="" D
.I $D(USED(X)) Q
.S USED(X)=""
.S X(1)=$F(OLD,X),X(2)=$F(NEW,X) ; try to find time code in TT8B
.I 'CHECK,'X(1),'X(2) Q ;not in either string
.I CHECK S LOC(1)=(I\2+1) S:'LOC LOC(1)=LOC(1)+50 D
..S FOUND(LOC(1))=$G(FOUND(LOC(1)))
..S $P(FOUND(LOC(1)),"^",$S(LOC<2:1,1:4))=X
.S Y=$P($T(@($E(X)_"^PRS8VW2")),";;",2)
.S Y(1)=$F(Y,$E(X,2)_":")
.S Y=$P($E(Y,Y(1),999),":",1,2)
.I 'CHECK W !,W,?10,$P($T(TYP+Y^PRS8VW2),";;",2),?45,X
.S X=X(1),X1=52 D CON
.S X=X(2),X1=67 D CON
Q
;
CON ; --- convert to proper format
I '+X S X=$E("00000000000",1,+$P(Y,":",2))
I X,X1=52 S (X,Z)=$E(OLD,X(1),X(1)+$P(Y,":",2)-1)
I X,X1=67 S:'$D(Z) Z="" S X=$E(NEW,X(2),X(2)+$P(Y,":",2)-1)
I 'CHECK W ?X1,$J(X,9) D Q
.I OLD=""!(NEW="") Q
.I X1=67,Z'="",X'=Z W " *"
S LOC(2)=$S(X1=52:2,1:3) I LOC=2 S LOC(2)=LOC(2)+3
S $P(FOUND(LOC(1)),"^",LOC(2))=X
Q:X1'=67
I $P(FOUND(LOC(1)),"^",1)="CD" Q
S S=0,X=FOUND(LOC(1))
I +$P(X,"^",2)!(+$P(X,"^",3)) S S=1
I 'S,LOC,+$P(X,"^",5)!(+$P(X,"^",6)) S S=1
I 'S,LOC'=1 K FOUND(LOC(1))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRS8VW1 1799 printed Dec 13, 2024@02:23:07 Page 2
PRS8VW1 ;HISC/MRL-DECOMPOSITION, VIEW RESULTS, CONT. ;01/23/07
+1 ;;4.0;PAID;**6,35,45,69,112**;Sep 21, 1995;Build 54
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;This routine is used to view the results of the decomposition.
+5 ;It is a continuation of routine ^PRS8VW.
+6 ;
+7 ;See routine PRS8VW2 at label TYP for type of time
+8 ;text displayed from this routine.
+9 ;
+10 ;Called by Routines: PRS8VW1
+11 ;
+12 SET CHECK=0
+13 ;
EN ; --- entry point from PRS8CK1
+1 SET E=E(1)
SET W="Wk-1"
SET LOC=1
DO SHOW
+2 SET E=E(2)
SET W="Wk-2"
SET LOC=2
DO SHOW
+3 SET E=E(3)
SET W="Misc"
SET LOC=0
DO SHOW
+4 IF 'CHECK
IF "C"'[$EXTRACT(IOST)
Begin DoDot:1
+5 WRITE !,DASH1
+6 WRITE !,TR
End DoDot:1
+7 KILL %,CHECK,D,E,I,L,LOC,USED,W,X,Y
QUIT
+8 ;
SHOW ; --- show information
+1 FOR I=1:2
SET X=$EXTRACT(E,I,I+1)
if X=""
QUIT
Begin DoDot:1
+2 IF $DATA(USED(X))
QUIT
+3 SET USED(X)=""
+4 ; try to find time code in TT8B
SET X(1)=$FIND(OLD,X)
SET X(2)=$FIND(NEW,X)
+5 ;not in either string
IF 'CHECK
IF 'X(1)
IF 'X(2)
QUIT
+6 IF CHECK
SET LOC(1)=(I\2+1)
if 'LOC
SET LOC(1)=LOC(1)+50
Begin DoDot:2
+7 SET FOUND(LOC(1))=$GET(FOUND(LOC(1)))
+8 SET $PIECE(FOUND(LOC(1)),"^",$SELECT(LOC<2:1,1:4))=X
End DoDot:2
+9 SET Y=$PIECE($TEXT(@($EXTRACT(X)_"^PRS8VW2")),";;",2)
+10 SET Y(1)=$FIND(Y,$EXTRACT(X,2)_":")
+11 SET Y=$PIECE($EXTRACT(Y,Y(1),999),":",1,2)
+12 IF 'CHECK
WRITE !,W,?10,$PIECE($TEXT(TYP+Y^PRS8VW2),";;",2),?45,X
+13 SET X=X(1)
SET X1=52
DO CON
+14 SET X=X(2)
SET X1=67
DO CON
End DoDot:1
+15 QUIT
+16 ;
CON ; --- convert to proper format
+1 IF '+X
SET X=$EXTRACT("00000000000",1,+$PIECE(Y,":",2))
+2 IF X
IF X1=52
SET (X,Z)=$EXTRACT(OLD,X(1),X(1)+$PIECE(Y,":",2)-1)
+3 IF X
IF X1=67
if '$DATA(Z)
SET Z=""
SET X=$EXTRACT(NEW,X(2),X(2)+$PIECE(Y,":",2)-1)
+4 IF 'CHECK
WRITE ?X1,$JUSTIFY(X,9)
Begin DoDot:1
+5 IF OLD=""!(NEW="")
QUIT
+6 IF X1=67
IF Z'=""
IF X'=Z
WRITE " *"
End DoDot:1
QUIT
+7 SET LOC(2)=$SELECT(X1=52:2,1:3)
IF LOC=2
SET LOC(2)=LOC(2)+3
+8 SET $PIECE(FOUND(LOC(1)),"^",LOC(2))=X
+9 if X1'=67
QUIT
+10 IF $PIECE(FOUND(LOC(1)),"^",1)="CD"
QUIT
+11 SET S=0
SET X=FOUND(LOC(1))
+12 IF +$PIECE(X,"^",2)!(+$PIECE(X,"^",3))
SET S=1
+13 IF 'S
IF LOC
IF +$PIECE(X,"^",5)!(+$PIECE(X,"^",6))
SET S=1
+14 IF 'S
IF LOC'=1
KILL FOUND(LOC(1))
+15 QUIT
