SDRRSLCT ;10N20/MAH;-RECALL REMINDER Generic file entry selector ;12/09/2007 14:26
;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
;
;
;Requires:
; SDRRDDIC = File number or global root
; SDRRDDIC(0) = DIC(0) string
; SDRRDUTIL = Node to store data under in ^TMP($J,SDRRDUTIL,
;
;Optional:
; SDRRDDIC("A") = DIC("A") string
; SDRRDDIC("B") = DIC("B") string
; SDRRDDIC("S") = DIC("S") string
; SDRRDDIC("W") = DIC("W") string
; SDRRDROOT = Closed array reference where data should be stored
; Defaluts to ^TMP($J,SDRRDUTIL)
; SDRRDFLD = Field to sort by if valid data to be stored as
; @Root@(SDRRDUTIL,ExternalValueSDRRDFLD,IEN)=""
; SDRRDFLD must reside on the zero (0) node to be valid
;
;Returns:
; $$EN() = $S(UpArrowOut:0, NothingSelected:0, 1:1)
; @SDRRDROOT@(SDRRDUTIL,ExternalFieldData,IEN)=""
;
;Example:
; SET SDRRDDIC=44,SDRRDDIC(0)="EMNQZ",SDRRDDIC("A")="Select CLINIC: "
; SET SDRRDDIC("B")="ALL",SDRRDDIC("S")="IF $PIECE(^(0),U,3)=""C"""
; IF $$EN^SDRRSLCT(.SDRRDDIC,"ClinicNode","MYARRAY",1)'>0 QUIT
;
EN(SDRRDDIC,SDRRDUTIL,SDRRDROOT,SDRRDFLD) ;
N %DT,SDRRDDONE,SDRRDDSEL,SDRRDFL01,SDRRDFNAM,SDRRDFNUM,SDRRDFSCR,SDRRDMASK
N SDRRDNUM,SDRRDQUIT,SDRRDVALU,SDRRDX,DIC,DO,DTOUT,DUOUT,I,X,Y
S SDRRDFLD=$G(SDRRDFLD)
I $G(SDRRDROOT)]"" S SDRRDROOT=$NA(@SDRRDROOT@(SDRRDUTIL))
E S SDRRDROOT=$NA(^TMP($J,SDRRDUTIL))
K @SDRRDROOT
S (SDRRDQUIT,SDRRDDONE)=0
S SDRRDQUIT=(($G(SDRRDDIC)="")!($G(SDRRDDIC(0))="")!($G(SDRRDUTIL)=""))
I SDRRDQUIT>0 G EXIT
S DIC=SDRRDDIC
I DIC>0 D I SDRRDQUIT G EXIT
. S (SDRRDDIC,DIC)=$$GET1^DID(DIC,"","","GLOBAL NAME")
. S SDRRDQUIT=$S(DIC="":1,1:0)
. Q
S (DIC(0),SDRRDDIC(0))=$TR(SDRRDDIC(0),"AL")_$S(SDRRDDIC(0)'["Z":"Z",1:"")
D FILEATTR(DIC,DIC(0),.SDRRDFNUM,.SDRRDFNAM,.SDRRDFL01,.SDRRDFSCR)
I SDRRDFLD]"" S SDRRDQUIT=$$FLD(SDRRDFNUM,SDRRDFLD) I SDRRDQUIT G EXIT
F I="A","B","S","W" S SDRRDDIC(I)=$G(SDRRDDIC(I))
I SDRRDDIC("A")="" S SDRRDDIC("A")="Select "_SDRRDFNAM_" "_SDRRDFL01_": "
S SDRRDNUM=1
D HOME^%ZIS
F D Q:SDRRDQUIT!SDRRDDONE
. D SETDIC(.SDRRDDIC,.DIC,.DO)
. W !!,$S(SDRRDNUM>1:"Another one (Select/De-Select): ",1:DIC("A"))
. W $S((SDRRDNUM=1)&(SDRRDDIC("B")]""):SDRRDDIC("B")_"// ",1:"")
. R SDRRDX:DTIME S:('$T)!($E(SDRRDX)=U) SDRRDQUIT=1 Q:SDRRDQUIT
. I (SDRRDNUM=1)&(SDRRDX="")&(SDRRDDIC("B")]"") S SDRRDX=SDRRDDIC("B")
. I SDRRDX="" S SDRRDDONE=1 Q
. S SDRRDDSEL=$S(SDRRDX?1"-"1.E:1,1:0)
. I SDRRDDSEL S SDRRDX=$E(SDRRDX,2,$L(SDRRDX))
. I SDRRDX?1.ANP1"-"1.ANP D Q:SDRRDQUIT=1 I SDRRDQUIT=-1 S SDRRDQUIT=0 Q
.. S SDRRDQUIT=$$RANGE^SDRRSLC1(SDRRDX,.SDRRDDIC,SDRRDUTIL,SDRRDFLD,SDRRDDSEL,.SDRRDNUM)
.. Q
. I ($$UP^XLFSTR(SDRRDX)="ALL")!(SDRRDX["*") D Q:SDRRDQUIT=1 I SDRRDQUIT=-1 S SDRRDQUIT=0 Q
.. S SDRRDQUIT=$$ALL^SDRRSLC1(SDRRDX,.SDRRDDIC,SDRRDUTIL,SDRRDFLD,SDRRDDSEL,.SDRRDNUM)
.. Q
. I $E(SDRRDX)="?" D HELP(.SDRRDDIC,SDRRDUTIL,SDRRDFLD)
. I $L($G(DIC("S")))<235 D
.. S DIC("S")=$S($G(DIC("S"))]"":DIC("S")_" ",1:"")
.. S DIC("S")=DIC("S")_"I $$SEL^SDRRSLCT(Y,"_SDRRDFNUM_","_SDRRDDSEL
.. S DIC("S")=DIC("S")_$S($G(SDRRDFLD)]"":","_SDRRDFLD,1:"")_")"
.. Q
. S X=SDRRDX D ^DIC K DIC I +Y'>0 Q
. S SDRRDMASK=+Y
. I $$CHFLD(SDRRDFNUM)["D" D
.. N %DT,X
.. S X=Y(0,0),%DT="ST" D ^%DT S Y(0,0)=Y
.. Q
. S Y=SDRRDMASK
. I SDRRDFLD="" D
.. D SETDATA(Y(0,0),+Y,SDRRDUTIL,SDRRDDSEL,.SDRRDNUM)
.. Q
. E D
.. S SDRRDVALU=$$FLDSRT(SDRRDFNUM,SDRRDFLD,Y(0))
.. I SDRRDVALU]"" D SETDATA(SDRRDVALU,+Y,SDRRDUTIL,SDRRDDSEL,.SDRRDNUM)
.. Q
. Q
;
EXIT ;
S SDRRDQUIT=$S(SDRRDQUIT>0:0,$O(@SDRRDROOT@(""))="":0,1:1)
I SDRRDQUIT'>0 K @SDRRDROOT
Q SDRRDQUIT
;
SETDATA(SDRRDVALU,SDRRD0,SDRRDUTIL,SDRRDDSEL,SDRRDNUM) ;
I 'SDRRDDSEL,'$D(@SDRRDROOT@($E(SDRRDVALU,1,63),SDRRD0)) D
. S @SDRRDROOT@($E(SDRRDVALU,1,63),SDRRD0)=""
. S SDRRDNUM=SDRRDNUM+1
. Q
I SDRRDDSEL,$D(@SDRRDROOT@($E(SDRRDVALU,1,63),SDRRD0)) D
. K @SDRRDROOT@($E(SDRRDVALU,1,63),SDRRD0)
. S SDRRDNUM=SDRRDNUM-$S(SDRRDNUM>0:1,1:0)
. Q
Q
;
HELP(SDRRDDIC,SDRRDUTIL,SDRRDFLD) ;
N SDRRD,SDRRD0,SDRRDCASE,SDRRDFL01,SDRRDFNAM,SDRRDFNUM
N SDRRDFSCR,SDRRDLINE,SDRRDQUIT,DIC,D0,DA,DO,X
S SDRRDQUIT=0
D FILEATTR(SDRRDDIC,SDRRDDIC(0),.SDRRDFNUM,.SDRRDFNAM,.SDRRDFL01,.SDRRDFSCR)
S SDRRDCASE=$$PLURAL(SDRRDFL01)
W !
S SDRRD="Select a "_SDRRDFNAM_" "_SDRRDFL01_" from the displayed list."
D WRAP(SDRRD,.SDRRDLINE)
S SDRRD=0
F S SDRRD=$O(SDRRDLINE(SDRRD)) Q:SDRRD'>0 W !?5,SDRRDLINE(SDRRD)
W !?5,"To deselect a ",SDRRDFL01," type a minus sign (-)"
W !?5,"in front of it, e.g., -",SDRRDFL01,"."
W !?5,"To get all ",SDRRDFL01,SDRRDCASE," type ALL."
W !?5,"Use an asterisk (*) to do a wildcard selection, e.g.,"
W !?5,"enter ",SDRRDFL01,"* to select all entries that begin"
W !?5,"with the text '",SDRRDFL01,"'. Wildcard selection is"
W !?5,"case sensitive. A range may be selected by entering"
W !?5,"'AAA-CCC', i.e., select all records from 'AAA' to"
W !?5,"'CCC' inclusive."
W !
I $O(@SDRRDROOT@(""))]"" D
. S SDRRDLINE=$Y
. S SDRRD=""
. W !,"You have already selected:"
. F S SDRRD=$O(@SDRRDROOT@(SDRRD)) Q:SDRRD=""!SDRRDQUIT D
.. S SDRRD0=0
.. F S SDRRD0=$O(@SDRRDROOT@(SDRRD,SDRRD0)) Q:SDRRD0'>0!SDRRDQUIT D
... I SDRRDFLD]"" S SDRRD(0)=$P($G(@(SDRRDDIC_+SDRRD0_",0)")),U)
... E S SDRRD(0)=SDRRD
... I $$CHFLD(SDRRDFNUM)["D" S SDRRD(0)=$$FMTE^XLFDT(SDRRD(0),"5Z")
... I SDRRDDIC(0)["N" W !?3,SDRRD0,?15,SDRRD(0)
... E W !?3,SDRRD(0)
... D SETDIC(.SDRRDDIC,.DIC,.DO)
... I $D(DIC("W"))#2,DIC("W")]"",$D(@(SDRRDDIC_"SDRRD0,0)"))#2 D
.... S (D0,DA,Y)=SDRRD0
.... X DIC("W")
.... Q
... I $Y>(IOSL+SDRRDLINE-3) S SDRRDQUIT=$$PAUSE,SDRRDLINE=$Y
... Q
.. Q
. Q
Q
;
WRAP(X,LINE) ;
N I,Y
K LINE
S I=0
F S Y=$L($E(X,1,IOM-20)," ") D Q:X=""
. S I=I+1
. S LINE(I)=$P(X," ",1,Y)
. S X=$P(X," ",Y+1,$L(X," "))
. Q
Q
;
PAUSE() ;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="E"
D ^DIR
Q $S(''$G(Y):0,1:1)
;
CHFLD(X) ;
N A
S A=$$GET1^DID(X,.01,"","SPECIFIER")
I A["P" D
. F D Q:A'["P"
.. S A=$TR(A,$TR(A,".0123456789"))
.. S A=$$CHFLD(A)
.. Q
. Q
Q A
;
SEL(SDRRD0,SDRRDFNUM,SDRRDDSEL,SDRRDFLD) ;
N %DT,SDRRDPNTR,SDRRDXTRN,DA,DIC,DIQ,DR,X,Y
S SDRRDFLD=$S($G(SDRRDFLD)]"":SDRRDFLD,1:.01)
S (SDRRDPNTR,DA)=SDRRD0
S DIC=SDRRDFNUM,DIQ(0)="E",DIQ="SDRRDXTRN(",DR=SDRRDFLD
D EN^DIQ1
S SDRRDXTRN=$G(SDRRDXTRN(SDRRDFNUM,SDRRDPNTR,SDRRDFLD,"E"))
I $$CHFLD(SDRRDFNUM)["D" S X=SDRRDXTRN,%DT="ST" D ^%DT S SDRRDXTRN=Y
S X=$D(@SDRRDROOT@(SDRRDXTRN,SDRRDPNTR))
Q $S(X#2&SDRRDDSEL:1,X[0&'SDRRDDSEL:1,1:0)
;
FLD(SDRRDFNUM,SDRRDFLD) ; 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.
; SDRRDFNUM = File #
; SDRRDFLD = Field #
; returns SDRRDPASS: 0 if valid, else 1
N SDRRD,SDRRDPASS,I
I SDRRDFLD=.01 Q 1 ; .01 field is not valid!
I $$VFIELD^DILFD(SDRRDFNUM,SDRRDFLD)'>0 Q 1 ; field does not exist
S SDRRD(2)=$$GET1^DID(SDRRDFNUM,SDRRDFLD,"","SPECIFIER")
S SDRRD(4)=$$GET1^DID(SDRRDFNUM,SDRRDFLD,"","GLOBAL SUBSCRIPT LOCATION")
I +SDRRD(2)>0&($$VFIELD^DILFD(+SDRRD(2),.01)>0) Q 1 ; mult field not valid
I $P(SDRRD(4),";")'=0 Q 1 ; field not on the 0 node not valid
S SDRRDPASS=1 ; set initially to not valid
F I="D","F","N","P","S" S:SDRRD(2)[I SDRRDPASS=0 Q:'SDRRDPASS
Q SDRRDPASS
;
FLDSRT(SDRRDFNUM,SDRRDFLD,SDRRDINTR) ; Converts internal to external value
; for sets of codes & pointers.
; SDRRDFNUM = File #
; SDRRDFLD = Field #
; SDRRDPIEC = piece position on 0 node
N SDRRDPIEC
S SDRRDPIEC=$$GET1^DID(SDRRDFNUM,SDRRDFLD,"","GLOBAL SUBSCRIPT LOCATION")
S SDRRDPIEC=$P(SDRRDPIEC,";",2)
Q $$EXTERNAL^DILFD(SDRRDFNUM,SDRRDFLD,"",$P(SDRRDINTR,U,SDRRDPIEC))
;
SETDIC(SDRRDDIC,DIC,DO) ;
N I K DIC,DO
S DIC=SDRRDDIC
D DO^DIC1
F I="0","A","B","S","W" I $G(SDRRDDIC(I))]"" S DIC(I)=SDRRDDIC(I)
Q
;
FILEATTR(DIC,DIC0,SDRRDFNUM,SDRRDFNAM,SDRRDFL01,SDRRDFSCR) ;
N DO
S DIC(0)=DIC0
D DO^DIC1
S SDRRDFNUM=+DO(2)
S SDRRDFNAM=$P(DO,U)
S SDRRDFL01=$$GET1^DID(SDRRDFNUM,.01,"","LABEL")
S SDRRDFSCR=$G(DO("SCR"))
Q
;
PLURAL(SDRRDFL01) ;
Q $S($E(SDRRDFL01,($L(SDRRDFL01)))?1L:"s",1:"S")
SDRRSLCT ;10N20/MAH;-RECALL REMINDER Generic file entry selector ;12/09/2007 14:26
+1 ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
+2 ;
+3 ;
+4 ;Requires:
+5 ; SDRRDDIC = File number or global root
+6 ; SDRRDDIC(0) = DIC(0) string
+7 ; SDRRDUTIL = Node to store data under in ^TMP($J,SDRRDUTIL,
+8 ;
+9 ;Optional:
+10 ; SDRRDDIC("A") = DIC("A") string
+11 ; SDRRDDIC("B") = DIC("B") string
+12 ; SDRRDDIC("S") = DIC("S") string
+13 ; SDRRDDIC("W") = DIC("W") string
+14 ; SDRRDROOT = Closed array reference where data should be stored
+15 ; Defaluts to ^TMP($J,SDRRDUTIL)
+16 ; SDRRDFLD = Field to sort by if valid data to be stored as
+17 ; @Root@(SDRRDUTIL,ExternalValueSDRRDFLD,IEN)=""
+18 ; SDRRDFLD must reside on the zero (0) node to be valid
+19 ;
+20 ;Returns:
+21 ; $$EN() = $S(UpArrowOut:0, NothingSelected:0, 1:1)
+22 ; @SDRRDROOT@(SDRRDUTIL,ExternalFieldData,IEN)=""
+23 ;
+24 ;Example:
+25 ; SET SDRRDDIC=44,SDRRDDIC(0)="EMNQZ",SDRRDDIC("A")="Select CLINIC: "
+26 ; SET SDRRDDIC("B")="ALL",SDRRDDIC("S")="IF $PIECE(^(0),U,3)=""C"""
+27 ; IF $$EN^SDRRSLCT(.SDRRDDIC,"ClinicNode","MYARRAY",1)'>0 QUIT
+28 ;
EN(SDRRDDIC,SDRRDUTIL,SDRRDROOT,SDRRDFLD) ;
+1 NEW %DT,SDRRDDONE,SDRRDDSEL,SDRRDFL01,SDRRDFNAM,SDRRDFNUM,SDRRDFSCR,SDRRDMASK
+2 NEW SDRRDNUM,SDRRDQUIT,SDRRDVALU,SDRRDX,DIC,DO,DTOUT,DUOUT,I,X,Y
+3 SET SDRRDFLD=$GET(SDRRDFLD)
+4 IF $GET(SDRRDROOT)]""
SET SDRRDROOT=$NAME(@SDRRDROOT@(SDRRDUTIL))
+5 IF '$TEST
SET SDRRDROOT=$NAME(^TMP($JOB,SDRRDUTIL))
+6 KILL @SDRRDROOT
+7 SET (SDRRDQUIT,SDRRDDONE)=0
+8 SET SDRRDQUIT=(($GET(SDRRDDIC)="")!($GET(SDRRDDIC(0))="")!($GET(SDRRDUTIL)=""))
+9 IF SDRRDQUIT>0
GOTO EXIT
+10 SET DIC=SDRRDDIC
+11 IF DIC>0
Begin DoDot:1
+12 SET (SDRRDDIC,DIC)=$$GET1^DID(DIC,"","","GLOBAL NAME")
+13 SET SDRRDQUIT=$SELECT(DIC="":1,1:0)
+14 QUIT
End DoDot:1
IF SDRRDQUIT
GOTO EXIT
+15 SET (DIC(0),SDRRDDIC(0))=$TRANSLATE(SDRRDDIC(0),"AL")_$SELECT(SDRRDDIC(0)'["Z":"Z",1:"")
+16 DO FILEATTR(DIC,DIC(0),.SDRRDFNUM,.SDRRDFNAM,.SDRRDFL01,.SDRRDFSCR)
+17 IF SDRRDFLD]""
SET SDRRDQUIT=$$FLD(SDRRDFNUM,SDRRDFLD)
IF SDRRDQUIT
GOTO EXIT
+18 FOR I="A","B","S","W"
SET SDRRDDIC(I)=$GET(SDRRDDIC(I))
+19 IF SDRRDDIC("A")=""
SET SDRRDDIC("A")="Select "_SDRRDFNAM_" "_SDRRDFL01_": "
+20 SET SDRRDNUM=1
+21 DO HOME^%ZIS
+22 FOR
Begin DoDot:1
+23 DO SETDIC(.SDRRDDIC,.DIC,.DO)
+24 WRITE !!,$SELECT(SDRRDNUM>1:"Another one (Select/De-Select): ",1:DIC("A"))
+25 WRITE $SELECT((SDRRDNUM=1)&(SDRRDDIC("B")]""):SDRRDDIC("B")_"// ",1:"")
+26 READ SDRRDX:DTIME
IF ('$TEST)!($EXTRACT(SDRRDX)=U)
SET SDRRDQUIT=1
IF SDRRDQUIT
QUIT
+27 IF (SDRRDNUM=1)&(SDRRDX="")&(SDRRDDIC("B")]"")
SET SDRRDX=SDRRDDIC("B")
+28 IF SDRRDX=""
SET SDRRDDONE=1
QUIT
+29 SET SDRRDDSEL=$SELECT(SDRRDX?1"-"1.E:1,1:0)
+30 IF SDRRDDSEL
SET SDRRDX=$EXTRACT(SDRRDX,2,$LENGTH(SDRRDX))
+31 IF SDRRDX?1.ANP1"-"1.ANP
Begin DoDot:2
+32 SET SDRRDQUIT=$$RANGE^SDRRSLC1(SDRRDX,.SDRRDDIC,SDRRDUTIL,SDRRDFLD,SDRRDDSEL,.SDRRDNUM)
+33 QUIT
End DoDot:2
IF SDRRDQUIT=1
QUIT
IF SDRRDQUIT=-1
SET SDRRDQUIT=0
QUIT
+34 IF ($$UP^XLFSTR(SDRRDX)="ALL")!(SDRRDX["*")
Begin DoDot:2
+35 SET SDRRDQUIT=$$ALL^SDRRSLC1(SDRRDX,.SDRRDDIC,SDRRDUTIL,SDRRDFLD,SDRRDDSEL,.SDRRDNUM)
+36 QUIT
End DoDot:2
IF SDRRDQUIT=1
QUIT
IF SDRRDQUIT=-1
SET SDRRDQUIT=0
QUIT
+37 IF $EXTRACT(SDRRDX)="?"
DO HELP(.SDRRDDIC,SDRRDUTIL,SDRRDFLD)
+38 IF $LENGTH($GET(DIC("S")))<235
Begin DoDot:2
+39 SET DIC("S")=$SELECT($GET(DIC("S"))]"":DIC("S")_" ",1:"")
+40 SET DIC("S")=DIC("S")_"I $$SEL^SDRRSLCT(Y,"_SDRRDFNUM_","_SDRRDDSEL
+41 SET DIC("S")=DIC("S")_$SELECT($GET(SDRRDFLD)]"":","_SDRRDFLD,1:"")_")"
+42 QUIT
End DoDot:2
+43 SET X=SDRRDX
DO ^DIC
KILL DIC
IF +Y'>0
QUIT
+44 SET SDRRDMASK=+Y
+45 IF $$CHFLD(SDRRDFNUM)["D"
Begin DoDot:2
+46 NEW %DT,X
+47 SET X=Y(0,0)
SET %DT="ST"
DO ^%DT
SET Y(0,0)=Y
+48 QUIT
End DoDot:2
+49 SET Y=SDRRDMASK
+50 IF SDRRDFLD=""
Begin DoDot:2
+51 DO SETDATA(Y(0,0),+Y,SDRRDUTIL,SDRRDDSEL,.SDRRDNUM)
+52 QUIT
End DoDot:2
+53 IF '$TEST
Begin DoDot:2
+54 SET SDRRDVALU=$$FLDSRT(SDRRDFNUM,SDRRDFLD,Y(0))
+55 IF SDRRDVALU]""
DO SETDATA(SDRRDVALU,+Y,SDRRDUTIL,SDRRDDSEL,.SDRRDNUM)
+56 QUIT
End DoDot:2
+57 QUIT
End DoDot:1
IF SDRRDQUIT!SDRRDDONE
QUIT
+58 ;
EXIT ;
+1 SET SDRRDQUIT=$SELECT(SDRRDQUIT>0:0,$ORDER(@SDRRDROOT@(""))="":0,1:1)
+2 IF SDRRDQUIT'>0
KILL @SDRRDROOT
+3 QUIT SDRRDQUIT
+4 ;
SETDATA(SDRRDVALU,SDRRD0,SDRRDUTIL,SDRRDDSEL,SDRRDNUM) ;
+1 IF 'SDRRDDSEL
IF '$DATA(@SDRRDROOT@($EXTRACT(SDRRDVALU,1,63),SDRRD0))
Begin DoDot:1
+2 SET @SDRRDROOT@($EXTRACT(SDRRDVALU,1,63),SDRRD0)=""
+3 SET SDRRDNUM=SDRRDNUM+1
+4 QUIT
End DoDot:1
+5 IF SDRRDDSEL
IF $DATA(@SDRRDROOT@($EXTRACT(SDRRDVALU,1,63),SDRRD0))
Begin DoDot:1
+6 KILL @SDRRDROOT@($EXTRACT(SDRRDVALU,1,63),SDRRD0)
+7 SET SDRRDNUM=SDRRDNUM-$SELECT(SDRRDNUM>0:1,1:0)
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
HELP(SDRRDDIC,SDRRDUTIL,SDRRDFLD) ;
+1 NEW SDRRD,SDRRD0,SDRRDCASE,SDRRDFL01,SDRRDFNAM,SDRRDFNUM
+2 NEW SDRRDFSCR,SDRRDLINE,SDRRDQUIT,DIC,D0,DA,DO,X
+3 SET SDRRDQUIT=0
+4 DO FILEATTR(SDRRDDIC,SDRRDDIC(0),.SDRRDFNUM,.SDRRDFNAM,.SDRRDFL01,.SDRRDFSCR)
+5 SET SDRRDCASE=$$PLURAL(SDRRDFL01)
+6 WRITE !
+7 SET SDRRD="Select a "_SDRRDFNAM_" "_SDRRDFL01_" from the displayed list."
+8 DO WRAP(SDRRD,.SDRRDLINE)
+9 SET SDRRD=0
+10 FOR
SET SDRRD=$ORDER(SDRRDLINE(SDRRD))
IF SDRRD'>0
QUIT
WRITE !?5,SDRRDLINE(SDRRD)
+11 WRITE !?5,"To deselect a ",SDRRDFL01," type a minus sign (-)"
+12 WRITE !?5,"in front of it, e.g., -",SDRRDFL01,"."
+13 WRITE !?5,"To get all ",SDRRDFL01,SDRRDCASE," type ALL."
+14 WRITE !?5,"Use an asterisk (*) to do a wildcard selection, e.g.,"
+15 WRITE !?5,"enter ",SDRRDFL01,"* to select all entries that begin"
+16 WRITE !?5,"with the text '",SDRRDFL01,"'. Wildcard selection is"
+17 WRITE !?5,"case sensitive. A range may be selected by entering"
+18 WRITE !?5,"'AAA-CCC', i.e., select all records from 'AAA' to"
+19 WRITE !?5,"'CCC' inclusive."
+20 WRITE !
+21 IF $ORDER(@SDRRDROOT@(""))]""
Begin DoDot:1
+22 SET SDRRDLINE=$Y
+23 SET SDRRD=""
+24 WRITE !,"You have already selected:"
+25 FOR
SET SDRRD=$ORDER(@SDRRDROOT@(SDRRD))
IF SDRRD=""!SDRRDQUIT
QUIT
Begin DoDot:2
+26 SET SDRRD0=0
+27 FOR
SET SDRRD0=$ORDER(@SDRRDROOT@(SDRRD,SDRRD0))
IF SDRRD0'>0!SDRRDQUIT
QUIT
Begin DoDot:3
+28 IF SDRRDFLD]""
SET SDRRD(0)=$PIECE($GET(@(SDRRDDIC_+SDRRD0_",0)")),U)
+29 IF '$TEST
SET SDRRD(0)=SDRRD
+30 IF $$CHFLD(SDRRDFNUM)["D"
SET SDRRD(0)=$$FMTE^XLFDT(SDRRD(0),"5Z")
+31 IF SDRRDDIC(0)["N"
WRITE !?3,SDRRD0,?15,SDRRD(0)
+32 IF '$TEST
WRITE !?3,SDRRD(0)
+33 DO SETDIC(.SDRRDDIC,.DIC,.DO)
+34 IF $DATA(DIC("W"))#2
IF DIC("W")]""
IF $DATA(@(SDRRDDIC_"SDRRD0,0)"))#2
Begin DoDot:4
+35 SET (D0,DA,Y)=SDRRD0
+36 XECUTE DIC("W")
+37 QUIT
End DoDot:4
+38 IF $Y>(IOSL+SDRRDLINE-3)
SET SDRRDQUIT=$$PAUSE
SET SDRRDLINE=$Y
+39 QUIT
End DoDot:3
+40 QUIT
End DoDot:2
+41 QUIT
End DoDot:1
+42 QUIT
+43 ;
WRAP(X,LINE) ;
+1 NEW I,Y
+2 KILL LINE
+3 SET I=0
+4 FOR
SET Y=$LENGTH($EXTRACT(X,1,IOM-20)," ")
Begin DoDot:1
+5 SET I=I+1
+6 SET LINE(I)=$PIECE(X," ",1,Y)
+7 SET X=$PIECE(X," ",Y+1,$LENGTH(X," "))
+8 QUIT
End DoDot:1
IF X=""
QUIT
+9 QUIT
+10 ;
PAUSE() ;
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="E"
+3 DO ^DIR
+4 QUIT $SELECT(''$GET(Y):0,1:1)
+5 ;
CHFLD(X) ;
+1 NEW A
+2 SET A=$$GET1^DID(X,.01,"","SPECIFIER")
+3 IF A["P"
Begin DoDot:1
+4 FOR
Begin DoDot:2
+5 SET A=$TRANSLATE(A,$TRANSLATE(A,".0123456789"))
+6 SET A=$$CHFLD(A)
+7 QUIT
End DoDot:2
IF A'["P"
QUIT
+8 QUIT
End DoDot:1
+9 QUIT A
+10 ;
SEL(SDRRD0,SDRRDFNUM,SDRRDDSEL,SDRRDFLD) ;
+1 NEW %DT,SDRRDPNTR,SDRRDXTRN,DA,DIC,DIQ,DR,X,Y
+2 SET SDRRDFLD=$SELECT($GET(SDRRDFLD)]"":SDRRDFLD,1:.01)
+3 SET (SDRRDPNTR,DA)=SDRRD0
+4 SET DIC=SDRRDFNUM
SET DIQ(0)="E"
SET DIQ="SDRRDXTRN("
SET DR=SDRRDFLD
+5 DO EN^DIQ1
+6 SET SDRRDXTRN=$GET(SDRRDXTRN(SDRRDFNUM,SDRRDPNTR,SDRRDFLD,"E"))
+7 IF $$CHFLD(SDRRDFNUM)["D"
SET X=SDRRDXTRN
SET %DT="ST"
DO ^%DT
SET SDRRDXTRN=Y
+8 SET X=$DATA(@SDRRDROOT@(SDRRDXTRN,SDRRDPNTR))
+9 QUIT $SELECT(X#2&SDRRDDSEL:1,X[0&'SDRRDDSEL:1,1:0)
+10 ;
FLD(SDRRDFNUM,SDRRDFLD) ; 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 ; SDRRDFNUM = File #
+4 ; SDRRDFLD = Field #
+5 ; returns SDRRDPASS: 0 if valid, else 1
+6 NEW SDRRD,SDRRDPASS,I
+7 ; .01 field is not valid!
IF SDRRDFLD=.01
QUIT 1
+8 ; field does not exist
IF $$VFIELD^DILFD(SDRRDFNUM,SDRRDFLD)'>0
QUIT 1
+9 SET SDRRD(2)=$$GET1^DID(SDRRDFNUM,SDRRDFLD,"","SPECIFIER")
+10 SET SDRRD(4)=$$GET1^DID(SDRRDFNUM,SDRRDFLD,"","GLOBAL SUBSCRIPT LOCATION")
+11 ; mult field not valid
IF +SDRRD(2)>0&($$VFIELD^DILFD(+SDRRD(2),.01)>0)
QUIT 1
+12 ; field not on the 0 node not valid
IF $PIECE(SDRRD(4),";")'=0
QUIT 1
+13 ; set initially to not valid
SET SDRRDPASS=1
+14 FOR I="D","F","N","P","S"
IF SDRRD(2)[I
SET SDRRDPASS=0
IF 'SDRRDPASS
QUIT
+15 QUIT SDRRDPASS
+16 ;
FLDSRT(SDRRDFNUM,SDRRDFLD,SDRRDINTR) ; Converts internal to external value
+1 ; for sets of codes & pointers.
+2 ; SDRRDFNUM = File #
+3 ; SDRRDFLD = Field #
+4 ; SDRRDPIEC = piece position on 0 node
+5 NEW SDRRDPIEC
+6 SET SDRRDPIEC=$$GET1^DID(SDRRDFNUM,SDRRDFLD,"","GLOBAL SUBSCRIPT LOCATION")
+7 SET SDRRDPIEC=$PIECE(SDRRDPIEC,";",2)
+8 QUIT $$EXTERNAL^DILFD(SDRRDFNUM,SDRRDFLD,"",$PIECE(SDRRDINTR,U,SDRRDPIEC))
+9 ;
SETDIC(SDRRDDIC,DIC,DO) ;
+1 NEW I
KILL DIC,DO
+2 SET DIC=SDRRDDIC
+3 DO DO^DIC1
+4 FOR I="0","A","B","S","W"
IF $GET(SDRRDDIC(I))]""
SET DIC(I)=SDRRDDIC(I)
+5 QUIT
+6 ;
FILEATTR(DIC,DIC0,SDRRDFNUM,SDRRDFNAM,SDRRDFL01,SDRRDFSCR) ;
+1 NEW DO
+2 SET DIC(0)=DIC0
+3 DO DO^DIC1
+4 SET SDRRDFNUM=+DO(2)
+5 SET SDRRDFNAM=$PIECE(DO,U)
+6 SET SDRRDFL01=$$GET1^DID(SDRRDFNUM,.01,"","LABEL")
+7 SET SDRRDFSCR=$GET(DO("SCR"))
+8 QUIT
+9 ;
PLURAL(SDRRDFL01) ;
+1 QUIT $SELECT($EXTRACT(SDRRDFL01,($LENGTH(SDRRDFL01)))?1L:"s",1:"S")
