- LRAURPT ;AVAMC/REG/WTY - AUTOPSY RPT ;9/22/00
- ;;5.2;LAB SERVICE;**1,72,173,248,259,464**;Sep 27, 1994;Build 12
- ;
- ;Reference to ^DD(63 supported by IA #10155
- ;WTY;24-AUG-01;Added ICD to the print coding question
- ;
- N LRPTR,LREL
- W !!,LRO(68)," Autopsy Protocols" D XR^LRU,EN2^LRUA S LRD("V")=""
- G END:LRAPX=2,SGL:LRAPX=3,CH:LRAPX=4
- L +^LRO(69.2,LRAA,2):5
- I '$T D EN^DDIOL("Someone else is building a print queue for this Accession Area","","$C(7),!!") 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,2) Q
- G:$D(^LRO(69.2,LRAA,2,LRAN,0)) GETP
- S FDAIEN(2)=LRAN
- S FDA(2,69.23,"+2,"_+LRAA_",",.01)=LRDFN
- D UPDATE^DIE("","FDA(2)","FDAIEN") K FDAIEN G GETP
- CH ;Check Queue
- I '$O(^LRO(69.2,LRAA,2,0)) D Q
- .W $C(7),!!,"No AUTOPSY PROTOCOLS currently on the print queue.",!!
- ;Variable LR("DVD") is used to divide reports displayed in the browser
- K LR("DVD")
- S $P(LR("DVD"),"|",IOM)=""
- SPC ;Spacing
- I LRAPX=4 D
- .W !!,"The following two questions apply only to reports not stored in "
- .W "TIU."
- .W !,"If the report is stored in TIU it will be printed in its "
- .W "original format.",!
- 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 "
- .W "spacing of reports"
- S LRS=$S(X="D":"D",1:"")_"W"
- W !!,"Print special studies, journal references, weights, and "
- W "measures: "
- S %=1 D YN^LRU Q:%<1 S:%=1 LRD=1
- Q:LRAPX=3
- W !!,"Save protocol list for reprinting "
- S %=2 D YN^LRU S:%=1 LRSAV=1
- DEV ;Device Handling
- S %ZIS="Q" D ^%ZIS
- I POP W ! S LR("Q")=1 Q
- I $D(IO("Q")) D Q
- .S ZTDESC="Print AU Anat Path Reports"
- .S ZTSAVE("LR*")="",ZTRTN="QUE^LRAURPT"
- .D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !
- .K ZTSK,IO("Q") D HOME^%ZIS
- .S LR("Q")=1
- QUE ;
- U IO D L^LRU,S^LRU,EN^LRUA
- N LRFFF
- S LRQUIT=0,LR("Q")=+$G(LR("Q"))
- ;LRSF515=1 means an SF515 is being generated.
- S:'$D(LRSF515) LRSF515=0
- S:'$D(LRFOC) LRFOC=0 ;Final office copy
- S LRFFF=1 ;Flag used to determine whether to perform final form feed
- I LRFOC S LRFFF=0 ;If final office copy, don't perform final form feed
- S LR(.21)=+$G(^LRO(69.2,LRAA,.2)),(LRS(5),LRAURPT)=1
- PSGL ;Single Report
- I $D(LRAP) D G LST
- .S LRDFN=LRAP
- .I +$G(LRPTR) D Q
- ..D:$D(LR("AU1")) EN
- ..Q:LR("Q")
- ..D MAIN^LRAPTIUP(LRPTR,0)
- ..S LRFFF=0 ;Don't do final form feed. It's done by LRAPTIUP.
- ..I LRQUIT S LR("Q")=1 Q
- ..K LRAP S LR("F")=1
- ..I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT
- ..Q:LR("Q")
- ..I 'LRFOC S LR("Q")=1 Q
- ..S LRI="" D FOC^LRSPRPT
- ..I LRQUIT S LR("Q")=1 Q
- ..I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT
- .D EN
- .K LRAP
- .I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT
- .Q:LR("Q")
- .I 'LRFOC S LR("Q")=1 Q
- .W !
- .W:IOST?1"P-".E @IOF
- .S LRI="" D FOC^LRSPRPT
- .I LRQUIT S LR("Q")=1 Q
- .I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT
- PQUE ;Print all on queue
- S LRAN=0
- F S LRAN=$O(^LRO(69.2,LRAA,2,LRAN)) Q:'LRAN!(LR("Q")) D
- .S (LRQUIT,LRQ)=0
- .I 'LRFOC S LRFFF=1
- .K LR("F")
- .S LRDFN=+^LRO(69.2,LRAA,2,LRAN,0)
- .D RELEASE^LRAPUTL(.LREL,LRDFN,LRSS)
- .I +$G(LREL(1)) D
- ..D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS)
- .I +$G(LRPTR) D Q
- ..D MAIN^LRAPTIUP(LRPTR,0)
- ..S LRFFF=0
- ..W:IOST["BROWSER"&('LRFOC) !!,LR("DVD")
- ..K LRPTR
- ..I LRQUIT S LR("Q")=1 Q
- ..S LR("F")=1
- ..I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT
- ..Q:LR("Q")!('LRFOC)
- ..D FOC^LRSPRPT
- ..W:IOST["BROWSER" !!,LR("DVD")
- ..I LRQUIT S LR("Q")=1 Q
- ..I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
- .W:IOST?1"C-".E @IOF
- .D EN
- .W:IOST?1"P-".E @IOF
- .W:IOST["BROWSER"&('LRFOC) !!,LR("DVD")
- .I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT
- .Q:LR("Q")!('LRFOC)
- .W !
- .D FOC^LRSPRPT
- .W:IOST["BROWSER" !!,LR("DVD")
- .I LRQUIT S LR("Q")=1 Q
- .I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
- S LRFFF=0
- LST ;
- K:'$D(LRSAV) ^LRO(69.2,LRAA,2) K LRAURPT
- S:'$D(^LRO(69.2,LRAA,2,0)) ^(0)="^69.23A^0^0"
- K LRSAV D K^LRU
- D:'$D(LR("AU1")) DEVEND
- Q
- W ;
- W !,LR("%")
- Q
- F D E
- S A=0 F LRZ=0:1 S A=$O(^LR(LRDFN,LRV,A)) Q:'A!(LR("Q")) D
- .D:$Y>(IOSL-12) FT,H Q:LR("Q")
- .S X=^LR(LRDFN,LRV,A,0) D:X["|TOP|" TOP D ^DIWP
- Q:LR("Q") D:LRZ ^DIWW Q
- E K ^UTILITY($J) S DIWR=IOM-5,DIWL=5,DIWF=LRS
- Q
- EN ;
- S LR("SPSM")=1 ;Set this flag to suppress SNOMED codes
- S LRQ=0,X=^LR(LRDFN,0) D ^LRUP
- I '$D(^LR(LRDFN,"AU")) L +^LRO(69.2,LRAA,2,LRAN):5 Q:'$T D Q
- .S DIK="^LRO(69.2,LRAA,2,",DA=LRAN,DA(1)=0
- .D ^DIK K DA,DIK
- .L -^LRO(69.2,LRAA,2,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,Y=$P(X,"^",3) D D^LRU
- S LRH(3)=Y,Y=$P(X,"^",17) D D^LRU S LRH(17)=Y
- S LRLLOC=$P(X,"^",5),AGE=$P(X,"^",9)
- S Y=$P(X,"^",8),C=$P(^DD(63,14.5,0),U,3)
- D Y^DIQ S LRSVC=Y
- 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
- Q:+$G(LRPTR)
- D H Q:LR("Q") S LR("F")=1
- W:LRH(1)="" !?20,"**** REPORT INCOMPLETE ****",!
- W !!,LRAU(1),! S LRV=81 D F
- D:$Y>(IOSL-12) FT,H Q:LR("Q") W !!,LR("%")
- W !,LRAU(2),! S LRV=82 D F
- I $O(^LR(LRDFN,84,0)),LR(.21) D FT,H Q:LR("Q")
- 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-12) FT,H Q:LR("Q")
- .W !!,"SUPPLEMENTARY REPORT DATE: "
- .S Y=LRB D D^LRU W Y
- .D:$P($G(^LR(LRDFN,84,LRA,2,0)),U,4) SUPA^LRAPAUSR
- .D WRT
- Q:LR("Q")
- D:$G(LRD) ^LRAPT2
- 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-12) FT,H 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
- H ;
- Q:LR("Q")
- I $D(LR("F")),IOST?1"C".E D CONT Q:LR("Q")
- S LRQ=LRQ+1
- W:($D(LR("F"))) @IOF
- W !! D W
- W !?5,"CLINICAL RECORD |",?40,"AUTOPSY PROTOCOL",?73,"Pg ",LRQ
- W !,LR("%")
- W !,"Date died: ",LRH,?40,"| Autopsy date: ",LRH(1)
- W !,"Resident: ",LRM(2),?40,"| ",$E(LRS(3),1,13)
- 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-12) W !
- D W W !
- W:LRH(3)=""&(LRH(17)]"") ?55,"| Provisional Anatomic Dx"
- W !,"Pathologist: ",LRM(3),?52,LRW(9),?55,"| Date "
- W $E($S(LRH(3)]"":LRH(3),1:LRH(17)),1,12)
- D W W !,LRQ(1),?IOM-17,"AUTOPSY PROTOCOL"
- W !,"Patient: ",$E(LRP,1,30),?43,SSN,?56,"SEX:",SEX,?63,"DOB:",DOB
- W !,$E(LRLLOC,1,22),?23,"Physician: ",$E(LRM(1),1,28)
- W ?63,"AGE AT DEATH:",$J(AGE,3)
- Q
- SGL ;Print single report entry point
- K LRD("V") S X="" D ^LRUPS G:LRAN="?" SGL Q:LRAN=-1
- D RELEASE^LRAPUTL(.LREL,LRDFN,LRSS)
- I $D(LR("AU1")),'+$G(LREL(1)) D Q
- .W $C(7),!!,"Report not verified." S LR("AU1")=2
- I +$G(LREL(1)) D
- .D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS)
- I $D(LR("AU1"))!(+$G(LRPTR)) S LRS="W",LRD=1
- E D SPC Q:X=""!(X[U)
- D EN2^LRUA
- S LRAP=LRDFN,LRSAV=1
- G DEV
- DEVEND ;Close device
- I IOST?1"P-".E W:LRFFF @IOF
- D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
- Q
- 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 PROTOCOL list "
- S %=2 D YN^LRU
- I %=1 D Q
- .K ^LRO(69.2,LRAA,2)
- .S ^LRO(69.2,LRAA,2,0)="^69.23A^0^0"
- .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
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAURPT 7559 printed Jan 18, 2025@03:10:27 Page 2
- LRAURPT ;AVAMC/REG/WTY - AUTOPSY RPT ;9/22/00
- +1 ;;5.2;LAB SERVICE;**1,72,173,248,259,464**;Sep 27, 1994;Build 12
- +2 ;
- +3 ;Reference to ^DD(63 supported by IA #10155
- +4 ;WTY;24-AUG-01;Added ICD to the print coding question
- +5 ;
- +6 NEW LRPTR,LREL
- +7 WRITE !!,LRO(68)," Autopsy Protocols"
- DO XR^LRU
- DO EN2^LRUA
- SET LRD("V")=""
- +8 if LRAPX=2
- GOTO END
- if LRAPX=3
- GOTO SGL
- if LRAPX=4
- GOTO CH
- +9 LOCK +^LRO(69.2,LRAA,2):5
- +10 IF '$TEST
- DO EN^DDIOL("Someone else is building a print queue for this Accession Area","","$C(7),!!")
- 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,2)
- QUIT
- +2 if $DATA(^LRO(69.2,LRAA,2,LRAN,0))
- GOTO GETP
- +3 SET FDAIEN(2)=LRAN
- +4 SET FDA(2,69.23,"+2,"_+LRAA_",",.01)=LRDFN
- +5 DO UPDATE^DIE("","FDA(2)","FDAIEN")
- KILL FDAIEN
- GOTO GETP
- CH ;Check Queue
- +1 IF '$ORDER(^LRO(69.2,LRAA,2,0))
- Begin DoDot:1
- +2 WRITE $CHAR(7),!!,"No AUTOPSY PROTOCOLS currently on the print queue.",!!
- End DoDot:1
- QUIT
- +3 ;Variable LR("DVD") is used to divide reports displayed in the browser
- +4 KILL LR("DVD")
- +5 SET $PIECE(LR("DVD"),"|",IOM)=""
- SPC ;Spacing
- +1 IF LRAPX=4
- Begin DoDot:1
- +2 WRITE !!,"The following two questions apply only to reports not stored in "
- +3 WRITE "TIU."
- +4 WRITE !,"If the report is stored in TIU it will be printed in its "
- +5 WRITE "original format.",!
- End DoDot:1
- +6 READ !,"(D)ouble or (S)ingle spacing of report(s): ",X:DTIME
- +7 if X=""!(X[U)
- QUIT
- +8 IF $EXTRACT(X)'="D"&($EXTRACT(X)'="S")
- Begin DoDot:1
- +9 WRITE $CHAR(7),!,"Enter 'S' for single or 'D' for double "
- +10 WRITE "spacing of reports"
- End DoDot:1
- GOTO SPC
- +11 SET LRS=$SELECT(X="D":"D",1:"")_"W"
- +12 WRITE !!,"Print special studies, journal references, weights, and "
- +13 WRITE "measures: "
- +14 SET %=1
- DO YN^LRU
- if %<1
- QUIT
- if %=1
- SET LRD=1
- +15 if LRAPX=3
- QUIT
- +16 WRITE !!,"Save protocol list for reprinting "
- +17 SET %=2
- DO YN^LRU
- if %=1
- SET LRSAV=1
- DEV ;Device Handling
- +1 SET %ZIS="Q"
- DO ^%ZIS
- +2 IF POP
- WRITE !
- SET LR("Q")=1
- QUIT
- +3 IF $DATA(IO("Q"))
- Begin DoDot:1
- +4 SET ZTDESC="Print AU Anat Path Reports"
- +5 SET ZTSAVE("LR*")=""
- SET ZTRTN="QUE^LRAURPT"
- +6 DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !,"Request Queued, #",ZTSK
- WRITE !
- +7 KILL ZTSK,IO("Q")
- DO HOME^%ZIS
- +8 SET LR("Q")=1
- End DoDot:1
- QUIT
- QUE ;
- +1 USE IO
- DO L^LRU
- DO S^LRU
- DO EN^LRUA
- +2 NEW LRFFF
- +3 SET LRQUIT=0
- SET LR("Q")=+$GET(LR("Q"))
- +4 ;LRSF515=1 means an SF515 is being generated.
- +5 if '$DATA(LRSF515)
- SET LRSF515=0
- +6 ;Final office copy
- if '$DATA(LRFOC)
- SET LRFOC=0
- +7 ;Flag used to determine whether to perform final form feed
- SET LRFFF=1
- +8 ;If final office copy, don't perform final form feed
- IF LRFOC
- SET LRFFF=0
- +9 SET LR(.21)=+$GET(^LRO(69.2,LRAA,.2))
- SET (LRS(5),LRAURPT)=1
- PSGL ;Single Report
- +1 IF $DATA(LRAP)
- Begin DoDot:1
- +2 SET LRDFN=LRAP
- +3 IF +$GET(LRPTR)
- Begin DoDot:2
- +4 if $DATA(LR("AU1"))
- DO EN
- +5 if LR("Q")
- QUIT
- +6 DO MAIN^LRAPTIUP(LRPTR,0)
- +7 ;Don't do final form feed. It's done by LRAPTIUP.
- SET LRFFF=0
- +8 IF LRQUIT
- SET LR("Q")=1
- QUIT
- +9 KILL LRAP
- SET LR("F")=1
- +10 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C-".E
- DO CONT
- +11 if LR("Q")
- QUIT
- +12 IF 'LRFOC
- SET LR("Q")=1
- QUIT
- +13 SET LRI=""
- DO FOC^LRSPRPT
- +14 IF LRQUIT
- SET LR("Q")=1
- QUIT
- +15 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C-".E
- DO CONT
- End DoDot:2
- QUIT
- +16 DO EN
- +17 KILL LRAP
- +18 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C-".E
- DO CONT
- +19 if LR("Q")
- QUIT
- +20 IF 'LRFOC
- SET LR("Q")=1
- QUIT
- +21 WRITE !
- +22 if IOST?1"P-".E
- WRITE @IOF
- +23 SET LRI=""
- DO FOC^LRSPRPT
- +24 IF LRQUIT
- SET LR("Q")=1
- QUIT
- +25 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C-".E
- DO CONT
- End DoDot:1
- GOTO LST
- PQUE ;Print all on queue
- +1 SET LRAN=0
- +2 FOR
- SET LRAN=$ORDER(^LRO(69.2,LRAA,2,LRAN))
- if 'LRAN!(LR("Q"))
- QUIT
- Begin DoDot:1
- +3 SET (LRQUIT,LRQ)=0
- +4 IF 'LRFOC
- SET LRFFF=1
- +5 KILL LR("F")
- +6 SET LRDFN=+^LRO(69.2,LRAA,2,LRAN,0)
- +7 DO RELEASE^LRAPUTL(.LREL,LRDFN,LRSS)
- +8 IF +$GET(LREL(1))
- Begin DoDot:2
- +9 DO TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS)
- End DoDot:2
- +10 IF +$GET(LRPTR)
- Begin DoDot:2
- +11 DO MAIN^LRAPTIUP(LRPTR,0)
- +12 SET LRFFF=0
- +13 if IOST["BROWSER"&('LRFOC)
- WRITE !!,LR("DVD")
- +14 KILL LRPTR
- +15 IF LRQUIT
- SET LR("Q")=1
- QUIT
- +16 SET LR("F")=1
- +17 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C-".E
- DO CONT
- +18 if LR("Q")!('LRFOC)
- QUIT
- +19 DO FOC^LRSPRPT
- +20 if IOST["BROWSER"
- WRITE !!,LR("DVD")
- +21 IF LRQUIT
- SET LR("Q")=1
- QUIT
- +22 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO CONT
- End DoDot:2
- QUIT
- +23 if IOST?1"C-".E
- WRITE @IOF
- +24 DO EN
- +25 if IOST?1"P-".E
- WRITE @IOF
- +26 if IOST["BROWSER"&('LRFOC)
- WRITE !!,LR("DVD")
- +27 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C-".E
- DO CONT
- +28 if LR("Q")!('LRFOC)
- QUIT
- +29 WRITE !
- +30 DO FOC^LRSPRPT
- +31 if IOST["BROWSER"
- WRITE !!,LR("DVD")
- +32 IF LRQUIT
- SET LR("Q")=1
- QUIT
- +33 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO CONT
- End DoDot:1
- +34 SET LRFFF=0
- LST ;
- +1 if '$DATA(LRSAV)
- KILL ^LRO(69.2,LRAA,2)
- KILL LRAURPT
- +2 if '$DATA(^LRO(69.2,LRAA,2,0))
- SET ^(0)="^69.23A^0^0"
- +3 KILL LRSAV
- DO K^LRU
- +4 if '$DATA(LR("AU1"))
- DO DEVEND
- +5 QUIT
- W ;
- +1 WRITE !,LR("%")
- +2 QUIT
- F DO E
- +1 SET A=0
- FOR LRZ=0:1
- SET A=$ORDER(^LR(LRDFN,LRV,A))
- if 'A!(LR("Q"))
- QUIT
- Begin DoDot:1
- +2 if $Y>(IOSL-12)
- DO FT
- DO H
- if LR("Q")
- QUIT
- +3 SET X=^LR(LRDFN,LRV,A,0)
- if X["|TOP|"
- DO TOP
- DO ^DIWP
- End DoDot:1
- +4 if LR("Q")
- QUIT
- if LRZ
- DO ^DIWW
- QUIT
- E KILL ^UTILITY($JOB)
- SET DIWR=IOM-5
- SET DIWL=5
- SET DIWF=LRS
- +1 QUIT
- EN ;
- +1 ;Set this flag to suppress SNOMED codes
- SET LR("SPSM")=1
- +2 SET LRQ=0
- SET X=^LR(LRDFN,0)
- DO ^LRUP
- +3 IF '$DATA(^LR(LRDFN,"AU"))
- LOCK +^LRO(69.2,LRAA,2,LRAN):5
- if '$TEST
- QUIT
- Begin DoDot:1
- +4 SET DIK="^LRO(69.2,LRAA,2,"
- SET DA=LRAN
- SET DA(1)=0
- +5 DO ^DIK
- KILL DA,DIK
- +6 LOCK -^LRO(69.2,LRAA,2,LRAN)
- End DoDot:1
- QUIT
- +7 SET X=^LR(LRDFN,"AU")
- SET LRAC=$PIECE(X,"^",6)
- SET LRM(2)=$PIECE(X,"^",7)
- +8 SET LRM(1)=$PIECE(X,"^",12)
- SET LRW(9)=$PIECE(X,"^",13)
- SET LRM(3)=$PIECE(X,"^",10)
- +9 SET Y=$PIECE(X,"^")
- SET LRH(2)=$EXTRACT(Y,2,3)
- DO D^LRU
- +10 SET LRH(1)=Y
- SET Y=$PIECE(X,"^",3)
- DO D^LRU
- +11 SET LRH(3)=Y
- SET Y=$PIECE(X,"^",17)
- DO D^LRU
- SET LRH(17)=Y
- +12 SET LRLLOC=$PIECE(X,"^",5)
- SET AGE=$PIECE(X,"^",9)
- +13 SET Y=$PIECE(X,"^",8)
- SET C=$PIECE(^DD(63,14.5,0),U,3)
- +14 DO Y^DIQ
- SET LRSVC=Y
- +15 SET Y=$PIECE(X,"^",11)
- SET C=$PIECE(^DD(63,13.7,0),U,3)
- +16 DO Y^DIQ
- SET LRS(3)=Y
- +17 SET DA=LRDFN
- DO D^LRAUAW
- SET Y=LR(63,12)
- DO D^LRU
- SET LRH=Y
- SET X=LRM(1)
- +18 if X
- DO D^LRUA
- SET LRM(1)=X
- SET X=LRM(2)
- +19 if X
- DO D^LRUA
- SET LRM(2)=X
- SET X=LRM(3)
- +20 if X
- DO D^LRUA
- SET LRM(3)=X
- +21 if +$GET(LRPTR)
- QUIT
- +22 DO H
- if LR("Q")
- QUIT
- SET LR("F")=1
- +23 if LRH(1)=""
- WRITE !?20,"**** REPORT INCOMPLETE ****",!
- +24 WRITE !!,LRAU(1),!
- SET LRV=81
- DO F
- +25 if $Y>(IOSL-12)
- DO FT
- DO H
- if LR("Q")
- QUIT
- WRITE !!,LR("%")
- +26 WRITE !,LRAU(2),!
- SET LRV=82
- DO F
- +27 IF $ORDER(^LR(LRDFN,84,0))
- IF LR(.21)
- DO FT
- DO H
- if LR("Q")
- QUIT
- +28 SET LRA=0
- FOR
- SET LRA=$ORDER(^LR(LRDFN,84,LRA))
- if 'LRA!(LR("Q"))
- QUIT
- Begin DoDot:1
- +29 SET LRB=^LR(LRDFN,84,LRA,0)
- if $Y>(IOSL-12)
- DO FT
- DO H
- if LR("Q")
- QUIT
- +30 WRITE !!,"SUPPLEMENTARY REPORT DATE: "
- +31 SET Y=LRB
- DO D^LRU
- WRITE Y
- +32 if $PIECE($GET(^LR(LRDFN,84,LRA,2,0)),U,4)
- DO SUPA^LRAPAUSR
- +33 DO WRT
- End DoDot:1
- +34 if LR("Q")
- QUIT
- +35 if $GET(LRD)
- DO ^LRAPT2
- +36 if LR("Q")
- QUIT
- +37 DO FT
- +38 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-12)
- DO FT
- DO H
- 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
- QUIT
- H ;
- +1 if LR("Q")
- QUIT
- +2 IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO CONT
- if LR("Q")
- QUIT
- +3 SET LRQ=LRQ+1
- +4 if ($DATA(LR("F")))
- WRITE @IOF
- +5 WRITE !!
- DO W
- +6 WRITE !?5,"CLINICAL RECORD |",?40,"AUTOPSY PROTOCOL",?73,"Pg ",LRQ
- +7 WRITE !,LR("%")
- +8 WRITE !,"Date died: ",LRH,?40,"| Autopsy date: ",LRH(1)
- +9 WRITE !,"Resident: ",LRM(2),?40,"| ",$EXTRACT(LRS(3),1,13)
- +10 WRITE ?56,"Autopsy No. ",$SELECT(LRQ(8)]"":LRQ(8)_LRH(2)_" "_LRAC,1:LRAC)
- +11 WRITE !,LR("%")
- +12 QUIT
- FT ;Footer
- +1 if LR("Q")
- QUIT
- +2 IF IOSL'>66
- FOR
- if $Y>(IOSL-12)
- QUIT
- WRITE !
- +3 DO W
- WRITE !
- +4 if LRH(3)=""&(LRH(17)]"")
- WRITE ?55,"| Provisional Anatomic Dx"
- +5 WRITE !,"Pathologist: ",LRM(3),?52,LRW(9),?55,"| Date "
- +6 WRITE $EXTRACT($SELECT(LRH(3)]"":LRH(3),1:LRH(17)),1,12)
- +7 DO W
- WRITE !,LRQ(1),?IOM-17,"AUTOPSY PROTOCOL"
- +8 WRITE !,"Patient: ",$EXTRACT(LRP,1,30),?43,SSN,?56,"SEX:",SEX,?63,"DOB:",DOB
- +9 WRITE !,$EXTRACT(LRLLOC,1,22),?23,"Physician: ",$EXTRACT(LRM(1),1,28)
- +10 WRITE ?63,"AGE AT DEATH:",$JUSTIFY(AGE,3)
- +11 QUIT
- SGL ;Print single report entry point
- +1 KILL LRD("V")
- SET X=""
- DO ^LRUPS
- if LRAN="?"
- GOTO SGL
- if LRAN=-1
- QUIT
- +2 DO RELEASE^LRAPUTL(.LREL,LRDFN,LRSS)
- +3 IF $DATA(LR("AU1"))
- IF '+$GET(LREL(1))
- Begin DoDot:1
- +4 WRITE $CHAR(7),!!,"Report not verified."
- SET LR("AU1")=2
- End DoDot:1
- QUIT
- +5 IF +$GET(LREL(1))
- Begin DoDot:1
- +6 DO TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS)
- End DoDot:1
- +7 IF $DATA(LR("AU1"))!(+$GET(LRPTR))
- SET LRS="W"
- SET LRD=1
- +8 IF '$TEST
- DO SPC
- if X=""!(X[U)
- QUIT
- +9 DO EN2^LRUA
- +10 SET LRAP=LRDFN
- SET LRSAV=1
- +11 GOTO DEV
- DEVEND ;Close device
- +1 IF IOST?1"P-".E
- if LRFFF
- WRITE @IOF
- +2 DO ^%ZISC
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +3 QUIT
- 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 PROTOCOL list "
- +2 SET %=2
- DO YN^LRU
- +3 IF %=1
- Begin DoDot:1
- +4 KILL ^LRO(69.2,LRAA,2)
- +5 SET ^LRO(69.2,LRAA,2,0)="^69.23A^0^0"
- +6 WRITE $CHAR(7),!,"LIST DELETED !",!
- End DoDot:1
- QUIT
- +7 WRITE !!,"OK, LET'S FORGET IT.",!
- +8 QUIT
- TOP ;
- +1 SET Z=$PIECE(X,"|TOP|",1)_$PIECE(X,"|TOP|",2)
- +2 DO FT
- DO H
- SET X=Z
- +3 QUIT