LRSCTF ;DAL01/JMC - STORE STS MAPPING IN PARENT FILE ;02/08/12 15:25
;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
;
; ZEXCEPT is used to identify variables which are external to a specific TAG
; used in conjunction with Eclipse M-editor.
;
Q
;
LD(LRINST,LROVER) ; Load STS mapping into SCT encoded files
; Call with LRINST = #4 IEN
; LROVER<opt> Its a do-over
;
N LRABORT,LRCNT,LRFDA,LRFIEN,LRFILE,LRFLD,LRHIER,LRHIERX,LRI,LRIEN,LRJ,LRNOW,LRNODE,LROK,LRRECORDFORMAT,LRQUIET,LRSCT,LRSFILE,LRSN,LRSTATUS,LRSTR,LRSTRF,LRTX,LRTXT,LRTXTY,LRX,LRY
N CNT,DIQUIET,I,TMPNM,X,Y
;
; Prevent FileMan from issuing any unwanted WRITE(s).
S (DIQUIET,LRQUIET)=1
; Insure DT and DILOCKTM is defined
D DT^DICRW
;
I $G(LRINST)<1 Q
;
S X=$$NS^XUAF4(LRINST),LRINST(1)=$P(X,"^",1),LRINST(2)=$P(X,"^",2)
S LROVER=+$G(LROVER)
S LRNOW=$$HTFM^XLFDT($H),LRABORT=0
;
D BMES($S($G(LROVER):"RELOADING",1:"Loading")_" files with National SNOMED CT Codes")
;
S TMPNM="LRSCTF-ERR"
K ^XTMP(TMPNM)
S ^XTMP(TMPNM,0)=$$HTFM^XLFDT($H+180,1)_U_DT_U_$S(LROVER:"OVERLAY ",1:"")_"LAB SCT MAPPING ERRORS"_U_$$FMTE^XLFDT($$NOW^XLFDT(),"1Z")
;
I '$D(^LAHM(95.4,"AC",LRINST)) D Q
. S X="No data for "_LRINST(1)_" found in transport file"
. W ! D BMES(X)
. S ^XTMP(TMPNM,1)=X
;
D GET954
I LRABORT Q
;
; Purge those entries that were successfully processed.
D PURGE^LRSRVR5(1)
;
Q
;
;
GET954 ; Search cross reference of institution entries
;
;ZEXCEPT: LRABORT,LRCNT,LRIEN,LRINST,LRNODE,LROK,LROVER,LRSFILE,ZTQUEUED
;
; Get and lock file while processing.
L +^LAHM(95.4,0):DILOCKTM+15
I '$T S LRABORT=1 Q
;
S (LRCNT,LRIEN)=0,LRSFILE=""
F S LRIEN=$O(^LAHM(95.4,"AF","SCT",LRIEN)) Q:LRIEN<1 D
. S LRCNT=LRCNT+1
. I '(LRCNT#100) H 1 ; take a "rest" - allow OS to swap out process
. I '$D(ZTQUEUED) W:'(LRCNT#50) "."
. K LRNODE
. S LRNODE(0)=$G(^LAHM(95.4,LRIEN,0))
. I LRNODE(0)="" Q
. I '$G(LROVER),$P(LRNODE(0),"^",4)>0 Q
. I DUZ("AG")="V",$P(LRNODE(0),"-",1)'=LRINST(2) Q
. D LDPARS
. I $G(LROK) D LEX
;
; Unlock transport global.
L -^LAHM(95.4,0)
Q
;
;
LDPARS ;
; Parse the data
;
;ZEXCEPT: LRFIEN,LRFILE,LRFLD,LRNODE,LROK,LRRECORDFORMAT,LRSCT,LRSFILE,LRSN,LRTXTY
;
N LRFNAME,LRMSG
S LROK=0
S LRFILE=$P($P(LRNODE(0),U),"-",2) ;^LAB(FILE
S LRFNAME=$$GET1^DID(LRFILE,"","","NAME","","LRMSG")
I LRFILE'=LRSFILE D
. D BMES(" "),BMES("*************************************************")
. D BMES("Loading file #"_LRFILE_" [ "_LRFNAME_" ]")
. D BMES("*************************************************")
. S LRSFILE=LRFILE
K LRFIEN
S LRFIEN=$P($P(LRNODE(0),U),"-",3) ; IEN
D RETRIEVE
; Entry name
S LRTXTY=LRFLD(2)
;
; Legacy SNOMED I Code
I LRFLD(3)?1U1"-"1.AN S LRSN=$P(LRFLD(3),"-",2)
E S LRSN=LRFLD(3)
;
; SNOMED CT code
S LRSCT=""
I LRRECORDFORMAT=1 S LRSCT=LRFLD(5)
I LRRECORDFORMAT=2 S LRSCT=LRFLD(4)
;
I LRFILE,LRFIEN,LRTXTY'="" S LROK=1
Q
;
;
LEX ; Validate SCT code, get concept and term
; Only check those SCT codes if STS has mapped the term to SCT
;
;ZEXCEPT: LRFIEN,LRFILE,LRHIER,LRHIERX,LRSCT,LRSTATUS,LRTXTY
;
N LRFS,LRERR,LRSTRF,LRY,LRX
K LRSTATUS
S (LRSTATUS,LRHIERX)=""
S LRFS=3,LRX=0
;
S LRSTRF=$G(^LAB(LRFILE,LRFIEN,0)),LRSTRF("SCT")=$G(^LAB(LRFILE,LRFIEN,"SCT"))
I LRSTRF="" D Q
. D LDERR("No such entry: File #"_LRFILE_" IEN:"_LRFIEN)
. D LD954
;
I LRSCT S LRX=$$CODE^LRSCT(LRSCT,"SCT",DT,"LRY")
; If new term store SCT code only and change status to new code awaiting Lexcion update
; Otherwise if not new term then log error.
I LRSCT,LRX<0 D
. S LRSTATUS("ERR")=$P(LRX,"^",2),LRFS=2
. N LRZ
. S LRZ="SNOMED CT code "_LRSCT_" not on file"
. I LRSTATUS("ERR")=LRZ S LRSTATUS="LN" Q
. D LD954,LDERR("Lexicon SCT lookup error") S LRSTATUS="E"
;
I LRSCT,LRX>0 D
. S LRHIER="SCT "_$$UP^XLFSTR($P(LRY(0),U,2))
. S LRHIERX=$$FIND1^DIC(64.061,,"X",LRHIER,"C",,"LRERR")
. S LRSTATUS="L" ; Default [L] = The spelling is not standard
. I LRTXTY=$$UP^XLFSTR($G(LRY("P"))) S LRSTATUS="P" ; preferred term
. I LRSTATUS'="P",$O(LRY("S",0)) D ; Check to see if term in a synonym
. . N I
. . S I=0
. . F S I=$O(LRY("S",I)) Q:I<1 I LRTXTY=$$UP^XLFSTR(LRY("S",I)) S LRSTATUS="S" Q
;
D LDCK
Q
;
;
LDCK ; Check target file to determine if mapping is correct
;
;ZEXCEPT: LRFS,LRSN,LRSTRF,LRTX,LRTXTY
;
N LRMAPERR
;
I LRSN'="",$P(LRSTRF,"^",2)'=LRSN S LRMAPERR="SNOMED I code does not match"
;
S LRTX=$$TRIM^XLFSTR($P(LRSTRF,"^"),"LR"," ")
I $$UP^XLFSTR(LRTXTY)'=$$UP^XLFSTR(LRTX) S LRMAPERR="Names do not match: ["_LRTX_" < - > "_LRTXTY_"]"
;
I $G(LRMAPERR)'="" D Q
. S LRFS=3
. D LDERR(LRMAPERR)
. D SCTUPD ; ccr_7218n - Update SCT STATUS DATE multiple
. D LD954
;
; Do file update
D LDFILE
Q
;
;
LDERR(LRERR) ;
; Populate error message text file ^XTMP("LRSCT-ERR"
; Send STS alert if needed.
;
;ZEXCEPT: LRFIEN,LRFILE,LRFLD,LRFS,LRIEN,LRSCT,LRTXTY,TMPNM
;
N DATA,ERCNT,EXCDATA,I,LRX,TNUM,X
D BMES(" "),BMES(LRERR)
S ERCNT=$O(^XTMP(TMPNM,"A"),-1)+1
S ^XTMP(TMPNM,ERCNT,0)=LRIEN_U_LRERR_U_LRFS
S ^XTMP(TMPNM,ERCNT,1)=$G(^LAHM(95.4,LRIEN,0))
S ^XTMP(TMPNM,ERCNT,2)=LRFLD(1)_"^"_LRFLD(2)_"^"_LRFLD(3)_"^"_LRFLD(4)_"^"_LRFLD(5)
; LRFILE -- File #
; LRFIEN -- Entry IEN
;
S I=0
F S I=$O(LRFLD(I)) Q:I<1 S EXCDATA("RD",I)=$G(LRFLD(I))
;
; Existing entry extract record
S X=$$BLDERTX^LRERT(LRFILE,LRFIEN,"|",.DATA,2,"S")
M EXCDATA("SA")=DATA
;
; Lab mapping exception
S EXCDATA("TXT")=LRERR
;
S X=$$NOTIFY^LRSCTF1(LRTXTY,LRFILE,LRFIEN,LRSCT,.EXCDATA)
S TNUM=$G(EXCDATA("TNUM"))
S ^XTMP(TMPNM,ERCNT,10)=TNUM
I X D BMES("STS alert sent.")
I 'X D
. S X=$P(X,"^",3)
. D BMES("STS failure: "_X)
. S ^XTMP(TMPNM,ERCNT,10,1)=X
;
Q
;
;
BMES(MSG) ; Display message on screen and if during KIDS install store with install
;
;ZEXCEPT: XPDA,ZTQUEUED
;
I $G(XPDA)>0 D BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM)) Q
I '$D(ZTQUEUED) W !,MSG
Q
;
;
LDFILE ; Update target file
;
;ZEXCEPT: LRFIEN,LRFILE,LRFLD,LRFS,LRHIERX,LRNOW,LRRECORDFORMAT,LRSCT,LRSTATUS
;
N LRFDA,LRERR,LRFMERTS,LRMAPERR,LRSUBFILE,LRX
;
; Lock file entry prior to updating
F L +^LAB(LRFILE,LRFIEN):DILOCKTM+15 Q:$T
;
; Stop AERT xref from triggering alert (from ^LRERT1)
S LRFMERTS=1
S LRFMERTS("STS","STAT")="OK"
S LRFMERTS("STS","PROC")="LOAD"
;
; Check status if returned from STS and store in target file.
I LRSTATUS="" D
. I LRRECORDFORMAT=2 S LRSTATUS=$G(LRFLD(5)) Q
. I LRRECORDFORMAT=1 S LRSTATUS=$G(LRFLD(4))
;
; Load new mapping/purge previous data
S LRFDA(1,LRFILE,LRFIEN_",",20)=LRSCT
S LRFDA(1,LRFILE,LRFIEN_",",21)=LRSTATUS
S LRFDA(1,LRFILE,LRFIEN_",",22)=LRHIERX
D FILE^DIE("","LRFDA(1)","LRERR(1)")
I $D(LRERR(1)) D
. D LDERR("Unable to file entry")
. S LRMAPERR="FileMan FILE~DIE call failed: "_$G(LRERR(1,"DIERR",1))
S LRFS=$S($D(LRERR):3,1:1)
;
; Update SCT STATUS DATE multiple
D SCTUPD
;
L -^LAB(LRFILE,LRFIEN)
;
D LD954
;
Q
;
;
RETRIEVE ; Retrieve mapping data from file #95.4
;
;ZEXCEPT: LRFLD,LRI,LRIEN,LRJ,LRNODE,LRRECORDFORMAT
;
; Record format 1
; Station #-File #-IEN|Entry Name|SNOMED I|STS_FURTHER_ACTION|STS_SCT_ID|STS_TYPE_OF_MATCH
; LRFIELDLABEL(1)="1:IDENTIFIER"
; LRFIELDLABEL(2)="2:ENTRY NAME"
; LRFIELDLABEL(3)="3:SNOMED I"
; LRFIELDLABEL(4)="4:STS_FURTHER_ACTION"
; LRFIELDLABEL(5)="5:STS_SCT_CODE"
; LRFIELDLABEL(6)="6:STS_TYPE_OF_MATCH"
;
; Record format 2
; Station #-File #-IEN|Entry Name|SNOMED I|SNOMED CT|STS_EXCEPTION|STS_EXCEPTION_REASON|TRANSACTION NUMBER
; LRFIELDLABEL(1)="1:IDENTIFIER"
; LRFIELDLABEL(2)="2:ENTRY NAME"
; LRFIELDLABEL(3)="3:SNOMED I"
; LRFIELDLABEL(4)="4:SNOMED CT"
; LRFIELDLABEL(5)="5:STS_EXCEPTION"
; LRFIELDLABEL(6)="6:STS_EXCEPTION_REASON"
; LRFIELDLABEL(7)="7:TRANSACTION NUMBER"
;
N LRFIELDLABEL,LRX
;
K LRFLD,LRI,LRJ
S LRFLD(1)=$P(LRNODE(0),"^")
F LRI=2:1:7 S LRFLD(LRI)="",LRFIELDLABEL(LRI)=""
;
S LRI=0
F S LRI=$O(^LAHM(95.4,LRIEN,100,LRI)) Q:'LRI D
. S LRX=^LAHM(95.4,LRIEN,100,LRI,0)
. S LRJ=$P($P(LRX,"^"),":")
. S LRFIELDLABEL(LRJ)=$P(LRX,"^")
. S LRFLD(LRJ)=^LAHM(95.4,LRIEN,100,LRI,100,1,0)
;
; Determine SCT record format
; - check various fields since any one may not be sent.
S LRRECORDFORMAT=2
I LRFIELDLABEL(4)="4:SNOMED CT" Q
I LRFIELDLABEL(5)="5:STS_EXCEPTION" Q
I LRFIELDLABEL(6)="6:STS_EXCEPTION_REASON" Q
I LRFIELDLABEL(7)="7:TRANSACTION NUMBER" Q
;
; Othewise set to old orignal format
S LRRECORDFORMAT=1
I LRFIELDLABEL(4)="4:STS_FURTHER_ACTION" Q
I LRFIELDLABEL(5)="5:STS_SCT_CODE" Q
I LRFIELDLABEL(6)="6:STS_TYPE_OF_MATCH" Q
;
S LRRECORDFORMAT=0
;
Q
;
;
LD954 ;
; Update transport file with status
;
;ZEXCEPT: LRFS,LRIEN,LRNOW
;
N LRERR,LRFDA
S LRFDA(2,95.4,LRIEN_",",4)=$S(LRFS=1:1,1:.7)
S LRFDA(2,95.4,LRIEN_",",5)=$S(LRFS=0:"NOT LOADED",LRFS=1:"LOADED",LRFS=2:"LEXICON ERROR",LRFS=3:"MAPPING ERROR",1:"")
S LRFDA(2,95.4,LRIEN_",",6)=LRNOW
D FILE^DIE("","LRFDA(2)","LRERR")
Q
;
;
SCTUPD ; Update SCT STATUS DATE multiple
;
;ZEXCEPT: LRDUZ,LRFILE,LRFIEN,LRFLD,LRMAPERR,LRNOW,LRRECORDFORMAT,LRSTATUS
;
N LRERR,LRFDA,LRSUBFILE,LRWP
;
S LRSUBFILE=$S(LRFILE=61:61.023,LRFILE=61.2:61.223,LRFILE=62:62.023,1:"")
I LRSUBFILE="" Q
;
; Store date/time, user and new status
S LRFDA(2,LRSUBFILE,"+2,"_LRFIEN_",",.01)=LRNOW
S LRFDA(2,LRSUBFILE,"+2,"_LRFIEN_",",1)=LRSTATUS
S LRFDA(2,LRSUBFILE,"+2,"_LRFIEN_",",3)=$S($G(LRDUZ):LRDUZ,1:DUZ)
;
; Store transaction number if any
I LRRECORDFORMAT=2,$G(LRFLD(7))'="" S LRFDA(2,LRSUBFILE,"+2,"_LRFIEN_",",2)=LRFLD(7)
;
D UPDATE^DIE("","LRFDA(2)","LRFIEN","LRERR(2)")
;
; Store execption text in WP field
I LRRECORDFORMAT=1,$G(LRFLD(4))'="" S LRWP(1)="STS Exception: "_LRFLD(4)
I LRRECORDFORMAT=2,$G(LRFLD(6))'="" S LRWP(1)="STS Exception: "_LRFLD(6)
;
; Record any reported Lexicon API error
I $G(LRSTATUS("ERR"))'="" D
. N LRCNT
. S LRCNT=$O(LRWP(""),-1)+1
. I LRCNT>1 S LRWP(LRCNT)=" ",LRCNT=LRCNT+1
. S LRWP(LRCNT)="Lexicon API: "_LRSTATUS("ERR")
;
I $G(LRMAPERR)'="" D ; ccr_7218n
. N LRCNT
. S LRCNT=$O(LRWP(""),-1)+1
. I LRCNT>1 S LRWP(LRCNT)=" ",LRCNT=LRCNT+1
. S LRWP(LRCNT)="Mapping was not applied: "_LRMAPERR
;
I $G(LRFLD(10000))'="" D
. N LRCNT
. S LRCNT=$O(LRWP(""),-1)+1
. I LRCNT>1 S LRWP(LRCNT)=" ",LRCNT=LRCNT+1
. S LRWP(LRCNT)="File used to apply mapping and/or disposition: "_LRFLD(10000)
;
I $D(LRWP) D WP^DIE(LRSUBFILE,LRFIEN(2)_","_LRFIEN_",",4,"A","LRWP","LRERR(3)")
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSCTF 10764 printed Oct 16, 2024@18:21:01 Page 2
LRSCTF ;DAL01/JMC - STORE STS MAPPING IN PARENT FILE ;02/08/12 15:25
+1 ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
+2 ;
+3 ; ZEXCEPT is used to identify variables which are external to a specific TAG
+4 ; used in conjunction with Eclipse M-editor.
+5 ;
+6 QUIT
+7 ;
LD(LRINST,LROVER) ; Load STS mapping into SCT encoded files
+1 ; Call with LRINST = #4 IEN
+2 ; LROVER<opt> Its a do-over
+3 ;
+4 NEW LRABORT,LRCNT,LRFDA,LRFIEN,LRFILE,LRFLD,LRHIER,LRHIERX,LRI,LRIEN,LRJ,LRNOW,LRNODE,LROK,LRRECORDFORMAT,LRQUIET,LRSCT,LRSFILE,LRSN,LRSTATUS,LRSTR,LRSTRF,LRTX,LRTXT,LRTXTY,LRX,LRY
+5 NEW CNT,DIQUIET,I,TMPNM,X,Y
+6 ;
+7 ; Prevent FileMan from issuing any unwanted WRITE(s).
+8 SET (DIQUIET,LRQUIET)=1
+9 ; Insure DT and DILOCKTM is defined
+10 DO DT^DICRW
+11 ;
+12 IF $GET(LRINST)<1
QUIT
+13 ;
+14 SET X=$$NS^XUAF4(LRINST)
SET LRINST(1)=$PIECE(X,"^",1)
SET LRINST(2)=$PIECE(X,"^",2)
+15 SET LROVER=+$GET(LROVER)
+16 SET LRNOW=$$HTFM^XLFDT($HOROLOG)
SET LRABORT=0
+17 ;
+18 DO BMES($SELECT($GET(LROVER):"RELOADING",1:"Loading")_" files with National SNOMED CT Codes")
+19 ;
+20 SET TMPNM="LRSCTF-ERR"
+21 KILL ^XTMP(TMPNM)
+22 SET ^XTMP(TMPNM,0)=$$HTFM^XLFDT($HOROLOG+180,1)_U_DT_U_$SELECT(LROVER:"OVERLAY ",1:"")_"LAB SCT MAPPING ERRORS"_U_$$FMTE^XLFDT($$NOW^XLFDT(),"1Z")
+23 ;
+24 IF '$DATA(^LAHM(95.4,"AC",LRINST))
Begin DoDot:1
+25 SET X="No data for "_LRINST(1)_" found in transport file"
+26 WRITE !
DO BMES(X)
+27 SET ^XTMP(TMPNM,1)=X
End DoDot:1
QUIT
+28 ;
+29 DO GET954
+30 IF LRABORT
QUIT
+31 ;
+32 ; Purge those entries that were successfully processed.
+33 DO PURGE^LRSRVR5(1)
+34 ;
+35 QUIT
+36 ;
+37 ;
GET954 ; Search cross reference of institution entries
+1 ;
+2 ;ZEXCEPT: LRABORT,LRCNT,LRIEN,LRINST,LRNODE,LROK,LROVER,LRSFILE,ZTQUEUED
+3 ;
+4 ; Get and lock file while processing.
+5 LOCK +^LAHM(95.4,0):DILOCKTM+15
+6 IF '$TEST
SET LRABORT=1
QUIT
+7 ;
+8 SET (LRCNT,LRIEN)=0
SET LRSFILE=""
+9 FOR
SET LRIEN=$ORDER(^LAHM(95.4,"AF","SCT",LRIEN))
if LRIEN<1
QUIT
Begin DoDot:1
+10 SET LRCNT=LRCNT+1
+11 ; take a "rest" - allow OS to swap out process
IF '(LRCNT#100)
HANG 1
+12 IF '$DATA(ZTQUEUED)
if '(LRCNT#50)
WRITE "."
+13 KILL LRNODE
+14 SET LRNODE(0)=$GET(^LAHM(95.4,LRIEN,0))
+15 IF LRNODE(0)=""
QUIT
+16 IF '$GET(LROVER)
IF $PIECE(LRNODE(0),"^",4)>0
QUIT
+17 IF DUZ("AG")="V"
IF $PIECE(LRNODE(0),"-",1)'=LRINST(2)
QUIT
+18 DO LDPARS
+19 IF $GET(LROK)
DO LEX
End DoDot:1
+20 ;
+21 ; Unlock transport global.
+22 LOCK -^LAHM(95.4,0)
+23 QUIT
+24 ;
+25 ;
LDPARS ;
+1 ; Parse the data
+2 ;
+3 ;ZEXCEPT: LRFIEN,LRFILE,LRFLD,LRNODE,LROK,LRRECORDFORMAT,LRSCT,LRSFILE,LRSN,LRTXTY
+4 ;
+5 NEW LRFNAME,LRMSG
+6 SET LROK=0
+7 ;^LAB(FILE
SET LRFILE=$PIECE($PIECE(LRNODE(0),U),"-",2)
+8 SET LRFNAME=$$GET1^DID(LRFILE,"","","NAME","","LRMSG")
+9 IF LRFILE'=LRSFILE
Begin DoDot:1
+10 DO BMES(" ")
DO BMES("*************************************************")
+11 DO BMES("Loading file #"_LRFILE_" [ "_LRFNAME_" ]")
+12 DO BMES("*************************************************")
+13 SET LRSFILE=LRFILE
End DoDot:1
+14 KILL LRFIEN
+15 ; IEN
SET LRFIEN=$PIECE($PIECE(LRNODE(0),U),"-",3)
+16 DO RETRIEVE
+17 ; Entry name
+18 SET LRTXTY=LRFLD(2)
+19 ;
+20 ; Legacy SNOMED I Code
+21 IF LRFLD(3)?1U1"-"1.AN
SET LRSN=$PIECE(LRFLD(3),"-",2)
+22 IF '$TEST
SET LRSN=LRFLD(3)
+23 ;
+24 ; SNOMED CT code
+25 SET LRSCT=""
+26 IF LRRECORDFORMAT=1
SET LRSCT=LRFLD(5)
+27 IF LRRECORDFORMAT=2
SET LRSCT=LRFLD(4)
+28 ;
+29 IF LRFILE
IF LRFIEN
IF LRTXTY'=""
SET LROK=1
+30 QUIT
+31 ;
+32 ;
LEX ; Validate SCT code, get concept and term
+1 ; Only check those SCT codes if STS has mapped the term to SCT
+2 ;
+3 ;ZEXCEPT: LRFIEN,LRFILE,LRHIER,LRHIERX,LRSCT,LRSTATUS,LRTXTY
+4 ;
+5 NEW LRFS,LRERR,LRSTRF,LRY,LRX
+6 KILL LRSTATUS
+7 SET (LRSTATUS,LRHIERX)=""
+8 SET LRFS=3
SET LRX=0
+9 ;
+10 SET LRSTRF=$GET(^LAB(LRFILE,LRFIEN,0))
SET LRSTRF("SCT")=$GET(^LAB(LRFILE,LRFIEN,"SCT"))
+11 IF LRSTRF=""
Begin DoDot:1
+12 DO LDERR("No such entry: File #"_LRFILE_" IEN:"_LRFIEN)
+13 DO LD954
End DoDot:1
QUIT
+14 ;
+15 IF LRSCT
SET LRX=$$CODE^LRSCT(LRSCT,"SCT",DT,"LRY")
+16 ; If new term store SCT code only and change status to new code awaiting Lexcion update
+17 ; Otherwise if not new term then log error.
+18 IF LRSCT
IF LRX<0
Begin DoDot:1
+19 SET LRSTATUS("ERR")=$PIECE(LRX,"^",2)
SET LRFS=2
+20 NEW LRZ
+21 SET LRZ="SNOMED CT code "_LRSCT_" not on file"
+22 IF LRSTATUS("ERR")=LRZ
SET LRSTATUS="LN"
QUIT
+23 DO LD954
DO LDERR("Lexicon SCT lookup error")
SET LRSTATUS="E"
End DoDot:1
+24 ;
+25 IF LRSCT
IF LRX>0
Begin DoDot:1
+26 SET LRHIER="SCT "_$$UP^XLFSTR($PIECE(LRY(0),U,2))
+27 SET LRHIERX=$$FIND1^DIC(64.061,,"X",LRHIER,"C",,"LRERR")
+28 ; Default [L] = The spelling is not standard
SET LRSTATUS="L"
+29 ; preferred term
IF LRTXTY=$$UP^XLFSTR($GET(LRY("P")))
SET LRSTATUS="P"
+30 ; Check to see if term in a synonym
IF LRSTATUS'="P"
IF $ORDER(LRY("S",0))
Begin DoDot:2
+31 NEW I
+32 SET I=0
+33 FOR
SET I=$ORDER(LRY("S",I))
if I<1
QUIT
IF LRTXTY=$$UP^XLFSTR(LRY("S",I))
SET LRSTATUS="S"
QUIT
End DoDot:2
End DoDot:1
+34 ;
+35 DO LDCK
+36 QUIT
+37 ;
+38 ;
LDCK ; Check target file to determine if mapping is correct
+1 ;
+2 ;ZEXCEPT: LRFS,LRSN,LRSTRF,LRTX,LRTXTY
+3 ;
+4 NEW LRMAPERR
+5 ;
+6 IF LRSN'=""
IF $PIECE(LRSTRF,"^",2)'=LRSN
SET LRMAPERR="SNOMED I code does not match"
+7 ;
+8 SET LRTX=$$TRIM^XLFSTR($PIECE(LRSTRF,"^"),"LR"," ")
+9 IF $$UP^XLFSTR(LRTXTY)'=$$UP^XLFSTR(LRTX)
SET LRMAPERR="Names do not match: ["_LRTX_" < - > "_LRTXTY_"]"
+10 ;
+11 IF $GET(LRMAPERR)'=""
Begin DoDot:1
+12 SET LRFS=3
+13 DO LDERR(LRMAPERR)
+14 ; ccr_7218n - Update SCT STATUS DATE multiple
DO SCTUPD
+15 DO LD954
End DoDot:1
QUIT
+16 ;
+17 ; Do file update
+18 DO LDFILE
+19 QUIT
+20 ;
+21 ;
LDERR(LRERR) ;
+1 ; Populate error message text file ^XTMP("LRSCT-ERR"
+2 ; Send STS alert if needed.
+3 ;
+4 ;ZEXCEPT: LRFIEN,LRFILE,LRFLD,LRFS,LRIEN,LRSCT,LRTXTY,TMPNM
+5 ;
+6 NEW DATA,ERCNT,EXCDATA,I,LRX,TNUM,X
+7 DO BMES(" ")
DO BMES(LRERR)
+8 SET ERCNT=$ORDER(^XTMP(TMPNM,"A"),-1)+1
+9 SET ^XTMP(TMPNM,ERCNT,0)=LRIEN_U_LRERR_U_LRFS
+10 SET ^XTMP(TMPNM,ERCNT,1)=$GET(^LAHM(95.4,LRIEN,0))
+11 SET ^XTMP(TMPNM,ERCNT,2)=LRFLD(1)_"^"_LRFLD(2)_"^"_LRFLD(3)_"^"_LRFLD(4)_"^"_LRFLD(5)
+12 ; LRFILE -- File #
+13 ; LRFIEN -- Entry IEN
+14 ;
+15 SET I=0
+16 FOR
SET I=$ORDER(LRFLD(I))
if I<1
QUIT
SET EXCDATA("RD",I)=$GET(LRFLD(I))
+17 ;
+18 ; Existing entry extract record
+19 SET X=$$BLDERTX^LRERT(LRFILE,LRFIEN,"|",.DATA,2,"S")
+20 MERGE EXCDATA("SA")=DATA
+21 ;
+22 ; Lab mapping exception
+23 SET EXCDATA("TXT")=LRERR
+24 ;
+25 SET X=$$NOTIFY^LRSCTF1(LRTXTY,LRFILE,LRFIEN,LRSCT,.EXCDATA)
+26 SET TNUM=$GET(EXCDATA("TNUM"))
+27 SET ^XTMP(TMPNM,ERCNT,10)=TNUM
+28 IF X
DO BMES("STS alert sent.")
+29 IF 'X
Begin DoDot:1
+30 SET X=$PIECE(X,"^",3)
+31 DO BMES("STS failure: "_X)
+32 SET ^XTMP(TMPNM,ERCNT,10,1)=X
End DoDot:1
+33 ;
+34 QUIT
+35 ;
+36 ;
BMES(MSG) ; Display message on screen and if during KIDS install store with install
+1 ;
+2 ;ZEXCEPT: XPDA,ZTQUEUED
+3 ;
+4 IF $GET(XPDA)>0
DO BMES^XPDUTL($$CJ^XLFSTR(MSG,IOM))
QUIT
+5 IF '$DATA(ZTQUEUED)
WRITE !,MSG
+6 QUIT
+7 ;
+8 ;
LDFILE ; Update target file
+1 ;
+2 ;ZEXCEPT: LRFIEN,LRFILE,LRFLD,LRFS,LRHIERX,LRNOW,LRRECORDFORMAT,LRSCT,LRSTATUS
+3 ;
+4 NEW LRFDA,LRERR,LRFMERTS,LRMAPERR,LRSUBFILE,LRX
+5 ;
+6 ; Lock file entry prior to updating
+7 FOR
LOCK +^LAB(LRFILE,LRFIEN):DILOCKTM+15
if $TEST
QUIT
+8 ;
+9 ; Stop AERT xref from triggering alert (from ^LRERT1)
+10 SET LRFMERTS=1
+11 SET LRFMERTS("STS","STAT")="OK"
+12 SET LRFMERTS("STS","PROC")="LOAD"
+13 ;
+14 ; Check status if returned from STS and store in target file.
+15 IF LRSTATUS=""
Begin DoDot:1
+16 IF LRRECORDFORMAT=2
SET LRSTATUS=$GET(LRFLD(5))
QUIT
+17 IF LRRECORDFORMAT=1
SET LRSTATUS=$GET(LRFLD(4))
End DoDot:1
+18 ;
+19 ; Load new mapping/purge previous data
+20 SET LRFDA(1,LRFILE,LRFIEN_",",20)=LRSCT
+21 SET LRFDA(1,LRFILE,LRFIEN_",",21)=LRSTATUS
+22 SET LRFDA(1,LRFILE,LRFIEN_",",22)=LRHIERX
+23 DO FILE^DIE("","LRFDA(1)","LRERR(1)")
+24 IF $DATA(LRERR(1))
Begin DoDot:1
+25 DO LDERR("Unable to file entry")
+26 SET LRMAPERR="FileMan FILE~DIE call failed: "_$GET(LRERR(1,"DIERR",1))
End DoDot:1
+27 SET LRFS=$SELECT($DATA(LRERR):3,1:1)
+28 ;
+29 ; Update SCT STATUS DATE multiple
+30 DO SCTUPD
+31 ;
+32 LOCK -^LAB(LRFILE,LRFIEN)
+33 ;
+34 DO LD954
+35 ;
+36 QUIT
+37 ;
+38 ;
RETRIEVE ; Retrieve mapping data from file #95.4
+1 ;
+2 ;ZEXCEPT: LRFLD,LRI,LRIEN,LRJ,LRNODE,LRRECORDFORMAT
+3 ;
+4 ; Record format 1
+5 ; Station #-File #-IEN|Entry Name|SNOMED I|STS_FURTHER_ACTION|STS_SCT_ID|STS_TYPE_OF_MATCH
+6 ; LRFIELDLABEL(1)="1:IDENTIFIER"
+7 ; LRFIELDLABEL(2)="2:ENTRY NAME"
+8 ; LRFIELDLABEL(3)="3:SNOMED I"
+9 ; LRFIELDLABEL(4)="4:STS_FURTHER_ACTION"
+10 ; LRFIELDLABEL(5)="5:STS_SCT_CODE"
+11 ; LRFIELDLABEL(6)="6:STS_TYPE_OF_MATCH"
+12 ;
+13 ; Record format 2
+14 ; Station #-File #-IEN|Entry Name|SNOMED I|SNOMED CT|STS_EXCEPTION|STS_EXCEPTION_REASON|TRANSACTION NUMBER
+15 ; LRFIELDLABEL(1)="1:IDENTIFIER"
+16 ; LRFIELDLABEL(2)="2:ENTRY NAME"
+17 ; LRFIELDLABEL(3)="3:SNOMED I"
+18 ; LRFIELDLABEL(4)="4:SNOMED CT"
+19 ; LRFIELDLABEL(5)="5:STS_EXCEPTION"
+20 ; LRFIELDLABEL(6)="6:STS_EXCEPTION_REASON"
+21 ; LRFIELDLABEL(7)="7:TRANSACTION NUMBER"
+22 ;
+23 NEW LRFIELDLABEL,LRX
+24 ;
+25 KILL LRFLD,LRI,LRJ
+26 SET LRFLD(1)=$PIECE(LRNODE(0),"^")
+27 FOR LRI=2:1:7
SET LRFLD(LRI)=""
SET LRFIELDLABEL(LRI)=""
+28 ;
+29 SET LRI=0
+30 FOR
SET LRI=$ORDER(^LAHM(95.4,LRIEN,100,LRI))
if 'LRI
QUIT
Begin DoDot:1
+31 SET LRX=^LAHM(95.4,LRIEN,100,LRI,0)
+32 SET LRJ=$PIECE($PIECE(LRX,"^"),":")
+33 SET LRFIELDLABEL(LRJ)=$PIECE(LRX,"^")
+34 SET LRFLD(LRJ)=^LAHM(95.4,LRIEN,100,LRI,100,1,0)
End DoDot:1
+35 ;
+36 ; Determine SCT record format
+37 ; - check various fields since any one may not be sent.
+38 SET LRRECORDFORMAT=2
+39 IF LRFIELDLABEL(4)="4:SNOMED CT"
QUIT
+40 IF LRFIELDLABEL(5)="5:STS_EXCEPTION"
QUIT
+41 IF LRFIELDLABEL(6)="6:STS_EXCEPTION_REASON"
QUIT
+42 IF LRFIELDLABEL(7)="7:TRANSACTION NUMBER"
QUIT
+43 ;
+44 ; Othewise set to old orignal format
+45 SET LRRECORDFORMAT=1
+46 IF LRFIELDLABEL(4)="4:STS_FURTHER_ACTION"
QUIT
+47 IF LRFIELDLABEL(5)="5:STS_SCT_CODE"
QUIT
+48 IF LRFIELDLABEL(6)="6:STS_TYPE_OF_MATCH"
QUIT
+49 ;
+50 SET LRRECORDFORMAT=0
+51 ;
+52 QUIT
+53 ;
+54 ;
LD954 ;
+1 ; Update transport file with status
+2 ;
+3 ;ZEXCEPT: LRFS,LRIEN,LRNOW
+4 ;
+5 NEW LRERR,LRFDA
+6 SET LRFDA(2,95.4,LRIEN_",",4)=$SELECT(LRFS=1:1,1:.7)
+7 SET LRFDA(2,95.4,LRIEN_",",5)=$SELECT(LRFS=0:"NOT LOADED",LRFS=1:"LOADED",LRFS=2:"LEXICON ERROR",LRFS=3:"MAPPING ERROR",1:"")
+8 SET LRFDA(2,95.4,LRIEN_",",6)=LRNOW
+9 DO FILE^DIE("","LRFDA(2)","LRERR")
+10 QUIT
+11 ;
+12 ;
SCTUPD ; Update SCT STATUS DATE multiple
+1 ;
+2 ;ZEXCEPT: LRDUZ,LRFILE,LRFIEN,LRFLD,LRMAPERR,LRNOW,LRRECORDFORMAT,LRSTATUS
+3 ;
+4 NEW LRERR,LRFDA,LRSUBFILE,LRWP
+5 ;
+6 SET LRSUBFILE=$SELECT(LRFILE=61:61.023,LRFILE=61.2:61.223,LRFILE=62:62.023,1:"")
+7 IF LRSUBFILE=""
QUIT
+8 ;
+9 ; Store date/time, user and new status
+10 SET LRFDA(2,LRSUBFILE,"+2,"_LRFIEN_",",.01)=LRNOW
+11 SET LRFDA(2,LRSUBFILE,"+2,"_LRFIEN_",",1)=LRSTATUS
+12 SET LRFDA(2,LRSUBFILE,"+2,"_LRFIEN_",",3)=$SELECT($GET(LRDUZ):LRDUZ,1:DUZ)
+13 ;
+14 ; Store transaction number if any
+15 IF LRRECORDFORMAT=2
IF $GET(LRFLD(7))'=""
SET LRFDA(2,LRSUBFILE,"+2,"_LRFIEN_",",2)=LRFLD(7)
+16 ;
+17 DO UPDATE^DIE("","LRFDA(2)","LRFIEN","LRERR(2)")
+18 ;
+19 ; Store execption text in WP field
+20 IF LRRECORDFORMAT=1
IF $GET(LRFLD(4))'=""
SET LRWP(1)="STS Exception: "_LRFLD(4)
+21 IF LRRECORDFORMAT=2
IF $GET(LRFLD(6))'=""
SET LRWP(1)="STS Exception: "_LRFLD(6)
+22 ;
+23 ; Record any reported Lexicon API error
+24 IF $GET(LRSTATUS("ERR"))'=""
Begin DoDot:1
+25 NEW LRCNT
+26 SET LRCNT=$ORDER(LRWP(""),-1)+1
+27 IF LRCNT>1
SET LRWP(LRCNT)=" "
SET LRCNT=LRCNT+1
+28 SET LRWP(LRCNT)="Lexicon API: "_LRSTATUS("ERR")
End DoDot:1
+29 ;
+30 ; ccr_7218n
IF $GET(LRMAPERR)'=""
Begin DoDot:1
+31 NEW LRCNT
+32 SET LRCNT=$ORDER(LRWP(""),-1)+1
+33 IF LRCNT>1
SET LRWP(LRCNT)=" "
SET LRCNT=LRCNT+1
+34 SET LRWP(LRCNT)="Mapping was not applied: "_LRMAPERR
End DoDot:1
+35 ;
+36 IF $GET(LRFLD(10000))'=""
Begin DoDot:1
+37 NEW LRCNT
+38 SET LRCNT=$ORDER(LRWP(""),-1)+1
+39 IF LRCNT>1
SET LRWP(LRCNT)=" "
SET LRCNT=LRCNT+1
+40 SET LRWP(LRCNT)="File used to apply mapping and/or disposition: "_LRFLD(10000)
End DoDot:1
+41 ;
+42 IF $DATA(LRWP)
DO WP^DIE(LRSUBFILE,LRFIEN(2)_","_LRFIEN_",",4,"A","LRWP","LRERR(3)")
+43 ;
+44 QUIT
