source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRLNC63.m@ 1688

Last change on this file since 1688 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1LRLNC63 ;DALOI/FHS-HISTORICAL LOINC CODE MAPPER FOR DD(63.04 DATA ;10/15/2001 15:19
2 ;;5.2;LAB SERVICE;**279**;Sep 27, 1994
3TASK ;
4 I '$G(^XTMP("LRLNC63",0)) S ^(0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"LOINC HISTORICAL MAPPER INFORMATION"
5 Q:'$G(LRSEQ)
6 L +^XTMP("LRLNC63","TASK",LRSEQ):1 Q:'$T
7 H 5
8 I LRSEQ=999999 D DECIMAL^LRLNC63A Q
9 S LRNXT=+$G(^XTMP("LRLNC63","SEQ",LRSEQ))
10 I LRNXT>1 S LRNXT=LRNXT-1
11 S:LRNXT<1 LRNXT=(LRSEQ-1)
12 S:LRNXT<0 LRNXT=0
13 S LRMAP=$$GET1^DIQ(69.9,"1,",95.3,"I","","ERR")
14 S ^XTMP("LRLNC63","SEQ",LRSEQ,"START")=$$NOW^XLFDT
15 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
16 . I '$G(^LR(LRNXT,0)) S ^XTMP("LRLNC63","SEQ",LRSEQ)=LRNXT Q
17 . D LK6304(LRNXT)
18 . S ^XTMP("LRLNC63","SEQ",LRSEQ)=LRNXT
19 I $G(^XTMP("LRLNC63","STOP")) D Q
20 . N LRNOW
21 . S LRNOW=$$FMTE^XLFDT($$NOW^XLFDT,1)
22 . S ^XTMP("LRLNC63","SEQ",LRSEQ,"END")="USER STOP"_U_$$NOW^XLFDT
23 . S XQAMSG="LOINC Historical Mapper Sequence "_LRSEQ_"-"_(LRSEQ+20000)_" STOPPED @ "_LRNOW
24 . D XQA^LRLNC63A
25 . L -^XTMP("LRLNC63","TASK",LRSEQ)
26MES ; Send alert message when LRDFN sequence range mapping is finished
27 S XQAMSG="LOINC Historical Mapper LRDFN sequence "_LRSEQ_" - "_(LRSEQ+20000)_" completed @ "_$$FMTE^XLFDT($$NOW^XLFDT,1)
28 D DONE^LRLNC63A
29 Q
306304 ;Entry point for setting ALL Patient's LOINC CODE for CH subscripted test
31 K LRDFN,LRIDT,LRDATA,LRNLT,LRLNC
32 K ^XTMP("LRLNC63")
33 I $P($G(^LR(LRDFN,0)),U,2)=62.3 Q
34 S LRDFN=0 F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 I $O(^LR(LRDFN,"CH",0)) D I $$S^%ZTLOAD Q
35 . D LK6304(LRDFN)
36 Q
37LK6304(LRDFN) ;Call with LRDFN defined for single patient mapping
38 Q:'LRDFN
39 Q:'$G(^LR(LRDFN,0)) S LRFILE=+$P(^(0),U,2),DFN=+$P(^(0),U,3)
40 I '$G(LRFILE)!(LRFILE=62.3)!('DFN) Q ;Do not process controls
41 K LRSAGE
42 S SEX="M",AGE=99,LRSAGE=0
43 I $S($G(LRMAP):0,LRFILE=2:1,LRFILE=67:1,1:0) D
44 . D GETS^DIQ(LRFILE,DFN_",",".02;.03","IE","LRSAGE")
45 . S DOB=$G(LRSAGE(LRFILE,DFN_",",.03,"I"))
46 . I $L($G(LRSAGE(LRFILE,DFN_",",.02,"I"))) S SEX=LRSAGE(LRFILE,DFN_",",.02,"I")
47 . S LRSAGE=1
48 S LRIDT=0 F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1 D
49 . I $G(LRDBUG),'(LRDFN#100) W "."
50 . Q:$G(^LR(LRDFN,"CH",LRIDT,"NPC"))<2 ;Must have the New Person Convertion node set to >1
51 . Q:'$P($G(^LR(LRDFN,"CH",LRIDT,0)),U,3) S LRCDT=$P(^(0),U),LRDSPEC=$P(^(0),U,5) ; Must have completion date
52 . D SUB(LRDFN,LRIDT)
53 Q
54SUB(LRDFN,LRIDT) ;Single or all test LOINC mapping
55 ;LRDFN=Lab IEN number
56 ;LRIDT inverse date
57 ;Check each result and determine LOINC CODE
58 ;If Result NLT code is defined (LRNLT)
59 ;If Workload suffix code is set (LRCDEF)
60 ;If Specimen is defined (LRSPEC)
61 ;Variable LRLNC is the LOINC CODE
62 ;LRSB(LRSUB) will screen for only those datanames
63 ;LRSB(LRSUB)=Workload suffix -- this will be used to change default suffix code.
64 ;LRDATA= ^LR(LRDFN,"CH",LRIDT,TEST) node
65 K LR5,LRLNC,LRMNODE,LROVR,LRSUB,LRXDEF,LRXNLT,LRXCDEF
66 S LRXDEF=0,LRSUB=1
67 F S LRSUB=$O(^LR(LRDFN,"CH",LRIDT,LRSUB)) Q:LRSUB<1 S LRDATA=^(LRSUB) D
68 . I '$D(^XTMP("LRLNC63",1,LRSUB)) D XTMP^LRLNC63A(LRSUB)
69 . S (LR5,LROVR,LRLNC,LRXCDEF,LRMOD1)=""
70 . I $G(LRMOD),$G(^XTMP("LRLNC63",2,LRSUB)) S LRMNODE=^(LRSUB) D
71 . . S LROVR=+$P(LRMNODE,U,6),LRXCDEF=$P(LRMNODE,U,5)
72 . . S LRMOD1=1
73 . S LRDATA3=$P(LRDATA,U,3),LRDATA5=$P(LRDATA,U,5)
74 . S LRNLT=$S($G(LRXNLT):LRXNLT,1:$P(LRDATA3,"!",2))
75 . S LRCDEF=$S($G(LROVR):LRXCDEF,$P(LRDATA3,"!",4):$P(LRDATA3,"!",4),1:LRXCDEF)
76 . S LRSPEC=$S($P(LRDATA,U,5):+$P(LRDATA,U,5),1:LRDSPEC)
77 . I '$G(LRNLT) S LRNLT=$S(LRNLT:LRNLT,1:$G(^XTMP("LRLNC63",1,LRSUB)))
78 . I LRNLT>1,LRSPEC S LRLNC=$$LNC^LRVER1(LRNLT,LRCDEF,LRSPEC)
79 . I LRLNC D
80 . . S $P(LRDATA3,"!",3)=LRLNC,$P(LRDATA3,"!",4)=LRCDEF
81 . . I '$D(^XTMP("LRLNC63","MAP",LRSUB,LRSPEC,LRNLT,+LRCDEF,LRLNC)) S ^(LRLNC)=""
82 . I '$G(LRMAP),LRSAGE,LRDATA5["$S(" D RANGE^LRLNC63A
83 . I $G(LRDBUG) D Q
84 . . W !,LRDFN,?10,LRIDT,?30,LRSUB_" "_LRSPEC
85 . . I $G(LRDBUG)=2,$G(LRLNC) W !,LRDATA3,!,LRDATA5 Q
86 . . I $G(LRDBUG)=1 W !,$S(LRLNC:"",1:"** ")_LRDATA3,!,LRDATA5
87 . I $G(LRLNC) D
88 . . S $P(LRDATA3,"!",5)=$S($G(LRMOD1):2,1:1)
89 . . S $P(LRDATA,U,3)=LRDATA3
90 . . S $P(^LR(LRDFN,"CH",LRIDT,LRSUB),U,3)=LRDATA3
91 . I $G(LR5) S $P(^LR(LRDFN,"CH",LRIDT,LRSUB),U,5)=LRDATA5
92 Q
93LNC(LRNLT,LRCDEF,LRSPEC) ;reture the LOINC code for WKLD Code/Specimen
94 ; Call with (nlt code,method suffix,test specimen)
95 ; TA = Time Aspect
96 N X,LRXN,Y,LRSPECN,VAL,ERR,TA S X=""
97 Q:'LRNLT X
98 K LRMSGM
99 S:'$L($G(LRCDEF)) LRCDEF="0000"
100 I $P($G(LRCDEF),".",2) S LRCDEF=$P(LRCDEF,".",2)
101 S LRCDEF=$S($P(LRNLT,".",2):$P(LRNLT,".",2),1:LRCDEF)
102 I $L(LRCDEF)'=4 S LRCDEF=LRCDEF_$E("0000",$L(LRCDEF),($L(LRCDEF-4)))
103 S LRCDEF=LRCDEF_" "
104 S LRSPEC=+LRSPEC
105 ;Get time aspect from 61
106 S TA=$$GET1^DIQ(61,LRSPEC_",",.0961,"I")
107 S LRSPECN=$S($D(^LAB(61,LRSPEC,0))#2:$$GET1^DIQ(61,LRSPEC_",",.01),1:"Unknown")
108 S LRNLT=$P(LRNLT,".")_"."
109 ;Check for WKLD CODE_LOAD/WORK LIST method suffix
110 S VAL(1)=LRNLT_LRCDEF
111 S LRXN=$$FIND1^DIC(64,"","X",.VAL,"C","","ERR")
112 ;Looking for specimen specific LOINC
113 I LRXN,LRSPEC D I X D MSG(1) Q X
114 . I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_LRXN_",",4,"I") Q:X
115 . S TA=$O(^LAM(LRXN,5,LRSPEC,1,0)) ; get time aspect
116 . I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_LRXN_",",4,"I") Q:X
117 ;Looking LOINC default
118 I LRXN S X=$$LDEF(LRXN) I X D MSG(2) Q X
119 I LRCDEF="0000 " Q ""
120 ;Looking for WKLD CODE_GENERIC suffix
121 K VAL
122 S VAL(1)=LRNLT_"0000 "
123 S LRXN=$$FIND1^DIC(64,"","X",.VAL,"C","","ERR")
124 I 'LRXN Q ""
125 ;Looking for WKLD CODE_GENERIC specimen specific LOINC
126 I LRSPEC D I X D MSG(3) Q X
127 . I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_LRXN_",",4,"I") Q:X
128 . S TA=$O(^LAM(LRXN,5,LRSPEC,1,0)) ; get time aspect
129 . I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_LRXN_",",4,"I") Q:X
130 ;Looking for WKLD CODE_GENERIC default LOINC
131 I 'X,LRXN S X=$$LDEF(LRXN) I X D MSG(4)
132 I 'X S X=""
133 Q X
134LDEF(LRY) ;Find the default LOINC code for WKLD CODE
135 I 'LRY Q ""
136 S X=$$GET1^DIQ(64,LRY_",",25,"I")
137 I 'X S X=""
138 Q X
139TMPSB(LRSB) ; Get LOINC code from ^TMP("LR",$J,"TMP",LRSB,"P")
140 S NODE=$G(^TMP("LR",$J,"TMP",LRSB,"P"))
141 I 'NODE Q ""
142 S $P(NODE,"!",3)=$$LNC($P(NODE,"!",2),$G(LRCDEF),$G(LRSPEC))
143 S $P(NODE,"!",4)=$G(LRCDEF)
144 Q $P(NODE,U,2)
145 Q
146MSG(VAL) ;Set output message
147 Q:'$G(LRMSG)
148 S LRMSGM="0-No LOINC Code Defined for "_LRNLT_" "_LRCDEF
149 N TANAME
150 I $G(TA) S TANAME=$$GET1^DIQ(64.061,TA_",",.01,"E") ;TA Name
151 I VAL=1 S LRMSGM="1-"_LRNLT_$E(LRCDEF,1,4)_" - "_LRSPECN
152 I VAL=2 S LRMSGM="2-"_LRNLT_$E(LRCDEF,1,4)_" - Default LOINC"
153 I VAL=3 S LRMSGM="3-"_LRNLT_"0000 - "_LRSPECN
154 I VAL=4 S LRMSGM="4-"_LRNLT_"0000 - Default LOINC"
155 I $G(TA) S LRMSGM=LRMSGM_" Time Aspect "_TANAME
156 W:$G(LRDBUG) !,LRMSGM,!
157 Q
158 ;
159RNLT(X) ;
160 I 'X Q ""
161 N Y
162 S Y(1)=+$P($G(^LAB(60,X,64)),U,2)
163 S Y=$S($P($G(^LAM(Y(1),0)),U,2):$P(^(0),U,2),1:"")
164 I Y S $P(Y,"!",2)=$$LNC(Y,$G(LRCDEF),$G(LRSPEC))
165 S $P(Y,"!",3)=$G(LRCDEF)
166 Q Y
167 ;
168QUE ;Entry point to start/restart historical mapper
169 ;Queue to a the resource device LRRESOURCE to trottle number of
170 ;active conversion jobs.
171SEC ;Check for security key
172 I '$D(^XUSEC("XUPROGMODE",+$G(DUZ))) D Q
173 . W !,$$CJ^XLFSTR("You are not cleared to use this option",80)
174DEV ;Check to make sure LRRESOURCE device exist
175 W @IOF
176 N LRERR
177 S LRDEV=$$FIND1^DIC(3.5,"","B","LRRESOURCE","","","LRERR")
178 I '$G(LRDEV) D G END
179 . W !,$$CJ^XLFSTR("You must define the resource device named 'LRRESOURCE'",80)
180 . W !,$$CJ^XLFSTR("with at least one slot. Process Aborted.",80)
181 S LRSLOT=$$GET1^DIQ(3.5,LRDEV_",",35,"I")
182 I LRSLOT'>0 D G END
183 . W !,$$CJ^XLFSTR("LRRESOURCE device must have at leaset 1 slot.",80)
184 . W !,$$CJ^XLFSTR("The recommended number is 8.",80)
185 W !!,$$CJ^XLFSTR("D STOP^LRLNC63 to stop all background historical mapping tasks.",80),!
186DIS ;Inform the user of the option's functionality
187 W !!,$$CJ^XLFSTR("This option should be run during 24 hour off peak time frame!!",80),!!
188 W !,$$CJ^XLFSTR("This option will queue multiple tasks to LOINC map",80)
189 W !,$$CJ^XLFSTR("historical data in the LAB DATA (#63).",80)
190 K DIR S DIR(0)="Y",DIR("A")="Are you certain you wish to proceed"
191 D ^DIR I $G(Y)'=1 G END
192 S LRSTOP=$G(^XTMP("LRLNC63","STOP"))
193 K ^XTMP("LRLNC63",1),^XTMP("LRLNC63","STOP")
194 S LRLST=$O(^LR(999999),-1)
195 D
196 . I LRLST[".",$D(^LR(0))#2 S $P(^(0),U,3)=$P(LRLST,".") Q
197 . I $D(^LR(0))#2 S $P(^(0),U,3)=LRLST
198 K ^XTMP("LRLNC63",0)
199 F LRSEQ=1:20000:LRLST D IO
200 I $O(^LR(999999)) S LRSEQ=999999 D IO
201END ;Cleanup
202 K LRDEV,LRSLOT,LRLST,LRSEQ
203 K ZTSAVE,ZTDTH,ZTDESC,ZTRTN
204 Q
205IO ;Task to LRRESOURCE
206 L +^XTMP("LRLNC63","TASK",LRSEQ):1 I '$T D Q
207 . W !,$$CJ^XLFSTR("Sequence # "_LRSEQ_" is already running.",80),!
208 I $G(^XTMP("LRLNC63","SEQ",LRSEQ,"END")) D
209 . K ^XTMP("LRLNC63","SEQ",LRSEQ)
210 I $G(LRSTOP) K ^XTMP("LRLNC63","SEQ",LRSEQ,"END")
211 S ZTSAVE("LRSEQ")="",ZTIO="LRRESOURCE",ZTDTH=$H
212 S ZTDESC="LOINC Historical Conversion - Seq "_LRSEQ_" "_$$NOW^XLFDT
213 S ZTSAVE("LRLST")=""
214 S ZTRTN="TASK^LRLNC63"
215 D ^%ZTLOAD
216 L -^XTMP("LRLNC63","TASK",LRSEQ)
217 Q:'$D(ZTSK)
218 S XQAMSG="LRDFN Conversion Sequence "_LRSEQ_"-"_(LRSEQ+20000)_" Task number is "_ZTSK
219 W !,XQAMSG D XQA^LRLNC63A
220 Q
221STOP ;Stop all LOINC conversion background jobs
222 N DIR
223 W !?5,"Stopping all background LOINC historical mapping jobs",!!
224 S DIR(0)="Y",DIR("A")="Are you certain you want to continue"
225 D ^DIR Q:Y'=1
226 S ^XTMP("LRLNC63","STOP")=$H_U_$$HTE^XLFDT($H)_U_"DUZ= "_$G(DUZ)
227 W !," Background task stop node has been set, jobs should stop soon",!
228 Q
Note: See TracBrowser for help on using the repository browser.