LRUSNOM ;AVAMC/REG - ANATOMIC PATH REFERENCES ;4/12/94 10:15 ;
;;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUSNOM 992 printed Dec 13, 2024@02:22:09 Page 2
LRUSNOM ;AVAMC/REG - ANATOMIC PATH REFERENCES ;4/12/94 10:15 ;
+1 ;;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
