Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XUMF5I

XUMF5I.m

Go to the documentation of this file.
  1. XUMF5I ;ISS/PAVEL - XUMF5 MD5 Hash Entry point ;02/26/2015
  1. ;;8.0;KERNEL;**383,407,502,654**;July 10, 1995;Build 32
  1. ;
  1. ;MD5 based on info from 4.005 SORT BY VUID or USER DEFINED SORTING
  1. ;
  1. Q
  1. EN(X0,MODE,IENCOUNT) ;entry point to get MD5 algorithm
  1. ; Lookup uses AMASTERVUID for files and B x-ref for subfiles....
  1. ;
  1. ; X0 = IEN or name of entry from 4.005 file
  1. ; MODE = 0 regular mode.. last HASH value returned in Apl. ACK.
  1. ; 1 debugging mode.. all values + hash codess returned in Apl ACK
  1. ; 1.1 debugging mode.. all values (no hash codes) returned in Apl ACK
  1. ; 2 debugging mode.. all fields values, all hash values, all hash codes returned in Apl. ACK.
  1. ; IENCOUNT = maximum entries for MD5 hash.. if NULL.. all entries counted...
  1. ; FILTER = value of filter field defined in file 4.005, field 8. Passed in by HL7 message (X0).
  1. ;
  1. ; TMP(sequence, def entry IEN, file/subfile #, field #)=""
  1. ; TMP1(,"1,120.82,2,",2)="INTERNAL"
  1. ; TMP2(FILE #,FIELD #)="" if internal value requested...
  1. N X,Y,X1,X2,X3,X20,X201,X1NEW,X2NEW,X2OLD,X0NAME,XP,H,CNT,CNTT,CNHT,XMD5,XDATE,XXP
  1. N DIC,ERR,ROOT,ROOTX,ROOTB,ROOTB0,POINTER,JUMP,START,TMP,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,FDA,VERSION
  1. N SLEV,LEV,IENS,VAL,VALUE,SORT,SORT1,EXITMD5,FILTER,FILTER1,FILTER2,ACTFIL,SORTXREF,SORTACT,MAPFLG,VAR,VAR0,VAR1,VAR2,VAR3
  1. N A,B,C,D,ABCD
  1. 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
  1. D INIT^XUMF5II S X1=0,VAR="",VAR0=0,MAPFLG=0
  1. S VAR1=99.99,VAR2="99.991*",VAR3=99.991 ; fields for files other than Mappings
  1. F S VAR=$O(^DIC(4.005,"B",VAR)) Q:VAR="" D
  1. .I VAR="Mappings" S VAR0=0,VAR0=$O(^DIC(4.005,"B",VAR,VAR0))
  1. .I VAR0=X0 S VAR1=.01,VAR2="3*",VAR3=3,MAPFLG=1 ; fields for Mapping file
  1. S FILTER1=$$GET1^DIQ(4.005,X0,8)
  1. S SORTXREF=$$GET1^DIQ(4.005,X0,7)
  1. 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
  1. .S (XP,JUMP)=0,XXP=$O(TMP(X1,X0,X2,0))
  1. .;************ File/subfile has changed ************
  1. .D:X2'=X2OLD
  1. ..;K ^TMP("UNIQUE",$J)
  1. ..;
  1. ..;************ File Level & Start ************
  1. ..I $D(^DIC(X2)),START D Q
  1. ...S START=0,SLEV(1)=X1,X2OLD(1)=X2
  1. ...K ROOT,ROOTB,ROOTB0,X02,X021,TMP1
  1. ...S LEV=1,IENS=""
  1. ...D GETONE(LEV,X2)
  1. ..;
  1. ..;************ Going Up ************
  1. ..I $G(^DD(X2OLD,0,"UP"))=X2 D Q
  1. ...K ^TMP("UNIQUE",$J,X2OLD)
  1. ...I $$NEXTB(LEV,X2OLD) S JUMP=2 Q
  1. ...K ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),X2OLD(LEV)
  1. ...S LEV=LEV-1,IENS=$P(IENS,",",$L(IENS,",")-LEV,9999),X2=X2OLD(LEV)
  1. ..Q:JUMP
  1. ..;
  1. ..;************ Going DOWN ************
  1. ..I $G(^DD(X2,0,"UP"))=X2OLD D Q
  1. ...S LEV=LEV+1,SLEV(LEV)=X1,X2OLD(LEV)=X2
  1. ...D GETONE(LEV,X2)
  1. ..;
  1. ..;************ Same Level other multiple... ************
  1. ..I $G(^DD(X2,0,"UP"))=$G(^DD(X2OLD,0,"UP")),+$G(^DD(X2OLD,0,"UP")),+$G(^DD(X2,0,"UP")) D Q
  1. ...I $$NEXTB(LEV,X2OLD) S JUMP=2 Q
  1. ...K ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),X2OLD(LEV)
  1. ...S IENS=$P(IENS,",",$L(IENS,",")-LEV+1,9999) ;B:'$L(IENS)
  1. ...S SLEV(LEV)=X1
  1. ...S X2OLD(LEV)=X2
  1. ...;S X2=X2OLD
  1. ...D GETONE(LEV,X2)
  1. ..Q:JUMP
  1. ..;
  1. ..;************ New File not start... ************
  1. ..I $D(^DIC(X2)) D Q
  1. ...S:'$D(X2NEW) X2NEW=X2,X1NEW=X1
  1. ...I $$NEXTB(LEV,X2OLD(LEV)) S JUMP=2 Q
  1. ...K ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),SLEV(LEV),X2OLD(LEV)
  1. ...S IENS=$P(IENS,",",$L(IENS,",")-LEV+1,9999) ;B:'$L(IENS)
  1. ...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
  1. ...S LEV=LEV-1,X1=SLEV(LEV)-1,X2=+$G(X2OLD(LEV-1)),XP=1
  1. ..;
  1. ..;************ Last sequence number ************
  1. ..I X2OLD=0 D Q
  1. 21 ...I $$NEXTB(LEV,X2) S JUMP=2 Q
  1. ...K ROOT(LEV),ROOTB(LEV),ROOTB0(LEV),X20(LEV),X201(LEV),TMP1(LEV),X2OLD(LEV)
  1. ...Q:LEV=1
  1. ...S LEV=LEV-1,IENS=$P(IENS,",",$L(IENS,",")-LEV,9999),X2=X2OLD(LEV) ;,X1=SLEV(LEV)-1,XP=1
  1. ...G 21
  1. ..Q
  1. ..;
  1. .S X2OLD=X2
  1. .Q:JUMP
  1. .;************ Get value & MD5 ************
  1. .S X3=$O(TMP(X1+XP,X0,X2,0)) Q:'X3
  1. .S VAL=$S($L(IENS):$G(TMP1(LEV,X2,IENS,X3)),1:"")
  1. .Q:'$L(VAL)
  1. .D:$O(TMP1(LEV,X2,IENS,X3,0))
  1. ..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))
  1. .;Filter out non-matching entries if a filter exists
  1. .Q:'$$FILTER()
  1. .;If value set as uniqueue and already exist dont take it into MD5
  1. .Q:'$L(VAL)
  1. .I $G(TMP5(X2,X3)) Q:$D(^TMP("UNIQUE",$J,X2,X3,VAL)) S ^TMP("UNIQUE",$J,X2,X3,VAL)=""
  1. .D
  1. ..N X,TMP,I
  1. ..I X3=VAR1,$D(^DIC(X2)) S CNTT=CNTT+1 I $G(IENCOUNT),CNTT>IENCOUNT S EXITMD5=1,CNTT=CNTT-1 Q
  1. ..D:MODE>1.99 SETACK("File #: "_X2_" Field #: "_X3_" Value: "_VAL_" IENS: "_IENS)
  1. ..S CNT=$G(CNT)+1
  1. ..S VALUE=VALUE_VAL
  1. 211 ..Q:$L(VALUE)<65
  1. ..S X=$E(VALUE,65,$L(VALUE)),VALUE=$E(VALUE,1,64)
  1. ..D:MODE
  1. ...D SETACK($S(MODE=1.1:"",1:"Value: ")_VALUE)
  1. ...D:MODE'=1.1 SETACK("HASH: "_$$MAIN^XUMF5BYT($$HEX^XUMF5AU($$MD5E^XUMF5AU(ABCD,VALUE,0,CNHT+1*64))))
  1. ..S ABCD=$$MD5E^XUMF5AU(ABCD,VALUE,1)
  1. ..S VALUE=X,CNHT=CNHT+1
  1. ..G 211
  1. .Q
  1. G END^XUMF5II
  1. Q
  1. GETONE(LEV,X2) ;GET DATA
  1. S ROOT(LEV)=$$ROOT^DILFD(X2,"1,"_IENS,,"ERR")
  1. Q:'$L(ROOT(LEV))
  1. I $D(ERR) D Q
  1. .S ERROR="1^MD5 ROOT retrieval error, File/Subfile #: "_X2_" IENS: 1,"_IENS,EXITMD5=1,JUMP=2
  1. .D EM^XUMFX("file DIE call error message in RDT",.ERR)
  1. .K ERR
  1. I SORTXREF'="" S:'$D(@(ROOT(LEV)_""""_SORTXREF_""""_")")) SORTXREF=""
  1. S ROOTX(LEV)=ROOT(LEV)_"X201(LEV))" ;FOR LOOKUP OF ENTRIES
  1. S SORT1="",SORT="B" ; S:$D(^DIC(X2)) SORT="AMASTERVUID",SORT1="1,"
  1. I $D(^DIC(X2)) D
  1. .S SORT="AMASTERVUID",SORT1="1,"
  1. .I (SORTXREF'="") S SORT1="",SORT=SORTXREF
  1. S ROOTB(LEV)=ROOT(LEV)_""""_SORT_""",X20(LEV))"
  1. S X20(LEV)="",ROOTB0(LEV)=ROOT(LEV)_""""_SORT_""",X20(LEV),"_SORT1_"X201(LEV))"
  1. S:SORT="B" POINTER=$G(TMP7(X2,XXP)) ;Pointer = pointer to file #
  1. I SORT="B",+POINTER D ;Handle pointer type of subfile...
  1. .N BB S POINTER=$E(POINTER,2,$L(POINTER))
  1. .; ^TMP("PROOT",$J,Subfile #,IEN from up level,"Name sorted",IEN level)=""
  1. .; ^TMP("PROOT",$J,Subfile #,IEN from up level,X20(LEV),X201(LEV))=""
  1. .K ^TMP("PROOT",$J,X2)
  1. .;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  1. .S X201(LEV)=0 F S X201(LEV)=$O(@(ROOTX(LEV))) Q:'X201(LEV) D
  1. ..I $G(TMP4(X2,XXP)) D ; If sort By VUID
  1. ...S BB=$$GET1^DIQ(X2,X201(LEV)_","_IENS,XXP,"I") ;BB=IEN of poited to field
  1. ...S:BB BB=$$GET1^DIQ(TMP4(X2,XXP),BB_",",VAR1,"E") ;BB=VUID
  1. ..E S BB=$$GET1^DIQ(X2,X201(LEV)_","_IENS,XXP,"E") ; Else sort by .01 BB= .01
  1. ..S:$L(BB) ^TMP("PROOT",$J,X2,BB,X201(LEV))=""
  1. .;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  1. .S ROOTB(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV))"
  1. .S ROOTB0(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV),X201(LEV))"
  1. 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
  1. .K ^TMP("PROOT",$J,X2)
  1. .S X20(LEV)=$O(@(ROOTB(LEV)),-1) ;Get last date..
  1. .Q:'$L(X20(LEV)) ;No Data in Effective Date Multiple.
  1. .S X201(LEV)=0,X201(LEV)=+$O(@ROOTB0(LEV))
  1. .Q:'X201(LEV)
  1. .S ROOTB(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV))"
  1. .S ROOTB0(LEV)="^TMP(""PROOT"",$J,"_X2_",X20(LEV),X201(LEV))"
  1. .S ^TMP("PROOT",$J,X2,X20(LEV),X201(LEV))=""
  1. S X20(LEV)=""
  1. I SORTXREF'="" S X20(LEV)=0,X201(LEV)=0
  1. GET1 I SORTXREF="" S X20(LEV)=$O(@(ROOTB(LEV))) Q:'$L(X20(LEV)) S X201(LEV)=0,X201(LEV)=$O(@(ROOTB0(LEV)))
  1. I SORTXREF'="" S TMP8=$Q(@(ROOTB0(LEV))),X20(LEV)=$P(TMP8,",",3),X201(LEV)=+$P(TMP8,",",4) Q:'$L(X20(LEV))
  1. I (SORTXREF'=""),'$O(@(ROOTB0(LEV))),('$L($O(@(ROOTB(LEV))))),'$$ACTALL() S EXITMD5=1 Q
  1. I $D(^DIC(X2)),'$$ACTIVE(X2,X201(LEV)_","_IENS) G GET1 ;If not active entry.. skip it..
  1. S IENS=X201(LEV)_","_IENS
  1. Q:'X201(LEV)
  1. D GETSIE(X2,IENS,LEV)
  1. Q
  1. 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
  1. Q:'$D(X20(LEV)) 0
  1. N1 Q:'$L(X20(LEV)) 0
  1. I LEV=1,'($O(@(ROOTB0(LEV)))!$L($O(@(ROOTB(LEV))))) S EXITMD5=1 Q 1
  1. Q:'($O(@(ROOTB0(LEV)))!$L($O(@(ROOTB(LEV))))) 0
  1. S:X201(LEV) X201(LEV)=$O(@(ROOTB0(LEV))) ;Try get new IEN fron B-xref
  1. I 'X201(LEV) S X20(LEV)=$O(@(ROOTB(LEV))),X201(LEV)=0 S:$L(X20(LEV)) X201(LEV)=$O(@(ROOTB0(LEV)))
  1. Q:'X201(LEV) 0
  1. I $D(^DIC(X2X)),'$$ACTIVE(X2X,X201(LEV)_","_$P(IENS,",",2,99)) G N1 ;If not active entry.. skip it..
  1. S $P(IENS,",",1)=X201(LEV)
  1. S X2=X2X
  1. D GETSIE(X2,IENS,LEV)
  1. S X1=SLEV(LEV)-1,XP=1
  1. Q 1
  1. NEXTB1(LEV) ;See if some other entries in x-ref at any level exist... no variable is set.
  1. ;
  1. Q:X1 1
  1. 3 Q:LEV=0 0
  1. I LEV>1,'$L($G(X20(LEV))) G 4
  1. I LEV=1,'$L($G(X20(LEV))) Q 0
  1. I LEV=1,'($O(@(ROOTB0(LEV)))!$L($O(@(ROOTB(LEV))))) Q 0
  1. I LEV=1,'$$ACTALL() Q 0
  1. I X201(LEV),$O(@(ROOTB0(LEV))) Q 1
  1. Q:$L($O(@(ROOTB(LEV)))) 1
  1. Q:LEV=1 0
  1. 4 S LEV=LEV-1 G 3
  1. Q
  1. SETACK(X,MODE) ;SET APPL. Acknowledgment + WRIGHT ??
  1. W X,!
  1. S:$G(MODE) ^TMP("XUMF ERROR",$J,XMD5,$O(^TMP("XUMF ERROR",$J,XMD5,9999999999999),-1)+1)=X
  1. Q
  1. UP(X) ;Upercase conversion
  1. Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. ACTIVE(FILE,IEN) ;GET 1 = Active 0 = Inactive
  1. I $G(ACTFIL) Q 1
  1. N TMP,BB,X,X1,X2,XT,XX
  1. D GETS^DIQ(FILE,IEN,VAR2,"I","TMP","ERR")
  1. S (XT,XX)=0,X="TMP"
  1. F S X=$Q(@(X)) Q:'$L(X) D
  1. .S X1=$G(@(X)),X=$Q(@(X)),X2=$G(@(X)) S:X1>XT XT=X1,XX=+X2
  1. .I MAPFLG=1 S X=$Q(@(X))
  1. Q XX
  1. GETSIE(X2,IENS,LEV) ;GET Internal/External values + replace pointed field .01 with VUID
  1. K TMP1(LEV) D GETS^DIQ(X2,IENS,"*","","TMP1(LEV)")
  1. ;D:$D(TMP2(X2))!$D(TMP4(X2)) ;remove p654
  1. D:$D(TMP2(X2))!$D(TMP4(X2))!$D(TMP8(X2))
  1. .N TMP3,I
  1. .D GETS^DIQ(X2,IENS,"*","I","TMP3")
  1. .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")
  1. .;+++++++++++++++ Replace pointed .01 field with VUID if indicate so in 4.005
  1. .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)
  1. .;+++++++++++++++ Process post action on field patch XU*8.0*654
  1. .S I="" F S I=$O(TMP8(X2,I)) Q:'I X:$D(TMP1(LEV,X2,IENS,I)) TMP8(X2,I)
  1. Q
  1. ACTALL() ;See if there is some active entry on the file....
  1. I $G(SORTACT) Q 1
  1. N X1,X2,ACT
  1. S ACT=0,X1=X20(1),X2=X201(1)
  1. S:X20(1) X20(1)=X20(1)-.01
  1. 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
  1. I SORTXREF'="" D
  1. .S X20(1)=""
  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
  1. S X20(1)=X1,X201(1)=X2
  1. Q ACT
  1. FILTER() ;if filter value passed in via HL7 message, verify it matches file/field value
  1. ; FILTER = VALUE IN HL7 MESSAGE
  1. ; FILTER1 = FIELD NUMBER IN 4.005
  1. ; FILTER2 = VALUE OF FIELD IN REFERENCED FILE
  1. ; If reference file is "Mappings", resolve pointer of 757.33 field .02 to 757.32 field 5 and compare
  1. I '$D(FILTER) Q 1
  1. I MAPFLG D
  1. .S FILTER2=$$GET1^DIQ(X2OLD(1),X201(1),FILTER1,"I")
  1. .S FILTER2=$$GET1^DIQ(757.32,FILTER2,5)
  1. I 'MAPFLG S FILTER2=$$GET1^DIQ(X2,X201(1),FILTER1)
  1. I ($G(FILTER2)'=$G(FILTER)) Q 0
  1. Q 1