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 ;VA/DALOI/RWF - READ ACCESSION ; 13-Aug-2013 09:14 ; MKK
  1.  ;;5.2;LAB SERVICE;**1006,1013,128,153,201,271,1018,402,1033**;NOV 01, 1997
  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. EN ;
  1.  N %,DIC,DIR,DIRUT,DUOUT,DTOUT,LRQUIT,LRX
  1.  ;
  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 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.  S BLRLRAS=$G(X)
  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.AN D QUES Q
  1.  S LRAA=$O(^LRO(68,"B",X1,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 $L(%),'$D(^XUSEC(%,DUZ)) D WLQUES Q:LRAA<1
  1.  ;
  1.  S LRX=$G(^LRO(68,LRAA,0)),LRIDIV=$S($L($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 apropriate 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)," ",$$FMTE^XLFDT(LRAD,"5D")," ",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. UNIV ; see if entry is UID
  1.  N LRY
  1.  S LRY=$$CHECKUID(LRX)
  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.  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. WLQUES ; Ask user if acession 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.  W !,X
  1.  D ^DIC S LRAA=+Y
  1.  Q
  1.  ;
  1. SELBY(X1) ; Select by accession number or unique identifier (UID)
  1.  ; Call with X1 = message prompt
  1.  ;    Returns Y = 0 (abort)
  1.  ;              = 1 (accession number)
  1.  ;              = 2 (unique identifier)
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  S X1=$G(X1,"Select UID")
  1.  S DIR(0)="SO^1:Accession Number;2:Unique Identifier (UID)",DIR("A")=X1,DIR("B")=1
  1.  D ^DIR
  1.  I $D(DIRUT) S Y=0
  1.  Q Y
  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:10^K:'$D(^LRO(68,""C"",X)) X"
  1.  S DIR("A")=LRX,DIR("?")="Enter the full 10 character UID"
  1.  I $L($G(LRY)) S DIR("B")=LRY
  1.  D ^DIR
  1.  I $D(DIRUT) S Y=0
  1.  Q Y
  1.  ;
  1.  ;
  1. CHECKUID(LRX) ; Check if UID is valid, accession exists.
  1.  ; Call with LRX = UID to check
  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
  1.  S Y=$Q(^LRO(68,"C",LRX))
  1.  I $QS(Y,3)=LRX,+$QS(Y,4),+$QS(Y,5),+$QS(Y,6) D
  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