LRAPSL ;AVAMC/REG/CYM - ANATOMIC PATH SLIDE LABELS ;2/13/98 13:41 ;
;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
D ^LRAP G:'$D(Y) END I LRSS="AU" D AU^LRAPBS1 G:J END S:'$D(LRW(0)) LRW(0)=$O(^LAB(60,"B","AUTOPSY H & E",0))
ASK S LRZ=1,%DT="",X="T" D ^%DT S LRY=$E(Y,1,3)+1700 W !,"Enter year: ",LRY,"// " R X:DTIME G:'$T!(X[U) END S:X="" X=LRY
S %DT="EQ" D ^%DT G:Y<1 ASK S LRY=$E(Y,1,3),LRH(0)=LRY+1700 W " ",LRH(0)
S LRR=0 W !!,"Reprint slide labels " S %=2 D YN^LRU G:%<1 END I %=1 S LRR=1 G R
W !!,"Add/Delete slide labels to print " S %=2 D YN^LRU G:%<1 END I %=1 D S^LRAPST,^LRAPSL1
W !!,"Print ",LRO(68)," slide labels for ",LRY+1700
R R !!,"Start with accession number: ",X:DTIME G:X=""!(X[U) END S LR(3)=X I +X'=X D HELP G R
RR R !,"Go to accession number: LAST// ",LR(4):DTIME G:'$T!(LR(4)[U) END S:LR(4)="" LR(4)=9999999 I LR(4)'=+LR(4) D HELP G RR
S:'LR(4) LR(4)=9999999
I LR(4)<LR(3) S X=LR(3),LR(3)=LR(4),LR(4)=X
D SET W !!,"Just a moment while I check to see if there are labels to print",!! D C I '$D(LRZ(1)) W $C(7),?20,"There are no labels to print" G END
K LRZ S ZTRTN="QUE^LRAPSL" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO W $C(13) D SET
D C F A=0:0 S A=$O(^TMP($J,A)) Q:'A D W
D END^LRUTL,END Q
C F A=LR(3)-1:0 S A=$O(^LR(LRXREF,LRY,LRABV,A)) Q:'A!(A>LR(4)) S LRDFN=$O(^(A,0)),LRI=$O(^(LRDFN,0)) D S
Q
W W !,LRABV,?10,LRABV,?20,LRABV,?30,LRABV,?40,LRABV,?50,LRABV
F C=2:1:4 W ! F B=0:1:5 W ?B*10,$S($D(^TMP($J,A,B+1,C)):^(C),1:"")
W !,LR(12),?10,LR(12),?20,LR(12),?30,LR(12),?40,LR(12),?50,LR(12)
W ! Q
S I LRSS="AU" D AU Q
F B=0:0 S B=$O(^LR(LRDFN,LRSS,LRI,.1,B)) Q:'B!($D(LRZ(1))) F J=0:0 S J=$O(^LR(LRDFN,LRSS,LRI,.1,B,J)) Q:'J!($D(LRZ(1))) F C=0:0 S C=$O(^LR(LRDFN,LRSS,LRI,.1,B,J,C)) Q:'C!($D(LRZ(1))) S LRB=$P(^(C,0),"^") D T
Q
T F E=0:0 S E=$O(^LR(LRDFN,LRSS,LRI,.1,B,J,C,1,E)) Q:'E S X=^(E,0),F=$S('LRR:$P(X,"^",7),1:$P(X,"^",6)) D:'F X I F S:$D(LRZ) LRZ(1)=1 Q:$D(LRZ) S $P(^(0),"^",7)=0,LR(9)=$S($D(^LAB(60,E,.1)):$P(^(.1),"^"),1:"") D P
Q
P F G=1:1:F S LR(6)=LR(6)+1,LR(8)=LR(6)#6,LR(7)=LR(6)\6+1 S:'LR(8) LR(7)=LR(7)-1 S:'LR(8) LR(8)=6 S ^TMP($J,LR(7),LR(8),2)=LR(1)_A,^(3)=$E(LRB,1,9),^(4)=LR(9)
Q
X S F=$P(X,"^",2)+$P(X,"^",3) S:LRSS'="AU"&('$D(LRZ)) $P(^LR(LRDFN,LRSS,LRI,.1,B,J,C,1,E,0),"^",6)=F I LRSS="AU"&('$D(LRZ)) S $P(^LR(LRDFN,33,B,J,C,1,E,0),"^",6)=F
S:'LRR F=F-$P(X,"^",6) S:F<0 F=0 Q
AU F B=0:0 S B=$O(^LR(LRDFN,33,B)) Q:'B F J=0:0 S J=$O(^LR(LRDFN,33,B,J)) Q:'J F C=0:0 S C=$O(^LR(LRDFN,33,B,J,C)) Q:'C S LRB=$P(^(C,0),"^") D AUT
Q
AUT F E=0:0 S E=$O(^LR(LRDFN,33,B,J,C,1,E)) Q:'E S X=^(E,0),F=$S('LRR:$P(X,"^",7),1:$P(X,"^",6)) D:'F X I F S:$D(LRZ) LRZ(1)=1 Q:$D(LRZ) S $P(^(0),"^",7)=0,LR(9)=$S($D(^LAB(60,E,.1)):$P(^(.1),"^"),1:"") D P
Q
CK I LRR S:'F F=1 Q
S:$P(X,"^",7)="" F=1 Q
HELP W $C(7),!!,"Enter numbers only",! Q
END D V^LRU Q
SET K ^TMP($J) S (LR("FORM"),LR("LINE"))=1,LR(12)=$S(DUZ("AG")="V":"VAMC "_+$$SITE^VASITE,1:$E($$INS^LRU,1,9)),LR(6)=0,LR(1)=($E(LRY,1,3)+1700)_"-",LRXREF="A"_LRSS_"A" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPSL 3038 printed Dec 13, 2024@02:08:20 Page 2
LRAPSL ;AVAMC/REG/CYM - ANATOMIC PATH SLIDE LABELS ;2/13/98 13:41 ;
+1 ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
+2 DO ^LRAP
if '$DATA(Y)
GOTO END
IF LRSS="AU"
DO AU^LRAPBS1
if J
GOTO END
if '$DATA(LRW(0))
SET LRW(0)=$ORDER(^LAB(60,"B","AUTOPSY H & E",0))
ASK SET LRZ=1
SET %DT=""
SET X="T"
DO ^%DT
SET LRY=$EXTRACT(Y,1,3)+1700
WRITE !,"Enter year: ",LRY,"// "
READ X:DTIME
if '$TEST!(X[U)
GOTO END
if X=""
SET X=LRY
+1 SET %DT="EQ"
DO ^%DT
if Y<1
GOTO ASK
SET LRY=$EXTRACT(Y,1,3)
SET LRH(0)=LRY+1700
WRITE " ",LRH(0)
+2 SET LRR=0
WRITE !!,"Reprint slide labels "
SET %=2
DO YN^LRU
if %<1
GOTO END
IF %=1
SET LRR=1
GOTO R
+3 WRITE !!,"Add/Delete slide labels to print "
SET %=2
DO YN^LRU
if %<1
GOTO END
IF %=1
DO S^LRAPST
DO ^LRAPSL1
+4 WRITE !!,"Print ",LRO(68)," slide labels for ",LRY+1700
R READ !!,"Start with accession number: ",X:DTIME
if X=""!(X[U)
GOTO END
SET LR(3)=X
IF +X'=X
DO HELP
GOTO R
RR READ !,"Go to accession number: LAST// ",LR(4):DTIME
if '$TEST!(LR(4)[U)
GOTO END
if LR(4)=""
SET LR(4)=9999999
IF LR(4)'=+LR(4)
DO HELP
GOTO RR
+1 if 'LR(4)
SET LR(4)=9999999
+2 IF LR(4)<LR(3)
SET X=LR(3)
SET LR(3)=LR(4)
SET LR(4)=X
+3 DO SET
WRITE !!,"Just a moment while I check to see if there are labels to print",!!
DO C
IF '$DATA(LRZ(1))
WRITE $CHAR(7),?20,"There are no labels to print"
GOTO END
+4 KILL LRZ
SET ZTRTN="QUE^LRAPSL"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
WRITE $CHAR(13)
DO SET
+1 DO C
FOR A=0:0
SET A=$ORDER(^TMP($JOB,A))
if 'A
QUIT
DO W
+2 DO END^LRUTL
DO END
QUIT
C FOR A=LR(3)-1:0
SET A=$ORDER(^LR(LRXREF,LRY,LRABV,A))
if 'A!(A>LR(4))
QUIT
SET LRDFN=$ORDER(^(A,0))
SET LRI=$ORDER(^(LRDFN,0))
DO S
+1 QUIT
W WRITE !,LRABV,?10,LRABV,?20,LRABV,?30,LRABV,?40,LRABV,?50,LRABV
+1 FOR C=2:1:4
WRITE !
FOR B=0:1:5
WRITE ?B*10,$SELECT($DATA(^TMP($JOB,A,B+1,C)):^(C),1:"")
+2 WRITE !,LR(12),?10,LR(12),?20,LR(12),?30,LR(12),?40,LR(12),?50,LR(12)
+3 WRITE !
QUIT
S IF LRSS="AU"
DO AU
QUIT
+1 FOR B=0:0
SET B=$ORDER(^LR(LRDFN,LRSS,LRI,.1,B))
if 'B!($DATA(LRZ(1)))
QUIT
FOR J=0:0
SET J=$ORDER(^LR(LRDFN,LRSS,LRI,.1,B,J))
if 'J!($DATA(LRZ(1)))
QUIT
FOR C=0:0
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,.1,B,J,C))
if 'C!($DATA(LRZ(1)))
QUIT
SET LRB=$PIECE(^(C,0),"^")
DO T
+2 QUIT
T FOR E=0:0
SET E=$ORDER(^LR(LRDFN,LRSS,LRI,.1,B,J,C,1,E))
if 'E
QUIT
SET X=^(E,0)
SET F=$SELECT('LRR:$PIECE(X,"^",7),1:$PIECE(X,"^",6))
if 'F
DO X
IF F
if $DATA(LRZ)
SET LRZ(1)=1
if $DATA(LRZ)
QUIT
SET $PIECE(^(0),"^",7)=0
SET LR(9)=$SELECT($DATA(^LAB(60,E,.1)):$PIECE(^(.1),"^"),1:"")
DO P
+1 QUIT
P FOR G=1:1:F
SET LR(6)=LR(6)+1
SET LR(8)=LR(6)#6
SET LR(7)=LR(6)\6+1
if 'LR(8)
SET LR(7)=LR(7)-1
if 'LR(8)
SET LR(8)=6
SET ^TMP($JOB,LR(7),LR(8),2)=LR(1)_A
SET ^(3)=$EXTRACT(LRB,1,9)
SET ^(4)=LR(9)
+1 QUIT
X SET F=$PIECE(X,"^",2)+$PIECE(X,"^",3)
if LRSS'="AU"&('$DATA(LRZ))
SET $PIECE(^LR(LRDFN,LRSS,LRI,.1,B,J,C,1,E,0),"^",6)=F
IF LRSS="AU"&('$DATA(LRZ))
SET $PIECE(^LR(LRDFN,33,B,J,C,1,E,0),"^",6)=F
+1 if 'LRR
SET F=F-$PIECE(X,"^",6)
if F<0
SET F=0
QUIT
AU FOR B=0:0
SET B=$ORDER(^LR(LRDFN,33,B))
if 'B
QUIT
FOR J=0:0
SET J=$ORDER(^LR(LRDFN,33,B,J))
if 'J
QUIT
FOR C=0:0
SET C=$ORDER(^LR(LRDFN,33,B,J,C))
if 'C
QUIT
SET LRB=$PIECE(^(C,0),"^")
DO AUT
+1 QUIT
AUT FOR E=0:0
SET E=$ORDER(^LR(LRDFN,33,B,J,C,1,E))
if 'E
QUIT
SET X=^(E,0)
SET F=$SELECT('LRR:$PIECE(X,"^",7),1:$PIECE(X,"^",6))
if 'F
DO X
IF F
if $DATA(LRZ)
SET LRZ(1)=1
if $DATA(LRZ)
QUIT
SET $PIECE(^(0),"^",7)=0
SET LR(9)=$SELECT($DATA(^LAB(60,E,.1)):$PIECE(^(.1),"^"),1:"")
DO P
+1 QUIT
CK IF LRR
if 'F
SET F=1
QUIT
+1 if $PIECE(X,"^",7)=""
SET F=1
QUIT
HELP WRITE $CHAR(7),!!,"Enter numbers only",!
QUIT
END DO V^LRU
QUIT
SET KILL ^TMP($JOB)
SET (LR("FORM"),LR("LINE"))=1
SET LR(12)=$SELECT(DUZ("AG")="V":"VAMC "_+$$SITE^VASITE,1:$EXTRACT($$INS^LRU,1,9))
SET LR(6)=0
SET LR(1)=($EXTRACT(LRY,1,3)+1700)_"-"
SET LRXREF="A"_LRSS_"A"
QUIT
