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
+15 WRITE !?14,"*+* SUPPLEMENTARY REPORT HAS BEEN ADDED *+*"
+16 WRITE !?19,"*+* REFER TO BOTTOM OF REPORT *+*",!
End DoDot:1
+17 IF LRA
DO W
WRITE !,"Brief Clinical History:"
SET LRV=.2
DO F
IF LR("Q")
QUIT
+18 IF LRA
DO W
WRITE !,"Preoperative Diagnosis:"
SET LRV=.3
DO F
IF LR("Q")
QUIT
+19 IF LRA
DO W
WRITE !,"Operative Findings:"
SET LRV=.4
DO F
IF LR("Q")
QUIT
+20 IF LRA
DO W
WRITE !,"Postoperative Diagnosis:"
SET LRV=.5
DO F
IF LR("Q")
QUIT
+21 WRITE !?27,"Surgeon/physician: ",LRMD
IF LRA
WRITE !,LR("%1")
+22 IF $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
IF LR("Q")
QUIT
+23 DO P^LRAPF
+24 IF $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
IF LR("Q")
QUIT
+25 IF LRA
DO W
+26 IF LRRC=""
WRITE !?20,"+*+* REPORT INCOMPLETE *+*+",!
+27 IF $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
IF LR("Q")
QUIT
+28 WRITE !
IF LRRMD]""
WRITE ?31,$SELECT(LRSS="SP":"Pathology Resident: ",LRSS="CY":"Screened by: ",LRSS="EM":"Prepared by: ",1:" "),LRRMD
+29 IF $ORDER(^LR(LRDFN,LRSS,LRI,1.3,0))
Begin DoDot:1
+30 IF $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
IF LR("Q")
QUIT
+31 WRITE !,LR(69.2,.13)
+32 IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,6,0)),U,4)
SET LR(0)=6
DO ^LRSPRPTM
End DoDot:1
IF LR("Q")
QUIT
+33 SET LRV=1.3
DO F
IF LR("Q")
QUIT
+34 IF $ORDER(^LR(LRDFN,LRSS,LRI,1,0))
Begin DoDot:1
+35 IF $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
IF LR("Q")
QUIT
+36 WRITE !,LR(69.2,.03)
+37 IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,7,0)),U,4)
SET LR(0)=7
DO ^LRSPRPTM
End DoDot:1
IF LR("Q")
QUIT
+38 SET LRV=1
DO F
IF LR("Q")
QUIT
+39 IF $ORDER(^LR(LRDFN,LRSS,LRI,1.1,0))
Begin DoDot:1
+40 IF $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
IF LR("Q")
QUIT
+41 WRITE !,LR(69.2,.04)
+42 IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,4,0)),"^",4)
SET LR(0)=4
DO ^LRSPRPTM
End DoDot:1
IF LR("Q")
QUIT
+43 SET LRV=1.1
DO F
IF LR("Q")
QUIT
+44 IF $ORDER(^LR(LRDFN,LRSS,LRI,1.4,0))
Begin DoDot:1
+45 IF $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
IF LR("Q")
QUIT
+46 WRITE !,LR(69.2,.14)
+47 IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,5,0)),U,4)
SET LR(0)=5
DO ^LRSPRPTM
End DoDot:1
IF LR("Q")
QUIT
+48 SET LRV=1.4
DO F
IF LR("Q")
QUIT
+49 ;Supplementary Report
+50 IF $ORDER(^LR(LRDFN,LRSS,LRI,1.2,0))
IF LR(.21)
DO F^LRAPF
DO ^LRAPF
IF LR("Q")
QUIT
Begin DoDot:1
+51 IF $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
IF LR("Q")
QUIT
+52 WRITE !,"Supplementary Report:"
+53 SET LRV=0
FOR
SET LRV=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV))
IF 'LRV!(LR("Q"))
QUIT
Begin DoDot:2
+54 SET X=^LR(LRDFN,LRSS,LRI,1.2,LRV,0)
DO S
End DoDot:2
End DoDot:1
+55 DO ^LRSPRPT1
IF LR("Q")
QUIT
+56 ;Don't set the final flag and print the footer if prelim
IF +$GET(LRPRE)
QUIT
+57 SET LRO=1
DO F^LRAPF
+58 QUIT
S ;
+1 SET Y=+X
SET X=$PIECE(X,U,2)
DO D^LRU
+2 WRITE !?3,"Date: ",Y
+3 IF $DATA(LR("R"))
IF 'X
WRITE " not verified"
QUIT
+4 IF $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
IF LR("Q")
QUIT
+5 IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,0)),U,4)
DO SUPA
+6 DO E
SET B=0
+7 FOR LRZ=0:1
SET B=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV,1,B))
IF 'B!(LR("Q"))
QUIT
Begin DoDot:1
+8 IF $Y>(IOSL-14)
DO F^LRAPF
DO ^LRAPF
IF LR("Q")
QUIT
+9 SET DIWF="W"
+10 SET X=^LR(LRDFN,LRSS,LRI,1.2,LRV,1,B,0)
DO ^DIWP
IF LR("Q")
QUIT
End DoDot:1
+11 IF LR("Q")
QUIT
+12 IF LRZ
DO ^DIWW
+13 QUIT
SGL ;Print Single Report
+1 NEW LRPTR
+2 SET LRAPX(1)=""
+3 DO EN1^LRUPS
IF LRAN=-1
QUIT
+4 IF '$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",11)
Begin DoDot:1
+5 WRITE $CHAR(7)," Sorry, report not verified.",!
End DoDot:1
GOTO SGL
+6 DO TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)
+7 SET LRAP=LRDFN_"^"_LRI
SET LRSAV=1
+8 DO EN2^LRUA
+9 GOTO DEV
A ;
+1 SET A=0
FOR
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,LRV,A))
IF 'A!(LR("Q"))
QUIT
Begin DoDot:1
+2 IF $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
IF LR("Q")
QUIT
+3 WRITE !,$PIECE(^LR(LRDFN,LRSS,LRI,LRV,A,0),"^")
End DoDot:1
+4 QUIT
TOP ;
+1 SET Z=$PIECE(X,"|TOP|",1)_$PIECE(X,"|TOP|",2)
DO F^LRAPF
DO ^LRAPF
SET X=Z
+2 QUIT
SUPA ;Print supplementary report audit information
+1 WRITE !?14,"*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED *+*"
+2 WRITE !,"(Added/Last modified: "
+3 SET (A,B)=0
FOR
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A))
IF 'A!(LR("Q"))
QUIT
Begin DoDot:1
+4 SET B=A
End DoDot:1
+5 IF LR("Q")
QUIT
+6 IF '$DATA(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,B,0))
QUIT
+7 SET A=^(0)
SET Y=+A
SET LRSGN=" typed by "
SET A=$PIECE(A,"^",2)
+8 IF $PIECE(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,B,0),"^",3)
Begin DoDot:1
+9 SET A=^(0)
SET LRSGN=" signed by "
SET A2=$PIECE(A,"^",3)
SET Y=$PIECE(A,"^",4)
+10 SET A=A2
End DoDot:1
+11 SET A=$SELECT($DATA(^VA(200,A,0)):$PIECE(^(0),"^"),1:A)
+12 ;If supp rpt is released, display 'signed by' instead of 'typed by'
+13 DO D^LRU
WRITE Y,LRSGN,A,")"
+14 ;If RELEASE SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED"
+15 IF $PIECE(^LR(LRDFN,LRSS,LRI,1.2,LRV,0),"^",3)
WRITE !,?25,"**-* NOT VERIFIED *-**"
+16 IF $DATA(LRQ(9))
DO SUPM
+17 QUIT
SUPM ;Print previous versions of supplementary reports
+1 ;This is used by menu option 'Print path modifications [LRAPMOD]'
+2 ;
+3 SET A=0
FOR
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A))
IF 'A!(LR("Q"))
QUIT
Begin DoDot:1
+4 SET LRT=^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,0)
+5 IF $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
IF LR("Q")
QUIT
+6 SET Y=+LRT
SET Y2=" modified: "
SET X=$PIECE(LRT,"^",2)
SET LRSGN=" typed by "
+7 ;If supp rpt is released, display 'signed by' instead of 'typed by'
+8 IF $PIECE(LRT,"^",3)
SET LRSGN=" signed by "
SET X=$PIECE(LRT,"^",3)
SET Y=$PIECE(LRT,"^",4)
SET Y2=" released: "
+9 SET X=$SELECT($DATA(^VA(200,X,0)):$PIECE(^(0),"^"),1:X)
+10 DO D^LRU
WRITE !,"Date ",Y2,Y,LRSGN,X
+11 KILL ^UTILITY($JOB)
+12 SET DIWR=IOM-5
SET DIWL=5
SET DIWF="W"
+13 SET B=0
+14 FOR LRZ=0:1
SET B=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,1,B))
IF 'B!(LR("Q"))
QUIT
Begin DoDot:2
+15 SET LRT=^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,1,B,0)
+16 IF $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
IF LR("Q")
QUIT
+17 SET X=LRT
DO ^DIWP
End DoDot:2
+18 IF LR("Q")
QUIT
IF LRZ
DO ^DIWW
End DoDot:1
+19 IF LR("Q")
QUIT
+20 WRITE !?13,"==========Text below appears on final report=========="
+21 QUIT
CONT ;
+1 KILL DIR
SET DIR(0)="E"
+2 DO ^DIR
WRITE !
+3 IF $DATA(DTOUT)!(X[U)
SET LR("Q")=1
+4 QUIT
FOC ;Print final office copy page (SNOMEDS)
+1 NEW LRADC,LRCTR
+2 IF '$DATA(LRAP)
Begin DoDot:1
+3 IF LRSS'="AU"
DO ^LRUA
+4 IF LRSS="AU"
SET X=^LR(LRDFN,0)
DO ^LRUP
End DoDot:1
+5 IF LRSS="AU"
Begin DoDot:1
+6 SET LRADC=$EXTRACT($PIECE(^LR(LRDFN,LRSS),"^"),1,3)_"0000"
+7 IF +$GET(LRDPF)=2
SET LRDEM("DTH")=$PIECE(VADM(6),"^",2)
+8 ;Get DATE DIED from Referral File for Referral Patients
+9 IF +$GET(LRDPF)'=2
SET LRDEM("DTH")=$$GET1^DIQ(67,DFN_",",.351)
+10 SET LRDEM("AUDT")=$$GET1^DIQ(63,LRDFN_",",11)
+11 SET LRDEM("AUTYP")=$$GET1^DIQ(63,LRDFN_",",13.7)
+12 SET LRDEM("PRO")=$$GET1^DIQ(63,LRDFN_",",13.5)
End DoDot:1
+13 IF LRSS'="AU"
Begin DoDot:1
+14 SET LRADC=$EXTRACT($PIECE(^LR(LRDFN,LRSS,LRI,0),"^"),1,3)_"0000"
+15 SET LRDEM("PRO")=LRMD
End DoDot:1
+16 SET LRDEM("PNM")=LRP
SET LRDEM("SSN")=SSN
+17 SET LRDEM("SEX")=SEX
SET LRDEM("AGE")=AGE
SET LRDEM("DOB")=DOB
+18 DO INIT^LRAPSNMD(LRDFN,LRSS,$GET(LRI),LRSF,LRAA,LRAN,LRADC,.LRDEM,0)
+19 QUIT
END ;
+1 DO V^LRU
+2 KILL LRSF515
+3 QUIT
