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

BLRRLCOM.m

Go to the documentation of this file. 
  1. BLRRLCOM ; cmi/anch/maw - BLR Get Order Comments for HL7 Order Message ;01 MAY 2013  1300;SAT
  1.  ;;5.2;LR;**1021,1030,1031**;Nov 1, 1997
  1.  ;;1.0;BLR REFERENCE LAB;;MAR 14, 2005
  1.  ;
  1.  ;this routine will look up the test ien, ref lab and ask
  1.  ;the appropriate order comments, it will then return an array
  1.  ;with the appropriate result code and value to be stuffed into
  1.  ;the order's OBX segment
  1.  ;
  1. COM(TIEN,LEDI)          ; EP -- check to see if there are any comments
  1.  I $G(BLRPHASE)'="A",'$G(LEDI) Q ""  ;added check of LEDI for backward compatibility
  1.  S BLRCRL=$P($G(^BLRSITE(DUZ(2),"RL")),U)
  1.  I '$G(BLRCRL) Q "No Reference Lab Defined"
  1.  S BLRRIEN=$O(^BLRRL("ALP",TIEN,BLRCRL,0))
  1.  I '$G(BLRRIEN) Q "No Matching Reference Lab Test"
  1.  I '$D(^BLRRL(BLRCRL,1,BLRRIEN,1,0)) Q "No comments for test"
  1.  N TN S TN=$P($G(^LAB(60,TIEN,0)),U,1)
  1.  S BLRCN=0
  1.  NEW NOWTIME
  1.  S NOWTIME=$H
  1.  S ^XTMP("BLRRLCOM",NOWTIME,"001 TIEN:")=$G(TIEN)
  1.  S ^XTMP("BLRRLCOM",NOWTIME,"002 LEDI:")=$G(LEDI)
  1.  S ^XTMP("BLRRLCOM",NOWTIME,"003 BLRCRL:")=$G(BLRCRL)
  1.  S ^XTMP("BLRRLCOM",NOWTIME,"004 BLRRIEN:")=$G(BLRRIEN)
  1.  ; 
  1.  S BLRRC=0 F  S BLRRC=$O(^BLRRL(BLRCRL,1,BLRRIEN,1,BLRRC)) Q:'BLRRC  D
  1.  . S BLRCN=BLRCN+1
  1.  . S BLRTPC=$G(^BLRRL(BLRCRL,1,BLRRIEN,1,BLRRC,0))
  1.  . S BLRTP=$O(^BLRRL("BRES",BLRTPC,BLRCRL,0))
  1.  . S ^XTMP("BLRRLCOM",NOWTIME,"004 BLRRC:")=$G(BLRRC)
  1.  . S ^XTMP("BLRRLCOM",NOWTIME,"004 BLRCN:")=$G(BLRCN)
  1.  . S ^XTMP("BLRRLCOM",NOWTIME,"005 BLRTP:")=$G(BLRTP)
  1.  . Q:'BLRTP
  1.  . S BLRRTI=$P($G(^BLRRL(BLRCRL,1,BLRTP,0)),U,7)
  1.  . S BLRRSC=$P($G(^BLRRL(BLRCRL,1,BLRTP,0)),U,4)
  1.  . S ^XTMP("BLRRLCOM",NOWTIME,"006 BLRCN:",BLRCN,"01 BLRRTI:")=$G(BLRRTI)
  1.  . S ^XTMP("BLRRLCOM",NOWTIME,"006 BLRCN:",BLRCN,"02 BLRRSC:")=$G(BLRRSC)
  1.  . ; S BLRRES=$$ASK(BLRRTI,BLRTP,BLRRSC)
  1.  . ; S BLRRES=$S(+$G(ORWCLVER):BLRRSC_U_BLRRTI_U,1:$$ASK(BLRRTI,BLRTP,BLRRSC))   ; LR*5.2*1031 -- IHS/MSC/MKK - if LAB ACCESSIONING GUI, then DO NOT ask Ref Lab AOE questions: only store the AOE questions
  1.  . S:+$G(BLRAGUI) BLRRES=$$GUI(BLRAOE,TIEN,BLRRTI,BLRRSC,TN)   ; LR*5.2*1031 -- IHS/MSC/SAT - if LAB ACCESSIONING GUI, then DO NOT ask Ref Lab AOE questions: only store the AOE questions and passed in answers
  1.  . S:'+$G(BLRAGUI) BLRRES=$$ASK(BLRRTI,BLRTP,BLRRSC)         ; LR*5.2*1031 -- IHS/MSC/SAT
  1.  . S ^XTMP("BLRRLCOM",NOWTIME,"006 BLRCN:",BLRCN,"03 BLRRES:")=$G(BLRRES)
  1.  . I $G(BLRRES)]"" S BLRRLC(TIEN,BLRCN)=$G(BLRRES)
  1.  Q $G(BLRRLC)
  1.  ;
  1. ASK(RTI,RTP,RSC)       ; EP -- ask the comment question and get the result
  1.  ; RTI = Prompt
  1.  ; RTP = 
  1.  ; RSC = Result code
  1.  N DIR
  1.  S DIR(0)="FO",DIR("A")=RTI
  1.  D ^DIR
  1.  S BLRANS=Y
  1.  Q RSC_U_RTI_U_BLRANS
  1.  ;
  1. GUI(BLRAOE,TIEN,RTI,RSC,TN) ;
  1.  N BLRANS,BLRCNT
  1.  Q:$G(TIEN)=""
  1.  S BLRANS=""
  1.  S BLRRET=""
  1.  ;BLRAOE = <question prompt> ^ <result code> ^ <free-text answer> ^ <test name>
  1.  F BLRCNT=1:1:$L(BLRAOE,"|") D  Q:BLRANS'=""
  1.  .I $P($P(BLRAOE,"|",BLRCNT),U,4)=TN D
  1.  ..I $P($P(BLRAOE,"|",BLRCNT),U,1)=RTI D
  1.  ...S BLRANS=$P($P(BLRAOE,"|",BLRCNT),U,3)
  1.  Q RSC_U_RTI_U_BLRANS