source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPT2.m@ 1042

Last change on this file since 1042 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.0 KB
Line 
1LRAPT2 ;AVAMC/REG/WTY - AUTOPSY PRT ;08/23/01
2 ;;5.2;LAB SERVICE;**1,248,259**;Sep 27, 1994
3 ;
4 N LRSPSM S LRSPSM=0
5 S:'$D(LRSF515) LRSF515=0
6 D:'LRSF515 FF
7 I LRSF515 D:$Y>(IOSL-12) FTR
8 S LR("F")=1 Q:LR("Q")
9 I '$D(LRD("V")),'$P(^LR(LRDFN,"AU"),U,15) D Q
10 .W !!,"Report not verified."
11 S O(2)=^LR(LRDFN,"AU"),X=$P(O(2),"^",8)_":"
12 S LRLLOC=$P($P(LRAU("L"),X,2),";"),X=$P(O(2),"^",11)_":"
13 S LRAU(3)=$P($P(LRAU("T"),X,2),";")
14 W !,"Acc #: ",$P(O(2),"^",6),?32,"AUTOPSY DATA"
15 W ?52,"Age: ",$J($P(O(2),"^",9),3)
16 I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
17 W !,"Date/time Died",?52,"Date/time of Autopsy"
18 I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
19 S DA=LRDFN D D^LRAUAW S Y=LR(63,12) D D^LRU
20 W !,Y,?32,$E(LRAU(3),1,18)
21 S Y=+O(2) D D^LRU W:Y'[1700 ?52,Y
22 I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
23 W ! S TAB=0 F X(1)=7,10 D
24 .S Y=$P(O(2),"^",X(1)) Q:Y=""
25 .S:$D(^VA(200,Y,0)) Y=$P(^(0),"^")
26 .S:X(1)=10 Y=$E(Y,1,19),TAB=52
27 .W ?TAB,$S(X(1)=7:"Resident: ",1:"Senior: "),Y
28 K TAB
29 I '$D(LRD("V")),$D(LR("AU1")),'$P(^LR(LRDFN,"AU"),U,15) D Q
30 .W !!,"Report not verified."
31 W ! D EN
32 Q:LR("Q")
33 D ^LRAPT3
34 S:+$G(LR("SPSM")) LRSPSM=1 ;Set flag to suppress SNOMED codes
35 S A=0 F F=0:1 S A=$O(^LR(LRDFN,"AY",A)) Q:'A!(LR("Q")) D
36 .I 'F,'LRSPSM D HD
37 .S (T(3),T)=+^(A,0),T=^LAB(61,T,0),T(8)=$P(T,"^",2)
38 .I 'LRSF515,($Y>(IOSL-6)) D FF D:'LRSPSM HD
39 .Q:LR("Q")
40 .I LRSF515,($Y>(IOSL-12)) D
41 ..D FTR Q:LR("Q")
42 ..D:'LRSPSM HD
43 .Q:LR("Q")
44 .I 'LRSPSM D
45 ..W !,"T-",T(8),": "
46 ..S X=$P(T,"^") D:$G(LRS(5)) C^LRUA W X
47 .S T(4)=61
48 .D EN^LRSPRPT1,M
49 Q:LR("Q")!($D(LR("W")))
50 W !
51 I '$D(LRAURPT),$D(^LR(LRDFN,81)) W !,LRAU(1) S LRE=81 D Q:LR("Q")
52 .D F
53 .I 'LRSF515,($Y>(IOSL-6)) D FF
54 .Q:LR("Q")
55 .I LRSF515,($Y>(IOSL-12)) D FTR
56 I '$D(LRAURPT),$D(^LR(LRDFN,82)) W !,LRAU(2) S LRE=82 D Q:LR("Q")
57 .D F
58 .I 'LRSF515,($Y>(IOSL-6)) D FF
59 .Q:LR("Q")
60 .I LRSF515,($Y>(IOSL-12)) D FTR
61 Q
62F ;
63 D EE
64 S A=0 F LRZ=0:1 S A=$O(^LR(LRDFN,LRE,A)) Q:'A!(LR("Q")) D
65 .S X=^LR(LRDFN,LRE,A,0) D ^DIWP
66 Q:LR("Q") D:LRZ ^DIWW Q
67EE ;
68 K ^UTILITY($J) S DIWR=IOM-5,DIWL=5,DIWF="W"
69 Q
70M ;
71 S B=0 F S B=$O(^LR(LRDFN,"AY",A,2,B)) Q:'B!(LR("Q")) D
72 .S (T(3),M)=+^LR(LRDFN,"AY",A,2,B,0),M=^LAB(61.1,M,0)
73 .I 'LRSF515,($Y>(IOSL-6)) D FF D:'LRSPSM HD Q:LR("Q")
74 .I LRSF515,($Y>(IOSL-12)) D Q:LR("Q")
75 ..D FTR Q:LR("Q")
76 ..D:'LRSPSM HD
77 .Q:LR("Q")
78 .I 'LRSPSM D
79 ..W !?5,"M-",$P(M,"^",2),": "
80 ..S X=$P(M,"^") D:$G(LRS(5)) C^LRUA W X
81 .S T(4)=61.1
82 .D EN^LRSPRPT1,E
83 F B=1.4,3.3,4.5 D Q:LR("Q")
84 .S C=0 F S C=$O(^LR(LRDFN,"AY",A,$P(B,"."),C)) Q:'C!(LR("Q")) D
85 ..S (T(3),M)=+^LR(LRDFN,"AY",A,$P(B,"."),C,0)
86 ..D A
87 Q
88A S (E,T(4))="61."_$P(B,".",2)
89 S M=^LAB(E,M,0)
90 I 'LRSF515,($Y>(IOSL-6)) D FF D:'LRSPSM HD Q:LR("Q")
91 I LRSF515,($Y>(IOSL-12)) D Q:LR("Q")
92 .D FTR Q:LR("Q")
93 .D:'LRSPSM HD
94 Q:LR("Q")
95 I 'LRSPSM D
96 .W !?5,$S(B=1.4:"D-",B=3.3:"F-",B=4.5:"P-",1:""),$P(M,"^",2),?12,": "
97 .S X=$P(M,"^") D:$G(LRS(5)) C^LRUA W X
98 D EN^LRSPRPT1
99 Q
100E ;
101 S C=0 F S C=$O(^LR(LRDFN,"AY",A,2,B,1,C)) Q:'C!(LR("Q")) D
102 .S (T(3),E)=+^LR(LRDFN,"AY",A,2,B,1,C,0),E=^LAB(61.2,E,0)
103 .I $Y>(IOSL-6) D FF D:'LRSPSM HD Q:LR("Q")
104 .I 'LRSF515,($Y>(IOSL-6)) D FF D:'LRSPSM HD Q:LR("Q")
105 .I LRSF515,($Y>(IOSL-12)) D Q:LR("Q")
106 ..D FTR Q:LR("Q")
107 ..D:'LRSPSM HD
108 .Q:LR("Q")
109 .S T(4)=61.2
110 .I 'LRSPSM D
111 ..W !?10,"E-",$P(E,"^",2),": "
112 ..S X=$P(E,"^") D:$G(LRS(5)) C^LRUA W X
113 D EN^LRSPRPT1
114 Q
115HD ;
116 Q:LR("Q")
117 W !!,"SNOMED code(s):"
118 Q
119EN ;from LRAPPF1
120 K B
121 I $D(^LR(LRDFN,"AW")) D
122 .S X=^LR(LRDFN,"AW"),B(9)=$P(X,"^",9),B(1)=$P(X,"^",11,99)
123 .W !,"Rt--Lung--Lt Liver Spleen Rt--Kidney--Lt Brain Body "
124 .W "Wt(lb) Ht(in)"
125 I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
126 I $D(B) D
127 .W !,$J($P(X,"^",3),4),?8,$J($P(X,"^",4),4),?14,$J($P(X,"^",5),5)
128 .W ?21,$J($P(X,"^",6),5),?28,$J($P(X,"^",7),4),?38,$J($P(X,"^",8),4)
129 .W ?45,$J($P(X,"^",10),4),?55,$P(X,"^",2),?68,$P(X,"^")
130 I LRSF515 D:$Y>(IOSL-12) FTR
131 Q:LR("Q")
132 W !! W:$D(B) "Heart(gm)"
133 I LRSF515 D:$Y>(IOSL-12) FTR
134 Q:LR("Q")
135 I $D(^LR(LRDFN,"AV")) D
136 .S X=^LR(LRDFN,"AV"),B(2)=$P(X,"^",7,99)
137 .W ?12,"TV(cm) PV(cm) MV(cm) AV(cm) RV(cm) LV(cm)"
138 W ! W:$D(B(9)) $J(B(9),5)
139 I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
140 I $D(B(2)) D Q:LR("Q")
141 .W ?12,$J($P(X,"^"),4),?20,$J($P(X,"^",2),4),?28,$J($P(X,"^",3),4)
142 .W ?36,$J($P(X,"^",4),4),?44,$J($P(X,"^",5),4),?52,$J($P(X,"^",6),4)
143 .I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
144 .W !!,"Cavities(ml): Rt--Pleural--Lt Pericardial Peritoneal"
145 .I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
146 .W !?14,$J($P(B(2),"^",2),4),?25,$J($P(B(2),"^"),4)
147 .W ?33,$J($P(B(2),"^",3),4),?45,$J($P(B(2),"^",4),4)
148 I LRSF515 D:$Y>(IOSL-12) FTR Q:LR("Q")
149 S DIC="^DD(63,",DIC(0)="Z"
150 I $D(B(1)) F B=1:1:8 Q:LR("Q") D
151 .I $P(B(1),"^",B) S X="25."_B D
152 ..D ^DIC Q:Y='1
153 ..W !,Y(0,0)_": ",$P(B(1),"^",B)
154 ..I LRSF515 D:$Y>(IOSL-12) FTR
155 Q:LR("Q")
156 I $D(^LR(LRDFN,"AWI")) D
157 .S Z=^LR(LRDFN,"AWI") F B=1:1:5 Q:LR("Q") D
158 ..I $P(Z,"^",B) S X=$S(B=1:25.9,1:25.9_(B-1)) D
159 ...D ^DIC Q:Y=-1
160 ...W !,Y(0,0),": ",$P(Z,"^",B)
161 ...I LRSF515 D:$Y>(IOSL-12) FTR
162 K DIC,X,Y,Z
163 Q
164FTR ;
165 D:LRSS="AU" FT^LRAURPT,H^LRAURPT
166 D:LRSS'="AU" F^LRAPF,^LRAPF
167 Q
168FF ;
169 D H1^LRAPT
170 Q
Note: See TracBrowser for help on using the repository browser.