- LRAPH ; IHS/DIR/AAB - HISTOLOGY RECORD 7/28-97 07:19 ; [ 05/28/98 2:04 PM ]
- ;;5.2;LR;**1002,1003**;JUN 01, 1998
- ;;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("%")
- W !,LR("%"),!,"Accession",?10,"| SPECIMEN",?41,"|DECAL/GR",?51,"| BLOCKS",?61,"| SLIDES",?71,"| STAINS",!,LR("%") ;IHS/DIR TUC/AAB 5/4/98
- Q
- END D V^LRU Q
- LRAPH ; IHS/DIR/AAB - HISTOLOGY RECORD 7/28-97 07:19 ; [ 05/28/98 2:04 PM ]
- +1 ;;5.2;LR;**1002,1003**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**72,173**;Sep 27, 1994
- +3 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 ;W !,LR("%"),!,"Accession",?10,"| SPECIMEN",?41,"|CASSETTE",?51,"| BLOCKS",?61,"| SLIDES",?71,"| STAINS",!,LR("%")
- +3 ;IHS/DIR TUC/AAB 5/4/98
- WRITE !,LR("%"),!,"Accession",?10,"| SPECIMEN",?41,"|DECAL/GR",?51,"| BLOCKS",?61,"| SLIDES",?71,"| STAINS",!,LR("%")
- +4 QUIT
- END DO V^LRU
- QUIT
