LRAPBR4 ;DALOI/STAFF - Autopsy Browser Display ;04/06/10 15:52
;;5.2;LAB SERVICE;**259,317,350,416,464**;Sep 27, 1994;Build 12
;
; Reference to ^DPT supported by IA #918
;
Q
;
ENTER ; Entry point
N LRTEXT,LRFILE,LRFIELD,LRTMP,LRFLG
D INIT
Q:'$D(^LR(LRDFN,LRSS))
D HEADER
D BODY
D:'LRTIU POW
D:LRTIU ESIGLN^LRAPBR1
D FOOTER
Q
;
;
INIT ; Initialize variables
S X=^LR(LRDFN,0) D ^LRUP
Q:'$D(^LR(LRDFN,LRSS))
F LRTMP=1:1 D Q:LRFIELD="Q"
. S X=$T(VART1+LRTMP)
. S LRFIELD=$P(X,";",2),VAR=$P(X,";",3),LRFLG=$P(X,";",4)
. Q:LRFIELD="Q"
. S @VAR=$$GET1^DIQ(63,LRDFN_",",LRFIELD,LRFLG)
. I VAR["LRM",@VAR S X=@VAR D D^LRUA S @VAR=X
S LRH(2)=$E(LRH(2),2,3)
;
; Get date of death (LRH)
S DA=LRDFN D D^LRAUAW
S Y=LR(63,12) D D^LRU S LRH=Y
;
S LCT=0
S:'LRTIU GROOT="^TMP(""LRAPBR"",$J,"
S:LRTIU GROOT="^TMP(""TIUP"",$J,"
K ^TMP("LRAPBR",$J)
;
; If reporting lab available then use instead of VistA site name.
S LRX=$P($G(^LR(LRDFN,"AU")),"^",18)
I LRX S LRQ(1)=$$NAME^XUAF4(LRX)
;
Q
;
;
BODY ; Report body
D:LRTIU GLENTRY("$TEXT",,1)
S LR("F")=1
I LRH(1)="" D
. D GLENTRY("+*+* REPORT INCOMPLETE *+*+",20,1)
. D GLENTRY(,,1)
D MODAUCK
; Display supplementary report header if one or more has been added
I $P($G(^LR(LRDFN,84,0)),U,4) D
. S LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED *+*"
. S LRTEXT=$$CJ^XLFSTR(LRTEXT,IOM)
. D GLENTRY(LRTEXT,,1)
. S LRTEXT="*+* REFER TO BOTTOM OF REPORT *+*"
. S LRTEXT=$$CJ^XLFSTR(LRTEXT,IOM)
. D GLENTRY(LRTEXT,,1)
D GLENTRY(,,1)
F LRV=81,82,84 D
. D:LRV'=84 GLENTRY(,,1)
. D:LRV=81 GLENTRY(LRAU(1),0)
. D:LRV=82 GLENTRY(LRAU(2),0)
. I LRV'=84 D
. . D GLENTRY(,,1)
. . S LRFILE=63,LRIENS=LRDFN_","
. . S LRFIELD=$S(LRV=81:32.2,1:32.3)
. . D WP
. I LRV=84 D
. . N LRIENS1,LRIENS
. . S LRFILE=63.324
. . S LRA=0 F S LRA=$O(^LR(LRDFN,84,LRA)) Q:'LRA D
. . . S LRIENS1=LRA_","_LRDFN_","
. . . D GLENTRY("SUPPLEMENTARY REPORT DATE: ",0,1)
. . . S LRB=$$GET1^DIQ(LRFILE,LRIENS1,.01)
. . . D GLENTRY(LRB,BTAB)
. . . D:$P($G(^LR(LRDFN,84,LRA,2,0)),U,4) SUPA
. . . S LRFIELD=1,LRIENS=LRIENS1 D WP
. . . D GLENTRY(,,1)
. I LRV'=84 D DASH,GLENTRY(,,1)
D ^LRAPBR5
Q
;
;
WP ; Display word procesing fields
K LRTMP,^UTILITY($J,"W")
N LRX,DIWR,DIWL,LRA1
S LRX=$$GET1^DIQ(LRFILE,LRIENS,LRFIELD,"","LRTMP","LRERR(1)")
S DIWR=IOM-5,DIWL=5,DIWF=""
S LRX=+$$GET1^DID(LRFILE,LRFIELD,"","SPECIFIER","LRERR(2)")
I $$GET1^DID(LRX,.01,"","SPECIFIER","LRERR(2)")["L" S DIWF="N"
S DIWF="X" ;464
S LRA1=0 F S LRA1=$O(LRTMP(LRA1)) Q:'LRA1 S X=LRTMP(LRA1) D ^DIWP
S LRA1=0 F S LRA1=$O(^UTILITY($J,"W",DIWL,LRA1)) Q:'LRA1 D
.D GLENTRY(^UTILITY($J,"W",DIWL,LRA1,0),DIWL,1)
K ^UTILITY($J,"W")
Q
;
;
SUPA ; Print supplementary report audit information
N LRFILE,LRIENS1,LRWP
S LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED *+*"
S LRTEXT=$$CJ^XLFSTR(LRTEXT,IOM)
D GLENTRY(LRTEXT,,1)
S LRTEXT="(Added/Last" D GLENTRY(LRTEXT,0,1)
S (A,B)=0 F S A=$O(^LR(LRDFN,84,LRA,2,A)) Q:'A D
.S B=A
Q:'$D(^LR(LRDFN,84,LRA,2,B,0))
S A=^(0),Y=+A,LRSGN=" typed by ",LRDSC=" modified: ",A2=$P(A,"^",2)
;If supp rpt is released, display 'signed by' instead of 'typed by'
I $P(A,"^",3) S LRSGN=" signed by ",LRDSC=" released: ",A2=$P(A,"^",3),Y=$P(A,"^",4)
S A2=$S($D(^VA(200,A2,0)):$P(^(0),"^"),1:A2)
;S LRFILE=63.3242,LRIENS1=B_","_LRA_","_LRDFN_","
;D GETS^DIQ(LRFILE,LRIENS1,"*","","LRWP")
;S Y=LRWP(LRFILE,LRIENS1,.01)
;S A=LRWP(LRFILE,LRIENS1,.02)
D D^LRU
S LRTEXT=LRDSC_Y_LRSGN_A2_")" D GLENTRY(LRTEXT,BTAB)
Q
;
;
S LRQ=LRQ+1
D:LRTIU GLENTRY("$APHDR",,1)
F I=1:1:2 D GLENTRY(,,1)
;
; Print names of facilities printing/releasing this report.
N LRN,LRPL,LRRL,LRX
I $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1,'LRTIU D
. D PFAC^LRRP1(DUZ(2),"",1,.LRPL)
. S LRN=0
. F S LRN=$O(LRPL(LRN)) Q:'LRN D GLENTRY(LRPL(LRN),"",1)
;
; Display reporting lab
I $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2 D
. S LRX=+$P($G(^LR(LRDFN,"AU")),"^",18)
. I LRX<1 Q
. D RL^LRRP1(LRX,1,.LRRL),GLENTRY("","",1)
. S LRN=0
. F S LRN=$O(LRRL(LRN)) Q:'LRN D GLENTRY(LRRL(LRN),"",1)
;
D DASH
S LRTEXT="CLINICAL RECORD |" D GLENTRY(LRTEXT,5,1)
S LRTEXT="AUTOPSY PROTOCOL" D GLENTRY(LRTEXT,40)
D DASH
S LRTEXT="Date died: "_LRH D GLENTRY(LRTEXT,0,1)
S LRTEXT="| Autopsy date: "_LRH(1) D GLENTRY(LRTEXT,40)
S LRTEXT="Resident: "_LRM(2) D GLENTRY(LRTEXT,0,1)
S LRTEXT="| "_$E(LRS(3),1,13) D GLENTRY(LRTEXT,40)
S LRTEXT="Autopsy No. "_$S(LRQ(8)'="":LRQ(8)_LRH(2)_" "_LRAC,1:LRAC)
D GLENTRY(LRTEXT,56)
D DASH
Q
;
;
MODAUCK ; Display modified banner if required
S LRAPMR=$$GET1^DIQ(63,LRDFN,102,"I")
Q:'LRAPMR
S LRAPMD=$$GET1^DIQ(63,LRDFN,102.2,"I")
D GLENTRY("","",1)
S LRTEXT=""
F LRCNT=1:1:$S(LRAPMD:14,1:15) D
.S LRTEXT=LRTEXT_"*+"
S LRTEXT=LRTEXT_" MODIFIED "
S LRTEXT=LRTEXT_$S(LRAPMD:"DIAGNOSIS ",1:"REPORT ")
F LRCNT=1:1:$S(LRAPMD:14,1:15) D
.S LRTEXT=LRTEXT_"*+"
D GLENTRY(LRTEXT,"",1)
D GLENTRY("","",1)
Q
;
;
POW ; Determine POW or Persian Gulf status
I $P($G(^LR(LRDFN,0)),"^",2)=2 D
.S LRPOW=0
.I $D(^DPT(DFN,.52)) S:$P(^(.52),U,5)="Y" LRPOW=1
.I $D(^DPT(DFN,.322)) S:$P($G(^(.322)),"^",10)="Y" LRPOW=1
.D ^LRAPBRPW
.K LRPOW
Q
;
;
D:LRTIU GLENTRY("$FTR",,1)
D DASH
D GLENTRY(,,1)
I LRH(3)=""&(LRH(17)'="") D
. S LRTEXT="| Provisional Anatomic Dx"
. D GLENTRY(LRTEXT,55)
S LRTEXT="Pathologist: "_LRM(3) D GLENTRY(LRTEXT,0,1)
D GLENTRY(LRW(9),52)
S LRTEXT="| Date " D GLENTRY(LRTEXT,55)
S LRTEXT=$E($S(LRH(3)'="":LRH(3),1:LRH(17)),1,12) D GLENTRY(LRTEXT,BTAB)
D DASH
S LRTEXT=$E(LRQ(1),1,IOM-20) D GLENTRY(LRTEXT,0,1)
S LRTEXT="AUTOPSY PROTOCOL" D GLENTRY(LRTEXT,IOM-17)
S LRTEXT="Patient: "_$E(LRP,1,30) D GLENTRY(LRTEXT,0,1)
D GLENTRY(SSN,43),GLENTRY("SEX:"_SEX,56),GLENTRY("DOB:"_DOB,63)
D GLENTRY($E(LRLLOC,1,22),0,1)
S LRTEXT="Physician: "_$E(LRM(1),1,28) D GLENTRY(LRTEXT,23)
S LRTEXT="AGE AT DEATH:"_$J(AGE,3) D GLENTRY(LRTEXT,63)
Q
;
;
DASH ;
D GLENTRY(LR("%"),0,1)
Q
;
;
GLENTRY(LRPR1,LRPR2,LRPR3) ; Write to global
; LRPR1 = Text to be written to global
; LRPR2 = Tab position
; LRPR3 = 1 means start a new line. Othewise, write on current line.
S LRPR1=$G(LRPR1),LRPR2=+$G(LRPR2),LRPR3=+$G(LRPR3)
D:LRPR3 NEWLN^LRAPUTL(LRPR1,LRPR2)
D:'LRPR3 GLBWRT^LRAPUTL(LRPR1,LRPR2)
Q
;
;
VART1 ;Setup variables
;14;LRAC;I;AUTOPSY ACCESSION #
;13.5;LRM(2);I;RESIDENT PATHOLOGIST
;12.1;LRM(1);I;PHYSICIAN
;13.01;LRW(9);I;AUTOPSY TYPIST
;13.6;LRM(3);I;SENIOR PATHOLOGIST
;11;LRH(1);;AUTOPSY DATE/TIME
;11;LRH(2);I;AUTOPSY DATE/TIME 2 DIGIT YEAR
;13;LRH(3);;DATE AUTOPSY REPORT COMPLETED
;14.9;LRH(17);;PROVISIONAL ANAT DX DATE
;14.1;LRLLOC;I;LOCATION
;12.5;AGE;I;AGE AT DEATH
;14.5;LRSVC;;SERVICE
;13.7;LRS(3);;AUTOPSY TYPE
;Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPBR4 7023 printed Apr 09, 2024@21:05:32 Page 2
LRAPBR4 ;DALOI/STAFF - Autopsy Browser Display ;04/06/10 15:52
+1 ;;5.2;LAB SERVICE;**259,317,350,416,464**;Sep 27, 1994;Build 12
+2 ;
+3 ; Reference to ^DPT supported by IA #918
+4 ;
+5 QUIT
+6 ;
ENTER ; Entry point
+1 NEW LRTEXT,LRFILE,LRFIELD,LRTMP,LRFLG
+2 DO INIT
+3 if '$DATA(^LR(LRDFN,LRSS))
QUIT
+4 DO HEADER
+5 DO BODY
+6 if 'LRTIU
DO POW
+7 if LRTIU
DO ESIGLN^LRAPBR1
+8 DO FOOTER
+9 QUIT
+10 ;
+11 ;
INIT ; Initialize variables
+1 SET X=^LR(LRDFN,0)
DO ^LRUP
+2 if '$DATA(^LR(LRDFN,LRSS))
QUIT
+3 FOR LRTMP=1:1
Begin DoDot:1
+4 SET X=$TEXT(VART1+LRTMP)
+5 SET LRFIELD=$PIECE(X,";",2)
SET VAR=$PIECE(X,";",3)
SET LRFLG=$PIECE(X,";",4)
+6 if LRFIELD="Q"
QUIT
+7 SET @VAR=$$GET1^DIQ(63,LRDFN_",",LRFIELD,LRFLG)
+8 IF VAR["LRM"
IF @VAR
SET X=@VAR
DO D^LRUA
SET @VAR=X
End DoDot:1
if LRFIELD="Q"
QUIT
+9 SET LRH(2)=$EXTRACT(LRH(2),2,3)
+10 ;
+11 ; Get date of death (LRH)
+12 SET DA=LRDFN
DO D^LRAUAW
+13 SET Y=LR(63,12)
DO D^LRU
SET LRH=Y
+14 ;
+15 SET LCT=0
+16 if 'LRTIU
SET GROOT="^TMP(""LRAPBR"",$J,"
+17 if LRTIU
SET GROOT="^TMP(""TIUP"",$J,"
+18 KILL ^TMP("LRAPBR",$JOB)
+19 ;
+20 ; If reporting lab available then use instead of VistA site name.
+21 SET LRX=$PIECE($GET(^LR(LRDFN,"AU")),"^",18)
+22 IF LRX
SET LRQ(1)=$$NAME^XUAF4(LRX)
+23 ;
+24 QUIT
+25 ;
+26 ;
BODY ; Report body
+1 if LRTIU
DO GLENTRY("$TEXT",,1)
+2 SET LR("F")=1
+3 IF LRH(1)=""
Begin DoDot:1
+4 DO GLENTRY("+*+* REPORT INCOMPLETE *+*+",20,1)
+5 DO GLENTRY(,,1)
End DoDot:1
+6 DO MODAUCK
+7 ; Display supplementary report header if one or more has been added
+8 IF $PIECE($GET(^LR(LRDFN,84,0)),U,4)
Begin DoDot:1
+9 SET LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED *+*"
+10 SET LRTEXT=$$CJ^XLFSTR(LRTEXT,IOM)
+11 DO GLENTRY(LRTEXT,,1)
+12 SET LRTEXT="*+* REFER TO BOTTOM OF REPORT *+*"
+13 SET LRTEXT=$$CJ^XLFSTR(LRTEXT,IOM)
+14 DO GLENTRY(LRTEXT,,1)
End DoDot:1
+15 DO GLENTRY(,,1)
+16 FOR LRV=81,82,84
Begin DoDot:1
+17 if LRV'=84
DO GLENTRY(,,1)
+18 if LRV=81
DO GLENTRY(LRAU(1),0)
+19 if LRV=82
DO GLENTRY(LRAU(2),0)
+20 IF LRV'=84
Begin DoDot:2
+21 DO GLENTRY(,,1)
+22 SET LRFILE=63
SET LRIENS=LRDFN_","
+23 SET LRFIELD=$SELECT(LRV=81:32.2,1:32.3)
+24 DO WP
End DoDot:2
+25 IF LRV=84
Begin DoDot:2
+26 NEW LRIENS1,LRIENS
+27 SET LRFILE=63.324
+28 SET LRA=0
FOR
SET LRA=$ORDER(^LR(LRDFN,84,LRA))
if 'LRA
QUIT
Begin DoDot:3
+29 SET LRIENS1=LRA_","_LRDFN_","
+30 DO GLENTRY("SUPPLEMENTARY REPORT DATE: ",0,1)
+31 SET LRB=$$GET1^DIQ(LRFILE,LRIENS1,.01)
+32 DO GLENTRY(LRB,BTAB)
+33 if $PIECE($GET(^LR(LRDFN,84,LRA,2,0)),U,4)
DO SUPA
+34 SET LRFIELD=1
SET LRIENS=LRIENS1
DO WP
+35 DO GLENTRY(,,1)
End DoDot:3
End DoDot:2
+36 IF LRV'=84
DO DASH
DO GLENTRY(,,1)
End DoDot:1
+37 DO ^LRAPBR5
+38 QUIT
+39 ;
+40 ;
WP ; Display word procesing fields
+1 KILL LRTMP,^UTILITY($JOB,"W")
+2 NEW LRX,DIWR,DIWL,LRA1
+3 SET LRX=$$GET1^DIQ(LRFILE,LRIENS,LRFIELD,"","LRTMP","LRERR(1)")
+4 SET DIWR=IOM-5
SET DIWL=5
SET DIWF=""
+5 SET LRX=+$$GET1^DID(LRFILE,LRFIELD,"","SPECIFIER","LRERR(2)")
+6 IF $$GET1^DID(LRX,.01,"","SPECIFIER","LRERR(2)")["L"
SET DIWF="N"
+7 ;464
SET DIWF="X"
+8 SET LRA1=0
FOR
SET LRA1=$ORDER(LRTMP(LRA1))
if 'LRA1
QUIT
SET X=LRTMP(LRA1)
DO ^DIWP
+9 SET LRA1=0
FOR
SET LRA1=$ORDER(^UTILITY($JOB,"W",DIWL,LRA1))
if 'LRA1
QUIT
Begin DoDot:1
+10 DO GLENTRY(^UTILITY($JOB,"W",DIWL,LRA1,0),DIWL,1)
End DoDot:1
+11 KILL ^UTILITY($JOB,"W")
+12 QUIT
+13 ;
+14 ;
SUPA ; Print supplementary report audit information
+1 NEW LRFILE,LRIENS1,LRWP
+2 SET LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED *+*"
+3 SET LRTEXT=$$CJ^XLFSTR(LRTEXT,IOM)
+4 DO GLENTRY(LRTEXT,,1)
+5 SET LRTEXT="(Added/Last"
DO GLENTRY(LRTEXT,0,1)
+6 SET (A,B)=0
FOR
SET A=$ORDER(^LR(LRDFN,84,LRA,2,A))
if 'A
QUIT
Begin DoDot:1
+7 SET B=A
End DoDot:1
+8 if '$DATA(^LR(LRDFN,84,LRA,2,B,0))
QUIT
+9 SET A=^(0)
SET Y=+A
SET LRSGN=" typed by "
SET LRDSC=" modified: "
SET A2=$PIECE(A,"^",2)
+10 ;If supp rpt is released, display 'signed by' instead of 'typed by'
+11 IF $PIECE(A,"^",3)
SET LRSGN=" signed by "
SET LRDSC=" released: "
SET A2=$PIECE(A,"^",3)
SET Y=$PIECE(A,"^",4)
+12 SET A2=$SELECT($DATA(^VA(200,A2,0)):$PIECE(^(0),"^"),1:A2)
+13 ;S LRFILE=63.3242,LRIENS1=B_","_LRA_","_LRDFN_","
+14 ;D GETS^DIQ(LRFILE,LRIENS1,"*","","LRWP")
+15 ;S Y=LRWP(LRFILE,LRIENS1,.01)
+16 ;S A=LRWP(LRFILE,LRIENS1,.02)
+17 DO D^LRU
+18 SET LRTEXT=LRDSC_Y_LRSGN_A2_")"
DO GLENTRY(LRTEXT,BTAB)
+19 QUIT
+20 ;
+21 ;
+1 SET LRQ=LRQ+1
+2 if LRTIU
DO GLENTRY("$APHDR",,1)
+3 FOR I=1:1:2
DO GLENTRY(,,1)
+4 ;
+5 ; Print names of facilities printing/releasing this report.
+6 NEW LRN,LRPL,LRRL,LRX
+7 IF $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1
IF 'LRTIU
Begin DoDot:1
+8 DO PFAC^LRRP1(DUZ(2),"",1,.LRPL)
+9 SET LRN=0
+10 FOR
SET LRN=$ORDER(LRPL(LRN))
if 'LRN
QUIT
DO GLENTRY(LRPL(LRN),"",1)
End DoDot:1
+11 ;
+12 ; Display reporting lab
+13 IF $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2
Begin DoDot:1
+14 SET LRX=+$PIECE($GET(^LR(LRDFN,"AU")),"^",18)
+15 IF LRX<1
QUIT
+16 DO RL^LRRP1(LRX,1,.LRRL)
DO GLENTRY("","",1)
+17 SET LRN=0
+18 FOR
SET LRN=$ORDER(LRRL(LRN))
if 'LRN
QUIT
DO GLENTRY(LRRL(LRN),"",1)
End DoDot:1
+19 ;
+20 DO DASH
+21 SET LRTEXT="CLINICAL RECORD |"
DO GLENTRY(LRTEXT,5,1)
+22 SET LRTEXT="AUTOPSY PROTOCOL"
DO GLENTRY(LRTEXT,40)
+23 DO DASH
+24 SET LRTEXT="Date died: "_LRH
DO GLENTRY(LRTEXT,0,1)
+25 SET LRTEXT="| Autopsy date: "_LRH(1)
DO GLENTRY(LRTEXT,40)
+26 SET LRTEXT="Resident: "_LRM(2)
DO GLENTRY(LRTEXT,0,1)
+27 SET LRTEXT="| "_$EXTRACT(LRS(3),1,13)
DO GLENTRY(LRTEXT,40)
+28 SET LRTEXT="Autopsy No. "_$SELECT(LRQ(8)'="":LRQ(8)_LRH(2)_" "_LRAC,1:LRAC)
+29 DO GLENTRY(LRTEXT,56)
+30 DO DASH
+31 QUIT
+32 ;
+33 ;
MODAUCK ; Display modified banner if required
+1 SET LRAPMR=$$GET1^DIQ(63,LRDFN,102,"I")
+2 if 'LRAPMR
QUIT
+3 SET LRAPMD=$$GET1^DIQ(63,LRDFN,102.2,"I")
+4 DO GLENTRY("","",1)
+5 SET LRTEXT=""
+6 FOR LRCNT=1:1:$SELECT(LRAPMD:14,1:15)
Begin DoDot:1
+7 SET LRTEXT=LRTEXT_"*+"
End DoDot:1
+8 SET LRTEXT=LRTEXT_" MODIFIED "
+9 SET LRTEXT=LRTEXT_$SELECT(LRAPMD:"DIAGNOSIS ",1:"REPORT ")
+10 FOR LRCNT=1:1:$SELECT(LRAPMD:14,1:15)
Begin DoDot:1
+11 SET LRTEXT=LRTEXT_"*+"
End DoDot:1
+12 DO GLENTRY(LRTEXT,"",1)
+13 DO GLENTRY("","",1)
+14 QUIT
+15 ;
+16 ;
POW ; Determine POW or Persian Gulf status
+1 IF $PIECE($GET(^LR(LRDFN,0)),"^",2)=2
Begin DoDot:1
+2 SET LRPOW=0
+3 IF $DATA(^DPT(DFN,.52))
if $PIECE(^(.52),U,5)="Y"
SET LRPOW=1
+4 IF $DATA(^DPT(DFN,.322))
if $PIECE($GET(^(.322)),"^",10)="Y"
SET LRPOW=1
+5 DO ^LRAPBRPW
+6 KILL LRPOW
End DoDot:1
+7 QUIT
+8 ;
+9 ;
+1 if LRTIU
DO GLENTRY("$FTR",,1)
+2 DO DASH
+3 DO GLENTRY(,,1)
+4 IF LRH(3)=""&(LRH(17)'="")
Begin DoDot:1
+5 SET LRTEXT="| Provisional Anatomic Dx"
+6 DO GLENTRY(LRTEXT,55)
End DoDot:1
+7 SET LRTEXT="Pathologist: "_LRM(3)
DO GLENTRY(LRTEXT,0,1)
+8 DO GLENTRY(LRW(9),52)
+9 SET LRTEXT="| Date "
DO GLENTRY(LRTEXT,55)
+10 SET LRTEXT=$EXTRACT($SELECT(LRH(3)'="":LRH(3),1:LRH(17)),1,12)
DO GLENTRY(LRTEXT,BTAB)
+11 DO DASH
+12 SET LRTEXT=$EXTRACT(LRQ(1),1,IOM-20)
DO GLENTRY(LRTEXT,0,1)
+13 SET LRTEXT="AUTOPSY PROTOCOL"
DO GLENTRY(LRTEXT,IOM-17)
+14 SET LRTEXT="Patient: "_$EXTRACT(LRP,1,30)
DO GLENTRY(LRTEXT,0,1)
+15 DO GLENTRY(SSN,43)
DO GLENTRY("SEX:"_SEX,56)
DO GLENTRY("DOB:"_DOB,63)
+16 DO GLENTRY($EXTRACT(LRLLOC,1,22),0,1)
+17 SET LRTEXT="Physician: "_$EXTRACT(LRM(1),1,28)
DO GLENTRY(LRTEXT,23)
+18 SET LRTEXT="AGE AT DEATH:"_$JUSTIFY(AGE,3)
DO GLENTRY(LRTEXT,63)
+19 QUIT
+20 ;
+21 ;
DASH ;
+1 DO GLENTRY(LR("%"),0,1)
+2 QUIT
+3 ;
+4 ;
GLENTRY(LRPR1,LRPR2,LRPR3) ; Write to global
+1 ; LRPR1 = Text to be written to global
+2 ; LRPR2 = Tab position
+3 ; LRPR3 = 1 means start a new line. Othewise, write on current line.
+4 SET LRPR1=$GET(LRPR1)
SET LRPR2=+$GET(LRPR2)
SET LRPR3=+$GET(LRPR3)
+5 if LRPR3
DO NEWLN^LRAPUTL(LRPR1,LRPR2)
+6 if 'LRPR3
DO GLBWRT^LRAPUTL(LRPR1,LRPR2)
+7 QUIT
+8 ;
+9 ;
VART1 ;Setup variables
+1 ;14;LRAC;I;AUTOPSY ACCESSION #
+2 ;13.5;LRM(2);I;RESIDENT PATHOLOGIST
+3 ;12.1;LRM(1);I;PHYSICIAN
+4 ;13.01;LRW(9);I;AUTOPSY TYPIST
+5 ;13.6;LRM(3);I;SENIOR PATHOLOGIST
+6 ;11;LRH(1);;AUTOPSY DATE/TIME
+7 ;11;LRH(2);I;AUTOPSY DATE/TIME 2 DIGIT YEAR
+8 ;13;LRH(3);;DATE AUTOPSY REPORT COMPLETED
+9 ;14.9;LRH(17);;PROVISIONAL ANAT DX DATE
+10 ;14.1;LRLLOC;I;LOCATION
+11 ;12.5;AGE;I;AGE AT DEATH
+12 ;14.5;LRSVC;;SERVICE
+13 ;13.7;LRS(3);;AUTOPSY TYPE
+14 ;Q
