LRBLPA.m

LRBLPA ; IHS/DIR/AAB - GET PATIENT INSTR./TESTS 7/22/97 19:58 ; [ 04/29/98 10:46 AM ]

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

 ;;5.2;LAB SERVICE;**90**;Sep 27, 1994

 S:'$D(LRLLOC) LRLLOC="?" Q:LRLLOC["DIED"  S:'$D(LRAA)#2 LRAA=$O(^LRO(68,"B","BLOOD BANK",0))

 S (S,E,LRBBSPEC)=$O(^LAB(61,"B","BLOOD",0)) I 'E S (S,E,LRBBSPEC)=$O(^LAB(61,"B","PERIPHERAL BLOOD",0)) I 'E W $C(7),!,"BLOOD or PERIPHERAL BLOOD must be an entry in TOPOGRAPHY file (#61)",! Q

 D:'$D(LRBLT) T S X=$S('$D(LRPABO):1,LRPABO="":0,1:1) S:X X=$S('$D(LRPRH):1,LRPRH="":0,1:1) I 'X W $C(7),!!,"No Patient ABO &/or Rh !",! I $D(LRU(2)) S LRDFN=-1 Q

 K V F A=0:0 S A=$O(LRBLT(A)) Q:'A  S V(A)=LRBLT(A)

 K Q W ! D D I '$D(LRQ) W !!,"OK TO CONTINUE " S %=1 D YN^LRU G:%'=1 END

 W !! Q

T S:LRAA="" LRAA=$O(^LRO(68,"B","BLOOD BANK",0)) F A=0:0 S A=$O(^LRO(69.2,LRAA,61,S,1,A)) Q:'A  S Y=^(A,0),W=$P(Y,"^",2),Y=+Y D S

 Q

 ;

X S W=+W_"000",W=$E(W,4,5)_"/"_$E(W,6,7)_$S(W[".":" "_$E(W,9,10)_":"_$E(W,11,12),1:"") Q

 ;

S S X=^LAB(60,Y,0),Z=$S($D(^(1,W,0)):$P(^(0),"^",7),1:""),LRBLT(A)=W_"^"_$P($P(X,"^",5),";",2,3)_"^"_$P(X,"^")_"^"_Z_"^"_$P(^LAB(61,W,0),"^")_"^"_Y Q

D F A=0:0 S A=$O(^LR(LRDFN,"CH",A)) Q:'A!('$D(V))  S W=^(A,0),S=$P(W,"^",5) D X F B=0:0 S B=$O(V(B)) Q:'B  I +V(B)=S,$D(^(+$P(V(B),"^",2))) S X=^(+$P(V(B),"^",2)) D W

 Q

W S Y=$P($P(V(B),"^",2),";",2),X=$P(X,"^",Y)

 S S($P(V(B),"^",6),S)=X_"^"_$P(V(B),"^",3)_"^"_W_"^"_$P(V(B),"^",4)_"^"_$P(V(B),"^",5) W !,W,?12,"Last ",$P(V(B),"^",3),": ",X," ",$P(V(B),"^",4)," ",$P(V(B),"^",5) K V(B)

 Q

 ;

END S Q("Q")=1 Q

LRBLPA    ; IHS/DIR/AAB - GET PATIENT INSTR./TESTS 7/22/97 19:58 ; [ 04/29/98 10:46 AM ]

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

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

 +3        IF '$DATA(LRLLOC)

               SET LRLLOC="?"

           IF LRLLOC["DIED"

               QUIT 

           IF '$DATA(LRAA)#2

               SET LRAA=$ORDER(^LRO(68,"B","BLOOD BANK",0))

 +4        SET (S,E,LRBBSPEC)=$ORDER(^LAB(61,"B","BLOOD",0))

           IF 'E

               SET (S,E,LRBBSPEC)=$ORDER(^LAB(61,"B","PERIPHERAL BLOOD",0))

               IF 'E

                   WRITE $CHAR(7),!,"BLOOD or PERIPHERAL BLOOD must be an entry in TOPOGRAPHY file (#61)",!

                   QUIT 

 +5        IF '$DATA(LRBLT)

               DO T

           SET X=$SELECT('$DATA(LRPABO):1,LRPABO="":0,1:1)

           IF X

               SET X=$SELECT('$DATA(LRPRH):1,LRPRH="":0,1:1)

           IF 'X

               WRITE $CHAR(7),!!,"No Patient ABO &/or Rh !",!

               IF $DATA(LRU(2))

                   SET LRDFN=-1

                   QUIT 

 +6        KILL V

           FOR A=0:0

               SET A=$ORDER(LRBLT(A))

               IF 'A

                   QUIT 

               SET V(A)=LRBLT(A)

 +7        KILL Q

           WRITE !

           DO D

           IF '$DATA(LRQ)

               WRITE !!,"OK TO CONTINUE "

               SET %=1

               DO YN^LRU

               IF %'=1

                   GOTO END

 +8        WRITE !!

           QUIT 

T          IF LRAA=""

               SET LRAA=$ORDER(^LRO(68,"B","BLOOD BANK",0))

           FOR A=0:0

               SET A=$ORDER(^LRO(69.2,LRAA,61,S,1,A))

               IF 'A

                   QUIT 

               SET Y=^(A,0)

               SET W=$PIECE(Y,"^",2)

               SET Y=+Y

               DO S

 +1        QUIT 

 +2       ;

X          SET W=+W_"000"

           SET W=$EXTRACT(W,4,5)_"/"_$EXTRACT(W,6,7)_$SELECT(W[".":" "_$EXTRACT(W,9,10)_":"_$EXTRACT(W,11,12),1:"")

           QUIT 

 +1       ;

S          SET X=^LAB(60,Y,0)

           SET Z=$SELECT($DATA(^(1,W,0)):$PIECE(^(0),"^",7),1:"")

           SET LRBLT(A)=W_"^"_$PIECE($PIECE(X,"^",5),";",2,3)_"^"_$PIECE(X,"^")_"^"_Z_"^"_$PIECE(^LAB(61,W,0),"^")_"^"_Y

           QUIT 

D          FOR A=0:0

               SET A=$ORDER(^LR(LRDFN,"CH",A))

               IF 'A!('$DATA(V))

                   QUIT 

               SET W=^(A,0)

               SET S=$PIECE(W,"^",5)

               DO X

               FOR B=0:0

                   SET B=$ORDER(V(B))

                   IF 'B

                       QUIT 

                   IF +V(B)=S

                       IF $DATA(^(+$PIECE(V(B),"^",2)))

                           SET X=^(+$PIECE(V(B),"^",2))

                           DO W

 +1        QUIT 

W          SET Y=$PIECE($PIECE(V(B),"^",2),";",2)

           SET X=$PIECE(X,"^",Y)

 +1        SET S($PIECE(V(B),"^",6),S)=X_"^"_$PIECE(V(B),"^",3)_"^"_W_"^"_$PIECE(V(B),"^",4)_"^"_$PIECE(V(B),"^",5)

           WRITE !,W,?12,"Last ",$PIECE(V(B),"^",3),": ",X," ",$PIECE(V(B),"^",4)," ",$PIECE(V(B),"^",5)

           KILL V(B)

 +2        QUIT 

 +3       ;

END        SET Q("Q")=1

           QUIT