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

BLREVTQ.m

Go to the documentation of this file.
  1. BLREVTQ(BLRCMF,BLRPHASE,BLROPT,BLRPARAM,BLRIDS) ; IHS/HQT/MJL - EVENT SET QUE TO UPDATE LAB/PCC TRANSACTION ; 22-Oct-2013 09:22 ; MKK
  1. ;;5.2;IHS LABORATORY;**1010,1011,1013,1015,1018,1021,1027,1033**;NOV 01, 1997
  1. CTL ;
  1. D:$G(BLROPTS)="" RSBLROPT ; IHS/OIT/MKK - LR*5.2*1033
  1. ;
  1. Q:$P($G(^BLRSITE(DUZ(2),0)),U,2)=0
  1. S BLRDH=+$H,BLRPHASE=$G(BLRPHASE)
  1. S BLROPT=$G(BLROPT)
  1. S:'$D(BLRQSITE) BLRQSITE=$P($G(^AUTTSITE(1,0)),U)
  1. ;
  1. ; L +^BLRSITE(BLRQSITE,20,BLRDH):2
  1. ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1033
  1. LOCKIT ; EP
  1. L +^BLRSITE(BLRQSITE,20,BLRDH):5 I '$T H 5 G LOCKIT
  1. ; ----- END IHS/OIT/MKK - LR*5.2*1033
  1. ;
  1. S BLRQUE=$P($G(^BLRSITE(BLRQSITE,20,BLRDH,0)),U,2)+1
  1. S $P(^BLRSITE(BLRQSITE,20,BLRDH,0),U,2)=BLRQUE
  1. S:BLRQUE=1 $P(^BLRSITE(BLRQSITE,20,BLRDH,0),U)=DT
  1. L -^BLRSITE(BLRQSITE,20,BLRDH)
  1. ;
  1. S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,0)=$G(BLRCMF)_U_$G(BLRPHASE)_U_$G(BLROPT)_U_$G(BLRPARAM)_U_$G(BLRIDS)_U_$G(DUZ(2))_U_$G(DUZ)
  1. S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"C")=0 ;ENTRY INCOMPLETE
  1. D SETDATA
  1. S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"C")=1 ;ENTRY COMPLETE
  1. ;
  1. ;----- BEGIN IHS MODIFICATIONS LR*5.2*1021 - cmi/anch/maw REF LAB
  1. D ACC^BLRRLEVT ;cmi/maw 11/5/2007 moved for lr p23
  1. ;D ACC ;cmi/maw added for ref lab
  1. ;----- END IHS MODIFICATIONS LR*5.2*1021 - cmi/anch/maw end REF LAB
  1. ;
  1. Q
  1. ;
  1. ;SET UP THE EVENT IN THE 'BLR MASTER CONTROL' FILE
  1. SETDATA ;
  1. I BLROPT="ADDORD",$D(BLRTSTS) M ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTSTS")=BLRTSTS Q
  1. ;
  1. I BLROPT="ADDACC" S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=+$G(LRTS,$G(LRTSTS))
  1. ;
  1. ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1033
  1. ; Moved code to separate subroutines. See below.
  1. I BLRPHASE="R" D RESULTS Q ; IHS/OIT/MKK - LR*5.2*1033 - RESULTS BEING ENTERED
  1. ;
  1. I BLRPHASE="D" D DELETION Q ; IHS/OIT/MKK - LR*5.2*1033 - DELETION PHASE
  1. ; ----- END IHS/OIT/MKK - LR*5.2*1033
  1. ;
  1. I BLROPT="ADDCOL" S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRPSN")=$G(LRPSN,$G(LRSN))
  1. ;
  1. Q
  1. ;
  1. ;----- BEGIN IHS MODIFICATIONS LR*5.2*1021
  1. ACC ;EP - cmi/flag/maw added the following for ref lab accessions
  1. ;cmi/anch/maw REF LAB
  1. ;Q
  1. ;
  1. 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)
  1. . Q:'$G(LROLLOC)
  1. . Q:'$P($G(^SC(LROLLOC,0)),U,4)
  1. . S BLRALTDZ=$P($G(^SC(LROLLOC,0)),U,4)
  1. . Q:'+$G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL"))
  1. . S LRDUZ(2)=BLRALTDZ
  1. Q:BLRPHASE'="A" ;quit if not an accession
  1. ;
  1. K BLRRL,BLRRLC ;kill off existing BLRRL array
  1. S BLRRL("LRTS")=$S(+$G(LRTS):+LRTS,1:$G(LRTSORU))
  1. Q:$G(BLRRL("LRTS"))="" ;1/23/2006 don't proceed without a test
  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 I '$O(BLRRLC(0)),$P($G(XQY0),U)'="LRPHMAN" S BLRRLSUC=$$COM^BLRRLCOM(BLRRL("LRTS")) ;cmi/anch/maw modified due to routine collect no LRTS 9/8/2004
  1. I $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(.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("ALTDUZ2")=$G(BLRALTDZ) ;cmi/maw 5/29/2007 setup alternate duz2 if they select the prompt in blrsite to look at ordering location
  1. 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
  1. 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
  1. S BLRRL("RL")=+$G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")) ;ref lab site maw modified 5/29/2007
  1. Q:'BLRRL("RL")
  1. S BLRRL("BI")=$P($G(^BLRRL(BLRRL("RL"),0)),U,10) ;bi or unidirectional
  1. S BLRRL("RLE")=$P($G(^BLRRL(BLRRL("RL"),0)),U) ;get external name
  1. ;cmi/anch/maw 3/3/2006 lets try this for account number
  1. 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. ;cmi/anch/maw 3/3/2006 end of mods
  1. I $G(BLRRL("BI")) Q:$P($G(^BLRRL(BLRRL("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. Q:$G(BLRRL("ACCA"))=""
  1. S BLR("ACCAREA")=$O(^LRO(68,"B",BLRRL("ACCA"),0)) ;get ien of accession area
  1. Q:BLR("ACCAREA")="" ;don't proceed if not an SO area
  1. Q:'$D(^BLRRL("ACC",BLR("ACCAREA"),BLRRL("RL"))) ;quit when not a sendout area
  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. 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("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")
  1. . S BLRRL("ORDP")=BLRRL("ORDPUPIN")_"^"_BLRRL("ORDPNM")
  1. S BLRTSTI=+$G(LRTS) ;get test ien
  1. Q:'$D(^LAB(60,BLRTSTI,8,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)) ;quit if no accession area
  1. S BLRAREA=$P($G(^LAB(60,BLRTSTI,8,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)),U,2) ;get acc area
  1. Q:BLRAREA="" ;quit if accession area field is null
  1. Q:BLRAREA'=BLR("ACCAREA") ;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("TCODE")=$$CODE(BLRRL("RL"),BLRRL("TST")) ;lookup test code
  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. S BLRRL("URG")=$G(LRURG)
  1. S BLRRL("LOC")=$G(LRLLOC)
  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/maw 10/31/07 ask what type of billing here
  1. ;S DIR(0)="S^C:Client;T^Third Party;P:Patient"
  1. ;S DIR("A")="Which Party is Responsible for Billing: "
  1. ;S DIR("B")="Client"
  1. ;D ^DIR
  1. ;S BLRRL("BILL TYPE")=Y
  1. ;I $D(DIRUT) S BLRRL("BILL TYPE")="Client"
  1. ;K DIR
  1. ;cmi/maw 10/31/07 end of mods
  1. D TMPSET(.BLRRL)
  1. I $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
  1. Q
  1. ;
  1. TMPSET(BLRSHP) ;-- setup the array for the shipping manifest
  1. N BLRDA,BLRDATA
  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. N 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. N 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. Q
  1. ;
  1. CODE(RL,TST) ;lookup the test code via prefix and test
  1. K BLRTCODE
  1. I '$D(^BLRRL(RL,1,0)) Q 0
  1. S BLRRDA=0 F S BLRRDA=$O(^BLRRL("ALP",TST,RL,BLRRDA)) Q:'BLRRDA!($G(BLRTCODE)]"") D
  1. . S BLRTCODE=$P($G(^BLRRL(RL,1,BLRRDA,0)),U,3)
  1. . Q:$G(BLRTCODE)]""
  1. I $G(BLRTCODE)="" Q 0
  1. Q BLRTCODE
  1. ;cmi/anch/maw end REF LAB
  1. ;
  1. DISAAQ(BLRCNT,TIEN,AAQ) ;-- display the ask at order questions
  1. N A,BLRCNT
  1. S BLRCNT=0
  1. S A=0 F S A=$O(AAQ(TIEN,A)) Q:'A D
  1. . S BLRCNT=BLRCNT+1
  1. . W !,A_") ",$P(AAQ(TIEN,A),U,2),?50,$P(AAQ(TIEN,A),U,3)
  1. W !
  1. N RES
  1. K DIR
  1. S DIR(0)="N^1:"_BLRCNT
  1. S DIR("A")="Edit Which Ask At Accession Question "
  1. D ^DIR
  1. Q:$D(DIRUT)
  1. S RES=+Y
  1. K DIR
  1. S DIR(0)="F",DIR("A")=$P(AAQ(TIEN,RES),U,2)
  1. S DIR("B")=$P(AAQ(TIEN,RES),U,3)
  1. D ^DIR
  1. Q:$D(DIRUT)
  1. S $P(BLRRLC(TIEN,RES),U,3)=Y
  1. Q
  1. ;
  1. ;----- END IHS MODIFICATIONS LR*5.2*1021
  1. ;
  1. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
  1. ; Code moved to here to keep logic above from being obscured.
  1. RESULTS ; EP
  1. ;M ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRCOM")=^LR(LRDFN,LRSS,9999999-$S($D(LRCDT):LRCDT,1:LRI),1)
  1. M ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRCOM")=^LR(LRDFN,LRSS,9999999-$S($D(LRCDT):LRCDT,$D(LRI):LRI,1:LRIDT),1) ;IHS/ITSC/TPF 08/25/02 FIXED PROBLEM AT TALEQUAW **1015**
  1. ;
  1. ;AFTER MERGING THE TESTS IN, KILL THE B X-REF WE DONT NEED IT
  1. K ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRCOM","B")
  1. ;
  1. I $D(LRORDCOM) S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRORDCOM")=LRORDCOM
  1. I $D(LRDFN) S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRDFN")=LRDFN
  1. I $D(LRSPEC) S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRSPEC")=LRSPEC S:$D(SEX) ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"SEX")=SEX S:$D(AGE) ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"AGE")=AGE
  1. ;
  1. I BLROPT="BBANK" D Q
  1. . S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRDFN")=LRDFN,^("LRCDT")=9999999-LRI,^("LRIDT")=LRI,^("BLRTEST")=LRT,^("BLRTESTN")=$P(LRT(LRT),U),^("DR")=$G(DR)
  1. ;
  1. I BLROPT="MICRO" D Q
  1. . ;----- BEGIN IHS MODIFICATIONS LR*5.2*1016 IHS TESTING CHANGE
  1. . S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRSAMP")=$G(LRSAMP)
  1. . ;----- END IHS MODIFICATIONS
  1. . S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRAA")=LRAA,^("LRAD")=LRAD,^("LRAN")=LRAN,^("LRSS")=LRSS,^("LRODT")=LRODT,^("LRCDT")=LRCDT,^("LRSN")=LRSN
  1. . S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRDFN")=LRDFN,^("LRIDT")=LRIDT,^("BLRTEST")=$S($D(LRTS):LRTS,1:LRTEST)
  1. . S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRDFN")=LRDFN,^("LRIDT")=LRIDT,^("BLRTEST")=+$S($D(LRTS):LRTS,1:LRTEST) ;IHS/ITSC/TPF 9/24/02 **1014**
  1. ;
  1. M:$D(LRSB) ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRSB")=LRSB
  1. ;
  1. S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRAA")=LRAA,^("LRAD")=LRAD,^("LRAN")=LRAN,^("LRSS")=LRSS,^("LRODT")=LRODT,^("LRCDT")=$G(LRCDT),^("LRSN")=LRSN
  1. S:BLROPT="BYPASS" ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=$G(LRTY,$G(LRTNUM))
  1. S:BLROPT="ACCORD" ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=$G(LRTNUM)
  1. Q
  1. ;
  1. DELETION ; EP
  1. S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRODTM")=$P($S($D(LROD0):LROD0,1:^LRO(69,LRODT,1,LRSN,0)),U,5)
  1. ;I $G(BLRPARAM)["TESTS" S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=$P(T(J),U,3),^("LRSN")=+T(J) Q
  1. ;----- BEGIN IHS MODIFCATIONS LR*5.2*1016 IHS TESTING CHANGE
  1. I $G(BLRPARAM)["TESTS" S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=$P($G(T(J)),U,3),^("LRSN")=+$G(T(J)) Q
  1. ;
  1. I BLROPT="DELACC" S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRACCN")=^LRO(68,$P(BLRIDS,","),1,$P(BLRIDS,",",2),1,$P(BLRIDS,",",3),.2),^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=LRTSTS Q
  1. M:$D(T) ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"T")=T
  1. ;
  1. Q
  1. ;
  1. RSBLROPT ; EP -- Set/Reset BLROPT variable
  1. Q:$L($G(LRACC))<1 ; If Accession null, skip
  1. ;
  1. Q:$L($O(^BLRTXLOG("D",LRACC,0))) ; If Accession in 9009022, skip
  1. ;
  1. ; S BLROPT="BYPASS" ; Hard set BLROPT
  1. ;
  1. Q
  1. ; ----- END IHS/MSC/MKK - LR*5.2*1033