LRMIU4 ;SLC/RWF,BA - READ MICRO ACCESSION ; 2/27/89 08:33 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
;from LRMIEDZ, LRMIPSZ
START K DUOUT,DTOUT S U="^" D AA
S:LROK=1 (LRAN,LRAA,LRAD)=-1 K X1,X2,X3,%DT,DIC,LROK
Q
AA S X="T",%DT="" D ^%DT S DT=Y
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
Q
ACC S:$L(X)>2 ^DISV(DUZ,"LRACC")=X S:X=" " X=$S($D(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
S (LRAA,LRAD,LRAN)=0,(X1,X2,X3)="",X1=$P(X," "),X2=$P(X," ",2),X3=$P(X," ",3)
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
I $P(^LRO(68,LRAA,0),U,2)'="MI" D QUES Q
W !,$P(^LRO(68,LRAA,0),U)
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
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
S LRAD=$E(LRAD,1,3)_"0000"
W:X3>0 " ",+X3
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
S LRAN=+X3 I LRAN<1 D QUES Q
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
S LROK=2
Q
NQUES W !?5,"Enter just the number here, or you may:"
QUES W $C(7),!,"ENTER THE ACCESSION IN THIS FORMAT.",!?5," <ACCESSION AREA> <DATE> <NUMBER>"
W !?5," ie. MICRO 87 30173 or MICRO 30173"
W !?5," Must be a MICROBIOLOGY accession area."
W !?5," May enter just the Accession area, or area and number."
Q
LRANX ;from LRMIEDZ2, LRMIPSZ
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
I LRAN<1!(LRAN>999999)!(LRAN'?1N.N) S LRANOK=0 Q
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"Doesn't exist." S LRANOK=0 Q
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) W !,"Incomplete data available." S LRANOK=0 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMIU4 2064 printed Dec 13, 2024@02:17:40 Page 2
LRMIU4 ;SLC/RWF,BA - READ MICRO ACCESSION ; 2/27/89 08:33 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 ;from LRMIEDZ, LRMIPSZ
START KILL DUOUT,DTOUT
SET U="^"
DO AA
+1 if LROK=1
SET (LRAN,LRAA,LRAD)=-1
KILL X1,X2,X3,%DT,DIC,LROK
+2 QUIT
AA SET X="T"
SET %DT=""
DO ^%DT
SET DT=Y
+1 SET LROK=0
FOR I=0:0
READ !,"Select Microbiology Accession: ",X:DTIME
if X=""!(X[U)
SET LROK=1
if LROK
QUIT
if X["?"
DO QUES
IF X'["?"
DO ACC
if LROK
QUIT
+2 QUIT
ACC if $LENGTH(X)>2
SET ^DISV(DUZ,"LRACC")=X
if X=" "
SET X=$SELECT($DATA(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
+1 SET (LRAA,LRAD,LRAN)=0
SET (X1,X2,X3)=""
SET X1=$PIECE(X," ")
SET X2=$PIECE(X," ",2)
SET X3=$PIECE(X," ",3)
+2 if X3=""&(+X2=X2)
SET X3=X2
SET X2=""
if X1'?1A.AN
QUIT
SET LRAA=+$ORDER(^LRO(68,"B",X1,0))
IF LRAA<1
SET X=X1
SET DIC=68
SET DIC(0)="EMQ"
SET DIC("S")="I $P(^(0),U,2)=""MI"""
WRITE !,X
DO ^DIC
KILL DIC
SET LRAA=+Y
IF Y<1
QUIT
+3 IF $PIECE(^LRO(68,LRAA,0),U,2)'="MI"
DO QUES
QUIT
+4 WRITE !,$PIECE(^LRO(68,LRAA,0),U)
+5 IF X2=""
IF X3=""
SET %DT="AE"
SET %DT("A")=" Accession Date: "
SET %DT("B")=$EXTRACT(DT,2,3)
DO DATE^LRWU
SET LRAD=Y
if $DATA(DUOUT)
SET LROK=1
if LROK
QUIT
IF Y<1
DO QUES
QUIT
+6 IF LRAD<1
if X2=""
SET X2=$EXTRACT(DT,1,3)_"0000"
SET %DT="E"
SET X=X2
DO ^%DT
SET LRAD=Y
IF Y<1
DO QUES
QUIT
+7 SET LRAD=$EXTRACT(LRAD,1,3)_"0000"
+8 if X3>0
WRITE " ",+X3
+9 IF X3=""
READ !," Number part of Accession: ",X3:DTIME
if X3[U
SET LROK=1
if LROK
QUIT
IF X3<1!(X3>999999)!(X'?1N.N)
DO NQUES
QUIT
+10 SET LRAN=+X3
IF LRAN<1
DO QUES
QUIT
+11 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE !,"ACCESSION: ",$PIECE(^LRO(68,LRAA,0),U,11)," ",$EXTRACT(LRAD,2,3)," ",LRAN," DOES NOT EXIST!"
QUIT
+12 SET LROK=2
+13 QUIT
NQUES WRITE !?5,"Enter just the number here, or you may:"
QUES WRITE $CHAR(7),!,"ENTER THE ACCESSION IN THIS FORMAT.",!?5," <ACCESSION AREA> <DATE> <NUMBER>"
+1 WRITE !?5," ie. MICRO 87 30173 or MICRO 30173"
+2 WRITE !?5," Must be a MICROBIOLOGY accession area."
+3 WRITE !?5," May enter just the Accession area, or area and number."
+4 QUIT
LRANX ;from LRMIEDZ2, LRMIPSZ
+1 if $LENGTH(X)>2
SET ^DISV(DUZ,"LRAN")=X
if X=" "
WRITE $SELECT($DATA(^DISV(DUZ,"LRAN")):^("LRAN"),1:"")
if X=" "
SET X=$SELECT($DATA(^DISV(DUZ,"LRAN")):^("LRAN"),1:"?")
SET LRAN=X
+2 IF LRAN<1!(LRAN>999999)!(LRAN'?1N.N)
SET LRANOK=0
QUIT
+3 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE !,"Doesn't exist."
SET LRANOK=0
QUIT
+4 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
WRITE !,"Incomplete data available."
SET LRANOK=0
QUIT
+5 QUIT
