LRBLQST ;AVAMC/REG - SINGLE UNIT STATUS ;8/1/95 08:46 ;
;;5.2;LAB SERVICE;**72,247,267**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
; References to ^DIC(4 are supported by DBIA 2508
; references to ^DD(65 are supported by DBIA 3261
D V^LRU S IOP="HOME" D ^%ZIS
W !!?20,"Current status of a unit in inventory file" S LRC=$P(^DD(65,4.1,0),U,3),LRT=$P(^DD(65,8.1,0),U,3),LRD=$P(^DD(65,8.3,0),U,3)
ASK W !! S DIC=65,DIC(0)="AEQMZ" D ^DIC K DIC G:Y<1 END W !,"Is this the unit " S %=1 D YN^LRU G:%'=1 ASK S LRA=+Y
W @IOF,!,"Unit #:",$P(Y(0),"^"),?25,"Component:" S X=$P(Y(0),"^",4) W $S('X:"??",$D(^LAB(66,X,0)):$P(^(0),"^"),1:"??") W:$P($G(^LAB(69.9,1,8.1,+DUZ(2),0)),U,6) !,$P($G(^DIC(4,+$P(Y(0),U,16),0)),U)
W !!,"Expiration date:" S Y=$P(Y(0),"^",6) D D^LRU W Y,?40,"ABO:",$P(Y(0),"^",7),?50,"Rh:",$P(Y(0),"^",8)
I $D(^LRD(65,LRA,4)) S LRB=^(4),X=$P(LRB,"^") I X]"" S Y=$P(LRB,"^",2) D D^LRU W !!,"Disposition date:",Y,?40,"Disposition:",$P($P(LRC,X_":",2),";")
I $D(^LRD(65,LRA,8)) S X=^(8),Y=+X,W(2)=$P(X,"^",2),W(3)=$P(X,"^",3) D:Y AU I W(2)]""!(W(3)]"") W ! W:W(2)]"" "Positive screening tests:",$P($P(LRT,W(2)_":",2),";") W:W(3)]"" ?40,"Donation type:",$P($P(LRD,W(3)_":",2),";")
W !! F X=0:0 S X=$O(^LRD(65,LRA,2,X)) Q:'X S Z=^(X,0) I $P(Z,"^",2) S V=^LR(+Z,0),(LRDPF,W)=$P(V,"^",2),Y=$P(V,"^",3),W=^DIC(W,0,"GL"),W=@(W_Y_",0)"),Y=$P(Z,"^",2) D D^LRU,W
S X=$O(^LRD(65,LRA,3,0)) I X S L=^LRD(65,LRA,3,X,0),Y=+L D D^LRU W !!,"Current location:",$P(L,"^",4),!,"Date last located:",Y
G ASK
W S SSN=$P(W,"^",9) D SSN^LRU
W !,"Patient:",$P(W,"^")," ",SSN,!?8,"Date assigned:",Y Q
;
AU S X=^LR(Y,0),Y=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),Y=@(X_Y_",0)") S SSN=$P(Y,"^",9) D SSN^LRU W !,"Restricted for: ",$P(Y,"^")," ",SSN Q
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLQST 1848 printed Dec 13, 2024@02:12:11 Page 2
LRBLQST ;AVAMC/REG - SINGLE UNIT STATUS ;8/1/95 08:46 ;
+1 ;;5.2;LAB SERVICE;**72,247,267**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 ; References to ^DIC(4 are supported by DBIA 2508
+4 ; references to ^DD(65 are supported by DBIA 3261
+5 DO V^LRU
SET IOP="HOME"
DO ^%ZIS
+6 WRITE !!?20,"Current status of a unit in inventory file"
SET LRC=$PIECE(^DD(65,4.1,0),U,3)
SET LRT=$PIECE(^DD(65,8.1,0),U,3)
SET LRD=$PIECE(^DD(65,8.3,0),U,3)
ASK WRITE !!
SET DIC=65
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
if Y<1
GOTO END
WRITE !,"Is this the unit "
SET %=1
DO YN^LRU
if %'=1
GOTO ASK
SET LRA=+Y
+1 WRITE @IOF,!,"Unit #:",$PIECE(Y(0),"^"),?25,"Component:"
SET X=$PIECE(Y(0),"^",4)
WRITE $SELECT('X:"??",$DATA(^LAB(66,X,0)):$PIECE(^(0),"^"),1:"??")
if $PIECE($GET(^LAB(69.9,1,8.1,+DUZ(2),0)),U,6)
WRITE !,$PIECE($GET(^DIC(4,+$PIECE(Y(0),U,16),0)),U)
+2 WRITE !!,"Expiration date:"
SET Y=$PIECE(Y(0),"^",6)
DO D^LRU
WRITE Y,?40,"ABO:",$PIECE(Y(0),"^",7),?50,"Rh:",$PIECE(Y(0),"^",8)
+3 IF $DATA(^LRD(65,LRA,4))
SET LRB=^(4)
SET X=$PIECE(LRB,"^")
IF X]""
SET Y=$PIECE(LRB,"^",2)
DO D^LRU
WRITE !!,"Disposition date:",Y,?40,"Disposition:",$PIECE($PIECE(LRC,X_":",2),";")
+4 IF $DATA(^LRD(65,LRA,8))
SET X=^(8)
SET Y=+X
SET W(2)=$PIECE(X,"^",2)
SET W(3)=$PIECE(X,"^",3)
if Y
DO AU
IF W(2)]""!(W(3)]"")
WRITE !
if W(2)]""
WRITE "Positive screening tests:",$PIECE($PIECE(LRT,W(2)_":",2),";")
if W(3)]""
WRITE ?40,"Donation type:",$PIECE($PIECE(LRD,W(3)_":",2),";")
+5 WRITE !!
FOR X=0:0
SET X=$ORDER(^LRD(65,LRA,2,X))
if 'X
QUIT
SET Z=^(X,0)
IF $PIECE(Z,"^",2)
SET V=^LR(+Z,0)
SET (LRDPF,W)=$PIECE(V,"^",2)
SET Y=$PIECE(V,"^",3)
SET W=^DIC(W,0,"GL")
SET W=@(W_Y_",0)")
SET Y=$PIECE(Z,"^",2)
DO D^LRU
DO W
+6 SET X=$ORDER(^LRD(65,LRA,3,0))
IF X
SET L=^LRD(65,LRA,3,X,0)
SET Y=+L
DO D^LRU
WRITE !!,"Current location:",$PIECE(L,"^",4),!,"Date last located:",Y
+7 GOTO ASK
W SET SSN=$PIECE(W,"^",9)
DO SSN^LRU
+1 WRITE !,"Patient:",$PIECE(W,"^")," ",SSN,!?8,"Date assigned:",Y
QUIT
+2 ;
AU SET X=^LR(Y,0)
SET Y=$PIECE(X,"^",3)
SET (LRDPF,X)=$PIECE(X,"^",2)
SET X=^DIC(X,0,"GL")
SET Y=@(X_Y_",0)")
SET SSN=$PIECE(Y,"^",9)
DO SSN^LRU
WRITE !,"Restricted for: ",$PIECE(Y,"^")," ",SSN
QUIT
END DO V^LRU
QUIT
