- LRSPGD ;AVAMC/REG - ANATOMIC PATH DESCRIPTION ;9/20/95 10:56 ;
- ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- S A=$O(^LR(LRDFN,LRSS,LRI,.1,0)) Q:'A S X=^(A,0) S:$E(X,1)=" " X=$E(X,2,255) Q:X="" S X=$P(X,"^")
- F A=0:0 S A=$O(^LAB(62.5,"B",X,A)) Q:'A I $E(LRSS)_"I"[$P(^LAB(62.5,A,0),"^",4) D S Q
- Q
- S S %X="^LAB(62.5,A,""WP"",",%Y="^LR(LRDFN,LRSS,LRI,1," D %XY^%RCR Q
- M S %X="^LAB(62.5,A,""WP"",",%Y="^LR(LRDFN,LRSS,LRI,1.1," D %XY^%RCR Q
- D S %X="^LAB(62.5,A,""WP"",",%Y="^LR(LRDFN,LRSS,LRI,1.4," D %XY^%RCR Q
- A S %X="^LAB(62.5,A,""WP"",",%Y="^LR(LRDFN,82," D %XY^%RCR Q
- EN ;
- S A=$O(^LR(LRDFN,LRSS,LRI,1.1,0)) G:'A DX S X=$P(^(A,0),"*",2) G:X="" DX
- I $O(^LR(LRDFN,LRSS,LRI,1.1,A)) G DX
- F A=0:0 S A=$O(^LAB(62.5,"B",X,A)) Q:'A I $E(LRSS)_"I"[$P(^LAB(62.5,A,0),"^",4) K ^LR(LRDFN,LRSS,LRI,1.1) D M Q
- DX S A=$O(^LR(LRDFN,LRSS,LRI,1.4,0)) Q:'A S X=$P(^(A,0),"*",2) Q:X=""
- Q:$O(^LR(LRDFN,LRSS,LRI,1.4,A))
- F A=0:0 S A=$O(^LAB(62.5,"B",X,A)) Q:'A I $E(LRSS)_"I"[$P(^LAB(62.5,A,0),"^",4) K ^LR(LRDFN,LRSS,LRI,1.4) D D Q
- Q
- AU ;
- S A=$O(^LR(LRDFN,82,0)) Q:'A S B=$O(^(A)) Q:B S X=$P(^(A,0),"*",2) Q:X=""
- K ^LR(LRDFN,82) F A=0:0 S A=$O(^LAB(62.5,"B",X,A)) Q:'A I $E(LRSS)_"I"[$P(^LAB(62.5,A,0),"^",4) D A Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSPGD 1229 printed Feb 18, 2025@23:46:29 Page 2
- LRSPGD ;AVAMC/REG - ANATOMIC PATH DESCRIPTION ;9/20/95 10:56 ;
- +1 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- +2 SET A=$ORDER(^LR(LRDFN,LRSS,LRI,.1,0))
- if 'A
- QUIT
- SET X=^(A,0)
- if $EXTRACT(X,1)=" "
- SET X=$EXTRACT(X,2,255)
- if X=""
- QUIT
- SET X=$PIECE(X,"^")
- +3 FOR A=0:0
- SET A=$ORDER(^LAB(62.5,"B",X,A))
- if 'A
- QUIT
- IF $EXTRACT(LRSS)_"I"[$PIECE(^LAB(62.5,A,0),"^",4)
- DO S
- QUIT
- +4 QUIT
- S SET %X="^LAB(62.5,A,""WP"","
- SET %Y="^LR(LRDFN,LRSS,LRI,1,"
- DO %XY^%RCR
- QUIT
- M SET %X="^LAB(62.5,A,""WP"","
- SET %Y="^LR(LRDFN,LRSS,LRI,1.1,"
- DO %XY^%RCR
- QUIT
- D SET %X="^LAB(62.5,A,""WP"","
- SET %Y="^LR(LRDFN,LRSS,LRI,1.4,"
- DO %XY^%RCR
- QUIT
- A SET %X="^LAB(62.5,A,""WP"","
- SET %Y="^LR(LRDFN,82,"
- DO %XY^%RCR
- QUIT
- EN ;
- +1 SET A=$ORDER(^LR(LRDFN,LRSS,LRI,1.1,0))
- if 'A
- GOTO DX
- SET X=$PIECE(^(A,0),"*",2)
- if X=""
- GOTO DX
- +2 IF $ORDER(^LR(LRDFN,LRSS,LRI,1.1,A))
- GOTO DX
- +3 FOR A=0:0
- SET A=$ORDER(^LAB(62.5,"B",X,A))
- if 'A
- QUIT
- IF $EXTRACT(LRSS)_"I"[$PIECE(^LAB(62.5,A,0),"^",4)
- KILL ^LR(LRDFN,LRSS,LRI,1.1)
- DO M
- QUIT
- DX SET A=$ORDER(^LR(LRDFN,LRSS,LRI,1.4,0))
- if 'A
- QUIT
- SET X=$PIECE(^(A,0),"*",2)
- if X=""
- QUIT
- +1 if $ORDER(^LR(LRDFN,LRSS,LRI,1.4,A))
- QUIT
- +2 FOR A=0:0
- SET A=$ORDER(^LAB(62.5,"B",X,A))
- if 'A
- QUIT
- IF $EXTRACT(LRSS)_"I"[$PIECE(^LAB(62.5,A,0),"^",4)
- KILL ^LR(LRDFN,LRSS,LRI,1.4)
- DO D
- QUIT
- +3 QUIT
- AU ;
- +1 SET A=$ORDER(^LR(LRDFN,82,0))
- if 'A
- QUIT
- SET B=$ORDER(^(A))
- if B
- QUIT
- SET X=$PIECE(^(A,0),"*",2)
- if X=""
- QUIT
- +2 KILL ^LR(LRDFN,82)
- FOR A=0:0
- SET A=$ORDER(^LAB(62.5,"B",X,A))
- if 'A
- QUIT
- IF $EXTRACT(LRSS)_"I"[$PIECE(^LAB(62.5,A,0),"^",4)
- DO A
- QUIT
- +3 QUIT
