LRAURPT ;AVAMC/REG/WTY - AUTOPSY RPT ; 17-Oct-2014 09:22 ; MKK
;;5.2;LAB SERVICE;**1002,1003,1018,1030,1031,1034**;NOV 01, 1997;Build 88
;
; VA LR Patch(s): 1,72,173,248,259
;
;Reference to ^DD(63 supported by IA #10155
;WTY;24-AUG-01;Added ICD to the print coding question
;
N LRPTR,LREL
W !!,LRO(68)," Autopsy Protocols" D XR^LRU,EN2^LRUA S LRD("V")=""
G END:LRAPX=2,SGL:LRAPX=3,CH:LRAPX=4
L +^LRO(69.2,LRAA,2):5
I '$T D EN^DDIOL("Someone else is building a print queue for this Accession Area","","$C(7),!!") 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,2) Q
G:$D(^LRO(69.2,LRAA,2,LRAN,0)) GETP
S FDAIEN(2)=LRAN
S FDA(2,69.23,"+2,"_+LRAA_",",.01)=LRDFN
D UPDATE^DIE("","FDA(2)","FDAIEN") K FDAIEN G GETP
CH ;Check Queue
I '$O(^LRO(69.2,LRAA,2,0)) D Q
.W $C(7),!!,"No AUTOPSY PROTOCOLS currently on the print queue.",!!
;Variable LR("DVD") is used to divide reports displayed in the browser
K LR("DVD")
S $P(LR("DVD"),"|",IOM)=""
SPC ;Spacing
I LRAPX=4 D
.W !!,"The following two questions apply only to reports not stored in "
.W "TIU."
.W !,"If the report is stored in TIU it will be printed in its "
.W "original format.",!
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 "
.W "spacing of reports"
S LRS=$S(X="D":"D",1:"")_"W"
W !!,"Print special studies, journal references, weights, and "
W "measures: "
S %=1 D YN^LRU Q:%<1 S:%=1 LRD=1
Q:LRAPX=3
W !!,"Save protocol list for reprinting "
S %=2 D YN^LRU S:%=1 LRSAV=1
DEV ;Device Handling
S %ZIS="Q" D ^%ZIS
I POP W ! S LR("Q")=1 Q
I $D(IO("Q")) D Q
.S ZTDESC="Print AU Anat Path Reports"
.S ZTSAVE("LR*")="",ZTRTN="QUE^LRAURPT"
.D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !
.K ZTSK,IO("Q") D HOME^%ZIS
.S LR("Q")=1
QUE ;
U IO D L^LRU,S^LRU,EN^LRUA
N LRFFF
S LRQUIT=0,LR("Q")=+$G(LR("Q"))
;LRSF515=1 means an SF515 is being generated.
S:'$D(LRSF515) LRSF515=0
S:'$D(LRFOC) LRFOC=0 ;Final office copy
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)),(LRS(5),LRAURPT)=1
PSGL ;Single Report
I $D(LRAP) D G LST
.S LRDFN=LRAP
.I +$G(LRPTR) D Q
..D:$D(LR("AU1")) EN
..Q:LR("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
..S LRI="" D FOC^LRSPRPT
..I LRQUIT S LR("Q")=1 Q
..I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT
.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
.S LRI="" D FOC^LRSPRPT
.I LRQUIT S LR("Q")=1 Q
.I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT
PQUE ;Print all on queue
S LRAN=0
F S LRAN=$O(^LRO(69.2,LRAA,2,LRAN)) Q:'LRAN!(LR("Q")) D
.S (LRQUIT,LRQ)=0
.I 'LRFOC S LRFFF=1
.K LR("F")
.S LRDFN=+^LRO(69.2,LRAA,2,LRAN,0)
.D RELEASE^LRAPUTL(.LREL,LRDFN,LRSS)
.I +$G(LREL(1)) D
..D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS)
.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^LRSPRPT
..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")!('LRFOC)
.W !
.D FOC^LRSPRPT
.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:'$D(LRSAV) ^LRO(69.2,LRAA,2) K LRAURPT
S:'$D(^LRO(69.2,LRAA,2,0)) ^(0)="^69.23A^0^0"
K LRSAV D K^LRU
D:'$D(LR("AU1")) DEVEND
Q
W ;
W !,LR("%")
Q
F D E
S A=0 F LRZ=0:1 S A=$O(^LR(LRDFN,LRV,A)) Q:'A!(LR("Q")) D
.D:$Y>(IOSL-12) FT,H Q:LR("Q")
.S X=^LR(LRDFN,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=LRS
Q
EN ;
S LR("SPSM")=1 ;Set this flag to suppress SNOMED codes
S LRQ=0,X=^LR(LRDFN,0) D ^LRUP
I '$D(^LR(LRDFN,"AU")) L +^LRO(69.2,LRAA,2,LRAN):5 Q:'$T D Q
.S DIK="^LRO(69.2,LRAA,2,",DA=LRAN,DA(1)=0
.D ^DIK K DA,DIK
.L -^LRO(69.2,LRAA,2,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,Y=$P(X,"^",3) D D^LRU
S LRH(3)=Y,Y=$P(X,"^",17) D D^LRU S LRH(17)=Y
S LRLLOC=$P(X,"^",5),AGE=$P(X,"^",9)
S Y=$P(X,"^",8),C=$P(^DD(63,14.5,0),U,3)
D Y^DIQ S LRSVC=Y
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
Q:+$G(LRPTR)
D H Q:LR("Q") S LR("F")=1
W:LRH(1)="" !?20,"**** REPORT INCOMPLETE ****",!
W !!,LRAU(1),! S LRV=81 D F
D:$Y>(IOSL-12) FT,H Q:LR("Q") W !!,LR("%")
W !,LRAU(2),! S LRV=82 D F
I $O(^LR(LRDFN,84,0)),LR(.21) D FT,H Q:LR("Q")
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-12) FT,H Q:LR("Q")
.W !!,"SUPPLEMENTARY REPORT DATE: "
.S Y=LRB D D^LRU W Y
.D:$P($G(^LR(LRDFN,84,LRA,2,0)),U,4) SUPA^LRAPAUSR
.D WRT
Q:LR("Q")
D:$G(LRD) ^LRAPT2
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-12) FT,H 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
H ;
Q:LR("Q")
I $D(LR("F")),IOST?1"C".E D CONT Q:LR("Q")
S LRQ=LRQ+1
W:($D(LR("F"))) @IOF
W !! D W
W !?5,"CLINICAL RECORD |",?40,"AUTOPSY PROTOCOL",?73,"Pg ",LRQ
W !,LR("%")
W !,"Date died: ",LRH,?40,"| Autopsy date: ",LRH(1)
W !,"Resident: ",LRM(2),?40,"| ",$E(LRS(3),1,13)
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-12) W !
D W W !
W:LRH(3)=""&(LRH(17)]"") ?55,"| Provisional Anatomic Dx"
W !,"Pathologist: ",LRM(3),?52,LRW(9),?55,"| Date "
W $E($S(LRH(3)]"":LRH(3),1:LRH(17)),1,12)
D W W !,LRQ(1),?IOM-17,"AUTOPSY PROTOCOL"
; W !,"Patient: ",$E(LRP,1,30),?43,SSN,?56,"SEX:",SEX,?63,"DOB:",DOB
W !,"Patient: ",$E(LRP,1,30),?43,HRCN,?56,"SEX:",SEX,?63,"DOB:",DOB ; IHS/MSC/MKK - LR*5.2*1031 - restore LR*5.2*1018 code
W !,$E(LRLLOC,1,22),?23,"Physician: ",$E(LRM(1),1,28)
W ?63,"AGE AT DEATH:",$J(AGE,3)
Q
SGL ;Print single report entry point
K LRD("V") S X="" D ^LRUPS G:LRAN="?" SGL Q:LRAN=-1
D RELEASE^LRAPUTL(.LREL,LRDFN,LRSS)
I $D(LR("AU1")),'+$G(LREL(1)) D Q
.W $C(7),!!,"Report not verified." S LR("AU1")=2
I +$G(LREL(1)) D
.D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS)
I $D(LR("AU1"))!(+$G(LRPTR)) S LRS="W",LRD=1
E D SPC Q:X=""!(X[U)
D EN2^LRUA
S LRAP=LRDFN,LRSAV=1
G DEV
DEVEND ;Close device
I IOST?1"P-".E W:LRFFF @IOF
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
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 PROTOCOL list "
S %=2 D YN^LRU
I %=1 D Q
.K ^LRO(69.2,LRAA,2)
.S ^LRO(69.2,LRAA,2,0)="^69.23A^0^0"
.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
Q
LRAURPT ;AVAMC/REG/WTY - AUTOPSY RPT ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**1002,1003,1018,1030,1031,1034**;NOV 01, 1997;Build 88
+2 ;
+3 ; VA LR Patch(s): 1,72,173,248,259
+4 ;
+5 ;Reference to ^DD(63 supported by IA #10155
+6 ;WTY;24-AUG-01;Added ICD to the print coding question
+7 ;
+8 NEW LRPTR,LREL
+9 WRITE !!,LRO(68)," Autopsy Protocols"
DO XR^LRU
DO EN2^LRUA
SET LRD("V")=""
+10 IF LRAPX=2
GOTO END
IF LRAPX=3
GOTO SGL
IF LRAPX=4
GOTO CH
+11 LOCK +^LRO(69.2,LRAA,2):5
+12 IF '$TEST
DO EN^DDIOL("Someone else is building a print queue for this Accession Area","","$C(7),!!")
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,2)
QUIT
+2 IF $DATA(^LRO(69.2,LRAA,2,LRAN,0))
GOTO GETP
+3 SET FDAIEN(2)=LRAN
+4 SET FDA(2,69.23,"+2,"_+LRAA_",",.01)=LRDFN
+5 DO UPDATE^DIE("","FDA(2)","FDAIEN")
KILL FDAIEN
GOTO GETP
CH ;Check Queue
+1 IF '$ORDER(^LRO(69.2,LRAA,2,0))
Begin DoDot:1
+2 WRITE $CHAR(7),!!,"No AUTOPSY PROTOCOLS currently on the print queue.",!!
End DoDot:1
QUIT
+3 ;Variable LR("DVD") is used to divide reports displayed in the browser
+4 KILL LR("DVD")
+5 SET $PIECE(LR("DVD"),"|",IOM)=""
SPC ;Spacing
+1 IF LRAPX=4
Begin DoDot:1
+2 WRITE !!,"The following two questions apply only to reports not stored in "
+3 WRITE "TIU."
+4 WRITE !,"If the report is stored in TIU it will be printed in its "
+5 WRITE "original format.",!
End DoDot:1
+6 READ !,"(D)ouble or (S)ingle spacing of report(s): ",X:DTIME
+7 IF X=""!(X[U)
QUIT
+8 IF $EXTRACT(X)'="D"&($EXTRACT(X)'="S")
Begin DoDot:1
+9 WRITE $CHAR(7),!,"Enter 'S' for single or 'D' for double "
+10 WRITE "spacing of reports"
End DoDot:1
GOTO SPC
+11 SET LRS=$SELECT(X="D":"D",1:"")_"W"
+12 WRITE !!,"Print special studies, journal references, weights, and "
+13 WRITE "measures: "
+14 SET %=1
DO YN^LRU
IF %<1
QUIT
IF %=1
SET LRD=1
+15 IF LRAPX=3
QUIT
+16 WRITE !!,"Save protocol list for reprinting "
+17 SET %=2
DO YN^LRU
IF %=1
SET LRSAV=1
DEV ;Device Handling
+1 SET %ZIS="Q"
DO ^%ZIS
+2 IF POP
WRITE !
SET LR("Q")=1
QUIT
+3 IF $DATA(IO("Q"))
Begin DoDot:1
+4 SET ZTDESC="Print AU Anat Path Reports"
+5 SET ZTSAVE("LR*")=""
SET ZTRTN="QUE^LRAURPT"
+6 DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !,"Request Queued, #",ZTSK
WRITE !
+7 KILL ZTSK,IO("Q")
DO HOME^%ZIS
+8 SET LR("Q")=1
End DoDot:1
QUIT
QUE ;
+1 USE IO
DO L^LRU
DO S^LRU
DO EN^LRUA
+2 NEW LRFFF
+3 SET LRQUIT=0
SET LR("Q")=+$GET(LR("Q"))
+4 ;LRSF515=1 means an SF515 is being generated.
+5 IF '$DATA(LRSF515)
SET LRSF515=0
+6 ;Final office copy
IF '$DATA(LRFOC)
SET LRFOC=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 (LRS(5),LRAURPT)=1
PSGL ;Single Report
+1 IF $DATA(LRAP)
Begin DoDot:1
+2 SET LRDFN=LRAP
+3 IF +$GET(LRPTR)
Begin DoDot:2
+4 IF $DATA(LR("AU1"))
DO EN
+5 IF LR("Q")
QUIT
+6 DO MAIN^LRAPTIUP(LRPTR,0)
+7 ;Don't do final form feed. It's done by LRAPTIUP.
SET LRFFF=0
+8 IF LRQUIT
SET LR("Q")=1
QUIT
+9 KILL LRAP
SET LR("F")=1
+10 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C-".E
DO CONT
+11 IF LR("Q")
QUIT
+12 IF 'LRFOC
SET LR("Q")=1
QUIT
+13 SET LRI=""
DO FOC^LRSPRPT
+14 IF LRQUIT
SET LR("Q")=1
QUIT
+15 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C-".E
DO CONT
End DoDot:2
QUIT
+16 DO EN
+17 KILL LRAP
+18 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C-".E
DO CONT
+19 IF LR("Q")
QUIT
+20 IF 'LRFOC
SET LR("Q")=1
QUIT
+21 WRITE !
+22 IF IOST?1"P-".E
WRITE @IOF
+23 SET LRI=""
DO FOC^LRSPRPT
+24 IF LRQUIT
SET LR("Q")=1
QUIT
+25 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C-".E
DO CONT
End DoDot:1
GOTO LST
PQUE ;Print all on 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,LRQ)=0
+4 IF 'LRFOC
SET LRFFF=1
+5 KILL LR("F")
+6 SET LRDFN=+^LRO(69.2,LRAA,2,LRAN,0)
+7 DO RELEASE^LRAPUTL(.LREL,LRDFN,LRSS)
+8 IF +$GET(LREL(1))
Begin DoDot:2
+9 DO TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS)
End DoDot:2
+10 IF +$GET(LRPTR)
Begin DoDot:2
+11 DO MAIN^LRAPTIUP(LRPTR,0)
+12 SET LRFFF=0
+13 IF IOST["BROWSER"&('LRFOC)
WRITE !!,LR("DVD")
+14 KILL LRPTR
+15 IF LRQUIT
SET LR("Q")=1
QUIT
+16 SET LR("F")=1
+17 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C-".E
DO CONT
+18 IF LR("Q")!('LRFOC)
QUIT
+19 DO FOC^LRSPRPT
+20 IF IOST["BROWSER"
WRITE !!,LR("DVD")
+21 IF LRQUIT
SET LR("Q")=1
QUIT
+22 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C".E
DO CONT
End DoDot:2
QUIT
+23 IF IOST?1"C-".E
WRITE @IOF
+24 DO EN
+25 IF IOST?1"P-".E
WRITE @IOF
+26 IF IOST["BROWSER"&('LRFOC)
WRITE !!,LR("DVD")
+27 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C-".E
DO CONT
+28 IF LR("Q")!('LRFOC)
QUIT
+29 WRITE !
+30 DO FOC^LRSPRPT
+31 IF IOST["BROWSER"
WRITE !!,LR("DVD")
+32 IF LRQUIT
SET LR("Q")=1
QUIT
+33 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C".E
DO CONT
End DoDot:1
+34 SET LRFFF=0
LST ;
+1 IF '$DATA(LRSAV)
KILL ^LRO(69.2,LRAA,2)
KILL LRAURPT
+2 IF '$DATA(^LRO(69.2,LRAA,2,0))
SET ^(0)="^69.23A^0^0"
+3 KILL LRSAV
DO K^LRU
+4 IF '$DATA(LR("AU1"))
DO DEVEND
+5 QUIT
W ;
+1 WRITE !,LR("%")
+2 QUIT
F DO E
+1 SET A=0
FOR LRZ=0:1
SET A=$ORDER(^LR(LRDFN,LRV,A))
IF 'A!(LR("Q"))
QUIT
Begin DoDot:1
+2 IF $Y>(IOSL-12)
DO FT
DO H
IF LR("Q")
QUIT
+3 SET X=^LR(LRDFN,LRV,A,0)
IF X["|TOP|"
DO TOP
DO ^DIWP
End DoDot:1
+4 IF LR("Q")
QUIT
IF LRZ
DO ^DIWW
QUIT
E KILL ^UTILITY($JOB)
SET DIWR=IOM-5
SET DIWL=5
SET DIWF=LRS
+1 QUIT
EN ;
+1 ;Set this flag to suppress SNOMED codes
SET LR("SPSM")=1
+2 SET LRQ=0
SET X=^LR(LRDFN,0)
DO ^LRUP
+3 IF '$DATA(^LR(LRDFN,"AU"))
LOCK +^LRO(69.2,LRAA,2,LRAN):5
IF '$TEST
QUIT
Begin DoDot:1
+4 SET DIK="^LRO(69.2,LRAA,2,"
SET DA=LRAN
SET DA(1)=0
+5 DO ^DIK
KILL DA,DIK
+6 LOCK -^LRO(69.2,LRAA,2,LRAN)
End DoDot:1
QUIT
+7 SET X=^LR(LRDFN,"AU")
SET LRAC=$PIECE(X,"^",6)
SET LRM(2)=$PIECE(X,"^",7)
+8 SET LRM(1)=$PIECE(X,"^",12)
SET LRW(9)=$PIECE(X,"^",13)
SET LRM(3)=$PIECE(X,"^",10)
+9 SET Y=$PIECE(X,"^")
SET LRH(2)=$EXTRACT(Y,2,3)
DO D^LRU
+10 SET LRH(1)=Y
SET Y=$PIECE(X,"^",3)
DO D^LRU
+11 SET LRH(3)=Y
SET Y=$PIECE(X,"^",17)
DO D^LRU
SET LRH(17)=Y
+12 SET LRLLOC=$PIECE(X,"^",5)
SET AGE=$PIECE(X,"^",9)
+13 SET Y=$PIECE(X,"^",8)
SET C=$PIECE(^DD(63,14.5,0),U,3)
+14 DO Y^DIQ
SET LRSVC=Y
+15 SET Y=$PIECE(X,"^",11)
SET C=$PIECE(^DD(63,13.7,0),U,3)
+16 DO Y^DIQ
SET LRS(3)=Y
+17 SET DA=LRDFN
DO D^LRAUAW
SET Y=LR(63,12)
DO D^LRU
SET LRH=Y
SET X=LRM(1)
+18 IF X
DO D^LRUA
SET LRM(1)=X
SET X=LRM(2)
+19 IF X
DO D^LRUA
SET LRM(2)=X
SET X=LRM(3)
+20 IF X
DO D^LRUA
SET LRM(3)=X
+21 IF +$GET(LRPTR)
QUIT
+22 DO H
IF LR("Q")
QUIT
SET LR("F")=1
+23 IF LRH(1)=""
WRITE !?20,"**** REPORT INCOMPLETE ****",!
+24 WRITE !!,LRAU(1),!
SET LRV=81
DO F
+25 IF $Y>(IOSL-12)
DO FT
DO H
IF LR("Q")
QUIT
WRITE !!,LR("%")
+26 WRITE !,LRAU(2),!
SET LRV=82
DO F
+27 IF $ORDER(^LR(LRDFN,84,0))
IF LR(.21)
DO FT
DO H
IF LR("Q")
QUIT
+28 SET LRA=0
FOR
SET LRA=$ORDER(^LR(LRDFN,84,LRA))
IF 'LRA!(LR("Q"))
QUIT
Begin DoDot:1
+29 SET LRB=^LR(LRDFN,84,LRA,0)
IF $Y>(IOSL-12)
DO FT
DO H
IF LR("Q")
QUIT
+30 WRITE !!,"SUPPLEMENTARY REPORT DATE: "
+31 SET Y=LRB
DO D^LRU
WRITE Y
+32 IF $PIECE($GET(^LR(LRDFN,84,LRA,2,0)),U,4)
DO SUPA^LRAPAUSR
+33 DO WRT
End DoDot:1
+34 IF LR("Q")
QUIT
+35 IF $GET(LRD)
DO ^LRAPT2
+36 IF LR("Q")
QUIT
+37 DO FT
+38 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-12)
DO FT
DO H
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
QUIT
H ;
+1 IF LR("Q")
QUIT
+2 IF $DATA(LR("F"))
IF IOST?1"C".E
DO CONT
IF LR("Q")
QUIT
+3 SET LRQ=LRQ+1
+4 IF ($DATA(LR("F")))
WRITE @IOF
+5 WRITE !!
DO W
+6 WRITE !?5,"CLINICAL RECORD |",?40,"AUTOPSY PROTOCOL",?73,"Pg ",LRQ
+7 WRITE !,LR("%")
+8 WRITE !,"Date died: ",LRH,?40,"| Autopsy date: ",LRH(1)
+9 WRITE !,"Resident: ",LRM(2),?40,"| ",$EXTRACT(LRS(3),1,13)
+10 WRITE ?56,"Autopsy No. ",$SELECT(LRQ(8)]"":LRQ(8)_LRH(2)_" "_LRAC,1:LRAC)
+11 WRITE !,LR("%")
+12 QUIT
FT ;Footer
+1 IF LR("Q")
QUIT
+2 IF IOSL'>66
FOR
IF $Y>(IOSL-12)
QUIT
WRITE !
+3 DO W
WRITE !
+4 IF LRH(3)=""&(LRH(17)]"")
WRITE ?55,"| Provisional Anatomic Dx"
+5 WRITE !,"Pathologist: ",LRM(3),?52,LRW(9),?55,"| Date "
+6 WRITE $EXTRACT($SELECT(LRH(3)]"":LRH(3),1:LRH(17)),1,12)
+7 DO W
WRITE !,LRQ(1),?IOM-17,"AUTOPSY PROTOCOL"
+8 ; W !,"Patient: ",$E(LRP,1,30),?43,SSN,?56,"SEX:",SEX,?63,"DOB:",DOB
+9 ; IHS/MSC/MKK - LR*5.2*1031 - restore LR*5.2*1018 code
WRITE !,"Patient: ",$EXTRACT(LRP,1,30),?43,HRCN,?56,"SEX:",SEX,?63,"DOB:",DOB
+10 WRITE !,$EXTRACT(LRLLOC,1,22),?23,"Physician: ",$EXTRACT(LRM(1),1,28)
+11 WRITE ?63,"AGE AT DEATH:",$JUSTIFY(AGE,3)
+12 QUIT
SGL ;Print single report entry point
+1 KILL LRD("V")
SET X=""
DO ^LRUPS
IF LRAN="?"
GOTO SGL
IF LRAN=-1
QUIT
+2 DO RELEASE^LRAPUTL(.LREL,LRDFN,LRSS)
+3 IF $DATA(LR("AU1"))
IF '+$GET(LREL(1))
Begin DoDot:1
+4 WRITE $CHAR(7),!!,"Report not verified."
SET LR("AU1")=2
End DoDot:1
QUIT
+5 IF +$GET(LREL(1))
Begin DoDot:1
+6 DO TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS)
End DoDot:1
+7 IF $DATA(LR("AU1"))!(+$GET(LRPTR))
SET LRS="W"
SET LRD=1
+8 IF '$TEST
DO SPC
IF X=""!(X[U)
QUIT
+9 DO EN2^LRUA
+10 SET LRAP=LRDFN
SET LRSAV=1
+11 GOTO DEV
DEVEND ;Close device
+1 IF IOST?1"P-".E
IF LRFFF
WRITE @IOF
+2 DO ^%ZISC
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 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
END ;
+1 WRITE $CHAR(7),!!,"OK to delete the AUTOPSY PROTOCOL list "
+2 SET %=2
DO YN^LRU
+3 IF %=1
Begin DoDot:1
+4 KILL ^LRO(69.2,LRAA,2)
+5 SET ^LRO(69.2,LRAA,2,0)="^69.23A^0^0"
+6 WRITE $CHAR(7),!,"LIST DELETED !",!
End DoDot:1
QUIT
+7 WRITE !!,"OK, LET'S FORGET IT.",!
+8 QUIT
TOP ;
+1 SET Z=$PIECE(X,"|TOP|",1)_$PIECE(X,"|TOP|",2)
+2 DO FT
DO H
SET X=Z
+3 QUIT
