BLRPOC2 ;IHS/MSC/PLS - EHR POC Component support, part 2 ; 13-Oct-2017 14:04 ; MKK
;;5.2;IHS LABORATORY;**1029,1031,1033,1034,1041**;NOV 01, 1997;Build 23
;
; IHS/OIT/MKK
; Entries from BLRPOC were moved to this routine due to the BLRPOC routine
; becoming too large (i.e., violated SAC guidelines).
;
; ==============================================================
;
; ARY("CD")=Collection Date/Time FM Format
; ARY("ORDTST")=Test IEN^Test Name
; ARY("TST",n)=Test IEN^Test Name
; ARY("CM")=Collection Method IEN^Collection Method Name
; ARY("COL")=Collection Sample IEN^Collection Sample Name
; ARY("LOC")=Hospital Location (File 44) IEN^Hospital Location Name
; ARY("PRV")=Provider (File 200) IEN^Provider Name
; ARY("NOO")=Nature of Order IEN^Nature of Order Name
; ARY("URG")=Urgency IEN^Urgency Name
; ARY("SYMP")=Symptom Text^Indication code
; ARY("RES",n)=Result^Result Flag
; ARY("CMT",n)=Array of comment text
; SAVE(DATA,DFN,ARY) ; EP - original SAVE label from BLRPOC
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
; The ARY("SYMP") has been changed to:
; ARY("SYMP")=SNOMED Descriptive Text^ICD Indication code^SNOMED Concept ID
; ----- END IHS/MSC/MKK - LR*5.2*1033
;
SAVER ; EP -
NEW %,BLRDH,BLRGUI,BLRLOG,BLRPCC,BLRQSITE,BLRSTOP,BLRSTOP,BPCACC,BPCCOM
NEW LRAA,LRACC,LRAHEAD,LRAN,LRARY,LRBLOOD,LRCCOM,LRCDT,LRCMT,LRCOM,LRDEFSP
NEW LRDFN,LRDPF,LRDTO,LREAL,LREND,LRFDEFSP,LRFLOC,LRFNODE,LRGCOM,LRI,LRIDIV
NEW LRIDT,LRINI,LRJ,LRLABKY,LRLBLBP,LRLCSIEN,LRLLOC,LRLWC,LRNATURE,LRNG2
NEW LRNG3,LRNG4,LRNG5,LRNT,LRODT,LROLDIV,LROLLOC,LRORDR,LRORDTIM,LRORDTST
NEW LROT,LROUTINE,LRPARAM,LRPCEVSO,LRPLASMA,LRPOVREQ,LRPR,LRPRAC,LRSAMP
NEW LRSB,LRSERUM,LRSN,LRSPEC,LRSPEC0,LRSS,LRTFLG,LRTIEN,LRTRES,LRTSEQ
NEW LRTST,LRUNKNOW,LRURG,LRURINE,LRUSI,LRVF,LRVF,LRVIDO,LRVIDOF,LRWLC,LRWLO
NEW PNLINPNL,PNM,RES,RET,XQY,XQY0,ZTQUEUED
;
S LRNOLABL="" ; SUPPRESS LABEL PRINTING
I $G(^LAB(69.9,1,"RO"))="" S RES="0^Rollover has never been run. Please contact National Lab User Support." G END
I $P($G(^LAB(69.9,1,"RO")),U,2) S RES="0^Accessioning is currently running, please wait a few minutes and try again." G END
S RES=0,ZTQUEUED=1,BLRGUI=1,BPCACC=""
S XQY=$O(^DIC(19,"B","CIAV VUECENTRIC",""))
S XQY0=$G(^DIC(19,XQY,0))
S ARY("CM")="WC"
S LRORDTST=+$G(ARY("ORDTST"))
D ^LRPARAM
S $P(LRPARAM,U,4)=0 ; Force to NO LABELS
S LROUTINE=$P(^LAB(69.9,1,3),"^",2)
;
S LRSAMP=+$G(ARY("COL"))
S LRSPEC=+$P(^LAB(62,LRSAMP,0),U,2)
S LRDFN=$$GETPAT^BLRPOC(DFN)
;
I 'LRDFN D G END
. S RES="0^Failed to find patient in Lab Data File"
;
S LRDPF=2 ; indicates LRDFN represents a patient
S PNM=$$GET1^DIQ(2,DFN,.01)
S LROT(LRSAMP,LRSPEC,1)=+$G(ARY("ORDTST"))
S LRTST=+$G(ARY("ORDTST"))_U_+$G(ARY("URG"))
S LRLWC="WC"
S LRPRAC=+$G(ARY("PRV"))
S LROLLOC=+$G(ARY("LOC"))
S LRLLOC=$$GET1^DIQ(44,+LROLLOC,1)
S LRCDT=$G(ARY("CD"))_"^" ; note, this has 2 pieces due to the way the data is filed in ^LRORDST
S LRODT=$P($P(LRCDT,"^"),".") ; IHS/OIT/MKK - LR*5.2*1029 - Fix if ARY("CD") = just date (no seconds)
S LRORDTIM=$P(+LRCDT,".",2)
; S LRNATURE=$G(ARY("NOO"))
S LRNATURE=$G(ARY("NOO"))_"^99ORN" ; BEGIN IHS/MSC/BF - IHS Lab Patch 1026
S LRURG=+$G(ARY("URG"))
S BPCCOM=""
S LRORDR=""
;S LRORDR="P" ; this will make the software error, due to the ,1) node not being defined.
D NOW^%DTC S LRNT=%
;
D ORDER^LROW2
D ^LRORDST ; Create order and accession
N LRSPEC,LRSAMP
D ^LRWLST ; Accession setup
S LRTST=+$G(ARY("ORDTST"))
;
; Using the test data passed in, build the data that will be placed into the LRSB array.
S LRTSEQ=0 F S LRTSEQ=$O(ARY("TST",LRTSEQ)) Q:'LRTSEQ D
.; Get the individual test ien
.S LRTIEN=+$G(ARY("TST",LRTSEQ)) Q:'LRTIEN
.S LRTRES=$P($G(ARY("RES",LRTSEQ)),"^")
.S LRTFLG=$P($G(ARY("RES",LRTSEQ)),"^",2)
.; Get location data from file 60, field 5, then the second piece for the subscript in the data array.
.S LRFLOC=$$GET1^DIQ(60,LRTIEN,5,"E")
.S LRFNODE=$P(LRFLOC,";",2)
.S LRDEFSP=$$GET1^DIQ(62,+$G(ARY("COL")),2,"I")
.; Now use the pointer to the TOPOGRAPHY FIELD file to locate the appropriate SITE/SPECIMEN from the LABORATORY TEST file (#60)
.S LRSPEC0=$G(^LAB(60,LRTIEN,1,LRDEFSP,0)),LRSPEC0=$TR(LRSPEC0,"^","!")
.S LRNG4=$P(LRSPEC0,"!",4),LRNG4=$$REFRES^BLRPOC(LRNG4),$P(LRSPEC0,"!",4)=LRNG4
.S LRNG5=$P(LRSPEC0,"!",5),LRNG5=$$REFRES^BLRPOC(LRNG5),$P(LRSPEC0,"!",5)=LRNG5
.S LRNG2=$P(LRSPEC0,"!",2),LRNG2=$$REFRES^BLRPOC(LRNG2),$P(LRSPEC0,"!",2)=LRNG2
.S LRNG3=$P(LRSPEC0,"!",3),LRNG3=$$REFRES^BLRPOC(LRNG3),$P(LRSPEC0,"!",3)=LRNG3
.;
.D REVAL(LRTRES,.LRTFLG) ; IHS/MSC/MKK - LR*5.2*1031
.;
.S UCUM=$P(LRSPEC0,"!",7) I UCUM=+UCUM S UCUM=$P(^BLRUCUM(UCUM,0),U,1),$P(LRSPEC0,"!",7)=UCUM
.D BLDARY^BLRPOC(LRFNODE,LRSPEC0,LRTRES,LRTFLG)
;
S LRAA=$P($G(^LAB(60,+$G(ARY("ORDTST")),8,$G(DUZ(2)),0)),U,2)
I LRAA="" S RES="0^No Accession area defined for this test." G END
;
;S LRAD=DT
;S LRAN=+$P(LRACC," ",3)
S LRAN=+$P($G(LRACC)," ",3) ; See Heat Ticket # 16352
I LRAN<1 S RES="0^No Accession number defined for this test." G END
;
I $G(LRLLOC)="" S RES="0^Unable to resolve location. Please insure your location has an abbreviation set up." D END Q
;
; Merge array into LSRB as it is done in LRVRPOC
M LRSB=LRARY
;
; Call the test function as is done in LRVRPOC
D TEST^LRVR1
;
D LRHACK31 ; IHS/MSC/MKK - LR*5.2*1031
;
; File the result data with the reference ranges in ^LR
F LRSB=1:0 S LRSB=$O(LRSB(LRSB)) Q:LRSB<1 S:LRSB(LRSB)'="" ^LR(LRDFN,LRSS,LRIDT,LRSB)=LRSB(LRSB)
S (LRUSI,LRINI)=$$GET1^DIQ(200,$G(DUZ),1,"E")
;
; File the comments with the test results
S LRCOM=0 F S LRCOM=$O(ARY("CMT",LRCOM)) Q:'LRCOM D
.S LRCMT=$G(ARY("CMT",LRCOM))
.D FILECOM^LRVR4(LRDFN,LRIDT,LRCMT)
;
; File Sign/Symptom
; S FDA(69.03,$O(^LRO(69,LRODT,1,LRSN,2,"B",+ARY("ORDTST"),0))_","_LRSN_","_LRODT_",",9999999.1)=$P($G(ARY("SYMP")),U,1)
; D FILE^DIE(,"FDA","ERR") K FDA
; S $P(^LRO(69,LRODT,1,LRSN,2,$O(^LRO(69,LRODT,1,LRSN,2,"B",+ARY("ORDTST"),0)),9999999),U,2)=$P($G(ARY("SYMP")),U,2)
;
D SIGNSYMP ; IHS/MSC/MKK - LR*5.2*1033
;
; Verify the entry
D EXP^LRVER1
S LRVF=1
D V11^LRVER3
S RES="1^Filed"
END ; EP
S DATA=RES
D CLEAN^LRVRPOCU
K ARY
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
LRHACK31 ; EP
; There appears to be a defect brought about by a change to a VA routine that is included
; in IHS Lab Patch 1031. The defect causes the Lab Data File's SPECIMEN TYPE field to be null
; as well as the Accession File's Collection Specimen. This subroutine is a fix, not a solution.
NEW LRAA,LRAD,LRAN,LRAS
;
Q:$L($G(ARY("COL")))<1 ; If ARY("COL") is null, skip
;
; Set the Lab Data File's Speciment Type, if necessary
I +$P($G(^LR(LRDFN,"CH",LRIDT,0)),"^",5)<1 D
. S $P(^LR(LRDFN,"CH",LRIDT,0),"^",5)=$P($G(^LAB(62,+$G(ARY("COL")),0)),"^",2)
;
; Set Accession file's Collection Specimen, if necessary
S LRAS=$P($G(^LR(LRDFN,"CH",LRIDT,0)),"^",6)
D GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
I LRAA,LRAD,LRAN D
. I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)),"^",2)="" D
.. S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0),"^",2)=+$G(ARY("COL"))
Q
;
REVAL(LRTRES,LRTFLG) ; EP - Re-validate abnormal flag
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
; Qualitative flag for POC tests
NEW QUALFLAG
S QUALFLAG=0
D
. NEW LRDL,LRFLG,LRSB,LRSPEC,LRTS,X
. S LRDL=$G(LRTRES)
. S LRSB=$G(LRFNODE)
. S LRSPEC=$P($G(H8),U)
. S LRTS=$G(LRTIEN)
. I $L(LRDL),$L(LRSB),$L(LRSPEC),$L(LRTS) D
.. S X=$$QUALCHEK^BLRQUALU()
.. I $G(LRFLG)="A*" S QUALFLAG=1,LRTFLG=$G(LRFLG)
Q:QUALFLAG
; ----- END IHS/MSC/MKK - LR*5.2*1041
;
; Take into account results that begin with ">" or "<"
S:$E(LRTRES)=">" LRTRES=$P(LRTRES,">",2)+1
S:$E(LRTRES)="<" LRTRES=$P(LRTRES,"<",2)-1
;
S LRTFLG="" ; Initialize every time
I $L(LRNG4)&(LRTRES<LRNG4) S LRTFLG="L*" Q
I $L(LRNG5)&(LRTRES>LRNG5) S LRTFLG="H*" Q
I $L(LRNG2)&(LRTRES<LRNG2) S LRTFLG="L" Q
I $L(LRNG3)&(LRTRES>LRNG3) S LRTFLG="H"
Q
;
; ----- END IHS/MSC/MKK - LR*5.2*1031
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
SIGNSYMP ; EP - Sign or Symptom for Incoming POC test
NEW ARYSYMP,ERRS,FDA,ICD,ICDCNT,ICDSTR,IENS,IN,OUT,PROVNARR,SNOMED,STR,VARS
;
S PROVNARR=$P($G(ARY("SYMP")),"^")
S ICDSTR=$P($G(ARY("SYMP")),"^",2)
S SNOMED=$P($G(ARY("SYMP")),"^",3)
;
I SNOMED="" D ; Only SNOMED or SNOMED Concept ID received
. S STR=$$CONC^BSTSAPI(+PROVNARR) ; SNOMED Concept ID check
. I $TR(STR,"^")="" D
.. S OUT="VARS",IN=+PROVNARR
.. Q:+$$DSCLKP^BSTSAPI(OUT,IN)<1 ; SNOMED code check
.. ;
.. K STR
.. S $P(STR,"^",3)=+PROVNARR
.. S $P(STR,"^",4)=$$TRIM^XLFSTR($P($G(VARS(1,"FSN","TRM")),"("),"LR"," ")
.. S $P(STR,"^",5)=$G(VARS(1,"ICD",1,"COD"))
. S SNOMED=$P(STR,"^",3)
. S PROVNARR=$P(STR,"^",4)
. S ICDSTR=$P(STR,"^",5)
;
Q:$L(PROVNARR)<1&($L(ICDSTR)<1)&($L(SNOMED)<1) ; Skip if nothing to store
;
S IENS=$O(^LRO(69,LRODT,1,LRSN,2,"B",+ARY("ORDTST"),0))_","_LRSN_","_LRODT_","
;
S:$L(PROVNARR) FDA(69.03,IENS,9999999.1)=PROVNARR
S:$L(SNOMED) FDA(69.03,IENS,9999999.2)=SNOMED
;
D:$D(FDA) FILE^DIE(,"FDA","ERRS")
;
Q:$L(ICDSTR)<1 ; Skip if no ICD
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
NEW F60PTR
S F60PTR=$$GET1^DIQ(69.03,IENS,.01,"I")
; ----- END IHS/MSC/MKK - LR*5.2*1034
;
F ICDCNT=1:1:$L(ICDSTR,";") D
. S ICD=$P(ICDSTR,";",ICDCNT)
. K FDA,ERRS
. S FDA(69.05,"?+1,"_IENS,.01)=ICD
. D UPDATE^DIE("EKS","FDA",,"ERRS")
;
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
Q:$$REFLABCK^BLRUTIL6(+ARY("ORDTST"),LRODT,LRSN)<1 ; Quit if Test is NOT a Ref Lab Test
;
; Store ICD codes into BLR REFERENCE LAB ORDER/ACCESSION (#9009026.3) file
NEW DFN,LRDFN,ORDERN
S ORDERN=$$GET1^DIQ(69.01,LRSN_","_LRODT,9.5)
S LRDFN=$$GET1^DIQ(69.01,LRSN_","_LRODT,.01,"I")
S DFN=$$GET1^DIQ(63,LRDFN,.03,"I")
;
S X=$$ORD^BLRRLEDI(ORDERN,DFN)
S ORDIEN=$$FIND1^DIC(9009026.3,,,ORDERN)
Q:ORDIEN<1 ; If order not in 9009026.3, skip
;
F ICDCNT=1:1:$L(ICDSTR,";") D
. S ICDCODE=$P(ICDSTR,";",ICDCNT)
. Q:ICDCODE=".9999"!(ICDCODE="ZZZ.999") ; Don't store "Un-coded" ICDs
. ;
. S ICDIEN=+$$ICDDX^ICDEX(ICDCODE)
. ;
. K FDA,ERRS
. S FDA(9009026.31,"?+1,"_ORDIEN_",",.01)=ICDIEN
. S:$L(F60PTR) FDA(9009026.31,"?+1,"_ORDIEN_",",1)=F60PTR ; IHS/MSC/MKK - LR*5.2*1034
. D UPDATE^DIE(,"FDA",,"ERRS")
;
; Store the Accession number
NEW LRUID
S LRUID=$G(^LR(+$G(LRDFN),$S($L($G(LRSS)):LRSS,1:" "),+$G(LRIDT),"ORU"))
I $L(LRUID) D
. K ERRS,FDA
. S FDA(9009026.33,"?+1,"_ORDIEN_",",.01)=LRUID
. D UPDATE^DIE(,"FDA",,"ERRS")
; ----- END IHS/MSC/MKK - LR*5.2*1034
Q
;
; ----- END IHS/MSC/MKK - LR*5.2*1033
BLRPOC2 ;IHS/MSC/PLS - EHR POC Component support, part 2 ; 13-Oct-2017 14:04 ; MKK
+1 ;;5.2;IHS LABORATORY;**1029,1031,1033,1034,1041**;NOV 01, 1997;Build 23
+2 ;
+3 ; IHS/OIT/MKK
+4 ; Entries from BLRPOC were moved to this routine due to the BLRPOC routine
+5 ; becoming too large (i.e., violated SAC guidelines).
+6 ;
+7 ; ==============================================================
+8 ;
+9 ; ARY("CD")=Collection Date/Time FM Format
+10 ; ARY("ORDTST")=Test IEN^Test Name
+11 ; ARY("TST",n)=Test IEN^Test Name
+12 ; ARY("CM")=Collection Method IEN^Collection Method Name
+13 ; ARY("COL")=Collection Sample IEN^Collection Sample Name
+14 ; ARY("LOC")=Hospital Location (File 44) IEN^Hospital Location Name
+15 ; ARY("PRV")=Provider (File 200) IEN^Provider Name
+16 ; ARY("NOO")=Nature of Order IEN^Nature of Order Name
+17 ; ARY("URG")=Urgency IEN^Urgency Name
+18 ; ARY("SYMP")=Symptom Text^Indication code
+19 ; ARY("RES",n)=Result^Result Flag
+20 ; ARY("CMT",n)=Array of comment text
+21 ; SAVE(DATA,DFN,ARY) ; EP - original SAVE label from BLRPOC
+22 ;
+23 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+24 ; The ARY("SYMP") has been changed to:
+25 ; ARY("SYMP")=SNOMED Descriptive Text^ICD Indication code^SNOMED Concept ID
+26 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+27 ;
SAVER ; EP -
+1 NEW %,BLRDH,BLRGUI,BLRLOG,BLRPCC,BLRQSITE,BLRSTOP,BLRSTOP,BPCACC,BPCCOM
+2 NEW LRAA,LRACC,LRAHEAD,LRAN,LRARY,LRBLOOD,LRCCOM,LRCDT,LRCMT,LRCOM,LRDEFSP
+3 NEW LRDFN,LRDPF,LRDTO,LREAL,LREND,LRFDEFSP,LRFLOC,LRFNODE,LRGCOM,LRI,LRIDIV
+4 NEW LRIDT,LRINI,LRJ,LRLABKY,LRLBLBP,LRLCSIEN,LRLLOC,LRLWC,LRNATURE,LRNG2
+5 NEW LRNG3,LRNG4,LRNG5,LRNT,LRODT,LROLDIV,LROLLOC,LRORDR,LRORDTIM,LRORDTST
+6 NEW LROT,LROUTINE,LRPARAM,LRPCEVSO,LRPLASMA,LRPOVREQ,LRPR,LRPRAC,LRSAMP
+7 NEW LRSB,LRSERUM,LRSN,LRSPEC,LRSPEC0,LRSS,LRTFLG,LRTIEN,LRTRES,LRTSEQ
+8 NEW LRTST,LRUNKNOW,LRURG,LRURINE,LRUSI,LRVF,LRVF,LRVIDO,LRVIDOF,LRWLC,LRWLO
+9 NEW PNLINPNL,PNM,RES,RET,XQY,XQY0,ZTQUEUED
+10 ;
+11 ; SUPPRESS LABEL PRINTING
SET LRNOLABL=""
+12 IF $GET(^LAB(69.9,1,"RO"))=""
SET RES="0^Rollover has never been run. Please contact National Lab User Support."
GOTO END
+13 IF $PIECE($GET(^LAB(69.9,1,"RO")),U,2)
SET RES="0^Accessioning is currently running, please wait a few minutes and try again."
GOTO END
+14 SET RES=0
SET ZTQUEUED=1
SET BLRGUI=1
SET BPCACC=""
+15 SET XQY=$ORDER(^DIC(19,"B","CIAV VUECENTRIC",""))
+16 SET XQY0=$GET(^DIC(19,XQY,0))
+17 SET ARY("CM")="WC"
+18 SET LRORDTST=+$GET(ARY("ORDTST"))
+19 DO ^LRPARAM
+20 ; Force to NO LABELS
SET $PIECE(LRPARAM,U,4)=0
+21 SET LROUTINE=$PIECE(^LAB(69.9,1,3),"^",2)
+22 ;
+23 SET LRSAMP=+$GET(ARY("COL"))
+24 SET LRSPEC=+$PIECE(^LAB(62,LRSAMP,0),U,2)
+25 SET LRDFN=$$GETPAT^BLRPOC(DFN)
+26 ;
+27 IF 'LRDFN
Begin DoDot:1
+28 SET RES="0^Failed to find patient in Lab Data File"
End DoDot:1
GOTO END
+29 ;
+30 ; indicates LRDFN represents a patient
SET LRDPF=2
+31 SET PNM=$$GET1^DIQ(2,DFN,.01)
+32 SET LROT(LRSAMP,LRSPEC,1)=+$GET(ARY("ORDTST"))
+33 SET LRTST=+$GET(ARY("ORDTST"))_U_+$GET(ARY("URG"))
+34 SET LRLWC="WC"
+35 SET LRPRAC=+$GET(ARY("PRV"))
+36 SET LROLLOC=+$GET(ARY("LOC"))
+37 SET LRLLOC=$$GET1^DIQ(44,+LROLLOC,1)
+38 ; note, this has 2 pieces due to the way the data is filed in ^LRORDST
SET LRCDT=$GET(ARY("CD"))_"^"
+39 ; IHS/OIT/MKK - LR*5.2*1029 - Fix if ARY("CD") = just date (no seconds)
SET LRODT=$PIECE($PIECE(LRCDT,"^"),".")
+40 SET LRORDTIM=$PIECE(+LRCDT,".",2)
+41 ; S LRNATURE=$G(ARY("NOO"))
+42 ; BEGIN IHS/MSC/BF - IHS Lab Patch 1026
SET LRNATURE=$GET(ARY("NOO"))_"^99ORN"
+43 SET LRURG=+$GET(ARY("URG"))
+44 SET BPCCOM=""
+45 SET LRORDR=""
+46 ;S LRORDR="P" ; this will make the software error, due to the ,1) node not being defined.
+47 DO NOW^%DTC
SET LRNT=%
+48 ;
+49 DO ORDER^LROW2
+50 ; Create order and accession
DO ^LRORDST
+51 NEW LRSPEC,LRSAMP
+52 ; Accession setup
DO ^LRWLST
+53 SET LRTST=+$GET(ARY("ORDTST"))
+54 ;
+55 ; Using the test data passed in, build the data that will be placed into the LRSB array.
+56 SET LRTSEQ=0
FOR
SET LRTSEQ=$ORDER(ARY("TST",LRTSEQ))
IF 'LRTSEQ
QUIT
Begin DoDot:1
+57 ; Get the individual test ien
+58 SET LRTIEN=+$GET(ARY("TST",LRTSEQ))
IF 'LRTIEN
QUIT
+59 SET LRTRES=$PIECE($GET(ARY("RES",LRTSEQ)),"^")
+60 SET LRTFLG=$PIECE($GET(ARY("RES",LRTSEQ)),"^",2)
+61 ; Get location data from file 60, field 5, then the second piece for the subscript in the data array.
+62 SET LRFLOC=$$GET1^DIQ(60,LRTIEN,5,"E")
+63 SET LRFNODE=$PIECE(LRFLOC,";",2)
+64 SET LRDEFSP=$$GET1^DIQ(62,+$GET(ARY("COL")),2,"I")
+65 ; Now use the pointer to the TOPOGRAPHY FIELD file to locate the appropriate SITE/SPECIMEN from the LABORATORY TEST file (#60)
+66 SET LRSPEC0=$GET(^LAB(60,LRTIEN,1,LRDEFSP,0))
SET LRSPEC0=$TRANSLATE(LRSPEC0,"^","!")
+67 SET LRNG4=$PIECE(LRSPEC0,"!",4)
SET LRNG4=$$REFRES^BLRPOC(LRNG4)
SET $PIECE(LRSPEC0,"!",4)=LRNG4
+68 SET LRNG5=$PIECE(LRSPEC0,"!",5)
SET LRNG5=$$REFRES^BLRPOC(LRNG5)
SET $PIECE(LRSPEC0,"!",5)=LRNG5
+69 SET LRNG2=$PIECE(LRSPEC0,"!",2)
SET LRNG2=$$REFRES^BLRPOC(LRNG2)
SET $PIECE(LRSPEC0,"!",2)=LRNG2
+70 SET LRNG3=$PIECE(LRSPEC0,"!",3)
SET LRNG3=$$REFRES^BLRPOC(LRNG3)
SET $PIECE(LRSPEC0,"!",3)=LRNG3
+71 ;
+72 ; IHS/MSC/MKK - LR*5.2*1031
DO REVAL(LRTRES,.LRTFLG)
+73 ;
+74 SET UCUM=$PIECE(LRSPEC0,"!",7)
IF UCUM=+UCUM
SET UCUM=$PIECE(^BLRUCUM(UCUM,0),U,1)
SET $PIECE(LRSPEC0,"!",7)=UCUM
+75 DO BLDARY^BLRPOC(LRFNODE,LRSPEC0,LRTRES,LRTFLG)
End DoDot:1
+76 ;
+77 SET LRAA=$PIECE($GET(^LAB(60,+$GET(ARY("ORDTST")),8,$GET(DUZ(2)),0)),U,2)
+78 IF LRAA=""
SET RES="0^No Accession area defined for this test."
GOTO END
+79 ;
+80 ;S LRAD=DT
+81 ;S LRAN=+$P(LRACC," ",3)
+82 ; See Heat Ticket # 16352
SET LRAN=+$PIECE($GET(LRACC)," ",3)
+83 IF LRAN<1
SET RES="0^No Accession number defined for this test."
GOTO END
+84 ;
+85 IF $GET(LRLLOC)=""
SET RES="0^Unable to resolve location. Please insure your location has an abbreviation set up."
DO END
QUIT
+86 ;
+87 ; Merge array into LSRB as it is done in LRVRPOC
+88 MERGE LRSB=LRARY
+89 ;
+90 ; Call the test function as is done in LRVRPOC
+91 DO TEST^LRVR1
+92 ;
+93 ; IHS/MSC/MKK - LR*5.2*1031
DO LRHACK31
+94 ;
+95 ; File the result data with the reference ranges in ^LR
+96 FOR LRSB=1:0
SET LRSB=$ORDER(LRSB(LRSB))
IF LRSB<1
QUIT
IF LRSB(LRSB)'=""
SET ^LR(LRDFN,LRSS,LRIDT,LRSB)=LRSB(LRSB)
+97 SET (LRUSI,LRINI)=$$GET1^DIQ(200,$GET(DUZ),1,"E")
+98 ;
+99 ; File the comments with the test results
+100 SET LRCOM=0
FOR
SET LRCOM=$ORDER(ARY("CMT",LRCOM))
IF 'LRCOM
QUIT
Begin DoDot:1
+101 SET LRCMT=$GET(ARY("CMT",LRCOM))
+102 DO FILECOM^LRVR4(LRDFN,LRIDT,LRCMT)
End DoDot:1
+103 ;
+104 ; File Sign/Symptom
+105 ; S FDA(69.03,$O(^LRO(69,LRODT,1,LRSN,2,"B",+ARY("ORDTST"),0))_","_LRSN_","_LRODT_",",9999999.1)=$P($G(ARY("SYMP")),U,1)
+106 ; D FILE^DIE(,"FDA","ERR") K FDA
+107 ; S $P(^LRO(69,LRODT,1,LRSN,2,$O(^LRO(69,LRODT,1,LRSN,2,"B",+ARY("ORDTST"),0)),9999999),U,2)=$P($G(ARY("SYMP")),U,2)
+108 ;
+109 ; IHS/MSC/MKK - LR*5.2*1033
DO SIGNSYMP
+110 ;
+111 ; Verify the entry
+112 DO EXP^LRVER1
+113 SET LRVF=1
+114 DO V11^LRVER3
+115 SET RES="1^Filed"
END ; EP
+1 SET DATA=RES
+2 DO CLEAN^LRVRPOCU
+3 KILL ARY
+4 QUIT
+5 ;
+6 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
LRHACK31 ; EP
+1 ; There appears to be a defect brought about by a change to a VA routine that is included
+2 ; in IHS Lab Patch 1031. The defect causes the Lab Data File's SPECIMEN TYPE field to be null
+3 ; as well as the Accession File's Collection Specimen. This subroutine is a fix, not a solution.
+4 NEW LRAA,LRAD,LRAN,LRAS
+5 ;
+6 ; If ARY("COL") is null, skip
IF $LENGTH($GET(ARY("COL")))<1
QUIT
+7 ;
+8 ; Set the Lab Data File's Speciment Type, if necessary
+9 IF +$PIECE($GET(^LR(LRDFN,"CH",LRIDT,0)),"^",5)<1
Begin DoDot:1
+10 SET $PIECE(^LR(LRDFN,"CH",LRIDT,0),"^",5)=$PIECE($GET(^LAB(62,+$GET(ARY("COL")),0)),"^",2)
End DoDot:1
+11 ;
+12 ; Set Accession file's Collection Specimen, if necessary
+13 SET LRAS=$PIECE($GET(^LR(LRDFN,"CH",LRIDT,0)),"^",6)
+14 DO GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
+15 IF LRAA
IF LRAD
IF LRAN
Begin DoDot:1
+16 IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)),"^",2)=""
Begin DoDot:2
+17 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0),"^",2)=+$GET(ARY("COL"))
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
REVAL(LRTRES,LRTFLG) ; EP - Re-validate abnormal flag
+1 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
+2 ; Qualitative flag for POC tests
+3 NEW QUALFLAG
+4 SET QUALFLAG=0
+5 Begin DoDot:1
+6 NEW LRDL,LRFLG,LRSB,LRSPEC,LRTS,X
+7 SET LRDL=$GET(LRTRES)
+8 SET LRSB=$GET(LRFNODE)
+9 SET LRSPEC=$PIECE($GET(H8),U)
+10 SET LRTS=$GET(LRTIEN)
+11 IF $LENGTH(LRDL)
IF $LENGTH(LRSB)
IF $LENGTH(LRSPEC)
IF $LENGTH(LRTS)
Begin DoDot:2
+12 SET X=$$QUALCHEK^BLRQUALU()
+13 IF $GET(LRFLG)="A*"
SET QUALFLAG=1
SET LRTFLG=$GET(LRFLG)
End DoDot:2
End DoDot:1
+14 IF QUALFLAG
QUIT
+15 ; ----- END IHS/MSC/MKK - LR*5.2*1041
+16 ;
+17 ; Take into account results that begin with ">" or "<"
+18 IF $EXTRACT(LRTRES)=">"
SET LRTRES=$PIECE(LRTRES,">",2)+1
+19 IF $EXTRACT(LRTRES)="<"
SET LRTRES=$PIECE(LRTRES,"<",2)-1
+20 ;
+21 ; Initialize every time
SET LRTFLG=""
+22 IF $LENGTH(LRNG4)&(LRTRES<LRNG4)
SET LRTFLG="L*"
QUIT
+23 IF $LENGTH(LRNG5)&(LRTRES>LRNG5)
SET LRTFLG="H*"
QUIT
+24 IF $LENGTH(LRNG2)&(LRTRES<LRNG2)
SET LRTFLG="L"
QUIT
+25 IF $LENGTH(LRNG3)&(LRTRES>LRNG3)
SET LRTFLG="H"
+26 QUIT
+27 ;
+28 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+29 ;
+30 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
SIGNSYMP ; EP - Sign or Symptom for Incoming POC test
+1 NEW ARYSYMP,ERRS,FDA,ICD,ICDCNT,ICDSTR,IENS,IN,OUT,PROVNARR,SNOMED,STR,VARS
+2 ;
+3 SET PROVNARR=$PIECE($GET(ARY("SYMP")),"^")
+4 SET ICDSTR=$PIECE($GET(ARY("SYMP")),"^",2)
+5 SET SNOMED=$PIECE($GET(ARY("SYMP")),"^",3)
+6 ;
+7 ; Only SNOMED or SNOMED Concept ID received
IF SNOMED=""
Begin DoDot:1
+8 ; SNOMED Concept ID check
SET STR=$$CONC^BSTSAPI(+PROVNARR)
+9 IF $TRANSLATE(STR,"^")=""
Begin DoDot:2
+10 SET OUT="VARS"
SET IN=+PROVNARR
+11 ; SNOMED code check
IF +$$DSCLKP^BSTSAPI(OUT,IN)<1
QUIT
+12 ;
+13 KILL STR
+14 SET $PIECE(STR,"^",3)=+PROVNARR
+15 SET $PIECE(STR,"^",4)=$$TRIM^XLFSTR($PIECE($GET(VARS(1,"FSN","TRM")),"("),"LR"," ")
+16 SET $PIECE(STR,"^",5)=$GET(VARS(1,"ICD",1,"COD"))
End DoDot:2
+17 SET SNOMED=$PIECE(STR,"^",3)
+18 SET PROVNARR=$PIECE(STR,"^",4)
+19 SET ICDSTR=$PIECE(STR,"^",5)
End DoDot:1
+20 ;
+21 ; Skip if nothing to store
IF $LENGTH(PROVNARR)<1&($LENGTH(ICDSTR)<1)&($LENGTH(SNOMED)<1)
QUIT
+22 ;
+23 SET IENS=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",+ARY("ORDTST"),0))_","_LRSN_","_LRODT_","
+24 ;
+25 IF $LENGTH(PROVNARR)
SET FDA(69.03,IENS,9999999.1)=PROVNARR
+26 IF $LENGTH(SNOMED)
SET FDA(69.03,IENS,9999999.2)=SNOMED
+27 ;
+28 IF $DATA(FDA)
DO FILE^DIE(,"FDA","ERRS")
+29 ;
+30 ; Skip if no ICD
IF $LENGTH(ICDSTR)<1
QUIT
+31 ;
+32 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+33 NEW F60PTR
+34 SET F60PTR=$$GET1^DIQ(69.03,IENS,.01,"I")
+35 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+36 ;
+37 FOR ICDCNT=1:1:$LENGTH(ICDSTR,";")
Begin DoDot:1
+38 SET ICD=$PIECE(ICDSTR,";",ICDCNT)
+39 KILL FDA,ERRS
+40 SET FDA(69.05,"?+1,"_IENS,.01)=ICD
+41 DO UPDATE^DIE("EKS","FDA",,"ERRS")
End DoDot:1
+42 ;
+43 ;
+44 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+45 ; Quit if Test is NOT a Ref Lab Test
IF $$REFLABCK^BLRUTIL6(+ARY("ORDTST"),LRODT,LRSN)<1
QUIT
+46 ;
+47 ; Store ICD codes into BLR REFERENCE LAB ORDER/ACCESSION (#9009026.3) file
+48 NEW DFN,LRDFN,ORDERN
+49 SET ORDERN=$$GET1^DIQ(69.01,LRSN_","_LRODT,9.5)
+50 SET LRDFN=$$GET1^DIQ(69.01,LRSN_","_LRODT,.01,"I")
+51 SET DFN=$$GET1^DIQ(63,LRDFN,.03,"I")
+52 ;
+53 SET X=$$ORD^BLRRLEDI(ORDERN,DFN)
+54 SET ORDIEN=$$FIND1^DIC(9009026.3,,,ORDERN)
+55 ; If order not in 9009026.3, skip
IF ORDIEN<1
QUIT
+56 ;
+57 FOR ICDCNT=1:1:$LENGTH(ICDSTR,";")
Begin DoDot:1
+58 SET ICDCODE=$PIECE(ICDSTR,";",ICDCNT)
+59 ; Don't store "Un-coded" ICDs
IF ICDCODE=".9999"!(ICDCODE="ZZZ.999")
QUIT
+60 ;
+61 SET ICDIEN=+$$ICDDX^ICDEX(ICDCODE)
+62 ;
+63 KILL FDA,ERRS
+64 SET FDA(9009026.31,"?+1,"_ORDIEN_",",.01)=ICDIEN
+65 ; IHS/MSC/MKK - LR*5.2*1034
IF $LENGTH(F60PTR)
SET FDA(9009026.31,"?+1,"_ORDIEN_",",1)=F60PTR
+66 DO UPDATE^DIE(,"FDA",,"ERRS")
End DoDot:1
+67 ;
+68 ; Store the Accession number
+69 NEW LRUID
+70 SET LRUID=$GET(^LR(+$GET(LRDFN),$SELECT($LENGTH($GET(LRSS)):LRSS,1:" "),+$GET(LRIDT),"ORU"))
+71 IF $LENGTH(LRUID)
Begin DoDot:1
+72 KILL ERRS,FDA
+73 SET FDA(9009026.33,"?+1,"_ORDIEN_",",.01)=LRUID
+74 DO UPDATE^DIE(,"FDA",,"ERRS")
End DoDot:1
+75 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+76 QUIT
+77 ;
+78 ; ----- END IHS/MSC/MKK - LR*5.2*1033
