LRSRVR5.m

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

 ;

 ;

EXTRACT ; Extract data from PackMan global format in MailMan message.

 ;

 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 ---LRSRVR5   7085     printed  Feb 18, 2025@23:46:44                                                                                                                                                                                                     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      ;

EXTRACT   ; Extract data from PackMan global format in MailMan message.

 +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