source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRMIU4.m@ 811

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

initial load of FOIAVistA 6/30/08 version

File size: 2.0 KB
Line 
1LRMIU4 ;SLC/RWF,BA - READ MICRO ACCESSION ; 2/27/89 08:33 ;
2 ;;5.2;LAB SERVICE;;Sep 27, 1994
3 ;from LRMIEDZ, LRMIPSZ
4START K DUOUT,DTOUT S U="^" D AA
5 S:LROK=1 (LRAN,LRAA,LRAD)=-1 K X1,X2,X3,%DT,DIC,LROK
6 Q
7AA S X="T",%DT="" D ^%DT S DT=Y
8 S LROK=0 F I=0:0 R !,"Select Microbiology Accession: ",X:DTIME S:X=""!(X[U) LROK=1 Q:LROK D:X["?" QUES I X'["?" D ACC Q:LROK
9 Q
10ACC S:$L(X)>2 ^DISV(DUZ,"LRACC")=X S:X=" " X=$S($D(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
11 S (LRAA,LRAD,LRAN)=0,(X1,X2,X3)="",X1=$P(X," "),X2=$P(X," ",2),X3=$P(X," ",3)
12 S:X3=""&(+X2=X2) X3=X2,X2="" Q:X1'?1A.AN S LRAA=+$O(^LRO(68,"B",X1,0)) I LRAA<1 S X=X1,DIC=68,DIC(0)="EMQ",DIC("S")="I $P(^(0),U,2)=""MI""" W !,X D ^DIC K DIC S LRAA=+Y I Y<1 Q
13 I $P(^LRO(68,LRAA,0),U,2)'="MI" D QUES Q
14 W !,$P(^LRO(68,LRAA,0),U)
15 I X2="",X3="" S %DT="AE",%DT("A")=" Accession Date: ",%DT("B")=$E(DT,2,3) D DATE^LRWU S LRAD=Y S:$D(DUOUT) LROK=1 Q:LROK I Y<1 D QUES Q
16 I LRAD<1 S:X2="" X2=$E(DT,1,3)_"0000" S %DT="E",X=X2 D ^%DT S LRAD=Y I Y<1 D QUES Q
17 S LRAD=$E(LRAD,1,3)_"0000"
18 W:X3>0 " ",+X3
19 I X3="" R !," Number part of Accession: ",X3:DTIME S:X3[U LROK=1 Q:LROK I X3<1!(X3>999999)!(X'?1N.N) D NQUES Q
20 S LRAN=+X3 I LRAN<1 D QUES Q
21 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"ACCESSION: ",$P(^LRO(68,LRAA,0),U,11)," ",$E(LRAD,2,3)," ",LRAN," DOES NOT EXIST!" Q
22 S LROK=2
23 Q
24NQUES W !?5,"Enter just the number here, or you may:"
25QUES W $C(7),!,"ENTER THE ACCESSION IN THIS FORMAT.",!?5," <ACCESSION AREA> <DATE> <NUMBER>"
26 W !?5," ie. MICRO 87 30173 or MICRO 30173"
27 W !?5," Must be a MICROBIOLOGY accession area."
28 W !?5," May enter just the Accession area, or area and number."
29 Q
30LRANX ;from LRMIEDZ2, LRMIPSZ
31 S:$L(X)>2 ^DISV(DUZ,"LRAN")=X W:X=" " $S($D(^DISV(DUZ,"LRAN")):^("LRAN"),1:"") S:X=" " X=$S($D(^DISV(DUZ,"LRAN")):^("LRAN"),1:"?") S LRAN=X
32 I LRAN<1!(LRAN>999999)!(LRAN'?1N.N) S LRANOK=0 Q
33 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"Doesn't exist." S LRANOK=0 Q
34 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) W !,"Incomplete data available." S LRANOK=0 Q
35 Q
Note: See TracBrowser for help on using the repository browser.