- TIU144 ; SLC/MAM - Consults with Mismatched Patients ;3/6/03
- ;;1.0;TEXT INTEGRATION UTILITIES;**144**;Jun 20, 1997
- ; External References
- ; DBIA 3983 ^GMR(123
- ; DBIA 3472 $$CPPAT^GMRCCP
- BEGIN ; List mismatched Consults
- W !!,"Searching for mismatched Consults could take some time. Please"
- W !,"remember to queue this option."
- W ! K IOP S %ZIS="Q" D ^%ZIS I POP K POP Q
- I $D(IO("Q")) K IO("Q") D Q
- .S ZTRTN="BUILD^TIU144",ZTSAVE("DUZ")=""
- .S ZTDESC="TIU Mismatched Consults List - TIU*1*144"
- .D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Canceled!")
- .K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
- .D HOME^%ZIS
- U IO D BUILD,^%ZISC
- Q
- ;
- BUILD ; Build array of mismatched Consults
- N TIUCVPTR,TIUDA,TIUCNT,CNSLTCLS,NUMFOUND,NUMCHEKD
- I $E(IOST)="C" W !!,"Searching for Consult documents with mismatched patients...",!
- S CNSLTCLS=$$CLASS^TIUCNSLT()
- S TIUCVPTR="",NUMCHEKD=0
- F S TIUCVPTR=$O(^TIU(8925,"G",TIUCVPTR)) Q:TIUCVPTR="" D
- . ; -- If Requesting Pkg IEN is 0 or -1, exclude document:
- . Q:TIUCVPTR'>0
- . ; -- If Req Pkg has file but it's not GMR(123, exclude document:
- . I $P(TIUCVPTR,";",2)]"",$P(TIUCVPTR,";",2)'="GMR(123," Q
- . S TIUDA=0
- . F S TIUDA=+$O(^TIU(8925,"G",TIUCVPTR,TIUDA)) Q:'TIUDA D
- . . N DFN,TIUCNNBR,OK,TIUD0,TIUD13,DOC,TIUDAD,TIUDAD0,TITLDA,CAPTURE
- . . N PT,EDT,STATX,CNSLTPT,CNSLTEDT,TOSERV,CNSLTST,TIUMATCH,LOC,TIUD12
- . . N DIC,DR,DA,DIQ,DIV,EXTRA,CNSLT1,CNSLT2
- . . S TIUD0=$G(^TIU(8925,TIUDA,0)),DFN=+$P(TIUD0,U,2)
- . . S TITLDA=+TIUD0,NUMCHEKD=NUMCHEKD+1
- . . ; --If Req Pkg lacks file, & docmt is not a Consult, exclude docmt:
- . . I $P(TIUCVPTR,";",2)="",'$$ISA^TIULX(TITLDA,CNSLTCLS) Q
- . . S STATX=$P($G(^TIU(8925.6,+$P(TIUD0,U,5),0)),U)
- . . Q:STATX="RETRACTED"
- . . Q:STATX="DELETED"
- . . S TIUCNNBR=+$P(TIUCVPTR,";")
- . . S OK=$$CPPAT^GMRCCP(TIUCNNBR,DFN)
- . . Q:OK>0
- . . ; --If docmt is not a Consult, exclude docmt:
- . . I TITLDA'=81,'$$ISA^TIULX(TITLDA,CNSLTCLS) Q
- . . I TITLDA=81 S TIUDAD=+$P(TIUD0,U,6),TIUDAD0=$G(^TIU(8925,TIUDAD,0)) I '$$ISA^TIULX(+TIUDAD0,CNSLTCLS) Q
- . . S TIUD13=$G(^TIU(8925,TIUDA,13))
- . . S CAPTURE=$P(TIUD13,U,3)
- . . S DOC=$E($$PNAME^TIULC1(+TIUD0),1,39)
- . . S PT=$$PATIENT(DFN)
- . . S EDT=$$DATE^TIULS($P(TIUD13,U),"MM/DD/YY")
- . . S TIUD12=$G(^TIU(8925,TIUDA,12))
- . . S LOC=+$P(TIUD12,U,5)
- . . S DIV=+$P($G(^SC(LOC,0)),U,4)
- . . S DIC="^GMR(123,",DR=".02;1;3;8"
- . . S DA=TIUCNNBR,DIQ(0)="IE",DIQ="TIUMATCH"
- . . D EN^DIQ1
- . . S CNSLTPT=+$G(TIUMATCH(123,DA,.02,"I"))
- . . S CNSLTEDT=$G(TIUMATCH(123,DA,3,"I")),CNSLTEDT=$$DATE^TIULS(CNSLTEDT,"MM/DD/YY")
- . . S TOSERV=$E($G(TIUMATCH(123,DA,1,"E")),1,40)
- . . S CNSLTPT=$$PATIENT(CNSLTPT)
- . . S CNSLTST=$G(TIUMATCH(123,DA,8,"E"))
- . . S CNSLTST=$S(CNSLTST="DISCONTINUED":"(dc)",1:"")
- . . S TIUCNT=+$G(TIUCNT)+1
- . . S ^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"DOCMT")=DOC_U_TIUDA_U_PT_U_EDT_U_CAPTURE_U_STATX
- . . S ^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"CNSLT")=TOSERV_U_TIUCNNBR_U_CNSLTPT_U_CNSLTEDT_U_CNSLTST
- . . ; -- Add lines about parent if docmt is addendum:
- . . I TITLDA=81 D
- . . . N DADDFN,TIUDAD13,DADDOC,DADPT,DADEDT,DADSTATX
- . . . S DADDFN=$P(TIUDAD0,U,2) Q:'DADDFN
- . . . S DADSTATX=$P($G(^TIU(8925.6,+$P(TIUDAD0,U,5),0)),U)
- . . . S TIUDAD13=$G(^TIU(8925,TIUDAD,13))
- . . . S DADDOC=$E($$PNAME^TIULC1(+TIUDAD0),1,40)
- . . . S DADPT=$$PATIENT(DADDFN)
- . . . S DADEDT=$$DATE^TIULS($P(TIUDAD13,U),"MM/DD/YY")
- . . . S ^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"DADDOCMT")=DADDOC_U_TIUDAD_U_DADPT_U_DADEDT_U_DADSTATX
- . . Q:TIUCNNBR'>0
- . . S EXTRA=0
- . . S CNSLT1=+$O(^GMR(123,"R",TIUDA_";TIU(8925,",0))
- . . Q:CNSLT1'>0
- . . I CNSLT1'=TIUCNNBR S EXTRA=CNSLT1
- . . I 'EXTRA S CNSLT2=+$O(^GMR(123,"R",TIUDA_";TIU(8925,",CNSLT1))
- . . I $G(CNSLT2)>0,CNSLT2'=TIUCNNBR S EXTRA=CNSLT2
- . . I +EXTRA S ^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"EXTRA")=EXTRA
- S NUMFOUND=+$G(TIUCNT)
- D PRINT(NUMCHEKD,NUMFOUND)
- K ^TMP("TIU144",$J)
- Q
- ;
- PATIENT(PTDA) ; Return Patient Name & last 4 of SSN
- ; Receives Patient file IEN
- N PT,LASTI,LAST4
- S PT=$$NAME^TIULS($$PTNAME^TIULC1(+PTDA),"LAST,FI MI")
- S LASTI=$E(PT)
- S LAST4=$E($P($G(^DPT(+PTDA,0)),U,9),6,9)
- S LAST4="("_LASTI_LAST4_")"
- S PT=PT_" "_LAST4
- Q PT
- PRINT(CHEKD,FOUND) ; Print
- N TIUCNT,TIUCONT,DOCDATA,DADDATA,CNDATA,TITLDA,DIV,EXTDIV,MISMNUM
- I $D(ZTQUEUED) S ZTREQ="@" ; Tell TaskMan to delete Task log entry
- I $E(IOST)="C" W @IOF,!
- W " Consult Documents with Mismatched Patients"
- W !!," ",CHEKD," documents processed"
- I 'FOUND W !," No mismatches found" G PRINTX
- W !," ",FOUND," mismatched documents found"
- W !!," In listed mismatches, the patient for the request associated with the"
- W !,"document does not match the patient for the document. See the description for"
- W !,"patch TIU*1*144 in the National Patch Module for further explanation of this"
- W !,"display and for instructions on how to correct listed entries.",!!
- ;W " In addition to patient mismatches, this list may contain some Consult Results",!,"which are not linked to any request.",!!
- S DIV="",TIUCONT=1,MISMNUM=0
- F S DIV=$O(^TMP("TIU144",$J,DIV)) Q:DIV="" D Q:'TIUCONT
- . I DIV'=$O(^TMP("TIU144",$J,"")) D Q:'TIUCONT
- . . I $E(IOST)="C" W !! S TIUCONT=$$STOP Q
- . . W @IOF
- . S EXTDIV=$$EXTERNAL^DILFD(44,3,"",DIV)
- . I EXTDIV']"" S EXTDIV="UNKNOWN"
- . W "===============================================================================",!
- . W " Division: ",EXTDIV
- . W !,"==============================================================================="
- . S TITLDA=""
- . F S TITLDA=$O(^TMP("TIU144",$J,DIV,TITLDA)) Q:TITLDA="" D Q:'TIUCONT
- . . S TIUCNT=""
- . . F S TIUCNT=$O(^TMP("TIU144",$J,DIV,TITLDA,TIUCNT)) Q:TIUCNT="" D Q:'TIUCONT
- . . . W !!
- . . . S TIUCONT=$$SETCONT Q:'TIUCONT
- . . . S DOCDATA=^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"DOCMT")
- . . . S MISMNUM=MISMNUM+1
- . . . W ?2,MISMNUM,".",?7,"Note Title: ",$P(DOCDATA,U),?59,"#: ",$P(DOCDATA,U,2),?72,"Capt: ",$P(DOCDATA,U,5)
- . . . W !,?2,"Pt: ",$P(DOCDATA,U,3),?59,"Rf Date: ",$P(DOCDATA,U,4)
- . . . S CNDATA=^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"CNSLT")
- . . . W !,?2,"Cnslt To Serv: ",$P(CNDATA,U),?59,"Cnslt #: ",$P(CNDATA,U,2),?75,$P(CNDATA,U,5)
- . . . W !,?2,"Pt: ",$P(CNDATA,U,3),?59,"Date: ",$P(CNDATA,U,4)
- . . . S DADDATA=$G(^TMP("TIU144",$J,DIV,TITLDA,TIUCNT,"DADDOCMT"))
- . . . I DADDATA]"" D
- . . . . W !,?2,"Parent Title: ",$P(DADDATA,U),?59,"#: ",$P(DADDATA,U,2)
- . . . . W !,?2,"Rf Date: ",$P(DADDATA,U,4)
- . . . 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."
- PRINTX I $G(TIUCONT) W !! S TIUCONT=$$SETCONT W ?5,"================ ",FOUND," Mismatches Found."," ================="
- D MAIL(CHEKD,FOUND)
- Q
- MAIL(CHEKD,FOUND) ; Send msg to person who ran option & Pt Safety Committee
- N XMSUB,XMTEXT,XMDUZ,XMY,XMZ,XMMG,TIUTXT
- S XMDUZ="PATCH TIU*1*144 MISMATCHED CONSULTS SEARCH OPTION"
- S:$G(DUZ) XMY(DUZ)=""
- S XMY("G.PATIENT SAFETY NOTIFICATIONS")="",XMY(.5)=""
- S TIUTXT(1)="TIU Consult Documents Linked to Different Patient's Request"
- S TIUTXT(2)=""
- S TIUTXT(3)="Search completed successfully on "_$$FMTE^XLFDT($$NOW^XLFDT)
- S TIUTXT(4)="Number of TIU documents processed: "_CHEKD
- S TIUTXT(5)="Number of mismatched documents found: "_FOUND
- S TIUTXT(6)=""
- S TIUTXT(7)="These documents should be cleaned up manually, using TIU Document Management"
- S TIUTXT(8)="options. For more information, see patch TIU*1*144 in the National Patch"
- S TIUTXT(9)="Module on FORUM, or contact "_$S($G(DUZ):$P(^VA(200,DUZ,0),"^"),1:"IRM")_"."
- S XMTEXT="TIUTXT(",XMSUB="TIU*1*144 Mismatched TIU Consult Documents"
- D ^XMD
- Q
- STOP() ;on screen paging check
- ; quits TIUCONT=1 if cont. ELSE quits TIUCONT=0
- N DIR,Y,TIUCONT
- S DIR(0)="E" D ^DIR
- S TIUCONT=Y
- I TIUCONT W @IOF,!
- Q TIUCONT
- ;
- SETCONT() ; D form feed, Set TIUCONT
- N TIUCONT
- S TIUCONT=1
- I $E(IOST)="C" G SETX:$Y+8<IOSL
- I $E(IOST)="C" S TIUCONT=$$STOP G SETX
- G:$Y+7<IOSL SETX
- W @IOF
- SETX Q TIUCONT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIU144 8166 printed Jan 18, 2025@03:39:27 Page 2
- TIU144 ; SLC/MAM - Consults with Mismatched Patients ;3/6/03
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**144**;Jun 20, 1997
- +2 ; External References
- +3 ; DBIA 3983 ^GMR(123
- +4 ; DBIA 3472 $$CPPAT^GMRCCP
- BEGIN ; List mismatched Consults
- +1 WRITE !!,"Searching for mismatched Consults could take some time. Please"
- +2 WRITE !,"remember to queue this option."
- +3 WRITE !
- KILL IOP
- SET %ZIS="Q"
- DO ^%ZIS
- IF POP
- KILL POP
- QUIT
- +4 IF $DATA(IO("Q"))
- KILL IO("Q")
- Begin DoDot:1
- +5 SET ZTRTN="BUILD^TIU144"
- SET ZTSAVE("DUZ")=""
- +6 SET ZTDESC="TIU Mismatched Consults List - TIU*1*144"
- +7 DO ^%ZTLOAD
- WRITE !,$SELECT($DATA(ZTSK):"Request Queued!",1:"Request Canceled!")
- +8 KILL ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
- +9 DO HOME^%ZIS
- End DoDot:1
- QUIT
- +10 USE IO
- DO BUILD
- DO ^%ZISC
- +11 QUIT
- +12 ;
- BUILD ; Build array of mismatched Consults
- +1 NEW TIUCVPTR,TIUDA,TIUCNT,CNSLTCLS,NUMFOUND,NUMCHEKD
- +2 IF $EXTRACT(IOST)="C"
- WRITE !!,"Searching for Consult documents with mismatched patients...",!
- +3 SET CNSLTCLS=$$CLASS^TIUCNSLT()
- +4 SET TIUCVPTR=""
- SET NUMCHEKD=0
- +5 FOR
- SET TIUCVPTR=$ORDER(^TIU(8925,"G",TIUCVPTR))
- if TIUCVPTR=""
- QUIT
- Begin DoDot:1
- +6 ; -- If Requesting Pkg IEN is 0 or -1, exclude document:
- +7 if TIUCVPTR'>0
- QUIT
- +8 ; -- If Req Pkg has file but it's not GMR(123, exclude document:
- +9 IF $PIECE(TIUCVPTR,";",2)]""
- IF $PIECE(TIUCVPTR,";",2)'="GMR(123,"
- QUIT
- +10 SET TIUDA=0
- +11 FOR
- SET TIUDA=+$ORDER(^TIU(8925,"G",TIUCVPTR,TIUDA))
- if 'TIUDA
- QUIT
- Begin DoDot:2
- +12 NEW DFN,TIUCNNBR,OK,TIUD0,TIUD13,DOC,TIUDAD,TIUDAD0,TITLDA,CAPTURE
- +13 NEW PT,EDT,STATX,CNSLTPT,CNSLTEDT,TOSERV,CNSLTST,TIUMATCH,LOC,TIUD12
- +14 NEW DIC,DR,DA,DIQ,DIV,EXTRA,CNSLT1,CNSLT2
- +15 SET TIUD0=$GET(^TIU(8925,TIUDA,0))
- SET DFN=+$PIECE(TIUD0,U,2)
- +16 SET TITLDA=+TIUD0
- SET NUMCHEKD=NUMCHEKD+1
- +17 ; --If Req Pkg lacks file, & docmt is not a Consult, exclude docmt:
- +18 IF $PIECE(TIUCVPTR,";",2)=""
- IF '$$ISA^TIULX(TITLDA,CNSLTCLS)
- QUIT
- +19 SET STATX=$PIECE($GET(^TIU(8925.6,+$PIECE(TIUD0,U,5),0)),U)
- +20 if STATX="RETRACTED"
- QUIT
- +21 if STATX="DELETED"
- QUIT
- +22 SET TIUCNNBR=+$PIECE(TIUCVPTR,";")
- +23 SET OK=$$CPPAT^GMRCCP(TIUCNNBR,DFN)
- +24 if OK>0
- QUIT
- +25 ; --If docmt is not a Consult, exclude docmt:
- +26 IF TITLDA'=81
- IF '$$ISA^TIULX(TITLDA,CNSLTCLS)
- QUIT
- +27 IF TITLDA=81
- SET TIUDAD=+$PIECE(TIUD0,U,6)
- SET TIUDAD0=$GET(^TIU(8925,TIUDAD,0))
- IF '$$ISA^TIULX(+TIUDAD0,CNSLTCLS)
- QUIT
- +28 SET TIUD13=$GET(^TIU(8925,TIUDA,13))
- +29 SET CAPTURE=$PIECE(TIUD13,U,3)
- +30 SET DOC=$EXTRACT($$PNAME^TIULC1(+TIUD0),1,39)
- +31 SET PT=$$PATIENT(DFN)
- +32 SET EDT=$$DATE^TIULS($PIECE(TIUD13,U),"MM/DD/YY")
- +33 SET TIUD12=$GET(^TIU(8925,TIUDA,12))
- +34 SET LOC=+$PIECE(TIUD12,U,5)
- +35 SET DIV=+$PIECE($GET(^SC(LOC,0)),U,4)
- +36 SET DIC="^GMR(123,"
- SET DR=".02;1;3;8"
- +37 SET DA=TIUCNNBR
- SET DIQ(0)="IE"
- SET DIQ="TIUMATCH"
- +38 DO EN^DIQ1
- +39 SET CNSLTPT=+$GET(TIUMATCH(123,DA,.02,"I"))
- +40 SET CNSLTEDT=$GET(TIUMATCH(123,DA,3,"I"))
- SET CNSLTEDT=$$DATE^TIULS(CNSLTEDT,"MM/DD/YY")
- +41 SET TOSERV=$EXTRACT($GET(TIUMATCH(123,DA,1,"E")),1,40)
- +42 SET CNSLTPT=$$PATIENT(CNSLTPT)
- +43 SET CNSLTST=$GET(TIUMATCH(123,DA,8,"E"))
- +44 SET CNSLTST=$SELECT(CNSLTST="DISCONTINUED":"(dc)",1:"")
- +45 SET TIUCNT=+$GET(TIUCNT)+1
- +46 SET ^TMP("TIU144",$JOB,DIV,TITLDA,TIUCNT,"DOCMT")=DOC_U_TIUDA_U_PT_U_EDT_U_CAPTURE_U_STATX
- +47 SET ^TMP("TIU144",$JOB,DIV,TITLDA,TIUCNT,"CNSLT")=TOSERV_U_TIUCNNBR_U_CNSLTPT_U_CNSLTEDT_U_CNSLTST
- +48 ; -- Add lines about parent if docmt is addendum:
- +49 IF TITLDA=81
- Begin DoDot:3
- +50 NEW DADDFN,TIUDAD13,DADDOC,DADPT,DADEDT,DADSTATX
- +51 SET DADDFN=$PIECE(TIUDAD0,U,2)
- if 'DADDFN
- QUIT
- +52 SET DADSTATX=$PIECE($GET(^TIU(8925.6,+$PIECE(TIUDAD0,U,5),0)),U)
- +53 SET TIUDAD13=$GET(^TIU(8925,TIUDAD,13))
- +54 SET DADDOC=$EXTRACT($$PNAME^TIULC1(+TIUDAD0),1,40)
- +55 SET DADPT=$$PATIENT(DADDFN)
- +56 SET DADEDT=$$DATE^TIULS($PIECE(TIUDAD13,U),"MM/DD/YY")
- +57 SET ^TMP("TIU144",$JOB,DIV,TITLDA,TIUCNT,"DADDOCMT")=DADDOC_U_TIUDAD_U_DADPT_U_DADEDT_U_DADSTATX
- End DoDot:3
- +58 if TIUCNNBR'>0
- QUIT
- +59 SET EXTRA=0
- +60 SET CNSLT1=+$ORDER(^GMR(123,"R",TIUDA_";TIU(8925,",0))
- +61 if CNSLT1'>0
- QUIT
- +62 IF CNSLT1'=TIUCNNBR
- SET EXTRA=CNSLT1
- +63 IF 'EXTRA
- SET CNSLT2=+$ORDER(^GMR(123,"R",TIUDA_";TIU(8925,",CNSLT1))
- +64 IF $GET(CNSLT2)>0
- IF CNSLT2'=TIUCNNBR
- SET EXTRA=CNSLT2
- +65 IF +EXTRA
- SET ^TMP("TIU144",$JOB,DIV,TITLDA,TIUCNT,"EXTRA")=EXTRA
- End DoDot:2
- End DoDot:1
- +66 SET NUMFOUND=+$GET(TIUCNT)
- +67 DO PRINT(NUMCHEKD,NUMFOUND)
- +68 KILL ^TMP("TIU144",$JOB)
- +69 QUIT
- +70 ;
- PATIENT(PTDA) ; Return Patient Name & last 4 of SSN
- +1 ; Receives Patient file IEN
- +2 NEW PT,LASTI,LAST4
- +3 SET PT=$$NAME^TIULS($$PTNAME^TIULC1(+PTDA),"LAST,FI MI")
- +4 SET LASTI=$EXTRACT(PT)
- +5 SET LAST4=$EXTRACT($PIECE($GET(^DPT(+PTDA,0)),U,9),6,9)
- +6 SET LAST4="("_LASTI_LAST4_")"
- +7 SET PT=PT_" "_LAST4
- +8 QUIT PT
- PRINT(CHEKD,FOUND) ; Print
- +1 NEW TIUCNT,TIUCONT,DOCDATA,DADDATA,CNDATA,TITLDA,DIV,EXTDIV,MISMNUM
- +2 ; Tell TaskMan to delete Task log entry
- IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +3 IF $EXTRACT(IOST)="C"
- WRITE @IOF,!
- +4 WRITE " Consult Documents with Mismatched Patients"
- +5 WRITE !!," ",CHEKD," documents processed"
- +6 IF 'FOUND
- WRITE !," No mismatches found"
- GOTO PRINTX
- +7 WRITE !," ",FOUND," mismatched documents found"
- +8 WRITE !!," In listed mismatches, the patient for the request associated with the"
- +9 WRITE !,"document does not match the patient for the document. See the description for"
- +10 WRITE !,"patch TIU*1*144 in the National Patch Module for further explanation of this"
- +11 WRITE !,"display and for instructions on how to correct listed entries.",!!
- +12 ;W " In addition to patient mismatches, this list may contain some Consult Results",!,"which are not linked to any request.",!!
- +13 SET DIV=""
- SET TIUCONT=1
- SET MISMNUM=0
- +14 FOR
- SET DIV=$ORDER(^TMP("TIU144",$JOB,DIV))
- if DIV=""
- QUIT
- Begin DoDot:1
- +15 IF DIV'=$ORDER(^TMP("TIU144",$JOB,""))
- Begin DoDot:2
- +16 IF $EXTRACT(IOST)="C"
- WRITE !!
- SET TIUCONT=$$STOP
- QUIT
- +17 WRITE @IOF
- End DoDot:2
- if 'TIUCONT
- QUIT
- +18 SET EXTDIV=$$EXTERNAL^DILFD(44,3,"",DIV)
- +19 IF EXTDIV']""
- SET EXTDIV="UNKNOWN"
- +20 WRITE "===============================================================================",!
- +21 WRITE " Division: ",EXTDIV
- +22 WRITE !,"==============================================================================="
- +23 SET TITLDA=""
- +24 FOR
- SET TITLDA=$ORDER(^TMP("TIU144",$JOB,DIV,TITLDA))
- if TITLDA=""
- QUIT
- Begin DoDot:2
- +25 SET TIUCNT=""
- +26 FOR
- SET TIUCNT=$ORDER(^TMP("TIU144",$JOB,DIV,TITLDA,TIUCNT))
- if TIUCNT=""
- QUIT
- Begin DoDot:3
- +27 WRITE !!
- +28 SET TIUCONT=$$SETCONT
- if 'TIUCONT
- QUIT
- +29 SET DOCDATA=^TMP("TIU144",$JOB,DIV,TITLDA,TIUCNT,"DOCMT")
- +30 SET MISMNUM=MISMNUM+1
- +31 WRITE ?2,MISMNUM,".",?7,"Note Title: ",$PIECE(DOCDATA,U),?59,"#: ",$PIECE(DOCDATA,U,2),?72,"Capt: ",$PIECE(DOCDATA,U,5)
- +32 WRITE !,?2,"Pt: ",$PIECE(DOCDATA,U,3),?59,"Rf Date: ",$PIECE(DOCDATA,U,4)
- +33 SET CNDATA=^TMP("TIU144",$JOB,DIV,TITLDA,TIUCNT,"CNSLT")
- +34 WRITE !,?2,"Cnslt To Serv: ",$PIECE(CNDATA,U),?59,"Cnslt #: ",$PIECE(CNDATA,U,2),?75,$PIECE(CNDATA,U,5)
- +35 WRITE !,?2,"Pt: ",$PIECE(CNDATA,U,3),?59,"Date: ",$PIECE(CNDATA,U,4)
- +36 SET DADDATA=$GET(^TMP("TIU144",$JOB,DIV,TITLDA,TIUCNT,"DADDOCMT"))
- +37 IF DADDATA]""
- Begin DoDot:4
- +38 WRITE !,?2,"Parent Title: ",$PIECE(DADDATA,U),?59,"#: ",$PIECE(DADDATA,U,2)
- +39 WRITE !,?2,"Rf Date: ",$PIECE(DADDATA,U,4)
- End DoDot:4
- +40 IF $DATA(^TMP("TIU144",$JOB,DIV,TITLDA,TIUCNT,"EXTRA"))
- WRITE !,?2,"Consult # ",^TMP("TIU144",$JOB,DIV,TITLDA,TIUCNT,"EXTRA")," is ALSO linked to this document on the Consults side."
- End DoDot:3
- if 'TIUCONT
- QUIT
- End DoDot:2
- if 'TIUCONT
- QUIT
- End DoDot:1
- if 'TIUCONT
- QUIT
- PRINTX IF $GET(TIUCONT)
- WRITE !!
- SET TIUCONT=$$SETCONT
- WRITE ?5,"================ ",FOUND," Mismatches Found."," ================="
- +1 DO MAIL(CHEKD,FOUND)
- +2 QUIT
- MAIL(CHEKD,FOUND) ; Send msg to person who ran option & Pt Safety Committee
- +1 NEW XMSUB,XMTEXT,XMDUZ,XMY,XMZ,XMMG,TIUTXT
- +2 SET XMDUZ="PATCH TIU*1*144 MISMATCHED CONSULTS SEARCH OPTION"
- +3 if $GET(DUZ)
- SET XMY(DUZ)=""
- +4 SET XMY("G.PATIENT SAFETY NOTIFICATIONS")=""
- SET XMY(.5)=""
- +5 SET TIUTXT(1)="TIU Consult Documents Linked to Different Patient's Request"
- +6 SET TIUTXT(2)=""
- +7 SET TIUTXT(3)="Search completed successfully on "_$$FMTE^XLFDT($$NOW^XLFDT)
- +8 SET TIUTXT(4)="Number of TIU documents processed: "_CHEKD
- +9 SET TIUTXT(5)="Number of mismatched documents found: "_FOUND
- +10 SET TIUTXT(6)=""
- +11 SET TIUTXT(7)="These documents should be cleaned up manually, using TIU Document Management"
- +12 SET TIUTXT(8)="options. For more information, see patch TIU*1*144 in the National Patch"
- +13 SET TIUTXT(9)="Module on FORUM, or contact "_$SELECT($GET(DUZ):$PIECE(^VA(200,DUZ,0),"^"),1:"IRM")_"."
- +14 SET XMTEXT="TIUTXT("
- SET XMSUB="TIU*1*144 Mismatched TIU Consult Documents"
- +15 DO ^XMD
- +16 QUIT
- STOP() ;on screen paging check
- +1 ; quits TIUCONT=1 if cont. ELSE quits TIUCONT=0
- +2 NEW DIR,Y,TIUCONT
- +3 SET DIR(0)="E"
- DO ^DIR
- +4 SET TIUCONT=Y
- +5 IF TIUCONT
- WRITE @IOF,!
- +6 QUIT TIUCONT
- +7 ;
- SETCONT() ; D form feed, Set TIUCONT
- +1 NEW TIUCONT
- +2 SET TIUCONT=1
- +3 IF $EXTRACT(IOST)="C"
- if $Y+8<IOSL
- GOTO SETX
- +4 IF $EXTRACT(IOST)="C"
- SET TIUCONT=$$STOP
- GOTO SETX
- +5 if $Y+7<IOSL
- GOTO SETX
- +6 WRITE @IOF
- SETX QUIT TIUCONT