source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBLPUS.m@ 1006

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1LRBLPUS ;AVAMC/REG/CYM - PATIENT UNIT SELECTION ;08/15/01 1:15 pm
2 ;;5.2;LAB SERVICE;**72,247,267,275**;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4 D END,CK G:Y=-1 END
5 S LRB=$O(^LAB(61.3,"C",50710,0))
6 I 'LRB D EN1^LRBLU
7 W !!,?24,"Selection of units for a patient",!!?28,LRAA(4),!?12,"Accession Area: ",LRO(68)
8 S LR(3)="",LRU(2)=1 D BAR^LRBLB
9 W !!?15,"Select only unassigned/uncrossmatched units "
10 S %=1 D YN^LRU G:%<1 END S:%=1 LRK=1
11P W ! K S,V,DIC
12 D ^LRDPA K DIC,DIE,DR
13 W ! G:LRDFN=-1 END
14 D ^LRBLPA K Z
15 G:$D(Q("Q"))!(LRDFN=-1) P D REST G P
16REST Q:LRLLOC["DIED"
17 W !,LRP," ",SSN(1),?37,$J(LRPABO,2),?40,LRPRH D EN
18 I '$O(^LR(LRDFN,1.8,0)) W $C(7),!!,"Must have blood component request(s) on record to select units",! Q
19 S A=0 F B=1:1 S A=$O(^LRD(65,"AP",LRDFN,A)) Q:'A D N
20 W ! S A=0 F B=0:1 S A=$O(^LR(LRDFN,1.8,A)) Q:'A S X=^(A,0) W:'B !,"Component(s) requested",?24,"Units",?30,"Request date/time",?48,"Wanted date/time",?65,"Requestor",?77,"By" D L
21C K X W !! S X=$$READ^LRBLB("Blood component for unit selection: ") Q:X=""!(X[U)
22 I LR,$E(X,1,$L(LR(2)))=LR(2) D
23 .D P^LRBLB
24 E W $$STRIP^LRBLB(.X) ; Strip off the data identifiers just in case
25 I '$D(X) W $C(7),!,"Code not entered in BLOOD PRODUCT file or not product label.",!
26 S DIC="^LR(LRDFN,1.8,",DIC(0)="EQMZ" D ^DIC K DIC,G
27 G:Y<1 C D G G C
28G S C=+Y,X=^LAB(66,C,0),LRV=$P(X,"^",10),C(19)=$P(X,"^",19),C(9)=$P(X,"^",9),C(7)=$P(X,"^",7),C(8)=$P(X,"^",8),C(1)=$P(Y,"^",2)
29 ;
30 ; LR*5.2*275 - Specific Requirement 1 from SRS
31 ; BNT - Added K LRJ
32 I C(9)=1 K LRJ D ^LRBLPCS1 Q:'$D(Z)
33 ;
34 S B=0 I $D(Z) S A=0 F B=0:1 S A=$O(Z(A)) Q:'A S Y=+Z(A) D DD^LRX W !,A,") ",Y," Acc # ",$P(Z(A),"^",3)
35 I B=1 S G=Z(1) G R
36S I B W !,"Select patient blood sample (1-",B,"): " R X:DTIME Q:X=""!(X[U) I X<1!(X>B)!(+X'=X) W !,"Select a number from 1 to ",B,! G S
37 S:B G=Z(X)
38R I $D(G) S G(1)=$P(+G,".",1),G(3)=$P(G,"^",3) S:G(3)'=+G(3) G(3)=$P(G(3)," ",3),G(6)=""
39 I $D(G),C(9)=1 S G(4)=$P(G,U,2),G(5)=$P(G,U,3) D
40 . S LRSPABO=$P($G(^LR(LRDFN,"BB",G(4),10)),U)
41 . S LRSPRH=$P($G(^LR(LRDFN,"BB",G(4),11)),U)
42 . Q:LRSPABO="" Q:LRSPRH=""
43 . I LRSPABO'=LRPABO!(LRSPRH'=LRPRH) W $C(7),!!,"Results on "_G(5)_" do not match the Patient's previous ABO/Rh history",!!,"Resolve the discrepancy before proceeding ",! S G(6)=1 K LRSPABO,LRSPRH
44 I $D(G),G(6)=1 Q
45 G ^LRBLPUS1
46 ;
47N W:B=1 !?6,"Unit assigned/xmatched:",?46,"Exp date",?67,"Location"
48 I '$D(^LRD(65,A,0)) K ^LRD(65,"AP",LRDFN,A) Q
49 S X=^LRD(65,A,0),L=$O(^(3,0)) S:'L L="Blood Bank" I L S L=$P(^(L,0),"^",4)
50 S M=^LAB(66,$P(X,"^",4),0)
51 W !,$J(B,2),")",?6,$P(X,"^"),?17,$E($P(M,"^"),1,19),?38,$P(X,"^",7)_" "_$P(X,"^",8),?44
52 S Y=$P(X,"^",6) D DD^LRX S:L<0 L="Blood bank" W Y,?64,L Q
53 ;
54L W !,$E($P(^LAB(66,+X,0),"^"),1,23),?24,$J($P(X,"^",4),3),?30 S Y=$P(X,"^",3) D M W Y,?48 S Y=$P(X,"^",5) D M W Y,?65,$P(X,"^",9),?77,$S($P(X,"^",8)="":"",$D(^VA(200,$P(X,"^",8),0)):$P(^(0),"^",2),1:$P(X,"^",8)) Q
55M D DD^LRX
56 Q
57EN ; from LRBLJL
58 S M=0 F A=0:0 S A=$O(^LRD(65,"AU",LRDFN,A)) Q:'A I $S('$D(^LRD(65,A,4)):1,$P(^(4),"^")="":1,1:0),$D(^(8)) S C=^(8),M=M+1 W:M=1 !,$C(7),"Units restricted for ",LRP S X=^(0) W !,$P(X,"^"),?15,$P(^LAB(66,$P(X,"^",4),0),"^")
59 Q
60CK ;called by LRBLPX,LRBLJLA,LRBLAA,LRBLJL,LRBLPCS
61 S LR("M")=1,X="BLOOD BANK" D ^LRUTL Q:Y=-1
62 I LRSS'="BB" W $C(7),!!,"MUST BE BLOOD BANK" S Y=-1 Q
63 S LRI=$O(^LAB(60,"B","TRANSFUSION REQUEST",0)) I 'LRI W $C(7),!,"TRANSFUSION REQUEST must be entered in LAB TEST file (#60).",! S Y=-1 Q
64 S LRAA=+$P($G(^LAB(60,LRI,8,+DUZ(2),0)),U,2) I 'LRAA W !!,$C(7),!!,"TRANSFUSION REQUEST in LAB TEST file (#60) must have an accession area",!,"assigned to your DIVISION.",! S Y=-1 Q
65 S X=$G(^LRO(68,LRAA,0)),LRO(68)=$P(X,U),LRABV=$P(X,U,11)
66 I X="" W $C(7),!!,"There is no accession area for ",LRAA,!,"in the accession area file (#68)." S Y=-1 Q
67 I LRABV="" W !!,$C(7),"There is no abbreviation entered for ",LRO(68),!,"in the accession area file (#68)." S Y=-1
68 Q
69 ;
70END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.