LRAPT2 ;AVAMC/REG/WTY - AUTOPSY PRT ;08/23/01
;;5.2;LAB SERVICE;**1,248,259**;Sep 27, 1994
;
N LRSPSM S LRSPSM=0
S:'$D(LRSF515) LRSF515=0
D:'LRSF515 FF
I LRSF515 D:$Y>(IOSL-12) FTR
S LR("F")=1 Q:LR("Q")
I '$D(LRD("V")),'$P(^LR(LRDFN,"AU"),U,15) D Q
.W !!,"Report not verified."
S O(2)=^LR(LRDFN,"AU"),X=$P(O(2),"^",8)_":"
S LRLLOC=$P($P(LRAU("L"),X,2),";"),X=$P(O(2),"^",11)_":"
S LRAU(3)=$P($P(LRAU("T"),X,2),";")
W !,"Acc #: ",$P(O(2),"^",6),?32,"AUTOPSY DATA"
W ?52,"Age: ",$J($P(O(2),"^",9),3)
I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
W !,"Date/time Died",?52,"Date/time of Autopsy"
I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
S DA=LRDFN D D^LRAUAW S Y=LR(63,12) D D^LRU
W !,Y,?32,$E(LRAU(3),1,18)
S Y=+O(2) D D^LRU W:Y'[1700 ?52,Y
I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
W ! S TAB=0 F X(1)=7,10 D
.S Y=$P(O(2),"^",X(1)) Q:Y=""
.S:$D(^VA(200,Y,0)) Y=$P(^(0),"^")
.S:X(1)=10 Y=$E(Y,1,19),TAB=52
.W ?TAB,$S(X(1)=7:"Resident: ",1:"Senior: "),Y
K TAB
I '$D(LRD("V")),$D(LR("AU1")),'$P(^LR(LRDFN,"AU"),U,15) D Q
.W !!,"Report not verified."
W ! D EN
Q:LR("Q")
D ^LRAPT3
S:+$G(LR("SPSM")) LRSPSM=1 ;Set flag to suppress SNOMED codes
S A=0 F F=0:1 S A=$O(^LR(LRDFN,"AY",A)) Q:'A!(LR("Q")) D
.I 'F,'LRSPSM D HD
.S (T(3),T)=+^(A,0),T=^LAB(61,T,0),T(8)=$P(T,"^",2)
.I 'LRSF515,($Y>(IOSL-6)) D FF D:'LRSPSM HD
.Q:LR("Q")
.I LRSF515,($Y>(IOSL-12)) D
..D FTR Q:LR("Q")
..D:'LRSPSM HD
.Q:LR("Q")
.I 'LRSPSM D
..W !,"T-",T(8),": "
..S X=$P(T,"^") D:$G(LRS(5)) C^LRUA W X
.S T(4)=61
.D EN^LRSPRPT1,M
Q:LR("Q")!($D(LR("W")))
W !
I '$D(LRAURPT),$D(^LR(LRDFN,81)) W !,LRAU(1) S LRE=81 D Q:LR("Q")
.D F
.I 'LRSF515,($Y>(IOSL-6)) D FF
.Q:LR("Q")
.I LRSF515,($Y>(IOSL-12)) D FTR
I '$D(LRAURPT),$D(^LR(LRDFN,82)) W !,LRAU(2) S LRE=82 D Q:LR("Q")
.D F
.I 'LRSF515,($Y>(IOSL-6)) D FF
.Q:LR("Q")
.I LRSF515,($Y>(IOSL-12)) D FTR
Q
F ;
D EE
S A=0 F LRZ=0:1 S A=$O(^LR(LRDFN,LRE,A)) Q:'A!(LR("Q")) D
.S X=^LR(LRDFN,LRE,A,0) D ^DIWP
Q:LR("Q") D:LRZ ^DIWW Q
EE ;
K ^UTILITY($J) S DIWR=IOM-5,DIWL=5,DIWF="W"
Q
M ;
S B=0 F S B=$O(^LR(LRDFN,"AY",A,2,B)) Q:'B!(LR("Q")) D
.S (T(3),M)=+^LR(LRDFN,"AY",A,2,B,0),M=^LAB(61.1,M,0)
.I 'LRSF515,($Y>(IOSL-6)) D FF D:'LRSPSM HD Q:LR("Q")
.I LRSF515,($Y>(IOSL-12)) D Q:LR("Q")
..D FTR Q:LR("Q")
..D:'LRSPSM HD
.Q:LR("Q")
.I 'LRSPSM D
..W !?5,"M-",$P(M,"^",2),": "
..S X=$P(M,"^") D:$G(LRS(5)) C^LRUA W X
.S T(4)=61.1
.D EN^LRSPRPT1,E
F B=1.4,3.3,4.5 D Q:LR("Q")
.S C=0 F S C=$O(^LR(LRDFN,"AY",A,$P(B,"."),C)) Q:'C!(LR("Q")) D
..S (T(3),M)=+^LR(LRDFN,"AY",A,$P(B,"."),C,0)
..D A
Q
A S (E,T(4))="61."_$P(B,".",2)
S M=^LAB(E,M,0)
I 'LRSF515,($Y>(IOSL-6)) D FF D:'LRSPSM HD Q:LR("Q")
I LRSF515,($Y>(IOSL-12)) D Q:LR("Q")
.D FTR Q:LR("Q")
.D:'LRSPSM HD
Q:LR("Q")
I 'LRSPSM D
.W !?5,$S(B=1.4:"D-",B=3.3:"F-",B=4.5:"P-",1:""),$P(M,"^",2),?12,": "
.S X=$P(M,"^") D:$G(LRS(5)) C^LRUA W X
D EN^LRSPRPT1
Q
E ;
S C=0 F S C=$O(^LR(LRDFN,"AY",A,2,B,1,C)) Q:'C!(LR("Q")) D
.S (T(3),E)=+^LR(LRDFN,"AY",A,2,B,1,C,0),E=^LAB(61.2,E,0)
.I $Y>(IOSL-6) D FF D:'LRSPSM HD Q:LR("Q")
.I 'LRSF515,($Y>(IOSL-6)) D FF D:'LRSPSM HD Q:LR("Q")
.I LRSF515,($Y>(IOSL-12)) D Q:LR("Q")
..D FTR Q:LR("Q")
..D:'LRSPSM HD
.Q:LR("Q")
.S T(4)=61.2
.I 'LRSPSM D
..W !?10,"E-",$P(E,"^",2),": "
..S X=$P(E,"^") D:$G(LRS(5)) C^LRUA W X
D EN^LRSPRPT1
Q
HD ;
Q:LR("Q")
W !!,"SNOMED code(s):"
Q
EN ;from LRAPPF1
K B
I $D(^LR(LRDFN,"AW")) D
.S X=^LR(LRDFN,"AW"),B(9)=$P(X,"^",9),B(1)=$P(X,"^",11,99)
.W !,"Rt--Lung--Lt Liver Spleen Rt--Kidney--Lt Brain Body "
.W "Wt(lb) Ht(in)"
I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
I $D(B) D
.W !,$J($P(X,"^",3),4),?8,$J($P(X,"^",4),4),?14,$J($P(X,"^",5),5)
.W ?21,$J($P(X,"^",6),5),?28,$J($P(X,"^",7),4),?38,$J($P(X,"^",8),4)
.W ?45,$J($P(X,"^",10),4),?55,$P(X,"^",2),?68,$P(X,"^")
I LRSF515 D:$Y>(IOSL-12) FTR
Q:LR("Q")
W !! W:$D(B) "Heart(gm)"
I LRSF515 D:$Y>(IOSL-12) FTR
Q:LR("Q")
I $D(^LR(LRDFN,"AV")) D
.S X=^LR(LRDFN,"AV"),B(2)=$P(X,"^",7,99)
.W ?12,"TV(cm) PV(cm) MV(cm) AV(cm) RV(cm) LV(cm)"
W ! W:$D(B(9)) $J(B(9),5)
I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
I $D(B(2)) D Q:LR("Q")
.W ?12,$J($P(X,"^"),4),?20,$J($P(X,"^",2),4),?28,$J($P(X,"^",3),4)
.W ?36,$J($P(X,"^",4),4),?44,$J($P(X,"^",5),4),?52,$J($P(X,"^",6),4)
.I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
.W !!,"Cavities(ml): Rt--Pleural--Lt Pericardial Peritoneal"
.I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
.W !?14,$J($P(B(2),"^",2),4),?25,$J($P(B(2),"^"),4)
.W ?33,$J($P(B(2),"^",3),4),?45,$J($P(B(2),"^",4),4)
I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
S DIC="^DD(63,",DIC(0)="Z"
I $D(B(1)) F B=1:1:8 Q:LR("Q") D
.I $P(B(1),"^",B) S X="25."_B D
..D ^DIC Q:Y='1
..W !,Y(0,0)_": ",$P(B(1),"^",B)
..I LRSF515 D:$Y>(IOSL-12) FTR
Q:LR("Q")
I $D(^LR(LRDFN,"AWI")) D
.S Z=^LR(LRDFN,"AWI") F B=1:1:5 Q:LR("Q") D
..I $P(Z,"^",B) S X=$S(B=1:25.9,1:25.9_(B-1)) D
...D ^DIC Q:Y=-1
...W !,Y(0,0),": ",$P(Z,"^",B)
...I LRSF515 D:$Y>(IOSL-12) FTR
K DIC,X,Y,Z
Q
FTR ;
D:LRSS="AU" FT^LRAURPT,H^LRAURPT
D:LRSS'="AU" F^LRAPF,^LRAPF
Q
FF ;
D H1^LRAPT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPT2 5250 printed Apr 09, 2024@21:07:19 Page 2
LRAPT2 ;AVAMC/REG/WTY - AUTOPSY PRT ;08/23/01
+1 ;;5.2;LAB SERVICE;**1,248,259**;Sep 27, 1994
+2 ;
+3 NEW LRSPSM
SET LRSPSM=0
+4 if '$DATA(LRSF515)
SET LRSF515=0
+5 if 'LRSF515
DO FF
+6 IF LRSF515
if $Y>(IOSL-12)
DO FTR
+7 SET LR("F")=1
if LR("Q")
QUIT
+8 IF '$DATA(LRD("V"))
IF '$PIECE(^LR(LRDFN,"AU"),U,15)
Begin DoDot:1
+9 WRITE !!,"Report not verified."
End DoDot:1
QUIT
+10 SET O(2)=^LR(LRDFN,"AU")
SET X=$PIECE(O(2),"^",8)_":"
+11 SET LRLLOC=$PIECE($PIECE(LRAU("L"),X,2),";")
SET X=$PIECE(O(2),"^",11)_":"
+12 SET LRAU(3)=$PIECE($PIECE(LRAU("T"),X,2),";")
+13 WRITE !,"Acc #: ",$PIECE(O(2),"^",6),?32,"AUTOPSY DATA"
+14 WRITE ?52,"Age: ",$JUSTIFY($PIECE(O(2),"^",9),3)
+15 IF LRSF515
if $Y>(IOSL-12)
DO FTR
if LR("Q")
QUIT
+16 WRITE !,"Date/time Died",?52,"Date/time of Autopsy"
+17 IF LRSF515
if $Y>(IOSL-12)
DO FTR
if LR("Q")
QUIT
+18 SET DA=LRDFN
DO D^LRAUAW
SET Y=LR(63,12)
DO D^LRU
+19 WRITE !,Y,?32,$EXTRACT(LRAU(3),1,18)
+20 SET Y=+O(2)
DO D^LRU
if Y'[1700
WRITE ?52,Y
+21 IF LRSF515
if $Y>(IOSL-12)
DO FTR
if LR("Q")
QUIT
+22 WRITE !
SET TAB=0
FOR X(1)=7,10
Begin DoDot:1
+23 SET Y=$PIECE(O(2),"^",X(1))
if Y=""
QUIT
+24 if $DATA(^VA(200,Y,0))
SET Y=$PIECE(^(0),"^")
+25 if X(1)=10
SET Y=$EXTRACT(Y,1,19)
SET TAB=52
+26 WRITE ?TAB,$SELECT(X(1)=7:"Resident: ",1:"Senior: "),Y
End DoDot:1
+27 KILL TAB
+28 IF '$DATA(LRD("V"))
IF $DATA(LR("AU1"))
IF '$PIECE(^LR(LRDFN,"AU"),U,15)
Begin DoDot:1
+29 WRITE !!,"Report not verified."
End DoDot:1
QUIT
+30 WRITE !
DO EN
+31 if LR("Q")
QUIT
+32 DO ^LRAPT3
+33 ;Set flag to suppress SNOMED codes
if +$GET(LR("SPSM"))
SET LRSPSM=1
+34 SET A=0
FOR F=0:1
SET A=$ORDER(^LR(LRDFN,"AY",A))
if 'A!(LR("Q"))
QUIT
Begin DoDot:1
+35 IF 'F
IF 'LRSPSM
DO HD
+36 SET (T(3),T)=+^(A,0)
SET T=^LAB(61,T,0)
SET T(8)=$PIECE(T,"^",2)
+37 IF 'LRSF515
IF ($Y>(IOSL-6))
DO FF
if 'LRSPSM
DO HD
+38 if LR("Q")
QUIT
+39 IF LRSF515
IF ($Y>(IOSL-12))
Begin DoDot:2
+40 DO FTR
if LR("Q")
QUIT
+41 if 'LRSPSM
DO HD
End DoDot:2
+42 if LR("Q")
QUIT
+43 IF 'LRSPSM
Begin DoDot:2
+44 WRITE !,"T-",T(8),": "
+45 SET X=$PIECE(T,"^")
if $GET(LRS(5))
DO C^LRUA
WRITE X
End DoDot:2
+46 SET T(4)=61
+47 DO EN^LRSPRPT1
DO M
End DoDot:1
+48 if LR("Q")!($DATA(LR("W")))
QUIT
+49 WRITE !
+50 IF '$DATA(LRAURPT)
IF $DATA(^LR(LRDFN,81))
WRITE !,LRAU(1)
SET LRE=81
Begin DoDot:1
+51 DO F
+52 IF 'LRSF515
IF ($Y>(IOSL-6))
DO FF
+53 if LR("Q")
QUIT
+54 IF LRSF515
IF ($Y>(IOSL-12))
DO FTR
End DoDot:1
if LR("Q")
QUIT
+55 IF '$DATA(LRAURPT)
IF $DATA(^LR(LRDFN,82))
WRITE !,LRAU(2)
SET LRE=82
Begin DoDot:1
+56 DO F
+57 IF 'LRSF515
IF ($Y>(IOSL-6))
DO FF
+58 if LR("Q")
QUIT
+59 IF LRSF515
IF ($Y>(IOSL-12))
DO FTR
End DoDot:1
if LR("Q")
QUIT
+60 QUIT
F ;
+1 DO EE
+2 SET A=0
FOR LRZ=0:1
SET A=$ORDER(^LR(LRDFN,LRE,A))
if 'A!(LR("Q"))
QUIT
Begin DoDot:1
+3 SET X=^LR(LRDFN,LRE,A,0)
DO ^DIWP
End DoDot:1
+4 if LR("Q")
QUIT
if LRZ
DO ^DIWW
QUIT
EE ;
+1 KILL ^UTILITY($JOB)
SET DIWR=IOM-5
SET DIWL=5
SET DIWF="W"
+2 QUIT
M ;
+1 SET B=0
FOR
SET B=$ORDER(^LR(LRDFN,"AY",A,2,B))
if 'B!(LR("Q"))
QUIT
Begin DoDot:1
+2 SET (T(3),M)=+^LR(LRDFN,"AY",A,2,B,0)
SET M=^LAB(61.1,M,0)
+3 IF 'LRSF515
IF ($Y>(IOSL-6))
DO FF
if 'LRSPSM
DO HD
if LR("Q")
QUIT
+4 IF LRSF515
IF ($Y>(IOSL-12))
Begin DoDot:2
+5 DO FTR
if LR("Q")
QUIT
+6 if 'LRSPSM
DO HD
End DoDot:2
if LR("Q")
QUIT
+7 if LR("Q")
QUIT
+8 IF 'LRSPSM
Begin DoDot:2
+9 WRITE !?5,"M-",$PIECE(M,"^",2),": "
+10 SET X=$PIECE(M,"^")
if $GET(LRS(5))
DO C^LRUA
WRITE X
End DoDot:2
+11 SET T(4)=61.1
+12 DO EN^LRSPRPT1
DO E
End DoDot:1
+13 FOR B=1.4,3.3,4.5
Begin DoDot:1
+14 SET C=0
FOR
SET C=$ORDER(^LR(LRDFN,"AY",A,$PIECE(B,"."),C))
if 'C!(LR("Q"))
QUIT
Begin DoDot:2
+15 SET (T(3),M)=+^LR(LRDFN,"AY",A,$PIECE(B,"."),C,0)
+16 DO A
End DoDot:2
End DoDot:1
if LR("Q")
QUIT
+17 QUIT
A SET (E,T(4))="61."_$PIECE(B,".",2)
+1 SET M=^LAB(E,M,0)
+2 IF 'LRSF515
IF ($Y>(IOSL-6))
DO FF
if 'LRSPSM
DO HD
if LR("Q")
QUIT
+3 IF LRSF515
IF ($Y>(IOSL-12))
Begin DoDot:1
+4 DO FTR
if LR("Q")
QUIT
+5 if 'LRSPSM
DO HD
End DoDot:1
if LR("Q")
QUIT
+6 if LR("Q")
QUIT
+7 IF 'LRSPSM
Begin DoDot:1
+8 WRITE !?5,$SELECT(B=1.4:"D-",B=3.3:"F-",B=4.5:"P-",1:""),$PIECE(M,"^",2),?12,": "
+9 SET X=$PIECE(M,"^")
if $GET(LRS(5))
DO C^LRUA
WRITE X
End DoDot:1
+10 DO EN^LRSPRPT1
+11 QUIT
E ;
+1 SET C=0
FOR
SET C=$ORDER(^LR(LRDFN,"AY",A,2,B,1,C))
if 'C!(LR("Q"))
QUIT
Begin DoDot:1
+2 SET (T(3),E)=+^LR(LRDFN,"AY",A,2,B,1,C,0)
SET E=^LAB(61.2,E,0)
+3 IF $Y>(IOSL-6)
DO FF
if 'LRSPSM
DO HD
if LR("Q")
QUIT
+4 IF 'LRSF515
IF ($Y>(IOSL-6))
DO FF
if 'LRSPSM
DO HD
if LR("Q")
QUIT
+5 IF LRSF515
IF ($Y>(IOSL-12))
Begin DoDot:2
+6 DO FTR
if LR("Q")
QUIT
+7 if 'LRSPSM
DO HD
End DoDot:2
if LR("Q")
QUIT
+8 if LR("Q")
QUIT
+9 SET T(4)=61.2
+10 IF 'LRSPSM
Begin DoDot:2
+11 WRITE !?10,"E-",$PIECE(E,"^",2),": "
+12 SET X=$PIECE(E,"^")
if $GET(LRS(5))
DO C^LRUA
WRITE X
End DoDot:2
End DoDot:1
+13 DO EN^LRSPRPT1
+14 QUIT
HD ;
+1 if LR("Q")
QUIT
+2 WRITE !!,"SNOMED code(s):"
+3 QUIT
EN ;from LRAPPF1
+1 KILL B
+2 IF $DATA(^LR(LRDFN,"AW"))
Begin DoDot:1
+3 SET X=^LR(LRDFN,"AW")
SET B(9)=$PIECE(X,"^",9)
SET B(1)=$PIECE(X,"^",11,99)
+4 WRITE !,"Rt--Lung--Lt Liver Spleen Rt--Kidney--Lt Brain Body "
+5 WRITE "Wt(lb) Ht(in)"
End DoDot:1
+6 IF LRSF515
if $Y>(IOSL-12)
DO FTR
if LR("Q")
QUIT
+7 IF $DATA(B)
Begin DoDot:1
+8 WRITE !,$JUSTIFY($PIECE(X,"^",3),4),?8,$JUSTIFY($PIECE(X,"^",4),4),?14,$JUSTIFY($PIECE(X,"^",5),5)
+9 WRITE ?21,$JUSTIFY($PIECE(X,"^",6),5),?28,$JUSTIFY($PIECE(X,"^",7),4),?38,$JUSTIFY($PIECE(X,"^",8),4)
+10 WRITE ?45,$JUSTIFY($PIECE(X,"^",10),4),?55,$PIECE(X,"^",2),?68,$PIECE(X,"^")
End DoDot:1
+11 IF LRSF515
if $Y>(IOSL-12)
DO FTR
+12 if LR("Q")
QUIT
+13 WRITE !!
if $DATA(B)
WRITE "Heart(gm)"
+14 IF LRSF515
if $Y>(IOSL-12)
DO FTR
+15 if LR("Q")
QUIT
+16 IF $DATA(^LR(LRDFN,"AV"))
Begin DoDot:1
+17 SET X=^LR(LRDFN,"AV")
SET B(2)=$PIECE(X,"^",7,99)
+18 WRITE ?12,"TV(cm) PV(cm) MV(cm) AV(cm) RV(cm) LV(cm)"
End DoDot:1
+19 WRITE !
if $DATA(B(9))
WRITE $JUSTIFY(B(9),5)
+20 IF LRSF515
if $Y>(IOSL-12)
DO FTR
if LR("Q")
QUIT
+21 IF $DATA(B(2))
Begin DoDot:1
+22 WRITE ?12,$JUSTIFY($PIECE(X,"^"),4),?20,$JUSTIFY($PIECE(X,"^",2),4),?28,$JUSTIFY($PIECE(X,"^",3),4)
+23 WRITE ?36,$JUSTIFY($PIECE(X,"^",4),4),?44,$JUSTIFY($PIECE(X,"^",5),4),?52,$JUSTIFY($PIECE(X,"^",6),4)
+24 IF LRSF515
if $Y>(IOSL-12)
DO FTR
if LR("Q")
QUIT
+25 WRITE !!,"Cavities(ml): Rt--Pleural--Lt Pericardial Peritoneal"
+26 IF LRSF515
if $Y>(IOSL-12)
DO FTR
if LR("Q")
QUIT
+27 WRITE !?14,$JUSTIFY($PIECE(B(2),"^",2),4),?25,$JUSTIFY($PIECE(B(2),"^"),4)
+28 WRITE ?33,$JUSTIFY($PIECE(B(2),"^",3),4),?45,$JUSTIFY($PIECE(B(2),"^",4),4)
End DoDot:1
if LR("Q")
QUIT
+29 IF LRSF515
if $Y>(IOSL-12)
DO FTR
if LR("Q")
QUIT
+30 SET DIC="^DD(63,"
SET DIC(0)="Z"
+31 IF $DATA(B(1))
FOR B=1:1:8
if LR("Q")
QUIT
Begin DoDot:1
+32 IF $PIECE(B(1),"^",B)
SET X="25."_B
Begin DoDot:2
+33 DO ^DIC
if Y='1
QUIT
+34 WRITE !,Y(0,0)_": ",$PIECE(B(1),"^",B)
+35 IF LRSF515
if $Y>(IOSL-12)
DO FTR
End DoDot:2
End DoDot:1
+36 if LR("Q")
QUIT
+37 IF $DATA(^LR(LRDFN,"AWI"))
Begin DoDot:1
+38 SET Z=^LR(LRDFN,"AWI")
FOR B=1:1:5
if LR("Q")
QUIT
Begin DoDot:2
+39 IF $PIECE(Z,"^",B)
SET X=$SELECT(B=1:25.9,1:25.9_(B-1))
Begin DoDot:3
+40 DO ^DIC
if Y=-1
QUIT
+41 WRITE !,Y(0,0),": ",$PIECE(Z,"^",B)
+42 IF LRSF515
if $Y>(IOSL-12)
DO FTR
End DoDot:3
End DoDot:2
End DoDot:1
+43 KILL DIC,X,Y,Z
+44 QUIT
FTR ;
+1 if LRSS="AU"
DO FT^LRAURPT
DO H^LRAURPT
+2 if LRSS'="AU"
DO F^LRAPF
DO ^LRAPF
+3 QUIT
FF ;
+1 DO H1^LRAPT
+2 QUIT
