LRBLPX ;AVAMC/REG/CYM - XMATCH RESULTS ;08/20/2001 3:45 PM
;;5.2;LAB SERVICE;**72,77,247,275,408**;Sep 27, 1994;Build 8
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
Q D V^LRU,CK^LRBLPUS G:Y=-1 END
S LRB=$O(^LAB(61.3,"C",50710,0)) I 'LRB D EN1^LRBLU
W !!?28,"Enter crossmatch results",!!?28,LRAA(4) K LRDPAF S LRW=$P(^VA(200,DUZ,0),"^",2)
I LRCAPA D CK^LRBLPX1 I '$D(LRT) D END Q
ASK W ! K ^TMP($J),LRZ,LRV,DIC D ^LRDPA K DIC,DIE,DR G:LRDFN=-1 END D R G ASK
;
R S X=^LR(LRDFN,0),LRDPF=$P(X,U,2),LRPABO=$P(X,"^",5),LRPRH=$P(X,"^",6),LRP=PNM W !,LRP," ",SSN(1),?37,$J(LRPABO,2),?40,LRPRH D AB
S LRV=0 F E=0:0 S E=$O(^LR(LRDFN,1.8,E)) Q:'E F B=0:0 S B=$O(^LR(LRDFN,1.8,E,1,B)) Q:'B S X=^(B,0) D S
I 'LRV W $C(7),!,"No units currently selected for XMATCH",! Q
I LRV=1 G E
SEL W !!,"Select units (1-",LRV,") to enter XMATCH results: " R X:DTIME Q:X=""!(X[U) I X["?" W !,"Enter numbers from 1-",LRV,!,"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 LRA=0:0 S LRV=+LRQ,LRQ=$E(LRQ,$L(LRV)+2,$L(LRQ)) D:$D(^TMP($J,LRV)) E Q:'$L(LRQ)
Q
S S X(1)=+$P(X,"^",2) I '$D(^LR(LRDFN,LRSS,X(1),0)) K ^LR(LRDFN,1.8,E,1,B) S X=^LR(LRDFN,1.8,E,1,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1) Q
S LRV=LRV+1,(LRJ,^TMP($J,LRV))=^LR(LRDFN,1.8,E,1,B,0)_"^"_E D:LRV#20=0 M D ^LRBLPX1
Q
E W !! S LRJ=^TMP($J,LRV),LRR="",(LRI,DA(2))=+LRJ,DA=$P(LRJ,"^",2),LRC=$P(LRJ,"^",3),DIE="^LRD(65,LRI,2,LRDFN,1,",DA(1)=LRDFN
;
; LR*5.2*275 - Specific Requirement 6 from SRS
; BNT - Modified DR string below to only set the .05, .09, and 3 fields
; if data is entered in the .04 field.
; Also moved it down two lines just prior to the DIE call.
K F D EN^LRBLPX1 Q:$D(F(2)) I $D(F(1)) W !!?4,"Sorry, must have ABO/Rh results to enter XMATCH results" Q
I $D(F(6)) W !!?4,"Antibody screen results not entered. OK to continue " S %=2 D YN^LRU Q:%'=1
S DR=".04;S LRR=X;S:LRR="""" Y=0;.05////^S X=DUZ;.09///NOW;D:LRR=""IG"" IG^LRBLPX;3"
D ^DIE I $D(^LRD(65,LRI,2,LRDFN,1,+DA,0))#2 S LRAD=^(0) S:$P(LRAD,"^",10)]"" $P(^(0),"^",10)=""
K DIE,DR,DA I $G(Y)>0!(LRR="") S DIE="^LRD(65,LRI,2,",DA=LRDFN,DA(1)=LRI,DR=".02///@" D ^DIE K DIE Q
I LRR'="C",LRR'="IG",'$P(^LRD(65,LRI,2,LRDFN,0),"^",2) G K
S DIE="^LRD(65,LRI,2,",DA=LRDFN,DA(1)=LRI,DR=$S(LRR="C"!(LRR="IG"):".02//^S X=""NOW""",1:".02///@") D ^DIE Q:$D(Y) S LRK=$P(^LRD(65,LRI,2,LRDFN,0),"^",2) I 'LRK S X="N",%DT="T" D ^%DT S LRK=Y
S LRAN=$P($P(LRAD,"^",6)," ",3),LRAD=$P($P(LRAD,"^"),".") I LRCAPA,LRAN,LRAD S X=$P(^LRO(68,LRAA,0),"^",3),LRAD=$S(X="D":LRAD,X="Y":$E(LRAD,1,3)_"0000",X="M":$E(LRAD,1,5)_"00",1:LRAD) D STF^LRBLPX1
K L +^LR(LRDFN,1.8):5 I '$T W $C(7),!!,"I can't finish this. Someone else is editing this record" Q
K ^LR(LRDFN,1.8,LRC,1,LRI) S X=^LR(LRDFN,1.8,LRC,1,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_$S(X(1)="":"",1:($P(X,"^",4)-1)) L -^LR(LRDFN,1.8)
I $D(^LRD(65,"AP",LRDFN,LRI)) D LBL
Q
;
LBL S X=^LRD(65,LRI,0),Y(7)=$P(X,"^",7),Y(8)=$P(X,"^",8),Y=$P(^(2,LRDFN,0),"^",2) D DT^LRU
S Y(1)=$P(X,"^")_"^"_LRP_" "_SSN_"^"_"Patient "_LRPABO_" "_LRPRH_" "_Y_"^"_"Unit "_Y(7)_" "_Y(8)_" # "_$P(X,"^")
S X=^LRD(65,LRI,2,LRDFN,1,$P(LRJ,"^",2),0),Y(5)=$P(X,"^",5),Y(5)=$S(Y(5)="":"",$D(^VA(200,Y(5),0)):$P(^(0),"^",2),1:Y(5)),X=$P(X,"^",4),X=$$EXTERNAL^DILFD(65.02,.04,"",X),Y(1)=Y(1)_" "_Y(5)_"^"_X
EN ;from LRBLPUS2
S:'$D(^LRO(69.2,LRAA,9,0)) ^(0)="^69.25A^^" L +^LRO(69.2,LRAA,9):5 I '$T W $C(7),!!,"I won't be able to make this CAUTION TAG now. Someone else is using that function",! Q
S K=^LRO(69.2,LRAA,9,0),K(3)=$P(K,"^",3) F X=0:0 S K(3)=K(3)+1 Q:'$D(^LRO(69.2,LRAA,9,K(3)))
S ^LRO(69.2,LRAA,9,0)=$P(K,"^",1,2)_"^"_K(3)_"^"_($P(K,"^",4)+1)
S ^LRO(69.2,LRAA,9,K(3),0)=Y(1) L -^LRO(69.2,LRAA,9) Q
;
IG I '$D(^XUSEC("LRBLSUPER",DUZ)) W $C(7),!,"SORRY YOU DO NOT HAVE THE APPROPRIATE SECURITY",!,"TO ALLOW THIS UNIT TO BE ASSIGNED",! S LRR="" Q
R !!,"ENTER YOUR INITIALS TO ALLOW ASSIGNING UNIT: ",X(1):DTIME I X(1)'=LRW W $C(7),!,"NOT YOUR INITIALS !",! S LRR="" Q
Q
ALL F LRV=0:0 S LRV=$O(^TMP($J,LRV)) Q:'LRV D E
Q
M R !,"Press RETURN",X:DTIME W $C(13),$J("",15),$C(13) Q
AB K R S A=0 F B=0:1 S A=$O(^LR(LRDFN,1.7,A)) Q:'A S X=^LAB(61.3,A,0) S:$P(X,"^",4) R($P(X,"^",4))=$P(X,"^")
Q
END D V^LRU W !!,"Do you want to print caution tag labels " S %=1 D YN^LRU Q:%'=1 G ^LRBLJLA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPX 4640 printed Nov 22, 2024@17:22:13 Page 2
LRBLPX ;AVAMC/REG/CYM - XMATCH RESULTS ;08/20/2001 3:45 PM
+1 ;;5.2;LAB SERVICE;**72,77,247,275,408**;Sep 27, 1994;Build 8
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 QUIT
DO V^LRU
DO CK^LRBLPUS
if Y=-1
GOTO END
+4 SET LRB=$ORDER(^LAB(61.3,"C",50710,0))
IF 'LRB
DO EN1^LRBLU
+5 WRITE !!?28,"Enter crossmatch results",!!?28,LRAA(4)
KILL LRDPAF
SET LRW=$PIECE(^VA(200,DUZ,0),"^",2)
+6 IF LRCAPA
DO CK^LRBLPX1
IF '$DATA(LRT)
DO END
QUIT
ASK WRITE !
KILL ^TMP($JOB),LRZ,LRV,DIC
DO ^LRDPA
KILL DIC,DIE,DR
if LRDFN=-1
GOTO END
DO R
GOTO ASK
+1 ;
R SET X=^LR(LRDFN,0)
SET LRDPF=$PIECE(X,U,2)
SET LRPABO=$PIECE(X,"^",5)
SET LRPRH=$PIECE(X,"^",6)
SET LRP=PNM
WRITE !,LRP," ",SSN(1),?37,$JUSTIFY(LRPABO,2),?40,LRPRH
DO AB
+1 SET LRV=0
FOR E=0:0
SET E=$ORDER(^LR(LRDFN,1.8,E))
if 'E
QUIT
FOR B=0:0
SET B=$ORDER(^LR(LRDFN,1.8,E,1,B))
if 'B
QUIT
SET X=^(B,0)
DO S
+2 IF 'LRV
WRITE $CHAR(7),!,"No units currently selected for XMATCH",!
QUIT
+3 IF LRV=1
GOTO E
SEL WRITE !!,"Select units (1-",LRV,") to enter XMATCH results: "
READ X:DTIME
if X=""!(X[U)
QUIT
IF X["?"
WRITE !,"Enter numbers from 1-",LRV,!,"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 LRA=0:0
SET LRV=+LRQ
SET LRQ=$EXTRACT(LRQ,$LENGTH(LRV)+2,$LENGTH(LRQ))
if $DATA(^TMP($JOB,LRV))
DO E
if '$LENGTH(LRQ)
QUIT
+5 QUIT
S SET X(1)=+$PIECE(X,"^",2)
IF '$DATA(^LR(LRDFN,LRSS,X(1),0))
KILL ^LR(LRDFN,1.8,E,1,B)
SET X=^LR(LRDFN,1.8,E,1,0)
SET X(1)=$ORDER(^(0))
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)
QUIT
+1 SET LRV=LRV+1
SET (LRJ,^TMP($JOB,LRV))=^LR(LRDFN,1.8,E,1,B,0)_"^"_E
if LRV#20=0
DO M
DO ^LRBLPX1
+2 QUIT
E WRITE !!
SET LRJ=^TMP($JOB,LRV)
SET LRR=""
SET (LRI,DA(2))=+LRJ
SET DA=$PIECE(LRJ,"^",2)
SET LRC=$PIECE(LRJ,"^",3)
SET DIE="^LRD(65,LRI,2,LRDFN,1,"
SET DA(1)=LRDFN
+1 ;
+2 ; LR*5.2*275 - Specific Requirement 6 from SRS
+3 ; BNT - Modified DR string below to only set the .05, .09, and 3 fields
+4 ; if data is entered in the .04 field.
+5 ; Also moved it down two lines just prior to the DIE call.
+6 KILL F
DO EN^LRBLPX1
if $DATA(F(2))
QUIT
IF $DATA(F(1))
WRITE !!?4,"Sorry, must have ABO/Rh results to enter XMATCH results"
QUIT
+7 IF $DATA(F(6))
WRITE !!?4,"Antibody screen results not entered. OK to continue "
SET %=2
DO YN^LRU
if %'=1
QUIT
+8 SET DR=".04;S LRR=X;S:LRR="""" Y=0;.05////^S X=DUZ;.09///NOW;D:LRR=""IG"" IG^LRBLPX;3"
+9 DO ^DIE
IF $DATA(^LRD(65,LRI,2,LRDFN,1,+DA,0))#2
SET LRAD=^(0)
if $PIECE(LRAD,"^",10)]""
SET $PIECE(^(0),"^",10)=""
+10 KILL DIE,DR,DA
IF $GET(Y)>0!(LRR="")
SET DIE="^LRD(65,LRI,2,"
SET DA=LRDFN
SET DA(1)=LRI
SET DR=".02///@"
DO ^DIE
KILL DIE
QUIT
+11 IF LRR'="C"
IF LRR'="IG"
IF '$PIECE(^LRD(65,LRI,2,LRDFN,0),"^",2)
GOTO K
+12 SET DIE="^LRD(65,LRI,2,"
SET DA=LRDFN
SET DA(1)=LRI
SET DR=$SELECT(LRR="C"!(LRR="IG"):".02//^S X=""NOW""",1:".02///@")
DO ^DIE
if $DATA(Y)
QUIT
SET LRK=$PIECE(^LRD(65,LRI,2,LRDFN,0),"^",2)
IF 'LRK
SET X="N"
SET %DT="T"
DO ^%DT
SET LRK=Y
+13 SET LRAN=$PIECE($PIECE(LRAD,"^",6)," ",3)
SET LRAD=$PIECE($PIECE(LRAD,"^"),".")
IF LRCAPA
IF LRAN
IF LRAD
SET X=$PIECE(^LRO(68,LRAA,0),"^",3)
SET LRAD=$SELECT(X="D":LRAD,X="Y":$EXTRACT(LRAD,1,3)_"0000",X="M":$EXTRACT(LRAD,1,5)_"00",1:LRAD)
DO STF^LRBLPX1
K LOCK +^LR(LRDFN,1.8):5
IF '$TEST
WRITE $CHAR(7),!!,"I can't finish this. Someone else is editing this record"
QUIT
+1 KILL ^LR(LRDFN,1.8,LRC,1,LRI)
SET X=^LR(LRDFN,1.8,LRC,1,0)
SET X(1)=$ORDER(^(0))
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_$SELECT(X(1)="":"",1:($PIECE(X,"^",4)-1))
LOCK -^LR(LRDFN,1.8)
+2 IF $DATA(^LRD(65,"AP",LRDFN,LRI))
DO LBL
+3 QUIT
+4 ;
LBL SET X=^LRD(65,LRI,0)
SET Y(7)=$PIECE(X,"^",7)
SET Y(8)=$PIECE(X,"^",8)
SET Y=$PIECE(^(2,LRDFN,0),"^",2)
DO DT^LRU
+1 SET Y(1)=$PIECE(X,"^")_"^"_LRP_" "_SSN_"^"_"Patient "_LRPABO_" "_LRPRH_" "_Y_"^"_"Unit "_Y(7)_" "_Y(8)_" # "_$PIECE(X,"^")
+2 SET X=^LRD(65,LRI,2,LRDFN,1,$PIECE(LRJ,"^",2),0)
SET Y(5)=$PIECE(X,"^",5)
SET Y(5)=$SELECT(Y(5)="":"",$DATA(^VA(200,Y(5),0)):$PIECE(^(0),"^",2),1:Y(5))
SET X=$PIECE(X,"^",4)
SET X=$$EXTERNAL^DILFD(65.02,.04,"",X)
SET Y(1)=Y(1)_" "_Y(5)_"^"_X
EN ;from LRBLPUS2
+1 if '$DATA(^LRO(69.2,LRAA,9,0))
SET ^(0)="^69.25A^^"
LOCK +^LRO(69.2,LRAA,9):5
IF '$TEST
WRITE $CHAR(7),!!,"I won't be able to make this CAUTION TAG now. Someone else is using that function",!
QUIT
+2 SET K=^LRO(69.2,LRAA,9,0)
SET K(3)=$PIECE(K,"^",3)
FOR X=0:0
SET K(3)=K(3)+1
if '$DATA(^LRO(69.2,LRAA,9,K(3)))
QUIT
+3 SET ^LRO(69.2,LRAA,9,0)=$PIECE(K,"^",1,2)_"^"_K(3)_"^"_($PIECE(K,"^",4)+1)
+4 SET ^LRO(69.2,LRAA,9,K(3),0)=Y(1)
LOCK -^LRO(69.2,LRAA,9)
QUIT
+5 ;
IG IF '$DATA(^XUSEC("LRBLSUPER",DUZ))
WRITE $CHAR(7),!,"SORRY YOU DO NOT HAVE THE APPROPRIATE SECURITY",!,"TO ALLOW THIS UNIT TO BE ASSIGNED",!
SET LRR=""
QUIT
+1 READ !!,"ENTER YOUR INITIALS TO ALLOW ASSIGNING UNIT: ",X(1):DTIME
IF X(1)'=LRW
WRITE $CHAR(7),!,"NOT YOUR INITIALS !",!
SET LRR=""
QUIT
+2 QUIT
ALL FOR LRV=0:0
SET LRV=$ORDER(^TMP($JOB,LRV))
if 'LRV
QUIT
DO E
+1 QUIT
M READ !,"Press RETURN",X:DTIME
WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13)
QUIT
AB KILL R
SET A=0
FOR B=0:1
SET A=$ORDER(^LR(LRDFN,1.7,A))
if 'A
QUIT
SET X=^LAB(61.3,A,0)
if $PIECE(X,"^",4)
SET R($PIECE(X,"^",4))=$PIECE(X,"^")
+1 QUIT
END DO V^LRU
WRITE !!,"Do you want to print caution tag labels "
SET %=1
DO YN^LRU
if %'=1
QUIT
GOTO ^LRBLJLA
