- 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 Feb 18, 2025@23:38:01 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
