- BLRRLCOM ; cmi/anch/maw - BLR Get Order Comments for HL7 Order Message ;01 MAY 2013 1300;SAT
- ;;5.2;LR;**1021,1030,1031**;Nov 1, 1997
- ;;1.0;BLR REFERENCE LAB;;MAR 14, 2005
- ;
- ;this routine will look up the test ien, ref lab and ask
- ;the appropriate order comments, it will then return an array
- ;with the appropriate result code and value to be stuffed into
- ;the order's OBX segment
- ;
- COM(TIEN,LEDI) ; EP -- check to see if there are any comments
- I $G(BLRPHASE)'="A",'$G(LEDI) Q "" ;added check of LEDI for backward compatibility
- S BLRCRL=$P($G(^BLRSITE(DUZ(2),"RL")),U)
- I '$G(BLRCRL) Q "No Reference Lab Defined"
- S BLRRIEN=$O(^BLRRL("ALP",TIEN,BLRCRL,0))
- I '$G(BLRRIEN) Q "No Matching Reference Lab Test"
- I '$D(^BLRRL(BLRCRL,1,BLRRIEN,1,0)) Q "No comments for test"
- N TN S TN=$P($G(^LAB(60,TIEN,0)),U,1)
- S BLRCN=0
- NEW NOWTIME
- S NOWTIME=$H
- S ^XTMP("BLRRLCOM",NOWTIME,"001 TIEN:")=$G(TIEN)
- S ^XTMP("BLRRLCOM",NOWTIME,"002 LEDI:")=$G(LEDI)
- S ^XTMP("BLRRLCOM",NOWTIME,"003 BLRCRL:")=$G(BLRCRL)
- S ^XTMP("BLRRLCOM",NOWTIME,"004 BLRRIEN:")=$G(BLRRIEN)
- ;
- S BLRRC=0 F S BLRRC=$O(^BLRRL(BLRCRL,1,BLRRIEN,1,BLRRC)) Q:'BLRRC D
- . S BLRCN=BLRCN+1
- . S BLRTPC=$G(^BLRRL(BLRCRL,1,BLRRIEN,1,BLRRC,0))
- . S BLRTP=$O(^BLRRL("BRES",BLRTPC,BLRCRL,0))
- . S ^XTMP("BLRRLCOM",NOWTIME,"004 BLRRC:")=$G(BLRRC)
- . S ^XTMP("BLRRLCOM",NOWTIME,"004 BLRCN:")=$G(BLRCN)
- . S ^XTMP("BLRRLCOM",NOWTIME,"005 BLRTP:")=$G(BLRTP)
- . Q:'BLRTP
- . S BLRRTI=$P($G(^BLRRL(BLRCRL,1,BLRTP,0)),U,7)
- . S BLRRSC=$P($G(^BLRRL(BLRCRL,1,BLRTP,0)),U,4)
- . S ^XTMP("BLRRLCOM",NOWTIME,"006 BLRCN:",BLRCN,"01 BLRRTI:")=$G(BLRRTI)
- . S ^XTMP("BLRRLCOM",NOWTIME,"006 BLRCN:",BLRCN,"02 BLRRSC:")=$G(BLRRSC)
- . ; S BLRRES=$$ASK(BLRRTI,BLRTP,BLRRSC)
- . ; 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
- . 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
- . S:'+$G(BLRAGUI) BLRRES=$$ASK(BLRRTI,BLRTP,BLRRSC) ; LR*5.2*1031 -- IHS/MSC/SAT
- . S ^XTMP("BLRRLCOM",NOWTIME,"006 BLRCN:",BLRCN,"03 BLRRES:")=$G(BLRRES)
- . I $G(BLRRES)]"" S BLRRLC(TIEN,BLRCN)=$G(BLRRES)
- Q $G(BLRRLC)
- ;
- ASK(RTI,RTP,RSC) ; EP -- ask the comment question and get the result
- ; RTI = Prompt
- ; RTP =
- ; RSC = Result code
- N DIR
- S DIR(0)="FO",DIR("A")=RTI
- D ^DIR
- S BLRANS=Y
- Q RSC_U_RTI_U_BLRANS
- ;
- GUI(BLRAOE,TIEN,RTI,RSC,TN) ;
- N BLRANS,BLRCNT
- Q:$G(TIEN)=""
- S BLRANS=""
- S BLRRET=""
- ;BLRAOE = <question prompt> ^ <result code> ^ <free-text answer> ^ <test name>
- F BLRCNT=1:1:$L(BLRAOE,"|") D Q:BLRANS'=""
- .I $P($P(BLRAOE,"|",BLRCNT),U,4)=TN D
- ..I $P($P(BLRAOE,"|",BLRCNT),U,1)=RTI D
- ...S BLRANS=$P($P(BLRAOE,"|",BLRCNT),U,3)
- Q RSC_U_RTI_U_BLRANS
- 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
- +2 ;;1.0;BLR REFERENCE LAB;;MAR 14, 2005
- +3 ;
- +4 ;this routine will look up the test ien, ref lab and ask
- +5 ;the appropriate order comments, it will then return an array
- +6 ;with the appropriate result code and value to be stuffed into
- +7 ;the order's OBX segment
- +8 ;
- COM(TIEN,LEDI) ; EP -- check to see if there are any comments
- +1 ;added check of LEDI for backward compatibility
- IF $GET(BLRPHASE)'="A"
- IF '$GET(LEDI)
- QUIT ""
- +2 SET BLRCRL=$PIECE($GET(^BLRSITE(DUZ(2),"RL")),U)
- +3 IF '$GET(BLRCRL)
- QUIT "No Reference Lab Defined"
- +4 SET BLRRIEN=$ORDER(^BLRRL("ALP",TIEN,BLRCRL,0))
- +5 IF '$GET(BLRRIEN)
- QUIT "No Matching Reference Lab Test"
- +6 IF '$DATA(^BLRRL(BLRCRL,1,BLRRIEN,1,0))
- QUIT "No comments for test"
- +7 NEW TN
- SET TN=$PIECE($GET(^LAB(60,TIEN,0)),U,1)
- +8 SET BLRCN=0
- +9 NEW NOWTIME
- +10 SET NOWTIME=$HOROLOG
- +11 SET ^XTMP("BLRRLCOM",NOWTIME,"001 TIEN:")=$GET(TIEN)
- +12 SET ^XTMP("BLRRLCOM",NOWTIME,"002 LEDI:")=$GET(LEDI)
- +13 SET ^XTMP("BLRRLCOM",NOWTIME,"003 BLRCRL:")=$GET(BLRCRL)
- +14 SET ^XTMP("BLRRLCOM",NOWTIME,"004 BLRRIEN:")=$GET(BLRRIEN)
- +15 ;
- +16 SET BLRRC=0
- FOR
- SET BLRRC=$ORDER(^BLRRL(BLRCRL,1,BLRRIEN,1,BLRRC))
- IF 'BLRRC
- QUIT
- Begin DoDot:1
- +17 SET BLRCN=BLRCN+1
- +18 SET BLRTPC=$GET(^BLRRL(BLRCRL,1,BLRRIEN,1,BLRRC,0))
- +19 SET BLRTP=$ORDER(^BLRRL("BRES",BLRTPC,BLRCRL,0))
- +20 SET ^XTMP("BLRRLCOM",NOWTIME,"004 BLRRC:")=$GET(BLRRC)
- +21 SET ^XTMP("BLRRLCOM",NOWTIME,"004 BLRCN:")=$GET(BLRCN)
- +22 SET ^XTMP("BLRRLCOM",NOWTIME,"005 BLRTP:")=$GET(BLRTP)
- +23 IF 'BLRTP
- QUIT
- +24 SET BLRRTI=$PIECE($GET(^BLRRL(BLRCRL,1,BLRTP,0)),U,7)
- +25 SET BLRRSC=$PIECE($GET(^BLRRL(BLRCRL,1,BLRTP,0)),U,4)
- +26 SET ^XTMP("BLRRLCOM",NOWTIME,"006 BLRCN:",BLRCN,"01 BLRRTI:")=$GET(BLRRTI)
- +27 SET ^XTMP("BLRRLCOM",NOWTIME,"006 BLRCN:",BLRCN,"02 BLRRSC:")=$GET(BLRRSC)
- +28 ; S BLRRES=$$ASK(BLRRTI,BLRTP,BLRRSC)
- +29 ; 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
- +30 ; 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
- IF +$GET(BLRAGUI)
- SET BLRRES=$$GUI(BLRAOE,TIEN,BLRRTI,BLRRSC,TN)
- +31 ; LR*5.2*1031 -- IHS/MSC/SAT
- IF '+$GET(BLRAGUI)
- SET BLRRES=$$ASK(BLRRTI,BLRTP,BLRRSC)
- +32 SET ^XTMP("BLRRLCOM",NOWTIME,"006 BLRCN:",BLRCN,"03 BLRRES:")=$GET(BLRRES)
- +33 IF $GET(BLRRES)]""
- SET BLRRLC(TIEN,BLRCN)=$GET(BLRRES)
- End DoDot:1
- +34 QUIT $GET(BLRRLC)
- +35 ;
- ASK(RTI,RTP,RSC) ; EP -- ask the comment question and get the result
- +1 ; RTI = Prompt
- +2 ; RTP =
- +3 ; RSC = Result code
- +4 NEW DIR
- +5 SET DIR(0)="FO"
- SET DIR("A")=RTI
- +6 DO ^DIR
- +7 SET BLRANS=Y
- +8 QUIT RSC_U_RTI_U_BLRANS
- +9 ;
- GUI(BLRAOE,TIEN,RTI,RSC,TN) ;
- +1 NEW BLRANS,BLRCNT
- +2 IF $GET(TIEN)=""
- QUIT
- +3 SET BLRANS=""
- +4 SET BLRRET=""
- +5 ;BLRAOE = <question prompt> ^ <result code> ^ <free-text answer> ^ <test name>
- +6 FOR BLRCNT=1:1:$LENGTH(BLRAOE,"|")
- Begin DoDot:1
- +7 IF $PIECE($PIECE(BLRAOE,"|",BLRCNT),U,4)=TN
- Begin DoDot:2
- +8 IF $PIECE($PIECE(BLRAOE,"|",BLRCNT),U,1)=RTI
- Begin DoDot:3
- +9 SET BLRANS=$PIECE($PIECE(BLRAOE,"|",BLRCNT),U,3)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- IF BLRANS'=""
- QUIT
- +10 QUIT RSC_U_RTI_U_BLRANS