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 Apr 09, 2024@21:10:11 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
