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

LRVER3A.m

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