LRSPRPT.m

LRSPRPT ;AVAMC/REG/WTY/KLL - CY/EM/SP PATIENT RPT ;08/22/01

 ;;5.2;LAB SERVICE;**1030**;NOV 01, 1997

 ;;5.2;LAB SERVICE;**1,72,248,259,317**;Sep 27, 1994

 ;

 W !!?20,LRO(68)," FINAL PATIENT REPORTS"

 K LRSAV,LRAP,LRS(99)

 D EN2^LRUA

 G END^LRSPRPT1:LRAPX=2,SGL:LRAPX=3,CH:LRAPX=4

GETP ;

 D EN1^LRUPS Q:LRAN=-1

 G:$D(^LRO(69.2,LRAA,2,LRAN,0)) GETP

 L +^LRO(69.2,LRAA,2):5  I '$T D  G GETP

 .S MSG(1)="The final reports queue is in use by another person.  "

 .S MSG(1,"F")="!!"

 .S MSG(2)="You will need to add this accession to the queue later."

 .D EN^DDIOL(.MSG) K MSG

 S ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN_"^"_LRI

 S X=^LRO(69.2,LRAA,2,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)

 L -^LRO(69.2,LRAA,2)

 G GETP

CH ;

 S LRAPX(1)=2 D EN^LRSPRPT2 Q:%<1

 W !!,"Save final report list for reprinting "

 S %=2 D YN^LRU S:%=1 LRSAV=1

 ;Variable LR("DVD") is used to divide reports displayed in the browser

 K LR("DVD")

 S $P(LR("DVD"),"|",IOM)=""

DEV ;from LRAPMOD

 W !

 S %ZIS="Q" D ^%ZIS

 I POP W ! D END Q

 I $D(IO("Q")) D  Q

 .S ZTDESC="ANAT PATH FINAL REPORT"

 .S ZTSAVE("LR*")="",ZTRTN="QUE^LRSPRPT"

 .D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !

 .K ZTSK,IO("Q") D HOME^%ZIS

QUE ;

 U IO

 N LRFFF

 ;LRSF515=1 means that this is generating an SF515

 S:'$D(LRSF515) LRSF515=0

 S:'$D(LRFOC) LRFOC=0

 S:'$D(LRQUIT) LRQUIT=0

 S LRFFF=1  ;Flag used to determine whether to perform final form feed

 I LRFOC S LRFFF=0  ;If final office copy, don't perform final form feed

 S LR(.21)=+$G(^LRO(69.2,LRAA,.2)),LR("DIWF")="W"

 S LRA=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),U,9),1:1) S:LRA="" LRA=1

 D L^LRU,S^LRU,L1^LRU,SET^LRUA

PSGL ;Single Report

 I $D(LRAP) D  G LST

 .S LRDFN=$P(LRAP,"^"),LRI=$P(LRAP,"^",2)

 .I +$G(LRPTR) D  Q

 ..D MAIN^LRAPTIUP(LRPTR,0)

 ..S LRFFF=0 ;Don't do final form feed.  It's done by LRAPTIUP.

 ..I LRQUIT S LR("Q")=1 Q

 ..K LRAP S LR("F")=1

 ..I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT

 ..Q:LR("Q")

 ..I 'LRFOC S LR("Q")=1 Q

 ..D FOC

 ..I LRQUIT S LR("Q")=1 Q

 ..I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT

 .W:IOST?1"C-".E @IOF

 .D EN

 .K LRAP

 .I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT

 .Q:LR("Q")

 .I 'LRFOC S LR("Q")=1 Q

 .W !

 .W:IOST?1"P-".E @IOF

 .D FOC

 .I LRQUIT S LR("Q")=1 Q

 .I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT

PQUE ;Report from queue

 S LRAN=0

 F  S LRAN=$O(^LRO(69.2,LRAA,2,LRAN)) Q:'LRAN!(LR("Q"))  D

 .S LRQUIT=0

 .I 'LRFOC S LRFFF=1

 .K LR("F")

 .S X=^LRO(69.2,LRAA,2,LRAN,0),LRDFN=+X,LRI=$P(X,"^",2)

 .D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)

 .I +$G(LRPTR) D  Q

 ..D MAIN^LRAPTIUP(LRPTR,0)

 ..S LRFFF=0

 ..W:IOST["BROWSER"&('LRFOC) !!,LR("DVD")

 ..K LRPTR

 ..I LRQUIT S LR("Q")=1 Q

 ..S LR("F")=1

 ..I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT

 ..Q:LR("Q")!('LRFOC)

 ..D FOC

 ..W:IOST["BROWSER" !!,LR("DVD")

 ..I LRQUIT S LR("Q")=1 Q

 ..I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT

 .W:IOST?1"C-".E @IOF

 .D EN

 .W:IOST?1"P-".E @IOF

 .W:IOST["BROWSER"&('LRFOC) !!,LR("DVD")

 .I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT

 .Q:LR("Q")

 .Q:'LRFOC

 .W !

 .D FOC

 .W:IOST["BROWSER" !!,LR("DVD")

 .I LRQUIT S LR("Q")=1 Q

 .I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT

 S LRFFF=0

LST ;

 K LRRMD,LRPMD,LRAP

 K:'$D(LRSAV) ^LRO(69.2,LRAA,2)

 S ^LRO(69.2,LRAA,2,0)="^69.23A^^0"

 K LRSAV,LRV,LRW,LRZ

 I IOST?1"P-".E W:LRFFF @IOF

 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"

 K %,DIR,DTOUT,DUOUT,DIRUT,X,Y

 D END

 Q

W ;

 W !,LR("%")

 Q

F ;        

 D E

 S A=0 F LRZ=0:1 S A=$O(^LR(LRDFN,LRSS,LRI,LRV,A)) Q:'A!(LR("Q"))  D

 .D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")

 .S X=^LR(LRDFN,LRSS,LRI,LRV,A,0) D:X["|TOP|" TOP D ^DIWP

 Q:LR("Q")  D:LRZ ^DIWW

 Q

E ;

 K ^UTILITY($J)

 S DIWR=IOM-5,DIWL=5,DIWF=LR("DIWF")

 Q

 ;

EN ;from LRSPT

 ;KLL-Suppress printing of SNOMED codes, except on Preliminary prints

 S LR("SPSM")=$S($G(LRPRE):0,1:1)

 S LR(.21)=+$G(^LRO(69.2,+$G(LRAA),.2))

 K LRO Q:'$D(^LR(LRDFN,LRSS,LRI,0))

 S LRQ=0

 D ^LRUA

 D INP^VADPT S LRPRAC=+VAIN(2)

 S:'LRPRAC LRPRAC(1)=""

 I LRPRAC S X=LRPRAC D D^LRUA S LRPRAC(1)=X

 D ^LRAPF Q:LR("Q")

 S LR("F")=1 W !,"Submitted by: ",LRW(5),?44,"Date obtained: ",LRTK

 D:LRA W

 W !,"Specimen (Received ",LRTK(1),"):" S LRV=.1 D A Q:LR("Q")

 I $P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),"^",4) D

 .W !?14,"*+* SUPPLEMENTARY REPORT HAS BEEN ADDED *+*"

 .W !?19,"*+* REFER TO BOTTOM OF REPORT *+*",!

 D:LRA W W !,"Brief Clinical History:" S LRV=.2 D F Q:LR("Q")

 D:LRA W W !,"Preoperative Diagnosis:" S LRV=.3 D F Q:LR("Q")

 D:LRA W W !,"Operative Findings:" S LRV=.4 D F Q:LR("Q")

 D:LRA W W !,"Postoperative Diagnosis:" S LRV=.5 D F Q:LR("Q")

 W !?27,"Surgeon/physician: ",LRMD W:LRA !,LR("%1")

 D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")

 D P^LRAPF

 D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")

 D:LRA W

 W:LRRC="" !?20,"+*+* REPORT INCOMPLETE *+*+",!

 D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")

 W ! W:LRRMD]"" ?31,$S(LRSS="SP":"Pathology Resident: ",LRSS="CY":"Screened by: ",LRSS="EM":"Prepared by: ",1:" "),LRRMD

 I $O(^LR(LRDFN,LRSS,LRI,1.3,0)) D  Q:LR("Q")

 .D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")

 .W !,LR(69.2,.13)

 .I $P($G(^LR(LRDFN,LRSS,LRI,6,0)),U,4) S LR(0)=6 D ^LRSPRPTM

 S LRV=1.3 D F Q:LR("Q")

 I $O(^LR(LRDFN,LRSS,LRI,1,0)) D  Q:LR("Q")

 .D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")

 .W !,LR(69.2,.03)

 .I $P($G(^LR(LRDFN,LRSS,LRI,7,0)),U,4) S LR(0)=7 D ^LRSPRPTM

 S LRV=1 D F Q:LR("Q")

 I $O(^LR(LRDFN,LRSS,LRI,1.1,0)) D  Q:LR("Q")

 .D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")

 .W !,LR(69.2,.04)

 .I $P($G(^LR(LRDFN,LRSS,LRI,4,0)),"^",4) S LR(0)=4 D ^LRSPRPTM

 S LRV=1.1 D F Q:LR("Q")

 I $O(^LR(LRDFN,LRSS,LRI,1.4,0)) D  Q:LR("Q")

 .D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")

 .W !,LR(69.2,.14)

 .I $P($G(^LR(LRDFN,LRSS,LRI,5,0)),U,4) S LR(0)=5 D ^LRSPRPTM

 S LRV=1.4 D F Q:LR("Q")

 ;Supplementary Report

 I $O(^LR(LRDFN,LRSS,LRI,1.2,0)) D:LR(.21) F^LRAPF,^LRAPF Q:LR("Q")  D

 .D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")

 .W !,"Supplementary Report:"

 .S LRV=0 F  S LRV=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV)) Q:'LRV!(LR("Q"))  D

 ..S X=^LR(LRDFN,LRSS,LRI,1.2,LRV,0) D S

 D ^LRSPRPT1 Q:LR("Q")

 Q:+$G(LRPRE)  ;Don't set the final flag and print the footer if prelim

 S LRO=1 D F^LRAPF

 Q

S ;

 S Y=+X,X=$P(X,U,2) D D^LRU

 W !?3,"Date: ",Y

 I $D(LR("R")),'X W " not verified" Q

 D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")

 D:$P($G(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,0)),U,4) SUPA

 D E S B=0

 F LRZ=0:1 S B=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,1,B)) Q:'B!(LR("Q"))  D

 .D:$Y>(IOSL-14) F^LRAPF,^LRAPF Q:LR("Q")

 .S DIWF="W"

 .S X=^LR(LRDFN,LRSS,LRI,1.2,LRV,1,B,0) D ^DIWP Q:LR("Q")

 Q:LR("Q")

 D:LRZ ^DIWW

 Q

SGL ;Print Single Report

 N LRPTR

 S LRAPX(1)=""

 D EN1^LRUPS Q:LRAN=-1

 I '$P(^LR(LRDFN,LRSS,LRI,0),"^",11) D  G SGL

 .W $C(7)," Sorry, report not verified.",!

 D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)

 S LRAP=LRDFN_"^"_LRI,LRSAV=1

 D EN2^LRUA

 G DEV

A ;

 S A=0 F  S A=$O(^LR(LRDFN,LRSS,LRI,LRV,A)) Q:'A!(LR("Q"))  D

 .D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")

 .W !,$P(^LR(LRDFN,LRSS,LRI,LRV,A,0),"^")

 Q

TOP ;

 S Z=$P(X,"|TOP|",1)_$P(X,"|TOP|",2) D F^LRAPF,^LRAPF S X=Z

 Q

SUPA ;Print supplementary report audit information

 W !?14,"*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED *+*"

 W !,"(Added/Last modified: "

 S (A,B)=0 F  S A=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A)) Q:'A!(LR("Q"))  D

 .S B=A

 Q:LR("Q")

 Q:'$D(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,B,0))

 S A=^(0),Y=+A,LRSGN=" typed by ",A=$P(A,"^",2)

 I $P(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,B,0),"^",3) D

 .S A=^(0),LRSGN=" signed by ",A2=$P(A,"^",3),Y=$P(A,"^",4)

 .S A=A2

 S A=$S($D(^VA(200,A,0)):$P(^(0),"^"),1:A)

 ;If supp rpt is released, display 'signed by' instead of 'typed by'

 D D^LRU W Y,LRSGN,A,")"

 ;If RELEASE SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED"

 I $P(^LR(LRDFN,LRSS,LRI,1.2,LRV,0),"^",3) W !,?25,"**-* NOT VERIFIED *-**"

 D:$D(LRQ(9)) SUPM

 Q

SUPM ;Print previous versions of supplementary reports

 ;This is used by menu option 'Print path modifications [LRAPMOD]'

 ;

 S A=0 F  S A=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A)) Q:'A!(LR("Q"))  D

 .S LRT=^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,0)

 .D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")

 .S Y=+LRT,Y2=" modified: ",X=$P(LRT,"^",2),LRSGN="  typed by "

 .;If supp rpt is released, display 'signed by' instead of 'typed by' 

 .I $P(LRT,"^",3) S LRSGN=" signed by ",X=$P(LRT,"^",3),Y=$P(LRT,"^",4),Y2=" released: "

 .S X=$S($D(^VA(200,X,0)):$P(^(0),"^"),1:X)

 .D D^LRU W !,"Date ",Y2,Y,LRSGN,X

 .K ^UTILITY($J)

 .S DIWR=IOM-5,DIWL=5,DIWF="W"

 .S B=0

 .F LRZ=0:1 S B=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,1,B)) Q:'B!(LR("Q"))  D

 ..S LRT=^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,1,B,0)

 ..D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")

 ..S X=LRT D ^DIWP

 .Q:LR("Q")  D:LRZ ^DIWW

 Q:LR("Q")

 W !?13,"==========Text below appears on final report=========="

 Q

CONT ;

 K DIR S DIR(0)="E"

 D ^DIR W !

 S:$D(DTOUT)!(X[U) LR("Q")=1

 Q

FOC ;Print final office copy page (SNOMEDS)

 N LRADC,LRCTR

 I '$D(LRAP) D

 .D:LRSS'="AU" ^LRUA

 .I LRSS="AU" S X=^LR(LRDFN,0) D ^LRUP

 I LRSS="AU" D

 .S LRADC=$E($P(^LR(LRDFN,LRSS),"^"),1,3)_"0000"

 .S:+$G(LRDPF)=2 LRDEM("DTH")=$P(VADM(6),"^",2)

 .;Get DATE DIED from Referral File for Referral Patients

 .S:+$G(LRDPF)'=2 LRDEM("DTH")=$$GET1^DIQ(67,DFN_",",.351)

 .S LRDEM("AUDT")=$$GET1^DIQ(63,LRDFN_",",11)

 .S LRDEM("AUTYP")=$$GET1^DIQ(63,LRDFN_",",13.7)

 .S LRDEM("PRO")=$$GET1^DIQ(63,LRDFN_",",13.5)

 I LRSS'="AU" D

 .S LRADC=$E($P(^LR(LRDFN,LRSS,LRI,0),"^"),1,3)_"0000"

 .S LRDEM("PRO")=LRMD

 S LRDEM("PNM")=LRP,LRDEM("SSN")=SSN

 S LRDEM("SEX")=SEX,LRDEM("AGE")=AGE,LRDEM("DOB")=DOB

 D INIT^LRAPSNMD(LRDFN,LRSS,$G(LRI),LRSF,LRAA,LRAN,LRADC,.LRDEM,0)

 Q

END ;

 D V^LRU

 K LRSF515

 Q

LRSPRPT   ;AVAMC/REG/WTY/KLL - CY/EM/SP PATIENT RPT ;08/22/01

 +1       ;;5.2;LAB SERVICE;**1030**;NOV 01, 1997

 +2       ;;5.2;LAB SERVICE;**1,72,248,259,317**;Sep 27, 1994

 +3       ;

 +4        WRITE !!?20,LRO(68)," FINAL PATIENT REPORTS"

 +5        KILL LRSAV,LRAP,LRS(99)

 +6        DO EN2^LRUA

 +7        IF LRAPX=2

               GOTO END^LRSPRPT1

           IF LRAPX=3

               GOTO SGL

           IF LRAPX=4

               GOTO CH

GETP      ;

 +1        DO EN1^LRUPS

           IF LRAN=-1

               QUIT 

 +2        IF $DATA(^LRO(69.2,LRAA,2,LRAN,0))

               GOTO GETP

 +3        LOCK +^LRO(69.2,LRAA,2):5

           IF '$TEST

               Begin DoDot:1

 +4                SET MSG(1)="The final reports queue is in use by another person.  "

 +5                SET MSG(1,"F")="!!"

 +6                SET MSG(2)="You will need to add this accession to the queue later."

 +7                DO EN^DDIOL(.MSG)

                   KILL MSG

               End DoDot:1

               GOTO GETP

 +8        SET ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN_"^"_LRI

 +9        SET X=^LRO(69.2,LRAA,2,0)

           SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRAN_"^"_($PIECE(X,"^",4)+1)

 +10       LOCK -^LRO(69.2,LRAA,2)

 +11       GOTO GETP

CH        ;

 +1        SET LRAPX(1)=2

           DO EN^LRSPRPT2

           IF %<1

               QUIT 

 +2        WRITE !!,"Save final report list for reprinting "

 +3        SET %=2

           DO YN^LRU

           IF %=1

               SET LRSAV=1

 +4       ;Variable LR("DVD") is used to divide reports displayed in the browser

 +5        KILL LR("DVD")

 +6        SET $PIECE(LR("DVD"),"|",IOM)=""

DEV       ;from LRAPMOD

 +1        WRITE !

 +2        SET %ZIS="Q"

           DO ^%ZIS

 +3        IF POP

               WRITE !

               DO END

               QUIT 

 +4        IF $DATA(IO("Q"))

               Begin DoDot:1

 +5                SET ZTDESC="ANAT PATH FINAL REPORT"

 +6                SET ZTSAVE("LR*")=""

                   SET ZTRTN="QUE^LRSPRPT"

 +7                DO ^%ZTLOAD

                   IF $DATA(ZTSK)

                       WRITE !,"Request Queued, #",ZTSK

                   WRITE !

 +8                KILL ZTSK,IO("Q")

                   DO HOME^%ZIS

               End DoDot:1

               QUIT 

QUE       ;

 +1        USE IO

 +2        NEW LRFFF

 +3       ;LRSF515=1 means that this is generating an SF515

 +4        IF '$DATA(LRSF515)

               SET LRSF515=0

 +5        IF '$DATA(LRFOC)

               SET LRFOC=0

 +6        IF '$DATA(LRQUIT)

               SET LRQUIT=0

 +7       ;Flag used to determine whether to perform final form feed

           SET LRFFF=1

 +8       ;If final office copy, don't perform final form feed

           IF LRFOC

               SET LRFFF=0

 +9        SET LR(.21)=+$GET(^LRO(69.2,LRAA,.2))

           SET LR("DIWF")="W"

 +10       SET LRA=$SELECT($DATA(^LRO(69.2,LRAA,0)):$PIECE(^(0),U,9),1:1)

           IF LRA=""

               SET LRA=1

 +11       DO L^LRU

           DO S^LRU

           DO L1^LRU

           DO SET^LRUA

PSGL      ;Single Report

 +1        IF $DATA(LRAP)

               Begin DoDot:1

 +2                SET LRDFN=$PIECE(LRAP,"^")

                   SET LRI=$PIECE(LRAP,"^",2)

 +3                IF +$GET(LRPTR)

                       Begin DoDot:2

 +4                        DO MAIN^LRAPTIUP(LRPTR,0)

 +5       ;Don't do final form feed.  It's done by LRAPTIUP.

                           SET LRFFF=0

 +6                        IF LRQUIT

                               SET LR("Q")=1

                               QUIT 

 +7                        KILL LRAP

                           SET LR("F")=1

 +8                        IF 'LR("Q")

                               IF $DATA(LR("F"))

                                   IF IOST?1"C".E

                                       DO CONT

 +9                        IF LR("Q")

                               QUIT 

 +10                       IF 'LRFOC

                               SET LR("Q")=1

                               QUIT 

 +11                       DO FOC

 +12                       IF LRQUIT

                               SET LR("Q")=1

                               QUIT 

 +13                       IF 'LR("Q")

                               IF $DATA(LR("F"))

                                   IF IOST?1"C".E

                                       DO CONT

                       End DoDot:2

                       QUIT 

 +14               IF IOST?1"C-".E

                       WRITE @IOF

 +15               DO EN

 +16               KILL LRAP

 +17               IF 'LR("Q")

                       IF $DATA(LR("F"))

                           IF IOST?1"C".E

                               DO CONT

 +18               IF LR("Q")

                       QUIT 

 +19               IF 'LRFOC

                       SET LR("Q")=1

                       QUIT 

 +20               WRITE !

 +21               IF IOST?1"P-".E

                       WRITE @IOF

 +22               DO FOC

 +23               IF LRQUIT

                       SET LR("Q")=1

                       QUIT 

 +24               IF 'LR("Q")

                       IF $DATA(LR("F"))

                           IF IOST?1"C".E

                               DO CONT

               End DoDot:1

               GOTO LST

PQUE      ;Report from queue

 +1        SET LRAN=0

 +2        FOR 

               SET LRAN=$ORDER(^LRO(69.2,LRAA,2,LRAN))

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

                   QUIT 

               Begin DoDot:1

 +3                SET LRQUIT=0

 +4                IF 'LRFOC

                       SET LRFFF=1

 +5                KILL LR("F")

 +6                SET X=^LRO(69.2,LRAA,2,LRAN,0)

                   SET LRDFN=+X

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

 +7                DO TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)

 +8                IF +$GET(LRPTR)

                       Begin DoDot:2

 +9                        DO MAIN^LRAPTIUP(LRPTR,0)

 +10                       SET LRFFF=0

 +11                       IF IOST["BROWSER"&('LRFOC)

                               WRITE !!,LR("DVD")

 +12                       KILL LRPTR

 +13                       IF LRQUIT

                               SET LR("Q")=1

                               QUIT 

 +14                       SET LR("F")=1

 +15                       IF 'LR("Q")

                               IF $DATA(LR("F"))

                                   IF IOST?1"C-".E

                                       DO CONT

 +16                       IF LR("Q")!('LRFOC)

                               QUIT 

 +17                       DO FOC

 +18                       IF IOST["BROWSER"

                               WRITE !!,LR("DVD")

 +19                       IF LRQUIT

                               SET LR("Q")=1

                               QUIT 

 +20                       IF 'LR("Q")

                               IF $DATA(LR("F"))

                                   IF IOST?1"C".E

                                       DO CONT

                       End DoDot:2

                       QUIT 

 +21               IF IOST?1"C-".E

                       WRITE @IOF

 +22               DO EN

 +23               IF IOST?1"P-".E

                       WRITE @IOF

 +24               IF IOST["BROWSER"&('LRFOC)

                       WRITE !!,LR("DVD")

 +25               IF 'LR("Q")

                       IF $DATA(LR("F"))

                           IF IOST?1"C-".E

                               DO CONT

 +26               IF LR("Q")

                       QUIT 

 +27               IF 'LRFOC

                       QUIT 

 +28               WRITE !

 +29               DO FOC

 +30               IF IOST["BROWSER"

                       WRITE !!,LR("DVD")

 +31               IF LRQUIT

                       SET LR("Q")=1

                       QUIT 

 +32               IF 'LR("Q")

                       IF $DATA(LR("F"))

                           IF IOST?1"C".E

                               DO CONT

               End DoDot:1

 +33       SET LRFFF=0

LST       ;

 +1        KILL LRRMD,LRPMD,LRAP

 +2        IF '$DATA(LRSAV)

               KILL ^LRO(69.2,LRAA,2)

 +3        SET ^LRO(69.2,LRAA,2,0)="^69.23A^^0"

 +4        KILL LRSAV,LRV,LRW,LRZ

 +5        IF IOST?1"P-".E

               IF LRFFF

                   WRITE @IOF

 +6        DO ^%ZISC

           IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +7        KILL %,DIR,DTOUT,DUOUT,DIRUT,X,Y

 +8        DO END

 +9        QUIT 

W         ;

 +1        WRITE !,LR("%")

 +2        QUIT 

F         ;        

 +1        DO E

 +2        SET A=0

           FOR LRZ=0:1

               SET A=$ORDER(^LR(LRDFN,LRSS,LRI,LRV,A))

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

                   QUIT 

               Begin DoDot:1

 +3                IF $Y>(IOSL-13)

                       DO F^LRAPF

                       DO ^LRAPF

                   IF LR("Q")

                       QUIT 

 +4                SET X=^LR(LRDFN,LRSS,LRI,LRV,A,0)

                   IF X["|TOP|"

                       DO TOP

                   DO ^DIWP

               End DoDot:1

 +5        IF LR("Q")

               QUIT 

           IF LRZ

               DO ^DIWW

 +6        QUIT 

E         ;

 +1        KILL ^UTILITY($JOB)

 +2        SET DIWR=IOM-5

           SET DIWL=5

           SET DIWF=LR("DIWF")

 +3        QUIT 

 +4       ;

EN        ;from LRSPT

 +1       ;KLL-Suppress printing of SNOMED codes, except on Preliminary prints

 +2        SET LR("SPSM")=$SELECT($GET(LRPRE):0,1:1)

 +3        SET LR(.21)=+$GET(^LRO(69.2,+$GET(LRAA),.2))

 +4        KILL LRO

           IF '$DATA(^LR(LRDFN,LRSS,LRI,0))

               QUIT 

 +5        SET LRQ=0

 +6        DO ^LRUA

 +7        DO INP^VADPT

           SET LRPRAC=+VAIN(2)

 +8        IF 'LRPRAC

               SET LRPRAC(1)=""

 +9        IF LRPRAC

               SET X=LRPRAC

               DO D^LRUA

               SET LRPRAC(1)=X

 +10       DO ^LRAPF

           IF LR("Q")

               QUIT 

 +11       SET LR("F")=1

           WRITE !,"Submitted by: ",LRW(5),?44,"Date obtained: ",LRTK

 +12       IF LRA

               DO W

 +13       WRITE !,"Specimen (Received ",LRTK(1),"):"

           SET LRV=.1

           DO A

           IF LR("Q")

               QUIT 

 +14       IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,1.2,0)),"^",4)

               Begin DoDot:1