BLRLINK3 ; IHS/HQT/MJL - CONT. OF BLR - IHS LABORATORY VISIT CREATION ; 13-Oct-2017 14:04 ; MKK
;;5.2;IHS LABORATORY;**1010,1011,1014,1015,1018,1021,1022,1024,1025,1027,1028,1029,1030,1031,1033,1034,1037,1039,1041**;NOV 01, 1997;Build 23
;
EP ; EP
S BLRVFILE="9000010"_$S(BLRSS="CH":".09",BLRSS="MI":".25",BLRSS="BB":".31",1:"??")
I BLRVFILE["??" S BLRERR=1,BLRBUL=2,BLRPCC="Unknown Test Subscript - link not yet implemented" Q
;
S BLRVGL=$$GETGREF(BLRVFILE)
D VBUILD Q:BLRERR
D VEDIT
Q
;
VBUILD ; EP create APCDALVR array which is the array containing the elements to be passed to PCC
;--- BEGIN cmi/anch/maw REF LAB -- LR*5.2*1021
I $G(^BLRTXLOG("BVER",BLRIEN))]"" D Q ;cmi/maw don't move to pcc if held for verification, ref lab
. S BLRERR=1,BLRBUL=0
. S BLRPCC="Result being held for verification"
;--- END cmi/anch/maw end REF LAB -- LR*5.2*1021
;
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1022
; Make sure CLINIC STOP CODE of LABORATORY SERVICES is used, if it exists
NEW LABCLIN,OUT
D FIND^DIC(40.7,"","","","LABORATORY SERVICES","","","","","OUT")
S LABCLIN=+$G(OUT("DILIST",2,1))
I LABCLIN>0 D
. Q:$D(APCDALVR("APCDTCLN")) ; If and Only If APCDALVR("APCDCLN")="" -- IHS/MSC/MKK - LR*5.2*1031
. ; S APCDALVR("APCDTCLN")="`"_LABCLIN
. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
. NEW LOGSTOP
. S LOGSTOP=+$$GET1^DIQ(9009022,BLRLOGDA,109,"I")
. S APCDALVR("APCDTCLN")="`"_$S(LOGSTOP:LOGSTOP,1:LABCLIN)
. ; ----- END IHS/MSC/MKK - LR*5.2*1039
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1022
;
S APCDALVR("APCDTCSF")=BLRSTAT
S APCDALVR("APCDTLAB")=$S(BLRTLAB="":BLRTNAM,1:"`"_BLRTLAB)
S APCDALVR("APCDTORD")=BLRORD
S APCDALVR("APCDTCDT")=BLRCDT
S APCDALVR("APCDTODT")=BLRODT
S APCDALVR("APCDTACC")=BLRACC
;
; send parent ien of V file entry for children of panel
S:BLRPAREN'="" APCDALVR("APCDTPNT")="`"_$P($G(^BLRTXLOG(BLRPAREN,1)),U,5)
;ADDED FOR LOINC PROJECT
S:$G(APCDALVR("APCDTPNT"))="`" APCDALVR("APCDTPNT")="" ;ITSC/IHS/TPF 03/04/02 ADDED FOR LOINC
S APCDALVR("APCDTLNC")="`"_$G(BLRLOINC)
;
;----- BEGIN LR*5.2*1028;08/18/10;IHS/OIT/MPW - IHS LOINC/UCUM MODIFICATIONS
; N XXX,LRIEN,BLRUNIT,SIEN
N XXX,LRIEN,SIEN ; IHS/MSC/MKK - LR*5.2*1033
S XXX=$G(BLRVAL(0)),LRIEN=+$P(XXX,U,6)
I LRIEN,$P(^LAB(60,LRIEN,0),U,5)="" S APCDALVR("APCDTLNC")="`"_$P($G(^LAB(60,LRIEN,9999999)),U,2)
; K XXX,LRIEN,BLRUNIT,SIEN
K XXX,LRIEN,SIEN ; IHS/MSC/MKK - LR*5.2*1033
;----- END LR*5.2*1028 - IHS LOINC/UCUM MODIFICATIONS - IHS/OIT/MPW
;
D:+$L($G(BLRCOMDT))<1 GETCOMPD(BLRLOGDA,BLRACC,$S(BLRTLAB="":BLRTNAM,1:BLRTLAB),.BLRCOMDT) ; IHS/OIT/MKK - LR*5.2*1031
;
S APCDALVR("APCDTRDT")=$G(BLRCOMDT)
S APCDALVR("APCDTCLS")="`"_$G(BLRCOLSA)
S:$G(APCDALVR("APCDTLNC"))="`" APCDALVR("APCDTLNC")=""
S:APCDALVR("APCDTCLS")="`" APCDALVR("APCDTCLS")=""
;END LOINC STUFF
;
S APCDALVR("APCDTCOS")=BLRCOST
S APCDALVR("APCDTBIL")=BLRBILL
S APCDALVR("APCDTCPS")=BLRCPTST
S APCDALVR("APCDTSDI")=BLRSDI
;
;[LR*5.2*1028;08/18/10;IHS/OIT/MPW]S:$G(BLRUNIT)'="" APCDALVR("APCDTUNI")=BLRUNIT
I $G(BLRUNIT)'="",'$D(APCDALVR("APCDTUNI")) S APCDALVR("APCDTUNI")=BLRUNIT
;
S APCDALVR("APCDTRFL")=BLRRFL
S APCDALVR("APCDTRFH")=BLRRFH
;
;S APCDALVR("APCDTRES")=$E(BLRRES,1,10)
D:$G(BLRRES)'="" CHSETCOD^BLRLINK4 ; IHS/MSC/MKK - LR*5.2*1031
S APCDALVR("APCDTRES")=$E(BLRRES,1,30) ;cmi/maw 3/25/03 changed for ref lab
;S APCDALVR("APCDTRES")=BLRRES ;IHS/ITSC/TPF 03/25/02 WHY A LIMIT OF 10?
;THIS IS OLD COMMENT STUFF
;I $D(BLRCOM(1)) S APCDALVR("APCDTLC1")=BLRCOM(1)
;I $D(BLRCOM(2)) S APCDALVR("APCDTLC2")=BLRCOM(2)
;I $D(BLRCOM(3)) S APCDALVR("APCDTLC3")=BLRCOM(3)
;
;create micro or Blood Bank specific elements in the APCDALVR array
I BLRSS="MI" D ;IHS/DIR TUC/FJE 12/08/98
. S APCDALVR("APCDTORG")=$S(BLRORG="":BLRORGN,1:"`"_BLRORG),APCDALVR("APCDTANT")=$S(BLRANT="":BLRANTN,1:"`"_BLRANT) ; IHS/DIR TUC/FJE 12/08/98
. S:$G(BLRCOLSP)="" BLRCOLSP=$P($G(^LAB(60,+$G(BLRTEST),0)),"^",9) ; IHS/MSC/MKK - LR*5.2*1031
. ;S APCDALVR("APCDTCOL")=$S($G(BLCOLSP)="":$G(BLCOLSP),1:"`"_BLRCOLSP) S:+BLRCOMPD APCDALVR("APCDTCMD")=BLRCOMPD ; IHS/DIR TUC/FJE 12/08/98
. S APCDALVR("APCDTCOL")=$S($G(BLCOLSP)'="":$G(BLCOLSP),1:"`"_BLRCOLSP) S:+BLRCOMPD APCDALVR("APCDTCMD")=BLRCOMPD ; IHS/ITSC/TPF CHINLE FIX 08/16/02
;
D:BLRSS="CH" ADDORDL^BLRLNKU2(BLRLOGDA,.APCDALVR) ; IHS/MSC/MKK - LR*5.2*1039 - Add in Ordering Location for CH tests if missing
;
S:BLRSS="BB" APCDALVR("APCDTBTN")=BLRBTN,APCDALVR("APCDTANT")=$S(BLRANT="":BLRANTN,1:"`"_BLRANT)
;
S:BLREPRV'="" APCDALVR("APCDTEPR")="`"_BLREPRV
S:BLROPRV'="" APCDALVR("APCDTPRV")="`"_BLROPRV
S:BLROPRV="" APCDALVR("APCDTOPR")=$S(BLROPNM="":BLREPNM,1:BLROPNM)
S:BLRSITE'="" APCDALVR("APCDTSTE")="`"_BLRSITE
I BLRCPT,$D(^BLRCPT(BLRCPT,0)) S:BLRCPT'="" APCDALVR("APCDTCPT")="`"_BLRCPT ;FJE 1/25/2000
I BLRVIEN'="" S BLRMOD=1,APCDALVR("APCDLOOK")=BLRVIEN ; do mod
Q
;
VEDIT ; EP update V file entries
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
NEW REFLABF ; REFerence LAB Flag
;
S REFLABF=0 ; Initialize to FALSE
; ----- END IHS/MSC/MKK - LR*5.2*1031
;
I BLRSTAT="D" S DIK=BLRVGL,DA=BLRVIEN D CALLDIK^BLRNLINK Q ;;results null - do delete
S BLRTRAN=1
;M ^BLRAPCD=APCDALVR
; S APCDALVR("APCDTABN")=$S('$D(BLRMOD):BLRABNL,BLRABNL'="":BLRABNL,BLRVIEN="":"",$P($G(@(BLRVGL_"BLRVIEN,0)")),U,5)'="":"@",1:"") ;must be deleted if result value changes
;
S APCDALVR("APCDTABN")=$S('$D(BLRMOD):$G(BLRABNL),BLRVIEN="":"",$P($G(@(BLRVGL_"BLRVIEN,11)")),U,9)="R":"@",$G(BLRABNL)'="":BLRABNL,1:"") ; IHS/MSC/MKK - LR*5.2*1031 - code will delete flag if result value changes
;
; S APCDALVR("APCDATMP")=$S($D(BLRMOD):"[APCDALVR "_BLRVFILE_" (MOD)]",1:"[APCDALVR "_BLRVFILE_" (ADD)]") D ^APCDALVR
; ----- BEGIN IHS/OIT/MKK LR*5.2*1024 MODIFICATIONS
; Several entries in the APCDALVR array were being cleared, so they are now being
; double-checked BEFORE the call to APCDALVR.
S APCDALVR("APCDATMP")=$S($D(BLRMOD):"[APCDALVR "_BLRVFILE_" (MOD)]",1:"[APCDALVR "_BLRVFILE_" (ADD)]")
I $G(APCDALVR("APCDDATE"))="" S APCDALVR("APCDDATE")=$G(BLRCD)
I $G(APCDALVR("APCDLOC"))="" S APCDALVR("APCDLOC")=$G(BLR("SITE"))
I $G(APCDALVR("APCDPAT"))="" S APCDALVR("APCDPAT")=$G(BLRVADFN)
I $G(APCDALVR("APCDCAT"))="" S APCDALVR("APCDCAT")=$G(BLRVCAT)
I $G(APCDALVR("APCDTYPE"))="" S APCDALVR("APCDTYPE")=$S($P($G(^APCCCTRL(BLR("SITE"),0)),U,4)'="":$P($G(^(0)),U,4),1:"I")
;
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
I $G(APCDALVR("APCDTLPV"))=""&($G(BLRLPOV)'="") D
. NEW IHSLPOV
. I $G(BLRLPOV)["^" S IHSLPOV=$P(BLRLPOV,"^",2)
. S:$G(IHSLPOV)="" IHSLPOV="`"_$P(BLRLPOV,"^")
. ; I +$$ICDDX^ICDCODE($P(IHSLPOV,"`",2))<1 S IHSLPOV=$P(IHSLPOV,"`",2) ; IHS/MSC/MKK - LR*5.2*1031
. ; I +$$ICDDX^ICDCODE($TR($P(IHSLPOV,"`",2),$C(34)))<1 S IHSLPOV=$P(IHSLPOV,"`",2) ; IHS/MSC/MKK - LR*5.2*1033 -- Make certain no quotes are passed to the ICDCODE routine.
. I +$$ICDDX^ICDEX($P(IHSLPOV,"`",2),,,"I")<1 S IHSLPOV=$P(IHSLPOV,"`",2) ; IHS/MSC/MKK - LR*5.2*1034 -- Use AICD 4.0 function
. S APCDALVR("APCDTLPV")=IHSLPOV
; ----- END IHS/OIT/MKK - LR*5.2*1027
;
;APCDTLPV
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1025
; USER LAST UPDATE field in Visit file is populated by the DUZ.
; Temporarily change the DUZ, if possible
NEW OLDDUZ,USER,TSTR
M OLDDUZ=DUZ
; I +$G(BLRLOGDA)>0 S USER=$P($G(^BLRTXLOG(BLRLOGDA,20)),"^",6)
; I +$G(USER)>0 S TSTR="DUZ"_"=USER" S @TSTR
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1025
;
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
D RESETDUZ^BLRPCCVC
; S APCDALVR("APCDTEPR")="`"_DUZ ; IHS/OIT/MKK - LR*5.2*1029 - Line commented out
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
;
I $G(APCDALVR("BLRLINK"))="" S APCDALVR("BLRLINK")=1
;
; D HL7REFLR ; IHS/OIT/MKK - LR*5.2*1027 -- Make sure Ref Lab Reference Ranges used, if they exist
D HL7REFLR^BLRLINK4(.REFLABF) ; IHS/MSC/MKK - LR*5.2*1031 -- External Routine
;
; D CHKPCCRU ; IHS/OIT/MKK - LR*5.2*1030
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
I 'REFLABF D
. D CHKPCCRU^BLRLINK4
. D CHKREFA^BLRLINK4
. D LOTZERO^BLRLINK4(.APCDALVR)
; ----- END IHS/MSC/MKK - LR*5.2*1031
;
; D RESETLOI ; IHS/MSC/MKK - LR*5.2*1031 -- Have to reset LOINC each time
D RESETLOI^BLRLNKU1 ; IHS/MSC/MKK - LR*5.2*1041
;
D RESETPOV^BLRLINK4 ; IHS/MSC/MKK - LR*5.2*1033 -- Make Certain Lab POV valid
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
D
. NEW ICDNAME
. S ICDNAME=$$GET1^DIQ(80,+$P($G(APCDALVR("APCDTICD")),"`",2),.01)
. I ICDNAME=".9999"!(ICDNAME="ZZZ.999") K APCDALVR("APCDTICD")
; ----- END IHS/MSC/MKK - LR*5.2*1033
;
D RESETABN ; IHS/MSC/MKK - LR*5.2*1041 - Set ABNORMAL flag to value in the Lab Data file every time
;
D ^APCDALVR
;
; ----- END IHS/OIT/MKK LR*5.2*1024 MODIFICATIONS
;
D MSNOMED^BLRLINK4 ; IHS/MSC/MKK - LR*5.2*1033 -- Make Certain VLAB SNOMED field is set
;
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1025
S TSTR="DUZ"_"=OLDDUZ"
; S @TSTR ; Change DUZ back
M @TSTR ; Change DUZ back -- LR*5.2*1027
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1025
;
I '$D(APCDALVR("APCDAFLG")) D
.S:'BLRVIEN BLRVIEN=$G(APCDALVR("APCDADFN"))
.I 'BLRVIEN,$D(@(BLRVGL_"""ALR"",APCDALVR(""APCDVSIT""),BLRACC,BLRTLAB)")) S BLRVIEN=$O(@(BLRVGL_"""ALR"",APCDALVR(""APCDVSIT""),BLRACC,BLRTLAB,0)"))
.K DIE,DA,DR
.S DIE="^BLRTXLOG(",DA=BLRIEN,DR="104///^S X="_BLRVFILE_";105///^S X=BLRVIEN"
.D ^DIE
.K BLRCMSG ;IHS/ITSC/TPF 02/17/2004 ADDED TO CLEAR ERRO MESSAGE FOR COMMENTS LR*5.2*1018 RESULT OF "No V Lab Entry" message showing up in Tuba City EHR alpha testing
.I $O(BLRCOM("")) D
..S BLRCMSG=$$LABC^APCDALVR(BLRVIEN,.BLRCOM) ;maw comments
.. K BLRCOM ; IHS/MSC/MKK - LR*5.2*1041 - Make sure array is cleared after it's stored once.
.I $G(BLRCMSG)]"" S BLRBUL=2,BLRERR=1,BLRPCC=$P($G(BLRCMSG),U,2) ;maw
.K BLRCMSG ;IHS/ITSC/TPF 02/17/2004 ADDED TO CLEAR ERRO MESSAGE FOR COMMENTS
.Q
.S BLRBUL=2,BLRPCC="Another user is editing this TX file entry..."_BLRIEN S BLRERR=1
.W:'BLRQUIET !,"Another user is editing this TX file entry..."_BLRIEN,! S BLRERR=1
;
I $G(APCDALVR("APCDAFLG"))=1 S BLRBUL=2,BLRPCC="Invalid template for result display"_" FLG = 1" W:'BLRQUIET !,BLRPCC,!
;
D ^BLRLINKP:$G(APCDALVR("APCDAFLG"))=2
;
K APCDALVR
Q
;
GETGREF(BLRX) ; EP
Q $G(^DIC(BLRX,0,"GL"))
;
; If Complete Date variable is null, but there is a complete date, reset it
GETCOMPD(BLRLOGDA,LRAS,F60IEN,COMPDATE) ; EP
NEW LRAA,LRAD,LRAN,LOGCOMPD,PTR,RESULTDT
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
Q:+$G(BLRLOGDA)<1
Q:$L(LRAS)<1
Q:+$G(F60IEN)<1
Q:BLRSTAT'="R" ; Has to have status of "RESULTED"
;
; If COMPLETE DATE in 9009022, use it
S RESULTDT=$$GET1^DIQ(9009022,BLRLOGDA,1309,"I")
I RESULTDT S COMPDATE=RESULTDT Q
;
Q:$$RDINF63^BLRLNKU2(BLRLOGDA,LRAS,F60IEN,.COMPDATE) ; IHS/MSC/MKK - LR*5.2*1039
; ----- END IHS/MSC/MKK - LR*5.2*1039
;
Q:$$GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)<1
;
; Check Accession file for COMPLETE DATE
S PTR=+$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",F60IEN,0))
Q:PTR<1
;
S RESULTDT=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,PTR,0)),"^",5)
Q:RESULTDT<1
;
S COMPDATE=RESULTDT
;
; If Complete Date not in ^BLRTXLOG, set it
S:+$P($G(^BLRTXLOG(BLRLOGDA,13)),"^",9)<1 $P(^BLRTXLOG(BLRLOGDA,13),"^",9)=RESULTDT
Q
; ----- END IHS/MSC/MKK - LR*5.2*1031
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
RESETABN ; EP - For "CH" tests only, make sure "Abnormal" Flag is the same as the one in the LAB DATA file
NEW (APCDALVR,BLRACCN,BLRTLAB,BLRTEST,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
Q:+$G(BLRTLAB)<1 ; Skip if no test variable
Q:$L($G(BLRACCN))<1 ; Skip if no Accession string
;
S X=$$GETACCCP^BLRUTIL3(BLRACCN,.LRAA,.LRAD,.LRAN)
Q:LRAA<1!(LRAD<1)!(LRAN<1)
;
S LRSS=$$GET1^DIQ(68,LRAA,.02,"I")
Q:LRSS'="CH"
;
S LRAAIEN=LRAN_","_LRAD_","_LRAA
S LRDFN=$$GET1^DIQ(68.02,LRAAIEN,.01,"I")
Q:LRDFN<1
;
S LRAT=BLRTLAB
S BLRDATAN=$$GET1^DIQ(60,LRAT,400,"I")
Q:BLRDATAN<1
;
S LRIDT=$$GET1^DIQ(68.02,LRAAIEN,13.5,"I")
Q:LRIDT<1
;
S LRDATABN=$P($G(^LR(LRDFN,LRSS,LRIDT,BLRDATAN)),U,2)
S APCDALVR("APCDTABN")=$S($L(LRDATABN):LRDATABN,1:"@")
Q
; ----- END IHS/MSC/MKK - LR*5.2*1041
BLRLINK3 ; IHS/HQT/MJL - CONT. OF BLR - IHS LABORATORY VISIT CREATION ; 13-Oct-2017 14:04 ; MKK
+1 ;;5.2;IHS LABORATORY;**1010,1011,1014,1015,1018,1021,1022,1024,1025,1027,1028,1029,1030,1031,1033,1034,1037,1039,1041**;NOV 01, 1997;Build 23
+2 ;
EP ; EP
+1 SET BLRVFILE="9000010"_$SELECT(BLRSS="CH":".09",BLRSS="MI":".25",BLRSS="BB":".31",1:"??")
+2 IF BLRVFILE["??"
SET BLRERR=1
SET BLRBUL=2
SET BLRPCC="Unknown Test Subscript - link not yet implemented"
QUIT
+3 ;
+4 SET BLRVGL=$$GETGREF(BLRVFILE)
+5 DO VBUILD
IF BLRERR
QUIT
+6 DO VEDIT
+7 QUIT
+8 ;
VBUILD ; EP create APCDALVR array which is the array containing the elements to be passed to PCC
+1 ;--- BEGIN cmi/anch/maw REF LAB -- LR*5.2*1021
+2 ;cmi/maw don't move to pcc if held for verification, ref lab
IF $GET(^BLRTXLOG("BVER",BLRIEN))]""
Begin DoDot:1
+3 SET BLRERR=1
SET BLRBUL=0
+4 SET BLRPCC="Result being held for verification"
End DoDot:1
QUIT
+5 ;--- END cmi/anch/maw end REF LAB -- LR*5.2*1021
+6 ;
+7 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1022
+8 ; Make sure CLINIC STOP CODE of LABORATORY SERVICES is used, if it exists
+9 NEW LABCLIN,OUT
+10 DO FIND^DIC(40.7,"","","","LABORATORY SERVICES","","","","","OUT")
+11 SET LABCLIN=+$GET(OUT("DILIST",2,1))
+12 IF LABCLIN>0
Begin DoDot:1
+13 ; If and Only If APCDALVR("APCDCLN")="" -- IHS/MSC/MKK - LR*5.2*1031
IF $DATA(APCDALVR("APCDTCLN"))
QUIT
+14 ; S APCDALVR("APCDTCLN")="`"_LABCLIN
+15 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
+16 NEW LOGSTOP
+17 SET LOGSTOP=+$$GET1^DIQ(9009022,BLRLOGDA,109,"I")
+18 SET APCDALVR("APCDTCLN")="`"_$SELECT(LOGSTOP:LOGSTOP,1:LABCLIN)
+19 ; ----- END IHS/MSC/MKK - LR*5.2*1039
End DoDot:1
+20 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1022
+21 ;
+22 SET APCDALVR("APCDTCSF")=BLRSTAT
+23 SET APCDALVR("APCDTLAB")=$SELECT(BLRTLAB="":BLRTNAM,1:"`"_BLRTLAB)
+24 SET APCDALVR("APCDTORD")=BLRORD
+25 SET APCDALVR("APCDTCDT")=BLRCDT
+26 SET APCDALVR("APCDTODT")=BLRODT
+27 SET APCDALVR("APCDTACC")=BLRACC
+28 ;
+29 ; send parent ien of V file entry for children of panel
+30 IF BLRPAREN'=""
SET APCDALVR("APCDTPNT")="`"_$PIECE($GET(^BLRTXLOG(BLRPAREN,1)),U,5)
+31 ;ADDED FOR LOINC PROJECT
+32 ;ITSC/IHS/TPF 03/04/02 ADDED FOR LOINC
IF $GET(APCDALVR("APCDTPNT"))="`"
SET APCDALVR("APCDTPNT")=""
+33 SET APCDALVR("APCDTLNC")="`"_$GET(BLRLOINC)
+34 ;
+35 ;----- BEGIN LR*5.2*1028;08/18/10;IHS/OIT/MPW - IHS LOINC/UCUM MODIFICATIONS
+36 ; N XXX,LRIEN,BLRUNIT,SIEN
+37 ; IHS/MSC/MKK - LR*5.2*1033
NEW XXX,LRIEN,SIEN
+38 SET XXX=$GET(BLRVAL(0))
SET LRIEN=+$PIECE(XXX,U,6)
+39 IF LRIEN
IF $PIECE(^LAB(60,LRIEN,0),U,5)=""
SET APCDALVR("APCDTLNC")="`"_$PIECE($GET(^LAB(60,LRIEN,9999999)),U,2)
+40 ; K XXX,LRIEN,BLRUNIT,SIEN
+41 ; IHS/MSC/MKK - LR*5.2*1033
KILL XXX,LRIEN,SIEN
+42 ;----- END LR*5.2*1028 - IHS LOINC/UCUM MODIFICATIONS - IHS/OIT/MPW
+43 ;
+44 ; IHS/OIT/MKK - LR*5.2*1031
IF +$LENGTH($GET(BLRCOMDT))<1
DO GETCOMPD(BLRLOGDA,BLRACC,$SELECT(BLRTLAB="":BLRTNAM,1:BLRTLAB),.BLRCOMDT)
+45 ;
+46 SET APCDALVR("APCDTRDT")=$GET(BLRCOMDT)
+47 SET APCDALVR("APCDTCLS")="`"_$GET(BLRCOLSA)
+48 IF $GET(APCDALVR("APCDTLNC"))="`"
SET APCDALVR("APCDTLNC")=""
+49 IF APCDALVR("APCDTCLS")="`"
SET APCDALVR("APCDTCLS")=""
+50 ;END LOINC STUFF
+51 ;
+52 SET APCDALVR("APCDTCOS")=BLRCOST
+53 SET APCDALVR("APCDTBIL")=BLRBILL
+54 SET APCDALVR("APCDTCPS")=BLRCPTST
+55 SET APCDALVR("APCDTSDI")=BLRSDI
+56 ;
+57 ;[LR*5.2*1028;08/18/10;IHS/OIT/MPW]S:$G(BLRUNIT)'="" APCDALVR("APCDTUNI")=BLRUNIT
+58 IF $GET(BLRUNIT)'=""
IF '$DATA(APCDALVR("APCDTUNI"))
SET APCDALVR("APCDTUNI")=BLRUNIT
+59 ;
+60 SET APCDALVR("APCDTRFL")=BLRRFL
+61 SET APCDALVR("APCDTRFH")=BLRRFH
+62 ;
+63 ;S APCDALVR("APCDTRES")=$E(BLRRES,1,10)
+64 ; IHS/MSC/MKK - LR*5.2*1031
IF $GET(BLRRES)'=""
DO CHSETCOD^BLRLINK4
+65 ;cmi/maw 3/25/03 changed for ref lab
SET APCDALVR("APCDTRES")=$EXTRACT(BLRRES,1,30)
+66 ;S APCDALVR("APCDTRES")=BLRRES ;IHS/ITSC/TPF 03/25/02 WHY A LIMIT OF 10?
+67 ;THIS IS OLD COMMENT STUFF
+68 ;I $D(BLRCOM(1)) S APCDALVR("APCDTLC1")=BLRCOM(1)
+69 ;I $D(BLRCOM(2)) S APCDALVR("APCDTLC2")=BLRCOM(2)
+70 ;I $D(BLRCOM(3)) S APCDALVR("APCDTLC3")=BLRCOM(3)
+71 ;
+72 ;create micro or Blood Bank specific elements in the APCDALVR array
+73 ;IHS/DIR TUC/FJE 12/08/98
IF BLRSS="MI"
Begin DoDot:1
+74 ; IHS/DIR TUC/FJE 12/08/98
SET APCDALVR("APCDTORG")=$SELECT(BLRORG="":BLRORGN,1:"`"_BLRORG)
SET APCDALVR("APCDTANT")=$SELECT(BLRANT="":BLRANTN,1:"`"_BLRANT)
+75 ; IHS/MSC/MKK - LR*5.2*1031
IF $GET(BLRCOLSP)=""
SET BLRCOLSP=$PIECE($GET(^LAB(60,+$GET(BLRTEST),0)),"^",9)
+76 ;S APCDALVR("APCDTCOL")=$S($G(BLCOLSP)="":$G(BLCOLSP),1:"`"_BLRCOLSP) S:+BLRCOMPD APCDALVR("APCDTCMD")=BLRCOMPD ; IHS/DIR TUC/FJE 12/08/98
+77 ; IHS/ITSC/TPF CHINLE FIX 08/16/02
SET APCDALVR("APCDTCOL")=$SELECT($GET(BLCOLSP)'="":$GET(BLCOLSP),1:"`"_BLRCOLSP)
IF +BLRCOMPD
SET APCDALVR("APCDTCMD")=BLRCOMPD
End DoDot:1
+78 ;
+79 ; IHS/MSC/MKK - LR*5.2*1039 - Add in Ordering Location for CH tests if missing
IF BLRSS="CH"
DO ADDORDL^BLRLNKU2(BLRLOGDA,.APCDALVR)
+80 ;
+81 IF BLRSS="BB"
SET APCDALVR("APCDTBTN")=BLRBTN
SET APCDALVR("APCDTANT")=$SELECT(BLRANT="":BLRANTN,1:"`"_BLRANT)
+82 ;
+83 IF BLREPRV'=""
SET APCDALVR("APCDTEPR")="`"_BLREPRV
+84 IF BLROPRV'=""
SET APCDALVR("APCDTPRV")="`"_BLROPRV
+85 IF BLROPRV=""
SET APCDALVR("APCDTOPR")=$SELECT(BLROPNM="":BLREPNM,1:BLROPNM)
+86 IF BLRSITE'=""
SET APCDALVR("APCDTSTE")="`"_BLRSITE
+87 ;FJE 1/25/2000
IF BLRCPT
IF $DATA(^BLRCPT(BLRCPT,0))
IF BLRCPT'=""
SET APCDALVR("APCDTCPT")="`"_BLRCPT
+88 ; do mod
IF BLRVIEN'=""
SET BLRMOD=1
SET APCDALVR("APCDLOOK")=BLRVIEN
+89 QUIT
+90 ;
VEDIT ; EP update V file entries
+1 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+2 ; REFerence LAB Flag
NEW REFLABF
+3 ;
+4 ; Initialize to FALSE
SET REFLABF=0
+5 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+6 ;
+7 ;;results null - do delete
IF BLRSTAT="D"
SET DIK=BLRVGL
SET DA=BLRVIEN
DO CALLDIK^BLRNLINK
QUIT
+8 SET BLRTRAN=1
+9 ;M ^BLRAPCD=APCDALVR
+10 ; S APCDALVR("APCDTABN")=$S('$D(BLRMOD):BLRABNL,BLRABNL'="":BLRABNL,BLRVIEN="":"",$P($G(@(BLRVGL_"BLRVIEN,0)")),U,5)'="":"@",1:"") ;must be deleted if result value changes
+11 ;
+12 ; IHS/MSC/MKK - LR*5.2*1031 - code will delete flag if result value changes
SET APCDALVR("APCDTABN")=$SELECT('$DATA(BLRMOD):$GET(BLRABNL),BLRVIEN="":"",$PIECE($GET(@(BLRVGL_"BLRVIEN,11)")),U,9)="R":"@",$GET(BLRABNL)'="":BLRABNL,1:"")
+13 ;
+14 ; S APCDALVR("APCDATMP")=$S($D(BLRMOD):"[APCDALVR "_BLRVFILE_" (MOD)]",1:"[APCDALVR "_BLRVFILE_" (ADD)]") D ^APCDALVR
+15 ; ----- BEGIN IHS/OIT/MKK LR*5.2*1024 MODIFICATIONS
+16 ; Several entries in the APCDALVR array were being cleared, so they are now being
+17 ; double-checked BEFORE the call to APCDALVR.
+18 SET APCDALVR("APCDATMP")=$SELECT($DATA(BLRMOD):"[APCDALVR "_BLRVFILE_" (MOD)]",1:"[APCDALVR "_BLRVFILE_" (ADD)]")
+19 IF $GET(APCDALVR("APCDDATE"))=""
SET APCDALVR("APCDDATE")=$GET(BLRCD)
+20 IF $GET(APCDALVR("APCDLOC"))=""
SET APCDALVR("APCDLOC")=$GET(BLR("SITE"))
+21 IF $GET(APCDALVR("APCDPAT"))=""
SET APCDALVR("APCDPAT")=$GET(BLRVADFN)
+22 IF $GET(APCDALVR("APCDCAT"))=""
SET APCDALVR("APCDCAT")=$GET(BLRVCAT)
+23 IF $GET(APCDALVR("APCDTYPE"))=""
SET APCDALVR("APCDTYPE")=$SELECT($PIECE($GET(^APCCCTRL(BLR("SITE"),0)),U,4)'="":$PIECE($GET(^(0)),U,4),1:"I")
+24 ;
+25 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
+26 IF $GET(APCDALVR("APCDTLPV"))=""&($GET(BLRLPOV)'="")
Begin DoDot:1
+27 NEW IHSLPOV
+28 IF $GET(BLRLPOV)["^"
SET IHSLPOV=$PIECE(BLRLPOV,"^",2)
+29 IF $GET(IHSLPOV)=""
SET IHSLPOV="`"_$PIECE(BLRLPOV,"^")
+30 ; I +$$ICDDX^ICDCODE($P(IHSLPOV,"`",2))<1 S IHSLPOV=$P(IHSLPOV,"`",2) ; IHS/MSC/MKK - LR*5.2*1031
+31 ; I +$$ICDDX^ICDCODE($TR($P(IHSLPOV,"`",2),$C(34)))<1 S IHSLPOV=$P(IHSLPOV,"`",2) ; IHS/MSC/MKK - LR*5.2*1033 -- Make certain no quotes are passed to the ICDCODE routine.
+32 ; IHS/MSC/MKK - LR*5.2*1034 -- Use AICD 4.0 function
IF +$$ICDDX^ICDEX($PIECE(IHSLPOV,"`",2),,,"I")<1
SET IHSLPOV=$PIECE(IHSLPOV,"`",2)
+33 SET APCDALVR("APCDTLPV")=IHSLPOV
End DoDot:1
+34 ; ----- END IHS/OIT/MKK - LR*5.2*1027
+35 ;
+36 ;APCDTLPV
+37 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1025
+38 ; USER LAST UPDATE field in Visit file is populated by the DUZ.
+39 ; Temporarily change the DUZ, if possible
+40 NEW OLDDUZ,USER,TSTR
+41 MERGE OLDDUZ=DUZ
+42 ; I +$G(BLRLOGDA)>0 S USER=$P($G(^BLRTXLOG(BLRLOGDA,20)),"^",6)
+43 ; I +$G(USER)>0 S TSTR="DUZ"_"=USER" S @TSTR
+44 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1025
+45 ;
+46 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
+47 DO RESETDUZ^BLRPCCVC
+48 ; S APCDALVR("APCDTEPR")="`"_DUZ ; IHS/OIT/MKK - LR*5.2*1029 - Line commented out
+49 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
+50 ;
+51 IF $GET(APCDALVR("BLRLINK"))=""
SET APCDALVR("BLRLINK")=1
+52 ;
+53 ; D HL7REFLR ; IHS/OIT/MKK - LR*5.2*1027 -- Make sure Ref Lab Reference Ranges used, if they exist
+54 ; IHS/MSC/MKK - LR*5.2*1031 -- External Routine
DO HL7REFLR^BLRLINK4(.REFLABF)
+55 ;
+56 ; D CHKPCCRU ; IHS/OIT/MKK - LR*5.2*1030
+57 ;
+58 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+59 IF 'REFLABF
Begin DoDot:1
+60 DO CHKPCCRU^BLRLINK4
+61 DO CHKREFA^BLRLINK4
+62 DO LOTZERO^BLRLINK4(.APCDALVR)
End DoDot:1
+63 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+64 ;
+65 ; D RESETLOI ; IHS/MSC/MKK - LR*5.2*1031 -- Have to reset LOINC each time
+66 ; IHS/MSC/MKK - LR*5.2*1041
DO RESETLOI^BLRLNKU1
+67 ;
+68 ; IHS/MSC/MKK - LR*5.2*1033 -- Make Certain Lab POV valid
DO RESETPOV^BLRLINK4
+69 ;
+70 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+71 Begin DoDot:1
+72 NEW ICDNAME
+73 SET ICDNAME=$$GET1^DIQ(80,+$PIECE($GET(APCDALVR("APCDTICD")),"`",2),.01)
+74 IF ICDNAME=".9999"!(ICDNAME="ZZZ.999")
KILL APCDALVR("APCDTICD")
End DoDot:1
+75 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+76 ;
+77 ; IHS/MSC/MKK - LR*5.2*1041 - Set ABNORMAL flag to value in the Lab Data file every time
DO RESETABN
+78 ;
+79 DO ^APCDALVR
+80 ;
+81 ; ----- END IHS/OIT/MKK LR*5.2*1024 MODIFICATIONS
+82 ;
+83 ; IHS/MSC/MKK - LR*5.2*1033 -- Make Certain VLAB SNOMED field is set
DO MSNOMED^BLRLINK4
+84 ;
+85 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1025
+86 SET TSTR="DUZ"_"=OLDDUZ"
+87 ; S @TSTR ; Change DUZ back
+88 ; Change DUZ back -- LR*5.2*1027
MERGE @TSTR
+89 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1025
+90 ;
+91 IF '$DATA(APCDALVR("APCDAFLG"))
Begin DoDot:1
+92 IF 'BLRVIEN
SET BLRVIEN=$GET(APCDALVR("APCDADFN"))
+93 IF 'BLRVIEN
IF $DATA(@(BLRVGL_"""ALR"",APCDALVR(""APCDVSIT""),BLRACC,BLRTLAB)"))
SET BLRVIEN=$ORDER(@(BLRVGL_"""ALR"",APCDALVR(""APCDVSIT""),BLRACC,BLRTLAB,0)"))
+94 KILL DIE,DA,DR
+95 SET DIE="^BLRTXLOG("
SET DA=BLRIEN
SET DR="104///^S X="_BLRVFILE_";105///^S X=BLRVIEN"
+96 DO ^DIE
+97 ;IHS/ITSC/TPF 02/17/2004 ADDED TO CLEAR ERRO MESSAGE FOR COMMENTS LR*5.2*1018 RESULT OF "No V Lab Entry" message showing up in Tuba City EHR alpha testing
KILL BLRCMSG
+98 IF $ORDER(BLRCOM(""))
Begin DoDot:2
+99 ;maw comments
SET BLRCMSG=$$LABC^APCDALVR(BLRVIEN,.BLRCOM)
+100 ; IHS/MSC/MKK - LR*5.2*1041 - Make sure array is cleared after it's stored once.
KILL BLRCOM
End DoDot:2
+101 ;maw
IF $GET(BLRCMSG)]""
SET BLRBUL=2
SET BLRERR=1
SET BLRPCC=$PIECE($GET(BLRCMSG),U,2)
+102 ;IHS/ITSC/TPF 02/17/2004 ADDED TO CLEAR ERRO MESSAGE FOR COMMENTS
KILL BLRCMSG
+103 QUIT
+104 SET BLRBUL=2
SET BLRPCC="Another user is editing this TX file entry..."_BLRIEN
SET BLRERR=1
+105 IF 'BLRQUIET
WRITE !,"Another user is editing this TX file entry..."_BLRIEN,!
SET BLRERR=1
End DoDot:1
+106 ;
+107 IF $GET(APCDALVR("APCDAFLG"))=1
SET BLRBUL=2
SET BLRPCC="Invalid template for result display"_" FLG = 1"
IF 'BLRQUIET
WRITE !,BLRPCC,!
+108 ;
+109 IF $GET(APCDALVR("APCDAFLG"))=2
DO ^BLRLINKP
+110 ;
+111 KILL APCDALVR
+112 QUIT
+113 ;
GETGREF(BLRX) ; EP
+1 QUIT $GET(^DIC(BLRX,0,"GL"))
+2 ;
+3 ; If Complete Date variable is null, but there is a complete date, reset it
GETCOMPD(BLRLOGDA,LRAS,F60IEN,COMPDATE) ; EP
+1 NEW LRAA,LRAD,LRAN,LOGCOMPD,PTR,RESULTDT
+2 ;
+3 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
+4 IF +$GET(BLRLOGDA)<1
QUIT
+5 IF $LENGTH(LRAS)<1
QUIT
+6 IF +$GET(F60IEN)<1
QUIT
+7 ; Has to have status of "RESULTED"
IF BLRSTAT'="R"
QUIT
+8 ;
+9 ; If COMPLETE DATE in 9009022, use it
+10 SET RESULTDT=$$GET1^DIQ(9009022,BLRLOGDA,1309,"I")
+11 IF RESULTDT
SET COMPDATE=RESULTDT
QUIT
+12 ;
+13 ; IHS/MSC/MKK - LR*5.2*1039
IF $$RDINF63^BLRLNKU2(BLRLOGDA,LRAS,F60IEN,.COMPDATE)
QUIT
+14 ; ----- END IHS/MSC/MKK - LR*5.2*1039
+15 ;
+16 IF $$GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)<1
QUIT
+17 ;
+18 ; Check Accession file for COMPLETE DATE
+19 SET PTR=+$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",F60IEN,0))
+20 IF PTR<1
QUIT
+21 ;
+22 SET RESULTDT=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,PTR,0)),"^",5)
+23 IF RESULTDT<1
QUIT
+24 ;
+25 SET COMPDATE=RESULTDT
+26 ;
+27 ; If Complete Date not in ^BLRTXLOG, set it
+28 IF +$PIECE($GET(^BLRTXLOG(BLRLOGDA,13)),"^",9)<1
SET $PIECE(^BLRTXLOG(BLRLOGDA,13),"^",9)=RESULTDT
+29 QUIT
+30 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+31 ;
+32 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
RESETABN ; EP - For "CH" tests only, make sure "Abnormal" Flag is the same as the one in the LAB DATA file
+1 NEW (APCDALVR,BLRACCN,BLRTLAB,BLRTEST,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 ; Skip if no test variable
IF +$GET(BLRTLAB)<1
QUIT
+4 ; Skip if no Accession string
IF $LENGTH($GET(BLRACCN))<1
QUIT
+5 ;
+6 SET X=$$GETACCCP^BLRUTIL3(BLRACCN,.LRAA,.LRAD,.LRAN)
+7 IF LRAA<1!(LRAD<1)!(LRAN<1)
QUIT
+8 ;
+9 SET LRSS=$$GET1^DIQ(68,LRAA,.02,"I")
+10 IF LRSS'="CH"
QUIT
+11 ;
+12 SET LRAAIEN=LRAN_","_LRAD_","_LRAA
+13 SET LRDFN=$$GET1^DIQ(68.02,LRAAIEN,.01,"I")
+14 IF LRDFN<1
QUIT
+15 ;
+16 SET LRAT=BLRTLAB
+17 SET BLRDATAN=$$GET1^DIQ(60,LRAT,400,"I")
+18 IF BLRDATAN<1
QUIT
+19 ;
+20 SET LRIDT=$$GET1^DIQ(68.02,LRAAIEN,13.5,"I")
+21 IF LRIDT<1
QUIT
+22 ;
+23 SET LRDATABN=$PIECE($GET(^LR(LRDFN,LRSS,LRIDT,BLRDATAN)),U,2)
+24 SET APCDALVR("APCDTABN")=$SELECT($LENGTH(LRDATABN):LRDATABN,1:"@")
+25 QUIT
+26 ; ----- END IHS/MSC/MKK - LR*5.2*1041
