Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRAPT1

LRAPT1.m

Go to the documentation of this file.
  1. LRAPT1 ;AVAMC/REG/WTY - ANATOMIC PATH PRINT ;10/16/01
  1. ;;5.2;LAB SERVICE;**72,173,259**;Sep 27, 1994
  1. S LRSF515=+$G(LRSF515) ;Indicates an SF515 is being generated
  1. I LRSF515 D:$Y>(IOSL-13) F^LRAPF,^LRAPF
  1. I 'LRSF515 D H S LR("F")=1
  1. Q:LR("Q")
  1. F S="SP","CY","EM" Q:LR("Q") D
  1. .D H1 Q:LR("Q")
  1. .S LRI=0
  1. .F S LRI=$O(^LR(LRDFN,S,LRI)) Q:'LRI!(LR("Q")) D EN^LRAPPF1
  1. Q
  1. ;
  1. H1 ;
  1. N LRTMP
  1. Q:'$O(^LR(LRDFN,S,0))
  1. I LRSF515 D:$Y>(IOSL-13) F^LRAPF,^LRAPF
  1. I 'LRSF515 D:$Y>(IOSL-14) H
  1. Q:LR("Q")
  1. S LRTMP=$S(S="SP":"SURGICAL PATHOLOGY",S="CY":"CYTOPATHOLOGY",1:"")
  1. S:LRTMP="" LRTMP=$S(S="EM":"ELECTRON MICROSCOPY",1:"")
  1. W !!,?30,LRTMP
  1. Q
  1. ;
  1. H I $D(LR("F")),$E(IOST,1,2)["C-" D M^LRU Q:LR("Q")
  1. D F^LRU W !,"ANATOMIC PATHOLOGY"
  1. I $D(LR("W")) D
  1. .W !,$S($D(LRO(68)):LRO(68),1:LRAA(1))," QA from ",LRSTR
  1. .W " to ",LRLST
  1. W !,LR("%")
  1. W !,LRP,?32,"SSN:",SSN,?48,"DOB:",DOB
  1. Q