LRUSP ;AVAMC/REG - ADD/DELETE SPECIAL STAIN ; 10/9/87 16:26 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
W !!?20,"Add or Delete " W LRAA(1)," SPECIAL STAIN"
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
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),X=$P(Y,U,2),X=^DIC(X,0,"GL"),Y=$P(Y,U,3)
S LRP=@(X_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:'$D(^LRO(68,LRAA,1,LRAD,LRAN,5,0)) ^(0)="^68.05PA^^"
W !!,"ACC # ",LRAN 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
T W ! S DIC="^LRO(68,LRAA,1,LRAD,1,LRAN,5,",DIC(0)="AELMOQ",DLAYGO=68 D ^DIC K DIC,DLAYGO Q:X=""!(X[U)
S DIE="^LRO(68,LRAA,1,LRAD,1,LRAN,5,",DA=+Y,DR=".01;2:99" D ^DIE K DIE G T
BAD W $C(7),!!,"Entry not in file",!! G ASK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUSP 1178 printed Sep 23, 2025@19:57:49 Page 2
LRUSP ;AVAMC/REG - ADD/DELETE SPECIAL STAIN ; 10/9/87 16:26 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 WRITE !!?20,"Add or Delete "
WRITE LRAA(1)," SPECIAL STAIN"
+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
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 X=$PIECE(Y,U,2)
SET X=^DIC(X,0,"GL")
SET Y=$PIECE(Y,U,3)
+4 SET LRP=@(X_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
if '$DATA(^LRO(68,LRAA,1,LRAD,LRAN,5,0))
SET ^(0)="^68.05PA^^"
+5 WRITE !!,"ACC # ",LRAN
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
T WRITE !
SET DIC="^LRO(68,LRAA,1,LRAD,1,LRAN,5,"
SET DIC(0)="AELMOQ"
SET DLAYGO=68
DO ^DIC
KILL DIC,DLAYGO
if X=""!(X[U)
QUIT
+1 SET DIE="^LRO(68,LRAA,1,LRAD,1,LRAN,5,"
SET DA=+Y
SET DR=".01;2:99"
DO ^DIE
KILL DIE
GOTO T
BAD WRITE $CHAR(7),!!,"Entry not in file",!!
GOTO ASK
