Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRAPUALT

LRAPUALT.m

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