LR7OSAP.m

LR7OSAP ;slc/dcm/wty - Silent AP rpt (compare to LRAPCUM) ;3/27/2002

 ;;5.2;LAB SERVICE;**1030**;NOV 01, 1997

 ;;5.2;LAB SERVICE;**121,187,230,256,259,317**;Sep 27, 1994

 ;

GET I '$D(^LR(LRDFN,LRSS)) Q

 N FST,X,LRPTR

 S (A,FST)=0,LRI=LRIN

 F  S LRI=$O(^LR(LRDFN,LRSS,LRI)) Q:'LRI!(CT1>COUNT)!(LRI>LROUT)  S B=$G(^(LRI,0)),CT1=CT1+1 I B D

 . D W

 . S X="",$P(X,"=",GIOM)=""

 . D LN

 . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,X)

 . D LINE^LR7OSUM4

 Q

F(PIECE) ;

 ;If PIECE=1, then only get 1st piece; otherwise get whole node

 I '$G(PIECE) D WRAP^LR7OSAP1("^LR("_LRDFN_","""_LRSS_""","_LRI_","_LRV_")",79) Q

 S C=0

 F  S C=$O(^LR(LRDFN,LRSS,LRI,LRV,C)) Q:'C  S X=$P(^(C,0),"^") D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,X)

 Q

W ;

 N LRTEXT

 I 'FST D

 . D LINE^LR7OSUM4,LN

 . S X=GIOM/2-($L(LRAA(1))/2+5),^TMP("LRH",$J,LRAA(1))=GCNT,^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(X,CCNT,"---- "_LRAA(1)_" ----")

 I FST D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"Next "_LRAA(1)_" Specimen...")

 S FST=1

 D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)

 I +$G(LRPTR) D  Q

 .D MAIN^LR7OSAP3(LRPTR)

 S Y=+B

 D D^LRU

 S LRW(1)=Y,Y=$P(B,"^",10)

 D D^LRU

 S LRW(10)=Y,Y=$P(B,"^",3)

 D D^LRU

 S LRW(3)=Y,X=$P(B,"^",2)

 D:X D^LRUA

 S LRW(2)=X,LRW(11)=$P(B,"^",11),X=$P(B,"^",4)

 D:X D^LRUA

 S LRW(4)=X,X=$P(B,"^",7)

 D:X D^LRUA

 S LRW(7)=X

 D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"Date Spec taken: "_LRW(1)),^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(38,CCNT,"Pathologist:"_LRW(2))

 D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"Date Spec rec'd: "_LRW(10)),^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(38,CCNT,$S(LRSS="SP":"Resident: ",1:"Tech: ")_LRW(4))

 D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,$S($L(LRW(3)):"Date  completed: ",1:"REPORT INCOMPLETE")_LRW(3)),^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(38,CCNT,"Accession #: "_$P(B,"^",6))

 D LN S $P(LR("%"),"-",GIOM)="",^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"Submitted by: "_$P(B,"^",5)),^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(38,CCNT,"Practitioner:"_LRW(7)) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,LR("%"))

 I LRW(11)="" D A,LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"Report not verified") Q  ;don't show anymore data if not verified.

 I $D(^LR(LRDFN,LRSS,LRI,.1)) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"Specimen: ") S LRV=.1 D F(1)

 I $P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),"^",4) D

 .D LN

 .S LRTEXT="SUPPLEMENTARY REPORT HAS BEEN ADDED"

 .S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(14,CCNT,"*+* "_LRTEXT_" *+*")

 .D LN

 .S LRTEXT="REFER TO BOTTOM OF REPORT"

 .S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(19,CCNT,"*+* "_LRTEXT_" *+*")

 .D LN

 I $D(^LR(LRDFN,LRSS,LRI,.2)) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"Brief Clinical History:") S LRV=.2 D F()

 I $D(^LR(LRDFN,LRSS,LRI,.3)) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"Preoperative Diagnosis:") S LRV=.3 D F()

 I $D(^LR(LRDFN,LRSS,LRI,.4)) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"Operative Findings:") S LRV=.4 D F()

 I $D(^LR(LRDFN,LRSS,LRI,.5)) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"Postoperative Diagnosis:") S LRV=.5 D F()

 D SET^LRUA

 I $O(^LR(LRDFN,LRSS,LRI,1.3,0)) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,LR(69.2,.13)) I $P($G(^LR(LRDFN,LRSS,LRI,6,0)),U,4) S LR(0)=6 D MOD^LR7OSAP1

 S LRV=1.3

 D F()

 I $O(^LR(LRDFN,LRSS,LRI,1,0)) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,LR(69.2,.03)) I $P($G(^LR(LRDFN,LRSS,LRI,7,0)),U,4) S LR(0)=7 D MOD^LR7OSAP1

 S LRV=1

 D F()

 I $O(^LR(LRDFN,LRSS,LRI,1.1,0)) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,LR(69.2,.04)_" (Date Spec taken: "_LRW(1)_")") I $P($G(^LR(LRDFN,LRSS,LRI,4,0)),U,4) S LR(0)=4 D MOD^LR7OSAP1

 S LRV=1.1

 D F()

 I $O(^LR(LRDFN,LRSS,LRI,1.4,0)) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,LR(69.2,.14)) I $P($G(^LR(LRDFN,LRSS,LRI,5,0)),U,4) S LR(0)=5 D MOD^LR7OSAP1

 S LRV=1.4

 D F()

 I $O(^LR(LRDFN,LRSS,LRI,1.2,0)) D

 . D LN

 . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"Supplementary Report:")

 . S C=0 F  S C=$O(^LR(LRDFN,LRSS,LRI,1.2,C)) Q:'C  D

 .. S X=^LR(LRDFN,LRSS,LRI,1.2,C,0),Y=+X,X=$P(X,U,2)

 .. ;Don't even print supp date if supp is not released

 .. Q:'X

 .. D D^LRU,LN

 .. S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(3,CCNT,"Date: "_Y)

 .. I 'X S ^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(1,CCNT," not verified")

 .. I $O(^LR(LRDFN,LRSS,LRI,1.2,C,2,0)) D MODSR^LR7OSAP1

 .. D:X U

 I $D(^LR(LRDFN,LRSS,LRI,2)) D B

 Q

U ;

 D WRAP^LR7OSAP1("^LR("_LRDFN_","""_LRSS_""","_LRI_",1.2,"_C_",1)",79)

 Q

B ;

 S C=0

 F  S C=$O(^LR(LRDFN,LRSS,LRI,2,C)) Q:'C  D SP

 Q

SP ;

 S G=0

 F  S G=$O(^LR(LRDFN,LRSS,LRI,2,C,5,G)) Q:'G  S X=^(G,0),Y=$P(X,"^",2),E=$P(X,"^",3),E(1)=$P(X,"^")_":",E(1)=$P($P($G(LR(LRSS)),E(1),2),";") D D^LRU S T(2)=Y D WP

 Q

WP ;

 D LN

 S X=E(1)_" "_E_" Date: "_T(2)_" ",^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,X)

 D WRAP^LR7OSAP1("^LR("_LRDFN_","""_LRSS_""","_LRI_",2,"_C_",5,"_G_",1)",79)

 Q

A ;

 D WRAP^LR7OSAP1("^LR("_LRDFN_","""_LRSS_""","_LRI_",97)",79)

 Q

LN ;Increment the counter

 S GCNT=GCNT+1,CCNT=1

 Q

EN ;Get AP results

 I $S('$D(SUBHEAD):1,1:$D(SUBHEAD("CYTOPATHOLOGY"))) D CY

 I $S('$D(SUBHEAD):1,1:$D(SUBHEAD("SURGICAL PATHOLOGY"))) D SPA

 I $S('$D(SUBHEAD):1,1:$D(SUBHEAD("EM"))) D EM

 I $S('$D(SUBHEAD):1,1:$D(SUBHEAD("AUTOPSY"))),$D(^LR(LRDFN,"AU")) D AU

 Q

CY S LRSS="CY",LRAA(1)="CYTOPATHOLOGY",LRAA=+$O(^LRO(68,"B",LRAA(1),0)) S:'LRAA LRAA=$$FIND(LRSS) D GET

 Q

SPA S LRSS="SP",LRAA(1)="SURGICAL PATHOLOGY",LRAA=+$O(^LRO(68,"B",LRAA(1),0)) S:'LRAA LRAA=$$FIND(LRSS) D GET

 Q

EM S LRSS="EM",LRAA(1)="ELECTRON MICROSCOPY",LRAA=+$O(^LRO(68,"B","EM",0)) S:'LRAA LRAA=$$FIND(LRSS) D GET

 Q

AU D EN^LR7OSAP2(LRDFN)

 Q

FIND(SS) ;Find a valid entry in 68

 ;SS=LRSS value to look for

 N I,Y

 S I=0,Y="" F  S I=$O(^LRO(68,I)) Q:I<1  I $P($G(^LRO(68,I,0)),"^",2)=SS S Y=I Q

 Q Y

LR7OSAP   ;slc/dcm/wty - Silent AP rpt (compare to LRAPCUM) ;3/27/2002

 +1       ;;5.2;LAB SERVICE;**1030**;NOV 01, 1997

 +2       ;;5.2;LAB SERVICE;**121,187,230,256,259,317**;Sep 27, 1994

 +3       ;

GET        IF '$DATA(^LR(LRDFN,LRSS))

               QUIT 

 +1        NEW FST,X,LRPTR

 +2        SET (A,FST)=0

           SET LRI=LRIN

 +3        FOR 

               SET LRI=$ORDER(^LR(LRDFN,LRSS,LRI))

               IF 'LRI!(CT1>COUNT)!(LRI>LROUT)

                   QUIT 

               SET B=$GET(^(LRI,0))

               SET CT1=CT1+1

               IF B

                   Begin DoDot:1

 +4                    DO W

 +5                    SET X=""

                       SET $PIECE(X,"=",GIOM)=""

 +6                    DO LN

 +7                    SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,X)

 +8                    DO LINE^LR7OSUM4

                   End DoDot:1

 +9        QUIT 

F(PIECE)  ;

 +1       ;If PIECE=1, then only get 1st piece; otherwise get whole node

 +2        IF '$GET(PIECE)

               DO WRAP^LR7OSAP1("^LR("_LRDFN_","""_LRSS_""","_LRI_","_LRV_")",79)

               QUIT 

 +3        SET C=0

 +4        FOR 

               SET C=$ORDER(^LR(LRDFN,LRSS,LRI,LRV,C))

               IF 'C

                   QUIT 

               SET X=$PIECE(^(C,0),"^")

               DO LN

               SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,X)

 +5        QUIT 

W         ;

 +1        NEW LRTEXT

 +2        IF 'FST

               Begin DoDot:1

 +3                DO LINE^LR7OSUM4

                   DO LN

 +4                SET X=GIOM/2-($LENGTH(LRAA(1))/2+5)

                   SET ^TMP("LRH",$JOB,LRAA(1))=GCNT

                   SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(X,CCNT,"---- "_LRAA(1)_" ----")

               End DoDot:1

 +5        IF FST

               DO LN

               SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"Next "_LRAA(1)_" Specimen...")

 +6        SET FST=1

 +7        DO TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)

 +8        IF +$GET(LRPTR)

               Begin DoDot:1

 +9                DO MAIN^LR7OSAP3(LRPTR)

               End DoDot:1

               QUIT 

 +10       SET Y=+B

 +11       DO D^LRU

 +12       SET LRW(1)=Y

           SET Y=$PIECE(B,"^",10)

 +13       DO D^LRU

 +14       SET LRW(10)=Y

           SET Y=$PIECE(B,"^",3)

 +15       DO D^LRU

 +16       SET LRW(3)=Y

           SET X=$PIECE(B,"^",2)

 +17       IF X

               DO D^LRUA

 +18       SET LRW(2)=X

           SET LRW(11)=$PIECE(B,"^",11)

           SET X=$PIECE(B,"^",4)

 +19       IF X

               DO D^LRUA

 +20       SET LRW(4)=X

           SET X=$PIECE(B,"^",7)

 +21       IF X

               DO D^LRUA

 +22       SET LRW(7)=X

 +23       DO LN

           SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"Date Spec taken: "_LRW(1))

           SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(38,CCNT,"Pathologist:"_LRW(2))

 +24       DO LN

           SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"Date Spec rec'd: "_LRW(10))

           SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(38,CCNT,$SELECT(LRSS="SP":"Resident: ",1:"Tech: ")_LRW(4))

 +25       DO LN

           SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,$SELECT($LENGTH(LRW(3)):"Date  completed: ",1:"REPORT INCOMPLETE")_LRW(3))

           SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(38,CCNT,"Accession #: "_$PIECE(B,"^",6))

 +26       DO LN

           SET $PIECE(LR("%"),"-",GIOM)=""

           SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"Submitted by: "_$PIECE(B,"^",5))

           SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(38,CCNT,"Practitioner:"_LRW(7))

           DO LN

           SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,LR("%"))

 +27      ;don't show anymore data if not verified.

           IF LRW(11)=""

               DO A

               DO LN

               SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"Report not verified")

               QUIT 

 +28       IF $DATA(^LR(LRDFN,LRSS,LRI,.1))

               DO LN

               SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"Specimen: ")

               SET LRV=.1

               DO F(1)

 +29       IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,1.2,0)),"^",4)

               Begin DoDot:1

 +30               DO LN

 +31               SET LRTEXT="SUPPLEMENTARY REPORT HAS BEEN ADDED"

 +32               SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(14,CCNT,"*+* "_LRTEXT_" *+*")

 +33               DO LN

 +34               SET LRTEXT="REFER TO BOTTOM OF REPORT"

 +35               SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(19,CCNT,"*+* "_LRTEXT_" *+*")

 +36               DO LN

               End DoDot:1

 +37       IF $DATA(^LR(LRDFN,LRSS,LRI,.2))

               DO LN

               SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"Brief Clinical History:")

               SET LRV=.2

               DO F()

 +38       IF $DATA(^LR(LRDFN,LRSS,LRI,.3))

               DO LN

               SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"Preoperative Diagnosis:")

               SET LRV=.3

               DO F()

 +39       IF $DATA(^LR(LRDFN,LRSS,LRI,.4))

               DO LN

               SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"Operative Findings:")

               SET LRV=.4

               DO F()

 +40       IF $DATA(^LR(LRDFN,LRSS,LRI,.5))

               DO LN

               SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"Postoperative Diagnosis:")

               SET LRV=.5

               DO F()

 +41       DO SET^LRUA

 +42       IF $ORDER(^LR(LRDFN,LRSS,LRI,1.3,0))

               DO LN

               SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,LR(69.2,.13))

               IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,6,0)),U,4)

                   SET LR(0)=6

                   DO MOD^LR7OSAP1

 +43       SET LRV=1.3

 +44       DO F()

 +45       IF $ORDER(^LR(LRDFN,LRSS,LRI,1,0))

               DO LN

               SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,LR(69.2,.03))

               IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,7,0)),U,4)

                   SET LR(0)=7

                   DO MOD^LR7OSAP1

 +46       SET LRV=1

 +47       DO F()

 +48       IF $ORDER(^LR(LRDFN,LRSS,LRI,1.1,0))

               DO LN

               SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,LR(69.2,.04)_" (Date Spec taken: "_LRW(1)_")")

               IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,4,0)),U,4)

                   SET LR(0)=4

                   DO MOD^LR7OSAP1

 +49       SET LRV=1.1

 +50       DO F()

 +51       IF $ORDER(^LR(LRDFN,LRSS,LRI,1.4,0))

               DO LN

               SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,LR(69.2,.14))

               IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,5,0)),U,4)

                   SET LR(0)=5

                   DO MOD^LR7OSAP1

 +52       SET LRV=1.4

 +53       DO F()

 +54       IF $ORDER(^LR(LRDFN,LRSS,LRI,1.2,0))

               Begin DoDot:1

 +55               DO LN

 +56               SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"Supplementary Report:")

 +57               SET C=0

                   FOR 

                       SET C=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,C))

                       IF 'C

                           QUIT 

                       Begin DoDot:2

 +58                       SET X=^LR(LRDFN,LRSS,LRI,1.2,C,0)

                           SET Y=+X

                           SET X=$PIECE(X,U,2)

 +59      ;Don't even print supp date if supp is not released

 +60                       IF 'X

                               QUIT 

 +61                       DO D^LRU

                           DO LN

 +62                       SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(3,CCNT,"Date: "_Y)

 +63                       IF 'X

                               SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(1,CCNT," not verified")

 +64                       IF $ORDER(^LR(LRDFN,LRSS,LRI,1.2,C,2,0))

                               DO MODSR^LR7OSAP1

 +65                       IF X

                               DO U

                       End DoDot:2

               End DoDot:1

 +66       IF $DATA(^LR(LRDFN,LRSS,LRI,2))

               DO B

 +67       QUIT 

U         ;

 +1        DO WRAP^LR7OSAP1("^LR("_LRDFN_","""_LRSS_""","_LRI_",1.2,"_C_",1)",79)

 +2        QUIT 

B         ;

 +1        SET C=0

 +2        FOR 

               SET C=$ORDER(^LR(LRDFN,LRSS,LRI,2,C))

               IF 'C

                   QUIT 

               DO SP

 +3        QUIT 

SP        ;

 +1        SET G=0

 +2        FOR 

               SET G=$ORDER(^LR(LRDFN,LRSS,LRI,2,C,5,G))

               IF 'G

                   QUIT 

               SET X=^(G,0)

               SET Y=$PIECE(X,"^",2)

               SET E=$PIECE(X,"^",3)

               SET E(1)=$PIECE(X,"^")_":"

               SET E(1)=$PIECE($PIECE($GET(LR(LRSS)),E(1),2),";")

               DO D^LRU

               SET T(2)=Y

               DO WP

 +3        QUIT 

WP        ;

 +1        DO LN

 +2        SET X=E(1)_" "_E_" Date: "_T(2)_" "

           SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,X)

 +3        DO WRAP^LR7OSAP1("^LR("_LRDFN_","""_LRSS_""","_LRI_",2,"_C_",5,"_G_",1)",79)

 +4        QUIT 

A         ;

 +1        DO WRAP^LR7OSAP1("^LR("_LRDFN_","""_LRSS_""","_LRI_",97)",79)

 +2        QUIT 

LN        ;Increment the counter

 +1        SET GCNT=GCNT+1

           SET CCNT=1

 +2        QUIT 

EN        ;Get AP results

 +1        IF $SELECT('$DATA(SUBHEAD):1,1:$DATA(SUBHEAD("CYTOPATHOLOGY")))

               DO CY

 +2        IF $SELECT('$DATA(SUBHEAD):1,1:$DATA(SUBHEAD("SURGICAL PATHOLOGY")))

               DO SPA

 +3        IF $SELECT('$DATA(SUBHEAD):1,1:$DATA(SUBHEAD("EM")))

               DO EM

 +4        IF $SELECT('$DATA(SUBHEAD):1,1:$DATA(SUBHEAD("AUTOPSY")))

               IF $DATA(^LR(LRDFN,"AU"))

                   DO AU

 +5        QUIT 

CY         SET LRSS="CY"

           SET LRAA(1)="CYTOPATHOLOGY"

           SET LRAA=+$ORDER(^LRO(68,"B",LRAA(1),0))

           IF 'LRAA

               SET LRAA=$$FIND(LRSS)

           DO GET

 +1        QUIT 

SPA        SET LRSS="SP"

           SET LRAA(1)="SURGICAL PATHOLOGY"

           SET LRAA=+$ORDER(^LRO(68,"B",LRAA(1),0))

           IF 'LRAA

               SET LRAA=$$FIND(LRSS)

           DO GET

 +1        QUIT 

EM         SET LRSS="EM"

           SET LRAA(1)="ELECTRON MICROSCOPY"

           SET LRAA=+$ORDER(^LRO(68,"B","EM",0))

           IF 'LRAA

               SET LRAA=$$FIND(LRSS)

           DO GET

 +1        QUIT 

AU         DO EN^LR7OSAP2(LRDFN)

 +1        QUIT 

FIND(SS)  ;Find a valid entry in 68

 +1       ;SS=LRSS value to look for

 +2        NEW I,Y

 +3        SET I=0

           SET Y=""

           FOR 

               SET I=$ORDER(^LRO(68,I))

               IF I<1

                   QUIT 

               IF $PIECE($GET(^LRO(68,I,0)),"^",2)=SS

                   SET Y=I

                   QUIT 

 +4        QUIT Y