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

BLRUTIL8.m

Go to the documentation of this file. 
  1. BLRUTIL8 ;IHS/MSC/MKK - MISC IHS LAB UTILITIES (Cont) ; 01-Jun-2016 06:49 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1037,1039**;NOV 01, 1997;Build 38
  1.  ;
  1. DUPDNAME ; EP - Find Instances of Duplicate DataNames
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:$$DUPNAMEI()="Q"
  1.  ;
  1.  F  S DATADESC=$O(^DD(63.04,"B",DATADESC))  Q:DATADESC=""!(QFLG="Q")  D DUPNAMEL
  1.  ;
  1.  ; W !!,?4,"Number of Duplicate Datanames = ",CNT
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
  1.  W !!,?4,DATANCNT," DataNames Analyzed."
  1.  W !!,?9,$S(CNT:CNT,1:"No")," Duplicate DataName",$S(CNT=1:"",1:"s"),"."
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1034
  1.  ;
  1.  D ^%ZISC
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. DUPNAMEI() ; EP - Initialization
  1.  D SETBLRVS("DUPDNAME")
  1.  ;
  1.  S HEADER(1)="Duplicate DataNames"
  1.  S HEADER(2)="File 63.04"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  D HEADONE^BLRGMENU(.HDRONE)
  1.  ;
  1.  S HEADER(3)=" "
  1.  S $E(HEADER(4),10)="#"
  1.  S $E(HEADER(4),20)="Description"
  1.  S $E(HEADER(4),50)="Last Edit"
  1.  S $E(HEADER(4),65)="F 60"
  1.  ;
  1.  D ^%ZIS
  1.  I POP D  Q "Q"
  1.  . W !,?4,"Invalid DEVICE call.  Routine Ends."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  U IO
  1.  ;
  1.  S (CNT,PG)=0
  1.  S MAXLINES=(IOSL-4),LINES=MAXLINES+10
  1.  S QFLG="NO"
  1.  S DATADESC=""
  1.  S DATANCNT=0 ; IHS/MSC/MKK - LR*5.2*1034
  1.  Q "OK"
  1.  ;
  1. DUPNAMEL ; EP - Line of Data
  1.  Q:$$DUPNAMEC(.DUPNAMEA)=0
  1.  ;
  1.  I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)  Q:QFLG="Q"
  1.  ;
  1.  S (CNTDN,DATANAME)=0
  1.  F  S DATANAME=$O(DUPNAMEA(DATANAME))  Q:DATANAME<1!(QFLG="Q")  D
  1.  . I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)  Q:QFLG="Q"
  1.  . ;
  1.  . S CNTDN=CNTDN+1
  1.  . W $J(CNTDN,3)
  1.  . W ?9,DATANAME
  1.  . W ?19,$E(DATADESC,1,28)
  1.  . S CREATEDT=$G(DUPNAMEA(DATANAME,"DT"))
  1.  . W:$L(CREATEDT) ?49,$$FMTE^XLFDT(CREATEDT,"5DZ")
  1.  . W ?65,$O(^LAB(60,"C","CH;"_DATANAME_";1",0))
  1.  . W !
  1.  . S LINES=LINES+1
  1.  ;
  1.  W !
  1.  S LINES=LINES+1
  1.  S CNT=CNT+1
  1.  Q
  1.  ;
  1. DUPNAMEC(ARRAY) ; EP - Check on the DataName
  1.  S DATANCNT=DATANCNT+1  ; IHS/MSC/MKK - LR*5.2*1034
  1.  ;
  1.  NEW DN,NUMDUPS
  1.  ;
  1.  K ARRAY
  1.  ;
  1.  S (DN,NUMDUPS)=0
  1.  F  S DN=$O(^DD(63.04,"B",DATADESC,DN))  Q:DN<1  D
  1.  . S NUMDUPS=NUMDUPS+1
  1.  . S ARRAY(DN)=""
  1.  . S ARRAY(DN,"DT")=$G(^DD(63.04,DN,"DT"))
  1.  ;
  1.  Q $S(NUMDUPS<2:1,1:0)
  1.  ;
  1. SETBLRVS(TWO) ; EP - Use the STACK to find the Routine and set the BLRVRN variable(S)
  1.  ; S CONTXT=$STACK(-1)-1
  1.  ; S:CONTXT<1 CONTXT=1
  1.  ; S PLACE=$STACK(CONTXT,"PLACE")
  1.  ; S BLRVERN=$P($P(PLACE,"^",2)," ")
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039 - Don't use $STACK
  1.  K BLRVERN,BLRVERN2
  1.  ;
  1.  S BLRVERN=$P($P($T(+1),";")," ")
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1039
  1.  S:$L($G(TWO)) BLRVERN2=TWO
  1.  Q
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
  1. ARRIVETM(LRDFN,LRSS,LRIDT) ; EP - Print Arrival Time on Interim Report -- called from LRRP1
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRDFN,LRSS,LRIDT,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:LRSS="MI"  ; Micro Interim Reports already has RECEIVED date.
  1.  ;
  1.  S UID=$G(^LR(LRDFN,LRSS,LRIDT,"ORU"))
  1.  Q:$L(UID)<1
  1.  ;
  1.  S LRC=$Q(^LRO(68,"C",UID))
  1.  Q:$QS(LRC,3)'=UID
  1.  S LRAA=$QS(LRC,4),LRAD=$QS(LRC,5),LRAN=$QS(LRC,6)
  1.  S ARRIVTI=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA,12,"I") ; Arrival Time Internal (FileMan)
  1.  Q:ARRIVTI<1
  1.  ;
  1.  I LRSS'="MI" D
  1.  . S ARRIVTE="Lab Arrival Date/Time:"_$$FMTE^XLFDT(ARRIVTI,"2MZ") ; Arrival Time External
  1.  . W ?(IOM-$L(ARRIVTE)-1),ARRIVTE
  1.  Q
  1.  ;
  1.  ;
  1.  ; Send MAILMAN/ALERT to a specified MAIL GROUP
  1. MAILALMI(MESSAGE,MSGARRAY,FROMWHOM,NOUSER,MAILGROUP) ; EP - Generic MAILER/ALERTER - allows any MailGroup
  1.  NEW MAILARRY
  1.  ;
  1.  S MAILGROUP="G."_$G(MAILGROUP,"LMI")
  1.  ;
  1.  ; Send MESSAGE string as ALERT
  1.  D SNDALERT(MESSAGE,$G(NOUSER),MAILGROUP)
  1.  ;
  1.  ; Setup variables for sending MailMan e-mail
  1.  I $L($G(MSGARRAY(1))) M MAILARRY=MSGARRAY
  1.  ;
  1.  I $L($G(MSGARRAY(1)))<1 D     ; If MSGARRAY null, create generic array
  1.  . S MAILARRY(1)="The Subject of this email is the message:"
  1.  . S MAILARRY(2)="     "_MESSAGE
  1.  ;
  1.  I $G(FROMWHOM)="" S FROMWHOM="RPMS Lab Package"
  1.  ;
  1.  D SENDMAIL(MESSAGE,.MAILARRY,FROMWHOM,$G(NOUSER),MAILGROUP)
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. SNDALERT(ALERTMSG,NOUSER,MAILGROUP) ; EP - Send Alert
  1.  S XQAMSG=ALERTMSG
  1.  S XQA(MAILGROUP)=""
  1.  ;
  1.  ; If User NOT a member of the Mail Group, send them alert also, but
  1.  ; If-And-Only-If the NOUSER variable is null.
  1.  S:$G(NOUSER)=""&($$NINMGRP(MAILGROUP,DUZ)) XQA(DUZ)=""
  1.  ;
  1.  S X=$$SETUP1^XQALERT
  1.  K XQA,XQAMSG
  1.  Q:X
  1.  ;
  1.  ; If ALERT call failed, store information
  1.  NEW SUBSCRPT
  1.  S SUBSCRPT="BLR Alert^"_+$H_"^"_$J
  1.  S ^XTMP(SUBSCRPT,0)=$$FMADD^XLFDT($$DT^XLFDT,90)_"^"_$$DT^XLFDT_"^"_"Lab Package Alert."
  1.  S ^XTMP(SUBSCRPT,1)="Alert was not sent."
  1.  S ^XTMP(SUBSCRPT,2)="  Message that should have been sent follows:"
  1.  S ^XTMP(SUBSCRPT,3)="     "_ALERTMSG
  1.  S ^XTMP(SUBSCRPT,4)="  ALERT Error Message Follows:"
  1.  S ^XTMP(SUBSCRPT,5)="     "_XQALERR
  1.  Q
  1.  ;
  1.  ;
  1.  ; Send MailMan E-mail to MailGroup
  1. SENDMAIL(MAILMSG,MAILARRY,FROMWHOM,NOUSER,MAILGROUP) ; EP 
  1.  NEW DIFROM
  1.  ;
  1.  K XMY
  1.  S XMY(MAILGROUP)=""
  1.  ;
  1.  ; If User not part of MailGroup, send them e-mail also, but
  1.  ; If-And-Only-If the NOUSER variable is null.
  1.  S:$G(NOUSER)=""&($$NINMGRP(MAILGROUP,DUZ)) XMY(DUZ)=""
  1.  ;
  1.  S LRBLNOW=$E($$NOW^XLFDT,1,12)
  1.  ;
  1.  S XMSUB=MAILMSG
  1.  S XMTEXT="MAILARRY("
  1.  S XMDUZ=FROMWHOM
  1.  S XMZ="NOT OKAY"
  1.  D ^XMD
  1.  ;
  1.  I $G(XMMG)'=""!(XMZ="NOT OKAY") D
  1.  . NEW SUBSCRPT,ARRAY
  1.  . S SUBSCRPT="MailMan Message Failure for Group "_MAILGROUP_"^"_$$HTFM^XLFDT($H)_"^"_$J
  1.  . S ^XTMP(SUBSCRPT,0)=$$FMADD^XLFDT($$DT^XLFDT,90)_"^"_$$DT^XLFDT_"^"_"Lab Package MailMan Message."
  1.  . S ^XTMP(SUBSCRPT,1)="MailMan Message was not sent."
  1.  . S ^XTMP(SUBSCRPT,2)="  Message that should have been sent follows:"
  1.  . S ARRAY=0
  1.  . F  S ARRAY=$O(MAILARRY(ARRAY))  Q:ARRAY<1  D
  1.  .. S ^XTMP(SUBSCRPT,(ARRAY+2))="     "_$G(MAILARRY(ARRAY))
  1.  ;
  1.  K X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y   ; Cleanup
  1.  Q
  1.  ;
  1. NINMGRP(MAILGROUP,USERDUZ) ; EP - Is User NOT a member of the MailGroup?
  1.  NEW MGIEN,XMDUZ,Y
  1.  S MGIEN=+$$FIND1^DIC(3.8,,,$P(MAILGROUP,".",2))
  1.  Q:MGIEN<1 0
  1.  ;
  1.  S XMDUZ=USERDUZ,Y=MGIEN
  1.  D CHK^XMA21
  1.  Q '$T
  1.  ;
  1. RJZF(NUM,LEN) ; EP - Right Justify, Zero Fill function
  1.  Q $S((NUM'?.N):"",1:$TR($J(NUM,LEN)," ","0"))   ; If NUM variable not a number, return NULL
  1.  ;
  1.  ; The following is called from LR7OF1
  1.  ; If Urgency is ASAP or STAT or Hospital Location["EMER", send
  1.  ; Alert & E-Mail to LAB HIGH URGENCY NOTIFICATION Mail Group
  1. IHSURGNT ; EP 
  1.  Q:+$$GET^XPAR("PKG","BLR EMERGENCY ALERT",1,"Q")<1   ; Skip if XPAR is 'OFF'
  1.  Q:+$G(ORIFN)<1    ; Skip if file 100 IEN < 1
  1.  ;
  1.  NEW HOSPDIV,LABORD,MESSAGE,MSGARRAY,URGSTR
  1.  ;
  1.  S HOSPDIV=$$UP^XLFSTR($$GET1^DIQ(100,ORIFN,"PATIENT LOCATION"))
  1.  S URGSTR=$$UP^XLFSTR($$GET1^DIQ(62.05,+$$VALUE^ORCSAVE2(ORIFN,"URGENCY"),.01))
  1.  ;
  1.  ; Skip if not URGENT and not ASAP and not from Emergency room
  1.  Q:URGSTR'["STAT"&(URGSTR'["ASAP")&(HOSPDIV'["EMER")
  1.  ;
  1.  S LABORD=+$$GET1^DIQ(69.01,+$G(LRSN)_","_+$G(LRODT),9.5)
  1.  S:LABORD<1 LABORD=+$$GET1^DIQ(100,ORIFN,"PACKAGE REFERENCE")
  1.  ;
  1.  S MESSAGE="**URGENT** Lab Order:"_LABORD_"  Location:"_HOSPDIV_"  HRCN:"_$G(HRCN)
  1.  ;
  1.  S MSGARRAY(1)="Lab Order #:"_LABORD_"  OERR #:"_ORIFN_" detail:"
  1.  S MSGARRAY(2)=" "
  1.  S MSGARRAY(3)=$J("",5)_"Patient Name:"_$G(LRPNM)_"  HRCN:"_$G(HRCN)
  1.  S MSGARRAY(4)=" "
  1.  S MSGARRAY(5)=$J("",10)_"TEST:"_$P($G(MSG(5)),U,5)
  1.  ;
  1.  D MAILALMI^BLRUTIL8(MESSAGE,.MSGARRAY,,1,"LAB HIGH URGENCY NOTIFICATION")
  1.  Q
  1.  ;
  1.  ;
  1. LABGLOBR ; EP - Given Accession number/UID, list Data from Files 68, 69 & 63.
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:$$DETAILIN("DETAIL")="Q"
  1.  ;
  1.  D LRASDATA(LRAA,LRAD,LRAN,9)
  1.  ;
  1.  D ORDRDATA
  1.  ;
  1.  D LABDATA
  1.  ;
  1.  D PRESSKEY^BLRGMENU(4)
  1.  Q
  1.  ;
  1. DETAILIN(SUBRTN) ; EP - Initialize variables
  1.  NEW COL,COL2
  1.  ;
  1.  D ^XBCLS
  1.  D ^LRWU4
  1.  W !!
  1.  ;
  1.  I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))<1 Q $$BADSTUFF^BLRUTIL7("Accession does not Exist.")
  1.  ;
  1.  S LRSS=$$GET1^DIQ(68,LRAA,.02,"I")
  1.  S LRAAIEN=LRAN_","_LRAD_","_LRAA
  1.  S ORDERNUM=$$GET1^DIQ(68.02,LRAAIEN,14,"I")
  1.  S LRAS=$$GET1^DIQ(68.02,LRAAIEN,15)
  1.  S UID=$$GET1^DIQ(68.02,LRAAIEN,16)
  1.  ;
  1.  Q "OK"
  1.  ;
  1.  ;
  1. LRASDATA(LRAA,LRAD,LRAN,LM,RM) ; EP - Display File 68 Data
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRAA,LRAD,LRAN,NOPRESS,LM,RM,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D ^XBCLS
  1.  ;
  1.  W !
  1.  D LINEMSG("Accession (#68) file data","=",5)
  1.  ;
  1.  S NOMORE="^LRO(68,"_LRAA_",1,"_LRAD_",1,"_LRAN
  1.  S NOMOREL=$L(NOMORE)
  1.  S LETSGO=NOMORE_")"
  1.  ;
  1.  S LM=$G(LM,4)            ; Left Margin
  1.  S RM=$G(RM,(IOM-5))          ; Right Margin
  1.  ;
  1.  S STR1=$Q(@LETSGO@(""))
  1.  W ?LM,STR1,"="  S TAB=$X  D LINEWRAP^BLRGMENU(TAB,@STR1,(RM-TAB)) W !
  1.  F  S STR1=$Q(@STR1)  Q:STR1=""!($E(STR1,1,NOMOREL)'=NOMORE)  D
  1.  . W ?(LM+5),STR1,"=" S TAB=$X
  1.  . D LINEWRAP^BLRGMENU(TAB,@STR1,(RM-TAB)) W !
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. ORDRDATA ; EP - Display data from the ORDER file
  1.  NEW ORDERDT,LRSN
  1.  ;
  1.  W !
  1.  D LINEMSG("Lab Order Entry (#69) file Data","=",5)
  1.  ;
  1.  I +ORDERNUM<1 W ?7,"No Order File Data",!  Q	
  1.  ;
  1.  S LRODT=0
  1.  F  S LRODT=$O(^LRO(69,"C",ORDERNUM,LRODT))  Q:LRODT<1  D
  1.  . S LRSP=0
  1.  . F  S LRSP=$O(^LRO(69,"C",ORDERNUM,LRODT,LRSP))  Q:LRSP<1  D
  1.  .. D LRORDATA(LRODT,LRSP,9)
  1.  Q
  1.  ;
  1.  ;
  1. LRORDATA(LRODT,LRSP,LM,RM) ; EP - Display File 69 Data
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRODT,LRSP,LM,NOPRESS,RM,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S NOMORE="^LRO(69,"_LRODT_",1,"_LRSP
  1.  S NOMOREL=$L(NOMORE)
  1.  S LETSGO=NOMORE_")"
  1.  ;
  1.  S LM=$G(LM,4)            ; Left Margin
  1.  S RM=$G(RM,(IOM-5))          ; Right Margin
  1.  ;
  1.  S STR1=$Q(@LETSGO@(""))
  1.  W ?LM,STR1,"="  S TAB=$X  D LINEWRAP^BLRGMENU(TAB,@STR1,(RM-TAB)) W !
  1.  F  S STR1=$Q(@STR1)  Q:STR1=""!($E(STR1,1,NOMOREL)'=NOMORE)  D
  1.  . W ?(LM+5),STR1,"=" S TAB=$X
  1.  . D LINEWRAP^BLRGMENU(TAB,@STR1,(RM-TAB)) W !
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. LABDATA ; EP - Display Data from Lab Data file, if it exists -- LRAA,LRAD,LRAN must exist
  1.  NEW CNT,LRDFN,LRIDT,LRSUB,STR
  1.  ;
  1.  S LRDFN=$$GET1^DIQ(68.02,LRAAIEN,.01,"I")
  1.  S LRIDT=$$GET1^DIQ(68.02,LRAAIEN,13.5,"I")
  1.  S STR=$G(^LR(LRDFN,LRSS,LRIDT,0))
  1.  ;
  1.  I $D(^LR(LRDFN,LRSS,LRIDT))<1 D  Q
  1.  . W !
  1.  . D LINEONE("LRDFN:"_LRDFN_", LRIDT:"_LRIDT_", File #63 Data DOES NOT exist.","=")
  1.  . W !
  1.  ;
  1.  W !
  1.  D LINEMSG("Lab Data (#63) file data","=",5)
  1.  ;
  1.  D LABDATAD(LRDFN,LRSS,LRIDT,1,9)
  1.  Q
  1.  ;
  1.  ;
  1. LABDATAD(LRDFN,LRSS,LRIDT,NOPRESS,LM,RM) ; EP - Display File 63 Data
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRDFN,LRSS,LRIDT,NOPRESS,LM,RM,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S NOMORE="^LR("_LRDFN_","_$C(34)_LRSS_$C(34)_","_LRIDT
  1.  S NOMOREL=$L(NOMORE)
  1.  S LETSGO=NOMORE_")"
  1.  ;
  1.  S LM=$G(LM,4)            ; Left Margin
  1.  S RM=$G(RM,(IOM-5))      ; Right Margin
  1.  S NOPRESS=$G(NOPRESS,0)  ; Flag for PRESSKEY call below
  1.  ;
  1.  S STR1=$Q(@LETSGO@(""))
  1.  W ?LM,STR1,"="  S TAB=$X  D LINEWRAP^BLRGMENU(TAB,@STR1,(RM-TAB)) W !
  1.  F  S STR1=$Q(@STR1)  Q:STR1=""!($E(STR1,1,NOMOREL)'=NOMORE)  D
  1.  . W ?(LM+5),STR1,"=" S TAB=$X
  1.  . I $P(STR1,",",4)>1 D
  1.  .. S DN=$P($P(STR1,",",4),")")
  1.  .. S F60IEN=$O(^LAB(60,"C","CH;"_DN_";1",0))
  1.  .. W $S(LRSS="CH":$$GET1^DIQ(60,F60IEN,.01),1:""),!
  1.  . D LINEWRAP^BLRGMENU(TAB,@STR1,(RM-TAB)) W !
  1.  ;
  1.  Q:$G(NOPRESS)  ; Skip if the PRESSKEY call is not wanted
  1.  ;
  1.  D PRESSKEY^BLRGMENU(LM)
  1.  Q
  1.  ;
  1. LINEONE(MSG,FILLER) ; EP - Demarcation line
  1.  S MSG="@"_$TR(MSG," ","@")_"@"
  1.  S MSG=$TR($$CJ^XLFSTR(MSG,70)," @",FILLER_" ")
  1.  W ?4,MSG,!
  1.  Q
  1.  ;
  1. LINEMSG(MSG,FILLER,TAB) ; EP - Demarcation line, Version 2
  1.  S MSG="@"_$TR(MSG," ","@")_"@"
  1.  S MSG=$TR($$CJ^XLFSTR(MSG,(IOM-$S(+$G(TAB):TAB*2,1:0)))," @",FILLER_" ")
  1.  W ?($S(+$G(TAB):TAB-1,1:0)),MSG,!!
  1.  Q
  1.  ;
  1.  ;
  1. LAHREPT ; EP - ^LAH Update Date Report
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S HEADER(1)="^LAH Global Report"
  1.  D HEADERDT^BLRGMENU
  1.  D ^XBFMK
  1.  S DIR(0)="PO^68.2:EMZ"
  1.  D ^DIR
  1.  I +$G(DIRUT) D BADSTUFF^BLRUTIL7("No/Quit/Invalid Input.")  Q
  1.  ;
  1.  S LWL=+Y,LWLDESC=$P(Y,U,2)
  1.  ;
  1.  S HEADER(2)="LOAD/WORK LIST "_LWLDESC_" ["_LWL_"]"
  1.  D HEADERDT^BLRGMENU
  1.  D HEADONE^BLRGMENU(.HDRONE)
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  S HEADER(3)=" "
  1.  S $E(HEADER(4),5)="UID"
  1.  S $E(HEADER(4),20)="Create Date/Time"
  1.  S $E(HEADER(4),40)="Update Date/Time"
  1.  S $E(HEADER(4),60)="Time Difference"
  1.  ;
  1.  S MAXLINES=IOSL-4,LINES=MAXLINES+10
  1.  S (CNT,PG)=0,QFLG="NO"
  1.  ;
  1.  S (ISQN,ISQNCNT)=0
  1.  F  S ISQN=$O(^LAH(LWL,1,ISQN))  Q:ISQN<1!(QFLG="Q")  D
  1.  . S ISQNCNT=ISQNCNT+1
  1.  . S LRUID=$G(^LAH(LWL,1,ISQN,.3))
  1.  . Q:LRUID=""
  1.  . ;
  1.  . S STRZERO=$G(^LAH(LWL,1,ISQN,0))
  1.  . S CREATDTT=$P(STRZERO,U,10)
  1.  . S UPDTDTT=$P(STRZERO,U,11)
  1.  . ;
  1.  . I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)  Q:QFLG="Q"
  1.  . ;
  1.  . W ?4,LRUID
  1.  . W:CREATDTT ?19,$$FMTE^XLFDT(CREATDTT,"5MZ")
  1.  . W:UPDTDTT ?39,$$FMTE^XLFDT(UPDTDTT,"5MZ")
  1.  . I CREATDTT,UPDTDTT D
  1.  .. W:$E(CREATDTT,1,12)'=$E(UPDTDTT,1,12) ?60,$J($$FMDIFF^XLFDT(UPDTDTT,CREATDTT,3),13)
  1.  . W !
  1.  . S LINES=LINES+1
  1.  . S CNT=CNT+1
  1.  ;
  1.  W !!,?4,ISQNCNT," entries analyzed."
  1.  W !!,?9,$S(CNT:CNT,1:"No")," entr",$$PLURALI^BLRUTIL7(CNT)," with UIDs."
  1.  D PRESSKEY^BLRGMENU(4)
  1.  Q
  1.  ;
  1.  ; ============================= UTILITIES =============================
  1.  ;
  1. JUSTNEW ; EP - Generic RPMS EXCLUSIVE NEW
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1039