source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIU214.m@ 1314

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

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1TIU214 ; VMP/JML - ID NOTES with Mismatched Patients ;3/31/06 ; Compiled March 13, 2006 15:21:26
2 ;;1.0;TEXT INTEGRATION UTILITIES;**214**;Jun 20, 1997
3 ; Report/Fix ID Documents where the child note points to a parent note for a different patient.
4 ; Report only Documents where the child note points to a parent that may not be an id note.
5 Q
6EN ; Build array of mismatched ID documents
7 N TIUPRNT,TIUCHILD,TIUPDFN,TIUCDFN,TIUPNAME,TIUCNAME,TIUP0,TIUC0,TIUCAUTH,TIUCTITL,TIUDATA,TIUBAD
8 N TIUC12,TIUCEDT,TIUPAUTH,TIUPTITL,TIUP12,TIUPEDT,TIUFIX,Y,DFN,%ZIS,POP,DIR,DIRUT,TIULEN,TIUDUZ
9 S DIR(0)="SO^1:REPORT;2:FIX"
10 S DIR("L",1)="Report only or Report AND fix the bad pointers?"
11 S DIR("L",2)=""
12 S DIR("L",3)="1 - Report Only"
13 S DIR("L")="2 - Report and Fix"
14 S DIR("B")=1
15 D ^DIR K DIR
16 Q:$G(DIRUT)
17 S TIUFIX=$S(Y=2:1,1:0),TIUDUZ=$G(DUZ)
18 S %ZIS="Q" D ^%ZIS
19 Q:$G(POP)>0
20 I $G(IO("Q"))=1 D Q
21 .N ZTRTN,ZTDESC,ZTSAVE
22 .S ZTRTN="SEARCH^TIU214",ZTDESC="Mismatched ID Note Report",ZTSAVE("TIU*")=""
23 .D ^%ZTLOAD K IO("Q")
24SEARCH ;
25 K ^TMP("TIU214",$J)
26 S ^TMP("TIU214",$J)=0,^TMP("TIU214",$J,"MISMATCH")=0,^TMP("TIU214",$J,"MISSING")=0,^TMP("TIU214",$J,"NONPRNT")=0
27 I $E(IOST,1,2)="C-" W @IOF,!!?5,"Searching for Parent/Child ID Notes with mismatched patients...",!!
28 S TIUPRNT=0
29 F S TIUPRNT=$O(^TIU(8925,"GDAD",TIUPRNT)) Q:TIUPRNT="" D
30 . S ^TMP("TIU214",$J)=^TMP("TIU214",$J)+1
31 . S TIUCHILD=0
32 . F S TIUCHILD=+$O(^TIU(8925,"GDAD",TIUPRNT,TIUCHILD)) Q:'TIUCHILD D
33 . . S TIUC0=$G(^TIU(8925,TIUCHILD,0)),TIUCDFN=$P(TIUC0,U,2)
34 . . S TIUCNAME=$$PNAME(TIUCDFN)
35 . . S TIUCAUTH=$$GET1^DIQ(8925,TIUCHILD_",",1202)
36 . . S TIUCTITL=$$GET1^DIQ(8925,TIUCHILD_",",.01)
37 . . S TIUC12=$G(^TIU(8925,TIUCHILD,12))
38 . . S Y=$P(TIUC12,"^") D DD^%DT S TIUCEDT=Y
39 . . S TIUP0=$G(^TIU(8925,TIUPRNT,0)),TIUPDFN=$P(TIUP0,U,2)
40 . . I TIUP0="" D Q
41 . . . S ^TMP("TIU214",$J,"MISSING")=^TMP("TIU214",$J,"MISSING")+1
42 . . . S ^TMP("TIU214",$J,"MISSING",TIUPRNT,TIUCHILD)=TIUCNAME_"^"_TIUCTITL_"^"_TIUCEDT_"^"_TIUCAUTH
43 . . I TIUPDFN'=TIUCDFN D Q
44 . . . S TIUPNAME=$$PNAME(TIUPDFN)
45 . . . S ^TMP("TIU214",$J,"MISMATCH")=^TMP("TIU214",$J,"MISMATCH")+1
46 . . . I '$D(^TMP("TIU214",$J,"MISMATCH",TIUPRNT)) D
47 . . . . S TIUPAUTH=$$GET1^DIQ(8925,TIUPRNT_",",1202)
48 . . . . S TIUPTITL=$$GET1^DIQ(8925,TIUPRNT_",",.01)
49 . . . . S TIUP12=$G(^TIU(8925,TIUPRNT,12))
50 . . . . S Y=$P(TIUP12,"^") D DD^%DT S TIUPEDT=Y
51 . . . . S ^TMP("TIU214",$J,"MISMATCH",TIUPRNT)=TIUPNAME_"^"_TIUPTITL_"^"_TIUPEDT_"^"_TIUPAUTH_"^"_TIUPRNT
52 . . . S ^TMP("TIU214",$J,"MISMATCH",TIUPRNT,TIUCHILD)=TIUCNAME_"^"_TIUCTITL_"^"_TIUCEDT_"^"_TIUCAUTH_"^"_TIUCHILD
53 . . S TIUBAD="" S TIUBAD=$$POSSPRNT^TIULP(+TIUP0) I '+TIUBAD D Q
54 . . . S ^TMP("TIU214",$J,"NONPRNT")=^TMP("TIU214",$J,"NONPRNT")+1
55 . . . S TIUPAUTH=$$GET1^DIQ(8925,TIUPRNT_",",1202)
56 . . . S TIUPTITL=$$GET1^DIQ(8925,TIUPRNT_",",.01)
57 . . . S TIUP12=$G(^TIU(8925,TIUPRNT,12))
58 . . . S Y=$P(TIUP12,"^") D DD^%DT S TIUPEDT=Y
59 . . . S ^TMP("TIU214",$J,"NONPRNT",TIUPRNT,TIUCHILD)=TIUCNAME_"^"_TIUPTITL_"^"_TIUPEDT_"^"_TIUPAUTH_"^"_TIUPRNT_"^"_TIUCTITL
60 D REPORT
61 D MAIL
62 K ^TMP("TIU214",$J)
63 D ^%ZISC
64 Q
65REPORT ;
66 U IO
67 N TIUQUIT,TIUHIDE,TIUCINFO,TIUPINFO,TIUSHOW
68 S TIUQUIT=0,TIUSHOW=$S(IOST["P-":0,1:1)
69 S ^TMP("TIU214",$J,"FIX_MISMATCH_PTR")=0,^TMP("TIU214",$J,"FIX_MISMATCH_XREF")=0
70 S ^TMP("TIU214",$J,"FIX_MISSING_PTR")=0,^TMP("TIU214",$J,"FIX_MISSING_XREF")=0
71 I IOST["C-" D CLEAR^VALM1
72 S TIUDATA=0,TIULEN=$S(IOST["C-":8,1:6)
73 I TIUFIX S TIULEN=TIULEN+1
74 D HDR1(0)
75 S TIUPRNT=""
76 F S TIUPRNT=$O(^TMP("TIU214",$J,"MISMATCH",TIUPRNT)) Q:TIUPRNT=""!(TIUQUIT) D
77 .S TIUPINFO=$G(^TMP("TIU214",$J,"MISMATCH",TIUPRNT))
78 .S TIUCHILD=""
79 .F S TIUCHILD=$O(^TMP("TIU214",$J,"MISMATCH",TIUPRNT,TIUCHILD)) Q:TIUCHILD=""!(TIUQUIT) D
80 ..S TIUCINFO=$G(^TMP("TIU214",$J,"MISMATCH",TIUPRNT,TIUCHILD))
81 ..I $Y>(IOSL-TIULEN) D PAUSE Q:TIUQUIT D HDR1(1)
82 ..I TIUSHOW D
83 ...W !!," Patient: ",$E($P(TIUCINFO,"^",1),1,26)," (",$P(TIUCINFO,"^",2),")"
84 ...W ?45,$E($P(TIUPINFO,"^",1),1,26)," (",$P(TIUPINFO,"^",2),")"
85 ..I 'TIUSHOW D
86 ...W !!," Patient: ",$P(TIUCINFO,"^",2)
87 ...W ?45,$P(TIUPINFO,"^",2)
88 ..W !," Title: ",$E($P(TIUCINFO,"^",3),1,33),?45,$E($P(TIUPINFO,"^",3),1,33)
89 ..W !,"Entry DT: ",$E($P(TIUCINFO,"^",4),1,33),?45,$E($P(TIUPINFO,"^",4),1,33)
90 ..W !," Author: ",$E($P(TIUCINFO,"^",5),1,33),?45,$E($P(TIUPINFO,"^",5),1,33)
91 ..W !,"Note IEN: ",$E($P(TIUCINFO,"^",6),1,33),?45,$E($P(TIUPINFO,"^",6),1,33)
92 ..I TIUFIX D
93 ...I $G(^TIU(8925,TIUCHILD,21))=TIUPRNT D Q
94 ....N DIE,DA,DR
95 ....S DIE=8925,DA=TIUCHILD,DR="2101///@" D ^DIE
96 ....W !?5,"..... Removed pointer from child to parent."
97 ....S ^TMP("TIU214",$J,"FIX_MISMATCH_PTR")=^TMP("TIU214",$J,"FIX_MISMATCH_PTR")+1
98 ...I $G(^TIU(8925,TIUCHILD,21))'=TIUPRNT D
99 ....K ^TIU(8925,"GDAD",TIUPRNT,TIUCHILD)
100 ....W !?5,"..... Child note did not point to parent. GDAD cross reference removed."
101 ....S ^TMP("TIU214",$J,"FIX_MISMATCH_XREF")=^TMP("TIU214",$J,"FIX_MISMATCH_XREF")+1
102 Q:TIUQUIT
103 I TIUDATA D PAUSE Q:TIUQUIT
104 S TIUDATA=0,TIULEN=$S(IOST["C-":9,1:7)
105 I TIUFIX S TIULEN=TIULEN+1
106 D HDR2(1)
107 S TIUPRNT=""
108 F S TIUPRNT=$O(^TMP("TIU214",$J,"MISSING",TIUPRNT)) Q:TIUPRNT=""!(TIUQUIT) D
109 .S TIUCHILD=""
110 .F S TIUCHILD=$O(^TMP("TIU214",$J,"MISSING",TIUPRNT,TIUCHILD)) Q:TIUCHILD=""!(TIUQUIT) D
111 ..S TIUCINFO=^TMP("TIU214",$J,"MISSING",TIUPRNT,TIUCHILD)
112 ..I $Y>(IOSL-TIULEN) D PAUSE Q:TIUQUIT D HDR2(1)
113 ..W !!," Patient: " W:TIUSHOW $P(TIUCINFO,"^",1)," (" W $P(TIUCINFO,"^",2) W:TIUSHOW ")"
114 ..W !," Title: ",$P(TIUCINFO,"^",3)
115 ..W !," Entry DT: ",$P(TIUCINFO,"^",4)
116 ..W !," Author: ",$P(TIUCINFO,"^",5)
117 ..W !," Child IEN: ",TIUCHILD
118 ..W !,"Parent IEN: ",TIUPRNT
119 ..I TIUFIX D
120 ...I $G(^TIU(8925,TIUCHILD,21))=TIUPRNT D Q
121 ....N DIE,DA,DR
122 ....S DIE=8925,DA=TIUCHILD,DR="2101///@" D ^DIE
123 ....W !?5,"..... Removed pointer from child to parent."
124 ....S ^TMP("TIU214",$J,"FIX_MISSING_PTR")=^TMP("TIU214",$J,"FIX_MISSING_PTR")+1
125 ...I $G(^TIU(8925,TIUCHILD,21))'=TIUPRNT D
126 ....K ^TIU(8925,"GDAD",TIUPRNT,TIUCHILD)
127 ....W !?5,"..... Child note did not point to parent. GDAD cross reference removed."
128 ....S ^TMP("TIU214",$J,"FIX_MISSING_XREF")=^TMP("TIU214",$J,"FIX_MISSING_XREF")+1
129 Q:TIUQUIT
130 I TIUDATA D PAUSE Q:TIUQUIT
131 S TIUDATA=0,TIULEN=$S(IOST["C-":9,1:7)
132 D HDR3(1)
133 S TIUPRNT=""
134 F S TIUPRNT=$O(^TMP("TIU214",$J,"NONPRNT",TIUPRNT)) Q:TIUPRNT=""!(TIUQUIT) D
135 .S TIUCHILD=""
136 .F S TIUCHILD=$O(^TMP("TIU214",$J,"NONPRNT",TIUPRNT,TIUCHILD)) Q:TIUCHILD=""!(TIUQUIT) D
137 ..S TIUCINFO=^TMP("TIU214",$J,"NONPRNT",TIUPRNT,TIUCHILD)
138 ..I $Y>(IOSL-TIULEN) D PAUSE Q:TIUQUIT D HDR3(1)
139 ..W !!," Patient: " W:TIUSHOW $P(TIUCINFO,"^",1)," (" W $P(TIUCINFO,"^",2) W:TIUSHOW ")"
140 ..W !," Parent Title: ",$P(TIUCINFO,"^",3),"-IEN: ",TIUPRNT
141 ..W !,"Parent Entry DT: ",$P(TIUCINFO,"^",4)
142 ..W !," Parent Author: ",$P(TIUCINFO,"^",5)
143 ..W !," Child Title: ",$P(TIUCINFO,"^",7),"-IEN: ",TIUCHILD
144 Q:TIUQUIT
145 I TIUDATA D PAUSE Q:TIUQUIT
146 W !,@IOF
147 W !!?15,"TOTAL COUNTS FOR MISMATCHED ID NOTES"
148 W !?15,"------------------------------------",!
149 W !?15,+^TMP("TIU214",$J)_" CROSS REFERENCES CHECKED"
150 W !?15,+^TMP("TIU214",$J,"MISMATCH")_" MISSMATCHED NOTE(S) FOUND"
151 W !?15,+^TMP("TIU214",$J,"MISSING")_" NON EXISTENT PARENT NOTE(S)"
152 W !?15,+^TMP("TIU214",$J,"NONPRNT")_" PARENT MAY NOT BE AN ID NOTE"
153 I TIUFIX D
154 .W !!?15,+^TMP("TIU214",$J,"FIX_MISMATCH_PTR")_" POINTER(S) FIXED FOR MISMATCHED NOTES"
155 .W !?15,+^TMP("TIU214",$J,"FIX_MISMATCH_XREF")_" XREF(S) FIXED FOR MISMATCHED NOTES"
156 .W !?15,+^TMP("TIU214",$J,"FIX_MISSING_PTR")_" POINTER(S) FIXED FOR MISSING NOTES"
157 .W !?15,+^TMP("TIU214",$J,"FIX_MISSING_XREF")_" XREF(S) FIXED FOR MISSING NOTES"
158 Q
159MAIL ; EMAIL TOTALS TO B.PSI-06-030 TO TRACK COMPLIANCE
160 N XMDUZ,XMSUBJ,XMTO,TIUMAIL,%H,Y
161 S XMDUZ="",XMSUBJ="MISMATCHED ID NOTES"
162 S TIUMAIL(1,0)=$P($$SITE^VASITE(),"^",1,2)
163 S %H=$H D YX^%DTC
164 S TIUMAIL(2,0)=Y
165 S TIUMAIL(3,0)=""
166 S TIUMAIL(4,0)=+^TMP("TIU214",$J)_" CROSS REFERENCES CHECKED"
167 S TIUMAIL(5,0)=+^TMP("TIU214",$J,"MISMATCH")_" MISS MATCHED NOTE(S) FOUND"
168 S TIUMAIL(6,0)=+^TMP("TIU214",$J,"MISSING")_" NON EXISTENT PARENT NOTE(S)"
169 I 'TIUFIX D
170 .S TIUMAIL(7,0)=""
171 .S TIUMAIL(8,0)="MODE - REPORT ONLY"
172 I TIUFIX D
173 .S TIUMAIL(7,0)=""
174 .S TIUMAIL(8,0)="MODE - REPORT AND FIX"
175 .S TIUMAIL(9,0)=+^TMP("TIU214",$J,"FIX_MISMATCH_PTR")_" POINTER(S) FIXED FOR MISMATCHED NOTES"
176 .S TIUMAIL(10,0)=+^TMP("TIU214",$J,"FIX_MISMATCH_XREF")_" XREF(S) FIXED FOR MISMATCHED NOTES"
177 .S TIUMAIL(11,0)=+^TMP("TIU214",$J,"FIX_MISSING_PTR")_" POINTER(S) FIXED FOR MISSING NOTES"
178 .S TIUMAIL(12,0)=+^TMP("TIU214",$J,"FIX_MISSING_XREF")_" XREF(S) FIXED FOR MISSING NOTES"
179 S XMTO("G.PSI-06-030@FORUM.VA.GOV")=""
180 D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,"TIUMAIL",.XMTO)
181 Q
182PNAME(PTDFN) ; Return Patient Name & last 4 of SSN
183 N TIUSSN,TIUSSN4,TIUNAME,TIUPN,VADM
184 I $G(PTDFN)="" Q "UNKNOWN^UNKNOWN"
185 ;
186 S DFN=PTDFN D DEM^VADPT
187 S TIUSSN=$P(VADM(2),"^",2)
188 S TIUSSN4=$P(TIUSSN,"-",3)
189 S TIUPN=VADM(1)
190 I TIUPN'="" S TIUPN=TIUPN_"^"_$E(TIUPN)_TIUSSN4
191 I TIUPN="" S TIUPN="UNKNOWN^UNKNOWN"
192 Q TIUPN
193HDR1(TIUFF) ;
194 Q:^TMP("TIU214",$J,"MISMATCH")=0
195 S TIUDATA=1
196 I TIUFF W @IOF
197 W ?18,"MISMATCHED INTERDISCIPLINARY NOTES"
198 W !!?10,"CHILD DOCUMENT",?45,"PARENT DOCUMENT"
199 W !?10,"---------------",?45,"--------------" Q
200HDR2(TIUFF) ;
201 Q:^TMP("TIU214",$J,"MISSING")=0
202 S TIUDATA=1
203 I TIUFF W @IOF
204 W !?11,"CHILD ID NOTES POINTING TO A NON-EXISTENT PARENT ID NOTE" Q
205HDR3(TIUFF) ;
206 Q:^TMP("TIU214",$J,"NONPRNT")=0
207 S TIUDATA=1
208 I TIUFF W @IOF
209 W !?11,"CHILD ID NOTES POINTING TO A PARENT THAT MAY NOT BE AN ID NOTE"
210 W !!?11,"** NOTE: THIS IS AN INFORMATIONAL LIST FOR INVESTIGATION.",!?11," NOTHING WILL BE FIXED **" Q
211PAUSE ;
212 I IOST["C-" D
213 .N DIRUT,DIR
214 .W ! S DIR(0)="E" D ^DIR K DIR
215 .I $G(DIRUT)=1 S TIUQUIT=1
216 Q
Note: See TracBrowser for help on using the repository browser.