XUMF5I ;ISS/PAVEL - XUMF5 MD5 Hash Entry point ;5/19/06 06:15
;;8.0;KERNEL;**383,407,502**;July 10, 1995;Build 18
;
;MD5 based on info from 4.005 SORT BY VUID or USER DEFINED SORTING
;
Q
EN(X0,MODE,IENCOUNT) ;entry point to get MD5 algorithm
; Lookup uses AMASTERVUID for files and B x-ref for subfiles....
;
; X0 = IEN or name of entry from 4.005 file
; MODE = 0 regular mode.. last HASH value returned in Apl. ACK.
; 1 debugging mode.. all values + hash codess returned in Apl ACK
; 1.1 debugging mode.. all values (no hash codes) returned in Apl ACK
; 2 debugging mode.. all fields values, all hash values, all hash codes returned in Apl. ACK.
; IENCOUNT = maximum entries for MD5 hash.. if NULL.. all entries counted...
; FILTER = value of filter field defined in file 4.005, field 8. Passed in by HL7 message (X0).
;
; TMP(sequence, def entry IEN, file/subfile #, field #)=""
; TMP1(,"1,120.82,2,",2)="INTERNAL"
; TMP2(FILE #,FIELD #)="" if internal value requested...
N X,Y,X1,X2,X3,X20,X201,X1NEW,X2NEW,X2OLD,X0NAME,XP,H,CNT,CNTT,CNHT,XMD5,XDATE,XXP
N DIC,ERR,ROOT,ROOTX,ROOTB,ROOTB0,POINTER,JUMP,START,TMP,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,FDA,VERSION
N SLEV,LEV,IENS,VAL,VALUE,SORT,SORT1,EXITMD5,FILTER,FILTER1,FILTER2,ACTFIL,SORTXREF,SORTACT,MAPFLG,VAR,VAR0,VAR1,VAR2,VAR3
N A,B,C,D,ABCD
S:X0["~" FILTER=$P(X0,"~",2),ACTFIL=$P(X0,"~",3),X0=$P(X0,"~",1) ;parse out file name/IEN and filter value if it exists
D INIT^XUMF5II S X1=0,VAR="",VAR0=0,MAPFLG=0
S VAR1=99.99,VAR2="99.991*",VAR3=99.991 ; fields for files other than Mappings
F S VAR=$O(^DIC(4.005,"B",VAR)) Q:VAR="" D
.I VAR="Mappings" S VAR0=0,VAR0=$O(^DIC(4.005,"B",VAR,VAR0))
.I VAR0=X0 S VAR1=.01,VAR2="3*",VAR3=3,MAPFLG=1 ; fields for Mapping file
S FILTER1=$$GET1^DIQ(4.005,X0,8)
S SORTXREF=$$GET1^DIQ(4.005,X0,7)
2 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
.S (XP,JUMP)=0,XXP=$O(TMP(X1,X0,X2,0))
.;************ File/subfile has changed ************
.D:X2'=X2OLD
..;K ^TMP("UNIQUE",$J)
..;
..;************ File Level & Start ************
..I $D(^DIC(X2)),START D Q
...S START=0,SLEV(1)=X1,X2OLD(1)=X2
...K ROOT,ROOTB,ROOTB0,X02,X021,TMP1
...S LEV=1,IENS=""
...D GETONE(LEV,X2)
..;
..;************ Going Up ************
..I $G(^DD(X2OLD,0,"UP"))=X2 D Q
...K ^TMP("UNIQUE",$J,X2OLD)
...I $$NEXTB(LEV,X2OLD) S JUMP=2 Q
...K ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),X2OLD(LEV)
...S LEV=LEV-1,IENS=$P(IENS,",",$L(IENS,",")-LEV,9999),X2=X2OLD(LEV)
..Q:JUMP
..;
..;************ Going DOWN ************
..I $G(^DD(X2,0,"UP"))=X2OLD D Q
...S LEV=LEV+1,SLEV(LEV)=X1,X2OLD(LEV)=X2
...D GETONE(LEV,X2)
..;
..;************ Same Level other multiple... ************
..I $G(^DD(X2,0,"UP"))=$G(^DD(X2OLD,0,"UP")),+$G(^DD(X2OLD,0,"UP")),+$G(^DD(X2,0,"UP")) D Q
...I $$NEXTB(LEV,X2OLD) S JUMP=2 Q
...K ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),X2OLD(LEV)
...S IENS=$P(IENS,",",$L(IENS,",")-LEV+1,9999) ;B:'$L(IENS)
...S SLEV(LEV)=X1
...S X2OLD(LEV)=X2
...;S X2=X2OLD
...D GETONE(LEV,X2)
..Q:JUMP
..;
..;************ New File not start... ************
..I $D(^DIC(X2)) D Q
...S:'$D(X2NEW) X2NEW=X2,X1NEW=X1
...I $$NEXTB(LEV,X2OLD(LEV)) S JUMP=2 Q
...K ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),SLEV(LEV),X2OLD(LEV)
...S IENS=$P(IENS,",",$L(IENS,",")-LEV+1,9999) ;B:'$L(IENS)
...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
...S LEV=LEV-1,X1=SLEV(LEV)-1,X2=+$G(X2OLD(LEV-1)),XP=1
..;
..;************ Last sequence number ************
..I X2OLD=0 D Q
21 ...I $$NEXTB(LEV,X2) S JUMP=2 Q
...K ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),X2OLD(LEV)
...Q:LEV=1
...S LEV=LEV-1,IENS=$P(IENS,",",$L(IENS,",")-LEV,9999),X2=X2OLD(LEV) ;,X1=SLEV(LEV)-1,XP=1
...G 21
..Q
..;
.S X2OLD=X2
.Q:JUMP
.;************ Get value & MD5 ************
.S X3=$O(TMP(X1+XP,X0,X2,0)) Q:'X3
.S VAL=$S($L(IENS):$G(TMP1(LEV,X2,IENS,X3)),1:"")
.Q:'$L(VAL)
.D:$O(TMP1(LEV,X2,IENS,X3,0))
..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))
.;Filter out non-matching entries if a filter exists
.Q:'$$FILTER()
.;If value set as uniqueue and already exist dont take it into MD5
.Q:'$L(VAL)
.I $G(TMP5(X2,X3)) Q:$D(^TMP("UNIQUE",$J,X2,X3,VAL)) S ^TMP("UNIQUE",$J,X2,X3,VAL)=""
.D
..N X,TMP,I
..I X3=VAR1,$D(^DIC(X2)) S CNTT=CNTT+1 I $G(IENCOUNT),CNTT>IENCOUNT S EXITMD5=1,CNTT=CNTT-1 Q
..D:MODE>1.99 SETACK("File #: "_X2_" Field #: "_X3_" Value: "_VAL_" IENS: "_IENS)
..S CNT=$G(CNT)+1
..S VALUE=VALUE_VAL
211 ..Q:$L(VALUE)<65
..S X=$E(VALUE,65,$L(VALUE)),VALUE=$E(VALUE,1,64)
..D:MODE
...D SETACK($S(MODE=1.1:"",1:"Value: ")_VALUE)
...D:MODE'=1.1 SETACK("HASH: "_$$MAIN^XUMF5BYT($$HEX^XUMF5AU($$MD5E^XUMF5AU(ABCD,VALUE,0,CNHT+1*64))))
..S ABCD=$$MD5E^XUMF5AU(ABCD,VALUE,1)
..S VALUE=X,CNHT=CNHT+1
..G 211
.Q
G END^XUMF5II
Q
GETONE(LEV,X2) ;GET DATA
S ROOT(LEV)=$$ROOT^DILFD(X2,"1,"_IENS,,"ERR")
Q:'$L(ROOT(LEV))
I $D(ERR) D Q
.S ERROR="1^MD5 ROOT retrieval error, File/Subfile #: "_X2_" IENS: 1,"_IENS,EXITMD5=1,JUMP=2
.D EM^XUMFX("file DIE call error message in RDT",.ERR)
.K ERR
I SORTXREF'="" S:'$D(@(ROOT(LEV)_""""_SORTXREF_""""_")")) SORTXREF=""
S ROOTX(LEV)=ROOT(LEV)_"X201(LEV))" ;FOR LOOKUP OF ENTRIES
S SORT1="",SORT="B" ; S:$D(^DIC(X2)) SORT="AMASTERVUID",SORT1="1,"
I $D(^DIC(X2)) D
.S SORT="AMASTERVUID",SORT1="1,"
.I (SORTXREF'="") S SORT1="",SORT=SORTXREF
S ROOTB(LEV)=ROOT(LEV)_""""_SORT_""",X20(LEV))"
S X20(LEV)="",ROOTB0(LEV)=ROOT(LEV)_""""_SORT_""",X20(LEV),"_SORT1_"X201(LEV))"
S:SORT="B" POINTER=$G(TMP7(X2,XXP)) ;Pointer = pointer to file #
I SORT="B",+POINTER D ;Handle pointer type of subfile...
.N BB S POINTER=$E(POINTER,2,$L(POINTER))
.; ^TMP("PROOT",$J,Subfile #,IEN from up level,"Name sorted",IEN level)=""
.; ^TMP("PROOT",$J,Subfile #,IEN from up level,X20(LEV),X201(LEV))=""
.K ^TMP("PROOT",$J,X2)
.;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
.S X201(LEV)=0 F S X201(LEV)=$O(@(ROOTX(LEV))) Q:'X201(LEV) D
..I $G(TMP4(X2,XXP)) D ; If sort By VUID
...S BB=$$GET1^DIQ(X2,X201(LEV)_","_IENS,XXP,"I") ;BB=IEN of poited to field
...S:BB BB=$$GET1^DIQ(TMP4(X2,XXP),BB_",",VAR1,"E") ;BB=VUID
..E S BB=$$GET1^DIQ(X2,X201(LEV)_","_IENS,XXP,"E") ; Else sort by .01 BB= .01
..S:$L(BB) ^TMP("PROOT",$J,X2,BB,X201(LEV))=""
.;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
.S ROOTB(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV))"
.S ROOTB0(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV),X201(LEV))"
I SORT="B",LEV=2,X2=+$P(^DD(X2OLD(1),VAR3,0),U,2) D ;Handle Effective Date/Status multiple... only last date taken to HASH... TERMSTATUS
.K ^TMP("PROOT",$J,X2)
.S X20(LEV)=$O(@(ROOTB(LEV)),-1) ;Get last date..
.Q:'$L(X20(LEV)) ;No Data in Effective Date Multiple.
.S X201(LEV)=0,X201(LEV)=+$O(@ROOTB0(LEV))
.Q:'X201(LEV)
.S ROOTB(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV))"
.S ROOTB0(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV),X201(LEV))"
.S ^TMP("PROOT",$J,X2,X20(LEV),X201(LEV))=""
S X20(LEV)=""
I SORTXREF'="" S X20(LEV)=0,X201(LEV)=0
GET1 I SORTXREF="" S X20(LEV)=$O(@(ROOTB(LEV))) Q:'$L(X20(LEV)) S X201(LEV)=0,X201(LEV)=$O(@(ROOTB0(LEV)))
I SORTXREF'="" S TMP8=$Q(@(ROOTB0(LEV))),X20(LEV)=$P(TMP8,",",3),X201(LEV)=+$P(TMP8,",",4) Q:'$L(X20(LEV))
I (SORTXREF'=""),'$O(@(ROOTB0(LEV))),('$L($O(@(ROOTB(LEV))))),'$$ACTALL() S EXITMD5=1 Q
I $D(^DIC(X2)),'$$ACTIVE(X2,X201(LEV)_","_IENS) G GET1 ;If not active entry.. skip it..
S IENS=X201(LEV)_","_IENS
Q:'X201(LEV)
D GETSIE(X2,IENS,LEV)
Q
NEXTB(LEV,X2X) ;Get next IEN from xref on current level.. if exist
;Is there other entry at current level to be proceeded.. ?? get next "B" x-ref set old X2 = NEW X2 and go to loop
Q:'$D(X20(LEV)) 0
N1 Q:'$L(X20(LEV)) 0
I LEV=1,'($O(@(ROOTB0(LEV)))!$L($O(@(ROOTB(LEV))))) S EXITMD5=1 Q 1
Q:'($O(@(ROOTB0(LEV)))!$L($O(@(ROOTB(LEV))))) 0
S:X201(LEV) X201(LEV)=$O(@(ROOTB0(LEV))) ;Try get new IEN fron B-xref
I 'X201(LEV) S X20(LEV)=$O(@(ROOTB(LEV))),X201(LEV)=0 S:$L(X20(LEV)) X201(LEV)=$O(@(ROOTB0(LEV)))
Q:'X201(LEV) 0
I $D(^DIC(X2X)),'$$ACTIVE(X2X,X201(LEV)_","_$P(IENS,",",2,99)) G N1 ;If not active entry.. skip it..
S $P(IENS,",",1)=X201(LEV)
S X2=X2X
D GETSIE(X2,IENS,LEV)
S X1=SLEV(LEV)-1,XP=1
Q 1
NEXTB1(LEV) ;See if some other entries in x-ref at any level exist... no variable is set.
;
Q:X1 1
3 Q:LEV=0 0
I LEV>1,'$L($G(X20(LEV))) G 4
I LEV=1,'$L($G(X20(LEV))) Q 0
I LEV=1,'($O(@(ROOTB0(LEV)))!$L($O(@(ROOTB(LEV))))) Q 0
I LEV=1,'$$ACTALL() Q 0
I X201(LEV),$O(@(ROOTB0(LEV))) Q 1
Q:$L($O(@(ROOTB(LEV)))) 1
Q:LEV=1 0
4 S LEV=LEV-1 G 3
Q
SETACK(X,MODE) ;SET APPL. Acknowledgment + WRIGHT ??
W X,!
S:$G(MODE) ^TMP("XUMF ERROR",$J,XMD5,$O(^TMP("XUMF ERROR",$J,XMD5,9999999999999),-1)+1)=X
Q
UP(X) ;Upercase conversion
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
ACTIVE(FILE,IEN) ;GET 1 = Active 0 = Inactive
I $G(ACTFIL) Q 1
N TMP,BB,X,X1,X2,XT,XX
D GETS^DIQ(FILE,IEN,VAR2,"I","TMP","ERR")
S (XT,XX)=0,X="TMP"
F S X=$Q(@(X)) Q:'$L(X) D
.S X1=$G(@(X)),X=$Q(@(X)),X2=$G(@(X)) S:X1>XT XT=X1,XX=+X2
.I MAPFLG=1 S X=$Q(@(X))
Q XX
GETSIE(X2,IENS,LEV) ;GET Internal/External values + replace pointed field .01 with VUID
K TMP1(LEV) D GETS^DIQ(X2,IENS,"*","","TMP1(LEV)")
D:$D(TMP2(X2))!$D(TMP4(X2))
.N TMP3,I
.D GETS^DIQ(X2,IENS,"*","I","TMP3")
.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")
.;+++++++++++++++ Replace pointed .01 field with VUID if indicate so in 4.005
.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")_",",VAR1)
Q
ACTALL() ;See if there is some active entry on the file....
I $G(SORTACT) Q 1
N X1,X2,ACT
S ACT=0,X1=X20(1),X2=X201(1)
S:X20(1) X20(1)=X20(1)-.01
I SORTXREF="" 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
I SORTXREF'="" D
.S X20(1)=""
.F S X20(1)=$O(@(ROOTB(1))) Q:(X20(1)="")!ACT S X201(1)="" F S X201(1)=$O(@(ROOTB0(1))) Q:X201(1)="" I $$ACTIVE(X2OLD(1),X201(1)) S ACT=1,SORTACT=1 Q
S X20(1)=X1,X201(1)=X2
Q ACT
FILTER() ;if filter value passed in via HL7 message, verify it matches file/field value
; FILTER = VALUE IN HL7 MESSAGE
; FILTER1 = FIELD NUMBER IN 4.005
; FILTER2 = VALUE OF FIELD IN REFERENCED FILE
; If reference file is "Mappings", resolve pointer of 757.33 field .02 to 757.32 field 5 and compare
I '$D(FILTER) Q 1
I MAPFLG D
.S FILTER2=$$GET1^DIQ(X2OLD(1),X201(1),FILTER1,"I")
.S FILTER2=$$GET1^DIQ(757.32,FILTER2,5)
I 'MAPFLG S FILTER2=$$GET1^DIQ(X2,X201(1),FILTER1)
I ($G(FILTER2)'=$G(FILTER)) Q 0
Q 1
XUMF5I ;ISS/PAVEL - XUMF5 MD5 Hash Entry point ;5/19/06 06:15
+1 ;;8.0;KERNEL;**383,407,502**;July 10, 1995;Build 18
+2 ;
+3 ;MD5 based on info from 4.005 SORT BY VUID or USER DEFINED SORTING
+4 ;
+5 QUIT
EN(X0,MODE,IENCOUNT) ;entry point to get MD5 algorithm
+1 ; Lookup uses AMASTERVUID for files and B x-ref for subfiles....
+2 ;
+3 ; X0 = IEN or name of entry from 4.005 file
+4 ; MODE = 0 regular mode.. last HASH value returned in Apl. ACK.
+5 ; 1 debugging mode.. all values + hash codess returned in Apl ACK
+6 ; 1.1 debugging mode.. all values (no hash codes) returned in Apl ACK
+7 ; 2 debugging mode.. all fields values, all hash values, all hash codes returned in Apl. ACK.
+8 ; IENCOUNT = maximum entries for MD5 hash.. if NULL.. all entries counted...
+9 ; FILTER = value of filter field defined in file 4.005, field 8. Passed in by HL7 message (X0).
+10 ;
+11 ; TMP(sequence, def entry IEN, file/subfile #, field #)=""
+12 ; TMP1(,"1,120.82,2,",2)="INTERNAL"
+13 ; TMP2(FILE #,FIELD #)="" if internal value requested...
+14 NEW X,Y,X1,X2,X3,X20,X201,X1NEW,X2NEW,X2OLD,X0NAME,XP,H,CNT,CNTT,CNHT,XMD5,XDATE,XXP
+15 NEW DIC,ERR,ROOT,ROOTX,ROOTB,ROOTB0,POINTER,JUMP,START,TMP,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,FDA,VERSION
+16 NEW SLEV,LEV,IENS,VAL,VALUE,SORT,SORT1,EXITMD5,FILTER,FILTER1,FILTER2,ACTFIL,SORTXREF,SORTACT,MAPFLG,VAR,VAR0,VAR1,VAR2,VAR3
+17 NEW A,B,C,D,ABCD
+18 ;parse out file name/IEN and filter value if it exists
IF X0["~"
SET FILTER=$PIECE(X0,"~",2)
SET ACTFIL=$PIECE(X0,"~",3)
SET X0=$PIECE(X0,"~",1)
+19 DO INIT^XUMF5II
SET X1=0
SET VAR=""
SET VAR0=0
SET MAPFLG=0
+20 ; fields for files other than Mappings
SET VAR1=99.99
SET VAR2="99.991*"
SET VAR3=99.991
+21 FOR
SET VAR=$ORDER(^DIC(4.005,"B",VAR))
IF VAR=""
QUIT
Begin DoDot:1
+22 IF VAR="Mappings"
SET VAR0=0
SET VAR0=$ORDER(^DIC(4.005,"B",VAR,VAR0))
+23 ; fields for Mapping file
IF VAR0=X0
SET VAR1=.01
SET VAR2="3*"
SET VAR3=3
SET MAPFLG=1
End DoDot:1
+24 SET FILTER1=$$GET1^DIQ(4.005,X0,8)
+25 SET SORTXREF=$$GET1^DIQ(4.005,X0,7)
2 FOR
SET X1=$ORDER(TMP(X1))
IF '$$NEXTB1(LEV)!EXITMD5
QUIT
IF 'X1
SET X1=SLEV(LEV)
SET X2OLD=0
SET X2=$ORDER(TMP(X1,X0,0))
IF 'X2
QUIT
Begin DoDot:1
+1 SET (XP,JUMP)=0
SET XXP=$ORDER(TMP(X1,X0,X2,0))
+2 ;************ File/subfile has changed ************
+3 IF X2'=X2OLD
Begin DoDot:2
+4 ;K ^TMP("UNIQUE",$J)
+5 ;
+6 ;************ File Level & Start ************
+7 IF $DATA(^DIC(X2))
IF START
Begin DoDot:3
+8 SET START=0
SET SLEV(1)=X1
SET X2OLD(1)=X2
+9 KILL ROOT,ROOTB,ROOTB0,X02,X021,TMP1
+10 SET LEV=1
SET IENS=""
+11 DO GETONE(LEV,X2)
End DoDot:3
QUIT
+12 ;
+13 ;************ Going Up ************
+14 IF $GET(^DD(X2OLD,0,"UP"))=X2
Begin DoDot:3
+15 KILL ^TMP("UNIQUE",$JOB,X2OLD)
+16 IF $$NEXTB(LEV,X2OLD)
SET JUMP=2
QUIT
+17 KILL ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),X2OLD(LEV)
+18 SET LEV=LEV-1
SET IENS=$PIECE(IENS,",",$LENGTH(IENS,",")-LEV,9999)
SET X2=X2OLD(LEV)
End DoDot:3
QUIT
+19 IF JUMP
QUIT
+20 ;
+21 ;************ Going DOWN ************
+22 IF $GET(^DD(X2,0,"UP"))=X2OLD
Begin DoDot:3
+23 SET LEV=LEV+1
SET SLEV(LEV)=X1
SET X2OLD(LEV)=X2
+24 DO GETONE(LEV,X2)
End DoDot:3
QUIT
+25 ;
+26 ;************ Same Level other multiple... ************
+27 IF $GET(^DD(X2,0,"UP"))=$GET(^DD(X2OLD,0,"UP"))
IF +$GET(^DD(X2OLD,0,"UP"))
IF +$GET(^DD(X2,0,"UP"))
Begin DoDot:3
+28 IF $$NEXTB(LEV,X2OLD)
SET JUMP=2
QUIT
+29 KILL ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),X2OLD(LEV)
+30 ;B:'$L(IENS)
SET IENS=$PIECE(IENS,",",$LENGTH(IENS,",")-LEV+1,9999)
+31 SET SLEV(LEV)=X1
+32 SET X2OLD(LEV)=X2
+33 ;S X2=X2OLD
+34 DO GETONE(LEV,X2)
End DoDot:3
QUIT
+35 IF JUMP
QUIT
+36 ;
+37 ;************ New File not start... ************
+38 IF $DATA(^DIC(X2))
Begin DoDot:3
+39 IF '$DATA(X2NEW)
SET X2NEW=X2
SET X1NEW=X1
+40 IF $$NEXTB(LEV,X2OLD(LEV))
SET JUMP=2
QUIT
+41 KILL ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),SLEV(LEV),X2OLD(LEV)
+42 ;B:'$L(IENS)
SET IENS=$PIECE(IENS,",",$LENGTH(IENS,",")-LEV+1,9999)
+43 ;;;;;;;;GET TO THE BOTTOM LEVEL = 1 NOT ANY OTHRER'S B X-REF
IF LEV=1
SET (X1,SLEV(1))=X1NEW
SET (X2,X2OLD(1))=X2NEW
KILL X1NEW,X2NEW
DO GETONE(LEV,X2)
QUIT
+44 SET LEV=LEV-1
SET X1=SLEV(LEV)-1
SET X2=+$GET(X2OLD(LEV-1))
SET XP=1
End DoDot:3
QUIT
+45 ;
+46 ;************ Last sequence number ************
+47 IF X2OLD=0
Begin DoDot:3
21 IF $$NEXTB(LEV,X2)
SET JUMP=2
QUIT
+1 KILL ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),X2OLD(LEV)
+2 IF LEV=1
QUIT
+3 ;,X1=SLEV(LEV)-1,XP=1
SET LEV=LEV-1
SET IENS=$PIECE(IENS,",",$LENGTH(IENS,",")-LEV,9999)
SET X2=X2OLD(LEV)
+4 GOTO 21
End DoDot:3
QUIT
+5 QUIT
+6 ;
End DoDot:2
+7 SET X2OLD=X2
+8 IF JUMP
QUIT
+9 ;************ Get value & MD5 ************
+10 SET X3=$ORDER(TMP(X1+XP,X0,X2,0))
IF 'X3
QUIT
+11 SET VAL=$SELECT($LENGTH(IENS):$GET(TMP1(LEV,X2,IENS,X3)),1:"")
+12 IF '$LENGTH(VAL)
QUIT
+13 IF $ORDER(TMP1(LEV,X2,IENS,X3,0))
Begin DoDot:2
+14 NEW X4
SET X4=0
SET VAL=""
FOR
SET X4=$ORDER(TMP1(LEV,X2,IENS,X3,X4))
IF 'X4
QUIT
SET VAL=VAL_$GET(TMP1(LEV,X2,IENS,X3,X4))
End DoDot:2
+15 ;Filter out non-matching entries if a filter exists
+16 IF '$$FILTER()
QUIT
+17 ;If value set as uniqueue and already exist dont take it into MD5
+18 IF '$LENGTH(VAL)
QUIT
+19 IF $GET(TMP5(X2,X3))
IF $DATA(^TMP("UNIQUE",$JOB,X2,X3,VAL))
QUIT
SET ^TMP("UNIQUE",$JOB,X2,X3,VAL)=""
+20 Begin DoDot:2
+21 NEW X,TMP,I
+22 IF X3=VAR1
IF $DATA(^DIC(X2))
SET CNTT=CNTT+1
IF $GET(IENCOUNT)
IF CNTT>IENCOUNT
SET EXITMD5=1
SET CNTT=CNTT-1
QUIT
+23 IF MODE>1.99
DO SETACK("File #: "_X2_" Field #: "_X3_" Value: "_VAL_" IENS: "_IENS)
+24 SET CNT=$GET(CNT)+1
+25 SET VALUE=VALUE_VAL
211 IF $LENGTH(VALUE)<65
QUIT
+1 SET X=$EXTRACT(VALUE,65,$LENGTH(VALUE))
SET VALUE=$EXTRACT(VALUE,1,64)
+2 IF MODE
Begin DoDot:3
+3 DO SETACK($SELECT(MODE=1.1:"",1:"Value: ")_VALUE)
+4 IF MODE'=1.1
DO SETACK("HASH: "_$$MAIN^XUMF5BYT($$HEX^XUMF5AU($$MD5E^XUMF5AU(ABCD,VALUE,0,CNHT+1*64))))
End DoDot:3
+5 SET ABCD=$$MD5E^XUMF5AU(ABCD,VALUE,1)
+6 SET VALUE=X
SET CNHT=CNHT+1
+7 GOTO 211
End DoDot:2
+8 QUIT
End DoDot:1
+9 GOTO END^XUMF5II
+10 QUIT
GETONE(LEV,X2) ;GET DATA
+1 SET ROOT(LEV)=$$ROOT^DILFD(X2,"1,"_IENS,,"ERR")
+2 IF '$LENGTH(ROOT(LEV))
QUIT
+3 IF $DATA(ERR)
Begin DoDot:1
+4 SET ERROR="1^MD5 ROOT retrieval error, File/Subfile #: "_X2_" IENS: 1,"_IENS
SET EXITMD5=1
SET JUMP=2
+5 DO EM^XUMFX("file DIE call error message in RDT",.ERR)
+6 KILL ERR
End DoDot:1
QUIT
+7 IF SORTXREF'=""
IF '$DATA(@(ROOT(LEV)_""""_SORTXREF_""""_")"))
SET SORTXREF=""
+8 ;FOR LOOKUP OF ENTRIES
SET ROOTX(LEV)=ROOT(LEV)_"X201(LEV))"
+9 ; S:$D(^DIC(X2)) SORT="AMASTERVUID",SORT1="1,"
SET SORT1=""
SET SORT="B"
+10 IF $DATA(^DIC(X2))
Begin DoDot:1
+11 SET SORT="AMASTERVUID"
SET SORT1="1,"
+12 IF (SORTXREF'="")
SET SORT1=""
SET SORT=SORTXREF
End DoDot:1
+13 SET ROOTB(LEV)=ROOT(LEV)_""""_SORT_""",X20(LEV))"
+14 SET X20(LEV)=""
SET ROOTB0(LEV)=ROOT(LEV)_""""_SORT_""",X20(LEV),"_SORT1_"X201(LEV))"
+15 ;Pointer = pointer to file #
IF SORT="B"
SET POINTER=$GET(TMP7(X2,XXP))
+16 ;Handle pointer type of subfile...
IF SORT="B"
IF +POINTER
Begin DoDot:1
+17 NEW BB
SET POINTER=$EXTRACT(POINTER,2,$LENGTH(POINTER))
+18 ; ^TMP("PROOT",$J,Subfile #,IEN from up level,"Name sorted",IEN level)=""
+19 ; ^TMP("PROOT",$J,Subfile #,IEN from up level,X20(LEV),X201(LEV))=""
+20 KILL ^TMP("PROOT",$JOB,X2)
+21 ;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+22 SET X201(LEV)=0
FOR
SET X201(LEV)=$ORDER(@(ROOTX(LEV)))
IF 'X201(LEV)
QUIT
Begin DoDot:2
+23 ; If sort By VUID
IF $GET(TMP4(X2,XXP))
Begin DoDot:3
+24 ;BB=IEN of poited to field
SET BB=$$GET1^DIQ(X2,X201(LEV)_","_IENS,XXP,"I")
+25 ;BB=VUID
IF BB
SET BB=$$GET1^DIQ(TMP4(X2,XXP),BB_",",VAR1,"E")
End DoDot:3
+26 ; Else sort by .01 BB= .01
IF '$TEST
SET BB=$$GET1^DIQ(X2,X201(LEV)_","_IENS,XXP,"E")
+27 IF $LENGTH(BB)
SET ^TMP("PROOT",$JOB,X2,BB,X201(LEV))=""
End DoDot:2
+28 ;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+29 SET ROOTB(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV))"
+30 SET ROOTB0(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV),X201(LEV))"
End DoDot:1
+31 ;Handle Effective Date/Status multiple... only last date taken to HASH... TERMSTATUS
IF SORT="B"
IF LEV=2
IF X2=+$PIECE(^DD(X2OLD(1),VAR3,0),U,2)
Begin DoDot:1
+32 KILL ^TMP("PROOT",$JOB,X2)
+33 ;Get last date..
SET X20(LEV)=$ORDER(@(ROOTB(LEV)),-1)
+34 ;No Data in Effective Date Multiple.
IF '$LENGTH(X20(LEV))
QUIT
+35 SET X201(LEV)=0
SET X201(LEV)=+$ORDER(@ROOTB0(LEV))
+36 IF 'X201(LEV)
QUIT
+37 SET ROOTB(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV))"
+38 SET ROOTB0(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV),X201(LEV))"
+39 SET ^TMP("PROOT",$JOB,X2,X20(LEV),X201(LEV))=""
End DoDot:1
+40 SET X20(LEV)=""
+41 IF SORTXREF'=""
SET X20(LEV)=0
SET X201(LEV)=0
GET1 IF SORTXREF=""
SET X20(LEV)=$ORDER(@(ROOTB(LEV)))
IF '$LENGTH(X20(LEV))
QUIT
SET X201(LEV)=0
SET X201(LEV)=$ORDER(@(ROOTB0(LEV)))
+1 IF SORTXREF'=""
SET TMP8=$QUERY(@(ROOTB0(LEV)))
SET X20(LEV)=$PIECE(TMP8,",",3)
SET X201(LEV)=+$PIECE(TMP8,",",4)
IF '$LENGTH(X20(LEV))
QUIT
+2 IF (SORTXREF'="")
IF '$ORDER(@(ROOTB0(LEV)))
IF ('$LENGTH($ORDER(@(ROOTB(LEV)))))
IF '$$ACTALL()
SET EXITMD5=1
QUIT
+3 ;If not active entry.. skip it..
IF $DATA(^DIC(X2))
IF '$$ACTIVE(X2,X201(LEV)_","_IENS)
GOTO GET1
+4 SET IENS=X201(LEV)_","_IENS
+5 IF 'X201(LEV)
QUIT
+6 DO GETSIE(X2,IENS,LEV)
+7 QUIT
NEXTB(LEV,X2X) ;Get next IEN from xref on current level.. if exist
+1 ;Is there other entry at current level to be proceeded.. ?? get next "B" x-ref set old X2 = NEW X2 and go to loop
+2 IF '$DATA(X20(LEV))
QUIT 0
N1 IF '$LENGTH(X20(LEV))
QUIT 0
+1 IF LEV=1
IF '($ORDER(@(ROOTB0(LEV)))!$LENGTH($ORDER(@(ROOTB(LEV)))))
SET EXITMD5=1
QUIT 1
+2 IF '($ORDER(@(ROOTB0(LEV)))!$LENGTH($ORDER(@(ROOTB(LEV)))))
QUIT 0
+3 ;Try get new IEN fron B-xref
IF X201(LEV)
SET X201(LEV)=$ORDER(@(ROOTB0(LEV)))
+4 IF 'X201(LEV)
SET X20(LEV)=$ORDER(@(ROOTB(LEV)))
SET X201(LEV)=0
IF $LENGTH(X20(LEV))
SET X201(LEV)=$ORDER(@(ROOTB0(LEV)))
+5 IF 'X201(LEV)
QUIT 0
+6 ;If not active entry.. skip it..
IF $DATA(^DIC(X2X))
IF '$$ACTIVE(X2X,X201(LEV)_","_$PIECE(IENS,",",2,99))
GOTO N1
+7 SET $PIECE(IENS,",",1)=X201(LEV)
+8 SET X2=X2X
+9 DO GETSIE(X2,IENS,LEV)
+10 SET X1=SLEV(LEV)-1
SET XP=1
+11 QUIT 1
NEXTB1(LEV) ;See if some other entries in x-ref at any level exist... no variable is set.
+1 ;
+2 IF X1
QUIT 1
3 IF LEV=0
QUIT 0
+1 IF LEV>1
IF '$LENGTH($GET(X20(LEV)))
GOTO 4
+2 IF LEV=1
IF '$LENGTH($GET(X20(LEV)))
QUIT 0
+3 IF LEV=1
IF '($ORDER(@(ROOTB0(LEV)))!$LENGTH($ORDER(@(ROOTB(LEV)))))
QUIT 0
+4 IF LEV=1
IF '$$ACTALL()
QUIT 0
+5 IF X201(LEV)
IF $ORDER(@(ROOTB0(LEV)))
QUIT 1
+6 IF $LENGTH($ORDER(@(ROOTB(LEV))))
QUIT 1
+7 IF LEV=1
QUIT 0
4 SET LEV=LEV-1
GOTO 3
+1 QUIT
SETACK(X,MODE) ;SET APPL. Acknowledgment + WRIGHT ??
+1 WRITE X,!
+2 IF $GET(MODE)
SET ^TMP("XUMF ERROR",$JOB,XMD5,$ORDER(^TMP("XUMF ERROR",$JOB,XMD5,9999999999999),-1)+1)=X
+3 QUIT
UP(X) ;Upercase conversion
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
ACTIVE(FILE,IEN) ;GET 1 = Active 0 = Inactive
+1 IF $GET(ACTFIL)
QUIT 1
+2 NEW TMP,BB,X,X1,X2,XT,XX
+3 DO GETS^DIQ(FILE,IEN,VAR2,"I","TMP","ERR")
+4 SET (XT,XX)=0
SET X="TMP"
+5 FOR
SET X=$QUERY(@(X))
IF '$LENGTH(X)
QUIT
Begin DoDot:1
+6 SET X1=$GET(@(X))
SET X=$QUERY(@(X))
SET X2=$GET(@(X))
IF X1>XT
SET XT=X1
SET XX=+X2
+7 IF MAPFLG=1
SET X=$QUERY(@(X))
End DoDot:1
+8 QUIT XX
GETSIE(X2,IENS,LEV) ;GET Internal/External values + replace pointed field .01 with VUID
+1 KILL TMP1(LEV)
DO GETS^DIQ(X2,IENS,"*","","TMP1(LEV)")
+2 IF $DATA(TMP2(X2))!$DATA(TMP4(X2))
Begin DoDot:1
+3 NEW TMP3,I
+4 DO GETS^DIQ(X2,IENS,"*","I","TMP3")
+5 SET I=""
FOR
SET I=$ORDER(TMP2(X2,I))
IF 'I
QUIT
IF $DATA(TMP1(LEV,X2,IENS,I))
SET TMP1(LEV,X2,IENS,I)=TMP3(X2,IENS,I,"I")
+6 ;+++++++++++++++ Replace pointed .01 field with VUID if indicate so in 4.005
+7 SET I=""
FOR
SET I=$ORDER(TMP4(X2,I))
IF 'I
QUIT
IF $DATA(TMP1(LEV,X2,IENS,I))
SET TMP1(LEV,X2,IENS,I)=$$GET1^DIQ(TMP4(X2,I),TMP3(X2,IENS,I,"I")_",",VAR1)
End DoDot:1
+8 QUIT
ACTALL() ;See if there is some active entry on the file....
+1 IF $GET(SORTACT)
QUIT 1
+2 NEW X1,X2,ACT
+3 SET ACT=0
SET X1=X20(1)
SET X2=X201(1)
+4 IF X20(1)
SET X20(1)=X20(1)-.01
+5 IF SORTXREF=""
FOR
SET X20(1)=$ORDER(@(ROOTB(1)))
IF (X20(1)="")!ACT
QUIT
FOR
SET X201(1)=$ORDER(@(ROOTB0(1)))
IF X201(1)=""
QUIT
IF $$ACTIVE(X2OLD(1),X201(1))
SET ACT=1
QUIT
+6 IF SORTXREF'=""
Begin DoDot:1
+7 SET X20(1)=""
+8 FOR
SET X20(1)=$ORDER(@(ROOTB(1)))
IF (X20(1)="")!ACT
QUIT
SET X201(1)=""
FOR
SET X201(1)=$ORDER(@(ROOTB0(1)))
IF X201(1)=""
QUIT
IF $$ACTIVE(X2OLD(1),X201(1))
SET ACT=1
SET SORTACT=1
QUIT
End DoDot:1
+9 SET X20(1)=X1
SET X201(1)=X2
+10 QUIT ACT
FILTER() ;if filter value passed in via HL7 message, verify it matches file/field value
+1 ; FILTER = VALUE IN HL7 MESSAGE
+2 ; FILTER1 = FIELD NUMBER IN 4.005
+3 ; FILTER2 = VALUE OF FIELD IN REFERENCED FILE
+4 ; If reference file is "Mappings", resolve pointer of 757.33 field .02 to 757.32 field 5 and compare
+5 IF '$DATA(FILTER)
QUIT 1
+6 IF MAPFLG
Begin DoDot:1
+7 SET FILTER2=$$GET1^DIQ(X2OLD(1),X201(1),FILTER1,"I")
+8 SET FILTER2=$$GET1^DIQ(757.32,FILTER2,5)
End DoDot:1
+9 IF 'MAPFLG
SET FILTER2=$$GET1^DIQ(X2,X201(1),FILTER1)
+10 IF ($GET(FILTER2)'=$GET(FILTER))
QUIT 0
+11 QUIT 1
