LRLNC63 ;DALOI/FHS-HISTORICAL LOINC CODE MAPPER FOR DD(63.04 DATA ;10/15/2001 15:19
;;5.2;LAB SERVICE;**279**;Sep 27, 1994
TASK ;
I '$G(^XTMP("LRLNC63",0)) S ^(0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"LOINC HISTORICAL MAPPER INFORMATION"
Q:'$G(LRSEQ)
L +^XTMP("LRLNC63","TASK",LRSEQ):1 Q:'$T
H 5
I LRSEQ=999999 D DECIMAL^LRLNC63A Q
S LRNXT=+$G(^XTMP("LRLNC63","SEQ",LRSEQ))
I LRNXT>1 S LRNXT=LRNXT-1
S:LRNXT<1 LRNXT=(LRSEQ-1)
S:LRNXT<0 LRNXT=0
S LRMAP=$$GET1^DIQ(69.9,"1,",95.3,"I","","ERR")
S ^XTMP("LRLNC63","SEQ",LRSEQ,"START")=$$NOW^XLFDT
F S LRNXT=$O(^LR(LRNXT)) Q:$S(LRNXT<1:1,LRNXT>(LRSEQ+20000):1,$G(^XTMP("LRLNC63","STOP")):1,1:0) D I $$S^%ZTLOAD(LRSEQ_" Stopped at "_LRNXT) S ZTSTOP=1 Q
. I '$G(^LR(LRNXT,0)) S ^XTMP("LRLNC63","SEQ",LRSEQ)=LRNXT Q
. D LK6304(LRNXT)
. S ^XTMP("LRLNC63","SEQ",LRSEQ)=LRNXT
I $G(^XTMP("LRLNC63","STOP")) D Q
. N LRNOW
. S LRNOW=$$FMTE^XLFDT($$NOW^XLFDT,1)
. S ^XTMP("LRLNC63","SEQ",LRSEQ,"END")="USER STOP"_U_$$NOW^XLFDT
. S XQAMSG="LOINC Historical Mapper Sequence "_LRSEQ_"-"_(LRSEQ+20000)_" STOPPED @ "_LRNOW
. D XQA^LRLNC63A
. L -^XTMP("LRLNC63","TASK",LRSEQ)
MES ; Send alert message when LRDFN sequence range mapping is finished
S XQAMSG="LOINC Historical Mapper LRDFN sequence "_LRSEQ_" - "_(LRSEQ+20000)_" completed @ "_$$FMTE^XLFDT($$NOW^XLFDT,1)
D DONE^LRLNC63A
Q
6304 ;Entry point for setting ALL Patient's LOINC CODE for CH subscripted test
K LRDFN,LRIDT,LRDATA,LRNLT,LRLNC
K ^XTMP("LRLNC63")
I $P($G(^LR(LRDFN,0)),U,2)=62.3 Q
S LRDFN=0 F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 I $O(^LR(LRDFN,"CH",0)) D I $$S^%ZTLOAD Q
. D LK6304(LRDFN)
Q
LK6304(LRDFN) ;Call with LRDFN defined for single patient mapping
Q:'LRDFN
Q:'$G(^LR(LRDFN,0)) S LRFILE=+$P(^(0),U,2),DFN=+$P(^(0),U,3)
I '$G(LRFILE)!(LRFILE=62.3)!('DFN) Q ;Do not process controls
K LRSAGE
S SEX="M",AGE=99,LRSAGE=0
I $S($G(LRMAP):0,LRFILE=2:1,LRFILE=67:1,1:0) D
. D GETS^DIQ(LRFILE,DFN_",",".02;.03","IE","LRSAGE")
. S DOB=$G(LRSAGE(LRFILE,DFN_",",.03,"I"))
. I $L($G(LRSAGE(LRFILE,DFN_",",.02,"I"))) S SEX=LRSAGE(LRFILE,DFN_",",.02,"I")
. S LRSAGE=1
S LRIDT=0 F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1 D
. I $G(LRDBUG),'(LRDFN#100) W "."
. Q:$G(^LR(LRDFN,"CH",LRIDT,"NPC"))<2 ;Must have the New Person Convertion node set to >1
. Q:'$P($G(^LR(LRDFN,"CH",LRIDT,0)),U,3) S LRCDT=$P(^(0),U),LRDSPEC=$P(^(0),U,5) ; Must have completion date
. D SUB(LRDFN,LRIDT)
Q
SUB(LRDFN,LRIDT) ;Single or all test LOINC mapping
;LRDFN=Lab IEN number
;LRIDT inverse date
;Check each result and determine LOINC CODE
;If Result NLT code is defined (LRNLT)
;If Workload suffix code is set (LRCDEF)
;If Specimen is defined (LRSPEC)
;Variable LRLNC is the LOINC CODE
;LRSB(LRSUB) will screen for only those datanames
;LRSB(LRSUB)=Workload suffix -- this will be used to change default suffix code.
;LRDATA= ^LR(LRDFN,"CH",LRIDT,TEST) node
K LR5,LRLNC,LRMNODE,LROVR,LRSUB,LRXDEF,LRXNLT,LRXCDEF
S LRXDEF=0,LRSUB=1
F S LRSUB=$O(^LR(LRDFN,"CH",LRIDT,LRSUB)) Q:LRSUB<1 S LRDATA=^(LRSUB) D
. I '$D(^XTMP("LRLNC63",1,LRSUB)) D XTMP^LRLNC63A(LRSUB)
. S (LR5,LROVR,LRLNC,LRXCDEF,LRMOD1)=""
. I $G(LRMOD),$G(^XTMP("LRLNC63",2,LRSUB)) S LRMNODE=^(LRSUB) D
. . S LROVR=+$P(LRMNODE,U,6),LRXCDEF=$P(LRMNODE,U,5)
. . S LRMOD1=1
. S LRDATA3=$P(LRDATA,U,3),LRDATA5=$P(LRDATA,U,5)
. S LRNLT=$S($G(LRXNLT):LRXNLT,1:$P(LRDATA3,"!",2))
. S LRCDEF=$S($G(LROVR):LRXCDEF,$P(LRDATA3,"!",4):$P(LRDATA3,"!",4),1:LRXCDEF)
. S LRSPEC=$S($P(LRDATA,U,5):+$P(LRDATA,U,5),1:LRDSPEC)
. I '$G(LRNLT) S LRNLT=$S(LRNLT:LRNLT,1:$G(^XTMP("LRLNC63",1,LRSUB)))
. I LRNLT>1,LRSPEC S LRLNC=$$LNC^LRVER1(LRNLT,LRCDEF,LRSPEC)
. I LRLNC D
. . S $P(LRDATA3,"!",3)=LRLNC,$P(LRDATA3,"!",4)=LRCDEF
. . I '$D(^XTMP("LRLNC63","MAP",LRSUB,LRSPEC,LRNLT,+LRCDEF,LRLNC)) S ^(LRLNC)=""
. I '$G(LRMAP),LRSAGE,LRDATA5["$S(" D RANGE^LRLNC63A
. I $G(LRDBUG) D Q
. . W !,LRDFN,?10,LRIDT,?30,LRSUB_" "_LRSPEC
. . I $G(LRDBUG)=2,$G(LRLNC) W !,LRDATA3,!,LRDATA5 Q
. . I $G(LRDBUG)=1 W !,$S(LRLNC:"",1:"** ")_LRDATA3,!,LRDATA5
. I $G(LRLNC) D
. . S $P(LRDATA3,"!",5)=$S($G(LRMOD1):2,1:1)
. . S $P(LRDATA,U,3)=LRDATA3
. . S $P(^LR(LRDFN,"CH",LRIDT,LRSUB),U,3)=LRDATA3
. I $G(LR5) S $P(^LR(LRDFN,"CH",LRIDT,LRSUB),U,5)=LRDATA5
Q
LNC(LRNLT,LRCDEF,LRSPEC) ;reture the LOINC code for WKLD Code/Specimen
; Call with (nlt code,method suffix,test specimen)
; TA = Time Aspect
N X,LRXN,Y,LRSPECN,VAL,ERR,TA S X=""
Q:'LRNLT X
K LRMSGM
S:'$L($G(LRCDEF)) LRCDEF="0000"
I $P($G(LRCDEF),".",2) S LRCDEF=$P(LRCDEF,".",2)
S LRCDEF=$S($P(LRNLT,".",2):$P(LRNLT,".",2),1:LRCDEF)
I $L(LRCDEF)'=4 S LRCDEF=LRCDEF_$E("0000",$L(LRCDEF),($L(LRCDEF-4)))
S LRCDEF=LRCDEF_" "
S LRSPEC=+LRSPEC
;Get time aspect from 61
S TA=$$GET1^DIQ(61,LRSPEC_",",.0961,"I")
S LRSPECN=$S($D(^LAB(61,LRSPEC,0))#2:$$GET1^DIQ(61,LRSPEC_",",.01),1:"Unknown")
S LRNLT=$P(LRNLT,".")_"."
;Check for WKLD CODE_LOAD/WORK LIST method suffix
S VAL(1)=LRNLT_LRCDEF
S LRXN=$$FIND1^DIC(64,"","X",.VAL,"C","","ERR")
;Looking for specimen specific LOINC
I LRXN,LRSPEC D I X D MSG(1) Q X
. I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_LRXN_",",4,"I") Q:X
. S TA=$O(^LAM(LRXN,5,LRSPEC,1,0)) ; get time aspect
. I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_LRXN_",",4,"I") Q:X
;Looking LOINC default
I LRXN S X=$$LDEF(LRXN) I X D MSG(2) Q X
I LRCDEF="0000 " Q ""
;Looking for WKLD CODE_GENERIC suffix
K VAL
S VAL(1)=LRNLT_"0000 "
S LRXN=$$FIND1^DIC(64,"","X",.VAL,"C","","ERR")
I 'LRXN Q ""
;Looking for WKLD CODE_GENERIC specimen specific LOINC
I LRSPEC D I X D MSG(3) Q X
. I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_LRXN_",",4,"I") Q:X
. S TA=$O(^LAM(LRXN,5,LRSPEC,1,0)) ; get time aspect
. I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_LRXN_",",4,"I") Q:X
;Looking for WKLD CODE_GENERIC default LOINC
I 'X,LRXN S X=$$LDEF(LRXN) I X D MSG(4)
I 'X S X=""
Q X
LDEF(LRY) ;Find the default LOINC code for WKLD CODE
I 'LRY Q ""
S X=$$GET1^DIQ(64,LRY_",",25,"I")
I 'X S X=""
Q X
TMPSB(LRSB) ; Get LOINC code from ^TMP("LR",$J,"TMP",LRSB,"P")
S NODE=$G(^TMP("LR",$J,"TMP",LRSB,"P"))
I 'NODE Q ""
S $P(NODE,"!",3)=$$LNC($P(NODE,"!",2),$G(LRCDEF),$G(LRSPEC))
S $P(NODE,"!",4)=$G(LRCDEF)
Q $P(NODE,U,2)
Q
MSG(VAL) ;Set output message
Q:'$G(LRMSG)
S LRMSGM="0-No LOINC Code Defined for "_LRNLT_" "_LRCDEF
N TANAME
I $G(TA) S TANAME=$$GET1^DIQ(64.061,TA_",",.01,"E") ;TA Name
I VAL=1 S LRMSGM="1-"_LRNLT_$E(LRCDEF,1,4)_" - "_LRSPECN
I VAL=2 S LRMSGM="2-"_LRNLT_$E(LRCDEF,1,4)_" - Default LOINC"
I VAL=3 S LRMSGM="3-"_LRNLT_"0000 - "_LRSPECN
I VAL=4 S LRMSGM="4-"_LRNLT_"0000 - Default LOINC"
I $G(TA) S LRMSGM=LRMSGM_" Time Aspect "_TANAME
W:$G(LRDBUG) !,LRMSGM,!
Q
;
RNLT(X) ;
I 'X Q ""
N Y
S Y(1)=+$P($G(^LAB(60,X,64)),U,2)
S Y=$S($P($G(^LAM(Y(1),0)),U,2):$P(^(0),U,2),1:"")
I Y S $P(Y,"!",2)=$$LNC(Y,$G(LRCDEF),$G(LRSPEC))
S $P(Y,"!",3)=$G(LRCDEF)
Q Y
;
QUE ;Entry point to start/restart historical mapper
;Queue to a the resource device LRRESOURCE to trottle number of
;active conversion jobs.
SEC ;Check for security key
I '$D(^XUSEC("XUPROGMODE",+$G(DUZ))) D Q
. W !,$$CJ^XLFSTR("You are not cleared to use this option",80)
DEV ;Check to make sure LRRESOURCE device exist
W @IOF
N LRERR
S LRDEV=$$FIND1^DIC(3.5,"","B","LRRESOURCE","","","LRERR")
I '$G(LRDEV) D G END
. W !,$$CJ^XLFSTR("You must define the resource device named 'LRRESOURCE'",80)
. W !,$$CJ^XLFSTR("with at least one slot. Process Aborted.",80)
S LRSLOT=$$GET1^DIQ(3.5,LRDEV_",",35,"I")
I LRSLOT'>0 D G END
. W !,$$CJ^XLFSTR("LRRESOURCE device must have at leaset 1 slot.",80)
. W !,$$CJ^XLFSTR("The recommended number is 8.",80)
W !!,$$CJ^XLFSTR("D STOP^LRLNC63 to stop all background historical mapping tasks.",80),!
DIS ;Inform the user of the option's functionality
W !!,$$CJ^XLFSTR("This option should be run during 24 hour off peak time frame!!",80),!!
W !,$$CJ^XLFSTR("This option will queue multiple tasks to LOINC map",80)
W !,$$CJ^XLFSTR("historical data in the LAB DATA (#63).",80)
K DIR S DIR(0)="Y",DIR("A")="Are you certain you wish to proceed"
D ^DIR I $G(Y)'=1 G END
S LRSTOP=$G(^XTMP("LRLNC63","STOP"))
K ^XTMP("LRLNC63",1),^XTMP("LRLNC63","STOP")
S LRLST=$O(^LR(999999),-1)
D
. I LRLST[".",$D(^LR(0))#2 S $P(^(0),U,3)=$P(LRLST,".") Q
. I $D(^LR(0))#2 S $P(^(0),U,3)=LRLST
K ^XTMP("LRLNC63",0)
F LRSEQ=1:20000:LRLST D IO
I $O(^LR(999999)) S LRSEQ=999999 D IO
END ;Cleanup
K LRDEV,LRSLOT,LRLST,LRSEQ
K ZTSAVE,ZTDTH,ZTDESC,ZTRTN
Q
IO ;Task to LRRESOURCE
L +^XTMP("LRLNC63","TASK",LRSEQ):1 I '$T D Q
. W !,$$CJ^XLFSTR("Sequence # "_LRSEQ_" is already running.",80),!
I $G(^XTMP("LRLNC63","SEQ",LRSEQ,"END")) D
. K ^XTMP("LRLNC63","SEQ",LRSEQ)
I $G(LRSTOP) K ^XTMP("LRLNC63","SEQ",LRSEQ,"END")
S ZTSAVE("LRSEQ")="",ZTIO="LRRESOURCE",ZTDTH=$H
S ZTDESC="LOINC Historical Conversion - Seq "_LRSEQ_" "_$$NOW^XLFDT
S ZTSAVE("LRLST")=""
S ZTRTN="TASK^LRLNC63"
D ^%ZTLOAD
L -^XTMP("LRLNC63","TASK",LRSEQ)
Q:'$D(ZTSK)
S XQAMSG="LRDFN Conversion Sequence "_LRSEQ_"-"_(LRSEQ+20000)_" Task number is "_ZTSK
W !,XQAMSG D XQA^LRLNC63A
Q
STOP ;Stop all LOINC conversion background jobs
N DIR
W !?5,"Stopping all background LOINC historical mapping jobs",!!
S DIR(0)="Y",DIR("A")="Are you certain you want to continue"
D ^DIR Q:Y'=1
S ^XTMP("LRLNC63","STOP")=$H_U_$$HTE^XLFDT($H)_U_"DUZ= "_$G(DUZ)
W !," Background task stop node has been set, jobs should stop soon",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLNC63 9643 printed Apr 09, 2024@21:22:22 Page 2
LRLNC63 ;DALOI/FHS-HISTORICAL LOINC CODE MAPPER FOR DD(63.04 DATA ;10/15/2001 15:19
+1 ;;5.2;LAB SERVICE;**279**;Sep 27, 1994
TASK ;
+1 IF '$GET(^XTMP("LRLNC63",0))
SET ^(0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"LOINC HISTORICAL MAPPER INFORMATION"
+2 if '$GET(LRSEQ)
QUIT
+3 LOCK +^XTMP("LRLNC63","TASK",LRSEQ):1
if '$TEST
QUIT
+4 HANG 5
+5 IF LRSEQ=999999
DO DECIMAL^LRLNC63A
QUIT
+6 SET LRNXT=+$GET(^XTMP("LRLNC63","SEQ",LRSEQ))
+7 IF LRNXT>1
SET LRNXT=LRNXT-1
+8 if LRNXT<1
SET LRNXT=(LRSEQ-1)
+9 if LRNXT<0
SET LRNXT=0
+10 SET LRMAP=$$GET1^DIQ(69.9,"1,",95.3,"I","","ERR")
+11 SET ^XTMP("LRLNC63","SEQ",LRSEQ,"START")=$$NOW^XLFDT
+12 FOR
SET LRNXT=$ORDER(^LR(LRNXT))
if $SELECT(LRNXT<1
QUIT
Begin DoDot:1
+13 IF '$GET(^LR(LRNXT,0))
SET ^XTMP("LRLNC63","SEQ",LRSEQ)=LRNXT
QUIT
+14 DO LK6304(LRNXT)
+15 SET ^XTMP("LRLNC63","SEQ",LRSEQ)=LRNXT
End DoDot:1
IF $$S^%ZTLOAD(LRSEQ_" Stopped at "_LRNXT)
SET ZTSTOP=1
QUIT
+16 IF $GET(^XTMP("LRLNC63","STOP"))
Begin DoDot:1
+17 NEW LRNOW
+18 SET LRNOW=$$FMTE^XLFDT($$NOW^XLFDT,1)
+19 SET ^XTMP("LRLNC63","SEQ",LRSEQ,"END")="USER STOP"_U_$$NOW^XLFDT
+20 SET XQAMSG="LOINC Historical Mapper Sequence "_LRSEQ_"-"_(LRSEQ+20000)_" STOPPED @ "_LRNOW
+21 DO XQA^LRLNC63A
+22 LOCK -^XTMP("LRLNC63","TASK",LRSEQ)
End DoDot:1
QUIT
MES ; Send alert message when LRDFN sequence range mapping is finished
+1 SET XQAMSG="LOINC Historical Mapper LRDFN sequence "_LRSEQ_" - "_(LRSEQ+20000)_" completed @ "_$$FMTE^XLFDT($$NOW^XLFDT,1)
+2 DO DONE^LRLNC63A
+3 QUIT
6304 ;Entry point for setting ALL Patient's LOINC CODE for CH subscripted test
+1 KILL LRDFN,LRIDT,LRDATA,LRNLT,LRLNC
+2 KILL ^XTMP("LRLNC63")
+3 IF $PIECE($GET(^LR(LRDFN,0)),U,2)=62.3
QUIT
+4 SET LRDFN=0
FOR
SET LRDFN=$ORDER(^LR(LRDFN))
if LRDFN<1
QUIT
IF $ORDER(^LR(LRDFN,"CH",0))
Begin DoDot:1
+5 DO LK6304(LRDFN)
End DoDot:1
IF $$S^%ZTLOAD
QUIT
+6 QUIT
LK6304(LRDFN) ;Call with LRDFN defined for single patient mapping
+1 if 'LRDFN
QUIT
+2 if '$GET(^LR(LRDFN,0))
QUIT
SET LRFILE=+$PIECE(^(0),U,2)
SET DFN=+$PIECE(^(0),U,3)
+3 ;Do not process controls
IF '$GET(LRFILE)!(LRFILE=62.3)!('DFN)
QUIT
+4 KILL LRSAGE
+5 SET SEX="M"
SET AGE=99
SET LRSAGE=0
+6 IF $SELECT($GET(LRMAP):0,LRFILE=2:1,LRFILE=67:1,1:0)
Begin DoDot:1
+7 DO GETS^DIQ(LRFILE,DFN_",",".02;.03","IE","LRSAGE")
+8 SET DOB=$GET(LRSAGE(LRFILE,DFN_",",.03,"I"))
+9 IF $LENGTH($GET(LRSAGE(LRFILE,DFN_",",.02,"I")))
SET SEX=LRSAGE(LRFILE,DFN_",",.02,"I")
+10 SET LRSAGE=1
End DoDot:1
+11 SET LRIDT=0
FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
if LRIDT<1
QUIT
Begin DoDot:1
+12 IF $GET(LRDBUG)
IF '(LRDFN#100)
WRITE "."
+13 ;Must have the New Person Convertion node set to >1
if $GET(^LR(LRDFN,"CH",LRIDT,"NPC"))<2
QUIT
+14 ; Must have completion date
if '$PIECE($GET(^LR(LRDFN,"CH",LRIDT,0)),U,3)
QUIT
SET LRCDT=$PIECE(^(0),U)
SET LRDSPEC=$PIECE(^(0),U,5)
+15 DO SUB(LRDFN,LRIDT)
End DoDot:1
+16 QUIT
SUB(LRDFN,LRIDT) ;Single or all test LOINC mapping
+1 ;LRDFN=Lab IEN number
+2 ;LRIDT inverse date
+3 ;Check each result and determine LOINC CODE
+4 ;If Result NLT code is defined (LRNLT)
+5 ;If Workload suffix code is set (LRCDEF)
+6 ;If Specimen is defined (LRSPEC)
+7 ;Variable LRLNC is the LOINC CODE
+8 ;LRSB(LRSUB) will screen for only those datanames
+9 ;LRSB(LRSUB)=Workload suffix -- this will be used to change default suffix code.
+10 ;LRDATA= ^LR(LRDFN,"CH",LRIDT,TEST) node
+11 KILL LR5,LRLNC,LRMNODE,LROVR,LRSUB,LRXDEF,LRXNLT,LRXCDEF
+12 SET LRXDEF=0
SET LRSUB=1
+13 FOR
SET LRSUB=$ORDER(^LR(LRDFN,"CH",LRIDT,LRSUB))
if LRSUB<1
QUIT
SET LRDATA=^(LRSUB)
Begin DoDot:1
+14 IF '$DATA(^XTMP("LRLNC63",1,LRSUB))
DO XTMP^LRLNC63A(LRSUB)
+15 SET (LR5,LROVR,LRLNC,LRXCDEF,LRMOD1)=""
+16 IF $GET(LRMOD)
IF $GET(^XTMP("LRLNC63",2,LRSUB))
SET LRMNODE=^(LRSUB)
Begin DoDot:2
+17 SET LROVR=+$PIECE(LRMNODE,U,6)
SET LRXCDEF=$PIECE(LRMNODE,U,5)
+18 SET LRMOD1=1
End DoDot:2
+19 SET LRDATA3=$PIECE(LRDATA,U,3)
SET LRDATA5=$PIECE(LRDATA,U,5)
+20 SET LRNLT=$SELECT($GET(LRXNLT):LRXNLT,1:$PIECE(LRDATA3,"!",2))
+21 SET LRCDEF=$SELECT($GET(LROVR):LRXCDEF,$PIECE(LRDATA3,"!",4):$PIECE(LRDATA3,"!",4),1:LRXCDEF)
+22 SET LRSPEC=$SELECT($PIECE(LRDATA,U,5):+$PIECE(LRDATA,U,5),1:LRDSPEC)
+23 IF '$GET(LRNLT)
SET LRNLT=$SELECT(LRNLT:LRNLT,1:$GET(^XTMP("LRLNC63",1,LRSUB)))
+24 IF LRNLT>1
IF LRSPEC
SET LRLNC=$$LNC^LRVER1(LRNLT,LRCDEF,LRSPEC)
+25 IF LRLNC
Begin DoDot:2
+26 SET $PIECE(LRDATA3,"!",3)=LRLNC
SET $PIECE(LRDATA3,"!",4)=LRCDEF
+27 IF '$DATA(^XTMP("LRLNC63","MAP",LRSUB,LRSPEC,LRNLT,+LRCDEF,LRLNC))
SET ^(LRLNC)=""
End DoDot:2
+28 IF '$GET(LRMAP)
IF LRSAGE
IF LRDATA5["$S("
DO RANGE^LRLNC63A
+29 IF $GET(LRDBUG)
Begin DoDot:2
+30 WRITE !,LRDFN,?10,LRIDT,?30,LRSUB_" "_LRSPEC
+31 IF $GET(LRDBUG)=2
IF $GET(LRLNC)
WRITE !,LRDATA3,!,LRDATA5
QUIT
+32 IF $GET(LRDBUG)=1
WRITE !,$SELECT(LRLNC:"",1:"** ")_LRDATA3,!,LRDATA5
End DoDot:2
QUIT
+33 IF $GET(LRLNC)
Begin DoDot:2
+34 SET $PIECE(LRDATA3,"!",5)=$SELECT($GET(LRMOD1):2,1:1)
+35 SET $PIECE(LRDATA,U,3)=LRDATA3
+36 SET $PIECE(^LR(LRDFN,"CH",LRIDT,LRSUB),U,3)=LRDATA3
End DoDot:2
+37 IF $GET(LR5)
SET $PIECE(^LR(LRDFN,"CH",LRIDT,LRSUB),U,5)=LRDATA5
End DoDot:1
+38 QUIT
LNC(LRNLT,LRCDEF,LRSPEC) ;reture the LOINC code for WKLD Code/Specimen
+1 ; Call with (nlt code,method suffix,test specimen)
+2 ; TA = Time Aspect
+3 NEW X,LRXN,Y,LRSPECN,VAL,ERR,TA
SET X=""
+4 if 'LRNLT
QUIT X
+5 KILL LRMSGM
+6 if '$LENGTH($GET(LRCDEF))
SET LRCDEF="0000"
+7 IF $PIECE($GET(LRCDEF),".",2)
SET LRCDEF=$PIECE(LRCDEF,".",2)
+8 SET LRCDEF=$SELECT($PIECE(LRNLT,".",2):$PIECE(LRNLT,".",2),1:LRCDEF)
+9 IF $LENGTH(LRCDEF)'=4
SET LRCDEF=LRCDEF_$EXTRACT("0000",$LENGTH(LRCDEF),($LENGTH(LRCDEF-4)))
+10 SET LRCDEF=LRCDEF_" "
+11 SET LRSPEC=+LRSPEC
+12 ;Get time aspect from 61
+13 SET TA=$$GET1^DIQ(61,LRSPEC_",",.0961,"I")
+14 SET LRSPECN=$SELECT($DATA(^LAB(61,LRSPEC,0))#2:$$GET1^DIQ(61,LRSPEC_",",.01),1:"Unknown")
+15 SET LRNLT=$PIECE(LRNLT,".")_"."
+16 ;Check for WKLD CODE_LOAD/WORK LIST method suffix
+17 SET VAL(1)=LRNLT_LRCDEF
+18 SET LRXN=$$FIND1^DIC(64,"","X",.VAL,"C","","ERR")
+19 ;Looking for specimen specific LOINC
+20 IF LRXN
IF LRSPEC
Begin DoDot:1
+21 IF TA
SET X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_LRXN_",",4,"I")
if X
QUIT
+22 ; get time aspect
SET TA=$ORDER(^LAM(LRXN,5,LRSPEC,1,0))
+23 IF TA
SET X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_LRXN_",",4,"I")
if X
QUIT
End DoDot:1
IF X
DO MSG(1)
QUIT X
+24 ;Looking LOINC default
+25 IF LRXN
SET X=$$LDEF(LRXN)
IF X
DO MSG(2)
QUIT X
+26 IF LRCDEF="0000 "
QUIT ""
+27 ;Looking for WKLD CODE_GENERIC suffix
+28 KILL VAL
+29 SET VAL(1)=LRNLT_"0000 "
+30 SET LRXN=$$FIND1^DIC(64,"","X",.VAL,"C","","ERR")
+31 IF 'LRXN
QUIT ""
+32 ;Looking for WKLD CODE_GENERIC specimen specific LOINC
+33 IF LRSPEC
Begin DoDot:1
+34 IF TA
SET X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_LRXN_",",4,"I")
if X
QUIT
+35 ; get time aspect
SET TA=$ORDER(^LAM(LRXN,5,LRSPEC,1,0))
+36 IF TA
SET X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_LRXN_",",4,"I")
if X
QUIT
End DoDot:1
IF X
DO MSG(3)
QUIT X
+37 ;Looking for WKLD CODE_GENERIC default LOINC
+38 IF 'X
IF LRXN
SET X=$$LDEF(LRXN)
IF X
DO MSG(4)
+39 IF 'X
SET X=""
+40 QUIT X
LDEF(LRY) ;Find the default LOINC code for WKLD CODE
+1 IF 'LRY
QUIT ""
+2 SET X=$$GET1^DIQ(64,LRY_",",25,"I")
+3 IF 'X
SET X=""
+4 QUIT X
TMPSB(LRSB) ; Get LOINC code from ^TMP("LR",$J,"TMP",LRSB,"P")
+1 SET NODE=$GET(^TMP("LR",$JOB,"TMP",LRSB,"P"))
+2 IF 'NODE
QUIT ""
+3 SET $PIECE(NODE,"!",3)=$$LNC($PIECE(NODE,"!",2),$GET(LRCDEF),$GET(LRSPEC))
+4 SET $PIECE(NODE,"!",4)=$GET(LRCDEF)
+5 QUIT $PIECE(NODE,U,2)
+6 QUIT
MSG(VAL) ;Set output message
+1 if '$GET(LRMSG)
QUIT
+2 SET LRMSGM="0-No LOINC Code Defined for "_LRNLT_" "_LRCDEF
+3 NEW TANAME
+4 ;TA Name
IF $GET(TA)
SET TANAME=$$GET1^DIQ(64.061,TA_",",.01,"E")
+5 IF VAL=1
SET LRMSGM="1-"_LRNLT_$EXTRACT(LRCDEF,1,4)_" - "_LRSPECN
+6 IF VAL=2
SET LRMSGM="2-"_LRNLT_$EXTRACT(LRCDEF,1,4)_" - Default LOINC"
+7 IF VAL=3
SET LRMSGM="3-"_LRNLT_"0000 - "_LRSPECN
+8 IF VAL=4
SET LRMSGM="4-"_LRNLT_"0000 - Default LOINC"
+9 IF $GET(TA)
SET LRMSGM=LRMSGM_" Time Aspect "_TANAME
+10 if $GET(LRDBUG)
WRITE !,LRMSGM,!
+11 QUIT
+12 ;
RNLT(X) ;
+1 IF 'X
QUIT ""
+2 NEW Y
+3 SET Y(1)=+$PIECE($GET(^LAB(60,X,64)),U,2)
+4 SET Y=$SELECT($PIECE($GET(^LAM(Y(1),0)),U,2):$PIECE(^(0),U,2),1:"")
+5 IF Y
SET $PIECE(Y,"!",2)=$$LNC(Y,$GET(LRCDEF),$GET(LRSPEC))
+6 SET $PIECE(Y,"!",3)=$GET(LRCDEF)
+7 QUIT Y
+8 ;
QUE ;Entry point to start/restart historical mapper
+1 ;Queue to a the resource device LRRESOURCE to trottle number of
+2 ;active conversion jobs.
SEC ;Check for security key
+1 IF '$DATA(^XUSEC("XUPROGMODE",+$GET(DUZ)))
Begin DoDot:1
+2 WRITE !,$$CJ^XLFSTR("You are not cleared to use this option",80)
End DoDot:1
QUIT
DEV ;Check to make sure LRRESOURCE device exist
+1 WRITE @IOF
+2 NEW LRERR
+3 SET LRDEV=$$FIND1^DIC(3.5,"","B","LRRESOURCE","","","LRERR")
+4 IF '$GET(LRDEV)
Begin DoDot:1
+5 WRITE !,$$CJ^XLFSTR("You must define the resource device named 'LRRESOURCE'",80)
+6 WRITE !,$$CJ^XLFSTR("with at least one slot. Process Aborted.",80)
End DoDot:1
GOTO END
+7 SET LRSLOT=$$GET1^DIQ(3.5,LRDEV_",",35,"I")
+8 IF LRSLOT'>0
Begin DoDot:1
+9 WRITE !,$$CJ^XLFSTR("LRRESOURCE device must have at leaset 1 slot.",80)
+10 WRITE !,$$CJ^XLFSTR("The recommended number is 8.",80)
End DoDot:1
GOTO END
+11 WRITE !!,$$CJ^XLFSTR("D STOP^LRLNC63 to stop all background historical mapping tasks.",80),!
DIS ;Inform the user of the option's functionality
+1 WRITE !!,$$CJ^XLFSTR("This option should be run during 24 hour off peak time frame!!",80),!!
+2 WRITE !,$$CJ^XLFSTR("This option will queue multiple tasks to LOINC map",80)
+3 WRITE !,$$CJ^XLFSTR("historical data in the LAB DATA (#63).",80)
+4 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Are you certain you wish to proceed"
+5 DO ^DIR
IF $GET(Y)'=1
GOTO END
+6 SET LRSTOP=$GET(^XTMP("LRLNC63","STOP"))
+7 KILL ^XTMP("LRLNC63",1),^XTMP("LRLNC63","STOP")
+8 SET LRLST=$ORDER(^LR(999999),-1)
+9 Begin DoDot:1
+10 IF LRLST["."
IF $DATA(^LR(0))#2
SET $PIECE(^(0),U,3)=$PIECE(LRLST,".")
QUIT
+11 IF $DATA(^LR(0))#2
SET $PIECE(^(0),U,3)=LRLST
End DoDot:1
+12 KILL ^XTMP("LRLNC63",0)
+13 FOR LRSEQ=1:20000:LRLST
DO IO
+14 IF $ORDER(^LR(999999))
SET LRSEQ=999999
DO IO
END ;Cleanup
+1 KILL LRDEV,LRSLOT,LRLST,LRSEQ
+2 KILL ZTSAVE,ZTDTH,ZTDESC,ZTRTN
+3 QUIT
IO ;Task to LRRESOURCE
+1 LOCK +^XTMP("LRLNC63","TASK",LRSEQ):1
IF '$TEST
Begin DoDot:1
+2 WRITE !,$$CJ^XLFSTR("Sequence # "_LRSEQ_" is already running.",80),!
End DoDot:1
QUIT
+3 IF $GET(^XTMP("LRLNC63","SEQ",LRSEQ,"END"))
Begin DoDot:1
+4 KILL ^XTMP("LRLNC63","SEQ",LRSEQ)
End DoDot:1
+5 IF $GET(LRSTOP)
KILL ^XTMP("LRLNC63","SEQ",LRSEQ,"END")
+6 SET ZTSAVE("LRSEQ")=""
SET ZTIO="LRRESOURCE"
SET ZTDTH=$HOROLOG
+7 SET ZTDESC="LOINC Historical Conversion - Seq "_LRSEQ_" "_$$NOW^XLFDT
+8 SET ZTSAVE("LRLST")=""
+9 SET ZTRTN="TASK^LRLNC63"
+10 DO ^%ZTLOAD
+11 LOCK -^XTMP("LRLNC63","TASK",LRSEQ)
+12 if '$DATA(ZTSK)
QUIT
+13 SET XQAMSG="LRDFN Conversion Sequence "_LRSEQ_"-"_(LRSEQ+20000)_" Task number is "_ZTSK
+14 WRITE !,XQAMSG
DO XQA^LRLNC63A
+15 QUIT
STOP ;Stop all LOINC conversion background jobs
+1 NEW DIR
+2 WRITE !?5,"Stopping all background LOINC historical mapping jobs",!!
+3 SET DIR(0)="Y"
SET DIR("A")="Are you certain you want to continue"
+4 DO ^DIR
if Y'=1
QUIT
+5 SET ^XTMP("LRLNC63","STOP")=$HOROLOG_U_$$HTE^XLFDT($HOROLOG)_U_"DUZ= "_$GET(DUZ)
+6 WRITE !," Background task stop node has been set, jobs should stop soon",!
+7 QUIT
