- 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 Mar 13, 2025@21:15:21 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
