source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRBLPX.m@ 1800

Last change on this file since 1800 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.5 KB
Line 
1LRBLPX ;AVAMC/REG/CYM - XMATCH RESULTS ;08/20/2001 3:45 PM
2 ;;5.2;LAB SERVICE;**72,77,247,275**;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4 D V^LRU,CK^LRBLPUS G:Y=-1 END
5 S LRB=$O(^LAB(61.3,"C",50710,0)) I 'LRB D EN1^LRBLU
6 W !!?28,"Enter crossmatch results",!!?28,LRAA(4) K LRDPAF S LRW=$P(^VA(200,DUZ,0),"^",2)
7 I LRCAPA D CK^LRBLPX1 I '$D(LRT) D END Q
8ASK W ! K ^TMP($J),LRZ,LRV,DIC D ^LRDPA K DIC,DIE,DR G:LRDFN=-1 END D R G ASK
9 ;
10R 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
11 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
12 I 'LRV W $C(7),!,"No units currently selected for XMATCH",! Q
13 I LRV=1 G E
14SEL 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
15 G:X="ALL" ALL
16 I X?.E1CA.E!($L(X)>200) W $C(7),!,"No CONTROL CHARACTERS, LETTERS or more than 200 characters allowed." G SEL
17 I '+X W $C(7),!,"START with a NUMBER !!",! G SEL
18 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)
19 Q
20S 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
21 S LRV=LRV+1,(LRJ,^TMP($J,LRV))=^LR(LRDFN,1.8,E,1,B,0)_"^"_E D:LRV#20=0 M D ^LRBLPX1
22 Q
23E 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
24 ;
25 ; LR*5.2*275 - Specific Requirement 6 from SRS
26 ; BNT - Modified DR string below to only set the .05, .09, and 3 fields
27 ; if data is entered in the .04 field.
28 ; Also moved it down two lines just prior to the DIE call.
29 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
30 I $D(F(6)) W !!?4,"Antibody screen results not entered. OK to continue " S %=2 D YN^LRU Q:%'=1
31 S DR=".04;S LRR=X;S:LRR="""" Y=0;.05////^S X=DUZ;.09///NOW;D:LRR=""IG"" IG^LRBLPX;3"
32 D ^DIE I $D(^LRD(65,LRI,2,LRDFN,1,+DA,0))#2 S LRAD=^(0) S:$P(LRAD,"^",10)]"" $P(^(0),"^",10)=""
33 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
34 I LRR'="C",LRR'="IG",'$P(^LRD(65,LRI,2,LRDFN,0),"^",2) G K
35 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
36 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
37K L +^LR(LRDFN,1.8):5 I '$T W $C(7),!!,"I can't finish this. Someone else is editing this record" Q
38 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)
39 I $D(^LRD(65,"AP",LRDFN,LRI)) D LBL
40 Q
41 ;
42LBL 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
43 S Y(1)=$P(X,"^")_"^"_LRP_" "_SSN_"^"_"Patient "_LRPABO_" "_LRPRH_" "_Y_"^"_"Unit "_Y(7)_" "_Y(8)_" # "_$P(X,"^")
44 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
45EN ;from LRBLPUS2
46 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
47 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)))
48 S ^LRO(69.2,LRAA,9,0)=$P(K,"^",1,2)_"^"_K(3)_"^"_($P(K,"^",4)+1)
49 S ^LRO(69.2,LRAA,9,K(3),0)=Y(1) L -^LRO(69.2,LRAA,9) Q
50 ;
51IG 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
52 R !!,"ENTER YOUR INITIALS TO ALLOW ASSIGNING UNIT: ",X(1):DTIME I X(1)'=LRW W $C(7),!,"NOT YOUR INITIALS !",! S LRR="" Q
53 Q
54ALL F LRV=0:0 S LRV=$O(^TMP($J,LRV)) Q:'LRV D E
55 Q
56M R !,"Press RETURN",X:DTIME W $C(13),$J("",15),$C(13) Q
57AB 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,"^")
58 Q
59END D V^LRU W !!,"Do you want to print caution tag labels " S %=1 D YN^LRU Q:%'=1 G ^LRBLJLA
Note: See TracBrowser for help on using the repository browser.