LRAPAUA ;AVAMC/REG/CYM - AUTOPSY LIST ; 2/9/98 10:26 ;
;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
S LRDICS="AU" D ^LRAP G:'$D(Y) END D XR^LRU,B^LRU G:Y<0 END S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99,ZTRTN="QUE^LRAPAUA" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) D L^LRU,S^LRU,H S LR("F")=1
F LRSDT=LRSDT:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN D SET
D W,END^LRUTL,END Q
SET Q:'$D(^LR(LRDFN,"AU"))!('$D(^(0))#2) S Z=^("AU"),LRAC=$P(Z,U,6) Q:$P(LRAC," ")'=LRABV S X=^(0),DFN=$P(X,"^",3),(LRDPF,X)=+$P(X,"^",2) Q:'X S P(0)=$P(^DIC(X,0),"^"),X=^DIC(X,0,"GL") D PT^LRX Q:$G(VAERR) S LRP=PNM
I $L(LRP),LRDFN S ^TMP($J,LRP,LRDFN)=SSN_"^"_+Z_"^"_LRAC_"^"_$S(P(0)="PATIENT":"",1:P(0))
Q
;
W S LRP="" F A=0:0 S LRP=$O(^TMP($J,LRP)) Q:LRP=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^TMP($J,LRP,LRDFN)) Q:'LRDFN!(LR("Q")) S LRX=^(LRDFN) D:$Y>(IOSL-6) H Q:LR("Q") D W1
Q
W1 S LRAUDT=$P(LRX,"^",2),LRAUDT=$P(LRAUDT,".") W !,LRP,?31,$P(LRX,"^"),?46,$P(LRX,"^",3),?58,$$Y2K^LRX(LRAUDT),?70,$E($P(LRX,"^",4),1,10) Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,LRO(68)," list from ",LRSTR," to ",LRLST,!,"Patient",?35,"SSN",?46,"Autopsy#",?58,"Autopsy Date",!,LR("%") Q
;
END K LRAUDT D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPAUA 1291 printed Dec 13, 2024@02:06:52 Page 2
LRAPAUA ;AVAMC/REG/CYM - AUTOPSY LIST ; 2/9/98 10:26 ;
+1 ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
+2 SET LRDICS="AU"
DO ^LRAP
if '$DATA(Y)
GOTO END
DO XR^LRU
DO B^LRU
if Y<0
GOTO END
SET LRSDT=LRSDT-.01
SET LRLDT=LRLDT+.99
SET ZTRTN="QUE^LRAPAUA"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
DO L^LRU
DO S^LRU
DO H
SET LR("F")=1
+1 FOR LRSDT=LRSDT:0
SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
if 'LRSDT!(LRSDT>LRLDT)
QUIT
FOR LRDFN=0:0
SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))
if 'LRDFN
QUIT
DO SET
+2 DO W
DO END^LRUTL
DO END
QUIT
SET if '$DATA(^LR(LRDFN,"AU"))!('$DATA(^(0))#2)
QUIT
SET Z=^("AU")
SET LRAC=$PIECE(Z,U,6)
if $PIECE(LRAC," ")'=LRABV
QUIT
SET X=^(0)
SET DFN=$PIECE(X,"^",3)
SET (LRDPF,X)=+$PIECE(X,"^",2)
if 'X
QUIT
SET P(0)=$PIECE(^DIC(X,0),"^")
SET X=^DIC(X,0,"GL")
DO PT^LRX
if $GET(VAERR)
QUIT
SET LRP=PNM
+1 IF $LENGTH(LRP)
IF LRDFN
SET ^TMP($JOB,LRP,LRDFN)=SSN_"^"_+Z_"^"_LRAC_"^"_$SELECT(P(0)="PATIENT":"",1:P(0))
+2 QUIT
+3 ;
W SET LRP=""
FOR A=0:0
SET LRP=$ORDER(^TMP($JOB,LRP))
if LRP=""!(LR("Q"))
QUIT
FOR LRDFN=0:0
SET LRDFN=$ORDER(^TMP($JOB,LRP,LRDFN))
if 'LRDFN!(LR("Q"))
QUIT
SET LRX=^(LRDFN)
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
DO W1
+1 QUIT
W1 SET LRAUDT=$PIECE(LRX,"^",2)
SET LRAUDT=$PIECE(LRAUDT,".")
WRITE !,LRP,?31,$PIECE(LRX,"^"),?46,$PIECE(LRX,"^",3),?58,$$Y2K^LRX(LRAUDT),?70,$EXTRACT($PIECE(LRX,"^",4),1,10)
QUIT
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,LRO(68)," list from ",LRSTR," to ",LRLST,!,"Patient",?35,"SSN",?46,"Autopsy#",?58,"Autopsy Date",!,LR("%")
QUIT
+2 ;
END KILL LRAUDT
DO V^LRU
QUIT
