LRUSP.m

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 ---LRUSP   1178     printed  Apr 09, 2024@21:08:55                                                                                                                                                                                                       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