BLRCINDX ; IHS/OIT/MKK - Lab Accession File "C" Index "Orphan" Pointers Kill ; MAY 06, 2009 9:58 AM
;;5.2;IHS LABORATORY;**1026,1028,1031**;NOV 01, 1997
;;
;; Some code cloned from VA's LROC routine
;;
EP ; EP -- Entry Point
NEW BLRMMENU,BLRVERN,QFLG
;
D SETMENU
;
; Main Menu driver
D MENUDRFM^BLRGMENU("IHS Lab Accession File","""C"" Index Routines")
;
W !!
Q
;
S BLRVERN="BLRCINDX"
D ADDTMENU^BLRGMENU("DELOPRHE^BLRCINDX","Delete ""Orphan"" Entries")
D ADDTMENU^BLRGMENU("CIREPORT^BLRCINDX","""C"" Index Report")
D ADDTMENU^BLRGMENU("REPORT^BLRCINDX","""Orphan"" Entries Report")
Q
;
DELOPRHE ; EP -- Delete Orphan Entries in Accession File's "C" Index
NEW KCNT,LRAA,LRAD,LRAN,LRCNT,LRROOT
NEW HEADER
;
D DELOEINI
;
F S UID=$O(^LRO(68,"C",UID)) Q:UID="" D
. F S LRAA=$O(^LRO(68,"C",UID,LRAA)) Q:LRAA<1 D
.. F S LRAD=$O(^LRO(68,"C",UID,LRAA,LRAD)) Q:LRAD<1 D
... F S LRAN=$O(^LRO(68,"C",UID,LRAA,LRAD,LRAN)) Q:LRAN<1 D
.... D DELOEKLN
;
D DELOEFIN
;
Q
;
DELOEINI ; EP -- Delete Orphan Entries INItialization
S HEADER(1)="IHS Lab Accession File"
S HEADER(2)="""C"" Index ""Orphan"" Deletion"
D HEADERDT^BLRGMENU
;
D DISABLE^%NOJRN ; Disable Journalling
W ?5,"Journalling stopped for this process only.",!
W ?5,"Deleting ""Orphan"" Pointers in Accession File's ""C"" Index",!!
;
S LRROOT="^LRO(68,""C"")"
S (KCNT,LRAA,LRAD,LRAN,LRCNT)=0
S UID=""
;
W !,?5
Q
;
DELOEKLN ; EP -- Delete Orphan Entries Kill LiNes
S LRCNT=LRCNT+1
;
I $X>70 W !,?5
;
; Accession exists, so skip this entry
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
. W:LRCNT>0&((LRCNT#1000=0)) "."
;
K ^LRO(68,"C",UID)
S KCNT=KCNT+1
W:LRCNT>0&((LRCNT#1000=0)) "*"
Q
;
DELOEFIN ; EP - Delete Orphan Entries FINal lines
D ENABLE^%NOJRN ; Enable Journalling again
W ?5,"Journalling restarted.",!!
;
W ?5,"Number of Pointers in ""C"" Index = ",LRCNT,!
W ?5,"Number of ""Orphan"" Pointers deleted from ""C"" Index = ",KCNT,!
;
D PRESSKEY()
Q
;
CIREPORT ; EP - Full "C" Index Report
NEW CNT,CNTACC,CNTKILL,CNTZERO,KCNT,LRAA,LRAD,LRAN,LRCNT
NEW OLDYEAR,LRROOT,UID,YEAR,YEARCNT
NEW DASHER,HEADER
;
D CIRCMPLD ; Compile the Data
D CIROUTD ; Print the Data
Q
;
CIRCMPLD ; EP -- "C" Index Report CoMPiLe Data
D CIRCMPDI
;
F S UID=$O(^LRO(68,"C",UID)) Q:UID="" D
. F S LRAA=$O(^LRO(68,"C",UID,LRAA)) Q:LRAA<1 D
.. F S LRAD=$O(^LRO(68,"C",UID,LRAA,LRAD)) Q:LRAD<1 D
... F S LRAN=$O(^LRO(68,"C",UID,LRAA,LRAD,LRAN)) Q:LRAN<1 D
.... D CIRCMPLC
;
D CIRCMPFL
;
Q
;
CIRCMPDI ; EP -- "C" Index Report CoMPile Data Initialization
S HEADER(1)="IHS Lab Accession File"
S HEADER(2)="""C"" Index Report"
D HEADERDT^BLRGMENU
;
W ?5,"Compilation of ""C"" Index Data Begins",!!
;
S LRROOT="^LRO(68,""C"")"
S (KCNT,LRAA,LRAD,LRAN,LRCNT)=0
S UID=""
;
W ?5
Q
;
CIRCMPLC ; EP -- "C" Index Report CoMPiLation Counts
S YEAR=$P($$FMTE^XLFDT(LRAD,"6D"),"/",3)
;
S LRCNT=LRCNT+1
;
I $X>70 W !,?5
;
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
. S YEARCNT(YEAR,LRAA,"VALID")=1+$G(YEARCNT(YEAR,LRAA,"VALID"))
. S:$E(UID,1,2)="00" YEARCNT(YEAR,LRAA,"VALID","00")=1+$G(YEARCNT(YEAR,LRAA,"VALID","00"))
. W:LRCNT>0&((LRCNT#1000=0)) "."
;
S KCNT=KCNT+1
S YEARCNT(YEAR,LRAA,"ORPHAN")=1+$G(YEARCNT(YEAR,LRAA,"ORPHAN"))
S:$E(UID,1,2)="00" YEARCNT(YEAR,LRAA,"ORPHAN","00")=1+$G(YEARCNT(YEAR,LRAA,"ORPHAN","00"))
W:LRCNT>0&((LRCNT#1000=0)) "*"
Q
;
CIRCMPFL ; EP -- "C" Index Report CoMPilation data Final Lines
W !,?5,"Compilation of ""C"" Index Data Ends",!!
;
W ?5,"Number of Pointers in ""C"" Index = ",LRCNT,!
W ?5,"Number of ""Orphan"" Pointers in ""C"" Index = ",KCNT,!
;
D PRESSKEY()
Q
;
CIROUTD ; EP -- "C" Index Report OUTput the Data
NEW BLRMMENU,BLRVERN,HEADER
;
D SETOMENU
;
; Main Menu driver
D MENUDRFM^BLRGMENU("IHS Lab Accession File","""C"" Index Routines")
;
Q
;
D ADDTMENU^BLRGMENU("CINTERPT^BLRCINDX","Interactive ""C"" Index Report")
D ADDTMENU^BLRGMENU("REPORTPR^BLRCINDX","Print ""C"" Index Report")
Q
;
CINTERPT ; EP -- Interactive Version of the report
NEW BLRCINDX,CNT,CNTACC,CNTKILL,CNTOZERO,CNTVZERO,LINES
NEW OLDYEAR,TOPBAR,TOTZERO,YEAR
;
S (CNT,CNTACC,CNTKILL,CNTZERO,LINES,OLDYEAR,YEAR)=0
F S YEAR=$O(YEARCNT(YEAR)) Q:YEAR="" D
. S LRAA=""
. F S LRAA=$O(YEARCNT(YEAR,LRAA)) Q:LRAA="" D
.. D CINTERPB
;
D BROWSEIT
;
D FINALBIT
Q
;
CINTERPB ; EP -- Interactive Version of Report -- Building Arrays
S:+$G(OLDYEAR)<1 OLDYEAR=YEAR
S CNT=CNT+1
I OLDYEAR'=YEAR&(CNT>0) S LINES=LINES+1 S BLRCINDX(LINES)=" "
S:OLDYEAR'=YEAR OLDYEAR=YEAR
S CNTKZERO=+$G(YEARCNT(YEAR,LRAA,"ORPHAN","00"))
S CNTVZERO=+$G(YEARCNT(YEAR,LRAA,"VALID","00"))
S TOTZERO=CNTVZERO+CNTKZERO
S CNTZERO=CNTZERO+TOTZERO
;
S LINES=LINES+1
S $E(BLRCINDX(LINES),5)=YEAR
S $E(BLRCINDX(LINES),10)=LRAA
S $E(BLRCINDX(LINES),15)=$P($G(^LRO(68,LRAA,0)),"^",1)
S $E(BLRCINDX(LINES),45)=$J($G(YEARCNT(YEAR,LRAA,"VALID")),8)
S:TOTZERO>0 $E(BLRCINDX(LINES),55)=$J(TOTZERO,8)
S $E(BLRCINDX(LINES),67)=$J($G(YEARCNT(YEAR,LRAA,"ORPHAN")),8)
S CNTACC=CNTACC+$G(YEARCNT(YEAR,LRAA,"VALID"))
S CNTKILL=CNTKILL+$G(YEARCNT(YEAR,LRAA,"ORPHAN"))
Q
;
BROWSEIT ; EP -- Use Browser to display report
S HEADER(3)=" "
D HEADERDT^BLRGMENU
;
S TOPBAR="YEAR LRAA Accession Description # Accs # 00 UIDs # Orphans"
S:+$G(YEARCNT(0))<1 TOPBAR="YEAR LRAA Accession Description # Accs # Orphans"
D BROWSE^DDBR("BLRCINDX","N",TOPBAR,,,5,24)
;
Q
;
FINALBIT ; EP -- Final section of interactive report
S $E(HEADER(4),45)=$J("# Accs",8)
S:CNTZERO>0 $E(HEADER(4),55)="# 00 UIDs"
S $E(HEADER(4),67)=$J("# Orphans",8)
;
D HEADERDT^BLRGMENU
W ?14,"TOTAL"
W ?44,$J($G(CNTACC),8)
W:CNTZERO>0 ?55,$J(CNTZERO,8)
W ?67,$J($G(CNTKILL),8)
W !!
D PRESSKEY()
Q
;
REPORTPR ; EP -- Output Data
NEW CNT,CNTACC,CNTKILL,CNTOZERO,CNTVZERO,LINES,OLDYEAR,YEAR
NEW DASHER,HDR1,LINES,MAXLINES,PG,QFLG
NEW TOTLZERO
;
D REPORTPI
;
F S YEAR=$O(YEARCNT(YEAR)) Q:YEAR=""!(QFLG="Q") D
. S LRAA=""
. F S LRAA=$O(YEARCNT(YEAR,LRAA)) Q:LRAA=""!(QFLG="Q") D
.. D REPORTPL
;
I QFLG'="Q" D TOTATLNE
W !!
;
D ^%ZISC ; Close all the devices
;
D PRESSKEY()
Q
;
REPORTPI ; EP -- Print Report Initialization
S HEADER(1)="IHS Lab Accession File"
S HEADER(2)="""C"" Index Report"
S HEADER(3)=" "
S $E(HEADER(4),5)="YEAR"
S $E(HEADER(4),10)="LRAA"
S $E(HEADER(4),15)="Accession Description"
S $E(HEADER(4),45)=$J("# Accs",8)
S:+$G(YEARCNT(0))>0 $E(HEADER(4),55)=$J("# 00 UIDs",8)
S $E(HEADER(4),67)=$J("# Orphans",8)
;
S PG=0
S HDR1=0
S QFLG="NO"
;
D ^%ZIS
I POP D
. W !!,?10,"DEVICE could not be selected. Output will be to the screen.",!!
. D ^%ZISC
;
S MAXLINES=IOSL-3
S LINES=MAXLINES+10
;
U IO
S (CNT,CNTACC,CNTKILL,CNTOZERO,CNTVZERO,CNTZERO,OLDYEAR,TOTLZERO,YEAR)=0
Q
;
REPORTPL ; EP - Report Liner
S:+$G(OLDYEAR)<1 OLDYEAR=YEAR
;
I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDR1) I QFLG="Q" Q
;
I OLDYEAR'=YEAR S OLDYEAR=YEAR W:CNT>0 !
S CNT=CNT+1
;
S CNTKZERO=+$G(YEARCNT(YEAR,LRAA,"ORPHAN","00"))
S CNTVZERO=+$G(YEARCNT(YEAR,LRAA,"VALID","00"))
S TOTLZERO=CNTKZERO+CNTVZERO
;
W ?4,YEAR
W ?9,LRAA
W ?14,$E($P($G(^LRO(68,LRAA,0)),"^",1),1,23)
W ?44,$J($G(YEARCNT(YEAR,LRAA,"VALID")),8)
W:TOTLZERO>0 ?55,$J(TOTLZERO,8)
W ?67,$J($G(YEARCNT(YEAR,LRAA,"ORPHAN")),8)
W !
S LINES=LINES+1
;
S CNTACC=CNTACC+$G(YEARCNT(YEAR,LRAA,"VALID"))
S CNTZERO=CNTZERO+TOTLZERO
S CNTKILL=CNTKILL+$G(YEARCNT(YEAR,LRAA,"ORPHAN"))
Q
;
TOTATLNE ; EP - Totals Line for Report
S DASHER=$TR($J("",8)," ","-")
W ?44,DASHER
W:CNTZERO>0 ?55,DASHER
W ?67,DASHER
W !
W ?14,"TOTAL"
W ?44,$J($G(CNTACC),8)
W:CNTZERO>0 ?55,$J($G(CNTZERO),8)
W ?67,$J($G(CNTKILL),8)
Q
;
REPORT ; EP -- Report on orphan "C" index entries
NEW KCNT,LRAA,LRAD,LRAN,LRCNT,LRROOT,YEARCNT
NEW HEADER
;
D REPORTIN
;
F S UID=$O(^LRO(68,"C",UID)) Q:UID="" D
. F S LRAA=$O(^LRO(68,"C",UID,LRAA)) Q:LRAA<1 D
.. F S LRAD=$O(^LRO(68,"C",UID,LRAA,LRAD)) Q:LRAD<1 D
... F S LRAN=$O(^LRO(68,"C",UID,LRAA,LRAD,LRAN)) Q:LRAN<1 D
.... D REPORTCW
;
D REPORTFL
Q
;
REPORTIN ; -- Report on orphan "C" index INitialization
S HEADER(1)="IHS Lab Accession File"
S HEADER(2)="""C"" Index ""Orphan"" Report"
D HEADERDT^BLRGMENU
;
W !,?5,"Counting ""Orphan"" Pointers in Accession File's ""C"" Index",!!
;
S LRROOT="^LRO(68,""C"")"
S (KCNT,LRAA,LRAD,LRAN,LRCNT)=0
S UID=""
;
W ?5
Q
;
REPORTCW ; EP -- Report on orphan "C" index Counts & Warm fuzzies
S YEAR=$P($$FMTE^XLFDT(LRAD,"6D"),"/",3)
;
I $X>70 W !,?5
S LRCNT=LRCNT+1
;
; Accession exists, so skip this entry
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
. S YEARCNT(YEAR,LRAA,"VALID")=1+$G(YEARCNT(YEAR,LRAA,"VALID"))
. S:$E(UID,1,2)="00" YEARCNT(YEAR,LRAA,"VALID","00")=1+$G(YEARCNT(YEAR,LRAA,"VALID","00"))
. W:LRCNT>0&((LRCNT#1000=0)) "."
;
; "Orphan" Entry
S KCNT=KCNT+1
S YEARCNT(YEAR,LRAA,"ORPHAN")=1+$G(YEARCNT(YEAR,LRAA,"ORPHAN"))
S:$E(UID,1,2)="00" YEARCNT(YEAR,LRAA,"ORPHAN","00")=1+$G(YEARCNT(YEAR,LRAA,"ORPHAN","00"))
W:LRCNT>0&((LRCNT#1000=0)) "*"
;
Q
;
REPORTFL ; EP -- Report on orphan "C" index Counts Final Lines
W !,?5,"Number of Pointers in ""C"" Index = ",LRCNT,!
W ?5,"Number of ""Orphan"" Pointers in ""C"" Index = ",KCNT,!
;
D PRESSKEY(5,"REPORT ENDS. Press RETURN Key")
Q
;
PRESSKEY(TAB,MSGSTR) ; EP
NEW TABSTR
;
S:+$G(TAB)<1 TAB=5
S TABSTR=$J("",+$G(TAB))_$S(+$L($G(MSGSTR)):$G(MSGSTR),1:"Press RETURN Key")
;
W !
D ^XBFMK
S DIR(0)="E"
S DIR("A")=TABSTR
D ^DIR
I $G(DUOUT) S QFLG="Q" ; If Fileman quit, then set Quit Flag
;
Q
;
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1028
; Silent Version of the DELOPRHE option -- Created for TaskMan Entries
SILENT ; EP
NEW KCNT,LRAA,LRAD,LRAN,LRCNT,LRROOT,STOREDTT
;
D SILENTI
;
F S UID=$O(^LRO(68,"C",UID)) Q:UID="" D
. F S LRAA=$O(^LRO(68,"C",UID,LRAA)) Q:LRAA<1 D
.. F S LRAD=$O(^LRO(68,"C",UID,LRAA,LRAD)) Q:LRAD<1 D
... F S LRAN=$O(^LRO(68,"C",UID,LRAA,LRAD,LRAN)) Q:LRAN<1 D
.... D SILENTD
;
S STOREDTT=$$NOW^XLFDT
S ^BLRCINDX(STOREDTT,LRCNT,KCNT)=""
;
D SILENTR
;
Q
;
SILENTI ; EP - Initialization
D DISABLE^%NOJRN
S LRROOT="^LRO(68,""C"")"
S (CNT,KCNT,LRAA,LRAD,LRAN,LRCNT)=0
S UID=""
Q
;
SILENTD ; EP - Silent Delete
S LRCNT=LRCNT+1
;
; Accession exists, so skip this entry
Q:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
;
K ^LRO(68,"C",UID)
S KCNT=KCNT+1
Q
;
SILENTR ; EP - Report on the Silent Deletes
NEW DATETIME,CNT1,CNT2,STR,STRLINE
NEW CNT ; IHS/MSC/MKK - LR*5.2*1031
;
D SILENTRI
;
D SILENTRC
;
Q:CNT<1 ; IHS/MSC/MKK - LR*5.2*1031 -- If latest # of Orphans = 0, don't send message
;
D SENDMAIL("Accession File ""C"" Index ""Orphans"" Report")
;
Q
;
SILENTRI ; EP - Initialization
S STR(1)=" "
S STR(2)=$$CJ^XLFSTR($$LOC^XBFUNC,70)
S STR(3)=" "
S $E(STR(4),45)="# of ""Orphan"""
S $E(STR(5),5)="Date/Time ^BLRCINDX Run"
S $E(STR(5),35)="# UIDs"
S $E(STR(5),45)="Deletions"
S STR(6)=$TR($J("",70)," ","-")
;
S (DATETIME)=0
S (CNT1,CNT2)=""
S STRLINE=6
S CNT=0 ; IHS/MSC/MKK - LR*5.2*1031
Q
;
SILENTRC ; EP - Compilation
F S DATETIME=$O(^BLRCINDX(DATETIME)) Q:DATETIME<1 D
. F S CNT1=$O(^BLRCINDX(DATETIME,CNT1)) Q:CNT1="" D
.. F S CNT2=$O(^BLRCINDX(DATETIME,CNT1,CNT2)) Q:CNT2="" D
... S STRLINE=STRLINE+1
... S $E(STR(STRLINE),5)=$$UP^XLFSTR($$FMTE^XLFDT(DATETIME,"5MPZ"))
... S $E(STR(STRLINE),35)=CNT1
... S $E(STR(STRLINE),45)=CNT2
... S CNT=CNT2 ; IHS/MSC/MKK - LR*5.2*1031 - Latest # of Orphans
Q
;
SENDMAIL(MAILMSG) ; EP -- Send MailMan E-mail to all users with LRSUPER key
NEW BADUSERS,DIFROM,ERRORS,HEREYAGO,LRSUPER,WHO,WHOCNT,YEARAGO
;
; Get "LRSUPER" Security Key IEN
D FIND^DIC(19.1,,,,"LRSUPER",,,,,"HEREYAGO")
S LRSUPER=+$G(HEREYAGO("DILIST",2,1))
Q:LRSUPER<1
;
S YEARAGO=$P($$HTE^XLFDT(+$H-365,"5DZ"),"/",3) ; Get year in CCYY format from 365 Days Ago
;
K XMY
S (WHO,WHOCNT)=0
F S WHO=$O(^VA(200,"AB",LRSUPER,WHO)) Q:WHO<1 D
. K ERRORS,X
. ; S X=+$P($$FMTE^XLFDT($$GET1^DIQ(3.7,WHO,"LATEST MAILMAN ACCESS DATE","I",,"ERRORS"),"5DZ"),"/",3)
. ; Q:X<YEARAGO ; Only send e-mail to those who have accessed MailMan within the past year
. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
. S X=$$FMDIFF^XLFDT($$DT^XLFDT,+$$GET1^DIQ(3.7,WHO,"LATEST MAILMAN ACCESS DATE","I",,"ERRORS"),1)
. Q:X>365 ; Only send e-mail to those who have accessed MailMan within the past year
. ; ----- END IHS/MSC/MKK - LR*5.2*1031
. ;
. S XMY(WHO)=""
. D:WHOCNT<1 MAILHEAD
. S STRLINE=STRLINE+1
. S $E(STR(STRLINE),5)=WHO
. S $E(STR(STRLINE),15)=$P($G(^VA(200,WHO,0)),"^")
. S WHOCNT=WHOCNT+1
;
S:WHOCNT<1 XMY("G.LMI")="" ; Send to members of LMI Mail Group iff no user has LRSUPER key
;
S XMSUB=MAILMSG
S XMTEXT="STR("
S XMDUZ="IHS Lab Maintenance"
S XMZ="NOT OKAY"
D ^XMD
;
I $G(XMMG)'=""!(XMZ="NOT OKAY") S ^BLRCINDX(STOREDTT,LRCNT,KCNT)="MAILMAN ERROR.^"_XMZ_"^"_XMMG
;
K X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y ; Cleanup
Q
;
MAILHEAD ; EP - E-Mail Header
D ADDONEL(.STR,.STRLINE," ")
D ADDONEL(.STR,.STRLINE,"E-Mail sent to the following:")
D ADDONEL(.STR,.STRLINE," ")
;
S STRLINE=STRLINE+1
S $E(STR(STRLINE),5)="File 200"
;
S STRLINE=STRLINE+1
S $E(STR(STRLINE),5)=" IEN"
S $E(STR(STRLINE),15)="Name"
;
S STRLINE=STRLINE+1
S $E(STR(STRLINE),5)="--------"
S $E(STR(STRLINE),15)=$TR($J("",30)," ","-")
Q
;
ADDONEL(ARRAY,LINE,STR) ; EP - Add 1 Line
S LINE=1+$G(LINE)
S ARRAY(LINE)=STR
Q
;
SILENTRB ; EP -- Report Browser
NEW DATETIME,CNT1,CNT2,STR,STRLINE
NEW HEADER,TOPBAR
;
S (DATETIME,STRLINE)=0
S (CNT1,CNT2)=""
D SILENTRC
;
S HEADER(1)="IHS Lab Accession File"
S HEADER(2)="""C"" Index ""Orphan"" Deletion"
S HEADER(3)=" "
;
S $E(TOPBAR,5)="Date/Time ^BLRCINDX Run"
S $E(TOPBAR,35)="# UIDS"
S $E(TOPBAR,45)="# of ""Orphan"" Deletions"
S TOPBAR=$$LJ^XLFSTR(TOPBAR,80)
;
D HEADERDT^BLRGMENU
D BROWSE^DDBR("STR","N",TOPBAR,,,5,24)
;
D PRESSKEY^BLRGMENU(5)
Q
;
; ----- END IHS/OIT/MKK - LR*5.2*1028
BLRCINDX ; IHS/OIT/MKK - Lab Accession File "C" Index "Orphan" Pointers Kill ; MAY 06, 2009 9:58 AM
+1 ;;5.2;IHS LABORATORY;**1026,1028,1031**;NOV 01, 1997
+2 ;;
+3 ;; Some code cloned from VA's LROC routine
+4 ;;
EP ; EP -- Entry Point
+1 NEW BLRMMENU,BLRVERN,QFLG
+2 ;
+3 DO SETMENU
+4 ;
+5 ; Main Menu driver
+6 DO MENUDRFM^BLRGMENU("IHS Lab Accession File","""C"" Index Routines")
+7 ;
+8 WRITE !!
+9 QUIT
+10 ;
+1 SET BLRVERN="BLRCINDX"
+2 DO ADDTMENU^BLRGMENU("DELOPRHE^BLRCINDX","Delete ""Orphan"" Entries")
+3 DO ADDTMENU^BLRGMENU("CIREPORT^BLRCINDX","""C"" Index Report")
+4 DO ADDTMENU^BLRGMENU("REPORT^BLRCINDX","""Orphan"" Entries Report")
+5 QUIT
+6 ;
DELOPRHE ; EP -- Delete Orphan Entries in Accession File's "C" Index
+1 NEW KCNT,LRAA,LRAD,LRAN,LRCNT,LRROOT
+2 NEW HEADER
+3 ;
+4 DO DELOEINI
+5 ;
+6 FOR
SET UID=$ORDER(^LRO(68,"C",UID))
IF UID=""
QUIT
Begin DoDot:1
+7 FOR
SET LRAA=$ORDER(^LRO(68,"C",UID,LRAA))
IF LRAA<1
QUIT
Begin DoDot:2
+8 FOR
SET LRAD=$ORDER(^LRO(68,"C",UID,LRAA,LRAD))
IF LRAD<1
QUIT
Begin DoDot:3
+9 FOR
SET LRAN=$ORDER(^LRO(68,"C",UID,LRAA,LRAD,LRAN))
IF LRAN<1
QUIT
Begin DoDot:4
+10 DO DELOEKLN
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+11 ;
+12 DO DELOEFIN
+13 ;
+14 QUIT
+15 ;
DELOEINI ; EP -- Delete Orphan Entries INItialization
+1 SET HEADER(1)="IHS Lab Accession File"
+2 SET HEADER(2)="""C"" Index ""Orphan"" Deletion"
+3 DO HEADERDT^BLRGMENU
+4 ;
+5 ; Disable Journalling
DO DISABLE^%NOJRN
+6 WRITE ?5,"Journalling stopped for this process only.",!
+7 WRITE ?5,"Deleting ""Orphan"" Pointers in Accession File's ""C"" Index",!!
+8 ;
+9 SET LRROOT="^LRO(68,""C"")"
+10 SET (KCNT,LRAA,LRAD,LRAN,LRCNT)=0
+11 SET UID=""
+12 ;
+13 WRITE !,?5
+14 QUIT
+15 ;
DELOEKLN ; EP -- Delete Orphan Entries Kill LiNes
+1 SET LRCNT=LRCNT+1
+2 ;
+3 IF $X>70
WRITE !,?5
+4 ;
+5 ; Accession exists, so skip this entry
+6 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
Begin DoDot:1
+7 IF LRCNT>0&((LRCNT#1000=0))
WRITE "."
End DoDot:1
QUIT
+8 ;
+9 KILL ^LRO(68,"C",UID)
+10 SET KCNT=KCNT+1
+11 IF LRCNT>0&((LRCNT#1000=0))
WRITE "*"
+12 QUIT
+13 ;
DELOEFIN ; EP - Delete Orphan Entries FINal lines
+1 ; Enable Journalling again
DO ENABLE^%NOJRN
+2 WRITE ?5,"Journalling restarted.",!!
+3 ;
+4 WRITE ?5,"Number of Pointers in ""C"" Index = ",LRCNT,!
+5 WRITE ?5,"Number of ""Orphan"" Pointers deleted from ""C"" Index = ",KCNT,!
+6 ;
+7 DO PRESSKEY()
+8 QUIT
+9 ;
CIREPORT ; EP - Full "C" Index Report
+1 NEW CNT,CNTACC,CNTKILL,CNTZERO,KCNT,LRAA,LRAD,LRAN,LRCNT
+2 NEW OLDYEAR,LRROOT,UID,YEAR,YEARCNT
+3 NEW DASHER,HEADER
+4 ;
+5 ; Compile the Data
DO CIRCMPLD
+6 ; Print the Data
DO CIROUTD
+7 QUIT
+8 ;
CIRCMPLD ; EP -- "C" Index Report CoMPiLe Data
+1 DO CIRCMPDI
+2 ;
+3 FOR
SET UID=$ORDER(^LRO(68,"C",UID))
IF UID=""
QUIT
Begin DoDot:1
+4 FOR
SET LRAA=$ORDER(^LRO(68,"C",UID,LRAA))
IF LRAA<1
QUIT
Begin DoDot:2
+5 FOR
SET LRAD=$ORDER(^LRO(68,"C",UID,LRAA,LRAD))
IF LRAD<1
QUIT
Begin DoDot:3
+6 FOR
SET LRAN=$ORDER(^LRO(68,"C",UID,LRAA,LRAD,LRAN))
IF LRAN<1
QUIT
Begin DoDot:4
+7 DO CIRCMPLC
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+8 ;
+9 DO CIRCMPFL
+10 ;
+11 QUIT
+12 ;
CIRCMPDI ; EP -- "C" Index Report CoMPile Data Initialization
+1 SET HEADER(1)="IHS Lab Accession File"
+2 SET HEADER(2)="""C"" Index Report"
+3 DO HEADERDT^BLRGMENU
+4 ;
+5 WRITE ?5,"Compilation of ""C"" Index Data Begins",!!
+6 ;
+7 SET LRROOT="^LRO(68,""C"")"
+8 SET (KCNT,LRAA,LRAD,LRAN,LRCNT)=0
+9 SET UID=""
+10 ;
+11 WRITE ?5
+12 QUIT
+13 ;
CIRCMPLC ; EP -- "C" Index Report CoMPiLation Counts
+1 SET YEAR=$PIECE($$FMTE^XLFDT(LRAD,"6D"),"/",3)
+2 ;
+3 SET LRCNT=LRCNT+1
+4 ;
+5 IF $X>70
WRITE !,?5
+6 ;
+7 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
Begin DoDot:1
+8 SET YEARCNT(YEAR,LRAA,"VALID")=1+$GET(YEARCNT(YEAR,LRAA,"VALID"))
+9 IF $EXTRACT(UID,1,2)="00"
SET YEARCNT(YEAR,LRAA,"VALID","00")=1+$GET(YEARCNT(YEAR,LRAA,"VALID","00"))
+10 IF LRCNT>0&((LRCNT#1000=0))
WRITE "."
End DoDot:1
QUIT
+11 ;
+12 SET KCNT=KCNT+1
+13 SET YEARCNT(YEAR,LRAA,"ORPHAN")=1+$GET(YEARCNT(YEAR,LRAA,"ORPHAN"))
+14 IF $EXTRACT(UID,1,2)="00"
SET YEARCNT(YEAR,LRAA,"ORPHAN","00")=1+$GET(YEARCNT(YEAR,LRAA,"ORPHAN","00"))
+15 IF LRCNT>0&((LRCNT#1000=0))
WRITE "*"
+16 QUIT
+17 ;
CIRCMPFL ; EP -- "C" Index Report CoMPilation data Final Lines
+1 WRITE !,?5,"Compilation of ""C"" Index Data Ends",!!
+2 ;
+3 WRITE ?5,"Number of Pointers in ""C"" Index = ",LRCNT,!
+4 WRITE ?5,"Number of ""Orphan"" Pointers in ""C"" Index = ",KCNT,!
+5 ;
+6 DO PRESSKEY()
+7 QUIT
+8 ;
CIROUTD ; EP -- "C" Index Report OUTput the Data
+1 NEW BLRMMENU,BLRVERN,HEADER
+2 ;
+3 DO SETOMENU
+4 ;
+5 ; Main Menu driver
+6 DO MENUDRFM^BLRGMENU("IHS Lab Accession File","""C"" Index Routines")
+7 ;
+8 QUIT
+9 ;
+1 DO ADDTMENU^BLRGMENU("CINTERPT^BLRCINDX","Interactive ""C"" Index Report")
+2 DO ADDTMENU^BLRGMENU("REPORTPR^BLRCINDX","Print ""C"" Index Report")
+3 QUIT
+4 ;
CINTERPT ; EP -- Interactive Version of the report
+1 NEW BLRCINDX,CNT,CNTACC,CNTKILL,CNTOZERO,CNTVZERO,LINES
+2 NEW OLDYEAR,TOPBAR,TOTZERO,YEAR
+3 ;
+4 SET (CNT,CNTACC,CNTKILL,CNTZERO,LINES,OLDYEAR,YEAR)=0
+5 FOR
SET YEAR=$ORDER(YEARCNT(YEAR))
IF YEAR=""
QUIT
Begin DoDot:1
+6 SET LRAA=""
+7 FOR
SET LRAA=$ORDER(YEARCNT(YEAR,LRAA))
IF LRAA=""
QUIT
Begin DoDot:2
+8 DO CINTERPB
End DoDot:2
End DoDot:1
+9 ;
+10 DO BROWSEIT
+11 ;
+12 DO FINALBIT
+13 QUIT
+14 ;
CINTERPB ; EP -- Interactive Version of Report -- Building Arrays
+1 IF +$GET(OLDYEAR)<1
SET OLDYEAR=YEAR
+2 SET CNT=CNT+1
+3 IF OLDYEAR'=YEAR&(CNT>0)
SET LINES=LINES+1
SET BLRCINDX(LINES)=" "
+4 IF OLDYEAR'=YEAR
SET OLDYEAR=YEAR
+5 SET CNTKZERO=+$GET(YEARCNT(YEAR,LRAA,"ORPHAN","00"))
+6 SET CNTVZERO=+$GET(YEARCNT(YEAR,LRAA,"VALID","00"))
+7 SET TOTZERO=CNTVZERO+CNTKZERO
+8 SET CNTZERO=CNTZERO+TOTZERO
+9 ;
+10 SET LINES=LINES+1
+11 SET $EXTRACT(BLRCINDX(LINES),5)=YEAR
+12 SET $EXTRACT(BLRCINDX(LINES),10)=LRAA
+13 SET $EXTRACT(BLRCINDX(LINES),15)=$PIECE($GET(^LRO(68,LRAA,0)),"^",1)
+14 SET $EXTRACT(BLRCINDX(LINES),45)=$JUSTIFY($GET(YEARCNT(YEAR,LRAA,"VALID")),8)
+15 IF TOTZERO>0
SET $EXTRACT(BLRCINDX(LINES),55)=$JUSTIFY(TOTZERO,8)
+16 SET $EXTRACT(BLRCINDX(LINES),67)=$JUSTIFY($GET(YEARCNT(YEAR,LRAA,"ORPHAN")),8)
+17 SET CNTACC=CNTACC+$GET(YEARCNT(YEAR,LRAA,"VALID"))
+18 SET CNTKILL=CNTKILL+$GET(YEARCNT(YEAR,LRAA,"ORPHAN"))
+19 QUIT
+20 ;
BROWSEIT ; EP -- Use Browser to display report
+1 SET HEADER(3)=" "
+2 DO HEADERDT^BLRGMENU
+3 ;
+4 SET TOPBAR="YEAR LRAA Accession Description # Accs # 00 UIDs # Orphans"
+5 IF +$GET(YEARCNT(0))<1
SET TOPBAR="YEAR LRAA Accession Description # Accs # Orphans"
+6 DO BROWSE^DDBR("BLRCINDX","N",TOPBAR,,,5,24)
+7 ;
+8 QUIT
+9 ;
FINALBIT ; EP -- Final section of interactive report
+1 SET $EXTRACT(HEADER(4),45)=$JUSTIFY("# Accs",8)
+2 IF CNTZERO>0
SET $EXTRACT(HEADER(4),55)="# 00 UIDs"
+3 SET $EXTRACT(HEADER(4),67)=$JUSTIFY("# Orphans",8)
+4 ;
+5 DO HEADERDT^BLRGMENU
+6 WRITE ?14,"TOTAL"
+7 WRITE ?44,$JUSTIFY($GET(CNTACC),8)
+8 IF CNTZERO>0
WRITE ?55,$JUSTIFY(CNTZERO,8)
+9 WRITE ?67,$JUSTIFY($GET(CNTKILL),8)
+10 WRITE !!
+11 DO PRESSKEY()
+12 QUIT
+13 ;
REPORTPR ; EP -- Output Data
+1 NEW CNT,CNTACC,CNTKILL,CNTOZERO,CNTVZERO,LINES,OLDYEAR,YEAR
+2 NEW DASHER,HDR1,LINES,MAXLINES,PG,QFLG
+3 NEW TOTLZERO
+4 ;
+5 DO REPORTPI
+6 ;
+7 FOR
SET YEAR=$ORDER(YEARCNT(YEAR))
IF YEAR=""!(QFLG="Q")
QUIT
Begin DoDot:1
+8 SET LRAA=""
+9 FOR
SET LRAA=$ORDER(YEARCNT(YEAR,LRAA))
IF LRAA=""!(QFLG="Q")
QUIT
Begin DoDot:2
+10 DO REPORTPL
End DoDot:2
End DoDot:1
+11 ;
+12 IF QFLG'="Q"
DO TOTATLNE
+13 WRITE !!
+14 ;
+15 ; Close all the devices
DO ^%ZISC
+16 ;
+17 DO PRESSKEY()
+18 QUIT
+19 ;
REPORTPI ; EP -- Print Report Initialization
+1 SET HEADER(1)="IHS Lab Accession File"
+2 SET HEADER(2)="""C"" Index Report"
+3 SET HEADER(3)=" "
+4 SET $EXTRACT(HEADER(4),5)="YEAR"
+5 SET $EXTRACT(HEADER(4),10)="LRAA"
+6 SET $EXTRACT(HEADER(4),15)="Accession Description"
+7 SET $EXTRACT(HEADER(4),45)=$JUSTIFY("# Accs",8)
+8 IF +$GET(YEARCNT(0))>0
SET $EXTRACT(HEADER(4),55)=$JUSTIFY("# 00 UIDs",8)
+9 SET $EXTRACT(HEADER(4),67)=$JUSTIFY("# Orphans",8)
+10 ;
+11 SET PG=0
+12 SET HDR1=0
+13 SET QFLG="NO"
+14 ;
+15 DO ^%ZIS
+16 IF POP
Begin DoDot:1
+17 WRITE !!,?10,"DEVICE could not be selected. Output will be to the screen.",!!
+18 DO ^%ZISC
End DoDot:1
+19 ;
+20 SET MAXLINES=IOSL-3
+21 SET LINES=MAXLINES+10
+22 ;
+23 USE IO
+24 SET (CNT,CNTACC,CNTKILL,CNTOZERO,CNTVZERO,CNTZERO,OLDYEAR,TOTLZERO,YEAR)=0
+25 QUIT
+26 ;
REPORTPL ; EP - Report Liner
+1 IF +$GET(OLDYEAR)<1
SET OLDYEAR=YEAR
+2 ;
+3 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HDR1)
IF QFLG="Q"
QUIT
+4 ;
+5 IF OLDYEAR'=YEAR
SET OLDYEAR=YEAR
IF CNT>0
WRITE !
+6 SET CNT=CNT+1
+7 ;
+8 SET CNTKZERO=+$GET(YEARCNT(YEAR,LRAA,"ORPHAN","00"))
+9 SET CNTVZERO=+$GET(YEARCNT(YEAR,LRAA,"VALID","00"))
+10 SET TOTLZERO=CNTKZERO+CNTVZERO
+11 ;
+12 WRITE ?4,YEAR
+13 WRITE ?9,LRAA
+14 WRITE ?14,$EXTRACT($PIECE($GET(^LRO(68,LRAA,0)),"^",1),1,23)
+15 WRITE ?44,$JUSTIFY($GET(YEARCNT(YEAR,LRAA,"VALID")),8)
+16 IF TOTLZERO>0
WRITE ?55,$JUSTIFY(TOTLZERO,8)
+17 WRITE ?67,$JUSTIFY($GET(YEARCNT(YEAR,LRAA,"ORPHAN")),8)
+18 WRITE !
+19 SET LINES=LINES+1
+20 ;
+21 SET CNTACC=CNTACC+$GET(YEARCNT(YEAR,LRAA,"VALID"))
+22 SET CNTZERO=CNTZERO+TOTLZERO
+23 SET CNTKILL=CNTKILL+$GET(YEARCNT(YEAR,LRAA,"ORPHAN"))
+24 QUIT
+25 ;
TOTATLNE ; EP - Totals Line for Report
+1 SET DASHER=$TRANSLATE($JUSTIFY("",8)," ","-")
+2 WRITE ?44,DASHER
+3 IF CNTZERO>0
WRITE ?55,DASHER
+4 WRITE ?67,DASHER
+5 WRITE !
+6 WRITE ?14,"TOTAL"
+7 WRITE ?44,$JUSTIFY($GET(CNTACC),8)
+8 IF CNTZERO>0
WRITE ?55,$JUSTIFY($GET(CNTZERO),8)
+9 WRITE ?67,$JUSTIFY($GET(CNTKILL),8)
+10 QUIT
+11 ;
REPORT ; EP -- Report on orphan "C" index entries
+1 NEW KCNT,LRAA,LRAD,LRAN,LRCNT,LRROOT,YEARCNT
+2 NEW HEADER
+3 ;
+4 DO REPORTIN
+5 ;
+6 FOR
SET UID=$ORDER(^LRO(68,"C",UID))
IF UID=""
QUIT
Begin DoDot:1
+7 FOR
SET LRAA=$ORDER(^LRO(68,"C",UID,LRAA))
IF LRAA<1
QUIT
Begin DoDot:2
+8 FOR
SET LRAD=$ORDER(^LRO(68,"C",UID,LRAA,LRAD))
IF LRAD<1
QUIT
Begin DoDot:3
+9 FOR
SET LRAN=$ORDER(^LRO(68,"C",UID,LRAA,LRAD,LRAN))
IF LRAN<1
QUIT
Begin DoDot:4
+10 DO REPORTCW
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+11 ;
+12 DO REPORTFL
+13 QUIT
+14 ;
REPORTIN ; -- Report on orphan "C" index INitialization
+1 SET HEADER(1)="IHS Lab Accession File"
+2 SET HEADER(2)="""C"" Index ""Orphan"" Report"
+3 DO HEADERDT^BLRGMENU
+4 ;
+5 WRITE !,?5,"Counting ""Orphan"" Pointers in Accession File's ""C"" Index",!!
+6 ;
+7 SET LRROOT="^LRO(68,""C"")"
+8 SET (KCNT,LRAA,LRAD,LRAN,LRCNT)=0
+9 SET UID=""
+10 ;
+11 WRITE ?5
+12 QUIT
+13 ;
REPORTCW ; EP -- Report on orphan "C" index Counts & Warm fuzzies
+1 SET YEAR=$PIECE($$FMTE^XLFDT(LRAD,"6D"),"/",3)
+2 ;
+3 IF $X>70
WRITE !,?5
+4 SET LRCNT=LRCNT+1
+5 ;
+6 ; Accession exists, so skip this entry
+7 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
Begin DoDot:1
+8 SET YEARCNT(YEAR,LRAA,"VALID")=1+$GET(YEARCNT(YEAR,LRAA,"VALID"))
+9 IF $EXTRACT(UID,1,2)="00"
SET YEARCNT(YEAR,LRAA,"VALID","00")=1+$GET(YEARCNT(YEAR,LRAA,"VALID","00"))
+10 IF LRCNT>0&((LRCNT#1000=0))
WRITE "."
End DoDot:1
QUIT
+11 ;
+12 ; "Orphan" Entry
+13 SET KCNT=KCNT+1
+14 SET YEARCNT(YEAR,LRAA,"ORPHAN")=1+$GET(YEARCNT(YEAR,LRAA,"ORPHAN"))
+15 IF $EXTRACT(UID,1,2)="00"
SET YEARCNT(YEAR,LRAA,"ORPHAN","00")=1+$GET(YEARCNT(YEAR,LRAA,"ORPHAN","00"))
+16 IF LRCNT>0&((LRCNT#1000=0))
WRITE "*"
+17 ;
+18 QUIT
+19 ;
REPORTFL ; EP -- Report on orphan "C" index Counts Final Lines
+1 WRITE !,?5,"Number of Pointers in ""C"" Index = ",LRCNT,!
+2 WRITE ?5,"Number of ""Orphan"" Pointers in ""C"" Index = ",KCNT,!
+3 ;
+4 DO PRESSKEY(5,"REPORT ENDS. Press RETURN Key")
+5 QUIT
+6 ;
PRESSKEY(TAB,MSGSTR) ; EP
+1 NEW TABSTR
+2 ;
+3 IF +$GET(TAB)<1
SET TAB=5
+4 SET TABSTR=$JUSTIFY("",+$GET(TAB))_$SELECT(+$LENGTH($GET(MSGSTR)):$GET(MSGSTR),1:"Press RETURN Key")
+5 ;
+6 WRITE !
+7 DO ^XBFMK
+8 SET DIR(0)="E"
+9 SET DIR("A")=TABSTR
+10 DO ^DIR
+11 ; If Fileman quit, then set Quit Flag
IF $GET(DUOUT)
SET QFLG="Q"
+12 ;
+13 QUIT
+14 ;
+15 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1028
+16 ; Silent Version of the DELOPRHE option -- Created for TaskMan Entries
SILENT ; EP
+1 NEW KCNT,LRAA,LRAD,LRAN,LRCNT,LRROOT,STOREDTT
+2 ;
+3 DO SILENTI
+4 ;
+5 FOR
SET UID=$ORDER(^LRO(68,"C",UID))
IF UID=""
QUIT
Begin DoDot:1
+6 FOR
SET LRAA=$ORDER(^LRO(68,"C",UID,LRAA))
IF LRAA<1
QUIT
Begin DoDot:2
+7 FOR
SET LRAD=$ORDER(^LRO(68,"C",UID,LRAA,LRAD))
IF LRAD<1
QUIT
Begin DoDot:3
+8 FOR
SET LRAN=$ORDER(^LRO(68,"C",UID,LRAA,LRAD,LRAN))
IF LRAN<1
QUIT
Begin DoDot:4
+9 DO SILENTD
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+10 ;
+11 SET STOREDTT=$$NOW^XLFDT
+12 SET ^BLRCINDX(STOREDTT,LRCNT,KCNT)=""
+13 ;
+14 DO SILENTR
+15 ;
+16 QUIT
+17 ;
SILENTI ; EP - Initialization
+1 DO DISABLE^%NOJRN
+2 SET LRROOT="^LRO(68,""C"")"
+3 SET (CNT,KCNT,LRAA,LRAD,LRAN,LRCNT)=0
+4 SET UID=""
+5 QUIT
+6 ;
SILENTD ; EP - Silent Delete
+1 SET LRCNT=LRCNT+1
+2 ;
+3 ; Accession exists, so skip this entry
+4 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
+5 ;
+6 KILL ^LRO(68,"C",UID)
+7 SET KCNT=KCNT+1
+8 QUIT
+9 ;
SILENTR ; EP - Report on the Silent Deletes
+1 NEW DATETIME,CNT1,CNT2,STR,STRLINE
+2 ; IHS/MSC/MKK - LR*5.2*1031
NEW CNT
+3 ;
+4 DO SILENTRI
+5 ;
+6 DO SILENTRC
+7 ;
+8 ; IHS/MSC/MKK - LR*5.2*1031 -- If latest # of Orphans = 0, don't send message
IF CNT<1
QUIT
+9 ;
+10 DO SENDMAIL("Accession File ""C"" Index ""Orphans"" Report")
+11 ;
+12 QUIT
+13 ;
SILENTRI ; EP - Initialization
+1 SET STR(1)=" "
+2 SET STR(2)=$$CJ^XLFSTR($$LOC^XBFUNC,70)
+3 SET STR(3)=" "
+4 SET $EXTRACT(STR(4),45)="# of ""Orphan"""
+5 SET $EXTRACT(STR(5),5)="Date/Time ^BLRCINDX Run"
+6 SET $EXTRACT(STR(5),35)="# UIDs"
+7 SET $EXTRACT(STR(5),45)="Deletions"
+8 SET STR(6)=$TRANSLATE($JUSTIFY("",70)," ","-")
+9 ;
+10 SET (DATETIME)=0
+11 SET (CNT1,CNT2)=""
+12 SET STRLINE=6
+13 ; IHS/MSC/MKK - LR*5.2*1031
SET CNT=0
+14 QUIT
+15 ;
SILENTRC ; EP - Compilation
+1 FOR
SET DATETIME=$ORDER(^BLRCINDX(DATETIME))
IF DATETIME<1
QUIT
Begin DoDot:1
+2 FOR
SET CNT1=$ORDER(^BLRCINDX(DATETIME,CNT1))
IF CNT1=""
QUIT
Begin DoDot:2
+3 FOR
SET CNT2=$ORDER(^BLRCINDX(DATETIME,CNT1,CNT2))
IF CNT2=""
QUIT
Begin DoDot:3
+4 SET STRLINE=STRLINE+1
+5 SET $EXTRACT(STR(STRLINE),5)=$$UP^XLFSTR($$FMTE^XLFDT(DATETIME,"5MPZ"))
+6 SET $EXTRACT(STR(STRLINE),35)=CNT1
+7 SET $EXTRACT(STR(STRLINE),45)=CNT2
+8 ; IHS/MSC/MKK - LR*5.2*1031 - Latest # of Orphans
SET CNT=CNT2
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
SENDMAIL(MAILMSG) ; EP -- Send MailMan E-mail to all users with LRSUPER key
+1 NEW BADUSERS,DIFROM,ERRORS,HEREYAGO,LRSUPER,WHO,WHOCNT,YEARAGO
+2 ;
+3 ; Get "LRSUPER" Security Key IEN
+4 DO FIND^DIC(19.1,,,,"LRSUPER",,,,,"HEREYAGO")
+5 SET LRSUPER=+$GET(HEREYAGO("DILIST",2,1))
+6 IF LRSUPER<1
QUIT
+7 ;
+8 ; Get year in CCYY format from 365 Days Ago
SET YEARAGO=$PIECE($$HTE^XLFDT(+$HOROLOG-365,"5DZ"),"/",3)
+9 ;
+10 KILL XMY
+11 SET (WHO,WHOCNT)=0
+12 FOR
SET WHO=$ORDER(^VA(200,"AB",LRSUPER,WHO))
IF WHO<1
QUIT
Begin DoDot:1
+13 KILL ERRORS,X
+14 ; S X=+$P($$FMTE^XLFDT($$GET1^DIQ(3.7,WHO,"LATEST MAILMAN ACCESS DATE","I",,"ERRORS"),"5DZ"),"/",3)
+15 ; Q:X<YEARAGO ; Only send e-mail to those who have accessed MailMan within the past year
+16 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+17 SET X=$$FMDIFF^XLFDT($$DT^XLFDT,+$$GET1^DIQ(3.7,WHO,"LATEST MAILMAN ACCESS DATE","I",,"ERRORS"),1)
+18 ; Only send e-mail to those who have accessed MailMan within the past year
IF X>365
QUIT
+19 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+20 ;
+21 SET XMY(WHO)=""
+22 IF WHOCNT<1
DO MAILHEAD
+23 SET STRLINE=STRLINE+1
+24 SET $EXTRACT(STR(STRLINE),5)=WHO
+25 SET $EXTRACT(STR(STRLINE),15)=$PIECE($GET(^VA(200,WHO,0)),"^")
+26 SET WHOCNT=WHOCNT+1
End DoDot:1
+27 ;
+28 ; Send to members of LMI Mail Group iff no user has LRSUPER key
IF WHOCNT<1
SET XMY("G.LMI")=""
+29 ;
+30 SET XMSUB=MAILMSG
+31 SET XMTEXT="STR("
+32 SET XMDUZ="IHS Lab Maintenance"
+33 SET XMZ="NOT OKAY"
+34 DO ^XMD
+35 ;
+36 IF $GET(XMMG)'=""!(XMZ="NOT OKAY")
SET ^BLRCINDX(STOREDTT,LRCNT,KCNT)="MAILMAN ERROR.^"_XMZ_"^"_XMMG
+37 ;
+38 ; Cleanup
KILL X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y
+39 QUIT
+40 ;
MAILHEAD ; EP - E-Mail Header
+1 DO ADDONEL(.STR,.STRLINE," ")
+2 DO ADDONEL(.STR,.STRLINE,"E-Mail sent to the following:")
+3 DO ADDONEL(.STR,.STRLINE," ")
+4 ;
+5 SET STRLINE=STRLINE+1
+6 SET $EXTRACT(STR(STRLINE),5)="File 200"
+7 ;
+8 SET STRLINE=STRLINE+1
+9 SET $EXTRACT(STR(STRLINE),5)=" IEN"
+10 SET $EXTRACT(STR(STRLINE),15)="Name"
+11 ;
+12 SET STRLINE=STRLINE+1
+13 SET $EXTRACT(STR(STRLINE),5)="--------"
+14 SET $EXTRACT(STR(STRLINE),15)=$TRANSLATE($JUSTIFY("",30)," ","-")
+15 QUIT
+16 ;
ADDONEL(ARRAY,LINE,STR) ; EP - Add 1 Line
+1 SET LINE=1+$GET(LINE)
+2 SET ARRAY(LINE)=STR
+3 QUIT
+4 ;
SILENTRB ; EP -- Report Browser
+1 NEW DATETIME,CNT1,CNT2,STR,STRLINE
+2 NEW HEADER,TOPBAR
+3 ;
+4 SET (DATETIME,STRLINE)=0
+5 SET (CNT1,CNT2)=""
+6 DO SILENTRC
+7 ;
+8 SET HEADER(1)="IHS Lab Accession File"
+9 SET HEADER(2)="""C"" Index ""Orphan"" Deletion"
+10 SET HEADER(3)=" "
+11 ;
+12 SET $EXTRACT(TOPBAR,5)="Date/Time ^BLRCINDX Run"
+13 SET $EXTRACT(TOPBAR,35)="# UIDS"
+14 SET $EXTRACT(TOPBAR,45)="# of ""Orphan"" Deletions"
+15 SET TOPBAR=$$LJ^XLFSTR(TOPBAR,80)
+16 ;
+17 DO HEADERDT^BLRGMENU
+18 DO BROWSE^DDBR("STR","N",TOPBAR,,,5,24)
+19 ;
+20 DO PRESSKEY^BLRGMENU(5)
+21 QUIT
+22 ;
+23 ; ----- END IHS/OIT/MKK - LR*5.2*1028
