source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBLWD.m@ 975

Last change on this file since 975 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.6 KB
Line 
1LRBLWD ;AVAMC/REG - STUFF WORKLOAD IN 65.5 ;2/7/91 18:45
2 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4N S Y="ND" G SET ;no donation
5HW S Y="HW" G SET ;homologous whole blood donation
6TW S Y="TW" G SET ;therapeutic phlebotomy
7DW S Y="DW" G SET ;directed whole blood
8HP S Y="HP" G SET ;homologous plasmapheresis
9AP ;autologous plasmapheresis
10 D CK S Y=$S('Z:"APF",1:"APN") G SET ;APF=1st APN=not 1st
11TP S Y="TP" G SET ;therapeutic plasmapheresis
12DP S Y="DP" G SET ;directed plasmapheresis
13HC S Y="HC" G SET ;homologous cytapheresis
14AC ;autologous cytapheresis
15 D CK S Y=$S('Z:"ACF",1:"ACN") G SET ;ACF=1st ACN=not 1st donation
16TC S Y="TC" G SET ;therapeutic cytapheresis
17DC S Y="DC" G SET ;directed cytapheresis
18AW ;autologous whole blood donation
19 D CK S Y=$S('Z:"AWF",1:"AWN") G SET ;AWF=1st AWN=not 1st donation
20 ;
21C S X=$D(^LRE(LRQ,5,LRI,99,LRT,0)) Q
22CK S X1=9999999-LRI,X2=-60 D C^%DTC S Z(1)=9999999-X
23 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
24 Q
25SET 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)=""
26 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
27 ;
28X K LRT S LRT=$O(^LAB(60,"B",X,0)) G:'LRT OUT Q:$D(X("NOCODES"))
29 F B=0:0 S B=$O(^LAB(60,LRT,9,B)) Q:'B S LRT(B)=""
30 Q:$D(LRT)=11
31OUT 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
32S 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)=""
33 Q
34Z ;from LRBLDLG
35 K LRX S X="DONOR DEFERRAL" D X I $D(X) S Y="ND" D S
36 S X="HOMOLOGOUS WB DONATION" D X I $D(X) S Y="HW" D S
37 S X="HOMOLOGOUS PLASMAPHERESIS" D X I $D(X) S Y="HP" D S
38 S X="HOMOLOGOUS CYTAPHERESIS" D X I $D(X) S Y="HC" D S
39 S X="AUTOLOGOUS WHOLE BLOOD 1ST" D X I $D(X) S Y="AWF" D S
40 S X="AUTOLOGOUS WHOLE BLOOD NOT 1ST" D X I $D(X) S Y="AWN" D S
41 S X="AUTOLOGOUS PLASMAPHERESIS 1ST" D X I $D(X) S Y="APF" D S
42 S X="AUTOLOGOUS PLASMAPH NOT 1ST" D X I $D(X) S Y="APN" D S
43 S X="AUTOLOGOUS CYTAPHERESIS 1ST" D X I $D(X) S Y="ACF" D S
44 S X="AUTOLOGOUS CYTAPH NOT 1ST" D X I $D(X) S Y="ACN" D S
45 S X="THERAPEUTIC PHLEBOTOMY" D X I $D(X) S Y="TW" D S
46 S X="THERAPEUTIC PLASMAPHERESIS" D X I $D(X) S Y="TP" D S
47 S X="THERAPEUTIC CYTAPHERESIS" D X I $D(X) S Y="TC" D S
48 S X="DIRECTED WB DONATION" D X I $D(X) S Y="DW" D S
49 S X="DIRECTED PLASMAPHERESIS" D X I $D(X) S Y="DP" D S
50 S X="DIRECTED CYTAPHERESIS" D X I $D(X) S Y="DC" D S
51 K LRT Q
Note: See TracBrowser for help on using the repository browser.