- 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 Jan 18, 2025@03:24 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