LRVER3A ;DALOI/FHS - DATA VERIFICATION;Sep 27, 2018@10:00:00
;;5.2;LAB SERVICE;**1,5,42,100,121,153,190,221,254,263,266,274,295,373,350,512,524,538,545**;Sep 27, 1994;Build 5
;
; Also contains LRORFLG to restrict multiple OERR alerts (VER+2)
; Reference to ^DIC(42 supported by IA #10039
;
VER ; Call with L ^LR(LRDFN,LRSS,LRIDT) from LRGV2, LRGVG1, LRSTUF1, LRSTUF2, LRVR3
Q:'$O(LRSB(0))
K ^TMP("LR",$J,"PANEL")
;
N LRVCHK,LRORTST,LRORFLG,LRT
S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),(LRAOD,LRACD)=$P(^(0),U,3)
S LRACD=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,9)):^(9),1:LRACD)
S:'($D(^LRO(68,LRAA,1,LRACD,1,LRAN,0))#2) LRACD=LRAD
S LRAOD=$S($D(^LRO(68,LRAA,1,LRAOD,1,LRAN,0))#2:LRAOD,1:LRAD)
I '$G(LRFIX) S LRNOW=$$NOW^XLFDT,$P(^LR(LRDFN,LRSS,LRIDT,0),U,3,4)=LRNOW_U_$S($G(LRDUZ):LRDUZ,1:DUZ)
K A2
I '$D(PNM) S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX S:PNM="" PNM="NONAME"
N LRT
S LRT=0
F S LRT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT)) Q:LRT<.5 S:$P(^(LRT,0),U,5)="" A2(LRT)=1 I $D(^TMP("LR",$J,"VTO",LRT)) S LRVCHK=+^(LRT) D
. ;LR*5.2*545: Test might have been run on instrument and then canceled
. ; or merged to another accession.
. ; Do not verify results for canceled or merged tests.
. ;Only checking for "Not Performed" and "Merged" in case other dispositions
. ;are added in future releases.
. Q:$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),U,6)["*Not Performed"!($P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),U,6)["*Merged")
. I $S(LRVCHK<1:1,$D(LRSB(LRVCHK))#2:1,1:0) D
. . I $D(LRSB(LRVCHK)) Q:$P(LRSB(LRVCHK),U)=""
. . I LRVCHK<1,$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),U,6)'="" Q
. . ;
. . ;LR7OB3 will correctly evaluate the panel status due to setting of ^XTMP("LR",$J,"PANEL"..
. . ;Panel statuses (i.e LRVCHK<1) will be set after all component statuses are
. . ;evaluated
. . I LRVCHK>1 D
. . . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"")
. . . I '$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,5) S $P(^(0),U,5)=LRNOW
. . . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,6)="",$P(^(0),U,8)=$G(LRCDEF)
. . S LRORTST(LRT)=""
. . ;
. . I LRVCHK>1,LRACD'=LRAD,$D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0)) D
. . . S $P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"")
. . . I '$P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0),U,5) S $P(^(0),U,5)=LRNOW
. . . S $P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0),U,6)="",$P(^(0),U,8)=$G(LRCDEF)
. . I $P($G(LRPARAM),U,14),$P($G(^LRO(68,+LRAA,0)),U,16) S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
. . K A2(LRT)
;
S D1=1,X=0
F S X=$O(^TMP("LR",$J,"TMP",X)) Q:X<1 S LRT=+^(X) I $D(LRM(X)) D REQ
I $D(^LRO(69,LRODT,1,LRSN,0)) S ^(3)=$S($D(^(3)):+^(3),1:LRNOW) S:'$P(^(3),U,2) $P(^(3),U,2)=LRNOW
;LR*5.2*524 - line below was moved to after the "PANEL" call
;keeping previous location commented out below in case it is needed for later research
;I D1,'$D(A2) S:'$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRAD,1,"AC",LRNOW,LRAN)=""
; Class I CareVue routine TASKED if CareVue ward - pwc/10-2000
D
. N I,LR7DLOC D IN5^VADPT S LR7DLOC=$G(^DIC(42,+$P($G(VAIP(5)),"^"),44))
. Q:'LR7DLOC D:$D(^LAB(62.487,"C",LR7DLOC)) ;good ward location
. . S ZTRTN="^LA7DLOC",ZTDESC="LAB AUTOMATION CAREVUE SUPPORTED WARDS"
. . S ZTIO="",ZTDTH=$H,ZTSAVE("L*")="" D ^%ZTLOAD
. . K ZTSAVE,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTREQ,ZTQUEUED
;
;LR*5.2*524 - line below was moved to after the "PANEL" call
;keeping previous location commented out below in case it is needed for later research
;I D1,'$D(A2),LRAD'=LRACD S:'$P(^LRO(68,LRAA,1,LRACD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRACD,1,"AC",LRNOW,LRAN)=""
D XREF I $D(^LRO(68,LRAA,.2))'[0 X ^(.2)
;
;LR*5.2*512 added panel evaluation which builds ^TMP("LR",$J,"PANEL",order number)=status
;Routine LR7OB3 evaluates the panel status before setting "CM" or "SC" in the ORC segment.
D PANEL
;
I D1,'$D(A2),LRAD'=LRACD S:'$P(^LRO(68,LRAA,1,LRACD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRACD,1,"AC",LRNOW,LRAN)=""
I D1,'$D(A2) S:'$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRAD,1,"AC",LRNOW,LRAN)=""
N CORRECT S:$G(LRCORECT) CORRECT=1 D NEW^LR7OB1(LRODT,LRSN,"RE",,.LRORTST)
L -^LR(LRDFN,LRSS,LRIDT) ; unlock
;second kill to be safe
K ^TMP("LR",$J,"PANEL")
Q
;
;
XREF ; from COM1^LRVER4, LRTSTOUT and VER^LRVER3A
I LRDPF=62.3 S ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)="" Q
S LRPRAC=$$PRAC^LRX($P(^LR(LRDFN,LRSS,LRIDT,0),U,10)) ;get doc name
S ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)=""
S ^LRO(69,9999999-LRIDT\1,1,"AP",LRPRAC,$E(PNM,1,30),LRDFN)=""
I $G(LRLLOC)'="" D
. S ^LRO(69,9999999-LRIDT\1,1,"AL",$E(LRLLOC,1,20),$E(PNM,1,30),LRDFN)=""
. S ^LRO(69,DT,1,"AN",$E(LRLLOC,1,20),LRDFN,LRIDT)=""
. S ^LRO(69,DT,1,"AR",$E(LRLLOC,1,20),$E(PNM,1,30),LRDFN)=""
. S ^LRO(69,"AN",$E(LRLLOC,1,20),LRDFN,LRIDT)=""
I LRDPF=2 D CHSET^LRPX(LRDFN,LRIDT)
Q:'$P(LRPARAM,U,3)
;
TSKM ;
N KK,ZTSK,ZTRTN,ZTDTH,ZTSAVE,ZTIO
F KK="LRDFN","LRAA","LRAOD","LRAD","LRAN","LRIDT","LRSS","LRLLOC","LRSN","LRODT" S ZTSAVE(KK)=""
S ZTRTN="DQ^LRTP",ZTIO="",ZTDTH=$H,ZTDESC="LAB INTERIM REPORTS" D ^%ZTLOAD
Q
;
PANEL ;
;LRCOMP - array which updates parent levels in file 68
;LRCOMP2 - array used to update file 100
N LRPNL,LRCOMP,LRCOMP2,LRPARENT,LR69TST,LRORDTST,LRDONE,LROR100,LRCPORD
D PANEL1,PANEL2
;^TMP("LR",$J,"PANEL" used by LR7OB3 to update CPRS status
S LRPARENT=""
F S LRPARENT=$O(LRCOMP(LRPARENT)) Q:'LRPARENT D
. ;if only an atomic test was specified in a subsequent verification
. ;session, only the parent might have been set into the A2 array
. ;A2 is used to determine whether the overall status of the accession at
. ;the "3" subscript should be set to complete
. I LRCOMP2(LRPARENT) K A2(LRPARENT)
. S LRORDTST=$G(LROR100(LRPARENT))
. Q:LRORDTST']""
. ;This parent was not ordered in CPRS as the overall panel.
. Q:'$D(LRCPORD(LRORDTST,LRPARENT))
. S ^TMP("LR",$J,"PANEL",LRORDTST)=LRCOMP2(LRPARENT)
Q
;
PANEL1 ;gather panel components and related information
;
N LRTST,LRSTR,LRPANX,LRSUBAR,LR68X,LRPANELX
S LRTST=0
F S LRTST=$O(^TMP("LR",$J,"VTO",LRTST)) Q:'LRTST D
. ;check to see if the test is a panel within a panel
. ;LRCOMP is initially set to "not complete". If any component is verified/complete,
. ;the status will be set to "complete" for a later complete date/time set in file 68
. ;at subscript 4 for the panel.
. ;LRCOMP2 is initially set to "complete". If any components are NOT verified/complete,
. ;the status will be set to "not complete" for later determination of file 100
. ;status.
. I $O(^LAB(60,LRTST,2,0)),'$D(LRCOMP(LRTST)) S LRCOMP(LRTST)=0,LRCOMP2(LRTST)=1
. S LRPARENT=$P($G(^TMP("LR",$J,"VTO",LRTST,"P")),U)
. ;not a panel, so quit
. I LRPARENT']""!('$O(^LAB(60,+LRPARENT,2,0))) Q
. ;initialize if first time evaluating this parent
. I '$D(LRCOMP(LRPARENT)) S LRCOMP(LRPARENT)=0,LRCOMP2(LRPARENT)=1
. ;panel should be set in LRORTST array for use by
. ;downstream LR7OB* routines
. S LRORTST(LRPARENT)=""
. ;does this panel contain other panels
. D SUBPAN(LRPARENT)
D OR100
F S LRTST=$O(LRCOMP(LRTST)) Q:'LRTST D
. ;check whether all atomic tests have correct status, etc.
. D ATOMIC(LRTST)
. ;retrieve all atomic tests for this parent
. I '$D(LRPNL(LRTST)) D LRTST(LRTST,LRTST,1)
. ;If there are still no LRPNL array entries, there are no required tests
. ;in this panel. In that case, set LRCOMP to 1 so that the panel in file 68 will
. ;be marked as complete if any tests have been verified.
. I '$D(LRPNL(LRTST)),$G(LRPANELX(LRTST)) S LRCOMP(LRTST)=1
Q
;
SUBPAN(LRPRCHK) ;
;find all sub-panels within panels
N LRSUBPXN,LRSUBTST
S LRSUBPXN=0
F S LRSUBPXN=$O(^LAB(60,LRPRCHK,2,LRSUBPXN)) Q:'LRSUBPXN D
. S LRSUBTST=$P($G(^LAB(60,LRPRCHK,2,LRSUBPXN,0)),U)
. Q:LRSUBTST']""
. ;If the test being verified is a component of a panel within a panel, and the
. ;user selected only the test (not "all"), the package reference field in file 100
. ;won't be set by downstream routines if LRORTST isn't set for the sub-panel.
. I LRSUBTST=LRTST S LRORTST(LRPRCHK)=""
. I $O(^LAB(60,LRSUBTST,2,0))]"" D
. . ;this is also a panel
. . I '$D(LRCOMP(LRSUBTST)) S LRCOMP(LRSUBTST)=0,LRCOMP2(LRSUBTST)=1
. . ;will need to later evaluate all components of this panel
. . ;to determine whether any are also panels
. . S LRSUBAR(LRSUBTST)=""
;not finished yet going through LRSUBAR2
I $O(LRSUBAR2(LRPRCHK))'="" Q
;
N LRSUBAR2
I $O(LRSUBAR(0))]"" D
. N LRSUBSQ
. ;LRSUBAR might be re-set so need to keep values for this loop
. ;in LRSUBAR2
. M LRSUBAR2=LRSUBAR
. K LRSUBAR
. S LRSUBSQ=0
. F S LRSUBSQ=$O(LRSUBAR2(LRSUBSQ)) Q:'LRSUBSQ D SUBPAN(LRSUBSQ)
Q
;
OR100 ;
;are parents a sub-panel under a profile which was ordered
N LRX69,LRX100,LRX10143,LRX60
S LRX69=0
F S LRX69=$O(^LRO(69,LRODT,1,LRSN,2,LRX69)) Q:'LRX69 D
. S LRX100=$P($G(^LRO(69,LRODT,1,LRSN,2,LRX69,0)),U,7)
. Q:LRX100']""
. ;used later in PANEL to find order number again
. S LRX60=$P($G(^LRO(69,LRODT,1,LRSN,2,LRX69,0)),U) Q:LRX60=""
. S LROR100(LRX60)=LRX100
. S LRX10143=0
. F S LRX10143=$O(^OR(100,LRX100,.1,"B",LRX10143)) Q:'LRX10143 D
. . S LRX60=$P($P($G(^ORD(101.43,LRX10143,0)),U,2),";")
. . ;store Lab test which was ordered in CPRS for each
. . ;order number - validates in PANEL section before setting
. . ;^TMP("LR",$J,"PANEL" which is used by LR7OB3 to determine
. . ;CPRS order status of active or complete
. . ;If this parent is a sub-panel under a profile which was ordered,
. . ;the value of LRX60 will differ from the value of LRPARENT
. . Q:LRX60']""
. . S LRCPORD(LRX100,LRX60)=""
. . ;if ordered test is not yet in LRCOMP, add because overall status
. . ;needs to be determined
. . I '$D(LRCOMP(LRX60)),$O(^LAB(60,LRX60,2,0))]"" S LRCOMP(LRX60)=0,LRCOMP2(LRX60)=1
Q
;
ATOMIC(LR68X) ;
;if component has been resulted but has been set previously
;into ^LRO(68, the LRCAP* routines won't update the complete date
;correcting the issue here so that all panel related logic is
;in one place
;
N LR63,LR68Y,LR68Z,LR63RES
S LR63=$P($P(^LAB(60,LR68X,0),U,5),";",2),LR63RES=0
;LRPNLX is used to track whether at least one component of a panel which contains
;only non-required tests has been resulted.
I LR63]"",$D(LRSB(LR63)),$P(LRSB(LR63),U)]"",$P(LRSB(LR63),U)'["pending" D
. S LR63RES=1
. S LRPANELX(LR68X)=1
I LR63RES,$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LR68X,0)) D
. I '$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LR68X,0),U,4) S $P(^(0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"")
. I '$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LR68X,0),U,5) S $P(^(0),U,5)=LRNOW
. ;kill component out of A2 (if present) if it wasn't exploded out in ^TMP("LR",$J,"VT"
. K A2(LR68X)
. ;not setting workload suffix field (#8) if disposition field (#6) is already set
. ;so as to not affect workload already counted
. I '$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LR68X,0),U,6) S $P(^(0),U,8)=$G(LRCDEF)
. I $G(LRACD)]"",LRACD'=LRAD,$D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LR68X,0)) D
. . I '$P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LR68X,0),U,4) S $P(^(0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"")
. . I '$P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LR68X,0),U,5) S $P(^(0),U,5)=LRNOW
. . ;not setting workload suffix field (#8) if disposition field (#6) is already set
. . ;so as to not affect workload already counted
. . I '$P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LR68X,0),U,6) S $P(^(0),U,8)=$G(LRCDEF)
;check atomic tests if this test is a panel which has not been broken out in ^TMP("LR",$J,"VTO"
I $O(^LAB(60,LR68X,2,0))]"" D
. S LR68Y=0
. F S LR68Y=$O(^LAB(60,LR68X,2,LR68Y)) Q:'LR68Y D
. . S LR68Z=$P(^LAB(60,LR68X,2,LR68Y,0),U)
. . I LR68Z]"" D ATOMIC(LR68Z)
. . I $G(LRPANELX(LR68Z)) S LRPANELX(LR68X)=1
Q
;
LRTST(LRPARENT,LRSUB,LRGO) ;
;retrieve all required tests for a panel
N LRA,LRTEST,LRTESTX,LRDISP,LRTX,LRPANZ,LRAAX
S LRA=0
F S LRA=$O(^LAB(60,LRSUB,2,LRA)) Q:'LRA D
. S LRTEST=+$G(^LAB(60,LRSUB,2,LRA,0)) Q:'LRTEST
. I $O(^LAB(60,LRTEST,2,0))]"" D Q
. . ;this is a panel within a panel - store for later evaluation
. . S LRPANZ(LRTEST)=""
. ;check to see if this test is a required test
. I $P($G(^LAB(60,LRTEST,0)),U,17) D
. . ;get information for each atomic test within the panel
. . D LRPNL
;if LRGO is 0, panels within panels are being evaluated
;so need to store off the panels within panels within panels
I 'LRGO,$D(LRPANZ) M LRPANZ1=LRPANZ
;
I LRGO,$D(LRPANZ1) M LRPANZ=LRPANZ1 K LRPANZ1
;
;break down panels within panels
I $D(LRPANZ),LRGO D
. ;must merge to new array because LRPANZ might be
. ;re-created for panels within panels within panels...
. K LRPANX
. M LRPANX=LRPANZ K LRPANZ
. S LRB="",LRDONE=0
. F S LRB=$O(LRPANX(LRB)) Q:'LRB D
. . ;flag that this is the last entry in the array indicates
. . ;that may continue looking for panel within a panel
. . I $O(LRPANX(LRB))="" S LRDONE=1
. . D LRTST(LRPARENT,LRB,LRDONE)
. ;
. ;a second kill of LRPANX is needed for certain situations
. ;when a single panel is embedded within another panel.
. ;Execution occurs twice which causes no harm, but adding
. ;second kill in case a situation occurs which would cause
. ;an endless loop.
. K LRPANX
Q
;
LRPNL ;
N LRTX,LRSTR,LRAAX,LRADX,LRANX,LRIDTX,LRTXI
S LRTX=$P(^LAB(60,LRTEST,0),U,5)
Q:LRTX']""
;LR*5.2*538 - allow for the fact that a test might exist on more than
; one subscript
S LRTXI=0
LRPNL1 ;
S LR69TST=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRSUB,LRTXI))
I LR69TST,$P($G(^LRO(69,LRODT,1,LRSN,2,LR69TST,0)),U,9)="CA" S LRTXI=LR69TST G LRPNL1
;Accession area and accession number might differ among components
I 'LR69TST S LR69TST=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRTEST,LRTXI))
I LR69TST,$P($G(^LRO(69,LRODT,1,LRSN,2,LR69TST,0)),U,9)="CA" S LRTXI=LR69TST G LRPNL1
Q:'LR69TST
S LRSTR=$G(^LRO(69,LRODT,1,LRSN,2,LR69TST,0))
S LRAAX=$P(LRSTR,U,4)
S LRADX=$P(LRSTR,U,3)
S LRANX=$P(LRSTR,U,5)
S LRIDTX=$P($G(^LRO(68,+LRAAX,1,+LRADX,1,+LRANX,3)),U,5)
;LRPNL(LRPARENT,LRTEST)=File 63 dept (2nd) subscript^File 63 test (4rd) subscript^accession area
; ^accession date^accession number^File 63 inverted date/time (3rd) subscript
S LRPNL(LRPARENT,LRTEST)=$P(LRTX,";")_U_$P(LRTX,";",2)_U_LRAAX_U_LRADX_U_LRANX_U_LRIDTX
Q
;
PANEL2 ;
;evaluate all components / atomic tests of each parent
N LRPARENT,LRTX,LRTSTX,LRSTR,LR63X,LRAAX,LRADX,LRANX,LRIDTX,LRADX2,LR63STR
;
;LRPNL(PARENT,TEST NUMBER)=FILE 63 DEPT (2ND) SUBSCRIPT_"^"_TEST (4TH) SUBSCRIPT IN FILE 63
; _"^"_ACCESSION AREA IN FILE 68_"^"_ACCESSION DATE_"^"_
; ACCESSION NUMBER"_"^"_FILE 63 INVERTED DATE/TIME (3RD) SUBSCRIPT
;
S (LRPARENT,LRTSTX)=""
F S LRPARENT=$O(LRPNL(LRPARENT)) Q:LRPARENT="" D
. F S LRTSTX=$O(LRPNL(LRPARENT,LRTSTX)) Q:LRTSTX="" D
. . S LRSTR=LRPNL(LRPARENT,LRTSTX)
. . ;
. . ;LR63X = file 63 dept subscript
. . ;LRTX = file 63 test subscript
. . ;LRAAX = accession area
. . ;LRADX = accession date
. . ;LRANX = accession number
. . ;LRIDTX = file 63 inverted date/time subscript
. . S LR63X=$P(LRSTR,U)
. . S LRTX=$P(LRSTR,U,2)
. . S LRAAX=$P(LRSTR,U,3)
. . S LRADX=$P(LRSTR,U,4)
. . S LRANX=$P(LRSTR,U,5)
. . S LRIDTX=$P(LRSTR,U,6)
. . I $G(^LRO(68,+LRAAX,1,+LRADX,1,+LRANX,9)) S LRADX=^LRO(68,+LRAAX,1,+LRADX,1,+LRANX,9)
. . I LRIDTX>1,LR63X]"" S LR63STR=$G(^LR(LRDFN,LR63X,+LRIDTX,+LRTX)) D
. . . ;This component is still pending, so order in file 100 should not be "complete"
. . . ;since at least one component of a panel is pending.
. . . I LR63STR=""!($P(LR63STR,U)["pending") S LRCOMP2(LRPARENT)=0 Q
. . . ;This component has been verified. File 68 status for the parent should be complete
. . . ;since at least one component has been verified.
. . . S LRCOMP(LRPARENT)=1
;update parent level in file 68
D UPDPAR
Q
;
UPDPAR ;
;
;If the panel encompasses multiple accession areas, an entry may
;not be present in file 68 at the panel level.
;
S LRPARENT=""
F S LRPARENT=$O(LRCOMP(LRPARENT)) Q:LRPARENT="" D
. I '$G(LRCOMP(LRPARENT))!('$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0))) Q
. ;LR*5.2*545: add check as to whether the parent (i.e. panel) has been merged or canceled
. Q:$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0),U,6)["*Not Performed"!($P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0),U,6)["*Merged")
. S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"")
. I '$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0),U,5) S $P(^(0),U,5)=LRNOW
. S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0),U,6)="",$P(^(0),U,8)=$G(LRCDEF)
. I $G(LRACD)]"",LRACD'=LRAD,$D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRPARENT,0)) D
. . S $P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRPARENT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"")
. . I '$P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRPARENT,0),U,5) S $P(^(0),U,5)=LRNOW
. . S $P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRPARENT,0),U,6)="",$P(^(0),U,8)=$G(LRCDEF)
Q
;
REQ ;
Q:$P($G(LRSB(X)),U)="comment"
I $D(LRSB(X)),$P(LRSB(X),U)="canc" Q
I $D(LRSB(X)),$P(LRSB(X),U)'["pend" Q
I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)),U,6)'="" Q
S:'$G(LRALERT) LRALERT=$S($G(LROUTINE):LROUTINE,1:9)
S D1=0 N A,LRPPURG
I $D(LRSB(X)),LRSB(X)["pending",$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 D Q
. S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)="",$P(^(0),U,5,6)="^",$P(^(0),U,9)=+$G(LRM(X,"P"))
. D REQ1
;
; If required test with no result then store 'pending' and related info (NLT/LOINC codes, user and division).
I '$D(LRSB(X)),$P($G(^LR(LRDFN,"CH",LRIDT,X)),U)="" D STOREP
;
I '$D(LRSB(X)),$P($G(^LR(LRDFN,"CH",LRIDT,X)),U)'="pending" Q
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 S $P(^(0),U,4,5)="^",A=$P(^(0),U,2) I A>49 S $P(^(0),U,2)=$S(A=50:9,1:A-50)
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 D
. S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",+LRT,+LRT)=""
. S LRPPURG=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+$G(LRM(X,"P")),0)),U,2)
. S:'LRPPURG LRPPURG=$S($G(LRALERT):+LRALERT,1:9)
. S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)=+LRT_U_LRPPURG,$P(^(0),U,9)=+$G(LRM(X,"P"))
. S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),U,3)=+LRT,$P(^(0),U,4)=$P(^(0),U,4)+1 Q
;
REQ1 ;
Q:LRACD=LRAD
I $D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0))#2,'$L($P(^(0),U,6)) S ^(0)=$P(^(0),U,1,2),$P(^(0),U,7)=1,$P(^(0),U,9)=+$G(LRM(X,"P"))
K CNT,LRAMC
Q
;
;
STOREP ; Store pending as a result
N LRX
S LRX=$G(^LR(LRDFN,"CH",LRIDT,X))
S $P(LRX,"^")="pending"
I $P(LRX,"^",3)="" S $P(LRX,"^",3)=$P($G(LRM(X,"P")),"^",2)
S $P(LRX,"^",4)=$S($G(LRDUZ):LRDUZ,1:$G(DUZ))
S $P(LRX,"^",9)=$S($G(DUZ(2)):DUZ(2),1:"")
S ^LR(LRDFN,"CH",LRIDT,X)=LRX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVER3A 19024 printed Apr 09, 2024@21:06:11 Page 2
LRVER3A ;DALOI/FHS - DATA VERIFICATION;Sep 27, 2018@10:00:00
+1 ;;5.2;LAB SERVICE;**1,5,42,100,121,153,190,221,254,263,266,274,295,373,350,512,524,538,545**;Sep 27, 1994;Build 5
+2 ;
+3 ; Also contains LRORFLG to restrict multiple OERR alerts (VER+2)
+4 ; Reference to ^DIC(42 supported by IA #10039
+5 ;
VER ; Call with L ^LR(LRDFN,LRSS,LRIDT) from LRGV2, LRGVG1, LRSTUF1, LRSTUF2, LRVR3
+1 if '$ORDER(LRSB(0))
QUIT
+2 KILL ^TMP("LR",$JOB,"PANEL")
+3 ;
+4 NEW LRVCHK,LRORTST,LRORFLG,LRT
+5 SET LRORU3=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
SET (LRAOD,LRACD)=$PIECE(^(0),U,3)
+6 SET LRACD=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,9)):^(9),1:LRACD)
+7 if '($DATA(^LRO(68,LRAA,1,LRACD,1,LRAN,0))#2)
SET LRACD=LRAD
+8 SET LRAOD=$SELECT($DATA(^LRO(68,LRAA,1,LRAOD,1,LRAN,0))#2:LRAOD,1:LRAD)
+9 IF '$GET(LRFIX)
SET LRNOW=$$NOW^XLFDT
SET $PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,3,4)=LRNOW_U_$SELECT($GET(LRDUZ):LRDUZ,1:DUZ)
+10 KILL A2
+11 IF '$DATA(PNM)
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
if PNM=""
SET PNM="NONAME"
+12 NEW LRT
+13 SET LRT=0
+14 FOR
SET LRT=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT))
if LRT<.5
QUIT
if $PIECE(^(LRT,0),U,5)=""
SET A2(LRT)=1
IF $DATA(^TMP("LR",$JOB,"VTO",LRT))
SET LRVCHK=+^(LRT)
Begin DoDot:1
+15 ;LR*5.2*545: Test might have been run on instrument and then canceled
+16 ; or merged to another accession.
+17 ; Do not verify results for canceled or merged tests.
+18 ;Only checking for "Not Performed" and "Merged" in case other dispositions
+19 ;are added in future releases.
+20 if $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),U,6)["*Not Performed"!($PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),U,6)["*Merged")
QUIT
+21 IF $SELECT(LRVCHK<1:1,$DATA(LRSB(LRVCHK))#2:1,1:0)
Begin DoDot:2
+22 IF $DATA(LRSB(LRVCHK))
if $PIECE(LRSB(LRVCHK),U)=""
QUIT
+23 IF LRVCHK<1
IF $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),U,6)'=""
QUIT
+24 ;
+25 ;LR7OB3 will correctly evaluate the panel status due to setting of ^XTMP("LR",$J,"PANEL"..
+26 ;Panel statuses (i.e LRVCHK<1) will be set after all component statuses are
+27 ;evaluated
+28 IF LRVCHK>1
Begin DoDot:3
+29 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)=$SELECT($GET(LRDUZ):LRDUZ,$GET(DUZ):DUZ,1:"")
+30 IF '$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,5)
SET $PIECE(^(0),U,5)=LRNOW
+31 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,6)=""
SET $PIECE(^(0),U,8)=$GET(LRCDEF)
End DoDot:3
+32 SET LRORTST(LRT)=""
+33 ;
+34 IF LRVCHK>1
IF LRACD'=LRAD
IF $DATA(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0))
Begin DoDot:3
+35 SET $PIECE(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0),U,4)=$SELECT($GET(LRDUZ):LRDUZ,$GET(DUZ):DUZ,1:"")
+36 IF '$PIECE(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0),U,5)
SET $PIECE(^(0),U,5)=LRNOW
+37 SET $PIECE(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0),U,6)=""
SET $PIECE(^(0),U,8)=$GET(LRCDEF)
End DoDot:3
+38 IF $PIECE($GET(LRPARAM),U,14)
IF $PIECE($GET(^LRO(68,+LRAA,0)),U,16)
SET ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
+39 KILL A2(LRT)
End DoDot:2
End DoDot:1
+40 ;
+41 SET D1=1
SET X=0
+42 FOR
SET X=$ORDER(^TMP("LR",$JOB,"TMP",X))
if X<1
QUIT
SET LRT=+^(X)
IF $DATA(LRM(X))
DO REQ
+43 IF $DATA(^LRO(69,LRODT,1,LRSN,0))
SET ^(3)=$SELECT($DATA(^(3)):+^(3),1:LRNOW)
if '$PIECE(^(3),U,2)
SET $PIECE(^(3),U,2)=LRNOW
+44 ;LR*5.2*524 - line below was moved to after the "PANEL" call
+45 ;keeping previous location commented out below in case it is needed for later research
+46 ;I D1,'$D(A2) S:'$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRAD,1,"AC",LRNOW,LRAN)=""
+47 ; Class I CareVue routine TASKED if CareVue ward - pwc/10-2000
+48 Begin DoDot:1
+49 NEW I,LR7DLOC
DO IN5^VADPT
SET LR7DLOC=$GET(^DIC(42,+$PIECE($GET(VAIP(5)),"^"),44))
+50 ;good ward location
if 'LR7DLOC
QUIT
if $DATA(^LAB(62.487,"C",LR7DLOC))
Begin DoDot:2
+51 SET ZTRTN="^LA7DLOC"
SET ZTDESC="LAB AUTOMATION CAREVUE SUPPORTED WARDS"
+52 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTSAVE("L*")=""
DO ^%ZTLOAD
+53 KILL ZTSAVE,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTREQ,ZTQUEUED
End DoDot:2
End DoDot:1
+54 ;
+55 ;LR*5.2*524 - line below was moved to after the "PANEL" call
+56 ;keeping previous location commented out below in case it is needed for later research
+57 ;I D1,'$D(A2),LRAD'=LRACD S:'$P(^LRO(68,LRAA,1,LRACD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRACD,1,"AC",LRNOW,LRAN)=""
+58 DO XREF
IF $DATA(^LRO(68,LRAA,.2))'[0
XECUTE ^(.2)
+59 ;
+60 ;LR*5.2*512 added panel evaluation which builds ^TMP("LR",$J,"PANEL",order number)=status
+61 ;Routine LR7OB3 evaluates the panel status before setting "CM" or "SC" in the ORC segment.
+62 DO PANEL
+63 ;
+64 IF D1
IF '$DATA(A2)
IF LRAD'=LRACD
if '$PIECE(^LRO(68,LRAA,1,LRACD,1,LRAN,3),U,4)
SET $PIECE(^(3),U,4)=LRNOW
SET ^LRO(68,LRAA,1,LRACD,1,"AC",LRNOW,LRAN)=""
+65 IF D1
IF '$DATA(A2)
if '$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4)
SET $PIECE(^(3),U,4)=LRNOW
SET ^LRO(68,LRAA,1,LRAD,1,"AC",LRNOW,LRAN)=""
+66 NEW CORRECT
if $GET(LRCORECT)
SET CORRECT=1
DO NEW^LR7OB1(LRODT,LRSN,"RE",,.LRORTST)
+67 ; unlock
LOCK -^LR(LRDFN,LRSS,LRIDT)
+68 ;second kill to be safe
+69 KILL ^TMP("LR",$JOB,"PANEL")
+70 QUIT
+71 ;
+72 ;
XREF ; from COM1^LRVER4, LRTSTOUT and VER^LRVER3A
+1 IF LRDPF=62.3
SET ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)=""
QUIT
+2 ;get doc name
SET LRPRAC=$$PRAC^LRX($PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,10))
+3 SET ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)=""
+4 SET ^LRO(69,9999999-LRIDT\1,1,"AP",LRPRAC,$EXTRACT(PNM,1,30),LRDFN)=""
+5 IF $GET(LRLLOC)'=""
Begin DoDot:1
+6 SET ^LRO(69,9999999-LRIDT\1,1,"AL",$EXTRACT(LRLLOC,1,20),$EXTRACT(PNM,1,30),LRDFN)=""
+7 SET ^LRO(69,DT,1,"AN",$EXTRACT(LRLLOC,1,20),LRDFN,LRIDT)=""
+8 SET ^LRO(69,DT,1,"AR",$EXTRACT(LRLLOC,1,20),$EXTRACT(PNM,1,30),LRDFN)=""
+9 SET ^LRO(69,"AN",$EXTRACT(LRLLOC,1,20),LRDFN,LRIDT)=""
End DoDot:1
+10 IF LRDPF=2
DO CHSET^LRPX(LRDFN,LRIDT)
+11 if '$PIECE(LRPARAM,U,3)
QUIT
+12 ;
TSKM ;
+1 NEW KK,ZTSK,ZTRTN,ZTDTH,ZTSAVE,ZTIO
+2 FOR KK="LRDFN","LRAA","LRAOD","LRAD","LRAN","LRIDT","LRSS","LRLLOC","LRSN","LRODT"
SET ZTSAVE(KK)=""
+3 SET ZTRTN="DQ^LRTP"
SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTDESC="LAB INTERIM REPORTS"
DO ^%ZTLOAD
+4 QUIT
+5 ;
PANEL ;
+1 ;LRCOMP - array which updates parent levels in file 68
+2 ;LRCOMP2 - array used to update file 100
+3 NEW LRPNL,LRCOMP,LRCOMP2,LRPARENT,LR69TST,LRORDTST,LRDONE,LROR100,LRCPORD
+4 DO PANEL1
DO PANEL2
+5 ;^TMP("LR",$J,"PANEL" used by LR7OB3 to update CPRS status
+6 SET LRPARENT=""
+7 FOR
SET LRPARENT=$ORDER(LRCOMP(LRPARENT))
if 'LRPARENT
QUIT
Begin DoDot:1
+8 ;if only an atomic test was specified in a subsequent verification
+9 ;session, only the parent might have been set into the A2 array
+10 ;A2 is used to determine whether the overall status of the accession at
+11 ;the "3" subscript should be set to complete
+12 IF LRCOMP2(LRPARENT)
KILL A2(LRPARENT)
+13 SET LRORDTST=$GET(LROR100(LRPARENT))
+14 if LRORDTST']""
QUIT
+15 ;This parent was not ordered in CPRS as the overall panel.
+16 if '$DATA(LRCPORD(LRORDTST,LRPARENT))
QUIT
+17 SET ^TMP("LR",$JOB,"PANEL",LRORDTST)=LRCOMP2(LRPARENT)
End DoDot:1
+18 QUIT
+19 ;
PANEL1 ;gather panel components and related information
+1 ;
+2 NEW LRTST,LRSTR,LRPANX,LRSUBAR,LR68X,LRPANELX
+3 SET LRTST=0
+4 FOR
SET LRTST=$ORDER(^TMP("LR",$JOB,"VTO",LRTST))
if 'LRTST
QUIT
Begin DoDot:1
+5 ;check to see if the test is a panel within a panel
+6 ;LRCOMP is initially set to "not complete". If any component is verified/complete,
+7 ;the status will be set to "complete" for a later complete date/time set in file 68
+8 ;at subscript 4 for the panel.
+9 ;LRCOMP2 is initially set to "complete". If any components are NOT verified/complete,
+10 ;the status will be set to "not complete" for later determination of file 100
+11 ;status.
+12 IF $ORDER(^LAB(60,LRTST,2,0))
IF '$DATA(LRCOMP(LRTST))
SET LRCOMP(LRTST)=0
SET LRCOMP2(LRTST)=1
+13 SET LRPARENT=$PIECE($GET(^TMP("LR",$JOB,"VTO",LRTST,"P")),U)
+14 ;not a panel, so quit
+15 IF LRPARENT']""!('$ORDER(^LAB(60,+LRPARENT,2,0)))
QUIT
+16 ;initialize if first time evaluating this parent
+17 IF '$DATA(LRCOMP(LRPARENT))
SET LRCOMP(LRPARENT)=0
SET LRCOMP2(LRPARENT)=1
+18 ;panel should be set in LRORTST array for use by
+19 ;downstream LR7OB* routines
+20 SET LRORTST(LRPARENT)=""
+21 ;does this panel contain other panels
+22 DO SUBPAN(LRPARENT)
End DoDot:1
+23 DO OR100
+24 FOR
SET LRTST=$ORDER(LRCOMP(LRTST))
if 'LRTST
QUIT
Begin DoDot:1
+25 ;check whether all atomic tests have correct status, etc.
+26 DO ATOMIC(LRTST)
+27 ;retrieve all atomic tests for this parent
+28 IF '$DATA(LRPNL(LRTST))
DO LRTST(LRTST,LRTST,1)
+29 ;If there are still no LRPNL array entries, there are no required tests
+30 ;in this panel. In that case, set LRCOMP to 1 so that the panel in file 68 will
+31 ;be marked as complete if any tests have been verified.
+32 IF '$DATA(LRPNL(LRTST))
IF $GET(LRPANELX(LRTST))
SET LRCOMP(LRTST)=1
End DoDot:1
+33 QUIT
+34 ;
SUBPAN(LRPRCHK) ;
+1 ;find all sub-panels within panels
+2 NEW LRSUBPXN,LRSUBTST
+3 SET LRSUBPXN=0
+4 FOR
SET LRSUBPXN=$ORDER(^LAB(60,LRPRCHK,2,LRSUBPXN))
if 'LRSUBPXN
QUIT
Begin DoDot:1
+5 SET LRSUBTST=$PIECE($GET(^LAB(60,LRPRCHK,2,LRSUBPXN,0)),U)
+6 if LRSUBTST']""
QUIT
+7 ;If the test being verified is a component of a panel within a panel, and the
+8 ;user selected only the test (not "all"), the package reference field in file 100
+9 ;won't be set by downstream routines if LRORTST isn't set for the sub-panel.
+10 IF LRSUBTST=LRTST
SET LRORTST(LRPRCHK)=""
+11 IF $ORDER(^LAB(60,LRSUBTST,2,0))]""
Begin DoDot:2
+12 ;this is also a panel
+13 IF '$DATA(LRCOMP(LRSUBTST))
SET LRCOMP(LRSUBTST)=0
SET LRCOMP2(LRSUBTST)=1
+14 ;will need to later evaluate all components of this panel
+15 ;to determine whether any are also panels
+16 SET LRSUBAR(LRSUBTST)=""
End DoDot:2
End DoDot:1
+17 ;not finished yet going through LRSUBAR2
+18 IF $ORDER(LRSUBAR2(LRPRCHK))'=""
QUIT
+19 ;
+20 NEW LRSUBAR2
+21 IF $ORDER(LRSUBAR(0))]""
Begin DoDot:1
+22 NEW LRSUBSQ
+23 ;LRSUBAR might be re-set so need to keep values for this loop
+24 ;in LRSUBAR2
+25 MERGE LRSUBAR2=LRSUBAR
+26 KILL LRSUBAR
+27 SET LRSUBSQ=0
+28 FOR
SET LRSUBSQ=$ORDER(LRSUBAR2(LRSUBSQ))
if 'LRSUBSQ
QUIT
DO SUBPAN(LRSUBSQ)
End DoDot:1
+29 QUIT
+30 ;
OR100 ;
+1 ;are parents a sub-panel under a profile which was ordered
+2 NEW LRX69,LRX100,LRX10143,LRX60
+3 SET LRX69=0
+4 FOR
SET LRX69=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRX69))
if 'LRX69
QUIT
Begin DoDot:1
+5 SET LRX100=$PIECE($GET(^LRO(69,LRODT,1,LRSN,2,LRX69,0)),U,7)
+6 if LRX100']""
QUIT
+7 ;used later in PANEL to find order number again
+8 SET LRX60=$PIECE($GET(^LRO(69,LRODT,1,LRSN,2,LRX69,0)),U)
if LRX60=""
QUIT
+9 SET LROR100(LRX60)=LRX100
+10 SET LRX10143=0
+11 FOR
SET LRX10143=$ORDER(^OR(100,LRX100,.1,"B",LRX10143))
if 'LRX10143
QUIT
Begin DoDot:2
+12 SET LRX60=$PIECE($PIECE($GET(^ORD(101.43,LRX10143,0)),U,2),";")
+13 ;store Lab test which was ordered in CPRS for each
+14 ;order number - validates in PANEL section before setting
+15 ;^TMP("LR",$J,"PANEL" which is used by LR7OB3 to determine
+16 ;CPRS order status of active or complete
+17 ;If this parent is a sub-panel under a profile which was ordered,
+18 ;the value of LRX60 will differ from the value of LRPARENT
+19 if LRX60']""
QUIT
+20 SET LRCPORD(LRX100,LRX60)=""
+21 ;if ordered test is not yet in LRCOMP, add because overall status
+22 ;needs to be determined
+23 IF '$DATA(LRCOMP(LRX60))
IF $ORDER(^LAB(60,LRX60,2,0))]""
SET LRCOMP(LRX60)=0
SET LRCOMP2(LRX60)=1
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
ATOMIC(LR68X) ;
+1 ;if component has been resulted but has been set previously
+2 ;into ^LRO(68, the LRCAP* routines won't update the complete date
+3 ;correcting the issue here so that all panel related logic is
+4 ;in one place
+5 ;
+6 NEW LR63,LR68Y,LR68Z,LR63RES
+7 SET LR63=$PIECE($PIECE(^LAB(60,LR68X,0),U,5),";",2)
SET LR63RES=0
+8 ;LRPNLX is used to track whether at least one component of a panel which contains
+9 ;only non-required tests has been resulted.
+10 IF LR63]""
IF $DATA(LRSB(LR63))
IF $PIECE(LRSB(LR63),U)]""
IF $PIECE(LRSB(LR63),U)'["pending"
Begin DoDot:1
+11 SET LR63RES=1
+12 SET LRPANELX(LR68X)=1
End DoDot:1
+13 IF LR63RES
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LR68X,0))
Begin DoDot:1
+14 IF '$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LR68X,0),U,4)
SET $PIECE(^(0),U,4)=$SELECT($GET(LRDUZ):LRDUZ,$GET(DUZ):DUZ,1:"")
+15 IF '$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LR68X,0),U,5)
SET $PIECE(^(0),U,5)=LRNOW
+16 ;kill component out of A2 (if present) if it wasn't exploded out in ^TMP("LR",$J,"VT"
+17 KILL A2(LR68X)
+18 ;not setting workload suffix field (#8) if disposition field (#6) is already set
+19 ;so as to not affect workload already counted
+20 IF '$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LR68X,0),U,6)
SET $PIECE(^(0),U,8)=$GET(LRCDEF)
+21 IF $GET(LRACD)]""
IF LRACD'=LRAD
IF $DATA(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LR68X,0))
Begin DoDot:2
+22 IF '$PIECE(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LR68X,0),U,4)
SET $PIECE(^(0),U,4)=$SELECT($GET(LRDUZ):LRDUZ,$GET(DUZ):DUZ,1:"")
+23 IF '$PIECE(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LR68X,0),U,5)
SET $PIECE(^(0),U,5)=LRNOW
+24 ;not setting workload suffix field (#8) if disposition field (#6) is already set
+25 ;so as to not affect workload already counted
+26 IF '$PIECE(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LR68X,0),U,6)
SET $PIECE(^(0),U,8)=$GET(LRCDEF)
End DoDot:2
End DoDot:1
+27 ;check atomic tests if this test is a panel which has not been broken out in ^TMP("LR",$J,"VTO"
+28 IF $ORDER(^LAB(60,LR68X,2,0))]""
Begin DoDot:1
+29 SET LR68Y=0
+30 FOR
SET LR68Y=$ORDER(^LAB(60,LR68X,2,LR68Y))
if 'LR68Y
QUIT
Begin DoDot:2
+31 SET LR68Z=$PIECE(^LAB(60,LR68X,2,LR68Y,0),U)
+32 IF LR68Z]""
DO ATOMIC(LR68Z)
+33 IF $GET(LRPANELX(LR68Z))
SET LRPANELX(LR68X)=1
End DoDot:2
End DoDot:1
+34 QUIT
+35 ;
LRTST(LRPARENT,LRSUB,LRGO) ;
+1 ;retrieve all required tests for a panel
+2 NEW LRA,LRTEST,LRTESTX,LRDISP,LRTX,LRPANZ,LRAAX
+3 SET LRA=0
+4 FOR
SET LRA=$ORDER(^LAB(60,LRSUB,2,LRA))
if 'LRA
QUIT
Begin DoDot:1
+5 SET LRTEST=+$GET(^LAB(60,LRSUB,2,LRA,0))
if 'LRTEST
QUIT
+6 IF $ORDER(^LAB(60,LRTEST,2,0))]""
Begin DoDot:2
+7 ;this is a panel within a panel - store for later evaluation
+8 SET LRPANZ(LRTEST)=""
End DoDot:2
QUIT
+9 ;check to see if this test is a required test
+10 IF $PIECE($GET(^LAB(60,LRTEST,0)),U,17)
Begin DoDot:2
+11 ;get information for each atomic test within the panel
+12 DO LRPNL
End DoDot:2
End DoDot:1
+13 ;if LRGO is 0, panels within panels are being evaluated
+14 ;so need to store off the panels within panels within panels
+15 IF 'LRGO
IF $DATA(LRPANZ)
MERGE LRPANZ1=LRPANZ
+16 ;
+17 IF LRGO
IF $DATA(LRPANZ1)
MERGE LRPANZ=LRPANZ1
KILL LRPANZ1
+18 ;
+19 ;break down panels within panels
+20 IF $DATA(LRPANZ)
IF LRGO
Begin DoDot:1
+21 ;must merge to new array because LRPANZ might be
+22 ;re-created for panels within panels within panels...
+23 KILL LRPANX
+24 MERGE LRPANX=LRPANZ
KILL LRPANZ
+25 SET LRB=""
SET LRDONE=0
+26 FOR
SET LRB=$ORDER(LRPANX(LRB))
if 'LRB
QUIT
Begin DoDot:2
+27 ;flag that this is the last entry in the array indicates
+28 ;that may continue looking for panel within a panel
+29 IF $ORDER(LRPANX(LRB))=""
SET LRDONE=1
+30 DO LRTST(LRPARENT,LRB,LRDONE)
End DoDot:2
+31 ;
+32 ;a second kill of LRPANX is needed for certain situations
+33 ;when a single panel is embedded within another panel.
+34 ;Execution occurs twice which causes no harm, but adding
+35 ;second kill in case a situation occurs which would cause
+36 ;an endless loop.
+37 KILL LRPANX
End DoDot:1
+38 QUIT
+39 ;
LRPNL ;
+1 NEW LRTX,LRSTR,LRAAX,LRADX,LRANX,LRIDTX,LRTXI
+2 SET LRTX=$PIECE(^LAB(60,LRTEST,0),U,5)
+3 if LRTX']""
QUIT
+4 ;LR*5.2*538 - allow for the fact that a test might exist on more than
+5 ; one subscript
+6 SET LRTXI=0
LRPNL1 ;
+1 SET LR69TST=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRSUB,LRTXI))
+2 IF LR69TST
IF $PIECE($GET(^LRO(69,LRODT,1,LRSN,2,LR69TST,0)),U,9)="CA"
SET LRTXI=LR69TST
GOTO LRPNL1
+3 ;Accession area and accession number might differ among components
+4 IF 'LR69TST
SET LR69TST=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRTEST,LRTXI))
+5 IF LR69TST
IF $PIECE($GET(^LRO(69,LRODT,1,LRSN,2,LR69TST,0)),U,9)="CA"
SET LRTXI=LR69TST
GOTO LRPNL1
+6 if 'LR69TST
QUIT
+7 SET LRSTR=$GET(^LRO(69,LRODT,1,LRSN,2,LR69TST,0))
+8 SET LRAAX=$PIECE(LRSTR,U,4)
+9 SET LRADX=$PIECE(LRSTR,U,3)
+10 SET LRANX=$PIECE(LRSTR,U,5)
+11 SET LRIDTX=$PIECE($GET(^LRO(68,+LRAAX,1,+LRADX,1,+LRANX,3)),U,5)
+12 ;LRPNL(LRPARENT,LRTEST)=File 63 dept (2nd) subscript^File 63 test (4rd) subscript^accession area
+13 ; ^accession date^accession number^File 63 inverted date/time (3rd) subscript
+14 SET LRPNL(LRPARENT,LRTEST)=$PIECE(LRTX,";")_U_$PIECE(LRTX,";",2)_U_LRAAX_U_LRADX_U_LRANX_U_LRIDTX
+15 QUIT
+16 ;
PANEL2 ;
+1 ;evaluate all components / atomic tests of each parent
+2 NEW LRPARENT,LRTX,LRTSTX,LRSTR,LR63X,LRAAX,LRADX,LRANX,LRIDTX,LRADX2,LR63STR
+3 ;
+4 ;LRPNL(PARENT,TEST NUMBER)=FILE 63 DEPT (2ND) SUBSCRIPT_"^"_TEST (4TH) SUBSCRIPT IN FILE 63
+5 ; _"^"_ACCESSION AREA IN FILE 68_"^"_ACCESSION DATE_"^"_
+6 ; ACCESSION NUMBER"_"^"_FILE 63 INVERTED DATE/TIME (3RD) SUBSCRIPT
+7 ;
+8 SET (LRPARENT,LRTSTX)=""
+9 FOR
SET LRPARENT=$ORDER(LRPNL(LRPARENT))
if LRPARENT=""
QUIT
Begin DoDot:1
+10 FOR
SET LRTSTX=$ORDER(LRPNL(LRPARENT,LRTSTX))
if LRTSTX=""
QUIT
Begin DoDot:2
+11 SET LRSTR=LRPNL(LRPARENT,LRTSTX)
+12 ;
+13 ;LR63X = file 63 dept subscript
+14 ;LRTX = file 63 test subscript
+15 ;LRAAX = accession area
+16 ;LRADX = accession date
+17 ;LRANX = accession number
+18 ;LRIDTX = file 63 inverted date/time subscript
+19 SET LR63X=$PIECE(LRSTR,U)
+20 SET LRTX=$PIECE(LRSTR,U,2)
+21 SET LRAAX=$PIECE(LRSTR,U,3)
+22 SET LRADX=$PIECE(LRSTR,U,4)
+23 SET LRANX=$PIECE(LRSTR,U,5)
+24 SET LRIDTX=$PIECE(LRSTR,U,6)
+25 IF $GET(^LRO(68,+LRAAX,1,+LRADX,1,+LRANX,9))
SET LRADX=^LRO(68,+LRAAX,1,+LRADX,1,+LRANX,9)
+26 IF LRIDTX>1
IF LR63X]""
SET LR63STR=$GET(^LR(LRDFN,LR63X,+LRIDTX,+LRTX))
Begin DoDot:3
+27 ;This component is still pending, so order in file 100 should not be "complete"
+28 ;since at least one component of a panel is pending.
+29 IF LR63STR=""!($PIECE(LR63STR,U)["pending")
SET LRCOMP2(LRPARENT)=0
QUIT
+30 ;This component has been verified. File 68 status for the parent should be complete
+31 ;since at least one component has been verified.
+32 SET LRCOMP(LRPARENT)=1
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;update parent level in file 68
+34 DO UPDPAR
+35 QUIT
+36 ;
UPDPAR ;
+1 ;
+2 ;If the panel encompasses multiple accession areas, an entry may
+3 ;not be present in file 68 at the panel level.
+4 ;
+5 SET LRPARENT=""
+6 FOR
SET LRPARENT=$ORDER(LRCOMP(LRPARENT))
if LRPARENT=""
QUIT
Begin DoDot:1
+7 IF '$GET(LRCOMP(LRPARENT))!('$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0)))
QUIT
+8 ;LR*5.2*545: add check as to whether the parent (i.e. panel) has been merged or canceled
+9 if $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0),U,6)["*Not Performed"!($PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0),U,6)["*Merged")
QUIT
+10 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0),U,4)=$SELECT($GET(LRDUZ):LRDUZ,$GET(DUZ):DUZ,1:"")
+11 IF '$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0),U,5)
SET $PIECE(^(0),U,5)=LRNOW
+12 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0),U,6)=""
SET $PIECE(^(0),U,8)=$GET(LRCDEF)
+13 IF $GET(LRACD)]""
IF LRACD'=LRAD
IF $DATA(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRPARENT,0))
Begin DoDot:2
+14 SET $PIECE(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRPARENT,0),U,4)=$SELECT($GET(LRDUZ):LRDUZ,$GET(DUZ):DUZ,1:"")
+15 IF '$PIECE(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRPARENT,0),U,5)
SET $PIECE(^(0),U,5)=LRNOW
+16 SET $PIECE(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRPARENT,0),U,6)=""
SET $PIECE(^(0),U,8)=$GET(LRCDEF)
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
REQ ;
+1 if $PIECE($GET(LRSB(X)),U)="comment"
QUIT
+2 IF $DATA(LRSB(X))
IF $PIECE(LRSB(X),U)="canc"
QUIT
+3 IF $DATA(LRSB(X))
IF $PIECE(LRSB(X),U)'["pend"
QUIT
+4 IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)),U,6)'=""
QUIT
+5 if '$GET(LRALERT)
SET LRALERT=$SELECT($GET(LROUTINE):LROUTINE,1:9)
+6 SET D1=0
NEW A,LRPPURG
+7 IF $DATA(LRSB(X))
IF LRSB(X)["pending"
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2
Begin DoDot:1
+8 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)=""
SET $PIECE(^(0),U,5,6)="^"
SET $PIECE(^(0),U,9)=+$GET(LRM(X,"P"))
+9 DO REQ1
End DoDot:1
QUIT
+10 ;
+11 ; If required test with no result then store 'pending' and related info (NLT/LOINC codes, user and division).
+12 IF '$DATA(LRSB(X))
IF $PIECE($GET(^LR(LRDFN,"CH",LRIDT,X)),U)=""
DO STOREP
+13 ;
+14 IF '$DATA(LRSB(X))
IF $PIECE($GET(^LR(LRDFN,"CH",LRIDT,X)),U)'="pending"
QUIT
+15 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2
SET $PIECE(^(0),U,4,5)="^"
SET A=$PIECE(^(0),U,2)
IF A>49
SET $PIECE(^(0),U,2)=$SELECT(A=50:9,1:A-50)
+16 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2
Begin DoDot:1
+17 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",+LRT,+LRT)=""
+18 SET LRPPURG=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+$GET(LRM(X,"P")),0)),U,2)
+19 if 'LRPPURG
SET LRPPURG=$SELECT($GET(LRALERT):+LRALERT,1:9)
+20 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)=+LRT_U_LRPPURG
SET $PIECE(^(0),U,9)=+$GET(LRM(X,"P"))
+21 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),U,3)=+LRT
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
QUIT
End DoDot:1
+22 ;
REQ1 ;
+1 if LRACD=LRAD
QUIT
+2 IF $DATA(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0))#2
IF '$LENGTH($PIECE(^(0),U,6))
SET ^(0)=$PIECE(^(0),U,1,2)
SET $PIECE(^(0),U,7)=1
SET $PIECE(^(0),U,9)=+$GET(LRM(X,"P"))
+3 KILL CNT,LRAMC
+4 QUIT
+5 ;
+6 ;
STOREP ; Store pending as a result
+1 NEW LRX
+2 SET LRX=$GET(^LR(LRDFN,"CH",LRIDT,X))
+3 SET $PIECE(LRX,"^")="pending"
+4 IF $PIECE(LRX,"^",3)=""
SET $PIECE(LRX,"^",3)=$PIECE($GET(LRM(X,"P")),"^",2)
+5 SET $PIECE(LRX,"^",4)=$SELECT($GET(LRDUZ):LRDUZ,1:$GET(DUZ))
+6 SET $PIECE(LRX,"^",9)=$SELECT($GET(DUZ(2)):DUZ(2),1:"")
+7 SET ^LR(LRDFN,"CH",LRIDT,X)=LRX
+8 QUIT
