LRBLPT ;AVAMC/REG - TRANSFUSION RESULTS ;9/7/95 08:59 ;
;;5.2;LAB SERVICE;**72,247,408**;Sep 27, 1994;Build 8
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
Q D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END
W !!?28,"Enter transfusion results"
ASK W ! K ^TMP($J),LRZ,LRA,DIC,DIE,DR D ^LRDPA G:LRDFN=-1 END D R G ASK
;
R I '$D(^LRD(65,"AP",LRDFN)) W $C(7),!!,"No units currently assigned/xmatched.",! Q
W ! S DIC("B")=LRMD,DIC="^VA(200,",DIC(0)="AEQ",D="AK.PROVIDER",DIC("A")="Select PROVIDER: " D IX^DIC Q:Y<1 S X=+Y,LRMD=$P(Y,U,2),LRMD(1)=+Y K DIC
T W !!,"Select TREATING SPECIALTY: ",LRS,$S(LRS]"":"// ",1:"") R X:DTIME Q:X[U!'$T I X="",LRS="" Q
S:X="" X=LRS I X["?" S DIC=45.7,DIC(0)="EM" D ^DIC K DIC W !,"You may select a specialty not in the treating specialty file." G T
X $P(^DD(65,6.3,0),"^",5,99) I '$D(X) W $C(7),! W:$D(^(3)) ^(3) X:$D(^(4)) ^(4) G T
S DIC="^DIC(45.7,",DIC(0)="EM" D ^DIC K DIC
I Y<1 W $C(7),!,"Not an entry in the TREATING SPECIALTY file.",!,"Still want to accept it " S %=2 D YN^LRU I %'=1 S LRS="" G T
S LRS=$S(Y>0:$P(Y,"^",2),1:X),LRS(1)=$S(Y>0:+Y,1:"")
W ! S (LRA,LRZ)=0,LRG=1 F LRB=1:1 S LRA=$O(^LRD(65,"AP",LRDFN,LRA)) Q:'LRA D:LRB#20=0 M D N
K LRG I LRZ=1 S LRV=1 G ^LRBLPT1
SEL W !!,"Select units (1-",LRZ,") to enter TRANSFUSION results: " R X:DTIME Q:X=""!(X[U) I X["?" W !,"Enter numbers from 1 to ",LRZ,!,"For 2 or more selections separate each with a ',' (ex. 1,3,4)",!,"Enter 'ALL' for all units." G SEL
G:X="ALL" ALL
I X?.E1CA.E!($L(X)>200) W $C(7),!,"No CONTROL CHARACTERS, LETTERS or more than 200 characters allowed." G SEL
I '+X W $C(7),!,"START with a NUMBER !!",! G SEL
S LRQ=X F LRB=0:0 S LRV=+LRQ,LRQ=$E(LRQ,$L(LRV)+2,$L(LRQ)) D:$D(^TMP($J,LRV)) ^LRBLPT1 Q:'$L(LRQ)
Q
;
N W:LRB=1 !?6,"Unit assigned/xmatched:",?48,"Exp date",?64,"Loc"
I '$D(^LRD(65,LRA,0)) K ^LRD(65,"AP",LRDFN,LRA) Q
Q:$P(^LRD(65,LRA,0),"^",16)'=DUZ(2) I '$P(^LRD(65,LRA,2,LRDFN,0),"^",3) S X=$O(^LRD(65,LRA,2,LRDFN,1,0)) S:X X=+^(X,0) S:X $P(^LRD(65,LRA,2,LRDFN,0),"^",3)=X
S X=^LRD(65,LRA,0),F=$O(^(3,0)) S:F F=$P(^(F,0),"^",4) S:F="" F="Blood Bank"
S M=$P(^LAB(66,$P(X,"^",4),0),"^"),LRZ=LRZ+1,^TMP($J,LRZ)=LRA_"^"_$P(X,"^",4)_"^"_$P(X,"^")_"^"_$P(X,"^",7)_"^"_$P(X,"^",8)_"^"_$P(^LRD(65,LRA,2,LRDFN,0),"^",3)_"^"_F W ! W:$D(LRG) $J(LRZ,2),") "
W $P(X,"^"),?17,$E(M,1,22),?40,$J($P(X,"^",7),2),?43,$P(X,"^",8),?48 S Y=$P(X,"^",6) D DT^LRU W Y,?64,F Q
;
ALL F LRV=0:0 S LRV=$O(^TMP($J,LRV)) Q:'LRV D ^LRBLPT1
Q
M R !,"Press RETURN",X:DTIME W $C(13),$J("",15),$C(13) Q
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPT 2610 printed Dec 13, 2024@02:12:01 Page 2
LRBLPT ;AVAMC/REG - TRANSFUSION RESULTS ;9/7/95 08:59 ;
+1 ;;5.2;LAB SERVICE;**72,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 END
SET X="BLOOD BANK"
DO ^LRUTL
if Y=-1
GOTO END
+4 WRITE !!?28,"Enter transfusion results"
ASK WRITE !
KILL ^TMP($JOB),LRZ,LRA,DIC,DIE,DR
DO ^LRDPA
if LRDFN=-1
GOTO END
DO R
GOTO ASK
+1 ;
R IF '$DATA(^LRD(65,"AP",LRDFN))
WRITE $CHAR(7),!!,"No units currently assigned/xmatched.",!
QUIT
+1 WRITE !
SET DIC("B")=LRMD
SET DIC="^VA(200,"
SET DIC(0)="AEQ"
SET D="AK.PROVIDER"
SET DIC("A")="Select PROVIDER: "
DO IX^DIC
if Y<1
QUIT
SET X=+Y
SET LRMD=$PIECE(Y,U,2)
SET LRMD(1)=+Y
KILL DIC
T WRITE !!,"Select TREATING SPECIALTY: ",LRS,$SELECT(LRS]"":"// ",1:"")
READ X:DTIME
if X[U!'$TEST
QUIT
IF X=""
IF LRS=""
QUIT
+1 if X=""
SET X=LRS
IF X["?"
SET DIC=45.7
SET DIC(0)="EM"
DO ^DIC
KILL DIC
WRITE !,"You may select a specialty not in the treating specialty file."
GOTO T
+2 XECUTE $PIECE(^DD(65,6.3,0),"^",5,99)
IF '$DATA(X)
WRITE $CHAR(7),!
if $DATA(^(3))
WRITE ^(3)
if $DATA(^(4))
XECUTE ^(4)
GOTO T
+3 SET DIC="^DIC(45.7,"
SET DIC(0)="EM"
DO ^DIC
KILL DIC
+4 IF Y<1
WRITE $CHAR(7),!,"Not an entry in the TREATING SPECIALTY file.",!,"Still want to accept it "
SET %=2
DO YN^LRU
IF %'=1
SET LRS=""
GOTO T
+5 SET LRS=$SELECT(Y>0:$PIECE(Y,"^",2),1:X)
SET LRS(1)=$SELECT(Y>0:+Y,1:"")
+6 WRITE !
SET (LRA,LRZ)=0
SET LRG=1
FOR LRB=1:1
SET LRA=$ORDER(^LRD(65,"AP",LRDFN,LRA))
if 'LRA
QUIT
if LRB#20=0
DO M
DO N
+7 KILL LRG
IF LRZ=1
SET LRV=1
GOTO ^LRBLPT1
SEL WRITE !!,"Select units (1-",LRZ,") to enter TRANSFUSION results: "
READ X:DTIME
if X=""!(X[U)
QUIT
IF X["?"
WRITE !,"Enter numbers from 1 to ",LRZ,!,"For 2 or more selections separate each with a ',' (ex. 1,3,4)",!,"Enter 'ALL' for all units."
GOTO SEL
+1 if X="ALL"
GOTO ALL
+2 IF X?.E1CA.E!($LENGTH(X)>200)
WRITE $CHAR(7),!,"No CONTROL CHARACTERS, LETTERS or more than 200 characters allowed."
GOTO SEL
+3 IF '+X
WRITE $CHAR(7),!,"START with a NUMBER !!",!
GOTO SEL
+4 SET LRQ=X
FOR LRB=0:0
SET LRV=+LRQ
SET LRQ=$EXTRACT(LRQ,$LENGTH(LRV)+2,$LENGTH(LRQ))
if $DATA(^TMP($JOB,LRV))
DO ^LRBLPT1
if '$LENGTH(LRQ)
QUIT
+5 QUIT
+6 ;
N if LRB=1
WRITE !?6,"Unit assigned/xmatched:",?48,"Exp date",?64,"Loc"
+1 IF '$DATA(^LRD(65,LRA,0))
KILL ^LRD(65,"AP",LRDFN,LRA)
QUIT
+2 if $PIECE(^LRD(65,LRA,0),"^",16)'=DUZ(2)
QUIT
IF '$PIECE(^LRD(65,LRA,2,LRDFN,0),"^",3)
SET X=$ORDER(^LRD(65,LRA,2,LRDFN,1,0))
if X
SET X=+^(X,0)
if X
SET $PIECE(^LRD(65,LRA,2,LRDFN,0),"^",3)=X
+3 SET X=^LRD(65,LRA,0)
SET F=$ORDER(^(3,0))
if F
SET F=$PIECE(^(F,0),"^",4)
if F=""
SET F="Blood Bank"
+4 SET M=$PIECE(^LAB(66,$PIECE(X,"^",4),0),"^")
SET LRZ=LRZ+1
SET ^TMP($JOB,LRZ)=LRA_"^"_$PIECE(X,"^",4)_"^"_$PIECE(X,"^")_"^"_$PIECE(X,"^",7)_"^"_$PIECE(X,"^",8)_"^"_$PIECE(^LRD(65,LRA,2,LRDFN,0),"^",3)_"^"_F
WRITE !
if $DATA(LRG)
WRITE $JUSTIFY(LRZ,2),") "
+5 WRITE $PIECE(X,"^"),?17,$EXTRACT(M,1,22),?40,$JUSTIFY($PIECE(X,"^",7),2),?43,$PIECE(X,"^",8),?48
SET Y=$PIECE(X,"^",6)
DO DT^LRU
WRITE Y,?64,F
QUIT
+6 ;
ALL FOR LRV=0:0
SET LRV=$ORDER(^TMP($JOB,LRV))
if 'LRV
QUIT
DO ^LRBLPT1
+1 QUIT
M READ !,"Press RETURN",X:DTIME
WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13)
QUIT
END DO V^LRU
QUIT
