LRAUMLK ;VAMC 695/MLK - AUTOPSY SLIDE LABELS;1/21/91 ;5/31/96 08:29
;;5.2;LAB SERVICE;**72**;Sep 27, 1994
;
S LRDICS="AU" D ^LRAP G:'$D(Y) END D XR^LRU W !!?25,"Autopsy Slide Labels"
ASK ;SECTION WITH INPUTS
S %DT="",X="T" D ^%DT S LRY=$E(Y,1,3),LR(5)=LRY+1700 W !,"Enter year: ",LR(5),"// " R X:DTIME G:'$T!(X[U) END S:X="" X=LR(5)
S %DT="EQ" D ^%DT G:Y<1 ASK S LR(2)=$E(Y,1,3) W " ",LR(2)+1700
R R !!,"Enter Autopsy Case number: ",X:DTIME G:X=""!(X[U) END S LR(3)=X I +X'=X D HELP G R
I '$D(^LR(LRXREF,LR(2),LRABV,LR(3))) W $C(7),!!,"Autopsy not entered",! G R
R1 W !,"Want labels for whole case" S %=1 D YN^DICN I '%!(%=0) W " Answer 'Y' or 'N'" G R1
G:%<0 END I %=2 S J=0,WR=1 G ADDL
R2 R !,"Enter total number of blocks :",BLKS:DTIME G:'$T!BLKS=""!(BLKS["^") END I +BLKS'=BLKS D HELP G R2
SET S WR=BLKS\6 F I=0:1:(WR-1) F J=1:1:6 S ^TMP($J,I+1,J)=(I*6+J)_"^"_"H & E"
I BLKS#6=0 S WR=WR+1,J=0 G ADDL
F J=1:1:BLKS#6 S ^TMP($J,WR+1,J)=WR*6+J_"^"_"H & E"
S WR=WR+1
ADDL W !,"Want to enter additional stains :" S %=2 D YN^DICN I '%!(%=0) W "Answer 'Y' or 'N'" G ADDL
G:%<0 END I %=2 G TSK
ADDL1 R !,"Enter Block #: ",BLK:DTIME G:BLK="" TSK G:'$T!(BLK["^") END I +BLK'=BLK D HELP G ADDL1
STAIN S DIC=60,DIC("A")="Select stain: ",DIC(0)="AEQMZ",DIC("S")="I $P(^LAB(60,+Y,0),U,4)=""SP""" D ^DIC K DIC G:$D(DTOUT)!$D(DUOUT) END G:Y<0 STAIN
S ST=$P(^LAB(60,+Y,.1),U,1) K DIC
SLIDE R !,"Enter # of slides for this block/stain: 1//",TS:DTIME G:'$T!(TS["^") END S:TS="" TS=1 I +TS'=TS D HELP G SLIDE
F K=1:1:TS S J=J+1 S:J>6 WR=WR+1,J=1 S ^TMP($J,WR,J)=BLK_"^"_ST
G ADDL1
TSK S ZTRTN="QUE^LRAUMLK",ZTDESC="Autopsy labels",ZTSAVE("LR*")="",ZTSAVE("^TMP($J,")="",ZTSAVE("WR")="" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO W @IOF
S LR(1)=$E(LR(2),2,3)_"-"_LR(3),LR("SITE")=+$$SITE^VASITE
PL F I=1:1:WR W:I>1 ! S X=LRABV D PL1 S X=LR(1) D PL1,PL2 S X=LR("SITE") D PL1
D END^LRUTL,END Q
PL1 W !,X,?10,X,?20,X,?30,X,?40,X,?50,X Q
PL2 F C=1:1:2 W ! F B=0:1:5 W ?B*10,$S($D(^TMP($J,I,B+1)):$P(^TMP($J,I,B+1),U,C),1:"")
Q
PL3 W !,X,?10,X+1,?20,X+2,?30,X+3,?40,X+4,?50,X+5 Q
HELP W $C(7),!!,"Enter numbers only",! Q
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAUMLK 2165 printed Dec 13, 2024@02:09:44 Page 2
LRAUMLK ;VAMC 695/MLK - AUTOPSY SLIDE LABELS;1/21/91 ;5/31/96 08:29
+1 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
+2 ;
+3 SET LRDICS="AU"
DO ^LRAP
if '$DATA(Y)
GOTO END
DO XR^LRU
WRITE !!?25,"Autopsy Slide Labels"
ASK ;SECTION WITH INPUTS
+1 SET %DT=""
SET X="T"
DO ^%DT
SET LRY=$EXTRACT(Y,1,3)
SET LR(5)=LRY+1700
WRITE !,"Enter year: ",LR(5),"// "
READ X:DTIME
if '$TEST!(X[U)
GOTO END
if X=""
SET X=LR(5)
+2 SET %DT="EQ"
DO ^%DT
if Y<1
GOTO ASK
SET LR(2)=$EXTRACT(Y,1,3)
WRITE " ",LR(2)+1700
R READ !!,"Enter Autopsy Case number: ",X:DTIME
if X=""!(X[U)
GOTO END
SET LR(3)=X
IF +X'=X
DO HELP
GOTO R
+1 IF '$DATA(^LR(LRXREF,LR(2),LRABV,LR(3)))
WRITE $CHAR(7),!!,"Autopsy not entered",!
GOTO R
R1 WRITE !,"Want labels for whole case"
SET %=1
DO YN^DICN
IF '%!(%=0)
WRITE " Answer 'Y' or 'N'"
GOTO R1
+1 if %<0
GOTO END
IF %=2
SET J=0
SET WR=1
GOTO ADDL
R2 READ !,"Enter total number of blocks :",BLKS:DTIME
if '$TEST!BLKS=""!(BLKS["^")
GOTO END
IF +BLKS'=BLKS
DO HELP
GOTO R2
SET SET WR=BLKS\6
FOR I=0:1:(WR-1)
FOR J=1:1:6
SET ^TMP($JOB,I+1,J)=(I*6+J)_"^"_"H & E"
+1 IF BLKS#6=0
SET WR=WR+1
SET J=0
GOTO ADDL
+2 FOR J=1:1:BLKS#6
SET ^TMP($JOB,WR+1,J)=WR*6+J_"^"_"H & E"
+3 SET WR=WR+1
ADDL WRITE !,"Want to enter additional stains :"
SET %=2
DO YN^DICN
IF '%!(%=0)
WRITE "Answer 'Y' or 'N'"
GOTO ADDL
+1 if %<0
GOTO END
IF %=2
GOTO TSK
ADDL1 READ !,"Enter Block #: ",BLK:DTIME
if BLK=""
GOTO TSK
if '$TEST!(BLK["^")
GOTO END
IF +BLK'=BLK
DO HELP
GOTO ADDL1
STAIN SET DIC=60
SET DIC("A")="Select stain: "
SET DIC(0)="AEQMZ"
SET DIC("S")="I $P(^LAB(60,+Y,0),U,4)=""SP"""
DO ^DIC
KILL DIC
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO END
if Y<0
GOTO STAIN
+1 SET ST=$PIECE(^LAB(60,+Y,.1),U,1)
KILL DIC
SLIDE READ !,"Enter # of slides for this block/stain: 1//",TS:DTIME
if '$TEST!(TS["^")
GOTO END
if TS=""
SET TS=1
IF +TS'=TS
DO HELP
GOTO SLIDE
+1 FOR K=1:1:TS
SET J=J+1
if J>6
SET WR=WR+1
SET J=1
SET ^TMP($JOB,WR,J)=BLK_"^"_ST
+2 GOTO ADDL1
TSK SET ZTRTN="QUE^LRAUMLK"
SET ZTDESC="Autopsy labels"
SET ZTSAVE("LR*")=""
SET ZTSAVE("^TMP($J,")=""
SET ZTSAVE("WR")=""
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
WRITE @IOF
+1 SET LR(1)=$EXTRACT(LR(2),2,3)_"-"_LR(3)
SET LR("SITE")=+$$SITE^VASITE
PL FOR I=1:1:WR
if I>1
WRITE !
SET X=LRABV
DO PL1
SET X=LR(1)
DO PL1
DO PL2
SET X=LR("SITE")
DO PL1
+1 DO END^LRUTL
DO END
QUIT
PL1 WRITE !,X,?10,X,?20,X,?30,X,?40,X,?50,X
QUIT
PL2 FOR C=1:1:2
WRITE !
FOR B=0:1:5
WRITE ?B*10,$SELECT($DATA(^TMP($JOB,I,B+1)):$PIECE(^TMP($JOB,I,B+1),U,C),1:"")
+1 QUIT
PL3 WRITE !,X,?10,X+1,?20,X+2,?30,X+3,?40,X+4,?50,X+5
QUIT
HELP WRITE $CHAR(7),!!,"Enter numbers only",!
QUIT
END DO V^LRU
QUIT
