LR7OF1 ;slc/dcm/JAH - Setup new order from OE/RR ; 18-Apr-2016 06:13 ; MKK
;;5.2;LAB SERVICE;**1003,121,187,223,1021,256,299,1022,291,1031,1033,1034,1036,1037,1039**;NOV 1, 1997;Build 38
;
;
EN ;Setup NEW orders from OE/RR messages
;[^TMP("OR",$J,"LRES") DOCUMENTATION]
; 'Combining of Orders' functionality depends on this TMP global
; Set and Killed when BHS and BTS batch message headers are received
; Global contains a list of lab orders for a session
; Lab adds elements to the global array as orders are processed:
; ^TMP("OR",$J,"LRES",LRDFN,LRSDT,LRXZ,^TMP("OR",$J,"LRES","CTR"))=LRORD_"^"_LRODT_"^"_LRSN
; ^TMP("OR",$J,"LRES","CTR")=Count
N ZTSK,LRORDR,X,UNEEK,LRNT ;UNEEK forces a unique entry (Micro tests), set when ^..."LROT" built
D DT
S LRORDR=LRXZ
S:'$D(^TMP("OR",$J,"LRES","CTR")) ^("CTR")=0
F LRSAMP=-1:0 S LRSAMP=$O(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP)) Q:LRSAMP="" D
. F LRSPEC=-1:0 S LRSPEC=$O(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC)) Q:LRSPEC="" S X=^(LRSPEC,0) D
.. S ORIFN=+X,UNEEK=$P(X,"^",2)
.. D ZX
Q
ZX ;
N COMBINE,X,NEWORD
I '$D(^LRO(69,LRODT,0)) D
. S ^(0)=$P(^LRO(69,0),U,1,2)_"^"_LRODT_"^"_(1+$P(^(0),U,4)),^LRO(69,LRODT,0)=LRODT,^LRO(69,"B",LRODT,LRODT)=""
S COMBINE=""
I 'UNEEK D
. S COMBINE=$$ORES^LR7OF5(LRDFN,LRSDT,LRXZ,+LRSAMP,LRPRAC,LROLLOC,LRSPEC,LRDUZ)
. I '$L(COMBINE) S COMBINE=$$FIND^LR7OF5(LRDFN,LRODT,LRSDT,LRXZ,+LRSAMP,LRPRAC,LROLLOC,LRSPEC,LRDUZ)
I '$L(COMBINE) S (NEWORD,ZTQUEUED)=1 L +^LRO(69,$E(DT,1,3)_"0000",2):1 D ORDER^LROW2 K ZTSK,ZTQUEUED,ZTREQ G LOCK
I $E(COMBINE,1,2)="S." S LRSN=$P(COMBINE,".",2),LRORD=$P(COMBINE,".",3) G ADD ;Combine on specimen
I $E(COMBINE,1,2)="O."!($E(COMBINE,1,2)="C.") S LRORD=$S($E(COMBINE,1,2)="O.":$P(COMBINE,".",2),1:$P(COMBINE,".",3)) ;Combine on order #
LOCK ;
L +^LRO(69,LRODT,1):360
I '$T G LOCK
S LRSN=1+$O(^LRO(69,LRODT,1,999999999),-1),LRSUM=1+$S($D(^LRO(69,LRODT,1,0)):$P(^(0),U,4),1:0)
ZSN ;
I $D(^LRO(69,LRODT,1,LRSN,0)) S LRSN=LRSN+1 G ZSN
S ^LRO(69,LRODT,1,LRSN,0)=LRDFN_"^"_LRDUZ_"^"_+LRSAMP_"^"_LRORDR_"^"_LRNT_"^"_LRPRAC_"^"_LRLLOC_"^"_LRSDT_"^"_LROLLOC_"^^"_ORIFN,^LRO(69,LRODT,1,0)="^69.01PA^"_LRSN_"^"_LRSUM
L -^LRO(69,LRODT,1)
S ^LRO(69,LRODT,1,"AA",LRDFN,LRSN)="",^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,"SN")=LRSN,^LRO(69,"D",LRDFN,LRODT,LRSN)=""
I $L(LRLLOC) S ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
I $L(LRSPEC) S ^LRO(69,LRODT,1,LRSN,4,0)="^69.02PA^1^1",^(1,0)=LRSPEC
S ^LRO(69,LRODT,1,LRSN,.1)=LRORD,^LRO(69,"C",+LRORD,LRODT,LRSN)=""
I $G(NEWORD) L -^LRO(69,$E(DT,1,3)_"0000",2)
ADD ;
N I,J,LRJ,LRSXN,LRORIFN,NODE,STATUS
S ^TMP("OR",$J,"LRES","CTR")=^TMP("OR",$J,"LRES","CTR")+1,^TMP("OR",$J,"LRES",LRDFN,LRSDT,LRXZ,^TMP("OR",$J,"LRES","CTR"))=LRORD_"^"_LRODT_"^"_LRSN
; S LRORIFN=+$G(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,0))
; ----- IHS/OIT/MKK - BEGIN Lab Patch 1022 Modification
S LRORIFN=+$G(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,0)),INDIC=$G(^(-1)) ;IHS/CIA/DKM - Added INDIC
; ----- IHS/OIT/MKK - End Lab Patch 1022 Modification
S J=0
; F LRJ=1:1 S J=$O(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,J)) Q:J<1 S NODE=^(J),STATUS=$G(^(J,1)) D ZSN1(NODE,STATUS)
; ----- IHS/OIT/MKK - BEGIN Lab Patch 1022 Modification
F LRJ=1:1 S J=$O(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,J)) Q:J<1 S NODE=^(J),STATUS=$G(^(J,1)) D ZSN1(NODE,STATUS,INDIC)
; ----- IHS/OIT/MKK - End Lab Patch 1022 Modification
S (LRSXN,I)=0
F S I=$O(^LRO(69,LRODT,1,LRSN,2,I)) Q:I<1 S LRSXN=LRSXN+1
S:LRSXN ^LRO(69,LRODT,1,LRSN,2,0)="^69.03PA^"_LRSXN_"^"_LRSXN
I $E(COMBINE,1,2)="C." D
. S (LRSXN,I)=0 F S I=$O(^LRO(69,LRODT,1,+$P(COMBINE,".",2),2,I)) Q:I<1 S LRSXN=LRSXN+1
. S:LRSXN ^LRO(69,LRODT,1,+$P(COMBINE,".",2),2,0)="^69.03PA^"_LRSXN_"^"_LRSXN
Q
; ZSN1(NODE,STATUS) ;Add tests
; ----- IHS/OIT/MKK - BEGIN Lab Patch 1022 Modification
ZSN1(NODE,STATUS,INDIC) ; EP Add tests ;IHS/CIA/DKM - Added INDIC
; ----- IHS/OIT/MKK - END Lab Patch 1022 Modification
N CNT,XI,X,I,C,TCNT
S CNT=+$O(^LRO(69,LRODT,1,LRSN,2,99999),-1)
S LRTSTS=+NODE,LRQUANT=$P(NODE,"^",2)
I $D(^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS)) S REJECT(LRTSTS)="" Q
S ^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,0)=LRTSTS_"^"_$S($L(STATUS):STATUS,1:LROUTINE)_"^^^^^"_LRORIFN
; ----- IHS/OIT/MKK - BEGIN Lab Patch 1022 Modification
; S:$L($G(INDIC)) ^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,9999999)=INDIC ; IHS/CIA/DKM - Set clnical indication, if present
; ----- IHS/OIT/MKK - End Lab Patch 1022 Modification
;
I $L($G(INDIC)) D IHSCLINI ; IHS/MSC/MKK - LR*5.2*1033
;
D SDGX69^LRBEBA2(J,(CNT+LRJ)_","_LRSN_","_LRODT_",")
I $O(^TMP("OR",$J,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J,0)) D
. S X=^TMP("OR",$J,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J)+$S($P($G(^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,0)),"^",4):$P(^(0),"^",4),1:0),^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,0)="^^"_X_"^"_X_"^"_DT
. S TCNT=+$O(^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,99999),-1),(C,I)=0
. F S I=$O(^TMP("OR",$J,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J,I)) Q:I<1 S C=C+1,^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,C+TCNT,0)=^TMP("OR",$J,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J,I)
S ^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS,CNT+LRJ)=""
S ^LRO(69,"AT",LRDFN,LRTSTS,LRSPEC,LRODT)="",^(-LRODT)=""
I $E(COMBINE,1,2)="C." S X=^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,0),$P(^(0),"^",6)=LRORD,XI=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7),XI=XI_LRORD_"/",$P(^(1),"^",7)=XI D
. N CNT1
. S CNT1=$O(^LRO(69,LRODT,1,+$P(COMBINE,".",2),2,99999),-1)+1,^(CNT1,0)=X,$P(^(0),"^",14)=LRODT_";"_LRSN_";"_(CNT+LRJ),^LRO(69,LRODT,1,$P(COMBINE,".",2),2,"B",LRTSTS,CNT1)=""
;
D IHSURGNT^BLRUTIL8 ; IHS/MSC/MKK - LR*5.2*1039
Q
;
DT ;
S DT=$$DT^XLFDT()
S LRNT=$P($H,",",2),LRNT=LRNT\3600*100+(LRNT\60#60)/10000+DT
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
IHSCLINI ; EP - Clinical Indication
NEW SCHEMA,FDA,IENS
NEW ERRS ; IHS/MSC/MKK - LR*5.2*1036
;
Q:$TR($P(INDIC,"^",1,2),"^")="" ; Skip if No Data
;
S IENS=(CNT+LRJ)_","_LRSN_","_LRODT_","
S SCHEMA=$E($P(INDIC,"^",3))
I SCHEMA="I"!(SCHEMA="") D IHSICDI ; ICD Coding Schema
I SCHEMA="S" D IHSSNOI ; SNOMED Coding Schemas
;
D:$D(FDA) UPDATE^DIE("EKS","FDA",,"ERRS")
;
; D:$D(ERRS) ERRMSG^BLRSGNSP("IHSCLINI: UPDATE^DIE","LR7OF1") ; IHS/MSC/MKK - LR*5.2*1034 Send Error Message to LMI Mail Group
D:$D(ERRS) ERRMSG^BLRSGNS3("IHSCLINI: UPDATE^DIE","LR7OF1") ; IHS/MSC/MKK - LR*5.2*1036 Send Error Message to LMI Mail Group
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
D REFLICDS
;
D ADBLRRLO^BLRUTIL6(LRODT,LRSN,(CNT+LRJ))
; ----- END IHS/MSC/MKK - LR*5.2*1034
Q
;
IHSICDI ; ICD Clinical Indication
; S ICDCODE=$P(INDIC,"^")
S ICDCODE=$P($P(INDIC,"^"),";") ; IHS/MSC/MKK - LR*5.2*1036 - Just the 1st code
S ICDDESC=$P(INDIC,"^",2)
; I $L(ICDCODE)&($L(ICDDESC)<1!(ICDDESC["*")) S ICDDESC=$P($$ICDDX^ICDCODE(ICDCODE),"^",4)
I $L(ICDCODE)&($L(ICDDESC)<1!(ICDDESC["*")) S ICDDESC=$P($$ICDDX^ICDEX(ICDCODE),"^",4) ; IHS/MSC/MKK - LR*5.2*1034
S:$L(ICDDESC) FDA(69.03,IENS,9999999.1)=ICDDESC
S:$L(ICDCODE) FDA(69.05,"?+1,"_IENS,.01)=ICDCODE
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1037
D FSNOMED
Q
; ----- END IHS/MSC/MKK - LR*5.2*1037
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034 - Get the SNOMED code, if possible
Q:$L(ICDCODE)<1
;
NEW CONCID,BSTSFLAG,IN,OUT,SNOMED,STR
S OUT="VARS",IN=ICDCODE
I +$$ICD2SMD^BSTSAPI(OUT,IN) D
. S CONCID=$G(VARS(1,"CON")) ; Pick 1st Concept ID
. S STR=$$CONC^BSTSAPI(CONCID)
. S SNOMED=$P(STR,"^",3)
. S:$L(SNOMED)<1 SNOMED=$P(STR,"^",1)
E S SNOMED=$$ICD2SMD(ICDCODE,ICDDESC)
;
S:$L(SNOMED) FDA(69.03,IENS,9999999.2)=SNOMED
; ----- END IHS/MSC/MKK - LR*5.2*1034
Q
;
IHSSNOI ; SNOMED Clinical Indication
S SNOMED=$P(INDIC,"^")
S SNOMDESC=$P(INDIC,"^",2)
S:$L(SNOMEDESC) FDA(69.03,IENS,9999999.1)=SNOMDESC
S FDA(69.03,IENS,9999999.2)=SNOMED
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034 - Get the ICD code, if possible
NEW ICD10,ICD10DT,ICD10CS,ICD9,ICDCODE,STR
S STR=$$DESC^BSTSAPI(SNOMED)
I $L(STR)&($L(SNOMEDESC)<1) D ; Get SNOMED Description
. S SNOMEDESC=$$TRIM^XLFSTR($P($P(STR,"^",2),"("),"LR"," ")
. S:$L(SNOMEDESC) FDA(69.03,IENS,9999999.1)=SNOMDESC
;
S ICD10CS=+$$FIND1^DIC(80.4,,,"ICD-10-CM") ; Get Coding System IEN
S ICD10DT=$$GET1^DIQ(80.4,ICD10CS,"IMPLEMENTATION DATE","I")
S:ICD10DT<1 ICD10DT=3151001 ; If no Date returned from 80.4, hard set to 10/1/2015.
;
; Note that $$DESC^BSTAPI will only return 3 pieces of data if the SNOMED variable
; is a SNOMED CONCEPT ID. If it is a "real" SNOMED code, it will return 4 pieces
; of information.
S ICD10=$P($P(STR,"^",3),";") ; Just the 1st code
S ICD9=$P($P(STR,"^",4),";") ; Just the 1st Code
S:ICD9="" ICD9=ICD10
S ICDCODE=$S($$DT^XLFDT'<ICD10DT:ICD10,1:ICD9)
S:$L(ICDCODE) FDA(69.05,"?+1,"_IENS,.01)=ICDCODE
; ----- END IHS/MSC/MKK - LR*5.2*1034
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
REFLICDS ; EP - Store the ICD code(s) into the BLR REFERENCE LAB ORDER/ACCESSION (#9009026.3) file
NEW DFN,F60IEN,ICD,ICDCODE,ICDEXIST,IENS,IENSICD,ORDERIEN,ORDERN
NEW FDA,ERRS ; IHS/MSC/MKK - LR*5.2*1036
;
Q:$D(FDA(69.05))<1 ; If no ICD codes, skip
;
S IENS=LRSN_","_LRODT
S ORDERN=$$GET1^DIQ(69.01,IENS,9.5)
Q:ORDERN<1 ; If no order #, skip
;
S F60IEN=$$GET1^DIQ(69.03,(CNT+LRJ)_","_IENS,.01,"I")
Q:$$REFLABCK^BLRUTIL6(F60IEN,LRODT,LRSN)<1 ; If Not Ref Lab Test, skip
;
S IENS=(CNT+LRJ)_","_LRSN_","_LRODT
S F60IEN=$$GET1^DIQ(69.03,IENS,.01,"I")
;
Q:$$REFLAB^BLRUTIL6(DUZ(2),+F60IEN)<1 ; If Test not MAPPED, do NOT put into 9009026.3
;
S DFN=$$GET1^DIQ(63,LRDFN,.03,"I")
S X=$$ORD^BLRRLEDI(ORDERN,DFN) ; Store Order # if not in there already
S ORDIEN=$$FIND1^DIC(9009026.3,,,ORDERN)
;
Q:ORDIEN<1 ; If order not in 9009026.3, skip
;
S ICDEXIST=$O(^LRO(69,LRODT,1,LRSN,2,(CNT+LRJ),2,0))
;
Q:F60IEN<1
;
S ICD=.9999999
F S ICD=$O(^LRO(69,LRODT,1,LRSN,2,(CNT+LRJ),2,ICD)) Q:ICD<1 D
. S IENSICD=ICD_","_IENS
. S ICDCODE=$$GET1^DIQ(69.05,IENSICD,.01,"I")
. ;
. ; Skip if UNCODED DIAGNOSIS
. Q:$$GET1^DIQ(80,ICDCODE,.01)=".9999"!($$GET1^DIQ(80,ICDCODE,.01)="ZZZ.999")
. ;
. K FDA,ERRS
. S FDA(9009026.31,"?+1,"_ORDIEN_",",.01)=ICDCODE
. D UPDATE^DIE(,"FDA",,"ERRS")
. ; D:$D(ERRS) ERRMSG^BLRSGNSP("REFLICDS: UPDATE^DIE","LR7OF1")
. D:$D(ERRS) ERRMSG^BLRSGNS3("REFLICDS: UPDATE^DIE","LR7OF1") ; IHS/MSC/MKK - LR*5.2*1036
;
Q
;
TESTIT ; EP - Test the REFLICDS logic
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
R !,"ORDER #:",ORDERN,!
Q:+ORDERN<1
;
S LRODT=0
F S LRODT=$O(^LRO(69,"C",ORDERN,LRODT)) Q:LRODT<1 D
. S LRSN=0
. F S LRSN=$O(^LRO(69,"C",ORDERN,LRODT,LRSN)) Q:LRSN<1 D
.. S LRDFN=$$GET1^DIQ(69.01,LRSN_","_LRODT,.01,"I")
.. ;
.. S LROT=.9999999
.. F S LROT=$O(^LRO(69,LRODT,1,LRSN,2,LROT)) Q:LROT<1 D
... S LRJ=LROT,CNT=0
... D REFLICDS
Q
;
ICD2SMD(ICD,PROVNARR) ; EP - Use Provider Narrative and ICD-10 Code to get SNOMED match
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,ICD,PROVNARR,U,XPARSYS,XQXFLG)
;
S SNOMED=""
;
S OUT="VARS",IN=PROVNARR_"^F"
S X=$$SEARCH^BSTSAPI(OUT,IN)
Q:X<1 SNOMED
;
; "Trick" because Terminology Server may return ICD code without final period
S ICD2CHK=$S($P(ICD,".",2)="":$P(ICD,"."),1:ICD)
;
S (CNT,FOUND)=0
F S CNT=$O(VARS(CNT)) Q:CNT<1!(FOUND) D
. S TSICD=$G(VARS(CNT,"ICD",1,"COD")) ; Terminology Server ICD-10
. Q:ICD'=TSICD&(ICD2CHK'=TSICD)
. Q:$G(VARS(CNT,"PRB","TRM"))'=PROVNARR
. ;
. S CONCID=$G(VARS(CNT,"CON")) ; Pick Concept ID
. S STR=$$CONC^BSTSAPI(CONCID)
. S CSNOMED=$P(STR,"^",3)
. S:$L(CSNOMED)<1 CSNOMED=$P(STR,"^",1)
. Q:$L(CSNOMED)<1
. ;
. K FOUND("SNOMED")
. S FOUND("SNOMED")=CSNOMED
. S FOUND=FOUND+1
;
Q $S(FOUND:$G(FOUND("SNOMED")),1:$G(SNOMED))
;
; ----- END IHS/MSC/MKK - LR*5.2*1034
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1037
FSNOMED ; EP - Try to find a SNOMED Code using an OE/RR API & BSTSAPI call
NEW CLININD,FOUNDIT,SNOCONID,VARS
;
Q:+$G(ORIFN)<1 ; Skip if file 100 IEN < 1
;
; OE/RR API - CLINICAL INDICATION. Note that it can contain a | that sometimes
; separates two clinical indications. Only use the first clinical indication.
; Trim any leading and/or trailing blanks.
S CLININD=$$TRIM^XLFSTR($P($$VALUE^ORCSAVE2(ORIFN,"CLININD"),"|"),"LR"," ")
;
S SNOCONID=$$VALUE^ORCSAVE2(ORIFN,"SNMDCNPTID") ; OE/RR API - SNOmed CONcept ID
Q:$L(CLININD)<1!($L(SNOCONID)<1) ; Skip if either variable is null.
;
D CNCLKP^BSTSAPI("VARS",SNOCONID)
;
; If PREFERRED TERM, then set and return
I $G(VARS(1,"PRE","TRM"))=CLININD S FDA(69.03,IENS,9999999.2)=$G(VARS(1,"PRE","DSC")) Q
;
; If PRB, then set and return
I $G(VARS(1,"PRB","TRM"))=CLININD S FDA(69.03,IENS,9999999.2)=$G(VARS(1,"PRB","DSC")) Q
;
; Have to search the synonyms
S SYN=0,FOUNDIT=""
F S SYN=$O(VARS(1,"SUB",SYN)) Q:SYN<1!($L(FOUNDIT)) D
. I $G(VARS(1,"SUB",SYN,"TRM"))=CLININD S FOUNDIT=$G(VARS(1,"SUB",SYN,"DSC"))
;
S:$L(FOUNDIT) FDA(69.03,IENS,9999999.2)=FOUNDIT
Q
; ----- END IHS/MSC/MKK - LR*5.2*1037
LR7OF1 ;slc/dcm/JAH - Setup new order from OE/RR ; 18-Apr-2016 06:13 ; MKK
+1 ;;5.2;LAB SERVICE;**1003,121,187,223,1021,256,299,1022,291,1031,1033,1034,1036,1037,1039**;NOV 1, 1997;Build 38
+2 ;
+3 ;
EN ;Setup NEW orders from OE/RR messages
+1 ;[^TMP("OR",$J,"LRES") DOCUMENTATION]
+2 ; 'Combining of Orders' functionality depends on this TMP global
+3 ; Set and Killed when BHS and BTS batch message headers are received
+4 ; Global contains a list of lab orders for a session
+5 ; Lab adds elements to the global array as orders are processed:
+6 ; ^TMP("OR",$J,"LRES",LRDFN,LRSDT,LRXZ,^TMP("OR",$J,"LRES","CTR"))=LRORD_"^"_LRODT_"^"_LRSN
+7 ; ^TMP("OR",$J,"LRES","CTR")=Count
+8 ;UNEEK forces a unique entry (Micro tests), set when ^..."LROT" built
NEW ZTSK,LRORDR,X,UNEEK,LRNT
+9 DO DT
+10 SET LRORDR=LRXZ
+11 IF '$DATA(^TMP("OR",$JOB,"LRES","CTR"))
SET ^("CTR")=0
+12 FOR LRSAMP=-1:0
SET LRSAMP=$ORDER(^TMP("OR",$JOB,"LROT",LRSDT,LRXZ,LRSAMP))
IF LRSAMP=""
QUIT
Begin DoDot:1
+13 FOR LRSPEC=-1:0
SET LRSPEC=$ORDER(^TMP("OR",$JOB,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC))
IF LRSPEC=""
QUIT
SET X=^(LRSPEC,0)
Begin DoDot:2
+14 SET ORIFN=+X
SET UNEEK=$PIECE(X,"^",2)
+15 DO ZX
End DoDot:2
End DoDot:1
+16 QUIT
ZX ;
+1 NEW COMBINE,X,NEWORD
+2 IF '$DATA(^LRO(69,LRODT,0))
Begin DoDot:1
+3 SET ^(0)=$PIECE(^LRO(69,0),U,1,2)_"^"_LRODT_"^"_(1+$PIECE(^(0),U,4))
SET ^LRO(69,LRODT,0)=LRODT
SET ^LRO(69,"B",LRODT,LRODT)=""
End DoDot:1
+4 SET COMBINE=""
+5 IF 'UNEEK
Begin DoDot:1
+6 SET COMBINE=$$ORES^LR7OF5(LRDFN,LRSDT,LRXZ,+LRSAMP,LRPRAC,LROLLOC,LRSPEC,LRDUZ)
+7 IF '$LENGTH(COMBINE)
SET COMBINE=$$FIND^LR7OF5(LRDFN,LRODT,LRSDT,LRXZ,+LRSAMP,LRPRAC,LROLLOC,LRSPEC,LRDUZ)
End DoDot:1
+8 IF '$LENGTH(COMBINE)
SET (NEWORD,ZTQUEUED)=1
LOCK +^LRO(69,$EXTRACT(DT,1,3)_"0000",2):1
DO ORDER^LROW2
KILL ZTSK,ZTQUEUED,ZTREQ
GOTO LOCK
+9 ;Combine on specimen
IF $EXTRACT(COMBINE,1,2)="S."
SET LRSN=$PIECE(COMBINE,".",2)
SET LRORD=$PIECE(COMBINE,".",3)
GOTO ADD
+10 ;Combine on order #
IF $EXTRACT(COMBINE,1,2)="O."!($EXTRACT(COMBINE,1,2)="C.")
SET LRORD=$SELECT($EXTRACT(COMBINE,1,2)="O.":$PIECE(COMBINE,".",2),1:$PIECE(COMBINE,".",3))
LOCK ;
+1 LOCK +^LRO(69,LRODT,1):360
+2 IF '$TEST
GOTO LOCK
+3 SET LRSN=1+$ORDER(^LRO(69,LRODT,1,999999999),-1)
SET LRSUM=1+$SELECT($DATA(^LRO(69,LRODT,1,0)):$PIECE(^(0),U,4),1:0)
ZSN ;
+1 IF $DATA(^LRO(69,LRODT,1,LRSN,0))
SET LRSN=LRSN+1
GOTO ZSN
+2 SET ^LRO(69,LRODT,1,LRSN,0)=LRDFN_"^"_LRDUZ_"^"_+LRSAMP_"^"_LRORDR_"^"_LRNT_"^"_LRPRAC_"^"_LRLLOC_"^"_LRSDT_"^"_LROLLOC_"^^"_ORIFN
SET ^LRO(69,LRODT,1,0)="^69.01PA^"_LRSN_"^"_LRSUM
+3 LOCK -^LRO(69,LRODT,1)
+4 SET ^LRO(69,LRODT,1,"AA",LRDFN,LRSN)=""
SET ^TMP("OR",$JOB,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,"SN")=LRSN
SET ^LRO(69,"D",LRDFN,LRODT,LRSN)=""
+5 IF $LENGTH(LRLLOC)
SET ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
+6 IF $LENGTH(LRSPEC)
SET ^LRO(69,LRODT,1,LRSN,4,0)="^69.02PA^1^1"
SET ^(1,0)=LRSPEC
+7 SET ^LRO(69,LRODT,1,LRSN,.1)=LRORD
SET ^LRO(69,"C",+LRORD,LRODT,LRSN)=""
+8 IF $GET(NEWORD)
LOCK -^LRO(69,$EXTRACT(DT,1,3)_"0000",2)
ADD ;
+1 NEW I,J,LRJ,LRSXN,LRORIFN,NODE,STATUS
+2 SET ^TMP("OR",$JOB,"LRES","CTR")=^TMP("OR",$JOB,"LRES","CTR")+1
SET ^TMP("OR",$JOB,"LRES",LRDFN,LRSDT,LRXZ,^TMP("OR",$JOB,"LRES","CTR"))=LRORD_"^"_LRODT_"^"_LRSN
+3 ; S LRORIFN=+$G(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,0))
+4 ; ----- IHS/OIT/MKK - BEGIN Lab Patch 1022 Modification
+5 ;IHS/CIA/DKM - Added INDIC
SET LRORIFN=+$GET(^TMP("OR",$JOB,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,0))
SET INDIC=$GET(^(-1))
+6 ; ----- IHS/OIT/MKK - End Lab Patch 1022 Modification
+7 SET J=0
+8 ; F LRJ=1:1 S J=$O(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,J)) Q:J<1 S NODE=^(J),STATUS=$G(^(J,1)) D ZSN1(NODE,STATUS)
+9 ; ----- IHS/OIT/MKK - BEGIN Lab Patch 1022 Modification
+10 FOR LRJ=1:1
SET J=$ORDER(^TMP("OR",$JOB,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,J))
IF J<1
QUIT
SET NODE=^(J)
SET STATUS=$GET(^(J,1))
DO ZSN1(NODE,STATUS,INDIC)
+11 ; ----- IHS/OIT/MKK - End Lab Patch 1022 Modification
+12 SET (LRSXN,I)=0
+13 FOR
SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,I))
IF I<1
QUIT
SET LRSXN=LRSXN+1
+14 IF LRSXN
SET ^LRO(69,LRODT,1,LRSN,2,0)="^69.03PA^"_LRSXN_"^"_LRSXN
+15 IF $EXTRACT(COMBINE,1,2)="C."
Begin DoDot:1
+16 SET (LRSXN,I)=0
FOR
SET I=$ORDER(^LRO(69,LRODT,1,+$PIECE(COMBINE,".",2),2,I))
IF I<1
QUIT
SET LRSXN=LRSXN+1
+17 IF LRSXN
SET ^LRO(69,LRODT,1,+$PIECE(COMBINE,".",2),2,0)="^69.03PA^"_LRSXN_"^"_LRSXN
End DoDot:1
+18 QUIT
+19 ; ZSN1(NODE,STATUS) ;Add tests
+20 ; ----- IHS/OIT/MKK - BEGIN Lab Patch 1022 Modification
ZSN1(NODE,STATUS,INDIC) ; EP Add tests ;IHS/CIA/DKM - Added INDIC
+1 ; ----- IHS/OIT/MKK - END Lab Patch 1022 Modification
+2 NEW CNT,XI,X,I,C,TCNT
+3 SET CNT=+$ORDER(^LRO(69,LRODT,1,LRSN,2,99999),-1)
+4 SET LRTSTS=+NODE
SET LRQUANT=$PIECE(NODE,"^",2)
+5 IF $DATA(^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS))
SET REJECT(LRTSTS)=""
QUIT
+6 SET ^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,0)=LRTSTS_"^"_$SELECT($LENGTH(STATUS):STATUS,1:LROUTINE)_"^^^^^"_LRORIFN
+7 ; ----- IHS/OIT/MKK - BEGIN Lab Patch 1022 Modification
+8 ; S:$L($G(INDIC)) ^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,9999999)=INDIC ; IHS/CIA/DKM - Set clnical indication, if present
+9 ; ----- IHS/OIT/MKK - End Lab Patch 1022 Modification
+10 ;
+11 ; IHS/MSC/MKK - LR*5.2*1033
IF $LENGTH($GET(INDIC))
DO IHSCLINI
+12 ;
+13 DO SDGX69^LRBEBA2(J,(CNT+LRJ)_","_LRSN_","_LRODT_",")
+14 IF $ORDER(^TMP("OR",$JOB,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J,0))
Begin DoDot:1
+15 SET X=^TMP("OR",$JOB,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J)+$SELECT($PIECE($GET(^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,0)),"^",4):$PIECE(^(0),"^",4),1:0)
SET ^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,0)="^^"_X_"^"_X_"^"_DT
+16 SET TCNT=+$ORDER(^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,99999),-1)
SET (C,I)=0
+17 FOR
SET I=$ORDER(^TMP("OR",$JOB,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J,I))
IF I<1
QUIT
SET C=C+1
SET ^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,1,C+TCNT,0)=^TMP("OR",$JOB,"COM",LRSDT,LRXZ,LRSAMP,LRSPEC,J,I)
End DoDot:1
+18 SET ^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS,CNT+LRJ)=""
+19 SET ^LRO(69,"AT",LRDFN,LRTSTS,LRSPEC,LRODT)=""
SET ^(-LRODT)=""
+20 IF $EXTRACT(COMBINE,1,2)="C."
SET X=^LRO(69,LRODT,1,LRSN,2,CNT+LRJ,0)
SET $PIECE(^(0),"^",6)=LRORD
SET XI=$PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),"^",7)
SET XI=XI_LRORD_"/"
SET $PIECE(^(1),"^",7)=XI
Begin DoDot:1
+21 NEW CNT1
+22 SET CNT1=$ORDER(^LRO(69,LRODT,1,+$PIECE(COMBINE,".",2),2,99999),-1)+1
SET ^(CNT1,0)=X
SET $PIECE(^(0),"^",14)=LRODT_";"_LRSN_";"_(CNT+LRJ)
SET ^LRO(69,LRODT,1,$PIECE(COMBINE,".",2),2,"B",LRTSTS,CNT1)=""
End DoDot:1
+23 ;
+24 ; IHS/MSC/MKK - LR*5.2*1039
DO IHSURGNT^BLRUTIL8
+25 QUIT
+26 ;
DT ;
+1 SET DT=$$DT^XLFDT()
+2 SET LRNT=$PIECE($HOROLOG,",",2)
SET LRNT=LRNT\3600*100+(LRNT\60#60)/10000+DT
+3 QUIT
+4 ;
+5 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
IHSCLINI ; EP - Clinical Indication
+1 NEW SCHEMA,FDA,IENS
+2 ; IHS/MSC/MKK - LR*5.2*1036
NEW ERRS
+3 ;
+4 ; Skip if No Data
IF $TRANSLATE($PIECE(INDIC,"^",1,2),"^")=""
QUIT
+5 ;
+6 SET IENS=(CNT+LRJ)_","_LRSN_","_LRODT_","
+7 SET SCHEMA=$EXTRACT($PIECE(INDIC,"^",3))
+8 ; ICD Coding Schema
IF SCHEMA="I"!(SCHEMA="")
DO IHSICDI
+9 ; SNOMED Coding Schemas
IF SCHEMA="S"
DO IHSSNOI
+10 ;
+11 IF $DATA(FDA)
DO UPDATE^DIE("EKS","FDA",,"ERRS")
+12 ;
+13 ; D:$D(ERRS) ERRMSG^BLRSGNSP("IHSCLINI: UPDATE^DIE","LR7OF1") ; IHS/MSC/MKK - LR*5.2*1034 Send Error Message to LMI Mail Group
+14 ; IHS/MSC/MKK - LR*5.2*1036 Send Error Message to LMI Mail Group
IF $DATA(ERRS)
DO ERRMSG^BLRSGNS3("IHSCLINI: UPDATE^DIE","LR7OF1")
+15 ;
+16 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+17 DO REFLICDS
+18 ;
+19 DO ADBLRRLO^BLRUTIL6(LRODT,LRSN,(CNT+LRJ))
+20 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+21 QUIT
+22 ;
IHSICDI ; ICD Clinical Indication
+1 ; S ICDCODE=$P(INDIC,"^")
+2 ; IHS/MSC/MKK - LR*5.2*1036 - Just the 1st code
SET ICDCODE=$PIECE($PIECE(INDIC,"^"),";")
+3 SET ICDDESC=$PIECE(INDIC,"^",2)
+4 ; I $L(ICDCODE)&($L(ICDDESC)<1!(ICDDESC["*")) S ICDDESC=$P($$ICDDX^ICDCODE(ICDCODE),"^",4)
+5 ; IHS/MSC/MKK - LR*5.2*1034
IF $LENGTH(ICDCODE)&($LENGTH(ICDDESC)<1!(ICDDESC["*"))
SET ICDDESC=$PIECE($$ICDDX^ICDEX(ICDCODE),"^",4)
+6 IF $LENGTH(ICDDESC)
SET FDA(69.03,IENS,9999999.1)=ICDDESC
+7 IF $LENGTH(ICDCODE)
SET FDA(69.05,"?+1,"_IENS,.01)=ICDCODE
+8 ;
+9 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1037
+10 DO FSNOMED
+11 QUIT
+12 ; ----- END IHS/MSC/MKK - LR*5.2*1037
+13 ;
+14 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034 - Get the SNOMED code, if possible
+15 IF $LENGTH(ICDCODE)<1
QUIT
+16 ;
+17 NEW CONCID,BSTSFLAG,IN,OUT,SNOMED,STR
+18 SET OUT="VARS"
SET IN=ICDCODE
+19 IF +$$ICD2SMD^BSTSAPI(OUT,IN)
Begin DoDot:1
+20 ; Pick 1st Concept ID
SET CONCID=$GET(VARS(1,"CON"))
+21 SET STR=$$CONC^BSTSAPI(CONCID)
+22 SET SNOMED=$PIECE(STR,"^",3)
+23 IF $LENGTH(SNOMED)<1
SET SNOMED=$PIECE(STR,"^",1)
End DoDot:1
+24 IF '$TEST
SET SNOMED=$$ICD2SMD(ICDCODE,ICDDESC)
+25 ;
+26 IF $LENGTH(SNOMED)
SET FDA(69.03,IENS,9999999.2)=SNOMED
+27 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+28 QUIT
+29 ;
IHSSNOI ; SNOMED Clinical Indication
+1 SET SNOMED=$PIECE(INDIC,"^")
+2 SET SNOMDESC=$PIECE(INDIC,"^",2)
+3 IF $LENGTH(SNOMEDESC)
SET FDA(69.03,IENS,9999999.1)=SNOMDESC
+4 SET FDA(69.03,IENS,9999999.2)=SNOMED
+5 ;
+6 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034 - Get the ICD code, if possible
+7 NEW ICD10,ICD10DT,ICD10CS,ICD9,ICDCODE,STR
+8 SET STR=$$DESC^BSTSAPI(SNOMED)
+9 ; Get SNOMED Description
IF $LENGTH(STR)&($LENGTH(SNOMEDESC)<1)
Begin DoDot:1
+10 SET SNOMEDESC=$$TRIM^XLFSTR($PIECE($PIECE(STR,"^",2),"("),"LR"," ")
+11 IF $LENGTH(SNOMEDESC)
SET FDA(69.03,IENS,9999999.1)=SNOMDESC
End DoDot:1
+12 ;
+13 ; Get Coding System IEN
SET ICD10CS=+$$FIND1^DIC(80.4,,,"ICD-10-CM")
+14 SET ICD10DT=$$GET1^DIQ(80.4,ICD10CS,"IMPLEMENTATION DATE","I")
+15 ; If no Date returned from 80.4, hard set to 10/1/2015.
IF ICD10DT<1
SET ICD10DT=3151001
+16 ;
+17 ; Note that $$DESC^BSTAPI will only return 3 pieces of data if the SNOMED variable
+18 ; is a SNOMED CONCEPT ID. If it is a "real" SNOMED code, it will return 4 pieces
+19 ; of information.
+20 ; Just the 1st code
SET ICD10=$PIECE($PIECE(STR,"^",3),";")
+21 ; Just the 1st Code
SET ICD9=$PIECE($PIECE(STR,"^",4),";")
+22 IF ICD9=""
SET ICD9=ICD10
+23 SET ICDCODE=$SELECT($$DT^XLFDT'<ICD10DT:ICD10,1:ICD9)
+24 IF $LENGTH(ICDCODE)
SET FDA(69.05,"?+1,"_IENS,.01)=ICDCODE
+25 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+26 QUIT
+27 ;
+28 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
REFLICDS ; EP - Store the ICD code(s) into the BLR REFERENCE LAB ORDER/ACCESSION (#9009026.3) file
+1 NEW DFN,F60IEN,ICD,ICDCODE,ICDEXIST,IENS,IENSICD,ORDERIEN,ORDERN
+2 ; IHS/MSC/MKK - LR*5.2*1036
NEW FDA,ERRS
+3 ;
+4 ; If no ICD codes, skip
IF $DATA(FDA(69.05))<1
QUIT
+5 ;
+6 SET IENS=LRSN_","_LRODT
+7 SET ORDERN=$$GET1^DIQ(69.01,IENS,9.5)
+8 ; If no order #, skip
IF ORDERN<1
QUIT
+9 ;
+10 SET F60IEN=$$GET1^DIQ(69.03,(CNT+LRJ)_","_IENS,.01,"I")
+11 ; If Not Ref Lab Test, skip
IF $$REFLABCK^BLRUTIL6(F60IEN,LRODT,LRSN)<1
QUIT
+12 ;
+13 SET IENS=(CNT+LRJ)_","_LRSN_","_LRODT
+14 SET F60IEN=$$GET1^DIQ(69.03,IENS,.01,"I")
+15 ;
+16 ; If Test not MAPPED, do NOT put into 9009026.3
IF $$REFLAB^BLRUTIL6(DUZ(2),+F60IEN)<1
QUIT
+17 ;
+18 SET DFN=$$GET1^DIQ(63,LRDFN,.03,"I")
+19 ; Store Order # if not in there already
SET X=$$ORD^BLRRLEDI(ORDERN,DFN)
+20 SET ORDIEN=$$FIND1^DIC(9009026.3,,,ORDERN)
+21 ;
+22 ; If order not in 9009026.3, skip
IF ORDIEN<1
QUIT
+23 ;
+24 SET ICDEXIST=$ORDER(^LRO(69,LRODT,1,LRSN,2,(CNT+LRJ),2,0))
+25 ;
+26 IF F60IEN<1
QUIT
+27 ;
+28 SET ICD=.9999999
+29 FOR
SET ICD=$ORDER(^LRO(69,LRODT,1,LRSN,2,(CNT+LRJ),2,ICD))
IF ICD<1
QUIT
Begin DoDot:1
+30 SET IENSICD=ICD_","_IENS
+31 SET ICDCODE=$$GET1^DIQ(69.05,IENSICD,.01,"I")
+32 ;
+33 ; Skip if UNCODED DIAGNOSIS
+34 IF $$GET1^DIQ(80,ICDCODE,.01)=".9999"!($$GET1^DIQ(80,ICDCODE,.01)="ZZZ.999")
QUIT
+35 ;
+36 KILL FDA,ERRS
+37 SET FDA(9009026.31,"?+1,"_ORDIEN_",",.01)=ICDCODE
+38 DO UPDATE^DIE(,"FDA",,"ERRS")
+39 ; D:$D(ERRS) ERRMSG^BLRSGNSP("REFLICDS: UPDATE^DIE","LR7OF1")
+40 ; IHS/MSC/MKK - LR*5.2*1036
IF $DATA(ERRS)
DO ERRMSG^BLRSGNS3("REFLICDS: UPDATE^DIE","LR7OF1")
End DoDot:1
+41 ;
+42 QUIT
+43 ;
TESTIT ; EP - Test the REFLICDS logic
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 READ !,"ORDER #:",ORDERN,!
+4 IF +ORDERN<1
QUIT
+5 ;
+6 SET LRODT=0
+7 FOR
SET LRODT=$ORDER(^LRO(69,"C",ORDERN,LRODT))
IF LRODT<1
QUIT
Begin DoDot:1
+8 SET LRSN=0
+9 FOR
SET LRSN=$ORDER(^LRO(69,"C",ORDERN,LRODT,LRSN))
IF LRSN<1
QUIT
Begin DoDot:2
+10 SET LRDFN=$$GET1^DIQ(69.01,LRSN_","_LRODT,.01,"I")
+11 ;
+12 SET LROT=.9999999
+13 FOR
SET LROT=$ORDER(^LRO(69,LRODT,1,LRSN,2,LROT))
IF LROT<1
QUIT
Begin DoDot:3
+14 SET LRJ=LROT
SET CNT=0
+15 DO REFLICDS
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
ICD2SMD(ICD,PROVNARR) ; EP - Use Provider Narrative and ICD-10 Code to get SNOMED match
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,ICD,PROVNARR,U,XPARSYS,XQXFLG)
+2 ;
+3 SET SNOMED=""
+4 ;
+5 SET OUT="VARS"
SET IN=PROVNARR_"^F"
+6 SET X=$$SEARCH^BSTSAPI(OUT,IN)
+7 IF X<1
QUIT SNOMED
+8 ;
+9 ; "Trick" because Terminology Server may return ICD code without final period
+10 SET ICD2CHK=$SELECT($PIECE(ICD,".",2)="":$PIECE(ICD,"."),1:ICD)
+11 ;
+12 SET (CNT,FOUND)=0
+13 FOR
SET CNT=$ORDER(VARS(CNT))
IF CNT<1!(FOUND)
QUIT
Begin DoDot:1
+14 ; Terminology Server ICD-10
SET TSICD=$GET(VARS(CNT,"ICD",1,"COD"))
+15 IF ICD'=TSICD&(ICD2CHK'=TSICD)
QUIT
+16 IF $GET(VARS(CNT,"PRB","TRM"))'=PROVNARR
QUIT
+17 ;
+18 ; Pick Concept ID
SET CONCID=$GET(VARS(CNT,"CON"))
+19 SET STR=$$CONC^BSTSAPI(CONCID)
+20 SET CSNOMED=$PIECE(STR,"^",3)
+21 IF $LENGTH(CSNOMED)<1
SET CSNOMED=$PIECE(STR,"^",1)
+22 IF $LENGTH(CSNOMED)<1
QUIT
+23 ;
+24 KILL FOUND("SNOMED")
+25 SET FOUND("SNOMED")=CSNOMED
+26 SET FOUND=FOUND+1
End DoDot:1
+27 ;
+28 QUIT $SELECT(FOUND:$GET(FOUND("SNOMED")),1:$GET(SNOMED))
+29 ;
+30 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+31 ;
+32 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1037
FSNOMED ; EP - Try to find a SNOMED Code using an OE/RR API & BSTSAPI call
+1 NEW CLININD,FOUNDIT,SNOCONID,VARS
+2 ;
+3 ; Skip if file 100 IEN < 1
IF +$GET(ORIFN)<1
QUIT
+4 ;
+5 ; OE/RR API - CLINICAL INDICATION. Note that it can contain a | that sometimes
+6 ; separates two clinical indications. Only use the first clinical indication.
+7 ; Trim any leading and/or trailing blanks.
+8 SET CLININD=$$TRIM^XLFSTR($PIECE($$VALUE^ORCSAVE2(ORIFN,"CLININD"),"|"),"LR"," ")
+9 ;
+10 ; OE/RR API - SNOmed CONcept ID
SET SNOCONID=$$VALUE^ORCSAVE2(ORIFN,"SNMDCNPTID")
+11 ; Skip if either variable is null.
IF $LENGTH(CLININD)<1!($LENGTH(SNOCONID)<1)
QUIT
+12 ;
+13 DO CNCLKP^BSTSAPI("VARS",SNOCONID)
+14 ;
+15 ; If PREFERRED TERM, then set and return
+16 IF $GET(VARS(1,"PRE","TRM"))=CLININD
SET FDA(69.03,IENS,9999999.2)=$GET(VARS(1,"PRE","DSC"))
QUIT
+17 ;
+18 ; If PRB, then set and return
+19 IF $GET(VARS(1,"PRB","TRM"))=CLININD
SET FDA(69.03,IENS,9999999.2)=$GET(VARS(1,"PRB","DSC"))
QUIT
+20 ;
+21 ; Have to search the synonyms
+22 SET SYN=0
SET FOUNDIT=""
+23 FOR
SET SYN=$ORDER(VARS(1,"SUB",SYN))
IF SYN<1!($LENGTH(FOUNDIT))
QUIT
Begin DoDot:1
+24 IF $GET(VARS(1,"SUB",SYN,"TRM"))=CLININD
SET FOUNDIT=$GET(VARS(1,"SUB",SYN,"DSC"))
End DoDot:1
+25 ;
+26 IF $LENGTH(FOUNDIT)
SET FDA(69.03,IENS,9999999.2)=FOUNDIT
+27 QUIT
+28 ; ----- END IHS/MSC/MKK - LR*5.2*1037
