source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPBR4.m@ 623

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

initial load of WorldVistAEHR

File size: 5.8 KB
Line 
1LRAPBR4 ;DALOI/WTY/KLL - Autopsy Browser Display;7/27/01
2 ;;5.2;LAB SERVICE;**259,317**;Sep 27, 1994
3 ;
4 ;Reference to ^DPT supported by IA #918
5 ;
6 Q
7ENTER ;Entry point
8 N LRTEXT,LRFILE,LRFIELD,LRTMP,LRFLG
9 D INIT
10 Q:'$D(^LR(LRDFN,LRSS))
11 D HEADER
12 D BODY
13 D:'LRTIU POW
14 D:LRTIU ESIGLN^LRAPBR1
15 D FOOTER
16 Q
17INIT ;Initialize variables
18 S X=^LR(LRDFN,0) D ^LRUP
19 Q:'$D(^LR(LRDFN,LRSS))
20 F LRTMP=1:1 D Q:LRFIELD="Q"
21 .S X=$T(VART1+LRTMP)
22 .S LRFIELD=$P(X,";",2),VAR=$P(X,";",3),LRFLG=$P(X,";",4)
23 .Q:LRFIELD="Q"
24 .S @VAR=$$GET1^DIQ(63,LRDFN_",",LRFIELD,LRFLG)
25 .I VAR["LRM",@VAR S X=@VAR D D^LRUA S @VAR=X
26 S LRH(2)=$E(LRH(2),2,3)
27 ;Get date of death (LRH)
28 S DA=LRDFN D D^LRAUAW
29 S Y=LR(63,12) D D^LRU S LRH=Y
30 S LCT=0
31 S:'LRTIU GROOT="^TMP(""LRAPBR"",$J,"
32 S:LRTIU GROOT="^TMP(""TIUP"",$J,"
33 K ^TMP("LRAPBR",$J)
34 Q
35BODY ;Report body
36 D:LRTIU GLENTRY("$TEXT",,1)
37 S LR("F")=1
38 I LRH(1)="" D
39 .D GLENTRY("+*+* REPORT INCOMPLETE *+*+",20,1)
40 .D GLENTRY(,,1)
41 D MODAUCK
42 ;Display supplementary report header if one or more has been added
43 I $P($G(^LR(LRDFN,84,0)),U,4) D
44 .S LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED *+*"
45 .S LRTEXT=$$CJ^XLFSTR(LRTEXT,IOM)
46 .D GLENTRY(LRTEXT,,1)
47 .S LRTEXT="*+* REFER TO BOTTOM OF REPORT *+*"
48 .S LRTEXT=$$CJ^XLFSTR(LRTEXT,IOM)
49 .D GLENTRY(LRTEXT,,1)
50 D GLENTRY(,,1)
51 F LRV=81,82,84 D
52 .D:LRV'=84 GLENTRY(,,1)
53 .D:LRV=81 GLENTRY(LRAU(1),0)
54 .D:LRV=82 GLENTRY(LRAU(2),0)
55 .I LRV'=84 D
56 ..D GLENTRY(,,1)
57 ..S LRFILE=63,LRIENS=LRDFN_","
58 ..S LRFIELD=$S(LRV=81:32.2,1:32.3)
59 ..D WP
60 .I LRV=84 D
61 ..N LRIENS1,LRIENS
62 ..S LRFILE=63.324
63 ..S LRA=0 F S LRA=$O(^LR(LRDFN,84,LRA)) Q:'LRA D
64 ...S LRIENS1=LRA_","_LRDFN_","
65 ...D GLENTRY("SUPPLEMENTARY REPORT DATE: ",0,1)
66 ...S LRB=$$GET1^DIQ(LRFILE,LRIENS1,.01)
67 ...D GLENTRY(LRB,BTAB)
68 ...D:$P($G(^LR(LRDFN,84,LRA,2,0)),U,4) SUPA
69 ...S LRFIELD=1,LRIENS=LRIENS1 D WP
70 ...D GLENTRY(,,1)
71 .I LRV'=84 D DASH,GLENTRY(,,1)
72 D ^LRAPBR5
73 Q
74WP ;Display word procesing fields
75 K LRTMP,^UTILITY($J,"W")
76 N LRX,DIWR,DIWL,LRA1
77 S LRX=$$GET1^DIQ(LRFILE,LRIENS,LRFIELD,"","LRTMP","LRERR(1)")
78 S DIWR=IOM-5,DIWL=5,DIWF=""
79 S LRX=+$$GET1^DID(LRFILE,LRFIELD,"","SPECIFIER","LRERR(2)")
80 I $$GET1^DID(LRX,.01,"","SPECIFIER","LRERR(2)")["L" S DIWF="N"
81 S LRA1=0 F S LRA1=$O(LRTMP(LRA1)) Q:'LRA1 S X=LRTMP(LRA1) D ^DIWP
82 S LRA1=0 F S LRA1=$O(^UTILITY($J,"W",DIWL,LRA1)) Q:'LRA1 D
83 .D GLENTRY(^UTILITY($J,"W",DIWL,LRA1,0),DIWL,1)
84 K ^UTILITY($J,"W")
85 Q
86SUPA ;Print supplementary report audit information
87 N LRFILE,LRIENS1,LRWP
88 S LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED *+*"
89 S LRTEXT=$$CJ^XLFSTR(LRTEXT,IOM)
90 D GLENTRY(LRTEXT,,1)
91 S LRTEXT="(Added/Last" D GLENTRY(LRTEXT,0,1)
92 S (A,B)=0 F S A=$O(^LR(LRDFN,84,LRA,2,A)) Q:'A D
93 .S B=A
94 Q:'$D(^LR(LRDFN,84,LRA,2,B,0))
95 S A=^(0),Y=+A,LRSGN=" typed by ",LRDSC=" modified: ",A2=$P(A,"^",2)
96 ;If supp rpt is released, display 'signed by' instead of 'typed by'
97 I $P(A,"^",3) S LRSGN=" signed by ",LRDSC=" released: ",A2=$P(A,"^",3),Y=$P(A,"^",4)
98 S A2=$S($D(^VA(200,A2,0)):$P(^(0),"^"),1:A2)
99 ;S LRFILE=63.3242,LRIENS1=B_","_LRA_","_LRDFN_","
100 ;D GETS^DIQ(LRFILE,LRIENS1,"*","","LRWP")
101 ;S Y=LRWP(LRFILE,LRIENS1,.01)
102 ;S A=LRWP(LRFILE,LRIENS1,.02)
103 D D^LRU
104 S LRTEXT=LRDSC_Y_LRSGN_A2_")" D GLENTRY(LRTEXT,BTAB)
105 Q
106HEADER ;
107 S LRQ=LRQ+1
108 D:LRTIU GLENTRY("$APHDR",,1)
109 F I=1:1:2 D GLENTRY(,,1)
110 D DASH
111 S LRTEXT="CLINICAL RECORD |" D GLENTRY(LRTEXT,5,1)
112 S LRTEXT="AUTOPSY PROTOCOL" D GLENTRY(LRTEXT,40)
113 D DASH
114 S LRTEXT="Date died: "_LRH D GLENTRY(LRTEXT,0,1)
115 S LRTEXT="| Autopsy date: "_LRH(1) D GLENTRY(LRTEXT,40)
116 S LRTEXT="Resident: "_LRM(2) D GLENTRY(LRTEXT,0,1)
117 S LRTEXT="| "_$E(LRS(3),1,13) D GLENTRY(LRTEXT,40)
118 S LRTEXT="Autopsy No. "_$S(LRQ(8)'="":LRQ(8)_LRH(2)_" "_LRAC,1:LRAC)
119 D GLENTRY(LRTEXT,56)
120 D DASH
121 Q
122MODAUCK ;Display modified banner if required
123 S LRAPMR=$$GET1^DIQ(63,LRDFN,102,"I")
124 Q:'LRAPMR
125 S LRAPMD=$$GET1^DIQ(63,LRDFN,102.2,"I")
126 D GLENTRY("","",1)
127 S LRTEXT=""
128 F LRCNT=1:1:$S(LRAPMD:29,1:31) D
129 .S LRTEXT=LRTEXT_"*"
130 S LRTEXT=LRTEXT_" MODIFIED "
131 S LRTEXT=LRTEXT_$S(LRAPMD:"DIAGNOSIS ",1:"REPORT ")
132 F LRCNT=1:1:$S(LRAPMD:29,1:31) D
133 .S LRTEXT=LRTEXT_"*"
134 D GLENTRY(LRTEXT,"",1)
135 D GLENTRY("","",1)
136 Q
137POW ;Determine POW or Persian Gulf status
138 I $P($G(^LR(LRDFN,0)),"^",2)=2 D
139 .S LRPOW=0
140 .I $D(^DPT(DFN,.52)) S:$P(^(.52),U,5)="Y" LRPOW=1
141 .I $D(^DPT(DFN,.322)) S:$P($G(^(.322)),"^",10)="Y" LRPOW=1
142 .D ^LRAPBRPW
143 .K LRPOW
144 Q
145FOOTER ;Report footer
146 D:LRTIU GLENTRY("$FTR",,1)
147 D DASH
148 D GLENTRY(,,1)
149 I LRH(3)=""&(LRH(17)'="") D
150 .S LRTEXT="| Provisional Anatomic Dx"
151 .D GLENTRY(LRTEXT,55)
152 S LRTEXT="Pathologist: "_LRM(3) D GLENTRY(LRTEXT,0,1)
153 D GLENTRY(LRW(9),52)
154 S LRTEXT="| Date " D GLENTRY(LRTEXT,55)
155 S LRTEXT=$E($S(LRH(3)'="":LRH(3),1:LRH(17)),1,12) D GLENTRY(LRTEXT,BTAB)
156 D DASH
157 S LRTEXT=LRQ(1) D GLENTRY(LRTEXT,0,1)
158 S LRTEXT="AUTOPSY PROTOCOL" D GLENTRY(LRTEXT,IOM-17)
159 S LRTEXT="Patient: "_$E(LRP,1,30) D GLENTRY(LRTEXT,0,1)
160 D GLENTRY(SSN,43),GLENTRY("SEX:"_SEX,56),GLENTRY("DOB:"_DOB,63)
161 D GLENTRY($E(LRLLOC,1,22),0,1)
162 S LRTEXT="Physician: "_$E(LRM(1),1,28) D GLENTRY(LRTEXT,23)
163 S LRTEXT="AGE AT DEATH:"_$J(AGE,3) D GLENTRY(LRTEXT,63)
164 Q
165DASH ;
166 D GLENTRY(LR("%"),0,1)
167 Q
168GLENTRY(LRPR1,LRPR2,LRPR3) ;Write to global
169 ;LRPR1 = Text to be written to global
170 ;LRPR2 = Tab position
171 ;LRPR3 = 1 means start a new line. Othewise, write on current line.
172 S LRPR1=$G(LRPR1),LRPR2=+$G(LRPR2),LRPR3=+$G(LRPR3)
173 D:LRPR3 NEWLN^LRAPUTL(LRPR1,LRPR2)
174 D:'LRPR3 GLBWRT^LRAPUTL(LRPR1,LRPR2)
175 Q
176VART1 ;Setup variables
177 ;14;LRAC;I;AUTOPSY ACCESSION #
178 ;13.5;LRM(2);I;RESIDENT PATHOLOGIST
179 ;12.1;LRM(1);I;PHYSICIAN
180 ;13.01;LRW(9);I;AUTOPSY TYPIST
181 ;13.6;LRM(3);I;SENIOR PATHOLOGIST
182 ;11;LRH(1);;AUTOPSY DATE/TIME
183 ;11;LRH(2);I;AUTOPSY DATE/TIME 2 DIGIT YEAR
184 ;13;LRH(3);;DATE AUTOPSY REPORT COMPLETED
185 ;14.9;LRH(17);;PROVISIONAL ANAT DX DATE
186 ;14.1;LRLLOC;I;LOCATION
187 ;12.5;AGE;I;AGE AT DEATH
188 ;14.5;LRSVC;;SERVICE
189 ;13.7;LRS(3);;AUTOPSY TYPE
190 ;Q
Note: See TracBrowser for help on using the repository browser.