LRWU4 ;DALOI/RWF - READ ACCESSION ;10/28/10 17:22
;;5.2;LAB SERVICE;**128,153,201,271,402,350**;Sep 27, 1994;Build 230
;
; 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.
;
; NOTE: variable LRACC if defined ($D(LRACC)) will require user to select accession area, date and number.
; if not defined then user is allowed to select accession area and date - used by some verifying options
; to select area and date then cycle through accession numbers for that area.
EN ;
N LRSCR
S LRSCR=""
;
;
SCR ; Screened entry point, called by ENA below
;
N %,DIC,DIR,DIRUT,DUOUT,DTOUT,LRQUIT,LRX,X1,X2,X3
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 "_$S(LRSCR'="":LRSCR(0)_" ",1:"")_"Accession"_$S($G(LRVBY)=1:"",1:" or UID")
S DIR("?")="^D QUES^LRWU4"
D ^DIR
I Y=""!$D(DIRUT) D QUIT Q
S LRX=Y
;
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(^LRO(68,"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.ANP D QUES Q
S LRAA=$O(^LRO(68,"B",X1,0))
I LRAA,LRSCR'="",$P(^LRO(68,LRAA,0),"^",2)'=LRSCR S LRAA=0
I LRAA<1 D WLQUES Q:LRAA<1
S %=$P(^LRO(68,LRAA,0),U,14)
S %=$$LKUP^XPDKEY(%)
I %'="",'$D(^XUSEC(%,DUZ)) D WLQUES Q:LRAA<1
;
S LRX=$G(^LRO(68,LRAA,0)),LRIDIV=$S($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 appropriate date for accession area transform
S X=$P(^LRO(68,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(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
. W !,"ACCESSION: ",$P(^LRO(68,LRAA,0),U,11)," ",$S(LRAD["0000":$E(LRAD,2,3),1:$E(LRAD,4,7))," ",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
;
;
ENA(LRSCR) ; Alternate entry to pass in file 63 subscript value to screen accession areas.
; Used for MI and AP accession lookup.
;
S LRSCR(0)=$$EXTERNAL^DILFD(68,.02,"",LRSCR)
D SCR
Q
;
;
UNIV ; see if entry is UID
N LRY
S LRY=$$CHECKUID(LRX,LRSCR)
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(^LRO(68,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"
I LRSCR'="" W !,?5," Only accessions from subscript ",LRSCR(0)," are selectable."
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 accession 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))"
I LRSCR'="" S DIC("S")="I $P(^(0),U,2)=LRSCR "_DIC("S")
W !,X
D ^DIC S LRAA=+Y
Q
;
;
SELBY(LRX1,LRX2) ; Select by accession number or unique identifier (UID)
; Call with LRX1 = message prompt
; LRX2 = default method
; Returns Y = 0 (abort), 1 (accession number), 2 (unique identifier)
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
I $G(LRX1)="" S LRX1="Select UID"
I $G(LRX2)<1 S LRX2=1
S DIR(0)="SO^1:Accession Number;2:Unique Identifier (UID)",DIR("A")=LRX1,DIR("B")=LRX2
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:15^K:'$D(^LRO(68,""C"",X)) X"
S DIR("A")=LRX,DIR("?")="Enter the full 10-15 character UID."
I $G(LRY)'="" S DIR("B")=LRY
D ^DIR
I $D(DIRUT) S Y=0
Q Y
;
;
CHECKUID(LRX,LRSCR) ; Check if UID is valid, accession exists.
; Call with LRX = UID to check
; LRSCR = subscript screen
; Returns Y = 0 (accession does not exist)
; = 1 (accession exists)^area^date^number
;
N LRY,Y
;
S LRY=0,LRSCR=$G(LRSCR)
S Y=$Q(^LRO(68,"C",LRX))
I Y'="",$QS(Y,3)=LRX,+$QS(Y,4),+$QS(Y,5),+$QS(Y,6) D
. I LRSCR'="",LRSCR'=$P(^LRO(68,$QS(Y,4),0),"^",2) Q
. I '$D(^LRO(68,+$QS(Y,4),1,+$QS(Y,5),1,+$QS(Y,6),0)) Q
. S LRY=1_"^"_$QS(Y,4)_"^"_$QS(Y,5)_"^"_+$QS(Y,6)
Q LRY
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRWU4 6110 printed Dec 13, 2024@02:23:18 Page 2
LRWU4 ;DALOI/RWF - READ ACCESSION ;10/28/10 17:22
+1 ;;5.2;LAB SERVICE;**128,153,201,271,402,350**;Sep 27, 1994;Build 230
+2 ;
+3 ; Reference to ^DISV("LRACC") global supported by DBIA #510
+4 ;
+5 ; Variable LRVBY set/used by routine LRVER to determine if user
+6 ; verifying by accession or UID.
+7 ; If variable LRVBY evaluates to 1 then only select by accession.
+8 ; If LRVBY<1 or undefined then lookup also by UID.
+9 ;
+10 ; NOTE: variable LRACC if defined ($D(LRACC)) will require user to select accession area, date and number.
+11 ; if not defined then user is allowed to select accession area and date - used by some verifying options
+12 ; to select area and date then cycle through accession numbers for that area.
EN ;
+1 NEW LRSCR
+2 SET LRSCR=""
+3 ;
+4 ;
SCR ; Screened entry point, called by ENA below
+1 ;
+2 NEW %,DIC,DIR,DIRUT,DUOUT,DTOUT,LRQUIT,LRX,X1,X2,X3
+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 "_$SELECT(LRSCR'="":LRSCR(0)_" ",1:"")_"Accession"_$SELECT($GET(LRVBY)=1:"",1:" or UID")
+2 SET DIR("?")="^D QUES^LRWU4"
+3 DO ^DIR
+4 IF Y=""!$DATA(DIRUT)
DO QUIT
QUIT
+5 SET LRX=Y
+6 ;
+7 if $LENGTH(LRX)>2
SET ^DISV(DUZ,"LRACC")=LRX
+8 if LRX=" "
SET LRX=$SELECT($DATA(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
+9 SET (LRAA,LRAD,LRAN)=0
+10 ;
+11 ; see if entry is UID
+12 IF $GET(LRVBY)<1
IF $DATA(^LRO(68,"C",LRX))
DO UNIV
QUIT
+13 ;
+14 ; Parse and process user input.
+15 SET (X1,X2,X3)=""
SET X1=$PIECE(LRX," ",1)
SET X2=$PIECE(LRX," ",2)
SET X3=$PIECE(LRX," ",3)
+16 if X3=""&(+X2=X2)
SET X3=X2
SET X2=""
+17 IF X1'?1A.ANP
DO QUES
QUIT
+18 SET LRAA=$ORDER(^LRO(68,"B",X1,0))
+19 IF LRAA
IF LRSCR'=""
IF $PIECE(^LRO(68,LRAA,0),"^",2)'=LRSCR
SET LRAA=0
+20 IF LRAA<1
DO WLQUES
if LRAA<1
QUIT
+21 SET %=$PIECE(^LRO(68,LRAA,0),U,14)
+22 SET %=$$LKUP^XPDKEY(%)
+23 IF %'=""
IF '$DATA(^XUSEC(%,DUZ))
DO WLQUES
if LRAA<1
QUIT
+24 ;
+25 SET LRX=$GET(^LRO(68,LRAA,0))
SET LRIDIV=$SELECT($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 appropriate date for accession area transform
+54 SET X=$PIECE(^LRO(68,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 IF $DATA(LRACC)
IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
Begin DoDot:1
+69 WRITE !,"ACCESSION: ",$PIECE(^LRO(68,LRAA,0),U,11)," ",$SELECT(LRAD["0000":$EXTRACT(LRAD,2,3),1:$EXTRACT(LRAD,4,7))," ",LRAN," DOES NOT EXIST!"
End DoDot:1
QUIT
+70 ;
+71 SET LRQUIT=1
+72 QUIT
+73 ;
+74 ;
QUIT ;
+1 SET (LRAN,LRAA,LRAD)=-1
END ;
+1 KILL X1,X2,X3,%DT,DIC,LRIDIV
+2 SET LRQUIT=1
+3 QUIT
+4 ;
+5 ;
ENA(LRSCR) ; Alternate entry to pass in file 63 subscript value to screen accession areas.
+1 ; Used for MI and AP accession lookup.
+2 ;
+3 SET LRSCR(0)=$$EXTERNAL^DILFD(68,.02,"",LRSCR)
+4 DO SCR
+5 QUIT
+6 ;
+7 ;
UNIV ; see if entry is UID
+1 NEW LRY
+2 SET LRY=$$CHECKUID(LRX,LRSCR)
+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(^LRO(68,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 LRSCR'=""
WRITE !,?5," Only accessions from subscript ",LRSCR(0)," are selectable."
+6 if '$DATA(LRACC)
WRITE !?5," or just the Accession area, or area and date."
+7 if $DATA(LRACC)
WRITE !?5," Must include the Accession area and the final number part."
+8 IF $GET(LRVBY)<1
WRITE !,"If entering the UID, enter the entire 10-15 characters."
+9 QUIT
+10 ;
+11 ;
WLQUES ; Ask user if accession 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 IF LRSCR'=""
SET DIC("S")="I $P(^(0),U,2)=LRSCR "_DIC("S")
+5 WRITE !,X
+6 DO ^DIC
SET LRAA=+Y
+7 QUIT
+8 ;
+9 ;
SELBY(LRX1,LRX2) ; Select by accession number or unique identifier (UID)
+1 ; Call with LRX1 = message prompt
+2 ; LRX2 = default method
+3 ; Returns Y = 0 (abort), 1 (accession number), 2 (unique identifier)
+4 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+5 IF $GET(LRX1)=""
SET LRX1="Select UID"
+6 IF $GET(LRX2)<1
SET LRX2=1
+7 SET DIR(0)="SO^1:Accession Number;2:Unique Identifier (UID)"
SET DIR("A")=LRX1
SET DIR("B")=LRX2
+8 DO ^DIR
+9 IF $DATA(DIRUT)
SET Y=0
+10 QUIT Y
+11 ;
+12 ;
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:15^K:'$D(^LRO(68,""C"",X)) X"
+10 SET DIR("A")=LRX
SET DIR("?")="Enter the full 10-15 character UID."
+11 IF $GET(LRY)'=""
SET DIR("B")=LRY
+12 DO ^DIR
+13 IF $DATA(DIRUT)
SET Y=0
+14 QUIT Y
+15 ;
+16 ;
CHECKUID(LRX,LRSCR) ; Check if UID is valid, accession exists.
+1 ; Call with LRX = UID to check
+2 ; LRSCR = subscript screen
+3 ; Returns Y = 0 (accession does not exist)
+4 ; = 1 (accession exists)^area^date^number
+5 ;
+6 NEW LRY,Y
+7 ;
+8 SET LRY=0
SET LRSCR=$GET(LRSCR)
+9 SET Y=$QUERY(^LRO(68,"C",LRX))
+10 IF Y'=""
IF $QSUBSCRIPT(Y,3)=LRX
IF +$QSUBSCRIPT(Y,4)
IF +$QSUBSCRIPT(Y,5)
IF +$QSUBSCRIPT(Y,6)
Begin DoDot:1
+11 IF LRSCR'=""
IF LRSCR'=$PIECE(^LRO(68,$QSUBSCRIPT(Y,4),0),"^",2)
QUIT
+12 IF '$DATA(^LRO(68,+$QSUBSCRIPT(Y,4),1,+$QSUBSCRIPT(Y,5),1,+$QSUBSCRIPT(Y,6),0))
QUIT
+13 SET LRY=1_"^"_$QSUBSCRIPT(Y,4)_"^"_$QSUBSCRIPT(Y,5)_"^"_+$QSUBSCRIPT(Y,6)
End DoDot:1
+14 QUIT LRY
