- LRBLPTR ;AVAMC/REG - TRANSFUSION DATA REPORT ;2/18/93 09:47 ;
- ;;5.2;LAB SERVICE;**247,267**;Sep 27, 1994
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- D END W !?30,"Transfusion data report"
- D B^LRBLU G:Y<0 END S LRSDT=LRSDT-.0001,LRLDT=$S(LRLDT'[".":LRLDT+.99,1:LRLDT),LRG=0
- W !!,"Also print transfusions with hematology results " S %=2 D YN^LRU G:%<1 END S:%=1 LRG=1
- S ZTRTN="QUE^LRBLPTR" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO K ^TMP($J),^TMP("LRBL",$J) D L^LRU,S^LRU,H S LR("F")=1
- F LRD=LRSDT:0 S LRD=$O(^LRD(65,"AB",LRD)) Q:'LRD!(LRD>LRLDT) F LRI=0:0 S LRI=$O(^LRD(65,"AB",LRD,LRI)) Q:'LRI I $D(^LRD(65,LRI,6)),$P(^(6),"^") S W(6)=^(6),W(4)=^(4),W(0)=^(0),C=$P(W(0),"^",4) D SET
- F P=0:0 S P=$O(^TMP($J,P)) Q:'P D PT
- S LRP=0 F S LRP=$O(^TMP($J,"B",LRP)) Q:LRP=""!(LR("Q")) F P=0:0 S P=$O(^TMP($J,"B",LRP,P)) Q:'P!(LR("Q")) S SSN=^(P) D W
- G:LR("Q") OUT D:$Y>(IOSL-9) H G:LR("Q") OUT W !!,LR("%") F A=0:0 S A=$O(LRC(A)) Q:'A D:$Y>(IOSL-6) H Q:LR("Q") S X=^LAB(66,A,0) W !?2,$P(X,"^",2),?8,"=",$P(X,"^")
- OUT D:LRG&('LR("Q")) ^LRBLPTR1 D END,END^LRUTL Q
- W D:$Y>(IOSL-6) H Q:LR("Q") S (LRE,LRF)="" W !!,"Patient: ",LRP,?41,"SSN: ",SSN D:$O(^LR(P,1.9,0)) B Q:LR("Q")
- F C=0:0 S C=$O(^TMP($J,P,C)) Q:'C!(LR("Q")) S C(1)=$P(^LAB(66,C,0),"^",2),LRC(C)="",LRD=0 F LRJ=0:1 S LRD=$O(^TMP($J,P,C,LRD)) Q:'LRD!(LR("Q")) S:'LRJ LRE=LRD D W1
- I LRG S X1=$P(LRE,"."),X2=-1 D C^%DTC S LRE=X,X1=$P(LRF,"."),X2=1 D C^%DTC S ^TMP("LRBL",$J,LRP,P)=LRE_"^"_X
- Q
- W1 F LRI=0:0 S LRI=$O(^TMP($J,P,C,LRD,LRI)) Q:'LRI!(LR("Q")) S W=^(LRI) D P
- I LRG S:LRD<LRE LRE=LRD S:LRD>LRF LRF=LRD
- Q
- P D:$Y>(IOSL-6) H1 Q:LR("Q") W !,$P(W,"^"),?14,C(1),?19,$P(W,"^",8),?24,$P(W,"^",9),?29,$P(W,"^",2),?44,$P(W,"^",4),?47,$P(W,"^",5),?53,$P(W,"^",6),?62,$P(W,"^",3),?77,$P(W,"^",7)
- W:$D(^LAB(65.4,+$P(W,"^",10),0)) !?2,"Transfusion reaction type: ",$P(^(0),"^")
- F W=0:0 S W=$O(^LRD(65,LRI,7,W)) Q:'W!(LR("Q")) S W(1)=^(W,0) D:$Y>(IOSL-6) H1 Q:LR("Q") W !?2,W(1)
- Q
- SET I LRD'=$P(W(4),"^",2) K ^LRD(65,"AB",LRD,LRI) Q
- S W(3)=$O(^LRD(65,LRI,3,0)) S:W(3) W(3)=^(W(3),0)
- S J=$P(W(3),"^",2),L=$S($P(W(3),"^",4)]"":$E($P(W(3),"^",4),1,9),1:"??"),Y=+W(3) D D S Y(1)=Y,Y=LRD D D S Y(2)=Y,Y=$P(W(3),"^",3) I Y,$D(^VA(200,Y,0)) S Y=$P(^(0),"^",2)
- S X=$P(W(6),"^",5),^TMP($J,+W(6),C,LRD,LRI)=$P(W(0),"^")_"^"_Y(1)_"^"_Y(2)_"^"_J_"^"_Y_"^"_L_"^"_$S(X=0:"NO",X=1:"YES",1:"")_"^"_$P(W(4),"^",4)_"^"_$P(W(0),"^",11)_"^"_$P(W(6),"^",8) Q
- PT S X=^LR(P,0),Y=$P(X,"^",3),LRDPF=$P(X,U,2),X=^DIC(LRDPF,0,"GL"),Y=@(X_Y_",0)"),LRP=$P(Y,"^"),SSN=$P(Y,"^",9) D SSN^LRU S ^TMP($J,"B",LRP,P)=SSN Q
- B S A=0 F C=0:1 S A=$O(^LR(P,1.9,A)) Q:'A!(LR("Q")) S LR(1.9)=^(A,0) D:$Y>(IOSL-6) H1 Q:LR("Q") D:'C L S Y=+LR(1.9) D D^LRU S LRK=Y,LRR=$P($G(^LAB(65.4,+$P(LR(1.9),U,2),0)),U) W !,Y,?21,LRR D A
- Q
- A F B=0:0 S B=$O(^LR(P,1.9,A,1,B)) Q:'B!(LR("Q")) S B(1)=^(B,0) D:$Y>(IOSL-6) H2 Q:LR("Q") W !,B(1)
- Q
- ;
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"TRANSFUSION DATA REPORT FROM ",LRSTR," TO ",LRLST
- W !,"Unit ID",?14,"Comp",?20,"(#)",?24,"(ml)",?29,"Relocated",?44,"CK",?47,"By",?53,"Location",?62,"Transfused",?77,"RXN"
- W !,LR("%") Q
- H1 D H Q:LR("Q") W !!,"Patient: ",LRP,?41,"SSN: ",SSN Q
- H2 D H1 Q:LR("Q") D L W !,LRK,?21,LRR Q
- L W !,"TRANSFUSION REACTIONS WITHOUT UNIT IDENTIFIED" Q
- ;
- D S:'Y Y="" Q:'Y S Y=Y_"000",Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_$S(Y[".":" "_$E(Y,9,10)_":"_$E(Y,11,12),1:"") Q
- END D V^LRU Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPTR 3499 printed Feb 18, 2025@23:37:56 Page 2
- LRBLPTR ;AVAMC/REG - TRANSFUSION DATA REPORT ;2/18/93 09:47 ;
- +1 ;;5.2;LAB SERVICE;**247,267**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 DO END
- WRITE !?30,"Transfusion data report"
- +4 DO B^LRBLU
- if Y<0
- GOTO END
- SET LRSDT=LRSDT-.0001
- SET LRLDT=$SELECT(LRLDT'[".":LRLDT+.99,1:LRLDT)
- SET LRG=0
- +5 WRITE !!,"Also print transfusions with hematology results "
- SET %=2
- DO YN^LRU
- if %<1
- GOTO END
- if %=1
- SET LRG=1
- +6 SET ZTRTN="QUE^LRBLPTR"
- DO BEG^LRUTL
- if POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- KILL ^TMP($JOB),^TMP("LRBL",$JOB)
- DO L^LRU
- DO S^LRU
- DO H
- SET LR("F")=1
- +1 FOR LRD=LRSDT:0
- SET LRD=$ORDER(^LRD(65,"AB",LRD))
- if 'LRD!(LRD>LRLDT)
- QUIT
- FOR LRI=0:0
- SET LRI=$ORDER(^LRD(65,"AB",LRD,LRI))
- if 'LRI
- QUIT
- IF $DATA(^LRD(65,LRI,6))
- IF $PIECE(^(6),"^")
- SET W(6)=^(6)
- SET W(4)=^(4)
- SET W(0)=^(0)
- SET C=$PIECE(W(0),"^",4)
- DO SET
- +2 FOR P=0:0
- SET P=$ORDER(^TMP($JOB,P))
- if 'P
- QUIT
- DO PT
- +3 SET LRP=0
- FOR
- SET LRP=$ORDER(^TMP($JOB,"B",LRP))
- if LRP=""!(LR("Q"))
- QUIT
- FOR P=0:0
- SET P=$ORDER(^TMP($JOB,"B",LRP,P))
- if 'P!(LR("Q"))
- QUIT
- SET SSN=^(P)
- DO W
- +4 if LR("Q")
- GOTO OUT
- if $Y>(IOSL-9)
- DO H
- if LR("Q")
- GOTO OUT
- WRITE !!,LR("%")
- FOR A=0:0
- SET A=$ORDER(LRC(A))
- if 'A
- QUIT
- if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- SET X=^LAB(66,A,0)
- WRITE !?2,$PIECE(X,"^",2),?8,"=",$PIECE(X,"^")
- OUT if LRG&('LR("Q"))
- DO ^LRBLPTR1
- DO END
- DO END^LRUTL
- QUIT
- W if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- SET (LRE,LRF)=""
- WRITE !!,"Patient: ",LRP,?41,"SSN: ",SSN
- if $ORDER(^LR(P,1.9,0))
- DO B
- if LR("Q")
- QUIT
- +1 FOR C=0:0
- SET C=$ORDER(^TMP($JOB,P,C))
- if 'C!(LR("Q"))
- QUIT
- SET C(1)=$PIECE(^LAB(66,C,0),"^",2)
- SET LRC(C)=""
- SET LRD=0
- FOR LRJ=0:1
- SET LRD=$ORDER(^TMP($JOB,P,C,LRD))
- if 'LRD!(LR("Q"))
- QUIT
- if 'LRJ
- SET LRE=LRD
- DO W1
- +2 IF LRG
- SET X1=$PIECE(LRE,".")
- SET X2=-1
- DO C^%DTC
- SET LRE=X
- SET X1=$PIECE(LRF,".")
- SET X2=1
- DO C^%DTC
- SET ^TMP("LRBL",$JOB,LRP,P)=LRE_"^"_X
- +3 QUIT
- W1 FOR LRI=0:0
- SET LRI=$ORDER(^TMP($JOB,P,C,LRD,LRI))
- if 'LRI!(LR("Q"))
- QUIT
- SET W=^(LRI)
- DO P
- +1 IF LRG
- if LRD<LRE
- SET LRE=LRD
- if LRD>LRF
- SET LRF=LRD
- +2 QUIT
- P if $Y>(IOSL-6)
- DO H1
- if LR("Q")
- QUIT
- WRITE !,$PIECE(W,"^"),?14,C(1),?19,$PIECE(W,"^",8),?24,$PIECE(W,"^",9),?29,$PIECE(W,"^",2),?44,$PIECE(W,"^",4),?47,$PIECE(W,"^",5),?53,$PIECE(W,"^",6),?62,$PIECE(W,"^",3),?77,$PIECE(W,"^",7)
- +1 if $DATA(^LAB(65.4,+$PIECE(W,"^",10),0))
- WRITE !?2,"Transfusion reaction type: ",$PIECE(^(0),"^")
- +2 FOR W=0:0
- SET W=$ORDER(^LRD(65,LRI,7,W))
- if 'W!(LR("Q"))
- QUIT
- SET W(1)=^(W,0)
- if $Y>(IOSL-6)
- DO H1
- if LR("Q")
- QUIT
- WRITE !?2,W(1)
- +3 QUIT
- SET IF LRD'=$PIECE(W(4),"^",2)
- KILL ^LRD(65,"AB",LRD,LRI)
- QUIT
- +1 SET W(3)=$ORDER(^LRD(65,LRI,3,0))
- if W(3)
- SET W(3)=^(W(3),0)
- +2 SET J=$PIECE(W(3),"^",2)
- SET L=$SELECT($PIECE(W(3),"^",4)]"":$EXTRACT($PIECE(W(3),"^",4),1,9),1:"??")
- SET Y=+W(3)
- DO D
- SET Y(1)=Y
- SET Y=LRD
- DO D
- SET Y(2)=Y
- SET Y=$PIECE(W(3),"^",3)
- IF Y
- IF $DATA(^VA(200,Y,0))
- SET Y=$PIECE(^(0),"^",2)
- +3 SET X=$PIECE(W(6),"^",5)
- SET ^TMP($JOB,+W(6),C,LRD,LRI)=$PIECE(W(0),"^")_"^"_Y(1)_"^"_Y(2)_"^"_J_"^"_Y_"^"_L_"^"_$SELECT(X=0:"NO",X=1:"YES",1:"")_"^"_$PIECE(W(4),"^",4)_"^"_$PIECE(W(0),"^",11)_"^"_$PIECE(W(6),"^",8)
- QUIT
- PT SET X=^LR(P,0)
- SET Y=$PIECE(X,"^",3)
- SET LRDPF=$PIECE(X,U,2)
- SET X=^DIC(LRDPF,0,"GL")
- SET Y=@(X_Y_",0)")
- SET LRP=$PIECE(Y,"^")
- SET SSN=$PIECE(Y,"^",9)
- DO SSN^LRU
- SET ^TMP($JOB,"B",LRP,P)=SSN
- QUIT
- B SET A=0
- FOR C=0:1
- SET A=$ORDER(^LR(P,1.9,A))
- if 'A!(LR("Q"))
- QUIT
- SET LR(1.9)=^(A,0)
- if $Y>(IOSL-6)
- DO H1
- if LR("Q")
- QUIT
- if 'C
- DO L
- SET Y=+LR(1.9)
- DO D^LRU
- SET LRK=Y
- SET LRR=$PIECE($GET(^LAB(65.4,+$PIECE(LR(1.9),U,2),0)),U)
- WRITE !,Y,?21,LRR
- DO A
- +1 QUIT
- A FOR B=0:0
- SET B=$ORDER(^LR(P,1.9,A,1,B))
- if 'B!(LR("Q"))
- QUIT
- SET B(1)=^(B,0)
- if $Y>(IOSL-6)
- DO H2
- if LR("Q")
- QUIT
- WRITE !,B(1)
- +1 QUIT
- +2 ;
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- if LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"TRANSFUSION DATA REPORT FROM ",LRSTR," TO ",LRLST
- +2 WRITE !,"Unit ID",?14,"Comp",?20,"(#)",?24,"(ml)",?29,"Relocated",?44,"CK",?47,"By",?53,"Location",?62,"Transfused",?77,"RXN"
- +3 WRITE !,LR("%")
- QUIT
- H1 DO H
- if LR("Q")
- QUIT
- WRITE !!,"Patient: ",LRP,?41,"SSN: ",SSN
- QUIT
- H2 DO H1
- if LR("Q")
- QUIT
- DO L
- WRITE !,LRK,?21,LRR
- QUIT
- L WRITE !,"TRANSFUSION REACTIONS WITHOUT UNIT IDENTIFIED"
- QUIT
- +1 ;
- D if 'Y
- SET Y=""
- if 'Y
- QUIT
- SET Y=Y_"000"
- SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_$SELECT(Y[".":" "_$EXTRACT(Y,9,10)_":"_$EXTRACT(Y,11,12),1:"")
- QUIT
- END DO V^LRU
- QUIT