source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRAPBS1.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 3.0 KB
Line 
1LRAPBS1 ;AVAMC/REG - BLOCK/SLIDE DATA ENTRY;3/25/2002
2 ;;5.2;LAB SERVICE;**121,259**;Sep 27, 1994
3 ;
4ASK N CORRECT,LRREL,LRMSG
5 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
6 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)
7 I '$O(^LRO(68,LRAA,1,LRAD,1,0)) W $C(7),!!,"NO ",LRAA(1)," ACCESSIONS IN FILE FOR ",LRH(0),!! Q
8W ;
9 K X,Y,LR("CK")
10 W !!,"Select Accession Number: ",LRN,$S(LRN:"// ",1:"")
11 R LRAN:DTIME
12 I '$T!(LRAN[U)!(LRN=""&(LRAN="")) D END Q
13 S:LRAN="" LRAN=LRN
14 I LRAN'?1N.N S LRN="" W $C(7),!!,"Enter a number." G W
15 S LRN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)) S:LRN'=+LRN LRN=""
16 D OE1^LR7OB63D,REST,OERR^LR7OB63D
17 G W
18REST ;
19 W " for ",LRH(0)
20 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
21 .W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in"
22 .W " ACCESSION file",!!
23 S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRLLOC=$P(X,"^",7),LRDFN=+X
24 Q:'$D(^LR(LRDFN,0)) S X=^(0) D ^LRUP
25 W !,LRP," ID: ",SSN
26 Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) S LRI=$P(^(3),"^",5)
27 S LRA=$S("SPCYEM"[LRSS:^LR(LRDFN,LRSS,LRI,0),$D(^LR(LRDFN,"AU")):^("AU"),1:"")
28 S LRRC=$S("SPCYEM"[LRSS:$P(LRA,"^",10),1:+LRA)
29 ;K LRREL
30 ;D RELEASE^LRAPUTL(.LRREL,LRDFN,LRSS,$G(LRI))
31 ;I +$G(LRREL(1)) D Q
32 ;.K LRMSG
33 ;.S LRMSG=$C(7)_"Report verified. Cannot use this option."
34 ;.D EN^DDIOL(LRMSG,"","!!")
35 I LRSS="CY",LRCAPA D C^LRAPCWK Q:LRK<1
36 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
37 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)
38 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
39A D EN^LRAPBS2,EN^LRAPST W !!,"Data displayed ok " S %=2 D YN^LRU Q:%<1 I %=1 D EN^LRAPWKA Q
40 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
41 S DIE="^LR(",DA=LRDFN L +^LR(LRDFN,"AU"):1 I '$T W !,$C(7),"ANOTHER TERMINAL IS EDITING THIS ENTRY!" Q
42 D ^DIE L -^LR(LRDFN,"AU") G A
43 ;
44CK 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=""
45 Q
46SP S J=0,X="PARAFFIN BLOCK" D X^LRUWK S LRW(1)=LRT K LRT
47 S X="PARAFFIN BLOCK, ADDITIONAL CUT" D X^LRUWK S LRW(0)=LRT K LRT
48 S X="PLASTIC SECTION" D X^LRUWK S LRW(2)=LRT K LRT
49 S X="FROZEN SECTION BLOCK RUSH" D X^LRUWK S LRW(3)=LRT K LRT
50 S X="FROZEN SECTION BLOCK NOT RUSH" D X^LRUWK S LRW(4)=LRT K LRT
51 S X="FROZEN SECTION BLOCK RUSH ADD" D X^LRUWK S LRW(5)=LRT K LRT
52 S X="FROZEN SECTION ADDITIONAL CUT" D X^LRUWK S LRW(6)=LRT K LRT
53 S X="FROZEN SECTION H & E" D X^LRUWK S LRW(7)=LRT K LRT Q
54AU S J=0,X="AUTOPSY SECTION COMPLETE" Q:'LRCAPA D X^LRUWK S LRW(1)=LRT K LRT
55 S X="AUTOPSY H & E" D X^LRUWK S LRW(0)=LRT K LRT
56 S X="AUTOPSY UNSTAINED SLIDE" D X^LRUWK S LRW(2)=LRT K LRT Q
57 ;
58END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.