LRBLJLG1 ; IHS/DIR/AAB - REVIEW UNIT LOG-IN 11/12/96 07:41 ;
;;5.2;LR;**1002**;JUN 01, 1998
;;5.2;LAB SERVICE;**72,139**;Sep 27, 1994
Q:'$D(LRL) W @IOF,P," Source: ",LRW," Invoice: ",LRI,!,"Review:",?12,"Unit",?25,"ABO/Rh",?32,"Expiration date (*=Expired or expires today)"
S X=0 F A=0:1 S X=$O(LRL(X)) Q:'X W !?5,$J(X,3),")",?12,$P(LRL(X),"^",2),?25,$P(LRL(X),"^",3),?28,$P(LRL(X),"^",4),?32 S Y=$P(LRL(X),"^",5) D D^LRU W Y,$P(LRL(X),"^",6)
Q:'A W !!,"All OK " S %=1 D YN^LRU G:%=1&LRCAPA WRK Q:%'=2 I %=1 L -^LRD(65)
ASK W !!,"Select (1-",A,") to Edit: " R LRE:DTIME G:LRE=""!(LRE["^") ^LRBLJLG1 I LRE'?1N.N!(LRE<1!(LRE>A)) W $C(7),! D H G ASK
DIE S DA=+LRL(LRE),DIE="^LRD(65,",LR(65,.01)=$P(^LRD(65,DA,0),U)
S DR=".01;I X["" "" W $C(7),"" No spaces. Enter '@' to delete."" S Y=.01;D CK^LRBLJLG1;S:LRF Y=.01;S LRP=X;.07;S LRABO=X;.08;S LRRH=X;.06;S LRH=X;I LRS,LRH>LRS D A^LRBLJLG1 S Y=.06"
D ^DIE I $D(Y) W $C(7),!,"No entering '^' during this edit !!" G DIE
I '$D(DA) D FIX G LRBLJLG1
S X=$P(^LRD(65,DA,0),U) D:X'=LR(65,.01) KK^LRBLU
S LRL(LRE)=DA_"^"_LRP_"^"_LRABO_"^"_LRRH_"^"_LRH_"^"_LRA_"^"_LRC S:$D(^LRO(69.2,LRAA,6,DA,0)) ^(0)=LRP_"^"_LRABO_"^"_LRRH K DIE,DR,DA G LRBLJLG1
;
WRK F LRL=0:0 S LRL=$O(LRL(LRL)) Q:'LRL S LRX=+LRL(LRL) D ^LRBLW
Q
FIX S X=+LRL(LRE) K LRL(LRE) I $D(^LRO(69.2,LRAA,6,X,0)) K ^(0) S X=^LRO(69.2,LRAA,6,0),^(0)=$P(X,"^",1,2)_"^^"_($P(X,"^",4)-1)
K B S X=0 F A=1:1 S X=$O(LRL(X)) Q:'X S B(A)=LRL(X)
K LRL F A=0:0 S A=$O(B(A)) Q:'A S LRL(A)=B(A) K B(A)
Q
H W " Enter a number from 1 to ",A Q
EN ;from LRBLJLG
S LRB(7)=$P(^LAB(66,LRC,0),"^",17),LRB(6)="" G:'LRB(7) END
S LRB(3)=$P(LRK,".",2),X1=LRK,X2=$P(LRB(7),".")
D C^%DTC S LRB(6)=X I LRB(7)["." S Z=LRB(6)_"."_LRB(3),X="."_$P(LRB(7),".",2),Z(0)=$P(X*24*60,".") D EN^LRBLDC
END S LRS=LRB(6) K LRB Q
;
CK S LRF=0,LRO=$P(LRL(LRE),"^",2)
F C=0:0 S C=$O(^LRD(65,"B",X,C)) Q:'C I C'=DA,$D(^LRD(65,C,0)),$P(^(0),"^",4)=$P(LRL(LRE),"^",7) S $P(^LRD(65,DA,0),"^")=LRO,LRF=1 W $C(7)," Sorry, that unit exists in inventory." Q
Q:'LRF F LRF=1:1:4 X:$D(^DD(65,.01,1,LRF,2)) ^(2)
S X=LRO F LRF=1:1:4 X:$D(^DD(65,.01,1,LRF,1)) ^(1)
S Y=.01 Q
EN1 ;
S X=$P($G(^DIC(4,+$P(Y(0),"^",16),0)),"^") W:X]"" !,"Institution: ",X
I $D(^LRD(65,C,4)) S W=^(4),LRP=$P(W,"^") I LRP="R"!(LRP="S") W !!,"DISPOSITION: ",$S(LRP="S":"SENT ELSEWHERE",1:"RETURNED TO SENDER"),". Re-enter unit in inventory " S %=2 D YN^LRU Q:%'=1 S ^(4)="^^^"_$P(W,"^",4)_"^^"_$P(W,"^",6,99) G Z
Q
A W $C(7),!!?4,"Expiration date exceeds allowable limit !",! Q
;
Z S:'$D(^LRD(65,C,15,0)) ^(0)="^65.15DA^^" S A=^(0),X=$P(A,"^",4),X=X+1,^(0)=$P(A,"^",1,2)_"^"_X_"^"_X
S Z=^LRD(65,C,0),W(5)=$P(Z,U,5),Z(4)=$P(Z,U,4),Z(6)=$P(Z,U,6),^LRD(65,C,15,X,0)=LRK_U_$P(W,U,1,3)_U_$P(Z,U,13)_U_$P(Z,U,3)_U_$P(Z,U,9)_U_$P(Z,U,5)_U_$P(W,U,5),W(11)=$P(W,U,2) K:W(11) ^LRD(65,"AB",W(11),C)
S $P(Z,"^",5)=LRK,$P(Z,"^",9)=DUZ,$P(Z,"^",10)=$P($P(Z,"^",14),"-",2),$P(Z,"^",14)="",$P(Z,"^",3)=LRI,$P(Z,"^",13)="",^LRD(65,C,0)=Z,^LRD(65,"A",W(5),C)=""
I Z(4),Z(6) S ^LRD(65,"AE",Z(4),Z(6),C)="",^LRD(65,"AI",Z(4),$P(Z,"^"),Z(6),C)=""
Q
LRBLJLG1 ; IHS/DIR/AAB - REVIEW UNIT LOG-IN 11/12/96 07:41 ;
+1 ;;5.2;LR;**1002**;JUN 01, 1998
+2 ;;5.2;LAB SERVICE;**72,139**;Sep 27, 1994
+3 IF '$DATA(LRL)
QUIT
WRITE @IOF,P," Source: ",LRW," Invoice: ",LRI,!,"Review:",?12,"Unit",?25,"ABO/Rh",?32,"Expiration date (*=Expired or expires today)"
+4 SET X=0
FOR A=0:1
SET X=$ORDER(LRL(X))
IF 'X
QUIT
WRITE !?5,$JUSTIFY(X,3),")",?12,$PIECE(LRL(X),"^",2),?25,$PIECE(LRL(X),"^",3),?28,$PIECE(LRL(X),"^",4),?32
SET Y=$PIECE(LRL(X),"^",5)
DO D^LRU
WRITE Y,$PIECE(LRL(X),"^",6)
+5 IF 'A
QUIT
WRITE !!,"All OK "
SET %=1
DO YN^LRU
IF %=1&LRCAPA
GOTO WRK
IF %'=2
QUIT
IF %=1
LOCK -^LRD(65)
ASK WRITE !!,"Select (1-",A,") to Edit: "
READ LRE:DTIME
IF LRE=""!(LRE["^")
GOTO ^LRBLJLG1
IF LRE'?1N.N!(LRE<1!(LRE>A))
WRITE $CHAR(7),!
DO H
GOTO ASK
DIE SET DA=+LRL(LRE)
SET DIE="^LRD(65,"
SET LR(65,.01)=$PIECE(^LRD(65,DA,0),U)
+1 SET DR=".01;I X["" "" W $C(7),"" No spaces. Enter '@' to delete."" S Y=.01;D CK^LRBLJLG1;S:LRF Y=.01;S LRP=X;.07;S LRABO=X;.08;S LRRH=X;.06;S LRH=X;I LRS,LRH>LRS D A^LRBLJLG1 S Y=.06"
+2 DO ^DIE
IF $DATA(Y)
WRITE $CHAR(7),!,"No entering '^' during this edit !!"
GOTO DIE
+3 IF '$DATA(DA)
DO FIX
GOTO LRBLJLG1
+4 SET X=$PIECE(^LRD(65,DA,0),U)
IF X'=LR(65,.01)
DO KK^LRBLU
+5 SET LRL(LRE)=DA_"^"_LRP_"^"_LRABO_"^"_LRRH_"^"_LRH_"^"_LRA_"^"_LRC
IF $DATA(^LRO(69.2,LRAA,6,DA,0))
SET ^(0)=LRP_"^"_LRABO_"^"_LRRH
KILL DIE,DR,DA
GOTO LRBLJLG1
+6 ;
WRK FOR LRL=0:0
SET LRL=$ORDER(LRL(LRL))
IF 'LRL
QUIT
SET LRX=+LRL(LRL)
DO ^LRBLW
+1 QUIT
FIX SET X=+LRL(LRE)
KILL LRL(LRE)
IF $DATA(^LRO(69.2,LRAA,6,X,0))
KILL ^(0)
SET X=^LRO(69.2,LRAA,6,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^^"_($PIECE(X,"^",4)-1)
+1 KILL B
SET X=0
FOR A=1:1
SET X=$ORDER(LRL(X))
IF 'X
QUIT
SET B(A)=LRL(X)
+2 KILL LRL
FOR A=0:0
SET A=$ORDER(B(A))
IF 'A
QUIT
SET LRL(A)=B(A)
KILL B(A)
+3 QUIT
H WRITE " Enter a number from 1 to ",A
QUIT
EN ;from LRBLJLG
+1 SET LRB(7)=$PIECE(^LAB(66,LRC,0),"^",17)
SET LRB(6)=""
IF 'LRB(7)
GOTO END
+2 SET LRB(3)=$PIECE(LRK,".",2)
SET X1=LRK
SET X2=$PIECE(LRB(7),".")
+3 DO C^%DTC
SET LRB(6)=X
IF LRB(7)["."
SET Z=LRB(6)_"."_LRB(3)
SET X="."_$PIECE(LRB(7),".",2)
SET Z(0)=$PIECE(X*24*60,".")
DO EN^LRBLDC
END SET LRS=LRB(6)
KILL LRB
QUIT
+1 ;
CK SET LRF=0
SET LRO=$PIECE(LRL(LRE),"^",2)
+1 FOR C=0:0
SET C=$ORDER(^LRD(65,"B",X,C))
IF 'C
QUIT
IF C'=DA
IF $DATA(^LRD(65,C,0))
IF $PIECE(^(0),"^",4)=$PIECE(LRL(LRE),"^",7)
SET $PIECE(^LRD(65,DA,0),"^")=LRO
SET LRF=1
WRITE $CHAR(7)," Sorry, that unit exists in inventory."
QUIT
+2 IF 'LRF
QUIT
FOR LRF=1:1:4
IF $DATA(^DD(65,.01,1,LRF,2))
XECUTE ^(2)
+3 SET X=LRO
FOR LRF=1:1:4
IF $DATA(^DD(65,.01,1,LRF,1))
XECUTE ^(1)
+4 SET Y=.01
QUIT
EN1 ;
+1 SET X=$PIECE($GET(^DIC(4,+$PIECE(Y(0),"^",16),0)),"^")
IF X]""
WRITE !,"Institution: ",X
+2 IF $DATA(^LRD(65,C,4))
SET W=^(4)
SET LRP=$PIECE(W,"^")
IF LRP="R"!(LRP="S")
WRITE !!,"DISPOSITION: ",$SELECT(LRP="S":"SENT ELSEWHERE",1:"RETURNED TO SENDER"),". Re-enter unit in inventory "
SET %=2
DO YN^LRU
IF %'=1
QUIT
SET ^(4)="^^^"_$PIECE(W,"^",4)_"^^"_$PIECE(W,"^",6,99)
GOTO Z
+3 QUIT
A WRITE $CHAR(7),!!?4,"Expiration date exceeds allowable limit !",!
QUIT
+1 ;
Z IF '$DATA(^LRD(65,C,15,0))
SET ^(0)="^65.15DA^^"
SET A=^(0)
SET X=$PIECE(A,"^",4)
SET X=X+1
SET ^(0)=$PIECE(A,"^",1,2)_"^"_X_"^"_X
+1 SET Z=^LRD(65,C,0)
SET W(5)=$PIECE(Z,U,5)
SET Z(4)=$PIECE(Z,U,4)
SET Z(6)=$PIECE(Z,U,6)
SET ^LRD(65,C,15,X,0)=LRK_U_$PIECE(W,U,1,3)_U_$PIECE(Z,U,13)_U_$PIECE(Z,U,3)_U_$PIECE(Z,U,9)_U_$PIECE(Z,U,5)_U_$PIECE(W,U,5)
SET W(11)=$PIECE(W,U,2)
IF W(11)
KILL ^LRD(65,"AB",W(11),C)
+2 SET $PIECE(Z,"^",5)=LRK
SET $PIECE(Z,"^",9)=DUZ
SET $PIECE(Z,"^",10)=$PIECE($PIECE(Z,"^",14),"-",2)
SET $PIECE(Z,"^",14)=""
SET $PIECE(Z,"^",3)=LRI
SET $PIECE(Z,"^",13)=""
SET ^LRD(65,C,0)=Z
SET ^LRD(65,"A",W(5),C)=""
+3 IF Z(4)
IF Z(6)
SET ^LRD(65,"AE",Z(4),Z(6),C)=""
SET ^LRD(65,"AI",Z(4),$PIECE(Z,"^"),Z(6),C)=""
+4 QUIT
