- LRBLJL1 ;AVAMC/REG/CYM - UNIT RELOCATION ; 12/18/00 1:49pm
- ;;5.2;LAB SERVICE;**72,79,90,247,267**;Sep 27, 1994
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- ;
- ; Reference to ^SC( supported by DBIA908
- ;
- S X="N",%DT="T" D ^%DT S H=Y,(A,LR("Q"),C)=0
- F C(1)=0:0 S C=$O(^LRD(65,"AP",LRDFN,C)) Q:'C D L
- S (A,F)=0 F B=0:0 S A=$O(^TMP($J,"B",A)) Q:A="" D
- . F C=0:0 S C=$O(^TMP($J,"B",A,C)) Q:'C D
- .. F E=0:0 S E=$O(^TMP($J,"B",A,C,E)) Q:'E D
- ... S F=F+1,^TMP($J,"C",A,F)=^TMP($J,"B",A,C,E)
- K ^TMP($J,"B")
- S (B,F)=0 F A=1:1 S B=$O(^TMP($J,"C",B)) Q:B=""!(LR("Q")) D
- . W:A>1 ! F C=0:0 S C=$O(^TMP($J,"C",B,C)) Q:'C!(LR("Q")) S LRX=^(C) D S
- K ^TMP($J,"C") Q
- ;
- L I $D(^LRD(65,C,4)),$P(^(4),"^")]"" K ^LRD(65,"AP",LRDFN,C) Q
- S X=^LRD(65,C,0) Q:DUZ(2)'=$P(X,U,16)
- 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)
- ; The following 2 lines searches ALL previous relocation
- ; episodes to see if there have been any previous inspections
- ; of Unsatisfactory.
- N LRDT F LRDT=0:0 S LRDT=$O(^LRD(65,C,3,LRDT)) Q:LRDT'>0 D
- . I $D(^LRD(65,C,3,LRDT,0)) S:$P(^(0),U,2)="U" LRG(C)="U"
- S:T'["." T=T+.99
- S M=^LAB(66,$P(X,U,4),0),Z=$P(M,U,26),Z=$S($P(M,U,19):1,'Z:"?",1:Z)
- S LR(65.01)=$P($G(^LRD(65,C,2,LRDFN,0)),"^",2)
- 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)
- D:$P(M,U,14) N Q
- ;
- S S F=F+1,^TMP($J,F)=^TMP($J,"C",B,C)
- W:F=1 !,"Unit assigned/xmatched:",?48,"Exp date",?67,"Location" D:F#21=0 M^LRU W !,$J(F,2),")"
- 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
- S I=+LRX
- F E=0:0 S E=$O(^LRD(65,I,2,E)) Q:'E D
- . 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)
- Q
- ;
- N S Z(1)=Y,LRX=^TMP($J,"B",Z,Y,A)
- W ! D W
- K ^TMP($J,"B",Z,Z(1),A)
- W $C(7),!?6,"This unit needs to be modified before release !" Q
- ;
- A S (A,B,C)=0
- 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
- 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
- S LR(44)=C(1)
- 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)
- K A,B,C Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJL1 2818 printed Feb 18, 2025@23:37:06 Page 2
- LRBLJL1 ;AVAMC/REG/CYM - UNIT RELOCATION ; 12/18/00 1:49pm
- +1 ;;5.2;LAB SERVICE;**72,79,90,247,267**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 ;
- +4 ; Reference to ^SC( supported by DBIA908
- +5 ;
- +6 SET X="N"
- SET %DT="T"
- DO ^%DT
- SET H=Y
- SET (A,LR("Q"),C)=0
- +7 FOR C(1)=0:0
- SET C=$ORDER(^LRD(65,"AP",LRDFN,C))
- if 'C
- QUIT
- DO L
- +8 SET (A,F)=0
- FOR B=0:0
- SET A=$ORDER(^TMP($JOB,"B",A))
- if A=""
- QUIT
- Begin DoDot:1
- +9 FOR C=0:0
- SET C=$ORDER(^TMP($JOB,"B",A,C))
- if 'C
- QUIT
- Begin DoDot:2
- +10 FOR E=0:0
- SET E=$ORDER(^TMP($JOB,"B",A,C,E))
- if 'E
- QUIT
- Begin DoDot:3
- +11 SET F=F+1
- SET ^TMP($JOB,"C",A,F)=^TMP($JOB,"B",A,C,E)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +12 KILL ^TMP($JOB,"B")
- +13 SET (B,F)=0
- FOR A=1:1
- SET B=$ORDER(^TMP($JOB,"C",B))
- if B=""!(LR("Q"))
- QUIT
- Begin DoDot:1
- +14 if A>1
- WRITE !
- FOR C=0:0
- SET C=$ORDER(^TMP($JOB,"C",B,C))
- if 'C!(LR("Q"))
- QUIT
- SET LRX=^(C)
- DO S
- End DoDot:1
- +15 KILL ^TMP($JOB,"C")
- QUIT
- +16 ;
- L IF $DATA(^LRD(65,C,4))
- IF $PIECE(^(4),"^")]""
- KILL ^LRD(65,"AP",LRDFN,C)
- QUIT
- +1 SET X=^LRD(65,C,0)
- if DUZ(2)'=$PIECE(X,U,16)
- QUIT
- +2 SET (T,Y)=$PIECE(X,U,6)
- SET L=+$ORDER(^(3,0))
- SET LRG=$GET(^(L,0))
- SET L=$SELECT($PIECE(LRG,U,4)]"":$PIECE(LRG,U,4),1:"Blood Bank")
- SET LRG=$PIECE(LRG,U,2)
- +3 ; The following 2 lines searches ALL previous relocation
- +4 ; episodes to see if there have been any previous inspections
- +5 ; of Unsatisfactory.
- +6 NEW LRDT
- FOR LRDT=0:0
- SET LRDT=$ORDER(^LRD(65,C,3,LRDT))
- if LRDT'>0
- QUIT
- Begin DoDot:1
- +7 IF $DATA(^LRD(65,C,3,LRDT,0))
- if $PIECE(^(0),U,2)="U"
- SET LRG(C)="U"
- End DoDot:1
- +8 if T'["."
- SET T=T+.99
- +9 SET M=^LAB(66,$PIECE(X,U,4),0)
- SET Z=$PIECE(M,U,26)
- SET Z=$SELECT($PIECE(M,U,19):1,'Z:"?",1:Z)
- +10 SET LR(65.01)=$PIECE($GET(^LRD(65,C,2,LRDFN,0)),"^",2)
- +11 SET A=A+1
- SET ^TMP($JOB,"B",Z,Y,A)=C_"^"_$PIECE(X,"^")_"^"_$EXTRACT($PIECE(M,"^"),1,19)_"^"_$PIECE(X,"^",7)_" "_$PIECE(X,"^",8)_"^"_Y_"^"_L_"^"_$SELECT(T<H:"*",1:"")_"^"_$PIECE(M,"^",9)_"^"_$PIECE(M,"^",19)_"^"_$PIECE(M,"^",25)_"^"_LRG_"^"_LR(65.01)
- +12 if $PIECE(M,U,14)
- DO N
- QUIT
- +13 ;
- S SET F=F+1
- SET ^TMP($JOB,F)=^TMP($JOB,"C",B,C)
- +1 if F=1
- WRITE !,"Unit assigned/xmatched:",?48,"Exp date",?67,"Location"
- if F#21=0
- DO M^LRU
- WRITE !,$JUSTIFY(F,2),")"
- W if $PIECE(LRX,U,11)="U"
- WRITE ?5,"#"
- WRITE ?6,$PIECE(LRX,U,2),?20,$PIECE(LRX,U,3),?41,$PIECE(LRX,U,4)
- SET Y=$PIECE(LRX,U,5)
- SET L=$PIECE(LRX,U,6)
- if L=""
- SET L="Blood Bank"
- DO A^LRU
- WRITE ?48,Y,$PIECE(LRX,U,7),?67,$EXTRACT(L,1,13)
- if $PIECE(LRX,U,7)]""
- SET V=1
- if $PIECE(LRX,U,11)="U"
- SET LRG(1)=1
- +1 SET I=+LRX
- +2 FOR E=0:0
- SET E=$ORDER(^LRD(65,I,2,E))
- if 'E
- QUIT
- Begin DoDot:1
- +3 IF LRDFN'=E
- IF $DATA(^LRD(65,"AP",E,I))
- SET X=^LR(E,0)
- SET Y=$PIECE(X,"^",3)
- SET X=$PIECE(X,"^",2)
- SET X=^DIC(X,0,"GL")
- SET N=@(X_Y_",0)")
- WRITE !?6,$CHAR(7),"*** Also assigned/xmatched to ",$PIECE(N,"^")," ",$PIECE(N,"^",9)
- End DoDot:1
- +4 QUIT
- +5 ;
- N SET Z(1)=Y
- SET LRX=^TMP($JOB,"B",Z,Y,A)
- +1 WRITE !
- DO W
- +2 KILL ^TMP($JOB,"B",Z,Z(1),A)
- +3 WRITE $CHAR(7),!?6,"This unit needs to be modified before release !"
- QUIT
- +4 ;
- A SET (A,B,C)=0
- +1 FOR
- SET A=$ORDER(^SC("B",A))
- if A=""
- QUIT
- IF A["BLOOD BANK"
- FOR
- SET B=$ORDER(^(A,B))
- if 'B
- QUIT
- IF DUZ(2)=+$$SITE^VASITE(DT,($PIECE($GET(^SC(B,0)),U,15)))
- SET C=C+1
- SET C(C)=A
- +2 IF 'C
- WRITE $CHAR(7),!!,"There must be an entry in the HOSPITAL LOCATION file",!,"containing 'BLOOD BANK' in the name for ",LRAA(4)
- SET Y=-1
- QUIT
- +3 SET LR(44)=C(1)
- +4 IF C>1
- SET Y=-1
- WRITE $CHAR(7),!!,"There can only be one entry in the HOSPITAL LOCATION file",!,"containing 'BLOOD BANK' in the name for ",LRAA(4)
- FOR A=0:0
- SET A=$ORDER(C(A))
- if 'A
- QUIT
- WRITE !?3,C(A)
- +5 KILL A,B,C
- QUIT