- LRBLTXA ;AVAMC/REG - TRANSFUSION FOLLOW-UP ;2/18/93 09:55 ;
- ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END W !!,"Search for possible transfusion related disorders"
- D B^LRU G:Y<0 END S X1=LRSDT,X2=-185 D C^%DTC S LRT=9999999-X,J=LRSDT-1,LRSDT=9999999-LRSDT,LRJ=9999998-LRLDT
- S ZTRTN="QUE^LRBLTXA" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO K ^TMP($J) S LR("D")=0,Z(2)=$O(^LAB(61,"B","SERUM",0)),Z(3)=$O(^LAB(61,"B","BLOOD",0)),Z(5)=$O(^LAB(61,"B","PLASMA",0)) D L^LRU,S^LRU,H S LR("F")=1
- F A=0:0 S A=$O(^LRO(69.2,LRAA,60,A)) Q:'A F B=0:0 S B=$O(^LRO(69.2,LRAA,60,A,1,B)) Q:'B S C=^(B,0),N(A,B)=$P(^LAB(60,+C,.1),"^"),L(A,B)=$P($P(^(0),"^",5),";",2)_"^"_$P(C,"^",2,3)
- F A=J:0 S A=$O(^LRO(69,A)) Q:'A!(A>LRLDT) F B=0:0 S B=$O(^LRO(69,A,1,"AA",B)) Q:'B S T=$O(^LR(B,1.6,0)) I T,T<LRT D P
- S LRP=0 F A=0:0 S LRP=$O(^TMP($J,LRP)) Q:LRP=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^TMP($J,LRP,LRDFN)) Q:'LRDFN!(LR("Q")) S LRP(1)=^(LRDFN),SSN=$P(LRP(1),"^"),LRDPF=$P(^LR(LRDFN,0),U,2) D SSN^LRU,T
- W !,LR("%") S A=0 F B=0:0 S A=$O(LR("D",A)) Q:A="" D:$Y>(IOSL-6) H Q:LR("Q") W !,A,?5,"= ",LR("D",A)
- D END^LRUTL,END Q
- T S W(1)=0 F LRI=LRJ:0 S LRI=$O(^LR(LRDFN,"CH",LRI)) Q:'LRI!(LRI>LRSDT)!(LR("Q")) S X=^(LRI,0),Y=+X_"000",T=$P(X,"^",5),T(1)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_" "_$S(Y[".":$E(Y,9,10)_":"_$E(Y,11,12),1:"") D W
- I W(1),DFN S W(2)=LRP,W(10)=$P(LRP(1),"^"),W(5)=$P(LRP(1),"^",2),W(4)=$P(LRP(1),"^",4) D ^LRBLPC1
- W:W(1) !,LR("%") Q
- W F LR=0:0 S LR=$O(L(LR)) Q:'LR!(LR("Q")) S J(2)=0 F B=0:0 S B=$O(L(LR,B)) Q:'B!(LR("Q")) D B Q:LR("Q")
- Q
- B S J=$P(L(LR,B),"^",3),X=$S($D(^LR(LRDFN,"CH",LRI,+L(LR,B))):$P(^(+L(LR,B)),"^"),1:"") S:"<>"[$E(X) X=$E(X,2,99) I X]"",T=$P(L(LR,B),"^",2) D L Q:J(2)
- Q
- L I $E(J)="[" Q:X'[$E(J,2,99) G M
- I $E(J)="=" Q:X'=$E(J,2,99) G M
- I X=+X,@(X_J) G M
- Q
- M S J(2)=1,W(1)=W(1)+1,DFN=$P(LRP(1),"^",3),W(4)=$P(LRP(1),"^",4) D:$Y>(IOSL-6) H1 Q:LR("Q")
- W:W(1)=1 !,LRP," SSN:",SSN," Loc: ",$P(LRP(1),"^",2) D:W(1)=1 A,C W !,T(1) W:T'=Z(2)&(T'=Z(3))&(T'=Z(5)) ?13,$E($P(^LAB(61,T,0),"^"),1,7)
- F X=0:0 S X=$O(L(LR,X)) Q:'X I $D(^LR(LRDFN,"CH",LRI,+L(LR,X))) W ?(16+(X*8)),$J($P(^(+L(LR,X)),"^"),7)
- S B=99 Q
- A F E=0:0 S E=$O(^LR(LRDFN,1.6,E)) Q:'E!(E>LRT)!(LR("Q")) S X=^(E,0),F=$E(X,1,5),G=$P(X,"^",2) S:'$D(E(F,G)) E(F,G)=0 S E(F,G)=E(F,G)+1
- F F=0:0 S F=$O(E(F)) Q:'F!(LR("Q")) D:$Y>(IOSL-6) H2 Q:LR("Q") W !,$E(F,4,5)_"/"_$E(F,2,3) F G=0:0 S G=$O(E(F,G)) Q:'G S X=^LAB(66,G,0),Y=$P(X,"^",2) S:Y="" Y="?" W " ",Y,":",E(F,G) S LR("D",Y)=$P(X,"^")
- K E Q
- C I LR W ! F X=0:0 S X=$O(N(LR,X)) Q:'X W ?(16+(X*8)),$J(N(LR,X),7)
- Q
- P S X=^LR(B,0),Y=$P(X,"^",3),X=$P(X,"^",2),DFN=$S(X=2:Y,1:""),L=^DIC(X,0,"GL"),X=@(L_Y_",0)"),L=$S($D(@(L_Y_",.1)")):^(.1),$D(^LR(B,.1)):^(.1),1:"UNKNOWN"),Y=$P(X,"^",3) D:Y D^LRU S W(4)=Y
- S ^TMP($J,$P(X,"^"),B)=$P(X,"^",9)_"^"_L_"^"_DFN_"^"_W(4) Q
- ;
- END D V^LRU Q
- ;
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"BLOOD BANK SEARCH FOR TRANSFUSION RELATED DISORDERS",!?24,"FROM ",LRSTR," TO ",LRLST,!,LR("%") Q
- H1 D H Q:LR("Q") W:W(1)>1 !,LRP," SSN:",SSN," Loc: ",$P(LRP(1),"^",2) D:W(1)>1 C Q
- H2 D H Q:LR("Q") W !,LRP," SSN:",SSN," Loc: ",$P(LRP(1),"^",2) Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLTXA 3322 printed Feb 18, 2025@23:38:16 Page 2
- LRBLTXA ;AVAMC/REG - TRANSFUSION FOLLOW-UP ;2/18/93 09:55 ;
- +1 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 DO END
- SET X="BLOOD BANK"
- DO ^LRUTL
- if Y=-1
- GOTO END
- WRITE !!,"Search for possible transfusion related disorders"
- +4 DO B^LRU
- if Y<0
- GOTO END
- SET X1=LRSDT
- SET X2=-185
- DO C^%DTC
- SET LRT=9999999-X
- SET J=LRSDT-1
- SET LRSDT=9999999-LRSDT
- SET LRJ=9999998-LRLDT
- +5 SET ZTRTN="QUE^LRBLTXA"
- DO BEG^LRUTL
- if POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- KILL ^TMP($JOB)
- SET LR("D")=0
- SET Z(2)=$ORDER(^LAB(61,"B","SERUM",0))
- SET Z(3)=$ORDER(^LAB(61,"B","BLOOD",0))
- SET Z(5)=$ORDER(^LAB(61,"B","PLASMA",0))
- DO L^LRU
- DO S^LRU
- DO H
- SET LR("F")=1
- +1 FOR A=0:0
- SET A=$ORDER(^LRO(69.2,LRAA,60,A))
- if 'A
- QUIT
- FOR B=0:0
- SET B=$ORDER(^LRO(69.2,LRAA,60,A,1,B))
- if 'B
- QUIT
- SET C=^(B,0)
- SET N(A,B)=$PIECE(^LAB(60,+C,.1),"^")
- SET L(A,B)=$PIECE($PIECE(^(0),"^",5),";",2)_"^"_$PIECE(C,"^",2,3)
- +2 FOR A=J:0
- SET A=$ORDER(^LRO(69,A))
- if 'A!(A>LRLDT)
- QUIT
- FOR B=0:0
- SET B=$ORDER(^LRO(69,A,1,"AA",B))
- if 'B
- QUIT
- SET T=$ORDER(^LR(B,1.6,0))
- IF T
- IF T<LRT
- DO P
- +3 SET LRP=0
- FOR A=0:0
- SET LRP=$ORDER(^TMP($JOB,LRP))
- if LRP=""!(LR("Q"))
- QUIT
- FOR LRDFN=0:0
- SET LRDFN=$ORDER(^TMP($JOB,LRP,LRDFN))
- if 'LRDFN!(LR("Q"))
- QUIT
- SET LRP(1)=^(LRDFN)
- SET SSN=$PIECE(LRP(1),"^")
- SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- DO SSN^LRU
- DO T
- +4 WRITE !,LR("%")
- SET A=0
- FOR B=0:0
- SET A=$ORDER(LR("D",A))
- if A=""
- QUIT
- if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- WRITE !,A,?5,"= ",LR("D",A)
- +5 DO END^LRUTL
- DO END
- QUIT
- T SET W(1)=0
- FOR LRI=LRJ:0
- SET LRI=$ORDER(^LR(LRDFN,"CH",LRI))
- if 'LRI!(LRI>LRSDT)!(LR("Q"))
- QUIT
- SET X=^(LRI,0)
- SET Y=+X_"000"
- SET T=$PIECE(X,"^",5)
- SET T(1)=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_" "_$SELECT(Y[".":$EXTRACT(Y,9,10)_":"_$EXTRACT(Y,11,12),1:"")
- DO W
- +1 IF W(1)
- IF DFN
- SET W(2)=LRP
- SET W(10)=$PIECE(LRP(1),"^")
- SET W(5)=$PIECE(LRP(1),"^",2)
- SET W(4)=$PIECE(LRP(1),"^",4)
- DO ^LRBLPC1
- +2 if W(1)
- WRITE !,LR("%")
- QUIT
- W FOR LR=0:0
- SET LR=$ORDER(L(LR))
- if 'LR!(LR("Q"))
- QUIT
- SET J(2)=0
- FOR B=0:0
- SET B=$ORDER(L(LR,B))
- if 'B!(LR("Q"))
- QUIT
- DO B
- if LR("Q")
- QUIT
- +1 QUIT
- B SET J=$PIECE(L(LR,B),"^",3)
- SET X=$SELECT($DATA(^LR(LRDFN,"CH",LRI,+L(LR,B))):$PIECE(^(+L(LR,B)),"^"),1:"")
- if "<>"[$EXTRACT(X)
- SET X=$EXTRACT(X,2,99)
- IF X]""
- IF T=$PIECE(L(LR,B),"^",2)
- DO L
- if J(2)
- QUIT
- +1 QUIT
- L IF $EXTRACT(J)="["
- if X'[$EXTRACT(J,2,99)
- QUIT
- GOTO M
- +1 IF $EXTRACT(J)="="
- if X'=$EXTRACT(J,2,99)
- QUIT
- GOTO M
- +2 IF X=+X
- IF @(X_J)
- GOTO M
- +3 QUIT
- M SET J(2)=1
- SET W(1)=W(1)+1
- SET DFN=$PIECE(LRP(1),"^",3)
- SET W(4)=$PIECE(LRP(1),"^",4)
- if $Y>(IOSL-6)
- DO H1
- if LR("Q")
- QUIT
- +1 if W(1)=1
- WRITE !,LRP," SSN:",SSN," Loc: ",$PIECE(LRP(1),"^",2)
- if W(1)=1
- DO A
- DO C
- WRITE !,T(1)
- if T'=Z(2)&(T'=Z(3))&(T'=Z(5))
- WRITE ?13,$EXTRACT($PIECE(^LAB(61,T,0),"^"),1,7)
- +2 FOR X=0:0
- SET X=$ORDER(L(LR,X))
- if 'X
- QUIT
- IF $DATA(^LR(LRDFN,"CH",LRI,+L(LR,X)))
- WRITE ?(16+(X*8)),$JUSTIFY($PIECE(^(+L(LR,X)),"^"),7)
- +3 SET B=99
- QUIT
- A FOR E=0:0
- SET E=$ORDER(^LR(LRDFN,1.6,E))
- if 'E!(E>LRT)!(LR("Q"))
- QUIT
- SET X=^(E,0)
- SET F=$EXTRACT(X,1,5)
- SET G=$PIECE(X,"^",2)
- if '$DATA(E(F,G))
- SET E(F,G)=0
- SET E(F,G)=E(F,G)+1
- +1 FOR F=0:0
- SET F=$ORDER(E(F))
- if 'F!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)
- DO H2
- if LR("Q")
- QUIT
- WRITE !,$EXTRACT(F,4,5)_"/"_$EXTRACT(F,2,3)
- FOR G=0:0
- SET G=$ORDER(E(F,G))
- if 'G
- QUIT
- SET X=^LAB(66,G,0)
- SET Y=$PIECE(X,"^",2)
- if Y=""
- SET Y="?"
- WRITE " ",Y,":",E(F,G)
- SET LR("D",Y)=$PIECE(X,"^")
- +2 KILL E
- QUIT
- C IF LR
- WRITE !
- FOR X=0:0
- SET X=$ORDER(N(LR,X))
- if 'X
- QUIT
- WRITE ?(16+(X*8)),$JUSTIFY(N(LR,X),7)
- +1 QUIT
- P SET X=^LR(B,0)
- SET Y=$PIECE(X,"^",3)
- SET X=$PIECE(X,"^",2)
- SET DFN=$SELECT(X=2:Y,1:"")
- SET L=^DIC(X,0,"GL")
- SET X=@(L_Y_",0)")
- SET L=$SELECT($DATA(@(L_Y_",.1)")):^(.1),$DATA(^LR(B,.1)):^(.1),1:"UNKNOWN")
- SET Y=$PIECE(X,"^",3)
- if Y
- DO D^LRU
- SET W(4)=Y
- +1 SET ^TMP($JOB,$PIECE(X,"^"),B)=$PIECE(X,"^",9)_"^"_L_"^"_DFN_"^"_W(4)
- QUIT
- +2 ;
- END DO V^LRU
- QUIT
- +1 ;
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- if LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"BLOOD BANK SEARCH FOR TRANSFUSION RELATED DISORDERS",!?24,"FROM ",LRSTR," TO ",LRLST,!,LR("%")
- QUIT
- H1 DO H
- if LR("Q")
- QUIT
- if W(1)>1
- WRITE !,LRP," SSN:",SSN," Loc: ",$PIECE(LRP(1),"^",2)
- if W(1)>1
- DO C
- QUIT
- H2 DO H
- if LR("Q")
- QUIT
- WRITE !,LRP," SSN:",SSN," Loc: ",$PIECE(LRP(1),"^",2)
- QUIT
