source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBLJD.m@ 1005

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1LRBLJD ;AVAMC/REG/CYM - BB UNIT DISPOSITION ;7/25/96 11:53 ; 12/18/00 2:06pm
2 ;;5.2;LAB SERVICE;**25,72,78,247,267**;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4 ;
5 ; References to ^DD(65, supported by DBIA3261
6 ;
7 D END S LR("M")=1,LRN="",X="BLOOD BANK" D ^LRUTL G:Y=-1 END S X=$P(^DD(65,4.1,0),U,3),LR(3)="" F Y=1:1 S Z=$P($P(X,";",Y),":",2) Q:Z="" I $A(Z)'=84 S LRB(Y)=Z
8 W !?15,"Division: ",LRAA(4)
9 I LRCAPA S X="UNIT MODIFICATION",X("NOCODES")=1 D X^LRUWK G:'$D(X) END K X S LRW("MO")=LRT S X="UNIT LOG-IN/SEND-OUT" D X^LRUWK G:'$D(X) END S LRW("S")=LRT F A=0:0 S A=$O(LRT(A)) Q:'A S LRW("S",A)=""
10 K LRT D BAR^LRBLB
11ASK S X="N",%DT="T" D ^%DT S LRF=Y K %DT W !! S X=$$READ^LRBLB("Select UNIT ID FOR DISPOSITION: ") G:X=""!(X[U) END
12 I LR,$E(X,1,$L(LR(2)))=LR(2) D
13 .D ^LRBLBU
14 E W $$STRIP^LRBLB(.X) ; Strip off data identifiers just in case
15 G:'$D(X) ASK
16 D REST,K^LRU K ^TMP($J),DA,LR("CK"),LR("C"),LR("%5"),LR("%4"),LR("%3"),LR("%2"),LR("%"),LRO,LRM,LRV,LRE,LRP,LRJ,LRT G ASK
17REST S (DIC,DIE)="^LRD(65,",DIC(0)="EFQMZ",DIC("S")="I $P(^(0),U,16)=DUZ(2),$S('$D(^(4)):1,$P(^(4),U,2):0,$P(^(4),U)="""":1,1:0)" D ^DIC K DIC Q:Y<1
18 S DA=+Y,LRV(10)=$P(Y(0),"^",10),LRV(4)=+$P(Y(0),"^",4),LRV(26)=$P(^LAB(66,LRV(4),0),U,26),LRV(15)=$P(Y(0),"^",15) D EN^LRBLJDA Q:$D(LR("%"))
19 D CK^LRU Q:$D(LR("CK")) S DR="[LRBLID]" D ^DIE D FRE^LRU S LRX=DA K DIC,DIE,DR,DA,D S DA=LRX I $D(Y) D K Q
20 F A=0:0 S A=$O(^LRD(65,DA,2,A)) Q:'A I $D(^LR(A,1.8,LRV(4),1,DA,0)) K ^(0) L +^LR(A,1.8,LRV(4),1,0) S X=^LR(A,1.8,LRV(4),1,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1) L -^LR(A,1.8,LRV(4),1,0)
21 D:$D(LR("%2")) EN1^LRBLJDA Q:'$D(LRE(1)) D:"RS"[LRE(1)&LRCAPA RS^LRBLW Q:LRE(1)'="MO" S LRJ=$P($G(^LRD(65,LRX,8)),"^",2) S:LRCAPA LRT=LRW("MO")
22 S LRV(3)=$P(^LAB(66,LRE(4),0),"^",10),DIE="^LRD(65,",DA=LRX,DR=".11//^S X=LRV(3);S LRM=X" D ^DIE I $D(Y) D K Q
23M S DIC="^LAB(66,LRE(4),3,",DIC(0)="AEQMZ" D ^DIC K DIC I Y<1 W !!,"Nothing selected " D K Q
24 S LRV=+Y,LRV(2)=$P(Y(0),"^",2),X=^LAB(66,LRV,0),LRN=$P(X,"^",28),LRV(1)=$P(X,"^"),LRV(6)=$P(X,"^",6),LRV(6)=$S("DP"[LRV(6):LRV(6),1:""),LRD=$P(X,"^",18),LRJ(1)=$P(X,"^",25)
25 I LRV(1)["PLASMA REMOVED" D PV^LRBLJDA I '$D(Z) D K Q
26 I LRJ,LRJ(1)'=1 W $C(7),!!,"Unit has positive screening tests and component selected is not autologous.",! G M
27 S (LRO(9),LRO(1))=$P(X,"^",11),LRV(11)="" D:LRO(1) F^LRBLJDM
28 S LRE=^LRD(65,LRX,0),(LRE(6),Y)=$P(LRE,"^",6) S:LRE(6)'["." LRE(6)=LRE(6)_".9999" D D^LRU S LRE(3)=Y,LRE(69)=LRE(6)
29 I LRE(6)<LRF W $C(7),!!,"UNIT EXPIRED " S Y=$P(LRE,U,6) D D^LRU W Y," STILL WANT TO MODIFY " S %=2 D YN^LRU I %'=1 D K Q
30 I LRO(1)="" S Y=$P(LRE,"^",6) D DA^LRU S LRO(1)=Y
31 D @$S(LRV(6)="D":"D^LRBLJDM",LRV(2):"^LRBLJDM",LRV(6)="P":"^LRBLJD1",1:"S^LRBLJDM") Q
32K ;from LRBLJD1, LRBLJDM, [LRBLID] edit template file #65
33 W $C(7),!,"Answer all prompts (no NULL responses) DISPOSITION DELETED",!!
34 X:$D(^DD(65,4.1,1,1,2)) ^(2) X:$D(^DD(65,4.1,1,2,2)) ^(2) X:$D(^DD(65,4.1,1,3,2)) ^(2) S X=$S($D(^LRD(65,DA,4)):$P(^(4),"^",2),1:"") K:X ^LRD(65,"AB",X,DA) K ^LRD(65,DA,4),^(5) Q
35 ;
36END D V^LRU Q
37 ;
38R R !,"DISPOSITION: ",LRE(1):DTIME S:LRE(1)="" LRE(1)=U Q:LRE(1)[U
39 F X=0:0 S X=$O(LRB(X)) Q:'X I $E(LRB(X),1,$L(LRE(1)))=LRE(1) W $E(LRB(X),$L(LRE(1))+1,$L(LRB(X))) S LRE(1)=LRB(X) G OUT
40 W !!,"Select from:"
41 F X=0:0 S X=$O(LRB(X)) Q:'X W !?3,LRB(X)
42 W ! G R
43OUT I $D(^LRD(65,DA,8)),$P(^(8),"^",2)'=0,LRE(1)="SEND ELSEWHERE"!(LRE(1)="SALVAGED") S X=$P(^(8),"^",2) D C
44 Q
45C W $C(7),!,$S(X:"POSITIVE",1:"INCOMPLETE")," SCREENING TESTS." I LRE(1)="SEND ELSEWHERE" W " WANT TO CONTINUE " S %=2 D YN^LRU S:%'=1 LRE(1)=U Q
46 W " SALVAGE NOT ALLOWED." S LRE(1)=U Q
Note: See TracBrowser for help on using the repository browser.