source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRAPOLD.m@ 1791

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

initial load of FOIAVistA 6/30/08 version

File size: 2.6 KB
Line 
1LRAPOLD ;AVAMC/REG - ENTER OLD AP ACCESSIONS ;8/12/95 08:04 ;
2 ;;5.2;LAB SERVICE;**72,324**;Sep 27, 1994
3 S IOP="HOME" D ^%ZIS W @IOF,?20,"Enter old pathology records",!!
4 W $C(7),!,"This option skips entering accession number in the Accession Area file.",!?5,"Is this what you want " S %=2 D YN^LRU G:%'=1 END
5 D A^LRAPD Q:'$D(Y) S (LRB,LRC)=1 D XR^LRU
6 W !!,"Enter Etiology, Function, Procedure & Disease " S %=2 D YN^LRU G:%<1 END K:%=2 LRB
7 W !!,"Enter Special Studies " S %=2 D YN^LRU G:%<1 END K:%=2 LRC
8GETP W ! K DIC D ^LRDPA G:LRDFN=-1 END D REST G GETP
9REST I '$D(^LR(LRDFN,LRSS,0)) S ^LR(LRDFN,LRSS,0)="^"_LRSF_"DA^0^0"
10DT W ! S %DT="AEXT",%DT(0)="-N",%DT("A")="Date (must be exact) specimen taken: " D ^%DT K %DT G:X["?" DT Q:Y<1
11 S LRE=Y,LRH="",LRI=9999999-Y D D^LRU S %DT("B")=Y
12R W ! S %DT="AEXT",%DT(0)="-N",%DT("A")="Date (must be exact) specimen received: " D ^%DT K %DT G:X["?" R Q:Y<1 I Y<LRE W $C(7),!!,"Date received must be after date taken.",! G R
13 S LRAD=Y,LRF=$E(LRAD,1,3) D D^LRU S LRD=Y D A G DT
14A R !!,"Enter Accession number: ",LRAN:DTIME Q:LRAN=""!(LRAN[U) I LRAN'?1N.N!($L(LRAN)>5) W $C(7),!!,"Enter up to 5 numbers",!! G A
15 I $D(^LR(LRXREF,LRF,LRABV,LRAN)) S X=+$O(^LR(LRXREF,LRF,LRABV,LRAN,0)) I $D(^LR(X,0)) S X=^(0) D ^LRUP W $C(7),!,"AC #",LRAN," in ",LRO(68)," for ",$E(LRF,2,3),!?5,"Patient: ",LRP," ID: ",SSN G A
16 I $D(^LR(LRDFN,LRSS,LRI,0)) S LRI=LRI-.00001 D FIX
17 L +^LR(LRDFN,LRSS) S ^LR(LRDFN,LRSS,LRI,0)=LRE,^LR(LRDFN,LRSS,0)="^"_LRSF_"DA^"_LRI_"^"_($P(^LR(LRDFN,LRSS,0),"^",4)+1) L -^LR(LRDFN,LRSS)
18 N LRAPOLDF
19 S LRAPOLDF=1
20 S DIE="^LR(LRDFN,LRSS,",DA=LRI,DA(1)=LRDFN,LRAC=LRABV_" "_$E(LRF,2,3)_" "_LRAN D @LRSS,^DIE
21 I $D(Y) W $C(7),!!,"All Prompts were not answered <ENTRY DELETED>" L +^LR(LRDFN,LRSS) K ^LR(LRDFN,LRSS,DA) D X L -^LR(LRDFN,LRSS) Q
22FIX Q:'$D(^LR(LRDFN,LRSS,LRI,0)) S LRI=LRI-.00001 G FIX
23X I $D(LRH),LRH>1 K ^LR(LRXR,LRH,LRDFN,LRI)
24 S X=^LR(LRDFN,LRSS,0),X(1)=+$O(^(0)) S ^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1)
25 K ^LR(LRXREF,LRF,LRABV,LRAN,LRDFN,LRI) Q
26SP S DR=".1///"_LRD_";S LRH=X;.03//"_LRD_";.02;.11////1;.06///"_LRAC_";10;.99",DR(2,63.12)=".01;S LRJ=$P(^LAB(61,X,0),U,4);S:'LRJ Y=4;2;4;S:'$D(LRB) Y=""@1"";1;1.5;3;@1;S:'$D(LRC) Y=0;5",DR(3,63.16)=".01;I '$D(LRB) S Y=0;1" Q
27CY S DR=".1///"_LRD_";S LRH=X;.03//"_LRD_";.02;.11////1;.06///"_LRAC_";10;.99",DR(2,63.912)=".01;4;S:'$D(LRB) Y=""@1"";1;1.5;3;@1;S:'$D(LRC) Y=0;5",DR(3,63.916)=".01;I '$D(LRB) S Y=0;1" Q
28EM S DR=".1///"_LRD_";S LRH=X;.03//"_LRD_";.02;.11////1;.06///"_LRAC_";10;.99",DR(2,63.212)=".01;4;S:'$D(LRB) Y=""@1"";1;1.5;3;@1;S:'$D(LRC) Y=0;5",DR(3,63.216)=".01;I '$D(LRB) S Y=0;1" Q
29 ;
30END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.