source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIU144.m@ 862

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

initial load of WorldVistAEHR
File size: 7.8 KB
RevLine 
[613]1TIU144 ; SLC/MAM - Consults with Mismatched Patients ;3/6/03
2 ;;1.0;TEXT INTEGRATION UTILITIES;**144**;Jun 20, 1997
3 ; External References
4 ; DBIA 3983 ^GMR(123
5 ; DBIA 3472 $$CPPAT^GMRCCP
6BEGIN ; List mismatched Consults
7 W !!,"Searching for mismatched Consults could take some time. Please"
8 W !,"remember to queue this option."
9 W ! K IOP S %ZIS="Q" D ^%ZIS I POP K POP Q
10 I $D(IO("Q")) K IO("Q") D Q
11 .S ZTRTN="BUILD^TIU144",ZTSAVE("DUZ")=""
12 .S ZTDESC="TIU Mismatched Consults List - TIU*1*144"
13 .D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Canceled!")
14 .K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
15 .D HOME^%ZIS
16 U IO D BUILD,^%ZISC
17 Q
18 ;
19BUILD ; Build array of mismatched Consults
20 N TIUCVPTR,TIUDA,TIUCNT,CNSLTCLS,NUMFOUND,NUMCHEKD
21 I $E(IOST)="C" W !!,"Searching for Consult documents with mismatched patients...",!
22 S CNSLTCLS=$$CLASS^TIUCNSLT()
23 S TIUCVPTR="",NUMCHEKD=0
24 F S TIUCVPTR=$O(^TIU(8925,"G",TIUCVPTR)) Q:TIUCVPTR="" D
25 . ; -- If Requesting Pkg IEN is 0 or -1, exclude document:
26 . Q:TIUCVPTR'>0
27 . ; -- If Req Pkg has file but it's not GMR(123, exclude document:
28 . I $P(TIUCVPTR,";",2)]"",$P(TIUCVPTR,";",2)'="GMR(123," Q
29 . S TIUDA=0
30 . F S TIUDA=+$O(^TIU(8925,"G",TIUCVPTR,TIUDA)) Q:'TIUDA D
31 . . N DFN,TIUCNNBR,OK,TIUD0,TIUD13,DOC,TIUDAD,TIUDAD0,TITLDA,CAPTURE
32 . . N PT,EDT,STATX,CNSLTPT,CNSLTEDT,TOSERV,CNSLTST,TIUMATCH,LOC,TIUD12
33 . . N DIC,DR,DA,DIQ,DIV,EXTRA,CNSLT1,CNSLT2
34 . . S TIUD0=$G(^TIU(8925,TIUDA,0)),DFN=+$P(TIUD0,U,2)
35 . . S TITLDA=+TIUD0,NUMCHEKD=NUMCHEKD+1
36 . . ; --If Req Pkg lacks file, & docmt is not a Consult, exclude docmt:
37 . . I $P(TIUCVPTR,";",2)="",'$$ISA^TIULX(TITLDA,CNSLTCLS) Q
38 . . S STATX=$P($G(^TIU(8925.6,+$P(TIUD0,U,5),0)),U)
39 . . Q:STATX="RETRACTED"
40 . . Q:STATX="DELETED"
41 . . S TIUCNNBR=+$P(TIUCVPTR,";")
42 . . S OK=$$CPPAT^GMRCCP(TIUCNNBR,DFN)
43 . . Q:OK>0
44 . . ; --If docmt is not a Consult, exclude docmt:
45 . . I TITLDA'=81,'$$ISA^TIULX(TITLDA,CNSLTCLS) Q
46 . . I TITLDA=81 S TIUDAD=+$P(TIUD0,U,6),TIUDAD0=$G(^TIU(8925,TIUDAD,0)) I '$$ISA^TIULX(+TIUDAD0,CNSLTCLS) Q
47 . . S TIUD13=$G(^TIU(8925,TIUDA,13))
48 . . S CAPTURE=$P(TIUD13,U,3)
49 . . S DOC=$E($$PNAME^TIULC1(+TIUD0),1,39)
50 . . S PT=$$PATIENT(DFN)
51 . . S EDT=$$DATE^TIULS($P(TIUD13,U),"MM/DD/YY")
52 . . S TIUD12=$G(^TIU(8925,TIUDA,12))
53 . . S LOC=+$P(TIUD12,U,5)
54 . . S DIV=+$P($G(^SC(LOC,0)),U,4)
55 . . S DIC="^GMR(123,",DR=".02;1;3;8"
56 . . S DA=TIUCNNBR,DIQ(0)="IE",DIQ="TIUMATCH"
57 . . D EN^DIQ1
58 . . S CNSLTPT=+$G(TIUMATCH(123,DA,.02,"I"))
59 . . S CNSLTEDT=$G(TIUMATCH(123,DA,3,"I")),CNSLTEDT=$$DATE^TIULS(CNSLTEDT,"MM/DD/YY")
60 . . S TOSERV=$E($G(TIUMATCH(123,DA,1,"E")),1,40)
61 . . S CNSLTPT=$$PATIENT(CNSLTPT)
62 . . S CNSLTST=$G(TIUMATCH(123,DA,8,"E"))
63 . . S CNSLTST=$S(CNSLTST="DISCONTINUED":"(dc)",1:"")
64 . . S TIUCNT=+$G(TIUCNT)+1
65 . . S ^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"DOCMT")=DOC_U_TIUDA_U_PT_U_EDT_U_CAPTURE_U_STATX
66 . . S ^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"CNSLT")=TOSERV_U_TIUCNNBR_U_CNSLTPT_U_CNSLTEDT_U_CNSLTST
67 . . ; -- Add lines about parent if docmt is addendum:
68 . . I TITLDA=81 D
69 . . . N DADDFN,TIUDAD13,DADDOC,DADPT,DADEDT,DADSTATX
70 . . . S DADDFN=$P(TIUDAD0,U,2) Q:'DADDFN
71 . . . S DADSTATX=$P($G(^TIU(8925.6,+$P(TIUDAD0,U,5),0)),U)
72 . . . S TIUDAD13=$G(^TIU(8925,TIUDAD,13))
73 . . . S DADDOC=$E($$PNAME^TIULC1(+TIUDAD0),1,40)
74 . . . S DADPT=$$PATIENT(DADDFN)
75 . . . S DADEDT=$$DATE^TIULS($P(TIUDAD13,U),"MM/DD/YY")
76 . . . S ^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"DADDOCMT")=DADDOC_U_TIUDAD_U_DADPT_U_DADEDT_U_DADSTATX
77 . . Q:TIUCNNBR'>0
78 . . S EXTRA=0
79 . . S CNSLT1=+$O(^GMR(123,"R",TIUDA_";TIU(8925,",0))
80 . . Q:CNSLT1'>0
81 . . I CNSLT1'=TIUCNNBR S EXTRA=CNSLT1
82 . . I 'EXTRA S CNSLT2=+$O(^GMR(123,"R",TIUDA_";TIU(8925,",CNSLT1))
83 . . I $G(CNSLT2)>0,CNSLT2'=TIUCNNBR S EXTRA=CNSLT2
84 . . I +EXTRA S ^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"EXTRA")=EXTRA
85 S NUMFOUND=+$G(TIUCNT)
86 D PRINT(NUMCHEKD,NUMFOUND)
87 K ^TMP("TIU144",$J)
88 Q
89 ;
90PATIENT(PTDA) ; Return Patient Name & last 4 of SSN
91 ; Receives Patient file IEN
92 N PT,LASTI,LAST4
93 S PT=$$NAME^TIULS($$PTNAME^TIULC1(+PTDA),"LAST,FI MI")
94 S LASTI=$E(PT)
95 S LAST4=$E($P($G(^DPT(+PTDA,0)),U,9),6,9)
96 S LAST4="("_LASTI_LAST4_")"
97 S PT=PT_" "_LAST4
98 Q PT
99PRINT(CHEKD,FOUND) ; Print
100 N TIUCNT,TIUCONT,DOCDATA,DADDATA,CNDATA,TITLDA,DIV,EXTDIV,MISMNUM
101 I $D(ZTQUEUED) S ZTREQ="@" ; Tell TaskMan to delete Task log entry
102 I $E(IOST)="C" W @IOF,!
103 W " Consult Documents with Mismatched Patients"
104 W !!," ",CHEKD," documents processed"
105 I 'FOUND W !," No mismatches found" G PRINTX
106 W !," ",FOUND," mismatched documents found"
107 W !!," In listed mismatches, the patient for the request associated with the"
108 W !,"document does not match the patient for the document. See the description for"
109 W !,"patch TIU*1*144 in the National Patch Module for further explanation of this"
110 W !,"display and for instructions on how to correct listed entries.",!!
111 ;W " In addition to patient mismatches, this list may contain some Consult Results",!,"which are not linked to any request.",!!
112 S DIV="",TIUCONT=1,MISMNUM=0
113 F S DIV=$O(^TMP("TIU144",$J,DIV)) Q:DIV="" D Q:'TIUCONT
114 . I DIV'=$O(^TMP("TIU144",$J,"")) D Q:'TIUCONT
115 . . I $E(IOST)="C" W !! S TIUCONT=$$STOP Q
116 . . W @IOF
117 . S EXTDIV=$$EXTERNAL^DILFD(44,3,"",DIV)
118 . I EXTDIV']"" S EXTDIV="UNKNOWN"
119 . W "===============================================================================",!
120 . W " Division: ",EXTDIV
121 . W !,"==============================================================================="
122 . S TITLDA=""
123 . F S TITLDA=$O(^TMP("TIU144",$J,DIV,TITLDA)) Q:TITLDA="" D Q:'TIUCONT
124 . . S TIUCNT=""
125 . . F S TIUCNT=$O(^TMP("TIU144",$J,DIV,TITLDA,TIUCNT)) Q:TIUCNT="" D Q:'TIUCONT
126 . . . W !!
127 . . . S TIUCONT=$$SETCONT Q:'TIUCONT
128 . . . S DOCDATA=^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"DOCMT")
129 . . . S MISMNUM=MISMNUM+1
130 . . . W ?2,MISMNUM,".",?7,"Note Title: ",$P(DOCDATA,U),?59,"#: ",$P(DOCDATA,U,2),?72,"Capt: ",$P(DOCDATA,U,5)
131 . . . W !,?2,"Pt: ",$P(DOCDATA,U,3),?59,"Rf Date: ",$P(DOCDATA,U,4)
132 . . . S CNDATA=^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"CNSLT")
133 . . . W !,?2,"Cnslt To Serv: ",$P(CNDATA,U),?59,"Cnslt #: ",$P(CNDATA,U,2),?75,$P(CNDATA,U,5)
134 . . . W !,?2,"Pt: ",$P(CNDATA,U,3),?59,"Date: ",$P(CNDATA,U,4)
135 . . . S DADDATA=$G(^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"DADDOCMT"))
136 . . . I DADDATA]"" D
137 . . . . W !,?2,"Parent Title: ",$P(DADDATA,U),?59,"#: ",$P(DADDATA,U,2)
138 . . . . W !,?2,"Rf Date: ",$P(DADDATA,U,4)
139 . . . I $D(^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"EXTRA")) W !,?2,"Consult # ",^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"EXTRA")," is ALSO linked to this document on the Consults side."
140PRINTX I $G(TIUCONT) W !! S TIUCONT=$$SETCONT W ?5,"================ ",FOUND," Mismatches Found."," ================="
141 D MAIL(CHEKD,FOUND)
142 Q
143MAIL(CHEKD,FOUND) ; Send msg to person who ran option & Pt Safety Committee
144 N XMSUB,XMTEXT,XMDUZ,XMY,XMZ,XMMG,TIUTXT
145 S XMDUZ="PATCH TIU*1*144 MISMATCHED CONSULTS SEARCH OPTION"
146 S:$G(DUZ) XMY(DUZ)=""
147 S XMY("G.PATIENT SAFETY NOTIFICATIONS")="",XMY(.5)=""
148 S TIUTXT(1)="TIU Consult Documents Linked to Different Patient's Request"
149 S TIUTXT(2)=""
150 S TIUTXT(3)="Search completed successfully on "_$$FMTE^XLFDT($$NOW^XLFDT)
151 S TIUTXT(4)="Number of TIU documents processed: "_CHEKD
152 S TIUTXT(5)="Number of mismatched documents found: "_FOUND
153 S TIUTXT(6)=""
154 S TIUTXT(7)="These documents should be cleaned up manually, using TIU Document Management"
155 S TIUTXT(8)="options. For more information, see patch TIU*1*144 in the National Patch"
156 S TIUTXT(9)="Module on FORUM, or contact "_$S($G(DUZ):$P(^VA(200,DUZ,0),"^"),1:"IRM")_"."
157 S XMTEXT="TIUTXT(",XMSUB="TIU*1*144 Mismatched TIU Consult Documents"
158 D ^XMD
159 Q
160STOP() ;on screen paging check
161 ; quits TIUCONT=1 if cont. ELSE quits TIUCONT=0
162 N DIR,Y,TIUCONT
163 S DIR(0)="E" D ^DIR
164 S TIUCONT=Y
165 I TIUCONT W @IOF,!
166 Q TIUCONT
167 ;
168SETCONT() ; D form feed, Set TIUCONT
169 N TIUCONT
170 S TIUCONT=1
171 I $E(IOST)="C" G SETX:$Y+8<IOSL
172 I $E(IOST)="C" S TIUCONT=$$STOP G SETX
173 G:$Y+7<IOSL SETX
174 W @IOF
175SETX Q TIUCONT
Note: See TracBrowser for help on using the repository browser.