LRBLPUS.m

LRBLPUS ; IHS/DIR/AAB - PATIENT UNIT SELECTION 8/16/96 06:33 ;

 ;;5.2;LR;**1002**;JUN 01, 1998

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

 D END,CK G:Y=-1 END

 S LRB=$O(^LAB(61.3,"C",50710,0)) I 'LRB D EN1^LRBLU

 W !!,?24,"Selection of units for a patient",!!?28,LRAA(4),!?12,"Accession Area: ",LRO(68) S LR(3)="",LRU(2)=1 D BAR^LRBLB

 W !!?15,"Select only unassigned/uncrossmatched units " S %=1 D YN^LRU G:%<1 END S:%=1 LRK=1

P W ! K S,V,DIC D ^LRDPA K DIC,DIE,DR W ! G:LRDFN=-1 END D ^LRBLPA K Z G:$D(Q("Q"))!(LRDFN=-1) P D REST G P

REST ;Q:LRLLOC["DIED"  W !,LRP," ",SSN(1),?37,$J(LRPABO,2),?40,LRPRH D EN

 Q:LRLLOC["DIED"  W !,LRP," ",HRCN,?37,$J(LRPABO,2),?40,LRPRH D EN  ;IHS/ANMC/CLS 11/1/95

 I '$O(^LR(LRDFN,1.8,0)) W $C(7),!!,"Must have blood component request(s) on record to select units",! Q

 S A=0 F B=1:1 S A=$O(^LRD(65,"AP",LRDFN,A)) Q:'A  D N

 W ! S A=0 F B=0:1 S A=$O(^LR(LRDFN,1.8,A)) Q:'A  S X=^(A,0) W:'B !,"Component",?27,"Units",?33,"Request date",?47,"Date wanted",?59,"Requestor",?77,"By" D L

C K X R !!,"Blood component for unit selection: ",X:DTIME Q:X=""!(X[U)

 I LR,$E(X,1,$L(LR(2)))=LR(2) D P^LRBLB I '$D(X) W $C(7),!,"Code not entered in BLOOD PRODUCT file or not product label.",! G C

 S DIC="^LR(LRDFN,1.8,",DIC(0)="EQMZ" D ^DIC K DIC,G G:Y<1 C D G G C

G S C=+Y,X=^LAB(66,C,0),LRV=$P(X,"^",10),C(19)=$P(X,"^",19),C(9)=$P(X,"^",9),C(7)=$P(X,"^",7),C(8)=$P(X,"^",8),C(1)=$P(Y,"^",2) I C(9)=1 D ^LRBLPCS1 Q:'$D(Z)

 S B=0 I $D(Z) S A=0 F B=0:1 S A=$O(Z(A)) Q:'A  S Y=+Z(A) D DT^LRU W !,A,") ",Y," Acc # ",$P(Z(A),"^",3)

 I B=1 S G=Z(1) G R

S I B W !,"Select patient blood sample (1-",B,"): " R X:DTIME Q:X=""!(X[U)  I X<1!(X>B)!(+X'=X) W !,"Select a number from 1 to ",B,! G S

 S:B G=Z(X)

R I $D(G) S G(1)=$P(+G,".",1),G(3)=$P(G,"^",3) S:G(3)'=+G(3) G(3)=$P(G(3)," ",3),G(6)=""

 I $D(G),C(9)=1 S G(4)=$P(G,U,2),G(5)=$P(G,U,3) D

 . S LRSPABO=$P($G(^LR(LRDFN,"BB",G(4),10)),U)

 . S LRSPRH=$P($G(^LR(LRDFN,"BB",G(4),11)),U)

 . Q:LRSPABO=""  Q:LRSPRH=""

 . I LRSPABO'=LRPABO!(LRSPRH'=LRPRH) W $C(7),!!,"Results on "_G(5)_" do not match the Patient's previous ABO/Rh history",!!,"Resolve the discrepancy before proceeding ",! S G(6)=1 K LRSPABO,LRSPRH

 I $D(G),G(6)=1 Q

 G ^LRBLPUS1

 ;

N W:B=1 !?6,"Unit assigned/xmatched:",?46,"Exp date",?64,"Location"

 I '$D(^LRD(65,A,0)) K ^LRD(65,"AP",LRDFN,A) Q

 S X=^LRD(65,A,0),L=$O(^(3,0)) S:'L L="Blood Bank" I L S L=$P(^(L,0),"^",4)

 S M=^LAB(66,$P(X,"^",4),0) W !,$J(B,2),")",?6,$P(X,"^"),?17,$E($P(M,"^"),1,19),?38,$P(X,"^",7)_" "_$P(X,"^",8),?44 S Y=$P(X,"^",6) D DT^LRU S:L<0 L="Blood bank" W Y,?64,L Q

 ;

L W !,$E($P(^LAB(66,+X,0),"^"),1,27),?27,$J($P(X,"^",4),3),?33 S Y=$P(X,"^",3) D M W Y,?47 S Y=$P(X,"^",5) D M W Y,?59,$P(X,"^",9),?77,$S($P(X,"^",8)="":"",$D(^VA(200,$P(X,"^",8),0)):$P(^(0),"^",2),1:$P(X,"^",8)) Q

M S Y=Y_"000",Y=$E(Y,4,5)_"/"_$E(Y,6,7)_$S(Y'[".":"",1:" "_$E(Y,9,10)_":"_$E(Y,11,12)) Q

EN ; from LRBLJL

 S M=0 F A=0:0 S A=$O(^LRD(65,"AU",LRDFN,A)) Q:'A  I $S('$D(^LRD(65,A,4)):1,$P(^(4),"^")="":1,1:0),$D(^(8)) S C=^(8),M=M+1 W:M=1 !,$C(7),"Units restricted for ",LRP S X=^(0) W !,$P(X,"^"),?15,$P(^LAB(66,$P(X,"^",4),0),"^")

 Q

CK ;called by LRBLPX,LRBLJLA,LRBLAA,LRBLJL,LRBLPCS

 S LR("M")=1,X="BLOOD BANK" D ^LRUTL Q:Y=-1  I LRSS'="BB" W $C(7),!!,"MUST BE BLOOD BANK" S Y=-1 Q

 S LRI=$O(^LAB(60,"B","TRANSFUSION REQUEST",0)) I 'LRI W $C(7),!,"TRANSFUSION REQUEST must be entered in LAB TEST file (#60).",! S Y=-1 Q

 S LRAA=+$P($G(^LAB(60,LRI,8,+DUZ(2),0)),U,2) I 'LRAA W !!,$C(7),!!,"TRANSFUSION REQUEST in LAB TEST file (#60) must have an accession area",!,"assigned to your DIVISION.",! S Y=-1 Q

 S X=$G(^LRO(68,LRAA,0)),LRO(68)=$P(X,U),LRABV=$P(X,U,11) I X="" W $C(7),!!,"There is no accession area for ",LRAA,!,"in the accession area file (#68)." S Y=-1 Q

 I LRABV="" W !!,$C(7),"There is no abbreviation entered for ",LRO(68),!,"in the accession area file (#68)." S Y=-1

 Q

 ;

END D V^LRU Q

LRBLPUS   ; IHS/DIR/AAB - PATIENT UNIT SELECTION 8/16/96 06:33 ;

 +1       ;;5.2;LR;**1002**;JUN 01, 1998

 +2       ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 +3        DO END

           DO CK

           IF Y=-1

               GOTO END

 +4        SET LRB=$ORDER(^LAB(61.3,"C",50710,0))

           IF 'LRB

               DO EN1^LRBLU

 +5        WRITE !!,?24,"Selection of units for a patient",!!?28,LRAA(4),!?12,"Accession Area: ",LRO(68)

           SET LR(3)=""

           SET LRU(2)=1

           DO BAR^LRBLB

 +6        WRITE !!?15,"Select only unassigned/uncrossmatched units "

           SET %=1

           DO YN^LRU

           IF %<1

               GOTO END

           IF %=1

               SET LRK=1

P          WRITE !

           KILL S,V,DIC

           DO ^LRDPA

           KILL DIC,DIE,DR

           WRITE !

           IF LRDFN=-1

               GOTO END

           DO ^LRBLPA

           KILL Z

           IF $DATA(Q("Q"))!(LRDFN=-1)

               GOTO P

           DO REST

           GOTO P

REST      ;Q:LRLLOC["DIED"  W !,LRP," ",SSN(1),?37,$J(LRPABO,2),?40,LRPRH D EN

 +1       ;IHS/ANMC/CLS 11/1/95

           IF LRLLOC["DIED"

               QUIT 

           WRITE !,LRP," ",HRCN,?37,$JUSTIFY(LRPABO,2),?40,LRPRH

           DO EN

 +2        IF '$ORDER(^LR(LRDFN,1.8,0))

               WRITE $CHAR(7),!!,"Must have blood component request(s) on record to select units",!

               QUIT 

 +3        SET A=0

           FOR B=1:1

               SET A=$ORDER(^LRD(65,"AP",LRDFN,A))

               IF 'A

                   QUIT 

               DO N

 +4        WRITE !

           SET A=0

           FOR B=0:1

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

               IF 'A

                   QUIT 

               SET X=^(A,0)

               IF 'B

                   WRITE !,"Component",?27,"Units",?33,"Request date",?47,"Date wanted",?59,"Requestor",?77,"By"

               DO L

C          KILL X

           READ !!,"Blood component for unit selection: ",X:DTIME

           IF X=""!(X[U)

               QUIT 

 +1        IF LR

               IF $EXTRACT(X,1,$LENGTH(LR(2)))=LR(2)

                   DO P^LRBLB

                   IF '$DATA(X)

                       WRITE $CHAR(7),!,"Code not entered in BLOOD PRODUCT file or not product label.",!

                       GOTO C

 +2        SET DIC="^LR(LRDFN,1.8,"

           SET DIC(0)="EQMZ"

           DO ^DIC

           KILL DIC,G

           IF Y<1

               GOTO C

           DO G

           GOTO C

G          SET C=+Y

           SET X=^LAB(66,C,0)

           SET LRV=$PIECE(X,"^",10)

           SET C(19)=$PIECE(X,"^",19)

           SET C(9)=$PIECE(X,"^",9)

           SET C(7)=$PIECE(X,"^",7)

           SET C(8)=$PIECE(X,"^",8)

           SET C(1)=$PIECE(Y,"^",2)

           IF C(9)=1

               DO ^LRBLPCS1

               IF '$DATA(Z)

                   QUIT 

 +1        SET B=0

           IF $DATA(Z)

               SET A=0

               FOR B=0:1

                   SET A=$ORDER(Z(A))

                   IF 'A

                       QUIT 

                   SET Y=+Z(A)

                   DO DT^LRU

                   WRITE !,A,") ",Y," Acc # ",$PIECE(Z(A),"^",3)

 +2        IF B=1

               SET G=Z(1)

               GOTO R

S          IF B

               WRITE !,"Select patient blood sample (1-",B,"): "

               READ X:DTIME

               IF X=""!(X[U)

                   QUIT 

               IF X<1!(X>B)!(+X'=X)

                   WRITE !,"Select a number from 1 to ",B,!

                   GOTO S

 +1        IF B

               SET G=Z(X)

R          IF $DATA(G)

               SET G(1)=$PIECE(+G,".",1)

               SET G(3)=$PIECE(G,"^",3)

               IF G(3)'=+G(3)

                   SET G(3)=$PIECE(G(3)," ",3)

                   SET G(6)=""

 +1        IF $DATA(G)

               IF C(9)=1

                   SET G(4)=$PIECE(G,U,2)

                   SET G(5)=$PIECE(G,U,3)

                   Begin DoDot:1

 +2                    SET LRSPABO=$PIECE($GET(^LR(LRDFN,"BB",G(4),10)),U)

 +3                    SET LRSPRH=$PIECE($GET(^LR(LRDFN,"BB",G(4),11)),U)

 +4                    IF LRSPABO=""

                           QUIT 

                       IF LRSPRH=""

                           QUIT 

 +5                    IF LRSPABO'=LRPABO!(LRSPRH'=LRPRH)

                           WRITE $CHAR(7),!!,"Results on "_G(5)_" do not match the Patient's previous ABO/Rh history",!!,"Resolve the discrepancy before proceeding ",!

                           SET G(6)=1

                           KILL LRSPABO,LRSPRH

                   End DoDot:1

 +6        IF $DATA(G)

               IF G(6)=1

                   QUIT 

 +7        GOTO ^LRBLPUS1

 +8       ;

N          IF B=1

               WRITE !?6,"Unit assigned/xmatched:",?46,"Exp date",?64,"Location"

 +1        IF '$DATA(^LRD(65,A,0))

               KILL ^LRD(65,"AP",LRDFN,A)

               QUIT 

 +2        SET X=^LRD(65,A,0)

           SET L=$ORDER(^(3,0))

           IF 'L

               SET L="Blood Bank"

           IF L

               SET L=$PIECE(^(L,0),"^",4)

 +3        SET M=^LAB(66,$PIECE(X,"^",4),0)

           WRITE !,$JUSTIFY(B,2),")",?6,$PIECE(X,"^"),?17,$EXTRACT($PIECE(M,"^"),1,19),?38,$PIECE(X,"^",7)_" "_$PIECE(X,"^",8),?44

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

           DO DT^LRU

           IF L<0

               SET L="Blood bank"

           WRITE Y,?64,L

           QUIT 

 +4       ;

L          WRITE !,$EXTRACT($PIECE(^LAB(66,+X,0),"^"),1,27),?27,$JUSTIFY($PIECE(X,"^",4),3),?33

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

           DO M

           WRITE Y,?47

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

           DO M

           WRITE Y,?59,$PIECE(X,"^",9),?77,$SELECT($PIECE(X,"^",8)="":"",$DATA(^VA(200,$PIECE(X,"^",8),0)):$PIECE(^(0),"^",2),1:$PIECE(X,"^",8))

           QUIT 

M          SET Y=Y_"000"

           SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_$SELECT(Y'[".":"",1:" "_$EXTRACT(Y,9,10)_":"_$EXTRACT(Y,11,12))

           QUIT 

EN        ; from LRBLJL

 +1        SET M=0

           FOR A=0:0

               SET A=$ORDER(^LRD(65,"AU",LRDFN,A))

               IF 'A

                   QUIT 

               IF $SELECT('$DATA(^LRD(65,A,4)):1,$PIECE(^(4),"^")="":1,1:0)

                   IF $DATA(^(8))

                       SET C=^(8)

                       SET M=M+1

                       IF M=1

                           WRITE !,$CHAR(7),"Units restricted for ",LRP

                       SET X=^(0)

                       WRITE !,$PIECE(X,"^"),?15,$PIECE(^LAB(66,$PIECE(X,"^",4),0),"^")

 +2        QUIT 

CK        ;called by LRBLPX,LRBLJLA,LRBLAA,LRBLJL,LRBLPCS

 +1        SET LR("M")=1

           SET X="BLOOD BANK"

           DO ^LRUTL

           IF Y=-1

               QUIT 

           IF LRSS'="BB"

               WRITE $CHAR(7),!!,"MUST BE BLOOD BANK"

               SET Y=-1

               QUIT 

 +2        SET LRI=$ORDER(^LAB(60,"B","TRANSFUSION REQUEST",0))

           IF 'LRI

               WRITE $CHAR(7),!,"TRANSFUSION REQUEST must be entered in LAB TEST file (#60).",!

               SET Y=-1

               QUIT 

 +3        SET LRAA=+$PIECE($GET(^LAB(60,LRI,8,+DUZ(2),0)),U,2)

           IF 'LRAA

               WRITE !!,$CHAR(7),!!,"TRANSFUSION REQUEST in LAB TEST file (#60) must have an accession area",!,"assigned to your DIVISION.",!

               SET Y=-1

               QUIT 

 +4        SET X=$GET(^LRO(68,LRAA,0))

           SET LRO(68)=$PIECE(X,U)

           SET LRABV=$PIECE(X,U,11)

           IF X=""

               WRITE $CHAR(7),!!,"There is no accession area for ",LRAA,!,"in the accession area file (#68)."

               SET Y=-1

               QUIT 

 +5        IF LRABV=""

               WRITE !!,$CHAR(7),"There is no abbreviation entered for ",LRO(68),!,"in the accession area file (#68)."

               SET Y=-1

 +6        QUIT 

 +7       ;

END        DO V^LRU

           QUIT