LRAPUALT ;HPS/DSK - MISSING ANATOMIC PATHOLOGY ALERT SEARCH ;May 1, 2018@16:24
;;5.2;LAB SERVICE;**504**;Sep 27, 1994;Build 33
;
Q
;
;Reference to ^DPT supported by IA# 10035
;Reference to ^OR(100 supported by IA# 4167
;Reference to ^XTV(8992.1 supported by IA# 6914
;Reference to DD^%DT supported by IA #10003
;Reference to NOW^%DTC supported by IA #10000
;Reference to ^XLFDT calls supported by IA #10103
;Reference to ^XPAR calls supported by IA #2263
;Reference to %ZTLOAD supported by IA #10063
;Reference to $$SENDMSG^XMXAPI supported by IA #2729
;Reference to $$SETUP1^XQALERT supported by IA #10081
;
EN ;
N LRQUIT,LRTASK,LRSDATE,LREDATE,LRSUB,LRDUZ
;
S LRQUIT=0
D DATE
Q:LRQUIT
D QUEUE
Q
;
DATE ;
I '$G(ZTQUEUED) D Q
. W !!,?5,"This option will search for missing Anatomic Pathology alerts"
. W !,?5,"on verified accessions as well as other issues such as"
. W !,?5,"incorrect settings in the Orders (#100) file."
. W !!,?5,"This routine will run in the background and send an alert as well as"
. W !,?5,"a MailMan message to you as well as the MailMan group ""LMI"" if any"
. W !,?5,"missing Anatomic Pathology alerts are found."
. W !!,?5,"The search may take upwards of 20 minutes to run the first time"
. W !,?5,"or if it is run infrequently.",!
. W !!,"The dates for the following prompts pertain to the dates that an"
. W !,"Anatomic Pathology case is verified."
. W !," (The date range cannot be more than a year due to the possibility that"
. W !," the search may take a long time to complete.)",!
. D ASK
;
;Search all verified cases from start date to current for TaskMan executions
S LREDATE=$$NOW^XLFDT()
;
;Check parameter setting for the last date/time that TaskMan ran the search
S LRSDATE=$$GET^XPAR("SYS","LR AP ALERT SEARCH END",1,"Q")
;
;If report hasn't been run before, generate for previous 30 days
I LRSDATE="" S LRSDATE=$$FMADD^XLFDT(LREDATE,-30)
;
;Save end date/time in parameter to use next time that TaskMan searches
D EN^XPAR("SYS","LR AP ALERT SEARCH END",,LREDATE,"")
Q
;
ASK ;
;Only used for manual execution of routine "Missing AP Alert Search"
;(not used by TaskMan).
;
N DIR
S DIR(0)="DO",DIR("A")="Date to begin search"
D ^DIR
I $G(Y)=""!($D(DTOUT))!($D(DUOUT)) S LRQUIT=1 Q
S LRSDATE=$P(Y,".")
D DD^%DT W ?40,$G(Y)
S DIR(0)="DO",DIR("A")="Date to end search"
D ^DIR
I $G(Y)=""!($D(DTOUT))!($D(DUOUT)) S LRQUIT=1 Q
S LREDATE=$P(Y,".")
I LRSDATE>LREDATE D G ASK
. W !,?5,"The start date cannot be greater than the end date.",!
D DD^%DT W ?40,$G(Y)
I $$FMDIFF^XLFDT(LREDATE,LRSDATE)>365 D G ASK
. W !!,"A maximum of a year's worth of orders may be searched due to"
. W !,"potential journaling or other system issues.",!
S LREDATE=LREDATE_".2359"
Q
;
QUEUE ;
S LRSUB="LR AP ALERT TRACE "_LREDATE
L +^XTMP(LRSUB):5
;
;For the lock to fail, two processes must be starting the same date/time, but
;checking anyway.
I '$T,'$G(ZTQUEUED) D Q
. W !!,"Someone else (or TaskMan) is currently executing this option. Please try later."
;
L -^XTMP(LRSUB)
;
;store DUZ if a user is manually executing the option
S LRDUZ=$S('$G(ZTQUEUED):DUZ,1:"")
;
S LRTASK=0
S LRTASK=$$TASK()
I '$G(ZTQUEUED),LRTASK D Q
. W !!,"Task #: ",+LRTASK," has been queued to run on "
. W $$HTE^XLFDT($P(LRTASK,"^",2))
I '$G(ZTQUEUED),'LRTASK D
. W !!,"Task not queued for unknown reason. Please try again."
Q
;
TASK() ;
N ZTRTN,ZTDESC
S ZTSAVE("LRDUZ")=""
S ZTSAVE("LRSDATE")=""
S ZTSAVE("LREDATE")=""
S ZTSAVE("LRSUB")=""
S ZTRTN="START^LRAPUALT"
S ZTDESC="Missing AP Alert Search"
S ZTIO=""
D ^%ZTLOAD
Q +$G(ZTSK)_"^"_$G(ZTSK("D"))
;
START ;
L +^XTMP(LRSUB):20
I '$T D LOCKED Q
;
N LRAREA,LRSS,X,%,LRDT,LRDTTM
D NOW^%DTC
;Keep date/time stamp in case running this routine manually multiple times a day
;and monitoring for missing alerts since the last time the routine ran
;
S LRDT=X,LRDTTM=%
;
;Keep data for 90 days for future research, if needed
S ^XTMP(LRSUB,0)=$$FMADD^XLFDT(LRDT,90)_"^"_LRDT_"^Missing AP Alert research"
;
;Kill message text if not killed previously for some reason
K ^XTMP("AP ALERT MESSAGE "_LREDATE)
;
;LRLINE for Mail Message line count
S LRLINE=4
;
;Find all accession areas for CY, EM, and SP LR subscripts
;
S LRSS=0
F S LRSS=$O(^LRO(68,LRSS)) Q:'LRSS D
. S LRAREA=$P($G(^LRO(68,LRSS,0)),"^",2)
. I "CYEMSP"[LRAREA D LRSS
D END
Q
;
;Check to see if a yearly, monthly or daily accession area
;even though Anatomic Pathology accession areas are normally yearly
N LRTYPE,LRAD
S LRTYPE=$P(^LRO(68,LRSS,0),"^",3)
;
;No other types should exist, but checking to be sure
I ",Y,M,D,"'[LRTYPE Q
;
;A daily accession area might have some cases re-checked due to logic below.
;However, Anatomic Pathology accession areas are normally not daily.
S LRAD=$S(LRTYPE="Y":$E(LRSDATE,1,3)-1_"000",LRTYPE="M":$E(LRSDATE,1,5)-1_"00",1:$P(LRSDATE,".")-1_".2359")
;
;Yearly area: If LRAD year is greater than end date's year - quit
;Monthly area: If LRAD year/month is greater than end date's year/month - quit
;Daily area: If LRAD year/month/day is greater than end date - quit
;All checks are needed if user manually executed the search.
;(Note: The line below is long but is more efficient by not looping through
; all date levels if manually manually executed the search.)
;
F S LRAD=$O(^LRO(68,LRSS,1,LRAD)) Q:'LRAD Q:$E(LRAD,1,3)>$E(LREDATE,1,3) Q:$E(LRAD,1,5)>$E(LREDATE,1,5) Q:LRAD>$P(LREDATE,".") D
. ;only looping through accessions starting with start date's year
. I $E(LRAD,1,3)'<$E(LRSDATE,1,3) D LRAC
Q
;
LRAC ;Cycle through accessions by verified date/time
N LRVER,LRAC
;
;Start of search will be by date/time for TaskMan and by date for a user
;TaskMan searches might be defined to run several times daily.
S LRVER=$S(LRDUZ]"":LRSDATE-1_".2359",1:LRSDATE)
;
F S LRVER=$O(^LRO(68,LRSS,1,LRAD,1,"AC",LRVER)) Q:LRVER>LREDATE Q:LRVER="" D
. S LRAC=0
. F S LRAC=$O(^LRO(68,LRSS,1,LRAD,1,"AC",LRVER,LRAC)) Q:LRAC="" D
. . ;
. . ;Are results verified?
. . ;Since multiple tests may be on file in file 68, it's
. . ;easier to look in file 69 for the completion status
. . D CHK69
Q
;
CHK69 ;
N LRLABNM,LRODT,LRSN,LRRL
S LRLABNM=$G(^LRO(68,LRSS,1,LRAD,1,LRAC,.1))
I LRLABNM="" S ^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC)="No Lab Number in file 68" Q
;
;There should only be one file 69 entry, but running a loop
;just in case
;
S LRRL="",(LRODT,LRSN)=0
F S LRODT=$O(^LRO(69,"C",LRLABNM,LRODT)) Q:LRODT="" D
. F S LRSN=$O(^LRO(69,"C",LRLABNM,LRODT,LRSN)) Q:LRSN="" D
. . S LRRL=$P($G(^LRO(69,LRODT,1,LRSN,3)),"^",2)
. . I LRRL]"" D CHK100
Q
;
CHK100 ;check the orders file
;get CPRS order number
;multiple order numbers can be present per file 69 specimen number
;but Anatomic Pathology should only have one CPRS order number
N LRCPRS,LRFULL,LRPKG,LRSTATUS,LRRES,LRADFN
S LRCPRS=$P($G(^LRO(69,LRODT,1,LRSN,0)),"^",11)
I LRCPRS="" S ^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC)="No CPRS order number" Q
;
;Need full accession number (ex. "SP 18 34") when checking
;for missing alerts and for possible MailMan messages
S LRFULL=$G(^LRO(68,LRSS,1,LRAD,1,LRAC,.2))
;
;This should never be null, but checking nevertheless.
I LRFULL="" S ^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC)="No accession in File 68 at .2 level." Q
;
;Setting date/time levels in ^XTMP using variable LRDTTM
;so will only have to check recent dates/times the search was executed
;if reviewing the global and the search runs multiple times daily
;
;is package reference missing
S LRPKG=$P($G(^OR(100,LRCPRS,4)),";",4,5)
I LRPKG="" D
. D MSGINIT
. S LRLINE=LRLINE+1
. S ^XTMP("AP ALERT MESSAGE "_LREDATE,LRLINE)=" - is missing package reference for order "_LRCPRS_"."
. S ^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC,"NO_PKG_REF")=LRCPRS_"^Missing package reference"
;
;is status correct
S LRSTATUS=$P($G(^OR(100,LRCPRS,3)),"^",3)
I LRSTATUS'=2 D
. I '$D(^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC)) D MSGINIT
. S LRLINE=LRLINE+1
. S ^XTMP("AP ALERT MESSAGE "_LREDATE,LRLINE)=" - has incorrect status of "_LRSTATUS_" for order "_LRCPRS_"."
. S ^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC,"INCORRECT_STATUS")=LRCPRS_"^Incorrect status of "_LRSTATUS
;
;Is Results Date/Time set
S LRRES=$P($G(^OR(100,LRCPRS,7)),"^")
I LRRES="" D
. I '$D(^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC)) D MSGINIT
. S LRLINE=LRLINE+1
. S ^XTMP("AP ALERT MESSAGE "_LREDATE,LRLINE)=" - has no results date/time for order "_LRCPRS_"."
. S ^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC,"NO_RESULTS_DATE/TIME")=LRCPRS_"^No results date/time"
;
;was alert generated?
;alerts are only sent for Patient (#2) file
S LRADFN=$P(^OR(100,LRCPRS,0),"^",2)
I $P(LRADFN,";",2)["DPT" D
. S LRADFN=$P(LRADFN,";")
. D CHKALERT
Q
;
MSGINIT ;
;First time issue found for this accession
S LRLINE=LRLINE+1
S ^XTMP("AP ALERT MESSAGE "_LREDATE,LRLINE)=" "_LRFULL_":"
Q
;
CHKALERT ;
N LRALERT,LRHIT,LRPNM
S LRALERT="",LRHIT=0
F S LRALERT=$O(^XTV(8992.1,"C",LRADFN,LRALERT)) Q:LRALERT="" Q:LRHIT D
. I $P($G(^XTV(8992.1,LRALERT,2)),"^",2)=LRFULL S LRHIT=1
I 'LRHIT D
. S LRPNM=$P(^DPT(LRADFN,0),"^")
. I '$D(^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC)) D MSGINIT
. S LRLINE=LRLINE+1
. S ^XTMP("AP ALERT MESSAGE "_LREDATE,LRLINE)=" - *** did not generate an alert. ***"
. ;not sending patient name in MailMan message in case this would violate CRISP
. ;setting into ^XTMP to aid in research if needed
. S ^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC,"NO_ALERT")=LRFULL_"^"_LRCPRS_"^"_LRPNM_"^Missing alert"
. S ^XTMP("AP NO ALERT "_LREDATE)=""
Q
;
END ;Send alerts and MailMan messages
;LRDUZ is null if search executed by TaskMan
;
;Issues were found
I $D(^XTMP("AP ALERT MESSAGE "_LREDATE)) D
. D MAIL
. I $D(^XTMP("AP NO ALERT "_LREDATE)) D ALERT Q
. ;Issues were found by none are missing alerts
. D ALERT3
;
;No issues were found
;Do not send alert and MailMan message if executed by TaskMan
I '$D(^XTMP("AP ALERT MESSAGE "_LREDATE)),LRDUZ]"" D
. D MAIL2,ALERT2
;
K ^XTMP("AP ALERT MESSAGE "_LREDATE),^XTMP("AP NO ALERT "_LREDATE)
S ^XTMP(LRSUB,LRDTTM,.1)=$S($D(^XTMP(LRSUB,LRDTTM)):"Issue(s) found",1:"Nothing found")
S ^XTMP(LRSUB,LRDTTM,.2)="Date Range: "_$$FMTE^XLFDT(LRSDATE)_" to: "_$$FMTE^XLFDT(LREDATE)
L -^XTMP(LRSUB)
Q
;
MAIL ;
N LRMRANGE,LRMTEXT,LRMSUB,LRMY,LRMZ,LRMIN
S ^XTMP("AP ALERT MESSAGE "_LREDATE,1)="Anatomic Pathology Alert Search Issues Found"
S ^XTMP("AP ALERT MESSAGE "_LREDATE,2)=" "
S LRMRANGE=$S(LRDUZ]"":"Date ",1:"Date/Time ")_"Range Searched: "_$$FMTE^XLFDT(LRSDATE)
S LRMRANGE=LRMRANGE_" to: "_$S(LRDUZ]"":$P($$FMTE^XLFDT(LREDATE),"@"),1:$$FMTE^XLFDT(LREDATE))
S ^XTMP("AP ALERT MESSAGE "_LREDATE,3)=LRMRANGE
S ^XTMP("AP ALERT MESSAGE "_LREDATE,4)=" "
S LRMTEXT="^XTMP(""AP ALERT MESSAGE ""_LREDATE)"
S LRMSUB="Anatomic Pathology Alert Search Issues Found"
;
;send to user if manually running the routine
I LRDUZ]"" S LRMY(LRDUZ)=""
S LRMY("G.LMI")=""
;
S LRMIN("FROM")="Anatomic Pathology Missing Alert Search"
D SENDMSG^XMXAPI(DUZ,LRMSUB,LRMTEXT,.LRMY,.LRMIN,.LRMZ,"")
Q
;
ALERT ;
;Individual alerts are sent for each accession which is missing an alert
;"X" prefixed variables are needed for sending alerts
N LRTXT,XQAMSG,XQA,XQAID,LRSS,LRAD,LRAC,LRALERT
S LRTXT="*** ALERT NOT SENT FOR ACCESSION: "
S (LRSS,LRAD,LRAC)=""
F S LRSS=$O(^XTMP(LRSUB,LRDTTM,LRSS)) Q:LRSS="" D
. F S LRAD=$O(^XTMP(LRSUB,LRDTTM,LRSS,LRAD)) Q:LRAD="" D
. . F S LRAC=$O(^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC)) Q:LRAC="" D
. . . S LRFULL=$P($G(^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC,"NO_ALERT")),"^")
. . . Q:LRFULL=""
. . . ;need to re-set XQAID and XQA because it is killed if sending multiple
. . . ;alerts
. . . S XQAID="Missing Alert"
. . . I LRDUZ]"" S XQA(LRDUZ)=""
. . . S XQA("G.LMI")=""
. . . S XQAMSG=LRTXT_LRFULL_" ***"
. . . S LRALERT=$$SETUP1^XQALERT
Q
;
MAIL2 ;
;This section is only called if a user manually invoked the option.
N LRMRANGE,LRMTEXT,LRMSUB,LRMY,LRMZ,LRMIN
S ^XTMP("AP ALERT MESSAGE "_LREDATE,1)=" "
S ^XTMP("AP ALERT MESSAGE "_LREDATE,2)="No missing Anatomic Pathology alert issues found on "
S ^XTMP("AP ALERT MESSAGE "_LREDATE,2)=^XTMP("AP ALERT MESSAGE "_LREDATE,2)_$$FMTE^XLFDT(LRDTTM,"MZ")_"."
S LRMRANGE="Date Range Searched: "_$$FMTE^XLFDT(LRSDATE)
S LRMRANGE=LRMRANGE_" to: "_$S(LRDUZ]"":$P($$FMTE^XLFDT(LREDATE),"@"),1:$$FMTE^XLFDT(LREDATE))
S ^XTMP("AP ALERT MESSAGE "_LREDATE,3)=LRMRANGE
S ^XTMP("AP ALERT MESSAGE "_LREDATE,4)=" "
S LRMTEXT="^XTMP(""AP ALERT MESSAGE ""_LREDATE)"
S LRMSUB="No Anatomic Pathology Alert Search Issues Found"
;
;send to person running the routine
S LRMY(LRDUZ)=""
S LRMY("G.LMI")=""
;
S LRMIN("FROM")="Anatomic Pathology Missing Alert Search"
D SENDMSG^XMXAPI(LRDUZ,LRMSUB,LRMTEXT,.LRMY,.LRMIN,.LRMZ,"")
K ^XTMP("AP ALERT MESSAGE "_LREDATE)
Q
;
ALERT2 ;
;This section is only called if a user manually invoked the search option.
N XQAMSG,XQA,XQAID,LRALERT
S XQAID="Missing Alert Search"
S XQA(LRDUZ)=""
S XQA("G.LMI")=""
S XQAMSG="No Missing AP Alerts Found on "_$$FMTE^XLFDT(LRDTTM,"MZ")
S LRALERT=$$SETUP1^XQALERT
Q
;
ALERT3 ;
N XQAMSG,XQA,XQAID,LRALERT
S XQAID="Missing Alert Search"
I LRDUZ]"" S XQA(LRDUZ)=""
S XQA("G.LMI")=""
S XQAMSG="Issues(s) found but no missing AP alerts on "_$$FMTE^XLFDT(LRDTTM,"MZ")
S LRALERT=$$SETUP1^XQALERT
Q
;
LOCKED ;Routine was already being executed by time a user or TaskMan started
;This should be a rare occurrence.
N XQAMSG,XQA,XQAID,LRALERT,%
D NOW^%DTC
S XQAID="Missing Alert Search"
I LRDUZ]"" S XQA(LRDUZ)=""
S XQA("G.LMI")=""
S XQAMSG="Missing Alert Search already running - "_$$FMTE^XLFDT(%,"MZ")
S LRALERT=$$SETUP1^XQALERT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPUALT 14093 printed Nov 22, 2024@17:18:40 Page 2
LRAPUALT ;HPS/DSK - MISSING ANATOMIC PATHOLOGY ALERT SEARCH ;May 1, 2018@16:24
+1 ;;5.2;LAB SERVICE;**504**;Sep 27, 1994;Build 33
+2 ;
+3 QUIT
+4 ;
+5 ;Reference to ^DPT supported by IA# 10035
+6 ;Reference to ^OR(100 supported by IA# 4167
+7 ;Reference to ^XTV(8992.1 supported by IA# 6914
+8 ;Reference to DD^%DT supported by IA #10003
+9 ;Reference to NOW^%DTC supported by IA #10000
+10 ;Reference to ^XLFDT calls supported by IA #10103
+11 ;Reference to ^XPAR calls supported by IA #2263
+12 ;Reference to %ZTLOAD supported by IA #10063
+13 ;Reference to $$SENDMSG^XMXAPI supported by IA #2729
+14 ;Reference to $$SETUP1^XQALERT supported by IA #10081
+15 ;
EN ;
+1 NEW LRQUIT,LRTASK,LRSDATE,LREDATE,LRSUB,LRDUZ
+2 ;
+3 SET LRQUIT=0
+4 DO DATE
+5 if LRQUIT
QUIT
+6 DO QUEUE
+7 QUIT
+8 ;
DATE ;
+1 IF '$GET(ZTQUEUED)
Begin DoDot:1
+2 WRITE !!,?5,"This option will search for missing Anatomic Pathology alerts"
+3 WRITE !,?5,"on verified accessions as well as other issues such as"
+4 WRITE !,?5,"incorrect settings in the Orders (#100) file."
+5 WRITE !!,?5,"This routine will run in the background and send an alert as well as"
+6 WRITE !,?5,"a MailMan message to you as well as the MailMan group ""LMI"" if any"
+7 WRITE !,?5,"missing Anatomic Pathology alerts are found."
+8 WRITE !!,?5,"The search may take upwards of 20 minutes to run the first time"
+9 WRITE !,?5,"or if it is run infrequently.",!
+10 WRITE !!,"The dates for the following prompts pertain to the dates that an"
+11 WRITE !,"Anatomic Pathology case is verified."
+12 WRITE !," (The date range cannot be more than a year due to the possibility that"
+13 WRITE !," the search may take a long time to complete.)",!
+14 DO ASK
End DoDot:1
QUIT
+15 ;
+16 ;Search all verified cases from start date to current for TaskMan executions
+17 SET LREDATE=$$NOW^XLFDT()
+18 ;
+19 ;Check parameter setting for the last date/time that TaskMan ran the search
+20 SET LRSDATE=$$GET^XPAR("SYS","LR AP ALERT SEARCH END",1,"Q")
+21 ;
+22 ;If report hasn't been run before, generate for previous 30 days
+23 IF LRSDATE=""
SET LRSDATE=$$FMADD^XLFDT(LREDATE,-30)
+24 ;
+25 ;Save end date/time in parameter to use next time that TaskMan searches
+26 DO EN^XPAR("SYS","LR AP ALERT SEARCH END",,LREDATE,"")
+27 QUIT
+28 ;
ASK ;
+1 ;Only used for manual execution of routine "Missing AP Alert Search"
+2 ;(not used by TaskMan).
+3 ;
+4 NEW DIR
+5 SET DIR(0)="DO"
SET DIR("A")="Date to begin search"
+6 DO ^DIR
+7 IF $GET(Y)=""!($DATA(DTOUT))!($DATA(DUOUT))
SET LRQUIT=1
QUIT
+8 SET LRSDATE=$PIECE(Y,".")
+9 DO DD^%DT
WRITE ?40,$GET(Y)
+10 SET DIR(0)="DO"
SET DIR("A")="Date to end search"
+11 DO ^DIR
+12 IF $GET(Y)=""!($DATA(DTOUT))!($DATA(DUOUT))
SET LRQUIT=1
QUIT
+13 SET LREDATE=$PIECE(Y,".")
+14 IF LRSDATE>LREDATE
Begin DoDot:1
+15 WRITE !,?5,"The start date cannot be greater than the end date.",!
End DoDot:1
GOTO ASK
+16 DO DD^%DT
WRITE ?40,$GET(Y)
+17 IF $$FMDIFF^XLFDT(LREDATE,LRSDATE)>365
Begin DoDot:1
+18 WRITE !!,"A maximum of a year's worth of orders may be searched due to"
+19 WRITE !,"potential journaling or other system issues.",!
End DoDot:1
GOTO ASK
+20 SET LREDATE=LREDATE_".2359"
+21 QUIT
+22 ;
QUEUE ;
+1 SET LRSUB="LR AP ALERT TRACE "_LREDATE
+2 LOCK +^XTMP(LRSUB):5
+3 ;
+4 ;For the lock to fail, two processes must be starting the same date/time, but
+5 ;checking anyway.
+6 IF '$TEST
IF '$GET(ZTQUEUED)
Begin DoDot:1
+7 WRITE !!,"Someone else (or TaskMan) is currently executing this option. Please try later."
End DoDot:1
QUIT
+8 ;
+9 LOCK -^XTMP(LRSUB)
+10 ;
+11 ;store DUZ if a user is manually executing the option
+12 SET LRDUZ=$SELECT('$GET(ZTQUEUED):DUZ,1:"")
+13 ;
+14 SET LRTASK=0
+15 SET LRTASK=$$TASK()
+16 IF '$GET(ZTQUEUED)
IF LRTASK
Begin DoDot:1
+17 WRITE !!,"Task #: ",+LRTASK," has been queued to run on "
+18 WRITE $$HTE^XLFDT($PIECE(LRTASK,"^",2))
End DoDot:1
QUIT
+19 IF '$GET(ZTQUEUED)
IF 'LRTASK
Begin DoDot:1
+20 WRITE !!,"Task not queued for unknown reason. Please try again."
End DoDot:1
+21 QUIT
+22 ;
TASK() ;
+1 NEW ZTRTN,ZTDESC
+2 SET ZTSAVE("LRDUZ")=""
+3 SET ZTSAVE("LRSDATE")=""
+4 SET ZTSAVE("LREDATE")=""
+5 SET ZTSAVE("LRSUB")=""
+6 SET ZTRTN="START^LRAPUALT"
+7 SET ZTDESC="Missing AP Alert Search"
+8 SET ZTIO=""
+9 DO ^%ZTLOAD
+10 QUIT +$GET(ZTSK)_"^"_$GET(ZTSK("D"))
+11 ;
START ;
+1 LOCK +^XTMP(LRSUB):20
+2 IF '$TEST
DO LOCKED
QUIT
+3 ;
+4 NEW LRAREA,LRSS,X,%,LRDT,LRDTTM
+5 DO NOW^%DTC
+6 ;Keep date/time stamp in case running this routine manually multiple times a day
+7 ;and monitoring for missing alerts since the last time the routine ran
+8 ;
+9 SET LRDT=X
SET LRDTTM=%
+10 ;
+11 ;Keep data for 90 days for future research, if needed
+12 SET ^XTMP(LRSUB,0)=$$FMADD^XLFDT(LRDT,90)_"^"_LRDT_"^Missing AP Alert research"
+13 ;
+14 ;Kill message text if not killed previously for some reason
+15 KILL ^XTMP("AP ALERT MESSAGE "_LREDATE)
+16 ;
+17 ;LRLINE for Mail Message line count
+18 SET LRLINE=4
+19 ;
+20 ;Find all accession areas for CY, EM, and SP LR subscripts
+21 ;
+22 SET LRSS=0
+23 FOR
SET LRSS=$ORDER(^LRO(68,LRSS))
if 'LRSS
QUIT
Begin DoDot:1
+24 SET LRAREA=$PIECE($GET(^LRO(68,LRSS,0)),"^",2)
+25 IF "CYEMSP"[LRAREA
DO LRSS
End DoDot:1
+26 DO END
+27 QUIT
+28 ;
+1 ;Check to see if a yearly, monthly or daily accession area
+2 ;even though Anatomic Pathology accession areas are normally yearly
+3 NEW LRTYPE,LRAD
+4 SET LRTYPE=$PIECE(^LRO(68,LRSS,0),"^",3)
+5 ;
+6 ;No other types should exist, but checking to be sure
+7 IF ",Y,M,D,"'[LRTYPE
QUIT
+8 ;
+9 ;A daily accession area might have some cases re-checked due to logic below.
+10 ;However, Anatomic Pathology accession areas are normally not daily.
+11 SET LRAD=$SELECT(LRTYPE="Y":$EXTRACT(LRSDATE,1,3)-1_"000",LRTYPE="M":$EXTRACT(LRSDATE,1,5)-1_"00",1:$PIECE(LRSDATE,".")-1_".2359")
+12 ;
+13 ;Yearly area: If LRAD year is greater than end date's year - quit
+14 ;Monthly area: If LRAD year/month is greater than end date's year/month - quit
+15 ;Daily area: If LRAD year/month/day is greater than end date - quit
+16 ;All checks are needed if user manually executed the search.
+17 ;(Note: The line below is long but is more efficient by not looping through
+18 ; all date levels if manually manually executed the search.)
+19 ;
+20 FOR
SET LRAD=$ORDER(^LRO(68,LRSS,1,LRAD))
if 'LRAD
QUIT
if $EXTRACT(LRAD,1,3)>$EXTRACT(LREDATE,1,3)
QUIT
if $EXTRACT(LRAD,1,5)>$EXTRACT(LREDATE,1,5)
QUIT
if LRAD>$PIECE(LREDATE,".")
QUIT
Begin DoDot:1
+21 ;only looping through accessions starting with start date's year
+22 IF $EXTRACT(LRAD,1,3)'<$EXTRACT(LRSDATE,1,3)
DO LRAC
End DoDot:1
+23 QUIT
+24 ;
LRAC ;Cycle through accessions by verified date/time
+1 NEW LRVER,LRAC
+2 ;
+3 ;Start of search will be by date/time for TaskMan and by date for a user
+4 ;TaskMan searches might be defined to run several times daily.
+5 SET LRVER=$SELECT(LRDUZ]"":LRSDATE-1_".2359",1:LRSDATE)
+6 ;
+7 FOR
SET LRVER=$ORDER(^LRO(68,LRSS,1,LRAD,1,"AC",LRVER))
if LRVER>LREDATE
QUIT
if LRVER=""
QUIT
Begin DoDot:1
+8 SET LRAC=0
+9 FOR
SET LRAC=$ORDER(^LRO(68,LRSS,1,LRAD,1,"AC",LRVER,LRAC))
if LRAC=""
QUIT
Begin DoDot:2
+10 ;
+11 ;Are results verified?
+12 ;Since multiple tests may be on file in file 68, it's
+13 ;easier to look in file 69 for the completion status
+14 DO CHK69
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
CHK69 ;
+1 NEW LRLABNM,LRODT,LRSN,LRRL
+2 SET LRLABNM=$GET(^LRO(68,LRSS,1,LRAD,1,LRAC,.1))
+3 IF LRLABNM=""
SET ^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC)="No Lab Number in file 68"
QUIT
+4 ;
+5 ;There should only be one file 69 entry, but running a loop
+6 ;just in case
+7 ;
+8 SET LRRL=""
SET (LRODT,LRSN)=0
+9 FOR
SET LRODT=$ORDER(^LRO(69,"C",LRLABNM,LRODT))
if LRODT=""
QUIT
Begin DoDot:1
+10 FOR
SET LRSN=$ORDER(^LRO(69,"C",LRLABNM,LRODT,LRSN))
if LRSN=""
QUIT
Begin DoDot:2
+11 SET LRRL=$PIECE($GET(^LRO(69,LRODT,1,LRSN,3)),"^",2)
+12 IF LRRL]""
DO CHK100
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
CHK100 ;check the orders file
+1 ;get CPRS order number
+2 ;multiple order numbers can be present per file 69 specimen number
+3 ;but Anatomic Pathology should only have one CPRS order number
+4 NEW LRCPRS,LRFULL,LRPKG,LRSTATUS,LRRES,LRADFN
+5 SET LRCPRS=$PIECE($GET(^LRO(69,LRODT,1,LRSN,0)),"^",11)
+6 IF LRCPRS=""
SET ^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC)="No CPRS order number"
QUIT
+7 ;
+8 ;Need full accession number (ex. "SP 18 34") when checking
+9 ;for missing alerts and for possible MailMan messages
+10 SET LRFULL=$GET(^LRO(68,LRSS,1,LRAD,1,LRAC,.2))
+11 ;
+12 ;This should never be null, but checking nevertheless.
+13 IF LRFULL=""
SET ^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC)="No accession in File 68 at .2 level."
QUIT
+14 ;
+15 ;Setting date/time levels in ^XTMP using variable LRDTTM
+16 ;so will only have to check recent dates/times the search was executed
+17 ;if reviewing the global and the search runs multiple times daily
+18 ;
+19 ;is package reference missing
+20 SET LRPKG=$PIECE($GET(^OR(100,LRCPRS,4)),";",4,5)
+21 IF LRPKG=""
Begin DoDot:1
+22 DO MSGINIT
+23 SET LRLINE=LRLINE+1
+24 SET ^XTMP("AP ALERT MESSAGE "_LREDATE,LRLINE)=" - is missing package reference for order "_LRCPRS_"."
+25 SET ^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC,"NO_PKG_REF")=LRCPRS_"^Missing package reference"
End DoDot:1
+26 ;
+27 ;is status correct
+28 SET LRSTATUS=$PIECE($GET(^OR(100,LRCPRS,3)),"^",3)
+29 IF LRSTATUS'=2
Begin DoDot:1
+30 IF '$DATA(^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC))
DO MSGINIT
+31 SET LRLINE=LRLINE+1
+32 SET ^XTMP("AP ALERT MESSAGE "_LREDATE,LRLINE)=" - has incorrect status of "_LRSTATUS_" for order "_LRCPRS_"."
+33 SET ^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC,"INCORRECT_STATUS")=LRCPRS_"^Incorrect status of "_LRSTATUS
End DoDot:1
+34 ;
+35 ;Is Results Date/Time set
+36 SET LRRES=$PIECE($GET(^OR(100,LRCPRS,7)),"^")
+37 IF LRRES=""
Begin DoDot:1
+38 IF '$DATA(^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC))
DO MSGINIT
+39 SET LRLINE=LRLINE+1
+40 SET ^XTMP("AP ALERT MESSAGE "_LREDATE,LRLINE)=" - has no results date/time for order "_LRCPRS_"."
+41 SET ^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC,"NO_RESULTS_DATE/TIME")=LRCPRS_"^No results date/time"
End DoDot:1
+42 ;
+43 ;was alert generated?
+44 ;alerts are only sent for Patient (#2) file
+45 SET LRADFN=$PIECE(^OR(100,LRCPRS,0),"^",2)
+46 IF $PIECE(LRADFN,";",2)["DPT"
Begin DoDot:1
+47 SET LRADFN=$PIECE(LRADFN,";")
+48 DO CHKALERT
End DoDot:1
+49 QUIT
+50 ;
MSGINIT ;
+1 ;First time issue found for this accession
+2 SET LRLINE=LRLINE+1
+3 SET ^XTMP("AP ALERT MESSAGE "_LREDATE,LRLINE)=" "_LRFULL_":"
+4 QUIT
+5 ;
CHKALERT ;
+1 NEW LRALERT,LRHIT,LRPNM
+2 SET LRALERT=""
SET LRHIT=0
+3 FOR
SET LRALERT=$ORDER(^XTV(8992.1,"C",LRADFN,LRALERT))
if LRALERT=""
QUIT
if LRHIT
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^XTV(8992.1,LRALERT,2)),"^",2)=LRFULL
SET LRHIT=1
End DoDot:1
+5 IF 'LRHIT
Begin DoDot:1
+6 SET LRPNM=$PIECE(^DPT(LRADFN,0),"^")
+7 IF '$DATA(^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC))
DO MSGINIT
+8 SET LRLINE=LRLINE+1
+9 SET ^XTMP("AP ALERT MESSAGE "_LREDATE,LRLINE)=" - *** did not generate an alert. ***"
+10 ;not sending patient name in MailMan message in case this would violate CRISP
+11 ;setting into ^XTMP to aid in research if needed
+12 SET ^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC,"NO_ALERT")=LRFULL_"^"_LRCPRS_"^"_LRPNM_"^Missing alert"
+13 SET ^XTMP("AP NO ALERT "_LREDATE)=""
End DoDot:1
+14 QUIT
+15 ;
END ;Send alerts and MailMan messages
+1 ;LRDUZ is null if search executed by TaskMan
+2 ;
+3 ;Issues were found
+4 IF $DATA(^XTMP("AP ALERT MESSAGE "_LREDATE))
Begin DoDot:1
+5 DO MAIL
+6 IF $DATA(^XTMP("AP NO ALERT "_LREDATE))
DO ALERT
QUIT
+7 ;Issues were found by none are missing alerts
+8 DO ALERT3
End DoDot:1
+9 ;
+10 ;No issues were found
+11 ;Do not send alert and MailMan message if executed by TaskMan
+12 IF '$DATA(^XTMP("AP ALERT MESSAGE "_LREDATE))
IF LRDUZ]""
Begin DoDot:1
+13 DO MAIL2
DO ALERT2
End DoDot:1
+14 ;
+15 KILL ^XTMP("AP ALERT MESSAGE "_LREDATE),^XTMP("AP NO ALERT "_LREDATE)
+16 SET ^XTMP(LRSUB,LRDTTM,.1)=$SELECT($DATA(^XTMP(LRSUB,LRDTTM)):"Issue(s) found",1:"Nothing found")
+17 SET ^XTMP(LRSUB,LRDTTM,.2)="Date Range: "_$$FMTE^XLFDT(LRSDATE)_" to: "_$$FMTE^XLFDT(LREDATE)
+18 LOCK -^XTMP(LRSUB)
+19 QUIT
+20 ;
MAIL ;
+1 NEW LRMRANGE,LRMTEXT,LRMSUB,LRMY,LRMZ,LRMIN
+2 SET ^XTMP("AP ALERT MESSAGE "_LREDATE,1)="Anatomic Pathology Alert Search Issues Found"
+3 SET ^XTMP("AP ALERT MESSAGE "_LREDATE,2)=" "
+4 SET LRMRANGE=$SELECT(LRDUZ]"":"Date ",1:"Date/Time ")_"Range Searched: "_$$FMTE^XLFDT(LRSDATE)
+5 SET LRMRANGE=LRMRANGE_" to: "_$SELECT(LRDUZ]"":$PIECE($$FMTE^XLFDT(LREDATE),"@"),1:$$FMTE^XLFDT(LREDATE))
+6 SET ^XTMP("AP ALERT MESSAGE "_LREDATE,3)=LRMRANGE
+7 SET ^XTMP("AP ALERT MESSAGE "_LREDATE,4)=" "
+8 SET LRMTEXT="^XTMP(""AP ALERT MESSAGE ""_LREDATE)"
+9 SET LRMSUB="Anatomic Pathology Alert Search Issues Found"
+10 ;
+11 ;send to user if manually running the routine
+12 IF LRDUZ]""
SET LRMY(LRDUZ)=""
+13 SET LRMY("G.LMI")=""
+14 ;
+15 SET LRMIN("FROM")="Anatomic Pathology Missing Alert Search"
+16 DO SENDMSG^XMXAPI(DUZ,LRMSUB,LRMTEXT,.LRMY,.LRMIN,.LRMZ,"")
+17 QUIT
+18 ;
ALERT ;
+1 ;Individual alerts are sent for each accession which is missing an alert
+2 ;"X" prefixed variables are needed for sending alerts
+3 NEW LRTXT,XQAMSG,XQA,XQAID,LRSS,LRAD,LRAC,LRALERT
+4 SET LRTXT="*** ALERT NOT SENT FOR ACCESSION: "
+5 SET (LRSS,LRAD,LRAC)=""
+6 FOR
SET LRSS=$ORDER(^XTMP(LRSUB,LRDTTM,LRSS))
if LRSS=""
QUIT
Begin DoDot:1
+7 FOR
SET LRAD=$ORDER(^XTMP(LRSUB,LRDTTM,LRSS,LRAD))
if LRAD=""
QUIT
Begin DoDot:2
+8 FOR
SET LRAC=$ORDER(^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC))
if LRAC=""
QUIT
Begin DoDot:3
+9 SET LRFULL=$PIECE($GET(^XTMP(LRSUB,LRDTTM,LRSS,LRAD,LRAC,"NO_ALERT")),"^")
+10 if LRFULL=""
QUIT
+11 ;need to re-set XQAID and XQA because it is killed if sending multiple
+12 ;alerts
+13 SET XQAID="Missing Alert"
+14 IF LRDUZ]""
SET XQA(LRDUZ)=""
+15 SET XQA("G.LMI")=""
+16 SET XQAMSG=LRTXT_LRFULL_" ***"
+17 SET LRALERT=$$SETUP1^XQALERT
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
MAIL2 ;
+1 ;This section is only called if a user manually invoked the option.
+2 NEW LRMRANGE,LRMTEXT,LRMSUB,LRMY,LRMZ,LRMIN
+3 SET ^XTMP("AP ALERT MESSAGE "_LREDATE,1)=" "
+4 SET ^XTMP("AP ALERT MESSAGE "_LREDATE,2)="No missing Anatomic Pathology alert issues found on "
+5 SET ^XTMP("AP ALERT MESSAGE "_LREDATE,2)=^XTMP("AP ALERT MESSAGE "_LREDATE,2)_$$FMTE^XLFDT(LRDTTM,"MZ")_"."
+6 SET LRMRANGE="Date Range Searched: "_$$FMTE^XLFDT(LRSDATE)
+7 SET LRMRANGE=LRMRANGE_" to: "_$SELECT(LRDUZ]"":$PIECE($$FMTE^XLFDT(LREDATE),"@"),1:$$FMTE^XLFDT(LREDATE))
+8 SET ^XTMP("AP ALERT MESSAGE "_LREDATE,3)=LRMRANGE
+9 SET ^XTMP("AP ALERT MESSAGE "_LREDATE,4)=" "
+10 SET LRMTEXT="^XTMP(""AP ALERT MESSAGE ""_LREDATE)"
+11 SET LRMSUB="No Anatomic Pathology Alert Search Issues Found"
+12 ;
+13 ;send to person running the routine
+14 SET LRMY(LRDUZ)=""
+15 SET LRMY("G.LMI")=""
+16 ;
+17 SET LRMIN("FROM")="Anatomic Pathology Missing Alert Search"
+18 DO SENDMSG^XMXAPI(LRDUZ,LRMSUB,LRMTEXT,.LRMY,.LRMIN,.LRMZ,"")
+19 KILL ^XTMP("AP ALERT MESSAGE "_LREDATE)
+20 QUIT
+21 ;
ALERT2 ;
+1 ;This section is only called if a user manually invoked the search option.
+2 NEW XQAMSG,XQA,XQAID,LRALERT
+3 SET XQAID="Missing Alert Search"
+4 SET XQA(LRDUZ)=""
+5 SET XQA("G.LMI")=""
+6 SET XQAMSG="No Missing AP Alerts Found on "_$$FMTE^XLFDT(LRDTTM,"MZ")
+7 SET LRALERT=$$SETUP1^XQALERT
+8 QUIT
+9 ;
ALERT3 ;
+1 NEW XQAMSG,XQA,XQAID,LRALERT
+2 SET XQAID="Missing Alert Search"
+3 IF LRDUZ]""
SET XQA(LRDUZ)=""
+4 SET XQA("G.LMI")=""
+5 SET XQAMSG="Issues(s) found but no missing AP alerts on "_$$FMTE^XLFDT(LRDTTM,"MZ")
+6 SET LRALERT=$$SETUP1^XQALERT
+7 QUIT
+8 ;
LOCKED ;Routine was already being executed by time a user or TaskMan started
+1 ;This should be a rare occurrence.
+2 NEW XQAMSG,XQA,XQAID,LRALERT,%
+3 DO NOW^%DTC
+4 SET XQAID="Missing Alert Search"
+5 IF LRDUZ]""
SET XQA(LRDUZ)=""
+6 SET XQA("G.LMI")=""
+7 SET XQAMSG="Missing Alert Search already running - "_$$FMTE^XLFDT(%,"MZ")
+8 SET LRALERT=$$SETUP1^XQALERT
+9 QUIT
