LR7OSAP4.m

LR7OSAP4 ;va/slc/dcm - Silent AP API ;3/22/2007

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

 ;;5.2;LAB SERVICE;**365**;Sep 27, 1994;Build 11

 ;

EN(LRX,LRDFN,LRSS,LRI,GIOM)        ;Get Anatomic Path results from either TIU or Lab files

 ; LRX is the global where the output is placed. Calling package is responsible for cleaning this up

 ; LRDFN = Lab Patient ID

 ; LRSS = Lab Subscript

 ; LRI = Inverse Date/Time from ^LR(LRDFN,LRSS,LRIDT)

 Q:'LRDFN  Q:$G(LRSS)=""  Q:'LRI  Q:'$D(^LR(+LRDFN,LRSS,LRI))&(LRSS'="AU")

 N LRAA,FST,GCNT,B

 K ^TMP("LRC",$J)

 D:LRSS="CY" CY D:LRSS="SP" SPA D:LRSS="EM" EM

 S FST=0,GCNT=0,GIOM=$G(GIOM,96),B=$G(^LR(LRDFN,LRSS,LRI,0))

 D:LRSS="AU" AU

 I LRSS'="AU" D W^LR7OSAP

 M @LRX=^TMP("LRC",$J)

 Q

 ;

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

 Q

 ;

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

 Q

 ;

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

 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

LR7OSAP4  ;va/slc/dcm - Silent AP API ;3/22/2007

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

 +2       ;;5.2;LAB SERVICE;**365**;Sep 27, 1994;Build 11

 +3       ;

EN(LRX,LRDFN,LRSS,LRI,GIOM) ;Get Anatomic Path results from either TIU or Lab files

 +1       ; LRX is the global where the output is placed. Calling package is responsible for cleaning this up

 +2       ; LRDFN = Lab Patient ID

 +3       ; LRSS = Lab Subscript

 +4       ; LRI = Inverse Date/Time from ^LR(LRDFN,LRSS,LRIDT)

 +5        IF 'LRDFN

               QUIT 

           IF $GET(LRSS)=""

               QUIT 

           IF 'LRI

               QUIT 

           IF '$DATA(^LR(+LRDFN,LRSS,LRI))&(LRSS'="AU")

               QUIT 

 +6        NEW LRAA,FST,GCNT,B

 +7        KILL ^TMP("LRC",$JOB)

 +8        IF LRSS="CY"

               DO CY

           IF LRSS="SP"

               DO SPA

           IF LRSS="EM"

               DO EM

 +9        SET FST=0

           SET GCNT=0

           SET GIOM=$GET(GIOM,96)

           SET B=$GET(^LR(LRDFN,LRSS,LRI,0))

 +10       IF LRSS="AU"

               DO AU

 +11       IF LRSS'="AU"

               DO W^LR7OSAP

 +12       MERGE @LRX=^TMP("LRC",$JOB)

 +13       QUIT 

 +14      ;

CY         SET LRSS="CY"

           SET LRAA(1)="CYTOPATHOLOGY"

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

           IF 'LRAA

               SET LRAA=$$FIND(LRSS)

 +1        QUIT 

 +2       ;

SPA        SET LRSS="SP"

           SET LRAA(1)="SURGICAL PATHOLOGY"

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

           IF 'LRAA

               SET LRAA=$$FIND(LRSS)

 +1        QUIT 

 +2       ;

EM         SET LRSS="EM"

           SET LRAA(1)="ELECTRON MICROSCOPY"

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

           IF 'LRAA

               SET LRAA=$$FIND(LRSS)

 +1        QUIT 

 +2       ;

AU         DO EN^LR7OSAP2(LRDFN)

 +1        QUIT 

 +2       ;

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