Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRVER1

LRVER1.m

Go to the documentation of this file. 
  1. LRVER1 ;DALOI/FHS/JAH - LAB ROUTINE DATA VERIFICATION ;8/10/04
  1.  ;;5.2;LAB SERVICE;**1027,1031**;NOV 1, 1997
  1.  ;
  1.  ;;VA LR Patch(s): 42,153,201,215,239,240,263,232,286,291
  1.  ;
  1.  ; NOTE: LR*5.2*1031 restores LR*5.2*1027 modifications
  1.  ;
  1. VER ; from LRGVP
  1.  N LRBEY
  1.  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)
  1.  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)
  1.  S LRCDT=+LRCDT,LRSAMP=$S($D(^LRO(69,LRODT,1,LRSN,0)):$P(^(0),U,3),1:"")
  1.  S LRIDT=$S($P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5):$P(^(3),U,5),1:"")
  1.  S:'LRIDT LRIDT=9999999-LRCDT
  1.  D EXP
  1. LD S LRSS="CH" ;ONLY WORKS FOR 'CH'
  1.  S LRMETH=LRSS IF $D(^LR(LRDFN,LRSS,LRIDT,0)) S LRMETH=$P($P(^(0),U,8),";",1)
  1.  W:$D(^LAB(62,+LRSAMP,0)) !,"Sample: ",$P(^(0),U)
  1.  K ^TMP("LR",$J,"TMP"),LRORD,LRM
  1.  D ^LRVER2
  1.  K LRDL
  1.  Q
  1.  ;
  1.  ;
  1. EXP ; Get the list of tests for this ACC. from LRGVG1
  1.  ; Do not process tests which have been "NP" (not performed).
  1.  N I,N,IX,LRNLT,T1,X
  1.  K LRTEST,LRNAME,LRSM60
  1.  S LRALERT=LROUTINE,N=0,I=0,IX=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
  1.  F  S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<.5  D
  1.  . S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I,0))
  1.  . I 'X Q
  1.  . I $P(X,"^",6)="*Not Performed" Q
  1.  . S N=N+1,LRTEST(N)=I,LRNLT=$S($P(X,"^",2)>50:$P(X,U,9),1:$P(X,"^"))
  1.  . S LRTEST(N,"P")=LRNLT_U_$$NLT(LRNLT)
  1.  . S LRAL=$P(X,U,2)#50
  1.  . I LRAL S LRALERT=$S(LRAL<LRALERT:LRAL,1:LRALERT)
  1.  ;
  1.  S LRNTN=N
  1.  F T1=1:1:N I $D(^LAB(60,+LRTEST(T1),0)) D
  1.  . S LRTEST(T1)=LRTEST(T1)_U_^(0)
  1.  . S LRNAME(T1)=$P(LRTEST(T1),U,2),LRNAME(T1,+LRTEST(T1))=""
  1.  . S:$G(^(1,IX,3)) LRSM60(+$P(LRTEST(T1),";",2))=^(3)
  1.  . D EX1
  1.  K IX
  1.  N X1,X
  1.  S X=$P($H,","),X(1)=$P($H,",",2),I=0
  1.  F  S I=$O(LRSM60(I)) Q:'I  S X1=X-LRSM60(I)_","_X(1),LRSM60(I)=9999999-$$HTFM^XLFDT(X1)
  1.  Q
  1.  ;
  1.  ;
  1. EX1 ; Expand the list of tests to edit.
  1.  Q:'$D(LRTEST(T1))
  1.  S X=LRTEST(T1),^TMP("LR",$J,"VTO",+X)=$P($P(X,U,6),";",2)
  1.  S ^TMP("LR",$J,"VTO",+X,"P")=LRTEST(T1,"P"),S1=0,J=0
  1.  D EX2
  1.  K S1,J
  1.  Q
  1.  ;
  1. EX2 ;
  1.  S:'$D(LRCFL) LRCFL=""
  1.  S LRSUB=$P(X,U,6)
  1.  ; I $D(^LAB(60,+X,4)),$P(^(4),"^",2) S LRCFL=LRCFL_$P(^(4),"^",2)_U
  1.  ;
  1.  ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
  1.  I $D(^LAB(60,+X,4)),$P($G(^(4)),"^",2) S:'($D(LRCFL)#2) LRCFL="" S LRCFL=LRCFL_$P($G(^(4)),"^",2)_U
  1.  ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
  1.  ;
  1.  ; If atomic test then setup and quit
  1.  I LRSUB'="" D  Q
  1.  . S S2=$P(LRSUB,";",2)
  1.  . D:'$D(^TMP("LR",$J,"TMP",S2)) ORD
  1.  ;
  1.  ; Explode panel tests
  1.  ; Do not process tests which have been "NP" (not performed).
  1.  S S1=S1+1,S1(S1)=X,S1(S1,1)=J
  1.  S J=0
  1.  F  S J=$O(^LAB(60,+S1(S1),2,J)) Q:J<1  D
  1.  . S Y=+^(J,0),X=Y_U_^LAB(60,Y,0)
  1.  . I $P($G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),4,Y,0)),"^",6)="*Not Performed" Q
  1.  . D EX2
  1.  S X=S1(S1),J=S1(S1,1),S1=S1-1
  1.  Q
  1.  ;
  1.  ;
  1. ORD ;
  1.  ; LRNX is set by caller
  1.  S LRNX=+$G(LRNX)+1,LRORD(LRNX)=S2
  1.  S LRBEY($P(LRTEST(T1),U,1),S2)=""   ; CIDC
  1.  S ^TMP("LR",$J,"TMP",S2)=+X
  1.  ; If panel being exploded then set parent("P" node)
  1.  ;  to file #60 test being exploded
  1.  I $G(LRTEST(T1,"P")) D
  1.  . I +LRTEST(T1)=+LRTEST(T1,"P") S ^TMP("LR",$J,"TMP",S2,"P")=LRTEST(T1,"P")_"!"_$$RNLT(+X)
  1.  . E  S ^TMP("LR",$J,"TMP",S2,"P")=+LRTEST(T1)_U_$$NLT(+LRTEST(T1))_"!"_$$RNLT(+X)
  1.  ;
  1.  I $P(X,U,18) D
  1.  . S LRM(S2)=+X
  1.  . S LRM(S2,"P")=$G(^TMP("LR",$J,"TMP",S2,"P"))
  1.  . S LRMX(+X)=""
  1.  Q
  1.  ;
  1.  ;
  1. NLT(X) ;
  1.  N Y
  1.  S Y=$S($P($G(^LAM(+$G(^LAB(60,+X,64)),0)),U,2):$P(^(0),U,2),1:"")
  1.  Q Y
  1.  ;
  1.  ;
  1. RNLT(X) ;
  1.  I 'X Q ""
  1.  N Y
  1.  S Y(1)=+$P($G(^LAB(60,X,64)),U,2)
  1.  S Y=$S($P($G(^LAM(Y(1),0)),U,2):$P(^(0),U,2),1:"")
  1.  I Y S $P(Y,"!",2)=$$LNC(Y,$G(LRCDEF),$G(LRSPEC))
  1.  S $P(Y,"!",3)=$G(LRCDEF),$P(Y,"!",6)=X
  1.  Q Y
  1.  ;
  1.  ;
  1. LNC(LRNLT,LRCDEF,LRSPEC) ;reture the LOINC code for WKLD Code/Specimen
  1.  ; Call with (nlt code,method suffix,test specimen)
  1.  ; TA = Time Aspect
  1.  N X,N,Y,LRSPECN,VAL,ERR,TA S X=""
  1.  Q:'LRNLT X
  1.  K LRMSGM
  1.  S:$G(LRCDEF)="" LRCDEF="0000"
  1.  I $P(LRCDEF,".",2) S LRCDEF=$P(LRCDEF,".",2)
  1.  S LRCDEF=$S($P(LRNLT,".",2):$P(LRNLT,".",2),1:LRCDEF)
  1.  I $L(LRCDEF)'=4 S LRCDEF=LRCDEF_$E("0000",$L(LRCDEF),($L(LRCDEF-4)))
  1.  S LRCDEF=LRCDEF_" "
  1.  S LRSPEC=+LRSPEC
  1.  ;Get time aspect from 61
  1.  S TA=$$GET1^DIQ(61,LRSPEC_",",.0961,"I")
  1.  S LRSPECN=$S($D(^LAB(61,LRSPEC,0))#2:$$GET1^DIQ(61,LRSPEC_",",.01),1:"Unknown")
  1.  S LRNLT=$P(LRNLT,".")_"."
  1.  ;Check for WKLD CODE_LOAD/WORK LIST method suffix
  1.  S VAL(1)=LRNLT_LRCDEF
  1.  S N=$$FIND1^DIC(64,"","X",.VAL,"C","","ERR")
  1.  ;Looking for specimen specific LOINC
  1.  I N,LRSPEC D  I X D MSG(1) Q X
  1.  . I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_N_",",4,"I") Q:X
  1.  . S TA=$O(^LAM(N,5,LRSPEC,1,0)) ; get time aspect
  1.  . I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_N_",",4,"I") Q:X
  1.  ;Looking LOINC default
  1.  I N S X=$$LDEF(N) I X D MSG(2) Q X
  1.  I LRCDEF="0000 " Q ""
  1.  ;Looking for WKLD CODE_GENERIC suffix
  1.  K VAL
  1.  S VAL(1)=LRNLT_"0000 "
  1.  S N=$$FIND1^DIC(64,"","X",.VAL,"C","","ERR")
  1.  I 'N Q ""
  1.  ;Looking for WKLD CODE_GENERIC specimen specific LOINC
  1.  I LRSPEC D  I X D MSG(3) Q X
  1.  . I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_N_",",4,"I") Q:X
  1.  . S TA=$O(^LAM(N,5,LRSPEC,1,0)) ; get time aspect
  1.  . I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_N_",",4,"I") Q:X
  1.  ;Looking for WKLD CODE_GENERIC default LOINC
  1.  I 'X,N S X=$$LDEF(N) I X D MSG(4)
  1.  I 'X S X=""
  1.  Q X
  1.  ;
  1.  ;
  1. LDEF(Y) ;Find the default LOINC code for WKLD CODE
  1.  I 'Y Q ""
  1.  S X=$$GET1^DIQ(64,Y_",",25,"I")
  1.  I 'X S X=""
  1.  Q X
  1.  ;
  1.  ;
  1. TMPSB(LRSB) ; Get LOINC code from ^TMP("LR",$J,"TMP",LRSB,"P")
  1.  S NODE=$G(^TMP("LR",$J,"TMP",LRSB,"P"))
  1.  I 'NODE Q ""
  1.  S $P(NODE,"!",3)=$$LNC($P(NODE,"!",2),$G(LRCDEF),$G(LRSPEC))
  1.  S $P(NODE,"!",4)=$G(LRCDEF)
  1.  Q $P(NODE,U,2)
  1.  ;
  1.  ;
  1. MSG(VAL) ;Set output message
  1.  Q:'$G(LRMSG)
  1.  S LRMSGM="0-No LOINC Code Defined for "_LRNLT_LRCDEF
  1.  N TANAME
  1.  I $G(TA) S TANAME=$$GET1^DIQ(64.061,TA_",",.01,"E") ;TA Name
  1.  I VAL=1 S LRMSGM="1-"_LRNLT_$E(LRCDEF,1,4)_" - "_LRSPECN
  1.  I VAL=2 S LRMSGM="2-"_LRNLT_$E(LRCDEF,1,4)_" - Default LOINC"
  1.  I VAL=3 S LRMSGM="3-"_LRNLT_"0000 - "_LRSPECN
  1.  I VAL=4 S LRMSGM="4-"_LRNLT_"0000 - Default LOINC"
  1.  I $G(TA) S LRMSGM=LRMSGM_" Time Aspect "_TANAME
  1.  W:$G(LRDBUG) !,LRMSGM,!
  1.  Q