LRBLJA ;AVAMC/REG/CYM - BB INVENTORY DATA ENTRY ;10/24/96 19:20 ;
;;5.2;LAB SERVICE;**72,90,247,408**;Sep 27, 1994;Build 8
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
SET K DR,DA,LR("CK") D:'$D(LRAA) Z W ! S (DIC,DIE)="^LRD(65,",DIC(0)="AEFQMZ",DIC("S")="I $P(^(0),U,16)=DUZ(2)" D ^DIC K DIC Q:Y<1 S DA=+Y Q
S Q W ! S DIC=66,X="TYPING CHARGE",DIC(0)="X" D ^DIC I Y<1 W !," 'TYPING CHARGE' entry not in BLOOD PRODUCT File",!!,"Inform Blood Bank Supervisor",! Q
S W=$S($D(^LAB(66,+Y,"SU",1,0)):$P(^(0),"^",2),1:"")
D SET G:Y<1 END D CK^LRU G:$D(LR("CK")) S S DR=".12//"_W D ^DIE D FRE^LRU K DIC,DIE,DR G S
A Q D Z G:Y=-1 END S LRF=0
I LRCAPA W !!,"Enter 'YES' to record results and workload or 'NO' to record only results:",!,"Was testing performed at this facility " S %="" D YN^LRU G:%<1 END S:%=1 LRF=1 S X="UNIT PHENOTYPING",X("NOCODES")=1 D X^LRUWK G:'$D(X) END
B S LR("SLAM")=0 D L^LRU,SET G:Y<1 END D CK^LRU G:$D(LR("CK")) B D P^LRBLJA1 S (LR,LRD)=0,DR="[LRBLIAG]" W ! D ^DIE D FRE^LRU D:LRF ^LRBLJA1 I $D(^LRD(65,LR,0)),$P(^(0),"^",2)="SELF" S LRB=$P(^(0),"^"),LRD=$O(^LRE("C",LRB,0))
F Q:LR("SLAM")=1 F LRW=0:0 S LRW=$O(LRW(LRW)) Q:'LRW F M=0:0 S M=$O(LRW(LRW,M)) Q:'M D ST,CLNP
I LR("SLAM")=1 Q
F LRW=60,70,80,90 D
. S M=0 F S M=$O(^LRD(65,LR,LRW,M)) Q:'M D ST,CK
D:LRD CMV K A,B,C,M,LR,LRD,LRW,O,LR,LRS G B
CLNP I '$D(^LRD(65,LR,LRW,M)) D K Q:LR("SLAM")=1 S O=M,X="deleted",Z=LRW(LRW,M)_",.01" D EN^LRUD Q
Q
CK Q:LRD'>0 Q:LR("SLAM")=1 Q:$D(^LRE(LRD,LRS,M,0))
I $D(^LRE(LRD,LRO,M,0)) W $C(7),!!,$P(^LAB(61.3,M,0),U)," entered for ",$P(^LRE(LRD,0),U),!,"in donor file as ",$P(^DD(+$P(^LRE(LRD,LRO,0),U,2),.01,0),U),!,"Recheck donor and inventory phenotyping.",!! Q
I '$D(^LRE(LRD,LRS,0)) S ^(0)="^"_65.5_$S(LRS=1.1:6,LRS=1.2:7,LRS=1.3:8,1:9)_"PA^^"
L +^LRE(LRD,LRS):5 I '$T W $C(7),!,"I can't ADD the Antigen typings to the Donor File. Someone else is editing this record.",!!,"Use the Donor-Donor phenotyping option to enter typing results to the appropriate donor",!! S LR("SLAM")=1 Q
S V=^LRE(LRD,LRS,0),^(0)=$P(V,"^",1,2)_"^"_M_"^"_($P(V,"^",4)+1)
S ^LRE(LRD,LRS,M,0)=M L -^LRE(LRD,LRS) Q
;
K Q:LRD'>0 Q:'$D(^LRE(LRD,LRS,M))
L +^LRE(LRD,LRS):5 I '$T W $C(7),!,"I can't DELETE the Antigen Typing FOR the Donor. Someone else is editing the record",!!,"Use the Donor-Donor phenotyping option to update the donor's phenotype",! S LR("SLAM")=1 Q
K ^LRE(LRD,LRS,M,0)
S V(1)=$O(^LRE(LRD,LRS,0)),V=^(0),Z=+$P(V,"^",2),^(0)=$P(V,"^",1,2)_"^"_V(1)_"^"_$S(V(1)="":"",1:($P(V,"^",4)-1)) L -^LRE(LRD,LRS)
S LRC=DA,LRC(1)=DA(1),DA(1)=LRD,(O,DA)=M,X="deleted",Z=Z_",.01" D EN^LRUD S DA=LRC,DA(1)=LRC(1) Q
;
Z S LR("M")=1,X="BLOOD BANK" D ^LRUTL W:Y'=-1 !?20,LRAA(4) Q
ST S LRS=$S(LRW=60:"1.1;1.2",LRW=70:"1.2;1.1",LRW=80:"1.3;1.4",1:"1.4;1.3"),LRO=$P(LRS,";",2),LRS=$P(LRS,";") Q
CMV S M=$P(^LRD(65,LR,0),"^",15) Q:M="" F M(2)=0:0 S M(2)=$O(^LRD(65,"B",LRB,M(2))) Q:'M(2) I M(2)'=LR S $P(^LRD(65,M(2),0),"^",15)=M
S M(1)=$P(^LRE(LRD,0),"^",15) Q:M(1)=M I M(1)="" S $P(^(0),"^",15)=M Q
W $C(7),!!,"Inventory unit:",$P(^LRD(65,LR,0),"^"),?38,"CMV ANTIBODY ",$S(M:"PRESENT",1:"ABSENT"),!,"Donor ",$P(^LRE(LRD,0),"^"),?38,"CMV ANTIBODY ",$S(M(1):"PRESENT",1:"ABSENT")
W !!,"Recheck donor and inventory unit CMV ANTIBODY testing." Q
T ;transfer unit to another division
Q D SET G:Y<1 END D CK^LRU G:$D(LR("CK")) T S LRO=$P(^LRD(65,DA,0),U,16),DR=".16" D ^DIE,FRE^LRU K DIC,DIE,DR S LRN=$P(^LRD(65,DA,0),U,16) D:LRO'=LRN AD G T
AD S LRO=$P($G(^DIC(4,+LRO,0)),U),LRN=$P($G(^DIC(4,LRN,0)),U),LRW=$P($G(^VA(200,+DUZ,0)),U)
S %DT="ETX",X="N" D ^%DT K %DT S A=$P($H,",")_$P($H,",",2)
S:'$D(^LRD(65,DA,999,0)) ^(0)="^65.099DA^^" S X=^(0),^(0)=$P(X,"^",1,2)_"^"_A_"^"_($P(X,"^",4)+1),^(A,0)=Y_"^"_LRW_"^DIVISION^"_LRO_"^"_LRN Q
Q
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJA 3862 printed Nov 22, 2024@17:21:06 Page 2
LRBLJA ;AVAMC/REG/CYM - BB INVENTORY DATA ENTRY ;10/24/96 19:20 ;
+1 ;;5.2;LAB SERVICE;**72,90,247,408**;Sep 27, 1994;Build 8
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
SET KILL DR,DA,LR("CK")
if '$DATA(LRAA)
DO Z
WRITE !
SET (DIC,DIE)="^LRD(65,"
SET DIC(0)="AEFQMZ"
SET DIC("S")="I $P(^(0),U,16)=DUZ(2)"
DO ^DIC
KILL DIC
if Y<1
QUIT
SET DA=+Y
QUIT
S QUIT
WRITE !
SET DIC=66
SET X="TYPING CHARGE"
SET DIC(0)="X"
DO ^DIC
IF Y<1
WRITE !," 'TYPING CHARGE' entry not in BLOOD PRODUCT File",!!,"Inform Blood Bank Supervisor",!
QUIT
+1 SET W=$SELECT($DATA(^LAB(66,+Y,"SU",1,0)):$PIECE(^(0),"^",2),1:"")
+2 DO SET
if Y<1
GOTO END
DO CK^LRU
if $DATA(LR("CK"))
GOTO S
SET DR=".12//"_W
DO ^DIE
DO FRE^LRU
KILL DIC,DIE,DR
GOTO S
A QUIT
DO Z
if Y=-1
GOTO END
SET LRF=0
+1 IF LRCAPA
WRITE !!,"Enter 'YES' to record results and workload or 'NO' to record only results:",!,"Was testing performed at this facility "
SET %=""
DO YN^LRU
if %<1
GOTO END
if %=1
SET LRF=1
SET X="UNIT PHENOTYPING"
SET X("NOCODES")=1
DO X^LRUWK
if '$DATA(X)
GOTO END
B SET LR("SLAM")=0
DO L^LRU
DO SET
if Y<1
GOTO END
DO CK^LRU
if $DATA(LR("CK"))
GOTO B
DO P^LRBLJA1
SET (LR,LRD)=0
SET DR="[LRBLIAG]"
WRITE !
DO ^DIE
DO FRE^LRU
if LRF
DO ^LRBLJA1
IF $DATA(^LRD(65,LR,0))
IF $PIECE(^(0),"^",2)="SELF"
SET LRB=$PIECE(^(0),"^")
SET LRD=$ORDER(^LRE("C",LRB,0))
F if LR("SLAM")=1
QUIT
FOR LRW=0:0
SET LRW=$ORDER(LRW(LRW))
if 'LRW
QUIT
FOR M=0:0
SET M=$ORDER(LRW(LRW,M))
if 'M
QUIT
DO ST
DO CLNP
+1 IF LR("SLAM")=1
QUIT
+2 FOR LRW=60,70,80,90
Begin DoDot:1
+3 SET M=0
FOR
SET M=$ORDER(^LRD(65,LR,LRW,M))
if 'M
QUIT
DO ST
DO CK
End DoDot:1
+4 if LRD
DO CMV
KILL A,B,C,M,LR,LRD,LRW,O,LR,LRS
GOTO B
CLNP IF '$DATA(^LRD(65,LR,LRW,M))
DO K
if LR("SLAM")=1
QUIT
SET O=M
SET X="deleted"
SET Z=LRW(LRW,M)_",.01"
DO EN^LRUD
QUIT
+1 QUIT
CK if LRD'>0
QUIT
if LR("SLAM")=1
QUIT
if $DATA(^LRE(LRD,LRS,M,0))
QUIT
+1 IF $DATA(^LRE(LRD,LRO,M,0))
WRITE $CHAR(7),!!,$PIECE(^LAB(61.3,M,0),U)," entered for ",$PIECE(^LRE(LRD,0),U),!,"in donor file as ",$PIECE(^DD(+$PIECE(^LRE(LRD,LRO,0),U,2),.01,0),U),!,"Recheck donor and inventory phenotyping.",!!
QUIT
+2 IF '$DATA(^LRE(LRD,LRS,0))
SET ^(0)="^"_65.5_$SELECT(LRS=1.1:6,LRS=1.2:7,LRS=1.3:8,1:9)_"PA^^"
+3 LOCK +^LRE(LRD,LRS):5
IF '$TEST
WRITE $CHAR(7),!,"I can't ADD the Antigen typings to the Donor File. Someone else is editing this record.",!!,"Use the Donor-Donor phenotyping option to enter typing results to the appropriate donor",!!
SET LR("SLAM")=1
QUIT
+4 SET V=^LRE(LRD,LRS,0)
SET ^(0)=$PIECE(V,"^",1,2)_"^"_M_"^"_($PIECE(V,"^",4)+1)
+5 SET ^LRE(LRD,LRS,M,0)=M
LOCK -^LRE(LRD,LRS)
QUIT
+6 ;
K if LRD'>0
QUIT
if '$DATA(^LRE(LRD,LRS,M))
QUIT
+1 LOCK +^LRE(LRD,LRS):5
IF '$TEST
WRITE $CHAR(7),!,"I can't DELETE the Antigen Typing FOR the Donor. Someone else is editing the record",!!,"Use the Donor-Donor phenotyping option to update the donor's phenotype",!
SET LR("SLAM")=1
QUIT
+2 KILL ^LRE(LRD,LRS,M,0)
+3 SET V(1)=$ORDER(^LRE(LRD,LRS,0))
SET V=^(0)
SET Z=+$PIECE(V,"^",2)
SET ^(0)=$PIECE(V,"^",1,2)_"^"_V(1)_"^"_$SELECT(V(1)="":"",1:($PIECE(V,"^",4)-1))
LOCK -^LRE(LRD,LRS)
+4 SET LRC=DA
SET LRC(1)=DA(1)
SET DA(1)=LRD
SET (O,DA)=M
SET X="deleted"
SET Z=Z_",.01"
DO EN^LRUD
SET DA=LRC
SET DA(1)=LRC(1)
QUIT
+5 ;
Z SET LR("M")=1
SET X="BLOOD BANK"
DO ^LRUTL
if Y'=-1
WRITE !?20,LRAA(4)
QUIT
ST SET LRS=$SELECT(LRW=60:"1.1;1.2",LRW=70:"1.2;1.1",LRW=80:"1.3;1.4",1:"1.4;1.3")
SET LRO=$PIECE(LRS,";",2)
SET LRS=$PIECE(LRS,";")
QUIT
CMV SET M=$PIECE(^LRD(65,LR,0),"^",15)
if M=""
QUIT
FOR M(2)=0:0
SET M(2)=$ORDER(^LRD(65,"B",LRB,M(2)))
if 'M(2)
QUIT
IF M(2)'=LR
SET $PIECE(^LRD(65,M(2),0),"^",15)=M
+1 SET M(1)=$PIECE(^LRE(LRD,0),"^",15)
if M(1)=M
QUIT
IF M(1)=""
SET $PIECE(^(0),"^",15)=M
QUIT
+2 WRITE $CHAR(7),!!,"Inventory unit:",$PIECE(^LRD(65,LR,0),"^"),?38,"CMV ANTIBODY ",$SELECT(M:"PRESENT",1:"ABSENT"),!,"Donor ",$PIECE(^LRE(LRD,0),"^"),?38,"CMV ANTIBODY ",$SELECT(M(1):"PRESENT",1:"ABSENT")
+3 WRITE !!,"Recheck donor and inventory unit CMV ANTIBODY testing."
QUIT
T ;transfer unit to another division
+1 QUIT
DO SET
if Y<1
GOTO END
DO CK^LRU
if $DATA(LR("CK"))
GOTO T
SET LRO=$PIECE(^LRD(65,DA,0),U,16)
SET DR=".16"
DO ^DIE
DO FRE^LRU
KILL DIC,DIE,DR
SET LRN=$PIECE(^LRD(65,DA,0),U,16)
if LRO'=LRN
DO AD
GOTO T
AD SET LRO=$PIECE($GET(^DIC(4,+LRO,0)),U)
SET LRN=$PIECE($GET(^DIC(4,LRN,0)),U)
SET LRW=$PIECE($GET(^VA(200,+DUZ,0)),U)
+1 SET %DT="ETX"
SET X="N"
DO ^%DT
KILL %DT
SET A=$PIECE($HOROLOG,",")_$PIECE($HOROLOG,",",2)
+2 if '$DATA(^LRD(65,DA,999,0))
SET ^(0)="^65.099DA^^"
SET X=^(0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_A_"^"_($PIECE(X,"^",4)+1)
SET ^(A,0)=Y_"^"_LRW_"^DIVISION^"_LRO_"^"_LRN
QUIT
+3 QUIT
END DO V^LRU
QUIT
