BLRWU4 ;VA/DALOI/RWF - READ ACCESSION ; 22-Oct-2013 09:22 ; MKK
;;5.2;LAB SERVICE;**1033**;NOV 01, 1997
;
; Clone of LRWU4 routine.
;
; Hard setting the LRVBY variable to 1. VA comments follow.
;
;;VA Patches: 128,153,201,271,402 ;Sep 27, 1994;Build 1
;
; Reference to ^DISV("LRACC") global supported by DBIA #510
;
; Variable LRVBY set/used by routine LRVER to determine if user
; verifying by accession or UID.
; If variable LRVBY evaluates to 1 then only select by accession.
; If LRVBY<1 or undefined then lookup also by UID.
;
EN ;
N %,DIC,DIR,DIRUT,DUOUT,DTOUT,LRQUIT,LRX
;
K LRNATURE
S U="^",DT=$$DT^XLFDT,LRQUIT=0
F D AA Q:LRQUIT
Q
;
;
AA ;
S DIR(0)="FO^1:30",DIR("A")="Select Accession"_$S($G(LRVBY)=1:"",1:" or UID")
S DIR("?")="^D QUES^BLRWU4"
D ^DIR
I Y=""!$D(DIRUT) D QUIT Q
S LRX=Y
S LRAS=X
;
S:$L(LRX)>2 ^DISV(DUZ,"LRACC")=LRX
S:LRX=" " LRX=$S($D(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
S (LRAA,LRAD,LRAN)=0
;
; see if entry is UID
I $G(LRVBY)<1,$D(^BLRARC68("C",LRX)) D UNIV Q
;
; Parse and process user input.
S (X1,X2,X3)="",X1=$P(LRX," ",1),X2=$P(LRX," ",2),X3=$P(LRX," ",3)
S:X3=""&(+X2=X2) X3=X2,X2=""
I X1'?1A.AN D QUES Q
S LRAA=$O(^BLRARC68("B",X1,0))
I LRAA<1 D WLQUES Q:LRAA<1
S %=$P(^BLRARC68(LRAA,0),U,14)
S %=$$LKUP^XPDKEY(%)
I $L(%),'$D(^XUSEC(%,DUZ)) D WLQUES Q:LRAA<1
;
S LRX=$G(^BLRARC68(LRAA,0)),LRIDIV=$S($L($P(LRX,U,19)):$P(LRX,U,19),1:"CP")
W !,$P(LRX,U)
;
; User entered only accession area identifier, no date or number
I X2="",X3="" D
. N %DT
. S %DT="AEP",%DT("A")=" Accession Date: ",%DT("B")="TODAY"
. D DATE^LRWU
. I $D(DUOUT) D QUIT Q
. I Y<1 D QUES Q
. S LRAD=Y
I LRQUIT Q
;
; Convert middle value to FileMan date
; Adjust for monthly and quarterly formats (MM00) if user enters 4 digit
; number as middle part of accession then convert to appropriate date.
I LRAD<1 D
. N %DT
. I X2="" S X2=DT
. I X2?4N D
. . S X2=$E(DT,1,3)_X2
. . I X2>DT S X2=X2-10000
. S %DT="EP",X=X2
. D ^%DT
. I Y>0 S LRAD=Y Q
. D QUES
I LRAD<1 Q
;
; Convert date entered to apropriate date for accession area transform
S X=$P(^BLRARC68(LRAA,0),U,3)
S LRAD=$S("D"[X:LRAD,X="Y":$E(LRAD,1,3)_"0000","M"[X:$E(LRAD,1,5)_"00","Q"[X:$E(LRAD,1,3)_"0000"+(($E(LRAD,4,5)-1)\3*300+100),1:LRAD)
W:X3>0 " ",+X3
;
I X3="",$D(LRACC) D
. N DIR,DIRUT,DUOUT,DTOUT,X,Y
. S DIR(0)="NO^1:999999",DIR("A")=" Number part of Accession"
. D ^DIR
. I Y=""!$D(DIRUT) Q
. S X3=Y
;
I X3="",$D(LRACC) D QUIT Q
S LRAN=+X3
I LRAN<1,$D(LRACC) D QUES Q
;
I $D(LRACC),'$D(^BLRARC68(LRAA,1,LRAD,1,LRAN,0)) D Q
. W !,"ACCESSION: ",$P(^BLRARC68(LRAA,0),U,11)," ",$$FMTE^XLFDT(LRAD,"5D")," ",LRAN," DOES NOT EXIST!"
;
S LRQUIT=1
Q
;
;
QUIT ;
S (LRAN,LRAA,LRAD)=-1
END ;
K X1,X2,X3,%DT,DIC,LRIDIV
S LRQUIT=1
Q
;
;
UNIV ; see if entry is UID
N LRY
S LRY=$$CHECKUID(LRX)
I 'LRY S (LRAA,LRAD,LRAN)=0 D QUES Q
S LRAA=$P(LRY,"^",2),LRAD=$P(LRY,"^",3),LRAN=$P(LRY,"^",4)
S LRQUIT=1
W " (",$P($G(^BLRARC68(LRAA,1,LRAD,1,LRAN,.2)),"^"),")"
Q
;
;
QUES ;
W $C(7),!,"Enter the accession number",$S($G(LRVBY)<1:" or the unique identifier (UID)",1:""),"."
W !,"If entering the accession number, enter in this format:"
W !?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."
I $G(LRVBY)<1 W !,"If entering the UID, enter the entire 10-15 characters."
Q
;
WLQUES ; Ask user if acession area enter does not match any existing entries
N DIC,X
S X=X1,DIC="^LRO(68,",DIC(0)="EMOQ"
S DIC("S")="Q:$D(LREXMPT) S %=$P(^(0),U,14) X ""I '$L(%)"" Q:$T S %=$$LKUP^XPDKEY(%) I $D(^XUSEC(%,DUZ))"
W !,X
D ^DIC S LRAA=+Y
Q
;
SELBY(X1) ; Select by accession number or unique identifier (UID)
; Call with X1 = message prompt
; Returns Y = 0 (abort)
; = 1 (accession number)
; = 2 (unique identifier)
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S X1=$G(X1,"Select UID")
S DIR(0)="SO^1:Accession Number;2:Unique Identifier (UID)",DIR("A")=X1,DIR("B")=1
D ^DIR
I $D(DIRUT) S Y=0
Q Y
;
UID(LRX,LRY) ; Lookup accession by UID
; Call with LRX = message prompt
; LRY = default UID to display
; Returns Y = 0 (abort)
; = UID
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
;
S LRX=$G(LRX,"Select UID")
S DIR(0)="F^10:10^K:'$D(^BLRARC68(""C"",X)) X"
S DIR("A")=LRX,DIR("?")="Enter the full 10 character UID"
I $L($G(LRY)) S DIR("B")=LRY
D ^DIR
I $D(DIRUT) S Y=0
Q Y
;
;
CHECKUID(LRX) ; Check if UID is valid, accession exists.
; Call with LRX = UID to check
; Returns Y = 0 (accession does not exist)
; = 1 (accession exists)^area^date^number
;
N LRY,Y
;
S LRY=0
S Y=$Q(^BLRARC68("C",LRX))
I $QS(Y,2)=LRX,+$QS(Y,3),+$QS(Y,4),+$QS(Y,5) D
. I '$D(^BLRARC68(+$QS(Y,3),1,+$QS(Y,4),1,+$QS(Y,5),0)) Q
. S LRY=1_"^"_$QS(Y,3)_"^"_$QS(Y,4)_"^"_+$QS(Y,5)
Q LRY
BLRWU4 ;VA/DALOI/RWF - READ ACCESSION ; 22-Oct-2013 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**1033**;NOV 01, 1997
+2 ;
+3 ; Clone of LRWU4 routine.
+4 ;
+5 ; Hard setting the LRVBY variable to 1. VA comments follow.
+6 ;
+7 ;;VA Patches: 128,153,201,271,402 ;Sep 27, 1994;Build 1
+8 ;
+9 ; Reference to ^DISV("LRACC") global supported by DBIA #510
+10 ;
+11 ; Variable LRVBY set/used by routine LRVER to determine if user
+12 ; verifying by accession or UID.
+13 ; If variable LRVBY evaluates to 1 then only select by accession.
+14 ; If LRVBY<1 or undefined then lookup also by UID.
+15 ;
EN ;
+1 NEW %,DIC,DIR,DIRUT,DUOUT,DTOUT,LRQUIT,LRX
+2 ;
+3 KILL LRNATURE
+4 SET U="^"
SET DT=$$DT^XLFDT
SET LRQUIT=0
+5 FOR
DO AA
IF LRQUIT
QUIT
+6 QUIT
+7 ;
+8 ;
AA ;
+1 SET DIR(0)="FO^1:30"
SET DIR("A")="Select Accession"_$SELECT($GET(LRVBY)=1:"",1:" or UID")
+2 SET DIR("?")="^D QUES^BLRWU4"
+3 DO ^DIR
+4 IF Y=""!$DATA(DIRUT)
DO QUIT
QUIT
+5 SET LRX=Y
+6 SET LRAS=X
+7 ;
+8 IF $LENGTH(LRX)>2
SET ^DISV(DUZ,"LRACC")=LRX
+9 IF LRX=" "
SET LRX=$SELECT($DATA(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
+10 SET (LRAA,LRAD,LRAN)=0
+11 ;
+12 ; see if entry is UID
+13 IF $GET(LRVBY)<1
IF $DATA(^BLRARC68("C",LRX))
DO UNIV
QUIT
+14 ;
+15 ; Parse and process user input.
+16 SET (X1,X2,X3)=""
SET X1=$PIECE(LRX," ",1)
SET X2=$PIECE(LRX," ",2)
SET X3=$PIECE(LRX," ",3)
+17 IF X3=""&(+X2=X2)
SET X3=X2
SET X2=""
+18 IF X1'?1A.AN
DO QUES
QUIT
+19 SET LRAA=$ORDER(^BLRARC68("B",X1,0))
+20 IF LRAA<1
DO WLQUES
IF LRAA<1
QUIT
+21 SET %=$PIECE(^BLRARC68(LRAA,0),U,14)
+22 SET %=$$LKUP^XPDKEY(%)
+23 IF $LENGTH(%)
IF '$DATA(^XUSEC(%,DUZ))
DO WLQUES
IF LRAA<1
QUIT
+24 ;
+25 SET LRX=$GET(^BLRARC68(LRAA,0))
SET LRIDIV=$SELECT($LENGTH($PIECE(LRX,U,19)):$PIECE(LRX,U,19),1:"CP")
+26 WRITE !,$PIECE(LRX,U)
+27 ;
+28 ; User entered only accession area identifier, no date or number
+29 IF X2=""
IF X3=""
Begin DoDot:1
+30 NEW %DT
+31 SET %DT="AEP"
SET %DT("A")=" Accession Date: "
SET %DT("B")="TODAY"
+32 DO DATE^LRWU
+33 IF $DATA(DUOUT)
DO QUIT
QUIT
+34 IF Y<1
DO QUES
QUIT
+35 SET LRAD=Y
End DoDot:1
+36 IF LRQUIT
QUIT
+37 ;
+38 ; Convert middle value to FileMan date
+39 ; Adjust for monthly and quarterly formats (MM00) if user enters 4 digit
+40 ; number as middle part of accession then convert to appropriate date.
+41 IF LRAD<1
Begin DoDot:1
+42 NEW %DT
+43 IF X2=""
SET X2=DT
+44 IF X2?4N
Begin DoDot:2
+45 SET X2=$EXTRACT(DT,1,3)_X2
+46 IF X2>DT
SET X2=X2-10000
End DoDot:2
+47 SET %DT="EP"
SET X=X2
+48 DO ^%DT
+49 IF Y>0
SET LRAD=Y
QUIT
+50 DO QUES
End DoDot:1
+51 IF LRAD<1
QUIT
+52 ;
+53 ; Convert date entered to apropriate date for accession area transform
+54 SET X=$PIECE(^BLRARC68(LRAA,0),U,3)
+55 SET LRAD=$SELECT("D"[X:LRAD,X="Y":$EXTRACT(LRAD,1,3)_"0000","M"[X:$EXTRACT(LRAD,1,5)_"00","Q"[X:$EXTRACT(LRAD,1,3)_"0000"+(($EXTRACT(LRAD,4,5)-1)\3*300+100),1:LRAD)
+56 IF X3>0
WRITE " ",+X3
+57 ;
+58 IF X3=""
IF $DATA(LRACC)
Begin DoDot:1
+59 NEW DIR,DIRUT,DUOUT,DTOUT,X,Y
+60 SET DIR(0)="NO^1:999999"
SET DIR("A")=" Number part of Accession"
+61 DO ^DIR
+62 IF Y=""!$DATA(DIRUT)
QUIT
+63 SET X3=Y
End DoDot:1
+64 ;
+65 IF X3=""
IF $DATA(LRACC)
DO QUIT
QUIT
+66 SET LRAN=+X3
+67 IF LRAN<1
IF $DATA(LRACC)
DO QUES
QUIT
+68 ;
+69 IF $DATA(LRACC)
IF '$DATA(^BLRARC68(LRAA,1,LRAD,1,LRAN,0))
Begin DoDot:1
+70 WRITE !,"ACCESSION: ",$PIECE(^BLRARC68(LRAA,0),U,11)," ",$$FMTE^XLFDT(LRAD,"5D")," ",LRAN," DOES NOT EXIST!"
End DoDot:1
QUIT
+71 ;
+72 SET LRQUIT=1
+73 QUIT
+74 ;
+75 ;
QUIT ;
+1 SET (LRAN,LRAA,LRAD)=-1
END ;
+1 KILL X1,X2,X3,%DT,DIC,LRIDIV
+2 SET LRQUIT=1
+3 QUIT
+4 ;
+5 ;
UNIV ; see if entry is UID
+1 NEW LRY
+2 SET LRY=$$CHECKUID(LRX)
+3 IF 'LRY
SET (LRAA,LRAD,LRAN)=0
DO QUES
QUIT
+4 SET LRAA=$PIECE(LRY,"^",2)
SET LRAD=$PIECE(LRY,"^",3)
SET LRAN=$PIECE(LRY,"^",4)
+5 SET LRQUIT=1
+6 WRITE " (",$PIECE($GET(^BLRARC68(LRAA,1,LRAD,1,LRAN,.2)),"^"),")"
+7 QUIT
+8 ;
+9 ;
QUES ;
+1 WRITE $CHAR(7),!,"Enter the accession number",$SELECT($GET(LRVBY)<1:" or the unique identifier (UID)",1:""),"."
+2 WRITE !,"If entering the accession number, enter in this format:"
+3 WRITE !?5," <ACCESSION AREA> <DATE> <NUMBER>"
+4 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"
+5 IF '$DATA(LRACC)
WRITE !?5," or just the Accession area, or area and date."
+6 IF $DATA(LRACC)
WRITE !?5," Must include the Accession area and the final number part."
+7 IF $GET(LRVBY)<1
WRITE !,"If entering the UID, enter the entire 10-15 characters."
+8 QUIT
+9 ;
WLQUES ; Ask user if acession area enter does not match any existing entries
+1 NEW DIC,X
+2 SET X=X1
SET DIC="^LRO(68,"
SET DIC(0)="EMOQ"
+3 SET DIC("S")="Q:$D(LREXMPT) S %=$P(^(0),U,14) X ""I '$L(%)"" Q:$T S %=$$LKUP^XPDKEY(%) I $D(^XUSEC(%,DUZ))"
+4 WRITE !,X
+5 DO ^DIC
SET LRAA=+Y
+6 QUIT
+7 ;
SELBY(X1) ; Select by accession number or unique identifier (UID)
+1 ; Call with X1 = message prompt
+2 ; Returns Y = 0 (abort)
+3 ; = 1 (accession number)
+4 ; = 2 (unique identifier)
+5 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+6 SET X1=$GET(X1,"Select UID")
+7 SET DIR(0)="SO^1:Accession Number;2:Unique Identifier (UID)"
SET DIR("A")=X1
SET DIR("B")=1
+8 DO ^DIR
+9 IF $DATA(DIRUT)
SET Y=0
+10 QUIT Y
+11 ;
UID(LRX,LRY) ; Lookup accession by UID
+1 ; Call with LRX = message prompt
+2 ; LRY = default UID to display
+3 ; Returns Y = 0 (abort)
+4 ; = UID
+5 ;
+6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+7 ;
+8 SET LRX=$GET(LRX,"Select UID")
+9 SET DIR(0)="F^10:10^K:'$D(^BLRARC68(""C"",X)) X"
+10 SET DIR("A")=LRX
SET DIR("?")="Enter the full 10 character UID"
+11 IF $LENGTH($GET(LRY))
SET DIR("B")=LRY
+12 DO ^DIR
+13 IF $DATA(DIRUT)
SET Y=0
+14 QUIT Y
+15 ;
+16 ;
CHECKUID(LRX) ; Check if UID is valid, accession exists.
+1 ; Call with LRX = UID to check
+2 ; Returns Y = 0 (accession does not exist)
+3 ; = 1 (accession exists)^area^date^number
+4 ;
+5 NEW LRY,Y
+6 ;
+7 SET LRY=0
+8 SET Y=$QUERY(^BLRARC68("C",LRX))
+9 IF $QSUBSCRIPT(Y,2)=LRX
IF +$QSUBSCRIPT(Y,3)
IF +$QSUBSCRIPT(Y,4)
IF +$QSUBSCRIPT(Y,5)
Begin DoDot:1
+10 IF '$DATA(^BLRARC68(+$QSUBSCRIPT(Y,3),1,+$QSUBSCRIPT(Y,4),1,+$QSUBSCRIPT(Y,5),0))
QUIT
+11 SET LRY=1_"^"_$QSUBSCRIPT(Y,3)_"^"_$QSUBSCRIPT(Y,4)_"^"_+$QSUBSCRIPT(Y,5)
End DoDot:1
+12 QUIT LRY
