LRBLPCS1 ;AVAMC/REG/CYM - COMPONENT SELECTION CK PT SPEC ;7/22/97 08:13 ;
;;5.2;LAB SERVICE;**1,72,90,247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
S (H,M)=0
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
I 'H,'M S H=$E(X(1),9,10),M=$E(X(1),11,12)
D D^LRUT S X=X_"."_$E("00",1,2-$L(H))_H_$E("00",1,2-$L(M))_M,G=9999999-X
; Following 10 lines check spec. age during LRBLPLOGIN
I '$D(LRQ) D
. 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)
. 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",!
. S Y="^" Q
I $D(LRQ) D
. 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)
. Q:'$D(LRCDT)
. N LRINVDT S LRINVDT=(9999999-LRCDT)
. 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",!
S Y="^" Q
;
EN ;
S:'$D(LRAA)#2 LRAA=$O(^LRO(68,"B","BLOOD BANK",0)) Q:'LRAA
I LRAA<1 S LRAA=$O(^LRO(68,"B","BLOOD BANK",0)) Q:'LRAA
I '$D(^LRO(69.2,LRAA,8,0)) S ^(0)="^69.31A^^"
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)
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
S:'$D(^LRO(69.2,LRAA,8,66,1,0)) ^(0)="^69.32A^^"
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
L -^LRO(69.2,LRAA,8,66) Q
B 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)=""
S:'$D(^LRO(69.2,LRAA,8,66,1,A,1,0)) ^(0)="^69.321DA^^" S X(1)=^(0),X=$P(X(1),"^",4)
A S X=X+1 G:$D(^LRO(69.2,LRAA,8,66,1,A,1,X,0)) A
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^^"
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)
S ^LRO(69.2,LRAA,8,66,1,A,1,X,1,3,0)="Request entered by: "_$P(^VA(200,DUZ,0),"^")
S X(3)=0,X(4)=3
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)
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
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
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)
S Y=^LRO(69.2,LRAA,8,66,1,A,1,X,1,0),^(0)=$P(Y,"^",1,2)_"^"_X(4)_"^"_X(4) Q
C 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPCS1 3510 printed Dec 13, 2024@02:11:45 Page 2
LRBLPCS1 ;AVAMC/REG/CYM - COMPONENT SELECTION CK PT SPEC ;7/22/97 08:13 ;
+1 ;;5.2;LAB SERVICE;**1,72,90,247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 SET (H,M)=0
+4 SET X=$PIECE(^LAB(66,C,0),"^",16)
if 'X
SET X=72
SET Z=X*60
SET X="N"
SET %DT="T"
DO ^%DT
KILL %DT
SET X=Y
SET X(1)=Y_"000"
DO H^%DTC
SET %H=%H-(Z\1440)
SET Z=Z#1440
IF Z
SET %H=%H-1
SET Z=1440-Z
SET H=Z\60
SET M=Z#60
+5 IF 'H
IF 'M
SET H=$EXTRACT(X(1),9,10)
SET M=$EXTRACT(X(1),11,12)
+6 DO D^LRUT
SET X=X_"."_$EXTRACT("00",1,2-$LENGTH(H))_H_$EXTRACT("00",1,2-$LENGTH(M))_M
SET G=9999999-X
+7 ; Following 10 lines check spec. age during LRBLPLOGIN
+8 IF '$DATA(LRQ)
Begin DoDot:1
+9 KILL Z
SET A=0
FOR B=0:0
SET B=$ORDER(^LR(LRDFN,"BB",B))
if 'B!(B>G)
QUIT
SET X=^(B,0)
SET S=$PIECE(X,"^",5)
IF S=LRBBSPEC
IF LRABV=$PIECE($PIECE(X,"^",6)," ")
SET Y=$PIECE(X,"^",10)
if 'Y
SET Y=+X
SET A=A+1
SET Z(A)=Y_"^"_B_"^"_$PIECE(X,"^",6)
if $DATA(LRJ)
QUIT
+10 IF '$DATA(Z)
IF '$DATA(LRQ)
WRITE $CHAR(7),!?18,"No patient blood sample within required time",!?9,"Obtain a new sample from the patient for compatibility testing",!
+11 SET Y="^"
QUIT
End DoDot:1
+12 IF $DATA(LRQ)
Begin DoDot:1
+13 KILL Z
SET A=0
FOR B=0:0
SET B=$ORDER(^LR(LRDFN,"BB",B))
if 'B!(B>G)
QUIT
SET X=^(B,0)
SET S=$PIECE(X,"^",5)
IF S=E
IF LRABV=$PIECE($PIECE(X,"^",6)," ")
SET Y=$PIECE(X,"^",10)
if 'Y
SET Y=+X
SET A=A+1
SET Z(A)=Y_"^"_B_"^"_$PIECE(X,"^",6)
if $DATA(LRJ)
QUIT
+14 if '$DATA(LRCDT)
QUIT
+15 NEW LRINVDT
SET LRINVDT=(9999999-LRCDT)
+16 IF LRINVDT>G
WRITE $CHAR(7),!,?18,"Log in specimen collection date/time NOT within required time",!,?9,"Obtain a new sample from the patient for compatibility testing",!
End DoDot:1
+17 SET Y="^"
QUIT
+18 ;
EN ;
+1 if '$DATA(LRAA)#2
SET LRAA=$ORDER(^LRO(68,"B","BLOOD BANK",0))
if 'LRAA
QUIT
+2 IF LRAA<1
SET LRAA=$ORDER(^LRO(68,"B","BLOOD BANK",0))
if 'LRAA
QUIT
+3 IF '$DATA(^LRO(69.2,LRAA,8,0))
SET ^(0)="^69.31A^^"
+4 IF '$DATA(^LRO(69.2,LRAA,8,66,0))
SET ^(0)=66
SET X=^LRO(69.2,LRAA,8,0)
SET ^(0)="^69.31A^66^"_($PIECE(X,"^",4)+1)
+5 LOCK +^LRO(69.2,LRAA,8,66):5
IF '$TEST
WRITE $CHAR(7),!!,"I Cannot add this request to the Inappropriate transfusion requests report at this time ",!!,"Please make note ...",!!
QUIT
+6 if '$DATA(^LRO(69.2,LRAA,8,66,1,0))
SET ^(0)="^69.32A^^"
+7 FOR A=0:0
SET A=$ORDER(LRK(A))
if 'A
QUIT
IF $DATA(^LR(LRDFN,1.8,A,0))
SET X(2)=^(0)
SET A(3)=$PIECE(X(2),"^",3)
SET Y=$PIECE(X(2),"^",5)
SET A(1)=$PIECE(^LAB(66,A,0),"^")
DO D^LRU
DO B
+8 LOCK -^LRO(69.2,LRAA,8,66)
QUIT
B IF '$DATA(^LRO(69.2,LRAA,8,66,1,A,0))
SET ^(0)=A(1)
SET X=^LRO(69.2,LRAA,8,66,1,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_A_"^"_($PIECE(X,"^",4)+1)
SET ^LRO(69.2,LRAA,8,66,1,"B",A(1),A)=""
+1 if '$DATA(^LRO(69.2,LRAA,8,66,1,A,1,0))
SET ^(0)="^69.321DA^^"
SET X(1)=^(0)
SET X=$PIECE(X(1),"^",4)
A SET X=X+1
if $DATA(^LRO(69.2,LRAA,8,66,1,A,1,X,0))
GOTO A
+1 SET ^LRO(69.2,LRAA,8,66,1,A,1,0)=$PIECE(X(1),"^",1,2)_"^"_X_"^"_($PIECE(X(1),"^",4)+1)
SET ^(X,0)=A(3)_"^"_PNM_"^"_SSN
SET ^(1,0)="^69.3211A^^"
+2 SET ^LRO(69.2,LRAA,8,66,1,A,1,X,1,1,0)="Pre-op:"_$SELECT($PIECE(X(2),"^",2):"Yes",1:"No")
SET ^LRO(69.2,LRAA,8,66,1,A,1,X,1,2,0)="Date wanted: "_Y_" #Units:"_$PIECE(X(2),"^",4)_" Requestor:"_$PIECE(X(2),"^",9)
+3 SET ^LRO(69.2,LRAA,8,66,1,A,1,X,1,3,0)="Request entered by: "_$PIECE(^VA(200,DUZ,0),"^")
+4 SET X(3)=0
SET X(4)=3
+5 IF $DATA(^LR(LRDFN,1.8,A,2))
SET X(3)=^(2)
if $PIECE(X(3),"^")]""
SET X(4)=X(4)+1
SET ^LRO(69.2,LRAA,8,66,1,A,1,X,1,X(4),0)=$PIECE(X(3),"^")
if $PIECE(X(3),"^",2)]""
SET X(4)=X(4)+1
SET ^LRO(69.2,LRAA,8,66,1,A,1,X,1,X(4),0)="Approved by: "_$PIECE(X(3),"^",2)
+6 SET Y=$PIECE(X(3),"^",3)
IF Y
IF $DATA(^DIC(45.7,Y,0))
SET Y=$PIECE(^(0),"^")
SET Y(1)=^LRO(69.2,LRAA,8,66,1,A,1,X,1,1,0)
SET ^(0)=Y(1)_" Treating Specialty: "_Y
+7 FOR B=0:0
SET B=$ORDER(C(A,B))
if 'B
QUIT
FOR E=0:0
SET E=$ORDER(C(A,B,E))
if 'E
QUIT
DO C
+8 IF $DATA(LRK(A,1))
SET X(4)=X(4)+1
SET ^LRO(69.2,LRAA,8,66,1,A,1,X,1,X(4),0)=LRK(A,1)
+9 SET Y=^LRO(69.2,LRAA,8,66,1,A,1,X,1,0)
SET ^(0)=$PIECE(Y,"^",1,2)_"^"_X(4)_"^"_X(4)
QUIT
C if '$DATA(S(B,E))
QUIT
SET Y=S(B,E)
SET X(4)=X(4)+1
SET ^LRO(69.2,LRAA,8,66,1,A,1,X,1,X(4),0)=$PIECE(Y,"^",3)_" "_$PIECE(Y,"^",2)_":"_$PIECE(Y,"^")_" "_$PIECE(Y,"^",4)_" "_$PIECE(Y,"^",5)
QUIT
