- XUMF5I ;ISS/PAVEL - XUMF5 MD5 Hash Entry point ;02/26/2015
- ;;8.0;KERNEL;**383,407,502,654**;July 10, 1995;Build 32
- ;
- ;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)) ;remove p654
- D:$D(TMP2(X2))!$D(TMP4(X2))!$D(TMP8(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)
- .;+++++++++++++++ Process post action on field patch XU*8.0*654
- .S I="" F S I=$O(TMP8(X2,I)) Q:'I X:$D(TMP1(LEV,X2,IENS,I)) TMP8(X2,I)
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMF5I 11473 printed Feb 18, 2025@23:36:59 Page 2
- XUMF5I ;ISS/PAVEL - XUMF5 MD5 Hash Entry point ;02/26/2015
- +1 ;;8.0;KERNEL;**383,407,502,654**;July 10, 1995;Build 32
- +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 ;D:$D(TMP2(X2))!$D(TMP4(X2)) ;remove p654
- +3 if $DATA(TMP2(X2))!$DATA(TMP4(X2))!$DATA(TMP8(X2))
- Begin DoDot:1
- +4 NEW TMP3,I
- +5 DO GETS^DIQ(X2,IENS,"*","I","TMP3")
- +6 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")
- +7 ;+++++++++++++++ Replace pointed .01 field with VUID if indicate so in 4.005
- +8 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)
- +9 ;+++++++++++++++ Process post action on field patch XU*8.0*654
- +10 SET I=""
- FOR
- SET I=$ORDER(TMP8(X2,I))
- if 'I
- QUIT
- if $DATA(TMP1(LEV,X2,IENS,I))
- XECUTE TMP8(X2,I)
- End DoDot:1
- +11 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