LRBLPT1 ;AVAMC/REG - TRANSFUSION RESULTS (COND'T) ;12/11/92 07:38 ;
;;5.2;LAB SERVICE;**247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
W !! S LRJ=^TMP($J,LRV),(X,LRI)=+LRJ,F=$P(LRJ,"^",7),X=^LRD(65,X,0),LRC=$P(X,"^",11),M=^LAB(66,$P(X,"^",4),0),M(1)=$P(M,"^",24),M=$P(M,"^"),LRW=$P(X,"^",5),LR(65,.04)=+$P(X,"^",4)
D U W !,"Is this the unit " S %=1 D YN^LRU Q:%'=1
DT S %DT="AEXT",%DT("A")="DATE/TIME TRANSFUSION COMPLETED: ",%DT(0)="-N" D ^%DT K %DT Q:Y<1 S LRR=Y,LRQ(1)="" I Y'["." W $C(7)," Enter date & TIME" G DT
I Y<LRW W $C(7),!!,"DATE/TIME MUST BE AFTER DATE UNIT RECEIVED IN INVENTORY",! G DT
I M(1) S R=$O(^LRD(65,LRI,3,0)) I R S W(3)=^(R,0),R=+W(3),Z=Y D H^LRUT S J=%H,J(0)=Z(3),Z=R D H^LRUT S X=J-%H*1440,Y=J(0)-Z(3),J=X+Y I J>M(1) W $C(7),!!,"Prolonged transfusion time (",J," min) OK " S %=2 D YN^LRU Q:%'=1 G T
S Y=LRR W !!,"DATE/TIME TRANSFUSION COMPLETED: " D D^LRU W Y," " S %=1 D YN^LRU G:%'=1 DT
T W !!,"TRANSFUSION REACTION " S %=2 D YN^LRU Q:%<1 S LRR(3)=$S(%=2:0,%=1:1,1:""),LRR(8)=""
I LRR(3)=1 S DIC="^LAB(65.4,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)=""T""",DIC("A")="Select TRANSFUSION REACTION TYPE: " D ^DIC K DIC S:Y>0 LRR(8)=+Y
S DIE="^LRD(65,",DA=LRI,DR="4.1///T;4.2///^S X=LRR;4.3////^S X=DUZ;7" D ^DIE I $D(^LRD(65,LRI,9,0)) S LRQ(1)=$P(^(0),"^",4) S:LRQ(1)>0 $P(^LRD(65,LRI,4),"^",4)="("_LRQ(1)_")"
S X=$P(LRJ,"^",6) I X S X=$O(^LRD(65,LRI,2,LRDFN,1,"B",X,0)) S:X $P(^LRD(65,LRI,2,LRDFN,1,X,0),"^",10)="TRANSFUSED"
F A=0:0 S A=$O(^LRD(65,DA,2,A)) Q:'A I $D(^LR(A,1.8,LR(65,.04),1,DA,0)) K ^(0) L +^LR(A,1.8,LR(65,.04),1,0) S X=^LR(A,1.8,LR(65,.04),1,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1) L -^LR(A,1.8,LR(65,.04),1,0)
S LRR(1)=9999999-LRR S:'$D(^LR(LRDFN,1.6,0)) ^(0)="^63.017DAI^^" L +^LR(LRDFN,1.6)
F I $D(^LR(LRDFN,1.6,LRR(1))) S LRR(1)=LRR(1)-.00001 G F
S ^LR(LRDFN,1.6,LRR(1),0)=LRR_"^"_$P(LRJ,"^",2)_"^"_$P(LRJ,"^",3)_"^"_DUZ_"^"_$P(LRJ,"^",4)_"^"_$P(LRJ,"^",5)_"^"_LRQ(1)_"^"_LRR(3)_"^^"_LRC_"^"_LRR(8)
S:LRR(8) ^LR("AB",LRDFN,LRR(8),LRR(1))=""
S ^LR(LRDFN,1.6,0)="^63.017DAI^"_LRR(1)_"^"_($P(^LR(LRDFN,1.6,0),"^",4)+1) L -^LR(LRDFN,1.6)
S ^LRD(65,LRI,6)=LRDFN_"^"_LRMD_"^"_LRS_"^"_LRR(1)_"^"_LRR(3)_"^"_LRMD(1)_"^"_LRS(1)_"^"_LRR(8) S E=0 F E(1)=1:1 S E=$O(^LRD(65,LRI,7,E)) Q:'E S E(2)=^(E,0),^LR(LRDFN,1.6,LRR(1),1,E(1),0)=E(2)
S:E(1)>1 ^LR(LRDFN,1.6,LRR(1),1,0)="^63.186A^"_(E(1)-1)_"^"_(E(1)-1)
S E(3)=$O(^LRD(65,LRI,2,LRDFN,1,0)) I E(3) S E=0 F E(1)=1:1 S E=$O(^LRD(65,LRI,2,LRDFN,1,E(3),3,E)) Q:'E S E(2)=^(E,0),^LR(LRDFN,1.6,LRR(1),2,E(1),0)=E(2)
S:E(1)>1 ^LR(LRDFN,1.6,LRR(1),2,0)="^63.027A^"_(E(1)-1)_"^"_(E(1)-1) Q
U W $P(X,"^"),?17,$E(M,1,22),?40,$J($P(X,"^",7),2),?43,$P(X,"^",8),?48 S Y=$P(X,"^",6) D DT^LRU W Y,?64,F Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPT1 2815 printed Nov 22, 2024@17:22:07 Page 2
LRBLPT1 ;AVAMC/REG - TRANSFUSION RESULTS (COND'T) ;12/11/92 07:38 ;
+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 WRITE !!
SET LRJ=^TMP($JOB,LRV)
SET (X,LRI)=+LRJ
SET F=$PIECE(LRJ,"^",7)
SET X=^LRD(65,X,0)
SET LRC=$PIECE(X,"^",11)
SET M=^LAB(66,$PIECE(X,"^",4),0)
SET M(1)=$PIECE(M,"^",24)
SET M=$PIECE(M,"^")
SET LRW=$PIECE(X,"^",5)
SET LR(65,.04)=+$PIECE(X,"^",4)
+4 DO U
WRITE !,"Is this the unit "
SET %=1
DO YN^LRU
if %'=1
QUIT
DT SET %DT="AEXT"
SET %DT("A")="DATE/TIME TRANSFUSION COMPLETED: "
SET %DT(0)="-N"
DO ^%DT
KILL %DT
if Y<1
QUIT
SET LRR=Y
SET LRQ(1)=""
IF Y'["."
WRITE $CHAR(7)," Enter date & TIME"
GOTO DT
+1 IF Y<LRW
WRITE $CHAR(7),!!,"DATE/TIME MUST BE AFTER DATE UNIT RECEIVED IN INVENTORY",!
GOTO DT
+2 IF M(1)
SET R=$ORDER(^LRD(65,LRI,3,0))
IF R
SET W(3)=^(R,0)
SET R=+W(3)
SET Z=Y
DO H^LRUT
SET J=%H
SET J(0)=Z(3)
SET Z=R
DO H^LRUT
SET X=J-%H*1440
SET Y=J(0)-Z(3)
SET J=X+Y
IF J>M(1)
WRITE $CHAR(7),!!,"Prolonged transfusion time (",J," min) OK "
SET %=2
DO YN^LRU
if %'=1
QUIT
GOTO T
+3 SET Y=LRR
WRITE !!,"DATE/TIME TRANSFUSION COMPLETED: "
DO D^LRU
WRITE Y," "
SET %=1
DO YN^LRU
if %'=1
GOTO DT
T WRITE !!,"TRANSFUSION REACTION "
SET %=2
DO YN^LRU
if %<1
QUIT
SET LRR(3)=$SELECT(%=2:0,%=1:1,1:"")
SET LRR(8)=""
+1 IF LRR(3)=1
SET DIC="^LAB(65.4,"
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,2)=""T"""
SET DIC("A")="Select TRANSFUSION REACTION TYPE: "
DO ^DIC
KILL DIC
if Y>0
SET LRR(8)=+Y
+2 SET DIE="^LRD(65,"
SET DA=LRI
SET DR="4.1///T;4.2///^S X=LRR;4.3////^S X=DUZ;7"
DO ^DIE
IF $DATA(^LRD(65,LRI,9,0))
SET LRQ(1)=$PIECE(^(0),"^",4)
if LRQ(1)>0
SET $PIECE(^LRD(65,LRI,4),"^",4)="("_LRQ(1)_")"
+3 SET X=$PIECE(LRJ,"^",6)
IF X
SET X=$ORDER(^LRD(65,LRI,2,LRDFN,1,"B",X,0))
if X
SET $PIECE(^LRD(65,LRI,2,LRDFN,1,X,0),"^",10)="TRANSFUSED"
+4 FOR A=0:0
SET A=$ORDER(^LRD(65,DA,2,A))
if 'A
QUIT
IF $DATA(^LR(A,1.8,LR(65,.04),1,DA,0))
KILL ^(0)
LOCK +^LR(A,1.8,LR(65,.04),1,0)
SET X=^LR(A,1.8,LR(65,.04),1,0)
SET X(1)=$ORDER(^(0))
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)
LOCK -^LR(A,1.8,LR(65,.04),1,0)
+5 SET LRR(1)=9999999-LRR
if '$DATA(^LR(LRDFN,1.6,0))
SET ^(0)="^63.017DAI^^"
LOCK +^LR(LRDFN,1.6)
F IF $DATA(^LR(LRDFN,1.6,LRR(1)))
SET LRR(1)=LRR(1)-.00001
GOTO F
+1 SET ^LR(LRDFN,1.6,LRR(1),0)=LRR_"^"_$PIECE(LRJ,"^",2)_"^"_$PIECE(LRJ,"^",3)_"^"_DUZ_"^"_$PIECE(LRJ,"^",4)_"^"_$PIECE(LRJ,"^",5)_"^"_LRQ(1)_"^"_LRR(3)_"^^"_LRC_"^"_LRR(8)
+2 if LRR(8)
SET ^LR("AB",LRDFN,LRR(8),LRR(1))=""
+3 SET ^LR(LRDFN,1.6,0)="^63.017DAI^"_LRR(1)_"^"_($PIECE(^LR(LRDFN,1.6,0),"^",4)+1)
LOCK -^LR(LRDFN,1.6)
+4 SET ^LRD(65,LRI,6)=LRDFN_"^"_LRMD_"^"_LRS_"^"_LRR(1)_"^"_LRR(3)_"^"_LRMD(1)_"^"_LRS(1)_"^"_LRR(8)
SET E=0
FOR E(1)=1:1
SET E=$ORDER(^LRD(65,LRI,7,E))
if 'E
QUIT
SET E(2)=^(E,0)
SET ^LR(LRDFN,1.6,LRR(1),1,E(1),0)=E(2)
+5 if E(1)>1
SET ^LR(LRDFN,1.6,LRR(1),1,0)="^63.186A^"_(E(1)-1)_"^"_(E(1)-1)
+6 SET E(3)=$ORDER(^LRD(65,LRI,2,LRDFN,1,0))
IF E(3)
SET E=0
FOR E(1)=1:1
SET E=$ORDER(^LRD(65,LRI,2,LRDFN,1,E(3),3,E))
if 'E
QUIT
SET E(2)=^(E,0)
SET ^LR(LRDFN,1.6,LRR(1),2,E(1),0)=E(2)
+7 if E(1)>1
SET ^LR(LRDFN,1.6,LRR(1),2,0)="^63.027A^"_(E(1)-1)_"^"_(E(1)-1)
QUIT
U WRITE $PIECE(X,"^"),?17,$EXTRACT(M,1,22),?40,$JUSTIFY($PIECE(X,"^",7),2),?43,$PIECE(X,"^",8),?48
SET Y=$PIECE(X,"^",6)
DO DT^LRU
WRITE Y,?64,F
QUIT
