- LRMIU4 ; IHS/DIR/FJE - READ MICRO ACCESSION 2/27/89 08:33 ;
- ;;5.2;LR;**1013**;JUL 15, 2002
- ;
- ;;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
- LRMIU4 ; IHS/DIR/FJE - READ MICRO ACCESSION 2/27/89 08:33 ;
- +1 ;;5.2;LR;**1013**;JUL 15, 2002
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 ;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
