LRAPH.m

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