Routine: LRWRKINC

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

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

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

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,"^")

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

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

% R %:DTIME Q:%=""!(%["N")!(%["Y")  W !,"Answer 'Y' or 'N': " G %

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)

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

LRWRKINC.m