LRBLPCS.m

LRBLPCS ; IHS/DIR/AAB - COMPONENT SELECTION FOR PATIENTS 8/4/95 06:32 ;

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

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

 D V^LRU,CK^LRBLPUS G:Y=-1 END I LRSS'="BB" W $C(7),!!,"MUST BE BLOOD BANK" G END

 W !?20,LRAA(4),!!?15,"Selection of blood components for a patient" S LRJ=1

 W !,"Display instructions for component selected " S %=2 D YN^LRU G:%<1 END S:%=1 LRO=1

P W ! K DIC D ^LRDPA K DIC,DIE,DR W ! G:LRDFN=-1 END D EN1 G P

 ;

EN1 ;Q:'$D(LRP)  D ^LRBLPA Q:$D(Q("Q"))!(LRLLOC["DIED")  W LRP," ",SSN(1),?42,$J(LRPABO,2),?45,LRPRH D EN^LRBLPUS

 Q:'$D(LRP)  D ^LRBLPA Q:$D(Q("Q"))!(LRLLOC["DIED")  W LRP," ",HRCN,?42,$J(LRPABO,2),?45,LRPRH D EN^LRBLPUS  ;IHS/ANMC/CLS 11/1/95

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

 I $D(LRQ),B=1 W !,"No units currently assigned/xmatched"

 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(s) requested",?27,"Units",?33,"Request date",?47,"Date wanted",?59,"Requestor",?77,"By" D L

OP K LRR S LRCPT=0 W !!,"Is patient Pre-op " S %="" D YN^LRU I %<1 W $C(7),!,"You must answer 'YES' or 'NO' to enter component request.",!,"Do you want to enter component request at this time " S %=1 D YN^LRU G:%=1 OP Q

 S LRV=$S(%=2:0,1:1),LRV(1)=$S(LRV=1:8,1:6) D:LRV ^LRBLPCSS

 S DIE=63,DA=LRDFN,DR="[LRBLPCS]"

 W ! D ^DIE K DIE,DR D:$D(LRK) EN^LRBLPCS1 K LRK,S,C Q

 ;

EN3 F A=0:0 S A=$O(^LAB(66,C,LRV(1),A)) Q:'A  S X=^(A,0),E=$P(X,"^",2),F=+X,C(C,F,E)=$P(X,"^",3) I '$D(S(F,E)) D G

 K I(0) F A=0:0 S A=$O(C(C,A)) Q:'A  F B=0:0 S B=$O(C(C,A,B)) Q:'B  D A

 K:$D(I(0)) Q I $D(Q) K Q W !?5,$C(7)," Request still OK " S %=2 D YN^LRU S:%=1 LRR=1 I %'=1 S Y=0 D DEL

 S:$D(LRR) LRK(C)="" Q

G S X=$S($D(^LAB(60,F,0)):^(0),1:F) I $P(X,"^",5)'["CH" W $C(7),!,"No DATA NAME in file 60 for ",$P(X,"^") Q

 S G=$P(X,";",2),H=+$P(X,";",3),Z=$S($D(^LAB(60,F,1,E,0)):$P(^(0),"^",7),1:""),I(0)=$P(X,"^")

 F B=0:0 S B=$O(^LR(LRDFN,"CH",B)) Q:'B  S W=^(B,0),S=$P(W,"^",5) I S=E,$D(^(G)),$L(^(G)) S X=^(G) D H Q

 S:'$D(S(F,E)) S(F,E)="^"_I(0) Q

H S S(F,E)=$P(X,"^",H)_"^"_I(0)_"^"_$E(W,4,5)_"/"_$E(W,6,7)_"^"_Z_"^"_$P(^LAB(61,E,0),"^") Q

A Q:'$D(S(A,B))  I $P(S(A,B),"^")="" W !?10,"No ",$P(S(A,B),"^",2)," results " S Q=1 Q

 I +S(A,B),@(+$P(S(A,B),"^")_C(C,A,B)) W !?10,$P(S(A,B),"^",3)," Last ",$P(S(A,B),"^",2),": ",$P(S(A,B),"^")," ",$P(S(A,B),"^",4)," ",$P(S(A,B),"^",5) S Q=1 Q

 S I(0)=1 Q

EN2 K ^UTILITY($J) S DIWR=IOM-5,DIWL=5,DIWF="W" S A=0 F K=0:1 S A=$O(^LAB(66,C,7,A)) Q:'A  S X=^(A,0) D ^DIWP

 D:K ^DIWW Q

 ;

L S Y=+X I '$D(^LAB(66,Y,0)) K ^LR(LRDFN,1.8,Y) S Y=^LR(LRDFN,1.8,0),^(0)=$P(Y,"^",1,2)_"^^"_($P(Y,"^",4)-1) Q

 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) S Y=$P(X,"^",8) W ?77,$S(Y="":Y,$D(^VA(200,Y,0)):$P(^(0),"^",2),1:Y) Q

M Q:'Y  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

 ;

N W:B=1 !,"Unit assigned/xmatched:",?49,"Exp date",?64,"Loc"

 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,24),?42,$J($P(X,"^",7),2),?45,$P(X,"^",8),?49 S Y=$P(X,"^",6) D DT^LRU S:L<0 L="Blood bank" W Y,?64,L Q

 ;

DEL I $O(^LR(LRDFN,1.8,C,1,0)) S ^LR(LRDFN,1.8,C,0)=$P(^LR(LRDFN,1.8,C,0),"^") K ^LR(LRDFN,1.8,C,2) Q

 K ^LR(LRDFN,1.8,C) S X=^LR(LRDFN,1.8,0),X(2)=$O(^(0)),X(1)=$P(X,"^",4),^(0)="^63.084PA^"_X(2)_"^"_$S(X(1)<2:"",1:X(1)-1) Q

END D V^LRU Q

EN K LRO S IOM=$S('$D(IOM):80,IOM:IOM,1:80)

 W !,"FOR TRANSFUSION REQUESTS: Display instructions for components " S %=2 D YN^LRU Q:%<1  S:%=1 LRO=1 Q

LRBLPCS   ; IHS/DIR/AAB - COMPONENT SELECTION FOR PATIENTS 8/4/95 06:32 ;

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

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

 +3        DO V^LRU

           DO CK^LRBLPUS

           IF Y=-1

               GOTO END

           IF LRSS'="BB"

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

               GOTO END

 +4        WRITE !?20,LRAA(4),!!?15,"Selection of blood components for a patient"

           SET LRJ=1

 +5        WRITE !,"Display instructions for component selected "

           SET %=2

           DO YN^LRU

           IF %<1

               GOTO END

           IF %=1

               SET LRO=1

P          WRITE !

           KILL DIC

           DO ^LRDPA

           KILL DIC,DIE,DR

           WRITE !

           IF LRDFN=-1

               GOTO END

           DO EN1

           GOTO P

 +1       ;

EN1       ;Q:'$D(LRP)  D ^LRBLPA Q:$D(Q("Q"))!(LRLLOC["DIED")  W LRP," ",SSN(1),?42,$J(LRPABO,2),?45,LRPRH D EN^LRBLPUS

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

           IF '$DATA(LRP)

               QUIT 

           DO ^LRBLPA

           IF $DATA(Q("Q"))!(LRLLOC["DIED")

               QUIT 

           WRITE LRP," ",HRCN,?42,$JUSTIFY(LRPABO,2),?45,LRPRH

           DO EN^LRBLPUS

 +2        SET A=0

           FOR B=1:1

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

               IF 'A

                   QUIT 

               DO N

 +3        IF $DATA(LRQ)

               IF B=1

                   WRITE !,"No units currently assigned/xmatched"

 +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(s) requested",?27,"Units",?33,"Request date",?47,"Date wanted",?59,"Requestor",?77,"By"

               DO L

OP         KILL LRR

           SET LRCPT=0

           WRITE !!,"Is patient Pre-op "

           SET %=""

           DO YN^LRU

           IF %<1

               WRITE $CHAR(7),!,"You must answer 'YES' or 'NO' to enter component request.",!,"Do you want to enter component request at this time "

               SET %=1

               DO YN^LRU

               IF %=1

                   GOTO OP

               QUIT 

 +1        SET LRV=$SELECT(%=2:0,1:1)

           SET LRV(1)=$SELECT(LRV=1:8,1:6)

           IF LRV

               DO ^LRBLPCSS

 +2        SET DIE=63

           SET DA=LRDFN

           SET DR="[LRBLPCS]"

 +3        WRITE !

           DO ^DIE

           KILL DIE,DR

           IF $DATA(LRK)

               DO EN^LRBLPCS1

           KILL LRK,S,C

           QUIT 

 +4       ;

EN3        FOR A=0:0

               SET A=$ORDER(^LAB(66,C,LRV(1),A))

               IF 'A

                   QUIT 

               SET X=^(A,0)

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

               SET F=+X

               SET C(C,F,E)=$PIECE(X,"^",3)

               IF '$DATA(S(F,E))

                   DO G

 +1        KILL I(0)

           FOR A=0:0

               SET A=$ORDER(C(C,A))

               IF 'A

                   QUIT 

               FOR B=0:0

                   SET B=$ORDER(C(C,A,B))

                   IF 'B

                       QUIT 

                   DO A

 +2        IF $DATA(I(0))

               KILL Q

           IF $DATA(Q)

               KILL Q

               WRITE !?5,$CHAR(7)," Request still OK "

               SET %=2

               DO YN^LRU

               IF %=1

                   SET LRR=1

               IF %'=1

                   SET Y=0

                   DO DEL

 +3        IF $DATA(LRR)

               SET LRK(C)=""

           QUIT 

G          SET X=$SELECT($DATA(^LAB(60,F,0)):^(0),1:F)

           IF $PIECE(X,"^",5)'["CH"

               WRITE $CHAR(7),!,"No DATA NAME in file 60 for ",$PIECE(X,"^")

               QUIT 

 +1        SET G=$PIECE(X,";",2)

           SET H=+$PIECE(X,";",3)

           SET Z=$SELECT($DATA(^LAB(60,F,1,E,0)):$PIECE(^(0),"^",7),1:"")

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

 +2        FOR B=0:0

               SET B=$ORDER(^LR(LRDFN,"CH",B))

               IF 'B

                   QUIT 

               SET W=^(B,0)

               SET S=$PIECE(W,"^",5)

               IF S=E

                   IF $DATA(^(G))

                       IF $LENGTH(^(G))

                           SET X=^(G)

                           DO H

                           QUIT 

 +3        IF '$DATA(S(F,E))

               SET S(F,E)="^"_I(0)

           QUIT 

H          SET S(F,E)=$PIECE(X,"^",H)_"^"_I(0)_"^"_$EXTRACT(W,4,5)_"/"_$EXTRACT(W,6,7)_"^"_Z_"^"_$PIECE(^LAB(61,E,0),"^")

           QUIT 

A          IF '$DATA(S(A,B))

               QUIT 

           IF $PIECE(S(A,B),"^")=""

               WRITE !?10,"No ",$PIECE(S(A,B),"^",2)," results "

               SET Q=1

               QUIT 

 +1        IF +S(A,B)

               IF @(+$PIECE(S(A,B),"^")_C(C,A,B))

                   WRITE !?10,$PIECE(S(A,B),"^",3)," Last ",$PIECE(S(A,B),"^",2),": ",$PIECE(S(A,B),"^")," ",$PIECE(S(A,B),"^",4)," ",$PIECE(S(A,B),"^",5)

                   SET Q=1

                   QUIT 

 +2        SET I(0)=1

           QUIT 

EN2        KILL ^UTILITY($JOB)

           SET DIWR=IOM-5

           SET DIWL=5

           SET DIWF="W"

           SET A=0

           FOR K=0:1

               SET A=$ORDER(^LAB(66,C,7,A))

               IF 'A

                   QUIT 

               SET X=^(A,0)

               DO ^DIWP

 +1        IF K

               DO ^DIWW

           QUIT 

 +2       ;

L          SET Y=+X

           IF '$DATA(^LAB(66,Y,0))

               KILL ^LR(LRDFN,1.8,Y)

               SET Y=^LR(LRDFN,1.8,0)

               SET ^(0)=$PIECE(Y,"^",1,2)_"^^"_($PIECE(Y,"^",4)-1)

               QUIT 

 +1        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)

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

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

           QUIT 

M          IF 'Y

               QUIT 

           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 

 +1       ;

N          IF B=1

               WRITE !,"Unit assigned/xmatched:",?49,"Exp date",?64,"Loc"

 +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,24),?42,$JUSTIFY($PIECE(X,"^",7),2),?45,$PIECE(X,"^",8),?49

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

           DO DT^LRU

           IF L<0

               SET L="Blood bank"

           WRITE Y,?64,L

           QUIT 

 +4       ;

DEL        IF $ORDER(^LR(LRDFN,1.8,C,1,0))

               SET ^LR(LRDFN,1.8,C,0)=$PIECE(^LR(LRDFN,1.8,C,0),"^")

               KILL ^LR(LRDFN,1.8,C,2)

               QUIT 

 +1        KILL ^LR(LRDFN,1.8,C)

           SET X=^LR(LRDFN,1.8,0)

           SET X(2)=$ORDER(^(0))

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

           SET ^(0)="^63.084PA^"_X(2)_"^"_$SELECT(X(1)<2:"",1:X(1)-1)

           QUIT 

END        DO V^LRU

           QUIT 

EN         KILL LRO

           SET IOM=$SELECT('$DATA(IOM):80,IOM:IOM,1:80)

 +1        WRITE !,"FOR TRANSFUSION REQUESTS: Display instructions for components "

           SET %=2

           DO YN^LRU

           IF %<1

               QUIT 

           IF %=1

               SET LRO=1

           QUIT