LRBLWD ;AVAMC/REG - STUFF WORKLOAD IN 65.5 ;2/7/91 18:45
;;5.2;LAB SERVICE;**247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
N S Y="ND" G SET ;no donation
HW S Y="HW" G SET ;homologous whole blood donation
TW S Y="TW" G SET ;therapeutic phlebotomy
DW S Y="DW" G SET ;directed whole blood
HP S Y="HP" G SET ;homologous plasmapheresis
AP ;autologous plasmapheresis
D CK S Y=$S('Z:"APF",1:"APN") G SET ;APF=1st APN=not 1st
TP S Y="TP" G SET ;therapeutic plasmapheresis
DP S Y="DP" G SET ;directed plasmapheresis
HC S Y="HC" G SET ;homologous cytapheresis
AC ;autologous cytapheresis
D CK S Y=$S('Z:"ACF",1:"ACN") G SET ;ACF=1st ACN=not 1st donation
TC S Y="TC" G SET ;therapeutic cytapheresis
DC S Y="DC" G SET ;directed cytapheresis
AW ;autologous whole blood donation
D CK S Y=$S('Z:"AWF",1:"AWN") G SET ;AWF=1st AWN=not 1st donation
;
C S X=$D(^LRE(LRQ,5,LRI,99,LRT,0)) Q
CK S X1=9999999-LRI,X2=-60 D C^%DTC S Z(1)=9999999-X
S Z=0 F X=LRI:0 S X=$O(^LRE(LRQ,5,X)) Q:'X!(X>Z(1)) S Y=$P(^(X,0),"^",11) I Y="A" S Z=1 Q
Q
SET K LRT S LRT=+LRW(Y),LR(60,320)=$P(LRW(Y),"^",2) D C Q:X F A=0:0 S A=$O(LRW(Y,A)) Q:'A S LRT(A)=""
S LRK=$S($D(LRK("LRK")):LRK("LRK"),$D(LR("LRBLDLG")):$P(^LRE(LRQ,5,LRI,0),"^",13),1:"") D:'LRK DT^LRBLU D ^LRBLWDS K LRT Q
;
X K LRT S LRT=$O(^LAB(60,"B",X,0)) G:'LRT OUT Q:$D(X("NOCODES"))
F B=0:0 S B=$O(^LAB(60,LRT,9,B)) Q:'B S LRT(B)=""
Q:$D(LRT)=11
OUT W $C(7),!!,"Must have test in LAB TEST file (#60) called",!,"'",X,"'" W:'$D(X("NOCODES")) " with WKLD CODES." K X S LRX=1 Q
S S LRW(Y)=LRT_"^"_$P(^LAB(60,LRT,0),"^",19) F A=0:0 S A=$O(LRT(A)) Q:'A S LRW(Y,A)=""
Q
Z ;from LRBLDLG
K LRX S X="DONOR DEFERRAL" D X I $D(X) S Y="ND" D S
S X="HOMOLOGOUS WB DONATION" D X I $D(X) S Y="HW" D S
S X="HOMOLOGOUS PLASMAPHERESIS" D X I $D(X) S Y="HP" D S
S X="HOMOLOGOUS CYTAPHERESIS" D X I $D(X) S Y="HC" D S
S X="AUTOLOGOUS WHOLE BLOOD 1ST" D X I $D(X) S Y="AWF" D S
S X="AUTOLOGOUS WHOLE BLOOD NOT 1ST" D X I $D(X) S Y="AWN" D S
S X="AUTOLOGOUS PLASMAPHERESIS 1ST" D X I $D(X) S Y="APF" D S
S X="AUTOLOGOUS PLASMAPH NOT 1ST" D X I $D(X) S Y="APN" D S
S X="AUTOLOGOUS CYTAPHERESIS 1ST" D X I $D(X) S Y="ACF" D S
S X="AUTOLOGOUS CYTAPH NOT 1ST" D X I $D(X) S Y="ACN" D S
S X="THERAPEUTIC PHLEBOTOMY" D X I $D(X) S Y="TW" D S
S X="THERAPEUTIC PLASMAPHERESIS" D X I $D(X) S Y="TP" D S
S X="THERAPEUTIC CYTAPHERESIS" D X I $D(X) S Y="TC" D S
S X="DIRECTED WB DONATION" D X I $D(X) S Y="DW" D S
S X="DIRECTED PLASMAPHERESIS" D X I $D(X) S Y="DP" D S
S X="DIRECTED CYTAPHERESIS" D X I $D(X) S Y="DC" D S
K LRT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLWD 2669 printed Dec 13, 2024@02:12:27 Page 2
LRBLWD ;AVAMC/REG - STUFF WORKLOAD IN 65.5 ;2/7/91 18:45
+1 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
N ;no donation
SET Y="ND"
GOTO SET
HW ;homologous whole blood donation
SET Y="HW"
GOTO SET
TW ;therapeutic phlebotomy
SET Y="TW"
GOTO SET
DW ;directed whole blood
SET Y="DW"
GOTO SET
HP ;homologous plasmapheresis
SET Y="HP"
GOTO SET
AP ;autologous plasmapheresis
+1 ;APF=1st APN=not 1st
DO CK
SET Y=$SELECT('Z:"APF",1:"APN")
GOTO SET
TP ;therapeutic plasmapheresis
SET Y="TP"
GOTO SET
DP ;directed plasmapheresis
SET Y="DP"
GOTO SET
HC ;homologous cytapheresis
SET Y="HC"
GOTO SET
AC ;autologous cytapheresis
+1 ;ACF=1st ACN=not 1st donation
DO CK
SET Y=$SELECT('Z:"ACF",1:"ACN")
GOTO SET
TC ;therapeutic cytapheresis
SET Y="TC"
GOTO SET
DC ;directed cytapheresis
SET Y="DC"
GOTO SET
AW ;autologous whole blood donation
+1 ;AWF=1st AWN=not 1st donation
DO CK
SET Y=$SELECT('Z:"AWF",1:"AWN")
GOTO SET
+2 ;
C SET X=$DATA(^LRE(LRQ,5,LRI,99,LRT,0))
QUIT
CK SET X1=9999999-LRI
SET X2=-60
DO C^%DTC
SET Z(1)=9999999-X
+1 SET Z=0
FOR X=LRI:0
SET X=$ORDER(^LRE(LRQ,5,X))
if 'X!(X>Z(1))
QUIT
SET Y=$PIECE(^(X,0),"^",11)
IF Y="A"
SET Z=1
QUIT
+2 QUIT
SET KILL LRT
SET LRT=+LRW(Y)
SET LR(60,320)=$PIECE(LRW(Y),"^",2)
DO C
if X
QUIT
FOR A=0:0
SET A=$ORDER(LRW(Y,A))
if 'A
QUIT
SET LRT(A)=""
+1 SET LRK=$SELECT($DATA(LRK("LRK")):LRK("LRK"),$DATA(LR("LRBLDLG")):$PIECE(^LRE(LRQ,5,LRI,0),"^",13),1:"")
if 'LRK
DO DT^LRBLU
DO ^LRBLWDS
KILL LRT
QUIT
+2 ;
X KILL LRT
SET LRT=$ORDER(^LAB(60,"B",X,0))
if 'LRT
GOTO OUT
if $DATA(X("NOCODES"))
QUIT
+1 FOR B=0:0
SET B=$ORDER(^LAB(60,LRT,9,B))
if 'B
QUIT
SET LRT(B)=""
+2 if $DATA(LRT)=11
QUIT
OUT WRITE $CHAR(7),!!,"Must have test in LAB TEST file (#60) called",!,"'",X,"'"
if '$DATA(X("NOCODES"))
WRITE " with WKLD CODES."
KILL X
SET LRX=1
QUIT
S SET LRW(Y)=LRT_"^"_$PIECE(^LAB(60,LRT,0),"^",19)
FOR A=0:0
SET A=$ORDER(LRT(A))
if 'A
QUIT
SET LRW(Y,A)=""
+1 QUIT
Z ;from LRBLDLG
+1 KILL LRX
SET X="DONOR DEFERRAL"
DO X
IF $DATA(X)
SET Y="ND"
DO S
+2 SET X="HOMOLOGOUS WB DONATION"
DO X
IF $DATA(X)
SET Y="HW"
DO S
+3 SET X="HOMOLOGOUS PLASMAPHERESIS"
DO X
IF $DATA(X)
SET Y="HP"
DO S
+4 SET X="HOMOLOGOUS CYTAPHERESIS"
DO X
IF $DATA(X)
SET Y="HC"
DO S
+5 SET X="AUTOLOGOUS WHOLE BLOOD 1ST"
DO X
IF $DATA(X)
SET Y="AWF"
DO S
+6 SET X="AUTOLOGOUS WHOLE BLOOD NOT 1ST"
DO X
IF $DATA(X)
SET Y="AWN"
DO S
+7 SET X="AUTOLOGOUS PLASMAPHERESIS 1ST"
DO X
IF $DATA(X)
SET Y="APF"
DO S
+8 SET X="AUTOLOGOUS PLASMAPH NOT 1ST"
DO X
IF $DATA(X)
SET Y="APN"
DO S
+9 SET X="AUTOLOGOUS CYTAPHERESIS 1ST"
DO X
IF $DATA(X)
SET Y="ACF"
DO S
+10 SET X="AUTOLOGOUS CYTAPH NOT 1ST"
DO X
IF $DATA(X)
SET Y="ACN"
DO S
+11 SET X="THERAPEUTIC PHLEBOTOMY"
DO X
IF $DATA(X)
SET Y="TW"
DO S
+12 SET X="THERAPEUTIC PLASMAPHERESIS"
DO X
IF $DATA(X)
SET Y="TP"
DO S
+13 SET X="THERAPEUTIC CYTAPHERESIS"
DO X
IF $DATA(X)
SET Y="TC"
DO S
+14 SET X="DIRECTED WB DONATION"
DO X
IF $DATA(X)
SET Y="DW"
DO S
+15 SET X="DIRECTED PLASMAPHERESIS"
DO X
IF $DATA(X)
SET Y="DP"
DO S
+16 SET X="DIRECTED CYTAPHERESIS"
DO X
IF $DATA(X)
SET Y="DC"
DO S
+17 KILL LRT
QUIT
