- 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 Feb 18, 2025@23:37:38 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
