BLRLINK4 ; IHS/MSC/MKK - CONT. OF BLR - IHS LABORATORY VISIT CREATION ; 02-Nov-2015 13:44 ; MKK
;;5.2;IHS LABORATORY;**1031,1032,1033,1034,1037**;NOV 01, 1997;Build 4
;;
;; Parts of original BLRLINK3 moved to here due to BLRLINK3 becoming too large.
;;
; IF and ONLY IF the transaction is tied to an incoming HL7 message
; get Reference Ranges & Units from HL7 message
HL7REFLR(REFLABF) ; EP
NEW ABNFLAG,REFHIGH,REFLOW,UNITS,WOT
S WOT=$$CHKINHL7(BLRLOGDA,.REFLABF)
Q:WOT<1
;
S:$G(UNITS)'="" APCDALVR("APCDTUNI")=UNITS
S:$G(REFLOW)'="" APCDALVR("APCDTRFL")=REFLOW
S:$G(REFHIGH)'="" APCDALVR("APCDTRFH")=REFHIGH
D ENTRYAUD^BLRUTIL("HL7REFLR^BLRLINK4 9.0","APCDALVR")
Q
;
CHKINHL7(BLRLOGDA,REFLABF) ; EP
NEW DNIEN,DNDESC,F60IEN,HL7TEST,LRAA,LRAD,LRAN,LRAS,STR,UID
;
Q:+$G(BLRLOGDA)<1 0 ; Skip if no Txn #
;
S F60IEN=+$P($G(^BLRTXLOG(BLRLOGDA,0)),"^",6) ; File 60 IEN
;
S LRAS=$P($G(^BLRTXLOG(BLRLOGDA,12)),"^",2) ; Accession Number
D GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
Q:LRAA<1!(LRAD<1)!(LRAN<1) 0 ; Skip if no Accession
;
D REFLAB68^BLRLINKU ; Check on ^XTMP("BLRLINKU")
Q:$D(^XTMP("BLRLINKU",+$G(DUZ(2)),LRAA))<1 0 ; Skip if not a Ref Lab Accession
;
S REFLABF=1 ; Set the Ref Lab Flag
;
S UID=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
Q:UID<1 0 ; Skip if no UID
;
Q:$$GETINTHU^BLRLINKU(UID)<1 0 ; Reference Ranges in File 4001 (UNIVERSAL INTERFACE)
;
S STR=$G(^TMP("BLR",$J,UID,F60IEN))
Q:$L(STR)<1 0 ; Skip if no data found
;
S ABNFLAG=$P(STR,"^",2)
S REFLOW=$P(STR,"^",3)
S REFHIGH=$P(STR,"^",4)
S UNITS=$P(STR,"^",5)
;
S:$L(ABNFLAG) APCDALVR("APCDTABN")=$G(ABNFLAG)
S:$L(UNITS) APCDALVR("APCDTUNI")=$G(UNITS)
S:$L(REFLOW) APCDALVR("APCDTRFL")=$G(REFLOW)
S:$L(REFHIGH) APCDALVR("APCDTRFH")=$G(REFHIGH)
;
D ENTRYAUD^BLRUTIL("CHKINHL7^BLRLINK4 9.0","APCDALVR")
Q 1
;
;
CHSETCOD ; EP - Check to see if SET OF CODES & "Change" Result, if Necessary
NEW CHANGED,DATANAME,F60PTR,LRPIECE,LRSET,Q2
;
S F60PTR=+$TR($G(APCDALVR("APCDTLAB")),"`")
S DATANAME=$G(^LAB(60,F60PTR,.2))
Q:DATANAME<1 ; Skip if no Dataname
;
Q:$P($G(^DD(63.04,DATANAME,0)),"^",2)'="S" ; Skip if NOT Set of Codes
;
S Q2=$P(^DD(63.04,DATANAME,0),U,3)
S CHANGED=0
F LRPIECE=1:1 S LRSET=$P(Q2,";",LRPIECE) Q:LRSET'[":"!(CHANGED) D
. Q:$P(LRSET,":")'=BLRRES ; Quit if NOT code
. ;
. S BLRRES=$P(LRSET,":",2)
. S CHANGED=1
;
Q
;
; Double check Ref Ranges & Units. If null, reset -- if possible.
; Need to do this because POC tests' Ref Ranges & Units variables are cleared out somewhere.
; Also, reset Lab POV if necessary.
CHKPCCRU ; EP
NEW PCCLOW,PCCHIGH,PCCUNITS
NEW ABNFLAG,CPTCODE,CRITLOW,CRITHIGH,LABPOV,REFLOW,REFHIGH,STR,UNITS
NEW LABTIEN,IHSLCPTP,IHSLCPT
NEW LRAA,LRAD,LRAN,LRASUB
;
S X=$$GETACCCP^BLRUTIL3(BLRACC,.LRAA,.LRAD,.LRAN) ; Get Accession variables
Q:X<1 ; Skip if cannot "break out" Accession variables
;
S LRASUB=$P($G(^LRO(68,LRAA,0)),"^",2) ; Get Accession's Lab Data Subscript
Q:LRASUB'="CH" ; Only "CH" subscripted tests will have Ref Ranges
;
S PCCLOW=$G(APCDALVR("APCDTRFL"))
S PCCHIGH=$G(APCDALVR("APCDTRFH"))
S PCCUNITS=$G(APCDALVR("APCDTUNI"))
;
; If Ref Low, Ref High Ranges & Units already filled out, just return
Q:$L(PCCLOW)&($L(PCCHIGH))&($L(PCCUNITS))
;
; If the test is part of a panel being processed, the BLRTLAB variable
; has the ATOMIC test's IEN. If the test is not part of a panel, the
; BLRTLAB variable doesn't exist.
S LABTIEN=$S(+$G(BLRTLAB):BLRTLAB,1:BLRTEST)
;
S STR=$G(^LAB(60,+$G(LABTIEN),1,+$G(BLRSITE),0)) ; Ref Ranges & Units from File 60
;
D ENTRYAUD^BLRUTIL("CHKPCCRU^BLRLINK4 4.0","APCDALVR")
;
Q:$L($TR(STR,"^"))<1 ; If no Ref Ranges nor units, skip
;
S REFLOW=$P(STR,"^",2)
S REFHIGH=$P(STR,"^",3)
S CRITLOW=$P(STR,"^",4)
S CRITHIGH=$P(STR,"^",5)
S UNITS=$P(STR,"^",7)
;
; Reset PCC array if and only if PCC Ref Ranges or Units "empty". Reset ^BLRTXLOG entries, if possible
I '$L(PCCLOW)&($L(REFLOW)) S APCDALVR("APCDTRFL")=REFLOW S:+$G(BLRIEN) $P(^BLRTXLOG(BLRIEN,20),"^",8)=REFLOW
I '$L(PCCHIGH)&($L(REFHIGH)) S APCDALVR("APCDTRFH")=REFHIGH S:+$G(BLRIEN) $P(^BLRTXLOG(BLRIEN,20),"^",9)=REFHIGH
I '$L(PCCUNITS)&($L(UNITS)) S APCDALVR("APCDTUNI")=UNITS S:+$G(BLRIEN) $P(^BLRTXLOG(BLRIEN,20),"^",3)=UNITS
;
; If LAB Point Of View has ` and IS NOT an ICD code, just make it a string.
S LABPOV=$G(APCDALVR("APCDTLPV"))
I LABPOV["`" D
. S LABPOV=$P(LABPOV,"`",2)
. ; I $$ICDDX^ICDCODE(LABPOV)<1 S APCDALVR("APCDTLPV")=LABPOV
. I $$ICDDX^ICDEX(LABPOV)<1 S APCDALVR("APCDTLPV")=LABPOV ; IHS/MSC/MKK - LR*5.2*1034
;
; The following have to be rechecked due to POC tests
;
; NO CPT code in APCDALVR array
D:$L($G(APCDALVR("APCDTCPT")))<1 APCDPCCR
;
D ENTRYAUD^BLRUTIL("CHKPCCRU^BLRLINK4 9.0","APCDALVR")
Q
;
APCDPCCR ; EP - Reset CPT nodes, if Possible.
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
; Do not try to reset the CPT codes because it will "unbundle"
; all the Atomic tests that should be under one CPT code
; for a Cosmic test. This subroutine was a mistake.
Q
; ----- END IHS/MSC/MKK - LR*5.2*1033
;
;
I $L($G(BLRCPT)),$L($G(BLRCPTST)) D Q ; Reset from BLR variables, if possible
. S APCDALVR("APCDTCPS")=BLRCPTST
. S APCDALVR("APCDTCPT")="`"_BLRCPT
;
I $L($G(BLRCPT)) S APCDALVR("APCDTCPT")="`"_BLRCPT Q ; If only BLRCPT, reset
;
; At this point, use Lab Test IEN, if possible
NEW BLRCPT,BLRCPTST,CNT,IHSCPTLP,STR1,STR2
;
S IHSCPTLP=+$O(^BLRCPT("C",+$G(LABTIEN),0))
I IHSCPTLP D
. S STR1=$G(^BLRCPT(IHSCPTLP,11,+$O(^BLRCPT(IHSCPTLP,11,0)),0))
. S STR2=$P(STR1,"^",2)
. S BLRCPTST=""
. S BLRCPT="`"_IHSCPTLP
. I $L(STR2) D
.. F CNT=1:1:5 S BLRCPTST=BLRCPTST_$P(STR2,"^",CNT)_"|"
. I $L(STR2)<1 S BLRCPTST=+STR1_"|||||"
. ;
. S APCDALVR("APCDTCPS")=BLRCPTST
. S APCDALVR("APCDTCPT")=BLRCPT
;
Q:$L($G(APCDALVR("APCDTCPT")))
;
; Still empty, so KILL off the nodes
K APCDALVR("APCDTCPS")
K APCDALVR("APCDTCPT")
Q
;
CHKREFA ; EP - Make sure Reference Ranges are not formulas
NEW OKAYFLAG,PCCLOW,PCCHIGH,SHOULDBE,TESTIT,X
;
S PCCLOW=$G(APCDALVR("APCDTRFL"))
S PCCHIGH=$G(APCDALVR("APCDTRFH"))
;
Q:$G(PCCLOW)'["$S"&($G(PCCHIGH)'["$S")
;
D ENTRYAUD^BLRUTIL("CHKREFA^BLRLINK4 0.0")
;
S OKAYFLAG=0
;
I $G(PCCLOW)["$S" D
. S X=PCCLOW
. D ^DIM ; Make sure M code in Reference Value is valid
. Q:$D(X)
. ;
. S SHOULDBE="SHOULDBE="_PCCLOW
. S @SHOULDBE
. Q:$L(SHOULDBE)<1
. ;
. S APCDALVR("APCDTRFL")=SHOULDBE
. S:+$G(BLRIEN) $P(^BLRTXLOG(BLRIEN,20),"^",8)=SHOULDBE
;
I $G(PCCHIGH)["$S" D
. S X=PCCHIGH
. D ^DIM
. Q:$D(X)
. ;
. S SHOULDBE="SHOULDBE="_PCCHIGH
. S @SHOULDBE
. Q:$L(SHOULDBE)<1
. ;
. S APCDALVR("APCDTRFH")=SHOULDBE
. S:+$G(BLRIEN) $P(^BLRTXLOG(BLRIEN,20),"^",9)=SHOULDBE
;
D ENTRYAUD^BLRUTIL("CHKREFA^BLRLINK4 8.8")
;
Q
;
LOTZERO(ARRAY) ; EP - Leading and/Or Trailing ZERO(s) for PCC
NEW (ARRAY,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D ENTRYAUD^BLRUTIL("LOTZERO^BLRLINK4 0.0","ARRAY")
;
S L60IEN=$P($G(ARRAY("APCDTLAB")),"`",2)
Q:+L60IEN<1 ; IHS/MSC/MKK - LR*5.2*1037
;
S DN=+$G(^LAB(60,L60IEN,.2))
Q:+$G(DN)<1 ; Skip if no Data Name number
;
S STR=$P($G(^DD(63.04,DN,0)),"^",5)
Q:$L(STR)<1 ; Skip if no numeric defintiion
;
; S DP=+$P($P(STR,",",3),$C(34))
S DP=+$P($P(STR,"Q9=",2),",",3) ; IHS/MSC/MKK - LR*5.2*1032 -- Need to take into account INPUT TRANSFORM code
Q:DP<1 ; Skip if no Decimal Defintion
;
S RESULT=$G(ARRAY("APCDTRES"))
;
S SYMBOL="",ORIGRSLT=RESULT
F Q:$E(RESULT)="."!($E(RESULT)?1N)!(RESULT="") D ; Adjust if ANY Non-Numeric is at the beginning of RESULT
. S SYMBOL=SYMBOL_$E(RESULT)
. S RESULT=$E(RESULT,2,$L(RESULT))
;
S:$E(RESULT)="." RESULT="0"_RESULT ; Leading Zero Fix
;
I $E(RESULT)'?1N S RESULT=ORIGRSLT Q ; Skip if RESULT has no numeric part
;
S RESULT=$TR($FN(RESULT,"P",DP)," ")
;
S:$L($G(SYMBOL)) RESULT=SYMBOL_RESULT ; Restore "symbol", if necessary
;
S ARRAY("APCDTRES")=RESULT
;
S PCCLOW=$G(ARRAY("APCDTRFL"))
S PCCHIGH=$G(ARRAY("APCDTRFH"))
;
I $L($G(PCCLOW)) D
. S:$E(PCCLOW,1)="." PCCLOW="0"_PCCLOW
. S PCCLOW=$TR($FN(PCCLOW,"P",DP)," ")
. S ARRAY("APCDTRFL")=PCCLOW
;
I $L($G(PCCHIGH)) D
. S:$E(PCCHIGH,1)="." PCCHIGH="0"_PCCHIGH
. S PCCHIGH=$TR($FN(PCCHIGH,"P",DP)," ")
. S ARRAY("APCDTRFH")=PCCHIGH
;
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
RESETPOV ; EP -- Reset "Provider Narrative"
D ENTRYAUD^BLRUTIL("RESETPOV^BLRLINK4 0.0","APCDALVR")
;
; NEW FDA,ICD,ICDCODE,IENS,LRORD,LRORDT,LRSP,LRTN,LRTST,ORDNUM,POV,POVICD,PROVNAR,SNOMED,TESTIEN
NEW (APCDALVR,BLRLOGDA,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,X,XPARSYS,XQXFLG) ; IHS/MSC/MKK - LR*5.2*1034
;
D ENTRYAUD^BLRUTIL("RESETPOV^BLRLINK4 0.1","APCDALVR")
;
; S ORDNUM=+$G(APCDALVR("APCDTORD"))
; Q:ORDNUM<1 ; If no Order Number, skip
;
; S TESTIEN=+$P($G(APCDALVR("APCDTLAB")),"`",2)
; Q:TESTIEN<1 ; If no Lab Test IEN, skip
;
; S LRODT=+$O(^LRO(69,"C",ORDNUM,0))
; S LRSP=+$O(^LRO(69,"C",ORDNUM,LRODT,0))
; S LRTN=+$O(^LRO(69,LRODT,1,LRSP,2,"B",TESTIEN,0))
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
S ORDNUM=+$$GET1^DIQ(9009022,BLRLOGDA,"ORDER NUMBER")
Q:ORDNUM<1
;
S TESTIEN=+$$GET1^DIQ(9009022,BLRLOGDA,"PANEL/TEST POINTER","I")
Q:TESTIEN<1
;
; Because there can be multiple tests on an order, find entry
; in file 69 that matches the TESTIEN.
S (FOUNDIT,LRODT)=0
S LRODT=$O(^LRO(69,"C",ORDNUM,LRODT)) Q:LRODT<1!(FOUNDIT) D
. S LRSP=0
. F S LRSP=$O(^LRO(69,"C",ORDNUM,LRODT,LRSP)) Q:LRSP<1!(FOUNDIT) D
.. S LROT=0
.. F S LROT=$O(^LRO(69,LRODT,1,LRSP,2,LROT)) Q:LROT<1!(FOUNDIT) D
... S:+$G(^LRO(69,LRODT,1,LRSP,2,LROT,0))=TESTIEN FOUNDIT=FOUNDIT+1,FOUNDIT("LRSP")=LRSP,FOUNDIT("LRTN")=LROT
S LRSP=+$G(FOUNDIT("LRSP")),LRTN=+$G(FOUNDIT("LRTN"))
;
Q:LRTN<1 ; If no entry in Lab Order Entry file, skip
;
; S ICD=+$O(^LRO(69,LRODT,1,LRSP,2,LRTN,2,0))
; S ICDPTR=+$P($G(^LRO(69,LRODT,1,LRSP,2,LRTN,2,ICD,0)),"^")
; S ICDSTR=$$ICDDX^ICDCODE(ICDPTR) ; Currently, ICD Description & Code
; S ICDCODE=$P(ICDSTR,"^",2),ICDDESC=$P(ICDSTR,"^",4)
;
; S ICDCODE=$$UP^XLFSTR($P(ICDSTR,"^",2)),ICDDESC=$P(ICDSTR,"^",4)
;
; S IENS=LRTN_","_LRSP_","_LRODT
; S PROVNAR=$$GET1^DIQ(69.03,IENS,9999999.1)
; S SNOMED=$$GET1^DIQ(69.03,IENS,9999999.2)
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
S IEN=LRTN_","_LRSP_","_LRODT_","
S PROVNAR=$$GET1^DIQ(69.03,IEN,"PROVIDER NARRATIVE")
S SNOMED=$$GET1^DIQ(69.03,IEN,"SNOMED")
; S ICDCODE=$$GET1^DIQ(69.05,1_","_IEN,"ICD-9 CODES")
; S ICDPTR=+$P($G(^LRO(69,LRODT,1,LRSP,2,LRTN,2,ICD,0)),"^")
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
S ICDCODE=$$GET1^DIQ(69.05,1_","_IEN,"ICD CODES")
S ICDIEN=$$GET1^DIQ(69.05,1_","_IEN,"ICD CODES","I")
S ICDDESC=$$VLTD^ICDEX(ICDIEN)
S:$L(ICDDESC)<1 ICDDESC=$$VLTP^ICDEX(ICDIEN)
; ----- END IHS/MSC/MKK - LR*5.2*1034
;
D ENTRYAUD^BLRUTIL(" RESETPOV^BLRLINK4 5.0")
;
; Skip if no data in the Lab Order Entry file
I $L(PROVNAR)<1,$L(SNOMED)<1,$L(ICDCODE)<1 Q
;
S:$L(PROVNAR) APCDALVR("APCDTLPV")=PROVNAR
D:$L(SNOMED) FMSNOMED
; S:$L(ICDCODE)&(ICDCODE'["INVALID") APCDALVR("APCDTICD")=ICDCODE
; S:$L(ICDCODE)&(ICDCODE'["INVALID") APCDALVR("APCDTICD")="`"_ICDPTR
;
S:ICDIEN APCDALVR("APCDTICD")="`"_ICDIEN ; IHS/MSC/MKK - LR*5.2*1034 - Use ICD Code's IEN to store into PCC
;
D ENTRYAUD^BLRUTIL(" RESETPOV^BLRLINK4 5.5")
;
K:$G(APCDALVR("APCDTICD"))["INVALID" APCDALVR("APCDTICD")
;
; Reset ^BLRTXLOG, if necessary. Skip if No BLRLOGDA variable.
I +$G(BLRLOGDA) D
. NEW BLRPROVN,BLRSNOM,BLRICD,BLRPROVN,BLRSNOM,BLRICD
. S BLRPROVN=$$GET1^DIQ(9009022,BLRLOGDA_",",1601)
. S BLRSNOM=$$GET1^DIQ(9009022,BLRLOGDA_",",1602)
. S BLRICD=$$GET1^DIQ(9009022,BLRLOGDA_",",1603)
. ;
. I BLRPROVN=PROVNAR,BLRSNOM=SNOMED,BLRICD=ICDCODE Q
. ;
. K FDA,ERRS
. S:$L(PROVNAR)&(BLRPROVN'=PROVNAR) FDA(9009022,BLRLOGDA_",",1601)=PROVNAR
. S:$L(SNOMED)&(BLRSNOM'=SNOMED) FDA(9009022,BLRLOGDA_",",1602)=SNOMED
. ; S:$L(ICDCODE)&(BLRICD'=ICDCODE) FDA(9009022,BLRLOGDA_",",1603)=ICDCODE
. ;
. S:$L(ICDCODE)&(ICDCODE'["INVALID")&(BLRICD'=ICDCODE) FDA(9009022,BLRLOGDA_",",1603)=ICDCODE
. ;
. Q:$D(FDA)<1
. ;
. D UPDATE^DIE("S","FDA",,"ERRS")
;
D ENTRYAUD^BLRUTIL(" RESETPOV^BLRLINK4 9.0","APCDALVR","ERRS","VERRS")
Q
;
FMSNOMED ; EP - SNOMED codes to be done via FileMan
NEW IEN,VLABFILE,VLABIEN
;
S VLABFILE=+$$GET1^DIQ(9009022,BLRLOGDA_",",104,"I")
Q:VLABFILE<1
;
S VLABIEN=+$$GET1^DIQ(9009022,BLRLOGDA_",",105)
Q:VLABIEN<1
;
S FDA(VLABFILE_"26","?+1,"_VLABIEN_",",.01)=SNOMED
;
D UPDATE^DIE("ES","FDA",,"VERRS")
Q
;
; If SNOMED is in 9009029 & missing in the PCC file, then fix it. Done for BYPASS entries.
MSNOMED ; EP - Called from BLRLINK3
NEW ERRS,FDA,SNOMED,VFILENUM,VFILEIEN
;
; Note -- When this routine is called, the V File data are not in the ^BLRTXLOG global yet, but are in the APCDALVR array.
;
; Skip if there is a PCC error
Q:+$G(APCDALVR("APCDAFLG"))>0
;
; Get V File #
S VFILENUM=+$G(APCDALVR("APCDAVF"))
Q:VFILENUM<1
;
; Get V File IEN
S VFILEIEN=+$G(APCDALVR("APCDADFN"))
Q:VFILEIEN<1
;
; If SNOMED already in V File, skip
S SNOMED=$$GET1^DIQ(VFILENUM,VFILEIEN,1602)
Q:$L(SNOMED)
;
; Get SNOMED code
; S SNOMED=+$$GET1^DIQ(9009022,BLRLOGDA_",",1602)
S SNOMED=$$GET1^DIQ(9009022,BLRLOGDA_",",1602) ; IHS/MSC/MKK - LR*5.2*1037
Q:$L(SNOMED)<1
;
S FDA(VFILENUM_"26","?+1,"_VFILEIEN_",",.01)=SNOMED
;
D UPDATE^DIE("S","FDA",,"ERRS")
;
Q
;
; ----- END IHS/MSC/MKK - LR*5.2*1033
BLRLINK4 ; IHS/MSC/MKK - CONT. OF BLR - IHS LABORATORY VISIT CREATION ; 02-Nov-2015 13:44 ; MKK
+1 ;;5.2;IHS LABORATORY;**1031,1032,1033,1034,1037**;NOV 01, 1997;Build 4
+2 ;;
+3 ;; Parts of original BLRLINK3 moved to here due to BLRLINK3 becoming too large.
+4 ;;
+5 ; IF and ONLY IF the transaction is tied to an incoming HL7 message
+6 ; get Reference Ranges & Units from HL7 message
HL7REFLR(REFLABF) ; EP
+1 NEW ABNFLAG,REFHIGH,REFLOW,UNITS,WOT
+2 SET WOT=$$CHKINHL7(BLRLOGDA,.REFLABF)
+3 IF WOT<1
QUIT
+4 ;
+5 IF $GET(UNITS)'=""
SET APCDALVR("APCDTUNI")=UNITS
+6 IF $GET(REFLOW)'=""
SET APCDALVR("APCDTRFL")=REFLOW
+7 IF $GET(REFHIGH)'=""
SET APCDALVR("APCDTRFH")=REFHIGH
+8 DO ENTRYAUD^BLRUTIL("HL7REFLR^BLRLINK4 9.0","APCDALVR")
+9 QUIT
+10 ;
CHKINHL7(BLRLOGDA,REFLABF) ; EP
+1 NEW DNIEN,DNDESC,F60IEN,HL7TEST,LRAA,LRAD,LRAN,LRAS,STR,UID
+2 ;
+3 ; Skip if no Txn #
IF +$GET(BLRLOGDA)<1
QUIT 0
+4 ;
+5 ; File 60 IEN
SET F60IEN=+$PIECE($GET(^BLRTXLOG(BLRLOGDA,0)),"^",6)
+6 ;
+7 ; Accession Number
SET LRAS=$PIECE($GET(^BLRTXLOG(BLRLOGDA,12)),"^",2)
+8 DO GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
+9 ; Skip if no Accession
IF LRAA<1!(LRAD<1)!(LRAN<1)
QUIT 0
+10 ;
+11 ; Check on ^XTMP("BLRLINKU")
DO REFLAB68^BLRLINKU
+12 ; Skip if not a Ref Lab Accession
IF $DATA(^XTMP("BLRLINKU",+$GET(DUZ(2)),LRAA))<1
QUIT 0
+13 ;
+14 ; Set the Ref Lab Flag
SET REFLABF=1
+15 ;
+16 SET UID=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
+17 ; Skip if no UID
IF UID<1
QUIT 0
+18 ;
+19 ; Reference Ranges in File 4001 (UNIVERSAL INTERFACE)
IF $$GETINTHU^BLRLINKU(UID)<1
QUIT 0
+20 ;
+21 SET STR=$GET(^TMP("BLR",$JOB,UID,F60IEN))
+22 ; Skip if no data found
IF $LENGTH(STR)<1
QUIT 0
+23 ;
+24 SET ABNFLAG=$PIECE(STR,"^",2)
+25 SET REFLOW=$PIECE(STR,"^",3)
+26 SET REFHIGH=$PIECE(STR,"^",4)
+27 SET UNITS=$PIECE(STR,"^",5)
+28 ;
+29 IF $LENGTH(ABNFLAG)
SET APCDALVR("APCDTABN")=$GET(ABNFLAG)
+30 IF $LENGTH(UNITS)
SET APCDALVR("APCDTUNI")=$GET(UNITS)
+31 IF $LENGTH(REFLOW)
SET APCDALVR("APCDTRFL")=$GET(REFLOW)
+32 IF $LENGTH(REFHIGH)
SET APCDALVR("APCDTRFH")=$GET(REFHIGH)
+33 ;
+34 DO ENTRYAUD^BLRUTIL("CHKINHL7^BLRLINK4 9.0","APCDALVR")
+35 QUIT 1
+36 ;
+37 ;
CHSETCOD ; EP - Check to see if SET OF CODES & "Change" Result, if Necessary
+1 NEW CHANGED,DATANAME,F60PTR,LRPIECE,LRSET,Q2
+2 ;
+3 SET F60PTR=+$TRANSLATE($GET(APCDALVR("APCDTLAB")),"`")
+4 SET DATANAME=$GET(^LAB(60,F60PTR,.2))
+5 ; Skip if no Dataname
IF DATANAME<1
QUIT
+6 ;
+7 ; Skip if NOT Set of Codes
IF $PIECE($GET(^DD(63.04,DATANAME,0)),"^",2)'="S"
QUIT
+8 ;
+9 SET Q2=$PIECE(^DD(63.04,DATANAME,0),U,3)
+10 SET CHANGED=0
+11 FOR LRPIECE=1:1
SET LRSET=$PIECE(Q2,";",LRPIECE)
IF LRSET'["
QUIT
Begin DoDot:1
+12 ; Quit if NOT code
IF $PIECE(LRSET,"
QUIT
+13 ;
+14 SET BLRRES=$PIECE(LRSET,":",2)
+15 SET CHANGED=1
End DoDot:1
+16 ;
+17 QUIT
+18 ;
+19 ; Double check Ref Ranges & Units. If null, reset -- if possible.
+20 ; Need to do this because POC tests' Ref Ranges & Units variables are cleared out somewhere.
+21 ; Also, reset Lab POV if necessary.
CHKPCCRU ; EP
+1 NEW PCCLOW,PCCHIGH,PCCUNITS
+2 NEW ABNFLAG,CPTCODE,CRITLOW,CRITHIGH,LABPOV,REFLOW,REFHIGH,STR,UNITS
+3 NEW LABTIEN,IHSLCPTP,IHSLCPT
+4 NEW LRAA,LRAD,LRAN,LRASUB
+5 ;
+6 ; Get Accession variables
SET X=$$GETACCCP^BLRUTIL3(BLRACC,.LRAA,.LRAD,.LRAN)
+7 ; Skip if cannot "break out" Accession variables
IF X<1
QUIT
+8 ;
+9 ; Get Accession's Lab Data Subscript
SET LRASUB=$PIECE($GET(^LRO(68,LRAA,0)),"^",2)
+10 ; Only "CH" subscripted tests will have Ref Ranges
IF LRASUB'="CH"
QUIT
+11 ;
+12 SET PCCLOW=$GET(APCDALVR("APCDTRFL"))
+13 SET PCCHIGH=$GET(APCDALVR("APCDTRFH"))
+14 SET PCCUNITS=$GET(APCDALVR("APCDTUNI"))
+15 ;
+16 ; If Ref Low, Ref High Ranges & Units already filled out, just return
+17 IF $LENGTH(PCCLOW)&($LENGTH(PCCHIGH))&($LENGTH(PCCUNITS))
QUIT
+18 ;
+19 ; If the test is part of a panel being processed, the BLRTLAB variable
+20 ; has the ATOMIC test's IEN. If the test is not part of a panel, the
+21 ; BLRTLAB variable doesn't exist.
+22 SET LABTIEN=$SELECT(+$GET(BLRTLAB):BLRTLAB,1:BLRTEST)
+23 ;
+24 ; Ref Ranges & Units from File 60
SET STR=$GET(^LAB(60,+$GET(LABTIEN),1,+$GET(BLRSITE),0))
+25 ;
+26 DO ENTRYAUD^BLRUTIL("CHKPCCRU^BLRLINK4 4.0","APCDALVR")
+27 ;
+28 ; If no Ref Ranges nor units, skip
IF $LENGTH($TRANSLATE(STR,"^"))<1
QUIT
+29 ;
+30 SET REFLOW=$PIECE(STR,"^",2)
+31 SET REFHIGH=$PIECE(STR,"^",3)
+32 SET CRITLOW=$PIECE(STR,"^",4)
+33 SET CRITHIGH=$PIECE(STR,"^",5)
+34 SET UNITS=$PIECE(STR,"^",7)
+35 ;
+36 ; Reset PCC array if and only if PCC Ref Ranges or Units "empty". Reset ^BLRTXLOG entries, if possible
+37 IF '$LENGTH(PCCLOW)&($LENGTH(REFLOW))
SET APCDALVR("APCDTRFL")=REFLOW
IF +$GET(BLRIEN)
SET $PIECE(^BLRTXLOG(BLRIEN,20),"^",8)=REFLOW
+38 IF '$LENGTH(PCCHIGH)&($LENGTH(REFHIGH))
SET APCDALVR("APCDTRFH")=REFHIGH
IF +$GET(BLRIEN)
SET $PIECE(^BLRTXLOG(BLRIEN,20),"^",9)=REFHIGH
+39 IF '$LENGTH(PCCUNITS)&($LENGTH(UNITS))
SET APCDALVR("APCDTUNI")=UNITS
IF +$GET(BLRIEN)
SET $PIECE(^BLRTXLOG(BLRIEN,20),"^",3)=UNITS
+40 ;
+41 ; If LAB Point Of View has ` and IS NOT an ICD code, just make it a string.
+42 SET LABPOV=$GET(APCDALVR("APCDTLPV"))
+43 IF LABPOV["`"
Begin DoDot:1
+44 SET LABPOV=$PIECE(LABPOV,"`",2)
+45 ; I $$ICDDX^ICDCODE(LABPOV)<1 S APCDALVR("APCDTLPV")=LABPOV
+46 ; IHS/MSC/MKK - LR*5.2*1034
IF $$ICDDX^ICDEX(LABPOV)<1
SET APCDALVR("APCDTLPV")=LABPOV
End DoDot:1
+47 ;
+48 ; The following have to be rechecked due to POC tests
+49 ;
+50 ; NO CPT code in APCDALVR array
+51 IF $LENGTH($GET(APCDALVR("APCDTCPT")))<1
DO APCDPCCR
+52 ;
+53 DO ENTRYAUD^BLRUTIL("CHKPCCRU^BLRLINK4 9.0","APCDALVR")
+54 QUIT
+55 ;
APCDPCCR ; EP - Reset CPT nodes, if Possible.
+1 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+2 ; Do not try to reset the CPT codes because it will "unbundle"
+3 ; all the Atomic tests that should be under one CPT code
+4 ; for a Cosmic test. This subroutine was a mistake.
+5 QUIT
+6 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+7 ;
+8 ;
+9 ; Reset from BLR variables, if possible
IF $LENGTH($GET(BLRCPT))
IF $LENGTH($GET(BLRCPTST))
Begin DoDot:1
+10 SET APCDALVR("APCDTCPS")=BLRCPTST
+11 SET APCDALVR("APCDTCPT")="`"_BLRCPT
End DoDot:1
QUIT
+12 ;
+13 ; If only BLRCPT, reset
IF $LENGTH($GET(BLRCPT))
SET APCDALVR("APCDTCPT")="`"_BLRCPT
QUIT
+14 ;
+15 ; At this point, use Lab Test IEN, if possible
+16 NEW BLRCPT,BLRCPTST,CNT,IHSCPTLP,STR1,STR2
+17 ;
+18 SET IHSCPTLP=+$ORDER(^BLRCPT("C",+$GET(LABTIEN),0))
+19 IF IHSCPTLP
Begin DoDot:1
+20 SET STR1=$GET(^BLRCPT(IHSCPTLP,11,+$ORDER(^BLRCPT(IHSCPTLP,11,0)),0))
+21 SET STR2=$PIECE(STR1,"^",2)
+22 SET BLRCPTST=""
+23 SET BLRCPT="`"_IHSCPTLP
+24 IF $LENGTH(STR2)
Begin DoDot:2
+25 FOR CNT=1:1:5
SET BLRCPTST=BLRCPTST_$PIECE(STR2,"^",CNT)_"|"
End DoDot:2
+26 IF $LENGTH(STR2)<1
SET BLRCPTST=+STR1_"|||||"
+27 ;
+28 SET APCDALVR("APCDTCPS")=BLRCPTST
+29 SET APCDALVR("APCDTCPT")=BLRCPT
End DoDot:1
+30 ;
+31 IF $LENGTH($GET(APCDALVR("APCDTCPT")))
QUIT
+32 ;
+33 ; Still empty, so KILL off the nodes
+34 KILL APCDALVR("APCDTCPS")
+35 KILL APCDALVR("APCDTCPT")
+36 QUIT
+37 ;
CHKREFA ; EP - Make sure Reference Ranges are not formulas
+1 NEW OKAYFLAG,PCCLOW,PCCHIGH,SHOULDBE,TESTIT,X
+2 ;
+3 SET PCCLOW=$GET(APCDALVR("APCDTRFL"))
+4 SET PCCHIGH=$GET(APCDALVR("APCDTRFH"))
+5 ;
+6 IF $GET(PCCLOW)'["$S"&($GET(PCCHIGH)'["$S")
QUIT
+7 ;
+8 DO ENTRYAUD^BLRUTIL("CHKREFA^BLRLINK4 0.0")
+9 ;
+10 SET OKAYFLAG=0
+11 ;
+12 IF $GET(PCCLOW)["$S"
Begin DoDot:1
+13 SET X=PCCLOW
+14 ; Make sure M code in Reference Value is valid
DO ^DIM
+15 IF $DATA(X)
QUIT
+16 ;
+17 SET SHOULDBE="SHOULDBE="_PCCLOW
+18 SET @SHOULDBE
+19 IF $LENGTH(SHOULDBE)<1
QUIT
+20 ;
+21 SET APCDALVR("APCDTRFL")=SHOULDBE
+22 IF +$GET(BLRIEN)
SET $PIECE(^BLRTXLOG(BLRIEN,20),"^",8)=SHOULDBE
End DoDot:1
+23 ;
+24 IF $GET(PCCHIGH)["$S"
Begin DoDot:1
+25 SET X=PCCHIGH
+26 DO ^DIM
+27 IF $DATA(X)
QUIT
+28 ;
+29 SET SHOULDBE="SHOULDBE="_PCCHIGH
+30 SET @SHOULDBE
+31 IF $LENGTH(SHOULDBE)<1
QUIT
+32 ;
+33 SET APCDALVR("APCDTRFH")=SHOULDBE
+34 IF +$GET(BLRIEN)
SET $PIECE(^BLRTXLOG(BLRIEN,20),"^",9)=SHOULDBE
End DoDot:1
+35 ;
+36 DO ENTRYAUD^BLRUTIL("CHKREFA^BLRLINK4 8.8")
+37 ;
+38 QUIT
+39 ;
LOTZERO(ARRAY) ; EP - Leading and/Or Trailing ZERO(s) for PCC
+1 NEW (ARRAY,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO ENTRYAUD^BLRUTIL("LOTZERO^BLRLINK4 0.0","ARRAY")
+4 ;
+5 SET L60IEN=$PIECE($GET(ARRAY("APCDTLAB")),"`",2)
+6 ; IHS/MSC/MKK - LR*5.2*1037
IF +L60IEN<1
QUIT
+7 ;
+8 SET DN=+$GET(^LAB(60,L60IEN,.2))
+9 ; Skip if no Data Name number
IF +$GET(DN)<1
QUIT
+10 ;
+11 SET STR=$PIECE($GET(^DD(63.04,DN,0)),"^",5)
+12 ; Skip if no numeric defintiion
IF $LENGTH(STR)<1
QUIT
+13 ;
+14 ; S DP=+$P($P(STR,",",3),$C(34))
+15 ; IHS/MSC/MKK - LR*5.2*1032 -- Need to take into account INPUT TRANSFORM code
SET DP=+$PIECE($PIECE(STR,"Q9=",2),",",3)
+16 ; Skip if no Decimal Defintion
IF DP<1
QUIT
+17 ;
+18 SET RESULT=$GET(ARRAY("APCDTRES"))
+19 ;
+20 SET SYMBOL=""
SET ORIGRSLT=RESULT
+21 ; Adjust if ANY Non-Numeric is at the beginning of RESULT
FOR
IF $EXTRACT(RESULT)="."!($EXTRACT(RESULT)?1N)!(RESULT="")
QUIT
Begin DoDot:1
+22 SET SYMBOL=SYMBOL_$EXTRACT(RESULT)
+23 SET RESULT=$EXTRACT(RESULT,2,$LENGTH(RESULT))
End DoDot:1
+24 ;
+25 ; Leading Zero Fix
IF $EXTRACT(RESULT)="."
SET RESULT="0"_RESULT
+26 ;
+27 ; Skip if RESULT has no numeric part
IF $EXTRACT(RESULT)'?1N
SET RESULT=ORIGRSLT
QUIT
+28 ;
+29 SET RESULT=$TRANSLATE($FNUMBER(RESULT,"P",DP)," ")
+30 ;
+31 ; Restore "symbol", if necessary
IF $LENGTH($GET(SYMBOL))
SET RESULT=SYMBOL_RESULT
+32 ;
+33 SET ARRAY("APCDTRES")=RESULT
+34 ;
+35 SET PCCLOW=$GET(ARRAY("APCDTRFL"))
+36 SET PCCHIGH=$GET(ARRAY("APCDTRFH"))
+37 ;
+38 IF $LENGTH($GET(PCCLOW))
Begin DoDot:1
+39 IF $EXTRACT(PCCLOW,1)="."
SET PCCLOW="0"_PCCLOW
+40 SET PCCLOW=$TRANSLATE($FNUMBER(PCCLOW,"P",DP)," ")
+41 SET ARRAY("APCDTRFL")=PCCLOW
End DoDot:1
+42 ;
+43 IF $LENGTH($GET(PCCHIGH))
Begin DoDot:1
+44 IF $EXTRACT(PCCHIGH,1)="."
SET PCCHIGH="0"_PCCHIGH
+45 SET PCCHIGH=$TRANSLATE($FNUMBER(PCCHIGH,"P",DP)," ")
+46 SET ARRAY("APCDTRFH")=PCCHIGH
End DoDot:1
+47 ;
+48 QUIT
+49 ;
+50 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
RESETPOV ; EP -- Reset "Provider Narrative"
+1 DO ENTRYAUD^BLRUTIL("RESETPOV^BLRLINK4 0.0","APCDALVR")
+2 ;
+3 ; NEW FDA,ICD,ICDCODE,IENS,LRORD,LRORDT,LRSP,LRTN,LRTST,ORDNUM,POV,POVICD,PROVNAR,SNOMED,TESTIEN
+4 ; IHS/MSC/MKK - LR*5.2*1034
NEW (APCDALVR,BLRLOGDA,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,X,XPARSYS,XQXFLG)
+5 ;
+6 DO ENTRYAUD^BLRUTIL("RESETPOV^BLRLINK4 0.1","APCDALVR")
+7 ;
+8 ; S ORDNUM=+$G(APCDALVR("APCDTORD"))
+9 ; Q:ORDNUM<1 ; If no Order Number, skip
+10 ;
+11 ; S TESTIEN=+$P($G(APCDALVR("APCDTLAB")),"`",2)
+12 ; Q:TESTIEN<1 ; If no Lab Test IEN, skip
+13 ;
+14 ; S LRODT=+$O(^LRO(69,"C",ORDNUM,0))
+15 ; S LRSP=+$O(^LRO(69,"C",ORDNUM,LRODT,0))
+16 ; S LRTN=+$O(^LRO(69,LRODT,1,LRSP,2,"B",TESTIEN,0))
+17 ;
+18 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+19 SET ORDNUM=+$$GET1^DIQ(9009022,BLRLOGDA,"ORDER NUMBER")
+20 IF ORDNUM<1
QUIT
+21 ;
+22 SET TESTIEN=+$$GET1^DIQ(9009022,BLRLOGDA,"PANEL/TEST POINTER","I")
+23 IF TESTIEN<1
QUIT
+24 ;
+25 ; Because there can be multiple tests on an order, find entry
+26 ; in file 69 that matches the TESTIEN.
+27 SET (FOUNDIT,LRODT)=0
+28 SET LRODT=$ORDER(^LRO(69,"C",ORDNUM,LRODT))
IF LRODT<1!(FOUNDIT)
QUIT
Begin DoDot:1
+29 SET LRSP=0
+30 FOR
SET LRSP=$ORDER(^LRO(69,"C",ORDNUM,LRODT,LRSP))
IF LRSP<1!(FOUNDIT)
QUIT
Begin DoDot:2
+31 SET LROT=0
+32 FOR
SET LROT=$ORDER(^LRO(69,LRODT,1,LRSP,2,LROT))
IF LROT<1!(FOUNDIT)
QUIT
Begin DoDot:3
+33 IF +$GET(^LRO(69,LRODT,1,LRSP,2,LROT,0))=TESTIEN
SET FOUNDIT=FOUNDIT+1
SET FOUNDIT("LRSP")=LRSP
SET FOUNDIT("LRTN")=LROT
End DoDot:3
End DoDot:2
End DoDot:1
+34 SET LRSP=+$GET(FOUNDIT("LRSP"))
SET LRTN=+$GET(FOUNDIT("LRTN"))
+35 ;
+36 ; If no entry in Lab Order Entry file, skip
IF LRTN<1
QUIT
+37 ;
+38 ; S ICD=+$O(^LRO(69,LRODT,1,LRSP,2,LRTN,2,0))
+39 ; S ICDPTR=+$P($G(^LRO(69,LRODT,1,LRSP,2,LRTN,2,ICD,0)),"^")
+40 ; S ICDSTR=$$ICDDX^ICDCODE(ICDPTR) ; Currently, ICD Description & Code
+41 ; S ICDCODE=$P(ICDSTR,"^",2),ICDDESC=$P(ICDSTR,"^",4)
+42 ;
+43 ; S ICDCODE=$$UP^XLFSTR($P(ICDSTR,"^",2)),ICDDESC=$P(ICDSTR,"^",4)
+44 ;
+45 ; S IENS=LRTN_","_LRSP_","_LRODT
+46 ; S PROVNAR=$$GET1^DIQ(69.03,IENS,9999999.1)
+47 ; S SNOMED=$$GET1^DIQ(69.03,IENS,9999999.2)
+48 ;
+49 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+50 SET IEN=LRTN_","_LRSP_","_LRODT_","
+51 SET PROVNAR=$$GET1^DIQ(69.03,IEN,"PROVIDER NARRATIVE")
+52 SET SNOMED=$$GET1^DIQ(69.03,IEN,"SNOMED")
+53 ; S ICDCODE=$$GET1^DIQ(69.05,1_","_IEN,"ICD-9 CODES")
+54 ; S ICDPTR=+$P($G(^LRO(69,LRODT,1,LRSP,2,LRTN,2,ICD,0)),"^")
+55 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+56 SET ICDCODE=$$GET1^DIQ(69.05,1_","_IEN,"ICD CODES")
+57 SET ICDIEN=$$GET1^DIQ(69.05,1_","_IEN,"ICD CODES","I")
+58 SET ICDDESC=$$VLTD^ICDEX(ICDIEN)
+59 IF $LENGTH(ICDDESC)<1
SET ICDDESC=$$VLTP^ICDEX(ICDIEN)
+60 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+61 ;
+62 DO ENTRYAUD^BLRUTIL(" RESETPOV^BLRLINK4 5.0")
+63 ;
+64 ; Skip if no data in the Lab Order Entry file
+65 IF $LENGTH(PROVNAR)<1
IF $LENGTH(SNOMED)<1
IF $LENGTH(ICDCODE)<1
QUIT
+66 ;
+67 IF $LENGTH(PROVNAR)
SET APCDALVR("APCDTLPV")=PROVNAR
+68 IF $LENGTH(SNOMED)
DO FMSNOMED
+69 ; S:$L(ICDCODE)&(ICDCODE'["INVALID") APCDALVR("APCDTICD")=ICDCODE
+70 ; S:$L(ICDCODE)&(ICDCODE'["INVALID") APCDALVR("APCDTICD")="`"_ICDPTR
+71 ;
+72 ; IHS/MSC/MKK - LR*5.2*1034 - Use ICD Code's IEN to store into PCC
IF ICDIEN
SET APCDALVR("APCDTICD")="`"_ICDIEN
+73 ;
+74 DO ENTRYAUD^BLRUTIL(" RESETPOV^BLRLINK4 5.5")
+75 ;
+76 IF $GET(APCDALVR("APCDTICD"))["INVALID"
KILL APCDALVR("APCDTICD")
+77 ;
+78 ; Reset ^BLRTXLOG, if necessary. Skip if No BLRLOGDA variable.
+79 IF +$GET(BLRLOGDA)
Begin DoDot:1
+80 NEW BLRPROVN,BLRSNOM,BLRICD,BLRPROVN,BLRSNOM,BLRICD
+81 SET BLRPROVN=$$GET1^DIQ(9009022,BLRLOGDA_",",1601)
+82 SET BLRSNOM=$$GET1^DIQ(9009022,BLRLOGDA_",",1602)
+83 SET BLRICD=$$GET1^DIQ(9009022,BLRLOGDA_",",1603)
+84 ;
+85 IF BLRPROVN=PROVNAR
IF BLRSNOM=SNOMED
IF BLRICD=ICDCODE
QUIT
+86 ;
+87 KILL FDA,ERRS
+88 IF $LENGTH(PROVNAR)&(BLRPROVN'=PROVNAR)
SET FDA(9009022,BLRLOGDA_",",1601)=PROVNAR
+89 IF $LENGTH(SNOMED)&(BLRSNOM'=SNOMED)
SET FDA(9009022,BLRLOGDA_",",1602)=SNOMED
+90 ; S:$L(ICDCODE)&(BLRICD'=ICDCODE) FDA(9009022,BLRLOGDA_",",1603)=ICDCODE
+91 ;
+92 IF $LENGTH(ICDCODE)&(ICDCODE'["INVALID")&(BLRICD'=ICDCODE)
SET FDA(9009022,BLRLOGDA_",",1603)=ICDCODE
+93 ;
+94 IF $DATA(FDA)<1
QUIT
+95 ;
+96 DO UPDATE^DIE("S","FDA",,"ERRS")
End DoDot:1
+97 ;
+98 DO ENTRYAUD^BLRUTIL(" RESETPOV^BLRLINK4 9.0","APCDALVR","ERRS","VERRS")
+99 QUIT
+100 ;
FMSNOMED ; EP - SNOMED codes to be done via FileMan
+1 NEW IEN,VLABFILE,VLABIEN
+2 ;
+3 SET VLABFILE=+$$GET1^DIQ(9009022,BLRLOGDA_",",104,"I")
+4 IF VLABFILE<1
QUIT
+5 ;
+6 SET VLABIEN=+$$GET1^DIQ(9009022,BLRLOGDA_",",105)
+7 IF VLABIEN<1
QUIT
+8 ;
+9 SET FDA(VLABFILE_"26","?+1,"_VLABIEN_",",.01)=SNOMED
+10 ;
+11 DO UPDATE^DIE("ES","FDA",,"VERRS")
+12 QUIT
+13 ;
+14 ; If SNOMED is in 9009029 & missing in the PCC file, then fix it. Done for BYPASS entries.
MSNOMED ; EP - Called from BLRLINK3
+1 NEW ERRS,FDA,SNOMED,VFILENUM,VFILEIEN
+2 ;
+3 ; Note -- When this routine is called, the V File data are not in the ^BLRTXLOG global yet, but are in the APCDALVR array.
+4 ;
+5 ; Skip if there is a PCC error
+6 IF +$GET(APCDALVR("APCDAFLG"))>0
QUIT
+7 ;
+8 ; Get V File #
+9 SET VFILENUM=+$GET(APCDALVR("APCDAVF"))
+10 IF VFILENUM<1
QUIT
+11 ;
+12 ; Get V File IEN
+13 SET VFILEIEN=+$GET(APCDALVR("APCDADFN"))
+14 IF VFILEIEN<1
QUIT
+15 ;
+16 ; If SNOMED already in V File, skip
+17 SET SNOMED=$$GET1^DIQ(VFILENUM,VFILEIEN,1602)
+18 IF $LENGTH(SNOMED)
QUIT
+19 ;
+20 ; Get SNOMED code
+21 ; S SNOMED=+$$GET1^DIQ(9009022,BLRLOGDA_",",1602)
+22 ; IHS/MSC/MKK - LR*5.2*1037
SET SNOMED=$$GET1^DIQ(9009022,BLRLOGDA_",",1602)
+23 IF $LENGTH(SNOMED)<1
QUIT
+24 ;
+25 SET FDA(VFILENUM_"26","?+1,"_VFILEIEN_",",.01)=SNOMED
+26 ;
+27 DO UPDATE^DIE("S","FDA",,"ERRS")
+28 ;
+29 QUIT
+30 ;
+31 ; ----- END IHS/MSC/MKK - LR*5.2*1033
