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