LRBLST.m

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 ---LRBLST   1361     printed  Apr 09, 2024@21:19:05                                                                                                                                                                                                      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