LRBLDC1.m

LRBLDC1 ; IHS/DIR/FJE - COMPONENT PREP WORKLOAD 11:49 ; [ 4/20/93 ]

 ;;5.2;LR;;NOV 01, 1997

 ;

 ;;5.2;LAB SERVICE;;Sep 27, 1994

 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

LRBLDC1   ; IHS/DIR/FJE - COMPONENT PREP WORKLOAD 11:49 ; [ 4/20/93 ]

 +1       ;;5.2;LR;;NOV 01, 1997

 +2       ;

 +3       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +4        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

 +5        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