LRSPGD.m

LRSPGD ; IHS/DIR/AAB - ANATOMIC PATH DESCRIPTION 9/20/95 10:56 ;

 ;;5.2;LR;**1002**;JUN 01, 1998

 ;;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

LRSPGD    ; IHS/DIR/AAB - ANATOMIC PATH DESCRIPTION 9/20/95 10:56 ;

 +1       ;;5.2;LR;**1002**;JUN 01, 1998

 +2       ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 +3        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,"^")

 +4        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 

 +5        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