LRUSNOM.m

LRUSNOM ; IHS/DIR/FJE - ANATOMIC PATH REFERENCES 4/12/94 10:15 ;

 ;;5.2;LR;**1013**;JUL 15, 2002

 ;

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

A G:'$D(LRF) END K LR("CK") W ! S (DIE,DIC)=LRF,DIC(0)="AEQM" D ^DIC K DIC G:Y<1 END S DA=+Y I DR=5 D CK^LRU G:$D(LR("CK")) A D ^DIE D FRE^LRU G A

 D PRT G A

 ;

DE D END S LRF="^LAB(61.4," G E ;edit Disease

EE D END S LRF="^LAB(61.2," G E ;edit Etiology

FE D END S LRF="^LAB(61.3," G E ;edit edit Function

ME D END S LRF="^LAB(61.1," G E ;edit edit Morphology

OE D END S LRF="^LAB(61.6," G E ;edit Occupation

TE D END S LRF="^LAB(61," G E ;edit Topography

PE D END S LRF="^LAB(61.5," G E ;edit Procedure

E S DR=5 G LRUSNOM

 ;

DP D END S LRF=61.4 G P

EP D END S LRF=61.2 G P

FP D END S LRF=61.3 G P

MP D END S LRF=61.1 G P

OP D END S LRF=61.6 G P

TP D END S LRF=61 G P

PP D END S LRF=61.5 G P

P S DR="0;JR" G LRUSNOM

 ;

PRT ;print references

 S ZTRTN="QUE^LRUSNOM" D BEG^LRUTL G:POP!($D(ZTSK)) END

QUE U IO S DIC=^DIC(LRF,0,"GL") D EN^DIQ,END^LRUTL Q

 ;

END D V^LRU Q

LRUSNOM   ; IHS/DIR/FJE - ANATOMIC PATH REFERENCES 4/12/94 10:15 ;

 +1       ;;5.2;LR;**1013**;JUL 15, 2002

 +2       ;

 +3       ;;5.2;LAB SERVICE;;Sep 27, 1994

A          IF '$DATA(LRF)

               GOTO END

           KILL LR("CK")

           WRITE !

           SET (DIE,DIC)=LRF

           SET DIC(0)="AEQM"

           DO ^DIC

           KILL DIC

           IF Y<1

               GOTO END

           SET DA=+Y

           IF DR=5

               DO CK^LRU

               IF $DATA(LR("CK"))

                   GOTO A

               DO ^DIE

               DO FRE^LRU

               GOTO A

 +1        DO PRT

           GOTO A

 +2       ;

DE        ;edit Disease

           DO END

           SET LRF="^LAB(61.4,"

           GOTO E

EE        ;edit Etiology

           DO END

           SET LRF="^LAB(61.2,"

           GOTO E

FE        ;edit edit Function

           DO END

           SET LRF="^LAB(61.3,"

           GOTO E

ME        ;edit edit Morphology

           DO END

           SET LRF="^LAB(61.1,"

           GOTO E

OE        ;edit Occupation

           DO END

           SET LRF="^LAB(61.6,"

           GOTO E

TE        ;edit Topography

           DO END

           SET LRF="^LAB(61,"

           GOTO E

PE        ;edit Procedure

           DO END

           SET LRF="^LAB(61.5,"

           GOTO E

E          SET DR=5

           GOTO LRUSNOM

 +1       ;

DP         DO END

           SET LRF=61.4

           GOTO P

EP         DO END

           SET LRF=61.2

           GOTO P

FP         DO END

           SET LRF=61.3

           GOTO P

MP         DO END

           SET LRF=61.1

           GOTO P

OP         DO END

           SET LRF=61.6

           GOTO P

TP         DO END

           SET LRF=61

           GOTO P

PP         DO END

           SET LRF=61.5

           GOTO P

P          SET DR="0;JR"

           GOTO LRUSNOM

 +1       ;

PRT       ;print references

 +1        SET ZTRTN="QUE^LRUSNOM"

           DO BEG^LRUTL

           IF POP!($DATA(ZTSK))

               GOTO END

QUE        USE IO

           SET DIC=^DIC(LRF,0,"GL")

           DO EN^DIQ

           DO END^LRUTL

           QUIT 

 +1       ;

END        DO V^LRU

           QUIT