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

BLRRLEV2.m

Go to the documentation of this file. 
  1. BLRRLEV2 ;IHS/OIT/MKK - BLR Reference Lab Event, part 2 ; 22-Oct-2013 09:22 ; MAW
  1.  ;;5.2;IHS LABORATORY;**1033**;NOV 01, 1997
  1.  ;
  1.  ; Code had to be moved here from BLRRLEVT because BLRRLEVT became too large.
  1.  ;
  1. EEP ; EP - Ersatz EP
  1.  D EEP^BLRGMENU
  1.  ;
  1.  Q
  1.  ;
  1.  ;cmi/anch/maw 2/24/2006 added look for LRPHMAN before asking for comments
  1.  ;cmi/anch/maw 2/28/2006 added AAA tag for allowing edit of ask at accession questions
  1. AAA ; EP
  1.  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
  1.  I ('$G(LRQUIET))&$O(BLRRLC(0)) D
  1.  . S DIR(0)="Y",DIR("A")="Are the responses to the Ask At Accession questions correct "
  1.  . S DIR("B")="Y"
  1.  . D ^DIR
  1.  . I '$G(Y) D  G AAA
  1.  .. D DISAAQ^BLRRLEVT(.BLRCNT,BLRRL("LRTS"),.BLRRLC)
  1.  ;cmi/anch/maw 2/28/2005 end of mods
  1.  ;I '$O(BLRRLC(0)) S BLRRLSUC=$$COM^BLRRLCOM(+LRTS)  maw orig 9/8/2004
  1.  Q:$G(BLRRL("LRTS"))=""  ;1/23/2006 don't proceed without a test
  1.  S BLRRL("LOCI")=$G(LROLLOC)  ;cmi/maw 5/29/2007 added for internal location pointer to file 44
  1.  S BLRRL("LOC")=$G(LRLLOC)
  1.  S BLRRL("LOC")=$S($G(LROLLOC):$P($G(^SC(LROLLOC,0)),U),1:"")  ;4/3/2008 added for pointer to hosp location file
  1.  ;S BLRRL("BI")=$P($G(^BLRRL(BLRRL("RL"),0)),U,10)  ;bi or unidirectional 2/25/2008 orig line
  1.  S BLRRL("BI")=$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL",0)),U,18)  ;NEW cmi/maw 2/25/2008 bi or unidirectional
  1.  S BLRRL("RLE")=$P($G(^BLRRL(BLRRL("RL"),0)),U)  ;get external name
  1.  ;I $G(BLRRL("BI")) Q:$P($G(^BLRRL(BLRRL("RL"),0)),U,6)=""  ;no orders 5/31/06
  1.  ;I $G(BLRRL("BI")) Q:$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL"),0)),U,6)=""  ;no orders 5/31/06
  1.  S BLRRL("PAT")=$G(DFN)  ;patient
  1.  S BLRRL("ACC")=$G(LRACC)  ;accession number
  1.  S BLRRL("UID")=$G(LRUID)  ;unique id
  1.  S BLRRL("CDT")=$G(LRCDT)  ;collection date
  1.  S BLRRL("ACCA")=$P(BLRRL("ACC")," ")  ;get accession abbreviation
  1.  I $G(BLRRL("ACCA"))="" W !,"No valid accession area prefix" Q
  1.  S BLR("ACCAREA")=$O(^LRO(68,"B",BLRRL("ACCA"),0))  ;get ien of accession area
  1.  I BLR("ACCAREA")=""  W !,"Accession Area is not a sendout area"  ;don't proceed if not an SO area
  1.  ;todo see why this is failing
  1.  I '$D(^BLRSITE("ACC",BLR("ACCAREA"),DUZ(2),BLRRL("RL"))) D  Q  ;2/25/2008 moved to BLR MASTER CONTROL FILE quit when not a sendout area
  1.  . W !,"Accession area is not setup in the BLR MASTER CONTROL file"
  1.  S BLRRL("ORDPRV")=$G(LRPRAC)  ;ordering provider
  1.  ;the following must be setup in an array for GIS software
  1.  ;do something here to check for mult tests under ac #
  1.  ;or each acc # unique
  1.  S (BLRTSTDA,BLRRL("TSTDA"))=+$G(LRTS)
  1.  K BLRRL(BLRTSTDA)  ;kill off array from previous accession
  1.  K BLRRL("ORDPUPIN"),BLRRL("ORDPNM")  ;maw 5/10/06
  1.  S (BLRRL("UPINNPI"),BLRRL(BLRTSTDA,"UPINNPI"))="U"  ;upin or NPI
  1.  I BLRRL("ORDPRV")]"" D  ;setup provider array
  1.  . S BLRRL("ORDPUPIN")=$$VAL^XBDIQ1(200,BLRRL("ORDPRV"),9999999.08)  ;maw 5/10/06
  1.  . S BLRRL("ORDPNPI")=$$VAL^XBDIQ1(200,BLRRL("ORDPRV"),41.99)  ;cmi/maw 2/26/2008 NPI
  1.  . S BLRRL("ORDPNM")=$$VAL^XBDIQ1(200,BLRRL("ORDPRV"),.01)
  1.  . S BLRRL("ORDPNM")=$P(BLRRL("ORDPNM"),",")_"^"_$P($P(BLRRL("ORDPNM"),",",2)," ")
  1.  . S BLRRL(BLRTSTDA,"ORDP")=BLRRL("ORDPUPIN")_"^"_BLRRL("ORDPNM")  ;cmi/maw 3/4/09 labcorp
  1.  . S $P(BLRRL(BLRTSTDA,"ORDP"),U,8)="U"  ;cmi/maw 3/12/09 labcorp
  1.  . S BLRRL("ORDP")=BLRRL("ORDPUPIN")_"^"_BLRRL("ORDPNM")  ;cmi/maw 3/4/09 labcorp
  1.  . S $P(BLRRL("ORDP"),U,8)="U"  ;cmi/maw 3/12/09 labcorp
  1.  . ;cmi/maw 2/27/2008 added NPI based on parameter set in BLR MASTER CONTROL file
  1.  . I $P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,19)="N" D
  1.  .. S (BLRRL("UPINNPI"),BLRRL(BLRTSTDA,"UPINNPI"))="N"
  1.  .. S BLRRL(BLRTSTDA,"ORDP")=BLRRL("ORDPNPI")_"^"_BLRRL("ORDPNM")  ;cmi/maw 3/4/09 labcorp
  1.  .. S $P(BLRRL(BLRTSTDA,"ORDP"),U,8)="N"  ;cmi/maw 3/12/09 labcorp
  1.  .. S BLRRL("ORDP")=BLRRL("ORDPNPI")_"^"_BLRRL("ORDPNM")  ;cmi/maw 3/4/09 labcorp
  1.  .. S $P(BLRRL("ORDP"),U,8)="N"  ;cmi/maw 3/12/09 labcorp
  1.  S BLRTSTI=+$G(LRTS)  ;get test ien
  1.  I '$D(^LAB(60,BLRTSTI,8,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)) D  Q  ;quit if no accession area
  1.  . W !,"Institution "_$P($G(^DIC(4,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)),U)_" is not setup in the Accession Area multiple of file 60"
  1.  S BLRAREA=$P($G(^LAB(60,BLRTSTI,8,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)),U,2)  ;get acc area
  1.  I BLRAREA="" W !,"Accession Area field is not setup in file 60 for "_$P($G(^DIC(4,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)),U) Q  ;quit if accession area field is null
  1.  ;todo see why the below code does not work
  1.  I BLRAREA'=BLR("ACCAREA") W !,"Accession Area in file 60 is not a sendout accession area" Q  ;quit if test acc area is not SO area
  1.  S BLRRL(BLRTSTDA,"CDT")=$G(LRCDT)  ;collection date
  1.  S BLRRL("TNAME")=$P($G(^LAB(60,BLRTSTI,0)),U)  ;get test name
  1.  S BLRRL("ABBR")=$P($G(^LRO(68,BLRAREA,0)),U,11)  ;get area abbr
  1.  S BLRRL("TST")=BLRTSTI  ;get test ien
  1.  S BLRRL("TCODEE")=$$CODE^BLRRLEVT(BLRRL("RL"),BLRRL("TST"))  ;lookup test code
  1.  S BLRRL("TCODE")=$P(BLRRL("TCODEE"),U)  ;test code
  1.  S BLRRL("SHIPCOND")=$P(BLRRL("TCODEE"),U,2)  ;shipping condition
  1.  I $G(BLRRL("TCODE"))=0 K BLRRL(BLRTSTDA) Q  ;quit if no test code
  1.  S BLRRL(BLRTSTDA,"ACC")=$G(LRACC)  ;setup acc array for OBR
  1.  S BLRRL(BLRTSTDA,"UID")=$G(LRUID)
  1.  S BLRRL("TCNM")=BLRRL("TCODE")_U_BLRRL("TNAME")  ;test arry
  1.  S BLRRL(BLRTSTDA,"TCNM")=BLRRL("TCODE")_U_BLRRL("TNAME")  ;test arry
  1.  I $G(BLRRL("RLE"))="LABCORP" D
  1.  . S BLRRL("TCNM")=BLRRL("TCNM")_"^L"
  1.  . S BLRRL(BLRTSTDA,"TCNM")=BLRRL(BLRTSTDA,"TCNM")_"^L"
  1.  S BLRRL("URGHL")=$S($G(LRURG):$P($G(^LAB(62.05,LRURG,0)),U,4),1:"")
  1.  S BLRRL("URG")=$G(LRURG)
  1.  S BLRRL("ODT")=$G(LRODT)
  1.  S BLRRL(BLRTSTDA,"SAMP")=$G(LRSAMP)
  1.  S BLRRL("SAMP")=$G(LRSAMP)
  1.  S BLRRL(BLRTSTDA,"SRC")=$G(LRSPEC)
  1.  S BLRRL("SRC")=$G(LRSPEC)
  1.  I $G(LRSPEC) S (BLRRL(BLRTSTDA,"SRC"),BLRRL("SRC"))=$P($G(^LAB(61,LRSPEC,0)),U)
  1.  S BLRRL("ORD")=$G(LRORD)
  1.  S BLRRL(BLRTSTDA,"ORD")=$G(LRORD)
  1.  S BLRCM=0 F  S BLRCM=$O(BLRRLC(BLRTSTDA,BLRCM)) Q:'BLRCM  D
  1.  . S BLRRL(BLRTSTDA,"COMMENT",BLRCM)=$G(BLRRLC(BLRTSTDA,BLRCM))
  1.  . S BLRRL("COMMENT",BLRCM)=$G(BLRRLC(BLRTSTDA,BLRCM))
  1.  ;cmi/anch/maw 3/3/2006 lets try this for account number
  1.  ;cmi/maw 2/25/2008 code added to get multiple account numbers
  1.  ;S BLRRL("BILL TYPE")="Client"
  1.  ;I $P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)'="C" D BILL^BLRRLHL
  1.  I +$G(LRQUIET) D
  1.  .I $G(BLRBT)="T" S BLRRL("BILL TYPE")="T" D BILL^BLRAG05C    ; IHS/MSC/SAT - LR*5.2*1031
  1.  .S BLRRL("BILL TYPE")=$S($G(BLRBT)="C":"C",$G(BLRBT)="P":"P",1:"")
  1.  I '+$G(LRQUIET) I $P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)'="C" D BILL^BLRRLHL   ; IHS/MSC/SAT - LR*5.2*1031
  1.  ;
  1.  ;cmi/anch/maw 3/3/2006 end of mods
  1.  I '$G(BLRRLCLA) D CLIENT^BLRRLHL
  1.  I '$G(BLRRL("CLIENT")) S BLRRL("CLIENT")=$G(BLRRLCLT)
  1.  I '$G(BLRRL("CLIENT")) S BLRRL("CLIENT")=$O(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RLCA","B",""))
  1.  I $G(BLRRL("CLIENT"))="" S BLRRL("CLIENT")=$P($G(^BLRRL(BLRRL("RL"),0)),U,13)
  1.  I $G(BLRRL("BILL TYPE"))="" S BLRRL("BILL TYPE")=$G(BLRRLBTP)
  1.  D TMPSET(.BLRRL)
  1.  I +$G(BLRAGUI)!($P($G(XQY0),U)="LRPHMAN") D  ;cmi/anch/maw added for ward collection list 2/23/2006
  1.  . D PRT^BLRSHPM
  1.  S X="BLR REFLAB ACCESSION A TEST",DIC=101 D EN^XQOR  ;call accession protocol
  1.  K BLRRL,BLRRLC(BLRTSTDA),LRTEST,PAT
  1.  Q
  1.  ;
  1. TMPSET(BLRSHP) ;-- setup the array for the shipping manifest
  1.  N BLRDA,BLRDATA,BLRIEN,BLROEN
  1.  S BLRDA=0 F  S BLRDA=$O(BLRSHP(BLRDA)) Q:BLRDA=""  D
  1.  . Q:BLRDA?.N
  1.  . ;cmi/anch/maw 7/24/2007 right here you could store by order number if passed in at the top
  1.  . S BLRDATA=$G(BLRSHP(BLRDA))
  1.  . I '$D(^TMP("BLRRL",$J,BLRDA)) S ^TMP("BLRRL",$J,"COMMON",BLRDA)=BLRDATA
  1.  ;
  1.  K BLRDA,BLRDATA,BLRIEN
  1.  S BLRDA=0 F  S BLRDA=$O(BLRSHP(BLRDA)) Q:BLRDA=""  D
  1.  . Q:BLRDA'?.N
  1.  . S BLRIEN=0 F  S BLRIEN=$O(BLRSHP(BLRDA,BLRIEN)) Q:BLRIEN=""  D
  1.  .. Q:BLRIEN="COMMENT"
  1.  .. S BLRDATA=$G(BLRSHP(BLRDA,BLRIEN))
  1.  .. I '$D(^TMP("BLRRL",$J,BLRDA,BLRIEN)) S ^TMP("BLRRL",$J,BLRDA,BLRIEN)=BLRDATA
  1.  ;
  1.  K BLRDA,BLRDATA,BLRIEN,BLROEN
  1.  S BLRDA=0 F  S BLRDA=$O(BLRSHP(BLRDA)) Q:BLRDA=""  D
  1.  . Q:BLRDA'?.N
  1.  . S BLRIEN=0 F  S BLRIEN=$O(BLRSHP(BLRDA,BLRIEN)) Q:BLRIEN=""  D
  1.  .. Q:BLRIEN="COMMENT"
  1.  .. S BLROEN=0 F  S BLROEN=$O(BLRSHP(BLRDA,BLRIEN,BLROEN)) Q:'BLROEN  D
  1.  ... S BLRDATA=$G(BLRSHP(BLRDA,BLRIEN,BLROEN))
  1.  ... I '$D(^TMP("BLRRL",$J,BLRDA,BLRIEN,BLROEN)) S ^TMP("BLRRL",$J,BLRDA,BLRIEN,BLROEN)=BLRDATA
  1.  ;
  1.  K BLRDA,BLRIEN,BLROEN,BLRDATA
  1.  S BLRDA=0 F  S BLRDA=$O(BLRSHP(BLRDA)) Q:BLRDA=""  D
  1.  . Q:'BLRDA
  1.  . S BLRIEN=0 F  S BLRIEN=$O(BLRSHP(BLRDA,"COMMENT",BLRIEN)) Q:'BLRIEN  D
  1.  .. S BLRDATA=$G(BLRSHP(BLRDA,"COMMENT",BLRIEN))
  1.  .. I '$D(^TMP("BLRRL",$J,BLRDA,"COMMENT",BLRIEN)) S ^TMP("BLRRL",$J,BLRDA,"COMMENT",BLRIEN)=BLRDATA
  1.  ;
  1.  Q