- 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 Jan 18, 2025@03:22:54 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