LRAPT1 ;AVAMC/REG/WTY - ANATOMIC PATH PRINT ;10/16/01
;;5.2;LAB SERVICE;**72,173,259**;Sep 27, 1994
S LRSF515=+$G(LRSF515) ;Indicates an SF515 is being generated
I LRSF515 D:$Y>(IOSL-13) F^LRAPF,^LRAPF
I 'LRSF515 D H S LR("F")=1
Q:LR("Q")
F S="SP","CY","EM" Q:LR("Q") D
.D H1 Q:LR("Q")
.S LRI=0
.F S LRI=$O(^LR(LRDFN,S,LRI)) Q:'LRI!(LR("Q")) D EN^LRAPPF1
Q
;
H1 ;
N LRTMP
Q:'$O(^LR(LRDFN,S,0))
I LRSF515 D:$Y>(IOSL-13) F^LRAPF,^LRAPF
I 'LRSF515 D:$Y>(IOSL-14) H
Q:LR("Q")
S LRTMP=$S(S="SP":"SURGICAL PATHOLOGY",S="CY":"CYTOPATHOLOGY",1:"")
S:LRTMP="" LRTMP=$S(S="EM":"ELECTRON MICROSCOPY",1:"")
W !!,?30,LRTMP
Q
;
H I $D(LR("F")),$E(IOST,1,2)["C-" D M^LRU Q:LR("Q")
D F^LRU W !,"ANATOMIC PATHOLOGY"
I $D(LR("W")) D
.W !,$S($D(LRO(68)):LRO(68),1:LRAA(1))," QA from ",LRSTR
.W " to ",LRLST
W !,LR("%")
W !,LRP,?32,"SSN:",SSN,?48,"DOB:",DOB
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPT1 903 printed Dec 13, 2024@02:08:28 Page 2
LRAPT1 ;AVAMC/REG/WTY - ANATOMIC PATH PRINT ;10/16/01
+1 ;;5.2;LAB SERVICE;**72,173,259**;Sep 27, 1994
+2 ;Indicates an SF515 is being generated
SET LRSF515=+$GET(LRSF515)
+3 IF LRSF515
if $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
+4 IF 'LRSF515
DO H
SET LR("F")=1
+5 if LR("Q")
QUIT
+6 FOR S="SP","CY","EM"
if LR("Q")
QUIT
Begin DoDot:1
+7 DO H1
if LR("Q")
QUIT
+8 SET LRI=0
+9 FOR
SET LRI=$ORDER(^LR(LRDFN,S,LRI))
if 'LRI!(LR("Q"))
QUIT
DO EN^LRAPPF1
End DoDot:1
+10 QUIT
+11 ;
H1 ;
+1 NEW LRTMP
+2 if '$ORDER(^LR(LRDFN,S,0))
QUIT
+3 IF LRSF515
if $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
+4 IF 'LRSF515
if $Y>(IOSL-14)
DO H
+5 if LR("Q")
QUIT
+6 SET LRTMP=$SELECT(S="SP":"SURGICAL PATHOLOGY",S="CY":"CYTOPATHOLOGY",1:"")
+7 if LRTMP=""
SET LRTMP=$SELECT(S="EM":"ELECTRON MICROSCOPY",1:"")
+8 WRITE !!,?30,LRTMP
+9 QUIT
+10 ;
H IF $DATA(LR("F"))
IF $EXTRACT(IOST,1,2)["C-"
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,"ANATOMIC PATHOLOGY"
+2 IF $DATA(LR("W"))
Begin DoDot:1
+3 WRITE !,$SELECT($DATA(LRO(68)):LRO(68),1:LRAA(1))," QA from ",LRSTR
+4 WRITE " to ",LRLST
End DoDot:1
+5 WRITE !,LR("%")
+6 WRITE !,LRP,?32,"SSN:",SSN,?48,"DOB:",DOB
+7 QUIT
