LRBLPCS ; IHS/DIR/AAB - COMPONENT SELECTION FOR PATIENTS 8/4/95 06:32 ;
;;5.2;LR;**1002**;JUN 01, 1998
;;5.2;LAB SERVICE;**1,72**;Sep 27, 1994
D V^LRU,CK^LRBLPUS G:Y=-1 END I LRSS'="BB" W $C(7),!!,"MUST BE BLOOD BANK" G END
W !?20,LRAA(4),!!?15,"Selection of blood components for a patient" S LRJ=1
W !,"Display instructions for component selected " S %=2 D YN^LRU G:%<1 END S:%=1 LRO=1
P W ! K DIC D ^LRDPA K DIC,DIE,DR W ! G:LRDFN=-1 END D EN1 G P
;
EN1 ;Q:'$D(LRP) D ^LRBLPA Q:$D(Q("Q"))!(LRLLOC["DIED") W LRP," ",SSN(1),?42,$J(LRPABO,2),?45,LRPRH D EN^LRBLPUS
Q:'$D(LRP) D ^LRBLPA Q:$D(Q("Q"))!(LRLLOC["DIED") W LRP," ",HRCN,?42,$J(LRPABO,2),?45,LRPRH D EN^LRBLPUS ;IHS/ANMC/CLS 11/1/95
S A=0 F B=1:1 S A=$O(^LRD(65,"AP",LRDFN,A)) Q:'A D N
I $D(LRQ),B=1 W !,"No units currently assigned/xmatched"
W ! S A=0 F B=0:1 S A=$O(^LR(LRDFN,1.8,A)) Q:'A S X=^(A,0) W:'B !,"Component(s) requested",?27,"Units",?33,"Request date",?47,"Date wanted",?59,"Requestor",?77,"By" D L
OP K LRR S LRCPT=0 W !!,"Is patient Pre-op " S %="" D YN^LRU I %<1 W $C(7),!,"You must answer 'YES' or 'NO' to enter component request.",!,"Do you want to enter component request at this time " S %=1 D YN^LRU G:%=1 OP Q
S LRV=$S(%=2:0,1:1),LRV(1)=$S(LRV=1:8,1:6) D:LRV ^LRBLPCSS
S DIE=63,DA=LRDFN,DR="[LRBLPCS]"
W ! D ^DIE K DIE,DR D:$D(LRK) EN^LRBLPCS1 K LRK,S,C Q
;
EN3 F A=0:0 S A=$O(^LAB(66,C,LRV(1),A)) Q:'A S X=^(A,0),E=$P(X,"^",2),F=+X,C(C,F,E)=$P(X,"^",3) I '$D(S(F,E)) D G
K I(0) F A=0:0 S A=$O(C(C,A)) Q:'A F B=0:0 S B=$O(C(C,A,B)) Q:'B D A
K:$D(I(0)) Q I $D(Q) K Q W !?5,$C(7)," Request still OK " S %=2 D YN^LRU S:%=1 LRR=1 I %'=1 S Y=0 D DEL
S:$D(LRR) LRK(C)="" Q
G S X=$S($D(^LAB(60,F,0)):^(0),1:F) I $P(X,"^",5)'["CH" W $C(7),!,"No DATA NAME in file 60 for ",$P(X,"^") Q
S G=$P(X,";",2),H=+$P(X,";",3),Z=$S($D(^LAB(60,F,1,E,0)):$P(^(0),"^",7),1:""),I(0)=$P(X,"^")
F B=0:0 S B=$O(^LR(LRDFN,"CH",B)) Q:'B S W=^(B,0),S=$P(W,"^",5) I S=E,$D(^(G)),$L(^(G)) S X=^(G) D H Q
S:'$D(S(F,E)) S(F,E)="^"_I(0) Q
H S S(F,E)=$P(X,"^",H)_"^"_I(0)_"^"_$E(W,4,5)_"/"_$E(W,6,7)_"^"_Z_"^"_$P(^LAB(61,E,0),"^") Q
A Q:'$D(S(A,B)) I $P(S(A,B),"^")="" W !?10,"No ",$P(S(A,B),"^",2)," results " S Q=1 Q
I +S(A,B),@(+$P(S(A,B),"^")_C(C,A,B)) W !?10,$P(S(A,B),"^",3)," Last ",$P(S(A,B),"^",2),": ",$P(S(A,B),"^")," ",$P(S(A,B),"^",4)," ",$P(S(A,B),"^",5) S Q=1 Q
S I(0)=1 Q
EN2 K ^UTILITY($J) S DIWR=IOM-5,DIWL=5,DIWF="W" S A=0 F K=0:1 S A=$O(^LAB(66,C,7,A)) Q:'A S X=^(A,0) D ^DIWP
D:K ^DIWW Q
;
L S Y=+X I '$D(^LAB(66,Y,0)) K ^LR(LRDFN,1.8,Y) S Y=^LR(LRDFN,1.8,0),^(0)=$P(Y,"^",1,2)_"^^"_($P(Y,"^",4)-1) Q
W !,$E($P(^LAB(66,+X,0),"^"),1,27),?27,$J($P(X,"^",4),3),?33 S Y=$P(X,"^",3) D M W Y,?47 S Y=$P(X,"^",5) D M W Y,?59,$P(X,"^",9) S Y=$P(X,"^",8) W ?77,$S(Y="":Y,$D(^VA(200,Y,0)):$P(^(0),"^",2),1:Y) Q
M Q:'Y S Y=Y_"000",Y=$E(Y,4,5)_"/"_$E(Y,6,7)_$S(Y'[".":"",1:" "_$E(Y,9,10)_":"_$E(Y,11,12)) Q
;
N W:B=1 !,"Unit assigned/xmatched:",?49,"Exp date",?64,"Loc"
I '$D(^LRD(65,A,0)) K ^LRD(65,"AP",LRDFN,A) Q
S X=^LRD(65,A,0),L=$O(^(3,0)) S:'L L="Blood Bank" I L S L=$P(^(L,0),"^",4)
S M=^LAB(66,$P(X,"^",4),0) W !,$J(B,2),")",?6,$P(X,"^"),?17,$E($P(M,"^"),1,24),?42,$J($P(X,"^",7),2),?45,$P(X,"^",8),?49 S Y=$P(X,"^",6) D DT^LRU S:L<0 L="Blood bank" W Y,?64,L Q
;
DEL I $O(^LR(LRDFN,1.8,C,1,0)) S ^LR(LRDFN,1.8,C,0)=$P(^LR(LRDFN,1.8,C,0),"^") K ^LR(LRDFN,1.8,C,2) Q
K ^LR(LRDFN,1.8,C) S X=^LR(LRDFN,1.8,0),X(2)=$O(^(0)),X(1)=$P(X,"^",4),^(0)="^63.084PA^"_X(2)_"^"_$S(X(1)<2:"",1:X(1)-1) Q
END D V^LRU Q
EN K LRO S IOM=$S('$D(IOM):80,IOM:IOM,1:80)
W !,"FOR TRANSFUSION REQUESTS: Display instructions for components " S %=2 D YN^LRU Q:%<1 S:%=1 LRO=1 Q
LRBLPCS ; IHS/DIR/AAB - COMPONENT SELECTION FOR PATIENTS 8/4/95 06:32 ;
+1 ;;5.2;LR;**1002**;JUN 01, 1998
+2 ;;5.2;LAB SERVICE;**1,72**;Sep 27, 1994
+3 DO V^LRU
DO CK^LRBLPUS
IF Y=-1
GOTO END
IF LRSS'="BB"
WRITE $CHAR(7),!!,"MUST BE BLOOD BANK"
GOTO END
+4 WRITE !?20,LRAA(4),!!?15,"Selection of blood components for a patient"
SET LRJ=1
+5 WRITE !,"Display instructions for component selected "
SET %=2
DO YN^LRU
IF %<1
GOTO END
IF %=1
SET LRO=1
P WRITE !
KILL DIC
DO ^LRDPA
KILL DIC,DIE,DR
WRITE !
IF LRDFN=-1
GOTO END
DO EN1
GOTO P
+1 ;
EN1 ;Q:'$D(LRP) D ^LRBLPA Q:$D(Q("Q"))!(LRLLOC["DIED") W LRP," ",SSN(1),?42,$J(LRPABO,2),?45,LRPRH D EN^LRBLPUS
+1 ;IHS/ANMC/CLS 11/1/95
IF '$DATA(LRP)
QUIT
DO ^LRBLPA
IF $DATA(Q("Q"))!(LRLLOC["DIED")
QUIT
WRITE LRP," ",HRCN,?42,$JUSTIFY(LRPABO,2),?45,LRPRH
DO EN^LRBLPUS
+2 SET A=0
FOR B=1:1
SET A=$ORDER(^LRD(65,"AP",LRDFN,A))
IF 'A
QUIT
DO N
+3 IF $DATA(LRQ)
IF B=1
WRITE !,"No units currently assigned/xmatched"
+4 WRITE !
SET A=0
FOR B=0:1
SET A=$ORDER(^LR(LRDFN,1.8,A))
IF 'A
QUIT
SET X=^(A,0)
IF 'B
WRITE !,"Component(s) requested",?27,"Units",?33,"Request date",?47,"Date wanted",?59,"Requestor",?77,"By"
DO L
OP KILL LRR
SET LRCPT=0
WRITE !!,"Is patient Pre-op "
SET %=""
DO YN^LRU
IF %<1
WRITE $CHAR(7),!,"You must answer 'YES' or 'NO' to enter component request.",!,"Do you want to enter component request at this time "
SET %=1
DO YN^LRU
IF %=1
GOTO OP
QUIT
+1 SET LRV=$SELECT(%=2:0,1:1)
SET LRV(1)=$SELECT(LRV=1:8,1:6)
IF LRV
DO ^LRBLPCSS
+2 SET DIE=63
SET DA=LRDFN
SET DR="[LRBLPCS]"
+3 WRITE !
DO ^DIE
KILL DIE,DR
IF $DATA(LRK)
DO EN^LRBLPCS1
KILL LRK,S,C
QUIT
+4 ;
EN3 FOR A=0:0
SET A=$ORDER(^LAB(66,C,LRV(1),A))
IF 'A
QUIT
SET X=^(A,0)
SET E=$PIECE(X,"^",2)
SET F=+X
SET C(C,F,E)=$PIECE(X,"^",3)
IF '$DATA(S(F,E))
DO G
+1 KILL I(0)
FOR A=0:0
SET A=$ORDER(C(C,A))
IF 'A
QUIT
FOR B=0:0
SET B=$ORDER(C(C,A,B))
IF 'B
QUIT
DO A
+2 IF $DATA(I(0))
KILL Q
IF $DATA(Q)
KILL Q
WRITE !?5,$CHAR(7)," Request still OK "
SET %=2
DO YN^LRU
IF %=1
SET LRR=1
IF %'=1
SET Y=0
DO DEL
+3 IF $DATA(LRR)
SET LRK(C)=""
QUIT
G SET X=$SELECT($DATA(^LAB(60,F,0)):^(0),1:F)
IF $PIECE(X,"^",5)'["CH"
WRITE $CHAR(7),!,"No DATA NAME in file 60 for ",$PIECE(X,"^")
QUIT
+1 SET G=$PIECE(X,";",2)
SET H=+$PIECE(X,";",3)
SET Z=$SELECT($DATA(^LAB(60,F,1,E,0)):$PIECE(^(0),"^",7),1:"")
SET I(0)=$PIECE(X,"^")
+2 FOR B=0:0
SET B=$ORDER(^LR(LRDFN,"CH",B))
IF 'B
QUIT
SET W=^(B,0)
SET S=$PIECE(W,"^",5)
IF S=E
IF $DATA(^(G))
IF $LENGTH(^(G))
SET X=^(G)
DO H
QUIT
+3 IF '$DATA(S(F,E))
SET S(F,E)="^"_I(0)
QUIT
H SET S(F,E)=$PIECE(X,"^",H)_"^"_I(0)_"^"_$EXTRACT(W,4,5)_"/"_$EXTRACT(W,6,7)_"^"_Z_"^"_$PIECE(^LAB(61,E,0),"^")
QUIT
A IF '$DATA(S(A,B))
QUIT
IF $PIECE(S(A,B),"^")=""
WRITE !?10,"No ",$PIECE(S(A,B),"^",2)," results "
SET Q=1
QUIT
+1 IF +S(A,B)
IF @(+$PIECE(S(A,B),"^")_C(C,A,B))
WRITE !?10,$PIECE(S(A,B),"^",3)," Last ",$PIECE(S(A,B),"^",2),": ",$PIECE(S(A,B),"^")," ",$PIECE(S(A,B),"^",4)," ",$PIECE(S(A,B),"^",5)
SET Q=1
QUIT
+2 SET I(0)=1
QUIT
EN2 KILL ^UTILITY($JOB)
SET DIWR=IOM-5
SET DIWL=5
SET DIWF="W"
SET A=0
FOR K=0:1
SET A=$ORDER(^LAB(66,C,7,A))
IF 'A
QUIT
SET X=^(A,0)
DO ^DIWP
+1 IF K
DO ^DIWW
QUIT
+2 ;
L SET Y=+X
IF '$DATA(^LAB(66,Y,0))
KILL ^LR(LRDFN,1.8,Y)
SET Y=^LR(LRDFN,1.8,0)
SET ^(0)=$PIECE(Y,"^",1,2)_"^^"_($PIECE(Y,"^",4)-1)
QUIT
+1 WRITE !,$EXTRACT($PIECE(^LAB(66,+X,0),"^"),1,27),?27,$JUSTIFY($PIECE(X,"^",4),3),?33
SET Y=$PIECE(X,"^",3)
DO M
WRITE Y,?47
SET Y=$PIECE(X,"^",5)
DO M
WRITE Y,?59,$PIECE(X,"^",9)
SET Y=$PIECE(X,"^",8)
WRITE ?77,$SELECT(Y="":Y,$DATA(^VA(200,Y,0)):$PIECE(^(0),"^",2),1:Y)
QUIT
M IF 'Y
QUIT
SET Y=Y_"000"
SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_$SELECT(Y'[".":"",1:" "_$EXTRACT(Y,9,10)_":"_$EXTRACT(Y,11,12))
QUIT
+1 ;
N IF B=1
WRITE !,"Unit assigned/xmatched:",?49,"Exp date",?64,"Loc"
+1 IF '$DATA(^LRD(65,A,0))
KILL ^LRD(65,"AP",LRDFN,A)
QUIT
+2 SET X=^LRD(65,A,0)
SET L=$ORDER(^(3,0))
IF 'L
SET L="Blood Bank"
IF L
SET L=$PIECE(^(L,0),"^",4)
+3 SET M=^LAB(66,$PIECE(X,"^",4),0)
WRITE !,$JUSTIFY(B,2),")",?6,$PIECE(X,"^"),?17,$EXTRACT($PIECE(M,"^"),1,24),?42,$JUSTIFY($PIECE(X,"^",7),2),?45,$PIECE(X,"^",8),?49
SET Y=$PIECE(X,"^",6)
DO DT^LRU
IF L<0
SET L="Blood bank"
WRITE Y,?64,L
QUIT
+4 ;
DEL IF $ORDER(^LR(LRDFN,1.8,C,1,0))
SET ^LR(LRDFN,1.8,C,0)=$PIECE(^LR(LRDFN,1.8,C,0),"^")
KILL ^LR(LRDFN,1.8,C,2)
QUIT
+1 KILL ^LR(LRDFN,1.8,C)
SET X=^LR(LRDFN,1.8,0)
SET X(2)=$ORDER(^(0))
SET X(1)=$PIECE(X,"^",4)
SET ^(0)="^63.084PA^"_X(2)_"^"_$SELECT(X(1)<2:"",1:X(1)-1)
QUIT
END DO V^LRU
QUIT
EN KILL LRO
SET IOM=$SELECT('$DATA(IOM):80,IOM:IOM,1:80)
+1 WRITE !,"FOR TRANSFUSION REQUESTS: Display instructions for components "
SET %=2
DO YN^LRU
IF %<1
QUIT
IF %=1
SET LRO=1
QUIT
