- LRBLPX1 ;AVAMC/REG - XMATCH RESULTS (COND'T) ; 08/17/01 3:30 PM ;
- ;;5.2;LAB SERVICE;**247,267,275**;Sep 27, 1994
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- S LRI=+LRJ I '$D(^LRD(65,LRI,0)) K ^LR(LRDFN,1.8,E,1,B,0),^TMP($J,LRV) S X=^LR(LRDFN,1.8,E,1,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_$S(X(1)="":"",1:($P(X,"^",4)-1)),LRV=LRV-1 Q
- W:LRV=1 !?6,"Unit for XMATCHING",?52,"Exp date",?68,"Loc"
- EN ;from LRBLPX
- K F(1),F(2)
- D:'$D(LR("%")) L^LRU
- S X=^LRD(65,LRI,0),A=$P(X,"^",7),H=$P(X,"^",8),L=$O(^(3,0)),LRE=^LAB(66,$P(X,"^",4),0),L=$S(L:$P(^LRD(65,LRI,3,L,0),"^",4),1:"Blood Bank")
- W !!,$J(LRV,2),")",?6,$P(X,"^"),?20,$E($P(LRE,"^"),1,23),?45,$J(A,2),?48,H,?52 S Y=$P(X,"^",6) D DT^LRU S:L<0 L="Blood bank" W Y,?68,$E(L,1,12)
- S X=$S($D(^LRD(65,LRI,10)):$P(^(10),"^"),1:"") S:X="ND" X="" I X="" W $C(7),!,"ABO not rechecked"
- I X]"",X'=A W $C(7),!,"ABO recheck (group ",X,") does not match ABO group of unit. Resolve discrepancy." S F(2)=1
- S X=$S($D(^LRD(65,LRI,11)):$P(^(11),"^"),1:"") S:X="ND" X="" I H="NEG",X="" W $C(7),!,"Rh NEG unit not rechecked"
- I X]"",X'=H W $C(7),!,"Rh recheck (type ",X,") does not match Rh type of unit. Resolve discrepancy." S F(2)=1
- ;
- ; LR*5.2*275 Specific Requirement 3,4, and 5 from SRS
- ; BNT
- S X=$P(LRJ,"^",2)
- ; Initialize ABO/RH to false (No Results associated with this accn)
- S (X(10),X(11))=0
- ;
- ; Get ABO/RH Interpretation from file 63 for this accession
- I $D(^LR(LRDFN,LRSS,X,10)) D
- . ; Check if results are null or Not Done (ND) for ABO
- . S X(10)=$S($P(^LR(LRDFN,LRSS,X,10),"^")="":0,$P(^(10),"^")="ND":0,1:1)
- . ; Check if results match patient historical ABO rusults
- . ; LRPABO is ABO GROUP of 0 node in file 63
- . I 'X(10) Q
- . I $P(^LR(LRDFN,LRSS,X,10),"^")'=LRPABO S F(2)=1
- ;
- I $D(^LR(LRDFN,LRSS,X,11)) D
- . ; Check if results are null or Not Done (ND) for RH
- . S X(11)=$S($P(^LR(LRDFN,LRSS,X,11),"^")="":0,$P(^(11),"^")="ND":0,1:1)
- . ; Check if results match patient historical RH results
- . ; LRPRH is RH TYPE of 0 node in file 63
- . I 'X(11) Q
- . I $P(^LR(LRDFN,LRSS,X,11),"^")'=LRPRH S F(2)=1
- ;
- ; If results don't match historical ABO or RH, display warning message
- ; and don't proceed.
- I $D(F(2)) D Q
- . N LRACN,LRERRMSG
- . S LRACN=$P(^LR(LRDFN,LRSS,X,0),"^",6)
- . S LRERRMSG(1)="Results on "_LRACN_" do not match the Patient's previous ABO/Rh history"
- . S LRERRMSG(1,"F")="$C(7),!!"
- . S LRERRMSG(2)="Resolve the discrepancy before proceeding "
- . S LRERRMSG(2,"F")="!!"
- . S LRERRMSG(3,"F")="!"
- . D EN^DDIOL(.LRERRMSG)
- S X(6)=$S('$D(^LR(LRDFN,LRSS,X,6)):0,$P(^(6),"^")="":0,1:1)
- ;
- ; ************* END Patch LR*5.2*275 *************
- ;
- S X=^LR(LRDFN,LRSS,X,0),(LRJ,^TMP($J,LRV))=LRJ_"^"_+X_"^"_$P(X,"^",6)_"^"_X(10)_"^"_X(11)_"^"_X(6) K X
- I '$P(LRJ,"^",6)!'$P(LRJ,"^",7) W $C(7),!?4,"No patient ABO &/or Rh results" S (F(1),X)=1
- I '$P(LRJ,"^",8) W !?4,"No antibody screen results" S (F(6),X)=1
- I $D(X) S Y=$P(LRJ,"^",4) D DT^LRU W ?31,"(spec date:",Y," acc#:",$P($P(LRJ,"^",5)," ",3),")"
- C S Z(1)=0 I $D(R),$P(LRE,"^",9)=1,$P(LRE,"^",25)'=1 W ! F Z=0:0 S Z=$O(R(Z)) Q:'Z I Z'=LRB,'$D(^LRD(65,LRI,70,Z,0)) W !,$P(^LAB(61.3,Z,0),"^"),$E("..............",$X,14),?15,"RBC ANTIGEN" S Z(1)=1
- I Z(1) W $C(7),!,"Above antigen(s) not entered in RBC ANTIGEN ABSENT field"
- Q
- STF Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2
- I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)) S ^(0)=LRT_"^50^^"_DUZ_"^"_LRK,^(1,0)="^68.14P^^",X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),^(0)=$P(X,"^",1,2)_"^"_LRT_"^"_($P(X,"^",4)+1)
- F A=0:0 S A=$O(LRT(A)) Q:'A D:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,A,0)) A S Y=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,A,0),Z=$P(Y,U,3),X=$S('Z:$P(Y,U,2)+1,1:1),$P(Y,U,2,3)=X_U_0,$P(Y,U,7)=DUZ,$P(Y,U,6)=LRK,^(0)=Y
- S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)="",$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),"^",5)=LRK Q
- A S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,A,0)=A_"^0^0^0^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA,X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0),^(0)=$P(X,"^",1,2)_"^"_A_"^"_($P(X,"^",4)+1) Q
- ;
- CK S LRT=$O(^LAB(60,"B","WKLD CROSSMATCH",0)) I LRT F B=0:0 S B=$O(^LAB(60,LRT,9,B)) Q:'B S LRT(B)=""
- Q:$D(LRT)=11
- W $C(7),!,"Must have test in LAB TEST file (#60) called 'WKLD CROSSMATCH' with WKLD CODES." K LRT Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPX1 4334 printed Jan 18, 2025@03:12:51 Page 2
- LRBLPX1 ;AVAMC/REG - XMATCH RESULTS (COND'T) ; 08/17/01 3:30 PM ;
- +1 ;;5.2;LAB SERVICE;**247,267,275**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 SET LRI=+LRJ
- IF '$DATA(^LRD(65,LRI,0))
- KILL ^LR(LRDFN,1.8,E,1,B,0),^TMP($JOB,LRV)
- SET X=^LR(LRDFN,1.8,E,1,0)
- SET X(1)=$ORDER(^(0))
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_$SELECT(X(1)="":"",1:($PIECE(X,"^",4)-1))
- SET LRV=LRV-1
- QUIT
- +4 if LRV=1
- WRITE !?6,"Unit for XMATCHING",?52,"Exp date",?68,"Loc"
- EN ;from LRBLPX
- +1 KILL F(1),F(2)
- +2 if '$DATA(LR("%"))
- DO L^LRU
- +3 SET X=^LRD(65,LRI,0)
- SET A=$PIECE(X,"^",7)
- SET H=$PIECE(X,"^",8)
- SET L=$ORDER(^(3,0))
- SET LRE=^LAB(66,$PIECE(X,"^",4),0)
- SET L=$SELECT(L:$PIECE(^LRD(65,LRI,3,L,0),"^",4),1:"Blood Bank")
- +4 WRITE !!,$JUSTIFY(LRV,2),")",?6,$PIECE(X,"^"),?20,$EXTRACT($PIECE(LRE,"^"),1,23),?45,$JUSTIFY(A,2),?48,H,?52
- SET Y=$PIECE(X,"^",6)
- DO DT^LRU
- if L<0
- SET L="Blood bank"
- WRITE Y,?68,$EXTRACT(L,1,12)
- +5 SET X=$SELECT($DATA(^LRD(65,LRI,10)):$PIECE(^(10),"^"),1:"")
- if X="ND"
- SET X=""
- IF X=""
- WRITE $CHAR(7),!,"ABO not rechecked"
- +6 IF X]""
- IF X'=A
- WRITE $CHAR(7),!,"ABO recheck (group ",X,") does not match ABO group of unit. Resolve discrepancy."
- SET F(2)=1
- +7 SET X=$SELECT($DATA(^LRD(65,LRI,11)):$PIECE(^(11),"^"),1:"")
- if X="ND"
- SET X=""
- IF H="NEG"
- IF X=""
- WRITE $CHAR(7),!,"Rh NEG unit not rechecked"
- +8 IF X]""
- IF X'=H
- WRITE $CHAR(7),!,"Rh recheck (type ",X,") does not match Rh type of unit. Resolve discrepancy."
- SET F(2)=1
- +9 ;
- +10 ; LR*5.2*275 Specific Requirement 3,4, and 5 from SRS
- +11 ; BNT
- +12 SET X=$PIECE(LRJ,"^",2)
- +13 ; Initialize ABO/RH to false (No Results associated with this accn)
- +14 SET (X(10),X(11))=0
- +15 ;
- +16 ; Get ABO/RH Interpretation from file 63 for this accession
- +17 IF $DATA(^LR(LRDFN,LRSS,X,10))
- Begin DoDot:1
- +18 ; Check if results are null or Not Done (ND) for ABO
- +19 SET X(10)=$SELECT($PIECE(^LR(LRDFN,LRSS,X,10),"^")="":0,$PIECE(^(10),"^")="ND":0,1:1)
- +20 ; Check if results match patient historical ABO rusults
- +21 ; LRPABO is ABO GROUP of 0 node in file 63
- +22 IF 'X(10)
- QUIT
- +23 IF $PIECE(^LR(LRDFN,LRSS,X,10),"^")'=LRPABO
- SET F(2)=1
- End DoDot:1
- +24 ;
- +25 IF $DATA(^LR(LRDFN,LRSS,X,11))
- Begin DoDot:1
- +26 ; Check if results are null or Not Done (ND) for RH
- +27 SET X(11)=$SELECT($PIECE(^LR(LRDFN,LRSS,X,11),"^")="":0,$PIECE(^(11),"^")="ND":0,1:1)
- +28 ; Check if results match patient historical RH results
- +29 ; LRPRH is RH TYPE of 0 node in file 63
- +30 IF 'X(11)
- QUIT
- +31 IF $PIECE(^LR(LRDFN,LRSS,X,11),"^")'=LRPRH
- SET F(2)=1
- End DoDot:1
- +32 ;
- +33 ; If results don't match historical ABO or RH, display warning message
- +34 ; and don't proceed.
- +35 IF $DATA(F(2))
- Begin DoDot:1
- +36 NEW LRACN,LRERRMSG
- +37 SET LRACN=$PIECE(^LR(LRDFN,LRSS,X,0),"^",6)
- +38 SET LRERRMSG(1)="Results on "_LRACN_" do not match the Patient's previous ABO/Rh history"
- +39 SET LRERRMSG(1,"F")="$C(7),!!"
- +40 SET LRERRMSG(2)="Resolve the discrepancy before proceeding "
- +41 SET LRERRMSG(2,"F")="!!"
- +42 SET LRERRMSG(3,"F")="!"
- +43 DO EN^DDIOL(.LRERRMSG)
- End DoDot:1
- QUIT
- +44 SET X(6)=$SELECT('$DATA(^LR(LRDFN,LRSS,X,6)):0,$PIECE(^(6),"^")="":0,1:1)
- +45 ;
- +46 ; ************* END Patch LR*5.2*275 *************
- +47 ;
- +48 SET X=^LR(LRDFN,LRSS,X,0)
- SET (LRJ,^TMP($JOB,LRV))=LRJ_"^"_+X_"^"_$PIECE(X,"^",6)_"^"_X(10)_"^"_X(11)_"^"_X(6)
- KILL X
- +49 IF '$PIECE(LRJ,"^",6)!'$PIECE(LRJ,"^",7)
- WRITE $CHAR(7),!?4,"No patient ABO &/or Rh results"
- SET (F(1),X)=1
- +50 IF '$PIECE(LRJ,"^",8)
- WRITE !?4,"No antibody screen results"
- SET (F(6),X)=1
- +51 IF $DATA(X)
- SET Y=$PIECE(LRJ,"^",4)
- DO DT^LRU
- WRITE ?31,"(spec date:",Y," acc#:",$PIECE($PIECE(LRJ,"^",5)," ",3),")"
- C SET Z(1)=0
- IF $DATA(R)
- IF $PIECE(LRE,"^",9)=1
- IF $PIECE(LRE,"^",25)'=1
- WRITE !
- FOR Z=0:0
- SET Z=$ORDER(R(Z))
- if 'Z
- QUIT
- IF Z'=LRB
- IF '$DATA(^LRD(65,LRI,70,Z,0))
- WRITE !,$PIECE(^LAB(61.3,Z,0),"^"),$EXTRACT("..............",$X,14),?15,"RBC ANTIGEN"
- SET Z(1)=1
- +1 IF Z(1)
- WRITE $CHAR(7),!,"Above antigen(s) not entered in RBC ANTIGEN ABSENT field"
- +2 QUIT
- STF if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2
- QUIT
- +1 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0))
- SET ^(0)=LRT_"^50^^"_DUZ_"^"_LRK
- SET ^(1,0)="^68.14P^^"
- SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRT_"^"_($PIECE(X,"^",4)+1)
- +2 FOR A=0:0
- SET A=$ORDER(LRT(A))
- if 'A
- QUIT
- if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,A,0))
- DO A
- SET Y=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,A,0)
- SET Z=$PIECE(Y,U,3)
- SET X=$SELECT('Z:$PIECE(Y,U,2)+1,1:1)
- SET $PIECE(Y,U,2,3)=X_U_0
- SET $PIECE(Y,U,7)=DUZ
- SET $PIECE(Y,U,6)=LRK
- SET ^(0)=Y
- +3 SET ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
- SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),"^",5)=LRK
- QUIT
- A SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,A,0)=A_"^0^0^0^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA
- SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_A_"^"_($PIECE(X,"^",4)+1)
- QUIT
- +1 ;
- CK SET LRT=$ORDER(^LAB(60,"B","WKLD CROSSMATCH",0))
- IF LRT
- FOR B=0:0
- SET B=$ORDER(^LAB(60,LRT,9,B))
- if 'B
- QUIT
- SET LRT(B)=""
- +1 if $DATA(LRT)=11
- QUIT
- +2 WRITE $CHAR(7),!,"Must have test in LAB TEST file (#60) called 'WKLD CROSSMATCH' with WKLD CODES."
- KILL LRT
- QUIT