Changeset 623 for WorldVistAEHR/trunk/r/PAID-PRS/PRS8VW1.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PAID-PRS/PRS8VW1.m
r613 r623 1 PRS8VW1 ;HISC/MRL-DECOMPOSITION, VIEW RESULTS, CONT. ;01/23/07 2 ;;4.0;PAID;**6,35,45,69,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;This routine is used to view the results of the decomposition. 6 ;It is a continuation of routine ^PRS8VW. 7 ; 8 ;See routine PRS8VW2 at label TYP for type of time 9 ;text displayed from this routine. 10 ; 11 ;Called by Routines: PRS8VW1 12 ; 13 S CHECK=0 14 ; 15 EN ; --- entry point from PRS8CK1 16 S E=E(1),W="Wk-1",LOC=1 D SHOW 17 S E=E(2),W="Wk-2",LOC=2 D SHOW 18 S E=E(3),W="Misc",LOC=0 D SHOW 19 I 'CHECK,"C"'[$E(IOST) D 20 .W !,DASH1 21 .W !,TR 22 K %,CHECK,D,E,I,L,LOC,USED,W,X,Y Q 23 ; 24 SHOW ; --- show information 25 F I=1:2 S X=$E(E,I,I+1) Q:X="" D 26 .I $D(USED(X)) Q 27 .S USED(X)="" 28 .S X(1)=$F(OLD,X),X(2)=$F(NEW,X) ; try to find time code in TT8B 29 .I 'CHECK,'X(1),'X(2) Q ;not in either string 30 .I CHECK S LOC(1)=(I\2+1) S:'LOC LOC(1)=LOC(1)+50 D 31 ..S FOUND(LOC(1))=$G(FOUND(LOC(1))) 32 ..S $P(FOUND(LOC(1)),"^",$S(LOC<2:1,1:4))=X 33 .S Y=$P($T(@($E(X)_"^PRS8VW2")),";;",2) 34 .S Y(1)=$F(Y,$E(X,2)_":") 35 .S Y=$P($E(Y,Y(1),999),":",1,2) 36 .I 'CHECK W !,W,?10,$P($T(TYP+Y^PRS8VW2),";;",2),?45,X 37 .S X=X(1),X1=52 D CON 38 .S X=X(2),X1=67 D CON 39 Q 40 ; 41 CON ; --- convert to proper format 42 I '+X S X=$E("00000000000",1,+$P(Y,":",2)) 43 I X,X1=52 S (X,Z)=$E(OLD,X(1),X(1)+$P(Y,":",2)-1) 44 I X,X1=67 S:'$D(Z) Z="" S X=$E(NEW,X(2),X(2)+$P(Y,":",2)-1) 45 I 'CHECK W ?X1,$J(X,9) D Q 46 .I OLD=""!(NEW="") Q 47 .I X1=67,Z'="",X'=Z W " *" 48 S LOC(2)=$S(X1=52:2,1:3) I LOC=2 S LOC(2)=LOC(2)+3 49 S $P(FOUND(LOC(1)),"^",LOC(2))=X 50 Q:X1'=67 51 I $P(FOUND(LOC(1)),"^",1)="CD" Q 52 S S=0,X=FOUND(LOC(1)) 53 I +$P(X,"^",2)!(+$P(X,"^",3)) S S=1 54 I 'S,LOC,+$P(X,"^",5)!(+$P(X,"^",6)) S S=1 55 I 'S,LOC'=1 K FOUND(LOC(1)) 56 Q 1 PRS8VW1 ;HISC/MRL-DECOMPOSITION, VIEW RESULTS, CONT. ;8/23/01 2 ;;4.0;PAID;**6,35,45,69**;Sep 21, 1995 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 S CHECK=0 13 ; 14 EN ; --- entry point from PRS8CK1 15 S E=E(1),W="Wk-1",LOC=1 D SHOW 16 S E=E(2),W="Wk-2",LOC=2 D SHOW 17 S E=E(3),W="Misc",LOC=0 D SHOW 18 I 'CHECK,"C"'[$E(IOST) D 19 .W ! F I=1:1:79 W "-" 20 .W !,TR 21 K %,CHECK,D,E,I,L,LOC,USED,W,X,Y Q 22 ; 23 SHOW ; --- show information 24 F I=1:2 S X=$E(E,I,I+1) Q:X="" D 25 .I $D(USED(X)) Q 26 .S USED(X)="" 27 .S X(1)=$F(OLD,X),X(2)=$F(NEW,X) ; try to find time code in TT8B 28 .I 'CHECK,'X(1),'X(2) Q ;not in either string 29 .I CHECK S LOC(1)=(I\2+1) S:'LOC LOC(1)=LOC(1)+50 D 30 ..S FOUND(LOC(1))=$G(FOUND(LOC(1))) 31 ..S $P(FOUND(LOC(1)),"^",$S(LOC<2:1,1:4))=X 32 .S Y=$P($T(@$E(X)),";;",2) 33 .S Y(1)=$F(Y,$E(X,2)_":") 34 .S Y=$P($E(Y,Y(1),999),":",1,2) 35 .I 'CHECK W !,W,?10,$P($T(TYP+Y^PRS8VW2),";;",2),?45,X 36 .S X=X(1),X1=52 D CON 37 .S X=X(2),X1=67 D CON 38 Q 39 ; 40 CON ; --- convert to proper format 41 I '+X S X=$E("00000000000",1,+$P(Y,":",2)) 42 I X,X1=52 S (X,Z)=$E(OLD,X(1),X(1)+$P(Y,":",2)-1) 43 I X,X1=67 S:'$D(Z) Z="" S X=$E(NEW,X(2),X(2)+$P(Y,":",2)-1) 44 I 'CHECK W ?X1,$J(X,9) D Q 45 .I OLD=""!(NEW="") Q 46 .I X1=67,Z'="",X'=Z W " *" 47 S LOC(2)=$S(X1=52:2,1:3) I LOC=2 S LOC(2)=LOC(2)+3 48 S $P(FOUND(LOC(1)),"^",LOC(2))=X 49 Q:X1'=67 50 I $P(FOUND(LOC(1)),"^",1)="CD" Q 51 S S=0,X=FOUND(LOC(1)) 52 I +$P(X,"^",2)!(+$P(X,"^",3)) S S=1 53 I 'S,LOC,+$P(X,"^",5)!(+$P(X,"^",6)) S S=1 54 I 'S,LOC'=1 K FOUND(LOC(1)) 55 Q 56 ; 57 ; This internal table stores types of time codes and their 58 ; corresponding descriptions and TT8B value field lengths. Each 59 ; single char line label below is the 1st char of a type of time code. 60 ; The text on the corresponding line contains '^' delimited 61 ; pieces. The 1st char of those pieces is the 2nd char of a type of 62 ; time. The text description for that time code is given by the 63 ; the number in the 2nd ':' delimited piece. That number indicates 64 ; the line number below the label TYP in routine PRS8VW2. The 3rd 65 ; ':' delimited piece is the length of the time code's value in the 66 ; TT8B String. 67 ; 68 A ;;N:1:3^U:5:3^L:1:3^B:5:3^D:63:3^F:63:3 69 C ;;E:7:3^U:8:3^T:7:3^O:8:3^L:34:4^A:55:4^Y:57:3^D:60:6 70 D ;;A:16:3^B:17:3^C:18:3^E:16:3^F:17:3^G:18:3^W:45:2^T:48:6 71 E ;;A:38:5^B:40:5^C:38:5^D:40:5 72 F ;;F:59:4^A:61:3^B:61:3^C:62:3^D:62:3^E:64:6 73 H ;;A:29:3^B:30:3^C:31:3^L:29:3^M:30:3^N:31:3^D:36:3^O:36:3 74 I ;;N:46:1 75 L ;;U:48:4^N:49:4^D:50:4^A:53:1 76 M ;;L:54:4 77 N ;;O:4:3^A:10:3^B:11:3^P:4:3^R:10:3^S:11:3^L:44:2^T:65:3^H:65:3 78 O ;;A:20:3^B:21:3^C:22:3^K:24:3^M:25:3^N:34:4^E:20:3^F:21:3^G:22:3^S:24:3^U:25:3 79 P ;;T:32:3^A:33:3^H:32:3^B:33:3^C:56:2 80 R ;;T:6:3^A:26:3^B:27:3^C:28:3^L:6:3^E:26:3^F:27:3^G:28:3^R:58:1 81 S ;;K:2:3^P:12:3^A:13:3^B:14:3^C:15:3^L:2:3^Q:12:3^E:13:3^F:14:3^G:15:3 82 T ;;F:19:3^A:42:3^C:43:3^G:19:3^B:42:3^D:43:3^L:47:3^O:52:1 83 U ;;N:9:3^S:9:3 84 V ;;C:37:6^S:37:6 85 W ;;D:3:3^P:3:3 86 Y ;;A:23:3^D:35:4^E:23:3^H:35:4 87 Q
Note:
See TracChangeset
for help on using the changeset viewer.