LRVER1 ;DALOI/STAFF - LAB ROUTINE DATA VERIFICATION;Sep 27, 2018@10:00:00
;;5.2;LAB SERVICE;**42,153,201,215,239,240,263,232,286,291,350,468,484,461,512**;Sep 27, 1994;Build 7
;
;5.2;LAB SERVICE; CHANGE FOR PATCH LR*5.2*468; Feb 10 2016
;
VER ; from LRGVP
N LRBEY
S LRLLOC=0,LRCW=8,LROUTINE=$P(^LAB(69.9,1,3),U,2) I $D(^LRO(69,LRODT,1,LRSN,0)) S LRLLOC=$P(^(0),U,7) S:'$L(LRLLOC) LRLLOC=0 W !,$P(^LRO(69,LRODT,1,LRSN,1),U,6)
S LRCDT=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)):$P(^(3),U,1,2),1:$P(^(0),U,3)_U),LREAL=$P(LRCDT,U,2)
S LRCDT=+LRCDT,LRSAMP=$S($D(^LRO(69,LRODT,1,LRSN,0)):$P(^(0),U,3),1:"")
S LRIDT=$S($P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5):$P(^(3),U,5),1:"")
S:'LRIDT LRIDT=9999999-LRCDT
;
; Setup LRUID when called from LRGVP (group data review)
I $G(LRUID)="" N LRUID S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
;
D EXP
LD S LRSS="CH" ;ONLY WORKS FOR 'CH'
S LRMETH=LRSS IF $D(^LR(LRDFN,LRSS,LRIDT,0)) S LRMETH=$P($P(^(0),U,8),";",1)
W:$D(^LAB(62,+LRSAMP,0)) !,"Sample: ",$P(^(0),U)
K ^TMP("LR",$J,"TMP"),LRORD,LRM
D ^LRVER2
K LRDL
Q
;
;
EXP ; Get the list of tests for this ACC. from LRGVG1
; Do not process tests which have been "NP" (not performed)
; or merged to another accession
N I,N,IX,LRNLT,T1,X
K LRTEST,LRNAME,LRSM60
S LRALERT=LROUTINE,N=0,I=0,IX=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
F S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<.5 D
. S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I,0))
. I 'X Q
. I $P(X,"^",6)="*Not Performed"!($P(X,"^",6)="*Merged") Q
. ;LR*5.2*512: modified line below to always set the panel as the parent test
. ;line was formerly:
. ; . S N=N+1,LRTEST(N)=I,LRNLT=$S($P(X,"^",2)>50:$P(X,U,9),1:$P(X,"^")
. ;The line above may have been coded based on the urgency field in LR*5.2*291
. ;which was released in 2006 but the functionality regarding bundling/unbundling
. ;was not implemented.
. S N=N+1,LRTEST(N)=I,LRNLT=$P(X,U,9)
. I $P(X,"^",9),$P(X,"^")'=$P(X,"^",9),'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,$P(X,"^",9))) S LRNLT=$P(X,"^",9)
. S LRTEST(N,"P")=LRNLT_U_$$NLT(LRNLT)
. S LRAL=$P(X,U,2)#50
. I LRAL S LRALERT=$S(LRAL<LRALERT:LRAL,1:LRALERT)
;
S LRNTN=N
F T1=1:1:N I $D(^LAB(60,+LRTEST(T1),0)) D
. S LRTEST(T1)=LRTEST(T1)_U_^(0)
. S LRNAME(T1)=$P(LRTEST(T1),U,2),LRNAME(T1,+LRTEST(T1))=""
. S:$G(^(1,IX,3)) LRSM60(+$P(LRTEST(T1),";",2))=^(3)
. D EX1
K IX
N X1,X
S X=$P($H,","),X(1)=$P($H,",",2),I=0
F S I=$O(LRSM60(I)) Q:'I S X1=X-LRSM60(I)_","_X(1),LRSM60(I)=9999999-$$HTFM^XLFDT(X1)
Q
;
;
EX1 ; Expand the list of tests to edit.
Q:'$D(LRTEST(T1))
S X=LRTEST(T1),^TMP("LR",$J,"VTO",+X)=$P($P(X,U,6),";",2)
S ^TMP("LR",$J,"VTO",+X,"P")=LRTEST(T1,"P"),S1=0,J=0
D EX2
K S1,J
Q
;
EX2 ;
S:'$D(LRCFL) LRCFL=""
S LRSUB=$P(X,U,6)
I $D(^LAB(60,+X,4)),$P(^(4),"^",2) S LRCFL=LRCFL_$P(^(4),"^",2)_U
;
; If atomic test then setup and quit
I LRSUB'="" D Q
. S S2=$P(LRSUB,";",2)
. D:'$D(^TMP("LR",$J,"TMP",S2)) ORD
;
; Explode panel tests
; Do not process tests which have been "NP" (not performed)
; or merged to another accession
N LRDISP
S S1=S1+1,S1(S1)=X,S1(S1,1)=J
S J=0
F S J=$O(^LAB(60,+S1(S1),2,J)) Q:J<1 D
. S Y=+^(J,0),X=Y_U_^LAB(60,Y,0)
. S LRDISP=$P($G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),4,Y,0)),"^",6)
. I LRDISP="*Not Performed"!(LRDISP="*Merged") Q
. D EX2
S X=S1(S1),J=S1(S1,1),S1=S1-1
Q
;
;
ORD ;
; LRNX is set by caller
S LRNX=+$G(LRNX)+1,LRORD(LRNX)=S2
S LRBEY($P(LRTEST(T1),U,1),S2)="" ; CIDC
S ^TMP("LR",$J,"TMP",S2)=+X
; If panel being exploded then set parent("P" node)
; to file #60 test being exploded
I $G(LRTEST(T1,"P")) D
. I +LRTEST(T1)'=+LRTEST(T1,"P") S ^TMP("LR",$J,"TMP",S2,"P")=LRTEST(T1,"P")_"!"_$$RNLT(+X)
. E S ^TMP("LR",$J,"TMP",S2,"P")=+LRTEST(T1)_U_$$NLT(+LRTEST(T1))_"!"_$$RNLT(+X)
;
I $P(X,U,18) D
. S LRM(S2)=+X
. S LRM(S2,"P")=$G(^TMP("LR",$J,"TMP",S2,"P"))
. S LRMX(+X)=""
Q
;
;
NLT(X) ;
N Y
S Y=$S($P($G(^LAM(+$G(^LAB(60,+X,64)),0)),U,2):$P(^(0),U,2),1:"")
Q Y
;
;
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:"")
; START OF CHANGE FOR LR*5.2*468
;I Y S $P(Y,"!",2)=$$LNC(Y,$G(LRCDEF),$G(LRSPEC))
I Y S $P(Y,"!",2)=$$LNC(Y,$G(LRCDEF),$G(LRSPEC),X)
; END OF CHANGE FOR LR*5.2*468
S $P(Y,"!",3)=$G(LRCDEF),$P(Y,"!",6)=X
Q Y
;
;
; THE FOLLOWING ENTRY POINT WAS CHANGED BY PATCH LR*5.2.468 TO RECEIVE LAB TEST IEN
LNC(LRNLT,LRCDEF,LRSPEC,LRLTST) ;return the LOINC code for WKLD Code/Specimen
; orig entry point code
; (LRNLT,LRCDEF,LRSPEC) ;reture the LOINC code for WKLD Code/Specimen
; END OF CHANGE FOR LR*5.2*468
; Call with (nlt code,method suffix,test specimen)
; TA = Time Aspect
; START OF CHANGE FOR LR*5.2*468 check for new VUID LOINC in LAB(60,test,1,specimen N6,P1 (#30)
N LRMLTF,BL,C S LRLTST=$G(LRLTST)+0,LRSPEC=+LRSPEC
I LRSPEC&(LRLTST>0) S (LRMLTF,BL,C)="" D I BL'="" D LNCSET Q BL
. S LRSPECN=$S($D(^LAB(61,LRSPEC,0))#2:$$GET1^DIQ(61,LRSPEC_",",.01),1:"Unknown")
. S LRMLTF=$$GET1^DIQ(60.01,LRSPEC_","_LRLTST,30,"I") I LRMLTF="" Q ; does not have a vuid associated
. S BL=$$GET1^DIQ(66.3,LRMLTF_",",.04,"I")
. ; fix to strip off the check digit per agreement 20160920
. I BL'="" S BL=$P(BL,"-",1)
K LRMLTF,BL,C
; END OF CHANGE FOR LR*5.2*468
; START OF CHANGE FOR LR*5.2*484
G LNCO
; new entry point for mapping routine LRLNCV to skip checking of MLTF
LNCM(LRNLT,LRCDEF,LRSPEC,LRLTST) ; entry for LRLNCV
LNCO ; skip around point for LNC
; END OF CHANGE FOR LR*5.2*484
N X,N,Y,LRSPECN,VAL,ERR,TA S X=""
Q:'LRNLT X
K LRMSGM
S:$G(LRCDEF)="" LRCDEF="0000"
I $P(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 N=$$FIND1^DIC(64,"","X",.VAL,"C","","ERR")
;Looking for specimen specific LOINC
I N,LRSPEC D I X D MSG(1) Q X
. I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_N_",",4,"I") Q:X
. S TA=$O(^LAM(N,5,LRSPEC,1,0)) ; get time aspect
. I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_N_",",4,"I") Q:X
;Looking LOINC default
I N S X=$$LDEF(N) 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 N=$$FIND1^DIC(64,"","X",.VAL,"C","","ERR")
I 'N 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_","_N_",",4,"I") Q:X
. S TA=$O(^LAM(N,5,LRSPEC,1,0)) ; get time aspect
. I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_N_",",4,"I") Q:X
;Looking for WKLD CODE_GENERIC default LOINC
I 'X,N S X=$$LDEF(N) I X D MSG(4)
I 'X S X=""
Q X
;
; START OF CHANGE FOR LR*5.2*484
LNCSET ; set up string for MLTF msg
;
S:$G(LRCDEF)="" LRCDEF="0000"
I $P(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_" "
;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,".")_"."
I $G(TA) S TANAME=$$GET1^DIQ(64.061,TA_",",.01,"E") ;TA Name
S LRMSGM="1-"_LRNLT_$E(LRCDEF,1,4)_" - "_LRSPECN
I $G(TA) S LRMSGM=LRMSGM_" Time Aspect "_TANAME
Q
;
; END OF CHANGE FOR LR*5.2*484
LDEF(Y) ;Find the default LOINC code for WKLD CODE
I 'Y Q ""
S X=$$GET1^DIQ(64,Y_",",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 ""
; START CHANGE FOR LR*5.2*468
; S $P(NODE,"!",3)=$$LNC($P(NODE,"!",2),$G(LRCDEF),$G(LRSPEC))
S $P(NODE,"!",3)=$$LNC($P(NODE,"!",2),$G(LRCDEF),$G(LRSPEC),$G(LRTS))
; END CHANGE FOR LR*5.2*468
S $P(NODE,"!",4)=$G(LRCDEF)
Q $P(NODE,U,2)
;
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVER1 8766 printed Sep 23, 2025@19:58:09 Page 2
LRVER1 ;DALOI/STAFF - LAB ROUTINE DATA VERIFICATION;Sep 27, 2018@10:00:00
+1 ;;5.2;LAB SERVICE;**42,153,201,215,239,240,263,232,286,291,350,468,484,461,512**;Sep 27, 1994;Build 7
+2 ;
+3 ;5.2;LAB SERVICE; CHANGE FOR PATCH LR*5.2*468; Feb 10 2016
+4 ;
VER ; from LRGVP
+1 NEW LRBEY
+2 SET LRLLOC=0
SET LRCW=8
SET LROUTINE=$PIECE(^LAB(69.9,1,3),U,2)
IF $DATA(^LRO(69,LRODT,1,LRSN,0))
SET LRLLOC=$PIECE(^(0),U,7)
if '$LENGTH(LRLLOC)
SET LRLLOC=0
WRITE !,$PIECE(^LRO(69,LRODT,1,LRSN,1),U,6)
+3 SET LRCDT=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3)):$PIECE(^(3),U,1,2),1:$PIECE(^(0),U,3)_U)
SET LREAL=$PIECE(LRCDT,U,2)
+4 SET LRCDT=+LRCDT
SET LRSAMP=$SELECT($DATA(^LRO(69,LRODT,1,LRSN,0)):$PIECE(^(0),U,3),1:"")
+5 SET LRIDT=$SELECT($PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5):$PIECE(^(3),U,5),1:"")
+6 if 'LRIDT
SET LRIDT=9999999-LRCDT
+7 ;
+8 ; Setup LRUID when called from LRGVP (group data review)
+9 IF $GET(LRUID)=""
NEW LRUID
SET LRUID=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
+10 ;
+11 DO EXP
LD ;ONLY WORKS FOR 'CH'
SET LRSS="CH"
+1 SET LRMETH=LRSS
IF $DATA(^LR(LRDFN,LRSS,LRIDT,0))
SET LRMETH=$PIECE($PIECE(^(0),U,8),";",1)
+2 if $DATA(^LAB(62,+LRSAMP,0))
WRITE !,"Sample: ",$PIECE(^(0),U)
+3 KILL ^TMP("LR",$JOB,"TMP"),LRORD,LRM
+4 DO ^LRVER2
+5 KILL LRDL
+6 QUIT
+7 ;
+8 ;
EXP ; Get the list of tests for this ACC. from LRGVG1
+1 ; Do not process tests which have been "NP" (not performed)
+2 ; or merged to another accession
+3 NEW I,N,IX,LRNLT,T1,X
+4 KILL LRTEST,LRNAME,LRSM60
+5 SET LRALERT=LROUTINE
SET N=0
SET I=0
SET IX=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
+6 FOR
SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I))
if I<.5
QUIT
Begin DoDot:1
+7 SET X=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I,0))
+8 IF 'X
QUIT
+9 IF $PIECE(X,"^",6)="*Not Performed"!($PIECE(X,"^",6)="*Merged")
QUIT
+10 ;LR*5.2*512: modified line below to always set the panel as the parent test
+11 ;line was formerly:
+12 ; . S N=N+1,LRTEST(N)=I,LRNLT=$S($P(X,"^",2)>50:$P(X,U,9),1:$P(X,"^")
+13 ;The line above may have been coded based on the urgency field in LR*5.2*291
+14 ;which was released in 2006 but the functionality regarding bundling/unbundling
+15 ;was not implemented.
+16 SET N=N+1
SET LRTEST(N)=I
SET LRNLT=$PIECE(X,U,9)
+17 IF $PIECE(X,"^",9)
IF $PIECE(X,"^")'=$PIECE(X,"^",9)
IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,$PIECE(X,"^",9)))
SET LRNLT=$PIECE(X,"^",9)
+18 SET LRTEST(N,"P")=LRNLT_U_$$NLT(LRNLT)
+19 SET LRAL=$PIECE(X,U,2)#50
+20 IF LRAL
SET LRALERT=$SELECT(LRAL<LRALERT:LRAL,1:LRALERT)
End DoDot:1
+21 ;
+22 SET LRNTN=N
+23 FOR T1=1:1:N
IF $DATA(^LAB(60,+LRTEST(T1),0))
Begin DoDot:1
+24 SET LRTEST(T1)=LRTEST(T1)_U_^(0)
+25 SET LRNAME(T1)=$PIECE(LRTEST(T1),U,2)
SET LRNAME(T1,+LRTEST(T1))=""
+26 if $GET(^(1,IX,3))
SET LRSM60(+$PIECE(LRTEST(T1),";",2))=^(3)
+27 DO EX1
End DoDot:1
+28 KILL IX
+29 NEW X1,X
+30 SET X=$PIECE($HOROLOG,",")
SET X(1)=$PIECE($HOROLOG,",",2)
SET I=0
+31 FOR
SET I=$ORDER(LRSM60(I))
if 'I
QUIT
SET X1=X-LRSM60(I)_","_X(1)
SET LRSM60(I)=9999999-$$HTFM^XLFDT(X1)
+32 QUIT
+33 ;
+34 ;
EX1 ; Expand the list of tests to edit.
+1 if '$DATA(LRTEST(T1))
QUIT
+2 SET X=LRTEST(T1)
SET ^TMP("LR",$JOB,"VTO",+X)=$PIECE($PIECE(X,U,6),";",2)
+3 SET ^TMP("LR",$JOB,"VTO",+X,"P")=LRTEST(T1,"P")
SET S1=0
SET J=0
+4 DO EX2
+5 KILL S1,J
+6 QUIT
+7 ;
EX2 ;
+1 if '$DATA(LRCFL)
SET LRCFL=""
+2 SET LRSUB=$PIECE(X,U,6)
+3 IF $DATA(^LAB(60,+X,4))
IF $PIECE(^(4),"^",2)
SET LRCFL=LRCFL_$PIECE(^(4),"^",2)_U
+4 ;
+5 ; If atomic test then setup and quit
+6 IF LRSUB'=""
Begin DoDot:1
+7 SET S2=$PIECE(LRSUB,";",2)
+8 if '$DATA(^TMP("LR",$JOB,"TMP",S2))
DO ORD
End DoDot:1
QUIT
+9 ;
+10 ; Explode panel tests
+11 ; Do not process tests which have been "NP" (not performed)
+12 ; or merged to another accession
+13 NEW LRDISP
+14 SET S1=S1+1
SET S1(S1)=X
SET S1(S1,1)=J
+15 SET J=0
+16 FOR
SET J=$ORDER(^LAB(60,+S1(S1),2,J))
if J<1
QUIT
Begin DoDot:1
+17 SET Y=+^(J,0)
SET X=Y_U_^LAB(60,Y,0)
+18 SET LRDISP=$PIECE($GET(^LRO(68,+$GET(LRAA),1,+$GET(LRAD),1,+$GET(LRAN),4,Y,0)),"^",6)
+19 IF LRDISP="*Not Performed"!(LRDISP="*Merged")
QUIT
+20 DO EX2
End DoDot:1
+21 SET X=S1(S1)
SET J=S1(S1,1)
SET S1=S1-1
+22 QUIT
+23 ;
+24 ;
ORD ;
+1 ; LRNX is set by caller
+2 SET LRNX=+$GET(LRNX)+1
SET LRORD(LRNX)=S2
+3 ; CIDC
SET LRBEY($PIECE(LRTEST(T1),U,1),S2)=""
+4 SET ^TMP("LR",$JOB,"TMP",S2)=+X
+5 ; If panel being exploded then set parent("P" node)
+6 ; to file #60 test being exploded
+7 IF $GET(LRTEST(T1,"P"))
Begin DoDot:1
+8 IF +LRTEST(T1)'=+LRTEST(T1,"P")
SET ^TMP("LR",$JOB,"TMP",S2,"P")=LRTEST(T1,"P")_"!"_$$RNLT(+X)
+9 IF '$TEST
SET ^TMP("LR",$JOB,"TMP",S2,"P")=+LRTEST(T1)_U_$$NLT(+LRTEST(T1))_"!"_$$RNLT(+X)
End DoDot:1
+10 ;
+11 IF $PIECE(X,U,18)
Begin DoDot:1
+12 SET LRM(S2)=+X
+13 SET LRM(S2,"P")=$GET(^TMP("LR",$JOB,"TMP",S2,"P"))
+14 SET LRMX(+X)=""
End DoDot:1
+15 QUIT
+16 ;
+17 ;
NLT(X) ;
+1 NEW Y
+2 SET Y=$SELECT($PIECE($GET(^LAM(+$GET(^LAB(60,+X,64)),0)),U,2):$PIECE(^(0),U,2),1:"")
+3 QUIT Y
+4 ;
+5 ;
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 ; START OF CHANGE FOR LR*5.2*468
+6 ;I Y S $P(Y,"!",2)=$$LNC(Y,$G(LRCDEF),$G(LRSPEC))
+7 IF Y
SET $PIECE(Y,"!",2)=$$LNC(Y,$GET(LRCDEF),$GET(LRSPEC),X)
+8 ; END OF CHANGE FOR LR*5.2*468
+9 SET $PIECE(Y,"!",3)=$GET(LRCDEF)
SET $PIECE(Y,"!",6)=X
+10 QUIT Y
+11 ;
+12 ;
+13 ; THE FOLLOWING ENTRY POINT WAS CHANGED BY PATCH LR*5.2.468 TO RECEIVE LAB TEST IEN
LNC(LRNLT,LRCDEF,LRSPEC,LRLTST) ;return the LOINC code for WKLD Code/Specimen
+1 ; orig entry point code
+2 ; (LRNLT,LRCDEF,LRSPEC) ;reture the LOINC code for WKLD Code/Specimen
+3 ; END OF CHANGE FOR LR*5.2*468
+4 ; Call with (nlt code,method suffix,test specimen)
+5 ; TA = Time Aspect
+6 ; START OF CHANGE FOR LR*5.2*468 check for new VUID LOINC in LAB(60,test,1,specimen N6,P1 (#30)
+7 NEW LRMLTF,BL,C
SET LRLTST=$GET(LRLTST)+0
SET LRSPEC=+LRSPEC
+8 IF LRSPEC&(LRLTST>0)
SET (LRMLTF,BL,C)=""
Begin DoDot:1
+9 SET LRSPECN=$SELECT($DATA(^LAB(61,LRSPEC,0))#2:$$GET1^DIQ(61,LRSPEC_",",.01),1:"Unknown")
+10 ; does not have a vuid associated
SET LRMLTF=$$GET1^DIQ(60.01,LRSPEC_","_LRLTST,30,"I")
IF LRMLTF=""
QUIT
+11 SET BL=$$GET1^DIQ(66.3,LRMLTF_",",.04,"I")
+12 ; fix to strip off the check digit per agreement 20160920
+13 IF BL'=""
SET BL=$PIECE(BL,"-",1)
End DoDot:1
IF BL'=""
DO LNCSET
QUIT BL
+14 KILL LRMLTF,BL,C
+15 ; END OF CHANGE FOR LR*5.2*468
+16 ; START OF CHANGE FOR LR*5.2*484
+17 GOTO LNCO
+18 ; new entry point for mapping routine LRLNCV to skip checking of MLTF
LNCM(LRNLT,LRCDEF,LRSPEC,LRLTST) ; entry for LRLNCV
LNCO ; skip around point for LNC
+1 ; END OF CHANGE FOR LR*5.2*484
+2 NEW X,N,Y,LRSPECN,VAL,ERR,TA
SET X=""
+3 if 'LRNLT
QUIT X
+4 KILL LRMSGM
+5 if $GET(LRCDEF)=""
SET LRCDEF="0000"
+6 IF $PIECE(LRCDEF,".",2)
SET LRCDEF=$PIECE(LRCDEF,".",2)
+7 SET LRCDEF=$SELECT($PIECE(LRNLT,".",2):$PIECE(LRNLT,".",2),1:LRCDEF)
+8 IF $LENGTH(LRCDEF)'=4
SET LRCDEF=LRCDEF_$EXTRACT("0000",$LENGTH(LRCDEF),($LENGTH(LRCDEF-4)))
+9 SET LRCDEF=LRCDEF_" "
+10 SET LRSPEC=+LRSPEC
+11 ;Get time aspect from 61
+12 SET TA=$$GET1^DIQ(61,LRSPEC_",",.0961,"I")
+13 SET LRSPECN=$SELECT($DATA(^LAB(61,LRSPEC,0))#2:$$GET1^DIQ(61,LRSPEC_",",.01),1:"Unknown")
+14 SET LRNLT=$PIECE(LRNLT,".")_"."
+15 ;Check for WKLD CODE_LOAD/WORK LIST method suffix
+16 SET VAL(1)=LRNLT_LRCDEF
+17 SET N=$$FIND1^DIC(64,"","X",.VAL,"C","","ERR")
+18 ;Looking for specimen specific LOINC
+19 IF N
IF LRSPEC
Begin DoDot:1
+20 IF TA
SET X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_N_",",4,"I")
if X
QUIT
+21 ; get time aspect
SET TA=$ORDER(^LAM(N,5,LRSPEC,1,0))
+22 IF TA
SET X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_N_",",4,"I")
if X
QUIT
End DoDot:1
IF X
DO MSG(1)
QUIT X
+23 ;Looking LOINC default
+24 IF N
SET X=$$LDEF(N)
IF X
DO MSG(2)
QUIT X
+25 IF LRCDEF="0000 "
QUIT ""
+26 ;Looking for WKLD CODE_GENERIC suffix
+27 KILL VAL
+28 SET VAL(1)=LRNLT_"0000 "
+29 SET N=$$FIND1^DIC(64,"","X",.VAL,"C","","ERR")
+30 IF 'N
QUIT ""
+31 ;Looking for WKLD CODE_GENERIC specimen specific LOINC
+32 IF LRSPEC
Begin DoDot:1
+33 IF TA
SET X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_N_",",4,"I")
if X
QUIT
+34 ; get time aspect
SET TA=$ORDER(^LAM(N,5,LRSPEC,1,0))
+35 IF TA
SET X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_N_",",4,"I")
if X
QUIT
End DoDot:1
IF X
DO MSG(3)
QUIT X
+36 ;Looking for WKLD CODE_GENERIC default LOINC
+37 IF 'X
IF N
SET X=$$LDEF(N)
IF X
DO MSG(4)
+38 IF 'X
SET X=""
+39 QUIT X
+40 ;
+41 ; START OF CHANGE FOR LR*5.2*484
LNCSET ; set up string for MLTF msg
+1 ;
+2 if $GET(LRCDEF)=""
SET LRCDEF="0000"
+3 IF $PIECE(LRCDEF,".",2)
SET LRCDEF=$PIECE(LRCDEF,".",2)
+4 SET LRCDEF=$SELECT($PIECE(LRNLT,".",2):$PIECE(LRNLT,".",2),1:LRCDEF)
+5 IF $LENGTH(LRCDEF)'=4
SET LRCDEF=LRCDEF_$EXTRACT("0000",$LENGTH(LRCDEF),($LENGTH(LRCDEF-4)))
+6 SET LRCDEF=LRCDEF_" "
+7 ;Get time aspect from 61
+8 SET TA=$$GET1^DIQ(61,LRSPEC_",",.0961,"I")
+9 SET LRSPECN=$SELECT($DATA(^LAB(61,LRSPEC,0))#2:$$GET1^DIQ(61,LRSPEC_",",.01),1:"Unknown")
+10 SET LRNLT=$PIECE(LRNLT,".")_"."
+11 ;TA Name
IF $GET(TA)
SET TANAME=$$GET1^DIQ(64.061,TA_",",.01,"E")
+12 SET LRMSGM="1-"_LRNLT_$EXTRACT(LRCDEF,1,4)_" - "_LRSPECN
+13 IF $GET(TA)
SET LRMSGM=LRMSGM_" Time Aspect "_TANAME
+14 QUIT
+15 ;
+16 ; END OF CHANGE FOR LR*5.2*484
LDEF(Y) ;Find the default LOINC code for WKLD CODE
+1 IF 'Y
QUIT ""
+2 SET X=$$GET1^DIQ(64,Y_",",25,"I")
+3 IF 'X
SET X=""
+4 QUIT X
+5 ;
+6 ;
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 ; START CHANGE FOR LR*5.2*468
+4 ; S $P(NODE,"!",3)=$$LNC($P(NODE,"!",2),$G(LRCDEF),$G(LRSPEC))
+5 SET $PIECE(NODE,"!",3)=$$LNC($PIECE(NODE,"!",2),$GET(LRCDEF),$GET(LRSPEC),$GET(LRTS))
+6 ; END CHANGE FOR LR*5.2*468
+7 SET $PIECE(NODE,"!",4)=$GET(LRCDEF)
+8 QUIT $PIECE(NODE,U,2)
+9 ;
+10 ;
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
