Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRWU4

LRWU4.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to ^DISV("LRACC") global supported by DBIA #510
  1. ;
  1. ; Variable LRVBY set/used by routine LRVER to determine if user
  1. ; verifying by accession or UID.
  1. ; If variable LRVBY evaluates to 1 then only select by accession.
  1. ; If LRVBY<1 or undefined then lookup also by UID.
  1. ;
  1. ; NOTE: variable LRACC if defined ($D(LRACC)) will require user to select accession area, date and number.
  1. ; if not defined then user is allowed to select accession area and date - used by some verifying options
  1. ; to select area and date then cycle through accession numbers for that area.
  1. EN ;
  1. N LRSCR
  1. S LRSCR=""
  1. ;
  1. ;
  1. SCR ; Screened entry point, called by ENA below
  1. ;
  1. N %,DIC,DIR,DIRUT,DUOUT,DTOUT,LRQUIT,LRX,X1,X2,X3
  1. K LRNATURE
  1. S U="^",DT=$$DT^XLFDT,LRQUIT=0
  1. F D AA Q:LRQUIT
  1. Q
  1. ;
  1. ;
  1. AA ;
  1. S DIR(0)="FO^1:30",DIR("A")="Select "_$S(LRSCR'="":LRSCR(0)_" ",1:"")_"Accession"_$S($G(LRVBY)=1:"",1:" or UID")
  1. S DIR("?")="^D QUES^LRWU4"
  1. D ^DIR
  1. I Y=""!$D(DIRUT) D QUIT Q
  1. S LRX=Y
  1. ;
  1. S:$L(LRX)>2 ^DISV(DUZ,"LRACC")=LRX
  1. S:LRX=" " LRX=$S($D(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
  1. S (LRAA,LRAD,LRAN)=0
  1. ;
  1. ; see if entry is UID
  1. I $G(LRVBY)<1,$D(^LRO(68,"C",LRX)) D UNIV Q
  1. ;
  1. ; Parse and process user input.
  1. S (X1,X2,X3)="",X1=$P(LRX," ",1),X2=$P(LRX," ",2),X3=$P(LRX," ",3)
  1. S:X3=""&(+X2=X2) X3=X2,X2=""
  1. I X1'?1A.ANP D QUES Q
  1. S LRAA=$O(^LRO(68,"B",X1,0))
  1. I LRAA,LRSCR'="",$P(^LRO(68,LRAA,0),"^",2)'=LRSCR S LRAA=0
  1. I LRAA<1 D WLQUES Q:LRAA<1
  1. S %=$P(^LRO(68,LRAA,0),U,14)
  1. S %=$$LKUP^XPDKEY(%)
  1. I %'="",'$D(^XUSEC(%,DUZ)) D WLQUES Q:LRAA<1
  1. ;
  1. S LRX=$G(^LRO(68,LRAA,0)),LRIDIV=$S($P(LRX,U,19)'="":$P(LRX,U,19),1:"CP")
  1. W !,$P(LRX,U)
  1. ;
  1. ; User entered only accession area identifier, no date or number
  1. I X2="",X3="" D
  1. . N %DT
  1. . S %DT="AEP",%DT("A")=" Accession Date: ",%DT("B")="TODAY"
  1. . D DATE^LRWU
  1. . I $D(DUOUT) D QUIT Q
  1. . I Y<1 D QUES Q
  1. . S LRAD=Y
  1. I LRQUIT Q
  1. ;
  1. ; Convert middle value to FileMan date
  1. ; Adjust for monthly and quarterly formats (MM00) if user enters 4 digit
  1. ; number as middle part of accession then convert to appropriate date.
  1. I LRAD<1 D
  1. . N %DT
  1. . I X2="" S X2=DT
  1. . I X2?4N D
  1. . . S X2=$E(DT,1,3)_X2
  1. . . I X2>DT S X2=X2-10000
  1. . S %DT="EP",X=X2
  1. . D ^%DT
  1. . I Y>0 S LRAD=Y Q
  1. . D QUES
  1. I LRAD<1 Q
  1. ;
  1. ; Convert date entered to appropriate date for accession area transform
  1. S X=$P(^LRO(68,LRAA,0),U,3)
  1. 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)
  1. W:X3>0 " ",+X3
  1. ;
  1. I X3="",$D(LRACC) D
  1. . N DIR,DIRUT,DUOUT,DTOUT,X,Y
  1. . S DIR(0)="NO^1:999999",DIR("A")=" Number part of Accession"
  1. . D ^DIR
  1. . I Y=""!$D(DIRUT) Q
  1. . S X3=Y
  1. ;
  1. I X3="",$D(LRACC) D QUIT Q
  1. S LRAN=+X3
  1. I LRAN<1,$D(LRACC) D QUES Q
  1. I $D(LRACC),'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
  1. . 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!"
  1. ;
  1. S LRQUIT=1
  1. Q
  1. ;
  1. ;
  1. QUIT ;
  1. S (LRAN,LRAA,LRAD)=-1
  1. END ;
  1. K X1,X2,X3,%DT,DIC,LRIDIV
  1. S LRQUIT=1
  1. Q
  1. ;
  1. ;
  1. ENA(LRSCR) ; Alternate entry to pass in file 63 subscript value to screen accession areas.
  1. ; Used for MI and AP accession lookup.
  1. ;
  1. S LRSCR(0)=$$EXTERNAL^DILFD(68,.02,"",LRSCR)
  1. D SCR
  1. Q
  1. ;
  1. ;
  1. UNIV ; see if entry is UID
  1. N LRY
  1. S LRY=$$CHECKUID(LRX,LRSCR)
  1. I 'LRY S (LRAA,LRAD,LRAN)=0 D QUES Q
  1. S LRAA=$P(LRY,"^",2),LRAD=$P(LRY,"^",3),LRAN=$P(LRY,"^",4)
  1. S LRQUIT=1
  1. W " (",$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^"),")"
  1. Q
  1. ;
  1. ;
  1. QUES ;
  1. W $C(7),!,"Enter the accession number",$S($G(LRVBY)<1:" or the unique identifier (UID)",1:""),"."
  1. W !,"If entering the accession number, enter in this format:"
  1. W !?5," <ACCESSION AREA> <DATE> <NUMBER>"
  1. 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"
  1. I LRSCR'="" W !,?5," Only accessions from subscript ",LRSCR(0)," are selectable."
  1. W:'$D(LRACC) !?5," or just the Accession area, or area and date."
  1. W:$D(LRACC) !?5," Must include the Accession area and the final number part."
  1. I $G(LRVBY)<1 W !,"If entering the UID, enter the entire 10-15 characters."
  1. Q
  1. ;
  1. ;
  1. WLQUES ; Ask user if accession area enter does not match any existing entries
  1. N DIC,X
  1. S X=X1,DIC="^LRO(68,",DIC(0)="EMOQ"
  1. S DIC("S")="Q:$D(LREXMPT) S %=$P(^(0),U,14) X ""I '$L(%)"" Q:$T S %=$$LKUP^XPDKEY(%) I $D(^XUSEC(%,DUZ))"
  1. I LRSCR'="" S DIC("S")="I $P(^(0),U,2)=LRSCR "_DIC("S")
  1. W !,X
  1. D ^DIC S LRAA=+Y
  1. Q
  1. ;
  1. ;
  1. SELBY(LRX1,LRX2) ; Select by accession number or unique identifier (UID)
  1. ; Call with LRX1 = message prompt
  1. ; LRX2 = default method
  1. ; Returns Y = 0 (abort), 1 (accession number), 2 (unique identifier)
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1. I $G(LRX1)="" S LRX1="Select UID"
  1. I $G(LRX2)<1 S LRX2=1
  1. S DIR(0)="SO^1:Accession Number;2:Unique Identifier (UID)",DIR("A")=LRX1,DIR("B")=LRX2
  1. D ^DIR
  1. I $D(DIRUT) S Y=0
  1. Q Y
  1. ;
  1. ;
  1. UID(LRX,LRY) ; Lookup accession by UID
  1. ; Call with LRX = message prompt
  1. ; LRY = default UID to display
  1. ; Returns Y = 0 (abort)
  1. ; = UID
  1. ;
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1. ;
  1. S LRX=$G(LRX,"Select UID")
  1. S DIR(0)="F^10:15^K:'$D(^LRO(68,""C"",X)) X"
  1. S DIR("A")=LRX,DIR("?")="Enter the full 10-15 character UID."
  1. I $G(LRY)'="" S DIR("B")=LRY
  1. D ^DIR
  1. I $D(DIRUT) S Y=0
  1. Q Y
  1. ;
  1. ;
  1. CHECKUID(LRX,LRSCR) ; Check if UID is valid, accession exists.
  1. ; Call with LRX = UID to check
  1. ; LRSCR = subscript screen
  1. ; Returns Y = 0 (accession does not exist)
  1. ; = 1 (accession exists)^area^date^number
  1. ;
  1. N LRY,Y
  1. ;
  1. S LRY=0,LRSCR=$G(LRSCR)
  1. S Y=$Q(^LRO(68,"C",LRX))
  1. I Y'="",$QS(Y,3)=LRX,+$QS(Y,4),+$QS(Y,5),+$QS(Y,6) D
  1. . I LRSCR'="",LRSCR'=$P(^LRO(68,$QS(Y,4),0),"^",2) Q
  1. . I '$D(^LRO(68,+$QS(Y,4),1,+$QS(Y,5),1,+$QS(Y,6),0)) Q
  1. . S LRY=1_"^"_$QS(Y,4)_"^"_$QS(Y,5)_"^"_+$QS(Y,6)
  1. Q LRY