LRAPDS.m

LRAPDS ; IHS/DIR/AAB - AP REPORT DISPLAYS/PRINTS 11/9/95 07:22 ;

 ;;5.2;LR;**1002**;JUN 01, 1998

 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 D ^LRAPCUM,END Q

 ;

 ;display

CY D END S (LRAA(1),X)="CYTOPATHOLOGY",LRSS="CY" D SET G LRAPDS

SP D END S (LRAA(1),X)="SURGICAL PATHOLOGY",LRSS="SP" D SET G LRAPDS

EM D END S LRAA(1)="ELECTRON MICROSCOPY",(LRSS,X)="EM" D SET G LRAPDS

 ;

 ;print

PCY D END S (LRAA(1),X)="CYTOPATHOLOGY",LRSS="CY" D SET G P

PSP D END S (LRAA(1),X)="SURGICAL PATHOLOGY",LRSS="SP" D SET G P

PEM D END S LRAA(1)="ELECTRON MICROSCOPY",(LRSS,X)="EM" D SET G P

 ;

P S (LR("R"),LR("W"))=1 D SGL^LRSPRPT,END Q

 ;

END D V^LRU Q

 ;

SET S LRAA=+$O(^LRO(68,"B",X,0)) Q

LRAPDS    ; IHS/DIR/AAB - AP REPORT DISPLAYS/PRINTS 11/9/95 07:22 ;

 +1       ;;5.2;LR;**1002**;JUN 01, 1998

 +2       ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 +3        DO ^LRAPCUM

           DO END

           QUIT 

 +4       ;

 +5       ;display

CY         DO END

           SET (LRAA(1),X)="CYTOPATHOLOGY"

           SET LRSS="CY"

           DO SET

           GOTO LRAPDS

SP         DO END

           SET (LRAA(1),X)="SURGICAL PATHOLOGY"

           SET LRSS="SP"

           DO SET

           GOTO LRAPDS

EM         DO END

           SET LRAA(1)="ELECTRON MICROSCOPY"

           SET (LRSS,X)="EM"

           DO SET

           GOTO LRAPDS

 +1       ;

 +2       ;print

PCY        DO END

           SET (LRAA(1),X)="CYTOPATHOLOGY"

           SET LRSS="CY"

           DO SET

           GOTO P

PSP        DO END

           SET (LRAA(1),X)="SURGICAL PATHOLOGY"

           SET LRSS="SP"

           DO SET

           GOTO P

PEM        DO END

           SET LRAA(1)="ELECTRON MICROSCOPY"

           SET (LRSS,X)="EM"

           DO SET

           GOTO P

 +1       ;

P          SET (LR("R"),LR("W"))=1

           DO SGL^LRSPRPT

           DO END

           QUIT 

 +1       ;

END        DO V^LRU

           QUIT 

 +1       ;

SET        SET LRAA=+$ORDER(^LRO(68,"B",X,0))

           QUIT