LRBLJU ;AVAMC/REG - FIND UNITS NO DISPOSITION ;10/6/95 10:10 ;
;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
S %DT="T",X="N" D ^%DT S N=Y,E(1)=$S($D(E(1)):E(1),1:DT-.0001) S:'$D(LROPT) LROPT=""
S IOP="HOME" D ^%ZIS W !!?20,$S($D(A)#2:A,1:""),!!
ASK R !,"Select: (A)ll blood components or (S)pecific component: ",S:DTIME G:S=""!(S[U) END G:S?1"A".E T I S'?1"S" W !!,"Enter A to list all components or S for a specific component",! G ASK
S DIC=66,DIC(0)="AEQMZ",DIC("A")="Select BLOOD COMPONENT: ",DIC("S")="I $P(^(0),U,4)=""BB""" D ^DIC K DIC G:X=""!(X[U) END S C=+Y,C(1)=$P(Y(0),"^",3)
T R !,"Select: (A)ll units or (S)pecific ABO/Rh: ",X:DTIME G:X=""!(X[U) END G DEV:X?1"A".E I X'?1"S".E W !!,"Select A for all units or S for specific T & Rh",! G T
AB R !,"ABO GROUP: ",X:DTIME G:X=""!(X[U) END S T=$S(X="A":"A",X="O":"O",X="B":"B",X="AB":"AB",1:"") I T="" W $C(7),!!,"Enter A, O, B, or AB",! G AB
R R !,"Rh TYPE: ",X:DTIME G:X=""!(X[U) END S R=$S(X?1"P".E:"POS",X?1"N".E:"NEG",1:"") I R="" W $C(7),!!,"Enter P or N",! G R
DEV S ZTRTN="QUE^LRBLJU" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) D L^LRU,S^LRU
G:S?1"A".E ALL
L S E=E(1) F E=E:0 S E=$O(^LRD(65,"AE",C,E)) Q:'E D I
Q:S?1"A".E
OUT D ^LRBLJU1 W:IOST'?1"C".E @IOF K ^TMP($J) D END^LRUTL,END Q
I I LROPT="" Q:E<N&(E[".") I E'[".",E<$P(N,".") Q
F I=0:0 S I=$O(^LRD(65,"AE",C,E,I)) Q:'I D S
Q
S Q:'$D(^LRD(65,I,0)) I $D(^(4)),$P(^(4),"^")]"" K ^LRD(65,"AE",C,E,I) Q
S W=^LRD(65,I,0) Q:$P(W,"^",16)'=DUZ(2)
S LRB=$P(W,"^",7),R(1)=$S($P(W,"^",8)]"":$P(W,"^",8),1:"?"),LRLLOC=$O(^LRD(65,I,3,0)),LRLLOC=$S(LRLLOC="":"Bld Bank",1:$P(^(LRLLOC,0),"^",4))
I $D(T)#2,$D(R) Q:T'=LRB!(R'=R(1))
S ^TMP($J,C,LRB,R(1),$P(W,"^",6),$P(W,"^"))=I_"^"_LRLLOC Q
ALL F C=0:0 S C=$O(^LRD(65,"AE",C)) Q:'C D L
G OUT
EN D END,SET G:Y=-1 END S LROPT="" G LRBLJU
EN1 D END,SET G:Y=-1 END S E(1)=0,LROPT="EN1" G LRBLJU
;
SET S X="BLOOD BANK" D ^LRUTL Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJU 2046 printed Apr 09, 2024@21:25:55 Page 2
LRBLJU ;AVAMC/REG - FIND UNITS NO DISPOSITION ;10/6/95 10:10 ;
+1 ;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 SET %DT="T"
SET X="N"
DO ^%DT
SET N=Y
SET E(1)=$SELECT($DATA(E(1)):E(1),1:DT-.0001)
if '$DATA(LROPT)
SET LROPT=""
+4 SET IOP="HOME"
DO ^%ZIS
WRITE !!?20,$SELECT($DATA(A)#2:A,1:""),!!
ASK READ !,"Select: (A)ll blood components or (S)pecific component: ",S:DTIME
if S=""!(S[U)
GOTO END
if S?1"A".E
GOTO T
IF S'?1"S"
WRITE !!,"Enter A to list all components or S for a specific component",!
GOTO ASK
+1 SET DIC=66
SET DIC(0)="AEQMZ"
SET DIC("A")="Select BLOOD COMPONENT: "
SET DIC("S")="I $P(^(0),U,4)=""BB"""
DO ^DIC
KILL DIC
if X=""!(X[U)
GOTO END
SET C=+Y
SET C(1)=$PIECE(Y(0),"^",3)
T READ !,"Select: (A)ll units or (S)pecific ABO/Rh: ",X:DTIME
if X=""!(X[U)
GOTO END
if X?1"A".E
GOTO DEV
IF X'?1"S".E
WRITE !!,"Select A for all units or S for specific T & Rh",!
GOTO T
AB READ !,"ABO GROUP: ",X:DTIME
if X=""!(X[U)
GOTO END
SET T=$SELECT(X="A":"A",X="O":"O",X="B":"B",X="AB":"AB",1:"")
IF T=""
WRITE $CHAR(7),!!,"Enter A, O, B, or AB",!
GOTO AB
R READ !,"Rh TYPE: ",X:DTIME
if X=""!(X[U)
GOTO END
SET R=$SELECT(X?1"P".E:"POS",X?1"N".E:"NEG",1:"")
IF R=""
WRITE $CHAR(7),!!,"Enter P or N",!
GOTO R
DEV SET ZTRTN="QUE^LRBLJU"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
DO L^LRU
DO S^LRU
+1 if S?1"A".E
GOTO ALL
L SET E=E(1)
FOR E=E:0
SET E=$ORDER(^LRD(65,"AE",C,E))
if 'E
QUIT
DO I
+1 if S?1"A".E
QUIT
OUT DO ^LRBLJU1
if IOST'?1"C".E
WRITE @IOF
KILL ^TMP($JOB)
DO END^LRUTL
DO END
QUIT
I IF LROPT=""
if E<N&(E[".")
QUIT
IF E'["."
IF E<$PIECE(N,".")
QUIT
+1 FOR I=0:0
SET I=$ORDER(^LRD(65,"AE",C,E,I))
if 'I
QUIT
DO S
+2 QUIT
S if '$DATA(^LRD(65,I,0))
QUIT
IF $DATA(^(4))
IF $PIECE(^(4),"^")]""
KILL ^LRD(65,"AE",C,E,I)
QUIT
+1 SET W=^LRD(65,I,0)
if $PIECE(W,"^",16)'=DUZ(2)
QUIT
+2 SET LRB=$PIECE(W,"^",7)
SET R(1)=$SELECT($PIECE(W,"^",8)]"":$PIECE(W,"^",8),1:"?")
SET LRLLOC=$ORDER(^LRD(65,I,3,0))
SET LRLLOC=$SELECT(LRLLOC="":"Bld Bank",1:$PIECE(^(LRLLOC,0),"^",4))
+3 IF $DATA(T)#2
IF $DATA(R)
if T'=LRB!(R'=R(1))
QUIT
+4 SET ^TMP($JOB,C,LRB,R(1),$PIECE(W,"^",6),$PIECE(W,"^"))=I_"^"_LRLLOC
QUIT
ALL FOR C=0:0
SET C=$ORDER(^LRD(65,"AE",C))
if 'C
QUIT
DO L
+1 GOTO OUT
EN DO END
DO SET
if Y=-1
GOTO END
SET LROPT=""
GOTO LRBLJU
EN1 DO END
DO SET
if Y=-1
GOTO END
SET E(1)=0
SET LROPT="EN1"
GOTO LRBLJU
+1 ;
SET SET X="BLOOD BANK"
DO ^LRUTL
QUIT
+1 ;
END DO V^LRU
QUIT
