DIS ;SFISC/GFT - GATHER SEARCH CRITERIA ;24AUG2015
;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
;;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.
;
K ^UTILITY($J),DC,DIS,%ZIS,O,N,R D ^DICRW
G Q:'$D(DIC)!$D(DTOUT)
EN ;
S:DIC DIC=$G(^DIC(DIC,0,"GL")) Q:DIC=""
K DI,DX,DY,I,J,DL,DC,DA,DTOUT,^UTILITY($J) G Q:'$D(@(DIC_"0)"))
S (R,DI,I(0))=DIC,(DL,DC)=1,DY=999,N=0,Q="""",DV=""
R ;
I +R=R S (J(N),DK)=R,R=""
E S @("(J(N),DK)=+$P("_R_"0),U,2)"),R=$P(^(0),U)
F ;
G UP:DC>58
W ! K X,DIC,DISPOINT,DE D W
S DIC(0)="EZ",C=",",DIC="^DD("_DK_",",DIC("W")="S %=$P(^(0),U,2) W:% $S($P(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")",DIC("S")="I $P(^(0),U,2)'[""m"""_$S($D(DICS):" "_DICS,1:""),DU=""
W "SEARCH FOR "_R_" "_$P(^DD(DK,0),U)_": "
R X:DTIME S:'$T DTOUT=1 G Q:X=U!'$T,TEM^DIS2:X?1"[".E D
.N DISVX S DISVX=X D ^DIC S:Y=-1 X=DISVX Q
I Y>0 K DISPOINT S DE=Y(0),O(DC)=$P(DE,U),DU=+Y,Z=$P(DE,U,3),E=$P(DE,U,2) D:E["t" G G
.I E["S" S X=$$GETPROP^DIETLIBF(DK,+Y,"SET OF CODES") I X]"" S Z=X
HARD G UP:X="",F:X?."?",Q:X=U!($D(DTOUT)),COMP^DIS2
Q
G ;^DOPT("DIS",1,0)=NULL
;^DOPT("DIS",2,0)=CONTAINS
;^DOPT("DIS",3,0)=MATCHES
;^DOPT("DIS",4,0)=LESS THAN
;^DOPT("DIS",5,0)=EQUALS
;^DOPT("DIS",6,0)=GREATER THAN
K X,DIC S DIC="^DOPT(""DIS"",",DIC(0)="QEZ" I E["B" S X="" G OK
I E S N(DL)=N,N=N+1,DV(DL)=DV,DL(DL)=DK,DK=+E,J(N)=DK,X=$P($P(DE,U,4),";"),I(N)=$S(+X=X:X,1:""""_X_""""),Y(0)=^DD(DK,.01,0),DL=DL+1 G WP:$P(Y(0),U,2)["W" S DV=DV_+Y_"," G F
S X=$P(E,"p",2) I X,$D(^DIC(+X,0,"GL")) S DISPOINT=$S(Y:+Y,1:-DC)_U_U_^("GL") ;Y will be FIELD lookup, unless it's COMPUTED EXPRESSION from ^DIS2
I E["P" S DISPOINT=+Y_U_Y(0) S X=+$P(E,"P",2) F Q:'X D
.S DA=$P($G(^DD(X,.01,0)),U,2) I DA["D" S E="D"_E,X="" Q
.S X=+$P(DA,"P",2)
I $D(DISPOINT),Y>0 S X="(#"_+Y_")",DA="DIS("""_$C(DC+64)_DL_""",",DICOMP=N S:$D(O(DC))[0 O(DC)=X D EN^DICOMP G X:'$D(X) S DA(DC)=X,DU=-DC F %=0:0 S %=$O(X(%)) Q:'% S @(DA_%_")")=X(%)
;
C K X D W R "CONDITION: ",X:DTIME S:'$T DTOUT=1 G Q:X[U!'$T
S DN=$S("'-"[$E(X):"'",1:""),X=$E(X,DN]""+1,99)
S:E["S" DIC("S")="I Y<3!(Y=5)" D ^DIC K DIC("S") ;A 'SET' TYPE IS NULL, EQUALS, OR CONTAINS
G:Y<0 Q:X[U,B:X="",DISC^DIQQQ:X["?",C
S O=$P("NOT ",U,DN]"")_$P(Y,U,2)
I +Y=1 S X=DN_"?."" """,O(DC)=O(DC)_" "_O G OK
S DQ=Y
;
VALUE D W W O I E["D",Y-3 R " DATE: ",X:DTIME S:'$T DTOUT=1 G F:X=U,Q:'$T S %DT="TE" D ^%DT S X=Y_U_X G X:Y<0 X ^DD("DD") S Y=X_U_Y G GOT
;POINTERS
PT I $D(DISPOINT),+DQ=5 K DIC,DIS($C(DC+64)_DL) S DIC=U_$P(DISPOINT,U,4),DIC(0)="EMQ",DU=+DISPOINT W " "_$P(@(DIC_"0)"),U)_": " R X:DTIME S:'$T DTOUT=1 G F:U[X,Q:'$T D ^DIC G GOT:Y>0,PT
R ": ",Y:DTIME E S DTOUT=1 G Q
G X:Y="" I Y[U,$P($G(DE),U,4)'[";E",'$P($G(DE),U,2),E'["C" G F ;We can look for "^" in WP or $E-stored actual data
I +DQ=3 S X="I X?"_Y D ^DIM G GOT:$D(X) S Y="?" ;Is it a good PATTERN-MATCH?
I DQ=4!(DQ=6),+Y'=Y G X ;> or < have to be numeric
I Y?."?" D DIS^DIQQQ G VALUE
W:Y[""""&($L(Y)>1) " (Your answer includes quotes)"
SET I E["S" D K DIS("XFORM",DC) G GOT:$D(X) K DIS(U,DC) D DIS^DIQQQ G VALUE
.N D S X=1 I +DQ=5!(Y["""") D K:D="" X Q
..N DIR,DDER
..S X=Y,DIR(0)="S^"_Z,DIR("V")=1 D ^DIR I $G(DDER) S D="" Q
..F X=1:1 S D=$P(Z,";",X) Q:D="" I Y=$P(D,":") S Y=""""_$$CONVQQ^DILIBF($P(D,":"))_"""^"_$P(D,":",2) Q
.N N,%,C W !?7 S Y=""""_Y_"""",N="DE"_DN_$E(" [?<=>",DQ)_Y
.F X=1:1 S D=$P(Z,";",X),DE=$P(D,":",2) Q:D="" S DIS(U,DC,$P(D,":"))=DE I @N S:'$D(%) %="[ Will match" W % S C=$G(C)+1,%="'"_DE_"'" W:C>1 "," W " " W:$X+$L(%)>73 !?7
.I '$D(%) K X Q
.W:C>1 "and " W %_" ]"
I Y?.E2A.E S DIS("XFORM",DC)="$$UP^DILIBF(;)",Y=$$UP^DILIBF(Y)
D
.N P,YY,C S C="""",YY=C_$$CONVQQ^DILIBF($P(Y,U)) F P=2:1:$L(Y,U) S YY="("_YY_"""_$C(94)_"""_$$CONVQQ^DILIBF($P(Y,U,P)),C=C_")"
.S Y=YY_C
GOT S X=DN_$E(" [?<=>",DQ)_$P(Y,U) I E["D" D
.I $P(Y,U)'[".",$E(Y,6,7) S %=$P("^^^^ any time during^ the entire day",U,DQ) I %]"" S DIS("XFORM",DC)="$P(;,""."")",O=O_%
.S Y=$P(Y,U,3)_U_$P(Y,U,2)
I $G(DIS("XFORM",DC))="$$UP^DILIBF(;)" S O=O_" (case-insensitive)"
S O(DC)=O(DC)_" "_O_" "_Y
OK S DC(DC)=DV_DU_U_X,%=DL-1_U_(N#100)
I DL>1,O(DC)'[R S O(DC)=R_" "_O(DC)
S:DU["W" %=DL-2_U_(N#100-1) S DX(DC)=%,DC=DC+1 S:DC=27 DC=33 ;go from "Z" to "a"
B G F:(DU'["W"&(DC<59))
UP I DC>1 G ^DIS0:DL<$S('$D(DIARF0):2,1:2) S DL=DL-1,DV=DV(DL),DK=DL(DL),N=N(DL),R=$S($D(R(DL)):R(DL),1:R) K R(DL) S %=N F S %=$O(I(%)) S:%="" %=-1 G F:%<0 K I(%),J(%)
Q G Q^DIS2:'$D(DIARU),^DIS2
;
WP S DIC("S")="I Y<3",DU=+Y_"W" G C
;
X ;
W $C(7),"??",!! K O(DC) G B
;
W W !?DL*2,"-"_$C(DC+64)_"- " Q
;
;
;
;
;
;
;
ENS ; ENTRY POINT FOR RE-DOING THE SORT USING AN EXISTING SORT TEMPLATE
G EN^DIS3
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIS 4959 printed Jan 18, 2025@03:54:56 Page 2
DIS ;SFISC/GFT - GATHER SEARCH CRITERIA ;24AUG2015
+1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
+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 ;
+7 KILL ^UTILITY($JOB),DC,DIS,%ZIS,O,N,R
DO ^DICRW
+8 if '$DATA(DIC)!$DATA(DTOUT)
GOTO Q
EN ;
+1 if DIC
SET DIC=$GET(^DIC(DIC,0,"GL"))
if DIC=""
QUIT
+2 KILL DI,DX,DY,I,J,DL,DC,DA,DTOUT,^UTILITY($JOB)
if '$DATA(@(DIC_"0)"))
GOTO Q
+3 SET (R,DI,I(0))=DIC
SET (DL,DC)=1
SET DY=999
SET N=0
SET Q=""""
SET DV=""
R ;
+1 IF +R=R
SET (J(N),DK)=R
SET R=""
+2 IF '$TEST
SET @("(J(N),DK)=+$P("_R_"0),U,2)")
SET R=$PIECE(^(0),U)
F ;
+1 if DC>58
GOTO UP
+2 WRITE !
KILL X,DIC,DISPOINT,DE
DO W
+3 SET DIC(0)="EZ"
SET C=","
SET DIC="^DD("_DK_","
SET DIC("W")="S %=$P(^(0),U,2) W:% $S($P(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")"
SET DIC("S")="I $P(^(0),U,2)'[""m"""_$SELECT($DATA(DICS):" "_DICS,1:"")
SET DU=""
+4 WRITE "SEARCH FOR "_R_" "_$PIECE(^DD(DK,0),U)_": "
+5 READ X:DTIME
if '$TEST
SET DTOUT=1
if X=U!'$TEST
GOTO Q
if X?1"[".E
GOTO TEM^DIS2
Begin DoDot:1
+6 NEW DISVX
SET DISVX=X
DO ^DIC
if Y=-1
SET X=DISVX
QUIT
End DoDot:1
+7 IF Y>0
KILL DISPOINT
SET DE=Y(0)
SET O(DC)=$PIECE(DE,U)
SET DU=+Y
SET Z=$PIECE(DE,U,3)
SET E=$PIECE(DE,U,2)
if E["t"
Begin DoDot:1
+8 IF E["S"
SET X=$$GETPROP^DIETLIBF(DK,+Y,"SET OF CODES")
IF X]""
SET Z=X
End DoDot:1
GOTO G
HARD if X=""
GOTO UP
if X?."?"
GOTO F
if X=U!($DATA(DTOUT))
GOTO Q
GOTO COMP^DIS2
+1 QUIT
G ;^DOPT("DIS",1,0)=NULL
+1 ;^DOPT("DIS",2,0)=CONTAINS
+2 ;^DOPT("DIS",3,0)=MATCHES
+3 ;^DOPT("DIS",4,0)=LESS THAN
+4 ;^DOPT("DIS",5,0)=EQUALS
+5 ;^DOPT("DIS",6,0)=GREATER THAN
+6 KILL X,DIC
SET DIC="^DOPT(""DIS"","
SET DIC(0)="QEZ"
IF E["B"
SET X=""
GOTO OK
+7 IF E
SET N(DL)=N
SET N=N+1
SET DV(DL)=DV
SET DL(DL)=DK
SET DK=+E
SET J(N)=DK
SET X=$PIECE($PIECE(DE,U,4),";")
SET I(N)=$SELECT(+X=X:X,1:""""_X_"""")
SET Y(0)=^DD(DK,.01,0)
SET DL=DL+1
if $PIECE(Y(0),U,2)["W"
GOTO WP
SET DV=DV_+Y_","
GOTO F
+8 ;Y will be FIELD lookup, unless it's COMPUTED EXPRESSION from ^DIS2
SET X=$PIECE(E,"p",2)
IF X
IF $DATA(^DIC(+X,0,"GL"))
SET DISPOINT=$SELECT(Y:+Y,1:-DC)_U_U_^("GL")
+9 IF E["P"
SET DISPOINT=+Y_U_Y(0)
SET X=+$PIECE(E,"P",2)
FOR
if 'X
QUIT
Begin DoDot:1
+10 SET DA=$PIECE($GET(^DD(X,.01,0)),U,2)
IF DA["D"
SET E="D"_E
SET X=""
QUIT
+11 SET X=+$PIECE(DA,"P",2)
End DoDot:1
+12 IF $DATA(DISPOINT)
IF Y>0
SET X="(#"_+Y_")"
SET DA="DIS("""_$CHAR(DC+64)_DL_""","
SET DICOMP=N
if $DATA(O(DC))[0
SET O(DC)=X
DO EN^DICOMP
if '$DATA(X)
GOTO X
SET DA(DC)=X
SET DU=-DC
FOR %=0:0
SET %=$ORDER(X(%))
if '%
QUIT
SET @(DA_%_")")=X(%)
+13 ;
C KILL X
DO W
READ "CONDITION: ",X:DTIME
if '$TEST
SET DTOUT=1
if X[U!'$TEST
GOTO Q
+1 SET DN=$SELECT("'-"[$EXTRACT(X):"'",1:"")
SET X=$EXTRACT(X,DN]""+1,99)
+2 ;A 'SET' TYPE IS NULL, EQUALS, OR CONTAINS
if E["S"
SET DIC("S")="I Y<3!(Y=5)"
DO ^DIC
KILL DIC("S")
+3 if Y<0
if X[U
GOTO Q
if X=""
GOTO B
if X["?"
GOTO DISC^DIQQQ
GOTO C
+4 SET O=$PIECE("NOT ",U,DN]"")_$PIECE(Y,U,2)
+5 IF +Y=1
SET X=DN_"?."" """
SET O(DC)=O(DC)_" "_O
GOTO OK
+6 SET DQ=Y
+7 ;
VALUE DO W
WRITE O
IF E["D"
IF Y-3
READ " DATE: ",X:DTIME
if '$TEST
SET DTOUT=1
if X=U
GOTO F
if '$TEST
GOTO Q
SET %DT="TE"
DO ^%DT
SET X=Y_U_X
if Y<0
GOTO X
XECUTE ^DD("DD")
SET Y=X_U_Y
GOTO GOT
+1 ;POINTERS
PT IF $DATA(DISPOINT)
IF +DQ=5
KILL DIC,DIS($CHAR(DC+64)_DL)
SET DIC=U_$PIECE(DISPOINT,U,4)
SET DIC(0)="EMQ"
SET DU=+DISPOINT
WRITE " "_$PIECE(@(DIC_"0)"),U)_": "
READ X:DTIME
if '$TEST
SET DTOUT=1
if U[X
GOTO F
if '$TEST
GOTO Q
DO ^DIC
if Y>0
GOTO GOT
GOTO PT
+1 READ ": ",Y:DTIME
IF '$TEST
SET DTOUT=1
GOTO Q
+2 ;We can look for "^" in WP or $E-stored actual data
if Y=""
GOTO X
IF Y[U
IF $PIECE($GET(DE),U,4)'[";E"
IF '$PIECE($GET(DE),U,2)
IF E'["C"
GOTO F
+3 ;Is it a good PATTERN-MATCH?
IF +DQ=3
SET X="I X?"_Y
DO ^DIM
if $DATA(X)
GOTO GOT
SET Y="?"
+4 ;> or < have to be numeric
IF DQ=4!(DQ=6)
IF +Y'=Y
GOTO X
+5 IF Y?."?"
DO DIS^DIQQQ
GOTO VALUE
+6 if Y[""""&($LENGTH(Y)>1)
WRITE " (Your answer includes quotes)"
SET IF E["S"
Begin DoDot:1
+1 NEW D
SET X=1
IF +DQ=5!(Y["""")
Begin DoDot:2
+2 NEW DIR,DDER
+3 SET X=Y
SET DIR(0)="S^"_Z
SET DIR("V")=1
DO ^DIR
IF $GET(DDER)
SET D=""
QUIT
+4 FOR X=1:1
SET D=$PIECE(Z,";",X)
if D=""
QUIT
IF Y=$PIECE(D,":")
SET Y=""""_$$CONVQQ^DILIBF($PIECE(D,":"))_"""^"_$PIECE(D,":",2)
QUIT
End DoDot:2
if D=""
KILL X
QUIT
+5 NEW N,%,C
WRITE !?7
SET Y=""""_Y_""""
SET N="DE"_DN_$EXTRACT(" [?<=>",DQ)_Y
+6 FOR X=1:1
SET D=$PIECE(Z,";",X)
SET DE=$PIECE(D,":",2)
if D=""
QUIT
SET DIS(U,DC,$PIECE(D,":"))=DE
IF @N
if '$DATA(%)
SET %="[ Will match"
WRITE %
SET C=$GET(C)+1
SET %="'"_DE_"'"
if C>1
WRITE ","
WRITE " "
if $X+$LENGTH(%)>73
WRITE !?7
+7 IF '$DATA(%)
KILL X
QUIT
+8 if C>1
WRITE "and "
WRITE %_" ]"
End DoDot:1
KILL DIS("XFORM",DC)
if $DATA(X)
GOTO GOT
KILL DIS(U,DC)
DO DIS^DIQQQ
GOTO VALUE
+9 IF Y?.E2A.E
SET DIS("XFORM",DC)="$$UP^DILIBF(;)"
SET Y=$$UP^DILIBF(Y)
+10 Begin DoDot:1
+11 NEW P,YY,C
SET C=""""
SET YY=C_$$CONVQQ^DILIBF($PIECE(Y,U))
FOR P=2:1:$LENGTH(Y,U)
SET YY="("_YY_"""_$C(94)_"""_$$CONVQQ^DILIBF($PIECE(Y,U,P))
SET C=C_")"
+12 SET Y=YY_C
End DoDot:1
GOT SET X=DN_$EXTRACT(" [?<=>",DQ)_$PIECE(Y,U)
IF E["D"
Begin DoDot:1
+1 IF $PIECE(Y,U)'["."
IF $EXTRACT(Y,6,7)
SET %=$PIECE("^^^^ any time during^ the entire day",U,DQ)
IF %]""
SET DIS("XFORM",DC)="$P(;,""."")"
SET O=O_%
+2 SET Y=$PIECE(Y,U,3)_U_$PIECE(Y,U,2)
End DoDot:1
+3 IF $GET(DIS("XFORM",DC))="$$UP^DILIBF(;)"
SET O=O_" (case-insensitive)"
+4 SET O(DC)=O(DC)_" "_O_" "_Y
OK SET DC(DC)=DV_DU_U_X
SET %=DL-1_U_(N#100)
+1 IF DL>1
IF O(DC)'[R
SET O(DC)=R_" "_O(DC)
+2 ;go from "Z" to "a"
if DU["W"
SET %=DL-2_U_(N#100-1)
SET DX(DC)=%
SET DC=DC+1
if DC=27
SET DC=33
B if (DU'["W"&(DC<59))
GOTO F
UP IF DC>1
if DL<$SELECT('$DATA(DIARF0):2,1:2)
GOTO ^DIS0
SET DL=DL-1
SET DV=DV(DL)
SET DK=DL(DL)
SET N=N(DL)
SET R=$SELECT($DATA(R(DL)):R(DL),1:R)
KILL R(DL)
SET %=N
FOR
SET %=$ORDER(I(%))
if %=""
SET %=-1
if %<0
GOTO F
KILL I(%),J(%)
Q if '$DATA(DIARU)
GOTO Q^DIS2
GOTO ^DIS2
+1 ;
WP SET DIC("S")="I Y<3"
SET DU=+Y_"W"
GOTO C
+1 ;
X ;
+1 WRITE $CHAR(7),"??",!!
KILL O(DC)
GOTO B
+2 ;
W WRITE !?DL*2,"-"_$CHAR(DC+64)_"- "
QUIT
+1 ;
+2 ;
+3 ;
+4 ;
+5 ;
+6 ;
+7 ;
ENS ; ENTRY POINT FOR RE-DOING THE SORT USING AN EXISTING SORT TEMPLATE
+1 GOTO EN^DIS3
