LRUTAD ;AVAMC/REG - ADD/DELETE LAB TEST/PROCEDURE ; 11/12/88 09:34 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
K T W !!?20 W:LRSS'="BB" "Add or Delete " W LRAA(1)," TEST/PROCEDURE" I LRSS="BB" W $S($D(LRDEL):" DELETION",1:" ADDITION")
W !!,"For ",LRH(0)," OK " S %=1 D YN^LRU Q:%<1 I %=2 S %DT="AEX" D ^%DT Q:Y<1 S LRAD=Y D D^LRU S LRH(0)=Y
WH I LRSS'="BB" K LRDEL R !!,"Enter A for Add or D for Delete ==> ",X:DTIME Q:X'?1"D".E&(X'?1"A".E) S:X?1"D".E LRDEL=1
ASK R !,"Select Accession Number: ",LRAN:DTIME Q:LRAN=""!(LRAN[U) I LRAN'?1N.N W $C(7),!!,"Enter whole numbers only",!! G ASK
W " for ",LRH(0),!
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in file",!! G ASK
S LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRI=$P(^(3),U,5) G:'$D(^LR(LRDFN,0)) BAD S Y=^(0),LRPFN=$P(Y,U,2),LRFNAM=$P(^DIC(LRPFN,0),U,1),LRPF=^(0,"GL"),Y=$P(Y,U,3)
S LRP=@(LRPF_Y_",0)") W !,$P(LRP,U,1)," ID: ",$P(LRP,U,9) S Y=$P(LRP,U,3) D D^LRU W:Y'[1700 " DOB: ",Y S LRSIT=$S($D(^LRO(68,LRAA,1,LRAD,LRAN,5,1,0)):+^(0),1:"") S:LRSIT LRSIT=$S($D(^LAB(61,LRSIT,0)):$P(^(0),U,1),1:"")
W !!,"ACC # ",LRAN," ",$E(LRSIT,1,20) S Y=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)):+^(3),1:"") D:Y D^LRU W " DATE RECEIVED: ",Y," OK " S %=1 D YN^LRU G:%'=1 ASK
I "AUCYEMSP"'[LRSS S LRSIT=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)):+^(0),1:"") I LRPF'="^LRX(",'LRSIT W $C(7),!!,"NO SITE/SPECIMEN",!,"DELETE ACCESSION # AND REENTER",!! Q
Z I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)),$P(^(0),U,4)>0 W !?30,"Test/Procedure(s) ordered: ",?60,"STAT test= *" S N=0 F X=1:1 S N=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,N)) Q:'N S T=^(N,0),T(X)=+T,T=$S($P(T,U,2)=1:"*",1:"") D L
ADD S X=X-1 I '$D(LRDEL) D EN1^LRUWLF G WH
LRDEL I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)),$P(^(0),U,4)<1 W $C(7),!!,"There are NO tests to delete !!!" G WH
W !!,"Delete by selecting a number from 1",$S(X=1:"",1:"-"_X) R ": ",A("A"):DTIME G:A("A")<1!(A("A")>X) WH
I $L($P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,T(A("A")),0),U,4)) W $C(7),!!,"Results entered for this test !! Cannot delete it !" G WH
W !,"Delete ",$P(^LAB(60,T(A("A")),0),U,1) R " OK ? YES// ",N1:DTIME G:N1'?1"Y".E&(N1'="") LRDEL
K ^LRO(68,LRAA,1,LRAD,1,LRAN,4,T(A("A")),0) S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)="^68.04PA^^"_($P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),U,4)-1) K T(A("A")) G WH
L Q:'$D(^LAB(60,T(X),0)) W !,$J(X,38),")",T,?41,$E($P(^(0),U,1),1,38) Q
BAD W $C(7),!!,"Entry not in file",!! G ASK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUTAD 2433 printed Dec 13, 2024@02:22:12 Page 2
LRUTAD ;AVAMC/REG - ADD/DELETE LAB TEST/PROCEDURE ; 11/12/88 09:34 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 KILL T
WRITE !!?20
if LRSS'="BB"
WRITE "Add or Delete "
WRITE LRAA(1)," TEST/PROCEDURE"
IF LRSS="BB"
WRITE $SELECT($DATA(LRDEL):" DELETION",1:" ADDITION")
+3 WRITE !!,"For ",LRH(0)," OK "
SET %=1
DO YN^LRU
if %<1
QUIT
IF %=2
SET %DT="AEX"
DO ^%DT
if Y<1
QUIT
SET LRAD=Y
DO D^LRU
SET LRH(0)=Y
WH IF LRSS'="BB"
KILL LRDEL
READ !!,"Enter A for Add or D for Delete ==> ",X:DTIME
if X'?1"D".E&(X'?1"A".E)
QUIT
if X?1"D".E
SET LRDEL=1
ASK READ !,"Select Accession Number: ",LRAN:DTIME
if LRAN=""!(LRAN[U)
QUIT
IF LRAN'?1N.N
WRITE $CHAR(7),!!,"Enter whole numbers only",!!
GOTO ASK
+1 WRITE " for ",LRH(0),!
+2 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE $CHAR(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in file",!!
GOTO ASK
+3 SET LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRI=$PIECE(^(3),U,5)
if '$DATA(^LR(LRDFN,0))
GOTO BAD
SET Y=^(0)
SET LRPFN=$PIECE(Y,U,2)
SET LRFNAM=$PIECE(^DIC(LRPFN,0),U,1)
SET LRPF=^(0,"GL")
SET Y=$PIECE(Y,U,3)
+4 SET LRP=@(LRPF_Y_",0)")
WRITE !,$PIECE(LRP,U,1)," ID: ",$PIECE(LRP,U,9)
SET Y=$PIECE(LRP,U,3)
DO D^LRU
if Y'[1700
WRITE " DOB: ",Y
SET LRSIT=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,LRAN,5,1,0)):+^(0),1:"")
if LRSIT
SET LRSIT=$SELECT($DATA(^LAB(61,LRSIT,0)):$PIECE(^(0),U,1),1:"")
+5 WRITE !!,"ACC # ",LRAN," ",$EXTRACT(LRSIT,1,20)
SET Y=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3)):+^(3),1:"")
if Y
DO D^LRU
WRITE " DATE RECEIVED: ",Y," OK "
SET %=1
DO YN^LRU
if %'=1
GOTO ASK
+6 IF "AUCYEMSP"'[LRSS
SET LRSIT=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)):+^(0),1:"")
IF LRPF'="^LRX("
IF 'LRSIT
WRITE $CHAR(7),!!,"NO SITE/SPECIMEN",!,"DELETE ACCESSION # AND REENTER",!!
QUIT
Z IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
IF $PIECE(^(0),U,4)>0
WRITE !?30,"Test/Procedure(s) ordered: ",?60,"STAT test= *"
SET N=0
FOR X=1:1
SET N=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,N))
if 'N
QUIT
SET T=^(N,0)
SET T(X)=+T
SET T=$SELECT($PIECE(T,U,2)=1:"*",1:"")
DO L
ADD SET X=X-1
IF '$DATA(LRDEL)
DO EN1^LRUWLF
GOTO WH
LRDEL IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
IF $PIECE(^(0),U,4)<1
WRITE $CHAR(7),!!,"There are NO tests to delete !!!"
GOTO WH
+1 WRITE !!,"Delete by selecting a number from 1",$SELECT(X=1:"",1:"-"_X)
READ ": ",A("A"):DTIME
if A("A")<1!(A("A")>X)
GOTO WH
+2 IF $LENGTH($PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,T(A("A")),0),U,4))
WRITE $CHAR(7),!!,"Results entered for this test !! Cannot delete it !"
GOTO WH
+3 WRITE !,"Delete ",$PIECE(^LAB(60,T(A("A")),0),U,1)
READ " OK ? YES// ",N1:DTIME
if N1'?1"Y".E&(N1'="")
GOTO LRDEL
+4 KILL ^LRO(68,LRAA,1,LRAD,1,LRAN,4,T(A("A")),0)
SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)="^68.04PA^^"_($PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),U,4)-1)
KILL T(A("A"))
GOTO WH
L if '$DATA(^LAB(60,T(X),0))
QUIT
WRITE !,$JUSTIFY(X,38),")",T,?41,$EXTRACT($PIECE(^(0),U,1),1,38)
QUIT
BAD WRITE $CHAR(7),!!,"Entry not in file",!!
GOTO ASK
