source: FOIAVistA/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDVAL2.m@ 1733

Last change on this file since 1733 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 6.3 KB
Line 
1XDRDVAL2 ;SF-IRMFO.SEA/JLI - IDENTIFY FIELDS THAT NEED CHECKING FOR MERGE ;02/07/2000 09:55
2 ;;7.3;TOOLKIT;**23,34,36,42,45,77**;Apr 25, 1995
3 ;;
4 Q
5 ;
6CHKMERG(FILENUM,IENFROM,IENTO,ARRAY) ;
7 N XDRDVALF
8 S XDRDVALF=1
9 S FILE=FILENUM D SETUP^XDRMERG(2)
10 D CHKFMERG(FILE,IENFROM,IENTO,ARRAY)
11 S XGLOB="" F S XGLOB=$O(^TMP($J,"XGLOB",XGLOB)) Q:XGLOB="" D
12 . I $P($G(^TMP($J,"XGLOB",XGLOB,0,1)),U,3)="DINUM" S F=$P(^(1),U) D CHKFMERG(F,IENFROM,IENTO,ARRAY)
13 Q
14 ;
15CHKFMERG(XFILNO,IENFROM,IENTO,LOCATION) ; CHECK VALIDITY FOR MERGE OF TWO ENTRIES IN FILE
16 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
17 N XDRAA ; DEBUG STATEMENT
18 ;
19 S XDRDIC=$G(^DIC(XFILNO,0,"GL")) Q:XDRDIC=""
20 S IENTOSTR=IENTO_","
21 S DFN=IENTO
22 ;
23 ; CHECK FOR BROKEN LR NODES IF PATIENT FILE
24 ;
25 ; FOLLOWING LINE MODIFIED TO INCLUDE IDENTIFIED PROBLEMS IN OUTPUT - JLI 03/23/99
26 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
27 ;
28 ; NOW MERGE DATA GOING NODE BY NODE
29 ;
30 S NODE=""
31 F D Q:NODE=""
32 . S NODE1=$O(@(XDRDIC_IENFROM_","""_NODE_""")"))
33 . I NODE1="" S NODE="" Q ; NOTHING MORE TO MOVE OVER
34 . S NODE2=$O(@(XDRDIC_IENTO_","""_NODE_""")"))
35 . I NODE2'="",NODE1]NODE2 S NODE=NODE2 Q ; NODE ON TO, BUT NOT ON FROM - GO TO NEXT
36 . S NODE=NODE1
37 . I $D(@(XDRDIC_IENFROM_","""_NODE_""")"))=1 D Q ; SINGLE NODE, MERGE DATA
38 . . I NODE2]NODE1!(NODE2="") D Q ; MISSING NODE, JUST MOVE IT OVER
39 . . . N XDRXX,FLD,N,J
40 . . . 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
41 . . . . 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
42 . . . . I X>0 D
43 . . . . . S XDRXX(XFILNO,IENTOSTR,FLD)=$$GETEXT(XDRDIC,IENFROM,XFILNO,FLD)
44 . . . I $D(XDRXX) D CHEKFDA("XDRXX",LOCATION)
45 . . I $D(@(XDRDIC_IENTO_","""_NODE_""")"))>1 Q ; MISMATCH SKIP
46 . . N XDRXX,FLD
47 . . S X1=@(XDRDIC_IENFROM_","""_NODE_""")")
48 . . S (X2,X3)=@(XDRDIC_IENTO_","""_NODE_""")")
49 . . F XDRI=1:1 Q:X1="" S X=$P(X1,U),X1=$P(X1,U,2,999) I X'="" D
50 . . . S Y=$P(X2,U,XDRI)
51 . . . I Y="" D
52 . . . . S $P(X2,U,XDRI)=X
53 . . . . S FLD=$O(^DD(XFILNO,"GL",NODE,XDRI,0)) S JXFLD=FLD
54 . . . . I FLD>0,$O(^DD(XFILNO,FLD,1,0))>0 S XDRXX(XFILNO,IENTOSTR,FLD)=$$GETEXT(XDRDIC,IENFROM,XFILNO,FLD)
55 . . I X2'=X3 D
56 . . . I $D(XDRXX) D
57 . . . . N X2 D CHEKFDA("XDRXX",LOCATION)
58 . ;
59 . ; THE FOLLOWING HANDLES NODES THAT HAVE MULTIPLES
60 . ;
61 . S XDRFROM=XDRDIC_IENFROM_","""_NODE_""","
62 . S XDRTO=XDRDIC_IENTO_","""_NODE_""","
63 . I NODE="DIS",XFILNO=2 Q
64 . S IENTOSTR=IENTO_","
65 . D CHKSUBS(XDRFROM,XDRTO,IENTOSTR,IENTO)
66 Q
67 ;
68CHKSUBS(XDRFROM,XDRTO,IENTOSTR,XDRDASEQ) ;
69 N NODEA,SFILE,VALUE,XVALUE,XDRXX,XDRYY,YVALUE,XENTOSTR
70 N XDRAA,XDRZZ ; DEBUG STATEMENT
71 S SFILE=+$P($G(@(XDRFROM_"0)")),U,2)
72 I SFILE'>0 Q ; NO FILE NUMBER, NOT FILE MANAGER COMPATIBLE
73 I $P($G(^DD(SFILE,.01,0)),U,2)["W" Q ; HANDLE WORD PROCESSING FIELDS
74 F NODEA=0:0 S NODEA=$O(@(XDRFROM_NODEA_")")) Q:NODEA'>0 D
75 . S VALUE=$P($G(@(XDRFROM_NODEA_",0)")),U) ; GET .01 VALUE
76 . N XDRDT S XDRDT=^DD(SFILE,.01,0)
77 . 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
78 . S YVALUE=0,XVALUE=0 I $D(^DD(SFILE,.001,0)) S YVALUE=NODEA I $D(@(XDRTO_NODEA_")")) S XVALUE=YVALUE
79 . I XVALUE=0,$P(^DD(SFILE,.01,0),U,5,99)["DINUM",$D(@(XDRTO_NODEA_")")) S XVALUE=NODEA
80 . I XVALUE=0 S XVALUE=+$$FIND1^DIC(SFILE,(","_IENTOSTR),"Q",VALUE) ; FIND CURRENT ENTRY NUMBER, IF PRESENT
81 . I XVALUE>0 D Q ; SUBFILE EXISTS IN IENTO, CHECK FOR LOWER SUBFILES
82 . . N X,X1,NODE,NEWFROM,NEWTO,NEWTOIEN
83 . . S NODE=""
84 . . F S NODE=$O(@(XDRFROM_NODEA_","""_NODE_""")")) Q:NODE="" D
85 . . . I $D(@(XDRFROM_NODEA_","""_NODE_""")"))'>1 Q
86 . . . S NEWFROM=XDRFROM_NODEA_","""_NODE_""","
87 . . . S NEWTO=XDRTO_XVALUE_","""_NODE_""","
88 . . . S NEWTOIEN=XVALUE_","_IENTOSTR
89 . . . D CHKSUBS(NEWFROM,NEWTO,NEWTOIEN,(XVALUE_U_XDRDASEQ))
90 . K XDRYY I YVALUE>0 S XDRYY(1)=YVALUE
91 . S XENTOSTR="+1,"_IENTOSTR
92 . S XDRFILTY=$P($G(^DD(SFILE,.01,0)),U,2)
93 . ;I XDRFILTY["P",SFILE'=2.011 S VALUE="`"_VALUE
94 . ;I XDRFILTY["V" D
95 . ;. N Y S Y=$P(VALUE,";",2) Q:Y=""
96 . ;. S Y=$P($G(@("^"_Y_"0)")),U) Q:Y=""
97 . ;. S VALUE=Y_".`"_(+VALUE)
98 . ;. Q
99 . I (XDRFILTY["P")!(XDRFILTY["V")!(XDRFILTY["D") Q ; HANDLE AS INTERNAL VALUES ; JLI 9-1-99
100 . I SFILE=2.011 Q ; SPECIAL HANDLING ; JLI 9-1-99
101 . S XDRXX(SFILE,XENTOSTR,.01)=$$GETEXT(XDRFROM,NODEA,SFILE,.01)
102 . D CHEKFDA("XDRXX",LOCATION)
103 . F XDRID=0:0 S XDRID=$O(^DD(SFILE,0,"ID",XDRID)) Q:XDRID'>0 D
104 . . Q:$P(^DD(SFILE,XDRID,0),U,2)'["R"
105 . . S VALUE=$$GETEXT(XDRFROM,NODEA,SFILE,XDRID)
106 . . I VALUE="" W !,"PROBLEM WITH IDENTIFIER FILE=",SFILE," IENSTR=",XENTOSTR," FIELD=",XDRID
107 Q
108 ;
109GETEXT(DICA,DA,FILNUM,FIELD,TYPE) ; GET EXTERNAL VALUE FOR .01 FIELD
110 N DIC,DIQ,DR,XDRQ,TEMP
111 I $G(FIELD)="" S FIELD=.01
112 I $G(TYPE)="" S TYPE="E"
113 S DIC=DICA,DIC("P")=FILNUM,DR=FIELD,DIQ="XDRQ",DIQ(0)="I"
114 D EN^DIQ1
115 S TEMP=$G(XDRQ(FILNUM,DA,FIELD,"I")) I TEMP="" Q ""
116 S DIC=DICA,DIC("P")=FILNUM,DR=FIELD,DIQ="XDRQ",DIQ(0)="E" K XDRQ
117 D EN^DIQ1
118 Q TEMP_U_$G(XDRQ(FILNUM,DA,FIELD,"E"))
119 Q $G(XDRQ(FILNUM,DA,FIELD,TYPE))
120 ;
121DINUMDAT ; PROCESS ENTRIES WITH SAMPLE DATE/TIMES WITH SECONDS, NEEDS DINUM
122 I $D(@(XDRTO_NODEA_")")) Q
123 S XDRDT=1
124 Q
125 ;
126CHEKFDA(FDA,LOCATION) ;
127 N FILE,IENS,FIELD,VAL,VALEXT
128 F FILE=0:0 S FILE=$O(@FDA@(FILE)) Q:FILE'>0 D
129 . S IENS="" F S IENS=$O(@FDA@(FILE,IENS)) Q:IENS="" D
130 . . F FIELD=0:0 S FIELD=$O(@FDA@(FILE,IENS,FIELD)) Q:FIELD'>0 D
131 . . . S VAL=@FDA@(FILE,IENS,FIELD),VALEXT=$P(VAL,U,2),VAL=$P(VAL,U) I VAL="" Q
132 . . . I FILE=2,FIELD=.09 Q ; SSN NUMBER IS ENTERED AS INTERNAL
133 . . . I FILE=2,$P(^DD(FILE,FIELD,0),U,5,99)["DGLOCK2" Q ; no NOK check
134 . . . I FILE=70.03,FIELD=.01 Q ; TIES UP EVERYTHING... ; JLI 9-1-99
135 . . . I FILE=354,FIELD=.03!(FIELD=.05) Q ; THIS ONE IS TOUGH, DON'T WORRY ABOUT IT
136 . . . I FILE=2,FIELD=63 Q ; LAB DATA POINTER HAS SPECIAL PROCESSING
137 . . . I FILE=161,FIELD=.5 Q ; FB has special processing, JDS XT*7.3*77, 8/5/03
138 . . . S MESGROOT=$NA(^TMP($J,"MESG")) K @MESGROOT
139 . . . D CHKVALID^XDRDVAL(MESGROOT,FILE,IENS,FIELD,VALEXT,VAL)
140 . . . I $D(@MESGROOT) M @LOCATION=@MESGROOT K @MESGROOT
141 . . . Q
142 . . Q
143 . Q
144 Q
Note: See TracBrowser for help on using the repository browser.