LRBLPC ; IHS/DIR/FJE - TRANSFUSIONS/HEM RESULTS 2/18/93 09:42 ;
;;5.2;LR;;NOV 01, 1997
;
;;5.2;LAB SERVICE;;Sep 27, 1994
W !!?14,"Print transfusions & hematology data for a patient" D V^LRU
S LRS=$O(^LAB(61,"B","BLOOD",0)) I 'LRS S LRS=$O(^LAB(61,"B","PERIPHERAL BLOOD",0)) I 'LRS W $C(7),!,"BLOOD or PERIPHERAL BLOOD must be an entry in TOPOGRAPHY file (#61)",! G END
S X="BLOOD BANK" D ^LRUTL G:Y=-1 END K LRDPAF S A=0 F B=0:1 S A=$O(^LRO(69.2,LRAA,61,LRS,2,A)) Q:'A S Y=^(A,0),W=$P(Y,"^",2),Y=+Y D S
S LRT(0)=B I 'B W $C(7),!!,"Must have tests to print entered in the",!,"'Tests for inclusion in transfusion report option' in",!,"Blood bank supervisor menu",! G END
S:'$D(^LRO(69.2,LRAA,7,0)) ^(0)="^69.28PA^^" I '$D(^(DUZ,0)) S ^(0)=DUZ,X=^LRO(69.2,LRAA,7,0),^(0)="^69.28PA^"_DUZ_"^"_($P(X,"^",4)+1)
G:$O(^LRO(69.2,LRAA,7,DUZ,1,0)) OUT
K ^LRO(69.2,LRAA,7,DUZ) S ^LRO(69.2,LRAA,7,DUZ,0)=DUZ_"^"_DT,^LRO(69.2,LRAA,7,DUZ,1,0)="^69.3PA^^"
K DIC F LRA=1:1 W !,"Choice: ",LRA D ^LRDPA Q:LRDFN<1 D G S X=^LRO(69.2,LRAA,7,DUZ,1,0),^(0)="^69.3PA^"_LRDFN_"^"_($P(X,"^",4)+1),^(LRDFN,0)=LRDFN_"^"_Y(0),^LRO(69.2,LRAA,7,DUZ,1,"C",$P(Y(0),"^"),LRDFN)=""
G:LRA=1 END D B^LRU I Y<0 D SET^LRBLPC1 G END
S LRLDT=9999998-LRLDT,LRSDT=9999999-LRSDT,ZTRTN="QUE^LRBLPC" D BEG^LRUTL Q:$D(ZTSK) I POP D SET^LRBLPC1 G END
QUE U IO D L^LRU,S^LRU D:IOST?1"C".E WAIT^LRU K ^TMP($J)
F LRDFN=0:0 S LRDFN=$O(^LRO(69.2,LRAA,7,DUZ,1,LRDFN)) Q:'LRDFN D A
D WRT W:IOST'?1"C".E @IOF K ^LRO(69.2,LRAA,7,DUZ) D END,END^LRUTL Q
A S ^TMP($J,LRDFN)="" F A=LRLDT:0 S A=$O(^LR(LRDFN,1.6,A)) Q:'A!(A>LRSDT) S X=^(A,0),^TMP($J,LRDFN,A,0)=+X,^(.1)=$P(X,"^",2,99)
F A=LRLDT:0 S A=$O(^LR(LRDFN,"CH",A)) Q:'A!(A>LRSDT) S X=^(A,0) F B=0:0 S B=$O(LRT(B)) Q:B="" S Z=$S($D(^LR(LRDFN,"CH",A,LRV(B))):$P(^(LRV(B)),"^"),1:"") I Z]"",$P(X,"^",5)=LRS(B) S ^TMP($J,LRDFN,A,0)=+X,^(B)=Z
Q
WRT S N=0 F A=0:0 S N=$O(^LRO(69.2,LRAA,7,DUZ,1,"C",N)) Q:N=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^LRO(69.2,LRAA,7,DUZ,1,"C",N,LRDFN)) Q:'LRDFN!(LR("Q")) S W=^LRO(69.2,LRAA,7,DUZ,1,LRDFN,0) D W
Q
W S W(2)=$P(W,"^",2),W(5)=$P(W,"^",5),DFN=$P(W,"^",6),W(10)=$P(W,"^",10),Y=$P(W,"^",4) D D^LRU S W(4)=Y D H Q:LR("Q") S LR("F")=1
F A=0:0 S A=$O(^TMP($J,LRDFN,A)) Q:'A!(LR("Q")) S T=+^(A,0) D T,P
D:DFN ^LRBLPC1 Q
P D:$Y>(IOSL-6) H Q:LR("Q")
W !,T S Q=$S($D(^TMP($J,LRDFN,A,.1)):^(.1),1:"") W:Q ?15,$E($P(^LAB(66,+Q,0),"^"),1,25),$S($P(Q,"^",6):"("_$P(Q,"^",6)_")",1:"")
Q:'$O(^TMP($J,LRDFN,A,.1))
S X(1)=0 F B=0:0 S B=$O(LRT(B)) Q:B="" S X(1)=X(1)+1 S:$X>(IOM-9) X(1)=1 W:$X>(IOM-9) !?32 W ?32+(8*X(1)) I $D(^TMP($J,LRDFN,A,B)) W $J(^(B),5)
Q
S S X=^LAB(60,Y,0),X(1)=$S($D(^(.1)):$P(^(.1),"^"),1:"??"),Z=$S($D(^(1,W,0)):$P(^(0),"^",7),1:"")
S LRT(A)=$P($P(X,"^",5),";",2,3)_"^"_W_"^"_$P(X,"^")_"^"_Z_"^"_$P(^LAB(61,W,0),"^")_"^"_Y_"^"_X(1),LRV(A)=+LRT(A),LRS(A)=W 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
;
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"TRANSFUSION/HEMATOLOGY RESULTS",!,W(2),?31,W(10),?45,"DOB: ",W(4),!,"Location:",?12,W(5),!,"Mo/Da/Yr TIME",?15,"Blood component"
S X(1)=0 F X=0:0 S X=$O(LRT(X)) Q:X="" S X(1)=X(1)+1 S:$X>(IOM-8) X(1)=1 W:$X>(IOM-8) !?32 W ?32+(8*X(1)),$P(LRT(X),"^",7)
W !,LR("%") Q
G S:$D(DPF) LRDPF=DPF S LRPF="^"_$P(LRDPF,"^",2)
;S Y=@(LRPF_DFN_",0)"),Y(0)=$P(Y,"^")_U_$P(Y,"^",2)_U_$P(Y,"^",3)_U_$S($D(^(.1)):^(.1),1:"")_"^"_$S(LRPF="^DPT(":DFN,1:"")_"^^^^"_$P(Y,"^",9) Q
S Y=@(LRPF_DFN_",0)"),Y(0)=$P(Y,"^")_U_$P(Y,"^",2)_U_$P(Y,"^",3)_U_$S($D(^(.1)):^(.1),1:"")_"^"_$S(LRPF="^DPT(":DFN,1:"")_"^^^^"_$S($P($G(^AUPNPAT(+$G(DFN),41,+$G(DUZ(2)),0)),U,2)'="":$P(^(0),U,2),1:"??") Q ;IHS/ANMC/CLS 11/1/95
;
END D V^LRU Q
OUT W $C(7),!!?10,"Cannot use this option until your last report is completed.",!,"If the report was queued and never printed it must be removed from the"
W !,"list of queued reports (see your LIM). Also have your blood bank supervisor",!,"delete your patient list for transfusion & hematology data." G END
LRBLPC ; IHS/DIR/FJE - TRANSFUSIONS/HEM RESULTS 2/18/93 09:42 ;
+1 ;;5.2;LR;;NOV 01, 1997
+2 ;
+3 ;;5.2;LAB SERVICE;;Sep 27, 1994
+4 WRITE !!?14,"Print transfusions & hematology data for a patient"
DO V^LRU
+5 SET LRS=$ORDER(^LAB(61,"B","BLOOD",0))
IF 'LRS
SET LRS=$ORDER(^LAB(61,"B","PERIPHERAL BLOOD",0))
IF 'LRS
WRITE $CHAR(7),!,"BLOOD or PERIPHERAL BLOOD must be an entry in TOPOGRAPHY file (#61)",!
GOTO END
+6 SET X="BLOOD BANK"
DO ^LRUTL
IF Y=-1
GOTO END
KILL LRDPAF
SET A=0
FOR B=0:1
SET A=$ORDER(^LRO(69.2,LRAA,61,LRS,2,A))
IF 'A
QUIT
SET Y=^(A,0)
SET W=$PIECE(Y,"^",2)
SET Y=+Y
DO S
+7 SET LRT(0)=B
IF 'B
WRITE $CHAR(7),!!,"Must have tests to print entered in the",!,"'Tests for inclusion in transfusion report option' in",!,"Blood bank supervisor menu",!
GOTO END
+8 IF '$DATA(^LRO(69.2,LRAA,7,0))
SET ^(0)="^69.28PA^^"
IF '$DATA(^(DUZ,0))
SET ^(0)=DUZ
SET X=^LRO(69.2,LRAA,7,0)
SET ^(0)="^69.28PA^"_DUZ_"^"_($PIECE(X,"^",4)+1)
+9 IF $ORDER(^LRO(69.2,LRAA,7,DUZ,1,0))
GOTO OUT
+10 KILL ^LRO(69.2,LRAA,7,DUZ)
SET ^LRO(69.2,LRAA,7,DUZ,0)=DUZ_"^"_DT
SET ^LRO(69.2,LRAA,7,DUZ,1,0)="^69.3PA^^"
+11 KILL DIC
FOR LRA=1:1
WRITE !,"Choice: ",LRA
DO ^LRDPA
IF LRDFN<1
QUIT
DO G
SET X=^LRO(69.2,LRAA,7,DUZ,1,0)
SET ^(0)="^69.3PA^"_LRDFN_"^"_($PIECE(X,"^",4)+1)
SET ^(LRDFN,0)=LRDFN_"^"_Y(0)
SET ^LRO(69.2,LRAA,7,DUZ,1,"C",$PIECE(Y(0),"^"),LRDFN)=""
+12 IF LRA=1
GOTO END
DO B^LRU
IF Y<0
DO SET^LRBLPC1
GOTO END
+13 SET LRLDT=9999998-LRLDT
SET LRSDT=9999999-LRSDT
SET ZTRTN="QUE^LRBLPC"
DO BEG^LRUTL
IF $DATA(ZTSK)
QUIT
IF POP
DO SET^LRBLPC1
GOTO END
QUE USE IO
DO L^LRU
DO S^LRU
IF IOST?1"C".E
DO WAIT^LRU
KILL ^TMP($JOB)
+1 FOR LRDFN=0:0
SET LRDFN=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,LRDFN))
IF 'LRDFN
QUIT
DO A
+2 DO WRT
IF IOST'?1"C".E
WRITE @IOF
KILL ^LRO(69.2,LRAA,7,DUZ)
DO END
DO END^LRUTL
QUIT
A SET ^TMP($JOB,LRDFN)=""
FOR A=LRLDT:0
SET A=$ORDER(^LR(LRDFN,1.6,A))
IF 'A!(A>LRSDT)
QUIT
SET X=^(A,0)
SET ^TMP($JOB,LRDFN,A,0)=+X
SET ^(.1)=$PIECE(X,"^",2,99)
+1 FOR A=LRLDT:0
SET A=$ORDER(^LR(LRDFN,"CH",A))
IF 'A!(A>LRSDT)
QUIT
SET X=^(A,0)
FOR B=0:0
SET B=$ORDER(LRT(B))
IF B=""
QUIT
SET Z=$SELECT($DATA(^LR(LRDFN,"CH",A,LRV(B))):$PIECE(^(LRV(B)),"^"),1:"")
IF Z]""
IF $PIECE(X,"^",5)=LRS(B)
SET ^TMP($JOB,LRDFN,A,0)=+X
SET ^(B)=Z
+2 QUIT
WRT SET N=0
FOR A=0:0
SET N=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,"C",N))
IF N=""!(LR("Q"))
QUIT
FOR LRDFN=0:0
SET LRDFN=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,"C",N,LRDFN))
IF 'LRDFN!(LR("Q"))
QUIT
SET W=^LRO(69.2,LRAA,7,DUZ,1,LRDFN,0)
DO W
+1 QUIT
W SET W(2)=$PIECE(W,"^",2)
SET W(5)=$PIECE(W,"^",5)
SET DFN=$PIECE(W,"^",6)
SET W(10)=$PIECE(W,"^",10)
SET Y=$PIECE(W,"^",4)
DO D^LRU
SET W(4)=Y
DO H
IF LR("Q")
QUIT
SET LR("F")=1
+1 FOR A=0:0
SET A=$ORDER(^TMP($JOB,LRDFN,A))
IF 'A!(LR("Q"))
QUIT
SET T=+^(A,0)
DO T
DO P
+2 IF DFN
DO ^LRBLPC1
QUIT
P IF $Y>(IOSL-6)
DO H
IF LR("Q")
QUIT
+1 WRITE !,T
SET Q=$SELECT($DATA(^TMP($JOB,LRDFN,A,.1)):^(.1),1:"")
IF Q
WRITE ?15,$EXTRACT($PIECE(^LAB(66,+Q,0),"^"),1,25),$SELECT($PIECE(Q,"^",6):"("_$PIECE(Q,"^",6)_")",1:"")
+2 IF '$ORDER(^TMP($JOB,LRDFN,A,.1))
QUIT
+3 SET X(1)=0
FOR B=0:0
SET B=$ORDER(LRT(B))
IF B=""
QUIT
SET X(1)=X(1)+1
IF $X>(IOM-9)
SET X(1)=1
IF $X>(IOM-9)
WRITE !?32
WRITE ?32+(8*X(1))
IF $DATA(^TMP($JOB,LRDFN,A,B))
WRITE $JUSTIFY(^(B),5)
+4 QUIT
S SET X=^LAB(60,Y,0)
SET X(1)=$SELECT($DATA(^(.1)):$PIECE(^(.1),"^"),1:"??")
SET Z=$SELECT($DATA(^(1,W,0)):$PIECE(^(0),"^",7),1:"")
+1 SET LRT(A)=$PIECE($PIECE(X,"^",5),";",2,3)_"^"_W_"^"_$PIECE(X,"^")_"^"_Z_"^"_$PIECE(^LAB(61,W,0),"^")_"^"_Y_"^"_X(1)
SET LRV(A)=+LRT(A)
SET LRS(A)=W
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
+1 ;
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
IF LR("Q")
QUIT
+1 DO F^LRU
WRITE !,"TRANSFUSION/HEMATOLOGY RESULTS",!,W(2),?31,W(10),?45,"DOB: ",W(4),!,"Location:",?12,W(5),!,"Mo/Da/Yr TIME",?15,"Blood component"
+2 SET X(1)=0
FOR X=0:0
SET X=$ORDER(LRT(X))
IF X=""
QUIT
SET X(1)=X(1)+1
IF $X>(IOM-8)
SET X(1)=1
IF $X>(IOM-8)
WRITE !?32
WRITE ?32+(8*X(1)),$PIECE(LRT(X),"^",7)
+3 WRITE !,LR("%")
QUIT
G IF $DATA(DPF)
SET LRDPF=DPF
SET LRPF="^"_$PIECE(LRDPF,"^",2)
+1 ;PC_source.html#xPC_source.html#xS">S">PC_source.html#xS">S Y=@(LRPC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">PC_source.html#xPC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">P">PC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">PF_DFN_",0)"),Y(0)=$PC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">PC_source.html#xPC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">P">PC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">P(Y,"^")_U_$PC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">PC_source.html#xPC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">P">PC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">P(Y,"^",2)_U_$PC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">PC_source.html#xPC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">P">PC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">P(Y,"^",3)_U_$PC_source.html#xPC_source.html#xS">S">PC_source.html#xS">S($D(^(.1)):^(.1),1:"")_"^"_$PC_source.html#xPC_source.html#xS">S">PC_source.html#xS">S(LRPC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">PC_source.html#xPC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">P">PC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">PF="^DPC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">PC_source.html#xPC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">P">PC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">PT(":DFN,1:"")_"^^^^"_$PC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">PC_source.html#xPC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">P">PC_source.html#xP">PC_source.html#xPC_source.html#xP">P">PC_source.html#xP">P(Y,"^",9) Q
+2 ;IHS/ANMC/CLS 11/1/95
SET Y=@(LRPF_DFN_",0)")
SET Y(0)=$PIECE(Y,"^")_U_$PIECE(Y,"^",2)_U_$PIECE(Y,"^",3)_U_$SELECT($DATA(^(.1)):^(.1),1:"")_"^"_$SELECT(LRPF="^DPT(":DFN,1:"")_"^^^^"_$SELECT($PIECE($GET(^AUPNPAT(+$GET(DFN),41,+$GET(DUZ(2)),0)),U,2)'="":$PIECE(^(0),U,2),1:"??")
QUIT
+3 ;
END DO V^LRU
QUIT
OUT WRITE $CHAR(7),!!?10,"Cannot use this option until your last report is completed.",!,"If the report was queued and never printed it must be removed from the"
+1 WRITE !,"list of queued reports (see your LIM). Also have your blood bank supervisor",!,"delete your patient list for transfusion & hematology data."
GOTO END
