- 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 Jan 18, 2025@03:22:51 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