source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBLPCS1.m@ 862

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

initial load of WorldVistAEHR
File size: 3.4 KB
Line 
1LRBLPCS1 ;AVAMC/REG/CYM - COMPONENT SELECTION CK PT SPEC ;7/22/97 08:13 ;
2 ;;5.2;LAB SERVICE;**1,72,90,247**;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4 S (H,M)=0
5 S X=$P(^LAB(66,C,0),"^",16) S:'X X=72 S Z=X*60,X="N",%DT="T" D ^%DT K %DT S X=Y,X(1)=Y_"000" D H^%DTC S %H=%H-(Z\1440),Z=Z#1440 I Z S %H=%H-1,Z=1440-Z,H=Z\60,M=Z#60
6 I 'H,'M S H=$E(X(1),9,10),M=$E(X(1),11,12)
7 D D^LRUT S X=X_"."_$E("00",1,2-$L(H))_H_$E("00",1,2-$L(M))_M,G=9999999-X
8 ; Following 10 lines check spec. age during LRBLPLOGIN
9 I '$D(LRQ) D
10 . K Z S A=0 F B=0:0 S B=$O(^LR(LRDFN,"BB",B)) Q:'B!(B>G) S X=^(B,0),S=$P(X,"^",5) I S=LRBBSPEC,LRABV=$P($P(X,"^",6)," ") S Y=$P(X,"^",10) S:'Y Y=+X S A=A+1,Z(A)=Y_"^"_B_"^"_$P(X,"^",6) Q:$D(LRJ)
11 . I '$D(Z),'$D(LRQ) W $C(7),!?18,"No patient blood sample within required time",!?9,"Obtain a new sample from the patient for compatibility testing",!
12 . S Y="^" Q
13 I $D(LRQ) D
14 . K Z S A=0 F B=0:0 S B=$O(^LR(LRDFN,"BB",B)) Q:'B!(B>G) S X=^(B,0),S=$P(X,"^",5) I S=E,LRABV=$P($P(X,"^",6)," ") S Y=$P(X,"^",10) S:'Y Y=+X S A=A+1,Z(A)=Y_"^"_B_"^"_$P(X,"^",6) Q:$D(LRJ)
15 . Q:'$D(LRCDT)
16 . N LRINVDT S LRINVDT=(9999999-LRCDT)
17 . I LRINVDT>G W $C(7),!,?18,"Log in specimen collection date/time NOT within required time",!,?9,"Obtain a new sample from the patient for compatibility testing",!
18 S Y="^" Q
19 ;
20EN ;
21 S:'$D(LRAA)#2 LRAA=$O(^LRO(68,"B","BLOOD BANK",0)) Q:'LRAA
22 I LRAA<1 S LRAA=$O(^LRO(68,"B","BLOOD BANK",0)) Q:'LRAA
23 I '$D(^LRO(69.2,LRAA,8,0)) S ^(0)="^69.31A^^"
24 I '$D(^LRO(69.2,LRAA,8,66,0)) S ^(0)=66,X=^LRO(69.2,LRAA,8,0),^(0)="^69.31A^66^"_($P(X,"^",4)+1)
25 L +^LRO(69.2,LRAA,8,66):5 I '$T W $C(7),!!,"I Cannot add this request to the Inappropriate transfusion requests report at this time ",!!,"Please make note ...",!! Q
26 S:'$D(^LRO(69.2,LRAA,8,66,1,0)) ^(0)="^69.32A^^"
27 F A=0:0 S A=$O(LRK(A)) Q:'A I $D(^LR(LRDFN,1.8,A,0)) S X(2)=^(0),A(3)=$P(X(2),"^",3),Y=$P(X(2),"^",5),A(1)=$P(^LAB(66,A,0),"^") D D^LRU,B
28 L -^LRO(69.2,LRAA,8,66) Q
29B I '$D(^LRO(69.2,LRAA,8,66,1,A,0)) S ^(0)=A(1),X=^LRO(69.2,LRAA,8,66,1,0),^(0)=$P(X,"^",1,2)_"^"_A_"^"_($P(X,"^",4)+1),^LRO(69.2,LRAA,8,66,1,"B",A(1),A)=""
30 S:'$D(^LRO(69.2,LRAA,8,66,1,A,1,0)) ^(0)="^69.321DA^^" S X(1)=^(0),X=$P(X(1),"^",4)
31A S X=X+1 G:$D(^LRO(69.2,LRAA,8,66,1,A,1,X,0)) A
32 S ^LRO(69.2,LRAA,8,66,1,A,1,0)=$P(X(1),"^",1,2)_"^"_X_"^"_($P(X(1),"^",4)+1),^(X,0)=A(3)_"^"_PNM_"^"_SSN,^(1,0)="^69.3211A^^"
33 S ^LRO(69.2,LRAA,8,66,1,A,1,X,1,1,0)="Pre-op:"_$S($P(X(2),"^",2):"Yes",1:"No"),^LRO(69.2,LRAA,8,66,1,A,1,X,1,2,0)="Date wanted: "_Y_" #Units:"_$P(X(2),"^",4)_" Requestor:"_$P(X(2),"^",9)
34 S ^LRO(69.2,LRAA,8,66,1,A,1,X,1,3,0)="Request entered by: "_$P(^VA(200,DUZ,0),"^")
35 S X(3)=0,X(4)=3
36 I $D(^LR(LRDFN,1.8,A,2)) S X(3)=^(2) S:$P(X(3),"^")]"" X(4)=X(4)+1,^LRO(69.2,LRAA,8,66,1,A,1,X,1,X(4),0)=$P(X(3),"^") S:$P(X(3),"^",2)]"" X(4)=X(4)+1,^LRO(69.2,LRAA,8,66,1,A,1,X,1,X(4),0)="Approved by: "_$P(X(3),"^",2)
37 S Y=$P(X(3),"^",3) I Y,$D(^DIC(45.7,Y,0)) S Y=$P(^(0),"^"),Y(1)=^LRO(69.2,LRAA,8,66,1,A,1,X,1,1,0),^(0)=Y(1)_" Treating Specialty: "_Y
38 F B=0:0 S B=$O(C(A,B)) Q:'B F E=0:0 S E=$O(C(A,B,E)) Q:'E D C
39 I $D(LRK(A,1)) S X(4)=X(4)+1,^LRO(69.2,LRAA,8,66,1,A,1,X,1,X(4),0)=LRK(A,1)
40 S Y=^LRO(69.2,LRAA,8,66,1,A,1,X,1,0),^(0)=$P(Y,"^",1,2)_"^"_X(4)_"^"_X(4) Q
41C Q:'$D(S(B,E)) S Y=S(B,E),X(4)=X(4)+1,^LRO(69.2,LRAA,8,66,1,A,1,X,1,X(4),0)=$P(Y,"^",3)_" "_$P(Y,"^",2)_":"_$P(Y,"^")_" "_$P(Y,"^",4)_" "_$P(Y,"^",5) Q
Note: See TracBrowser for help on using the repository browser.