- LRAPAUSR ;AVAMC/REG/WTY - AUTOPSY SUPPLEMENTARY REPORT;9/14/01
- ;;5.2;LAB SERVICE;**1,173,248,259,317,464**;Sep 27, 1994;Build 12
- ;
- ;Reference to ^DD(63 supported by IA #10155
- ;
- S X="T",%DT="" D ^%DT,D^LRU S LRH(3)=Y,LRFLG=1
- W !!,LRO(68)," Autopsy Supplementary Reports" D XR^LRU
- S LRS(1)=$P(^LRO(69.2,LRAA,0),U,3),LRS(2)=$P(^(0),U,4)
- D EN2^LRUA
- G END:LRAPX=2,SGL:LRAPX=3,CH:LRAPX=4
- S XTMP="Someone else is building a print queue for this Accession Area"
- L +^LRO(69.2,LRAA,3):5 I '$T D EN^DDIOL(XTMP,"","$C(7),!!") K XTMP 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,3) Q
- S FDAIEN(2)=LRAN
- S FDA(1,69.29,"+2,"_+LRAA_",",.01)=LRDFN
- D UPDATE^DIE("","FDA(1)","FDAIEN") K FDAIEN G GETP
- CH I '$O(^LRO(69.2,LRAA,3,0)) D Q
- .W $C(7),!!,"No AUTOPSY SUPPLEMENTARY REPORTS currently on the "
- .W "print queue.",!!
- SPC 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 spacing of reports"
- S LRS=$S(X="D":"D",1:"")_"W" Q:LRAPX=3
- W !!,"Save supplementary report list for reprinting "
- S %=2 D YN^LRU S:%=1 LRSAV=1
- DEV ;
- W !
- S %ZIS="Q" D ^%ZIS
- I POP W ! Q
- I $D(IO("Q")) D Q
- .S ZTDESC="ANAT PATH FINAL REPORT"
- .S ZTSAVE("LR*")="",ZTRTN="QUE^LRAPAUSR"
- .D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !
- .K ZTSK,IO("Q") D HOME^%ZIS
- QUE U IO D L^LRU,S^LRU,EN^LRUA
- ;LRSF515=1 indicates that an SF515 is being generated.
- S:'$D(LRSF515) LRSF515=0
- S (LRS(5),LRAURPT)=1
- I $D(LRAP) S LRDFN=LRAP D EN Q:LR("Q") K LRAP G LST
- F LRAN=0:0 S LRAN=$O(^LRO(69.2,LRAA,3,LRAN)) Q:'LRAN!(LR("Q")) D
- .S LRDFN=+^(LRAN,0) D EN
- LST K:'$D(LRSAV) ^LRO(69.2,LRAA,3) K LRAURPT
- S:'$D(^LRO(69.2,LRAA,3,0)) ^(0)="^69.29A^0^0"
- I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
- K LRSAV D K^LRU
- W:IOST?1"P-".E @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
- K %,DIR,DTOUT,DUOUT,DIRUT,X,Y
- Q
- W W !,LR("%") Q
- E K ^UTILITY($J) S DIWR=IOM-5,DIWL=5,DIWF=LRS Q
- ;
- EN S LRQ=0,X=^LR(LRDFN,0) Q:'$O(^LR(LRDFN,84,0)) D ^LRUP
- I '$D(^LR(LRDFN,"AU")) L +^LRO(69.2,LRAA,3,LRAN):5 Q:'$T D Q
- .S DIK="^LRO(69.2,LRAA,3,",DA=LRAN,DA(1)=0
- .D ^DIK K KA,DIK
- .L -^LRO(69.2,LRAA,3,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
- S LRLLOC=$P(X,"^",5),AGE=$P(X,"^",9)
- ;Define the service
- S Y=$P(X,"^",8),C=$P(^DD(63,14.5,0),U,3)
- D Y^DIQ S LRSVC=Y
- ;Define autopsy type
- 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
- D H Q:LR("Q") S LR("F")=1
- W:LRH(1)="" !?20,"+*+* REPORT INCOMPLETE *+*+"
- 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-13) FT,H Q:LR("Q")
- .W !!,"SUPPLEMENTARY REPORT DATE: "
- .S Y=LRB D D^LRU W Y
- .D:$Y>(IOSL-13) FT,H Q:LR("Q")
- .D:$P($G(^LR(LRDFN,84,LRA,2,0)),U,4) SUPA
- .D WRT
- Q:LR("Q") D FT Q
- WRT D E S LRC=0
- S DIWF="X" ;464
- F LRZ=0:1 S LRC=$O(^LR(LRDFN,84,LRA,1,LRC)) Q:'LRC!(LR("Q")) D
- .D:$Y>(IOSL-13) FT,H S LR("F")=1 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
- SUPA ;Print supplementary report audit information
- W !?14,"*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED*+*"
- W !,"(Added/Last modified: "
- S (A,B)=0 F S A=$O(^LR(LRDFN,84,LRA,2,A)) Q:'A!(LR("Q")) D
- .S B=A
- Q:LR("Q")
- Q:'$D(^LR(LRDFN,84,LRA,2,B,0))
- S A=^(0),Y=+A,LRSGN=" typed by ",A2=$P(A,"^",2)
- I $P(A,"^",3) D
- .S LRSGN=" signed by ",A2=$P(A,"^",3),Y=$P(A,"^",4)
- S A2=$S($D(^VA(200,A2,0)):$P(^(0),"^"),1:A2)
- ;If supp rpt is released, display 'signed by' instead of 'typed by'
- D D^LRU W Y,LRSGN,A2,")"
- ;If RELEASE SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED"
- I $P(^LR(LRDFN,84,LRA,0),"^",3) W !,?25,"**-* NOT VERIFIED *-**"
- D:$D(LRQ(9)) SUPM
- Q
- SUPM ;Print previous versions of supplementary reports
- ;This is used by menu option 'Print path modifications [LRAPMOD]'
- ;
- S A=0 F S A=$O(^LR(LRDFN,84,LRA,2,A)) Q:'A!(LR("Q")) D
- .S LRT=^LR(LRDFN,84,LRA,2,A,0)
- .D:$Y>(IOSL-13) FT,H Q:LR("Q")
- .S Y=+LRT,Y2="modified: ",X=$P(LRT,"^",2),LRSGN=" typed by "
- .;If supp rpt is released, display 'signed by' instead of 'typed by'
- .I $P(LRT,"^",3) S LRSGN=" signed by",X=$P(LRT,"^",3),Y=$P(LRT,"^",4),Y2="released: "
- .S X=$S($D(^VA(200,X,0)):$P(^(0),"^"),1:X)
- .D D^LRU W !,"Date ",Y2,Y,LRSGN,X
- .K ^UTILITY($J) S DIWR=IOM-5,DIWL=5,DIWF="W"
- .S B=0
- .F LRZ=0:1 S B=$O(^LR(LRDFN,84,LRA,2,A,1,B)) Q:'B!(LR("Q")) D
- ..S LRT=^LR(LRDFN,84,LRA,2,A,1,B,0)
- ..D:$Y>(IOSL-13) FT,H Q:LR("Q")
- ..S X=LRT D ^DIWP
- .Q:LR("Q") D:LRZ ^DIWW
- Q:LR("Q")
- W !?13,"==========Text below appears on final report=========="
- Q
- H ;Header
- I $D(LR("F")),IOST?1"C".E D CONT Q:LR("Q")
- W:($D(LR("F"))) @IOF
- S LRQ=LRQ+1
- ;W:IOST?1"C".E!(IOST'?1"C".E&('$D(LRFLG))) @IOF,!
- ;K LRFLG
- W ! D W
- W !?5,"CLINICAL RECORD |",?40,"AUTOPSY SUPPLEMENTARY REPORT"
- W ?73,"Pg ",LRQ,!,LR("%")
- W !,"Date died: ",LRH,?40,"| Autopsy date: ",LRH(1)
- W !,"Resident: ",LRM(2),?40,"| ",LRS(3)
- 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-13) W !
- D W W !!,"Pathologist: ",LRM(3),?52,LRW(9),?55,"| Date ",$E(LRH(3),1,12)
- D W W !,LRQ(1),?(IOM-30),"AUTOPSY SUPPLEMENTARY REPORT"
- W !,$E(LRP,1,30),?31,SSN,?49,"SEX:",SEX,?55,"DOB:",DOB,!,LRLLOC
- W ?31,LRM(1),?55,"AGE AT DEATH: ",AGE
- Q
- SGL ;Entry point for printing single report
- S X="" D ^LRUPS G:LRAN="?" SGL Q:LRAN=-1
- I $D(LR("AU1")),'$P(^LR(LRDFN,"AU"),U,15) D Q
- .W $C(7),!!,"Report not verified."
- D SPC Q:X=""!(X[U)
- S LRAP=LRDFN,LRSAV=1
- D EN2^LRUA
- G DEV
- 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 SUPPLEMENTARY REPORT list "
- S %=2 D YN^LRU
- I %=1 K ^LRO(69.2,LRAA,3) S ^LRO(69.2,LRAA,3,0)="^69.29A^0^0" D Q
- .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,LR("F")=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPAUSR 6334 printed Feb 18, 2025@23:32:49 Page 2
- LRAPAUSR ;AVAMC/REG/WTY - AUTOPSY SUPPLEMENTARY REPORT;9/14/01
- +1 ;;5.2;LAB SERVICE;**1,173,248,259,317,464**;Sep 27, 1994;Build 12
- +2 ;
- +3 ;Reference to ^DD(63 supported by IA #10155
- +4 ;
- +5 SET X="T"
- SET %DT=""
- DO ^%DT
- DO D^LRU
- SET LRH(3)=Y
- SET LRFLG=1
- +6 WRITE !!,LRO(68)," Autopsy Supplementary Reports"
- DO XR^LRU
- +7 SET LRS(1)=$PIECE(^LRO(69.2,LRAA,0),U,3)
- SET LRS(2)=$PIECE(^(0),U,4)
- +8 DO EN2^LRUA
- +9 if LRAPX=2
- GOTO END
- if LRAPX=3
- GOTO SGL
- if LRAPX=4
- GOTO CH
- +10 SET XTMP="Someone else is building a print queue for this Accession Area"
- +11 LOCK +^LRO(69.2,LRAA,3):5
- IF '$TEST
- DO EN^DDIOL(XTMP,"","$C(7),!!")
- KILL XTMP
- 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,3)
- QUIT
- +2 SET FDAIEN(2)=LRAN
- +3 SET FDA(1,69.29,"+2,"_+LRAA_",",.01)=LRDFN
- +4 DO UPDATE^DIE("","FDA(1)","FDAIEN")
- KILL FDAIEN
- GOTO GETP
- CH IF '$ORDER(^LRO(69.2,LRAA,3,0))
- Begin DoDot:1
- +1 WRITE $CHAR(7),!!,"No AUTOPSY SUPPLEMENTARY REPORTS currently on the "
- +2 WRITE "print queue.",!!
- End DoDot:1
- QUIT
- SPC READ !,"(D)ouble or (S)ingle spacing of report(s): ",X:DTIME
- +1 if X=""!(X[U)
- QUIT
- +2 IF $EXTRACT(X)'="D"&($EXTRACT(X)'="S")
- Begin DoDot:1
- +3 WRITE $CHAR(7),!,"Enter 'S' for single or 'D' for double spacing of reports"
- End DoDot:1
- GOTO SPC
- +4 SET LRS=$SELECT(X="D":"D",1:"")_"W"
- if LRAPX=3
- QUIT
- +5 WRITE !!,"Save supplementary report list for reprinting "
- +6 SET %=2
- DO YN^LRU
- if %=1
- SET LRSAV=1
- DEV ;
- +1 WRITE !
- +2 SET %ZIS="Q"
- DO ^%ZIS
- +3 IF POP
- WRITE !
- QUIT
- +4 IF $DATA(IO("Q"))
- Begin DoDot:1
- +5 SET ZTDESC="ANAT PATH FINAL REPORT"
- +6 SET ZTSAVE("LR*")=""
- SET ZTRTN="QUE^LRAPAUSR"
- +7 DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !,"Request Queued, #",ZTSK
- WRITE !
- +8 KILL ZTSK,IO("Q")
- DO HOME^%ZIS
- End DoDot:1
- QUIT
- QUE USE IO
- DO L^LRU
- DO S^LRU
- DO EN^LRUA
- +1 ;LRSF515=1 indicates that an SF515 is being generated.
- +2 if '$DATA(LRSF515)
- SET LRSF515=0
- +3 SET (LRS(5),LRAURPT)=1
- +4 IF $DATA(LRAP)
- SET LRDFN=LRAP
- DO EN
- if LR("Q")
- QUIT
- KILL LRAP
- GOTO LST
- +5 FOR LRAN=0:0
- SET LRAN=$ORDER(^LRO(69.2,LRAA,3,LRAN))
- if 'LRAN!(LR("Q"))
- QUIT
- Begin DoDot:1
- +6 SET LRDFN=+^(LRAN,0)
- DO EN
- End DoDot:1
- LST if '$DATA(LRSAV)
- KILL ^LRO(69.2,LRAA,3)
- KILL LRAURPT
- +1 if '$DATA(^LRO(69.2,LRAA,3,0))
- SET ^(0)="^69.29A^0^0"
- +2 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO CONT
- +3 KILL LRSAV
- DO K^LRU
- +4 if IOST?1"P-".E
- WRITE @IOF
- DO ^%ZISC
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +5 KILL %,DIR,DTOUT,DUOUT,DIRUT,X,Y
- +6 QUIT
- W WRITE !,LR("%")
- QUIT
- E KILL ^UTILITY($JOB)
- SET DIWR=IOM-5
- SET DIWL=5
- SET DIWF=LRS
- QUIT
- +1 ;
- EN SET LRQ=0
- SET X=^LR(LRDFN,0)
- if '$ORDER(^LR(LRDFN,84,0))
- QUIT
- DO ^LRUP
- +1 IF '$DATA(^LR(LRDFN,"AU"))
- LOCK +^LRO(69.2,LRAA,3,LRAN):5
- if '$TEST
- QUIT
- Begin DoDot:1
- +2 SET DIK="^LRO(69.2,LRAA,3,"
- SET DA=LRAN
- SET DA(1)=0
- +3 DO ^DIK
- KILL KA,DIK
- +4 LOCK -^LRO(69.2,LRAA,3,LRAN)
- End DoDot:1
- QUIT
- +5 SET X=^LR(LRDFN,"AU")
- SET LRAC=$PIECE(X,"^",6)
- SET LRM(2)=$PIECE(X,"^",7)
- +6 SET LRM(1)=$PIECE(X,"^",12)
- SET LRW(9)=$PIECE(X,"^",13)
- SET LRM(3)=$PIECE(X,"^",10)
- +7 SET Y=$PIECE(X,"^")
- SET LRH(2)=$EXTRACT(Y,2,3)
- DO D^LRU
- SET LRH(1)=Y
- +8 SET LRLLOC=$PIECE(X,"^",5)
- SET AGE=$PIECE(X,"^",9)
- +9 ;Define the service
- +10 SET Y=$PIECE(X,"^",8)
- SET C=$PIECE(^DD(63,14.5,0),U,3)
- +11 DO Y^DIQ
- SET LRSVC=Y
- +12 ;Define autopsy type
- +13 SET Y=$PIECE(X,"^",11)
- SET C=$PIECE(^DD(63,13.7,0),U,3)
- +14 DO Y^DIQ
- SET LRS(3)=Y
- +15 SET DA=LRDFN
- DO D^LRAUAW
- SET Y=LR(63,12)
- DO D^LRU
- SET LRH=Y
- SET X=LRM(1)
- +16 if X
- DO D^LRUA
- SET LRM(1)=X
- SET X=LRM(2)
- if X
- DO D^LRUA
- SET LRM(2)=X
- SET X=LRM(3)
- +17 if X
- DO D^LRUA
- SET LRM(3)=X
- +18 DO H
- if LR("Q")
- QUIT
- SET LR("F")=1
- +19 if LRH(1)=""
- WRITE !?20,"+*+* REPORT INCOMPLETE *+*+"
- +20 SET LRA=0
- FOR
- SET LRA=$ORDER(^LR(LRDFN,84,LRA))
- if 'LRA!(LR("Q"))
- QUIT
- Begin DoDot:1
- +21 SET LRB=^LR(LRDFN,84,LRA,0)
- +22 if $Y>(IOSL-13)
- DO FT
- DO H
- if LR("Q")
- QUIT
- +23 WRITE !!,"SUPPLEMENTARY REPORT DATE: "
- +24 SET Y=LRB
- DO D^LRU
- WRITE Y
- +25 if $Y>(IOSL-13)
- DO FT
- DO H
- if LR("Q")
- QUIT
- +26 if $PIECE($GET(^LR(LRDFN,84,LRA,2,0)),U,4)
- DO SUPA
- +27 DO WRT
- End DoDot:1
- +28 if LR("Q")
- QUIT
- DO FT
- QUIT
- WRT DO E
- SET LRC=0
- +1 ;464
- SET DIWF="X"
- +2 FOR LRZ=0:1
- SET LRC=$ORDER(^LR(LRDFN,84,LRA,1,LRC))
- if 'LRC!(LR("Q"))
- QUIT
- Begin DoDot:1
- +3 if $Y>(IOSL-13)
- DO FT
- DO H
- SET LR("F")=1
- if LR("Q")
- QUIT
- +4 SET X=^LR(LRDFN,84,LRA,1,LRC,0)
- if X["|TOP|"
- DO TOP
- DO ^DIWP
- End DoDot:1
- +5 if LR("Q")
- QUIT
- if LRZ
- DO ^DIWW
- +6 QUIT
- SUPA ;Print supplementary report audit information
- +1 WRITE !?14,"*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED*+*"
- +2 WRITE !,"(Added/Last modified: "
- +3 SET (A,B)=0
- FOR
- SET A=$ORDER(^LR(LRDFN,84,LRA,2,A))
- if 'A!(LR("Q"))
- QUIT
- Begin DoDot:1
- +4 SET B=A
- End DoDot:1
- +5 if LR("Q")
- QUIT
- +6 if '$DATA(^LR(LRDFN,84,LRA,2,B,0))
- QUIT
- +7 SET A=^(0)
- SET Y=+A
- SET LRSGN=" typed by "
- SET A2=$PIECE(A,"^",2)
- +8 IF $PIECE(A,"^",3)
- Begin DoDot:1
- +9 SET LRSGN=" signed by "
- SET A2=$PIECE(A,"^",3)
- SET Y=$PIECE(A,"^",4)
- End DoDot:1
- +10 SET A2=$SELECT($DATA(^VA(200,A2,0)):$PIECE(^(0),"^"),1:A2)
- +11 ;If supp rpt is released, display 'signed by' instead of 'typed by'
- +12 DO D^LRU
- WRITE Y,LRSGN,A2,")"
- +13 ;If RELEASE SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED"
- +14 IF $PIECE(^LR(LRDFN,84,LRA,0),"^",3)
- WRITE !,?25,"**-* NOT VERIFIED *-**"
- +15 if $DATA(LRQ(9))
- DO SUPM
- +16 QUIT
- SUPM ;Print previous versions of supplementary reports
- +1 ;This is used by menu option 'Print path modifications [LRAPMOD]'
- +2 ;
- +3 SET A=0
- FOR
- SET A=$ORDER(^LR(LRDFN,84,LRA,2,A))
- if 'A!(LR("Q"))
- QUIT
- Begin DoDot:1
- +4 SET LRT=^LR(LRDFN,84,LRA,2,A,0)
- +5 if $Y>(IOSL-13)
- DO FT
- DO H
- if LR("Q")
- QUIT
- +6 SET Y=+LRT
- SET Y2="modified: "
- SET X=$PIECE(LRT,"^",2)
- SET LRSGN=" typed by "
- +7 ;If supp rpt is released, display 'signed by' instead of 'typed by'
- +8 IF $PIECE(LRT,"^",3)
- SET LRSGN=" signed by"
- SET X=$PIECE(LRT,"^",3)
- SET Y=$PIECE(LRT,"^",4)
- SET Y2="released: "
- +9 SET X=$SELECT($DATA(^VA(200,X,0)):$PIECE(^(0),"^"),1:X)
- +10 DO D^LRU
- WRITE !,"Date ",Y2,Y,LRSGN,X
- +11 KILL ^UTILITY($JOB)
- SET DIWR=IOM-5
- SET DIWL=5
- SET DIWF="W"
- +12 SET B=0
- +13 FOR LRZ=0:1
- SET B=$ORDER(^LR(LRDFN,84,LRA,2,A,1,B))
- if 'B!(LR("Q"))
- QUIT
- Begin DoDot:2
- +14 SET LRT=^LR(LRDFN,84,LRA,2,A,1,B,0)
- +15 if $Y>(IOSL-13)
- DO FT
- DO H
- if LR("Q")
- QUIT
- +16 SET X=LRT
- DO ^DIWP
- End DoDot:2
- +17 if LR("Q")
- QUIT
- if LRZ
- DO ^DIWW
- End DoDot:1
- +18 if LR("Q")
- QUIT
- +19 WRITE !?13,"==========Text below appears on final report=========="
- +20 QUIT
- H ;Header
- +1 IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO CONT
- if LR("Q")
- QUIT
- +2 if ($DATA(LR("F")))
- WRITE @IOF
- +3 SET LRQ=LRQ+1
- +4 ;W:IOST?1"C".E!(IOST'?1"C".E&('$D(LRFLG))) @IOF,!
- +5 ;K LRFLG
- +6 WRITE !
- DO W
- +7 WRITE !?5,"CLINICAL RECORD |",?40,"AUTOPSY SUPPLEMENTARY REPORT"
- +8 WRITE ?73,"Pg ",LRQ,!,LR("%")
- +9 WRITE !,"Date died: ",LRH,?40,"| Autopsy date: ",LRH(1)
- +10 WRITE !,"Resident: ",LRM(2),?40,"| ",LRS(3)
- +11 WRITE ?56,"Autopsy No. ",$SELECT(LRQ(8)]"":LRQ(8)_LRH(2)_" "_LRAC,1:LRAC)
- +12 WRITE !,LR("%")
- +13 QUIT
- FT ;Footer
- +1 if LR("Q")
- QUIT
- +2 IF IOSL'>66
- FOR
- if $Y>(IOSL-13)
- QUIT
- WRITE !
- +3 DO W
- WRITE !!,"Pathologist: ",LRM(3),?52,LRW(9),?55,"| Date ",$EXTRACT(LRH(3),1,12)
- +4 DO W
- WRITE !,LRQ(1),?(IOM-30),"AUTOPSY SUPPLEMENTARY REPORT"
- +5 WRITE !,$EXTRACT(LRP,1,30),?31,SSN,?49,"SEX:",SEX,?55,"DOB:",DOB,!,LRLLOC
- +6 WRITE ?31,LRM(1),?55,"AGE AT DEATH: ",AGE
- +7 QUIT
- SGL ;Entry point for printing single report
- +1 SET X=""
- DO ^LRUPS
- if LRAN="?"
- GOTO SGL
- if LRAN=-1
- QUIT
- +2 IF $DATA(LR("AU1"))
- IF '$PIECE(^LR(LRDFN,"AU"),U,15)
- Begin DoDot:1
- +3 WRITE $CHAR(7),!!,"Report not verified."
- End DoDot:1
- QUIT
- +4 DO SPC
- if X=""!(X[U)
- QUIT
- +5 SET LRAP=LRDFN
- SET LRSAV=1
- +6 DO EN2^LRUA
- +7 GOTO DEV
- 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 SUPPLEMENTARY REPORT list "
- +2 SET %=2
- DO YN^LRU
- +3 IF %=1
- KILL ^LRO(69.2,LRAA,3)
- SET ^LRO(69.2,LRAA,3,0)="^69.29A^0^0"
- Begin DoDot:1
- +4 WRITE $CHAR(7),!,"LIST DELETED !",!
- End DoDot:1
- QUIT
- +5 WRITE !!,"OK, LET'S FORGET IT.",!
- +6 QUIT
- TOP SET Z=$PIECE(X,"|TOP|",1)_$PIECE(X,"|TOP|",2)
- +1 DO FT
- DO H
- SET X=Z
- SET LR("F")=1
- +2 QUIT