LRAPAUSR ;AVAMC/REG/WTY - AUTOPSY SUPPLEMENTARY REPORT;9/14/01
;;5.2;LAB SERVICE;**1030**;NOV 01, 1997
;;5.2;LAB SERVICE;**1,173,248,259,317**;Sep 27, 1994
;
;Reference to ^DD(63 supported by IA #10155
;
S X="T",%DT="" D ^%DT,D^LRU S LRH(3)=Y,LRFLG=1
W !!,LRO(68)," Autopsy Supplementary Reports" D XR^LRU
S LRS(1)=$P(^LRO(69.2,LRAA,0),U,3),LRS(2)=$P(^(0),U,4)
D EN2^LRUA
G END:LRAPX=2,SGL:LRAPX=3,CH:LRAPX=4
S XTMP="Someone else is building a print queue for this Accession Area"
L +^LRO(69.2,LRAA,3):5 I '$T D EN^DDIOL(XTMP,"","$C(7),!!") K XTMP Q
GETP ;Add a patient to the report queue
W ! S X="" D ^LRUPS G GETP:LRAN["?" I LRAN=-1 L -^LRO(69.2,LRAA,3) Q
S FDAIEN(2)=LRAN
S FDA(1,69.29,"+2,"_+LRAA_",",.01)=LRDFN
D UPDATE^DIE("","FDA(1)","FDAIEN") K FDAIEN G GETP
CH I '$O(^LRO(69.2,LRAA,3,0)) D Q
.W $C(7),!!,"No AUTOPSY SUPPLEMENTARY REPORTS currently on the "
.W "print queue.",!!
SPC R !,"(D)ouble or (S)ingle spacing of report(s): ",X:DTIME
Q:X=""!(X[U)
I $E(X)'="D"&($E(X)'="S") D G SPC
.W $C(7),!,"Enter 'S' for single or 'D' for double spacing of reports"
S LRS=$S(X="D":"D",1:"")_"W" Q:LRAPX=3
W !!,"Save supplementary report list for reprinting "
S %=2 D YN^LRU S:%=1 LRSAV=1
DEV ;
W !
S %ZIS="Q" D ^%ZIS
I POP W ! Q
I $D(IO("Q")) D Q
.S ZTDESC="ANAT PATH FINAL REPORT"
.S ZTSAVE("LR*")="",ZTRTN="QUE^LRAPAUSR"
.D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !
.K ZTSK,IO("Q") D HOME^%ZIS
QUE U IO D L^LRU,S^LRU,EN^LRUA
;LRSF515=1 indicates that an SF515 is being generated.
S:'$D(LRSF515) LRSF515=0
S (LRS(5),LRAURPT)=1
I $D(LRAP) S LRDFN=LRAP D EN Q:LR("Q") K LRAP G LST
F LRAN=0:0 S LRAN=$O(^LRO(69.2,LRAA,3,LRAN)) Q:'LRAN!(LR("Q")) D
.S LRDFN=+^(LRAN,0) D EN
LST K:'$D(LRSAV) ^LRO(69.2,LRAA,3) K LRAURPT
S:'$D(^LRO(69.2,LRAA,3,0)) ^(0)="^69.29A^0^0"
I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
K LRSAV D K^LRU
W:IOST?1"P-".E @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
K %,DIR,DTOUT,DUOUT,DIRUT,X,Y
Q
W W !,LR("%") Q
E K ^UTILITY($J) S DIWR=IOM-5,DIWL=5,DIWF=LRS Q
;
EN S LRQ=0,X=^LR(LRDFN,0) Q:'$O(^LR(LRDFN,84,0)) D ^LRUP
I '$D(^LR(LRDFN,"AU")) L +^LRO(69.2,LRAA,3,LRAN):5 Q:'$T D Q
.S DIK="^LRO(69.2,LRAA,3,",DA=LRAN,DA(1)=0
.D ^DIK K KA,DIK
.L -^LRO(69.2,LRAA,3,LRAN)
S X=^LR(LRDFN,"AU"),LRAC=$P(X,"^",6),LRM(2)=$P(X,"^",7)
S LRM(1)=$P(X,"^",12),LRW(9)=$P(X,"^",13),LRM(3)=$P(X,"^",10)
S Y=$P(X,"^"),LRH(2)=$E(Y,2,3) D D^LRU S LRH(1)=Y
S LRLLOC=$P(X,"^",5),AGE=$P(X,"^",9)
;Define the service
S Y=$P(X,"^",8),C=$P(^DD(63,14.5,0),U,3)
D Y^DIQ S LRSVC=Y
;Define autopsy type
S Y=$P(X,"^",11),C=$P(^DD(63,13.7,0),U,3)
D Y^DIQ S LRS(3)=Y
S DA=LRDFN D D^LRAUAW S Y=LR(63,12) D D^LRU S LRH=Y,X=LRM(1)
D:X D^LRUA S LRM(1)=X,X=LRM(2) D:X D^LRUA S LRM(2)=X,X=LRM(3)
D:X D^LRUA S LRM(3)=X
D H Q:LR("Q") S LR("F")=1
W:LRH(1)="" !?20,"+*+* REPORT INCOMPLETE *+*+"
S LRA=0 F S LRA=$O(^LR(LRDFN,84,LRA)) Q:'LRA!(LR("Q")) D
.S LRB=^LR(LRDFN,84,LRA,0)
.D:$Y>(IOSL-13) FT,H Q:LR("Q")
.W !!,"SUPPLEMENTARY REPORT DATE: "
.S Y=LRB D D^LRU W Y
.D:$Y>(IOSL-13) FT,H Q:LR("Q")
.D:$P($G(^LR(LRDFN,84,LRA,2,0)),U,4) SUPA
.D WRT
Q:LR("Q") D FT Q
WRT D E S LRC=0
F LRZ=0:1 S LRC=$O(^LR(LRDFN,84,LRA,1,LRC)) Q:'LRC!(LR("Q")) D
.D:$Y>(IOSL-13) FT,H S LR("F")=1 Q:LR("Q")
.S X=^LR(LRDFN,84,LRA,1,LRC,0) D:X["|TOP|" TOP D ^DIWP
Q:LR("Q") D:LRZ ^DIWW
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,84,LRA,2,A)) Q:'A!(LR("Q")) D
.S B=A
Q:LR("Q")
Q:'$D(^LR(LRDFN,84,LRA,2,B,0))
S A=^(0),Y=+A,LRSGN=" typed by ",A2=$P(A,"^",2)
I $P(A,"^",3) D
.S LRSGN=" signed by ",A2=$P(A,"^",3),Y=$P(A,"^",4)
S A2=$S($D(^VA(200,A2,0)):$P(^(0),"^"),1:A2)
;If supp rpt is released, display 'signed by' instead of 'typed by'
D D^LRU W Y,LRSGN,A2,")"
;If RELEASE SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED"
I $P(^LR(LRDFN,84,LRA,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,84,LRA,2,A)) Q:'A!(LR("Q")) D
.S LRT=^LR(LRDFN,84,LRA,2,A,0)
.D:$Y>(IOSL-13) FT,H 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,84,LRA,2,A,1,B)) Q:'B!(LR("Q")) D
..S LRT=^LR(LRDFN,84,LRA,2,A,1,B,0)
..D:$Y>(IOSL-13) FT,H 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
H ;Header
I $D(LR("F")),IOST?1"C".E D CONT Q:LR("Q")
W:($D(LR("F"))) @IOF
S LRQ=LRQ+1
;W:IOST?1"C".E!(IOST'?1"C".E&('$D(LRFLG))) @IOF,!
;K LRFLG
W ! D W
W !?5,"CLINICAL RECORD |",?40,"AUTOPSY SUPPLEMENTARY REPORT"
W ?73,"Pg ",LRQ,!,LR("%")
W !,"Date died: ",LRH,?40,"| Autopsy date: ",LRH(1)
W !,"Resident: ",LRM(2),?40,"| ",LRS(3)
W ?56,"Autopsy No. ",$S(LRQ(8)]"":LRQ(8)_LRH(2)_" "_LRAC,1:LRAC)
W !,LR("%")
Q
FT ;Footer
Q:LR("Q")
I IOSL'>66 F Q:$Y>(IOSL-13) W !
D W W !!,"Pathologist: ",LRM(3),?52,LRW(9),?55,"| Date ",$E(LRH(3),1,12)
D W W !,LRQ(1),?(IOM-30),"AUTOPSY SUPPLEMENTARY REPORT"
; W !,$E(LRP,1,30),?31,SSN,?49,"SEX:",SEX,?55,"DOB:",DOB,!,LRLLOC
W !,$E(LRP,1,30),?31,HRCN,?49,"SEX:",SEX,?55,"DOB:",DOB,!,LRLLOC ; IHS/OIT/MKK - LR*5.2*1030
W ?31,LRM(1),?55,"AGE AT DEATH: ",AGE
Q
SGL ;Entry point for printing single report
S X="" D ^LRUPS G:LRAN="?" SGL Q:LRAN=-1
I $D(LR("AU1")),'$P(^LR(LRDFN,"AU"),U,15) D Q
.W $C(7),!!,"Report not verified."
D SPC Q:X=""!(X[U)
S LRAP=LRDFN,LRSAV=1
D EN2^LRUA
G DEV
CONT ;
K DIR S DIR(0)="E"
D ^DIR W !
S:$D(DTOUT)!(X[U) LR("Q")=1
Q
END ;
W $C(7),!!,"OK to delete the AUTOPSY SUPPLEMENTARY REPORT list "
S %=2 D YN^LRU
I %=1 K ^LRO(69.2,LRAA,3) S ^LRO(69.2,LRAA,3,0)="^69.29A^0^0" D Q
.W $C(7),!,"LIST DELETED !",!
W !!,"OK, LET'S FORGET IT.",!
Q
TOP S Z=$P(X,"|TOP|",1)_$P(X,"|TOP|",2)
D FT,H S X=Z,LR("F")=1
Q
LRAPAUSR ;AVAMC/REG/WTY - AUTOPSY SUPPLEMENTARY REPORT;9/14/01
+1 ;;5.2;LAB SERVICE;**1030**;NOV 01, 1997
+2 ;;5.2;LAB SERVICE;**1,173,248,259,317**;Sep 27, 1994
+3 ;
+4 ;Reference to ^DD(63 supported by IA #10155
+5 ;
+6 SET X="T"
SET %DT=""
DO ^%DT
DO D^LRU
SET LRH(3)=Y
SET LRFLG=1
+7 WRITE !!,LRO(68)," Autopsy Supplementary Reports"
DO XR^LRU
+8 SET LRS(1)=$PIECE(^LRO(69.2,LRAA,0),U,3)
SET LRS(2)=$PIECE(^(0),U,4)
+9 DO EN2^LRUA
+10 IF LRAPX=2
GOTO END
IF LRAPX=3
GOTO SGL
IF LRAPX=4
GOTO CH
+11 SET XTMP="Someone else is building a print queue for this Accession Area"
+12 LOCK +^LRO(69.2,LRAA,3):5
IF '$TEST
DO EN^DDIOL(XTMP,"","$C(7),!!")
KILL XTMP
QUIT
GETP ;Add a patient to the report queue
+1 WRITE !
SET X=""
DO ^LRUPS
IF LRAN["?"
GOTO GETP
IF LRAN=-1
LOCK -^LRO(69.2,LRAA,3)
QUIT
+2 SET FDAIEN(2)=LRAN
+3 SET FDA(1,69.29,"+2,"_+LRAA_",",.01)=LRDFN
+4 DO UPDATE^DIE("","FDA(1)","FDAIEN")
KILL FDAIEN
GOTO GETP
CH IF '$ORDER(^LRO(69.2,LRAA,3,0))
Begin DoDot:1
+1 WRITE $CHAR(7),!!,"No AUTOPSY SUPPLEMENTARY REPORTS currently on the "
+2 WRITE "print queue.",!!
End DoDot:1
QUIT
SPC READ !,"(D)ouble or (S)ingle spacing of report(s): ",X:DTIME
+1 IF X=""!(X[U)
QUIT
+2 IF $EXTRACT(X)'="D"&($EXTRACT(X)'="S")
Begin DoDot:1
+3 WRITE $CHAR(7),!,"Enter 'S' for single or 'D' for double spacing of reports"
End DoDot:1
GOTO SPC
+4 SET LRS=$SELECT(X="D":"D",1:"")_"W"
IF LRAPX=3
QUIT
+5 WRITE !!,"Save supplementary report list for reprinting "
+6 SET %=2
DO YN^LRU
IF %=1
SET LRSAV=1
DEV ;
+1 WRITE !
+2 SET %ZIS="Q"
DO ^%ZIS
+3 IF POP
WRITE !
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTDESC="ANAT PATH FINAL REPORT"
+6 SET ZTSAVE("LR*")=""
SET ZTRTN="QUE^LRAPAUSR"
+7 DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !,"Request Queued, #",ZTSK
WRITE !
+8 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
QUIT
QUE USE IO
DO L^LRU
DO S^LRU
DO EN^LRUA
+1 ;LRSF515=1 indicates that an SF515 is being generated.
+2 IF '$DATA(LRSF515)
SET LRSF515=0
+3 SET (LRS(5),LRAURPT)=1
+4 IF $DATA(LRAP)
SET LRDFN=LRAP
DO EN
IF LR("Q")
QUIT
KILL LRAP
GOTO LST
+5 FOR LRAN=0:0
SET LRAN=$ORDER(^LRO(69.2,LRAA,3,LRAN))
IF 'LRAN!(LR("Q"))
QUIT
Begin DoDot:1
+6 SET LRDFN=+^(LRAN,0)
DO EN
End DoDot:1
LST IF '$DATA(LRSAV)
KILL ^LRO(69.2,LRAA,3)
KILL LRAURPT
+1 IF '$DATA(^LRO(69.2,LRAA,3,0))
SET ^(0)="^69.29A^0^0"
+2 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C".E
DO CONT
+3 KILL LRSAV
DO K^LRU
+4 IF IOST?1"P-".E
WRITE @IOF
DO ^%ZISC
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 KILL %,DIR,DTOUT,DUOUT,DIRUT,X,Y
+6 QUIT
W WRITE !,LR("%")
QUIT
E KILL ^UTILITY($JOB)
SET DIWR=IOM-5
SET DIWL=5
SET DIWF=LRS
QUIT
+1 ;
EN SET LRQ=0
SET X=^LR(LRDFN,0)
IF '$ORDER(^LR(LRDFN,84,0))
QUIT
DO ^LRUP
+1 IF '$DATA(^LR(LRDFN,"AU"))
LOCK +^LRO(69.2,LRAA,3,LRAN):5
IF '$TEST
QUIT
Begin DoDot:1
+2 SET DIK="^LRO(69.2,LRAA,3,"
SET DA=LRAN
SET DA(1)=0
+3 DO ^DIK
KILL KA,DIK
+4 LOCK -^LRO(69.2,LRAA,3,LRAN)
End DoDot:1
QUIT
+5 SET X=^LR(LRDFN,"AU")
SET LRAC=$PIECE(X,"^",6)
SET LRM(2)=$PIECE(X,"^",7)
+6 SET LRM(1)=$PIECE(X,"^",12)
SET LRW(9)=$PIECE(X,"^",13)
SET LRM(3)=$PIECE(X,"^",10)
+7 SET Y=$PIECE(X,"^")
SET LRH(2)=$EXTRACT(Y,2,3)
DO D^LRU
SET LRH(1)=Y
+8 SET LRLLOC=$PIECE(X,"^",5)
SET AGE=$PIECE(X,"^",9)
+9 ;Define the service
+10 SET Y=$PIECE(X,"^",8)
SET C=$PIECE(^DD(63,14.5,0),U,3)
+11 DO Y^DIQ
SET LRSVC=Y
+12 ;Define autopsy type
+13 SET Y=$PIECE(X,"^",11)
SET C=$PIECE(^DD(63,13.7,0),U,3)
+14 DO Y^DIQ
SET LRS(3)=Y
+15 SET DA=LRDFN
DO D^LRAUAW
SET Y=LR(63,12)
DO D^LRU
SET LRH=Y
SET X=LRM(1)
+16 IF X
DO D^LRUA
SET LRM(1)=X
SET X=LRM(2)
IF X
DO D^LRUA
SET LRM(2)=X
SET X=LRM(3)
+17 IF X
DO D^LRUA
SET LRM(3)=X
+18 DO H
IF LR("Q")
QUIT
SET LR("F")=1
+19 IF LRH(1)=""
WRITE !?20,"+*+* REPORT INCOMPLETE *+*+"
+20 SET LRA=0
FOR
SET LRA=$ORDER(^LR(LRDFN,84,LRA))
IF 'LRA!(LR("Q"))
QUIT
Begin DoDot:1
+21 SET LRB=^LR(LRDFN,84,LRA,0)
+22 IF $Y>(IOSL-13)
DO FT
DO H
IF LR("Q")
QUIT
+23 WRITE !!,"SUPPLEMENTARY REPORT DATE: "
+24 SET Y=LRB
DO D^LRU
WRITE Y
+25 IF $Y>(IOSL-13)
DO FT
DO H
IF LR("Q")
QUIT
+26 IF $PIECE($GET(^LR(LRDFN,84,LRA,2,0)),U,4)
DO SUPA
+27 DO WRT
End DoDot:1
+28 IF LR("Q")
QUIT
DO FT
QUIT
WRT DO E
SET LRC=0
+1 FOR LRZ=0:1
SET LRC=$ORDER(^LR(LRDFN,84,LRA,1,LRC))
IF 'LRC!(LR("Q"))
QUIT
Begin DoDot:1
+2 IF $Y>(IOSL-13)
DO FT
DO H
SET LR("F")=1
IF LR("Q")
QUIT
+3 SET X=^LR(LRDFN,84,LRA,1,LRC,0)
IF X["|TOP|"
DO TOP
DO ^DIWP
End DoDot:1
+4 IF LR("Q")
QUIT
IF LRZ
DO ^DIWW
+5 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,84,LRA,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,84,LRA,2,B,0))
QUIT
+7 SET A=^(0)
SET Y=+A
SET LRSGN=" typed by "
SET A2=$PIECE(A,"^",2)
+8 IF $PIECE(A,"^",3)
Begin DoDot:1
+9 SET LRSGN=" signed by "
SET A2=$PIECE(A,"^",3)
SET Y=$PIECE(A,"^",4)
End DoDot:1
+10 SET A2=$SELECT($DATA(^VA(200,A2,0)):$PIECE(^(0),"^"),1:A2)
+11 ;If supp rpt is released, display 'signed by' instead of 'typed by'
+12 DO D^LRU
WRITE Y,LRSGN,A2,")"
+13 ;If RELEASE SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED"
+14 IF $PIECE(^LR(LRDFN,84,LRA,0),"^",3)
WRITE !,?25,"**-* NOT VERIFIED *-**"
+15 IF $DATA(LRQ(9))
DO SUPM
+16 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,84,LRA,2,A))
IF 'A!(LR("Q"))
QUIT
Begin DoDot:1
+4 SET LRT=^LR(LRDFN,84,LRA,2,A,0)
+5 IF $Y>(IOSL-13)
DO FT
DO H
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)
SET DIWR=IOM-5
SET DIWL=5
SET DIWF="W"
+12 SET B=0
+13 FOR LRZ=0:1
SET B=$ORDER(^LR(LRDFN,84,LRA,2,A,1,B))
IF 'B!(LR("Q"))
QUIT
Begin DoDot:2
+14 SET LRT=^LR(LRDFN,84,LRA,2,A,1,B,0)
+15 IF $Y>(IOSL-13)
DO FT
DO H
IF LR("Q")
QUIT
+16 SET X=LRT
DO ^DIWP
End DoDot:2
+17 IF LR("Q")
QUIT
IF LRZ
DO ^DIWW
End DoDot:1
+18 IF LR("Q")
QUIT
+19 WRITE !?13,"==========Text below appears on final report=========="
+20 QUIT
H ;Header
+1 IF $DATA(LR("F"))
IF IOST?1"C".E
DO CONT
IF LR("Q")
QUIT
+2 IF ($DATA(LR("F")))
WRITE @IOF
+3 SET LRQ=LRQ+1
+4 ;W:IOST?1"C".E!(IOST'?1"C".E&('$D(LRFLG))) @IOF,!
+5 ;K LRFLG
+6 WRITE !
DO W
+7 WRITE !?5,"CLINICAL RECORD |",?40,"AUTOPSY SUPPLEMENTARY REPORT"
+8 WRITE ?73,"Pg ",LRQ,!,LR("%")
+9 WRITE !,"Date died: ",LRH,?40,"| Autopsy date: ",LRH(1)
+10 WRITE !,"Resident: ",LRM(2),?40,"| ",LRS(3)
+11 WRITE ?56,"Autopsy No. ",$SELECT(LRQ(8)]"":LRQ(8)_LRH(2)_" "_LRAC,1:LRAC)
+12 WRITE !,LR("%")
+13 QUIT
FT ;Footer
+1 IF LR("Q")
QUIT
+2 IF IOSL'>66
FOR
IF $Y>(IOSL-13)
QUIT
WRITE !
+3 DO W
WRITE !!,"Pathologist: ",LRM(3),?52,LRW(9),?55,"| Date ",$EXTRACT(LRH(3),1,12)
+4 DO W
WRITE !,LRQ(1),?(IOM-30),"AUTOPSY SUPPLEMENTARY REPORT"
+5 ; W !,$E(LRP,1,30),?31,SSN,?49,"SEX:",SEX,?55,"DOB:",DOB,!,LRLLOC
+6 ; IHS/OIT/MKK - LR*5.2*1030
WRITE !,$EXTRACT(LRP,1,30),?31,HRCN,?49,"SEX:",SEX,?55,"DOB:",DOB,!,LRLLOC
+7 WRITE ?31,LRM(1),?55,"AGE AT DEATH: ",AGE
+8 QUIT
SGL ;Entry point for printing single report
+1 SET X=""
DO ^LRUPS
IF LRAN="?"
GOTO SGL
IF LRAN=-1
QUIT
+2 IF $DATA(LR("AU1"))
IF '$PIECE(^LR(LRDFN,"AU"),U,15)
Begin DoDot:1
+3 WRITE $CHAR(7),!!,"Report not verified."
End DoDot:1
QUIT
+4 DO SPC
IF X=""!(X[U)
QUIT
+5 SET LRAP=LRDFN
SET LRSAV=1
+6 DO EN2^LRUA
+7 GOTO DEV
CONT ;
+1 KILL DIR
SET DIR(0)="E"
+2 DO ^DIR
WRITE !
+3 IF $DATA(DTOUT)!(X[U)
SET LR("Q")=1
+4 QUIT
END ;
+1 WRITE $CHAR(7),!!,"OK to delete the AUTOPSY SUPPLEMENTARY REPORT list "
+2 SET %=2
DO YN^LRU
+3 IF %=1
KILL ^LRO(69.2,LRAA,3)
SET ^LRO(69.2,LRAA,3,0)="^69.29A^0^0"
Begin DoDot:1
+4 WRITE $CHAR(7),!,"LIST DELETED !",!
End DoDot:1
QUIT
+5 WRITE !!,"OK, LET'S FORGET IT.",!
+6 QUIT
TOP SET Z=$PIECE(X,"|TOP|",1)_$PIECE(X,"|TOP|",2)
+1 DO FT
DO H
SET X=Z
SET LR("F")=1
+2 QUIT
