Routine: BLRUER

BLRUER ;IHS/MSC/MKK - ERROR TRACKING TASKED REPORT ;2/18/98  07:03 ;

 ;;5.2;LAB SERVICE;**1038**;NOV 1, 1997;Build 6

EEP ; EP - Ersatz EP

 D EEP^BLRGMENU

 ; Cloned from the LR*5.2*1031 version of LRUER

 ; This version is designed to be tasked.  It will REJECT interactive reporting.

BEGIN ; EP - Beginning

 I $D(ZTQUEUED)<1 D  Q

 . W !!,?4,"This report can only be run from TASKMAN."

 . D PRESSKEY^BLRGMENU(9)

 S:$D(ZTQUEUED) ZTREQ="@"

GETPARAM ; EP - Get the parameters from the IHS LAB SUPERVISOR TASKED REPORTS PARAMETERS (#90475.7) file

 NEW ACCDELC,D1,D1IEN,DEVICE,DEVDESC,GPD0,GPD1,TRANGE,DUZ2,DUZ2DESC,LISTTEST,NEWPAGE,PREVREPT,SPECREJ

 ; Parameters for LRUER report are in 90475.71

 S (GPD0,GPD1)=1

 S D1IEN=GPD1_","_GPD0

 S DUZ2=$$GET1^DIQ(90475.71,D1IEN,.01,"I")

 S DUZ2=$$GET1^DIQ(90475.71,D1IEN,.01,"I")

 S DUZ2DESC=$$GET1^DIQ(90475.71,D1IEN,.01)

 S PREVREPT=+$$GET1^DIQ(90475.71,D1IEN,1,"I")

 S SPECREJ=+$$GET1^DIQ(90475.71,D1IEN,2,"I")

 S ACCDELC=+$$GET1^DIQ(90475.71,D1IEN,3,"I")

 S LISTTEST=+$$GET1^DIQ(90475.71,D1IEN,4,"I")

 S NEWPAGE=+$$GET1^DIQ(90475.71,D1IEN,5,"I")

 S DTRANGE=+$$GET1^DIQ(90475.71,D1IEN,6,"I")

 S DEVICE=+$$GET1^DIQ(90475.71,D1IEN,7,"I")

 ; IF and ONLY IF the DEVICE variable is zero, then quit.

 ; Can Only happen if user up-hatted (^) out of the setup process.

 Q:DEVICE<1

 D DONTASK    ; Do the report

 G END

DONTASK ; EP

 S LRC(1)=$S(PREVREPT:"reported incorrectly as",SPECREJ:"specimen rejected",1:"")

 S LRC(2)=$S(ACCDELC:1,1:"")

 S LRC(3)="DUMMYZZZZ"

 S LRSDT=$S(DTRANGE=1:$$HTFM^XLFDT(+$H-7),DTRANGE=2:$$HTFM^XLFDT(+$H-30),DTRANGE=3:$$HTFM^XLFDT(+$H-365),1:$$HTFM^XLFDT(+$H-1))

 S LRLDT=$$DT^XLFDT

 S LRSTR=$$FMTE^XLFDT(LRSDT,"5DZ")

 S LRLST=$$FMTE^XLFDT(LRLDT,"5DZ")

 S LRS=LRSDT-.01,LRE=LRLDT+.99,LRLDT=9999998-LRLDT,LRSDT=9999999-LRSDT

 S LRF=LISTTEST

 S LRL=NEWPAGE

 K IOP,ZTSK,%ZIS

 S ZTSAVE("*")=""

 S %ZIS="Q"

 ; S IOP="`"_$$FIND1^DIC(3.5,,,"BLRUER TASKED")

 S IOP="`"_DEVICE

 D ENTRYAUD^BLRUTIL("DONTASK^BLRUER")

 D EN^XUTMDEVQ("QUE^BLRUER","TASKED IHS LAB ERROR TRACKING REPORT",.ZTSAVE,.%ZIS)

 G END

QUE ; EP

 S:$D(ZTQUEUED) ZTREQ="@"

 U IO

 N A,B,C,D,E,G,J,LRDFN,LRX,V,X,Y,Z

 K ^TMP($J),^TMP("LRDFN",$J)

 S LRQ(1)=^DD("SITE"),(LRQ,LR("Q"))=0

 D L^LRU,H S LR("F")=1

 F B=LRS:0 S B=$O(^LRO(69,B)) Q:'B!(B>LRE)  D

 . N X,I

 . S I=0 F  S I=$O(^LRO(69,B,1,I)) Q:'I  S X=+$G(^(I,0)) I X D

 .. S ^TMP("LRDFN",$J,X)=""

 I $$GET1^DIQ(9009029,+$G(DUZ(2)),"TAKE SNAPSHOTS","I") D

 . NEW SHOTMP

 . M SHOTMP("LRDFN",$J)=^TMP("LRDFN",$J)

 . D ENTRYAUD^BLRUTIL("QUE^BLRUER")

 F LRDFN=0:0 S LRDFN=$O(^TMP("LRDFN",$J,LRDFN)) Q:'LRDFN  S LRI=LRLDT F A=0:0 S LRI=$O(^LR(LRDFN,"CH",LRI)) Q:'LRI!(LRI>LRSDT)  D A

 K ^TMP("LRDFN",$J) D W,END^LRUTL,END

A ; EP

 I LRC(2),$O(^LR(LRDFN,"CH",LRI,1,"AC",0)) D SET Q

 F B=0:0 S B=$O(^LR(LRDFN,"CH",LRI,1,B)) Q:'B  I $G(^LR(LRDFN,"CH",LRI,1,B,0))[LRC(1)!($G(^LR(LRDFN,"CH",LRI,1,B,0))[LRC(3)) D SET Q     ; IHS/OIT/MKK - LR*5.2*1030 - Get rid of Naked References

SET ; EP

 S X=^LR(LRDFN,"CH",LRI,0),Y=$P(X,"^",6) S:Y="" Y="?? ?? ??" S ^TMP($J,$P(Y," "),$P(Y," ",2,3),+X,LRDFN,LRI)=$P(X,"^",5) Q

W ; EP

 S (LRA,LRC)="" F A=0:0 S LRA=$O(^TMP($J,LRA)) Q:LRA=""!(LR("Q"))  S LRC=LRC+1 D:LRL&(LRC>1) H Q:LR("Q")  S LRB="" F B=0:0 S LRB=$O(^TMP($J,LRA,LRB)) Q:LRB=""!(LR("Q"))  D W1

W1 ; EP

 F LRT=0:0 S LRT=$O(^TMP($J,LRA,LRB,LRT)) Q:'LRT!(LR("Q"))  F LRDFN=0:0 S LRDFN=$O(^TMP($J,LRA,LRB,LRT,LRDFN)) Q:'LRDFN!(LR("Q"))  D X

X ; EP

 F LRI=0:0 S LRI=$O(^TMP($J,LRA,LRB,LRT,LRDFN,LRI)) Q:'LRI!(LR("Q"))  S X=+^(LRI),LRS=$P($G(^LAB(61,X,0)),"^") D P

P ; EP

 S LRDATE=$$FMTE^XLFDT(LRT,"M")

 S X=^LR(LRDFN,0),(DFN,Y)=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),V=@(X_Y_",0)"),LRP=$P(V,"^"),SSN=$P(V,"^",9) D SSN^LRU  ;IHS/ANMC/CLS 08/18/96

 D:$Y>(IOSL-6) H W !!,LRA_" "_LRB,?14,LRDATE,?34,LRP," ",HRCN,?67,LRS D:LRF TST Q:LR("Q")  ;IHS/ANMC/CLS 08/18/96

 F B=0:0 S B=$O(^LR(LRDFN,"CH",LRI,1,B)) Q:'B!(LR("Q"))  S B(1)=^(B,0) D:$Y>(IOSL-6) H1 Q:LR("Q")  W !?5,B(1)

 F B=0:0 S B=$O(^LR(LRDFN,"CH",LRI,1,"AC",B)) Q:'B!(LR("Q"))  S C="" F E=0:0 S C=$O(^LR(LRDFN,"CH",LRI,1,"AC",B,C)) Q:C=""  D:$Y>(IOSL-6) H1 Q:LR("Q")  D P1

P1 ; EP

 S X=$G(^VA(200,B,0)) W !?5,$P(^LR(LRDFN,"CH",LRI,1,"AC",B,C),"^",3) W:$X>60 ! W " (deleted by ",$S($P(X,"^",2)]"":$P(X,"^",2),1:$P(X,",")),")"

TST ; EP

 S:'$D(LR(LRA)) LR(LRA)=+$O(^LRO(68,"B",LRA,0)) S X=$P(^LRO(68,LR(LRA),0),"^",3),Z=$P(LRB," ",2),G=$E(LRT,1,3) S:X="D" G=G_$P(LRB," ")

 E  S G=$S(X="Y":G_"0000",X="M":G_$E($P(LRB," "),1,2)_"00",1:G)

 S (C,E,E(1))=0 F E(1)=0:0 S C=$O(^LRO(68,LR(LRA),1,G,1,Z,4,C)) Q:'C!(LR("Q"))  S LRX=^(C,0) I $P(^LAB(60,C,0),U,4)'="WK" D B

B ; EP

 S E=E+1,J=$P(LRX,U,4),J=$S(J:$P($G(^VA(200,J,0)),"^",2),1:J) D:$Y>(IOSL-6) H2 Q:LR("Q")  W ! W:E=1 "Test(s) ordered:" W ?18,$P($G(^LAB(60,C,0)),"^"),?49,"Tech: ",J

H ; EP

 I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")

 D F^LRU W !,LRC(1) W:$L(LRC(1))>44 ! W " From: ",LRSTR," To: ",LRLST,!,"Acc #",?14,"Date/Time",?34,"Name/HRCN",?67,"Specimen",!,LR("%")

H1 ; EP

 D H Q:LR("Q")  W !,LRA," ",LRB,?14,LRDATE,?34,LRP," ",HRCN," ",LRS

H2 ; EP

 D H1 Q:LR("Q")  W !,"Test(s) ordered:" S E=2

END ; EP

 D V^LRU

DEBUGFOR ; EP - Check the FOR loop

 NEW ACCDELC,D1,D1IEN,DEVICE,DEVDESC,TRANGE,DUZ2,DUZ2DESC,LISTTEST,NEWPAGE,PREVREPT,SPECREJ

 ; Parameters for LRUER report are in 90475.71

 S GPD1=.9999999

 F  S GPD1=$O(^BLRLSRP(1,1,GPD1))  Q:GPD1<1  D

 . S D1IEN=GPD1_","_1

 . S DUZ2=$$GET1^DIQ(90475.71,D1IEN,.01,"I")

 . S DUZ2=$$GET1^DIQ(90475.71,D1IEN,.01,"I")

 . S DUZ2DESC=$$GET1^DIQ(90475.71,D1IEN,.01)

 . S PREVREPT=+$$GET1^DIQ(90475.71,D1IEN,1,"I")

 . S SPECREJ=+$$GET1^DIQ(90475.71,D1IEN,2,"I")

 . S ACCDELC=+$$GET1^DIQ(90475.71,D1IEN,3,"I")

 . S LISTTEST=+$$GET1^DIQ(90475.71,D1IEN,4,"I")

 . S NEWPAGE=+$$GET1^DIQ(90475.71,D1IEN,5,"I")

 . S DTRANGE=+$$GET1^DIQ(90475.71,D1IEN,6,"I")

. ;

 . S LRSDT=$S(DTRANGE=1:$$HTFM^XLFDT(+$H-7),DTRANGE=2:$$HTFM^XLFDT(+$H-30),DTRANGE=3:$$HTFM^XLFDT(+$H-365),1:$$HTFM^XLFDT(+$H-1))

 . S LRLDT=$$DT^XLFDT

 . S LRSTR=$$FMTE^XLFDT(LRSDT,"5DZ")

 . S LRLST=$$FMTE^XLFDT(LRLDT,"5DZ")

 . S LRS=LRSDT-.01,LRE=LRLDT+.99,LRLDT=9999998-LRLDT,LRSDT=9999999-LRSDT

. ;

 . S DEVICE=+$$GET1^DIQ(90475.71,D1IEN,7,"I")

 . I DEVICE=0 D      ; Default device is LABLABEL

 .. S DEVICE=+$$FIND1^DIC(3.5,,,"LABLABEL")

 .. S DEVDESC=$$GET1^DIQ(3.5,DEVICE,.01)

. ;

 . W ?4,"GPD1:",GPD1," -- ",$$GET1^DIQ(4,GPD1,.01),!

 . W ?9,"DUZ2:",DUZ2,"; DUZ2DESC:",DUZ2DESC,!

 . W ?9,"PREVREPT:",PREVREPT,!

 . W ?9,"SPECREJ:",SPECREJ,!

 . W ?9,"ACCDELC:",ACCDELC,!

 . W ?9,"LISTTEST:",LISTTEST,!

 . W ?9,"NEWPAGE:",NEWPAGE,!

 . W ?9,"DTRANGE:",DTRANGE,!

. ;

 . S LRSDT=$S(DTRANGE=1:$$HTFM^XLFDT(+$H-7),DTRANGE=2:$$HTFM^XLFDT(+$H-30),DTRANGE=3:$$HTFM^XLFDT(+$H-365),1:$$HTFM^XLFDT(+$H-1))

 . S LRLDT=$$DT^XLFDT

 . W ?9,"LRSDT:",LRSDT,?29,"LRLDT:",LRLDT,!

 . S LRSTR=$$FMTE^XLFDT(LRSDT,"5DZ")

 . S LRLST=$$FMTE^XLFDT(LRLDT,"5DZ")

 . W ?9,"LRSTR:",LRSTR,?29,"LRLST:",LRLST,!

 . S LRS=LRSDT-.01,LRE=LRLDT+.99,LRLDT=9999998-LRLDT,LRSDT=9999999-LRSDT

 . W ?9,"LRS:",LRS,?29,"LRE:",LRE,!

 . W ?9,"LRSDT:",LRSDT,?29,"LRLDT:",LRLDT,!

BLRUER    ;IHS/MSC/MKK - ERROR TRACKING TASKED REPORT ;2/18/98  07:03 ;

 +1       ;;5.2;LAB SERVICE;**1038**;NOV 1, 1997;Build 6

 +2       ;

EEP       ; EP - Ersatz EP

 +1        DO EEP^BLRGMENU

 +2        QUIT

 +3       ;

 +4       ; Cloned from the LR*5.2*1031 version of LRUER

 +5       ;

 +6       ; This version is designed to be tasked.  It will REJECT interactive reporting.

 +7       ;

BEGIN     ; EP - Beginning

 +1        IF $DATA(ZTQUEUED)<1

               Begin DoDot:1

 +2                WRITE !!,?4,"This report can only be run from TASKMAN."

 +3                DO PRESSKEY^BLRGMENU(9)

               End DoDot:1

               QUIT

 +4        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +5       ;

GETPARAM  ; EP - Get the parameters from the IHS LAB SUPERVISOR TASKED REPORTS PARAMETERS (#90475.7) file

 +1        NEW ACCDELC,D1,D1IEN,DEVICE,DEVDESC,GPD0,GPD1,TRANGE,DUZ2,DUZ2DESC,LISTTEST,NEWPAGE,PREVREPT,SPECREJ

 +2       ;

 +3       ; Parameters for LRUER report are in 90475.71

 +4        SET (GPD0,GPD1)=1

 +5       ;

 +6        SET D1IEN=GPD1_","_GPD0

 +7        SET DUZ2=$$GET1^DIQ(90475.71,D1IEN,.01,"I")

 +8        SET DUZ2=$$GET1^DIQ(90475.71,D1IEN,.01,"I")

 +9        SET DUZ2DESC=$$GET1^DIQ(90475.71,D1IEN,.01)

 +10       SET PREVREPT=+$$GET1^DIQ(90475.71,D1IEN,1,"I")

 +11       SET SPECREJ=+$$GET1^DIQ(90475.71,D1IEN,2,"I")

 +12       SET ACCDELC=+$$GET1^DIQ(90475.71,D1IEN,3,"I")

 +13       SET LISTTEST=+$$GET1^DIQ(90475.71,D1IEN,4,"I")

 +14       SET NEWPAGE=+$$GET1^DIQ(90475.71,D1IEN,5,"I")

 +15       SET DTRANGE=+$$GET1^DIQ(90475.71,D1IEN,6,"I")

 +16       SET DEVICE=+$$GET1^DIQ(90475.71,D1IEN,7,"I")

 +17      ;

 +18      ; IF and ONLY IF the DEVICE variable is zero, then quit.

 +19      ; Can Only happen if user up-hatted (^) out of the setup process.

 +20       IF DEVICE<1

               QUIT

 +21      ;

 +22      ; Do the report

           DO DONTASK

 +23      ;

 +24       GOTO END

 +25       QUIT

 +26      ;

DONTASK   ; EP

 +1        SET LRC(1)=$SELECT(PREVREPT:"reported incorrectly as",SPECREJ:"specimen rejected",1:"")

 +2        SET LRC(2)=$SELECT(ACCDELC:1,1:"")

 +3        SET LRC(3)="DUMMYZZZZ"

 +4        SET LRSDT=$SELECT(DTRANGE=1:$$HTFM^XLFDT(+$HOROLOG-7),DTRANGE=2:$$HTFM^XLFDT(+$HOROLOG-30),DTRANGE=3:$$HTFM^XLFDT(+$HOROLOG-365),1:$$HTFM^XLFDT(+$HOROLOG-1))

 +5        SET LRLDT=$$DT^XLFDT

 +6        SET LRSTR=$$FMTE^XLFDT(LRSDT,"5DZ")

 +7        SET LRLST=$$FMTE^XLFDT(LRLDT,"5DZ")

 +8        SET LRS=LRSDT-.01

           SET LRE=LRLDT+.99

           SET LRLDT=9999998-LRLDT

           SET LRSDT=9999999-LRSDT

 +9        SET LRF=LISTTEST

 +10       SET LRL=NEWPAGE

 +11       KILL IOP,ZTSK,%ZIS

 +12       SET ZTSAVE("*")=""

 +13       SET %ZIS="Q"

 +14      ; S IOP="`"_$$FIND1^DIC(3.5,,,"BLRUER TASKED")

 +15       SET IOP="`"_DEVICE

 +16       DO ENTRYAUD^BLRUTIL("DONTASK^BLRUER")

 +17       DO EN^XUTMDEVQ("QUE^BLRUER","TASKED IHS LAB ERROR TRACKING REPORT",.ZTSAVE,.%ZIS)

 +18       GOTO END

 +19       QUIT

 +20      ;

QUE       ; EP

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +2        USE IO

 +3        NEW A,B,C,D,E,G,J,LRDFN,LRX,V,X,Y,Z

 +4        KILL ^TMP($JOB),^TMP("LRDFN",$JOB)

 +5        SET LRQ(1)=^DD("SITE")

           SET (LRQ,LR("Q"))=0

 +6        DO L^LRU

           DO H

           SET LR("F")=1

 +7        FOR B=LRS:0

               SET B=$ORDER(^LRO(69,B))

               IF 'B!(B>LRE)

                   QUIT

               Begin DoDot:1

 +8                NEW X,I

 +9                SET I=0

FOR

                       SET I=$ORDER(^LRO(69,B,1,I))

                       IF 'I

                           QUIT

                       SET X=+$GET(^(I,0))

                       IF X

                           Begin DoDot:2

 +10                           SET ^TMP("LRDFN",$JOB,X)=""

                           End DoDot:2

               End DoDot:1

 +11       IF $$GET1^DIQ(9009029,+$GET(DUZ(2)),"TAKE SNAPSHOTS","I")

               Begin DoDot:1

 +12               NEW SHOTMP

 +13               MERGE SHOTMP("LRDFN",$JOB)=^TMP("LRDFN",$JOB)

 +14               DO ENTRYAUD^BLRUTIL("QUE^BLRUER")

               End DoDot:1

 +15       FOR LRDFN=0:0

               SET LRDFN=$ORDER(^TMP("LRDFN",$JOB,LRDFN))

               IF 'LRDFN

                   QUIT

               SET LRI=LRLDT

               FOR A=0:0

                   SET LRI=$ORDER(^LR(LRDFN,"CH",LRI))

                   IF 'LRI!(LRI>LRSDT)

                       QUIT

                   DO A

 +16       KILL ^TMP("LRDFN",$JOB)

           DO W

           DO END^LRUTL

           DO END

 +17       QUIT

 +18      ;

A         ; EP

 +1        IF LRC(2)

               IF $ORDER(^LR(LRDFN,"CH",LRI,1,"AC",0))

                   DO SET

                   QUIT

 +2       ; IHS/OIT/MKK - LR*5.2*1030 - Get rid of Naked References

           FOR B=0:0

               SET B=$ORDER(^LR(LRDFN,"CH",LRI,1,B))

               IF 'B

                   QUIT

               IF $GET(^LR(LRDFN,"CH",LRI,1,B,0))[LRC(1)!($GET(^LR(LRDFN,"CH",LRI,1,B,0))[LRC(3))

                   DO SET

                   QUIT

 +3        QUIT

 +4       ;

SET       ; EP

 +1        SET X=^LR(LRDFN,"CH",LRI,0)

           SET Y=$PIECE(X,"^",6)

           IF Y=""

               SET Y="?? ?? ??"

           SET ^TMP($JOB,$PIECE(Y," "),$PIECE(Y," ",2,3),+X,LRDFN,LRI)=$PIECE(X,"^",5)

           QUIT

 +2        QUIT

 +3       ;

W         ; EP

 +1        SET (LRA,LRC)=""

           FOR A=0:0

               SET LRA=$ORDER(^TMP($JOB,LRA))

               IF LRA=""!(LR("Q"))

                   QUIT

               SET LRC=LRC+1

               IF LRL&(LRC>1)

                   DO H

               IF LR("Q")

                   QUIT

               SET LRB=""

               FOR B=0:0

                   SET LRB=$ORDER(^TMP($JOB,LRA,LRB))

                   IF LRB=""!(LR("Q"))

                       QUIT

                   DO W1

 +2        QUIT

 +3       ;

W1        ; EP

 +1        FOR LRT=0:0

               SET LRT=$ORDER(^TMP($JOB,LRA,LRB,LRT))

               IF 'LRT!(LR("Q"))

                   QUIT

               FOR LRDFN=0:0

                   SET LRDFN=$ORDER(^TMP($JOB,LRA,LRB,LRT,LRDFN))

                   IF 'LRDFN!(LR("Q"))

                       QUIT

                   DO X

 +2        QUIT

 +3       ;

X         ; EP

 +1        FOR LRI=0:0

               SET LRI=$ORDER(^TMP($JOB,LRA,LRB,LRT,LRDFN,LRI))

               IF 'LRI!(LR("Q"))

                   QUIT

               SET X=+^(LRI)

               SET LRS=$PIECE($GET(^LAB(61,X,0)),"^")

               DO P

 +2        QUIT

 +3       ;

P         ; EP

 +1        SET LRDATE=$$FMTE^XLFDT(LRT,"M")

 +2       ;IHS/ANMC/CLS 08/18/96

           SET X=^LR(LRDFN,0)

           SET (DFN,Y)=$PIECE(X,"^",3)

           SET (LRDPF,X)=$PIECE(X,"^",2)

           SET X=^DIC(X,0,"GL")

           SET V=@(X_Y_",0)")

           SET LRP=$PIECE(V,"^")

           SET SSN=$PIECE(V,"^",9)

           DO SSN^LRU

 +3       ;IHS/ANMC/CLS 08/18/96

           IF $Y>(IOSL-6)

               DO H

           WRITE !!,LRA_" "_LRB,?14,LRDATE,?34,LRP," ",HRCN,?67,LRS

           IF LRF

               DO TST

           IF LR("Q")

               QUIT

 +4        FOR B=0:0

               SET B=$ORDER(^LR(LRDFN,"CH",LRI,1,B))

               IF 'B!(LR("Q"))

                   QUIT

               SET B(1)=^(B,0)

               IF $Y>(IOSL-6)

                   DO H1

               IF LR("Q")

                   QUIT

               WRITE !?5,B(1)

 +5        FOR B=0:0

               SET B=$ORDER(^LR(LRDFN,"CH",LRI,1,"AC",B))

               IF 'B!(LR("Q"))

                   QUIT

               SET C=""

               FOR E=0:0

                   SET C=$ORDER(^LR(LRDFN,"CH",LRI,1,"AC",B,C))

                   IF C=""

                       QUIT

                   IF $Y>(IOSL-6)

                       DO H1

                   IF LR("Q")

                       QUIT

                   DO P1

 +6        QUIT

 +7       ;

P1        ; EP

 +1        SET X=$GET(^VA(200,B,0))

           WRITE !?5,$PIECE(^LR(LRDFN,"CH",LRI,1,"AC",B,C),"^",3)

           IF $X>60

               WRITE !

           WRITE " (deleted by ",$SELECT($PIECE(X,"^",2)]"":$PIECE(X,"^",2),1:$PIECE(X,",")),")"

 +2        QUIT

 +3       ;

TST       ; EP

 +1        IF '$DATA(LR(LRA))

               SET LR(LRA)=+$ORDER(^LRO(68,"B",LRA,0))

           SET X=$PIECE(^LRO(68,LR(LRA),0),"^",3)

           SET Z=$PIECE(LRB," ",2)

           SET G=$EXTRACT(LRT,1,3)

           IF X="D"

               SET G=G_$PIECE(LRB," ")

 +2       IF '$TEST

               SET G=$SELECT(X="Y":G_"0000",X="M":G_$EXTRACT($PIECE(LRB," "),1,2)_"00",1:G)

 +3        SET (C,E,E(1))=0

           FOR E(1)=0:0

               SET C=$ORDER(^LRO(68,LR(LRA),1,G,1,Z,4,C))

               IF 'C!(LR("Q"))

                   QUIT

               SET LRX=^(C,0)

               IF $PIECE(^LAB(60,C,0),U,4)'="WK"

                   DO B

 +4        QUIT

 +5       ;

B         ; EP

 +1        SET E=E+1

           SET J=$PIECE(LRX,U,4)

           SET J=$SELECT(J:$PIECE($GET(^VA(200,J,0)),"^",2),1:J)

           IF $Y>(IOSL-6)

               DO H2

           IF LR("Q")

               QUIT

           WRITE !

           IF E=1

               WRITE "Test(s) ordered:"

           WRITE ?18,$PIECE($GET(^LAB(60,C,0)),"^"),?49,"Tech: ",J

 +2        QUIT

 +3       ;

H         ; EP

 +1        IF $DATA(LR("F"))

               IF IOST?1"C".E

                   DO M^LRU

                   IF LR("Q")

                       QUIT

 +2        DO F^LRU

           WRITE !,LRC(1)

           IF $LENGTH(LRC(1))>44

               WRITE !

           WRITE " From: ",LRSTR," To: ",LRLST,!,"Acc #",?14,"Date/Time",?34,"Name/HRCN",?67,"Specimen",!,LR("%")

 +3        QUIT

H1        ; EP

 +1        DO H

           IF LR("Q")

               QUIT

           WRITE !,LRA," ",LRB,?14,LRDATE,?34,LRP," ",HRCN," ",LRS

 +2        QUIT

 +3       ;

H2        ; EP

 +1        DO H1

           IF LR("Q")

               QUIT

           WRITE !,"Test(s) ordered:"

           SET E=2

 +2        QUIT

END       ; EP

 +1        DO V^LRU

 +2        QUIT

 +3       ;

DEBUGFOR  ; EP - Check the FOR loop

 +1        NEW ACCDELC,D1,D1IEN,DEVICE,DEVDESC,TRANGE,DUZ2,DUZ2DESC,LISTTEST,NEWPAGE,PREVREPT,SPECREJ

 +2       ;

 +3       ; Parameters for LRUER report are in 90475.71

 +4        SET GPD1=.9999999

 +5        FOR

               SET GPD1=$ORDER(^BLRLSRP(1,1,GPD1))

               IF GPD1<1

                   QUIT

               Begin DoDot:1

 +6                SET D1IEN=GPD1_","_1

 +7                SET DUZ2=$$GET1^DIQ(90475.71,D1IEN,.01,"I")

 +8                SET DUZ2=$$GET1^DIQ(90475.71,D1IEN,.01,"I")

 +9                SET DUZ2DESC=$$GET1^DIQ(90475.71,D1IEN,.01)

 +10               SET PREVREPT=+$$GET1^DIQ(90475.71,D1IEN,1,"I")

 +11               SET SPECREJ=+$$GET1^DIQ(90475.71,D1IEN,2,"I")

 +12               SET ACCDELC=+$$GET1^DIQ(90475.71,D1IEN,3,"I")

 +13               SET LISTTEST=+$$GET1^DIQ(90475.71,D1IEN,4,"I")

 +14               SET NEWPAGE=+$$GET1^DIQ(90475.71,D1IEN,5,"I")

 +15               SET DTRANGE=+$$GET1^DIQ(90475.71,D1IEN,6,"I")

 +16      ;

 +17               SET LRSDT=$SELECT(DTRANGE=1:$$HTFM^XLFDT(+$HOROLOG-7),DTRANGE=2:$$HTFM^XLFDT(+$HOROLOG-30),DTRANGE=3:$$HTFM^XLFDT(+$HOROLOG-365),1:$$HTFM^XLFDT(+$HOROLOG-1))

 +18               SET LRLDT=$$DT^XLFDT

 +19               SET LRSTR=$$FMTE^XLFDT(LRSDT,"5DZ")

 +20               SET LRLST=$$FMTE^XLFDT(LRLDT,"5DZ")

 +21               SET LRS=LRSDT-.01

                   SET LRE=LRLDT+.99

                   SET LRLDT=9999998-LRLDT

                   SET LRSDT=9999999-LRSDT

 +22      ;

 +23               SET DEVICE=+$$GET1^DIQ(90475.71,D1IEN,7,"I")

 +24      ; Default device is LABLABEL

                   IF DEVICE=0

                       Begin DoDot:2

 +25                       SET DEVICE=+$$FIND1^DIC(3.5,,,"LABLABEL")

 +26                       SET DEVDESC=$$GET1^DIQ(3.5,DEVICE,.01)

                       End DoDot:2

 +27      ;

 +28               WRITE ?4,"GPD1:",GPD1," -- ",$$GET1^DIQ(4,GPD1,.01),!

 +29               WRITE ?9,"DUZ2:",DUZ2,"; DUZ2DESC:",DUZ2DESC,!

 +30               WRITE ?9,"PREVREPT:",PREVREPT,!

 +31               WRITE ?9,"SPECREJ:",SPECREJ,!

 +32               WRITE ?9,"ACCDELC:",ACCDELC,!

 +33               WRITE ?9,"LISTTEST:",LISTTEST,!

 +34               WRITE ?9,"NEWPAGE:",NEWPAGE,!

 +35               WRITE ?9,"DTRANGE:",DTRANGE,!

 +36      ;

 +37               SET LRSDT=$SELECT(DTRANGE=1:$$HTFM^XLFDT(+$HOROLOG-7),DTRANGE=2:$$HTFM^XLFDT(+$HOROLOG-30),DTRANGE=3:$$HTFM^XLFDT(+$HOROLOG-365),1:$$HTFM^XLFDT(+$HOROLOG-1))

 +38               SET LRLDT=$$DT^XLFDT

 +39               WRITE ?9,"LRSDT:",LRSDT,?29,"LRLDT:",LRLDT,!

 +40               SET LRSTR=$$FMTE^XLFDT(LRSDT,"5DZ")

 +41               SET LRLST=$$FMTE^XLFDT(LRLDT,"5DZ")

 +42               WRITE ?9,"LRSTR:",LRSTR,?29,"LRLST:",LRLST,!

 +43               SET LRS=LRSDT-.01

                   SET LRE=LRLDT+.99

                   SET LRLDT=9999998-LRLDT

                   SET LRSDT=9999999-LRSDT

 +44               WRITE ?9,"LRS:",LRS,?29,"LRE:",LRE,!

 +45               WRITE ?9,"LRSDT:",LRSDT,?29,"LRLDT:",LRLDT,!

               End DoDot:1

 +46       QUIT

BLRUER.m