- 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 Mar 13, 2025@21:28:09 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
