LRACC.m

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