- 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 Jan 18, 2025@03:23:14 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