source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUMF5I.m@ 1801

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

initial load of WorldVistAEHR
File size: 8.8 KB
RevLine 
[613]1XUMF5I ;ISS/PAVEL - XUMF5 MD5 Hash Entry point ;5/19/06 06:15
2 ;;8.0;KERNEL;**383,407**;July 10, 1995;Build 8
3 ;
4 ;MD5 based on info from 4.005 SORT BY VUID
5 ;
6 Q
7EN(X0,MODE,IENCOUNT) ;entry point to get MD5 algorithm
8 ; Lookup uses AMASTERVUID for files and B x-ref for subfiles....
9 ;
10 ; X0 = IEN or name of entry from 4.005 file
11 ; MODE = 0 regular mode.. last HASH value returned in Apl. ACK.
12 ; 1 debugging mode.. all values + hash codess returned in Apl ACK
13 ; 1.1 debugging mode.. all values (no hash codes) returned in Apl ACK
14 ; 2 debugging mode.. all fields values, all hash values, all hash codes returned in Apl. ACK.
15 ; IENCOUNT = maximum entries for MD5 hash.. if NULL.. all entries counted...
16 ;
17 ; TMP(sequence, def entry IEN, file/subfile #, field #)=""
18 ; TMP1(,"1,120.82,2,",2)="INTERNAL"
19 ; TMP2(FILE #,FIELD #)="" if internal value requested...
20 N X,Y,X1,X2,X3,X20,X201,X1NEW,X2NEW,X2OLD,X0NAME,XP,H,CNT,CNTT,CNHT,XMD5,XDATE,XXP
21 N DIC,ERR,ROOT,ROOTX,ROOTB,ROOTB0,POINTER,JUMP,START,TMP,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,FDA,VERSION
22 N SLEV,LEV,IENS,VAL,VALUE,SORT,SORT1,EXITMD5
23 N A,B,C,D,ABCD
24 D INIT^XUMF5II S X1=0
252 F S X1=$O(TMP(X1)) Q:'$$NEXTB1(LEV)!EXITMD5 S:'X1 X1=SLEV(LEV),X2OLD=0 S X2=$O(TMP(X1,X0,0)) Q:'X2 D
26 .S (XP,JUMP)=0,XXP=$O(TMP(X1,X0,X2,0))
27 .;************ File/subfile has changed ************
28 .D:X2'=X2OLD
29 ..;K ^TMP("UNIQUE",$J)
30 ..;
31 ..;************ File Level & Start ************
32 ..I $D(^DIC(X2)),START D Q
33 ...S START=0,SLEV(1)=X1,X2OLD(1)=X2
34 ...K ROOT,ROOTB,ROOTB0,X02,X021,TMP1
35 ...S LEV=1,IENS=""
36 ...D GETONE(LEV,X2)
37 ..;
38 ..;************ Going Up ************
39 ..I $G(^DD(X2OLD,0,"UP"))=X2 D Q
40 ...K ^TMP("UNIQUE",$J,X2OLD)
41 ...I $$NEXTB(LEV,X2OLD) S JUMP=2 Q
42 ...K ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),X2OLD(LEV)
43 ...S LEV=LEV-1,IENS=$P(IENS,",",$L(IENS,",")-LEV,9999),X2=X2OLD(LEV)
44 ..Q:JUMP
45 ..;
46 ..;************ Going DOWN ************
47 ..I $G(^DD(X2,0,"UP"))=X2OLD D Q
48 ...S LEV=LEV+1,SLEV(LEV)=X1,X2OLD(LEV)=X2
49 ...D GETONE(LEV,X2)
50 ..;
51 ..;************ Same Level other multiple... ************
52 ..I $G(^DD(X2,0,"UP"))=$G(^DD(X2OLD,0,"UP")),+$G(^DD(X2OLD,0,"UP")),+$G(^DD(X2,0,"UP")) D Q
53 ...I $$NEXTB(LEV,X2OLD) S JUMP=2 Q
54 ...K ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),X2OLD(LEV)
55 ...S IENS=$P(IENS,",",$L(IENS,",")-LEV+1,9999) ;B:'$L(IENS)
56 ...S SLEV(LEV)=X1
57 ...S X2OLD(LEV)=X2
58 ...;S X2=X2OLD
59 ...D GETONE(LEV,X2)
60 ..Q:JUMP
61 ..;
62 ..;************ New File not start... ************
63 ..I $D(^DIC(X2)) D Q
64 ...S:'$D(X2NEW) X2NEW=X2,X1NEW=X1
65 ...I $$NEXTB(LEV,X2OLD(LEV)) S JUMP=2 Q
66 ...K ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),SLEV(LEV),X2OLD(LEV)
67 ...S IENS=$P(IENS,",",$L(IENS,",")-LEV+1,9999) ;B:'$L(IENS)
68 ...I LEV=1 S (X1,SLEV(1))=X1NEW,(X2,X2OLD(1))=X2NEW K X1NEW,X2NEW D GETONE(LEV,X2) Q ;;;;;;;;GET TO THE BOTTOM LEVEL = 1 NOT ANY OTHRER'S B X-REF
69 ...S LEV=LEV-1,X1=SLEV(LEV)-1,X2=+$G(X2OLD(LEV-1)),XP=1
70 ..;
71 ..;************ Last sequence number ************
72 ..I X2OLD=0 D Q
7321 ...I $$NEXTB(LEV,X2) S JUMP=2 Q
74 ...K ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),X2OLD(LEV)
75 ...Q:LEV=1
76 ...S LEV=LEV-1,IENS=$P(IENS,",",$L(IENS,",")-LEV,9999),X2=X2OLD(LEV) ;,X1=SLEV(LEV)-1,XP=1
77 ...G 21
78 ..Q
79 ..;
80 .S X2OLD=X2
81 .Q:JUMP
82 .;************ Get value & MD5 ************
83 .S X3=$O(TMP(X1+XP,X0,X2,0)) Q:'X3
84 .S VAL=$S($L(IENS):$G(TMP1(LEV,X2,IENS,X3)),1:"")
85 .Q:'$L(VAL)
86 .D:$O(TMP1(LEV,X2,IENS,X3,0))
87 ..N X4 S X4=0,VAL="" F S X4=$O(TMP1(LEV,X2,IENS,X3,X4)) Q:'X4 S VAL=VAL_$G(TMP1(LEV,X2,IENS,X3,X4))
88 .;If value set as uniqueue and already exist dont take it into MD5
89 .Q:'$L(VAL)
90 .I $G(TMP5(X2,X3)) Q:$D(^TMP("UNIQUE",$J,X2,X3,VAL)) S ^TMP("UNIQUE",$J,X2,X3,VAL)=""
91 .D
92 ..N X,TMP,I
93 ..I X3=99.99,$D(^DIC(X2)) S CNTT=CNTT+1 I $G(IENCOUNT),CNTT>IENCOUNT S EXITMD5=1,CNTT=CNTT-1 Q
94 ..D:MODE>1.99 SETACK("File #: "_X2_" Field #: "_X3_" Value: "_VAL_" IENS: "_IENS)
95 ..S CNT=$G(CNT)+1
96 ..S VALUE=VALUE_VAL
97211 ..Q:$L(VALUE)<65
98 ..S X=$E(VALUE,65,$L(VALUE)),VALUE=$E(VALUE,1,64)
99 ..D:MODE
100 ...D SETACK($S(MODE=1.1:"",1:"Value: ")_VALUE)
101 ...D:MODE'=1.1 SETACK("HASH: "_$$MAIN^XUMF5BYT($$HEX^XUMF5AU($$MD5E^XUMF5AU(ABCD,VALUE,0,CNHT+1*64))))
102 ..S ABCD=$$MD5E^XUMF5AU(ABCD,VALUE,1)
103 ..S VALUE=X,CNHT=CNHT+1
104 ..G 211
105 .Q
106 G END^XUMF5II
107 Q
108GETONE(LEV,X2) ;GET DATA
109 S ROOT(LEV)=$$ROOT^DILFD(X2,"1,"_IENS,,"ERR")
110 Q:'$L(ROOT(LEV))
111 I $D(ERR) D Q
112 .S ERROR="1^MD5 ROOT retrieval error, File/Subfile #: "_X2_" IENS: 1,"_IENS,EXITMD5=1,JUMP=2
113 .D EM^XUMFX("file DIE call error message in RDT",.ERR)
114 .K ERR
115 S ROOTX(LEV)=ROOT(LEV)_"X201(LEV))" ;FOR LOOKUP OF ENTRIES
116 S SORT1="",SORT="B" S:$D(^DIC(X2)) SORT="AMASTERVUID",SORT1="1,"
117 S ROOTB(LEV)=ROOT(LEV)_""""_SORT_""",X20(LEV))"
118 S X20(LEV)="",ROOTB0(LEV)=ROOT(LEV)_""""_SORT_""",X20(LEV),"_SORT1_"X201(LEV))"
119 S:SORT="B" POINTER=$G(TMP7(X2,XXP)) ;Pointer = pointer to file #
120 I SORT="B",+POINTER D ;Handle poiter type of subfile...
121 .N BB S POINTER=$E(POINTER,2,$L(POINTER))
122 .; ^TMP("PROOT",$J,Subfile #,IEN from up level,"Name sorted",IEN level)=""
123 .; ^TMP("PROOT",$J,Subfile #,IEN from up level,X20(LEV),X201(LEV))=""
124 .K ^TMP("PROOT",$J,X2)
125 .;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
126 .S X201(LEV)=0 F S X201(LEV)=$O(@(ROOTX(LEV))) Q:'X201(LEV) D
127 ..I $G(TMP4(X2,XXP)) D ; If sort By VUID
128 ...S BB=$$GET1^DIQ(X2,X201(LEV)_","_IENS,XXP,"I") ;BB=IEN of poited to field
129 ...S:BB BB=$$GET1^DIQ(TMP4(X2,XXP),BB_",",99.99,"E") ;BB=VUID
130 ..E S BB=$$GET1^DIQ(X2,X201(LEV)_","_IENS,XXP,"E") ; Else sort by .01 BB= .01
131 ..S:$L(BB) ^TMP("PROOT",$J,X2,BB,X201(LEV))=""
132 .;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
133 .S ROOTB(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV))"
134 .S ROOTB0(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV),X201(LEV))"
135 I SORT="B",LEV=2,X2=+$P(^DD(X2OLD(1),99.991,0),U,2) D ;Handle Effective Date/Status multiple... only last date taken to HASH... TERMSTATUS
136 .K ^TMP("PROOT",$J,X2)
137 .S X20(LEV)=$O(@(ROOTB(LEV)),-1) ;Get last date..
138 .Q:'$L(X20(LEV)) ;No Data in Effective Date Multiple.
139 .S X201(LEV)=0,X201(LEV)=+$O(@ROOTB0(LEV))
140 .Q:'X201(LEV)
141 .S ROOTB(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV))"
142 .S ROOTB0(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV),X201(LEV))"
143 .S ^TMP("PROOT",$J,X2,X20(LEV),X201(LEV))=""
144 S X20(LEV)=""
145GET1 S X20(LEV)=$O(@(ROOTB(LEV))) Q:'$L(X20(LEV)) S X201(LEV)=0,X201(LEV)=$O(@(ROOTB0(LEV)))
146 I $D(^DIC(X2)),'$$ACTIVE(X2,X201(LEV)_","_IENS) G GET1 ;If not active entry.. skip it..
147 S IENS=X201(LEV)_","_IENS
148 Q:'X201(LEV)
149 D GETSIE(X2,IENS,LEV)
150 Q
151NEXTB(LEV,X2X) ;Get next IEN from xref on current level.. if exist
152 ;Is there other entry at current level to be proceeded.. ?? get next "B" x-ref set old X2 = NEW X2 and go to loop
153 Q:'$D(X20(LEV)) 0
154N1 Q:'$L(X20(LEV)) 0
155 Q:'($O(@(ROOTB0(LEV)))!$L($O(@(ROOTB(LEV))))) 0
156 S:X201(LEV) X201(LEV)=$O(@(ROOTB0(LEV))) ;Try get new IEN fron B-xref
157 I 'X201(LEV) S X20(LEV)=$O(@(ROOTB(LEV))),X201(LEV)=0 S:$L(X20(LEV)) X201(LEV)=$O(@(ROOTB0(LEV)))
158 Q:'X201(LEV) 0
159 I $D(^DIC(X2X)),'$$ACTIVE(X2X,X201(LEV)_","_$P(IENS,",",2,99)) G N1 ;If not active entry.. skip it..
160 S $P(IENS,",",1)=X201(LEV)
161 S X2=X2X
162 D GETSIE(X2,IENS,LEV)
163 S X1=SLEV(LEV)-1,XP=1
164 Q 1
165NEXTB1(LEV) ;See if some other entries in x-ref at any level exist... no variable is set.
166 ;
167 Q:X1 1
1683 Q:LEV=0 0
169 I LEV>1,'$L($G(X20(LEV))) G 4
170 I LEV=1,'$L($G(X20(LEV))) Q 0
171 I LEV=1,'($O(@(ROOTB0(LEV)))!$L($O(@(ROOTB(LEV))))) Q 0
172 I LEV=1,'$$ACTALL() Q 0
173 I X201(LEV),$O(@(ROOTB0(LEV))) Q 1
174 Q:$L($O(@(ROOTB(LEV)))) 1 ;
175 Q:LEV=1 0
1764 S LEV=LEV-1 G 3
177 Q
178SETACK(X,MODE) ;SET APPL. Acknowledgment + WRIGHT ??
179 W X,!
180 S:$G(MODE) ^TMP("XUMF ERROR",$J,XMD5,$O(^TMP("XUMF ERROR",$J,XMD5,9999999999999),-1)+1)=X
181 Q
182UP(X) ;Upercase conversion
183 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
184ACTIVE(FILE,IEN) ;GET 1 = Active 0 = Inactive
185 N TMP,BB,X,X1,X2,XT,XX
186 D GETS^DIQ(FILE,IEN,"99.991*","I","TMP","ERR")
187 S (XT,XX)=0,X="TMP"
188 F S X=$Q(@(X)) Q:'$L(X) S X1=$G(@(X)),X=$Q(@(X)),X2=$G(@(X)) S:X1>XT XT=X1,XX=+X2
189 Q XX
190GETSIE(X2,IENS,LEV) ;GET Internal/External values + replace pointed field .01 with VUID
191 K TMP1(LEV) D GETS^DIQ(X2,IENS,"*","","TMP1(LEV)")
192 D:$D(TMP2(X2))!$D(TMP4(X2))
193 .N TMP3,I
194 .D GETS^DIQ(X2,IENS,"*","I","TMP3")
195 .S I="" F S I=$O(TMP2(X2,I)) Q:'I S:$D(TMP1(LEV,X2,IENS,I)) TMP1(LEV,X2,IENS,I)=TMP3(X2,IENS,I,"I")
196 .;+++++++++++++++ Replace pointed .01 field with VUID if indicate so in 4.005
197 .S I="" F S I=$O(TMP4(X2,I)) Q:'I S:$D(TMP1(LEV,X2,IENS,I)) TMP1(LEV,X2,IENS,I)=$$GET1^DIQ(TMP4(X2,I),TMP3(X2,IENS,I,"I")_",",99.99)
198 Q
199ACTALL() ;See if there is some active entry on the file....
200 N X1,X2,ACT
201 S ACT=0,X1=X20(1),X2=X201(1)
202 S:X20(1) X20(1)=X20(1)-.01
203 F S X20(1)=$O(@(ROOTB(1))) Q:'X20(1)!ACT F S X201(1)=$O(@(ROOTB0(1))) Q:'X201(1) I $$ACTIVE(X2OLD(1),X201(1)) S ACT=1 Q
204 S X20(1)=X1,X201(1)=X2
205 Q ACT
206 Q
Note: See TracBrowser for help on using the repository browser.