- LRBLDPA2 ; IHS/DIR/AAB - BLOOD DONOR PRINT 6/26/96 20:57 ;
- ;;5.2;LR;**1002**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- 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
- LRBLDPA2 ; IHS/DIR/AAB - BLOOD DONOR PRINT 6/26/96 20:57 ;
- +1 ;;5.2;LR;**1002**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- +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
