Routine: LRAUSTA

LRAUSTA ;AVAMC/REG/CYM - AUTOPSY STATUS LIST ;3/11/98  10:27 ;

 ;;5.2;LAB SERVICE;**134,201**;Sep 27, 1994

 S LRDICS="AU" D ^LRAP G:'$D(Y) END W !!,LRO(68)," STATUS LIST"

YR W ! S %DT="AE",%DT(0)="-N",%DT("A")="Select year: " D ^%DT K %DT G:Y<0 END S H(1)=$E(Y,1,3) D XR^LRU I '$O(^LR(LRXREF,H(1),LRABV,0)) W $C(7),!!,"No entries for ",LRO(68)," (",LRABV,") in ",H(1)+1700 G YR

N1 R !,"Start with Acc #: ",N(1):DTIME G:N(1)=""!(N(1)[U) END I N(1)'?1N.N W $C(7),!!,"NUMBERS ONLY !!" G N1

N2 R !,"Go    to   Acc #: LAST // ",N(2):DTIME G:'$T!(N(2)[U) END S:N(2)="" N(2)=999999 I N(2)'?1N.N W $C(7),!!,"NUMBERS ONLY !!",!! G N2

 I N(2)<N(1) S X=N(2),N(1)=N(2),N(2)=X

DEV S ZTRTN="QUE^LRAUSTA" D BEG^LRUTL G:POP!($D(ZTSK)) END

QUE U IO S N(1)=N(1)-1 D L^LRU,S^LRU,H S LR("F")=1

 F Z=N(1):0 S Z=$O(^LR(LRXREF,H(1),LRABV,Z)) Q:'Z!(Z>N(2))!(LR("Q"))  S I=+$O(^(Z,0)) D WRT

 D END^LRUTL,END Q

FIX S X=$$Y2K^LRX(X,"5D") Q

WRT Q:'$D(^LR(I,"AU"))  S W=^("AU"),LRSENIOR=$P(W,"^",10),LRESIDEN=$P(W,"^",7),LRLLOC=$E($P(W,"^",5),1,5),P=^LR(I,0)

 S P(1)=^DIC($P(P,"^",2),0,"GL"),P=$P(P,"^",3),P=@(P(1)_P_",0)"),P(9)=$E($P(P,"^",9),6,9),P=$E($P(P,"^"),1,19)

 S X=$P(W,"^") D FIX S LRAUDT=X,X=$P(W,"^",3) D FIX S LRAUCOMP=X,X=$P(W,"^",4) D FIX S LRFAD=X,X=$P(W,"^",17) D FIX S LRPAD=X

 D:$Y>(IOSL-7) H Q:LR("Q")  W !!,$P(W,"^",6),?10,$E(P,1,14),?25,P(9),?30,LRLLOC,?36,$J(LRAUDT,8),?47,$J(LRPAD,8),?58,$J(LRFAD,8),?69,$J(LRAUCOMP,8)

 I LRSENIOR,$D(^VA(200,LRSENIOR,0)) W !?36,$P(^(0),"^")

 I LRESIDEN,$D(^VA(200,LRESIDEN,0)) W !?36,$P(^(0),"^")

H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")

 D F^LRU W !,LRABV," Autopsy Status List",?36,"|--------------- Date --------------|",!,"Acc#",?12,"Patient",?25,"ID",?30,"Loc",?36,"Autopsy",?49,"PAD",?59,"FAD",?68,"Completed",!?36,"Pathologist(s)",!,LR("%") Q

END K LRSENIOR,LRESIDEN,LRAUDT,LRAUCOMP,LRFAD,LRPAD D V^LRU Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAUSTA   1876     printed  Feb 18, 2025@23:35:42                                                                                                                                                                                                     Page 2

LRAUSTA   ;AVAMC/REG/CYM - AUTOPSY STATUS LIST ;3/11/98  10:27 ;

 +1       ;;5.2;LAB SERVICE;**134,201**;Sep 27, 1994

 +2        SET LRDICS="AU"

           DO ^LRAP

           if '$DATA(Y)

               GOTO END

           WRITE !!,LRO(68)," STATUS LIST"

YR         WRITE !

           SET %DT="AE"

           SET %DT(0)="-N"

           SET %DT("A")="Select year: "

           DO ^%DT

           KILL %DT

           if Y<0

               GOTO END

           SET H(1)=$EXTRACT(Y,1,3)

           DO XR^LRU

           IF '$ORDER(^LR(LRXREF,H(1),LRABV,0))

               WRITE $CHAR(7),!!,"No entries for ",LRO(68)," (",LRABV,") in ",H(1)+1700

               GOTO YR

N1         READ !,"Start with Acc #: ",N(1):DTIME

           if N(1)=""!(N(1)[U)

               GOTO END

           IF N(1)'?1N.N

               WRITE $CHAR(7),!!,"NUMBERS ONLY !!"

               GOTO N1

N2         READ !,"Go    to   Acc #: LAST // ",N(2):DTIME

           if '$TEST!(N(2)[U)

               GOTO END

           if N(2)=""

               SET N(2)=999999

           IF N(2)'?1N.N

               WRITE $CHAR(7),!!,"NUMBERS ONLY !!",!!

               GOTO N2

 +1        IF N(2)<N(1)

               SET X=N(2)

               SET N(1)=N(2)

               SET N(2)=X

DEV        SET ZTRTN="QUE^LRAUSTA"

           DO BEG^LRUTL

           if POP!($DATA(ZTSK))

               GOTO END

QUE        USE IO

           SET N(1)=N(1)-1

           DO L^LRU

           DO S^LRU

           DO H

           SET LR("F")=1

 +1        FOR Z=N(1):0

               SET Z=$ORDER(^LR(LRXREF,H(1),LRABV,Z))

               if 'Z!(Z>N(2))!(LR("Q"))

                   QUIT

               SET I=+$ORDER(^(Z,0))

               DO WRT

 +2        DO END^LRUTL

           DO END

           QUIT

FIX        SET X=$$Y2K^LRX(X,"5D")

           QUIT

WRT        if '$DATA(^LR(I,"AU"))

               QUIT

           SET W=^("AU")

           SET LRSENIOR=$PIECE(W,"^",10)

           SET LRESIDEN=$PIECE(W,"^",7)

           SET LRLLOC=$EXTRACT($PIECE(W,"^",5),1,5)

           SET P=^LR(I,0)

 +1        SET P(1)=^DIC($PIECE(P,"^",2),0,"GL")

           SET P=$PIECE(P,"^",3)

           SET P=@(P(1)_P_",0)")

           SET P(9)=$EXTRACT($PIECE(P,"^",9),6,9)

           SET P=$EXTRACT($PIECE(P,"^"),1,19)

 +2        SET X=$PIECE(W,"^")

           DO FIX

           SET LRAUDT=X

           SET X=$PIECE(W,"^",3)

           DO FIX

           SET LRAUCOMP=X

           SET X=$PIECE(W,"^",4)

           DO FIX

           SET LRFAD=X

           SET X=$PIECE(W,"^",17)

           DO FIX

           SET LRPAD=X

 +3        if $Y>(IOSL-7)

               DO H

           if LR("Q")

               QUIT

           WRITE !!,$PIECE(W,"^",6),?10,$EXTRACT(P,1,14),?25,P(9),?30,LRLLOC,?36,$JUSTIFY(LRAUDT,8),?47,$JUSTIFY(LRPAD,8),?58,$JUSTIFY(LRFAD,8),?69,$JUSTIFY(LRAUCOMP,8)

 +4        IF LRSENIOR

               IF $DATA(^VA(200,LRSENIOR,0))

                   WRITE !?36,$PIECE(^(0),"^")

 +5        IF LRESIDEN

               IF $DATA(^VA(200,LRESIDEN,0))

                   WRITE !?36,$PIECE(^(0),"^")

 +6        QUIT

H          IF $DATA(LR("F"))

               IF IOST?1"C".E

                   DO M^LRU

                   if LR("Q")

                       QUIT

 +1        DO F^LRU

           WRITE !,LRABV," Autopsy Status List",?36,"|--------------- Date --------------|",!,"Acc#",?12,"Patient",?25,"ID",?30,"Loc",?36,"Autopsy",?49,"PAD",?59,"FAD",?68,"Completed",!?36,"Pathologist(s)",!,LR("%")

           QUIT

 +2       ;

END        KILL LRSENIOR,LRESIDEN,LRAUDT,LRAUCOMP,LRFAD,LRPAD

           DO V^LRU

           QUIT

LRAUSTA.m