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