- 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
