Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRAURPT

LRAURPT.m

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