- 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 Mar 13, 2025@21:11:13 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
