LRBLPD ;AVAMC/REG - BB PT INFO ;2/18/93 09:42 ;
;;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 I LRSS'="BB" W $C(7),!!,"MUST BE BLOOD BANK" G END
S LRQ=1 D ^LRUL I '$O(^LRO(69.2,LRAA,7,DUZ,1,0)) D R^LRUL G END
S X=$P(^DD(66,.26,0),U,3),LRF(1)="RBC",LRG(1)="1^RBC",C=1 F A=7:1 S B=$P(X,";",A) Q:B="" S C=C+1,LRG(C)=A_"^"_$P(B,":",2),LRF(A)=$P(B,":",2)
W !,"List all blood components " S %=1 D YN^LRU G:%<1 END S LRE=$S(%=1:1,1:0) I 'LRE D ASK G:'LRF END
W !,"List only total number of units for each component " S %=2 D YN^LRU G:%<1 END S LRJ=$S(%=1:1,1:0)
D B^LRU G:Y<0 END S LRLDT=9999998-LRLDT,LRSDT=9999999-LRSDT
K DIC,DIE,DR S ZTRTN="QUE^LRBLPD" D BEG^LRUTL D:POP R^LRUL G:POP!($D(ZTSK)) END
QUE U IO D L^LRU,S^LRU
S DIWL=5,DIWR=IOM-5,DIWF="W",LRC(1.7)="RBC Antibody present:",LRC(1)="RBC Antigen present :",LRC(1.5)="RBC Antigen absent :"
S LRP=0 F LRP(1)=0:0 S LRP=$O(^LRO(69.2,LRAA,7,DUZ,1,"C",LRP)) Q:LRP=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^LRO(69.2,LRAA,7,DUZ,1,"C",LRP,LRDFN)) Q:'LRDFN!(LR("Q")) D LOOP
D EN^LRUL,END^LRUTL,END Q
LOOP K ^TMP($J) S LRQ=0,SSN=$P(^LRO(69.2,LRAA,7,DUZ,1,LRDFN,0),"^",10),X=^LR(LRDFN,0),LRPABO=$P(X,"^",5),LRPRH=$P(X,"^",6),LRDPF=$P(X,U,2) D H S LR("F")=1
S LRI=LRLDT F B=1:1 S LRI=$O(^LR(LRDFN,1.6,LRI)) Q:'LRI!(LRI>LRSDT) D SET
S A=0 F B=1:1 S A=$O(^TMP($J,A)) Q:A=""!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") W ! S LRT=0 D N Q:LR("Q") W:LRT !,"Total ",$S($D(LRF(A)):LRF(A),1:"?"),": ",LRT
Q:LR("Q") I B=1 W !,"No transfused units" W:'LRE " for ",LRF(LRF) W " on record for specified period.",!
W !! K ^TMP($J) S A=0 F B=0:1 S A=$O(^LR(LRDFN,3,A)) Q:'A!(LR("Q")) S LRX=^(A,0) D:$Y>(IOSL-6) H Q:LR("Q") S X=LRX D ^DIWP
D:B ^DIWW W ! F C=1.7,1,1.5 Q:LR("Q") W ! S A=0 F B=0:1 S A=$O(^LR(LRDFN,C,A)) Q:'A!(LR("Q")) W:'B LRC(C) W:B ! W ?21,$P(^LAB(61.3,A,0),"^") D:$Y>(IOSL-6) H Q:LR("Q")
Q
;
SET S X=^LR(LRDFN,1.6,LRI,0),Z=+$P(X,"^",2),Z=$S($D(^LAB(66,Z,0)):^(0),1:""),Y=+$P(Z,"^",19),Z=+$P(Z,"^",26),Z=$S(Y:1,'Z:"?",1:Z) I 'LRE,LRF'=Z Q
S ^TMP($J,Z,B)=LRI_"^"_X Q
;
ASK S (A,LRF)=0 F B=0:0 S B=$O(LRG(B)) Q:'B W !?13,$J(B,2),?18,$P(LRG(B),"^",2) S A=A+1
W !!,"Select (1-",A,"): " R X:DTIME Q:X=""!(X[U) I +X'=X!(X<1)!(X>A) W $C(7),!!,"Select a NUMBER from 1 to ",A G ASK
S LRF=+LRG(X) W ?18,$P(LRG(X),"^",2) Q
;
N F C=0:0 S C=$O(^TMP($J,A,C)) Q:'C!(LR("Q")) S X=^(C),LRI=+X,Y=$P(X,U,2) D D^LRU,O Q:LR("Q") D:$Y>(IOSL-6) H Q:LR("Q")
Q
O S X(1)=+$P(X,U,3),X(7)=$P(X,U,8),X(10)=$P(X,U,11),M=$S($D(^LAB(66,X(1),0)):$E($P(^(0),U),1,30),1:"component not known"),LRT=LRT+$S(X(7):X(7),1:1)
Q:LRJ W !,$P(X,"^",4),?18,$E($P(M,"^"),1,30) I X(7)!(X(10)) W ?45,"(",X(7),"/",X(10),")"
W ?54,$P(X,"^",6)_" "_$P(X,"^",7),?60,Y
F F=1,2 F E=0:0 S E=$O(^LR(LRDFN,1.6,LRI,F,E)) Q:'E!(LR("Q")) W !?6,^(E,0) D:$Y>(IOSL-6) H Q:LR("Q")
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 !,"TRANSFUSION SERVICE/BLOOD BANK REPORT from ",LRSTR," to ",LRLST,!,"PATIENT: ",LRP," ",SSN," ",$J(LRPABO,2)," ",LRPRH
W:'LRJ !,"Unit Transfused",?18,"Component",?36,"(# of Units/ml )",?60,"Date/Time Completed" W:LRJ !,"Components Transfused" W !,LR("%")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPD 3301 printed Nov 22, 2024@17:21:52 Page 2
LRBLPD ;AVAMC/REG - BB PT INFO ;2/18/93 09:42 ;
+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
IF LRSS'="BB"
WRITE $CHAR(7),!!,"MUST BE BLOOD BANK"
GOTO END
+4 SET LRQ=1
DO ^LRUL
IF '$ORDER(^LRO(69.2,LRAA,7,DUZ,1,0))
DO R^LRUL
GOTO END
+5 SET X=$PIECE(^DD(66,.26,0),U,3)
SET LRF(1)="RBC"
SET LRG(1)="1^RBC"
SET C=1
FOR A=7:1
SET B=$PIECE(X,";",A)
if B=""
QUIT
SET C=C+1
SET LRG(C)=A_"^"_$PIECE(B,":",2)
SET LRF(A)=$PIECE(B,":",2)
+6 WRITE !,"List all blood components "
SET %=1
DO YN^LRU
if %<1
GOTO END
SET LRE=$SELECT(%=1:1,1:0)
IF 'LRE
DO ASK
if 'LRF
GOTO END
+7 WRITE !,"List only total number of units for each component "
SET %=2
DO YN^LRU
if %<1
GOTO END
SET LRJ=$SELECT(%=1:1,1:0)
+8 DO B^LRU
if Y<0
GOTO END
SET LRLDT=9999998-LRLDT
SET LRSDT=9999999-LRSDT
+9 KILL DIC,DIE,DR
SET ZTRTN="QUE^LRBLPD"
DO BEG^LRUTL
if POP
DO R^LRUL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
DO L^LRU
DO S^LRU
+1 SET DIWL=5
SET DIWR=IOM-5
SET DIWF="W"
SET LRC(1.7)="RBC Antibody present:"
SET LRC(1)="RBC Antigen present :"
SET LRC(1.5)="RBC Antigen absent :"
+2 SET LRP=0
FOR LRP(1)=0:0
SET LRP=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,"C",LRP))
if LRP=""!(LR("Q"))
QUIT
FOR LRDFN=0:0
SET LRDFN=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,"C",LRP,LRDFN))
if 'LRDFN!(LR("Q"))
QUIT
DO LOOP
+3 DO EN^LRUL
DO END^LRUTL
DO END
QUIT
LOOP KILL ^TMP($JOB)
SET LRQ=0
SET SSN=$PIECE(^LRO(69.2,LRAA,7,DUZ,1,LRDFN,0),"^",10)
SET X=^LR(LRDFN,0)
SET LRPABO=$PIECE(X,"^",5)
SET LRPRH=$PIECE(X,"^",6)
SET LRDPF=$PIECE(X,U,2)
DO H
SET LR("F")=1
+1 SET LRI=LRLDT
FOR B=1:1
SET LRI=$ORDER(^LR(LRDFN,1.6,LRI))
if 'LRI!(LRI>LRSDT)
QUIT
DO SET
+2 SET A=0
FOR B=1:1
SET A=$ORDER(^TMP($JOB,A))
if A=""!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !
SET LRT=0
DO N
if LR("Q")
QUIT
if LRT
WRITE !,"Total ",$SELECT($DATA(LRF(A)):LRF(A),1:"?"),": ",LRT
+3 if LR("Q")
QUIT
IF B=1
WRITE !,"No transfused units"
if 'LRE
WRITE " for ",LRF(LRF)
WRITE " on record for specified period.",!
+4 WRITE !!
KILL ^TMP($JOB)
SET A=0
FOR B=0:1
SET A=$ORDER(^LR(LRDFN,3,A))
if 'A!(LR("Q"))
QUIT
SET LRX=^(A,0)
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
SET X=LRX
DO ^DIWP
+5 if B
DO ^DIWW
WRITE !
FOR C=1.7,1,1.5
if LR("Q")
QUIT
WRITE !
SET A=0
FOR B=0:1
SET A=$ORDER(^LR(LRDFN,C,A))
if 'A!(LR("Q"))
QUIT
if 'B
WRITE LRC(C)
if B
WRITE !
WRITE ?21,$PIECE(^LAB(61.3,A,0),"^")
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
+6 QUIT
+7 ;
SET SET X=^LR(LRDFN,1.6,LRI,0)
SET Z=+$PIECE(X,"^",2)
SET Z=$SELECT($DATA(^LAB(66,Z,0)):^(0),1:"")
SET Y=+$PIECE(Z,"^",19)
SET Z=+$PIECE(Z,"^",26)
SET Z=$SELECT(Y:1,'Z:"?",1:Z)
IF 'LRE
IF LRF'=Z
QUIT
+1 SET ^TMP($JOB,Z,B)=LRI_"^"_X
QUIT
+2 ;
ASK SET (A,LRF)=0
FOR B=0:0
SET B=$ORDER(LRG(B))
if 'B
QUIT
WRITE !?13,$JUSTIFY(B,2),?18,$PIECE(LRG(B),"^",2)
SET A=A+1
+1 WRITE !!,"Select (1-",A,"): "
READ X:DTIME
if X=""!(X[U)
QUIT
IF +X'=X!(X<1)!(X>A)
WRITE $CHAR(7),!!,"Select a NUMBER from 1 to ",A
GOTO ASK
+2 SET LRF=+LRG(X)
WRITE ?18,$PIECE(LRG(X),"^",2)
QUIT
+3 ;
N FOR C=0:0
SET C=$ORDER(^TMP($JOB,A,C))
if 'C!(LR("Q"))
QUIT
SET X=^(C)
SET LRI=+X
SET Y=$PIECE(X,U,2)
DO D^LRU
DO O
if LR("Q")
QUIT
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
+1 QUIT
O SET X(1)=+$PIECE(X,U,3)
SET X(7)=$PIECE(X,U,8)
SET X(10)=$PIECE(X,U,11)
SET M=$SELECT($DATA(^LAB(66,X(1),0)):$EXTRACT($PIECE(^(0),U),1,30),1:"component not known")
SET LRT=LRT+$SELECT(X(7):X(7),1:1)
+1 if LRJ
QUIT
WRITE !,$PIECE(X,"^",4),?18,$EXTRACT($PIECE(M,"^"),1,30)
IF X(7)!(X(10))
WRITE ?45,"(",X(7),"/",X(10),")"
+2 WRITE ?54,$PIECE(X,"^",6)_" "_$PIECE(X,"^",7),?60,Y
+3 FOR F=1,2
FOR E=0:0
SET E=$ORDER(^LR(LRDFN,1.6,LRI,F,E))
if 'E!(LR("Q"))
QUIT
WRITE !?6,^(E,0)
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
+4 QUIT
+5 ;
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 !,"TRANSFUSION SERVICE/BLOOD BANK REPORT from ",LRSTR," to ",LRLST,!,"PATIENT: ",LRP," ",SSN," ",$JUSTIFY(LRPABO,2)," ",LRPRH
+2 if 'LRJ
WRITE !,"Unit Transfused",?18,"Component",?36,"(# of Units/ml )",?60,"Date/Time Completed"
if LRJ
WRITE !,"Components Transfused"
WRITE !,LR("%")
+3 QUIT
