- LRBLPR1 ;AVAMC/REG - BLOOD BANK PT RECORD-COND'T ;9/11/95 07:30 ;
- ;;5.2;LAB SERVICE;**1,72,247**;Sep 27, 1994
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- D E S LR(9)=0 F LRZ=0:1 S LR(9)=$O(^LR(LRDFN,3,LR(9))) Q:'LR(9)!(LR("Q")) D:$Y>(IOSL-6) H^LRBLPR,H Q:LR("Q") S X=^LR(LRDFN,3,LR(9),0) D ^DIWP
- Q:LR("Q") D:LRZ ^DIWW
- D S Q:LR("Q")
- I $O(^LR(LRDFN,1.7,0)) W !?4,"Antibodies identified: " F LR(9)=0:0 S LR(9)=$O(^LR(LRDFN,1.7,LR(9))) Q:'LR(9)!(LR("Q")) D:$Y>(IOSL-6) H1 Q:LR("Q") W:$X>(IOM-15) !?4 W " ",$P(^LAB(61.3,LR(9),0),"^")
- Q:LR("Q") I $D(^LR(LRDFN,LRSS)),LR(8) D V
- W ! Q
- ;
- V W !,"Accession Number",?24,"Date/time",?40,"ABO",?44,"Rh",?48,"AHG(D)",?55,"AHG(I)"
- S LRI=0 F A=1:1 S LRI=$O(^LR(LRDFN,LRSS,LRI)) Q:'LRI!(A>LR(8))!(LR("Q")) S LR(5)=^(LRI,0) D:$Y>(IOSL-6) H2 Q:LR("Q") S T=+LR(5) D T W !,$J($P(LR(5),"^",6),15),?24,T D W
- Q
- W S LR(10)=$S($D(^LR(LRDFN,LRSS,LRI,10)):^(10),1:""),LR(11)=$S($D(^(11)):^(11),1:""),LR(0)=$S($D(^(2)):^(2),1:""),LR(6)=$S($D(^(6)):^(6),1:"")
- W ?41,$J($P(LR(10),"^"),2),?44,$P(LR(11),"^"),?51,$P(LR(0),"^",9),?58,$P(LR(6),"^")
- F E=10,11 I $P(LR(E),"^",3)]"" D:$Y>(IOSL-6) H2 Q:LR("Q") S X=$P(LR(E),"^",3) W !?20,$E(X,1,59) I $L(X)>59 W !?40,$E(X,60,80)
- Q:LR("Q") D:$Y>(IOSL-6) H2 Q:LR("Q") S X=$P(LR(0),"^",10) I X]"" W !?20,$E(X,1,59) W:$L(X)>59 !?40,$E(X,60,80)
- F E=0:0 S E=$O(^LR(LRDFN,LRSS,LRI,4,E)) Q:'E!(LR("Q")) D:$Y>(IOSL-6) H2 Q:LR("Q") S X=^LR(LRDFN,LRSS,LRI,4,E,0) W !?20,$E(X,1,59) W:$L(X)>59 !?40,$E(X,60,80)
- Q:LR("Q") F E=0:0 S E=$O(^LR(LRDFN,LRSS,LRI,5,E)) Q:'E!(LR("Q")) D:$Y>(IOSL-6) H2 Q:LR("Q") S X=+^LR(LRDFN,LRSS,LRI,5,E,0) I X,$D(^LAB(61.3,X,0)) W !?20,"Serum antibody: ",$P(^(0),"^")
- Q:LR("Q") F E=0:0 S E=$O(^LR(LRDFN,LRSS,LRI,"EA",E)) Q:'E!(LR("Q")) D:$Y>(IOSL-6) H2 Q:LR("Q") W !?20,"Eluate antibody: ",$P(^LAB(61.3,E,0),"^")
- Q:LR("Q") F E=0:0 S E=$O(^LR(LRDFN,LRSS,LRI,99,E)) Q:'E!(LR("Q")) S LRE=^(E,0) D:$Y>(IOSL-6) H2 Q:LR("Q") W !?8,LRE
- Q
- T S T=T_"000",T=$E(T,4,5)_"/"_$E(T,6,7)_"/"_$E(T,2,3)_$S(T[".":" "_$E(T,9,10)_":"_$E(T,11,12),1:"") Q
- E K ^UTILITY($J) S DIWR=IOM-5,DIWL=5,DIWF="W" Q
- H Q:LR("Q") W !,LRP,?31,$P(LR(4),"^",2),?42,"[See previous page (Pg ",LRQ-1,")]" Q
- H1 D H^LRBLPR,H Q:LR("Q") W !?4,"Antibodies identified (cond't): " Q
- H2 D H^LRBLPR,H Q:LR("Q") W !?4,"Date/time",?20,"ABO",?24,"Rh",?28,"AHG(D)",?35,"AHG(I)" Q
- H3 D H^LRBLPR,H Q:LR("Q") W !,"TRANSFUSION REACTIONS WITH UNIT IDENTIFIED",?51,"UNIT ID",?66,"COMPONENT" Q
- H4 D H^LRBLPR,H Q:LR("Q") W !,"TRANSFUSION REACTIONS WITHOUT UNIT IDENTIFIED" Q
- S S (C,LRA)=0 F B=0:1 S C=$O(^LR("AB",LRDFN,C)) Q:'C!(LR("Q")) F A=0:0 S A=$O(^LR("AB",LRDFN,C,A)) Q:'A!(LR("Q")) D R
- Q:LR("Q") S A=0 W ! F B=0:1 S A=$O(^LR(LRDFN,1.9,A)) Q:'A!(LR("Q")) S LR(1.9)=^(A,0) W:'B !,"TRANSFUSION REACTIONS WITHOUT UNIT IDENTIFIED:" S Y=+LR(1.9) D D^LRU W !,Y,?21,$P($G(^LAB(65.4,+$P(LR(1.9),U,2),0)),U) D A
- Q
- A D:$Y>(IOSL-6) H4 Q:LR("Q") F B=0:0 S B=$O(^LR(LRDFN,1.9,A,1,B)) Q:'B!(LR("Q")) S B(1)=^(B,0) D:$Y>(IOSL-6) H4 Q:LR("Q") W !,B(1)
- Q
- R S LR(1.9)=$G(^LR(LRDFN,1.6,A,0)),Y=+LR(1.9) I LR(1.9)="" K ^LR("AB",LRDFN,C,A) Q
- D D^LRU W:'LRA !,"TRANSFUSION REACTIONS WITH UNIT IDENTIFIED",?51,"UNIT ID",?66,"COMPONENT" W !,Y,?21,$P($G(^LAB(65.4,C,0)),U),?51,$P(LR(1.9),U,3),?69,$P($G(^LAB(66,+$P(LR(1.9),U,2),0)),U,2) S LRA=LRA+1
- D:$Y>(IOSL-6) H3 Q:LR("Q") F B(1)=0:0 S B(1)=$O(^LR(LRDFN,1.6,A,1,B(1))) Q:'B(1)!(LR("Q")) S B(2)=^(B(1),0) D:$Y>(IOSL-6) H3 Q:LR("Q") W !,B(2)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPR1 3535 printed Feb 18, 2025@23:37:52 Page 2
- LRBLPR1 ;AVAMC/REG - BLOOD BANK PT RECORD-COND'T ;9/11/95 07:30 ;
- +1 ;;5.2;LAB SERVICE;**1,72,247**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 DO E
- SET LR(9)=0
- FOR LRZ=0:1
- SET LR(9)=$ORDER(^LR(LRDFN,3,LR(9)))
- if 'LR(9)!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)
- DO H^LRBLPR
- DO H
- if LR("Q")
- QUIT
- SET X=^LR(LRDFN,3,LR(9),0)
- DO ^DIWP
- +4 if LR("Q")
- QUIT
- if LRZ
- DO ^DIWW
- +5 DO S
- if LR("Q")
- QUIT
- +6 IF $ORDER(^LR(LRDFN,1.7,0))
- WRITE !?4,"Antibodies identified: "
- FOR LR(9)=0:0
- SET LR(9)=$ORDER(^LR(LRDFN,1.7,LR(9)))
- if 'LR(9)!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)
- DO H1
- if LR("Q")
- QUIT
- if $X>(IOM-15)
- WRITE !?4
- WRITE " ",$PIECE(^LAB(61.3,LR(9),0),"^")
- +7 if LR("Q")
- QUIT
- IF $DATA(^LR(LRDFN,LRSS))
- IF LR(8)
- DO V
- +8 WRITE !
- QUIT
- +9 ;
- V WRITE !,"Accession Number",?24,"Date/time",?40,"ABO",?44,"Rh",?48,"AHG(D)",?55,"AHG(I)"
- +1 SET LRI=0
- FOR A=1:1
- SET LRI=$ORDER(^LR(LRDFN,LRSS,LRI))
- if 'LRI!(A>LR(8))!(LR("Q"))
- QUIT
- SET LR(5)=^(LRI,0)
- if $Y>(IOSL-6)
- DO H2
- if LR("Q")
- QUIT
- SET T=+LR(5)
- DO T
- WRITE !,$JUSTIFY($PIECE(LR(5),"^",6),15),?24,T
- DO W
- +2 QUIT
- W SET LR(10)=$SELECT($DATA(^LR(LRDFN,LRSS,LRI,10)):^(10),1:"")
- SET LR(11)=$SELECT($DATA(^(11)):^(11),1:"")
- SET LR(0)=$SELECT($DATA(^(2)):^(2),1:"")
- SET LR(6)=$SELECT($DATA(^(6)):^(6),1:"")
- +1 WRITE ?41,$JUSTIFY($PIECE(LR(10),"^"),2),?44,$PIECE(LR(11),"^"),?51,$PIECE(LR(0),"^",9),?58,$PIECE(LR(6),"^")
- +2 FOR E=10,11
- IF $PIECE(LR(E),"^",3)]""
- if $Y>(IOSL-6)
- DO H2
- if LR("Q")
- QUIT
- SET X=$PIECE(LR(E),"^",3)
- WRITE !?20,$EXTRACT(X,1,59)
- IF $LENGTH(X)>59
- WRITE !?40,$EXTRACT(X,60,80)
- +3 if LR("Q")
- QUIT
- if $Y>(IOSL-6)
- DO H2
- if LR("Q")
- QUIT
- SET X=$PIECE(LR(0),"^",10)
- IF X]""
- WRITE !?20,$EXTRACT(X,1,59)
- if $LENGTH(X)>59
- WRITE !?40,$EXTRACT(X,60,80)
- +4 FOR E=0:0
- SET E=$ORDER(^LR(LRDFN,LRSS,LRI,4,E))
- if 'E!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)
- DO H2
- if LR("Q")
- QUIT
- SET X=^LR(LRDFN,LRSS,LRI,4,E,0)
- WRITE !?20,$EXTRACT(X,1,59)
- if $LENGTH(X)>59
- WRITE !?40,$EXTRACT(X,60,80)
- +5 if LR("Q")
- QUIT
- FOR E=0:0
- SET E=$ORDER(^LR(LRDFN,LRSS,LRI,5,E))
- if 'E!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)
- DO H2
- if LR("Q")
- QUIT
- SET X=+^LR(LRDFN,LRSS,LRI,5,E,0)
- IF X
- IF $DATA(^LAB(61.3,X,0))
- WRITE !?20,"Serum antibody: ",$PIECE(^(0),"^")
- +6 if LR("Q")
- QUIT
- FOR E=0:0
- SET E=$ORDER(^LR(LRDFN,LRSS,LRI,"EA",E))
- if 'E!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)
- DO H2
- if LR("Q")
- QUIT
- WRITE !?20,"Eluate antibody: ",$PIECE(^LAB(61.3,E,0),"^")
- +7 if LR("Q")
- QUIT
- FOR E=0:0
- SET E=$ORDER(^LR(LRDFN,LRSS,LRI,99,E))
- if 'E!(LR("Q"))
- QUIT
- SET LRE=^(E,0)
- if $Y>(IOSL-6)
- DO H2
- if LR("Q")
- QUIT
- WRITE !?8,LRE
- +8 QUIT
- T SET T=T_"000"
- SET T=$EXTRACT(T,4,5)_"/"_$EXTRACT(T,6,7)_"/"_$EXTRACT(T,2,3)_$SELECT(T[".":" "_$EXTRACT(T,9,10)_":"_$EXTRACT(T,11,12),1:"")
- QUIT
- E KILL ^UTILITY($JOB)
- SET DIWR=IOM-5
- SET DIWL=5
- SET DIWF="W"
- QUIT
- H if LR("Q")
- QUIT
- WRITE !,LRP,?31,$PIECE(LR(4),"^",2),?42,"[See previous page (Pg ",LRQ-1,")]"
- QUIT
- H1 DO H^LRBLPR
- DO H
- if LR("Q")
- QUIT
- WRITE !?4,"Antibodies identified (cond't): "
- QUIT
- H2 DO H^LRBLPR
- DO H
- if LR("Q")
- QUIT
- WRITE !?4,"Date/time",?20,"ABO",?24,"Rh",?28,"AHG(D)",?35,"AHG(I)"
- QUIT
- H3 DO H^LRBLPR
- DO H
- if LR("Q")
- QUIT
- WRITE !,"TRANSFUSION REACTIONS WITH UNIT IDENTIFIED",?51,"UNIT ID",?66,"COMPONENT"
- QUIT
- H4 DO H^LRBLPR
- DO H
- if LR("Q")
- QUIT
- WRITE !,"TRANSFUSION REACTIONS WITHOUT UNIT IDENTIFIED"
- QUIT
- S SET (C,LRA)=0
- FOR B=0:1
- SET C=$ORDER(^LR("AB",LRDFN,C))
- if 'C!(LR("Q"))
- QUIT
- FOR A=0:0
- SET A=$ORDER(^LR("AB",LRDFN,C,A))
- if 'A!(LR("Q"))
- QUIT
- DO R
- +1 if LR("Q")
- QUIT
- SET A=0
- WRITE !
- FOR B=0:1
- SET A=$ORDER(^LR(LRDFN,1.9,A))
- if 'A!(LR("Q"))
- QUIT
- SET LR(1.9)=^(A,0)
- if 'B
- WRITE !,"TRANSFUSION REACTIONS WITHOUT UNIT IDENTIFIED:"
- SET Y=+LR(1.9)
- DO D^LRU
- WRITE !,Y,?21,$PIECE($GET(^LAB(65.4,+$PIECE(LR(1.9),U,2),0)),U)
- DO A
- +2 QUIT
- A if $Y>(IOSL-6)
- DO H4
- if LR("Q")
- QUIT
- FOR B=0:0
- SET B=$ORDER(^LR(LRDFN,1.9,A,1,B))
- if 'B!(LR("Q"))
- QUIT
- SET B(1)=^(B,0)
- if $Y>(IOSL-6)
- DO H4
- if LR("Q")
- QUIT
- WRITE !,B(1)
- +1 QUIT
- R SET LR(1.9)=$GET(^LR(LRDFN,1.6,A,0))
- SET Y=+LR(1.9)
- IF LR(1.9)=""
- KILL ^LR("AB",LRDFN,C,A)
- QUIT
- +1 DO D^LRU
- if 'LRA
- WRITE !,"TRANSFUSION REACTIONS WITH UNIT IDENTIFIED",?51,"UNIT ID",?66,"COMPONENT"
- WRITE !,Y,?21,$PIECE($GET(^LAB(65.4,C,0)),U),?51,$PIECE(LR(1.9),U,3),?69,$PIECE($GET(^LAB(66,+$PIECE(LR(1.9),U,2),0)),U,2)
- SET LRA=LRA+1
- +2 if $Y>(IOSL-6)
- DO H3
- if LR("Q")
- QUIT
- FOR B(1)=0:0
- SET B(1)=$ORDER(^LR(LRDFN,1.6,A,1,B(1)))
- if 'B(1)!(LR("Q"))
- QUIT
- SET B(2)=^(B(1),0)
- if $Y>(IOSL-6)
- DO H3
- if LR("Q")
- QUIT
- WRITE !,B(2)
- +3 QUIT