- XDRDVAL2 ;SF-IRMFO.SEA/JLI - IDENTIFY FIELDS THAT NEED CHECKING FOR MERGE ;02/07/2000 09:55
- ;;7.3;TOOLKIT;**23,34,36,42,45,77**;Apr 25, 1995
- ;;
- Q
- ;
- CHKMERG(FILENUM,IENFROM,IENTO,ARRAY) ;
- N XDRDVALF
- S XDRDVALF=1
- S FILE=FILENUM D SETUP^XDRMERG(2)
- D CHKFMERG(FILE,IENFROM,IENTO,ARRAY)
- S XGLOB="" F S XGLOB=$O(^TMP($J,"XGLOB",XGLOB)) Q:XGLOB="" D
- . I $P($G(^TMP($J,"XGLOB",XGLOB,0,1)),U,3)="DINUM" S F=$P(^(1),U) D CHKFMERG(F,IENFROM,IENTO,ARRAY)
- Q
- ;
- CHKFMERG(XFILNO,IENFROM,IENTO,LOCATION) ; CHECK VALIDITY FOR MERGE OF TWO ENTRIES IN FILE
- 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
- N XDRAA ; DEBUG STATEMENT
- ;
- S XDRDIC=$G(^DIC(XFILNO,0,"GL")) Q:XDRDIC=""
- S IENTOSTR=IENTO_","
- S DFN=IENTO
- ;
- ; CHECK FOR BROKEN LR NODES IF PATIENT FILE
- ;
- ; FOLLOWING LINE MODIFIED TO INCLUDE IDENTIFIED PROBLEMS IN OUTPUT - JLI 03/23/99
- 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
- ;
- ; NOW MERGE DATA GOING NODE BY NODE
- ;
- S NODE=""
- F D Q:NODE=""
- . S NODE1=$O(@(XDRDIC_IENFROM_","""_NODE_""")"))
- . I NODE1="" S NODE="" Q ; NOTHING MORE TO MOVE OVER
- . S NODE2=$O(@(XDRDIC_IENTO_","""_NODE_""")"))
- . I NODE2'="",NODE1]NODE2 S NODE=NODE2 Q ; NODE ON TO, BUT NOT ON FROM - GO TO NEXT
- . S NODE=NODE1
- . I $D(@(XDRDIC_IENFROM_","""_NODE_""")"))=1 D Q ; SINGLE NODE, MERGE DATA
- . . I NODE2]NODE1!(NODE2="") D Q ; MISSING NODE, JUST MOVE IT OVER
- . . . N XDRXX,FLD,N,J
- . . . 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
- . . . . 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
- . . . . I X>0 D
- . . . . . S XDRXX(XFILNO,IENTOSTR,FLD)=$$GETEXT(XDRDIC,IENFROM,XFILNO,FLD)
- . . . I $D(XDRXX) D CHEKFDA("XDRXX",LOCATION)
- . . I $D(@(XDRDIC_IENTO_","""_NODE_""")"))>1 Q ; MISMATCH SKIP
- . . N XDRXX,FLD
- . . S X1=@(XDRDIC_IENFROM_","""_NODE_""")")
- . . S (X2,X3)=@(XDRDIC_IENTO_","""_NODE_""")")
- . . F XDRI=1:1 Q:X1="" S X=$P(X1,U),X1=$P(X1,U,2,999) I X'="" D
- . . . S Y=$P(X2,U,XDRI)
- . . . I Y="" D
- . . . . S $P(X2,U,XDRI)=X
- . . . . S FLD=$O(^DD(XFILNO,"GL",NODE,XDRI,0)) S JXFLD=FLD
- . . . . I FLD>0,$O(^DD(XFILNO,FLD,1,0))>0 S XDRXX(XFILNO,IENTOSTR,FLD)=$$GETEXT(XDRDIC,IENFROM,XFILNO,FLD)
- . . I X2'=X3 D
- . . . I $D(XDRXX) D
- . . . . N X2 D CHEKFDA("XDRXX",LOCATION)
- . ;
- . ; THE FOLLOWING HANDLES NODES THAT HAVE MULTIPLES
- . ;
- . S XDRFROM=XDRDIC_IENFROM_","""_NODE_""","
- . S XDRTO=XDRDIC_IENTO_","""_NODE_""","
- . I NODE="DIS",XFILNO=2 Q
- . S IENTOSTR=IENTO_","
- . D CHKSUBS(XDRFROM,XDRTO,IENTOSTR,IENTO)
- Q
- ;
- CHKSUBS(XDRFROM,XDRTO,IENTOSTR,XDRDASEQ) ;
- N NODEA,SFILE,VALUE,XVALUE,XDRXX,XDRYY,YVALUE,XENTOSTR
- N XDRAA,XDRZZ ; DEBUG STATEMENT
- S SFILE=+$P($G(@(XDRFROM_"0)")),U,2)
- I SFILE'>0 Q ; NO FILE NUMBER, NOT FILE MANAGER COMPATIBLE
- I $P($G(^DD(SFILE,.01,0)),U,2)["W" Q ; HANDLE WORD PROCESSING FIELDS
- F NODEA=0:0 S NODEA=$O(@(XDRFROM_NODEA_")")) Q:NODEA'>0 D
- . S VALUE=$P($G(@(XDRFROM_NODEA_",0)")),U) ; GET .01 VALUE
- . N XDRDT S XDRDT=^DD(SFILE,.01,0)
- . 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
- . S YVALUE=0,XVALUE=0 I $D(^DD(SFILE,.001,0)) S YVALUE=NODEA I $D(@(XDRTO_NODEA_")")) S XVALUE=YVALUE
- . I XVALUE=0,$P(^DD(SFILE,.01,0),U,5,99)["DINUM",$D(@(XDRTO_NODEA_")")) S XVALUE=NODEA
- . I XVALUE=0 S XVALUE=+$$FIND1^DIC(SFILE,(","_IENTOSTR),"Q",VALUE) ; FIND CURRENT ENTRY NUMBER, IF PRESENT
- . I XVALUE>0 D Q ; SUBFILE EXISTS IN IENTO, CHECK FOR LOWER SUBFILES
- . . N X,X1,NODE,NEWFROM,NEWTO,NEWTOIEN
- . . S NODE=""
- . . F S NODE=$O(@(XDRFROM_NODEA_","""_NODE_""")")) Q:NODE="" D
- . . . I $D(@(XDRFROM_NODEA_","""_NODE_""")"))'>1 Q
- . . . S NEWFROM=XDRFROM_NODEA_","""_NODE_""","
- . . . S NEWTO=XDRTO_XVALUE_","""_NODE_""","
- . . . S NEWTOIEN=XVALUE_","_IENTOSTR
- . . . D CHKSUBS(NEWFROM,NEWTO,NEWTOIEN,(XVALUE_U_XDRDASEQ))
- . K XDRYY I YVALUE>0 S XDRYY(1)=YVALUE
- . S XENTOSTR="+1,"_IENTOSTR
- . S XDRFILTY=$P($G(^DD(SFILE,.01,0)),U,2)
- . ;I XDRFILTY["P",SFILE'=2.011 S VALUE="`"_VALUE
- . ;I XDRFILTY["V" D
- . ;. N Y S Y=$P(VALUE,";",2) Q:Y=""
- . ;. S Y=$P($G(@("^"_Y_"0)")),U) Q:Y=""
- . ;. S VALUE=Y_".`"_(+VALUE)
- . ;. Q
- . I (XDRFILTY["P")!(XDRFILTY["V")!(XDRFILTY["D") Q ; HANDLE AS INTERNAL VALUES ; JLI 9-1-99
- . I SFILE=2.011 Q ; SPECIAL HANDLING ; JLI 9-1-99
- . S XDRXX(SFILE,XENTOSTR,.01)=$$GETEXT(XDRFROM,NODEA,SFILE,.01)
- . D CHEKFDA("XDRXX",LOCATION)
- . F XDRID=0:0 S XDRID=$O(^DD(SFILE,0,"ID",XDRID)) Q:XDRID'>0 D
- . . Q:$P(^DD(SFILE,XDRID,0),U,2)'["R"
- . . S VALUE=$$GETEXT(XDRFROM,NODEA,SFILE,XDRID)
- . . I VALUE="" W !,"PROBLEM WITH IDENTIFIER FILE=",SFILE," IENSTR=",XENTOSTR," FIELD=",XDRID
- Q
- ;
- GETEXT(DICA,DA,FILNUM,FIELD,TYPE) ; GET EXTERNAL VALUE FOR .01 FIELD
- N DIC,DIQ,DR,XDRQ,TEMP
- I $G(FIELD)="" S FIELD=.01
- I $G(TYPE)="" S TYPE="E"
- S DIC=DICA,DIC("P")=FILNUM,DR=FIELD,DIQ="XDRQ",DIQ(0)="I"
- D EN^DIQ1
- S TEMP=$G(XDRQ(FILNUM,DA,FIELD,"I")) I TEMP="" Q ""
- S DIC=DICA,DIC("P")=FILNUM,DR=FIELD,DIQ="XDRQ",DIQ(0)="E" K XDRQ
- D EN^DIQ1
- Q TEMP_U_$G(XDRQ(FILNUM,DA,FIELD,"E"))
- Q $G(XDRQ(FILNUM,DA,FIELD,TYPE))
- ;
- DINUMDAT ; PROCESS ENTRIES WITH SAMPLE DATE/TIMES WITH SECONDS, NEEDS DINUM
- I $D(@(XDRTO_NODEA_")")) Q
- S XDRDT=1
- Q
- ;
- CHEKFDA(FDA,LOCATION) ;
- N FILE,IENS,FIELD,VAL,VALEXT
- F FILE=0:0 S FILE=$O(@FDA@(FILE)) Q:FILE'>0 D
- . S IENS="" F S IENS=$O(@FDA@(FILE,IENS)) Q:IENS="" D
- . . F FIELD=0:0 S FIELD=$O(@FDA@(FILE,IENS,FIELD)) Q:FIELD'>0 D
- . . . S VAL=@FDA@(FILE,IENS,FIELD),VALEXT=$P(VAL,U,2),VAL=$P(VAL,U) I VAL="" Q
- . . . I FILE=2,FIELD=.09 Q ; SSN NUMBER IS ENTERED AS INTERNAL
- . . . I FILE=2,$P(^DD(FILE,FIELD,0),U,5,99)["DGLOCK2" Q ; no NOK check
- . . . I FILE=70.03,FIELD=.01 Q ; TIES UP EVERYTHING... ; JLI 9-1-99
- . . . I FILE=354,FIELD=.03!(FIELD=.05) Q ; THIS ONE IS TOUGH, DON'T WORRY ABOUT IT
- . . . I FILE=2,FIELD=63 Q ; LAB DATA POINTER HAS SPECIAL PROCESSING
- . . . I FILE=161,FIELD=.5 Q ; FB has special processing, JDS XT*7.3*77, 8/5/03
- . . . S MESGROOT=$NA(^TMP($J,"MESG")) K @MESGROOT
- . . . D CHKVALID^XDRDVAL(MESGROOT,FILE,IENS,FIELD,VALEXT,VAL)
- . . . I $D(@MESGROOT) M @LOCATION=@MESGROOT K @MESGROOT
- . . . Q
- . . Q
- . Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRDVAL2 6583 printed Feb 19, 2025@00:05:48 Page 2
- 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
- +2 ;;
- +3 QUIT
- +4 ;
- CHKMERG(FILENUM,IENFROM,IENTO,ARRAY) ;
- +1 NEW XDRDVALF
- +2 SET XDRDVALF=1
- +3 SET FILE=FILENUM
- DO SETUP^XDRMERG(2)
- +4 DO CHKFMERG(FILE,IENFROM,IENTO,ARRAY)
- +5 SET XGLOB=""
- FOR
- SET XGLOB=$ORDER(^TMP($JOB,"XGLOB",XGLOB))
- if XGLOB=""
- QUIT
- Begin DoDot:1
- +6 IF $PIECE($GET(^TMP($JOB,"XGLOB",XGLOB,0,1)),U,3)="DINUM"
- SET F=$PIECE(^(1),U)
- DO CHKFMERG(F,IENFROM,IENTO,ARRAY)
- End DoDot:1
- +7 QUIT
- +8 ;
- CHKFMERG(XFILNO,IENFROM,IENTO,LOCATION) ; CHECK VALIDITY FOR MERGE OF TWO ENTRIES IN FILE
- +1 NEW 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
- +2 ; DEBUG STATEMENT
- NEW XDRAA
- +3 ;
- +4 SET XDRDIC=$GET(^DIC(XFILNO,0,"GL"))
- if XDRDIC=""
- QUIT
- +5 SET IENTOSTR=IENTO_","
- +6 SET DFN=IENTO
- +7 ;
- +8 ; CHECK FOR BROKEN LR NODES IF PATIENT FILE
- +9 ;
- +10 ; FOLLOWING LINE MODIFIED TO INCLUDE IDENTIFIED PROBLEMS IN OUTPUT - JLI 03/23/99
- +11 IF XFILNO=2
- FOR I=IENFROM,IENTO
- SET J=$GET(^DPT(I,"LR"))
- IF J>0
- IF ($PIECE(^LR(J,0),U,2)'=2)!($PIECE(^LR(J,0),U,3)'=I)
- SET @LOCATION@(2,(I_","),63,"INVALID")="Broken ""LR"" node pointers for PATIENT file and LAB DATA FILE - DFN="_I_" LRFN="_J
- +12 ;
- +13 ; NOW MERGE DATA GOING NODE BY NODE
- +14 ;
- +15 SET NODE=""
- +16 FOR
- Begin DoDot:1
- +17 SET NODE1=$ORDER(@(XDRDIC_IENFROM_","""_NODE_""")"))
- +18 ; NOTHING MORE TO MOVE OVER
- IF NODE1=""
- SET NODE=""
- QUIT
- +19 SET NODE2=$ORDER(@(XDRDIC_IENTO_","""_NODE_""")"))
- +20 ; NODE ON TO, BUT NOT ON FROM - GO TO NEXT
- IF NODE2'=""
- IF NODE1]NODE2
- SET NODE=NODE2
- QUIT
- +21 SET NODE=NODE1
- +22 ; SINGLE NODE, MERGE DATA
- IF $DATA(@(XDRDIC_IENFROM_","""_NODE_""")"))=1
- Begin DoDot:2
- +23 ; MISSING NODE, JUST MOVE IT OVER
- IF NODE2]NODE1!(NODE2="")
- Begin DoDot:3
- +24 NEW XDRXX,FLD,N,J
- +25 FOR N=0:0
- SET N=$ORDER(^DD(XFILNO,"GL",NODE,N))
- if N'>0
- QUIT
- SET FLD=$ORDER(^(N,0))
- IF $ORDER(^DD(XFILNO,FLD,1,0))>0
- Begin DoDot:4
- +26 SET X=0
- FOR J=0:0
- SET J=$ORDER(^DD(XFILNO,FLD,1,J))
- if J'>0
- QUIT
- IF $ORDER(^(J,0))>0
- SET X=1
- QUIT
- +27 IF X>0
- Begin DoDot:5
- +28 SET XDRXX(XFILNO,IENTOSTR,FLD)=$$GETEXT(XDRDIC,IENFROM,XFILNO,FLD)
- End DoDot:5
- End DoDot:4
- +29 IF $DATA(XDRXX)
- DO CHEKFDA("XDRXX",LOCATION)
- End DoDot:3
- QUIT
- +30 ; MISMATCH SKIP
- IF $DATA(@(XDRDIC_IENTO_","""_NODE_""")"))>1
- QUIT
- +31 NEW XDRXX,FLD
- +32 SET X1=@(XDRDIC_IENFROM_","""_NODE_""")")
- +33 SET (X2,X3)=@(XDRDIC_IENTO_","""_NODE_""")")
- +34 FOR XDRI=1:1
- if X1=""
- QUIT
- SET X=$PIECE(X1,U)
- SET X1=$PIECE(X1,U,2,999)
- IF X'=""
- Begin DoDot:3
- +35 SET Y=$PIECE(X2,U,XDRI)
- +36 IF Y=""
- Begin DoDot:4
- +37 SET $PIECE(X2,U,XDRI)=X
- +38 SET FLD=$ORDER(^DD(XFILNO,"GL",NODE,XDRI,0))
- SET JXFLD=FLD
- +39 IF FLD>0
- IF $ORDER(^DD(XFILNO,FLD,1,0))>0
- SET XDRXX(XFILNO,IENTOSTR,FLD)=$$GETEXT(XDRDIC,IENFROM,XFILNO,FLD)
- End DoDot:4
- End DoDot:3
- +40 IF X2'=X3
- Begin DoDot:3
- +41 IF $DATA(XDRXX)
- Begin DoDot:4
- +42 NEW X2
- DO CHEKFDA("XDRXX",LOCATION)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- QUIT
- +43 ;
- +44 ; THE FOLLOWING HANDLES NODES THAT HAVE MULTIPLES
- +45 ;
- +46 SET XDRFROM=XDRDIC_IENFROM_","""_NODE_""","
- +47 SET XDRTO=XDRDIC_IENTO_","""_NODE_""","
- +48 IF NODE="DIS"
- IF XFILNO=2
- QUIT
- +49 SET IENTOSTR=IENTO_","
- +50 DO CHKSUBS(XDRFROM,XDRTO,IENTOSTR,IENTO)
- End DoDot:1
- if NODE=""
- QUIT
- +51 QUIT
- +52 ;
- CHKSUBS(XDRFROM,XDRTO,IENTOSTR,XDRDASEQ) ;
- +1 NEW NODEA,SFILE,VALUE,XVALUE,XDRXX,XDRYY,YVALUE,XENTOSTR
- +2 ; DEBUG STATEMENT
- NEW XDRAA,XDRZZ
- +3 SET SFILE=+$PIECE($GET(@(XDRFROM_"0)")),U,2)
- +4 ; NO FILE NUMBER, NOT FILE MANAGER COMPATIBLE
- IF SFILE'>0
- QUIT
- +5 ; HANDLE WORD PROCESSING FIELDS
- IF $PIECE($GET(^DD(SFILE,.01,0)),U,2)["W"
- QUIT
- +6 FOR NODEA=0:0
- SET NODEA=$ORDER(@(XDRFROM_NODEA_")"))
- if NODEA'>0
- QUIT
- Begin DoDot:1
- +7 ; GET .01 VALUE
- SET VALUE=$PIECE($GET(@(XDRFROM_NODEA_",0)")),U)
- +8 NEW XDRDT
- SET XDRDT=^DD(SFILE,.01,0)
- +9 ; HANDLE DINUMED DATES BY SIMPLY MOVING THEM
- IF $PIECE(XDRDT,U,2)["D"
- SET XDRDT=$PIECE(XDRDT,U,5,999)
- SET XDRDINUM=$SELECT(XDRDT["DINUM":1,1:0)
- IF XDRDINUM
- SET XDRDT=0
- DO DINUMDAT
- if XDRDT
- QUIT
- +10 SET YVALUE=0
- SET XVALUE=0
- IF $DATA(^DD(SFILE,.001,0))
- SET YVALUE=NODEA
- IF $DATA(@(XDRTO_NODEA_")"))
- SET XVALUE=YVALUE
- +11 IF XVALUE=0
- IF $PIECE(^DD(SFILE,.01,0),U,5,99)["DINUM"
- IF $DATA(@(XDRTO_NODEA_")"))
- SET XVALUE=NODEA
- +12 ; FIND CURRENT ENTRY NUMBER, IF PRESENT
- IF XVALUE=0
- SET XVALUE=+$$FIND1^DIC(SFILE,(","_IENTOSTR),"Q",VALUE)
- +13 ; SUBFILE EXISTS IN IENTO, CHECK FOR LOWER SUBFILES
- IF XVALUE>0
- Begin DoDot:2
- +14 NEW X,X1,NODE,NEWFROM,NEWTO,NEWTOIEN
- +15 SET NODE=""
- +16 FOR
- SET NODE=$ORDER(@(XDRFROM_NODEA_","""_NODE_""")"))
- if NODE=""
- QUIT
- Begin DoDot:3
- +17 IF $DATA(@(XDRFROM_NODEA_","""_NODE_""")"))'>1
- QUIT
- +18 SET NEWFROM=XDRFROM_NODEA_","""_NODE_""","
- +19 SET NEWTO=XDRTO_XVALUE_","""_NODE_""","
- +20 SET NEWTOIEN=XVALUE_","_IENTOSTR
- +21 DO CHKSUBS(NEWFROM,NEWTO,NEWTOIEN,(XVALUE_U_XDRDASEQ))
- End DoDot:3
- End DoDot:2
- QUIT
- +22 KILL XDRYY
- IF YVALUE>0
- SET XDRYY(1)=YVALUE
- +23 SET XENTOSTR="+1,"_IENTOSTR
- +24 SET XDRFILTY=$PIECE($GET(^DD(SFILE,.01,0)),U,2)
- +25 ;I XDRFILTY["P",SFILE'=2.011 S VALUE="`"_VALUE
- +26 ;I XDRFILTY["V" D
- +27 ;. N Y S Y=$P(VALUE,";",2) Q:Y=""
- +28 ;. S Y=$P($G(@("^"_Y_"0)")),U) Q:Y=""
- +29 ;. S VALUE=Y_".`"_(+VALUE)
- +30 ;. Q
- +31 ; HANDLE AS INTERNAL VALUES ; JLI 9-1-99
- IF (XDRFILTY["P")!(XDRFILTY["V")!(XDRFILTY["D")
- QUIT
- +32 ; SPECIAL HANDLING ; JLI 9-1-99
- IF SFILE=2.011
- QUIT
- +33 SET XDRXX(SFILE,XENTOSTR,.01)=$$GETEXT(XDRFROM,NODEA,SFILE,.01)
- +34 DO CHEKFDA("XDRXX",LOCATION)
- +35 FOR XDRID=0:0
- SET XDRID=$ORDER(^DD(SFILE,0,"ID",XDRID))
- if XDRID'>0
- QUIT
- Begin DoDot:2
- +36 if $PIECE(^DD(SFILE,XDRID,0),U,2)'["R"
- QUIT
- +37 SET VALUE=$$GETEXT(XDRFROM,NODEA,SFILE,XDRID)
- +38 IF VALUE=""
- WRITE !,"PROBLEM WITH IDENTIFIER FILE=",SFILE," IENSTR=",XENTOSTR," FIELD=",XDRID
- End DoDot:2
- End DoDot:1
- +39 QUIT
- +40 ;
- GETEXT(DICA,DA,FILNUM,FIELD,TYPE) ; GET EXTERNAL VALUE FOR .01 FIELD
- +1 NEW DIC,DIQ,DR,XDRQ,TEMP
- +2 IF $GET(FIELD)=""
- SET FIELD=.01
- +3 IF $GET(TYPE)=""
- SET TYPE="E"
- +4 SET DIC=DICA
- SET DIC("P")=FILNUM
- SET DR=FIELD
- SET DIQ="XDRQ"
- SET DIQ(0)="I"
- +5 DO EN^DIQ1
- +6 SET TEMP=$GET(XDRQ(FILNUM,DA,FIELD,"I"))
- IF TEMP=""
- QUIT ""
- +7 SET DIC=DICA
- SET DIC("P")=FILNUM
- SET DR=FIELD
- SET DIQ="XDRQ"
- SET DIQ(0)="E"
- KILL XDRQ
- +8 DO EN^DIQ1
- +9 QUIT TEMP_U_$GET(XDRQ(FILNUM,DA,FIELD,"E"))
- +10 QUIT $GET(XDRQ(FILNUM,DA,FIELD,TYPE))
- +11 ;
- DINUMDAT ; PROCESS ENTRIES WITH SAMPLE DATE/TIMES WITH SECONDS, NEEDS DINUM
- +1 IF $DATA(@(XDRTO_NODEA_")"))
- QUIT
- +2 SET XDRDT=1
- +3 QUIT
- +4 ;
- CHEKFDA(FDA,LOCATION) ;
- +1 NEW FILE,IENS,FIELD,VAL,VALEXT
- +2 FOR FILE=0:0
- SET FILE=$ORDER(@FDA@(FILE))
- if FILE'>0
- QUIT
- Begin DoDot:1
- +3 SET IENS=""
- FOR
- SET IENS=$ORDER(@FDA@(FILE,IENS))
- if IENS=""
- QUIT
- Begin DoDot:2
- +4 FOR FIELD=0:0
- SET FIELD=$ORDER(@FDA@(FILE,IENS,FIELD))
- if FIELD'>0
- QUIT
- Begin DoDot:3
- +5 SET VAL=@FDA@(FILE,IENS,FIELD)
- SET VALEXT=$PIECE(VAL,U,2)
- SET VAL=$PIECE(VAL,U)
- IF VAL=""
- QUIT
- +6 ; SSN NUMBER IS ENTERED AS INTERNAL
- IF FILE=2
- IF FIELD=.09
- QUIT
- +7 ; no NOK check
- IF FILE=2
- IF $PIECE(^DD(FILE,FIELD,0),U,5,99)["DGLOCK2"
- QUIT
- +8 ; TIES UP EVERYTHING... ; JLI 9-1-99
- IF FILE=70.03
- IF FIELD=.01
- QUIT
- +9 ; THIS ONE IS TOUGH, DON'T WORRY ABOUT IT
- IF FILE=354
- IF FIELD=.03!(FIELD=.05)
- QUIT
- +10 ; LAB DATA POINTER HAS SPECIAL PROCESSING
- IF FILE=2
- IF FIELD=63
- QUIT
- +11 ; FB has special processing, JDS XT*7.3*77, 8/5/03
- IF FILE=161
- IF FIELD=.5
- QUIT
- +12 SET MESGROOT=$NAME(^TMP($JOB,"MESG"))
- KILL @MESGROOT
- +13 DO CHKVALID^XDRDVAL(MESGROOT,FILE,IENS,FIELD,VALEXT,VAL)
- +14 IF $DATA(@MESGROOT)
- MERGE @LOCATION=@MESGROOT
- KILL @MESGROOT
- +15 QUIT
- End DoDot:3
- +16 QUIT
- End DoDot:2
- +17 QUIT
- End DoDot:1
- +18 QUIT