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 Dec 13, 2024@02:12:23 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
