LA7CHKF1 ;DALOI/LMT - Check SNOMED CT mappings against Lexicon for exceptions ;01/10/13 08:56
;;5.2;AUTOMATED LAB INSTRUMENTS;**80**;Sep 27, 1994;Build 19
;
;
; This routine checks the SNOMED CT mappings against the Lexicon for exceptions.
; It checks the following files:
; - Topography Field (#61)
; - Etiology Field (#61.2)
; - Collection Sample (#62)
;
; If any exceptions are found:
; - the SCT CODE STATUS field for the entry will be updated to 'Error'
; - an HDI exception alert will be sent to STS
; - a MailMan message will be sent to the local staff with a list of all the exceptions found
;
; ZEXCEPT is used to identify variables which are external to a specific TAG
; used in conjunction with Eclipse M-editor.
;
;
EN ; Entry point
;
;ZEXCEPT: ZTQUEUED
;
N LACNT,LAFIEN,LAFILE,LALINE,LASCT,X
;
D CLEAN ;kill TMP global
;
S LACNT=0
;
;loop through "F" x-ref on files 61,61.2,62
F LAFILE=61,61.2,62 D
. S LASCT=""
. F S LASCT=$O(^LAB(LAFILE,"F",LASCT)) Q:LASCT="" D
. . ;
. . S LAFIEN=0
. . F S LAFIEN=$O(^LAB(LAFILE,"F",LASCT,LAFIEN)) Q:'LAFIEN D
. . . ;
. . . S LACNT=LACNT+1
. . . I '(LACNT#100) H 1 ; take a "rest" - allow OS to swap out process
. . . I '$D(ZTQUEUED) W:'(LACNT#50) "."
. . . ;
. . . D CHECK(LAFILE,LAFIEN,LASCT) ; Check entry against lexicon
;
; Send MailMan message to local staff if any exceptions were found.
I $D(^TMP("LA7CHK",$J,"MSG"))!($D(^TMP("LA7CHK",$J,"ERR"))) S X=$$SENDMSG
;
D CLEAN
;
Q
;
CHECK(LAFILE,LAFIEN,LASCT) ; Check Entry against Lexicon
;
N LAALRTST,LACODEINFO,LALEX,LALEXERR,LALEXSTAT,LANAME,LASCTSTAT
;
S LANAME=$P($G(^LAB(LAFILE,LAFIEN,0)),U,1)
;
S LACODEINFO=$$CODE^LRSCT(LASCT,"SCT",DT,"LALEX")
S LALEXSTAT=$P(LACODEINFO,U,1)
S LALEXERR=""
I LALEXSTAT<0 S LALEXERR=$P(LACODEINFO,U,2)
I $P($G(LALEX(0)),U,1)="" S $P(LALEX(0),U,1)=LASCT
;
S LASCTSTAT=$$GET1^DIQ(LAFILE,LAFIEN_",",21,"I")
I LASCTSTAT="E" Q ; Alert was already sent - don't send duplicate alert
;
I LASCTSTAT="LN",LALEXSTAT=-1 Q ; Code still does not exist in Lexicon. Don't send duplicate alert.
I LASCTSTAT="LN",LALEXSTAT=1 D Q ; Code now exists in the Lexicon. Update SCT CODE STATUS field and Quit.
. N LASTATUS
. ;
. S LASTATUS="L" ; Default [L] = The spelling is not standard
. I $$UP^XLFSTR(LANAME)=$$UP^XLFSTR($G(LALEX("P"))) S LASTATUS="P" ; preferred term
. I $$UP^XLFSTR(LANAME)=$$UP^XLFSTR($G(LALEX("F"))) S LASTATUS="P" ; preferred term
. I LASTATUS'="P",$O(LALEX("S",0)) D ; Check to see if term is a synonym
. . N I
. . S I=0
. . F S I=$O(LALEX("S",I)) Q:I<1 I $$UP^XLFSTR(LANAME)=$$UP^XLFSTR(LALEX("S",I)) S LASTATUS="S" Q
. . ;
. D UPDSTAT(LAFILE,LAFIEN,LASTATUS,"")
;
I LALEXSTAT<0 D
. S LAALRTST=$$SNDALERT(LAFILE,LAFIEN,LANAME,LASCT,LACODEINFO) ; Send HDI alert to STS
. D BLDMSG(LAFILE,LAFIEN,LANAME,.LALEX,LACODEINFO,LAALRTST) ; build mailman message
. D UPDSTAT(LAFILE,LAFIEN,"E",LALEXERR,$P(LAALRTST,U,4)) ; update SCT CODE STATUS to 'Error'
;
Q
;
SNDALERT(LAFILE,LAFIEN,LANAME,LASCT,LACODEINFO) ; Build alert that will be sent to STS. Return alert status.
;
N EXCDATA,LAALRTST,LADATA,TNUM,X
;
; Lab mapping exception
S EXCDATA("TXT")=$P(LACODEINFO,U,2)
;
S LAALRTST=$$NOTIFY^LRSCTF1(LANAME,LAFILE,LAFIEN,LASCT,.EXCDATA,0)
S TNUM=$G(EXCDATA("TNUM"))
S $P(LAALRTST,U,4)=TNUM
;
Q LAALRTST
;
BLDMSG(LAFILE,LAFIEN,LANAME,LALEX,LACODEINFO,LAALRTST) ; Build additional message text
;
N I,LACODETXT,LAERROR,LAMSGSUB
;
S LAMSGSUB="MSG"
;
I $D(LAALRTST),'LAALRTST,$P(LAALRTST,U,2)=5 S LAERROR=1,LAMSGSUB="ERR"
;
; Format 'Code Text' to display nicely on multiple lines
D FRMTTXT($G(LALEX("F")),1,60,.LACODETXT)
;
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=""
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=" "_$$REPEAT^XLFSTR("-",76)
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=""
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=" File #: "_LAFILE
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=" IEN #: "_LAFIEN
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=" Entry Name: "_LANAME
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=" SNOMED CT ID: "_$P(LALEX(0),U,1)
I $G(LALEX("F"))'="" D
. S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=" SNOMED CT Term: "_$G(LACODETXT(1,0))
. S I=1
. F S I=$O(LACODETXT(I)) Q:'I D
. . I $G(LACODETXT(I,0))'="" D
. . . S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=" "_$G(LACODETXT(I,0))
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=" Error: "_$P(LACODEINFO,U,2)
I $G(LAERROR) D
. S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=" STS Alert Failed: "_$P(LAALRTST,"^",3)
I '$G(LAERROR),$P($G(LAALRTST),U,4)'="" D
. S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=" STS Transaction #: "_$P(LAALRTST,U,4)
;
Q
;
UPDSTAT(LAFILE,LAFIEN,LASTATUS,LALEXERR,LATNUM) ; Update SCT CODE STATUS field
;
N LAERR,LAFDA,LRFMERTS
;
I $G(LASTATUS)="" Q
; Lock file entry prior to updating
F L +^LAB(LAFILE,LAFIEN):DILOCKTM+15 Q:$T
;
; Stop AERT xref from triggering alert (from ^LRERT1)
S LRFMERTS=1
S LRFMERTS("STS","STAT")="OK"
S LRFMERTS("STS","PROC")="CHECK"
;
; Update Status
S LAFDA(1,LAFILE,LAFIEN_",",21)=LASTATUS
D FILE^DIE("","LAFDA(1)","LAERR(1)")
;
; Update SCT STATUS DATE multiple
D SCTUPD(LAFILE,LAFIEN,LASTATUS,$G(LALEXERR),$G(LATNUM))
;
L -^LAB(LAFILE,LAFIEN)
;
Q
;
SCTUPD(LAFILE,LAFIEN,LASTATUS,LALEXERR,LATNUM) ; Update SCT STATUS DATE multiple
;
N LACNT,LAERR,LAFDA,LASUBFILE,LAWP
;
S LASUBFILE=$S(LAFILE=61:61.023,LAFILE=61.2:61.223,LAFILE=62:62.023,1:"")
I LASUBFILE="" Q
;
; Store date/time, user and new status
S LAFDA(2,LASUBFILE,"+2,"_LAFIEN_",",.01)=$$NOW^XLFDT
S LAFDA(2,LASUBFILE,"+2,"_LAFIEN_",",1)=LASTATUS
S LAFDA(2,LASUBFILE,"+2,"_LAFIEN_",",3)=DUZ
; Store transaction number
I $G(LATNUM)'="" S LAFDA(2,LASUBFILE,"+2,"_LAFIEN_",",2)=LATNUM
;
D UPDATE^DIE("","LAFDA(2)","LAFIEN","LAERR(2)")
;
I '$G(LAFIEN(2)) Q
;
S LACNT=1
S LAWP(LACNT)="SCT CODE STATUS updated by system due to current status in the Lexicon."
S LACNT=LACNT+1
; Record any reported Lexicon API error
I $G(LALEXERR)'="" D
. S LAWP(LACNT)=" "
. S LACNT=LACNT+1
. S LAWP(LACNT)="Lexicon API: "_LALEXERR
. S LACNT=LACNT+1
;
I $D(LAWP) D WP^DIE(LASUBFILE,LAFIEN(2)_","_LAFIEN_",",4,"A","LAWP","LAERR(3)")
;
Q
;
SENDMSG() ; Send MailMan message. Return message ID.
;
N I,LABODY,LAMSGSUB,LASUB,XMERR,XMINSTR,XMSUBJ,XMTO,XMZ
;
S LAMSGSUB="MSGFINAL"
;
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))="Due to a recent Lexicon patch that updated the SNOMED CT (SCT) code set at"
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))="your facility, some of the Lab entries in the TOPOGRAPHY FIELD file (#61),"
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))="COLLECTION SAMPLE file (#62), and ETIOLOGY FIELD file (#61.2) are mapped to"
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))="SCT codes that have been deprecated or have other exceptions."
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=""
;
; if failed to send alert to STS, use this verbiage:
I $D(^TMP("LA7CHK",$J,"ERR")) D
. S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))="An STS alert failed to be generated for some of these exceptions."
. S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))="Please contact Standards & Terminology Services (STS) to have those SNOMED"
. S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))="CT mappings updated."
;
; if alert was sent to STS, use this verbiage:
I '$D(^TMP("LA7CHK",$J,"ERR")) D
. S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))="Standards & Terminology Services (STS) has received notification of these"
. S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))="SNOMED CT exceptions and will provide your site with a new SCT mapping file"
. S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))="within several weeks or less."
. S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=""
. S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))="-----------------------------------------------------------------------------"
. S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=" NOTE: YOU DO NOT NEED TO DO ANYTHING UNTIL YOU GET THE UPDATED MAPPING FILE"
. S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=" FROM STS"
. S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))="-----------------------------------------------------------------------------"
;
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=""
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))="The following SNOMED CT exceptions have been found at:"
S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=$$NAME^XUAF4($$KSP^XUPARAM("INST"))_" ("_$$KSP^XUPARAM("WHERE")_")."
;
F LASUB="ERR","MSG" D
. S I=0
. F S I=$O(^TMP("LA7CHK",$J,LASUB,I)) Q:'I D
. . S ^TMP("LA7CHK",$J,LAMSGSUB,$$LN(LAMSGSUB))=$G(^TMP("LA7CHK",$J,LASUB,I))
;
S XMSUBJ="SNOMED CT MAPPING ERRORS"
S LABODY="^TMP(""LA7CHK"",$J,"""_LAMSGSUB_""")"
S XMINSTR("ADDR FLAGS")="R"
S XMINSTR("FROM")="LAB PACKAGE"
;
I $$GOTLOCAL^XMXAPIG("LAB MESSAGING") S XMTO("G.LAB MESSAGING")=""
I $$GOTLOCAL^XMXAPIG("LMI") S XMTO("G.LMI")=""
I '$D(XMTO) M XMTO=^XUSEC("LRLIASON") ; File ^XUSEC/10076
;
D SENDMSG^XMXAPI(DUZ,XMSUBJ,LABODY,.XMTO,.XMINSTR,.XMZ)
;
K ^TMP("XMERR",$J)
;
Q $G(XMZ)
;
FRMTTXT(TEXT,LMARGIN,RMARGIN,LARSLT) ;Format Text
;
; Format text
;
; Input:
; TEXT = The text to format
; LMARGIN (optional) = The left margin for the text
; Defaults to 1
; RMARGIN (optional) = The right margin for the text
; Defaults to 80
; LARSLT = The resulting array
;
N DIWF,DIWL,DIWR,X
;
K ^UTILITY($J,"W")
S DIWL=$G(LMARGIN)
S DIWR=$G(RMARGIN)
I DIWL="" S DIWL=1
I DIWR="" S DIWR=80
S DIWF=""
S X=TEXT
D ^DIWP
M LARSLT=^UTILITY($J,"W",DIWL)
K ^UTILITY($J,"W")
;
Q
;
LN(SUB) ; Increment the line counter.
;
;ZEXCEPT: LALINE
;
S LALINE(SUB)=$G(LALINE(SUB))+1
Q LALINE(SUB)
;
CLEAN ; Clean up tmp global(s)
;
K ^TMP("LA7CHK",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7CHKF1 10153 printed Sep 23, 2025@19:15 Page 2
LA7CHKF1 ;DALOI/LMT - Check SNOMED CT mappings against Lexicon for exceptions ;01/10/13 08:56
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**80**;Sep 27, 1994;Build 19
+2 ;
+3 ;
+4 ; This routine checks the SNOMED CT mappings against the Lexicon for exceptions.
+5 ; It checks the following files:
+6 ; - Topography Field (#61)
+7 ; - Etiology Field (#61.2)
+8 ; - Collection Sample (#62)
+9 ;
+10 ; If any exceptions are found:
+11 ; - the SCT CODE STATUS field for the entry will be updated to 'Error'
+12 ; - an HDI exception alert will be sent to STS
+13 ; - a MailMan message will be sent to the local staff with a list of all the exceptions found
+14 ;
+15 ; ZEXCEPT is used to identify variables which are external to a specific TAG
+16 ; used in conjunction with Eclipse M-editor.
+17 ;
+18 ;
EN ; Entry point
+1 ;
+2 ;ZEXCEPT: ZTQUEUED
+3 ;
+4 NEW LACNT,LAFIEN,LAFILE,LALINE,LASCT,X
+5 ;
+6 ;kill TMP global
DO CLEAN
+7 ;
+8 SET LACNT=0
+9 ;
+10 ;loop through "F" x-ref on files 61,61.2,62
+11 FOR LAFILE=61,61.2,62
Begin DoDot:1
+12 SET LASCT=""
+13 FOR
SET LASCT=$ORDER(^LAB(LAFILE,"F",LASCT))
if LASCT=""
QUIT
Begin DoDot:2
+14 ;
+15 SET LAFIEN=0
+16 FOR
SET LAFIEN=$ORDER(^LAB(LAFILE,"F",LASCT,LAFIEN))
if 'LAFIEN
QUIT
Begin DoDot:3
+17 ;
+18 SET LACNT=LACNT+1
+19 ; take a "rest" - allow OS to swap out process
IF '(LACNT#100)
HANG 1
+20 IF '$DATA(ZTQUEUED)
if '(LACNT#50)
WRITE "."
+21 ;
+22 ; Check entry against lexicon
DO CHECK(LAFILE,LAFIEN,LASCT)
End DoDot:3
End DoDot:2
End DoDot:1
+23 ;
+24 ; Send MailMan message to local staff if any exceptions were found.
+25 IF $DATA(^TMP("LA7CHK",$JOB,"MSG"))!($DATA(^TMP("LA7CHK",$JOB,"ERR")))
SET X=$$SENDMSG
+26 ;
+27 DO CLEAN
+28 ;
+29 QUIT
+30 ;
CHECK(LAFILE,LAFIEN,LASCT) ; Check Entry against Lexicon
+1 ;
+2 NEW LAALRTST,LACODEINFO,LALEX,LALEXERR,LALEXSTAT,LANAME,LASCTSTAT
+3 ;
+4 SET LANAME=$PIECE($GET(^LAB(LAFILE,LAFIEN,0)),U,1)
+5 ;
+6 SET LACODEINFO=$$CODE^LRSCT(LASCT,"SCT",DT,"LALEX")
+7 SET LALEXSTAT=$PIECE(LACODEINFO,U,1)
+8 SET LALEXERR=""
+9 IF LALEXSTAT<0
SET LALEXERR=$PIECE(LACODEINFO,U,2)
+10 IF $PIECE($GET(LALEX(0)),U,1)=""
SET $PIECE(LALEX(0),U,1)=LASCT
+11 ;
+12 SET LASCTSTAT=$$GET1^DIQ(LAFILE,LAFIEN_",",21,"I")
+13 ; Alert was already sent - don't send duplicate alert
IF LASCTSTAT="E"
QUIT
+14 ;
+15 ; Code still does not exist in Lexicon. Don't send duplicate alert.
IF LASCTSTAT="LN"
IF LALEXSTAT=-1
QUIT
+16 ; Code now exists in the Lexicon. Update SCT CODE STATUS field and Quit.
IF LASCTSTAT="LN"
IF LALEXSTAT=1
Begin DoDot:1
+17 NEW LASTATUS
+18 ;
+19 ; Default [L] = The spelling is not standard
SET LASTATUS="L"
+20 ; preferred term
IF $$UP^XLFSTR(LANAME)=$$UP^XLFSTR($GET(LALEX("P")))
SET LASTATUS="P"
+21 ; preferred term
IF $$UP^XLFSTR(LANAME)=$$UP^XLFSTR($GET(LALEX("F")))
SET LASTATUS="P"
+22 ; Check to see if term is a synonym
IF LASTATUS'="P"
IF $ORDER(LALEX("S",0))
Begin DoDot:2
+23 NEW I
+24 SET I=0
+25 FOR
SET I=$ORDER(LALEX("S",I))
if I<1
QUIT
IF $$UP^XLFSTR(LANAME)=$$UP^XLFSTR(LALEX("S",I))
SET LASTATUS="S"
QUIT
+26 ;
End DoDot:2
+27 DO UPDSTAT(LAFILE,LAFIEN,LASTATUS,"")
End DoDot:1
QUIT
+28 ;
+29 IF LALEXSTAT<0
Begin DoDot:1
+30 ; Send HDI alert to STS
SET LAALRTST=$$SNDALERT(LAFILE,LAFIEN,LANAME,LASCT,LACODEINFO)
+31 ; build mailman message
DO BLDMSG(LAFILE,LAFIEN,LANAME,.LALEX,LACODEINFO,LAALRTST)
+32 ; update SCT CODE STATUS to 'Error'
DO UPDSTAT(LAFILE,LAFIEN,"E",LALEXERR,$PIECE(LAALRTST,U,4))
End DoDot:1
+33 ;
+34 QUIT
+35 ;
SNDALERT(LAFILE,LAFIEN,LANAME,LASCT,LACODEINFO) ; Build alert that will be sent to STS. Return alert status.
+1 ;
+2 NEW EXCDATA,LAALRTST,LADATA,TNUM,X
+3 ;
+4 ; Lab mapping exception
+5 SET EXCDATA("TXT")=$PIECE(LACODEINFO,U,2)
+6 ;
+7 SET LAALRTST=$$NOTIFY^LRSCTF1(LANAME,LAFILE,LAFIEN,LASCT,.EXCDATA,0)
+8 SET TNUM=$GET(EXCDATA("TNUM"))
+9 SET $PIECE(LAALRTST,U,4)=TNUM
+10 ;
+11 QUIT LAALRTST
+12 ;
BLDMSG(LAFILE,LAFIEN,LANAME,LALEX,LACODEINFO,LAALRTST) ; Build additional message text
+1 ;
+2 NEW I,LACODETXT,LAERROR,LAMSGSUB
+3 ;
+4 SET LAMSGSUB="MSG"
+5 ;
+6 IF $DATA(LAALRTST)
IF 'LAALRTST
IF $PIECE(LAALRTST,U,2)=5
SET LAERROR=1
SET LAMSGSUB="ERR"
+7 ;
+8 ; Format 'Code Text' to display nicely on multiple lines
+9 DO FRMTTXT($GET(LALEX("F")),1,60,.LACODETXT)
+10 ;
+11 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=""
+12 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=" "_$$REPEAT^XLFSTR("-",76)
+13 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=""
+14 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=" File #: "_LAFILE
+15 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=" IEN #: "_LAFIEN
+16 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=" Entry Name: "_LANAME
+17 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=" SNOMED CT ID: "_$PIECE(LALEX(0),U,1)
+18 IF $GET(LALEX("F"))'=""
Begin DoDot:1
+19 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=" SNOMED CT Term: "_$GET(LACODETXT(1,0))
+20 SET I=1
+21 FOR
SET I=$ORDER(LACODETXT(I))
if 'I
QUIT
Begin DoDot:2
+22 IF $GET(LACODETXT(I,0))'=""
Begin DoDot:3
+23 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=" "_$GET(LACODETXT(I,0))
End DoDot:3
End DoDot:2
End DoDot:1
+24 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=" Error: "_$PIECE(LACODEINFO,U,2)
+25 IF $GET(LAERROR)
Begin DoDot:1
+26 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=" STS Alert Failed: "_$PIECE(LAALRTST,"^",3)
End DoDot:1
+27 IF '$GET(LAERROR)
IF $PIECE($GET(LAALRTST),U,4)'=""
Begin DoDot:1
+28 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=" STS Transaction #: "_$PIECE(LAALRTST,U,4)
End DoDot:1
+29 ;
+30 QUIT
+31 ;
UPDSTAT(LAFILE,LAFIEN,LASTATUS,LALEXERR,LATNUM) ; Update SCT CODE STATUS field
+1 ;
+2 NEW LAERR,LAFDA,LRFMERTS
+3 ;
+4 IF $GET(LASTATUS)=""
QUIT
+5 ; Lock file entry prior to updating
+6 FOR
LOCK +^LAB(LAFILE,LAFIEN):DILOCKTM+15
if $TEST
QUIT
+7 ;
+8 ; Stop AERT xref from triggering alert (from ^LRERT1)
+9 SET LRFMERTS=1
+10 SET LRFMERTS("STS","STAT")="OK"
+11 SET LRFMERTS("STS","PROC")="CHECK"
+12 ;
+13 ; Update Status
+14 SET LAFDA(1,LAFILE,LAFIEN_",",21)=LASTATUS
+15 DO FILE^DIE("","LAFDA(1)","LAERR(1)")
+16 ;
+17 ; Update SCT STATUS DATE multiple
+18 DO SCTUPD(LAFILE,LAFIEN,LASTATUS,$GET(LALEXERR),$GET(LATNUM))
+19 ;
+20 LOCK -^LAB(LAFILE,LAFIEN)
+21 ;
+22 QUIT
+23 ;
SCTUPD(LAFILE,LAFIEN,LASTATUS,LALEXERR,LATNUM) ; Update SCT STATUS DATE multiple
+1 ;
+2 NEW LACNT,LAERR,LAFDA,LASUBFILE,LAWP
+3 ;
+4 SET LASUBFILE=$SELECT(LAFILE=61:61.023,LAFILE=61.2:61.223,LAFILE=62:62.023,1:"")
+5 IF LASUBFILE=""
QUIT
+6 ;
+7 ; Store date/time, user and new status
+8 SET LAFDA(2,LASUBFILE,"+2,"_LAFIEN_",",.01)=$$NOW^XLFDT
+9 SET LAFDA(2,LASUBFILE,"+2,"_LAFIEN_",",1)=LASTATUS
+10 SET LAFDA(2,LASUBFILE,"+2,"_LAFIEN_",",3)=DUZ
+11 ; Store transaction number
+12 IF $GET(LATNUM)'=""
SET LAFDA(2,LASUBFILE,"+2,"_LAFIEN_",",2)=LATNUM
+13 ;
+14 DO UPDATE^DIE("","LAFDA(2)","LAFIEN","LAERR(2)")
+15 ;
+16 IF '$GET(LAFIEN(2))
QUIT
+17 ;
+18 SET LACNT=1
+19 SET LAWP(LACNT)="SCT CODE STATUS updated by system due to current status in the Lexicon."
+20 SET LACNT=LACNT+1
+21 ; Record any reported Lexicon API error
+22 IF $GET(LALEXERR)'=""
Begin DoDot:1
+23 SET LAWP(LACNT)=" "
+24 SET LACNT=LACNT+1
+25 SET LAWP(LACNT)="Lexicon API: "_LALEXERR
+26 SET LACNT=LACNT+1
End DoDot:1
+27 ;
+28 IF $DATA(LAWP)
DO WP^DIE(LASUBFILE,LAFIEN(2)_","_LAFIEN_",",4,"A","LAWP","LAERR(3)")
+29 ;
+30 QUIT
+31 ;
SENDMSG() ; Send MailMan message. Return message ID.
+1 ;
+2 NEW I,LABODY,LAMSGSUB,LASUB,XMERR,XMINSTR,XMSUBJ,XMTO,XMZ
+3 ;
+4 SET LAMSGSUB="MSGFINAL"
+5 ;
+6 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))="Due to a recent Lexicon patch that updated the SNOMED CT (SCT) code set at"
+7 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))="your facility, some of the Lab entries in the TOPOGRAPHY FIELD file (#61),"
+8 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))="COLLECTION SAMPLE file (#62), and ETIOLOGY FIELD file (#61.2) are mapped to"
+9 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))="SCT codes that have been deprecated or have other exceptions."
+10 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=""
+11 ;
+12 ; if failed to send alert to STS, use this verbiage:
+13 IF $DATA(^TMP("LA7CHK",$JOB,"ERR"))
Begin DoDot:1
+14 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))="An STS alert failed to be generated for some of these exceptions."
+15 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))="Please contact Standards & Terminology Services (STS) to have those SNOMED"
+16 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))="CT mappings updated."
End DoDot:1
+17 ;
+18 ; if alert was sent to STS, use this verbiage:
+19 IF '$DATA(^TMP("LA7CHK",$JOB,"ERR"))
Begin DoDot:1
+20 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))="Standards & Terminology Services (STS) has received notification of these"
+21 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))="SNOMED CT exceptions and will provide your site with a new SCT mapping file"
+22 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))="within several weeks or less."
+23 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=""
+24 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))="-----------------------------------------------------------------------------"
+25 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=" NOTE: YOU DO NOT NEED TO DO ANYTHING UNTIL YOU GET THE UPDATED MAPPING FILE"
+26 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=" FROM STS"
+27 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))="-----------------------------------------------------------------------------"
End DoDot:1
+28 ;
+29 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=""
+30 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))="The following SNOMED CT exceptions have been found at:"
+31 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=$$NAME^XUAF4($$KSP^XUPARAM("INST"))_" ("_$$KSP^XUPARAM("WHERE")_")."
+32 ;
+33 FOR LASUB="ERR","MSG"
Begin DoDot:1
+34 SET I=0
+35 FOR
SET I=$ORDER(^TMP("LA7CHK",$JOB,LASUB,I))
if 'I
QUIT
Begin DoDot:2
+36 SET ^TMP("LA7CHK",$JOB,LAMSGSUB,$$LN(LAMSGSUB))=$GET(^TMP("LA7CHK",$JOB,LASUB,I))
End DoDot:2
End DoDot:1
+37 ;
+38 SET XMSUBJ="SNOMED CT MAPPING ERRORS"
+39 SET LABODY="^TMP(""LA7CHK"",$J,"""_LAMSGSUB_""")"
+40 SET XMINSTR("ADDR FLAGS")="R"
+41 SET XMINSTR("FROM")="LAB PACKAGE"
+42 ;
+43 IF $$GOTLOCAL^XMXAPIG("LAB MESSAGING")
SET XMTO("G.LAB MESSAGING")=""
+44 IF $$GOTLOCAL^XMXAPIG("LMI")
SET XMTO("G.LMI")=""
+45 ; File ^XUSEC/10076
IF '$DATA(XMTO)
MERGE XMTO=^XUSEC("LRLIASON")
+46 ;
+47 DO SENDMSG^XMXAPI(DUZ,XMSUBJ,LABODY,.XMTO,.XMINSTR,.XMZ)
+48 ;
+49 KILL ^TMP("XMERR",$JOB)
+50 ;
+51 QUIT $GET(XMZ)
+52 ;
FRMTTXT(TEXT,LMARGIN,RMARGIN,LARSLT) ;Format Text
+1 ;
+2 ; Format text
+3 ;
+4 ; Input:
+5 ; TEXT = The text to format
+6 ; LMARGIN (optional) = The left margin for the text
+7 ; Defaults to 1
+8 ; RMARGIN (optional) = The right margin for the text
+9 ; Defaults to 80
+10 ; LARSLT = The resulting array
+11 ;
+12 NEW DIWF,DIWL,DIWR,X
+13 ;
+14 KILL ^UTILITY($JOB,"W")
+15 SET DIWL=$GET(LMARGIN)
+16 SET DIWR=$GET(RMARGIN)
+17 IF DIWL=""
SET DIWL=1
+18 IF DIWR=""
SET DIWR=80
+19 SET DIWF=""
+20 SET X=TEXT
+21 DO ^DIWP
+22 MERGE LARSLT=^UTILITY($JOB,"W",DIWL)
+23 KILL ^UTILITY($JOB,"W")
+24 ;
+25 QUIT
+26 ;
LN(SUB) ; Increment the line counter.
+1 ;
+2 ;ZEXCEPT: LALINE
+3 ;
+4 SET LALINE(SUB)=$GET(LALINE(SUB))+1
+5 QUIT LALINE(SUB)
+6 ;
CLEAN ; Clean up tmp global(s)
+1 ;
+2 KILL ^TMP("LA7CHK",$JOB)
+3 QUIT
