LRAPH ;AVAMC/REG/CYM - HISTOLOGY RECORD ;7/28-97 07:19
;;5.2;LAB SERVICE;**72,173**;Sep 27, 1994
S LRDICS="SPCYEM" D ^LRAP G:'$D(Y) END W !!,LRO(68)," HISTOPATHOLOGY DATA SHEET"
ASK S %DT="AEX",%DT(0)="-N",%DT("A")="Select ACCESSION DATE: " D ^%DT K %DT G:Y<1 END S LRSDT=Y-.0001,LRLDT=Y+.99 D D^LRU S LRD=Y
S ZTRTN="QUE^LRAPH",ZTDESC="Histology Data Sheet",ZTSAVE("LR*")="" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) D XR^LRU,L^LRU,S^LRU,H S LR("F")=1
F A=LRSDT:0 S A=$O(^LR(LRXR,A)) Q:'A!(A>LRLDT) S A(1)=$E(A,2,3) F B=0:0 S B=$O(^LR(LRXR,A,B)) Q:'B F C=0:0 S C=$O(^LR(LRXR,A,B,C)) Q:'C D A
S A=0 F B=0:1 S A=$O(^TMP($J,A)) Q:A=""!(LR("Q")) S C="" F S C=$O(^TMP($J,A,C)) Q:C=""!(LR("Q")) S X=^(C),LRDFN=+X,LRI=$P(X,"^",2) D W
W:'B !!,"NO ACCESSIONS FOR ",LRD D END^LRUTL,END Q
W F E=0:0 S E=$O(^LR(LRDFN,LRSS,LRI,.1,E)) Q:'E S F=$P(^(E,0),U) D:$Y>(IOSL-6) H Q:LR("Q") W !,C,?10,"|",$E(F,1,30),?41,"|",?51,"|",?61,"|",?71,"|",!,LR("%")
Q
A I '$D(^LR(B,LRSS,C,0)) K ^LR(LRXR,A,B,C) Q
S X=^LR(B,LRSS,C,0),Y=$P(X,"^",6) Q:$P(Y," ")'=LRABV S ^TMP($J,A(1),Y)=B_"^"_C Q
;
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,LRO(68)," (",LRABV,") SHEET ",?37,"ACCESSION DATE: ",LRD
W !,LR("%"),!,"Accession",?10,"| SPECIMEN",?41,"|CASSETTE",?51,"| BLOCKS",?61,"| SLIDES",?71,"| STAINS",!,LR("%")
Q
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPH 1368 printed Dec 13, 2024@02:07:27 Page 2
LRAPH ;AVAMC/REG/CYM - HISTOLOGY RECORD ;7/28-97 07:19
+1 ;;5.2;LAB SERVICE;**72,173**;Sep 27, 1994
+2 SET LRDICS="SPCYEM"
DO ^LRAP
if '$DATA(Y)
GOTO END
WRITE !!,LRO(68)," HISTOPATHOLOGY DATA SHEET"
ASK SET %DT="AEX"
SET %DT(0)="-N"
SET %DT("A")="Select ACCESSION DATE: "
DO ^%DT
KILL %DT
if Y<1
GOTO END
SET LRSDT=Y-.0001
SET LRLDT=Y+.99
DO D^LRU
SET LRD=Y
+1 SET ZTRTN="QUE^LRAPH"
SET ZTDESC="Histology Data Sheet"
SET ZTSAVE("LR*")=""
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
DO XR^LRU
DO L^LRU
DO S^LRU
DO H
SET LR("F")=1
+1 FOR A=LRSDT:0
SET A=$ORDER(^LR(LRXR,A))
if 'A!(A>LRLDT)
QUIT
SET A(1)=$EXTRACT(A,2,3)
FOR B=0:0
SET B=$ORDER(^LR(LRXR,A,B))
if 'B
QUIT
FOR C=0:0
SET C=$ORDER(^LR(LRXR,A,B,C))
if 'C
QUIT
DO A
+2 SET A=0
FOR B=0:1
SET A=$ORDER(^TMP($JOB,A))
if A=""!(LR("Q"))
QUIT
SET C=""
FOR
SET C=$ORDER(^TMP($JOB,A,C))
if C=""!(LR("Q"))
QUIT
SET X=^(C)
SET LRDFN=+X
SET LRI=$PIECE(X,"^",2)
DO W
+3 if 'B
WRITE !!,"NO ACCESSIONS FOR ",LRD
DO END^LRUTL
DO END
QUIT
W FOR E=0:0
SET E=$ORDER(^LR(LRDFN,LRSS,LRI,.1,E))
if 'E
QUIT
SET F=$PIECE(^(E,0),U)
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !,C,?10,"|",$EXTRACT(F,1,30),?41,"|",?51,"|",?61,"|",?71,"|",!,LR("%")
+1 QUIT
A IF '$DATA(^LR(B,LRSS,C,0))
KILL ^LR(LRXR,A,B,C)
QUIT
+1 SET X=^LR(B,LRSS,C,0)
SET Y=$PIECE(X,"^",6)
if $PIECE(Y," ")'=LRABV
QUIT
SET ^TMP($JOB,A(1),Y)=B_"^"_C
QUIT
+2 ;
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,LRO(68)," (",LRABV,") SHEET ",?37,"ACCESSION DATE: ",LRD
+2 WRITE !,LR("%"),!,"Accession",?10,"| SPECIMEN",?41,"|CASSETTE",?51,"| BLOCKS",?61,"| SLIDES",?71,"| STAINS",!,LR("%")
+3 QUIT
END DO V^LRU
QUIT
