- 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))
