- LRBLJLG ; IHS/DIR/AAB - BB INVENTORY LOG-IN 11/12/96 07:49 ;
- ;;5.2;LR;**1002**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**72,139**;Sep 27, 1994
- 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 R !,"Select BLOOD COMPONENT: ",X:DTIME 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 ! 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:"")
- 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 R !!?13,"UNIT ID: ",X:DTIME I X=""!(X[U) D ^LRBLJLG1 G C
- I LR,$E(X,1,$L(LR(2)))=LR(2) D U^LRBLB
- 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 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)="" R !?14,"ABO/Rh: ",X:DTIME 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="" D T^LRBLB G:'$D(X) A
- ED S (LRA,LRH)="" R !,"EXPIRATION DATE/TIME: ",X:DTIME 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
- 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
- LRBLJLG ; IHS/DIR/AAB - BB INVENTORY LOG-IN 11/12/96 07:49 ;
- +1 ;;5.2;LR;**1002**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**72,139**;Sep 27, 1994
- +3 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
- READ !,"Select BLOOD COMPONENT: ",X:DTIME
- 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 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:"")
- +3 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
- +4 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
- +5 DO EN^LRBLJLG1
- +6 NEW IPTR,HLP
- SET DA=0
- DO FIELD^DID(65,.01,"","INPUT TRANSFORM","IPTR")
- SET IPTR=IPTR("INPUT TRANSFORM")
- +7 DO FIELD^DID(65,.01,"","HELP-PROMPT","HLP")
- SET HLP=HLP("HELP-PROMPT")
- E READ !!?13,"UNIT ID: ",X:DTIME
- IF X=""!(X[U)
- DO ^LRBLJLG1
- GOTO C
- +1 IF LR
- IF $EXTRACT(X,1,$LENGTH(LR(2)))=LR(2)
- DO U^LRBLB
- +2 IF X[" "
- WRITE $CHAR(7)," No spaces allowed."
- GOTO E
- +3 IF X["?"
- WRITE $CHAR(7)," Enter the Unit ID Without the Prefix"
- GOTO E
- +4 XECUTE IPTR
- IF $DATA(X)
- IF X["?"
- KILL X
- GOTO E
- +5 IF '$DATA(X)
- WRITE !!,$CHAR(7),HLP
- GOTO E
- +6 ;concatinate supplier prefix #
- SET X=LR(1)_X
- +7 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:"")
- +8 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
- +9 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
- +10 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)=""
- READ !?14,"ABO/Rh: ",X:DTIME
- IF X=""!(X[U)
- GOTO E
- 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
- +1 IF LRABO=""
- DO T^LRBLB
- IF '$DATA(X)
- GOTO A
- ED SET (LRA,LRH)=""
- READ !,"EXPIRATION DATE/TIME: ",X:DTIME
- IF X=""!(X[U)
- GOTO E
- 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
- +1 IF 'LRH
- SET %DT="ETX"
- DO ^%DT
- KILL %DT
- IF X["?"
- GOTO ED
- IF Y<1
- GOTO E
- SET LRH=Y
- +2 IF LRS
- IF LRH>LRS
- WRITE $CHAR(7),!?4,"Expiration date exceeds allowable limit !"
- GOTO ED
- +3 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
- +4 SET (UNIT,TYPE)=""
- +5 IF $DATA(^LRD(65,"B",LRP))
- SET UNIT=$ORDER(^LRD(65,"B",LRP,0))
- Begin DoDot:1
- +6 SET TYPE=$PIECE($GET(^LRD(65,UNIT,0)),U,4)
- IF TYPE=LRC
- Begin DoDot:2
- +7 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
- +8 IF '$DATA(UNIT)
- GOTO E
- +9 SET DA=+$PIECE(^LRD(65,0),"^",3)
- FOR
- SET DA=DA+1
- IF '$DATA(^LRD(65,DA))
- QUIT
- +10 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
- +11 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)
- +12 LOCK -^LRD(65,0)
- +13 IF LR(4)>1
- SET ^LRD(65,"C",$EXTRACT(LRP,LR(4),$LENGTH(LRP)),DA)=""
- +14 SET DIE="^LRD(65,"
- SET DIE("NO^")="OUTOK"
- SET (^LRD(65,"AT",LRP,10,DA),^LRD(65,"AT",LRP,11,DA))=""
- +15 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
- +16 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
- +17 IF LRR=1
- DO S
- SET LRL=LRL+1
- SET LRL(LRL)=DA_"^"_LRP_"^"_LRABO_"^"_LRRH_"^"_LRH_"^"_LRA_"^"_LRC
- GOTO E
- +18 ;
- 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
