source: FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIKCU2.m@ 1582

Last change on this file since 1582 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1DIKCU2 ;SFISC/MKO-ARRAY COMPARE, TEXT MANIPULATION ;2:40 PM 28 Jan 1998
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;===============================
6 ; $$GCMP(ArrayName1,ArrayName2)
7 ;===============================
8 ;Compare the contents of two arrays
9 ;In:
10 ; DIKCU2A0 = Name of array 1
11 ; DIKCU2B0 = Name of array 2
12 ;Returns: 1 if equal, 0 if unequal
13 ;
14GCMP(DIKCU2A0,DIKCU2B0) ;
15 N DIKCU2A,DIKCU2B,DIKCU2DA,DIKCU2DB,DIKCU2E
16 S DIKCU2A=$G(DIKCU2A0),DIKCU2B=$G(DIKCU2B0)
17 Q:DIKCU2A=""!(DIKCU2B="") 0
18 ;
19 S DIKCU2DA=$D(@DIKCU2A),DIKCU2DB=$D(@DIKCU2B)
20 Q:DIKCU2DA'=DIKCU2DB 0
21 I DIKCU2DA=0,DIKCU2DB=0 Q 1
22 I DIKCU2DA#2,DIKCU2DB#2,@DIKCU2A'=@DIKCU2B Q 0
23 ;
24 S DIKCU2E=1
25 S DIKCU2A0=$$OREF^DILF(DIKCU2A0),DIKCU2B0=$$OREF^DILF(DIKCU2B0)
26 F S DIKCU2A=$Q(@DIKCU2A),DIKCU2B=$Q(@DIKCU2B) D Q:'DIKCU2E!(DIKCU2A="")!(DIKCU2B="")
27 . I DIKCU2A=""!($P(DIKCU2A,DIKCU2A0)]""),DIKCU2B=""!($P(DIKCU2B,DIKCU2B0)]"") Q
28 . I DIKCU2A=""!(DIKCU2B="") S DIKCU2E=0 Q
29 . I $P(DIKCU2A,DIKCU2A0,2,999)'=$P(DIKCU2B,DIKCU2B0,2,999) S DIKCU2E=0 Q
30 . I @DIKCU2A'=@DIKCU2B S DIKCU2E=0 Q
31 Q DIKCU2E
32 ;
33 ;==================================================
34 ; XRINFO(Xref#,.UIR,.LDif,.MaxL,.RFile,.IRoot,.SS)
35 ;==================================================
36 ;Get info about an index
37 ;In:
38 ; XR = ien of entry in Index file
39 ;Out:
40 ; .UIR = Closed root of index w/ X(n)
41 ; .LDIF = Level difference between file and root file
42 ; .MAXL(ord#) = maximum length of subscript with this order #
43 ; .IROOT = Closed root of index (up to name)
44 ; .RFILE = Root file #
45 ; .SS = # of field-type subscripts
46 ; .SS(ss#) = file#^field#^maxLen
47 ;Example: a whole file xref defined 3 levels down; the xref resides
48 ; on the subfile 2 levels down.
49 ; UIR = ^DIZ(1000,DA(3),10,DA(2),20,"WF",$E(X(1),1,30),X(2))
50 ; RFILE = 1000.03
51 ; IROOT = ^DIZ(1000,DA(3),10,DA(2),20,"WF")
52 ;
53XRINFO(XR,UIR,LDIF,MAXL,RFILE,IROOT,SS) ;
54 K UIR,LDIF,MAXL,SS
55 Q:$D(^DD("IX",XR,0))[0
56 N CRV,FIL,FILE,FLD,ML,NAME,ORD,TYPE,S
57 ;
58 S FILE=$P(^DD("IX",XR,0),U),NAME=$P(^(0),U,2),TYPE=$P(^(0),U,8),RFILE=$P(^(0),U,9)
59 Q:NAME=""!'FILE!'RFILE
60 ;
61 I FILE'=RFILE D
62 . S LDIF=$$FLEVDIFF^DIKCU(FILE,RFILE) Q:LDIF=""
63 . S UIR=$$FROOTDA^DIKCU(FILE,LDIF_"O") Q:UIR=""
64 E D
65 . S LDIF=0
66 . S UIR=$$FROOTDA^DIKCU(FILE,"O") Q:UIR=""
67 Q:$G(UIR)=""
68 S UIR=UIR_""""_NAME_"""",IROOT=UIR_")"
69 ;
70 S S=0 F S S=$O(^DD("IX",XR,11.1,"AC",S)) Q:'S S CRV=$O(^(S,0)) D:CRV
71 . Q:$D(^DD("IX",XR,11.1,CRV,0))[0 S ORD=$P(^(0),U),FIL=$P(^(0),U,3),FLD=$P(^(0),U,4),ML=$P(^(0),U,5)
72 . Q:'ORD
73 . I ML S UIR=UIR_",$E(X("_ORD_"),1,"_ML_")",MAXL(ORD)=ML
74 . E S UIR=UIR_",X("_ORD_")"
75 . I FIL,FLD S SS=$G(SS)+1,SS(S)=FIL_U_FLD_$S(ML:U_ML,1:"")
76 ;
77 S UIR=UIR_")"
78 Q
79 ;
80 ;===============================
81 ; WRAP(.Text,Width,Width1,Code)
82 ;===============================
83 ;Wrap the lines in array T
84 ;In:
85 ; .T = array of text; 1st line can be in T or T(0)
86 ; subsequent lines are in T(1),...,T(n)
87 ; WID = maximum length of each line (default = IOM[or 80]-1)
88 ; if < 0 : IOM-1+WID
89 ; WID1 = maximum length of line 1 (optional)
90 ; if "" : WID
91 ; if < 0 : IOM-1+WID1
92 ; COD = 1, if lines should NOT wrap on word boundaries
93 ;
94WRAP(T,WID,WID1,COD) ;Wrap the lines in the T array
95 Q:'$D(T)
96 N E,J,P,T0,W
97 ;
98 S WID=$G(WID)\1
99 S:WID<1 WID=$G(IOM,80)-1+WID
100 S:WID<1 WID=79
101 ;
102 S W=$S($G(WID1):WID1\1,$G(WID1)=0:$G(IOM,80)-1,1:WID)
103 S:W<1 W=$G(IOM,80)-1+W
104 S:W<1 W=79
105 ;
106 I $D(T(0))[0 S T0=1,T(0)=T
107 ;
108 ;Wrap at word boundaries
109 I '$G(COD) F J=0:1 Q:'$D(T(J)) D
110 . S:J=1 W=WID
111 . S:J T(J)=$$LD(T(J))
112 . ;
113 . ;Line must be split
114 . I $L(T(J))>W D
115 .. D DOWNT
116 .. F P=$L(T(J)," "):-1:0 Q:$L($P(T(J)," ",1,P))'>W
117 .. I 'P S T(J+1)=$E(T(J),W+1,999),T(J)=$E(T(J),1,W)
118 .. E S T(J+1)=$$LD($P(T(J)," ",P+1,999)),T(J)=$$TR($P(T(J)," ",1,P))
119 . ;
120 . ;Or line must be joined with next
121 . E I $L(T(J))<W D
122 .. Q:'$D(T(J+1))
123 .. I T(J)]"",T(J)'?.E1" " S T(J)=T(J)_" "
124 .. S T(J+1)=$$LD(T(J+1))
125 .. ;
126 .. F P=1:1:$L(T(J+1)," ")+1 Q:$L(T(J))+$L($P(T(J+1)," ",1,P))>W
127 .. S T(J)=$$TR(T(J)_$P(T(J+1)," ",1,P-1))
128 .. S T(J+1)=$$LD($P(T(J+1)," ",P,999))
129 .. I T(J+1)="" D UPT S J=J-1
130 ;
131 ;Or wrap to width
132 E F J=0:1 Q:'$D(T(J)) D
133 . S:J=1 W=WID
134 . ;
135 . ;Line must be split
136 . I $L(T(J))>W D
137 .. D DOWNT
138 .. S T(J+1)=$E(T(J),W+1,999)
139 .. S T(J)=$E(T(J),1,W)
140 . ;
141 . ;Or joined with next
142 . E I $L(T(J))<W D
143 .. Q:'$D(T(J+1))
144 .. S E=W-$L(T(J))
145 .. S T(J)=T(J)_$E(T(J+1),1,E)
146 .. S T(J+1)=$E(T(J+1),E+1,999)
147 .. I T(J+1)="" D UPT S J=J-1
148 ;
149 I $G(T0) S T=T(0) K T(0)
150 Q
151 ;
152DOWNT ;Push the T array from element J+1 down
153 N K
154 F K=$O(T(""),-1):-1:J+1 S T(K+1)=T(K)
155 S T(J+1)=""
156 Q
157 ;
158UPT ;Pop the T array from element J+1 down
159 N K
160 F K=J+1:1:$O(T(""),-1)-1 S T(K)=T(K+1)
161 K T($O(T(""),-1))
162 Q
163 ;
164TR(X) ;Strip trailing spaces
165 Q:$G(X)="" X
166 N I
167 F I=$L(X):-1:0 Q:$E(X,I)'=" "
168 Q $E(X,1,I)
169 ;
170LD(X) ;Strip leading spaces
171 Q:$G(X)="" X
172 N I
173 F I=1:1:$L(X)+1 Q:$E(X,I)'=" "
174 Q $E(X,I,999)
175 ;
176ERR(ERR,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;Build an error message
177 N P,I,V
178 F I="FILE","IENS","FIELD",1,2,3 S V=$G(@("DI"_I)) S:V]"" P(I)=V
179 D BLD^DIALOG(ERR,.P,.P)
180 Q
Note: See TracBrowser for help on using the repository browser.