LRAPT1.m

LRAPT1 ;AVAMC/REG/WTY - ANATOMIC PATH PRINT ;10/16/01

 ;;5.2;LAB SERVICE;**1002,1003,1030,1031**;NOV 01, 1997

 ;

 ;;VA LR Patche(s): 72,173,259

 ;

 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

 W !,LRP,?32,"HRCN:",$G(HRCN),?48,"DOB:",DOB     ; IHS/MSC/MKK - LR*5.2*1031

 Q

LRAPT1    ;AVAMC/REG/WTY - ANATOMIC PATH PRINT ;10/16/01

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

 +2       ;

 +3       ;;VA LR Patche(s): 72,173,259

 +4       ;

 +5       ;Indicates an SF515 is being generated

           SET LRSF515=+$GET(LRSF515)

 +6        IF LRSF515

               IF $Y>(IOSL-13)

                   DO F^LRAPF

                   DO ^LRAPF

 +7        IF 'LRSF515

               DO H

               SET LR("F")=1

 +8        IF LR("Q")

               QUIT 

 +9        FOR S="SP","CY","EM"

               IF LR("Q")

                   QUIT 

               Begin DoDot:1

 +10               DO H1

                   IF LR("Q")

                       QUIT 

 +11               SET LRI=0

 +12               FOR 

                       SET LRI=$ORDER(^LR(LRDFN,S,LRI))

                       IF 'LRI!(LR("Q"))

                           QUIT 

                       DO EN^LRAPPF1

               End DoDot:1

 +13       QUIT 

 +14      ;

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       ; W !,LRP,?32,"SSN:",SSN,?48,"DOB:",DOB

 +7       ; IHS/MSC/MKK - LR*5.2*1031

           WRITE !,LRP,?32,"HRCN:",$GET(HRCN),?48,"DOB:",DOB

 +8        QUIT