- 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),"^")
- Q
- 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