- 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 Feb 18, 2025@23:42:23 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