LRAPBS1 ;AVAMC/REG - BLOCK/SLIDE DATA ENTRY;3/25/2002
;;5.2;LAB SERVICE;**121,259**;Sep 27, 1994
;
ASK N CORRECT,LRREL,LRMSG
S %DT="",X="T" D ^%DT S LRY=$E(Y,1,3)+1700 W !!,"Enter year: ",LRY,"// " R X:DTIME G:'$T!(X[U) END S:X="" X=LRY
S LRN="",%DT="EQ" D ^%DT G:Y<1 ASK S LRY=$E(Y,1,3),LRAD=$E(LRY,1,3)_"0000",LRH(0)=LRY+1700 W " ",LRH(0)
I '$O(^LRO(68,LRAA,1,LRAD,1,0)) W $C(7),!!,"NO ",LRAA(1)," ACCESSIONS IN FILE FOR ",LRH(0),!! Q
W ;
K X,Y,LR("CK")
W !!,"Select Accession Number: ",LRN,$S(LRN:"// ",1:"")
R LRAN:DTIME
I '$T!(LRAN[U)!(LRN=""&(LRAN="")) D END Q
S:LRAN="" LRAN=LRN
I LRAN'?1N.N S LRN="" W $C(7),!!,"Enter a number." G W
S LRN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)) S:LRN'=+LRN LRN=""
D OE1^LR7OB63D,REST,OERR^LR7OB63D
G W
REST ;
W " for ",LRH(0)
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
.W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in"
.W " ACCESSION file",!!
S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRLLOC=$P(X,"^",7),LRDFN=+X
Q:'$D(^LR(LRDFN,0)) S X=^(0) D ^LRUP
W !,LRP," ID: ",SSN
Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) S LRI=$P(^(3),"^",5)
S LRA=$S("SPCYEM"[LRSS:^LR(LRDFN,LRSS,LRI,0),$D(^LR(LRDFN,"AU")):^("AU"),1:"")
S LRRC=$S("SPCYEM"[LRSS:$P(LRA,"^",10),1:+LRA)
;K LRREL
;D RELEASE^LRAPUTL(.LRREL,LRDFN,LRSS,$G(LRI))
;I +$G(LRREL(1)) D Q
;.K LRMSG
;.S LRMSG=$C(7)_"Report verified. Cannot use this option."
;.D EN^DDIOL(LRMSG,"","!!")
I LRSS="CY",LRCAPA D C^LRAPCWK Q:LRK<1
W ! I "AUSPEM"[LRSS S %DT("A")=$S('$D(LRF):"Date/time blocks prepared/modified: ",1:"Date/time Gross Description/Cutting: ") D W^LRAPWU Q:Y<1 S LRK(1)=LRK D CK Q:'$D(Y) G:$D(LRF) A
S %DT("A")="Date/time "_$S("AUSPCY"[LRSS:"slides stained: ",1:"sections prepared: ") D W^LRAPWU Q:Y<1 I LRSS="CY" D CK Q:'$D(Y)
I "AUSPEM"[LRSS,Y<LRK(1) W $C(7),!,"Date/time must not be before date/time blocks prepared(" S Y=LRK(1),LRN="" D DD^%DT W Y,")." Q
A D EN^LRAPBS2,EN^LRAPST W !!,"Data displayed ok " S %=2 D YN^LRU Q:%<1 I %=1 D EN^LRAPWKA Q
I LRSS'="AU" S DIE="^LR("_LRDFN_","""_LRSS_""",",DA=LRI,DA(1)=LRDFN D CK^LRU Q:$D(LR("CK")) D ^DIE D FRE^LRU G A
S DIE="^LR(",DA=LRDFN L +^LR(LRDFN,"AU"):1 I '$T W !,$C(7),"ANOTHER TERMINAL IS EDITING THIS ENTRY!" Q
D ^DIE L -^LR(LRDFN,"AU") G A
;
CK I LRK<LRRC W $C(7),!,"Date/time must not be before date/time ",$S("SPCYEM"[LRSS:"specimen received (",1:"autopsy performed (") S Y=LRRC D DD^%DT W Y,")" K Y S LRN=""
Q
SP S J=0,X="PARAFFIN BLOCK" D X^LRUWK S LRW(1)=LRT K LRT
S X="PARAFFIN BLOCK, ADDITIONAL CUT" D X^LRUWK S LRW(0)=LRT K LRT
S X="PLASTIC SECTION" D X^LRUWK S LRW(2)=LRT K LRT
S X="FROZEN SECTION BLOCK RUSH" D X^LRUWK S LRW(3)=LRT K LRT
S X="FROZEN SECTION BLOCK NOT RUSH" D X^LRUWK S LRW(4)=LRT K LRT
S X="FROZEN SECTION BLOCK RUSH ADD" D X^LRUWK S LRW(5)=LRT K LRT
S X="FROZEN SECTION ADDITIONAL CUT" D X^LRUWK S LRW(6)=LRT K LRT
S X="FROZEN SECTION H & E" D X^LRUWK S LRW(7)=LRT K LRT Q
AU S J=0,X="AUTOPSY SECTION COMPLETE" Q:'LRCAPA D X^LRUWK S LRW(1)=LRT K LRT
S X="AUTOPSY H & E" D X^LRUWK S LRW(0)=LRT K LRT
S X="AUTOPSY UNSTAINED SLIDE" D X^LRUWK S LRW(2)=LRT K LRT Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPBS1 3162 printed Oct 16, 2024@18:07:52 Page 2
LRAPBS1 ;AVAMC/REG - BLOCK/SLIDE DATA ENTRY;3/25/2002
+1 ;;5.2;LAB SERVICE;**121,259**;Sep 27, 1994
+2 ;
ASK NEW CORRECT,LRREL,LRMSG
+1 SET %DT=""
SET X="T"
DO ^%DT
SET LRY=$EXTRACT(Y,1,3)+1700
WRITE !!,"Enter year: ",LRY,"// "
READ X:DTIME
if '$TEST!(X[U)
GOTO END
if X=""
SET X=LRY
+2 SET LRN=""
SET %DT="EQ"
DO ^%DT
if Y<1
GOTO ASK
SET LRY=$EXTRACT(Y,1,3)
SET LRAD=$EXTRACT(LRY,1,3)_"0000"
SET LRH(0)=LRY+1700
WRITE " ",LRH(0)
+3 IF '$ORDER(^LRO(68,LRAA,1,LRAD,1,0))
WRITE $CHAR(7),!!,"NO ",LRAA(1)," ACCESSIONS IN FILE FOR ",LRH(0),!!
QUIT
W ;
+1 KILL X,Y,LR("CK")
+2 WRITE !!,"Select Accession Number: ",LRN,$SELECT(LRN:"// ",1:"")
+3 READ LRAN:DTIME
+4 IF '$TEST!(LRAN[U)!(LRN=""&(LRAN=""))
DO END
QUIT
+5 if LRAN=""
SET LRAN=LRN
+6 IF LRAN'?1N.N
SET LRN=""
WRITE $CHAR(7),!!,"Enter a number."
GOTO W
+7 SET LRN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN))
if LRN'=+LRN
SET LRN=""
+8 DO OE1^LR7OB63D
DO REST
DO OERR^LR7OB63D
+9 GOTO W
REST ;
+1 WRITE " for ",LRH(0)
+2 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
Begin DoDot:1
+3 WRITE $CHAR(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in"
+4 WRITE " ACCESSION file",!!
End DoDot:1
QUIT
+5 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRLLOC=$PIECE(X,"^",7)
SET LRDFN=+X
+6 if '$DATA(^LR(LRDFN,0))
QUIT
SET X=^(0)
DO ^LRUP
+7 WRITE !,LRP," ID: ",SSN
+8 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
QUIT
SET LRI=$PIECE(^(3),"^",5)
+9 SET LRA=$SELECT("SPCYEM"[LRSS:^LR(LRDFN,LRSS,LRI,0),$DATA(^LR(LRDFN,"AU")):^("AU"),1:"")
+10 SET LRRC=$SELECT("SPCYEM"[LRSS:$PIECE(LRA,"^",10),1:+LRA)
+11 ;K LRREL
+12 ;D RELEASE^LRAPUTL(.LRREL,LRDFN,LRSS,$G(LRI))
+13 ;I +$G(LRREL(1)) D Q
+14 ;.K LRMSG
+15 ;.S LRMSG=$C(7)_"Report verified. Cannot use this option."
+16 ;.D EN^DDIOL(LRMSG,"","!!")
+17 IF LRSS="CY"
IF LRCAPA
DO C^LRAPCWK
if LRK<1
QUIT
+18 WRITE !
IF "AUSPEM"[LRSS
SET %DT("A")=$SELECT('$DATA(LRF):"Date/time blocks prepared/modified: ",1:"Date/time Gross Description/Cutting: ")
DO W^LRAPWU
if Y<1
QUIT
SET LRK(1)=LRK
DO CK
if '$DATA(Y)
QUIT
if $DATA(LRF)
GOTO A
+19 SET %DT("A")="Date/time "_$SELECT("AUSPCY"[LRSS:"slides stained: ",1:"sections prepared: ")
DO W^LRAPWU
if Y<1
QUIT
IF LRSS="CY"
DO CK
if '$DATA(Y)
QUIT
+20 IF "AUSPEM"[LRSS
IF Y<LRK(1)
WRITE $CHAR(7),!,"Date/time must not be before date/time blocks prepared("
SET Y=LRK(1)
SET LRN=""
DO DD^%DT
WRITE Y,")."
QUIT
A DO EN^LRAPBS2
DO EN^LRAPST
WRITE !!,"Data displayed ok "
SET %=2
DO YN^LRU
if %<1
QUIT
IF %=1
DO EN^LRAPWKA
QUIT
+1 IF LRSS'="AU"
SET DIE="^LR("_LRDFN_","""_LRSS_""","
SET DA=LRI
SET DA(1)=LRDFN
DO CK^LRU
if $DATA(LR("CK"))
QUIT
DO ^DIE
DO FRE^LRU
GOTO A
+2 SET DIE="^LR("
SET DA=LRDFN
LOCK +^LR(LRDFN,"AU"):1
IF '$TEST
WRITE !,$CHAR(7),"ANOTHER TERMINAL IS EDITING THIS ENTRY!"
QUIT
+3 DO ^DIE
LOCK -^LR(LRDFN,"AU")
GOTO A
+4 ;
CK IF LRK<LRRC
WRITE $CHAR(7),!,"Date/time must not be before date/time ",$SELECT("SPCYEM"[LRSS:"specimen received (",1:"autopsy performed (")
SET Y=LRRC
DO DD^%DT
WRITE Y,")"
KILL Y
SET LRN=""
+1 QUIT
SP SET J=0
SET X="PARAFFIN BLOCK"
DO X^LRUWK
SET LRW(1)=LRT
KILL LRT
+1 SET X="PARAFFIN BLOCK, ADDITIONAL CUT"
DO X^LRUWK
SET LRW(0)=LRT
KILL LRT
+2 SET X="PLASTIC SECTION"
DO X^LRUWK
SET LRW(2)=LRT
KILL LRT
+3 SET X="FROZEN SECTION BLOCK RUSH"
DO X^LRUWK
SET LRW(3)=LRT
KILL LRT
+4 SET X="FROZEN SECTION BLOCK NOT RUSH"
DO X^LRUWK
SET LRW(4)=LRT
KILL LRT
+5 SET X="FROZEN SECTION BLOCK RUSH ADD"
DO X^LRUWK
SET LRW(5)=LRT
KILL LRT
+6 SET X="FROZEN SECTION ADDITIONAL CUT"
DO X^LRUWK
SET LRW(6)=LRT
KILL LRT
+7 SET X="FROZEN SECTION H & E"
DO X^LRUWK
SET LRW(7)=LRT
KILL LRT
QUIT
AU SET J=0
SET X="AUTOPSY SECTION COMPLETE"
if 'LRCAPA
QUIT
DO X^LRUWK
SET LRW(1)=LRT
KILL LRT
+1 SET X="AUTOPSY H & E"
DO X^LRUWK
SET LRW(0)=LRT
KILL LRT
+2 SET X="AUTOPSY UNSTAINED SLIDE"
DO X^LRUWK
SET LRW(2)=LRT
KILL LRT
QUIT
+3 ;
END DO V^LRU
QUIT
