Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLRPOC2

BLRPOC2.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ; IHS/OIT/MKK
  1.  ;      Entries from BLRPOC were moved to this routine due to the BLRPOC routine
  1.  ;      becoming too large (i.e., violated SAC guidelines).
  1.  ;
  1.  ; ==============================================================
  1.  ; 
  1.  ; ARY("CD")=Collection Date/Time FM Format
  1.  ; ARY("ORDTST")=Test IEN^Test Name
  1.  ; ARY("TST",n)=Test IEN^Test Name
  1.  ; ARY("CM")=Collection Method IEN^Collection Method Name
  1.  ; ARY("COL")=Collection Sample IEN^Collection Sample Name
  1.  ; ARY("LOC")=Hospital Location (File 44) IEN^Hospital Location Name
  1.  ; ARY("PRV")=Provider (File 200) IEN^Provider Name
  1.  ; ARY("NOO")=Nature of Order IEN^Nature of Order Name
  1.  ; ARY("URG")=Urgency IEN^Urgency Name
  1.  ; ARY("SYMP")=Symptom Text^Indication code
  1.  ; ARY("RES",n)=Result^Result Flag
  1.  ; ARY("CMT",n)=Array of comment text
  1.  ; SAVE(DATA,DFN,ARY) ; EP - original SAVE label from BLRPOC
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
  1.  ;       The ARY("SYMP") has been changed to:
  1.  ;           ARY("SYMP")=SNOMED Descriptive Text^ICD Indication code^SNOMED Concept ID
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1033
  1.  ;
  1. SAVER ; EP - 
  1.  NEW %,BLRDH,BLRGUI,BLRLOG,BLRPCC,BLRQSITE,BLRSTOP,BLRSTOP,BPCACC,BPCCOM
  1.  NEW LRAA,LRACC,LRAHEAD,LRAN,LRARY,LRBLOOD,LRCCOM,LRCDT,LRCMT,LRCOM,LRDEFSP
  1.  NEW LRDFN,LRDPF,LRDTO,LREAL,LREND,LRFDEFSP,LRFLOC,LRFNODE,LRGCOM,LRI,LRIDIV
  1.  NEW LRIDT,LRINI,LRJ,LRLABKY,LRLBLBP,LRLCSIEN,LRLLOC,LRLWC,LRNATURE,LRNG2
  1.  NEW LRNG3,LRNG4,LRNG5,LRNT,LRODT,LROLDIV,LROLLOC,LRORDR,LRORDTIM,LRORDTST
  1.  NEW LROT,LROUTINE,LRPARAM,LRPCEVSO,LRPLASMA,LRPOVREQ,LRPR,LRPRAC,LRSAMP
  1.  NEW LRSB,LRSERUM,LRSN,LRSPEC,LRSPEC0,LRSS,LRTFLG,LRTIEN,LRTRES,LRTSEQ
  1.  NEW LRTST,LRUNKNOW,LRURG,LRURINE,LRUSI,LRVF,LRVF,LRVIDO,LRVIDOF,LRWLC,LRWLO
  1.  NEW PNLINPNL,PNM,RES,RET,XQY,XQY0,ZTQUEUED
  1.  ;
  1.  S LRNOLABL="" ; SUPPRESS LABEL PRINTING
  1.  I $G(^LAB(69.9,1,"RO"))=""  S RES="0^Rollover has never been run. Please contact National Lab User Support." G END
  1.  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
  1.  S RES=0,ZTQUEUED=1,BLRGUI=1,BPCACC=""
  1.  S XQY=$O(^DIC(19,"B","CIAV VUECENTRIC",""))
  1.  S XQY0=$G(^DIC(19,XQY,0))
  1.  S ARY("CM")="WC"
  1.  S LRORDTST=+$G(ARY("ORDTST"))
  1.  D ^LRPARAM
  1.  S $P(LRPARAM,U,4)=0  ; Force to NO LABELS
  1.  S LROUTINE=$P(^LAB(69.9,1,3),"^",2)
  1.  ;
  1.  S LRSAMP=+$G(ARY("COL"))
  1.  S LRSPEC=+$P(^LAB(62,LRSAMP,0),U,2)
  1.  S LRDFN=$$GETPAT^BLRPOC(DFN)
  1.  ;
  1.  I 'LRDFN D  G END
  1.  . S RES="0^Failed to find patient in Lab Data File"
  1.  ;
  1.  S LRDPF=2  ; indicates LRDFN represents a patient
  1.  S PNM=$$GET1^DIQ(2,DFN,.01)
  1.  S LROT(LRSAMP,LRSPEC,1)=+$G(ARY("ORDTST"))
  1.  S LRTST=+$G(ARY("ORDTST"))_U_+$G(ARY("URG"))
  1.  S LRLWC="WC"
  1.  S LRPRAC=+$G(ARY("PRV"))
  1.  S LROLLOC=+$G(ARY("LOC"))
  1.  S LRLLOC=$$GET1^DIQ(44,+LROLLOC,1)
  1.  S LRCDT=$G(ARY("CD"))_"^" ; note, this has 2 pieces due to the way the data is filed in ^LRORDST
  1.  S LRODT=$P($P(LRCDT,"^"),".")    ; IHS/OIT/MKK - LR*5.2*1029 - Fix if ARY("CD") = just date (no seconds)
  1.  S LRORDTIM=$P(+LRCDT,".",2)
  1.  ; S LRNATURE=$G(ARY("NOO"))
  1.  S LRNATURE=$G(ARY("NOO"))_"^99ORN"    ; BEGIN IHS/MSC/BF - IHS Lab Patch 1026
  1.  S LRURG=+$G(ARY("URG"))
  1.  S BPCCOM=""
  1.  S LRORDR=""
  1.  ;S LRORDR="P" ; this will make the software error, due to the ,1) node not being defined.
  1.  D NOW^%DTC S LRNT=%
  1.  ;
  1.  D ORDER^LROW2
  1.  D ^LRORDST  ; Create order and accession
  1.  N LRSPEC,LRSAMP
  1.  D ^LRWLST   ; Accession setup
  1.  S LRTST=+$G(ARY("ORDTST"))
  1.  ;
  1.  ; Using the test data passed in, build the data that will be placed into the LRSB array.
  1.  S LRTSEQ=0 F  S LRTSEQ=$O(ARY("TST",LRTSEQ)) Q:'LRTSEQ  D
  1.  .; Get the individual test ien
  1.  .S LRTIEN=+$G(ARY("TST",LRTSEQ)) Q:'LRTIEN
  1.  .S LRTRES=$P($G(ARY("RES",LRTSEQ)),"^")
  1.  .S LRTFLG=$P($G(ARY("RES",LRTSEQ)),"^",2)
  1.  .; Get location data from file 60, field 5, then the second piece for the subscript in the data array.
  1.  .S LRFLOC=$$GET1^DIQ(60,LRTIEN,5,"E")
  1.  .S LRFNODE=$P(LRFLOC,";",2)
  1.  .S LRDEFSP=$$GET1^DIQ(62,+$G(ARY("COL")),2,"I")
  1.  .; Now use the pointer to the TOPOGRAPHY FIELD file to locate the appropriate SITE/SPECIMEN from the LABORATORY TEST file (#60)
  1.  .S LRSPEC0=$G(^LAB(60,LRTIEN,1,LRDEFSP,0)),LRSPEC0=$TR(LRSPEC0,"^","!")
  1.  .S LRNG4=$P(LRSPEC0,"!",4),LRNG4=$$REFRES^BLRPOC(LRNG4),$P(LRSPEC0,"!",4)=LRNG4
  1.  .S LRNG5=$P(LRSPEC0,"!",5),LRNG5=$$REFRES^BLRPOC(LRNG5),$P(LRSPEC0,"!",5)=LRNG5
  1.  .S LRNG2=$P(LRSPEC0,"!",2),LRNG2=$$REFRES^BLRPOC(LRNG2),$P(LRSPEC0,"!",2)=LRNG2
  1.  .S LRNG3=$P(LRSPEC0,"!",3),LRNG3=$$REFRES^BLRPOC(LRNG3),$P(LRSPEC0,"!",3)=LRNG3
  1.  .;
  1.  .D REVAL(LRTRES,.LRTFLG)         ; IHS/MSC/MKK - LR*5.2*1031
  1.  .;
  1.  .S UCUM=$P(LRSPEC0,"!",7) I UCUM=+UCUM S UCUM=$P(^BLRUCUM(UCUM,0),U,1),$P(LRSPEC0,"!",7)=UCUM
  1.  .D BLDARY^BLRPOC(LRFNODE,LRSPEC0,LRTRES,LRTFLG)
  1.  ;
  1.  S LRAA=$P($G(^LAB(60,+$G(ARY("ORDTST")),8,$G(DUZ(2)),0)),U,2)
  1.  I LRAA="" S RES="0^No Accession area defined for this test." G END
  1.  ;
  1.  ;S LRAD=DT
  1.  ;S LRAN=+$P(LRACC," ",3)
  1.  S LRAN=+$P($G(LRACC)," ",3)   ; See Heat Ticket # 16352
  1.  I LRAN<1 S RES="0^No Accession number defined for this test." G END
  1.  ;
  1.  I $G(LRLLOC)="" S RES="0^Unable to resolve location. Please insure your location has an abbreviation set up." D END Q
  1.  ;
  1.  ; Merge array into LSRB as it is done in LRVRPOC
  1.  M LRSB=LRARY
  1.  ;
  1.  ; Call the test function as is done in LRVRPOC
  1.  D TEST^LRVR1
  1.  ;
  1.  D LRHACK31        ; IHS/MSC/MKK - LR*5.2*1031
  1.  ;
  1.  ; File the result data with the reference ranges in ^LR
  1.  F LRSB=1:0 S LRSB=$O(LRSB(LRSB)) Q:LRSB<1  S:LRSB(LRSB)'="" ^LR(LRDFN,LRSS,LRIDT,LRSB)=LRSB(LRSB)
  1.  S (LRUSI,LRINI)=$$GET1^DIQ(200,$G(DUZ),1,"E")
  1.  ;
  1.  ; File the comments with the test results
  1.  S LRCOM=0 F  S LRCOM=$O(ARY("CMT",LRCOM)) Q:'LRCOM  D
  1.  .S LRCMT=$G(ARY("CMT",LRCOM))
  1.  .D FILECOM^LRVR4(LRDFN,LRIDT,LRCMT)
  1.  ;
  1.  ; File Sign/Symptom
  1.  ; 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)
  1.  ; D FILE^DIE(,"FDA","ERR") K FDA
  1.  ; 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)
  1.  ;
  1.  D SIGNSYMP   ; IHS/MSC/MKK - LR*5.2*1033
  1.  ;
  1.  ; Verify the entry
  1.  D EXP^LRVER1
  1.  S LRVF=1
  1.  D V11^LRVER3
  1.  S RES="1^Filed"
  1. END ; EP
  1.  S DATA=RES
  1.  D CLEAN^LRVRPOCU
  1.  K ARY
  1.  Q
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
  1. LRHACK31 ; EP
  1.  ; There appears to be a defect brought about by a change to a VA routine that is included
  1.  ; in IHS Lab Patch 1031.  The defect causes the Lab Data File's SPECIMEN TYPE field to be null
  1.  ; as well as the Accession File's Collection Specimen.  This subroutine is a fix, not a solution.
  1.  NEW LRAA,LRAD,LRAN,LRAS
  1.  ;
  1.  Q:$L($G(ARY("COL")))<1      ; If ARY("COL") is null, skip
  1.  ;
  1.  ; Set the Lab Data File's Speciment Type, if necessary
  1.  I +$P($G(^LR(LRDFN,"CH",LRIDT,0)),"^",5)<1 D
  1.  . S $P(^LR(LRDFN,"CH",LRIDT,0),"^",5)=$P($G(^LAB(62,+$G(ARY("COL")),0)),"^",2)
  1.   ;
  1.  ; Set Accession file's Collection Specimen, if necessary
  1.  S LRAS=$P($G(^LR(LRDFN,"CH",LRIDT,0)),"^",6)
  1.  D GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
  1.  I LRAA,LRAD,LRAN  D
  1.  . I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)),"^",2)="" D
  1.  .. S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0),"^",2)=+$G(ARY("COL"))
  1.  Q
  1.  ;
  1. REVAL(LRTRES,LRTFLG) ; EP - Re-validate abnormal flag
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
  1.  ; Qualitative flag for POC tests
  1.  NEW QUALFLAG
  1.  S QUALFLAG=0
  1.  D
  1.  . NEW LRDL,LRFLG,LRSB,LRSPEC,LRTS,X
  1.  . S LRDL=$G(LRTRES)
  1.  . S LRSB=$G(LRFNODE)
  1.  . S LRSPEC=$P($G(H8),U)
  1.  . S LRTS=$G(LRTIEN)
  1.  . I $L(LRDL),$L(LRSB),$L(LRSPEC),$L(LRTS) D
  1.  .. S X=$$QUALCHEK^BLRQUALU()
  1.  .. I $G(LRFLG)="A*" S QUALFLAG=1,LRTFLG=$G(LRFLG)
  1.  Q:QUALFLAG
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1041
  1.  ;
  1.  ; Take into account results that begin with ">" or "<"
  1.  S:$E(LRTRES)=">" LRTRES=$P(LRTRES,">",2)+1
  1.  S:$E(LRTRES)="<" LRTRES=$P(LRTRES,"<",2)-1
  1.  ;
  1.  S LRTFLG=""                                  ; Initialize every time
  1.  I $L(LRNG4)&(LRTRES<LRNG4) S LRTFLG="L*"  Q
  1.  I $L(LRNG5)&(LRTRES>LRNG5) S LRTFLG="H*"  Q
  1.  I $L(LRNG2)&(LRTRES<LRNG2) S LRTFLG="L"  Q
  1.  I $L(LRNG3)&(LRTRES>LRNG3) S LRTFLG="H"
  1.  Q
  1.  ;
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1031
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
  1. SIGNSYMP ; EP - Sign or Symptom for Incoming POC test
  1.  NEW ARYSYMP,ERRS,FDA,ICD,ICDCNT,ICDSTR,IENS,IN,OUT,PROVNARR,SNOMED,STR,VARS
  1.  ;
  1.  S PROVNARR=$P($G(ARY("SYMP")),"^")
  1.  S ICDSTR=$P($G(ARY("SYMP")),"^",2)
  1.  S SNOMED=$P($G(ARY("SYMP")),"^",3)
  1.  ;
  1.  I SNOMED="" D  ; Only SNOMED or SNOMED Concept ID received
  1.  . S STR=$$CONC^BSTSAPI(+PROVNARR)     ; SNOMED Concept ID check
  1.  . I $TR(STR,"^")="" D
  1.  .. S OUT="VARS",IN=+PROVNARR
  1.  .. Q:+$$DSCLKP^BSTSAPI(OUT,IN)<1      ; SNOMED code check
  1.  .. ;
  1.  .. K STR
  1.  .. S $P(STR,"^",3)=+PROVNARR
  1.  .. S $P(STR,"^",4)=$$TRIM^XLFSTR($P($G(VARS(1,"FSN","TRM")),"("),"LR"," ")
  1.  .. S $P(STR,"^",5)=$G(VARS(1,"ICD",1,"COD"))
  1.  . S SNOMED=$P(STR,"^",3)
  1.  . S PROVNARR=$P(STR,"^",4)
  1.  . S ICDSTR=$P(STR,"^",5)
  1.  ;
  1.  Q:$L(PROVNARR)<1&($L(ICDSTR)<1)&($L(SNOMED)<1)    ; Skip if nothing to store
  1.  ;
  1.  S IENS=$O(^LRO(69,LRODT,1,LRSN,2,"B",+ARY("ORDTST"),0))_","_LRSN_","_LRODT_","
  1.  ;
  1.  S:$L(PROVNARR) FDA(69.03,IENS,9999999.1)=PROVNARR
  1.  S:$L(SNOMED) FDA(69.03,IENS,9999999.2)=SNOMED
  1.  ;
  1.  D:$D(FDA) FILE^DIE(,"FDA","ERRS")
  1.  ;
  1.  Q:$L(ICDSTR)<1      ; Skip if no ICD
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
  1.  NEW F60PTR
  1.  S F60PTR=$$GET1^DIQ(69.03,IENS,.01,"I")
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1034
  1.  ;
  1.  F ICDCNT=1:1:$L(ICDSTR,";")  D
  1.  . S ICD=$P(ICDSTR,";",ICDCNT)
  1.  . K FDA,ERRS
  1.  . S FDA(69.05,"?+1,"_IENS,.01)=ICD
  1.  . D UPDATE^DIE("EKS","FDA",,"ERRS")
  1.  ;
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
  1.  Q:$$REFLABCK^BLRUTIL6(+ARY("ORDTST"),LRODT,LRSN)<1   ; Quit if Test is NOT a Ref Lab Test
  1.  ;
  1.  ; Store ICD codes into BLR REFERENCE LAB ORDER/ACCESSION (#9009026.3) file
  1.  NEW DFN,LRDFN,ORDERN
  1.  S ORDERN=$$GET1^DIQ(69.01,LRSN_","_LRODT,9.5)
  1.  S LRDFN=$$GET1^DIQ(69.01,LRSN_","_LRODT,.01,"I")
  1.  S DFN=$$GET1^DIQ(63,LRDFN,.03,"I")
  1.  ;
  1.  S X=$$ORD^BLRRLEDI(ORDERN,DFN)
  1.  S ORDIEN=$$FIND1^DIC(9009026.3,,,ORDERN)
  1.  Q:ORDIEN<1     ; If order not in 9009026.3, skip
  1.  ;
  1.  F ICDCNT=1:1:$L(ICDSTR,";")  D
  1.  . S ICDCODE=$P(ICDSTR,";",ICDCNT)
  1.  . Q:ICDCODE=".9999"!(ICDCODE="ZZZ.999") ; Don't store "Un-coded" ICDs
  1.  . ;
  1.  . S ICDIEN=+$$ICDDX^ICDEX(ICDCODE)
  1.  . ;
  1.  . K FDA,ERRS
  1.  . S FDA(9009026.31,"?+1,"_ORDIEN_",",.01)=ICDIEN
  1.  . S:$L(F60PTR) FDA(9009026.31,"?+1,"_ORDIEN_",",1)=F60PTR      ; IHS/MSC/MKK - LR*5.2*1034
  1.  . D UPDATE^DIE(,"FDA",,"ERRS")
  1.  ;
  1.  ; Store the Accession number
  1.  NEW LRUID
  1.  S LRUID=$G(^LR(+$G(LRDFN),$S($L($G(LRSS)):LRSS,1:" "),+$G(LRIDT),"ORU"))
  1.  I $L(LRUID) D
  1.  . K ERRS,FDA
  1.  . S FDA(9009026.33,"?+1,"_ORDIEN_",",.01)=LRUID
  1.  . D UPDATE^DIE(,"FDA",,"ERRS")
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1034
  1.  Q
  1.  ;
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1033