DICLGFT ;GFT/GFT- USE ANY SORT VALUES FOR LISTER;21MAR2013
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
DICL ;FROM ^DICL RETURN TO BADQ^DICL WITH DIERR DEFINED OR ELSE WE HAVE DINDEX SET UP CORRECTLY TO GET SORTED OUTPUT
N X,I,DITEMP,DICLGFT
D TMPB^DICUIX1(.DITEMP,DIFILE) ;SETS DITEMP=something like "^TMP("DICLB",2,3188"
S DIGFTEMP=DITEMP_")" ;so we can remember to KILL the temporary array
BACKWARD I $G(DINDEX("WAY","REVERSE"))=1 D
.S X=$$SORT(DIFILE,DINDEX,DIGFTEMP,,.DIFROM)
E D
.S X=$$SORT(DIFILE,DINDEX,DIGFTEMP,.DIFROM)
S DIFROM(1)="" I X D BLD^DIALOG(-X,$P(X,U,2)) K @DIGFTEMP Q ;We have already done the sort, so "FROM" can be the beginning
;now we have the answers in @DITEMP.
;D COMMON1^DICUIX2 probably need some of this
S DICLGFT=$P(X,U,2),DINDEX("#")=DICLGFT ;NUMBER OF LEVELS IN OUR SORT
S DINDEX("IXTYPE")="["
F I=1:1:DICLGFT+1 S DINDEX(I,"WAY")=DINDEX("WAY")
S DINDEX(1,"ROOT")=DITEMP_")",X=DITEMP
F I=1:1:DICLGFT S X=X_",DINDEX("_(I)_")",DINDEX(I+1,"ROOT")=X_")"
F I=1:1:DICLGFT S DINDEX(I,"FILE")=DIFILE
;S DINDEX(1,"GET")="DIVAL=ZZZ" ;????????
S DINDEX(1,"TYPE")="[",DINDEX("AT")=1
F I=1:1:DICLGFT S DINDEX(I)=$G(DIFROM(I)) ;FROM VALUES
S DINDEX(DICLGFT+1)=0
Q
;
;
;
;
SORT(DIFILE,BY,DICLARAY,FR,TO) ;SORT FILE BY TEMPLATE OR FIELD(S), AND PUT RESULTS IN 'DICLARAY' ARRAY
;EXTRINSIC FUNCTION RETURNS
;"OK^n" IF SUCCESSFUL, where 'n' is number of levels
;
N L,DIC,FLDS,DHD,DIASKHD,DIPCRIT,PG,DHIT,DIOEND,DIOBEG,DCOPIES,IOP,DQTIME,DIS,DISTOP,DISPAR,DIFIXPTH,DISH,DIS0
N D0,D1,D2,D3,D4,D5,D6,D7,D8,D9,D10,D11,D12,D13
N DIQUIET,DISUPNO S DIQUIET=1,DISUPNO=1
N X
N DIOSL S DIOSL=9999999 ;NORMALLY SET IN DIP5 OR DIARR
N DIFIXPT S DIFIXPT=1,DHD="@@" ;TRICK TO AVOID DEVICE SELECTION!
S DIOBEG="K ^UTILITY($J,""H"") S DISH=1,IOT="""",$X=0,$Y=0" ;TRICK TO SUPPRESS SUBHEADERS IN SORT TEMPLATE, WHETHER OR NOT THERE IS A PRE-SORT
I '$D(^DIC(DIFILE,0,"GL")) Q "401^"_DIFILE
S DIC=^("GL")
;
N DICLGFT S DICLGFT=1
;
I "@"[$G(BY) Q "-202^SORT VALUE"
DIBT S X=0 I $G(BY)?1"[".E1"]" S X=$O(^DIBT("F"_DIFILE,$TR(BY,"[]"),0)) I X&$O(^(X))!'X Q "-202^SORT TEMPLATE '"_BY_"'" ;MUST HAVE EXACTLY ONE TEMPLATE OF THAT NAME
I X S L=$O(^DIBT(X,2,999),-1) I L S DICLGFT=L D G A:$D(X) Q "-202^SORT TEMPLATE '"_BY_"'" ;NUMBER OF LEVELS
.F L=1:1:L I $G(^DIBT(X,2,L,"ASK")) K X Q ;NONE OF THE LEVELS MUST ASK
;I X,'L S DICLGFT0=1
;
FIELD N DICLGFTX,DD S DICLGFTX=$G(BY),DICLGFT=$L(DICLGFTX,",") ;SORT BY FIELD
S:$D(FR)[0 FR=",,,,,,,,,,,," S:$D(TO)[0 TO=",,,,,,,,,,"
S DD=DIFILE F S FLDS=$P(DICLGFTX,","),DICLGFTX=$P(DICLGFTX,",",2) Q:FLDS="" D
.S FLDS=$P(FLDS,";") I $D(^DD(DD,FLDS,0))
.E S FLDS=$O(^DD(DD,"B",FLDS,0)) Q:'FLDS
.S L=+$P(^DD(DD,FLDS,0),U,2) I L S DD=L,DICLGFT=DICLGFT-1 ;GOING DOWN INTO A MULTIPLE, SO LEVEL OF SORT IS 1 LESS THAN WE THOT
;
A I DICLARAY["^",DICLARAY'["(" Q "-202^BAD ARRAY "_DICLARAY
K ^UTILITY("DICLGFT",$J),@DICLARAY
;
DHIT S DHIT="" ;I $G(DICLGFT0) S DHIT="1," ;IF IT IS JUST A LIST
F L=1:1:DICLGFT S X="DIOO"_L,DHIT="$S($G("_X_")]"""":"_X_",1:1),"_DHIT
S DHIT="("_DHIT_"D0)",DHIT="S @DICLARAY@"_DHIT_"=""""" ;CREATES SOMETHING LIKE DHIT = S @DICLARAY@($S($G(DIOO2)]"":DIOO2,1:1),$S($G(DIOO1)]"":DIOO1,1:1),D0)=""
;
S L=0,FLDS="X ""QUIT"";X"
S $X=0,$Y=0 ;,IOP="NULL"
DIP D EN1^DIP ;HERE IS THE BIG CALL TO FILEMAN'S PRINT MODULE!
Q "OK^"_DICLGFT ;EXIT WITH 'DICLGFT' DEFINED AS THE NUMBER OF LEVELS
;
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICLGFT 3740 printed Oct 16, 2024@18:46:46 Page 2
DICLGFT ;GFT/GFT- USE ANY SORT VALUES FOR LISTER;21MAR2013
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
DICL ;FROM ^DICL RETURN TO BADQ^DICL WITH DIERR DEFINED OR ELSE WE HAVE DINDEX SET UP CORRECTLY TO GET SORTED OUTPUT
+1 NEW X,I,DITEMP,DICLGFT
+2 ;SETS DITEMP=something like "^TMP("DICLB",2,3188"
DO TMPB^DICUIX1(.DITEMP,DIFILE)
+3 ;so we can remember to KILL the temporary array
SET DIGFTEMP=DITEMP_")"
BACKWARD IF $GET(DINDEX("WAY","REVERSE"))=1
Begin DoDot:1
+1 SET X=$$SORT(DIFILE,DINDEX,DIGFTEMP,,.DIFROM)
End DoDot:1
+2 IF '$TEST
Begin DoDot:1
+3 SET X=$$SORT(DIFILE,DINDEX,DIGFTEMP,.DIFROM)
End DoDot:1
+4 ;We have already done the sort, so "FROM" can be the beginning
SET DIFROM(1)=""
IF X
DO BLD^DIALOG(-X,$PIECE(X,U,2))
KILL @DIGFTEMP
QUIT
+5 ;now we have the answers in @DITEMP.
+6 ;D COMMON1^DICUIX2 probably need some of this
+7 ;NUMBER OF LEVELS IN OUR SORT
SET DICLGFT=$PIECE(X,U,2)
SET DINDEX("#")=DICLGFT
+8 SET DINDEX("IXTYPE")="["
+9 FOR I=1:1:DICLGFT+1
SET DINDEX(I,"WAY")=DINDEX("WAY")
+10 SET DINDEX(1,"ROOT")=DITEMP_")"
SET X=DITEMP
+11 FOR I=1:1:DICLGFT
SET X=X_",DINDEX("_(I)_")"
SET DINDEX(I+1,"ROOT")=X_")"
+12 FOR I=1:1:DICLGFT
SET DINDEX(I,"FILE")=DIFILE
+13 ;S DINDEX(1,"GET")="DIVAL=ZZZ" ;????????
+14 SET DINDEX(1,"TYPE")="["
SET DINDEX("AT")=1
+15 ;FROM VALUES
FOR I=1:1:DICLGFT
SET DINDEX(I)=$GET(DIFROM(I))
+16 SET DINDEX(DICLGFT+1)=0
+17 QUIT
+18 ;
+19 ;
+20 ;
+21 ;
SORT(DIFILE,BY,DICLARAY,FR,TO) ;SORT FILE BY TEMPLATE OR FIELD(S), AND PUT RESULTS IN 'DICLARAY' ARRAY
+1 ;EXTRINSIC FUNCTION RETURNS
+2 ;"OK^n" IF SUCCESSFUL, where 'n' is number of levels
+3 ;
+4 NEW L,DIC,FLDS,DHD,DIASKHD,DIPCRIT,PG,DHIT,DIOEND,DIOBEG,DCOPIES,IOP,DQTIME,DIS,DISTOP,DISPAR,DIFIXPTH,DISH,DIS0
+5 NEW D0,D1,D2,D3,D4,D5,D6,D7,D8,D9,D10,D11,D12,D13
+6 NEW DIQUIET,DISUPNO
SET DIQUIET=1
SET DISUPNO=1
+7 NEW X
+8 ;NORMALLY SET IN DIP5 OR DIARR
NEW DIOSL
SET DIOSL=9999999
+9 ;TRICK TO AVOID DEVICE SELECTION!
NEW DIFIXPT
SET DIFIXPT=1
SET DHD="@@"
+10 ;TRICK TO SUPPRESS SUBHEADERS IN SORT TEMPLATE, WHETHER OR NOT THERE IS A PRE-SORT
SET DIOBEG="K ^UTILITY($J,""H"") S DISH=1,IOT="""",$X=0,$Y=0"
+11 IF '$DATA(^DIC(DIFILE,0,"GL"))
QUIT "401^"_DIFILE
+12 SET DIC=^("GL")
+13 ;
+14 NEW DICLGFT
SET DICLGFT=1
+15 ;
+16 IF "@"[$GET(BY)
QUIT "-202^SORT VALUE"
DIBT ;MUST HAVE EXACTLY ONE TEMPLATE OF THAT NAME
SET X=0
IF $GET(BY)?1"[".E1"]"
SET X=$ORDER(^DIBT("F"_DIFILE,$TRANSLATE(BY,"[]"),0))
IF X&$ORDER(^(X))!'X
QUIT "-202^SORT TEMPLATE '"_BY_"'"
+1 ;NUMBER OF LEVELS
IF X
SET L=$ORDER(^DIBT(X,2,999),-1)
IF L
SET DICLGFT=L
Begin DoDot:1
+2 ;NONE OF THE LEVELS MUST ASK
FOR L=1:1:L
IF $GET(^DIBT(X,2,L,"ASK"))
KILL X
QUIT
End DoDot:1
if $DATA(X)
GOTO A
QUIT "-202^SORT TEMPLATE '"_BY_"'"
+3 ;I X,'L S DICLGFT0=1
+4 ;
FIELD ;SORT BY FIELD
NEW DICLGFTX,DD
SET DICLGFTX=$GET(BY)
SET DICLGFT=$LENGTH(DICLGFTX,",")
+1 if $DATA(FR)[0
SET FR=",,,,,,,,,,,,"
if $DATA(TO)[0
SET TO=",,,,,,,,,,"
+2 SET DD=DIFILE
FOR
SET FLDS=$PIECE(DICLGFTX,",")
SET DICLGFTX=$PIECE(DICLGFTX,",",2)
if FLDS=""
QUIT
Begin DoDot:1
+3 SET FLDS=$PIECE(FLDS,";")
IF $DATA(^DD(DD,FLDS,0))
+4 IF '$TEST
SET FLDS=$ORDER(^DD(DD,"B",FLDS,0))
if 'FLDS
QUIT
+5 ;GOING DOWN INTO A MULTIPLE, SO LEVEL OF SORT IS 1 LESS THAN WE THOT
SET L=+$PIECE(^DD(DD,FLDS,0),U,2)
IF L
SET DD=L
SET DICLGFT=DICLGFT-1
End DoDot:1
+6 ;
A IF DICLARAY["^"
IF DICLARAY'["("
QUIT "-202^BAD ARRAY "_DICLARAY
+1 KILL ^UTILITY("DICLGFT",$JOB),@DICLARAY
+2 ;
DHIT ;I $G(DICLGFT0) S DHIT="1," ;IF IT IS JUST A LIST
SET DHIT=""
+1 FOR L=1:1:DICLGFT
SET X="DIOO"_L
SET DHIT="$S($G("_X_")]"""":"_X_",1:1),"_DHIT
+2 ;CREATES SOMETHING LIKE DHIT = S @DICLARAY@($S($G(DIOO2)]"":DIOO2,1:1),$S($G(DIOO1)]"":DIOO1,1:1),D0)=""
SET DHIT="("_DHIT_"D0)"
SET DHIT="S @DICLARAY@"_DHIT_"="""""
+3 ;
+4 SET L=0
SET FLDS="X ""QUIT"";X"
+5 ;,IOP="NULL"
SET $X=0
SET $Y=0
DIP ;HERE IS THE BIG CALL TO FILEMAN'S PRINT MODULE!
DO EN1^DIP
+1 ;EXIT WITH 'DICLGFT' DEFINED AS THE NUMBER OF LEVELS
QUIT "OK^"_DICLGFT
+2 ;
+3 ;
+4 ;
