| 1 | LRBLJL1 ;AVAMC/REG/CYM - UNIT RELOCATION ; 12/18/00 1:49pm
|
|---|
| 2 | ;;5.2;LAB SERVICE;**72,79,90,247,267**;Sep 27, 1994
|
|---|
| 3 | ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
|
|---|
| 4 | ;
|
|---|
| 5 | ; Reference to ^SC( supported by DBIA908
|
|---|
| 6 | ;
|
|---|
| 7 | S X="N",%DT="T" D ^%DT S H=Y,(A,LR("Q"),C)=0
|
|---|
| 8 | F C(1)=0:0 S C=$O(^LRD(65,"AP",LRDFN,C)) Q:'C D L
|
|---|
| 9 | S (A,F)=0 F B=0:0 S A=$O(^TMP($J,"B",A)) Q:A="" D
|
|---|
| 10 | . F C=0:0 S C=$O(^TMP($J,"B",A,C)) Q:'C D
|
|---|
| 11 | .. F E=0:0 S E=$O(^TMP($J,"B",A,C,E)) Q:'E D
|
|---|
| 12 | ... S F=F+1,^TMP($J,"C",A,F)=^TMP($J,"B",A,C,E)
|
|---|
| 13 | K ^TMP($J,"B")
|
|---|
| 14 | S (B,F)=0 F A=1:1 S B=$O(^TMP($J,"C",B)) Q:B=""!(LR("Q")) D
|
|---|
| 15 | . W:A>1 ! F C=0:0 S C=$O(^TMP($J,"C",B,C)) Q:'C!(LR("Q")) S LRX=^(C) D S
|
|---|
| 16 | K ^TMP($J,"C") Q
|
|---|
| 17 | ;
|
|---|
| 18 | L I $D(^LRD(65,C,4)),$P(^(4),"^")]"" K ^LRD(65,"AP",LRDFN,C) Q
|
|---|
| 19 | S X=^LRD(65,C,0) Q:DUZ(2)'=$P(X,U,16)
|
|---|
| 20 | S (T,Y)=$P(X,U,6),L=+$O(^(3,0)),LRG=$G(^(L,0)),L=$S($P(LRG,U,4)]"":$P(LRG,U,4),1:"Blood Bank"),LRG=$P(LRG,U,2)
|
|---|
| 21 | ; The following 2 lines searches ALL previous relocation
|
|---|
| 22 | ; episodes to see if there have been any previous inspections
|
|---|
| 23 | ; of Unsatisfactory.
|
|---|
| 24 | N LRDT F LRDT=0:0 S LRDT=$O(^LRD(65,C,3,LRDT)) Q:LRDT'>0 D
|
|---|
| 25 | . I $D(^LRD(65,C,3,LRDT,0)) S:$P(^(0),U,2)="U" LRG(C)="U"
|
|---|
| 26 | S:T'["." T=T+.99
|
|---|
| 27 | S M=^LAB(66,$P(X,U,4),0),Z=$P(M,U,26),Z=$S($P(M,U,19):1,'Z:"?",1:Z)
|
|---|
| 28 | S LR(65.01)=$P($G(^LRD(65,C,2,LRDFN,0)),"^",2)
|
|---|
| 29 | S A=A+1,^TMP($J,"B",Z,Y,A)=C_"^"_$P(X,"^")_"^"_$E($P(M,"^"),1,19)_"^"_$P(X,"^",7)_" "_$P(X,"^",8)_"^"_Y_"^"_L_"^"_$S(T<H:"*",1:"")_"^"_$P(M,"^",9)_"^"_$P(M,"^",19)_"^"_$P(M,"^",25)_"^"_LRG_"^"_LR(65.01)
|
|---|
| 30 | D:$P(M,U,14) N Q
|
|---|
| 31 | ;
|
|---|
| 32 | S S F=F+1,^TMP($J,F)=^TMP($J,"C",B,C)
|
|---|
| 33 | W:F=1 !,"Unit assigned/xmatched:",?48,"Exp date",?67,"Location" D:F#21=0 M^LRU W !,$J(F,2),")"
|
|---|
| 34 | W W:$P(LRX,U,11)="U" ?5,"#" W ?6,$P(LRX,U,2),?20,$P(LRX,U,3),?41,$P(LRX,U,4) S Y=$P(LRX,U,5),L=$P(LRX,U,6) S:L="" L="Blood Bank" D A^LRU W ?48,Y,$P(LRX,U,7),?67,$E(L,1,13) S:$P(LRX,U,7)]"" V=1 S:$P(LRX,U,11)="U" LRG(1)=1
|
|---|
| 35 | S I=+LRX
|
|---|
| 36 | F E=0:0 S E=$O(^LRD(65,I,2,E)) Q:'E D
|
|---|
| 37 | . I LRDFN'=E,$D(^LRD(65,"AP",E,I)) S X=^LR(E,0),Y=$P(X,"^",3),X=$P(X,"^",2),X=^DIC(X,0,"GL"),N=@(X_Y_",0)") W !?6,$C(7),"*** Also assigned/xmatched to ",$P(N,"^")," ",$P(N,"^",9)
|
|---|
| 38 | Q
|
|---|
| 39 | ;
|
|---|
| 40 | N S Z(1)=Y,LRX=^TMP($J,"B",Z,Y,A)
|
|---|
| 41 | W ! D W
|
|---|
| 42 | K ^TMP($J,"B",Z,Z(1),A)
|
|---|
| 43 | W $C(7),!?6,"This unit needs to be modified before release !" Q
|
|---|
| 44 | ;
|
|---|
| 45 | A S (A,B,C)=0
|
|---|
| 46 | F S A=$O(^SC("B",A)) Q:A="" I A["BLOOD BANK" F S B=$O(^(A,B)) Q:'B I DUZ(2)=+$$SITE^VASITE(DT,($P($G(^SC(B,0)),U,15))) S C=C+1,C(C)=A
|
|---|
| 47 | I 'C W $C(7),!!,"There must be an entry in the HOSPITAL LOCATION file",!,"containing 'BLOOD BANK' in the name for ",LRAA(4) S Y=-1 Q
|
|---|
| 48 | S LR(44)=C(1)
|
|---|
| 49 | I C>1 S Y=-1 W $C(7),!!,"There can only be one entry in the HOSPITAL LOCATION file",!,"containing 'BLOOD BANK' in the name for ",LRAA(4) F A=0:0 S A=$O(C(A)) Q:'A W !?3,C(A)
|
|---|
| 50 | K A,B,C Q
|
|---|
