- LRBLPBR1 ;AVAMC/REG/CYM - BB TESTS REPORT ;2/23/98 12:02 ;
- ;;5.2;LAB SERVICE;**203,247,267**;Sep 27, 1994
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- ;from LRBLPBR, LRBLSUM
- S LR(2)=0,LRMD=$P(LR,"^",5) D H S LR("F")=1
- I $D(^LR(LRDFN,1.7)) 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-9) FT,H1 Q:LR("Q") W:$X>(IOM-15) !?4 W $P(^LAB(61.3,LR(9),0),"^"),"; "
- D:$Y>(IOSL-9) FT,H Q:LR("Q") I $D(LRN(2)) D C
- D DT S LRI=0 F A=1:1 S LRI=$O(^LR(LRDFN,LRSS,LRI)) Q:'LRI!(LR("Q")) S LR(5)=^(LRI,0) I $P(LR(5),"^",3) D:$Y>(IOSL-9) H2 Q:LR("Q") S T=+LR(5) D T W !?4,T D W
- FT Q:LR("Q") F X=1:1 Q:$Y>(IOSL-9) W !
- W !,LR("%")
- W !,N,?31,$P(LR,"^",2),?45,DOB,?56,$J($P(LR,"^",3),2),?59,$P(LR,"^",4),!,"Location: ",G,?39,"Physician: ",LRMD,!,"CUMULATIVE BLOOD BANK TEST REPORT",?50,"PERMANENT COPY",!,"(discard earlier copies)" Q
- W S X=$S($D(^LR(LRDFN,LRSS,LRI,10)):^(10),1:""),LRN(10.3,3)=$P(X,"^",3) W ?21,$J($P(X,"^"),2) S X=$S($D(^(11)):^(11),1:""),LRN(11.3,3)=$P(X,"^",3) W ?24,$P(X,"^")
- S X=$S($D(^LR(LRDFN,LRSS,LRI,2)):^(2),1:""),LRN(2.91,3)=$P(X,"^",10) F H=1,4,6,9 S Y=$P(X,"^",H) W ?(30+$S(H=4:5,H=6:10,H=9:15,1:0)),$S(Y="N":"Neg",Y="P":"Pos",H=9&(Y="I"):"Invalid",1:Y)
- S X=$S($D(^LR(LRDFN,LRSS,LRI,6)):^(6),1:""),Y=$P(X,"^") W ?62,$S(Y="N":"Neg",Y="P":"Pos",1:Y)
- F X=10.3,11.3,2.91 I LRN(X,3)]"" W !,LRN(X),":",LRN(X,3)
- F J=0:0 S J=$O(^LR(LRDFN,LRSS,LRI,"EA",J)) Q:'J!(LR("Q")) D:$Y>(IOSL-9) H Q:LR("Q") W !,"ELUATE ANTIBODY: ",$S($D(^LAB(61.3,J,0)):$P(^(0),"^"),1:J)
- S J=0 F S J=$O(^LR(LRDFN,LRSS,LRI,5,J)) Q:'J!(LR("Q")) D:$Y>(IOSL-9) H Q:LR("Q") W !,"SERUM ANTIBODY IDENTIFIED: ",$S($D(^LAB(61.3,J,0)):$P(^(0),"^"),1:J)
- F J=0:0 S J=$O(^LR(LRDFN,LRSS,LRI,4,J)) Q:'J!(LR("Q")) S J(1)=^(J,0) D:$Y>(IOSL-9) H Q:LR("Q") W !,LRN(8),":",J(1)
- F J=0:0 S J=$O(^LR(LRDFN,LRSS,LRI,99,J)) Q:'J!(LR("Q")) S J(1)=^(J,0) D:$Y>(IOSL-9) H Q:LR("Q") W !?8,J(1)
- Q
- T S Y=T D DD^LRX S T=Y Q
- ;
- C S A=0 F B=1:1 S A=$O(^LRD(65,"AP",LRDFN,A)) Q:'A!(LR("Q")) D N
- Q:LR("Q") I B=1 W !,"No UNITS assigned/xmatched",!
- W ! S A=0 F B=0:1 S A=$O(^LR(LRDFN,1.8,A)) Q:'A!(LR("Q")) S F=^(A,0) D:'B R D L
- Q:LR("Q") I 'B W "No component requests",!
- Q
- N W:B=1 !!?6,"Unit assigned/xmatched:",?47,"Exp date",?68,"Loc"
- I '$D(^LRD(65,A,0)) K ^LRD(65,"AP",LRDFN,A) Q
- S F=^LRD(65,A,0),L=$O(^(3,0)) S:'L L="Blood Bank" I L S L=$P(^(L,0),"^",4)
- S M=^LAB(66,$P(F,"^",4),0) D:$Y>(IOSL-9) H3 Q:LR("Q") W !,$J(B,2),")",?4,$P(F,"^"),?19,$E($P(M,"^"),1,19),?40,$P(F,"^",7)_" "_$P(F,"^",8),?47 S Y=$P(F,"^",6) D D^LRU S:L<0 L="Blood bank" W Y,?68,$E(L,1,12) Q
- ;
- L I '$D(^LAB(66,+F,0)) L +^LR(LRDFN,1.8) K ^LR(LRDFN,1.8,+F) S X=^LR(LRDFN,1.8,0),X(1)=$O(^LR(LRDFN,1.8,0)),^LR(LRDFN,1.8,0)=$P(X,"^",1,2)_"^"_X(1)_"^"_$S(X(1)="":"",1:($P(X,"^",4)-1)) L -^LR(LRDFN,1.8) Q
- W !,$E($P(^LAB(66,+F,0),"^"),1,26),?26,$J($P(F,"^",4),2),?31 S T=$P(F,"^",3) D T W T,?48 S T=$P(F,"^",5) D T W T,?65,$E($P(F,"^",9),1,12),?77,$S($P(F,"^",8)="":"",$D(^VA(200,$P(F,"^",8),0)):$P(^(0),"^",2),1:$P(F,"^",8)) Q
- ;
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !?20,"BLOOD BANK TEST REPORT",!,LR("%")
- W !?10,"Patient",?34,"SSN",?43,"Birth Date",?55,"ABO",?59,"Rh",!,?10,"-------",?34,"---",?43,"----------",?55,"---",?59,"--"
- S T=+LR D T S DOB=T W !,N,?31,$P(LR,"^",2),?44,T,?56,$J($P(LR,"^",3),2),?59,$P(LR,"^",4),!!
- Q
- H1 D H Q:LR("Q") W !!?4,"Antibodies identified (cond't from pg ",LR(2)-1,")" Q
- H2 D FT,H Q:LR("Q") D DT Q
- DT W !!,?30,"|---",?39,"AHG(direct)",?55,"---|",?62,"|-AHG(indirect)-|",!?4,"Date/time",?20,"ABO",?24,"Rh",?30,"POLY",?35,"IgG",?40,"C3",?45,"Interpretation",?62,"(Antibody screen)"
- W !?4,"---------",?20,"---",?24,"--",?30,"----",?35,"---",?40,"---",?45,"--------------",?62,"-----------------" Q
- H3 D H Q:LR("Q") W !!?6,"Unit assigned/xmatched:",?47,"Exp date",?68,"Loc" Q
- R W !,"Component requests",?25,"Units",?32,"Request date",?48,"Date wanted",?65,"Requestor",?77,"By" Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPBR1 4039 printed Feb 18, 2025@23:37:34 Page 2
- LRBLPBR1 ;AVAMC/REG/CYM - BB TESTS REPORT ;2/23/98 12:02 ;
- +1 ;;5.2;LAB SERVICE;**203,247,267**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 ;from LRBLPBR, LRBLSUM
- +4 SET LR(2)=0
- SET LRMD=$PIECE(LR,"^",5)
- DO H
- SET LR("F")=1
- +5 IF $DATA(^LR(LRDFN,1.7))
- 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-9)
- DO FT
- DO H1
- if LR("Q")
- QUIT
- if $X>(IOM-15)
- WRITE !?4
- WRITE $PIECE(^LAB(61.3,LR(9),0),"^"),"; "
- +6 if $Y>(IOSL-9)
- DO FT
- DO H
- if LR("Q")
- QUIT
- IF $DATA(LRN(2))
- DO C
- +7 DO DT
- SET LRI=0
- FOR A=1:1
- SET LRI=$ORDER(^LR(LRDFN,LRSS,LRI))
- if 'LRI!(LR("Q"))
- QUIT
- SET LR(5)=^(LRI,0)
- IF $PIECE(LR(5),"^",3)
- if $Y>(IOSL-9)
- DO H2
- if LR("Q")
- QUIT
- SET T=+LR(5)
- DO T
- WRITE !?4,T
- DO W
- FT if LR("Q")
- QUIT
- FOR X=1:1
- if $Y>(IOSL-9)
- QUIT
- WRITE !
- +1 WRITE !,LR("%")
- +2 WRITE !,N,?31,$PIECE(LR,"^",2),?45,DOB,?56,$JUSTIFY($PIECE(LR,"^",3),2),?59,$PIECE(LR,"^",4),!,"Location: ",G,?39,"Physician: ",LRMD,!,"CUMULATIVE BLOOD BANK TEST REPORT",?50,"PERMANENT COPY",!,"(discard earlier copies)"
- QUIT
- W SET X=$SELECT($DATA(^LR(LRDFN,LRSS,LRI,10)):^(10),1:"")
- SET LRN(10.3,3)=$PIECE(X,"^",3)
- WRITE ?21,$JUSTIFY($PIECE(X,"^"),2)
- SET X=$SELECT($DATA(^(11)):^(11),1:"")
- SET LRN(11.3,3)=$PIECE(X,"^",3)
- WRITE ?24,$PIECE(X,"^")
- +1 SET X=$SELECT($DATA(^LR(LRDFN,LRSS,LRI,2)):^(2),1:"")
- SET LRN(2.91,3)=$PIECE(X,"^",10)
- FOR H=1,4,6,9
- SET Y=$PIECE(X,"^",H)
- WRITE ?(30+$SELECT(H=4:5,H=6:10,H=9:15,1:0)),$SELECT(Y="N":"Neg",Y="P":"Pos",H=9&(Y="I"):"Invalid",1:Y)
- +2 SET X=$SELECT($DATA(^LR(LRDFN,LRSS,LRI,6)):^(6),1:"")
- SET Y=$PIECE(X,"^")
- WRITE ?62,$SELECT(Y="N":"Neg",Y="P":"Pos",1:Y)
- +3 FOR X=10.3,11.3,2.91
- IF LRN(X,3)]""
- WRITE !,LRN(X),":",LRN(X,3)
- +4 FOR J=0:0
- SET J=$ORDER(^LR(LRDFN,LRSS,LRI,"EA",J))
- if 'J!(LR("Q"))
- QUIT
- if $Y>(IOSL-9)
- DO H
- if LR("Q")
- QUIT
- WRITE !,"ELUATE ANTIBODY: ",$SELECT($DATA(^LAB(61.3,J,0)):$PIECE(^(0),"^"),1:J)
- +5 SET J=0
- FOR
- SET J=$ORDER(^LR(LRDFN,LRSS,LRI,5,J))
- if 'J!(LR("Q"))
- QUIT
- if $Y>(IOSL-9)
- DO H
- if LR("Q")
- QUIT
- WRITE !,"SERUM ANTIBODY IDENTIFIED: ",$SELECT($DATA(^LAB(61.3,J,0)):$PIECE(^(0),"^"),1:J)
- +6 FOR J=0:0
- SET J=$ORDER(^LR(LRDFN,LRSS,LRI,4,J))
- if 'J!(LR("Q"))
- QUIT
- SET J(1)=^(J,0)
- if $Y>(IOSL-9)
- DO H
- if LR("Q")
- QUIT
- WRITE !,LRN(8),":",J(1)
- +7 FOR J=0:0
- SET J=$ORDER(^LR(LRDFN,LRSS,LRI,99,J))
- if 'J!(LR("Q"))
- QUIT
- SET J(1)=^(J,0)
- if $Y>(IOSL-9)
- DO H
- if LR("Q")
- QUIT
- WRITE !?8,J(1)
- +8 QUIT
- T SET Y=T
- DO DD^LRX
- SET T=Y
- QUIT
- +1 ;
- C SET A=0
- FOR B=1:1
- SET A=$ORDER(^LRD(65,"AP",LRDFN,A))
- if 'A!(LR("Q"))
- QUIT
- DO N
- +1 if LR("Q")
- QUIT
- IF B=1
- WRITE !,"No UNITS assigned/xmatched",!
- +2 WRITE !
- SET A=0
- FOR B=0:1
- SET A=$ORDER(^LR(LRDFN,1.8,A))
- if 'A!(LR("Q"))
- QUIT
- SET F=^(A,0)
- if 'B
- DO R
- DO L
- +3 if LR("Q")
- QUIT
- IF 'B
- WRITE "No component requests",!
- +4 QUIT
- N if B=1
- WRITE !!?6,"Unit assigned/xmatched:",?47,"Exp date",?68,"Loc"
- +1 IF '$DATA(^LRD(65,A,0))
- KILL ^LRD(65,"AP",LRDFN,A)
- QUIT
- +2 SET F=^LRD(65,A,0)
- SET L=$ORDER(^(3,0))
- if 'L
- SET L="Blood Bank"
- IF L
- SET L=$PIECE(^(L,0),"^",4)
- +3 SET M=^LAB(66,$PIECE(F,"^",4),0)
- if $Y>(IOSL-9)
- DO H3
- if LR("Q")
- QUIT
- WRITE !,$JUSTIFY(B,2),")",?4,$PIECE(F,"^"),?19,$EXTRACT($PIECE(M,"^"),1,19),?40,$PIECE(F,"^",7)_" "_$PIECE(F,"^",8),?47
- SET Y=$PIECE(F,"^",6)
- DO D^LRU
- if L<0
- SET L="Blood bank"
- WRITE Y,?68,$EXTRACT(L,1,12)
- QUIT
- +4 ;
- L IF '$DATA(^LAB(66,+F,0))
- LOCK +^LR(LRDFN,1.8)
- KILL ^LR(LRDFN,1.8,+F)
- SET X=^LR(LRDFN,1.8,0)
- SET X(1)=$ORDER(^LR(LRDFN,1.8,0))
- SET ^LR(LRDFN,1.8,0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_$SELECT(X(1)="":"",1:($PIECE(X,"^",4)-1))
- LOCK -^LR(LRDFN,1.8)
- QUIT
- +1 WRITE !,$EXTRACT($PIECE(^LAB(66,+F,0),"^"),1,26),?26,$JUSTIFY($PIECE(F,"^",4),2),?31
- SET T=$PIECE(F,"^",3)
- DO T
- WRITE T,?48
- SET T=$PIECE(F,"^",5)
- DO T
- WRITE T,?65,$EXTRACT($PIECE(F,"^",9),1,12),?77,$SELECT($PIECE(F,"^",8)="":"",$DATA(^VA(200,$PIECE(F,"^",8),0)):$PIECE(^(0),"^",2),1:$PIECE(F,"^",8))
- QUIT
- +2 ;
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- if LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !?20,"BLOOD BANK TEST REPORT",!,LR("%")
- +2 WRITE !?10,"Patient",?34,"SSN",?43,"Birth Date",?55,"ABO",?59,"Rh",!,?10,"-------",?34,"---",?43,"----------",?55,"---",?59,"--"
- +3 SET T=+LR
- DO T
- SET DOB=T
- WRITE !,N,?31,$PIECE(LR,"^",2),?44,T,?56,$JUSTIFY($PIECE(LR,"^",3),2),?59,$PIECE(LR,"^",4),!!
- +4 QUIT
- H1 DO H
- if LR("Q")
- QUIT
- WRITE !!?4,"Antibodies identified (cond't from pg ",LR(2)-1,")"
- QUIT
- H2 DO FT
- DO H
- if LR("Q")
- QUIT
- DO DT
- QUIT
- DT WRITE !!,?30,"|---",?39,"AHG(direct)",?55,"---|",?62,"|-AHG(indirect)-|",!?4,"Date/time",?20,"ABO",?24,"Rh",?30,"POLY",?35,"IgG",?40,"C3",?45,"Interpretation",?62,"(Antibody screen)"
- +1 WRITE !?4,"---------",?20,"---",?24,"--",?30,"----",?35,"---",?40,"---",?45,"--------------",?62,"-----------------"
- QUIT
- H3 DO H
- if LR("Q")
- QUIT
- WRITE !!?6,"Unit assigned/xmatched:",?47,"Exp date",?68,"Loc"
- QUIT
- R WRITE !,"Component requests",?25,"Units",?32,"Request date",?48,"Date wanted",?65,"Requestor",?77,"By"
- QUIT