LRSRVR5 ;DALOI/JMC - LAB DATA SERVER - Load standardized code mappings ;01/13/11 09:16
;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
;
Q
;
;
RMAP ; Load RELMA mapping into site's system
;
;ZEXCEPT: XMZ
;
N LRNAME,LRNODE,LRTYPE
S LRNODE="LRSRVR-RELMA-"_XMZ,LRNAME="Lab RELMA Mapping Update"
S LRTYPE=1,LRTYPE(0)="LN"
D PROCESS
Q
;
;
CTMAP ; Load SNOMED CT mapping into site's system
;
;
;ZEXCEPT: XMZ
;
N LRNAME,LRNODE,LRTYPE
S LRNODE="LRSRVR-SNOMED CT-"_XMZ,LRNAME="Lab SNOMED CT Mapping Update"
S LRTYPE=2,LRTYPE(0)="SCT"
D PROCESS
Q
;
;
PROCESS ; Process the message and load file
;
N DIC,DINUM,DO,LRCNT,LRDT,LRFILE,LRI,LRIEN,LRMAILGROUP,LRNOW,LRST,LRSTN,LRVAL,X
;
;ZEXCEPT: LRHDL,LRNAME,LRTYPE,XMZ
;
S X=$$HTFM^XLFDT($H),LRDT=X\1,LRNOW=X
S LRFILE=95.4,LRVAL=$$SITE^VASITE,LRST=$P(LRVAL,"^",3),LRSTN=$P(LRVAL,"^",2)
S $P(LRVAL,"^",4)=$P($$NNT^XUAF4($P(LRVAL,"^")),"^",3)
;
; Check that mail group has members
S LRMAILGROUP="LAB MAPPING"
I '$$GOTLOCAL^XMXAPIG(LRMAILGROUP) D
. N XQAID,XQAMSG,XQAROU,XQADATA,XQA
. S LRMAILGROUP="LMI"
. S XQAMSG="Lab "_LRTYPE(0)_" mapping process: No local members in mail group LAB MAPPING"
. S XQA("G."_LRMAILGROUP)="",XQAID="LRSRVR-"_$S(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_"-"_$H
. D SETUP^XQALERT
;
; Set lock so only one process runs at a time.
; If unable to obtain lock send Kernel alert to notify site that mapping processing unable to start.
F LRI=1:1:10 L +^XTMP("LABSERVER LOADING"):999 Q:$T
I '$T D Q
. N XQAID,XQAMSG,XQAROU,XQADATA,XQA
. S XQAMSG="Unable to obtain lock to process "_$S(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_" mapping from STS"
. S XQA("G."_LRMAILGROUP)="",XQAID="LRSRVR-"_$S(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_"-"_XMZ
. D SETUP^XQALERT
;
D EXTRACT
;
; Set lock so only one process updates file #95.4 at a time.
; If unable to obtain lock send Kernel alert to notify site that mapping processing unable to start.
F LRI=1:1:10 L +^LAHM(LRFILE,0):999 Q:$T
I '$T D Q
. N XQAID,XQAMSG,XQAROU,XQADATA,XQA
. S XQAMSG="Unable to obtain lock on file #"_LRFILE_" to process "_$S(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_" mapping from STS"
. S XQA("G."_LRMAILGROUP)="",XQAID="LRSRVR-"_$S(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_"-"_XMZ
. D SETUP^XQALERT
;
S (LRCNT,LRI)=0
F S LRI=$O(^TMP($J,"LRMAP",LRI)) Q:'LRI D
. S LRCNT=LRCNT+1
. I '(LRCNT#100) H 1 ; take a "rest" - allow OS to swap out process
. D LDFILE
;
; Release lock
L -^LAHM(LRFILE,0)
;
; Save master list of message handles when it arrives in 'last' message
I $D(^TMP($J,"LRMAP-HDL")) D
. S ^XTMP("LRMAP-HDL-"_LRTYPE(0),0)=$$HTFM^XLFDT($H+1,1)_"^"_LRDT_"^"_LRNAME
. M ^XTMP("LRMAP-HDL-"_LRTYPE(0),1)=^TMP($J,"LRMAP-HDL")
;
; Save this message's handle
I LRHDL'="" D
. S ^XTMP("LRMAP-HDL-"_LRTYPE(0),0)=$$HTFM^XLFDT($H+1,1)_"^"_LRDT_"^"_LRNAME
. S ^XTMP("LRMAP-HDL-"_LRTYPE(0),2,LRHDL)=XMZ
;
; Check to see if all the messages have arrived and start loading mapping
I $D(^XTMP("LRMAP-HDL-"_LRTYPE(0),1)),$D(^XTMP("LRMAP-HDL-"_LRTYPE(0),2)) D
. N I,LROK
. S I=0,LROK=1
. F S I=$O(^XTMP("LRMAP-HDL-"_LRTYPE(0),1,I)) Q:I="" S I(0)=^XTMP("LRMAP-HDL-"_LRTYPE(0),1,I,0) I '$D(^XTMP("LRMAP-HDL-"_LRTYPE(0),2,I(0))) S LROK=0
. I LROK D TASKMAP
;
; Release lock
L -^XTMP("LABSERVER LOADING")
;
; Cleanup mail message after serving
D CLEAN^LRSRVR
;
Q
;
;
;
N LRDATA,LRGLO,LRSTART,LRTEXT
;
;ZEXCEPT: LRDT,LRHDL,LRNAME,LRNODE,LRST,XMFROM,XMREC,XMRG,XMZ
;
; Check if PackMan message.
I '$$PAKMAN^XMXSEC1(XMZ,"") Q
;
I $D(^XTMP(LRNODE)) K ^XTMP(LRNODE)
;
S ^XTMP(LRNODE,0)=$$HTFM^XLFDT($H+90,1)_"^"_LRDT_"^"_LRNAME
S ^XTMP(LRNODE,0,1)="Lab Server triggered at "_LRST_" by "_XMFROM_" on "_$$HTE^XLFDT($H)
;
; Process message looking for global nodes to load.
S (LRSTART,LRTEXT)=0,LRHDL=""
F X XMREC Q:XMER<0 D
. I $E(XMRG,1,4)="$TXT" S LRTEXT=1 Q
. I $E(XMRG,1,8)="END $TXT" S LRTEXT=0 Q
. I $E(XMRG,1,4)="$GLO" S (LRSTART,LRDATA)=1,LRTEXT=0 Q
. I $E(XMRG,1,8)="END $GLO" S LRSTART=0 Q
. I LRTEXT D Q
. . I $E(XMRG,1,7)="LR-MAP-" S LRHDL=XMRG Q
. I 'LRSTART Q
. I LRDATA S LRDATA=0,LRGLO=XMRG Q
. S LRDATA=1,@LRGLO=XMRG
;
I LRHDL'="" S ^XTMP(LRNODE,0,2)=LRHDL
;
Q
;
;
LDFILE ; Load/store entries in mapping transport file.
;
;ZEXCEPT: DA,DIC,DIK,DINUM,DO,LR4,LRFILE,LRI,LRIEN,LRNOW,LRVAL,LRX,X,Y
;
K DIC,DINUM,DO,LRIEN
S LRI(0)=^TMP($J,"LRMAP",LRI,0)
S LRX=$P(LRI(0),"^")
S LR4=$$IEN^XUAF4($P(LRX,"-"))
I $P(LRVAL,"^",4)="VAMC",LR4'=$P(LRVAL,"^") Q
;
S X=LRX,DIC="^LAHM(LRFILE,",DIC(0)="F"
D FILE^DICN
I Y<1 Q
S LRIEN=+Y
;
; Merge rest of entry from TMP global
M ^LAHM(LRFILE,LRIEN,100)=^TMP($J,"LRMAP",LRI,100)
;
S $P(^LAHM(LRFILE,LRIEN,0),"^",2)=LR4
S $P(^LAHM(LRFILE,LRIEN,0),"^",3)=$P(LRI(0),"^",3)
S $P(^LAHM(LRFILE,LRIEN,0),"^",4)=0
S $P(^LAHM(LRFILE,LRIEN,0),"^",6)=LRNOW
;
; Index entry
K DA,DIK
S DIK="^LAHM(LRFILE,",DA=LRIEN
D IX1^DIK
;
Q
;
;
TASKMAP ; Task/run applying the mapping to site's lab files
;
N XQAID,XQAMSG,XQAROU,XQADATA,XQA
;
;ZEXCEPT: LRABORT,LRMAILGROUP,LRTYPE,XMZ
;
;
; Send Kernel alert to notify site that mapping has been triggered.
S XQAMSG=$S(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_" mapping has been triggered from STS on "_$$HTE^XLFDT($H,"1M")
S XQA("G."_LRMAILGROUP)="",XQAID="LRSRVR-"_$S(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_"-"_+$G(XMZ)
D SETUP^XQALERT
;
I LRTYPE=1 Q
;
; Load SNOMED CT codes into lab files
I LRTYPE=2 D
. D LD^LRSCTF(+$$SITE^VASITE,0)
. K ^XTMP("LRMAP-HDL-SCT")
;
; Send Kernel alert to notify site that mapping has ended.
K XQAID,XQAMSG,XQAROU,XQADATA,XQA
S XQAMSG=$S(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_" mapping has "_$S($G(LRABORT):"ABORTED",1:"completed")_" on "_$$HTE^XLFDT($H,"1M")
S XQA("G."_LRMAILGROUP)="",XQAID="LRSRVR-"_$S(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_"-"_+$G(XMZ)
D SETUP^XQALERT
;
Q
;
;
PURGE(LRSTAT,LRDATE) ; Purge entries matching status selected.
; Call with:
; LRSTAT = record status to purge
; LRDATE = (optional) only purge records with a Status Date <= LRDATE
;
N DA,DIK,LRQUIT,LRROOT,LRSTATDT
S LRQUIT=0,LRROOT="^LAHM(95.4,""AE"",LRSTAT)",DIK="^LAHM(95.4,"
F S LRROOT=$Q(@LRROOT) D Q:LRQUIT
. I LRROOT="" S LRQUIT=1 Q
. I $QS(LRROOT,2)'="AE" S LRQUIT=1 Q
. I $QS(LRROOT,3)'=LRSTAT S LRQUIT=1 Q
. S DA=$QS(LRROOT,4)
. S LRSTATDT=$P($G(^LAHM(95.4,+DA,0)),U,6)
. I $G(LRDATE),LRSTATDT>$G(LRDATE) Q
. D ^DIK
Q
;
;
PRGNIGHT ; Called from LRNIGHT to purge eligible entries in file 95.4
;
N LRDAYS,LRDATE,LRSTAT
;
S LRDAYS=$$GET^XPAR("SYS^PKG","LR MAPPING PURGE DAYS",1,"Q")
S LRDATE=$$FMADD^XLFDT(DT,-LRDAYS,0,0,0)
F LRSTAT=0,.5,.7,1,2 D PURGE(LRSTAT,LRDATE)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSRVR5 7085 printed Dec 13, 2024@02:20:52 Page 2
LRSRVR5 ;DALOI/JMC - LAB DATA SERVER - Load standardized code mappings ;01/13/11 09:16
+1 ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
+2 ;
+3 QUIT
+4 ;
+5 ;
RMAP ; Load RELMA mapping into site's system
+1 ;
+2 ;ZEXCEPT: XMZ
+3 ;
+4 NEW LRNAME,LRNODE,LRTYPE
+5 SET LRNODE="LRSRVR-RELMA-"_XMZ
SET LRNAME="Lab RELMA Mapping Update"
+6 SET LRTYPE=1
SET LRTYPE(0)="LN"
+7 DO PROCESS
+8 QUIT
+9 ;
+10 ;
CTMAP ; Load SNOMED CT mapping into site's system
+1 ;
+2 ;
+3 ;ZEXCEPT: XMZ
+4 ;
+5 NEW LRNAME,LRNODE,LRTYPE
+6 SET LRNODE="LRSRVR-SNOMED CT-"_XMZ
SET LRNAME="Lab SNOMED CT Mapping Update"
+7 SET LRTYPE=2
SET LRTYPE(0)="SCT"
+8 DO PROCESS
+9 QUIT
+10 ;
+11 ;
PROCESS ; Process the message and load file
+1 ;
+2 NEW DIC,DINUM,DO,LRCNT,LRDT,LRFILE,LRI,LRIEN,LRMAILGROUP,LRNOW,LRST,LRSTN,LRVAL,X
+3 ;
+4 ;ZEXCEPT: LRHDL,LRNAME,LRTYPE,XMZ
+5 ;
+6 SET X=$$HTFM^XLFDT($HOROLOG)
SET LRDT=X\1
SET LRNOW=X
+7 SET LRFILE=95.4
SET LRVAL=$$SITE^VASITE
SET LRST=$PIECE(LRVAL,"^",3)
SET LRSTN=$PIECE(LRVAL,"^",2)
+8 SET $PIECE(LRVAL,"^",4)=$PIECE($$NNT^XUAF4($PIECE(LRVAL,"^")),"^",3)
+9 ;
+10 ; Check that mail group has members
+11 SET LRMAILGROUP="LAB MAPPING"
+12 IF '$$GOTLOCAL^XMXAPIG(LRMAILGROUP)
Begin DoDot:1
+13 NEW XQAID,XQAMSG,XQAROU,XQADATA,XQA
+14 SET LRMAILGROUP="LMI"
+15 SET XQAMSG="Lab "_LRTYPE(0)_" mapping process: No local members in mail group LAB MAPPING"
+16 SET XQA("G."_LRMAILGROUP)=""
SET XQAID="LRSRVR-"_$SELECT(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_"-"_$HOROLOG
+17 DO SETUP^XQALERT
End DoDot:1
+18 ;
+19 ; Set lock so only one process runs at a time.
+20 ; If unable to obtain lock send Kernel alert to notify site that mapping processing unable to start.
+21 FOR LRI=1:1:10
LOCK +^XTMP("LABSERVER LOADING"):999
if $TEST
QUIT
+22 IF '$TEST
Begin DoDot:1
+23 NEW XQAID,XQAMSG,XQAROU,XQADATA,XQA
+24 SET XQAMSG="Unable to obtain lock to process "_$SELECT(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_" mapping from STS"
+25 SET XQA("G."_LRMAILGROUP)=""
SET XQAID="LRSRVR-"_$SELECT(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_"-"_XMZ
+26 DO SETUP^XQALERT
End DoDot:1
QUIT
+27 ;
+28 DO EXTRACT
+29 ;
+30 ; Set lock so only one process updates file #95.4 at a time.
+31 ; If unable to obtain lock send Kernel alert to notify site that mapping processing unable to start.
+32 FOR LRI=1:1:10
LOCK +^LAHM(LRFILE,0):999
if $TEST
QUIT
+33 IF '$TEST
Begin DoDot:1
+34 NEW XQAID,XQAMSG,XQAROU,XQADATA,XQA
+35 SET XQAMSG="Unable to obtain lock on file #"_LRFILE_" to process "_$SELECT(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_" mapping from STS"
+36 SET XQA("G."_LRMAILGROUP)=""
SET XQAID="LRSRVR-"_$SELECT(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_"-"_XMZ
+37 DO SETUP^XQALERT
End DoDot:1
QUIT
+38 ;
+39 SET (LRCNT,LRI)=0
+40 FOR
SET LRI=$ORDER(^TMP($JOB,"LRMAP",LRI))
if 'LRI
QUIT
Begin DoDot:1
+41 SET LRCNT=LRCNT+1
+42 ; take a "rest" - allow OS to swap out process
IF '(LRCNT#100)
HANG 1
+43 DO LDFILE
End DoDot:1
+44 ;
+45 ; Release lock
+46 LOCK -^LAHM(LRFILE,0)
+47 ;
+48 ; Save master list of message handles when it arrives in 'last' message
+49 IF $DATA(^TMP($JOB,"LRMAP-HDL"))
Begin DoDot:1
+50 SET ^XTMP("LRMAP-HDL-"_LRTYPE(0),0)=$$HTFM^XLFDT($HOROLOG+1,1)_"^"_LRDT_"^"_LRNAME
+51 MERGE ^XTMP("LRMAP-HDL-"_LRTYPE(0),1)=^TMP($JOB,"LRMAP-HDL")
End DoDot:1
+52 ;
+53 ; Save this message's handle
+54 IF LRHDL'=""
Begin DoDot:1
+55 SET ^XTMP("LRMAP-HDL-"_LRTYPE(0),0)=$$HTFM^XLFDT($HOROLOG+1,1)_"^"_LRDT_"^"_LRNAME
+56 SET ^XTMP("LRMAP-HDL-"_LRTYPE(0),2,LRHDL)=XMZ
End DoDot:1
+57 ;
+58 ; Check to see if all the messages have arrived and start loading mapping
+59 IF $DATA(^XTMP("LRMAP-HDL-"_LRTYPE(0),1))
IF $DATA(^XTMP("LRMAP-HDL-"_LRTYPE(0),2))
Begin DoDot:1
+60 NEW I,LROK
+61 SET I=0
SET LROK=1
+62 FOR
SET I=$ORDER(^XTMP("LRMAP-HDL-"_LRTYPE(0),1,I))
if I=""
QUIT
SET I(0)=^XTMP("LRMAP-HDL-"_LRTYPE(0),1,I,0)
IF '$DATA(^XTMP("LRMAP-HDL-"_LRTYPE(0),2,I(0)))
SET LROK=0
+63 IF LROK
DO TASKMAP
End DoDot:1
+64 ;
+65 ; Release lock
+66 LOCK -^XTMP("LABSERVER LOADING")
+67 ;
+68 ; Cleanup mail message after serving
+69 DO CLEAN^LRSRVR
+70 ;
+71 QUIT
+72 ;
+73 ;
+1 ;
+2 NEW LRDATA,LRGLO,LRSTART,LRTEXT
+3 ;
+4 ;ZEXCEPT: LRDT,LRHDL,LRNAME,LRNODE,LRST,XMFROM,XMREC,XMRG,XMZ
+5 ;
+6 ; Check if PackMan message.
+7 IF '$$PAKMAN^XMXSEC1(XMZ,"")
QUIT
+8 ;
+9 IF $DATA(^XTMP(LRNODE))
KILL ^XTMP(LRNODE)
+10 ;
+11 SET ^XTMP(LRNODE,0)=$$HTFM^XLFDT($HOROLOG+90,1)_"^"_LRDT_"^"_LRNAME
+12 SET ^XTMP(LRNODE,0,1)="Lab Server triggered at "_LRST_" by "_XMFROM_" on "_$$HTE^XLFDT($HOROLOG)
+13 ;
+14 ; Process message looking for global nodes to load.
+15 SET (LRSTART,LRTEXT)=0
SET LRHDL=""
+16 FOR
XECUTE XMREC
if XMER<0
QUIT
Begin DoDot:1
+17 IF $EXTRACT(XMRG,1,4)="$TXT"
SET LRTEXT=1
QUIT
+18 IF $EXTRACT(XMRG,1,8)="END $TXT"
SET LRTEXT=0
QUIT
+19 IF $EXTRACT(XMRG,1,4)="$GLO"
SET (LRSTART,LRDATA)=1
SET LRTEXT=0
QUIT
+20 IF $EXTRACT(XMRG,1,8)="END $GLO"
SET LRSTART=0
QUIT
+21 IF LRTEXT
Begin DoDot:2
+22 IF $EXTRACT(XMRG,1,7)="LR-MAP-"
SET LRHDL=XMRG
QUIT
End DoDot:2
QUIT
+23 IF 'LRSTART
QUIT
+24 IF LRDATA
SET LRDATA=0
SET LRGLO=XMRG
QUIT
+25 SET LRDATA=1
SET @LRGLO=XMRG
End DoDot:1
+26 ;
+27 IF LRHDL'=""
SET ^XTMP(LRNODE,0,2)=LRHDL
+28 ;
+29 QUIT
+30 ;
+31 ;
LDFILE ; Load/store entries in mapping transport file.
+1 ;
+2 ;ZEXCEPT: DA,DIC,DIK,DINUM,DO,LR4,LRFILE,LRI,LRIEN,LRNOW,LRVAL,LRX,X,Y
+3 ;
+4 KILL DIC,DINUM,DO,LRIEN
+5 SET LRI(0)=^TMP($JOB,"LRMAP",LRI,0)
+6 SET LRX=$PIECE(LRI(0),"^")
+7 SET LR4=$$IEN^XUAF4($PIECE(LRX,"-"))
+8 IF $PIECE(LRVAL,"^",4)="VAMC"
IF LR4'=$PIECE(LRVAL,"^")
QUIT
+9 ;
+10 SET X=LRX
SET DIC="^LAHM(LRFILE,"
SET DIC(0)="F"
+11 DO FILE^DICN
+12 IF Y<1
QUIT
+13 SET LRIEN=+Y
+14 ;
+15 ; Merge rest of entry from TMP global
+16 MERGE ^LAHM(LRFILE,LRIEN,100)=^TMP($JOB,"LRMAP",LRI,100)
+17 ;
+18 SET $PIECE(^LAHM(LRFILE,LRIEN,0),"^",2)=LR4
+19 SET $PIECE(^LAHM(LRFILE,LRIEN,0),"^",3)=$PIECE(LRI(0),"^",3)
+20 SET $PIECE(^LAHM(LRFILE,LRIEN,0),"^",4)=0
+21 SET $PIECE(^LAHM(LRFILE,LRIEN,0),"^",6)=LRNOW
+22 ;
+23 ; Index entry
+24 KILL DA,DIK
+25 SET DIK="^LAHM(LRFILE,"
SET DA=LRIEN
+26 DO IX1^DIK
+27 ;
+28 QUIT
+29 ;
+30 ;
TASKMAP ; Task/run applying the mapping to site's lab files
+1 ;
+2 NEW XQAID,XQAMSG,XQAROU,XQADATA,XQA
+3 ;
+4 ;ZEXCEPT: LRABORT,LRMAILGROUP,LRTYPE,XMZ
+5 ;
+6 ;
+7 ; Send Kernel alert to notify site that mapping has been triggered.
+8 SET XQAMSG=$SELECT(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_" mapping has been triggered from STS on "_$$HTE^XLFDT($HOROLOG,"1M")
+9 SET XQA("G."_LRMAILGROUP)=""
SET XQAID="LRSRVR-"_$SELECT(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_"-"_+$GET(XMZ)
+10 DO SETUP^XQALERT
+11 ;
+12 IF LRTYPE=1
QUIT
+13 ;
+14 ; Load SNOMED CT codes into lab files
+15 IF LRTYPE=2
Begin DoDot:1
+16 DO LD^LRSCTF(+$$SITE^VASITE,0)
+17 KILL ^XTMP("LRMAP-HDL-SCT")
End DoDot:1
+18 ;
+19 ; Send Kernel alert to notify site that mapping has ended.
+20 KILL XQAID,XQAMSG,XQAROU,XQADATA,XQA
+21 SET XQAMSG=$SELECT(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_" mapping has "_$SELECT($GET(LRABORT):"ABORTED",1:"completed")_" on "_$$HTE^XLFDT($HOROLOG,"1M")
+22 SET XQA("G."_LRMAILGROUP)=""
SET XQAID="LRSRVR-"_$SELECT(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_"-"_+$GET(XMZ)
+23 DO SETUP^XQALERT
+24 ;
+25 QUIT
+26 ;
+27 ;
PURGE(LRSTAT,LRDATE) ; Purge entries matching status selected.
+1 ; Call with:
+2 ; LRSTAT = record status to purge
+3 ; LRDATE = (optional) only purge records with a Status Date <= LRDATE
+4 ;
+5 NEW DA,DIK,LRQUIT,LRROOT,LRSTATDT
+6 SET LRQUIT=0
SET LRROOT="^LAHM(95.4,""AE"",LRSTAT)"
SET DIK="^LAHM(95.4,"
+7 FOR
SET LRROOT=$QUERY(@LRROOT)
Begin DoDot:1
+8 IF LRROOT=""
SET LRQUIT=1
QUIT
+9 IF $QSUBSCRIPT(LRROOT,2)'="AE"
SET LRQUIT=1
QUIT
+10 IF $QSUBSCRIPT(LRROOT,3)'=LRSTAT
SET LRQUIT=1
QUIT
+11 SET DA=$QSUBSCRIPT(LRROOT,4)
+12 SET LRSTATDT=$PIECE($GET(^LAHM(95.4,+DA,0)),U,6)
+13 IF $GET(LRDATE)
IF LRSTATDT>$GET(LRDATE)
QUIT
+14 DO ^DIK
End DoDot:1
if LRQUIT
QUIT
+15 QUIT
+16 ;
+17 ;
PRGNIGHT ; Called from LRNIGHT to purge eligible entries in file 95.4
+1 ;
+2 NEW LRDAYS,LRDATE,LRSTAT
+3 ;
+4 SET LRDAYS=$$GET^XPAR("SYS^PKG","LR MAPPING PURGE DAYS",1,"Q")
+5 SET LRDATE=$$FMADD^XLFDT(DT,-LRDAYS,0,0,0)
+6 FOR LRSTAT=0,.5,.7,1,2
DO PURGE(LRSTAT,LRDATE)
+7 ;
+8 QUIT
