RASELCT ;HISC/DAD-Generic file entry selector ;7/1/98 15:48
;;5.0;Radiology/Nuclear Medicine;**83**;Mar 16, 1998;Build 4
;
;*** SELECTS A GROUP OF RECORDS FROM A FILE ***
;
;REQUIRES:
; RADIC = FILE NUMBER OR GLOBAL ROOT
; RADIC(0) = DIC(0) STRING
; RAUTIL = NODE TO STORE DATA UNDER IN ^TMP($J,RAUTIL,
;
;OPTIONAL:
; RADIC("A") = DIC("A") STRING
; RADIC("B") = DIC("B") STRING
; RADIC("S") = DIC("S") STRING
; RADIC("W") = DIC("W") STRING
; RAARRY = LOCAL ARRAY TO STORE DATA IN
; RAFLD = field to sort by if valid data to be stored as
; ^TMP($J,RAUTIL,external value of RAFLD,IEN)=""
; RAFLD must reside on the zero (0) node to be valid!
; RAINPUT = ONE/MANY/ALL DISTINCTION (1=ALL, 0=ONE/MANY)
;
;RETURNS:
; 1) RAQUIT = $S(UP_ARROW_OUT:1 , NOTHING_SELECTED:1 , 1:0)
; 2) ^TMP($J,RAUTIL,EXTERNAL_.01_FIELD_DATA,IEN) = ""
; 3) if $D(RAFLD), ^TMP($J,RAUTIL,EXTERNAL_RAFLD_DATA,IEN) = ""
;
EN1(RADIC,RAUTIL,RAARRY,RAINPUT,RAFLD) ;
S RAQUIT=0 I ($D(RADIC)[0)!($D(RADIC(0))[0)!($D(RAUTIL)[0) S RAQUIT=1 G EXIT
I (RADIC="")!(RADIC(0)="")!(RAUTIL="") S RAQUIT=1 G EXIT
I $G(RAINPUT)=0 K RADIC("B")
D K S DIC=RADIC I DIC S (RADIC,DIC)=$S($D(^DIC(DIC,0,"GL"))#2:^("GL"),1:"") I DIC="" S RAQUIT=1 G EXIT
S DIC(0)=RADIC(0),DIC(0)=$TR(DIC(0),"AL") S:DIC(0)'["Z" DIC(0)=DIC(0)_"Z" S RADIC(0)=DIC(0)
D DO^DIC1 S RAFNUM=+DO(2),RAFNAME=$P(DO,"^"),RAFLD01=$P(^DD(RAFNUM,.01,0),"^"),RAFSCR=$S($D(DO("SCR"))#2:DO("SCR"),1:"") K DO
I $G(RAFLD)]"" S RAQUIT=$$FLD(RAFNUM,RAFLD) G:RAQUIT EXIT
S RACASE=$S($E(RAFLD01,($L(RAFLD01)))?1L:"s",1:"S")
F X="A","B","S","W" S RADIC(X)=$S($D(RADIC(X))#2:RADIC(X),1:"")
S:RADIC("A")="" RADIC("A")="Select "_RAFNAME_" "_RAFLD01_": "
S RAALL=0,RANUM=1 K ^TMP($J,RAUTIL) D HOME^%ZIS
1 D SETDIC W !!,$S(RANUM>1:"Another one (Select/De-Select): ",1:DIC("A")),$S((RANUM=1)&(RADIC("B")]""):RADIC("B")_"// ",1:"")
R X:DTIME S:('$T)!($E(X)="^") RAQUIT=1 G:RAQUIT EXIT S:(RANUM=1)&(X="")&(RADIC("B")]"") X=RADIC("B") G:X="" EXIT S RADSEL=$S(X?1"-"1.E:1,1:0) S:RADSEL X=$E(X,2,$L(X))
; RA*5*83 require exactly 3 chars when checking for "ALL"
I $L(X),(($L(X)=3&("Aa"[$E(X))&("Ll"[$E(X,2))&("Ll"[$E(X,3)))!(X["*")) D ALL G EXIT:RAQUIT,1:RAALL
D HELP:$E(X)="?"
I $L($G(DIC("S")))<235 S DIC("S")=$S($G(DIC("S"))]"":DIC("S")_" ",1:"")_"I $$SEL^RASELCT(Y)"
D ^DIC K DIC G:+Y'>0 1
S RAMASK=+Y
I $$CHFLD(RAFNUM)["D" D
. N %DT,X
. S X=Y(0,0),%DT="ST" D ^%DT S Y(0,0)=Y
. Q
S Y=RAMASK
I $G(RAFLD)']"" D
. I 'RADSEL,'$D(^TMP($J,RAUTIL,$E(Y(0,0),1,63),+Y)) S ^(+Y)="",RANUM=RANUM+1
. I RADSEL,$D(^TMP($J,RAUTIL,$E(Y(0,0),1,63),+Y)) K ^(+Y) S RANUM=RANUM-$S(RANUM>0:1,1:0)
. Q
E D
. S RAVALUE=$$FLDSRT(RAFNUM,RAFLD) Q:RAVALUE']""
. I 'RADSEL,'$D(^TMP($J,RAUTIL,$E(RAVALUE,1,63),+Y)) S ^(+Y)="",RANUM=RANUM+1
. I RADSEL,$D(^TMP($J,RAUTIL,$E(RAVALUE,1,63),+Y)) K ^(+Y) S RANUM=RANUM-$S(RANUM>0:1,1:0)
. Q
G 1
EXIT ;
I 'RAQUIT,($L($G(RAARRY))),('$D(@RAARRY)) D
. S %X="^TMP($J,"""_RAUTIL_""",",%Y=RAARRY_"("
. D %XY^%RCR
. Q
S RAQUIT=$S(RAQUIT:1,$O(^TMP($J,RAUTIL,""))="":1,1:0) K RADIC,RAUTIL
K K %,%X,%Y,%Z,C,D0,DA,DIC,DIK,DIR,DO,RA,RAALL,RACASE,RAD0,RADSEL,RAFLD01
K RAFNAME,RAFNUM,RAFSCR,RALINE,RAMASK,RANUM,RAVALUE,X,Y
Q
ALL ;
;I $G(RAINPUT)=0 Q
S RAALL=1 ; Assume the user answers desires ALL entries!
N PAT,RAX S RAX=X N X
I RAX["*" D
. N CHAR,I,TEMP
. S PAT="Y'?",TEMP=""
. F I=1:1:$L(RAX) D
.. S CHAR=$E(RAX,I)
.. I CHAR'="*" S TEMP=TEMP_CHAR Q
.. D BLDPAT
.. Q
. D BLDPAT
. Q
F RAD0=0:0 S RAD0=$O(@(RADIC_"RAD0)")) Q:RAD0'>0 D AL
W:RANUM=1&'RADSEL " ??",$C(7)
Q
AL I RAFSCR]"" D SETDIC I $D(@(RADIC_"RAD0,0)"))#2 S (D0,DA,Y)=RAD0 X RAFSCR Q:'$T
I RADIC("S")]"" D SETDIC I $D(@(RADIC_"RAD0,0)"))#2 S (D0,DA,Y)=RAD0 X DIC("S") Q:'$T
S Y=$P($G(@(RADIC_"RAD0,0)")),"^"),C=$P(^DD(RAFNUM,.01,0),"^",2)
Q:Y="" D Y^DIQ
I $$CHFLD(RAFNUM)["D" D
. N %DT,X
. S X=Y,%DT="ST" D ^%DT
. Q
I RAX["*",@PAT Q
I $G(RAFLD)']"" D
. I 'RADSEL,'$D(^TMP($J,RAUTIL,$E(Y,1,63),RAD0)) S ^(RAD0)="",RANUM=RANUM+1
. I RADSEL,$D(^TMP($J,RAUTIL,$E(Y,1,63),RAD0)) K ^(RAD0) S RANUM=RANUM-$S(RANUM>0:1,1:0)
. Q
E D
. N Y S Y=+RAD0,Y(0)=$G(@(RADIC_+Y_",0)")),Y(0,0)=$P(Y(0),"^")
. S RAVALUE=$$FLDSRT(RAFNUM,RAFLD) Q:RAVALUE']""
. I 'RADSEL,'$D(^TMP($J,RAUTIL,$E(RAVALUE,1,63),RAD0)) S ^(RAD0)="",RANUM=RANUM+1
. I RADSEL,$D(^TMP($J,RAUTIL,$E(RAVALUE,1,63),RAD0)) K ^(RAD0) S RANUM=RANUM-$S(RANUM>0:1,1:0)
. Q
Q
HELP ;
N X S RA="Select a "_RAFNAME_" "_RAFLD01_" from the displayed list." D WRAP
W !?5,"To deselect a ",RAFLD01," type a minus sign (-)",!?5,"in front of it, e.g., -",RAFLD01,"."
I $G(RAINPUT)=1 W !?5,"To get all ",RAFLD01,"S type ALL."
W !?5,"Use an asterisk (*) to do a wildcard selection, e.g.,"
W !?5,"enter ",RAFLD01,"* to select all entries that begin"
W !?5,"with the text '",RAFLD01,"'. Wildcard selection is"
W !?5,"case sensitive."
G:$O(^TMP($J,RAUTIL,""))="" HLP
SHOW S RALINE=$Y,RA="" W !!,"You have already selected:"
F S RA=$O(^TMP($J,RAUTIL,RA)) Q:RA=""!RAQUIT F RAD0=0:0 S RAD0=$O(^TMP($J,RAUTIL,RA,RAD0)) Q:RAD0'>0!RAQUIT D SHO
HLP W ! S RAQUIT=0
Q
SHO I $G(RAFLD)]"" S RA(0)=$P($G(@(RADIC_+RAD0_",0)")),"^")
E S RA(0)=RA
I $$CHFLD(RAFNUM)["D" D
. N Y
. S Y=RA(0) X ^DD("DD") S RA(0)=Y
. Q
I RADIC(0)["N" W !?3,RAD0,?15,RA(0)
E W !?3,RA(0)
D SETDIC I $D(DIC("W"))#2,DIC("W")]"",$D(@(RADIC_"RAD0,0)"))#2 S (D0,DA,Y)=RAD0 X DIC("W")
I $Y>(IOSL+RALINE-3) D PAUSE S RALINE=$Y
Q
WRAP ;
W ! F S Y=$L($E(RA,1,IOM-20)," ") W !?5,$P(RA," ",1,Y) S RA=$P(RA," ",Y+1,999) Q:RA=""
Q
PAUSE ;
K DIR S DIR(0)="E" D ^DIR K DIR S RAQUIT=$S(Y:0,1:1)
Q
SETDIC ;
K DIC,DO S DIC=RADIC
F X="0","A","B","S","W" I RADIC(X)]"" S DIC(X)=RADIC(X)
D DO^DIC1
Q
CHFLD(X) ;
N A
S A=$P($G(^DD(X,.01,0)),U,2)
Q:A'["P" A
F D Q:A'["P"
. S A=$TR(A,$TR(A,".0123456789"))
. S A=$$CHFLD(A)
. Q
Q A
SEL(Y) ;
N %DT,DA,DIC,DIQ,DR,RAEXTRN,RAPOINT,X
S (RAPOINT,DA)=Y,DIC=RAFNUM,DR=.01,DIQ(0)="E",DIQ="RAEXTRN("
D EN^DIQ1 S RAEXTRN=$G(RAEXTRN(RAFNUM,RAPOINT,.01,"E"))
I $$CHFLD(RAFNUM)["D" S X=RAEXTRN,%DT="ST" D ^%DT S RAEXTRN=Y
S X=$D(^TMP($J,RAUTIL,RAEXTRN,RAPOINT))
Q $S(X#2&RADSEL:1,X[0&'RADSEL:1,1:0)
BLDPAT ;
I TEMP]"" S PAT=PAT_"1"""_TEMP_""""
I CHAR="*",$E(PAT,$L(PAT)-1,$L(PAT))'=".E" S PAT=PAT_".E"
S TEMP=""
Q
FLD(RAFNUM,RAFLD) ; Validate if field can be sorted on i.e, if
; non-multiple and is either a pointer, free text, set of codes,
; numeric or a date/time field.
; 'RAFNUM' = File # 'RAFLD' = Field #
; returns RAPASS: 0 if valid, else 1
Q:RAFLD=.01 1 ; .01 field is not valid!
Q:'($D(^DD(RAFNUM,RAFLD,0))#2) 1 ; field does not exist
N RA,RAPASS S RA(0)=$G(^DD(RAFNUM,RAFLD,0)),RA(2)=$P(RA(0),"^",2)
S RA(4)=$P(RA(0),"^",4)
Q:+RA(2)>0&($D(^DD(+RA(2),.01,0))) 1 ; field is a multiple, not valid
Q:RA(4)'["0;" 1 ; field does not reside on the 0 node, not valid
S RAPASS=1 ; set initially to not valid
F RA="D","F","N","P","S" S:RA(2)[RA RAPASS=0 Q:'RAPASS
Q RAPASS
FLDSRT(RAFNUM,RAFLD) ; Converts the internal value to the external value
; for sets of codes & pointers.
; 'RAFNUM' = File # 'RAFLD' = Field #
; 'RAPCE' = piece position on 0 node
N RAPCE S RAPCE=$P($P($G(^DD(RAFNUM,RAFLD,0)),"^",4),";",2)
Q $$EXTERNAL^DILFD(RAFNUM,RAFLD,"",$P(Y(0),"^",RAPCE))
RASELCT ;HISC/DAD-Generic file entry selector ;7/1/98 15:48
+1 ;;5.0;Radiology/Nuclear Medicine;**83**;Mar 16, 1998;Build 4
+2 ;
+3 ;*** SELECTS A GROUP OF RECORDS FROM A FILE ***
+4 ;
+5 ;REQUIRES:
+6 ; RADIC = FILE NUMBER OR GLOBAL ROOT
+7 ; RADIC(0) = DIC(0) STRING
+8 ; RAUTIL = NODE TO STORE DATA UNDER IN ^TMP($J,RAUTIL,
+9 ;
+10 ;OPTIONAL:
+11 ; RADIC("A") = DIC("A") STRING
+12 ; RADIC("B") = DIC("B") STRING
+13 ; RADIC("S") = DIC("S") STRING
+14 ; RADIC("W") = DIC("W") STRING
+15 ; RAARRY = LOCAL ARRAY TO STORE DATA IN
+16 ; RAFLD = field to sort by if valid data to be stored as
+17 ; ^TMP($J,RAUTIL,external value of RAFLD,IEN)=""
+18 ; RAFLD must reside on the zero (0) node to be valid!
+19 ; RAINPUT = ONE/MANY/ALL DISTINCTION (1=ALL, 0=ONE/MANY)
+20 ;
+21 ;RETURNS:
+22 ; 1) RAQUIT = $S(UP_ARROW_OUT:1 , NOTHING_SELECTED:1 , 1:0)
+23 ; 2) ^TMP($J,RAUTIL,EXTERNAL_.01_FIELD_DATA,IEN) = ""
+24 ; 3) if $D(RAFLD), ^TMP($J,RAUTIL,EXTERNAL_RAFLD_DATA,IEN) = ""
+25 ;
EN1(RADIC,RAUTIL,RAARRY,RAINPUT,RAFLD) ;
+1 SET RAQUIT=0
IF ($DATA(RADIC)[0)!($DATA(RADIC(0))[0)!($DATA(RAUTIL)[0)
SET RAQUIT=1
GOTO EXIT
+2 IF (RADIC="")!(RADIC(0)="")!(RAUTIL="")
SET RAQUIT=1
GOTO EXIT
+3 IF $GET(RAINPUT)=0
KILL RADIC("B")
+4 DO K
SET DIC=RADIC
IF DIC
SET (RADIC,DIC)=$SELECT($DATA(^DIC(DIC,0,"GL"))#2:^("GL"),1:"")
IF DIC=""
SET RAQUIT=1
GOTO EXIT
+5 SET DIC(0)=RADIC(0)
SET DIC(0)=$TRANSLATE(DIC(0),"AL")
IF DIC(0)'["Z"
SET DIC(0)=DIC(0)_"Z"
SET RADIC(0)=DIC(0)
+6 DO DO^DIC1
SET RAFNUM=+DO(2)
SET RAFNAME=$PIECE(DO,"^")
SET RAFLD01=$PIECE(^DD(RAFNUM,.01,0),"^")
SET RAFSCR=$SELECT($DATA(DO("SCR"))#2:DO("SCR"),1:"")
KILL DO
+7 IF $GET(RAFLD)]""
SET RAQUIT=$$FLD(RAFNUM,RAFLD)
IF RAQUIT
GOTO EXIT
+8 SET RACASE=$SELECT($EXTRACT(RAFLD01,($LENGTH(RAFLD01)))?1L:"s",1:"S")
+9 FOR X="A","B","S","W"
SET RADIC(X)=$SELECT($DATA(RADIC(X))#2:RADIC(X),1:"")
+10 IF RADIC("A")=""
SET RADIC("A")="Select "_RAFNAME_" "_RAFLD01_": "
+11 SET RAALL=0
SET RANUM=1
KILL ^TMP($JOB,RAUTIL)
DO HOME^%ZIS
1 DO SETDIC
WRITE !!,$SELECT(RANUM>1:"Another one (Select/De-Select): ",1:DIC("A")),$SELECT((RANUM=1)&(RADIC("B")]""):RADIC("B")_"// ",1:"")
+1 READ X:DTIME
IF ('$TEST)!($EXTRACT(X)="^")
SET RAQUIT=1
IF RAQUIT
GOTO EXIT
IF (RANUM=1)&(X="")&(RADIC("B")]"")
SET X=RADIC("B")
IF X=""
GOTO EXIT
SET RADSEL=$SELECT(X?1"-"1.E:1,1:0)
IF RADSEL
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 ; RA*5*83 require exactly 3 chars when checking for "ALL"
+3 IF $LENGTH(X)
IF (($LENGTH(X)=3&("Aa"[$EXTRACT(X))&("Ll"[$EXTRACT(X,2))&("Ll"[$EXTRACT(X,3)))!(X["*"))
DO ALL
IF RAQUIT
GOTO EXIT
IF RAALL
GOTO 1
+4 IF $EXTRACT(X)="?"
DO HELP
+5 IF $LENGTH($GET(DIC("S")))<235
SET DIC("S")=$SELECT($GET(DIC("S"))]"":DIC("S")_" ",1:"")_"I $$SEL^RASELCT(Y)"
+6 DO ^DIC
KILL DIC
IF +Y'>0
GOTO 1
+7 SET RAMASK=+Y
+8 IF $$CHFLD(RAFNUM)["D"
Begin DoDot:1
+9 NEW %DT,X
+10 SET X=Y(0,0)
SET %DT="ST"
DO ^%DT
SET Y(0,0)=Y
+11 QUIT
End DoDot:1
+12 SET Y=RAMASK
+13 IF $GET(RAFLD)']""
Begin DoDot:1
+14 IF 'RADSEL
IF '$DATA(^TMP($JOB,RAUTIL,$EXTRACT(Y(0,0),1,63),+Y))
SET ^(+Y)=""
SET RANUM=RANUM+1
+15 IF RADSEL
IF $DATA(^TMP($JOB,RAUTIL,$EXTRACT(Y(0,0),1,63),+Y))
KILL ^(+Y)
SET RANUM=RANUM-$SELECT(RANUM>0:1,1:0)
+16 QUIT
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 SET RAVALUE=$$FLDSRT(RAFNUM,RAFLD)
IF RAVALUE']""
QUIT
+19 IF 'RADSEL
IF '$DATA(^TMP($JOB,RAUTIL,$EXTRACT(RAVALUE,1,63),+Y))
SET ^(+Y)=""
SET RANUM=RANUM+1
+20 IF RADSEL
IF $DATA(^TMP($JOB,RAUTIL,$EXTRACT(RAVALUE,1,63),+Y))
KILL ^(+Y)
SET RANUM=RANUM-$SELECT(RANUM>0:1,1:0)
+21 QUIT
End DoDot:1
+22 GOTO 1
EXIT ;
+1 IF 'RAQUIT
IF ($LENGTH($GET(RAARRY)))
IF ('$DATA(@RAARRY))
Begin DoDot:1
+2 SET %X="^TMP($J,"""_RAUTIL_""","
SET %Y=RAARRY_"("
+3 DO %XY^%RCR
+4 QUIT
End DoDot:1
+5 SET RAQUIT=$SELECT(RAQUIT:1,$ORDER(^TMP($JOB,RAUTIL,""))="":1,1:0)
KILL RADIC,RAUTIL
K KILL %,%X,%Y,%Z,C,D0,DA,DIC,DIK,DIR,DO,RA,RAALL,RACASE,RAD0,RADSEL,RAFLD01
+1 KILL RAFNAME,RAFNUM,RAFSCR,RALINE,RAMASK,RANUM,RAVALUE,X,Y
+2 QUIT
ALL ;
+1 ;I $G(RAINPUT)=0 Q
+2 ; Assume the user answers desires ALL entries!
SET RAALL=1
+3 NEW PAT,RAX
SET RAX=X
NEW X
+4 IF RAX["*"
Begin DoDot:1
+5 NEW CHAR,I,TEMP
+6 SET PAT="Y'?"
SET TEMP=""
+7 FOR I=1:1:$LENGTH(RAX)
Begin DoDot:2
+8 SET CHAR=$EXTRACT(RAX,I)
+9 IF CHAR'="*"
SET TEMP=TEMP_CHAR
QUIT
+10 DO BLDPAT
+11 QUIT
End DoDot:2
+12 DO BLDPAT
+13 QUIT
End DoDot:1
+14 FOR RAD0=0:0
SET RAD0=$ORDER(@(RADIC_"RAD0)"))
IF RAD0'>0
QUIT
DO AL
+15 IF RANUM=1&'RADSEL
WRITE " ??",$CHAR(7)
+16 QUIT
AL IF RAFSCR]""
DO SETDIC
IF $DATA(@(RADIC_"RAD0,0)"))#2
SET (D0,DA,Y)=RAD0
XECUTE RAFSCR
IF '$TEST
QUIT
+1 IF RADIC("S")]""
DO SETDIC
IF $DATA(@(RADIC_"RAD0,0)"))#2
SET (D0,DA,Y)=RAD0
XECUTE DIC("S")
IF '$TEST
QUIT
+2 SET Y=$PIECE($GET(@(RADIC_"RAD0,0)")),"^")
SET C=$PIECE(^DD(RAFNUM,.01,0),"^",2)
+3 IF Y=""
QUIT
DO Y^DIQ
+4 IF $$CHFLD(RAFNUM)["D"
Begin DoDot:1
+5 NEW %DT,X
+6 SET X=Y
SET %DT="ST"
DO ^%DT
+7 QUIT
End DoDot:1
+8 IF RAX["*"
IF @PAT
QUIT
+9 IF $GET(RAFLD)']""
Begin DoDot:1
+10 IF 'RADSEL
IF '$DATA(^TMP($JOB,RAUTIL,$EXTRACT(Y,1,63),RAD0))
SET ^(RAD0)=""
SET RANUM=RANUM+1
+11 IF RADSEL
IF $DATA(^TMP($JOB,RAUTIL,$EXTRACT(Y,1,63),RAD0))
KILL ^(RAD0)
SET RANUM=RANUM-$SELECT(RANUM>0:1,1:0)
+12 QUIT
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 NEW Y
SET Y=+RAD0
SET Y(0)=$GET(@(RADIC_+Y_",0)"))
SET Y(0,0)=$PIECE(Y(0),"^")
+15 SET RAVALUE=$$FLDSRT(RAFNUM,RAFLD)
IF RAVALUE']""
QUIT
+16 IF 'RADSEL
IF '$DATA(^TMP($JOB,RAUTIL,$EXTRACT(RAVALUE,1,63),RAD0))
SET ^(RAD0)=""
SET RANUM=RANUM+1
+17 IF RADSEL
IF $DATA(^TMP($JOB,RAUTIL,$EXTRACT(RAVALUE,1,63),RAD0))
KILL ^(RAD0)
SET RANUM=RANUM-$SELECT(RANUM>0:1,1:0)
+18 QUIT
End DoDot:1
+19 QUIT
HELP ;
+1 NEW X
SET RA="Select a "_RAFNAME_" "_RAFLD01_" from the displayed list."
DO WRAP
+2 WRITE !?5,"To deselect a ",RAFLD01," type a minus sign (-)",!?5,"in front of it, e.g., -",RAFLD01,"."
+3 IF $GET(RAINPUT)=1
WRITE !?5,"To get all ",RAFLD01,"S type ALL."
+4 WRITE !?5,"Use an asterisk (*) to do a wildcard selection, e.g.,"
+5 WRITE !?5,"enter ",RAFLD01,"* to select all entries that begin"
+6 WRITE !?5,"with the text '",RAFLD01,"'. Wildcard selection is"
+7 WRITE !?5,"case sensitive."
+8 IF $ORDER(^TMP($JOB,RAUTIL,""))=""
GOTO HLP
SHOW SET RALINE=$Y
SET RA=""
WRITE !!,"You have already selected:"
+1 FOR
SET RA=$ORDER(^TMP($JOB,RAUTIL,RA))
IF RA=""!RAQUIT
QUIT
FOR RAD0=0:0
SET RAD0=$ORDER(^TMP($JOB,RAUTIL,RA,RAD0))
IF RAD0'>0!RAQUIT
QUIT
DO SHO
HLP WRITE !
SET RAQUIT=0
+1 QUIT
SHO IF $GET(RAFLD)]""
SET RA(0)=$PIECE($GET(@(RADIC_+RAD0_",0)")),"^")
+1 IF '$TEST
SET RA(0)=RA
+2 IF $$CHFLD(RAFNUM)["D"
Begin DoDot:1
+3 NEW Y
+4 SET Y=RA(0)
XECUTE ^DD("DD")
SET RA(0)=Y
+5 QUIT
End DoDot:1
+6 IF RADIC(0)["N"
WRITE !?3,RAD0,?15,RA(0)
+7 IF '$TEST
WRITE !?3,RA(0)
+8 DO SETDIC
IF $DATA(DIC("W"))#2
IF DIC("W")]""
IF $DATA(@(RADIC_"RAD0,0)"))#2
SET (D0,DA,Y)=RAD0
XECUTE DIC("W")
+9 IF $Y>(IOSL+RALINE-3)
DO PAUSE
SET RALINE=$Y
+10 QUIT
WRAP ;
+1 WRITE !
FOR
SET Y=$LENGTH($EXTRACT(RA,1,IOM-20)," ")
WRITE !?5,$PIECE(RA," ",1,Y)
SET RA=$PIECE(RA," ",Y+1,999)
IF RA=""
QUIT
+2 QUIT
PAUSE ;
+1 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET RAQUIT=$SELECT(Y:0,1:1)
+2 QUIT
SETDIC ;
+1 KILL DIC,DO
SET DIC=RADIC
+2 FOR X="0","A","B","S","W"
IF RADIC(X)]""
SET DIC(X)=RADIC(X)
+3 DO DO^DIC1
+4 QUIT
CHFLD(X) ;
+1 NEW A
+2 SET A=$PIECE($GET(^DD(X,.01,0)),U,2)
+3 IF A'["P"
QUIT A
+4 FOR
Begin DoDot:1
+5 SET A=$TRANSLATE(A,$TRANSLATE(A,".0123456789"))
+6 SET A=$$CHFLD(A)
+7 QUIT
End DoDot:1
IF A'["P"
QUIT
+8 QUIT A
SEL(Y) ;
+1 NEW %DT,DA,DIC,DIQ,DR,RAEXTRN,RAPOINT,X
+2 SET (RAPOINT,DA)=Y
SET DIC=RAFNUM
SET DR=.01
SET DIQ(0)="E"
SET DIQ="RAEXTRN("
+3 DO EN^DIQ1
SET RAEXTRN=$GET(RAEXTRN(RAFNUM,RAPOINT,.01,"E"))
+4 IF $$CHFLD(RAFNUM)["D"
SET X=RAEXTRN
SET %DT="ST"
DO ^%DT
SET RAEXTRN=Y
+5 SET X=$DATA(^TMP($JOB,RAUTIL,RAEXTRN,RAPOINT))
+6 QUIT $SELECT(X#2&RADSEL:1,X[0&'RADSEL:1,1:0)
BLDPAT ;
+1 IF TEMP]""
SET PAT=PAT_"1"""_TEMP_""""
+2 IF CHAR="*"
IF $EXTRACT(PAT,$LENGTH(PAT)-1,$LENGTH(PAT))'=".E"
SET PAT=PAT_".E"
+3 SET TEMP=""
+4 QUIT
FLD(RAFNUM,RAFLD) ; Validate if field can be sorted on i.e, if
+1 ; non-multiple and is either a pointer, free text, set of codes,
+2 ; numeric or a date/time field.
+3 ; 'RAFNUM' = File # 'RAFLD' = Field #
+4 ; returns RAPASS: 0 if valid, else 1
+5 ; .01 field is not valid!
IF RAFLD=.01
QUIT 1
+6 ; field does not exist
IF '($DATA(^DD(RAFNUM,RAFLD,0))#2)
QUIT 1
+7 NEW RA,RAPASS
SET RA(0)=$GET(^DD(RAFNUM,RAFLD,0))
SET RA(2)=$PIECE(RA(0),"^",2)
+8 SET RA(4)=$PIECE(RA(0),"^",4)
+9 ; field is a multiple, not valid
IF +RA(2)>0&($DATA(^DD(+RA(2),.01,0)))
QUIT 1
+10 ; field does not reside on the 0 node, not valid
IF RA(4)'["0;"
QUIT 1
+11 ; set initially to not valid
SET RAPASS=1
+12 FOR RA="D","F","N","P","S"
IF RA(2)[RA
SET RAPASS=0
IF 'RAPASS
QUIT
+13 QUIT RAPASS
FLDSRT(RAFNUM,RAFLD) ; Converts the internal value to the external value
+1 ; for sets of codes & pointers.
+2 ; 'RAFNUM' = File # 'RAFLD' = Field #
+3 ; 'RAPCE' = piece position on 0 node
+4 NEW RAPCE
SET RAPCE=$PIECE($PIECE($GET(^DD(RAFNUM,RAFLD,0)),"^",4),";",2)
+5 QUIT $$EXTERNAL^DILFD(RAFNUM,RAFLD,"",$PIECE(Y(0),"^",RAPCE))
