- 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 Apr 23, 2025@18:25:13 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
