LRBLST ;AVAMC/REG - BB SUPERVISOR ;9/18/89 10:08 ;
;;5.2;LAB SERVICE;**247,408**;Sep 27, 1994;Build 8
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
Q D B G:Y=-1 END W !!?5,"Edit TESTS TO BE ",$S(LR=1:"DISPLAYED ON PATIENT LOOK-UP",1:"PRINTED ON TRANSFUSION REPORT"),!
I '$D(^LRO(69.2,LRAA,61,0)) S ^(0)="^69.61PA^^"
S LRQ=$O(^LAB(61,"B","BLOOD",0)) I 'LRQ W !!,$C(7),"BLOOD must be an entry in the TOPOGRAPHY file !" G END
I '$D(^LRO(69.2,LRAA,61,LRQ,0)) S X=^LRO(69.2,LRAA,61,0),^(0)="^69.61PA^"_LRQ_"^"_($P(X,"^",4)+1),^(LRQ,0)=LRQ
I '$D(^LRO(69.2,LRAA,61,LRQ,LR,0)) S ^(0)=$S(LR=1:"^69.62PAI^^",1:"^69.63PAI^^")
ASK W ! S DA(2)=LRAA,DA(1)=LRQ,DIC="^LRO(69.2,LRAA,61,LRQ,LR,",DIC(0)="AEQLM",DLAYGO=69 D ^DIC K DIC,DLAYGO G:X=""!(X[U) END S DA=+Y,X(1)=$P(Y,U,2)
S X=$P(^LRO(69.2,LRAA,61,LRQ,LR,DA,0),U,2) I X,'$D(^LAB(60,X(1),1,X)) S $P(^LRO(69.2,LRAA,61,LRQ,LR,DA,0),U,2)=""
S DIE("NO^")=1,DIE="^LRO(69.2,LRAA,61,LRQ,LR,",DR=".01;.02:99" D ^DIE K DIE,DR,DA G ASK
;
L Q D B Q:Y=-1 S DA=LRAA,DIE="^LRO(69.2,",DR=.07 D ^DIE Q
B S X="BLOOD BANK" D ^LRUTL Q:Y=-1
I '$D(^LRO(69.2,LRAA,0)) S ^(0)=LRAA_"^"_LRAA(2),X=^LRO(69.2,0),^(0)=$P(X,"^",1,2)_"^"_LRAA_"^"_($P(X,"^",4)+1),^LRO(69.2,"B",LRAA,LRAA)=""
Q
;
END D V^LRU Q
;
EN Q D V^LRU S LR=1 G LRBLST
EN1 D V^LRU S LR=2 G LRBLST
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLST 1361 printed Dec 13, 2024@02:12:17 Page 2
LRBLST ;AVAMC/REG - BB SUPERVISOR ;9/18/89 10:08 ;
+1 ;;5.2;LAB SERVICE;**247,408**;Sep 27, 1994;Build 8
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 QUIT
DO B
if Y=-1
GOTO END
WRITE !!?5,"Edit TESTS TO BE ",$SELECT(LR=1:"DISPLAYED ON PATIENT LOOK-UP",1:"PRINTED ON TRANSFUSION REPORT"),!
+4 IF '$DATA(^LRO(69.2,LRAA,61,0))
SET ^(0)="^69.61PA^^"
+5 SET LRQ=$ORDER(^LAB(61,"B","BLOOD",0))
IF 'LRQ
WRITE !!,$CHAR(7),"BLOOD must be an entry in the TOPOGRAPHY file !"
GOTO END
+6 IF '$DATA(^LRO(69.2,LRAA,61,LRQ,0))
SET X=^LRO(69.2,LRAA,61,0)
SET ^(0)="^69.61PA^"_LRQ_"^"_($PIECE(X,"^",4)+1)
SET ^(LRQ,0)=LRQ
+7 IF '$DATA(^LRO(69.2,LRAA,61,LRQ,LR,0))
SET ^(0)=$SELECT(LR=1:"^69.62PAI^^",1:"^69.63PAI^^")
ASK WRITE !
SET DA(2)=LRAA
SET DA(1)=LRQ
SET DIC="^LRO(69.2,LRAA,61,LRQ,LR,"
SET DIC(0)="AEQLM"
SET DLAYGO=69
DO ^DIC
KILL DIC,DLAYGO
if X=""!(X[U)
GOTO END
SET DA=+Y
SET X(1)=$PIECE(Y,U,2)
+1 SET X=$PIECE(^LRO(69.2,LRAA,61,LRQ,LR,DA,0),U,2)
IF X
IF '$DATA(^LAB(60,X(1),1,X))
SET $PIECE(^LRO(69.2,LRAA,61,LRQ,LR,DA,0),U,2)=""
+2 SET DIE("NO^")=1
SET DIE="^LRO(69.2,LRAA,61,LRQ,LR,"
SET DR=".01;.02:99"
DO ^DIE
KILL DIE,DR,DA
GOTO ASK
+3 ;
L QUIT
DO B
if Y=-1
QUIT
SET DA=LRAA
SET DIE="^LRO(69.2,"
SET DR=.07
DO ^DIE
QUIT
B SET X="BLOOD BANK"
DO ^LRUTL
if Y=-1
QUIT
+1 IF '$DATA(^LRO(69.2,LRAA,0))
SET ^(0)=LRAA_"^"_LRAA(2)
SET X=^LRO(69.2,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRAA_"^"_($PIECE(X,"^",4)+1)
SET ^LRO(69.2,"B",LRAA,LRAA)=""
+2 QUIT
+3 ;
END DO V^LRU
QUIT
+1 ;
EN QUIT
DO V^LRU
SET LR=1
GOTO LRBLST
EN1 DO V^LRU
SET LR=2
GOTO LRBLST