LRBLPA ;AVAMC/REG/CYM - GET PATIENT INSTR./TESTS ; 7/22/97 19:58 ;
;;5.2;LAB SERVICE;**90,247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
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=$$FMTE^XLFDT(+W,"5F"),W=$TR(W," ","0")
S W=$TR(W,"@"," ")
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)) D
. S W=^LR(LRDFN,"CH",A,0),S=$P(W,"^",5)
. D X
. F B=0:0 S B=$O(V(B)) Q:'B D
.. 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,?18,"Last ",$P(V(B),"^",3),": ",X," ",$P(V(B),"^",4)," ",$P(V(B),"^",5) K V(B)
Q
;
END S Q("Q")=1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPA 1624 printed Oct 16, 2024@18:12:23 Page 2
LRBLPA ;AVAMC/REG/CYM - GET PATIENT INSTR./TESTS ; 7/22/97 19:58 ;
+1 ;;5.2;LAB SERVICE;**90,247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+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))
+5 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
+6 if '$DATA(LRBLT)
DO T
+7 SET X=$SELECT('$DATA(LRPABO):1,LRPABO="":0,1:1)
+8 if X
SET X=$SELECT('$DATA(LRPRH):1,LRPRH="":0,1:1)
+9 IF 'X
WRITE $CHAR(7),!!,"No Patient ABO &/or Rh !",!
IF $DATA(LRU(2))
SET LRDFN=-1
QUIT
+10 KILL V
FOR A=0:0
SET A=$ORDER(LRBLT(A))
if 'A
QUIT
SET V(A)=LRBLT(A)
+11 KILL Q
WRITE !
DO D
IF '$DATA(LRQ)
WRITE !!,"OK TO CONTINUE "
SET %=1
DO YN^LRU
if %'=1
GOTO END
+12 WRITE !!
QUIT
T if LRAA=""
SET LRAA=$ORDER(^LRO(68,"B","BLOOD BANK",0))
+1 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
+2 QUIT
+3 ;
X SET W=$$FMTE^XLFDT(+W,"5F")
SET W=$TRANSLATE(W," ","0")
+1 SET W=$TRANSLATE(W,"@"," ")
+2 QUIT
+3 ;
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
+1 QUIT
D FOR A=0:0
SET A=$ORDER(^LR(LRDFN,"CH",A))
if 'A!('$DATA(V))
QUIT
Begin DoDot:1
+1 SET W=^LR(LRDFN,"CH",A,0)
SET S=$PIECE(W,"^",5)
+2 DO X
+3 FOR B=0:0
SET B=$ORDER(V(B))
if 'B
QUIT
Begin DoDot:2
+4 IF +V(B)=S
IF $DATA(^(+$PIECE(V(B),"^",2)))
SET X=^(+$PIECE(V(B),"^",2))
DO W
End DoDot:2
End DoDot:1
+5 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,?18,"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
