XUMF5II ;ISS/PAVEL - XUMF5 MD5 Hash Entry point ;02/02/2015
;;8.0;KERNEL;**407,654**;July 10, 1995;Build 32
;
;MD5 based on info from 4.005 SORT BY VUID
;
Q
INIT ;
K ^TMP("PROOT",$J) ;ROOT of file in the case of pointer...
K ^TMP("UNIQUE",$J) ; Global of unique Values
N X1,X11,X2,X20,X22,X3,X10,X21
;TMP5(sequence #)= 1 if unique value
S DIC=4.005,X=$S(X0:"`",1:"")_X0,DIC(0)="Z",U="^" D ^DIC
I Y=-1 S ERROR="1^Unknown entry of 4.005 File: "_X0 Q
S X0=+Y,X0NAME=$P(Y(0),U) S:'$G(MODE) MODE=+$P(Y(0),U,2) K TMP M TMP=@($$ROOT^DILFD(4.005,,0)_"""AC"",X0)")
; Set TMP5 if pointer type of field
S X1=0,(X10,X20)=0 F S X1=$O(TMP(X1)) Q:'X1 S X2=$O(TMP(X1,X0,0)) D
.S X3=$O(TMP(X1,X0,X2,0))
.S X11=$O(TMP(X1)),X21=$O(TMP(+X11,X0,0))
.I X20'=X2,X2'=X21,'$D(^DIC(X2)),$G(^DD(X2,0))'["EFFECTIVE DATE/TIME" S TMP6(X2,X3)=1
.S X20=X2
.S POINTER=$$POINTER(X2,X3)
.S:POINTER TMP7(X2,X3)=POINTER
D GETS^DIQ(4.005,X0_",","**","","TMP1")
S A="" F S A=$O(TMP1(4.00511,A)) Q:'$L(A) D
.N X1,X2
.S X1=$P(A,",",2),X2=$P(A,",",1)
.S:TMP1(4.00511,A,2)="INTERNAL" TMP2(X1,X2)=""
.;+++++++++++++++Set array of fields of pointer type VUID into TMP4 +++++++++++++++++++++++++
.;TMP1(4.00511,A,3) = File Number Of Pointed to Field for VUID sort
.S:TMP1(4.00511,A,3) TMP4(X1,X2)=TMP1(4.00511,A,3)
.;+++++++++++++++Set array of columns with Unique value into TMP5 +++++++++++++++++++++++++
.;TMP1(4.00511,A,4) = Unique value YES
.S:TMP1(4.00511,A,4)="YES" TMP5(X1,X2)=1
.;TMP1(4.00511,A,5) = Post processing logic XU*8.0*654
.S X=$G(TMP1(4.00511,A,5)) S:$L(X) TMP8(X1,X2)=X ; XU*8.0*654
;
;MODE set from input parameter or from file.
S A=$C(1,35,69,103)
S B=$C(137,171,205,239)
S C=$C(254,220,186,152)
S D=$C(118,84,50,16)
S ABCD=A_B_C_D
S (CNT,CNTT,CNHT)=0
S VALUE=""
;X1 = SEQUENCE
;X2 = FILE/SUBFILE #
;X3 = Field #
;TMP(MD5 Sequence ,IEN of entry from 4.005 file , File/Subfile#,field#)=""
;TMP1 = FILE # ALL ENTRIES
;TMP2(file#, field #)="" Set.. if INTERNAL value required
;TMP4(file#, field #)=Subfile # Set if SORT by VUID for subfile = file #
;TMP5(file#, field #)= 1 if unique value requested
;TMP6(file#, field #)= 1 if column mode.. it's not used yet...
;TMP7(file#, field #)=file # of pointer type field
;TMP8(file#, field #)= Postprocessing logic ; XU*8.0*654
S START=1,X1=0,LEV=0,X2OLD=0,XMD5=$O(^TMP("XUMF ERROR",$J,9999999999999),-1)+1,EXITMD5=0
Q
END ;************ So get the final ABCD value... ************
S ABCD=$$MD5E^XUMF5AU(ABCD,VALUE,0,CNHT*64+$L(VALUE))
D:MODE
.W ! D SETACK^XUMF5I($S(MODE=1.1:"",1:"Last value: ")_VALUE)
.D SETACK^XUMF5I("LAST HASH: "_$$MAIN^XUMF5BYT($$HEX^XUMF5AU(ABCD))) W !
.D SETACK^XUMF5I("Total number of Characters included in Hash : "_(CNHT*64+$L(VALUE)))
.D SETACK^XUMF5I("Length of last value: "_$L(VALUE))
.D SETACK^XUMF5I("Number of file entries: "_CNTT)
.D SETACK^XUMF5I("Number of hash entries: "_(CNHT+1))
.D SETACK^XUMF5I("Number of values: "_CNT)
.W !
;************ Hex conversion + storage of the final ABCD value ************
S VALUE=$$MAIN^XUMF5BYT($$HEX^XUMF5AU(ABCD))
K FDA
S FDA(4.005,X0_",",4)=$$NOW^XLFDT
S FDA(4.005,X0_",",5)=VALUE
K ERR D FILE^DIE(,"FDA","ERR")
I $D(ERR) D
.S ERROR="1^MD5 Date updating error"
.D EM^XUMFX("file DIE call error message in RDT",.ERR)
.K ERR
D SETACK^XUMF5I("MD5 Signature Entry: "_X0NAME)
D SETACK^XUMF5I("Local Hash value: "_VALUE)
S ERROR=$G(ERROR)
S X1=$O(@($$ROOT^DILFD(4.009,,0,"ERR")_"0)"))_","
D GETS^DIQ(4.009,X1,"*",,"TMP3") S VERSION=$G(TMP3(4.009,X1,1))
S $P(ERROR,U,2)=$P(ERROR,U,2)_";CHECKSUM:"_VALUE_";VERSION:"_VERSION_";"
D SETACK^XUMF5I("ERROR variable: "_ERROR)
K ^TMP("PROOT",$J)
Q VALUE
Q
POINTER(X2,XXP) ;GET THE POINTER FILE #
N FTYPE,TT,I
S:'$G(XXP) XXP=.01
D FIELD^DID(X2,XXP,,"TYPE;POINTER","TT")
Q:$G(TT("TYPE"))'="POINTER" 0
Q:'$L($G(TT("POINTER"))) 0
S TT="1^"_TT("POINTER")
Q TT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMF5II 3987 printed Dec 13, 2024@02:10:33 Page 2
XUMF5II ;ISS/PAVEL - XUMF5 MD5 Hash Entry point ;02/02/2015
+1 ;;8.0;KERNEL;**407,654**;July 10, 1995;Build 32
+2 ;
+3 ;MD5 based on info from 4.005 SORT BY VUID
+4 ;
+5 QUIT
INIT ;
+1 ;ROOT of file in the case of pointer...
KILL ^TMP("PROOT",$JOB)
+2 ; Global of unique Values
KILL ^TMP("UNIQUE",$JOB)
+3 NEW X1,X11,X2,X20,X22,X3,X10,X21
+4 ;TMP5(sequence #)= 1 if unique value
+5 SET DIC=4.005
SET X=$SELECT(X0:"`",1:"")_X0
SET DIC(0)="Z"
SET U="^"
DO ^DIC
+6 IF Y=-1
SET ERROR="1^Unknown entry of 4.005 File: "_X0
QUIT
+7 SET X0=+Y
SET X0NAME=$PIECE(Y(0),U)
if '$GET(MODE)
SET MODE=+$PIECE(Y(0),U,2)
KILL TMP
MERGE TMP=@($$ROOT^DILFD(4.005,,0)_"""AC"",X0)")
+8 ; Set TMP5 if pointer type of field
+9 SET X1=0
SET (X10,X20)=0
FOR
SET X1=$ORDER(TMP(X1))
if 'X1
QUIT
SET X2=$ORDER(TMP(X1,X0,0))
Begin DoDot:1
+10 SET X3=$ORDER(TMP(X1,X0,X2,0))
+11 SET X11=$ORDER(TMP(X1))
SET X21=$ORDER(TMP(+X11,X0,0))
+12 IF X20'=X2
IF X2'=X21
IF '$DATA(^DIC(X2))
IF $GET(^DD(X2,0))'["EFFECTIVE DATE/TIME"
SET TMP6(X2,X3)=1
+13 SET X20=X2
+14 SET POINTER=$$POINTER(X2,X3)
+15 if POINTER
SET TMP7(X2,X3)=POINTER
End DoDot:1
+16 DO GETS^DIQ(4.005,X0_",","**","","TMP1")
+17 SET A=""
FOR
SET A=$ORDER(TMP1(4.00511,A))
if '$LENGTH(A)
QUIT
Begin DoDot:1
+18 NEW X1,X2
+19 SET X1=$PIECE(A,",",2)
SET X2=$PIECE(A,",",1)
+20 if TMP1(4.00511,A,2)="INTERNAL"
SET TMP2(X1,X2)=""
+21 ;+++++++++++++++Set array of fields of pointer type VUID into TMP4 +++++++++++++++++++++++++
+22 ;TMP1(4.00511,A,3) = File Number Of Pointed to Field for VUID sort
+23 if TMP1(4.00511,A,3)
SET TMP4(X1,X2)=TMP1(4.00511,A,3)
+24 ;+++++++++++++++Set array of columns with Unique value into TMP5 +++++++++++++++++++++++++
+25 ;TMP1(4.00511,A,4) = Unique value YES
+26 if TMP1(4.00511,A,4)="YES"
SET TMP5(X1,X2)=1
+27 ;TMP1(4.00511,A,5) = Post processing logic XU*8.0*654
+28 ; XU*8.0*654
SET X=$GET(TMP1(4.00511,A,5))
if $LENGTH(X)
SET TMP8(X1,X2)=X
End DoDot:1
+29 ;
+30 ;MODE set from input parameter or from file.
+31 SET A=$CHAR(1,35,69,103)
+32 SET B=$CHAR(137,171,205,239)
+33 SET C=$CHAR(254,220,186,152)
+34 SET D=$CHAR(118,84,50,16)
+35 SET ABCD=A_B_C_D
+36 SET (CNT,CNTT,CNHT)=0
+37 SET VALUE=""
+38 ;X1 = SEQUENCE
+39 ;X2 = FILE/SUBFILE #
+40 ;X3 = Field #
+41 ;TMP(MD5 Sequence ,IEN of entry from 4.005 file , File/Subfile#,field#)=""
+42 ;TMP1 = FILE # ALL ENTRIES
+43 ;TMP2(file#, field #)="" Set.. if INTERNAL value required
+44 ;TMP4(file#, field #)=Subfile # Set if SORT by VUID for subfile = file #
+45 ;TMP5(file#, field #)= 1 if unique value requested
+46 ;TMP6(file#, field #)= 1 if column mode.. it's not used yet...
+47 ;TMP7(file#, field #)=file # of pointer type field
+48 ;TMP8(file#, field #)= Postprocessing logic ; XU*8.0*654
+49 SET START=1
SET X1=0
SET LEV=0
SET X2OLD=0
SET XMD5=$ORDER(^TMP("XUMF ERROR",$JOB,9999999999999),-1)+1
SET EXITMD5=0
+50 QUIT
END ;************ So get the final ABCD value... ************
+1 SET ABCD=$$MD5E^XUMF5AU(ABCD,VALUE,0,CNHT*64+$LENGTH(VALUE))
+2 if MODE
Begin DoDot:1
+3 WRITE !
DO SETACK^XUMF5I($SELECT(MODE=1.1:"",1:"Last value: ")_VALUE)
+4 DO SETACK^XUMF5I("LAST HASH: "_$$MAIN^XUMF5BYT($$HEX^XUMF5AU(ABCD)))
WRITE !
+5 DO SETACK^XUMF5I("Total number of Characters included in Hash : "_(CNHT*64+$LENGTH(VALUE)))
+6 DO SETACK^XUMF5I("Length of last value: "_$LENGTH(VALUE))
+7 DO SETACK^XUMF5I("Number of file entries: "_CNTT)
+8 DO SETACK^XUMF5I("Number of hash entries: "_(CNHT+1))
+9 DO SETACK^XUMF5I("Number of values: "_CNT)
+10 WRITE !
End DoDot:1
+11 ;************ Hex conversion + storage of the final ABCD value ************
+12 SET VALUE=$$MAIN^XUMF5BYT($$HEX^XUMF5AU(ABCD))
+13 KILL FDA
+14 SET FDA(4.005,X0_",",4)=$$NOW^XLFDT
+15 SET FDA(4.005,X0_",",5)=VALUE
+16 KILL ERR
DO FILE^DIE(,"FDA","ERR")
+17 IF $DATA(ERR)
Begin DoDot:1
+18 SET ERROR="1^MD5 Date updating error"
+19 DO EM^XUMFX("file DIE call error message in RDT",.ERR)
+20 KILL ERR
End DoDot:1
+21 DO SETACK^XUMF5I("MD5 Signature Entry: "_X0NAME)
+22 DO SETACK^XUMF5I("Local Hash value: "_VALUE)
+23 SET ERROR=$GET(ERROR)
+24 SET X1=$ORDER(@($$ROOT^DILFD(4.009,,0,"ERR")_"0)"))_","
+25 DO GETS^DIQ(4.009,X1,"*",,"TMP3")
SET VERSION=$GET(TMP3(4.009,X1,1))
+26 SET $PIECE(ERROR,U,2)=$PIECE(ERROR,U,2)_";CHECKSUM:"_VALUE_";VERSION:"_VERSION_";"
+27 DO SETACK^XUMF5I("ERROR variable: "_ERROR)
+28 KILL ^TMP("PROOT",$JOB)
+29 QUIT VALUE
+30 QUIT
POINTER(X2,XXP) ;GET THE POINTER FILE #
+1 NEW FTYPE,TT,I
+2 if '$GET(XXP)
SET XXP=.01
+3 DO FIELD^DID(X2,XXP,,"TYPE;POINTER","TT")
+4 if $GET(TT("TYPE"))'="POINTER"
QUIT 0
+5 if '$LENGTH($GET(TT("POINTER")))
QUIT 0
+6 SET TT="1^"_TT("POINTER")
+7 QUIT TT
