LRBLDC1 ;AVAMC/REG - COMPONENT PREP WORKLOAD ;4/20/93 11:49
;;5.2;LAB SERVICE;**247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
Q:'LRI!('LRCAPA) F A=0:0 S A=$O(^LRE(LRQ,5,LRI,66,A)) Q:'A S LRK=$P(^(A,0),"^",3) D:LRK S
Q
S K B F B=0:0 S B=$O(^LAB(66,A,9,B)) Q:'B S B(B)=""
I $D(B)'=11 W $C(7),!!,$P(^LAB(66,A,0),"^")," -No WKLD codes entered in BLOOD PRODUCT file",!,"Component preparation workload will not be recorded" Q
S:'$D(^LRE(LRQ,5,LRI,99,0)) ^(0)="^65.599PA^^" I '$D(^(LRT,0)) S ^(0)=LRT,X=^LRE(LRQ,5,LRI,99,0),^(0)=$P(X,"^",1,2)_"^"_LRT_"^"_($P(X,"^",4)+1)
S:'$D(^LRE(LRQ,5,LRI,99,LRT,1,0)) ^(0)="^65.5991DA^^" I '$D(^LRE(LRQ,5,LRI,99,LRT,1,LRK,0)) S ^(0)=LRK_"^"_DUZ,X=^LRE(LRQ,5,LRI,99,LRT,1,0),^(0)=$P(X,"^",1,2)_"^"_LRK_"^"_($P(X,"^",4)+1)
F C=0:0 S C=$O(B(C)) Q:'C D STF
S ^LRE("AA",LRQ,LRI,LRT,LRK)=$P(^LRE(LRQ,5,LRI,0),"^",4) I '$D(^LRE(LRQ,5,LRI,99,LRT,1,LRK,1,0)) K ^LRE(LRQ,5,LRI,99,LRT,1,LRK) S X=^LRE(LRQ,5,LRI,99,LRT,1,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1)
Q
STF Q:$D(^LRE(LRQ,5,LRI,99,LRT,1,LRK,1,C,0))
S:'$D(^LRE(LRQ,5,LRI,99,LRT,1,LRK,1,0)) ^(0)="^65.59911PA^^" L +^LRE(LRQ,5,LRI,99,LRT,1,LRK,1)
S X=^LRE(LRQ,5,LRI,99,LRT,1,LRK,1,0),^(0)=$P(X,"^",1,2)_"^"_C_"^"_($P(X,"^",4)+1),^(C,0)=C_"^"_1 L -^LRE(LRQ,5,LRI,99,LRT,1,LRK,1) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDC1 1374 printed Oct 16, 2024@18:11:11 Page 2
LRBLDC1 ;AVAMC/REG - COMPONENT PREP WORKLOAD ;4/20/93 11:49
+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 if 'LRI!('LRCAPA)
QUIT
FOR A=0:0
SET A=$ORDER(^LRE(LRQ,5,LRI,66,A))
if 'A
QUIT
SET LRK=$PIECE(^(A,0),"^",3)
if LRK
DO S
+4 QUIT
S KILL B
FOR B=0:0
SET B=$ORDER(^LAB(66,A,9,B))
if 'B
QUIT
SET B(B)=""
+1 IF $DATA(B)'=11
WRITE $CHAR(7),!!,$PIECE(^LAB(66,A,0),"^")," -No WKLD codes entered in BLOOD PRODUCT file",!,"Component preparation workload will not be recorded"
QUIT
+2 if '$DATA(^LRE(LRQ,5,LRI,99,0))
SET ^(0)="^65.599PA^^"
IF '$DATA(^(LRT,0))
SET ^(0)=LRT
SET X=^LRE(LRQ,5,LRI,99,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRT_"^"_($PIECE(X,"^",4)+1)
+3 if '$DATA(^LRE(LRQ,5,LRI,99,LRT,1,0))
SET ^(0)="^65.5991DA^^"
IF '$DATA(^LRE(LRQ,5,LRI,99,LRT,1,LRK,0))
SET ^(0)=LRK_"^"_DUZ
SET X=^LRE(LRQ,5,LRI,99,LRT,1,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRK_"^"_($PIECE(X,"^",4)+1)
+4 FOR C=0:0
SET C=$ORDER(B(C))
if 'C
QUIT
DO STF
+5 SET ^LRE("AA",LRQ,LRI,LRT,LRK)=$PIECE(^LRE(LRQ,5,LRI,0),"^",4)
IF '$DATA(^LRE(LRQ,5,LRI,99,LRT,1,LRK,1,0))
KILL ^LRE(LRQ,5,LRI,99,LRT,1,LRK)
SET X=^LRE(LRQ,5,LRI,99,LRT,1,0)
SET X(1)=$ORDER(^(0))
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)
+6 QUIT
STF if $DATA(^LRE(LRQ,5,LRI,99,LRT,1,LRK,1,C,0))
QUIT
+1 if '$DATA(^LRE(LRQ,5,LRI,99,LRT,1,LRK,1,0))
SET ^(0)="^65.59911PA^^"
LOCK +^LRE(LRQ,5,LRI,99,LRT,1,LRK,1)
+2 SET X=^LRE(LRQ,5,LRI,99,LRT,1,LRK,1,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_C_"^"_($PIECE(X,"^",4)+1)
SET ^(C,0)=C_"^"_1
LOCK -^LRE(LRQ,5,LRI,99,LRT,1,LRK,1)
QUIT
