LRBLDPA2 ;AVAMC/REG/CYM - BLOOD DONOR PRINT 6/26/96 20:57 ;
;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
S Y=$P(LRZ,U,2) D D^LRU W !,"COLLECTION STARTED: ",Y S Y=$P(LRZ,U,3) D D^LRU W ?40,"COMPLETED: ",Y
S Y=$P(LRZ,U,4) D D^LRU W !?9,"PROCESSED: ",Y,?40,"COLLECTION WT(gm): ",$P(LRZ,U,5)
W !,"EMPTY PRIMARY UNIT(gm): ",$P(LRZ,U,6),?40,"COLLECTION VOL(ml): ",$P(LRZ,U,7)
S X=+$P(LRZ,U,8) D V^LRBLDPA1 W !,"PROCESSING TECH: ",X
W:$P(LRX,U,5)]"" !,"PATIENT CREDIT: ",$P(LRX,U,5) W:$P(LRX,U,9)]"" !,"PHLEBOTOMIST: ",$P(LRX,U,9)
S X=$P(LRX,U,10),Z=6.1 D S^LRBLDPA1 W !,"COLLECTION DISPOSITION: ",Y
S C=0 F E=1:1 S C=$O(^LRE(LR,5,A,3,C)) Q:'C!(LR("Q")) S LRA=^(C,0) D M^LRBLDPA1 Q:LR("Q") W:E=1 !,"COLLECTION DISPOSITION COMMENT:" W !?3,LRA
D M^LRBLDPA1 Q:LR("Q") S I=$S($D(^LRE(LR,5,A,10)):^(10),1:"") S X=$P(I,U),Z=10 D S^LRBLDPA1 W !,"ABO INTERPRETATION: ",Y S X=+$P(I,U,2) D V^LRBLDPA1 W ?40,"TECH: ",X I $P(I,U,3)]"" W !,$P(I,U,3)
I $P(I,U,4)]"" S X=$P(I,U,4),Z=10.4 D S^LRBLDPA1 W !,"ABO RECHECK: ",Y S X=+$P(I,U,5) D V^LRBLDPA1 W ?40,"RECHECH TECH: ",X I $P(I,U,6)]"" W !,$P(I,U,6)
D M^LRBLDPA1 Q:LR("Q") S I=$S($D(^LRE(LR,5,A,11)):^(11),1:"") S X=$P(I,U),Z=11 D S^LRBLDPA1 W !,"RH INTERPRETATION: ",Y S X=+$P(I,U,2) D V^LRBLDPA1 W ?40,"TECH: ",X I $P(I,U,3)]"" W !,$P(I,U,3)
I $P(I,U,4)]"" S X=$P(I,U,4),Z=11.4 D S^LRBLDPA1 W !,"RH RECHECK: ",Y S X=+$P(I,U,5) D V^LRBLDPA1 W ?40,"RECHECH TECH: ",X I $P(I,U,6)]"" W !,$P(I,U,6)
F LRZ=12:1:20 D T Q:LR("Q")
Q:LR("Q") S LRF=65.66,C=0 F E=1:1 S C=$O(^LRE(LR,5,A,66,C)) Q:'C!(LR("Q")) S LRA=^(C,0) D M^LRBLDPA1 Q:LR("Q") W:E=1 !!,"COMPONENT PREPARED:" S X=+LRA W !?3,$S($D(^LAB(66,X,0)):$P(^(0),U),1:X) D R
Q
T D M^LRBLDPA1 Q:LR("Q")
S I=$S($D(^LRE(LR,5,A,LRZ)):^(LRZ),1:"") S X=$P(I,U),Z=LRZ D S^LRBLDPA1 D FIELD^DID(65.54,LRZ,"","LABEL","NAME") S NAME=NAME("LABEL") W !,NAME,": ",Y
S X=+$P(I,U,2) D V^LRBLDPA1 W ?40,"TECH: ",X
I $P(I,U,3)]"" D FIELD^DID(65.54,LRZ_.3,"","LABEL","NAME") S NAME=NAME("LABEL") W !,NAME,": ",$P(I,U,3)
Q
R S Y=$P(LRA,U,2) D D^LRU W ?40,"DISPOSITION DATE: ",Y S Y=$P(LRA,U,3) D D^LRU W !,"DATE STORED: ",Y S Y=$P(LRA,U,4) D D^LRU W ?40,"EXPIRATION DATE: ",Y
W !,"COMPONENT VOL(ml): ",$P(LRA,U,5) S X=+$P(LRA,U,6) D V^LRBLDPA1 W ?40,"LABELING TECH:",X
S X=+$P(LRA,U,7) D V^LRBLDPA1 W !,"DISPOSITION TECH:",X S X=$P(LRA,U,8),Z=.08 D S^LRBLDPA1 W ?40,"DISPOSITION: ",Y
S F=0 F G=1:1 S F=$O(^LRE(LR,5,A,66,C,1,F)) Q:'F!(LR("Q")) S LRB=^(F,0) D M^LRBLDPA1 Q:LR("Q") W:G=1 !,"COMPONENT DISPOSITION COMMENT:" W !,LRB
Q
A ;donor antigen list from LRBLDPA1
S E=1,(F(1),G)="" F V=1.1,1.3 F B=0:0 S B=$O(^LRE(LR,V,B)) Q:'B S I=$P(^LAB(61.3,B,0),"^"),F(E)=F(E)_I_", ",G=G+1 I $L(F(E))>39 S F(E)=$P(F(E),", ",1,G-1),E=E+1,F(E)=I_", ",G=""
S K=E,E=1,(J(1),G)="" F V=1.2,1.4 F B=0:0 S B=$O(^LRE(LR,V,B)) Q:'B S I=$P(^LAB(61.3,B,0),"^"),J(E)=J(E)_I_", ",G=G+1 I $L(J(E))>39 S J(E)=$P(J(E),", ",1,G-1),E=E+1,J(E)=I_", ",G=""
I $L(F(1))!($L(J(1))) W !,"Antigen(s) present",?40,"| Antigen(s) absent",! S:E>K K=E F E=1:1:K W:E>1 ! S X=$S($D(F(E)):F(E),1:"") D:X]"" C W ?40,"|" S X=$S($D(J(E)):J(E),1:"") D:X]"" C
Q:LR("Q") W ! F A=1.1,1.2,1.3,1.4 D L Q:LR("Q")
Q:LR("Q") S X=$P(LRX,U,15) I X]"" S Z=6.5,LRF=65.5 D S^LRBLDPA1 W !,"CMV ANTIBODY: ",Y
Q
C S Y=$L(X) I $E(X,Y-1,Y)=", " S X=$E(X,1,Y-2)
W X Q
L S B=0 F C=1:1 S B=$O(^LRE(LR,A,B)) Q:'B!(LR("Q")) S LRB=^(B,0) I $P(LRB,U,2)]"" D:$Y>(IOSL-6) H^LRBLDPA1 Q:LR("Q") W !?3,$P(^LAB(61.3,B,0),U) W:$P(LRB,U,2)]"" !?5,$P(LRB,U,2)
Q
P S X=^LR(X,0),Y=$P(X,U,3),X=^DIC($P(X,"^",2),0,"GL"),X=@(X_Y_",0)") Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDPA2 3688 printed Dec 13, 2024@02:10:42 Page 2
LRBLDPA2 ;AVAMC/REG/CYM - BLOOD DONOR PRINT 6/26/96 20:57 ;
+1 ;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 SET Y=$PIECE(LRZ,U,2)
DO D^LRU
WRITE !,"COLLECTION STARTED: ",Y
SET Y=$PIECE(LRZ,U,3)
DO D^LRU
WRITE ?40,"COMPLETED: ",Y
+4 SET Y=$PIECE(LRZ,U,4)
DO D^LRU
WRITE !?9,"PROCESSED: ",Y,?40,"COLLECTION WT(gm): ",$PIECE(LRZ,U,5)
+5 WRITE !,"EMPTY PRIMARY UNIT(gm): ",$PIECE(LRZ,U,6),?40,"COLLECTION VOL(ml): ",$PIECE(LRZ,U,7)
+6 SET X=+$PIECE(LRZ,U,8)
DO V^LRBLDPA1
WRITE !,"PROCESSING TECH: ",X
+7 if $PIECE(LRX,U,5)]""
WRITE !,"PATIENT CREDIT: ",$PIECE(LRX,U,5)
if $PIECE(LRX,U,9)]""
WRITE !,"PHLEBOTOMIST: ",$PIECE(LRX,U,9)
+8 SET X=$PIECE(LRX,U,10)
SET Z=6.1
DO S^LRBLDPA1
WRITE !,"COLLECTION DISPOSITION: ",Y
+9 SET C=0
FOR E=1:1
SET C=$ORDER(^LRE(LR,5,A,3,C))
if 'C!(LR("Q"))
QUIT
SET LRA=^(C,0)
DO M^LRBLDPA1
if LR("Q")
QUIT
if E=1
WRITE !,"COLLECTION DISPOSITION COMMENT:"
WRITE !?3,LRA
+10 DO M^LRBLDPA1
if LR("Q")
QUIT
SET I=$SELECT($DATA(^LRE(LR,5,A,10)):^(10),1:"")
SET X=$PIECE(I,U)
SET Z=10
DO S^LRBLDPA1
WRITE !,"ABO INTERPRETATION: ",Y
SET X=+$PIECE(I,U,2)
DO V^LRBLDPA1
WRITE ?40,"TECH: ",X
IF $PIECE(I,U,3)]""
WRITE !,$PIECE(I,U,3)
+11 IF $PIECE(I,U,4)]""
SET X=$PIECE(I,U,4)
SET Z=10.4
DO S^LRBLDPA1
WRITE !,"ABO RECHECK: ",Y
SET X=+$PIECE(I,U,5)
DO V^LRBLDPA1
WRITE ?40,"RECHECH TECH: ",X
IF $PIECE(I,U,6)]""
WRITE !,$PIECE(I,U,6)
+12 DO M^LRBLDPA1
if LR("Q")
QUIT
SET I=$SELECT($DATA(^LRE(LR,5,A,11)):^(11),1:"")
SET X=$PIECE(I,U)
SET Z=11
DO S^LRBLDPA1
WRITE !,"RH INTERPRETATION: ",Y
SET X=+$PIECE(I,U,2)
DO V^LRBLDPA1
WRITE ?40,"TECH: ",X
IF $PIECE(I,U,3)]""
WRITE !,$PIECE(I,U,3)
+13 IF $PIECE(I,U,4)]""
SET X=$PIECE(I,U,4)
SET Z=11.4
DO S^LRBLDPA1
WRITE !,"RH RECHECK: ",Y
SET X=+$PIECE(I,U,5)
DO V^LRBLDPA1
WRITE ?40,"RECHECH TECH: ",X
IF $PIECE(I,U,6)]""
WRITE !,$PIECE(I,U,6)
+14 FOR LRZ=12:1:20
DO T
if LR("Q")
QUIT
+15 if LR("Q")
QUIT
SET LRF=65.66
SET C=0
FOR E=1:1
SET C=$ORDER(^LRE(LR,5,A,66,C))
if 'C!(LR("Q"))
QUIT
SET LRA=^(C,0)
DO M^LRBLDPA1
if LR("Q")
QUIT
if E=1
WRITE !!,"COMPONENT PREPARED:"
SET X=+LRA
WRITE !?3,$SELECT($DATA(^LAB(66,X,0)):$PIECE(^(0),U),1:X)
DO R
+16 QUIT
T DO M^LRBLDPA1
if LR("Q")
QUIT
+1 SET I=$SELECT($DATA(^LRE(LR,5,A,LRZ)):^(LRZ),1:"")
SET X=$PIECE(I,U)
SET Z=LRZ
DO S^LRBLDPA1
DO FIELD^DID(65.54,LRZ,"","LABEL","NAME")
SET NAME=NAME("LABEL")
WRITE !,NAME,": ",Y
+2 SET X=+$PIECE(I,U,2)
DO V^LRBLDPA1
WRITE ?40,"TECH: ",X
+3 IF $PIECE(I,U,3)]""
DO FIELD^DID(65.54,LRZ_.3,"","LABEL","NAME")
SET NAME=NAME("LABEL")
WRITE !,NAME,": ",$PIECE(I,U,3)
+4 QUIT
R SET Y=$PIECE(LRA,U,2)
DO D^LRU
WRITE ?40,"DISPOSITION DATE: ",Y
SET Y=$PIECE(LRA,U,3)
DO D^LRU
WRITE !,"DATE STORED: ",Y
SET Y=$PIECE(LRA,U,4)
DO D^LRU
WRITE ?40,"EXPIRATION DATE: ",Y
+1 WRITE !,"COMPONENT VOL(ml): ",$PIECE(LRA,U,5)
SET X=+$PIECE(LRA,U,6)
DO V^LRBLDPA1
WRITE ?40,"LABELING TECH:",X
+2 SET X=+$PIECE(LRA,U,7)
DO V^LRBLDPA1
WRITE !,"DISPOSITION TECH:",X
SET X=$PIECE(LRA,U,8)
SET Z=.08
DO S^LRBLDPA1
WRITE ?40,"DISPOSITION: ",Y
+3 SET F=0
FOR G=1:1
SET F=$ORDER(^LRE(LR,5,A,66,C,1,F))
if 'F!(LR("Q"))
QUIT
SET LRB=^(F,0)
DO M^LRBLDPA1
if LR("Q")
QUIT
if G=1
WRITE !,"COMPONENT DISPOSITION COMMENT:"
WRITE !,LRB
+4 QUIT
A ;donor antigen list from LRBLDPA1
+1 SET E=1
SET (F(1),G)=""
FOR V=1.1,1.3
FOR B=0:0
SET B=$ORDER(^LRE(LR,V,B))
if 'B
QUIT
SET I=$PIECE(^LAB(61.3,B,0),"^")
SET F(E)=F(E)_I_", "
SET G=G+1
IF $LENGTH(F(E))>39
SET F(E)=$PIECE(F(E),", ",1,G-1)
SET E=E+1
SET F(E)=I_", "
SET G=""
+2 SET K=E
SET E=1
SET (J(1),G)=""
FOR V=1.2,1.4
FOR B=0:0
SET B=$ORDER(^LRE(LR,V,B))
if 'B
QUIT
SET I=$PIECE(^LAB(61.3,B,0),"^")
SET J(E)=J(E)_I_", "
SET G=G+1
IF $LENGTH(J(E))>39
SET J(E)=$PIECE(J(E),", ",1,G-1)
SET E=E+1
SET J(E)=I_", "
SET G=""
+3 IF $LENGTH(F(1))!($LENGTH(J(1)))
WRITE !,"Antigen(s) present",?40,"| Antigen(s) absent",!
if E>K
SET K=E
FOR E=1:1:K
if E>1
WRITE !
SET X=$SELECT($DATA(F(E)):F(E),1:"")
if X]""
DO C
WRITE ?40,"|"
SET X=$SELECT($DATA(J(E)):J(E),1:"")
if X]""
DO C
+4 if LR("Q")
QUIT
WRITE !
FOR A=1.1,1.2,1.3,1.4
DO L
if LR("Q")
QUIT
+5 if LR("Q")
QUIT
SET X=$PIECE(LRX,U,15)
IF X]""
SET Z=6.5
SET LRF=65.5
DO S^LRBLDPA1
WRITE !,"CMV ANTIBODY: ",Y
+6 QUIT
C SET Y=$LENGTH(X)
IF $EXTRACT(X,Y-1,Y)=", "
SET X=$EXTRACT(X,1,Y-2)
+1 WRITE X
QUIT
L SET B=0
FOR C=1:1
SET B=$ORDER(^LRE(LR,A,B))
if 'B!(LR("Q"))
QUIT
SET LRB=^(B,0)
IF $PIECE(LRB,U,2)]""
if $Y>(IOSL-6)
DO H^LRBLDPA1
if LR("Q")
QUIT
WRITE !?3,$PIECE(^LAB(61.3,B,0),U)
if $PIECE(LRB,U,2)]""
WRITE !?5,$PIECE(LRB,U,2)
+1 QUIT
P SET X=^LR(X,0)
SET Y=$PIECE(X,U,3)
SET X=^DIC($PIECE(X,"^",2),0,"GL")
SET X=@(X_Y_",0)")
QUIT
