LA7CHKF ;DALOI/JMC - Check Lab Messaging File Integrity ;11/16/11 10:49
;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,74**;Sep 27, 1994;Build 229
;
;This routine checks file integrity for Lab Messaging.
EN ; Run an integrity check
;
;ZEXCEPT: ION,POP
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK
N LA7CHKBX,LA7FIX,LA7ION,LA7LOG,LA7QUIT
;
S (LA7CHKBX,LA7LOG)=1
S DIR(0)="SO^1:Check File Integrity;2:Fix File Entries"
S DIR("A")="Select Option",DIR("B")=1
D ^DIR
I $D(DIRUT) Q
I Y=1 S LA7FIX=0
I Y=2 S LA7FIX=1
;
K DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="YO",DIR("A")="Print Report",DIR("B")="YES",DIR("?")="Enter 'YES' to print the integrity report."
D ^DIR
I $D(DIRUT) Q
I Y=1 D
. N %ZIS
. S %ZIS="NQ0",%ZIS("A")="Select Device: ",%ZIS("B")=""
. D ^%ZIS
. I POP S LA7QUIT=1
. S LA7ION=ION
I $G(LA7QUIT) D HOME^%ZIS Q
;
S ZTRTN="DQ^LA7CHKF",ZTDESC="Lab Messaging File Integrity Checker"
S ZTSAVE("LA7*")="",ZTIO=""
D ^%ZTLOAD,HOME^%ZIS
W !,"Request ",$S($G(ZTSK):"",1:"NOT "),"Queued"
Q
;
;
DQ ; Entry point from taskman
;
;ZEXCEPT: LA7CHKBX,LA7FIX,LA7ION,LA7LOG,ZTQUEUED,ZTREQ
;
N LA7ECNT,LA7IC,LA7XQA
;
D INIT,IC,CHECKMG
;
I LA7LOG D
. S $P(^XTMP(LA7IC,0),"^",5)=$$NOW^XLFDT ; End date/time
. L -^XTMP(LA7IC) ; Release lock
;
I LA7ECNT D
. N XQA,XQAID,XQADATA,XQAMSG,XQAOPT,XQAROU
. S XQAMSG="Lab Messaging -Warning- "_LA7ECNT_" errors found in File #62.49, LA7 MESSAGE QUEUE."
. I LA7LOG S XQADATA=LA7IC,XQAROU="DISIC^LA7UXQA"
. S XQAID="LA7ERR-"_$TR(LA7IC,"^",":")
. I $G(DUZ)>.9 S XQA(DUZ)=""
. M XQA=LA7XQA
. D SETUP^XQALERT
;
; Run check on certain files "B" index if first of the month or tasked by user.
I $G(LA7CHKBX)="" S LA7CHKBX=$S($E(DT,6,7)="01":1,1:0)
I LA7CHKBX D CHKBX
K LA7CHKBX
;
; Task print of integrity report
I $G(LA7ION)'="" D
. N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
. S ZTRTN="DQ^LA7CHKFP",ZTDTH=$H,ZTSAVE("LA7IC")="",ZTIO=LA7ION
. S ZTDESC="Print LA7 File Integrity Report"
. D ^%ZTLOAD
;
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
;
IC ; File 62.49 Integrity checker and fix-er-upper.
;
; Check that all the cross-references have entries
;
;ZEXCEPT: LA7ECNT,LA7FIX,LA7IC,LA7LOG,LA7TCNT
;
N LA7CFG,LA7DA,LA7DAT,LA7INAME,LA7Q,LA7ROOT,X,Y
;
; Check the "AD" cross-reference
S LA7ROOT="^LAHM(62.49,""AD"")"
F S LA7ROOT=$Q(LA7ROOT) Q:LA7ROOT="" Q:$QS(LA7ROOT,1)'=62.49!($QS(LA7ROOT,2)'="AD") D
. S LA7DAT=$QS(LA7ROOT,3),LA7DA=$QS(LA7ROOT,4)
. I '$$LOCK(LA7DA) Q
. I LA7DAT'=$P($P($G(^LAHM(62.49,LA7DA,0)),"^",5),".") D
. . I LA7FIX K @LA7ROOT
. . I LA7LOG D LOG("Bad ""AD"" cross-reference of "_LA7ROOT_" for entry "_LA7DA)
. D UNLOCK(LA7DA)
;
; Check the "B" cross-reference
S LA7ROOT="^LAHM(62.49,""B"")"
F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" Q:$QS(LA7ROOT,1)'=62.49!($QS(LA7ROOT,2)'="B") D
. S LA7DA=$QS(LA7ROOT,4)
. I '$$LOCK(LA7DA) Q
. I LA7DA'=$QS(LA7ROOT,3) D
. . I LA7FIX K @LA7ROOT
. . I LA7LOG D LOG("""B"" cross-reference "_LA7ROOT_" points to incorrect entry "_$QS(LA7ROOT,4))
. I '$D(^LAHM(62.49,LA7DA,0)) D
. . I LA7FIX K @LA7ROOT
. . I LA7LOG D LOG("""B"" cross-reference "_LA7ROOT_" points to missing entry "_LA7DA)
. D UNLOCK(LA7DA)
;
; Check the "C" cross-reference
S LA7ROOT="^LAHM(62.49,""C"")"
F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" Q:$QS(LA7ROOT,1)'=62.49!($QS(LA7ROOT,2)'="C") D
. S LA7INAME=$QS(LA7ROOT,3),LA7DA=$QS(LA7ROOT,4)
. I '$$LOCK(LA7DA) Q
. I LA7INAME=$P($G(^LAHM(62.49,LA7DA,0)),"^",6) D UNLOCK(LA7DA) Q
. I LA7FIX K @LA7ROOT
. I LA7LOG D LOG("Bad ""C"" cross-reference of "_LA7ROOT_" on entry "_LA7DA)
. D UNLOCK(LA7DA)
;
; Check the "Q" cross-reference
S LA7ROOT="^LAHM(62.49,""Q"")"
F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" Q:$QS(LA7ROOT,1)'=62.49!($QS(LA7ROOT,2)'="Q") D
. S LA7CFG=$QS(LA7ROOT,3)
. S LA7Q=$QS(LA7ROOT,4)
. S LA7DA=$QS(LA7ROOT,5)
. I '$$LOCK(LA7DA) Q
. S X(0)=$G(^LAHM(62.49,LA7DA,0))
. S X(.5)=$G(^LAHM(62.49,LA7DA,.5))
. I LA7CFG'=$P(X(.5),"^")!(LA7Q'=($P(X(0),"^",2)_$P(X(0),"^",3))) D
. . I LA7LOG D LOG("Bad ""Q"" cross-reference of "_LA7ROOT_" for entry: "_LA7DA)
. . I LA7FIX K @LA7ROOT
. D UNLOCK(LA7DA)
;
; Check that all entries have "AD" cross-reference set.
; "B" cross-reference set
; "C" cross-reference set
; "Q" cross-reference set
S (LA7DA,LA7TCNT)=0
F S LA7DA=$O(^LAHM(62.49,LA7DA)) Q:'LA7DA D
. I '$$LOCK(LA7DA) Q
. S LA7TCNT=LA7TCNT+1 ; Count of entries in file.
. S X(0)=$G(^LAHM(62.49,LA7DA,0))
. S X(.5)=$G(^LAHM(62.49,LA7DA,.5))
. S Y=$P(X(0),"^") ; Message number (.01 field)
. I 'Y D
. . I LA7FIX K ^LAHM(62.49,LA7DA)
. . I LA7LOG D LOG("Entry "_LA7DA_" missing .01 field")
. S Y=$P(X(0),"^",5) ; date/time entered
. I Y,'$D(^LAHM(62.49,"AD",$P(Y,"."),LA7DA)) D
. . I LA7FIX S ^LAHM(62.49,"AD",$P(Y,"."),LA7DA)=""
. . I LA7LOG D LOG("Entry "_LA7DA_" missing ""AD"" cross-reference "_$P(Y,"."))
. S Y=$P(X(0),"^")
. I Y,'$D(^LAHM(62.49,"B",Y,LA7DA)) D
. . I LA7FIX S ^LAHM(62.49,"B",Y,LA7DA)=""
. . I LA7LOG D LOG("Entry "_LA7DA_" missing ""B"" cross-reference")
. S Y=$P(X(0),"^",6) ; instrument name
. I Y'="",'$D(^LAHM(62.49,"C",$E(Y,1,45),LA7DA)) D
. . I LA7FIX S ^LAHM(62.49,"C",$E(Y,1,45),LA7DA)=""
. . I LA7LOG D LOG("Entry "_LA7DA_" missing ""C"" cross-reference "_Y)
. S Y=$P(X(0),"^",2)_$P(X(0),"^",3) ; concatentate configuration_status
. I +X(.5),Y'="",'$D(^LAHM(62.49,"Q",+X(.5),Y,LA7DA)) D
. . I LA7FIX S ^LAHM(62.49,"Q",+X(.5),Y,LA7DA)=""
. . I LA7LOG D LOG("Entry "_LA7DA_" missing ^LAHM(62.49,""Q"","_+X(.5)_","""_Y_""","_LA7DA_") cross-reference")
. D UNLOCK(LA7DA)
;
I LA7LOG D
. S $P(^XTMP(LA7IC,0),"^",6,7)=LA7TCNT_"^"_LA7ECNT ; Total^Error count
. S $P(^XTMP(LA7IC,0),"^",8)=LA7FIX
;
Q
;
;
CHKBX ; Check "B" index on selected Lab files
;
N LRFN,LRROOT
F LRFN=61,61.1,61.2,61.3,61.4,61.5,61.6,62 D
. S LRROOT="^LAB("_LRFN_",""B"")"
. D FILE
;
Q
;
;
FILE ; Check "B" index on this file
;
;ZEXCEPT: LRFN,LRROOT
;
N DIK,LRIEN,LRNAME
F S LRROOT=$Q(@LRROOT) Q:LRROOT="" Q:$QS(LRROOT,2)'="B" D
. S LRIEN=$QS(LRROOT,4)
. I LRFN<62,$G(@LRROOT) S LRNAME=$P($G(^LAB(LRFN,LRIEN,0)),"^",$S(((LRFN>61)&(LRFN<61.4)):7,1:5))
. E S LRNAME=$P($G(^LAB(LRFN,LRIEN,0)),"^")
. I $QS(LRROOT,3)'=$E(LRNAME,1,30) K @LRROOT
;
; Reindex the "B" x-index on this file for fields #.01 and #6 (abbreviation)
S DIK="^LAB("_LRFN_",",DIK(1)=".01^B" D ENALL^DIK
K DIK
I LRFN<62 S DIK="^LAB("_LRFN_",",DIK(1)="6^B" D ENALL^DIK
Q
;
;
LOG(X) ; Log error in XTMP global.
; Call with X = error message to store.
;
;ZEXCEPT: LA7ECNT,LA7FIX,LA7IC
;
S LA7ECNT=$G(LA7ECNT)+1
I LA7FIX S X=X_" **Fix attempted**"
S ^XTMP(LA7IC,LA7ECNT)=X
Q
;
;
LOCK(LA7DA) ; Lock entry in #62.49
; Call with LA7DA = entry to lock
; Returns 0 = failure to obtain lock
; 1 = lock obtained
;
;ZEXCEPT: LA7LOG
;
N LA7Y
S LA7Y=0,LA7DA=+$G(LA7DA)
L +^LAHM(62.49,LA7DA):10
I $T S LA7Y=1
I 'LA7Y,$G(LA7LOG) D LOG("Unable to obtain lock on entry "_LA7DA_" in file #62.49")
Q LA7Y
;
UNLOCK(LA7DA) ; Unlock entry in #62.49
; Call with LA7DA = entry to lock
;
S LA7DA=+$G(LA7DA)
L -^LAHM(62.49,LA7DA)
Q
;
LACHK() ; Check ^LA("ADL","Q") for build up of entries.
; Send alert to mail group LAB MESSAGING warning about large # of entries.
N LA7CNT,LA7DA,X,Y
S LA7DA="",LA7CNT=0
F S LA7DA=$O(^LA("ADL","Q",LA7DA)) Q:LA7DA="" S LA7CNT=LA7CNT+1
I LA7CNT>500 D
. N XQA,XQAID,XQADATA,XQAMSG,XQAOPT,XQAROU
. S XQAMSG="Lab Messaging -Warning- "_LA7CNT_" entries in LA(""ADL"",""Q"") global - please check."
. S XQAID="LA7ADL-"_$H
. I $G(DUZ)>.9 S XQA(DUZ)=""
. S XQA("G.LAB MESSAGING")=""
. D SETUP^XQALERT
Q LA7CNT
;
;
CHECKMG ; Check if LAB MESSAGING and LMI mail groups has active members.
; Check mail groups specified for alerts in file #62.48 are valid and have active members.
;
;ZEXCEPT: LA7ECNT,LA7IC,LA7LOG,LA7XQA
;
N LA76248,LA7FIX,LA7I,LA7MGERRORS,LA7X,LA7Y,XMERR,XQA,XQAID,XQAMSG
;
; Set flag that we've check the membership today.
S ^XTMP("LA7CHECKMG",0)=DT_"^"_DT_"^LAB HL7 CHECK LAB MESSAGING MAIL GROUP MEMBERS"
;
K ^TMP("XMERR",$J)
S XQAMSG="",LA7FIX=0,LA7MGERRORS=LA7ECNT
;
; Doucment error message returned by GOTLOCAL API when mail group does not exist.
;^TMP("XMERR",555809209,1)=39501
;^TMP("XMERR",555809209,1,"TEXT",1)=Mail group 'LMI' not found.
;^TMP("XMERR",555809209,"E",39501,1)=
;
; Mail group LAB MESSAGING has no active members
I '$$GOTLOCAL^XMXAPIG("LAB MESSAGING") D
. S LA7MGERRORS("LAB MESSAGING")=""
. S XQAMSG="Lab Messaging - Mail group LAB MESSAGING has no active members"
. I $D(^TMP("XMERR",$J,"E",39501)) S XQAMSG="Lab Messaging - Mail group LAB MESSAGING not found"
. S LA7XQA("G.LMI")=""
. I LA7LOG D
. . I $D(^TMP("XMERR",$J,"E",39501)) D Q
. . . S XQAMSG="Lab Messaging - Mail group LAB MESSAGING not found"
. . . D LOG("Mail group LAB MESSAGING not found")
. . D LOG("Mail group LAB MESSAGING has no active members")
. K ^TMP("XMERR",$J)
E S LA7XQA("G.LAB MESSAGING")=""
;
; Send alert to holders of mail group LMI
I '$$GOTLOCAL^XMXAPIG("LMI") D
. S LA7MGERRORS("LMI")=""
. I XQAMSG="" S XQAMSG="Lab Messaging - Mail group LMI has no active members"
. E S XQAMSG="Lab Messaging - Mail groups LAB MESSAGING and LMI have no active members"
. I LA7LOG D
. . I $D(^TMP("XMERR",$J,"E",39501)) D LOG("Mail group LMI not found") Q
. . D LOG("Mail group LMI has no active members")
. K LA7XQA("G.LMI"),^TMP("XMERR",$J)
E S LA7XQA("G.LMI")=""
;
; Neither LAB MESSAGING or LMI mail groups have active members - send alert to holders of LRLIASON security key
; Delete previous alerts
I XQAMSG'="" D
. S XQAID="LA7-MESSAGE-CHECKMG"
. D DEL^LA7UXQA(XQAID)
. I $O(LA7XQA(""))="" M LA7XQA=^XUSEC("LRLIASON")
. M XQA=LA7XQA
. D SETUP^XQALERT
;
S LA76248=0
F S LA76248=$O(^LAHM(62.48,LA76248)) Q:LA76248<1 D
. S LA7I=0
. F LA7I=$O(^LAHM(62.48,LA76248,20,LA7I)) Q:LA7I<1 D
. . S LA7I(0)=$G(^LAHM(62.48,LA76248,0))
. . S LA7Y=$G(^LAHM(62.48,LA76248,20,LA7I,0))
. . I $P(LA7Y,"^",2)="" Q
. . K ^TMP("XMERR",$J)
. . I $$GOTLOCAL^XMXAPIG($P(LA7Y,"^",2)) Q
. . I '$D(LA7MGERRORS($P(LA7Y,"^",2))) D
. . . S XQAID="LA7-MESSAGE-CHECKMG-"_$P(LA7Y,"^",2)
.. . D DEL^LA7UXQA(XQAID)
. . . S XQAMSG="Lab Messaging - Mail group "_$P(LA7Y,"^",2)_" has no active members"
. . . I $D(^TMP("XMERR",$J,"E",39501)) S XQAMSG="Lab Messaging - Mail group "_$P(LA7Y,"^",2)_" not found"
. . . K XQA
. . . M XQA=LA7XQA
. . . D SETUP^XQALERT
. . . S LA7MGERRORS($P(LA7Y,"^",2))=""
. . I LA7LOG D
. . . I $D(^TMP("XMERR",$J,"E",39501)) D LOG("Configuration "_$P(LA7I(0),"^")_" alert mail group "_$P(LA7Y,"^",2)_" not found") Q
. . . D LOG("Configuration "_$P(LA7I(0),"^")_" alert mail group "_$P(LA7Y,"^",2)_" has no active members")
;
I LA7LOG D
. S LA7MGERRORS=LA7ECNT-LA7MGERRORS
. S $P(^XTMP(LA7IC,0),"^",9)=LA7MGERRORS ; Total error count
;
K ^TMP("XMERR",$J)
;
Q
;
;
INIT ; Initialize variables
;
;ZEXCEPT: LA7ECNT,LA7FIX,LA7IC,LA7LOG
;
S LA7FIX=$G(LA7FIX,0) ; Set flag to fix problems 1=yes, 0=just check (default)
S LA7LOG=$G(LA7LOG,0) ; Set flag to report problems, 1=yes, 0=no (default)
I LA7LOG D
. F S LA7IC="LA7IC^"_$$NOW^XLFDT L +^XTMP(LA7IC):9999 Q:'$D(^XTMP(LA7IC)) L -^XTMP(LA7IC) H 1
. S DT=$$DT^XLFDT
. S ^XTMP(LA7IC,0)=$$FMADD^XLFDT(DT,7)_"^"_DT_"^Lab Messaging Integrity Checker"_"^"_$$NOW^XLFDT
;
; Count of number of errors
S LA7ECNT=0
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7CHKF 11818 printed Nov 22, 2024@16:49:11 Page 2
LA7CHKF ;DALOI/JMC - Check Lab Messaging File Integrity ;11/16/11 10:49
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,74**;Sep 27, 1994;Build 229
+2 ;
+3 ;This routine checks file integrity for Lab Messaging.
EN ; Run an integrity check
+1 ;
+2 ;ZEXCEPT: ION,POP
+3 ;
+4 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK
+5 NEW LA7CHKBX,LA7FIX,LA7ION,LA7LOG,LA7QUIT
+6 ;
+7 SET (LA7CHKBX,LA7LOG)=1
+8 SET DIR(0)="SO^1:Check File Integrity;2:Fix File Entries"
+9 SET DIR("A")="Select Option"
SET DIR("B")=1
+10 DO ^DIR
+11 IF $DATA(DIRUT)
QUIT
+12 IF Y=1
SET LA7FIX=0
+13 IF Y=2
SET LA7FIX=1
+14 ;
+15 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+16 SET DIR(0)="YO"
SET DIR("A")="Print Report"
SET DIR("B")="YES"
SET DIR("?")="Enter 'YES' to print the integrity report."
+17 DO ^DIR
+18 IF $DATA(DIRUT)
QUIT
+19 IF Y=1
Begin DoDot:1
+20 NEW %ZIS
+21 SET %ZIS="NQ0"
SET %ZIS("A")="Select Device: "
SET %ZIS("B")=""
+22 DO ^%ZIS
+23 IF POP
SET LA7QUIT=1
+24 SET LA7ION=ION
End DoDot:1
+25 IF $GET(LA7QUIT)
DO HOME^%ZIS
QUIT
+26 ;
+27 SET ZTRTN="DQ^LA7CHKF"
SET ZTDESC="Lab Messaging File Integrity Checker"
+28 SET ZTSAVE("LA7*")=""
SET ZTIO=""
+29 DO ^%ZTLOAD
DO HOME^%ZIS
+30 WRITE !,"Request ",$SELECT($GET(ZTSK):"",1:"NOT "),"Queued"
+31 QUIT
+32 ;
+33 ;
DQ ; Entry point from taskman
+1 ;
+2 ;ZEXCEPT: LA7CHKBX,LA7FIX,LA7ION,LA7LOG,ZTQUEUED,ZTREQ
+3 ;
+4 NEW LA7ECNT,LA7IC,LA7XQA
+5 ;
+6 DO INIT
DO IC
DO CHECKMG
+7 ;
+8 IF LA7LOG
Begin DoDot:1
+9 ; End date/time
SET $PIECE(^XTMP(LA7IC,0),"^",5)=$$NOW^XLFDT
+10 ; Release lock
LOCK -^XTMP(LA7IC)
End DoDot:1
+11 ;
+12 IF LA7ECNT
Begin DoDot:1
+13 NEW XQA,XQAID,XQADATA,XQAMSG,XQAOPT,XQAROU
+14 SET XQAMSG="Lab Messaging -Warning- "_LA7ECNT_" errors found in File #62.49, LA7 MESSAGE QUEUE."
+15 IF LA7LOG
SET XQADATA=LA7IC
SET XQAROU="DISIC^LA7UXQA"
+16 SET XQAID="LA7ERR-"_$TRANSLATE(LA7IC,"^",":")
+17 IF $GET(DUZ)>.9
SET XQA(DUZ)=""
+18 MERGE XQA=LA7XQA
+19 DO SETUP^XQALERT
End DoDot:1
+20 ;
+21 ; Run check on certain files "B" index if first of the month or tasked by user.
+22 IF $GET(LA7CHKBX)=""
SET LA7CHKBX=$SELECT($EXTRACT(DT,6,7)="01":1,1:0)
+23 IF LA7CHKBX
DO CHKBX
+24 KILL LA7CHKBX
+25 ;
+26 ; Task print of integrity report
+27 IF $GET(LA7ION)'=""
Begin DoDot:1
+28 NEW ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+29 SET ZTRTN="DQ^LA7CHKFP"
SET ZTDTH=$HOROLOG
SET ZTSAVE("LA7IC")=""
SET ZTIO=LA7ION
+30 SET ZTDESC="Print LA7 File Integrity Report"
+31 DO ^%ZTLOAD
End DoDot:1
+32 ;
+33 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+34 QUIT
+35 ;
+36 ;
IC ; File 62.49 Integrity checker and fix-er-upper.
+1 ;
+2 ; Check that all the cross-references have entries
+3 ;
+4 ;ZEXCEPT: LA7ECNT,LA7FIX,LA7IC,LA7LOG,LA7TCNT
+5 ;
+6 NEW LA7CFG,LA7DA,LA7DAT,LA7INAME,LA7Q,LA7ROOT,X,Y
+7 ;
+8 ; Check the "AD" cross-reference
+9 SET LA7ROOT="^LAHM(62.49,""AD"")"
+10 FOR
SET LA7ROOT=$QUERY(LA7ROOT)
if LA7ROOT=""
QUIT
if $QSUBSCRIPT(LA7ROOT,1)'=62.49!($QSUBSCRIPT(LA7ROOT,2)'="AD")
QUIT
Begin DoDot:1
+11 SET LA7DAT=$QSUBSCRIPT(LA7ROOT,3)
SET LA7DA=$QSUBSCRIPT(LA7ROOT,4)
+12 IF '$$LOCK(LA7DA)
QUIT
+13 IF LA7DAT'=$PIECE($PIECE($GET(^LAHM(62.49,LA7DA,0)),"^",5),".")
Begin DoDot:2
+14 IF LA7FIX
KILL @LA7ROOT
+15 IF LA7LOG
DO LOG("Bad ""AD"" cross-reference of "_LA7ROOT_" for entry "_LA7DA)
End DoDot:2
+16 DO UNLOCK(LA7DA)
End DoDot:1
+17 ;
+18 ; Check the "B" cross-reference
+19 SET LA7ROOT="^LAHM(62.49,""B"")"
+20 FOR
SET LA7ROOT=$QUERY(@LA7ROOT)
if LA7ROOT=""
QUIT
if $QSUBSCRIPT(LA7ROOT,1)'=62.49!($QSUBSCRIPT(LA7ROOT,2)'="B")
QUIT
Begin DoDot:1
+21 SET LA7DA=$QSUBSCRIPT(LA7ROOT,4)
+22 IF '$$LOCK(LA7DA)
QUIT
+23 IF LA7DA'=$QSUBSCRIPT(LA7ROOT,3)
Begin DoDot:2
+24 IF LA7FIX
KILL @LA7ROOT
+25 IF LA7LOG
DO LOG("""B"" cross-reference "_LA7ROOT_" points to incorrect entry "_$QSUBSCRIPT(LA7ROOT,4))
End DoDot:2
+26 IF '$DATA(^LAHM(62.49,LA7DA,0))
Begin DoDot:2
+27 IF LA7FIX
KILL @LA7ROOT
+28 IF LA7LOG
DO LOG("""B"" cross-reference "_LA7ROOT_" points to missing entry "_LA7DA)
End DoDot:2
+29 DO UNLOCK(LA7DA)
End DoDot:1
+30 ;
+31 ; Check the "C" cross-reference
+32 SET LA7ROOT="^LAHM(62.49,""C"")"
+33 FOR
SET LA7ROOT=$QUERY(@LA7ROOT)
if LA7ROOT=""
QUIT
if $QSUBSCRIPT(LA7ROOT,1)'=62.49!($QSUBSCRIPT(LA7ROOT,2)'="C")
QUIT
Begin DoDot:1
+34 SET LA7INAME=$QSUBSCRIPT(LA7ROOT,3)
SET LA7DA=$QSUBSCRIPT(LA7ROOT,4)
+35 IF '$$LOCK(LA7DA)
QUIT
+36 IF LA7INAME=$PIECE($GET(^LAHM(62.49,LA7DA,0)),"^",6)
DO UNLOCK(LA7DA)
QUIT
+37 IF LA7FIX
KILL @LA7ROOT
+38 IF LA7LOG
DO LOG("Bad ""C"" cross-reference of "_LA7ROOT_" on entry "_LA7DA)
+39 DO UNLOCK(LA7DA)
End DoDot:1
+40 ;
+41 ; Check the "Q" cross-reference
+42 SET LA7ROOT="^LAHM(62.49,""Q"")"
+43 FOR
SET LA7ROOT=$QUERY(@LA7ROOT)
if LA7ROOT=""
QUIT
if $QSUBSCRIPT(LA7ROOT,1)'=62.49!($QSUBSCRIPT(LA7ROOT,2)'="Q")
QUIT
Begin DoDot:1
+44 SET LA7CFG=$QSUBSCRIPT(LA7ROOT,3)
+45 SET LA7Q=$QSUBSCRIPT(LA7ROOT,4)
+46 SET LA7DA=$QSUBSCRIPT(LA7ROOT,5)
+47 IF '$$LOCK(LA7DA)
QUIT
+48 SET X(0)=$GET(^LAHM(62.49,LA7DA,0))
+49 SET X(.5)=$GET(^LAHM(62.49,LA7DA,.5))
+50 IF LA7CFG'=$PIECE(X(.5),"^")!(LA7Q'=($PIECE(X(0),"^",2)_$PIECE(X(0),"^",3)))
Begin DoDot:2
+51 IF LA7LOG
DO LOG("Bad ""Q"" cross-reference of "_LA7ROOT_" for entry: "_LA7DA)
+52 IF LA7FIX
KILL @LA7ROOT
End DoDot:2
+53 DO UNLOCK(LA7DA)
End DoDot:1
+54 ;
+55 ; Check that all entries have "AD" cross-reference set.
+56 ; "B" cross-reference set
+57 ; "C" cross-reference set
+58 ; "Q" cross-reference set
+59 SET (LA7DA,LA7TCNT)=0
+60 FOR
SET LA7DA=$ORDER(^LAHM(62.49,LA7DA))
if 'LA7DA
QUIT
Begin DoDot:1
+61 IF '$$LOCK(LA7DA)
QUIT
+62 ; Count of entries in file.
SET LA7TCNT=LA7TCNT+1
+63 SET X(0)=$GET(^LAHM(62.49,LA7DA,0))
+64 SET X(.5)=$GET(^LAHM(62.49,LA7DA,.5))
+65 ; Message number (.01 field)
SET Y=$PIECE(X(0),"^")
+66 IF 'Y
Begin DoDot:2
+67 IF LA7FIX
KILL ^LAHM(62.49,LA7DA)
+68 IF LA7LOG
DO LOG("Entry "_LA7DA_" missing .01 field")
End DoDot:2
+69 ; date/time entered
SET Y=$PIECE(X(0),"^",5)
+70 IF Y
IF '$DATA(^LAHM(62.49,"AD",$PIECE(Y,"."),LA7DA))
Begin DoDot:2
+71 IF LA7FIX
SET ^LAHM(62.49,"AD",$PIECE(Y,"."),LA7DA)=""
+72 IF LA7LOG
DO LOG("Entry "_LA7DA_" missing ""AD"" cross-reference "_$PIECE(Y,"."))
End DoDot:2
+73 SET Y=$PIECE(X(0),"^")
+74 IF Y
IF '$DATA(^LAHM(62.49,"B",Y,LA7DA))
Begin DoDot:2
+75 IF LA7FIX
SET ^LAHM(62.49,"B",Y,LA7DA)=""
+76 IF LA7LOG
DO LOG("Entry "_LA7DA_" missing ""B"" cross-reference")
End DoDot:2
+77 ; instrument name
SET Y=$PIECE(X(0),"^",6)
+78 IF Y'=""
IF '$DATA(^LAHM(62.49,"C",$EXTRACT(Y,1,45),LA7DA))
Begin DoDot:2
+79 IF LA7FIX
SET ^LAHM(62.49,"C",$EXTRACT(Y,1,45),LA7DA)=""
+80 IF LA7LOG
DO LOG("Entry "_LA7DA_" missing ""C"" cross-reference "_Y)
End DoDot:2
+81 ; concatentate configuration_status
SET Y=$PIECE(X(0),"^",2)_$PIECE(X(0),"^",3)
+82 IF +X(.5)
IF Y'=""
IF '$DATA(^LAHM(62.49,"Q",+X(.5),Y,LA7DA))
Begin DoDot:2
+83 IF LA7FIX
SET ^LAHM(62.49,"Q",+X(.5),Y,LA7DA)=""
+84 IF LA7LOG
DO LOG("Entry "_LA7DA_" missing ^LAHM(62.49,""Q"","_+X(.5)_","""_Y_""","_LA7DA_") cross-reference")
End DoDot:2
+85 DO UNLOCK(LA7DA)
End DoDot:1
+86 ;
+87 IF LA7LOG
Begin DoDot:1
+88 ; Total^Error count
SET $PIECE(^XTMP(LA7IC,0),"^",6,7)=LA7TCNT_"^"_LA7ECNT
+89 SET $PIECE(^XTMP(LA7IC,0),"^",8)=LA7FIX
End DoDot:1
+90 ;
+91 QUIT
+92 ;
+93 ;
CHKBX ; Check "B" index on selected Lab files
+1 ;
+2 NEW LRFN,LRROOT
+3 FOR LRFN=61,61.1,61.2,61.3,61.4,61.5,61.6,62
Begin DoDot:1
+4 SET LRROOT="^LAB("_LRFN_",""B"")"
+5 DO FILE
End DoDot:1
+6 ;
+7 QUIT
+8 ;
+9 ;
FILE ; Check "B" index on this file
+1 ;
+2 ;ZEXCEPT: LRFN,LRROOT
+3 ;
+4 NEW DIK,LRIEN,LRNAME
+5 FOR
SET LRROOT=$QUERY(@LRROOT)
if LRROOT=""
QUIT
if $QSUBSCRIPT(LRROOT,2)'="B"
QUIT
Begin DoDot:1
+6 SET LRIEN=$QSUBSCRIPT(LRROOT,4)
+7 IF LRFN<62
IF $GET(@LRROOT)
SET LRNAME=$PIECE($GET(^LAB(LRFN,LRIEN,0)),"^",$SELECT(((LRFN>61)&(LRFN<61.4)):7,1:5))
+8 IF '$TEST
SET LRNAME=$PIECE($GET(^LAB(LRFN,LRIEN,0)),"^")
+9 IF $QSUBSCRIPT(LRROOT,3)'=$EXTRACT(LRNAME,1,30)
KILL @LRROOT
End DoDot:1
+10 ;
+11 ; Reindex the "B" x-index on this file for fields #.01 and #6 (abbreviation)
+12 SET DIK="^LAB("_LRFN_","
SET DIK(1)=".01^B"
DO ENALL^DIK
+13 KILL DIK
+14 IF LRFN<62
SET DIK="^LAB("_LRFN_","
SET DIK(1)="6^B"
DO ENALL^DIK
+15 QUIT
+16 ;
+17 ;
LOG(X) ; Log error in XTMP global.
+1 ; Call with X = error message to store.
+2 ;
+3 ;ZEXCEPT: LA7ECNT,LA7FIX,LA7IC
+4 ;
+5 SET LA7ECNT=$GET(LA7ECNT)+1
+6 IF LA7FIX
SET X=X_" **Fix attempted**"
+7 SET ^XTMP(LA7IC,LA7ECNT)=X
+8 QUIT
+9 ;
+10 ;
LOCK(LA7DA) ; Lock entry in #62.49
+1 ; Call with LA7DA = entry to lock
+2 ; Returns 0 = failure to obtain lock
+3 ; 1 = lock obtained
+4 ;
+5 ;ZEXCEPT: LA7LOG
+6 ;
+7 NEW LA7Y
+8 SET LA7Y=0
SET LA7DA=+$GET(LA7DA)
+9 LOCK +^LAHM(62.49,LA7DA):10
+10 IF $TEST
SET LA7Y=1
+11 IF 'LA7Y
IF $GET(LA7LOG)
DO LOG("Unable to obtain lock on entry "_LA7DA_" in file #62.49")
+12 QUIT LA7Y
+13 ;
UNLOCK(LA7DA) ; Unlock entry in #62.49
+1 ; Call with LA7DA = entry to lock
+2 ;
+3 SET LA7DA=+$GET(LA7DA)
+4 LOCK -^LAHM(62.49,LA7DA)
+5 QUIT
+6 ;
LACHK() ; Check ^LA("ADL","Q") for build up of entries.
+1 ; Send alert to mail group LAB MESSAGING warning about large # of entries.
+2 NEW LA7CNT,LA7DA,X,Y
+3 SET LA7DA=""
SET LA7CNT=0
+4 FOR
SET LA7DA=$ORDER(^LA("ADL","Q",LA7DA))
if LA7DA=""
QUIT
SET LA7CNT=LA7CNT+1
+5 IF LA7CNT>500
Begin DoDot:1
+6 NEW XQA,XQAID,XQADATA,XQAMSG,XQAOPT,XQAROU
+7 SET XQAMSG="Lab Messaging -Warning- "_LA7CNT_" entries in LA(""ADL"",""Q"") global - please check."
+8 SET XQAID="LA7ADL-"_$HOROLOG
+9 IF $GET(DUZ)>.9
SET XQA(DUZ)=""
+10 SET XQA("G.LAB MESSAGING")=""
+11 DO SETUP^XQALERT
End DoDot:1
+12 QUIT LA7CNT
+13 ;
+14 ;
CHECKMG ; Check if LAB MESSAGING and LMI mail groups has active members.
+1 ; Check mail groups specified for alerts in file #62.48 are valid and have active members.
+2 ;
+3 ;ZEXCEPT: LA7ECNT,LA7IC,LA7LOG,LA7XQA
+4 ;
+5 NEW LA76248,LA7FIX,LA7I,LA7MGERRORS,LA7X,LA7Y,XMERR,XQA,XQAID,XQAMSG
+6 ;
+7 ; Set flag that we've check the membership today.
+8 SET ^XTMP("LA7CHECKMG",0)=DT_"^"_DT_"^LAB HL7 CHECK LAB MESSAGING MAIL GROUP MEMBERS"
+9 ;
+10 KILL ^TMP("XMERR",$JOB)
+11 SET XQAMSG=""
SET LA7FIX=0
SET LA7MGERRORS=LA7ECNT
+12 ;
+13 ; Doucment error message returned by GOTLOCAL API when mail group does not exist.
+14 ;^TMP("XMERR",555809209,1)=39501
+15 ;^TMP("XMERR",555809209,1,"TEXT",1)=Mail group 'LMI' not found.
+16 ;^TMP("XMERR",555809209,"E",39501,1)=
+17 ;
+18 ; Mail group LAB MESSAGING has no active members
+19 IF '$$GOTLOCAL^XMXAPIG("LAB MESSAGING")
Begin DoDot:1
+20 SET LA7MGERRORS("LAB MESSAGING")=""
+21 SET XQAMSG="Lab Messaging - Mail group LAB MESSAGING has no active members"
+22 IF $DATA(^TMP("XMERR",$JOB,"E",39501))
SET XQAMSG="Lab Messaging - Mail group LAB MESSAGING not found"
+23 SET LA7XQA("G.LMI")=""
+24 IF LA7LOG
Begin DoDot:2
+25 IF $DATA(^TMP("XMERR",$JOB,"E",39501))
Begin DoDot:3
+26 SET XQAMSG="Lab Messaging - Mail group LAB MESSAGING not found"
+27 DO LOG("Mail group LAB MESSAGING not found")
End DoDot:3
QUIT
+28 DO LOG("Mail group LAB MESSAGING has no active members")
End DoDot:2
+29 KILL ^TMP("XMERR",$JOB)
End DoDot:1
+30 IF '$TEST
SET LA7XQA("G.LAB MESSAGING")=""
+31 ;
+32 ; Send alert to holders of mail group LMI
+33 IF '$$GOTLOCAL^XMXAPIG("LMI")
Begin DoDot:1
+34 SET LA7MGERRORS("LMI")=""
+35 IF XQAMSG=""
SET XQAMSG="Lab Messaging - Mail group LMI has no active members"
+36 IF '$TEST
SET XQAMSG="Lab Messaging - Mail groups LAB MESSAGING and LMI have no active members"
+37 IF LA7LOG
Begin DoDot:2
+38 IF $DATA(^TMP("XMERR",$JOB,"E",39501))
DO LOG("Mail group LMI not found")
QUIT
+39 DO LOG("Mail group LMI has no active members")
End DoDot:2
+40 KILL LA7XQA("G.LMI"),^TMP("XMERR",$JOB)
End DoDot:1
+41 IF '$TEST
SET LA7XQA("G.LMI")=""
+42 ;
+43 ; Neither LAB MESSAGING or LMI mail groups have active members - send alert to holders of LRLIASON security key
+44 ; Delete previous alerts
+45 IF XQAMSG'=""
Begin DoDot:1
+46 SET XQAID="LA7-MESSAGE-CHECKMG"
+47 DO DEL^LA7UXQA(XQAID)
+48 IF $ORDER(LA7XQA(""))=""
MERGE LA7XQA=^XUSEC("LRLIASON")
+49 MERGE XQA=LA7XQA
+50 DO SETUP^XQALERT
End DoDot:1
+51 ;
+52 SET LA76248=0
+53 FOR
SET LA76248=$ORDER(^LAHM(62.48,LA76248))
if LA76248<1
QUIT
Begin DoDot:1
+54 SET LA7I=0
+55 FOR LA7I=$ORDER(^LAHM(62.48,LA76248,20,LA7I))
if LA7I<1
QUIT
Begin DoDot:2
+56 SET LA7I(0)=$GET(^LAHM(62.48,LA76248,0))
+57 SET LA7Y=$GET(^LAHM(62.48,LA76248,20,LA7I,0))
+58 IF $PIECE(LA7Y,"^",2)=""
QUIT
+59 KILL ^TMP("XMERR",$JOB)
+60 IF $$GOTLOCAL^XMXAPIG($PIECE(LA7Y,"^",2))
QUIT
+61 IF '$DATA(LA7MGERRORS($PIECE(LA7Y,"^",2)))
Begin DoDot:3
+62 SET XQAID="LA7-MESSAGE-CHECKMG-"_$PIECE(LA7Y,"^",2)
+63 DO DEL^LA7UXQA(XQAID)
+64 SET XQAMSG="Lab Messaging - Mail group "_$PIECE(LA7Y,"^",2)_" has no active members"
+65 IF $DATA(^TMP("XMERR",$JOB,"E",39501))
SET XQAMSG="Lab Messaging - Mail group "_$PIECE(LA7Y,"^",2)_" not found"
+66 KILL XQA
+67 MERGE XQA=LA7XQA
+68 DO SETUP^XQALERT
+69 SET LA7MGERRORS($PIECE(LA7Y,"^",2))=""
End DoDot:3
+70 IF LA7LOG
Begin DoDot:3
+71 IF $DATA(^TMP("XMERR",$JOB,"E",39501))
DO LOG("Configuration "_$PIECE(LA7I(0),"^")_" alert mail group "_$PIECE(LA7Y,"^",2)_" not found")
QUIT
+72 DO LOG("Configuration "_$PIECE(LA7I(0),"^")_" alert mail group "_$PIECE(LA7Y,"^",2)_" has no active members")
End DoDot:3
End DoDot:2
End DoDot:1
+73 ;
+74 IF LA7LOG
Begin DoDot:1
+75 SET LA7MGERRORS=LA7ECNT-LA7MGERRORS
+76 ; Total error count
SET $PIECE(^XTMP(LA7IC,0),"^",9)=LA7MGERRORS
End DoDot:1
+77 ;
+78 KILL ^TMP("XMERR",$JOB)
+79 ;
+80 QUIT
+81 ;
+82 ;
INIT ; Initialize variables
+1 ;
+2 ;ZEXCEPT: LA7ECNT,LA7FIX,LA7IC,LA7LOG
+3 ;
+4 ; Set flag to fix problems 1=yes, 0=just check (default)
SET LA7FIX=$GET(LA7FIX,0)
+5 ; Set flag to report problems, 1=yes, 0=no (default)
SET LA7LOG=$GET(LA7LOG,0)
+6 IF LA7LOG
Begin DoDot:1
+7 FOR
SET LA7IC="LA7IC^"_$$NOW^XLFDT
LOCK +^XTMP(LA7IC):9999
if '$DATA(^XTMP(LA7IC))
QUIT
LOCK -^XTMP(LA7IC)
HANG 1
+8 SET DT=$$DT^XLFDT
+9 SET ^XTMP(LA7IC,0)=$$FMADD^XLFDT(DT,7)_"^"_DT_"^Lab Messaging Integrity Checker"_"^"_$$NOW^XLFDT
End DoDot:1
+10 ;
+11 ; Count of number of errors
+12 SET LA7ECNT=0
+13 ;
+14 QUIT
