- 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 Jan 18, 2025@03:09:11 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