LRBLJLG ;AVAMC/REG/CYM - BB INVENTORY LOG-IN 11/12/96 07:49 ; 11/22/00 2:21pm
;;5.2;LAB SERVICE;**72,139,247,267,408**;Sep 27, 1994;Build 8
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
Q D END I '$G(DUZ(2)) W $C(7),!,"I need to know the name of your site (In the INSTITUTION file)." G END
S LR("M")=1,X="BLOOD BANK" D ^LRUTL G:Y=-1 END K LRDPAF
W !!?28,"Blood Component Log-In",!!?15,"Division: ",LRAA(4) D BAR^LRBLB
I LRCAPA S X="UNIT LOG-IN/SEND-OUT" D X^LRUWK G:'$D(X) END D S^LRBLW
I R !!,"Enter INVOICE (or order) NUMBER: ",X:DTIME G:X=""!(X[U) END S LRI=X D
. N IPTR,HLP D FIELD^DID(65,.03,"","INPUT TRANSFORM","IPTR") S IPTR=IPTR("INPUT TRANSFORM") X IPTR I $D(X),X["?" K X
. I '$D(X) D FIELD^DID(65,.03,"","HELP-PROMPT","HLP") S HLP=HLP("HELP-PROMPT") W !!,$C(7),HLP
I '$D(X) G I
D R !,"DATE/TIME RECEIVED: NOW// ",X:DTIME G:X[U!'$T END S:X="" X="N" S %DT="ETX",%DT(0)="-N" D ^%DT K %DT S LRK=Y I Y<1!('$P(Y,".",2)) W $C(7),!,"Must enter a TIME. Future DATE/TIME not allowed.",! G D
C K LRL,X S LRC="",LRL=0 W !!,"Invoice number: ",LRI,! S X=$$READ^LRBLB("Select BLOOD COMPONENT: ") G:X=""!(X[U) I
I LR,$E(X,1,$L(LR(2)))=LR(2) D P^LRBLB I '$D(X) W $C(7),!,"Code not entered in BLOOD PRODUCT file or not product label.",! G C
W:'LR $$STRIP^LRBLB(.X) ; Remove data identifiers just in case
W ! I LRC="" S DIC=66,DIC(0)="EQMZ",DIC("S")="I $P(^(0),U,4)=""BB""" D ^DIC K DIC G I:X=""!(X[U),C:X["?"!(Y<1) S LRC=+Y,P=$P(Y,U,2),LRR=$P(Y(0),U,19),LRV=$P(Y(0),U,10),Z=$P(Y(0),U,25),LRJ=$S(Z=1:"A",Z=2:"D",1:""),LRBLISBT=+$P(Y(0),U,29)
S X(1)=+$O(^LAB(66,LRC,"SU",0)) I X(1)<1 W $C(7),!!,"Must have at least one supplier for this component",!,"Please have appropriate person enter supplier(s) in ",$P(^LAB(66,0),U)," FILE (#66)",! G C
S DIC="^LAB(66,"_LRC_",""SU"",",DIC(0)="AEQMZ",DIC("B")=$P(@(DIC_X(1)_",0)"),U) D ^DIC K DIC G:X=""!(X[U) C S LRW=$P(Y,U,2),LRM=$P(Y(0),U,2),LR(1)=$P(Y(0),"^",10),LR(3)=$P(Y(0),U,12),LR(4)=$L(LR(1))+1 K Y
D EN^LRBLJLG1
N IPTR,HLP S DA=0 D FIELD^DID(65,.01,"","INPUT TRANSFORM","IPTR") S IPTR=IPTR("INPUT TRANSFORM")
D FIELD^DID(65,.01,"","HELP-PROMPT","HLP") S HLP=HLP("HELP-PROMPT")
E W !! S X=$$READ^LRBLB("UNIT ID: ",13) I X=""!(X[U) D ^LRBLJLG1 G C
I LR,$E(X,1,$L(LR(2)))=LR(2) D U^LRBLB
W:'LR $$STRIP^LRBLB(.X) ; Remove data identifiers just in case
I X[" " W $C(7)," No spaces allowed." G E
I X["?" W $C(7)," Enter the Unit ID Without the Prefix" G E
X IPTR I $D(X),X["?" K X G E
I '$D(X) W !!,$C(7),HLP G E
S:'LRBLISBT X=LR(1)_X ;concatinate supplier prefix #
S LRP=X,DIC=65,DIC(0)="EFMXZ" D ^DIC K DIC S DA=+Y,W=$S($D(Y(0)):Y(0),1:"")
I Y'>1 F C=0:0 S C=$O(^LRD(65,"B",X,C)) Q:'C I $D(^LRD(65,C,0)),$P(^(0),"^",4)=LRC W $C(7),!!,"I might have that unit already in inventory. Let's try that again ",! G E
I Y>0 S X=$P(Y(0),U) F C=0:0 S C=$O(^LRD(65,"B",X,C)) Q:'C I $D(^LRD(65,C,0)),$P(^(0),"^",4)=LRC W $C(7),!,$P(^LAB(66,LRC,0),U)," already in inventory with same Unit ID !" D EN1^LRBLJLG1 K Y G E
K Y(0) I Y>0 W $C(7),!,"Entry in INVENTORY file.",!,"Add ",P," for this DONOR ID# " S %=2 D YN^LRU G:%'=1 E W !!,"Are you SURE ? " S %=2 D YN^LRU G:%'=1 E S LRABO=$P(W,U,7),LRRH=$P(W,U,8) G ED
A K X S (LRABO,LRRH)="" W ! S X=$$READ^LRBLB("ABO/Rh: ",14) G:X=""!(X[U) E
I LR,$E(X,1,$L(LR(2)))=LR(2) D A^LRBLB I '$D(X) W !,$C(7),"No such ABO/Rh bar code",!! G A
I LRABO="" W $$STRIP^LRBLB(.X) D T^LRBLB G:'$D(X) A
ED S (LRA,LRH)="" W ! S X=$$READ^LRBLB("EXPIRATION DATE/TIME: ") G:X=""!(X[U) E
I LR,$E(X,1,$L(LR(2)))=LR(2) D D^LRBLB I '$D(X) W $C(7),!,"Not Date bar code",! G ED
W:'LR $$STRIP^LRBLB(.X) ; Remove data identifiers just in case
I 'LRH S %DT="ETX" D ^%DT K %DT G ED:X["?",E:Y<1 S LRH=Y
I LRS,LRH>LRS W $C(7),!?4,"Expiration date exceeds allowable limit !" G ED
L +^LRD(65,0):8 I '$T W $C(7),!!,"We can't do this right now...",!!,"Someone else is creating a new entry in the INVENTORY file ",!!,"Try again..",!! G E
S (UNIT,TYPE)=""
I $D(^LRD(65,"B",LRP)) S UNIT=$O(^LRD(65,"B",LRP,0)) D
. S TYPE=$P($G(^LRD(65,UNIT,0)),U,4) I TYPE=LRC D
.. W $C(7),!!,"I think someone else is trying to log this unit in" K UNIT,TYPE L -^LRD(65,0)
I '$D(UNIT) G E
S DA=+$P(^LRD(65,0),"^",3) F S DA=DA+1 Q:'$D(^LRD(65,DA))
L +^LRD(65,DA):1 I '$T W $C(7),!!,"Can't do this now...",!!,"Looks like 2 of you are creating the same record.",!!,"Try again..." G E
S ^LRD(65,DA,0)=LRP,^LRD(65,"B",LRP,DA)="",^LRD(65,0)="BLOOD INVENTORY^65I^"_DA_"^"_($P(^LRD(65,0),"^",4)+1)
L -^LRD(65,0)
S:LR(4)>1 ^LRD(65,"C",$E(LRP,LR(4),$L(LRP)),DA)=""
S DIE="^LRD(65,",DIE("NO^")="OUTOK",(^LRD(65,"AT",LRP,10,DA),^LRD(65,"AT",LRP,11,DA))=""
S DR=".02///"_LRW_";.03///"_LRI_";.04////"_LRC_";.05///"_LRK_";.09////"_DUZ_";.1///"_LRM_";.11///"_LRV_";.07///"_LRABO_";.08///"_LRRH_";.06///"_LRH_";.16////"_DUZ(2) D ^DIE
I LRJ]"" S DR="8;I X="""" D H^LRBLJLG S Y=8;8.1;I X="""" D H^LRBLJLG S Y=8.1;8.3///"_LRJ D ^DIE I $D(Y) W $C(7),!!,"Entry deleted." S DIK="^LRD(65," D ^DIK K DIK G E
D:LRR=1 S S LRL=LRL+1,LRL(LRL)=DA_"^"_LRP_"^"_LRABO_"^"_LRRH_"^"_LRH_"^"_LRA_"^"_LRC G E
;
S S:'$D(^LRO(69.2,LRAA,6,0)) ^(0)="^69.26A^^"
L +^LRO(69.2,LRAA,6):5 I '$T W $C(7),!!,"I can't add this to the ABO/Rh typing worksheet",!!,"Someone else is editing that worksheet",!!,"Add this unit Manually when printing the ABO/Rh typing worksheet",!! Q
S X=^LRO(69.2,LRAA,6,0)
S ^LRO(69.2,LRAA,6,DA,0)=DA,^LRO(69.2,LRAA,6,0)="^69.26A^"_DA_"^"_($P(X,"^",4)+1) L -^LRO(69.2,LRAA,6) Q
H W $C(7),!!,"Answer prompt. To quit enter '^' and unit will be deleted.",! Q
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJLG 5629 printed Dec 13, 2024@02:11:15 Page 2
LRBLJLG ;AVAMC/REG/CYM - BB INVENTORY LOG-IN 11/12/96 07:49 ; 11/22/00 2:21pm
+1 ;;5.2;LAB SERVICE;**72,139,247,267,408**;Sep 27, 1994;Build 8
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 QUIT
DO END
IF '$GET(DUZ(2))
WRITE $CHAR(7),!,"I need to know the name of your site (In the INSTITUTION file)."
GOTO END
+4 SET LR("M")=1
SET X="BLOOD BANK"
DO ^LRUTL
if Y=-1
GOTO END
KILL LRDPAF
+5 WRITE !!?28,"Blood Component Log-In",!!?15,"Division: ",LRAA(4)
DO BAR^LRBLB
+6 IF LRCAPA
SET X="UNIT LOG-IN/SEND-OUT"
DO X^LRUWK
if '$DATA(X)
GOTO END
DO S^LRBLW
I READ !!,"Enter INVOICE (or order) NUMBER: ",X:DTIME
if X=""!(X[U)
GOTO END
SET LRI=X
Begin DoDot:1
+1 NEW IPTR,HLP
DO FIELD^DID(65,.03,"","INPUT TRANSFORM","IPTR")
SET IPTR=IPTR("INPUT TRANSFORM")
XECUTE IPTR
IF $DATA(X)
IF X["?"
KILL X
+2 IF '$DATA(X)
DO FIELD^DID(65,.03,"","HELP-PROMPT","HLP")
SET HLP=HLP("HELP-PROMPT")
WRITE !!,$CHAR(7),HLP
End DoDot:1
+3 IF '$DATA(X)
GOTO I
D READ !,"DATE/TIME RECEIVED: NOW// ",X:DTIME
if X[U!'$TEST
GOTO END
if X=""
SET X="N"
SET %DT="ETX"
SET %DT(0)="-N"
DO ^%DT
KILL %DT
SET LRK=Y
IF Y<1!('$PIECE(Y,".",2))
WRITE $CHAR(7),!,"Must enter a TIME. Future DATE/TIME not allowed.",!
GOTO D
C KILL LRL,X
SET LRC=""
SET LRL=0
WRITE !!,"Invoice number: ",LRI,!
SET X=$$READ^LRBLB("Select BLOOD COMPONENT: ")
if X=""!(X[U)
GOTO I
+1 IF LR
IF $EXTRACT(X,1,$LENGTH(LR(2)))=LR(2)
DO P^LRBLB
IF '$DATA(X)
WRITE $CHAR(7),!,"Code not entered in BLOOD PRODUCT file or not product label.",!
GOTO C
+2 ; Remove data identifiers just in case
if 'LR
WRITE $$STRIP^LRBLB(.X)
+3 WRITE !
IF LRC=""
SET DIC=66
SET DIC(0)="EQMZ"
SET DIC("S")="I $P(^(0),U,4)=""BB"""
DO ^DIC
KILL DIC
if X=""!(X[U)
GOTO I
if X["?"!(Y<1)
GOTO C
SET LRC=+Y
SET P=$PIECE(Y,U,2)
SET LRR=$PIECE(Y(0),U,19)
SET LRV=$PIECE(Y(0),U,10)
SET Z=$PIECE(Y(0),U,25)
SET LRJ=$SELECT(Z=1:"A",Z=2:"D",1:"")
SET LRBLISBT=+$PIECE(Y(0),U,29)
+4 SET X(1)=+$ORDER(^LAB(66,LRC,"SU",0))
IF X(1)<1
WRITE $CHAR(7),!!,"Must have at least one supplier for this component",!,"Please have appropriate person enter supplier(s) in ",$PIECE(^LAB(66,0),U)," FILE (#66)",!
GOTO C
+5 SET DIC="^LAB(66,"_LRC_",""SU"","
SET DIC(0)="AEQMZ"
SET DIC("B")=$PIECE(@(DIC_X(1)_",0)"),U)
DO ^DIC
KILL DIC
if X=""!(X[U)
GOTO C
SET LRW=$PIECE(Y,U,2)
SET LRM=$PIECE(Y(0),U,2)
SET LR(1)=$PIECE(Y(0),"^",10)
SET LR(3)=$PIECE(Y(0),U,12)
SET LR(4)=$LENGTH(LR(1))+1
KILL Y
+6 DO EN^LRBLJLG1
+7 NEW IPTR,HLP
SET DA=0
DO FIELD^DID(65,.01,"","INPUT TRANSFORM","IPTR")
SET IPTR=IPTR("INPUT TRANSFORM")
+8 DO FIELD^DID(65,.01,"","HELP-PROMPT","HLP")
SET HLP=HLP("HELP-PROMPT")
E WRITE !!
SET X=$$READ^LRBLB("UNIT ID: ",13)
IF X=""!(X[U)
DO ^LRBLJLG1
GOTO C
+1 IF LR
IF $EXTRACT(X,1,$LENGTH(LR(2)))=LR(2)
DO U^LRBLB
+2 ; Remove data identifiers just in case
if 'LR
WRITE $$STRIP^LRBLB(.X)
+3 IF X[" "
WRITE $CHAR(7)," No spaces allowed."
GOTO E
+4 IF X["?"
WRITE $CHAR(7)," Enter the Unit ID Without the Prefix"
GOTO E
+5 XECUTE IPTR
IF $DATA(X)
IF X["?"
KILL X
GOTO E
+6 IF '$DATA(X)
WRITE !!,$CHAR(7),HLP
GOTO E
+7 ;concatinate supplier prefix #
if 'LRBLISBT
SET X=LR(1)_X
+8 SET LRP=X
SET DIC=65
SET DIC(0)="EFMXZ"
DO ^DIC
KILL DIC
SET DA=+Y
SET W=$SELECT($DATA(Y(0)):Y(0),1:"")
+9 IF Y'>1
FOR C=0:0
SET C=$ORDER(^LRD(65,"B",X,C))
if 'C
QUIT
IF $DATA(^LRD(65,C,0))
IF $PIECE(^(0),"^",4)=LRC
WRITE $CHAR(7),!!,"I might have that unit already in inventory. Let's try that again ",!
GOTO E
+10 IF Y>0
SET X=$PIECE(Y(0),U)
FOR C=0:0
SET C=$ORDER(^LRD(65,"B",X,C))
if 'C
QUIT
IF $DATA(^LRD(65,C,0))
IF $PIECE(^(0),"^",4)=LRC
WRITE $CHAR(7),!,$PIECE(^LAB(66,LRC,0),U)," already in inventory with same Unit ID !"
DO EN1^LRBLJLG1
KILL Y
GOTO E
+11 KILL Y(0)
IF Y>0
WRITE $CHAR(7),!,"Entry in INVENTORY file.",!,"Add ",P," for this DONOR ID# "
SET %=2
DO YN^LRU
if %'=1
GOTO E
WRITE !!,"Are you SURE ? "
SET %=2
DO YN^LRU
if %'=1
GOTO E
SET LRABO=$PIECE(W,U,7)
SET LRRH=$PIECE(W,U,8)
GOTO ED
A KILL X
SET (LRABO,LRRH)=""
WRITE !
SET X=$$READ^LRBLB("ABO/Rh: ",14)
if X=""!(X[U)
GOTO E
+1 IF LR
IF $EXTRACT(X,1,$LENGTH(LR(2)))=LR(2)
DO A^LRBLB
IF '$DATA(X)
WRITE !,$CHAR(7),"No such ABO/Rh bar code",!!
GOTO A
+2 IF LRABO=""
WRITE $$STRIP^LRBLB(.X)
DO T^LRBLB
if '$DATA(X)
GOTO A
ED SET (LRA,LRH)=""
WRITE !
SET X=$$READ^LRBLB("EXPIRATION DATE/TIME: ")
if X=""!(X[U)
GOTO E
+1 IF LR
IF $EXTRACT(X,1,$LENGTH(LR(2)))=LR(2)
DO D^LRBLB
IF '$DATA(X)
WRITE $CHAR(7),!,"Not Date bar code",!
GOTO ED
+2 ; Remove data identifiers just in case
if 'LR
WRITE $$STRIP^LRBLB(.X)
+3 IF 'LRH
SET %DT="ETX"
DO ^%DT
KILL %DT
if X["?"
GOTO ED
if Y<1
GOTO E
SET LRH=Y
+4 IF LRS
IF LRH>LRS
WRITE $CHAR(7),!?4,"Expiration date exceeds allowable limit !"
GOTO ED
+5 LOCK +^LRD(65,0):8
IF '$TEST
WRITE $CHAR(7),!!,"We can't do this right now...",!!,"Someone else is creating a new entry in the INVENTORY file ",!!,"Try again..",!!
GOTO E
+6 SET (UNIT,TYPE)=""
+7 IF $DATA(^LRD(65,"B",LRP))
SET UNIT=$ORDER(^LRD(65,"B",LRP,0))
Begin DoDot:1
+8 SET TYPE=$PIECE($GET(^LRD(65,UNIT,0)),U,4)
IF TYPE=LRC
Begin DoDot:2
+9 WRITE $CHAR(7),!!,"I think someone else is trying to log this unit in"
KILL UNIT,TYPE
LOCK -^LRD(65,0)
End DoDot:2
End DoDot:1
+10 IF '$DATA(UNIT)
GOTO E
+11 SET DA=+$PIECE(^LRD(65,0),"^",3)
FOR
SET DA=DA+1
if '$DATA(^LRD(65,DA))
QUIT
+12 LOCK +^LRD(65,DA):1
IF '$TEST
WRITE $CHAR(7),!!,"Can't do this now...",!!,"Looks like 2 of you are creating the same record.",!!,"Try again..."
GOTO E
+13 SET ^LRD(65,DA,0)=LRP
SET ^LRD(65,"B",LRP,DA)=""
SET ^LRD(65,0)="BLOOD INVENTORY^65I^"_DA_"^"_($PIECE(^LRD(65,0),"^",4)+1)
+14 LOCK -^LRD(65,0)
+15 if LR(4)>1
SET ^LRD(65,"C",$EXTRACT(LRP,LR(4),$LENGTH(LRP)),DA)=""
+16 SET DIE="^LRD(65,"
SET DIE("NO^")="OUTOK"
SET (^LRD(65,"AT",LRP,10,DA),^LRD(65,"AT",LRP,11,DA))=""
+17 SET DR=".02///"_LRW_";.03///"_LRI_";.04////"_LRC_";.05///"_LRK_";.09////"_DUZ_";.1///"_LRM_";.11///"_LRV_";.07///"_LRABO_";.08///"_LRRH_";.06///"_LRH_";.16////"_DUZ(2)
DO ^DIE
+18 IF LRJ]""
SET DR="8;I X="""" D H^LRBLJLG S Y=8;8.1;I X="""" D H^LRBLJLG S Y=8.1;8.3///"_LRJ
DO ^DIE
IF $DATA(Y)
WRITE $CHAR(7),!!,"Entry deleted."
SET DIK="^LRD(65,"
DO ^DIK
KILL DIK
GOTO E
+19 if LRR=1
DO S
SET LRL=LRL+1
SET LRL(LRL)=DA_"^"_LRP_"^"_LRABO_"^"_LRRH_"^"_LRH_"^"_LRA_"^"_LRC
GOTO E
+20 ;
S if '$DATA(^LRO(69.2,LRAA,6,0))
SET ^(0)="^69.26A^^"
+1 LOCK +^LRO(69.2,LRAA,6):5
IF '$TEST
WRITE $CHAR(7),!!,"I can't add this to the ABO/Rh typing worksheet",!!,"Someone else is editing that worksheet",!!,"Add this unit Manually when printing the ABO/Rh typing worksheet",!!
QUIT
+2 SET X=^LRO(69.2,LRAA,6,0)
+3 SET ^LRO(69.2,LRAA,6,DA,0)=DA
SET ^LRO(69.2,LRAA,6,0)="^69.26A^"_DA_"^"_($PIECE(X,"^",4)+1)
LOCK -^LRO(69.2,LRAA,6)
QUIT
H WRITE $CHAR(7),!!,"Answer prompt. To quit enter '^' and unit will be deleted.",!
QUIT
END DO V^LRU
QUIT
