- 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 Feb 18, 2025@23:38:20 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