LRWRKINC ;SLC/DCM/CJS-INCOMPLETE STATUS REPORT ;2/19/91 11:47 [ 04/23/2003 9:10 AM ]
;;5.2;LR;**1004,1006,1018,1022**;September 20, 2007
;;5.2;LAB SERVICE;**153,201,221**;Sep 27, 1994
;;
EN ; EP
N LAST,LRAD,LRAN,LRFAN,LRLAN,LRWDTL,LRSTAR,LRUSEAA,X,Y
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)
. K LAST,LRAD,LRAN,LRFAN,LRLAN,LRWDTL,LRSTAR,LRUSEAA,X,Y
. D ^XBFMK ; Kernel call cleans up FILEMAN vars
. S DIC="^LRO(68,",DIC(0)="AEMOQZ"
. 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 $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
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 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)
. . 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-"
D LREND^LRWRKIN1
Q
;
TD ;
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=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))
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
. I $P(LRI(0),U,5) Q ; Complete date
. 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
.;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
. S ^TMP($J,LRTSTN,LRURG,$P(LRACC," ",1,2),$P(LRACC," ",3))=LRST_U_HRCN_U_PNM_U_$P(LRDX,U,7)_U_$P(LRDLA,U,2)_U_LRMAN_U_LRACC ;IHS/ANMC/CLS 08/18/96
. ; 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))
. I $G(LREXD) S ^TMP($J,LRTSTN,LRURG,$P(LRACC," ",1,2),$P(LRACC," ",3),.3)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
. ; ----- BEGIN IHS/OIT/MKK MOD LR*5.2*1022- Comment out next 2 lines; left in by mistake when testing Patch 18
. ; S ^BLRMKKT("TESTS",LRAA,LRAD,LRAN,LRI)=LRCUTOFF_"|"_LRDLA_"^"_LR60(0)_"|"_Y
. ; S ^BLRMKKT("TESTS",LRAA,LRAD,LRAN,LRI,LRTSTN,LRURG,$P(LRACC," ",1,2),$P(LRACC," ",3))=""
. ; ----- END IHS/OIT/MKK MOD LR*5.2*1022
.;----- END IHS MODIFICATIONS
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(X,"^",10)
I LRMAN S LRMAN=$P($G(^LAHM(62.8,LRMAN,0)),"^")
S LREVNT=$$STATUS^LREVENT(LRUID,+X,LRMAN)
I LREVNT'="" S LRST=$P(LREVNT,"^")
Q
;
PHD ;
S LREND=0
I $P(LRAA(0),"^",3)="Y" D STAR^LRWU3
I $G(LRSTAR) Q
D ADATE^LRWU Q:LREND
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
LRWRKINC ;SLC/DCM/CJS-INCOMPLETE STATUS REPORT ;2/19/91 11:47 [ 04/23/2003 9:10 AM ]
+1 ;;5.2;LR;**1004,1006,1018,1022**;September 20, 2007
+2 ;;5.2;LAB SERVICE;**153,201,221**;Sep 27, 1994
+3 ;;
EN ; EP
+1 NEW LAST,LRAD,LRAN,LRFAN,LRLAN,LRWDTL,LRSTAR,LRUSEAA,X,Y
+2 KILL ^TMP($JOB),^TMP("LR",$JOB),^TMP("LRWRKINC",$JOB)
+3 KILL %ZIS,DIC
+4 SET Y=$$NOW^XLFDT
DO DD^LRX
SET LRDT=Y
+5 SET (LRCNT,LRCUTOFF,LREND,LREXD,LREXTST,LRNOCNTL,LREXNREQ)=0
SET LRSORTBY=1
+6 ; S DIC="^LRO(68,",DIC(0)="AEMOQZ"
+7 FOR
Begin DoDot:1
+8 KILL LAST,LRAD,LRAN,LRFAN,LRLAN,LRWDTL,LRSTAR,LRUSEAA,X,Y
+9 ; Kernel call cleans up FILEMAN vars
DO ^XBFMK
+10 SET DIC="^LRO(68,"
SET DIC(0)="AEMOQZ"
+11 DO ^DIC
+12 IF $DATA(DUOUT)
SET LREND=1
QUIT
+13 SET LRAA=+Y
SET LRAA(0)=$GET(Y(0))
+14 IF LRAA<1
QUIT
+15 DO CHKAA^LRWRKIN1
+16 IF LREND
QUIT
+17 IF '$LENGTH(LRUSEAA)
DO PHD
IF LREND
QUIT
+18 SET LRCNT=LRCNT+1
SET ^TMP("LRWRKINC",$JOB,$PIECE(LRAA(0),"^")_"^"_LRAA,LRCNT,0)=LRAA(0)
+19 IF $LENGTH(LRUSEAA)
Begin DoDot:2
+20 NEW X
+21 SET X=$PIECE($GET(^LRO(68,LRUSEAA,0)),"^")_"^"_LRUSEAA
+22 SET ^TMP("LRWRKINC",$JOB,$PIECE(LRAA(0),"^")_"^"_LRAA,LRCNT,1)=^TMP("LRWRKINC",$JOB,$PIECE(LRUSEAA,"^",1,2),$PIECE(LRUSEAA,"^",3),1)
End DoDot:2
+23 IF '$TEST
SET ^TMP("LRWRKINC",$JOB,$PIECE(LRAA(0),"^")_"^"_LRAA,LRCNT,1)=$GET(LRAD)_"^"_$GET(LRFAN)_"^"_$GET(LRLAN)_"^"_$GET(LRSTAR)_"^"_$GET(LAST)_"^"_$GET(LRWDTL)
+24 WRITE !
End DoDot:1
IF $GET(LRAA)<1!(LREND)
QUIT
+25 IF LREND!('$DATA(^TMP("LRWRKINC",$JOB)))
DO LREND^LRWRKIN1
QUIT
+26 KILL DIC
+27 NEW DIR,DIRUT,DTOUT,DUOUT
+28 IF LRCNT>1
Begin DoDot:1
+29 SET DIR(0)="SO^1:ACCESSION AREA;2:TEST NAME"
SET DIR("A")="Sort Report By"
SET DIR("B")=1
+30 SET DIR("?",1)="ACCESSION AREA will separate tests by accession area, then by test name."
+31 SET DIR("?")="TEST NAME will list tests alphabetically without regard to accession area."
+32 DO ^DIR
+33 IF $DATA(DIRUT)
SET LREND=1
QUIT
+34 SET LRSORTBY=+Y
End DoDot:1
+35 IF LREND
DO LREND^LRWRKIN1
QUIT
+36 SET DIR(0)="YO"
SET DIR("A")="Specify detailed sort criteria"
SET DIR("B")="NO"
+37 SET DIR("?",1)="Answer 'YES' if you WANT to specify detailed criteria."
+38 SET DIR("?",2)="Examples are excluding controls, specifying a lab arrival cut-off time,"
+39 SET DIR("?",3)="selecting or excluding specific tests, or excluding non-required tests."
+40 SET DIR("?")="Answer 'NO' if you DO NOT want to specify detailed criteria."
+41 DO ^DIR
+42 IF $DATA(DIRUT)
DO LREND^LRWRKIN1
QUIT
+43 IF Y=1
Begin DoDot:1
+44 KILL DIR
+45 SET DIR(0)="DO^::EXT"
SET DIR("A")="Lab Arrival Cut-off"
+46 SET DIR("?",1)="Entering a date/time will exclude uncollected specimens and"
+47 SET DIR("?")="specimens with a lab arrival time after the time specified."
+48 DO ^DIR
+49 IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+50 IF Y>0
SET LRCUTOFF=+Y
+51 KILL DIR
+52 SET DIR(0)="YO"
SET DIR("A")="Do you want to exclude controls"
SET DIR("B")="YES"
+53 SET DIR("?",1)="Answer 'NO' if you WANT accessions for LAB CONTROLS included on"
+54 SET DIR("?")="the report. 'YES' if you DO NOT want accessions for LAB CONTROLS."
+55 DO ^DIR
+56 IF $DATA(DIRUT)
QUIT
+57 SET LRNOCNTL=+Y
+58 KILL DIR
+59 SET DIR(0)="YO"
SET DIR("A")="Do you want a specific test"
SET DIR("B")="NO"
+60 DO ^DIR
+61 IF $DATA(DIRUT)
QUIT
+62 IF Y=1
Begin DoDot:2
+63 NEW I,LRY
+64 KILL DIR
+65 SET DIR(0)="YO"
SET DIR("A")="Check tests on panels also"
SET DIR("B")="YES"
+66 SET DIR("?",1)="If you select a panel test do you want to also check"
+67 SET DIR("?")="the tests that make up the panel for an incomplete status."
+68 DO ^DIR
+69 IF $DATA(DIRUT)
QUIT
+70 SET LRY=+Y
+71 NEW DIC
+72 SET DIC="^LAB(60,"
SET DIC(0)="AEFOQZ"
+73 FOR
Begin DoDot:3
+74 NEW LRTEST,LRTSTS
+75 DO ^DIC
IF +Y<1
QUIT
+76 SET ^TMP("LR",$JOB,"T",+Y)=Y(0)
+77 IF LRY
SET LRTEST=+Y
SET LREXPD="D LREXPD^LRWRKINC"
DO ^LREXPD
End DoDot:3
IF +Y<1
QUIT
End DoDot:2
+78 IF $DATA(DIRUT)
QUIT
+79 KILL DIR
+80 SET DIR(0)="YO"
+81 SET DIR("A")="Do you want to exclude a specific test"
SET DIR("B")="NO"
+82 DO ^DIR
+83 IF $DATA(DIRUT)
QUIT
+84 IF Y=1
Begin DoDot:2
+85 NEW DIC
+86 SET DIC="^LAB(60,"
SET DIC(0)="AEFOQ"
SET DIC("S")="I '$D(^TMP(""LR"",$J,""T"",Y))"
+87 FOR
DO ^DIC
IF +Y<1
QUIT
SET LREXTST(+Y)=""
SET LREXTST=1
End DoDot:2
+88 KILL DIR
+89 SET DIR(0)="YO"
SET DIR("A")="Exclude non-required tests"
SET DIR("B")="YES"
+90 SET DIR("?",1)="Answer 'NO' if you WANT incomplete non-required test included on"
+91 SET DIR("?")="the report. 'YES' if you DO NOT want non-required tests."
+92 DO ^DIR
+93 IF $DATA(DIRUT)
QUIT
+94 SET LREXNREQ=+Y
End DoDot:1
+95 IF $DATA(DIRUT)
DO LREND^LRWRKIN1
QUIT
+96 SET DIR(0)="YO"
SET DIR("A")="Do you want an extended display"
SET DIR("B")="NO"
+97 SET DIR("?")="Extended display will show UID and other referral information"
+98 DO ^DIR
+99 IF $DATA(DIRUT)
DO LREND^LRWRKIN1
QUIT
+100 SET LREXD=+Y
+101 SET %ZIS="Q"
DO ^%ZIS
+102 IF POP
DO LREND^LRWRKIN1
QUIT
+103 IF $DATA(IO("Q"))
Begin DoDot:1
+104 SET ZTRTN="DQ^LRWRKINC"
SET ZTDESC="Lab incomplete test list"
SET ZTSAVE("LR*")=""
+105 SET ZTSAVE("^TMP(""LRWRKINC"",$J,")=""
+106 IF $DATA(^TMP("LR",$JOB,"T"))
SET ZTSAVE("^TMP(""LR"",$J,""T"",")=""
+107 DO ^%ZTLOAD
DO ^%ZISC
+108 WRITE !,"Request ",$SELECT($GET(ZTSK):"Queued - Task #"_ZTSK,1:"NOT Queued")
+109 DO LREND^LRWRKIN1
End DoDot:1
QUIT
+110 ;
DQ ;
+1 USE IO
+2 SET (LRAA,LRINDEX,LRPAGE)=0
SET (LRX,LRY)=""
+3 FOR
SET LRX=$ORDER(^TMP("LRWRKINC",$JOB,LRX))
IF LRX=""
QUIT
Begin DoDot:1
+4 NEW LRZ
+5 SET LRZ=0
+6 FOR
SET LRZ=$ORDER(^TMP("LRWRKINC",$JOB,LRX,LRZ))
IF 'LRZ
QUIT
Begin DoDot:2
+7 NEW LRFAN,LRLAN,LRSTAR,LRLAST,LRY
+8 FOR I=0,1
SET LRZ(I)=$GET(^TMP("LRWRKINC",$JOB,LRX,LRZ,I))
+9 SET LRFAN=$PIECE(LRZ(1),"^",2)
SET LRLAN=$PIECE(LRZ(1),"^",3)
SET LRSTAR=$PIECE(LRZ(1),"^",4)
SET LRLAST=$PIECE(LRZ(1),"^",5)
+10 IF LRSTAR
IF LRLAST
SET LRY="From Date: "_$$FMTE^XLFDT(LRSTAR,"5DZ")_" To: "_$$FMTE^XLFDT(LRLAST,"5DZ")
+11 IF '$TEST
SET LRY=" For Date: "_$$FMTE^XLFDT(LRLAST,"5DZ")_" From: "_LRFAN_" To: "_LRLAN
+12 SET LRINDEX=LRINDEX+1
SET LRNAME(LRINDEX)=$$LJ^XLFSTR($EXTRACT($PIECE(LRZ(0),"^"),1,20),22)_LRY
End DoDot:2
End DoDot:1
+13 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")
+14 SET LRINDEX=LRINDEX+1
SET LRNAME(LRINDEX)="Exclude Specific Tests: "_$SELECT(LREXTST:"YES",1:"NO")_"; Required Tests Only: "_$SELECT(LREXNREQ:"YES",1:"NO")
+15 IF LRCUTOFF
SET LRINDEX=LRINDEX+1
SET LRNAME(LRINDEX)="For Tests Received Before: "_$$FMTE^XLFDT(LRCUTOFF,"5MZ")
+16 DO HED^LRWRKIN1
DO URG^LRX
+17 SET LRX=""
+18 FOR
SET LRX=$ORDER(^TMP("LRWRKINC",$JOB,LRX))
IF LRX=""
QUIT
Begin DoDot:1
+19 SET LRZ=0
+20 FOR
SET LRZ=$ORDER(^TMP("LRWRKINC",$JOB,LRX,LRZ))
IF 'LRZ
QUIT
Begin DoDot:2
+21 IF LRSORTBY=1
SET LRAA("NAME")=$PIECE(LRX,"^")
+22 SET X=^TMP("LRWRKINC",$JOB,LRX,LRZ,1)
+23 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)
+24 NEW LRX,LRZ
+25 FOR
SET LRAD=$ORDER(^LRO(68,LRAA,1,LRAD))
IF LRAD<1!(LRAD>LAST)
QUIT
Begin DoDot:3
+26 IF $GET(LRSTAR)
DO AC
QUIT
+27 SET LRAN=LRFAN-1
+28 FOR
SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN))
IF 'LRAN!(LRAN>LRLAN)
QUIT
Begin DoDot:4
+29 SET LREND=0
+30 DO TD
IF LREND
QUIT
+31 IF 'LRVERVER
DO LST1^LRWRKIN1
DO TESTS
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+32 DO X^LRWRKIN1
+33 IF LREND
DO LREND^LRWRKIN1
QUIT
+34 DO EQUALS^LRX
IF $EXTRACT(IOST,1,2)="C-"
DO WAIT^LRWRKIN1
+35 DO LREND^LRWRKIN1
+36 QUIT
+37 ;
TD ;
+1 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET LREND=1
QUIT
+2 IF LRNOCNTL
IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",2)=62.3
SET LREND=1
QUIT
+3 SET LRVERVER=1
SET I=0
+4 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))
+5 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
SET LREND=1
+6 QUIT
+7 ;
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 ; Complete date
IF $PIECE(LRI(0),U,5)
QUIT
+10 ; Uncollected
IF LRCUTOFF
IF 'LRDLA
QUIT
+11 ; After cut-off date/time
IF LRCUTOFF
IF LRCUTOFF<LRDLA
QUIT
+12 ; Get zeroth node from file #60
SET LR60(0)=$GET(^LAB(60,LR60,0))
+13 ; Exclude non-required tests
IF LREXNREQ
IF '$PIECE(LR60(0),"^",17)
QUIT
+14 ; Test name
SET LRTSTN=$PIECE(LR60(0),U)
+15 IF $PIECE(LR60(0),"^")=""
SET LRTSTN="MISSING FILE 60 - "_LR60
+16 IF LRSORTBY=1
SET LRTSTN=LRAA("NAME")_"^"_LRTSTN
+17 SET Y=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
+18 SET LRST=$SELECT($LENGTH($PIECE(LRI(0),U,3)):"Load/work list",$LENGTH($PIECE(Y,U,3)):"In lab",1:"Not in lab")
+19 DO REF
+20 ;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
+21 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+22 ;IHS/ANMC/CLS 08/18/96
SET ^TMP($JOB,LRTSTN,LRURG,$PIECE(LRACC," ",1,2),$PIECE(LRACC," ",3))=LRST_U_HRCN_U_PNM_U_$PIECE(LRDX,U,7)_U_$PIECE(LRDLA,U,2)_U_LRMAN_U_LRACC
+23 ; 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))
+24 IF $GET(LREXD)
SET ^TMP($JOB,LRTSTN,LRURG,$PIECE(LRACC," ",1,2),$PIECE(LRACC," ",3),.3)=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+25 ; ----- BEGIN IHS/OIT/MKK MOD LR*5.2*1022- Comment out next 2 lines; left in by mistake when testing Patch 18
+26 ; S ^BLRMKKT("TESTS",LRAA,LRAD,LRAN,LRI)=LRCUTOFF_"|"_LRDLA_"^"_LR60(0)_"|"_Y
+27 ; S ^BLRMKKT("TESTS",LRAA,LRAD,LRAN,LRI,LRTSTN,LRURG,$P(LRACC," ",1,2),$P(LRACC," ",3))=""
+28 ; ----- END IHS/OIT/MKK MOD LR*5.2*1022
+29 ;----- END IHS MODIFICATIONS
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(X,"^",10)
+3 IF LRMAN
SET LRMAN=$PIECE($GET(^LAHM(62.8,LRMAN,0)),"^")
+4 SET LREVNT=$$STATUS^LREVENT(LRUID,+X,LRMAN)
+5 IF LREVNT'=""
SET LRST=$PIECE(LREVNT,"^")
+6 QUIT
+7 ;
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 SET LAST=LRAD
SET LRAD=LRAD-1
+6 DO LRAN^LRWU3
+7 QUIT
+8 ;
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
