LR7OSAP4 ;DALOI/staff - Silent AP API ;11/05/09 10:57
;;5.2;LAB SERVICE;**365,350**;Sep 27, 1994;Build 230
;
EN(LRX,LRDFN,LRSS,LRI,LRGIOM) ;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,B=$G(^LR(LRDFN,LRSS,LRI,0))
;
S GIOM=$G(LRGIOM)
I GIOM="" D
. S GIOM=$$GET^XPAR("USR^DIV^PKG","LR AP GUI REPORT RIGHT MARGIN",1,"Q")
. I GIOM="" S GIOM=96
;
; Display "Printed at:" notice
I $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1 D PFAC^LR7OSMZU
;
I LRSS="AU" D AU
I LRSS'="AU" D
. 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OSAP4 1543 printed Sep 23, 2025@19:41:08 Page 2
LR7OSAP4 ;DALOI/staff - Silent AP API ;11/05/09 10:57
+1 ;;5.2;LAB SERVICE;**365,350**;Sep 27, 1994;Build 230
+2 ;
EN(LRX,LRDFN,LRSS,LRI,LRGIOM) ;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 ;
+8 KILL ^TMP("LRC",$JOB)
+9 ;
+10 if LRSS="CY"
DO CY
if LRSS="SP"
DO SPA
if LRSS="EM"
DO EM
+11 ;
+12 SET FST=0
SET GCNT=0
SET B=$GET(^LR(LRDFN,LRSS,LRI,0))
+13 ;
+14 SET GIOM=$GET(LRGIOM)
+15 IF GIOM=""
Begin DoDot:1
+16 SET GIOM=$$GET^XPAR("USR^DIV^PKG","LR AP GUI REPORT RIGHT MARGIN",1,"Q")
+17 IF GIOM=""
SET GIOM=96
End DoDot:1
+18 ;
+19 ; Display "Printed at:" notice
+20 IF $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1
DO PFAC^LR7OSMZU
+21 ;
+22 IF LRSS="AU"
DO AU
+23 IF LRSS'="AU"
Begin DoDot:1
+24 DO W^LR7OSAP
End DoDot:1
+25 ;
+26 MERGE @LRX=^TMP("LRC",$JOB)
+27 QUIT
+28 ;
+29 ;
CY ;
+1 SET LRSS="CY"
SET LRAA(1)="CYTOPATHOLOGY"
SET LRAA=+$ORDER(^LRO(68,"B",LRAA(1),0))
if 'LRAA
SET LRAA=$$FIND(LRSS)
+2 QUIT
+3 ;
+4 ;
SPA ;
+1 SET LRSS="SP"
SET LRAA(1)="SURGICAL PATHOLOGY"
SET LRAA=+$ORDER(^LRO(68,"B",LRAA(1),0))
if 'LRAA
SET LRAA=$$FIND(LRSS)
+2 QUIT
+3 ;
+4 ;
EM ;
+1 SET LRSS="EM"
SET LRAA(1)="ELECTRON MICROSCOPY"
SET LRAA=+$ORDER(^LRO(68,"B","EM",0))
if 'LRAA
SET LRAA=$$FIND(LRSS)
+2 QUIT
+3 ;
+4 ;
AU ;
+1 DO EN^LR7OSAP2(LRDFN)
+2 QUIT
+3 ;
+4 ;
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
