- LRACC ; IHS/DIR/FJE - READ ACCESSION 7/10/87 17:38 ;
- ;;5.2;LR;**1013**;JUL 15, 2002
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- K DUOUT,DTOUT S U="^" I '$D(DT) S X="T",%DT="" D ^%DT S DT=Y
- AA R !,"Select Accession: ",X:DTIME S:X[U DUOUT=1 G QUIT:X=""!$D(DUOUT),QUES:X["?"
- S:$L(X)>2 ^DISV(DUZ,"LRACC")=X S:X=" " X=$S($D(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
- AC S (WL,WDT,WLE,LOG)=0,(X1,X2,X3)="",X1=$P(X," ",1),X2=$P(X," ",2),X3=$P(X," ",3)
- S:X3=""&(+X2=X2) X3=X2,X2="" G AA:X1'?1A.AN S WL=$O(^LRO(68,"B",X1,0)) G WLQUES:WL<1
- AC2 W !,$P(^LRO(68,WL,0),U,1)
- 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
- I WDT<1 S:X2="" X2=DT S %DT="E",X=X2 D ^%DT S WDT=Y G QUES:Y<1
- 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)
- W:X3>0 " ",+X3
- AC4 I X3=""&$D(LRACC) R !," Number part of Accession: ",X3:DTIME G QUES:X3["?",QUIT:X3[U,QUES:X3<1!(X3>999999)
- S WLE=+X3,LOG=WLE G QUES:WLE<1&$D(LRACC)
- 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
- K X1,X2,X3,%DT,DIC Q
- QUIT S (WLE,LOG,WL,WDT)=-1 K X1,X2,X3,%DT,DIC Q
- QUES W $C(7),!,"PLEASE ENTER ACCESSION IN THIS FORMAT.",!?5," <ACCESSION AREA> <DATE> <NUMBER>"
- 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"
- W:'$D(LRACC) !?5," or just the Accession area, or area and date."
- W:$D(LRACC) !?5," Must include the Accession area and the final number part."
- G AA
- WLQUES S X=X1,DIC="^LRO(68,",DIC(0)="EMQ" W !,X D ^DIC S WL=+Y G AA:Y<1,AC2
- LRACC ; IHS/DIR/FJE - READ ACCESSION 7/10/87 17:38 ;
- +1 ;;5.2;LR;**1013**;JUL 15, 2002
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 KILL DUOUT,DTOUT
- SET U="^"
- IF '$DATA(DT)
- SET X="T"
- SET %DT=""
- DO ^%DT
- SET DT=Y
- AA READ !,"Select Accession: ",X:DTIME
- IF X[U
- SET DUOUT=1
- IF X=""!$DATA(DUOUT)
- GOTO QUIT
- IF X["?"
- GOTO QUES
- +1 IF $LENGTH(X)>2
- SET ^DISV(DUZ,"LRACC")=X
- IF X=" "
- SET X=$SELECT($DATA(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
- AC SET (WL,WDT,WLE,LOG)=0
- SET (X1,X2,X3)=""
- SET X1=$PIECE(X," ",1)
- SET X2=$PIECE(X," ",2)
- SET X3=$PIECE(X," ",3)
- +1 IF X3=""&(+X2=X2)
- SET X3=X2
- SET X2=""
- IF X1'?1A.AN
- GOTO AA
- SET WL=$ORDER(^LRO(68,"B",X1,0))
- IF WL<1
- GOTO WLQUES
- AC2 WRITE !,$PIECE(^LRO(68,WL,0),U,1)
- +1 IF X2=""
- IF X3=""
- SET %DT="AE"
- SET %DT("A")=" Accession Date: "
- SET %DT("B")="TODAY"
- DO DATE^LRWU
- SET WDT=Y
- IF $DATA(DUOUT)
- GOTO QUIT
- IF Y<1
- GOTO QUES
- +2 IF WDT<1
- IF X2=""
- SET X2=DT
- SET %DT="E"
- SET X=X2
- DO ^%DT
- SET WDT=Y
- IF Y<1
- GOTO QUES
- +3 SET X=$PIECE(^LRO(68,WL,0),U,3)
- SET WDT=$SELECT(X="D":WDT,X="M":$EXTRACT(WDT,1,5)_"00",X="Y":$EXTRACT(WDT,1,3)_"0000",1:WDT)
- +4 IF X3>0
- WRITE " ",+X3
- AC4 IF X3=""&$DATA(LRACC)
- READ !," Number part of Accession: ",X3:DTIME
- IF X3["?"
- GOTO QUES
- IF X3[U
- GOTO QUIT
- IF X3<1!(X3>999999)
- GOTO QUES
- +1 SET WLE=+X3
- SET LOG=WLE
- IF WLE<1&$DATA(LRACC)
- GOTO QUES
- +2 IF $DATA(LRACC)
- IF '$DATA(^LRO(68,WL,1,WDT,1,WLE,0))
- WRITE !,"ACCESSION: ",$PIECE(^LRO(68,WL,0),U,11),"/",$EXTRACT(WDT,2,7),"/",WLE," DOES NOT EXIST!"
- GOTO AA
- +3 KILL X1,X2,X3,%DT,DIC
- QUIT
- QUIT SET (WLE,LOG,WL,WDT)=-1
- KILL X1,X2,X3,%DT,DIC
- QUIT
- QUES WRITE $CHAR(7),!,"PLEASE ENTER ACCESSION IN THIS FORMAT.",!?5," <ACCESSION AREA> <DATE> <NUMBER>"
- +1 WRITE !?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"
- +2 IF '$DATA(LRACC)
- WRITE !?5," or just the Accession area, or area and date."
- +3 IF $DATA(LRACC)
- WRITE !?5," Must include the Accession area and the final number part."
- +4 GOTO AA
- WLQUES SET X=X1
- SET DIC="^LRO(68,"
- SET DIC(0)="EMQ"
- WRITE !,X
- DO ^DIC
- SET WL=+Y
- IF Y<1
- GOTO AA
- GOTO AC2
