LRWRKINC ;SLC/DCM/CJS - INCOMPLETE STATUS REPORT ;Mar 22, 2021@17:48
;;5.2;LAB SERVICE;**153,201,221,453,536,543,562,566**;Sep 27, 1994;Build 12
;
EN ;
K ^TMP($J),^TMP("LR",$J),^TMP("LRWRKINC",$J)
K %ZIS,DIC
S Y=$$NOW^XLFDT D DD^LRX S LRDT=Y
S (LRCNT,LRCUTOFF,LREND,LREXD,LREXTST,LRNOCNTL,LREXNREQ)=0,LRSORTBY=1
S DIC="^LRO(68,",DIC(0)="AEMOQZ"
F D Q:$G(LRAA)<1!(LREND)
. N LAST,LRAD,LRAN,LRFAN,LRLAN,LRWDTL,LRSTAR,LRUSEAA,X,Y,LRDIP
. D ^DIC
. I $D(DUOUT) S LREND=1 Q
. S LRAA=+Y,LRAA(0)=$G(Y(0))
. I LRAA<1 Q
. D CHKAA^LRWRKIN1
. I LREND Q
. I '$L(LRUSEAA) D PHD Q:LREND
. S LRCNT=LRCNT+1,^TMP("LRWRKINC",$J,$P(LRAA(0),"^")_"^"_LRAA,LRCNT,0)=LRAA(0)
. I $G(LRDIP) S LAST=LRDIP
. I $L(LRUSEAA) D
. . N X
. . S X=$P($G(^LRO(68,LRUSEAA,0)),"^")_"^"_LRUSEAA
. . S ^TMP("LRWRKINC",$J,$P(LRAA(0),"^")_"^"_LRAA,LRCNT,1)=^TMP("LRWRKINC",$J,$P(LRUSEAA,"^",1,2),$P(LRUSEAA,"^",3),1)
. E S ^TMP("LRWRKINC",$J,$P(LRAA(0),"^")_"^"_LRAA,LRCNT,1)=$G(LRAD)_"^"_$G(LRFAN)_"^"_$G(LRLAN)_"^"_$G(LRSTAR)_"^"_$G(LAST)_"^"_$G(LRWDTL)
. W !
I LREND!('$D(^TMP("LRWRKINC",$J))) D LREND^LRWRKIN1 Q
K DIC
N DIR,DIRUT,DTOUT,DUOUT
I LRCNT>1 D
. S DIR(0)="SO^1:ACCESSION AREA;2:TEST NAME",DIR("A")="Sort Report By",DIR("B")=1
. S DIR("?",1)="ACCESSION AREA will separate tests by accession area, then by test name."
. S DIR("?")="TEST NAME will list tests alphabetically without regard to accession area."
. D ^DIR
. I $D(DIRUT) S LREND=1 Q
. S LRSORTBY=+Y
I LREND D LREND^LRWRKIN1 Q
S DIR(0)="YO",DIR("A")="Specify detailed sort criteria",DIR("B")="NO"
S DIR("?",1)="Answer 'YES' if you WANT to specify detailed criteria."
S DIR("?",2)="Examples are excluding controls, specifying a lab arrival cut-off time,"
S DIR("?",3)="selecting or excluding specific tests, or excluding non-required tests."
S DIR("?")="Answer 'NO' if you DO NOT want to specify detailed criteria."
D ^DIR
I $D(DIRUT) D LREND^LRWRKIN1 Q
I Y=1 D
. K DIR
. S DIR(0)="DO^::EXT",DIR("A")="Lab Arrival Cut-off"
. S DIR("?",1)="Entering a date/time will exclude uncollected specimens and"
. S DIR("?")="specimens with a lab arrival time after the time specified."
. D ^DIR
. I $D(DUOUT)!($D(DTOUT)) Q
. I Y>0 S LRCUTOFF=+Y
. K DIR
. S DIR(0)="YO",DIR("A")="Do you want to exclude controls",DIR("B")="YES"
. S DIR("?",1)="Answer 'NO' if you WANT accessions for LAB CONTROLS included on"
. S DIR("?")="the report. 'YES' if you DO NOT want accessions for LAB CONTROLS."
. D ^DIR
. I $D(DIRUT) Q
. S LRNOCNTL=+Y
. K DIR
. S DIR(0)="YO",DIR("A")="Do you want a specific test",DIR("B")="NO"
. D ^DIR
. I $D(DIRUT) Q
. I Y=1 D
. . N I,LRY
. . K DIR
. . S DIR(0)="YO",DIR("A")="Check tests on panels also",DIR("B")="YES"
. . S DIR("?",1)="If you select a panel test do you want to also check"
. . S DIR("?")="the tests that make up the panel for an incomplete status."
. . D ^DIR
. . I $D(DIRUT) Q
. . S LRY=+Y
. . N DIC
. . S DIC="^LAB(60,",DIC(0)="AEFOQZ"
. . F D Q:+Y<1
. . . N LRTEST,LRTSTS
. . . D ^DIC Q:+Y<1
. . . S ^TMP("LR",$J,"T",+Y)=Y(0)
. . . I LRY S LRTEST=+Y,LREXPD="D LREXPD^LRWRKINC" D ^LREXPD
. I $D(DIRUT) Q
. K DIR
. S DIR(0)="YO"
. S DIR("A")="Do you want to exclude a specific test",DIR("B")="NO"
. D ^DIR
. I $D(DIRUT) Q
. I Y=1 D
. . N DIC
. . S DIC="^LAB(60,",DIC(0)="AEFOQ",DIC("S")="I '$D(^TMP(""LR"",$J,""T"",Y))"
. . F D ^DIC Q:+Y<1 S LREXTST(+Y)="",LREXTST=1
. K DIR
. S DIR(0)="YO",DIR("A")="Exclude non-required tests",DIR("B")="YES"
. S DIR("?",1)="Answer 'NO' if you WANT incomplete non-required test included on"
. S DIR("?")="the report. 'YES' if you DO NOT want non-required tests."
. D ^DIR
. I $D(DIRUT) Q
. S LREXNREQ=+Y
I $D(DIRUT) D LREND^LRWRKIN1 Q
S DIR(0)="YO",DIR("A")="Do you want an extended display",DIR("B")="NO"
S DIR("?")="Extended display will show UID and other referral information"
D ^DIR
I $D(DIRUT) D LREND^LRWRKIN1 Q
S LREXD=+Y
S %ZIS="Q" D ^%ZIS
I POP D LREND^LRWRKIN1 Q
I $D(IO("Q")) D Q
. S ZTRTN="DQ^LRWRKINC",ZTDESC="Lab incomplete test list",ZTSAVE("LR*")=""
. S ZTSAVE("^TMP(""LRWRKINC"",$J,")=""
. I $D(^TMP("LR",$J,"T")) S ZTSAVE("^TMP(""LR"",$J,""T"",")=""
. D ^%ZTLOAD,^%ZISC
. W !,"Request ",$S($G(ZTSK):"Queued - Task #"_ZTSK,1:"NOT Queued")
. D LREND^LRWRKIN1
;
DQ ;
U IO
;LR*5.2*536: Variable LRMI* variables in next line indicate Microbiology accession
N LRMIFLG,LRMIARX,LRMIPND
S (LRAA,LRINDEX,LRPAGE)=0,(LRX,LRY)=""
F S LRX=$O(^TMP("LRWRKINC",$J,LRX)) Q:LRX="" D
. N LRZ
. S LRZ=0
. F S LRZ=$O(^TMP("LRWRKINC",$J,LRX,LRZ)) Q:'LRZ D
. . N LRFAN,LRLAN,LRSTAR,LRLAST,LRY
. . F I=0,1 S LRZ(I)=$G(^TMP("LRWRKINC",$J,LRX,LRZ,I))
. . S LRFAN=$P(LRZ(1),"^",2),LRLAN=$P(LRZ(1),"^",3),LRSTAR=$P(LRZ(1),"^",4),LRLAST=$P(LRZ(1),"^",5)
. . I $P(LRZ(1),"^",7)'="" S LRLAST=$P(LRZ(1),"^",7)
. . I LRSTAR,LRLAST S LRY="From Date: "_$$FMTE^XLFDT(LRSTAR,"5DZ")_" To: "_$$FMTE^XLFDT(LRLAST,"5DZ")
. . E S LRY=" For Date: "_$$FMTE^XLFDT(LRLAST,"5DZ")_" From: "_LRFAN_" To: "_LRLAN
. . S LRINDEX=LRINDEX+1,LRNAME(LRINDEX)=$$LJ^XLFSTR($E($P(LRZ(0),"^"),1,20),22)_LRY
S LRINDEX=LRINDEX+1,LRNAME(LRINDEX)=$S(LRINDEX>1:"Sorted by "_$S(LRSORTBY=1:"Accession Area",1:"Test Name")_"; ",1:"")_"Controls Excluded: "_$S(LRNOCNTL:"YES",1:"NO")_"; Specific Tests: "_$S($D(^TMP("LR",$J,"T")):"YES",1:"NO")
S LRINDEX=LRINDEX+1,LRNAME(LRINDEX)="Exclude Specific Tests: "_$S(LREXTST:"YES",1:"NO")_"; Required Tests Only: "_$S(LREXNREQ:"YES",1:"NO")
I LRCUTOFF S LRINDEX=LRINDEX+1,LRNAME(LRINDEX)="For Tests Received Before: "_$$FMTE^XLFDT(LRCUTOFF,"5MZ")
D HED^LRWRKIN1 D URG^LRX
S LRX=""
F S LRX=$O(^TMP("LRWRKINC",$J,LRX)) Q:LRX="" D
. S LRZ=0
. F S LRZ=$O(^TMP("LRWRKINC",$J,LRX,LRZ)) Q:'LRZ D
. . I LRSORTBY=1 S LRAA("NAME")=$P(LRX,"^")
. . S X=^TMP("LRWRKINC",$J,LRX,LRZ,1)
. . S LRAA=$P(LRX,"^",2),LRAD=$P(X,"^"),LRFAN=$P(X,"^",2),LRLAN=$P(X,"^",3),LRSTAR=$P(X,"^",4),LAST=$P(X,"^",5),LRWDTL=$P(X,"^",6)
. . S:LAST'>LRAD LRAD=LAST-1
. . N LRX,LRZ
. . F S LRAD=$O(^LRO(68,LRAA,1,LRAD)) Q:LRAD<1!(LRAD>LAST) D
. . . I $G(LRSTAR) D AC Q
. . . S LRAN=LRFAN-1
. . . F S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)) Q:'LRAN!(LRAN>LRLAN) D
. . . . S LREND=0
. . . . D TD Q:LREND
. . . . I 'LRVERVER D LST1^LRWRKIN1,TESTS
D X^LRWRKIN1
I LREND D LREND^LRWRKIN1 Q
D EQUALS^LRX D WAIT^LRWRKIN1:$E(IOST,1,2)="C-"
K LRDIP D LREND^LRWRKIN1
Q
;
TD ;
N LRMIAREA,LRDFNX,LRIDTX,LRTST68
K LRMIARX,LRMIPND
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LREND=1 Q
I LRNOCNTL,$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",2)=62.3 S LREND=1 Q
S LRVERVER=1,(I,LRMIFLG)=0
F S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<.5 I $D(^(I,0)) S LRVERVER=(LRVERVER&$P(^(0),U,5))
;LR*5.2*536 - if "RPT DATE APPROVED" has not been populated for Microbiology accessions,
; display accession on the Incomplete list
; (considered combining logic below with lines above, but decided to keep
; Microbiology logic separate in case further changes are needed.)
I $P(^LRO(68,LRAA,0),U,2)="MI" D
. S LRDFNX=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U)
. S LRIDTX=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
. ;Subscripts: 1 = Bacteriology; 5=Parasitology; 8=Mycology; 11=TB; 16=Virology
. I LRIDTX>1 F LRMIAREA=1,5,8,11,16 D
. . ;using a different flag for Micro so that this change will only affect Micro
. . ;in the TESTS subsection of this routine
. . ;LRMIFLG = "[area] RPT DATE APPROVED" is not populated
. . I $D(^LR(LRDFNX,"MI",LRIDTX,LRMIAREA)),$P(^(LRMIAREA),U)="" D
. . . S LRVERVER=0,LRMIFLG=1
. . . S LRMIARX(LRMIAREA)=""
. Q:'$D(LRMIARX)
. ;determine which tests on the accession are defined for the pending Microbiology
. ;area subscript
. S LRTST68=0
. F S LRTST68=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST68)) Q:LRTST68<.5 D
. . ;LR*5.2*543: Do not list if test marked "not performed" or "merged".
. . I $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST68,0),U,6)]"" Q
. . N LREXCODE
. . S LREXCODE=$P($G(^LAB(60,LRTST68,0)),"^",14)
. . I LREXCODE]"" S LREXCODE=$G(^LAB(62.07,LREXCODE,.1))
. . ;Logic below is the same as the logic in result verification routine LRMIEDZ2 which
. . ;determines which Microbiology area is defined for a Microbiology test
. . S LRMIAREA=$S(LREXCODE["11.5":1,LREXCODE["23":11,LREXCODE["19":8,LREXCODE["15":5,LREXCODE["34":16,1:"")
. . ;setting an array because more than one test on the accession might be defined for the
. . ;Microbiology area
. . I LRMIAREA]"",$D(LRMIARX(LRMIAREA)) S LRMIPND(LRTST68)=""
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) S LREND=1
Q
;
TESTS Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
N LRI
S LRI=0
F S LRI=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI)) Q:LRI<.5 D
. N LR60,LRURG,LRTSTN
. S LRI(0)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0)),LRURG=+$P(LRI(0),U,2)
. S LR60=+LRI(0)
. I $D(^TMP("LR",$J,"T")),'$D(^TMP("LR",$J,"T",LR60)) Q ; Not specific test
. I LREXTST,$D(LREXTST(LR60)) Q ; Exclude specific test
. ;LR*5.2*536:
. ;LRMIFLG of 1 indicates this is a pending Microbiology accession even though
. ;a "complete" date has been set at LRI(0),U,5) by the prompt "[test name] completed:"
. ;(i.e. the "[area] RPT DATE APPROVED:" prompt has not been answered.
. I $P(LRI(0),U,5),'$G(LRMIFLG) Q
. ;LR*5.2*536: This is a Microbiology pending accession but the test being evaluated
. ; is not pending. (There may be more than one Micro test on an accession.)
. ;The check for LRI(0) is necessary because the area subscript may not yet exist in file 63.
. I $G(LRMIFLG),'$D(LRMIPND(LR60)),$P(LRI(0),U,5) Q
. I LRCUTOFF,'LRDLA Q ; Uncollected
. I LRCUTOFF,LRCUTOFF<LRDLA Q ; After cut-off date/time
. S LR60(0)=$G(^LAB(60,LR60,0)) ; Get zeroth node from file #60
. I LREXNREQ,'$P(LR60(0),"^",17) Q ; Exclude non-required tests
. S LRTSTN=$P(LR60(0),U) ; Test name
. I $P(LR60(0),"^")="" S LRTSTN="MISSING FILE 60 - "_LR60
. I LRSORTBY=1 S LRTSTN=LRAA("NAME")_"^"_LRTSTN
. S Y=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
. S LRST=$S($L($P(LRI(0),U,3)):"Load/work list",$L($P(Y,U,3)):"In lab",1:"Not in lab")
. D REF
. S ^TMP($J,LRTSTN,LRURG,$P(LRACC," ",1)_"^"_+$P(LRDX,"^",3),LRAN)=LRST_U_SSN_U_PNM_U_$P(LRDX,U,7)_U_$P(LRDLA,"^",2)_U_LRMAN_U_LRACC
. I $G(LREXD) S ^TMP($J,LRTSTN,LRURG,$P(LRACC," ",1)_"^"_+$P(LRDX,"^",3),LRAN,.3)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
Q
;
REF ; if referred test, get referral status
N LREVNT,LRUID
S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^"),LRMAN=$P(LRI(0),"^",10)
I LRMAN S LRMAN=$P($G(^LAHM(62.8,LRMAN,0)),"^")
S LREVNT=$$STATUS^LREVENT(LRUID,LR60,LRMAN)
I LREVNT'="" S LRST=$P(LREVNT,"^")
;LR*5.2*562 begin
;NOTE: Amended results do not display a status of "Results received"
; on the Incomplete report by design. The report should only
; display tests which currently do not contain a verified result.
;
;Only checking "CH" subscripted tests (i.e. not Microbiology).
;Microbiology will require an NSR due to the amount of code
;which must be written. Also, according to some SME's, panels
;should not be defined in Microbiology, even though some sites do.
;(Anatomic Pathology results are not transmitted through LEDI.)
Q:$P(^LAB(60,LR60,0),"^",4)'="CH"
;
;Only display "Results received" status if results are currently
;waiting in ^LAH waiting to be verified. The previous results
;received might have been equal to "pending".
;LRMNF=shipping manifest ien
N LRMNF
S LRMNF=$P(LRI(0),"^",10)
I LRMNF,LRST["Results" D LAH
Q:LRMNF
D PROF
Q
;
PROF ;
;Shipping manifest identifier is still null.
;Is the test a profile component and is the profile on a
;shipping manifest?
;LRPRF=parent (profile) indicator
N LRPRF,LRXTST
S LRPRF=$P(LRI(0),"^",9)
;Should not be null, but checking just in case.
Q:LRPRF=""
;Quit if test is not a profile component.
I LRPRF'=LR60 D PROFMAN
Q
;
PROFMAN ;
;Is the profile on a shipping manifest.
S LRMNF=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPRF,0)),"^",10)
I LRMNF="" D ORIG(LRPRF)
;Does the profile contain another profile?
I LRMNF="" D
. N LRPRFCHK,LRPRFZ,LRPROFX
. S LRPRFCHK=LRPRF,LRPRFZ=0
. F S LRPRFZ=$O(^LAB(60,LRPRFCHK,2,LRPRFZ)) Q:'LRPRFZ Q:LRMNF D
. . ;check if a profile within a profile
. . S LRPROFX=$P($G(^LAB(60,LRPRFCHK,2,LRPRFZ,0)),"^")
. . Q:LRPROFX=""
. . I $O(^LAB(60,LRPROFX,2,0))="" Q
. . ;This is a profile within a profile.
. . ;Is "profile within profile" on shipping manifest.
. . S LRMNF=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPROFX,0)),"^",10)
. . I LRMNF]"" S LRPRF=LRPROFX Q
. . ;Continue searching for shipping manifest.
. . D ORIG(LRPROFX)
. . I LRMNF]"" S LRPRF=LRPROFX Q
. . ;Check atomic tests.
. . N LRATOMIC
. . S LRATOMIC=0
. . F S LRATOMIC=$O(^LAB(60,LRPROFX,2,LRATOMIC)) Q:'LRATOMIC Q:LRMNF D
. . . I $P($G(^LAB(60,LRPROFX,2,LRATOMIC,0)),"^")=LR60 D
. . . . S LRMNF=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPROFX,0)),"^",10)
. . . . S LRPRF=LRPROFX
I LRMNF]"" D PROFSTAT
Q
;
ORIG(LRXTST) ;
;The shipping manifest might be on the original order date
;for the accession if the accession rolled over.
N LRORIG
S LRORIG=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^",3)
Q:LRORIG=LRAD
S LRMNF=$P($G(^LRO(68,LRAA,1,LRORIG,1,LRAN,4,LRXTST,0)),"^",10)
Q
;
PROFSTAT ;
;Determine profile's status on shipping manifest.
;LRMNSQ=sequence on shipping manifest
;LRMNTST=file 60 test ien on shipping manifest
;LRSTPR=profile's status
N LRMNSQ,LRMNTST,LRSTPR
S (LRMNSQ,LRSTPR)=""
F S LRMNSQ=$O(^LAHM(62.8,LRMNF,10,"UID",LRUID,LRMNSQ)) Q:'LRMNSQ Q:LRSTPR]"" D
. S LRMNTST=$P($G(^LAHM(62.8,LRMNF,10,LRMNSQ,0)),"^",2)
. ;Check the status of the profile on the shipping manifest.
. I LRMNTST=LRPRF D
. . S LREVNT=$$STATUS^LREVENT(LRUID,LRPRF,LRMNF)
. . ;Probably do not need both LRSTPR and LRST at this point,
. . ;but keeping so that won't inadvertently cause other issues.
. . I LREVNT'="" S (LRSTPR,LRST)=$P(LREVNT,"^")
. ;Further checking needed if status of the profile is "Results
. ;received".
. I LRSTPR["Results" D LAH
Q
;
LAH ;
;If "Results received" status, are results waiting to be verified.
;Results might have previously been verified for the profile,
;but no results are currently waiting to be verified on
;remaining components. Laboratory personnel use the "Results
;received" status as an indicator that results are waiting
;to be manually verified.
;Need to drill down through globals (re-using variable LRWKLST).
N LRWKLST,LRLAHSQ,LRLAHTST,LRHIT
;Retrieve shipping configuration ien.
S LRWKLST=$P(^LAHM(62.8,LRMNF,0),"^",2)
;Retrieve LAB MESSAGING LINK (#.07) field.
S LRWKLST=$P(^LAHM(62.9,LRWKLST,0),"^",7)
;Retrieve the name of the link.
S LRWKLST=$P(^LAHM(62.48,LRWKLST,0),"^")
;Finally, retrieve Load/Worklist ien.
S LRWKLST=$O(^LAB(62.4,"B",LRWKLST,""))
Q:LRWKLST=""
S LRWKLST=$P(^LAB(62.4,LRWKLST,0),"^",4)
Q:LRWKLST=""
;Are any results waiting to be verified for this UID.
I '$D(^LAH(LRWKLST,1,"U",LRUID)) S LRST="Test shipped" Q
;Check the results.
S LRLAHSQ="",LRHIT=0
F S LRLAHSQ=$O(^LAH(LRWKLST,1,"U",LRUID,LRLAHSQ)) Q:LRLAHSQ="" D
. S LRLAHTST=.3
. F S LRLAHTST=$O(^LAH(LRWKLST,1,LRLAHSQ,LRLAHTST)) Q:'LRLAHTST Q:LRHIT D
. . ;Do any tests in ^LAH have the same data name as the test being
. . ;evaluated. (Considered screening out results of "pending". But comments
. . ;might have been transmitted for pending results which need verification.)
. . I LRLAHTST=$P($P(^LAB(60,LR60,0),"^",5),";",2) S LRHIT=1
. . ;Check profile components.
. . N LRSUB,LRSUBTST
. . S LRSUB=0
. . F S LRSUB=$O(^LAB(60,LR60,2,LRSUB)) Q:'LRSUB D
. . . S LRSUBTST=$P($G(^LAB(60,LR60,2,LRSUB,0)),"^")
. . . I LRLAHTST=$P($P(^LAB(60,LRSUBTST,0),"^",5),";",2) S LRHIT=1
;No match found in ^LAH, so revert status to "Test shipped".
I 'LRHIT S LRST="Test shipped"
Q
;
PHD ;
S LREND=0
I $P(LRAA(0),"^",3)="Y" D STAR^LRWU3
I $G(LRSTAR) Q
D ADATE^LRWU Q:LREND
;LR*5.2*566: Reset LRAD if accession area has rolled over.
; Only Daily accession areas roll over - not Yearly, Monthly,
; or Quarterly.
; 10th piece indicates if Bypass Rollover is set to yes.
; Adding $G because 1 subscript might not be set yet
; for new accession areas.
I LRAD<DT,$P(LRAA(0),"^",3)="D",'$P(LRAA(0),"^",10) D Q:LREND
. K DIR
. S DIR(0)="YO",DIR("A")="Are you sure you want to proceed?",DIR("B")="NO"
. S DIR("A",1)="Rollover completed on "_$$DDDATE^LRAFUNC1($$CDHTFM^LRAFUNC1(^LAB(69.9,1,"RO")),1)
. S DIR("A",2)="You are selecting a date in the past."
. S DIR("?")="Answer 'YES' if you want to continue."
. D ^DIR
. I $D(DIRUT)!'Y S LREND=1 Q
. S LRDIP=LRAD
I $P(LRAA(0),"^",3)="D",'$P(LRAA(0),"^",10),$P($G(^LRO(68,LRAA,1,0)),"^",3)>LRAD S LRAD=$P(^LRO(68,LRAA,1,0),"^",3)
S LAST=LRAD,LRAD=LRAD-1
D LRAN^LRWU3
Q
;
AC S LRTK=LRSTAR-.00001
F S LRTK=$O(^LRO(68,LRAA,1,LRAD,1,"E",LRTK)) Q:LRTK<1!(LAST>1&(LRTK\1>LAST)) D
. S LRAN=0
. F S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,"E",LRTK,LRAN)) Q:'LRAN D
. . S LREND=0
. . I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LREND=1 Q
. . D TD Q:LREND
. . ;I LRUNC!('LRVERVER) D LST,TESTS
. . I 'LRVERVER D LST1^LRWRKIN1,TESTS
Q
;
% R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
Q
;
LREXPD ;Include panel test in list when selecting specific tests
I $G(S1(+$G(S1))) S ^TMP("LR",$J,"T",S1(S1))=^LAB(60,S1(S1),0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRWRKINC 17714 printed Nov 22, 2024@17:33:13 Page 2
LRWRKINC ;SLC/DCM/CJS - INCOMPLETE STATUS REPORT ;Mar 22, 2021@17:48
+1 ;;5.2;LAB SERVICE;**153,201,221,453,536,543,562,566**;Sep 27, 1994;Build 12
+2 ;
EN ;
+1 KILL ^TMP($JOB),^TMP("LR",$JOB),^TMP("LRWRKINC",$JOB)
+2 KILL %ZIS,DIC
+3 SET Y=$$NOW^XLFDT
DO DD^LRX
SET LRDT=Y
+4 SET (LRCNT,LRCUTOFF,LREND,LREXD,LREXTST,LRNOCNTL,LREXNREQ)=0
SET LRSORTBY=1
+5 SET DIC="^LRO(68,"
SET DIC(0)="AEMOQZ"
+6 FOR
Begin DoDot:1
+7 NEW LAST,LRAD,LRAN,LRFAN,LRLAN,LRWDTL,LRSTAR,LRUSEAA,X,Y,LRDIP
+8 DO ^DIC
+9 IF $DATA(DUOUT)
SET LREND=1
QUIT
+10 SET LRAA=+Y
SET LRAA(0)=$GET(Y(0))
+11 IF LRAA<1
QUIT
+12 DO CHKAA^LRWRKIN1
+13 IF LREND
QUIT
+14 IF '$LENGTH(LRUSEAA)
DO PHD
if LREND
QUIT
+15 SET LRCNT=LRCNT+1
SET ^TMP("LRWRKINC",$JOB,$PIECE(LRAA(0),"^")_"^"_LRAA,LRCNT,0)=LRAA(0)
+16 IF $GET(LRDIP)
SET LAST=LRDIP
+17 IF $LENGTH(LRUSEAA)
Begin DoDot:2
+18 NEW X
+19 SET X=$PIECE($GET(^LRO(68,LRUSEAA,0)),"^")_"^"_LRUSEAA
+20 SET ^TMP("LRWRKINC",$JOB,$PIECE(LRAA(0),"^")_"^"_LRAA,LRCNT,1)=^TMP("LRWRKINC",$JOB,$PIECE(LRUSEAA,"^",1,2),$PIECE(LRUSEAA,"^",3),1)
End DoDot:2
+21 IF '$TEST
SET ^TMP("LRWRKINC",$JOB,$PIECE(LRAA(0),"^")_"^"_LRAA,LRCNT,1)=$GET(LRAD)_"^"_$GET(LRFAN)_"^"_$GET(LRLAN)_"^"_$GET(LRSTAR)_"^"_$GET(LAST)_"^"_$GET(LRWDTL)
+22 WRITE !
End DoDot:1
if $GET(LRAA)<1!(LREND)
QUIT
+23 IF LREND!('$DATA(^TMP("LRWRKINC",$JOB)))
DO LREND^LRWRKIN1
QUIT
+24 KILL DIC
+25 NEW DIR,DIRUT,DTOUT,DUOUT
+26 IF LRCNT>1
Begin DoDot:1
+27 SET DIR(0)="SO^1:ACCESSION AREA;2:TEST NAME"
SET DIR("A")="Sort Report By"
SET DIR("B")=1
+28 SET DIR("?",1)="ACCESSION AREA will separate tests by accession area, then by test name."
+29 SET DIR("?")="TEST NAME will list tests alphabetically without regard to accession area."
+30 DO ^DIR
+31 IF $DATA(DIRUT)
SET LREND=1
QUIT
+32 SET LRSORTBY=+Y
End DoDot:1
+33 IF LREND
DO LREND^LRWRKIN1
QUIT
+34 SET DIR(0)="YO"
SET DIR("A")="Specify detailed sort criteria"
SET DIR("B")="NO"
+35 SET DIR("?",1)="Answer 'YES' if you WANT to specify detailed criteria."
+36 SET DIR("?",2)="Examples are excluding controls, specifying a lab arrival cut-off time,"
+37 SET DIR("?",3)="selecting or excluding specific tests, or excluding non-required tests."
+38 SET DIR("?")="Answer 'NO' if you DO NOT want to specify detailed criteria."
+39 DO ^DIR
+40 IF $DATA(DIRUT)
DO LREND^LRWRKIN1
QUIT
+41 IF Y=1
Begin DoDot:1
+42 KILL DIR
+43 SET DIR(0)="DO^::EXT"
SET DIR("A")="Lab Arrival Cut-off"
+44 SET DIR("?",1)="Entering a date/time will exclude uncollected specimens and"
+45 SET DIR("?")="specimens with a lab arrival time after the time specified."
+46 DO ^DIR
+47 IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+48 IF Y>0
SET LRCUTOFF=+Y
+49 KILL DIR
+50 SET DIR(0)="YO"
SET DIR("A")="Do you want to exclude controls"
SET DIR("B")="YES"
+51 SET DIR("?",1)="Answer 'NO' if you WANT accessions for LAB CONTROLS included on"
+52 SET DIR("?")="the report. 'YES' if you DO NOT want accessions for LAB CONTROLS."
+53 DO ^DIR
+54 IF $DATA(DIRUT)
QUIT
+55 SET LRNOCNTL=+Y
+56 KILL DIR
+57 SET DIR(0)="YO"
SET DIR("A")="Do you want a specific test"
SET DIR("B")="NO"
+58 DO ^DIR
+59 IF $DATA(DIRUT)
QUIT
+60 IF Y=1
Begin DoDot:2
+61 NEW I,LRY
+62 KILL DIR
+63 SET DIR(0)="YO"
SET DIR("A")="Check tests on panels also"
SET DIR("B")="YES"
+64 SET DIR("?",1)="If you select a panel test do you want to also check"
+65 SET DIR("?")="the tests that make up the panel for an incomplete status."
+66 DO ^DIR
+67 IF $DATA(DIRUT)
QUIT
+68 SET LRY=+Y
+69 NEW DIC
+70 SET DIC="^LAB(60,"
SET DIC(0)="AEFOQZ"
+71 FOR
Begin DoDot:3
+72 NEW LRTEST,LRTSTS
+73 DO ^DIC
if +Y<1
QUIT
+74 SET ^TMP("LR",$JOB,"T",+Y)=Y(0)
+75 IF LRY
SET LRTEST=+Y
SET LREXPD="D LREXPD^LRWRKINC"
DO ^LREXPD
End DoDot:3
if +Y<1
QUIT
End DoDot:2
+76 IF $DATA(DIRUT)
QUIT
+77 KILL DIR
+78 SET DIR(0)="YO"
+79 SET DIR("A")="Do you want to exclude a specific test"
SET DIR("B")="NO"
+80 DO ^DIR
+81 IF $DATA(DIRUT)
QUIT
+82 IF Y=1
Begin DoDot:2
+83 NEW DIC
+84 SET DIC="^LAB(60,"
SET DIC(0)="AEFOQ"
SET DIC("S")="I '$D(^TMP(""LR"",$J,""T"",Y))"
+85 FOR
DO ^DIC
if +Y<1
QUIT
SET LREXTST(+Y)=""
SET LREXTST=1
End DoDot:2
+86 KILL DIR
+87 SET DIR(0)="YO"
SET DIR("A")="Exclude non-required tests"
SET DIR("B")="YES"
+88 SET DIR("?",1)="Answer 'NO' if you WANT incomplete non-required test included on"
+89 SET DIR("?")="the report. 'YES' if you DO NOT want non-required tests."
+90 DO ^DIR
+91 IF $DATA(DIRUT)
QUIT
+92 SET LREXNREQ=+Y
End DoDot:1
+93 IF $DATA(DIRUT)
DO LREND^LRWRKIN1
QUIT
+94 SET DIR(0)="YO"
SET DIR("A")="Do you want an extended display"
SET DIR("B")="NO"
+95 SET DIR("?")="Extended display will show UID and other referral information"
+96 DO ^DIR
+97 IF $DATA(DIRUT)
DO LREND^LRWRKIN1
QUIT
+98 SET LREXD=+Y
+99 SET %ZIS="Q"
DO ^%ZIS
+100 IF POP
DO LREND^LRWRKIN1
QUIT
+101 IF $DATA(IO("Q"))
Begin DoDot:1
+102 SET ZTRTN="DQ^LRWRKINC"
SET ZTDESC="Lab incomplete test list"
SET ZTSAVE("LR*")=""
+103 SET ZTSAVE("^TMP(""LRWRKINC"",$J,")=""
+104 IF $DATA(^TMP("LR",$JOB,"T"))
SET ZTSAVE("^TMP(""LR"",$J,""T"",")=""
+105 DO ^%ZTLOAD
DO ^%ZISC
+106 WRITE !,"Request ",$SELECT($GET(ZTSK):"Queued - Task #"_ZTSK,1:"NOT Queued")
+107 DO LREND^LRWRKIN1
End DoDot:1
QUIT
+108 ;
DQ ;
+1 USE IO
+2 ;LR*5.2*536: Variable LRMI* variables in next line indicate Microbiology accession
+3 NEW LRMIFLG,LRMIARX,LRMIPND
+4 SET (LRAA,LRINDEX,LRPAGE)=0
SET (LRX,LRY)=""
+5 FOR
SET LRX=$ORDER(^TMP("LRWRKINC",$JOB,LRX))
if LRX=""
QUIT
Begin DoDot:1
+6 NEW LRZ
+7 SET LRZ=0
+8 FOR
SET LRZ=$ORDER(^TMP("LRWRKINC",$JOB,LRX,LRZ))
if 'LRZ
QUIT
Begin DoDot:2
+9 NEW LRFAN,LRLAN,LRSTAR,LRLAST,LRY
+10 FOR I=0,1
SET LRZ(I)=$GET(^TMP("LRWRKINC",$JOB,LRX,LRZ,I))
+11 SET LRFAN=$PIECE(LRZ(1),"^",2)
SET LRLAN=$PIECE(LRZ(1),"^",3)
SET LRSTAR=$PIECE(LRZ(1),"^",4)
SET LRLAST=$PIECE(LRZ(1),"^",5)
+12 IF $PIECE(LRZ(1),"^",7)'=""
SET LRLAST=$PIECE(LRZ(1),"^",7)
+13 IF LRSTAR
IF LRLAST
SET LRY="From Date: "_$$FMTE^XLFDT(LRSTAR,"5DZ")_" To: "_$$FMTE^XLFDT(LRLAST,"5DZ")
+14 IF '$TEST
SET LRY=" For Date: "_$$FMTE^XLFDT(LRLAST,"5DZ")_" From: "_LRFAN_" To: "_LRLAN
+15 SET LRINDEX=LRINDEX+1
SET LRNAME(LRINDEX)=$$LJ^XLFSTR($EXTRACT($PIECE(LRZ(0),"^"),1,20),22)_LRY
End DoDot:2
End DoDot:1
+16 SET LRINDEX=LRINDEX+1
SET LRNAME(LRINDEX)=$SELECT(LRINDEX>1:"Sorted by "_$SELECT(LRSORTBY=1:"Accession Area",1:"Test Name")_"; ",1:"")_"Controls Excluded: "_$SELECT(LRNOCNTL:"YES",1:"NO")_"; Specific Tests: "_$SELECT($DATA(^TMP("LR",$JOB,"T")):"YES",1:"NO")
+17 SET LRINDEX=LRINDEX+1
SET LRNAME(LRINDEX)="Exclude Specific Tests: "_$SELECT(LREXTST:"YES",1:"NO")_"; Required Tests Only: "_$SELECT(LREXNREQ:"YES",1:"NO")
+18 IF LRCUTOFF
SET LRINDEX=LRINDEX+1
SET LRNAME(LRINDEX)="For Tests Received Before: "_$$FMTE^XLFDT(LRCUTOFF,"5MZ")
+19 DO HED^LRWRKIN1
DO URG^LRX
+20 SET LRX=""
+21 FOR
SET LRX=$ORDER(^TMP("LRWRKINC",$JOB,LRX))
if LRX=""
QUIT
Begin DoDot:1
+22 SET LRZ=0
+23 FOR
SET LRZ=$ORDER(^TMP("LRWRKINC",$JOB,LRX,LRZ))
if 'LRZ
QUIT
Begin DoDot:2
+24 IF LRSORTBY=1
SET LRAA("NAME")=$PIECE(LRX,"^")
+25 SET X=^TMP("LRWRKINC",$JOB,LRX,LRZ,1)
+26 SET LRAA=$PIECE(LRX,"^",2)
SET LRAD=$PIECE(X,"^")
SET LRFAN=$PIECE(X,"^",2)
SET LRLAN=$PIECE(X,"^",3)
SET LRSTAR=$PIECE(X,"^",4)
SET LAST=$PIECE(X,"^",5)
SET LRWDTL=$PIECE(X,"^",6)
+27 if LAST'>LRAD
SET LRAD=LAST-1
+28 NEW LRX,LRZ
+29 FOR
SET LRAD=$ORDER(^LRO(68,LRAA,1,LRAD))
if LRAD<1!(LRAD>LAST)
QUIT
Begin DoDot:3
+30 IF $GET(LRSTAR)
DO AC
QUIT
+31 SET LRAN=LRFAN-1
+32 FOR
SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN))
if 'LRAN!(LRAN>LRLAN)
QUIT
Begin DoDot:4
+33 SET LREND=0
+34 DO TD
if LREND
QUIT
+35 IF 'LRVERVER
DO LST1^LRWRKIN1
DO TESTS
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+36 DO X^LRWRKIN1
+37 IF LREND
DO LREND^LRWRKIN1
QUIT
+38 DO EQUALS^LRX
if $EXTRACT(IOST,1,2)="C-"
DO WAIT^LRWRKIN1
+39 KILL LRDIP
DO LREND^LRWRKIN1
+40 QUIT
+41 ;
TD ;
+1 NEW LRMIAREA,LRDFNX,LRIDTX,LRTST68
+2 KILL LRMIARX,LRMIPND
+3 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET LREND=1
QUIT
+4 IF LRNOCNTL
IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",2)=62.3
SET LREND=1
QUIT
+5 SET LRVERVER=1
SET (I,LRMIFLG)=0
+6 FOR
SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I))
if I<.5
QUIT
IF $DATA(^(I,0))
SET LRVERVER=(LRVERVER&$PIECE(^(0),U,5))
+7 ;LR*5.2*536 - if "RPT DATE APPROVED" has not been populated for Microbiology accessions,
+8 ; display accession on the Incomplete list
+9 ; (considered combining logic below with lines above, but decided to keep
+10 ; Microbiology logic separate in case further changes are needed.)
+11 IF $PIECE(^LRO(68,LRAA,0),U,2)="MI"
Begin DoDot:1
+12 SET LRDFNX=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U)
+13 SET LRIDTX=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
+14 ;Subscripts: 1 = Bacteriology; 5=Parasitology; 8=Mycology; 11=TB; 16=Virology
+15 IF LRIDTX>1
FOR LRMIAREA=1,5,8,11,16
Begin DoDot:2
+16 ;using a different flag for Micro so that this change will only affect Micro
+17 ;in the TESTS subsection of this routine
+18 ;LRMIFLG = "[area] RPT DATE APPROVED" is not populated
+19 IF $DATA(^LR(LRDFNX,"MI",LRIDTX,LRMIAREA))
IF $PIECE(^(LRMIAREA),U)=""
Begin DoDot:3
+20 SET LRVERVER=0
SET LRMIFLG=1
+21 SET LRMIARX(LRMIAREA)=""
End DoDot:3
End DoDot:2
+22 if '$DATA(LRMIARX)
QUIT
+23 ;determine which tests on the accession are defined for the pending Microbiology
+24 ;area subscript
+25 SET LRTST68=0
+26 FOR
SET LRTST68=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST68))
if LRTST68<.5
QUIT
Begin DoDot:2
+27 ;LR*5.2*543: Do not list if test marked "not performed" or "merged".
+28 IF $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST68,0),U,6)]""
QUIT
+29 NEW LREXCODE
+30 SET LREXCODE=$PIECE($GET(^LAB(60,LRTST68,0)),"^",14)
+31 IF LREXCODE]""
SET LREXCODE=$GET(^LAB(62.07,LREXCODE,.1))
+32 ;Logic below is the same as the logic in result verification routine LRMIEDZ2 which
+33 ;determines which Microbiology area is defined for a Microbiology test
+34 SET LRMIAREA=$SELECT(LREXCODE["11.5":1,LREXCODE["23":11,LREXCODE["19":8,LREXCODE["15":5,LREXCODE["34":16,1:"")
+35 ;setting an array because more than one test on the accession might be defined for the
+36 ;Microbiology area
+37 IF LRMIAREA]""
IF $DATA(LRMIARX(LRMIAREA))
SET LRMIPND(LRTST68)=""
End DoDot:2
End DoDot:1
+38 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
SET LREND=1
+39 QUIT
+40 ;
TESTS if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
QUIT
+1 NEW LRI
+2 SET LRI=0
+3 FOR
SET LRI=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI))
if LRI<.5
QUIT
Begin DoDot:1
+4 NEW LR60,LRURG,LRTSTN
+5 SET LRI(0)=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0))
SET LRURG=+$PIECE(LRI(0),U,2)
+6 SET LR60=+LRI(0)
+7 ; Not specific test
IF $DATA(^TMP("LR",$JOB,"T"))
IF '$DATA(^TMP("LR",$JOB,"T",LR60))
QUIT
+8 ; Exclude specific test
IF LREXTST
IF $DATA(LREXTST(LR60))
QUIT
+9 ;LR*5.2*536:
+10 ;LRMIFLG of 1 indicates this is a pending Microbiology accession even though
+11 ;a "complete" date has been set at LRI(0),U,5) by the prompt "[test name] completed:"
+12 ;(i.e. the "[area] RPT DATE APPROVED:" prompt has not been answered.
+13 IF $PIECE(LRI(0),U,5)
IF '$GET(LRMIFLG)
QUIT
+14 ;LR*5.2*536: This is a Microbiology pending accession but the test being evaluated
+15 ; is not pending. (There may be more than one Micro test on an accession.)
+16 ;The check for LRI(0) is necessary because the area subscript may not yet exist in file 63.
+17 IF $GET(LRMIFLG)
IF '$DATA(LRMIPND(LR60))
IF $PIECE(LRI(0),U,5)
QUIT
+18 ; Uncollected
IF LRCUTOFF
IF 'LRDLA
QUIT
+19 ; After cut-off date/time
IF LRCUTOFF
IF LRCUTOFF<LRDLA
QUIT
+20 ; Get zeroth node from file #60
SET LR60(0)=$GET(^LAB(60,LR60,0))
+21 ; Exclude non-required tests
IF LREXNREQ
IF '$PIECE(LR60(0),"^",17)
QUIT
+22 ; Test name
SET LRTSTN=$PIECE(LR60(0),U)
+23 IF $PIECE(LR60(0),"^")=""
SET LRTSTN="MISSING FILE 60 - "_LR60
+24 IF LRSORTBY=1
SET LRTSTN=LRAA("NAME")_"^"_LRTSTN
+25 SET Y=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
+26 SET LRST=$SELECT($LENGTH($PIECE(LRI(0),U,3)):"Load/work list",$LENGTH($PIECE(Y,U,3)):"In lab",1:"Not in lab")
+27 DO REF
+28 SET ^TMP($JOB,LRTSTN,LRURG,$PIECE(LRACC," ",1)_"^"_+$PIECE(LRDX,"^",3),LRAN)=LRST_U_SSN_U_PNM_U_$PIECE(LRDX,U,7)_U_$PIECE(LRDLA,"^",2)_U_LRMAN_U_LRACC
+29 IF $GET(LREXD)
SET ^TMP($JOB,LRTSTN,LRURG,$PIECE(LRACC," ",1)_"^"_+$PIECE(LRDX,"^",3),LRAN,.3)=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
End DoDot:1
+30 QUIT
+31 ;
REF ; if referred test, get referral status
+1 NEW LREVNT,LRUID
+2 SET LRUID=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
SET LRMAN=$PIECE(LRI(0),"^",10)
+3 IF LRMAN
SET LRMAN=$PIECE($GET(^LAHM(62.8,LRMAN,0)),"^")
+4 SET LREVNT=$$STATUS^LREVENT(LRUID,LR60,LRMAN)
+5 IF LREVNT'=""
SET LRST=$PIECE(LREVNT,"^")
+6 ;LR*5.2*562 begin
+7 ;NOTE: Amended results do not display a status of "Results received"
+8 ; on the Incomplete report by design. The report should only
+9 ; display tests which currently do not contain a verified result.
+10 ;
+11 ;Only checking "CH" subscripted tests (i.e. not Microbiology).
+12 ;Microbiology will require an NSR due to the amount of code
+13 ;which must be written. Also, according to some SME's, panels
+14 ;should not be defined in Microbiology, even though some sites do.
+15 ;(Anatomic Pathology results are not transmitted through LEDI.)
+16 if $PIECE(^LAB(60,LR60,0),"^",4)'="CH"
QUIT
+17 ;
+18 ;Only display "Results received" status if results are currently
+19 ;waiting in ^LAH waiting to be verified. The previous results
+20 ;received might have been equal to "pending".
+21 ;LRMNF=shipping manifest ien
+22 NEW LRMNF
+23 SET LRMNF=$PIECE(LRI(0),"^",10)
+24 IF LRMNF
IF LRST["Results"
DO LAH
+25 if LRMNF
QUIT
+26 DO PROF
+27 QUIT
+28 ;
PROF ;
+1 ;Shipping manifest identifier is still null.
+2 ;Is the test a profile component and is the profile on a
+3 ;shipping manifest?
+4 ;LRPRF=parent (profile) indicator
+5 NEW LRPRF,LRXTST
+6 SET LRPRF=$PIECE(LRI(0),"^",9)
+7 ;Should not be null, but checking just in case.
+8 if LRPRF=""
QUIT
+9 ;Quit if test is not a profile component.
+10 IF LRPRF'=LR60
DO PROFMAN
+11 QUIT
+12 ;
PROFMAN ;
+1 ;Is the profile on a shipping manifest.
+2 SET LRMNF=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPRF,0)),"^",10)
+3 IF LRMNF=""
DO ORIG(LRPRF)
+4 ;Does the profile contain another profile?
+5 IF LRMNF=""
Begin DoDot:1
+6 NEW LRPRFCHK,LRPRFZ,LRPROFX
+7 SET LRPRFCHK=LRPRF
SET LRPRFZ=0
+8 FOR
SET LRPRFZ=$ORDER(^LAB(60,LRPRFCHK,2,LRPRFZ))
if 'LRPRFZ
QUIT
if LRMNF
QUIT
Begin DoDot:2
+9 ;check if a profile within a profile
+10 SET LRPROFX=$PIECE($GET(^LAB(60,LRPRFCHK,2,LRPRFZ,0)),"^")
+11 if LRPROFX=""
QUIT
+12 IF $ORDER(^LAB(60,LRPROFX,2,0))=""
QUIT
+13 ;This is a profile within a profile.
+14 ;Is "profile within profile" on shipping manifest.
+15 SET LRMNF=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPROFX,0)),"^",10)
+16 IF LRMNF]""
SET LRPRF=LRPROFX
QUIT
+17 ;Continue searching for shipping manifest.
+18 DO ORIG(LRPROFX)
+19 IF LRMNF]""
SET LRPRF=LRPROFX
QUIT
+20 ;Check atomic tests.
+21 NEW LRATOMIC
+22 SET LRATOMIC=0
+23 FOR
SET LRATOMIC=$ORDER(^LAB(60,LRPROFX,2,LRATOMIC))
if 'LRATOMIC
QUIT
if LRMNF
QUIT
Begin DoDot:3
+24 IF $PIECE($GET(^LAB(60,LRPROFX,2,LRATOMIC,0)),"^")=LR60
Begin DoDot:4
+25 SET LRMNF=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPROFX,0)),"^",10)
+26 SET LRPRF=LRPROFX
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+27 IF LRMNF]""
DO PROFSTAT
+28 QUIT
+29 ;
ORIG(LRXTST) ;
+1 ;The shipping manifest might be on the original order date
+2 ;for the accession if the accession rolled over.
+3 NEW LRORIG
+4 SET LRORIG=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^",3)
+5 if LRORIG=LRAD
QUIT
+6 SET LRMNF=$PIECE($GET(^LRO(68,LRAA,1,LRORIG,1,LRAN,4,LRXTST,0)),"^",10)
+7 QUIT
+8 ;
PROFSTAT ;
+1 ;Determine profile's status on shipping manifest.
+2 ;LRMNSQ=sequence on shipping manifest
+3 ;LRMNTST=file 60 test ien on shipping manifest
+4 ;LRSTPR=profile's status
+5 NEW LRMNSQ,LRMNTST,LRSTPR
+6 SET (LRMNSQ,LRSTPR)=""
+7 FOR
SET LRMNSQ=$ORDER(^LAHM(62.8,LRMNF,10,"UID",LRUID,LRMNSQ))
if 'LRMNSQ
QUIT
if LRSTPR]""
QUIT
Begin DoDot:1
+8 SET LRMNTST=$PIECE($GET(^LAHM(62.8,LRMNF,10,LRMNSQ,0)),"^",2)
+9 ;Check the status of the profile on the shipping manifest.
+10 IF LRMNTST=LRPRF
Begin DoDot:2
+11 SET LREVNT=$$STATUS^LREVENT(LRUID,LRPRF,LRMNF)
+12 ;Probably do not need both LRSTPR and LRST at this point,
+13 ;but keeping so that won't inadvertently cause other issues.
+14 IF LREVNT'=""
SET (LRSTPR,LRST)=$PIECE(LREVNT,"^")
End DoDot:2
+15 ;Further checking needed if status of the profile is "Results
+16 ;received".
+17 IF LRSTPR["Results"
DO LAH
End DoDot:1
+18 QUIT
+19 ;
LAH ;
+1 ;If "Results received" status, are results waiting to be verified.
+2 ;Results might have previously been verified for the profile,
+3 ;but no results are currently waiting to be verified on
+4 ;remaining components. Laboratory personnel use the "Results
+5 ;received" status as an indicator that results are waiting
+6 ;to be manually verified.
+7 ;Need to drill down through globals (re-using variable LRWKLST).
+8 NEW LRWKLST,LRLAHSQ,LRLAHTST,LRHIT
+9 ;Retrieve shipping configuration ien.
+10 SET LRWKLST=$PIECE(^LAHM(62.8,LRMNF,0),"^",2)
+11 ;Retrieve LAB MESSAGING LINK (#.07) field.
+12 SET LRWKLST=$PIECE(^LAHM(62.9,LRWKLST,0),"^",7)
+13 ;Retrieve the name of the link.
+14 SET LRWKLST=$PIECE(^LAHM(62.48,LRWKLST,0),"^")
+15 ;Finally, retrieve Load/Worklist ien.
+16 SET LRWKLST=$ORDER(^LAB(62.4,"B",LRWKLST,""))
+17 if LRWKLST=""
QUIT
+18 SET LRWKLST=$PIECE(^LAB(62.4,LRWKLST,0),"^",4)
+19 if LRWKLST=""
QUIT
+20 ;Are any results waiting to be verified for this UID.
+21 IF '$DATA(^LAH(LRWKLST,1,"U",LRUID))
SET LRST="Test shipped"
QUIT
+22 ;Check the results.
+23 SET LRLAHSQ=""
SET LRHIT=0
+24 FOR
SET LRLAHSQ=$ORDER(^LAH(LRWKLST,1,"U",LRUID,LRLAHSQ))
if LRLAHSQ=""
QUIT
Begin DoDot:1
+25 SET LRLAHTST=.3
+26 FOR
SET LRLAHTST=$ORDER(^LAH(LRWKLST,1,LRLAHSQ,LRLAHTST))
if 'LRLAHTST
QUIT
if LRHIT
QUIT
Begin DoDot:2
+27 ;Do any tests in ^LAH have the same data name as the test being
+28 ;evaluated. (Considered screening out results of "pending". But comments
+29 ;might have been transmitted for pending results which need verification.)
+30 IF LRLAHTST=$PIECE($PIECE(^LAB(60,LR60,0),"^",5),";",2)
SET LRHIT=1
+31 ;Check profile components.
+32 NEW LRSUB,LRSUBTST
+33 SET LRSUB=0
+34 FOR
SET LRSUB=$ORDER(^LAB(60,LR60,2,LRSUB))
if 'LRSUB
QUIT
Begin DoDot:3
+35 SET LRSUBTST=$PIECE($GET(^LAB(60,LR60,2,LRSUB,0)),"^")
+36 IF LRLAHTST=$PIECE($PIECE(^LAB(60,LRSUBTST,0),"^",5),";",2)
SET LRHIT=1
End DoDot:3
End DoDot:2
End DoDot:1
+37 ;No match found in ^LAH, so revert status to "Test shipped".
+38 IF 'LRHIT
SET LRST="Test shipped"
+39 QUIT
+40 ;
PHD ;
+1 SET LREND=0
+2 IF $PIECE(LRAA(0),"^",3)="Y"
DO STAR^LRWU3
+3 IF $GET(LRSTAR)
QUIT
+4 DO ADATE^LRWU
if LREND
QUIT
+5 ;LR*5.2*566: Reset LRAD if accession area has rolled over.
+6 ; Only Daily accession areas roll over - not Yearly, Monthly,
+7 ; or Quarterly.
+8 ; 10th piece indicates if Bypass Rollover is set to yes.
+9 ; Adding $G because 1 subscript might not be set yet
+10 ; for new accession areas.
+11 IF LRAD<DT
IF $PIECE(LRAA(0),"^",3)="D"
IF '$PIECE(LRAA(0),"^",10)
Begin DoDot:1
+12 KILL DIR
+13 SET DIR(0)="YO"
SET DIR("A")="Are you sure you want to proceed?"
SET DIR("B")="NO"
+14 SET DIR("A",1)="Rollover completed on "_$$DDDATE^LRAFUNC1($$CDHTFM^LRAFUNC1(^LAB(69.9,1,"RO")),1)
+15 SET DIR("A",2)="You are selecting a date in the past."
+16 SET DIR("?")="Answer 'YES' if you want to continue."
+17 DO ^DIR
+18 IF $DATA(DIRUT)!'Y
SET LREND=1
QUIT
+19 SET LRDIP=LRAD
End DoDot:1
if LREND
QUIT
+20 IF $PIECE(LRAA(0),"^",3)="D"
IF '$PIECE(LRAA(0),"^",10)
IF $PIECE($GET(^LRO(68,LRAA,1,0)),"^",3)>LRAD
SET LRAD=$PIECE(^LRO(68,LRAA,1,0),"^",3)
+21 SET LAST=LRAD
SET LRAD=LRAD-1
+22 DO LRAN^LRWU3
+23 QUIT
+24 ;
AC SET LRTK=LRSTAR-.00001
+1 FOR
SET LRTK=$ORDER(^LRO(68,LRAA,1,LRAD,1,"E",LRTK))
if LRTK<1!(LAST>1&(LRTK\1>LAST))
QUIT
Begin DoDot:1
+2 SET LRAN=0
+3 FOR
SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,"E",LRTK,LRAN))
if 'LRAN
QUIT
Begin DoDot:2
+4 SET LREND=0
+5 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET LREND=1
QUIT
+6 DO TD
if LREND
QUIT
+7 ;I LRUNC!('LRVERVER) D LST,TESTS
+8 IF 'LRVERVER
DO LST1^LRWRKIN1
DO TESTS
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
% READ %:DTIME
if %=""!(%["N")!(%["Y")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO %
+1 QUIT
+2 ;
LREXPD ;Include panel test in list when selecting specific tests
+1 IF $GET(S1(+$GET(S1)))
SET ^TMP("LR",$JOB,"T",S1(S1))=^LAB(60,S1(S1),0)
+2 QUIT
