LRAPAUA.m

LRAPAUA ; IHS/DIR/AAB - AUTOPSY LIST 2/9/98 10:26 ; [ 07/08/1998 9:43 AM ]

 ;;5.2;LR;**1002,1006**;SEP 01, 1998

 ;

 ;;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))

 I $L(LRP),LRDFN S ^TMP($J,LRP,LRDFN)=HRCN_"^"_+Z_"^"_LRAC_"^"_$S(P(0)="PATIENT":"",1:P(0))  ;IHS/ANMC/CLS 11/1/95

 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

 D F^LRU W !,LRO(68)," list from ",LRSTR," to ",LRLST,!,"Patient",?35,"HRCN",?46,"Autopsy#",?58,"Autopsy Date",!,LR("%") Q  ;IHS/ANMC/CLS 11/1/95

 ;

END K LRAUDT D V^LRU Q

LRAPAUA   ; IHS/DIR/AAB - AUTOPSY LIST 2/9/98 10:26 ; [ 07/08/1998 9:43 AM ]

 +1       ;;5.2;LR;**1002,1006**;SEP 01, 1998

 +2       ;

 +3       ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994

 +4        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       ;I $L(LRP),LRDFN S ^TMP($J,LRP,LRDFN)=SSN_"^"_+Z_"^"_LRAC_"^"_$S(P(0)="PATIENT":"",1:P(0))

 +2       ;IHS/ANMC/CLS 11/1/95

           IF $LENGTH(LRP)

               IF LRDFN

                   SET ^TMP($JOB,LRP,LRDFN)=HRCN_"^"_+Z_"^"_LRAC_"^"_$SELECT(P(0)="PATIENT":"",1:P(0))

 +3        QUIT 

 +4       ;

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       ;D F^LRU W !,LRO(68)," list from ",LRSTR," to ",LRLST,!,"Patient",?35,"SSN",?46,"Autopsy#",?58,"Autopsy Date",!,LR("%") Q

 +2       ;IHS/ANMC/CLS 11/1/95

           DO F^LRU

           WRITE !,LRO(68)," list from ",LRSTR," to ",LRLST,!,"Patient",?35,"HRCN",?46,"Autopsy#",?58,"Autopsy Date",!,LR("%")

           QUIT 

 +3       ;

END        KILL LRAUDT

           DO V^LRU

           QUIT