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

XDRDVAL2.m

Go to the documentation of this file.
  1. XDRDVAL2 ;SF-IRMFO.SEA/JLI - IDENTIFY FIELDS THAT NEED CHECKING FOR MERGE ;02/07/2000 09:55
  1. ;;7.3;TOOLKIT;**23,34,36,42,45,77**;Apr 25, 1995
  1. ;;
  1. Q
  1. ;
  1. CHKMERG(FILENUM,IENFROM,IENTO,ARRAY) ;
  1. N XDRDVALF
  1. S XDRDVALF=1
  1. S FILE=FILENUM D SETUP^XDRMERG(2)
  1. D CHKFMERG(FILE,IENFROM,IENTO,ARRAY)
  1. S XGLOB="" F S XGLOB=$O(^TMP($J,"XGLOB",XGLOB)) Q:XGLOB="" D
  1. . I $P($G(^TMP($J,"XGLOB",XGLOB,0,1)),U,3)="DINUM" S F=$P(^(1),U) D CHKFMERG(F,IENFROM,IENTO,ARRAY)
  1. Q
  1. ;
  1. CHKFMERG(XFILNO,IENFROM,IENTO,LOCATION) ; CHECK VALIDITY FOR MERGE OF TWO ENTRIES IN FILE
  1. N F,FILE,FILENUM,XGLOB,NODE,NODE1,NODE2,NODEA,SFILE,XDRFROM,XDRTO,NODEA,VALUE,XVALUE,XDRXX,NODEB,DIK,DA,I,Y,VREF,XNN,IENTOSTR,DFN,XDRZZ
  1. N XDRAA ; DEBUG STATEMENT
  1. ;
  1. S XDRDIC=$G(^DIC(XFILNO,0,"GL")) Q:XDRDIC=""
  1. S IENTOSTR=IENTO_","
  1. S DFN=IENTO
  1. ;
  1. ; CHECK FOR BROKEN LR NODES IF PATIENT FILE
  1. ;
  1. ; FOLLOWING LINE MODIFIED TO INCLUDE IDENTIFIED PROBLEMS IN OUTPUT - JLI 03/23/99
  1. I XFILNO=2 F I=IENFROM,IENTO S J=$G(^DPT(I,"LR")) I J>0,($P(^LR(J,0),U,2)'=2)!($P(^LR(J,0),U,3)'=I) S @LOCATION@(2,(I_","),63,"INVALID")="Broken ""LR"" node pointers for PATIENT file and LAB DATA FILE - DFN="_I_" LRFN="_J
  1. ;
  1. ; NOW MERGE DATA GOING NODE BY NODE
  1. ;
  1. S NODE=""
  1. F D Q:NODE=""
  1. . S NODE1=$O(@(XDRDIC_IENFROM_","""_NODE_""")"))
  1. . I NODE1="" S NODE="" Q ; NOTHING MORE TO MOVE OVER
  1. . S NODE2=$O(@(XDRDIC_IENTO_","""_NODE_""")"))
  1. . I NODE2'="",NODE1]NODE2 S NODE=NODE2 Q ; NODE ON TO, BUT NOT ON FROM - GO TO NEXT
  1. . S NODE=NODE1
  1. . I $D(@(XDRDIC_IENFROM_","""_NODE_""")"))=1 D Q ; SINGLE NODE, MERGE DATA
  1. . . I NODE2]NODE1!(NODE2="") D Q ; MISSING NODE, JUST MOVE IT OVER
  1. . . . N XDRXX,FLD,N,J
  1. . . . F N=0:0 S N=$O(^DD(XFILNO,"GL",NODE,N)) Q:N'>0 S FLD=$O(^(N,0)) I $O(^DD(XFILNO,FLD,1,0))>0 D
  1. . . . . S X=0 F J=0:0 S J=$O(^DD(XFILNO,FLD,1,J)) Q:J'>0 I $O(^(J,0))>0 S X=1 Q
  1. . . . . I X>0 D
  1. . . . . . S XDRXX(XFILNO,IENTOSTR,FLD)=$$GETEXT(XDRDIC,IENFROM,XFILNO,FLD)
  1. . . . I $D(XDRXX) D CHEKFDA("XDRXX",LOCATION)
  1. . . I $D(@(XDRDIC_IENTO_","""_NODE_""")"))>1 Q ; MISMATCH SKIP
  1. . . N XDRXX,FLD
  1. . . S X1=@(XDRDIC_IENFROM_","""_NODE_""")")
  1. . . S (X2,X3)=@(XDRDIC_IENTO_","""_NODE_""")")
  1. . . F XDRI=1:1 Q:X1="" S X=$P(X1,U),X1=$P(X1,U,2,999) I X'="" D
  1. . . . S Y=$P(X2,U,XDRI)
  1. . . . I Y="" D
  1. . . . . S $P(X2,U,XDRI)=X
  1. . . . . S FLD=$O(^DD(XFILNO,"GL",NODE,XDRI,0)) S JXFLD=FLD
  1. . . . . I FLD>0,$O(^DD(XFILNO,FLD,1,0))>0 S XDRXX(XFILNO,IENTOSTR,FLD)=$$GETEXT(XDRDIC,IENFROM,XFILNO,FLD)
  1. . . I X2'=X3 D
  1. . . . I $D(XDRXX) D
  1. . . . . N X2 D CHEKFDA("XDRXX",LOCATION)
  1. . ;
  1. . ; THE FOLLOWING HANDLES NODES THAT HAVE MULTIPLES
  1. . ;
  1. . S XDRFROM=XDRDIC_IENFROM_","""_NODE_""","
  1. . S XDRTO=XDRDIC_IENTO_","""_NODE_""","
  1. . I NODE="DIS",XFILNO=2 Q
  1. . S IENTOSTR=IENTO_","
  1. . D CHKSUBS(XDRFROM,XDRTO,IENTOSTR,IENTO)
  1. Q
  1. ;
  1. CHKSUBS(XDRFROM,XDRTO,IENTOSTR,XDRDASEQ) ;
  1. N NODEA,SFILE,VALUE,XVALUE,XDRXX,XDRYY,YVALUE,XENTOSTR
  1. N XDRAA,XDRZZ ; DEBUG STATEMENT
  1. S SFILE=+$P($G(@(XDRFROM_"0)")),U,2)
  1. I SFILE'>0 Q ; NO FILE NUMBER, NOT FILE MANAGER COMPATIBLE
  1. I $P($G(^DD(SFILE,.01,0)),U,2)["W" Q ; HANDLE WORD PROCESSING FIELDS
  1. F NODEA=0:0 S NODEA=$O(@(XDRFROM_NODEA_")")) Q:NODEA'>0 D
  1. . S VALUE=$P($G(@(XDRFROM_NODEA_",0)")),U) ; GET .01 VALUE
  1. . N XDRDT S XDRDT=^DD(SFILE,.01,0)
  1. . I $P(XDRDT,U,2)["D" S XDRDT=$P(XDRDT,U,5,999),XDRDINUM=$S(XDRDT["DINUM":1,1:0) I XDRDINUM S XDRDT=0 D DINUMDAT Q:XDRDT ; HANDLE DINUMED DATES BY SIMPLY MOVING THEM
  1. . S YVALUE=0,XVALUE=0 I $D(^DD(SFILE,.001,0)) S YVALUE=NODEA I $D(@(XDRTO_NODEA_")")) S XVALUE=YVALUE
  1. . I XVALUE=0,$P(^DD(SFILE,.01,0),U,5,99)["DINUM",$D(@(XDRTO_NODEA_")")) S XVALUE=NODEA
  1. . I XVALUE=0 S XVALUE=+$$FIND1^DIC(SFILE,(","_IENTOSTR),"Q",VALUE) ; FIND CURRENT ENTRY NUMBER, IF PRESENT
  1. . I XVALUE>0 D Q ; SUBFILE EXISTS IN IENTO, CHECK FOR LOWER SUBFILES
  1. . . N X,X1,NODE,NEWFROM,NEWTO,NEWTOIEN
  1. . . S NODE=""
  1. . . F S NODE=$O(@(XDRFROM_NODEA_","""_NODE_""")")) Q:NODE="" D
  1. . . . I $D(@(XDRFROM_NODEA_","""_NODE_""")"))'>1 Q
  1. . . . S NEWFROM=XDRFROM_NODEA_","""_NODE_""","
  1. . . . S NEWTO=XDRTO_XVALUE_","""_NODE_""","
  1. . . . S NEWTOIEN=XVALUE_","_IENTOSTR
  1. . . . D CHKSUBS(NEWFROM,NEWTO,NEWTOIEN,(XVALUE_U_XDRDASEQ))
  1. . K XDRYY I YVALUE>0 S XDRYY(1)=YVALUE
  1. . S XENTOSTR="+1,"_IENTOSTR
  1. . S XDRFILTY=$P($G(^DD(SFILE,.01,0)),U,2)
  1. . ;I XDRFILTY["P",SFILE'=2.011 S VALUE="`"_VALUE
  1. . ;I XDRFILTY["V" D
  1. . ;. N Y S Y=$P(VALUE,";",2) Q:Y=""
  1. . ;. S Y=$P($G(@("^"_Y_"0)")),U) Q:Y=""
  1. . ;. S VALUE=Y_".`"_(+VALUE)
  1. . ;. Q
  1. . I (XDRFILTY["P")!(XDRFILTY["V")!(XDRFILTY["D") Q ; HANDLE AS INTERNAL VALUES ; JLI 9-1-99
  1. . I SFILE=2.011 Q ; SPECIAL HANDLING ; JLI 9-1-99
  1. . S XDRXX(SFILE,XENTOSTR,.01)=$$GETEXT(XDRFROM,NODEA,SFILE,.01)
  1. . D CHEKFDA("XDRXX",LOCATION)
  1. . F XDRID=0:0 S XDRID=$O(^DD(SFILE,0,"ID",XDRID)) Q:XDRID'>0 D
  1. . . Q:$P(^DD(SFILE,XDRID,0),U,2)'["R"
  1. . . S VALUE=$$GETEXT(XDRFROM,NODEA,SFILE,XDRID)
  1. . . I VALUE="" W !,"PROBLEM WITH IDENTIFIER FILE=",SFILE," IENSTR=",XENTOSTR," FIELD=",XDRID
  1. Q
  1. ;
  1. GETEXT(DICA,DA,FILNUM,FIELD,TYPE) ; GET EXTERNAL VALUE FOR .01 FIELD
  1. N DIC,DIQ,DR,XDRQ,TEMP
  1. I $G(FIELD)="" S FIELD=.01
  1. I $G(TYPE)="" S TYPE="E"
  1. S DIC=DICA,DIC("P")=FILNUM,DR=FIELD,DIQ="XDRQ",DIQ(0)="I"
  1. D EN^DIQ1
  1. S TEMP=$G(XDRQ(FILNUM,DA,FIELD,"I")) I TEMP="" Q ""
  1. S DIC=DICA,DIC("P")=FILNUM,DR=FIELD,DIQ="XDRQ",DIQ(0)="E" K XDRQ
  1. D EN^DIQ1
  1. Q TEMP_U_$G(XDRQ(FILNUM,DA,FIELD,"E"))
  1. Q $G(XDRQ(FILNUM,DA,FIELD,TYPE))
  1. ;
  1. DINUMDAT ; PROCESS ENTRIES WITH SAMPLE DATE/TIMES WITH SECONDS, NEEDS DINUM
  1. I $D(@(XDRTO_NODEA_")")) Q
  1. S XDRDT=1
  1. Q
  1. ;
  1. CHEKFDA(FDA,LOCATION) ;
  1. N FILE,IENS,FIELD,VAL,VALEXT
  1. F FILE=0:0 S FILE=$O(@FDA@(FILE)) Q:FILE'>0 D
  1. . S IENS="" F S IENS=$O(@FDA@(FILE,IENS)) Q:IENS="" D
  1. . . F FIELD=0:0 S FIELD=$O(@FDA@(FILE,IENS,FIELD)) Q:FIELD'>0 D
  1. . . . S VAL=@FDA@(FILE,IENS,FIELD),VALEXT=$P(VAL,U,2),VAL=$P(VAL,U) I VAL="" Q
  1. . . . I FILE=2,FIELD=.09 Q ; SSN NUMBER IS ENTERED AS INTERNAL
  1. . . . I FILE=2,$P(^DD(FILE,FIELD,0),U,5,99)["DGLOCK2" Q ; no NOK check
  1. . . . I FILE=70.03,FIELD=.01 Q ; TIES UP EVERYTHING... ; JLI 9-1-99
  1. . . . I FILE=354,FIELD=.03!(FIELD=.05) Q ; THIS ONE IS TOUGH, DON'T WORRY ABOUT IT
  1. . . . I FILE=2,FIELD=63 Q ; LAB DATA POINTER HAS SPECIAL PROCESSING
  1. . . . I FILE=161,FIELD=.5 Q ; FB has special processing, JDS XT*7.3*77, 8/5/03
  1. . . . S MESGROOT=$NA(^TMP($J,"MESG")) K @MESGROOT
  1. . . . D CHKVALID^XDRDVAL(MESGROOT,FILE,IENS,FIELD,VALEXT,VAL)
  1. . . . I $D(@MESGROOT) M @LOCATION=@MESGROOT K @MESGROOT
  1. . . . Q
  1. . . Q
  1. . Q
  1. Q