LRDPA2.m

LRDPA2 ;AVAMC/REG - PT BLOOD BANK LOOKUP ;12/14/92  10:47 ;

 ;;5.2;LR;**310,1022**;September 20, 2007

 ;;

 ; VA Patch 310 is included in IHS LAB PATCH 1022

 ;;

 K ^TMP($J) I '$D(IOM) S IOP="HOME" D ^%ZIS

 S:IOM="" IOM=80

 S DIWR=IOM-5,DIWL=5,DIWF="W"

 S A=0 F B=0:1 S A=$O(^LR(LRDFN,3,A)) Q:'A  W:'B $C(7),! S X=^(A,0) D ^DIWP

 D:B ^DIWW K R S A=0 F B=0:1 S A=$O(^LR(LRDFN,1.7,A)) Q:'A  W:'B $C(7),!,"Antibody present:" W:B ! S X=^LAB(61.3,A,0) W ?18,$P(X,"^") S:$P(X,"^",4) R($P(X,"^",4))=$P(X,"^")

 W ! S (LR("Q"),A)=0,A(1)=12

 S C=0 F B=0:1 S C=$O(^LR("AB",LRDFN,C)) Q:'C!(LR("Q"))  F A=0:0 S A=$O(^LR("AB",LRDFN,C,A)) Q:'A!(LR("Q"))  D R

 S A=0 W ! F B=0:1 S A=$O(^LR(LRDFN,1.9,A)) Q:'A!(LR("Q"))  S LR(1.9)=^(A,0) W:'B !,"TRANSFUSION REACTIONS WITHOUT UNIT IDENTIFIED:" S Y=+LR(1.9),A(1)=A(1)+1 D D^LRU W !,Y,?21,$P($G(^LAB(65.4,+$P(LR(1.9),U,2),0)),U) D W

 S LR("Q")=0 Q

W D:A(1)#22=0 M^LRU Q:LR("Q")  F B=0:0 S B=$O(^LR(LRDFN,1.9,A,1,B)) Q:'B!(LR("Q"))  S A(1)=A(1)+1 W !,^(B,0) D:A(1)#22=0 M^LRU

 Q

R S LR(1.9)=$G(^LR(LRDFN,1.6,A,0)) I LR(1.9)="" K ^LR("AB",LRDFN,C,A) Q

 S A(1)=A(1)+1,Y=+LR(1.9) D D^LRU

 W:A(1)=13 !,"TRANSFUSION REACTIONS WITH UNIT IDENTIFIED",?51,"UNIT ID",?66,"COMPONENT" W !,Y,?21,$P($G(^LAB(65.4,C,0)),U),?51,$P(LR(1.9),U,3),?69,$P($G(^LAB(66,+$P(LR(1.9),U,2),0)),U,2) D:A(1)#22=0 M^LRU

 Q:LR("Q")  F B(1)=0:0 S B(1)=$O(^LR(LRDFN,1.6,A,1,B(1))) Q:'B(1)!(LR("Q"))  S B(2)=^(B(1),0),A(1)=A(1)+1 D:A(1)#22=0 M^LRU Q:LR("Q")  W !,B(2)

 Q

LRDPA2    ;AVAMC/REG - PT BLOOD BANK LOOKUP ;12/14/92  10:47 ;

 +1       ;;5.2;LR;**310,1022**;September 20, 2007

 +2       ;;

 +3       ; VA Patch 310 is included in IHS LAB PATCH 1022

 +4       ;;

 +5        KILL ^TMP($JOB)

           IF '$DATA(IOM)

               SET IOP="HOME"

               DO ^%ZIS

 +6        IF IOM=""

               SET IOM=80

 +7        SET DIWR=IOM-5

           SET DIWL=5

           SET DIWF="W"

 +8        SET A=0

           FOR B=0:1

               SET A=$ORDER(^LR(LRDFN,3,A))

               IF 'A

                   QUIT 

               IF 'B

                   WRITE $CHAR(7),!

               SET X=^(A,0)

               DO ^DIWP

 +9        IF B

               DO ^DIWW

           KILL R

           SET A=0

           FOR B=0:1

               SET A=$ORDER(^LR(LRDFN,1.7,A))

               IF 'A

                   QUIT 

               IF 'B

                   WRITE $CHAR(7),!,"Antibody present:"

               IF B

                   WRITE !

               SET X=^LAB(61.3,A,0)

               WRITE ?18,$PIECE(X,"^")

               IF $PIECE(X,"^",4)

                   SET R($PIECE(X,"^",4))=$PIECE(X,"^")

 +10       WRITE !

           SET (LR("Q"),A)=0

           SET A(1)=12

 +11       SET C=0

           FOR B=0:1

               SET C=$ORDER(^LR("AB",LRDFN,C))

               IF 'C!(LR("Q"))

                   QUIT 

               FOR A=0:0

                   SET A=$ORDER(^LR("AB",LRDFN,C,A))

                   IF 'A!(LR("Q"))

                       QUIT 

                   DO R

 +12       SET A=0

           WRITE !

           FOR B=0:1

               SET A=$ORDER(^LR(LRDFN,1.9,A))

               IF 'A!(LR("Q"))

                   QUIT 

               SET LR(1.9)=^(A,0)

               IF 'B

                   WRITE !,"TRANSFUSION REACTIONS WITHOUT UNIT IDENTIFIED:"

               SET Y=+LR(1.9)

               SET A(1)=A(1)+1

               DO D^LRU

               WRITE !,Y,?21,$PIECE($GET(^LAB(65.4,+$PIECE(LR(1.9),U,2),0)),U)

               DO W

 +13       SET LR("Q")=0

           QUIT 

W          IF A(1)#22=0

               DO M^LRU

           IF LR("Q")

               QUIT 

           FOR B=0:0

               SET B=$ORDER(^LR(LRDFN,1.9,A,1,B))

               IF 'B!(LR("Q"))

                   QUIT 

               SET A(1)=A(1)+1

               WRITE !,^(B,0)

               IF A(1)#22=0

                   DO M^LRU

 +1        QUIT 

R          SET LR(1.9)=$GET(^LR(LRDFN,1.6,A,0))

           IF LR(1.9)=""

               KILL ^LR("AB",LRDFN,C,A)

               QUIT 

 +1        SET A(1)=A(1)+1

           SET Y=+LR(1.9)

           DO D^LRU

 +2        IF A(1)=13

               WRITE !,"TRANSFUSION REACTIONS WITH UNIT IDENTIFIED",?51,"UNIT ID",?66,"COMPONENT"

           WRITE !,Y,?21,$PIECE($GET(^LAB(65.4,C,0)),U),?51,$PIECE(LR(1.9),U,3),?69,$PIECE($GET(^LAB(66,+$PIECE(LR(1.9),U,2),0)),U,2)

           IF A(1)#22=0

               DO M^LRU

 +3        IF LR("Q")

               QUIT 

           FOR B(1)=0:0

               SET B(1)=$ORDER(^LR(LRDFN,1.6,A,1,B(1)))

               IF 'B(1)!(LR("Q"))

                   QUIT 

               SET B(2)=^(B(1),0)

               SET A(1)=A(1)+1

               IF A(1)#22=0

                   DO M^LRU

               IF LR("Q")

                   QUIT 

               WRITE !,B(2)

 +4        QUIT