BLRRLEVT ;cmi/anch/maw - BLR Reference Lab Event ; 13-Oct-2017 14:04 ; MAW
;;5.2;IHS LABORATORY;**1027,1030,1031,1033,1034,1035,1036,1039,1041**;NOV 01, 1997;Build 23
;
Q
;
LEDI ;-- LEDI III insurance stuff
N BLRA,BLRC,BLRB
K BLRRLC
S BLRLEDI=1
S BLRTS=$S(+$G(LRTS):+LRTS,$G(LRTSTS):+LRTSTS,1:+$G(LRTSORU))
; ----- BEGIN IHS/CMI/MAW - LR*5.2*1031
;ihs/cmi/maw 11/15/2011 added the following for ehr ordering
Q:'$G(LROLLOC)
Q:'$P($G(^SC(LROLLOC,0)),U,4)
S BLRALTDZ=$S($P($G(^SC(LROLLOC,0)),U,4):$P($G(^SC(LROLLOC,0)),U,4),1:DUZ(2))
Q:'+$G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL"))
S LRDUZ(2)=BLRALTDZ
; ----- END IHS/CMI/MAW - LR*5.2*1031
;I BLRPHASE="O" D ;cmi/maw 5/30/2007 added for institution entry of file 44 so that it gets correct accession area from file 60 otherwise it gets duz(2)
;. Q:'$$SENDOUT(BLRALTDZ,BLRTS)
;. I '$G(BLRO) S BLRO=$$ORD^BLRRLEDI(LRORD,DFN)
;. Q:'$G(BLRO)
;. I $G(BLRTS) D LEDIAAA
;. Q:$G(BLRDXS)
;. ; ihs/cmi/maw patch 1034 we no longer want to ask DX at order time
;. I $P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)="T" D DX^BLRRLEDI(LRORD)
;. K BLRO,BLRRLC
Q:BLRPHASE'="A" ;quit if not an accession
S BLRRL("RL")=+$G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")) ;ref lab site maw modified 5/29/2007
Q:'BLRRL("RL")
Q:'$$NOMAP(BLRRL("RL"),+$G(BLRTS),$G(LROLLOC)) ;ihs/cmi/maw 07/15/2015 p1035 maintenance dont proceed if not a mapped test
;Q:'$$SENDOUT($G(BLRALTDZ),$G(BLRTS)) ; IHS/MSC/MKK - LR*5.2*1031 -- Possible null variable(s)
S BLRO=$O(^BLRRLO("B",LRORD,0))
I $G(BLROPT)="ADDCOL",'+$G(LRQUIET) D
. ;ihs/cmi/maw 12/30/2014 p1034 for lab collect reference lab
. ;we need to reset the order number here
. N BLRNORD,BLRNORDI
. S BLRNORDI=$O(^BLRRLO("ACC",LRUID,0))
. I BLRNORDI S BLRNORD=$P($G(^BLRRLO(BLRNORDI,0)),U)
. I '$G(BLRNORD) S BLRNORD=LRORD
. S BLRORDLC(BLRNORD)=""
. D PRTLC^BLRRLEVN(BLRNORD,LRUID,DFN,LRLLOC,LRODT,LRPRAC,LRTSTS)
. S BLRLCLNT(BLRNORD)=1
. S LRORD=BLRNORD
I '$G(BLRO) S BLRO=$$ORD^BLRRLEDI(LRORD,DFN)
S BLRA=$$ACC^BLRRLEDI(LRUID,LRORD,DFN,LRCDT)
Q:'BLRA
I $G(BLRTS) D LEDIAAA ;ihs/cmi/maw p1034
I '$G(BLRASFLG) S BLRC=$$CLIENT^BLRRLEDI(LRORD,LRUID)
S BLRASFLG=1
;I $P($G(^BLRRLO(BLRO,4,0)),U,4) D SETAO(BLRO),LEDIAAA
K BLRRLC
;I $O(^BLRRLO(BLRO,4,"B",BLRTS,0)) D SETAO(BLRO,BLRTS),LEDIAAA
S BLRB=$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)
I '+$G(BLRAGUI),$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)="T" D
. K BLRDXS,BLRDFLG
. D DX^BLRRLEDI(LRORD)
I '+$G(BLRAGUI),'$G(BLRINS) D BILL^BLRRLEDI(BLRB,LRORD,LRUID,LRCDT)
I $G(BLRAGUI) I "CTP"[$G(BLRBT) S BLRRL("BILL TYPE")=BLRBT,BLRINS=1 S BT=$$BTP^BLRRLEDI(LRORD,BLRBT)
K BLRO,BLRRLC
Q
;
SETAO(RO,TS) ;-- setup the ask at order array from whats in the BLRRLO global
N ADA,DATA,TST,QUES,ANS,RSC
K BLRRLC
S ADA=0 F S ADA=$O(^BLRRLO(RO,4,"B",TS,ADA)) Q:'ADA D
. S DATA=$G(^BLRRLO(RO,4,ADA,0))
. S TST=$P(DATA,U),QUES=$P(DATA,U,3),ANS=$P(DATA,U,4),RSC=$P(DATA,U,5)
. S BLRRLC(TST,ADA)=RSC_U_QUES_U_ANS
Q
;
LEDIAAA ;-- ledi ask at order question
I '$O(BLRRLC(0)),$P($G(XQY0),U)'="LRPHMAN" S BLRRLSUC=$$COM^BLRRLCOM(BLRTS,1) ;cmi/anch/maw modified due to routine collect no LRTS 9/8/2004
; I $O(BLRRLC(0)) D
I $O(BLRRLC(0)),'+$G(LRQUIET) D ; IHS/MSC/MKK - LR*5.2*1035
. S DIR(0)="Y",DIR("A")="Are the responses to the Ask At Accession questions correct ",DIR("B")="Y"
. D ^DIR
. I '$G(Y) D G LEDIAAA
.. D DISAAQ(.BLRCNT,BLRTS,.BLRRLC)
D FLAO(.BLRRLC,BLRTS,BLRO,$G(LRUID),1)
Q
;
FLAO(RLC,T,RL,ACC,LEDI) ;-- file the ask at order questions
I $G(LEDI) D CLNAO(RL,T)
N FIENS,FERR,FDA
N RDA,RIEN,QUES,ANS,RSC
S RDA=0 F S RDA=$O(RLC(RDA)) Q:'RDA D
. S RIEN=0 F S RIEN=$O(RLC(RDA,RIEN)) Q:'RIEN D
.. S QUES=$P($G(RLC(RDA,RIEN)),U,2)
.. S ANS=$P($G(RLC(RDA,RIEN)),U,3)
.. S RSC=$P($G(RLC(RDA,RIEN)),U)
.. S FIENS="+2,"_RL_","
.. S FDA(9009026.34,FIENS,.01)=T
.. S FDA(9009026.34,FIENS,.02)=ACC
.. S FDA(9009026.34,FIENS,.03)=QUES
.. S FDA(9009026.34,FIENS,.04)=ANS
.. S FDA(9009026.34,FIENS,.05)=RSC
.. D UPDATE^DIE("","FDA","FIENS","FERR(1)")
.. K FIENS,FERR,FDA
Q
;
CLNAO(L,T) ;-- clean ot the ask at order questions
S DA=0 F S DA=$O(^BLRRLO(L,4,"B",T,DA)) Q:'DA D
. S DA(1)=L
. S DIK="^BLRRLO("_DA(1)_",4,"
. D ^DIK
K DA,DIK
Q
;
SENDOUT(AC,LRT) ;-- check if a valid sendout test
Q:$G(AC)=""!($G(LRT)="") 0 ; IHS/MSC/MKK - LR*5.2*1031
;
N RL,ACCA,AREA,MATCH
S MATCH=0
S RL=+$G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL"))
I '$G(RL) Q 0
N ADA
S ADA=0 F S ADA=$O(^LAB(60,LRT,8,ADA)) Q:'ADA!($G(MATCH)) D
. S ACCA=$P($G(^LAB(60,LRT,8,ADA,0)),U,2)
. Q:'ACCA
. I $O(^BLRSITE("ACC",ACCA,AC,0)) S MATCH=1 Q
I '$G(MATCH) Q 0
Q 1
;
ACC ;EP - cmi/flag/maw added the following for ref lab accessions
I $P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,22) D LEDI Q
K BLRRL,BLRRLC ;kill off existing BLRRL array
N BLRLDIO
I BLRPHASE="O" D ;cmi/maw 5/30/2007 added for institution entry of file 44 so that it gets correct accession area from file 60 otherwise it gets duz(2)
. Q:'$G(LROLLOC)
. Q:'$P($G(^SC(LROLLOC,0)),U,4)
. S BLRALTDZ=$P($G(^SC(LROLLOC,0)),U,4)
. Q:'+$G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL"))
. S LRDUZ(2)=BLRALTDZ
Q:BLRPHASE'="A" ;quit if not an accession
;Q:$G(BLROPT)="ADDACC" ;p1034 dont hit event driver if adding a test
I $G(BLROPT)="ADDACC",$G(BLRAGUI) Q ;p1041
S BLRRL("ALTDUZ2")=$G(BLRALTDZ) ;cmi/maw 5/29/2007 setup alternate duz2 if they select the prompt in blrsite to look at ordering location
I $G(BLRALTDZ),$P($G(^BLRSITE(BLRALTDZ,"RL")),U,10)="D" K BLRALTDZ,BLRRL("ALTDUZ2") ;don't need variables if they use a true multidivisional site
I $G(BLRALTDZ),$P($G(^BLRSITE(BLRALTDZ,"RL")),U,10)="" K BLRALTDZ,BLRRL("ALTDUZ2") ;don't need variables if they use a true multidivisional site
S BLRRL("RL")=+$G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")) ;ref lab site maw modified 5/29/2007
Q:'BLRRL("RL")
Q:'$$NOMAP(BLRRL("RL"),+$G(LRTS),$G(LROLLOC)) ;ihs/cmi/maw 07/15/2015 p1035 maintenance dont proceed if not a mapped test
S BLRRL("RLE")=$P($G(^BLRRL(BLRRL("RL"),0)),U) ;get external name
S BLRRL("PAT")=$G(DFN) ;patient
I $G(LRAA) S BLRRL("ACCCHECK")=LRAA ;cmi/maw 2/9/2009
I $G(LRACC)]"" S BLRRL("ACCCHECK")=$O(^LRO(68,"B",$P(LRACC," "),0)) ;cmi/maw 2/9/2009
Q:'$G(BLRRL("ACCCHECK")) ;cmi/maw 2/9/2009
Q:'$D(^BLRSITE("ACC",BLRRL("ACCCHECK"),$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),BLRRL("RL"))) ;2/9/09 quit if not a reference lab accession
S BLRRL("LRTS")=$S(+$G(LRTS):+LRTS,1:$G(LRTSORU))
Q:$G(BLRRL("LRTS"))="" ;1/23/2006 don't proceed without a test
S BLRTS=$S(+$G(LRTS):+LRTS,1:$G(LRTSORU))
I '$G(LRORD) S LRORD=$G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),.1)) ;p1034
S BLRO=$O(^BLRRLO("B",LRORD,0)) ;p1034
I '$G(BLRO) S BLRO=$$ORD^BLRRLEDI(LRORD,DFN) ;added non ledi p1034
I '$O(^BLRRLO("ACC",LRUID,0)) S BLRA=$$ACC^BLRRLEDI(LRUID,LRORD,DFN,LRCDT) ;added non ledi p1034
I '$G(BLRRLCNT) S BLRRLCNT=0
AAA I '$O(BLRRLC(0)),$P($G(XQY0),U)'="LRPHMAN" S BLRRLSUC=$$COM^BLRRLCOM(BLRRL("LRTS"),0) ;cmi/anch/maw modified due to routine collect no LRTS 9/8/2004
I ('$G(LRQUIET))&$O(BLRRLC(0)) D
. S DIR(0)="Y",DIR("A")="Are the responses to the Ask At Accession questions correct ",DIR("B")="Y"
. D ^DIR
. I '$G(Y) D G AAA
.. D CLNAO(BLRO,BLRTS),DISAAQ(.BLRCNT,BLRRL("LRTS"),.BLRRLC)
D FLAO(.BLRRLC,BLRTS,BLRO,$G(LRUID),1)
Q:$G(BLRTS)="" ;1/23/2006 don't proceed without a test
S BLRTSTDA=+$G(BLRTS)
;
; LR*5.2*1034 - Numerous lines of commented out code deleted -- see BLRRLEVD routine.
;
I +$G(LRQUIET) D
.I $G(BLRBT)="T" S BLRRL("BILL TYPE")="T" D BILL^BLRAG05C ; IHS/MSC/SAT - LR*5.2*1031
.S BLRRL("BILL TYPE")=$S($G(BLRBT)="C":"C",$G(BLRBT)="P":"P",1:"")
I $G(BLROPT)="ADDCOL",'+$G(LRQUIET) D
. ;ihs/cmi/maw 12/30/2014 p1034 for lab collect reference lab
. ;we need to reset the order number here
. N BLRNORD,BLRNORDI
. S BLRNORDI=$O(^BLRRLO("ACC",LRUID,0))
. I BLRNORDI S BLRNORD=$P($G(^BLRRLO(BLRNORDI,0)),U)
. I '$G(BLRNORD) S BLRNORD=LRORD
. S BLRORDLC(BLRNORD)=""
. D PRTLC^BLRRLEVN(BLRNORD,LRUID,DFN,LRLLOC,LRODT,LRPRAC,LRTSTS)
. I '$G(BLRLCLNT(BLRNORD)) D CLIENT^BLRRLHL,CLIENTG^BLRRLEDI(BLRNORD,LRUID)
. S BLRLCLNT(BLRNORD)=1
I '$G(BLRRLCLA),'+$G(LRQUIET) D CLIENT^BLRRLHL,CLIENTG^BLRRLEDI(LRORD,LRUID)
;I '+$G(LRQUIET),$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)'="C" D BILL^BLRRLHL ; IHS/MSC/SAT - LR*5.2*1031
I '+$G(LRQUIET),$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)="T" D ;ihs/cmi/maw - LR*5.2*1034
. K BLRDXS,BLRDFLG
. Q:$G(BLRASFLG)
. D CLIENTG^BLRRLEDI(LRORD,LRUID)
. D DX^BLRRLEDI(LRORD)
. S BLRB=$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)
. I '+$G(BLRAGUI),'$G(BLRINS) D BILL^BLRRLEDI(BLRB,LRORD,LRUID,LRCDT)
. ;D BILL^BLRRLHL
. S BLRASFLG=1
;reset the DX tmp global here
I '+$G(LRQUIET),$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)="T" D
. D ADDDX^BLRRLHL2(LRORD)
. Q:$E($G(BLRRL("BILL TYPE")),1,1)'="T"
. ;D INS^BLRRLHL(DFN,1)
;I '$G(BLRRL("CLIENT")) S BLRRL("CLIENT")=$G(BLRRLCLT)
;I '$G(BLRRL("CLIENT")) S BLRRL("CLIENT")=$O(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RLCA","B",""))
;I $G(BLRRL("CLIENT"))="" S BLRRL("CLIENT")=$P($G(^BLRRL(BLRRL("RL"),0)),U,13)
;I $G(BLRRL("BILL TYPE"))="" S BLRRL("BILL TYPE")=$G(BLRRLBTP)
;I $G(BLROPT)'="ADDCOL" D TMPSET(.BLRRL)
I +$G(BLRAGUI)!(BLROPT="ADDCOL") D ;cmi/anch/maw added for ward collection list 2/23/2006
. ;cmi/maw p1033 added order number, dob, sex back because its missing from the message post 1031 patch
. K DOB,SEX ;lets reset DOB and sex here as it seems to not work correctly on Collection list
. N ORDNUM
. S ORDNUM=$G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),.1))
. S BLRRL("ORD")=ORDNUM
. S:$G(BLRTSTDA) BLRRL(BLRTSTDA,"ORD")=$G(ORDNUM)
. N PAI,PA
. S PAI=$P($G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),0)),U)
. Q:'$G(PAI)
. Q:$P(^LR(PAI,0),U,2)'=2
. S PA=$P(^LR(PAI,0),U,3)
. Q:'$G(PA)
. S DOB=$P($G(^DPT(PA,0)),U,3)
. S SEX=$P($G(^DPT(PA,0)),U,2)
. ;D PRT^BLRSHPM
. I +$G(BLRAGUI) D SHIPMAN^BLRRLEVN(ORDNUM,0,0) ;p1036
;S X="BLR REFLAB ACCESSION A TEST",DIC=101 D EN^XQOR ;call accession protocol
;K BLRRL,LRTEST,PAT
;I $G(BLRTSTDA)]"" K BLRRLC(BLRTSTDA)
Q
;
TMPSET(BLRSHP) ;-- setup the array for the shipping manifest
N BLRDA,BLRDATA
S BLRDA=0 F S BLRDA=$O(BLRSHP(BLRDA)) Q:BLRDA="" D
. Q:BLRDA?.N
. ;cmi/anch/maw 7/24/2007 right here you could store by order number if passed in at the top
. S BLRDATA=$G(BLRSHP(BLRDA))
. I '$D(^TMP("BLRRL",$J,BLRDA)) S ^TMP("BLRRL",$J,"COMMON",BLRDA)=BLRDATA
N BLRDA,BLRDATA,BLRIEN
S BLRDA=0 F S BLRDA=$O(BLRSHP(BLRDA)) Q:BLRDA="" D
. Q:BLRDA'?.N
. S BLRIEN=0 F S BLRIEN=$O(BLRSHP(BLRDA,BLRIEN)) Q:BLRIEN="" D
.. Q:BLRIEN="COMMENT"
.. S BLRDATA=$G(BLRSHP(BLRDA,BLRIEN))
.. I '$D(^TMP("BLRRL",$J,BLRDA,BLRIEN)) S ^TMP("BLRRL",$J,BLRDA,BLRIEN)=BLRDATA
N BLRDA,BLRDATA,BLRIEN,BLROEN
S BLRDA=0 F S BLRDA=$O(BLRSHP(BLRDA)) Q:BLRDA="" D
. Q:BLRDA'?.N
. S BLRIEN=0 F S BLRIEN=$O(BLRSHP(BLRDA,BLRIEN)) Q:BLRIEN="" D
.. Q:BLRIEN="COMMENT"
.. S BLROEN=0 F S BLROEN=$O(BLRSHP(BLRDA,BLRIEN,BLROEN)) Q:'BLROEN D
... S BLRDATA=$G(BLRSHP(BLRDA,BLRIEN,BLROEN))
... I '$D(^TMP("BLRRL",$J,BLRDA,BLRIEN,BLROEN)) S ^TMP("BLRRL",$J,BLRDA,BLRIEN,BLROEN)=BLRDATA
N BLRDA,BLRIEN,BLROEN,BLRDATA
S BLRDA=0 F S BLRDA=$O(BLRSHP(BLRDA)) Q:BLRDA="" D
. Q:'BLRDA
. S BLRIEN=0 F S BLRIEN=$O(BLRSHP(BLRDA,"COMMENT",BLRIEN)) Q:'BLRIEN D
.. S BLRDATA=$G(BLRSHP(BLRDA,"COMMENT",BLRIEN))
.. I '$D(^TMP("BLRRL",$J,BLRDA,"COMMENT",BLRIEN)) S ^TMP("BLRRL",$J,BLRDA,"COMMENT",BLRIEN)=BLRDATA
Q
;
CODE(RL,TST) ;lookup the test code via prefix and test
K BLRTCODE,BLRSHPC
I '$D(^BLRRL(RL,1,0)) Q 0
S BLRRDA=0 F S BLRRDA=$O(^BLRRL("ALP",TST,RL,BLRRDA)) Q:'BLRRDA!($G(BLRTCODE)]"") D
. S BLRTCODE=$P($G(^BLRRL(RL,1,BLRRDA,0)),U,3)
. S BLRSHPC=$P($G(^BLRRL(RL,1,BLRRDA,0)),U,5)
. Q:$G(BLRTCODE)]""
I $G(BLRTCODE)="" Q 0
Q BLRTCODE_U_BLRSHPC
;
DISAAQ(BLRCNT,TIEN,AAQ) ;-- display the ask at order questions
N A,BLRCNT
S BLRCNT=0
S A=0 F S A=$O(AAQ(TIEN,A)) Q:'A D
. S BLRCNT=BLRCNT+1
. W !,A_") ",$P(AAQ(TIEN,A),U,2),?50,$P(AAQ(TIEN,A),U,3)
W !
N RES
K DIR
S DIR(0)="N^1:"_BLRCNT
S DIR("A")="Edit Which Ask At Accession Question "
D ^DIR
Q:$D(DIRUT)
S RES=+Y
K DIR
S DIR(0)="F",DIR("A")=$P(AAQ(TIEN,RES),U,2)
S DIR("B")=$P(AAQ(TIEN,RES),U,3)
D ^DIR
Q:$D(DIRUT)
S $P(BLRRLC(TIEN,RES),U,3)=Y
Q
;
NOMAP(RL,TST,LOC) ;-- check if the test is mapped
;ihs/cmi/maw 07/16/2015 p1035
N ORDLINST,MAPPED,IEN
S ORDLINST=+$$GET1^DIQ(44,LOC,3,"I") ; Ord Loc's Institution
I +$$GET1^DIQ(9009029,ORDLINST,3022,"I"),$D(^LAHM(62.9,"D",ORDLINST)) D Q +$G(MAPPED)
. S MAPPED=$$CHECKMAP(ORDLINST,TST)
Q $S(+$O(^BLRRL("ALP",TST,RL,0)):1,1:0)
Q
;
CHECKMAP(INST,TS) ;-- there can be multiple entries mapped
N MATCH,MDA
S MATCH=0
S MDA=0 F S MDA=$O(^LAHM(62.9,"D",INST,MDA)) Q:'MDA D
. I $O(^LAHM(62.9,MDA,60,"B",TS,0)) S MATCH=1
Q +$G(MATCH)
;
BLRRLEVT ;cmi/anch/maw - BLR Reference Lab Event ; 13-Oct-2017 14:04 ; MAW
+1 ;;5.2;IHS LABORATORY;**1027,1030,1031,1033,1034,1035,1036,1039,1041**;NOV 01, 1997;Build 23
+2 ;
+3 QUIT
+4 ;
LEDI ;-- LEDI III insurance stuff
+1 NEW BLRA,BLRC,BLRB
+2 KILL BLRRLC
+3 SET BLRLEDI=1
+4 SET BLRTS=$SELECT(+$GET(LRTS):+LRTS,$GET(LRTSTS):+LRTSTS,1:+$GET(LRTSORU))
+5 ; ----- BEGIN IHS/CMI/MAW - LR*5.2*1031
+6 ;ihs/cmi/maw 11/15/2011 added the following for ehr ordering
+7 IF '$GET(LROLLOC)
QUIT
+8 IF '$PIECE($GET(^SC(LROLLOC,0)),U,4)
QUIT
+9 SET BLRALTDZ=$SELECT($PIECE($GET(^SC(LROLLOC,0)),U,4):$PIECE($GET(^SC(LROLLOC,0)),U,4),1:DUZ(2))
+10 IF '+$GET(^BLRSITE($SELECT($GET(BLRALTDZ)
QUIT
+11 SET LRDUZ(2)=BLRALTDZ
+12 ; ----- END IHS/CMI/MAW - LR*5.2*1031
+13 ;I BLRPHASE="O" D ;cmi/maw 5/30/2007 added for institution entry of file 44 so that it gets correct accession area from file 60 otherwise it gets duz(2)
+14 ;. Q:'$$SENDOUT(BLRALTDZ,BLRTS)
+15 ;. I '$G(BLRO) S BLRO=$$ORD^BLRRLEDI(LRORD,DFN)
+16 ;. Q:'$G(BLRO)
+17 ;. I $G(BLRTS) D LEDIAAA
+18 ;. Q:$G(BLRDXS)
+19 ;. ; ihs/cmi/maw patch 1034 we no longer want to ask DX at order time
+20 ;. I $P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)="T" D DX^BLRRLEDI(LRORD)
+21 ;. K BLRO,BLRRLC
+22 ;quit if not an accession
IF BLRPHASE'="A"
QUIT
+23 ;ref lab site maw modified 5/29/2007
SET BLRRL("RL")=+$GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL"))
+24 IF 'BLRRL("RL")
QUIT
+25 ;ihs/cmi/maw 07/15/2015 p1035 maintenance dont proceed if not a mapped test
IF '$$NOMAP(BLRRL("RL"),+$GET(BLRTS),$GET(LROLLOC))
QUIT
+26 ;Q:'$$SENDOUT($G(BLRALTDZ),$G(BLRTS)) ; IHS/MSC/MKK - LR*5.2*1031 -- Possible null variable(s)
+27 SET BLRO=$ORDER(^BLRRLO("B",LRORD,0))
+28 IF $GET(BLROPT)="ADDCOL"
IF '+$GET(LRQUIET)
Begin DoDot:1
+29 ;ihs/cmi/maw 12/30/2014 p1034 for lab collect reference lab
+30 ;we need to reset the order number here
+31 NEW BLRNORD,BLRNORDI
+32 SET BLRNORDI=$ORDER(^BLRRLO("ACC",LRUID,0))
+33 IF BLRNORDI
SET BLRNORD=$PIECE($GET(^BLRRLO(BLRNORDI,0)),U)
+34 IF '$GET(BLRNORD)
SET BLRNORD=LRORD
+35 SET BLRORDLC(BLRNORD)=""
+36 DO PRTLC^BLRRLEVN(BLRNORD,LRUID,DFN,LRLLOC,LRODT,LRPRAC,LRTSTS)
+37 SET BLRLCLNT(BLRNORD)=1
+38 SET LRORD=BLRNORD
End DoDot:1
+39 IF '$GET(BLRO)
SET BLRO=$$ORD^BLRRLEDI(LRORD,DFN)
+40 SET BLRA=$$ACC^BLRRLEDI(LRUID,LRORD,DFN,LRCDT)
+41 IF 'BLRA
QUIT
+42 ;ihs/cmi/maw p1034
IF $GET(BLRTS)
DO LEDIAAA
+43 IF '$GET(BLRASFLG)
SET BLRC=$$CLIENT^BLRRLEDI(LRORD,LRUID)
+44 SET BLRASFLG=1
+45 ;I $P($G(^BLRRLO(BLRO,4,0)),U,4) D SETAO(BLRO),LEDIAAA
+46 KILL BLRRLC
+47 ;I $O(^BLRRLO(BLRO,4,"B",BLRTS,0)) D SETAO(BLRO,BLRTS),LEDIAAA
+48 SET BLRB=$PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)
+49 IF '+$GET(BLRAGUI)
IF $PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)="T"
Begin DoDot:1
+50 KILL BLRDXS,BLRDFLG
+51 DO DX^BLRRLEDI(LRORD)
End DoDot:1
+52 IF '+$GET(BLRAGUI)
IF '$GET(BLRINS)
DO BILL^BLRRLEDI(BLRB,LRORD,LRUID,LRCDT)
+53 IF $GET(BLRAGUI)
IF "CTP"[$GET(BLRBT)
SET BLRRL("BILL TYPE")=BLRBT
SET BLRINS=1
SET BT=$$BTP^BLRRLEDI(LRORD,BLRBT)
+54 KILL BLRO,BLRRLC
+55 QUIT
+56 ;
SETAO(RO,TS) ;-- setup the ask at order array from whats in the BLRRLO global
+1 NEW ADA,DATA,TST,QUES,ANS,RSC
+2 KILL BLRRLC
+3 SET ADA=0
FOR
SET ADA=$ORDER(^BLRRLO(RO,4,"B",TS,ADA))
IF 'ADA
QUIT
Begin DoDot:1
+4 SET DATA=$GET(^BLRRLO(RO,4,ADA,0))
+5 SET TST=$PIECE(DATA,U)
SET QUES=$PIECE(DATA,U,3)
SET ANS=$PIECE(DATA,U,4)
SET RSC=$PIECE(DATA,U,5)
+6 SET BLRRLC(TST,ADA)=RSC_U_QUES_U_ANS
End DoDot:1
+7 QUIT
+8 ;
LEDIAAA ;-- ledi ask at order question
+1 ;cmi/anch/maw modified due to routine collect no LRTS 9/8/2004
IF '$ORDER(BLRRLC(0))
IF $PIECE($GET(XQY0),U)'="LRPHMAN"
SET BLRRLSUC=$$COM^BLRRLCOM(BLRTS,1)
+2 ; I $O(BLRRLC(0)) D
+3 ; IHS/MSC/MKK - LR*5.2*1035
IF $ORDER(BLRRLC(0))
IF '+$GET(LRQUIET)
Begin DoDot:1
+4 SET DIR(0)="Y"
SET DIR("A")="Are the responses to the Ask At Accession questions correct "
SET DIR("B")="Y"
+5 DO ^DIR
+6 IF '$GET(Y)
Begin DoDot:2
+7 DO DISAAQ(.BLRCNT,BLRTS,.BLRRLC)
End DoDot:2
GOTO LEDIAAA
End DoDot:1
+8 DO FLAO(.BLRRLC,BLRTS,BLRO,$GET(LRUID),1)
+9 QUIT
+10 ;
FLAO(RLC,T,RL,ACC,LEDI) ;-- file the ask at order questions
+1 IF $GET(LEDI)
DO CLNAO(RL,T)
+2 NEW FIENS,FERR,FDA
+3 NEW RDA,RIEN,QUES,ANS,RSC
+4 SET RDA=0
FOR
SET RDA=$ORDER(RLC(RDA))
IF 'RDA
QUIT
Begin DoDot:1
+5 SET RIEN=0
FOR
SET RIEN=$ORDER(RLC(RDA,RIEN))
IF 'RIEN
QUIT
Begin DoDot:2
+6 SET QUES=$PIECE($GET(RLC(RDA,RIEN)),U,2)
+7 SET ANS=$PIECE($GET(RLC(RDA,RIEN)),U,3)
+8 SET RSC=$PIECE($GET(RLC(RDA,RIEN)),U)
+9 SET FIENS="+2,"_RL_","
+10 SET FDA(9009026.34,FIENS,.01)=T
+11 SET FDA(9009026.34,FIENS,.02)=ACC
+12 SET FDA(9009026.34,FIENS,.03)=QUES
+13 SET FDA(9009026.34,FIENS,.04)=ANS
+14 SET FDA(9009026.34,FIENS,.05)=RSC
+15 DO UPDATE^DIE("","FDA","FIENS","FERR(1)")
+16 KILL FIENS,FERR,FDA
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
CLNAO(L,T) ;-- clean ot the ask at order questions
+1 SET DA=0
FOR
SET DA=$ORDER(^BLRRLO(L,4,"B",T,DA))
IF 'DA
QUIT
Begin DoDot:1
+2 SET DA(1)=L
+3 SET DIK="^BLRRLO("_DA(1)_",4,"
+4 DO ^DIK
End DoDot:1
+5 KILL DA,DIK
+6 QUIT
+7 ;
SENDOUT(AC,LRT) ;-- check if a valid sendout test
+1 ; IHS/MSC/MKK - LR*5.2*1031
IF $GET(AC)=""!($GET(LRT)="")
QUIT 0
+2 ;
+3 NEW RL,ACCA,AREA,MATCH
+4 SET MATCH=0
+5 SET RL=+$GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL"))
+6 IF '$GET(RL)
QUIT 0
+7 NEW ADA
+8 SET ADA=0
FOR
SET ADA=$ORDER(^LAB(60,LRT,8,ADA))
IF 'ADA!($GET(MATCH))
QUIT
Begin DoDot:1
+9 SET ACCA=$PIECE($GET(^LAB(60,LRT,8,ADA,0)),U,2)
+10 IF 'ACCA
QUIT
+11 IF $ORDER(^BLRSITE("ACC",ACCA,AC,0))
SET MATCH=1
QUIT
End DoDot:1
+12 IF '$GET(MATCH)
QUIT 0
+13 QUIT 1
+14 ;
ACC ;EP - cmi/flag/maw added the following for ref lab accessions
+1 IF $PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,22)
DO LEDI
QUIT
+2 ;kill off existing BLRRL array
KILL BLRRL,BLRRLC
+3 NEW BLRLDIO
+4 ;cmi/maw 5/30/2007 added for institution entry of file 44 so that it gets correct accession area from file 60 otherwise it gets duz(2)
IF BLRPHASE="O"
Begin DoDot:1
+5 IF '$GET(LROLLOC)
QUIT
+6 IF '$PIECE($GET(^SC(LROLLOC,0)),U,4)
QUIT
+7 SET BLRALTDZ=$PIECE($GET(^SC(LROLLOC,0)),U,4)
+8 IF '+$GET(^BLRSITE($SELECT($GET(BLRALTDZ)
QUIT
+9 SET LRDUZ(2)=BLRALTDZ
End DoDot:1
+10 ;quit if not an accession
IF BLRPHASE'="A"
QUIT
+11 ;Q:$G(BLROPT)="ADDACC" ;p1034 dont hit event driver if adding a test
+12 ;p1041
IF $GET(BLROPT)="ADDACC"
IF $GET(BLRAGUI)
QUIT
+13 ;cmi/maw 5/29/2007 setup alternate duz2 if they select the prompt in blrsite to look at ordering location
SET BLRRL("ALTDUZ2")=$GET(BLRALTDZ)
+14 ;don't need variables if they use a true multidivisional site
IF $GET(BLRALTDZ)
IF $PIECE($GET(^BLRSITE(BLRALTDZ,"RL")),U,10)="D"
KILL BLRALTDZ,BLRRL("ALTDUZ2")
+15 ;don't need variables if they use a true multidivisional site
IF $GET(BLRALTDZ)
IF $PIECE($GET(^BLRSITE(BLRALTDZ,"RL")),U,10)=""
KILL BLRALTDZ,BLRRL("ALTDUZ2")
+16 ;ref lab site maw modified 5/29/2007
SET BLRRL("RL")=+$GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL"))
+17 IF 'BLRRL("RL")
QUIT
+18 ;ihs/cmi/maw 07/15/2015 p1035 maintenance dont proceed if not a mapped test
IF '$$NOMAP(BLRRL("RL"),+$GET(LRTS),$GET(LROLLOC))
QUIT
+19 ;get external name
SET BLRRL("RLE")=$PIECE($GET(^BLRRL(BLRRL("RL"),0)),U)
+20 ;patient
SET BLRRL("PAT")=$GET(DFN)
+21 ;cmi/maw 2/9/2009
IF $GET(LRAA)
SET BLRRL("ACCCHECK")=LRAA
+22 ;cmi/maw 2/9/2009
IF $GET(LRACC)]""
SET BLRRL("ACCCHECK")=$ORDER(^LRO(68,"B",$PIECE(LRACC," "),0))
+23 ;cmi/maw 2/9/2009
IF '$GET(BLRRL("ACCCHECK"))
QUIT
+24 ;2/9/09 quit if not a reference lab accession
IF '$DATA(^BLRSITE("ACC",BLRRL("ACCCHECK"),$SELECT($GET(BLRALTDZ)
QUIT
+25 SET BLRRL("LRTS")=$SELECT(+$GET(LRTS):+LRTS,1:$GET(LRTSORU))
+26 ;1/23/2006 don't proceed without a test
IF $GET(BLRRL("LRTS"))=""
QUIT
+27 SET BLRTS=$SELECT(+$GET(LRTS):+LRTS,1:$GET(LRTSORU))
+28 ;p1034
IF '$GET(LRORD)
SET LRORD=$GET(^LRO(68,+$GET(LRAA),1,+$GET(LRAD),1,+$GET(LRAN),.1))
+29 ;p1034
SET BLRO=$ORDER(^BLRRLO("B",LRORD,0))
+30 ;added non ledi p1034
IF '$GET(BLRO)
SET BLRO=$$ORD^BLRRLEDI(LRORD,DFN)
+31 ;added non ledi p1034
IF '$ORDER(^BLRRLO("ACC",LRUID,0))
SET BLRA=$$ACC^BLRRLEDI(LRUID,LRORD,DFN,LRCDT)
+32 IF '$GET(BLRRLCNT)
SET BLRRLCNT=0
AAA ;cmi/anch/maw modified due to routine collect no LRTS 9/8/2004
IF '$ORDER(BLRRLC(0))
IF $PIECE($GET(XQY0),U)'="LRPHMAN"
SET BLRRLSUC=$$COM^BLRRLCOM(BLRRL("LRTS"),0)
+1 IF ('$GET(LRQUIET))&$ORDER(BLRRLC(0))
Begin DoDot:1
+2 SET DIR(0)="Y"
SET DIR("A")="Are the responses to the Ask At Accession questions correct "
SET DIR("B")="Y"
+3 DO ^DIR
+4 IF '$GET(Y)
Begin DoDot:2
+5 DO CLNAO(BLRO,BLRTS)
DO DISAAQ(.BLRCNT,BLRRL("LRTS"),.BLRRLC)
End DoDot:2
GOTO AAA
End DoDot:1
+6 DO FLAO(.BLRRLC,BLRTS,BLRO,$GET(LRUID),1)
+7 ;1/23/2006 don't proceed without a test
IF $GET(BLRTS)=""
QUIT
+8 SET BLRTSTDA=+$GET(BLRTS)
+9 ;
+10 ; LR*5.2*1034 - Numerous lines of commented out code deleted -- see BLRRLEVD routine.
+11 ;
+12 IF +$GET(LRQUIET)
Begin DoDot:1
+13 ; IHS/MSC/SAT - LR*5.2*1031
IF $GET(BLRBT)="T"
SET BLRRL("BILL TYPE")="T"
DO BILL^BLRAG05C
+14 SET BLRRL("BILL TYPE")=$SELECT($GET(BLRBT)="C":"C",$GET(BLRBT)="P":"P",1:"")
End DoDot:1
+15 IF $GET(BLROPT)="ADDCOL"
IF '+$GET(LRQUIET)
Begin DoDot:1
+16 ;ihs/cmi/maw 12/30/2014 p1034 for lab collect reference lab
+17 ;we need to reset the order number here
+18 NEW BLRNORD,BLRNORDI
+19 SET BLRNORDI=$ORDER(^BLRRLO("ACC",LRUID,0))
+20 IF BLRNORDI
SET BLRNORD=$PIECE($GET(^BLRRLO(BLRNORDI,0)),U)
+21 IF '$GET(BLRNORD)
SET BLRNORD=LRORD
+22 SET BLRORDLC(BLRNORD)=""
+23 DO PRTLC^BLRRLEVN(BLRNORD,LRUID,DFN,LRLLOC,LRODT,LRPRAC,LRTSTS)
+24 IF '$GET(BLRLCLNT(BLRNORD))
DO CLIENT^BLRRLHL
DO CLIENTG^BLRRLEDI(BLRNORD,LRUID)
+25 SET BLRLCLNT(BLRNORD)=1
End DoDot:1
+26 IF '$GET(BLRRLCLA)
IF '+$GET(LRQUIET)
DO CLIENT^BLRRLHL
DO CLIENTG^BLRRLEDI(LRORD,LRUID)
+27 ;I '+$G(LRQUIET),$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)'="C" D BILL^BLRRLHL ; IHS/MSC/SAT - LR*5.2*1031
+28 ;ihs/cmi/maw - LR*5.2*1034
IF '+$GET(LRQUIET)
IF $PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)="T"
Begin DoDot:1
+29 KILL BLRDXS,BLRDFLG
+30 IF $GET(BLRASFLG)
QUIT
+31 DO CLIENTG^BLRRLEDI(LRORD,LRUID)
+32 DO DX^BLRRLEDI(LRORD)
+33 SET BLRB=$PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)
+34 IF '+$GET(BLRAGUI)
IF '$GET(BLRINS)
DO BILL^BLRRLEDI(BLRB,LRORD,LRUID,LRCDT)
+35 ;D BILL^BLRRLHL
+36 SET BLRASFLG=1
End DoDot:1
+37 ;reset the DX tmp global here
+38 IF '+$GET(LRQUIET)
IF $PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)="T"
Begin DoDot:1
+39 DO ADDDX^BLRRLHL2(LRORD)
+40 IF $EXTRACT($GET(BLRRL("BILL TYPE")),1,1)'="T"
QUIT
+41 ;D INS^BLRRLHL(DFN,1)
End DoDot:1
+42 ;I '$G(BLRRL("CLIENT")) S BLRRL("CLIENT")=$G(BLRRLCLT)
+43 ;I '$G(BLRRL("CLIENT")) S BLRRL("CLIENT")=$O(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RLCA","B",""))
+44 ;I $G(BLRRL("CLIENT"))="" S BLRRL("CLIENT")=$P($G(^BLRRL(BLRRL("RL"),0)),U,13)
+45 ;I $G(BLRRL("BILL TYPE"))="" S BLRRL("BILL TYPE")=$G(BLRRLBTP)
+46 ;I $G(BLROPT)'="ADDCOL" D TMPSET(.BLRRL)
+47 ;cmi/anch/maw added for ward collection list 2/23/2006
IF +$GET(BLRAGUI)!(BLROPT="ADDCOL")
Begin DoDot:1
+48 ;cmi/maw p1033 added order number, dob, sex back because its missing from the message post 1031 patch
+49 ;lets reset DOB and sex here as it seems to not work correctly on Collection list
KILL DOB,SEX
+50 NEW ORDNUM
+51 SET ORDNUM=$GET(^LRO(68,+$GET(LRAA),1,+$GET(LRAD),1,+$GET(LRAN),.1))
+52 SET BLRRL("ORD")=ORDNUM
+53 IF $GET(BLRTSTDA)
SET BLRRL(BLRTSTDA,"ORD")=$GET(ORDNUM)
+54 NEW PAI,PA
+55 SET PAI=$PIECE($GET(^LRO(68,+$GET(LRAA),1,+$GET(LRAD),1,+$GET(LRAN),0)),U)
+56 IF '$GET(PAI)
QUIT
+57 IF $PIECE(^LR(PAI,0),U,2)'=2
QUIT
+58 SET PA=$PIECE(^LR(PAI,0),U,3)
+59 IF '$GET(PA)
QUIT
+60 SET DOB=$PIECE($GET(^DPT(PA,0)),U,3)
+61 SET SEX=$PIECE($GET(^DPT(PA,0)),U,2)
+62 ;D PRT^BLRSHPM
+63 ;p1036
IF +$GET(BLRAGUI)
DO SHIPMAN^BLRRLEVN(ORDNUM,0,0)
End DoDot:1
+64 ;S X="BLR REFLAB ACCESSION A TEST",DIC=101 D EN^XQOR ;call accession protocol
+65 ;K BLRRL,LRTEST,PAT
+66 ;I $G(BLRTSTDA)]"" K BLRRLC(BLRTSTDA)
+67 QUIT
+68 ;
TMPSET(BLRSHP) ;-- setup the array for the shipping manifest
+1 NEW BLRDA,BLRDATA
+2 SET BLRDA=0
FOR
SET BLRDA=$ORDER(BLRSHP(BLRDA))
IF BLRDA=""
QUIT
Begin DoDot:1
+3 IF BLRDA?.N
QUIT
+4 ;cmi/anch/maw 7/24/2007 right here you could store by order number if passed in at the top
+5 SET BLRDATA=$GET(BLRSHP(BLRDA))
+6 IF '$DATA(^TMP("BLRRL",$JOB,BLRDA))
SET ^TMP("BLRRL",$JOB,"COMMON",BLRDA)=BLRDATA
End DoDot:1
+7 NEW BLRDA,BLRDATA,BLRIEN
+8 SET BLRDA=0
FOR
SET BLRDA=$ORDER(BLRSHP(BLRDA))
IF BLRDA=""
QUIT
Begin DoDot:1
+9 IF BLRDA'?.N
QUIT
+10 SET BLRIEN=0
FOR
SET BLRIEN=$ORDER(BLRSHP(BLRDA,BLRIEN))
IF BLRIEN=""
QUIT
Begin DoDot:2
+11 IF BLRIEN="COMMENT"
QUIT
+12 SET BLRDATA=$GET(BLRSHP(BLRDA,BLRIEN))
+13 IF '$DATA(^TMP("BLRRL",$JOB,BLRDA,BLRIEN))
SET ^TMP("BLRRL",$JOB,BLRDA,BLRIEN)=BLRDATA
End DoDot:2
End DoDot:1
+14 NEW BLRDA,BLRDATA,BLRIEN,BLROEN
+15 SET BLRDA=0
FOR
SET BLRDA=$ORDER(BLRSHP(BLRDA))
IF BLRDA=""
QUIT
Begin DoDot:1
+16 IF BLRDA'?.N
QUIT
+17 SET BLRIEN=0
FOR
SET BLRIEN=$ORDER(BLRSHP(BLRDA,BLRIEN))
IF BLRIEN=""
QUIT
Begin DoDot:2
+18 IF BLRIEN="COMMENT"
QUIT
+19 SET BLROEN=0
FOR
SET BLROEN=$ORDER(BLRSHP(BLRDA,BLRIEN,BLROEN))
IF 'BLROEN
QUIT
Begin DoDot:3
+20 SET BLRDATA=$GET(BLRSHP(BLRDA,BLRIEN,BLROEN))
+21 IF '$DATA(^TMP("BLRRL",$JOB,BLRDA,BLRIEN,BLROEN))
SET ^TMP("BLRRL",$JOB,BLRDA,BLRIEN,BLROEN)=BLRDATA
End DoDot:3
End DoDot:2
End DoDot:1
+22 NEW BLRDA,BLRIEN,BLROEN,BLRDATA
+23 SET BLRDA=0
FOR
SET BLRDA=$ORDER(BLRSHP(BLRDA))
IF BLRDA=""
QUIT
Begin DoDot:1
+24 IF 'BLRDA
QUIT
+25 SET BLRIEN=0
FOR
SET BLRIEN=$ORDER(BLRSHP(BLRDA,"COMMENT",BLRIEN))
IF 'BLRIEN
QUIT
Begin DoDot:2
+26 SET BLRDATA=$GET(BLRSHP(BLRDA,"COMMENT",BLRIEN))
+27 IF '$DATA(^TMP("BLRRL",$JOB,BLRDA,"COMMENT",BLRIEN))
SET ^TMP("BLRRL",$JOB,BLRDA,"COMMENT",BLRIEN)=BLRDATA
End DoDot:2
End DoDot:1
+28 QUIT
+29 ;
CODE(RL,TST) ;lookup the test code via prefix and test
+1 KILL BLRTCODE,BLRSHPC
+2 IF '$DATA(^BLRRL(RL,1,0))
QUIT 0
+3 SET BLRRDA=0
FOR
SET BLRRDA=$ORDER(^BLRRL("ALP",TST,RL,BLRRDA))
IF 'BLRRDA!($GET(BLRTCODE)]"")
QUIT
Begin DoDot:1
+4 SET BLRTCODE=$PIECE($GET(^BLRRL(RL,1,BLRRDA,0)),U,3)
+5 SET BLRSHPC=$PIECE($GET(^BLRRL(RL,1,BLRRDA,0)),U,5)
+6 IF $GET(BLRTCODE)]""
QUIT
End DoDot:1
+7 IF $GET(BLRTCODE)=""
QUIT 0
+8 QUIT BLRTCODE_U_BLRSHPC
+9 ;
DISAAQ(BLRCNT,TIEN,AAQ) ;-- display the ask at order questions
+1 NEW A,BLRCNT
+2 SET BLRCNT=0
+3 SET A=0
FOR
SET A=$ORDER(AAQ(TIEN,A))
IF 'A
QUIT
Begin DoDot:1
+4 SET BLRCNT=BLRCNT+1
+5 WRITE !,A_") ",$PIECE(AAQ(TIEN,A),U,2),?50,$PIECE(AAQ(TIEN,A),U,3)
End DoDot:1
+6 WRITE !
+7 NEW RES
+8 KILL DIR
+9 SET DIR(0)="N^1:"_BLRCNT
+10 SET DIR("A")="Edit Which Ask At Accession Question "
+11 DO ^DIR
+12 IF $DATA(DIRUT)
QUIT
+13 SET RES=+Y
+14 KILL DIR
+15 SET DIR(0)="F"
SET DIR("A")=$PIECE(AAQ(TIEN,RES),U,2)
+16 SET DIR("B")=$PIECE(AAQ(TIEN,RES),U,3)
+17 DO ^DIR
+18 IF $DATA(DIRUT)
QUIT
+19 SET $PIECE(BLRRLC(TIEN,RES),U,3)=Y
+20 QUIT
+21 ;
NOMAP(RL,TST,LOC) ;-- check if the test is mapped
+1 ;ihs/cmi/maw 07/16/2015 p1035
+2 NEW ORDLINST,MAPPED,IEN
+3 ; Ord Loc's Institution
SET ORDLINST=+$$GET1^DIQ(44,LOC,3,"I")
+4 IF +$$GET1^DIQ(9009029,ORDLINST,3022,"I")
IF $DATA(^LAHM(62.9,"D",ORDLINST))
Begin DoDot:1
+5 SET MAPPED=$$CHECKMAP(ORDLINST,TST)
End DoDot:1
QUIT +$GET(MAPPED)
+6 QUIT $SELECT(+$ORDER(^BLRRL("ALP",TST,RL,0)):1,1:0)
+7 QUIT
+8 ;
CHECKMAP(INST,TS) ;-- there can be multiple entries mapped
+1 NEW MATCH,MDA
+2 SET MATCH=0
+3 SET MDA=0
FOR
SET MDA=$ORDER(^LAHM(62.9,"D",INST,MDA))
IF 'MDA
QUIT
Begin DoDot:1
+4 IF $ORDER(^LAHM(62.9,MDA,60,"B",TS,0))
SET MATCH=1
End DoDot:1
+5 QUIT +$GET(MATCH)
+6 ;
