- 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 Feb 18, 2025@23:32:59 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
