source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBLJL.m@ 794

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

initial load of WorldVistAEHR
File size: 5.2 KB
Line 
1LRBLJL ;AVAMC/REG/CYM - UNIT RELOCATION ;7/7/97 08:32 ;
2 ;;5.2;LAB SERVICE;**16,72,79,90,247**;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4 D END,S^LRBLW,CK^LRBLPUS G:Y=-1 END D A^LRBLJL1 G:Y=-1 END S LRB=$O(^LAB(61.3,"C",50710,0)) I 'LRB D EN1^LRBLU
5 W !!?30,"Relocation of units",!!?30,LRAA(4) I LRCAPA S X="UNIT RELOCATION" D X^LRUWK G:'$D(X) END
6P W ! K LRG,DIC,DIE,DR,DA,C,LRW,V,R,LRV,^TMP($J) D ^LRDPA G:LRDFN=-1 END S LRBL=$S(LRPFN=2:DFN,1:"") D R G P
7R D EN^LRBLPUS F X=1:1:4 S LRW(X)=""
8 D ^LRBLJL1 I F=0 W $C(7),!!,"No units available for release",!,"Use appropriate options to assign or modify" Q
9 I $D(LRG(1)) W $C(7),!!?3,"( # unsatisfactory unit)" K LRG(1)
10 I $D(V) W $C(7),!!?3,"( *Expired unit )" K V
11 I F=1 S LRV=1 D DIE Q
12M W !,"Select (1-",F,"): " R X:DTIME Q:X=""!(X[U) I X["?" W !,"Enter number(s) from 1 to ",F,!,"For 2 or more selections separate each with a ',' (ex. 1,3,4)",!,"Enter 'ALL' for all units" G M
13 I X="ALL" S LR("ALL")=1 D ALL Q
14 I X?.E1CA.E!($L(X)>200) W $C(7),!,"No CONTROL CHARACTERS, LETTERS or more than 200 characters allowed" G M
15 I '+X W $C(7),!,"START with a NUMBER !!",! G M
16 S LRQ=X F LRA=0:0 S LRZ=0,LRV=+LRQ,LRQ=$E(LRQ,$L(LRV)+2,$L(LRQ)) D:LRV A Q:'$L(LRQ)
17 Q
18A Q:'$D(^TMP($J,LRV)) S A=LRV,LRX=^(A) W !,A,")" D W^LRBLJL1,DIE
19 Q
20F S DA=9999999-LRW(1) S:'$D(^LRD(65,LRX,3,0)) ^(0)="^65.03DA^^" I '$D(^(DA,0)) S ^LRD(65,LRX,3,DA,0)=LRW(1),X=^LRD(65,LRX,3,0),^(0)="^65.03DA^"_DA_"^"_($P(X,"^",4)+1)
21 Q
22ALL ; This subroutine detects if a previous Inspection was
23 ; Unsatisfactory, then calls up another subroutine to give
24 ; a warning message. It also evaluates each individual unit
25 ; within a group selected to be sure that all required testing
26 ; is complete and compatible with the patient.
27 S (LRZ,LR("STOP"))=0
28 F LRC=0:0 S LRC=$O(^TMP($J,LRC)) Q:LRC'>0 Q:LR("STOP")=2 D
29 . S LRE=^TMP($J,LRC),LRX=+LRE,(LRZ(LRX),LRR(LRX))=0,L=$P(LRE,U,14) D:"Blood BankBLOOD BANK"[L C
30 . I $P(LRE,U,11)="U" W $C(7),!,"Unit unsatisfactory, cannot release." S LRZ(LRX)=1 Q
31 . Q:LRZ(LRX)
32 . I 'LR("STOP") D T Q
33 . I LR("STOP") D
34 .. I $D(LRG(LRX)) D PRE Q
35 .. S LRK=LRW(1) D F,G S ^LRD(65,LRX,3,DA,0)=LRW(1)_"^"_LRW(2)_"^"_DUZ_"^"_LRW(3)_"^"_LRW(4)_"^"_LRP_"^"_LRBL,^LRD(65,"AL",LRW(1),LRX)=""
36 Q
37DIE S LRE=^TMP($J,LRV),LRX=+LRE,(LRZ(LRX),LRR(LRX))=0 K ^TMP($J,LRV),Y,LR("CK") I "Blood BankBLOOD BANK"[L D C Q:LRZ(LRX)
38 I $P(LRE,"^",11)="U" W $C(7),!,"Unit unsatisfactory, cannot release." S LRR(LRX)=1 Q
39T R !!,"DATE/TIME UNIT RELOCATION: NOW//",X:DTIME I '$T!(X[U) S LRR(LRX)=1 Q
40 S:X="" X="N" S %DT="ETX",%DT(0)="-N" D ^%DT K %DT S LRW(1)=Y I Y<1!(Y'[".") W $C(7),!?5,"TIME and DATE must be entered, future time not allowed." G T
41 I Y<$P(LRE,U,12) W $C(7),!!,"Relocation time must be after DATE/TIME unit assigned " S Y=$P(LRE,U,12) D DT^LRU W "(",Y,")" S LRR(LRX)=1 Q
42 D F S DIE="^LRD(65,LRX,3," D CK^LRU Q:$D(LR("CK")) S DA(1)=LRX,X=$P(LRE,"^",6),LRW(5)=$S("Blood BankBLOOD BANK"[X:1,1:0) S:'LRW(5) LRW(3)=LR(44)
43 S DR=".03////^S X=DUZ;.02;S LRW(2)=X;D:X=""U"" I^LRBLJL;S:LRW(2)=""U""&(LRW(5)) Y=0;I 'LRW(5)&(LRW(2)=""U"") D S^LRBLJL;.04;S LRW(3)=X;.05;S LRW(4)=X;.06///^S X=LRP;.07////^S X=LRBL" D ^DIE D FRE^LRU
44 I $D(LR("ALL")) S LR("STOP")=1 ; Only enter relocation data once if "ALL"
45 I $D(Y)!(LRW(2)="U"&(LRW(5))) D W,CLNP K Y S LR("STOP")=2 Q ; If incomplete answers given during relocation, gives warning message and deletes current relocation.
46 I $D(LRG(LRX)) D PRE,CLNP Q ; If a previous Unsatisfactory Inspection, gives warning message and deletes current relocation.
47 S ^LRD(65,"AL",LRW(1),LRX)="",LRK=LRW(1) D G
48 Q
49PRE ; Warning message if a unit has had a previous Unsatisfactory Inspection
50 N UNIT S UNIT=$P(^LRD(65,LRX,0),U)
51 W $C(7),!!,UNIT," has had a previous Unsatisfactory inspection and cannot be relocated.",!!,"Relocation entry <DELETED>",! Q
52CLNP ; When indicated, current relocation episode is deleted.
53 S DA(1)=LRX,DIK="^LRD(65,"_DA(1)_",3," D ^DIK S LRZ(LRX)=1 Q
54C I $D(R),$P(LRE,"^",8)=1,$P(LRE,"^",10)'=1 W ! F Z=0:0 S Z=$O(R(Z)) Q:'Z I Z'=LRB,'$D(^LRD(65,LRX,70,Z,0)) W !,$P(^LAB(61.3,Z,0),"^"),$E("..............",$X,14),?15,"RBC ANTIGEN" S LRZ(LRX)=1
55 I LRZ(LRX) W $C(7),!,"Above antigen(s) not entered in RBC ANTIGEN ABSENT field"
56 D:$P(LRE,"^",9)=1 D W:LRZ(LRX) !?3,"for ",$P(LRE,"^",2),?28,"*** UNIT NOT RELOCATED ***",! Q
57D S X=$S($D(^LRD(65,+LRE,10)):$P(^(10),"^"),1:"") S:X="ND" X="" I X="" S LRZ(LRX)=1 W $C(7),!,"ABO not rechecked"
58 I X]"",X'=$P($P(LRE,"^",4)," ") S LRZ(LRX)=1 W $C(7),!,"ABO recheck different from ABO GROUP"
59 S X=$S($D(^LRD(65,+LRE,11)):$P(^(11),"^"),1:"") S:X="ND" X="" I $P($P(LRE,U,4)," ",2)="NEG",X="" S LRZ(LRX)=1 W $C(7),!,"Rh NEG unit not rechecked"
60 I X]"",X'=$P($P(LRE,U,4)," ",2) W $C(7),!!?6,"Rh recheck (",X,") different from Rh TYPE (",$P($P(LRE,U,4)," ",2),")" W !?6,"Are you sure you want to relocate unit " S %=2 D YN^LRU S:%'=1 LRZ(LRX)=1
61 Q
62G W !,$P(LRE,"^",2)," relocated" D:LRCAPA ^LRBLW K Y Q
63I W $C(7)," Are you sure " S %=2 D YN^LRU S:%'=1 Y=.02 Q
64S W !?15,$C(7),"***Unsatisfactory unit(s) returned to BLOOD BANK***",! S $P(^LRD(65,LRX,3,DA,0),"^",4)="BLOOD BANK",Y=.05 Q
65W W $C(7),!!,"No units with incomplete answers or units to be sent from the blood bank",!,"with unsatisfactory inspections can be relocated. Relocation entry <DELETED>",! Q
66END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.