source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRACC.m@ 1800

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

initial load of WorldVistAEHR

File size: 1.6 KB
Line 
1LRACC ;SLC/RWF - READ ACCESSION ; 7/10/87 17:38 ;
2 ;;5.2;LAB SERVICE;;Sep 27, 1994
3 K DUOUT,DTOUT S U="^" I '$D(DT) S X="T",%DT="" D ^%DT S DT=Y
4AA R !,"Select Accession: ",X:DTIME S:X[U DUOUT=1 G QUIT:X=""!$D(DUOUT),QUES:X["?"
5 S:$L(X)>2 ^DISV(DUZ,"LRACC")=X S:X=" " X=$S($D(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
6AC S (WL,WDT,WLE,LOG)=0,(X1,X2,X3)="",X1=$P(X," ",1),X2=$P(X," ",2),X3=$P(X," ",3)
7 S:X3=""&(+X2=X2) X3=X2,X2="" G AA:X1'?1A.AN S WL=$O(^LRO(68,"B",X1,0)) G WLQUES:WL<1
8AC2 W !,$P(^LRO(68,WL,0),U,1)
9 I X2="",X3="" S %DT="AE",%DT("A")=" Accession Date: ",%DT("B")="TODAY" D DATE^LRWU S WDT=Y G QUIT:$D(DUOUT),QUES:Y<1
10 I WDT<1 S:X2="" X2=DT S %DT="E",X=X2 D ^%DT S WDT=Y G QUES:Y<1
11 S X=$P(^LRO(68,WL,0),U,3),WDT=$S(X="D":WDT,X="M":$E(WDT,1,5)_"00",X="Y":$E(WDT,1,3)_"0000",1:WDT)
12 W:X3>0 " ",+X3
13AC4 I X3=""&$D(LRACC) R !," Number part of Accession: ",X3:DTIME G QUES:X3["?",QUIT:X3[U,QUES:X3<1!(X3>999999)
14 S WLE=+X3,LOG=WLE G QUES:WLE<1&$D(LRACC)
15 I $D(LRACC),'$D(^LRO(68,WL,1,WDT,1,WLE,0)) W !,"ACCESSION: ",$P(^LRO(68,WL,0),U,11),"/",$E(WDT,2,7),"/",WLE," DOES NOT EXIST!" G AA
16 K X1,X2,X3,%DT,DIC Q
17QUIT S (WLE,LOG,WL,WDT)=-1 K X1,X2,X3,%DT,DIC Q
18QUES W $C(7),!,"PLEASE ENTER ACCESSION IN THIS FORMAT.",!?5," <ACCESSION AREA> <DATE> <NUMBER>"
19 W !?5," ie. CH 0426 125 or CH 125 or CH T 125",!?5," or if it's a yearly accession area ie. MICRO 85 30173"
20 W:'$D(LRACC) !?5," or just the Accession area, or area and date."
21 W:$D(LRACC) !?5," Must include the Accession area and the final number part."
22 G AA
23WLQUES S X=X1,DIC="^LRO(68,",DIC(0)="EMQ" W !,X D ^DIC S WL=+Y G AA:Y<1,AC2
Note: See TracBrowser for help on using the repository browser.