LRBLAGG.m

LRBLAGG ;AVAMC/REG - BLOOD BANK AGGLUTINATION STRENGTH ;3/9/94  10:29 ;

 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994

 ;Per VHA Directive 97-033 this routine should not be modified.  Medical Device # BK970021

 I X'?.ANP!($L(X)<1)!($L(X)>5) K X Q

 S Y=$O(^LAB(62.55,"B",X,0)) I Y,$D(^LAB(62.55,Y,0)) S X(2)=^(0),X=$P(X(2),"^") W " ",X," ",$P(X(2),"^",2) Q

 S:$D(DIC) LRTDIC=DIC S:$D(DIC(0)) LRTDIC(0)=DIC(0)

 S DIC="^LAB(62.55,",DIC(0)="EQMZ" D ^DIC K DIC S:Y'=-1 X=$P(Y(0),"^") I Y=-1!(X["^") K X

END S:$D(LRTDIC) DIC=LRTDIC S:$D(LRTDIC(0)) DIC(0)=LRTDIC(0) K LRTDIC,LRTDIC(0) Q

OUT S %Y="",X=$O(^LAB(62.55,"B",Y,0)) Q:'X  I $D(^LAB(62.55,X,0)) S %Y="("_$P(^(0),"^",2)_")" Q

LST ;

 W "CHOOSE FROM:" S X=0 F A=0:0 S X=$O(^LAB(62.55,"B",X)) Q:X=""  F Y=0:0 S Y=$O(^LAB(62.55,"B",X,Y)) Q:'Y  I $D(^LAB(62.55,Y,0)) W !,X,"  ",$P(^(0),U,2) I $Y#21=0 R !,"'^' TO STOP: ",%Y:DTIME G:%Y[U END D STOP

 Q

STOP W $C(13),$J("",15),$C(13) Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRBLAGG   935     printed  Apr 09, 2024@21:20:20                                                                                                                                                                                                      Page 2

LRBLAGG   ;AVAMC/REG - BLOOD BANK AGGLUTINATION STRENGTH ;3/9/94  10:29 ;

 +1       ;;5.2;LAB SERVICE;**247**;Sep 27, 1994

 +2       ;Per VHA Directive 97-033 this routine should not be modified.  Medical Device # BK970021

 +3        IF X'?.ANP!($LENGTH(X)<1)!($LENGTH(X)>5)

               KILL X

               QUIT 

 +4        SET Y=$ORDER(^LAB(62.55,"B",X,0))

           IF Y

               IF $DATA(^LAB(62.55,Y,0))

                   SET X(2)=^(0)

                   SET X=$PIECE(X(2),"^")

                   WRITE " ",X," ",$PIECE(X(2),"^",2)

                   QUIT 

 +5        if $DATA(DIC)

               SET LRTDIC=DIC

           if $DATA(DIC(0))

               SET LRTDIC(0)=DIC(0)

 +6        SET DIC="^LAB(62.55,"

           SET DIC(0)="EQMZ"

           DO ^DIC

           KILL DIC

           if Y'=-1

               SET X=$PIECE(Y(0),"^")

           IF Y=-1!(X["^")

               KILL X

END        if $DATA(LRTDIC)

               SET DIC=LRTDIC

           if $DATA(LRTDIC(0))

               SET DIC(0)=LRTDIC(0)

           KILL LRTDIC,LRTDIC(0)

           QUIT 

OUT        SET %Y=""

           SET X=$ORDER(^LAB(62.55,"B",Y,0))

           if 'X

               QUIT 

           IF $DATA(^LAB(62.55,X,0))

               SET %Y="("_$PIECE(^(0),"^",2)_")"

               QUIT 

LST       ;

 +1        WRITE "CHOOSE FROM:"

           SET X=0

           FOR A=0:0

               SET X=$ORDER(^LAB(62.55,"B",X))

               if X=""

                   QUIT 

               FOR Y=0:0

                   SET Y=$ORDER(^LAB(62.55,"B",X,Y))

                   if 'Y

                       QUIT 

                   IF $DATA(^LAB(62.55,Y,0))

                       WRITE !,X,"  ",$PIECE(^(0),U,2)

                       IF $Y#21=0

                           READ !,"'^' TO STOP: ",%Y:DTIME

                           if %Y[U

                               GOTO END

                           DO STOP

 +2        QUIT 

STOP       WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13)

           QUIT