[796] | 1 | TMGDIS ;TMG/kst/Custom version of DIS ;03/25/06 ; 5/12/10 3:06pm
|
---|
| 2 | ;;1.0;TMG-LIB;**1**;01/01/06
|
---|
| 3 | ;"-------Prior header below ---------------
|
---|
| 4 | ;"SFISC/GFT-GATHER SEARCH CRITERIA ;05:52 PM 27 Mar 2002
|
---|
| 5 | ;";22.0;VA FileMan;**6,97**;Mar 30, 1999
|
---|
| 6 | ;"
|
---|
| 7 | ;"Purpose: to GATHER SEARCH CRITERIA
|
---|
| 8 | ;"------Also includes code from DIS2, with header as below.
|
---|
| 9 | ;SFISC/GFT-SEARCH, TEMPLATES & COMPUTED FIELDS ;5:49 AM 2 Jun 1999
|
---|
| 10 | ;;22.0;VA FileMan;**6**;Mar 30, 1999
|
---|
| 11 | ;
|
---|
| 12 | ;"Purpose: SEARCH, TEMPLATES & COMPUTED FIELDS
|
---|
| 13 | ;"Note: Program execution can loop all the way back to ^DIS
|
---|
| 14 | ;"
|
---|
| 15 | SRCH(TMGINFO,TMGOUT,TMGBYROOT) ;
|
---|
| 16 | ;"Purpose: Provide an API interface for the classic Fileman console search
|
---|
| 17 | ;"Input: TMGINFO -- PASS BY REFERENCE. This is pre-defined search terms. Format:
|
---|
| 18 | ;" TMGINFO("FILE") -- File name or number to be used for search
|
---|
| 19 | ;" TMGINFO(1,...) -- Search condition 1 (corresponds to 'A' in console)
|
---|
| 20 | ;" TMGINFO(2,...) -- Search condition 2 (corresponds to 'B' in console)
|
---|
| 21 | ;" ...
|
---|
| 22 | ;" --DETAILS ON SEARCH CONDITION----
|
---|
| 23 | ;" TMGINFO(n,"FLD") -- The Fileman field name or number to seach in
|
---|
| 24 | ;" TMGINFO(n,"COND") -- The condition: "=,>,<,[,?,NULL" Prefix ' or - to negate
|
---|
| 25 | ;" TMGINFO(n,"VALUE") -- the value to search for
|
---|
| 26 | ;" TMGOUT --An OUT PARAMETER. Prior values killed. Format:
|
---|
| 27 | ;" TMGOUT(FILENUM,IEN)=""
|
---|
| 28 | ;" TMGOUT(FILENUM,IEN)=""
|
---|
| 29 | ;" TMGOUT(FILENUM,IEN)=""
|
---|
| 30 | ;" TMGBYROOT -- (Optional) If 1, then TMGOUT is treated as a variable NAME (root)
|
---|
| 31 | ;" i.e. @TMGOUT@(FILENUM,IEN)=""
|
---|
| 32 | ;"Results: 1 if OK, or -1^Error Message
|
---|
| 33 | ;
|
---|
| 34 | NEW DC ;"Variable DC stores coded search values
|
---|
| 35 | ;"Example:
|
---|
| 36 | ;"DC(1)="14,.01^=105" <-- field 14, sub field .01 '=' IEN 105 (in pointed to file)
|
---|
| 37 | ;"DC(2)="14,2^=44" <-- field 14, sub field 2 '=' IEN 44 (in pointed to file)
|
---|
| 38 | ;"
|
---|
| 39 | ;"Example
|
---|
| 40 | ;"DC(1)="14,-1^[""ACETA""" <-- field 14 is a multiple, '-' --> ? 1 is field '[' ACETA
|
---|
| 41 | ;"DC(2)="14,-2^[""%""" <-- field 14 is a multiple, '-' --> ? 2 is field '[' %
|
---|
| 42 | ;"
|
---|
| 43 | ;"Example
|
---|
| 44 | ;"DC=6
|
---|
| 45 | ;"DC(1) = 14,.01^=105 <-- field 14, sub field .01 '=' IEN 105 (in pointed to file)
|
---|
| 46 | ;"DC(2) = 14,-2^["%" <-- field 14 is a multiple, '-' --> ? 2 is field '[' %
|
---|
| 47 | ;" note field 2 is a pointer, so perhaps '-' means non-exact match
|
---|
| 48 | ;"DC(3) = 14,1^["1" <-- field 14 is a multiple, 1 is field '[' ACETA
|
---|
| 49 | ;" note field 1 is free text, so perhaps '-' not needed
|
---|
| 50 | ;"DC(4) = 1^=211 <-- field 1 '=' IEN 211
|
---|
| 51 | ;"DC(5) = .01^["A" <-- field .01 '[' A
|
---|
| 52 | ;"Values of O with above example
|
---|
| 53 | ;"O=0
|
---|
| 54 | ;"O(1) = VA PRODUCT ACTIVE INGREDIENTS EQUALS 105^ACETAMINOPHEN
|
---|
| 55 | ;"O(2) = VA PRODUCT UNITS CONTAINS "%"
|
---|
| 56 | ;"O(3) = VA PRODUCT STRENGTH CONTAINS "1"
|
---|
| 57 | ;"O(4) = DOSAGE FORM EQUALS 211^BAG
|
---|
| 58 | ;"O(5) = NAME CONTAINS "A"
|
---|
| 59 | NEW DIS,%ZIS
|
---|
| 60 | NEW O ;"('Oh', not 'zero') Stores file & field names and values to search FOR
|
---|
| 61 | ;"Example:
|
---|
| 62 | ;"O=0
|
---|
| 63 | ;"O(1) = VA PRODUCT ACTIVE INGREDIENTS CONTAINS (case-insensitive) "ACETAMINOPHEN"
|
---|
| 64 | ;"O(2) = VA PRODUCT ACTIVE INGREDIENTS CONTAINS (case-insensitive) "CAFF"
|
---|
| 65 | ;"O(3) = VA GENERIC NAME CONTAINS "A"
|
---|
| 66 | ;"Note:
|
---|
| 67 | ;" Each node (i.e. (1),(2) etc) contains a separate search item.
|
---|
| 68 | ;"
|
---|
| 69 | ;"Another example
|
---|
| 70 | ;"O="EQUALS"
|
---|
| 71 | ;"O(1)="VA PRODUCT ACTIVE INGREDIENTS EQUALS 105^ACETAMINOPHEN"
|
---|
| 72 | ;"O(2)="VA PRODUCT UNITS EQUALS 44^%"
|
---|
| 73 | ;"
|
---|
| 74 | ;"Note:
|
---|
| 75 | ;" In above examples,
|
---|
| 76 | ;" O(1) --> VA PRODUCT is file name, ACTIVE INGREDIENTS is .01 field
|
---|
| 77 | ;" of ACTIVE INGREDIENTS multiple
|
---|
| 78 | ;" 105 is IEN of ACETAMINOPHEN
|
---|
| 79 | ;" EQUALS is chosen comparator
|
---|
| 80 | ;" O(2)--> VA PRODUCT is file name, UNITS is field 2 of ACTIVE INGREDIENTS multiple
|
---|
| 81 | ;" 44 is IEN of unit '%'
|
---|
| 82 | ;" EQUALS is chosen comparator
|
---|
| 83 | ;" The value in O (e.g. 'EQUALS') is later killed, so not used in actual search.
|
---|
| 84 |
|
---|
| 85 | NEW N,P,C,Z,I,J,Q
|
---|
| 86 | NEW R ;"stores root of file being searched
|
---|
| 87 | NEW E ;"stores field type codes (piece 2 of 0 node)
|
---|
| 88 | NEW DIC,X,Y
|
---|
| 89 | NEW DL ;"DL=indent amount from left margin.
|
---|
| 90 | NEW DC ;"DC=search element i.e. 1=A,2=B,3=C etc.
|
---|
| 91 | NEW DU ;"DU = field number
|
---|
| 92 | NEW DA,DI,DV,DX,DY,DTOUT,DK
|
---|
| 93 | NEW DICMX,DICOMP
|
---|
| 94 | NEW TMGRESULT SET TMGRESULT=1 ;"Default to success
|
---|
| 95 | SET DIC=1
|
---|
| 96 | SET X=$GET(TMGINFO("FILE"))
|
---|
| 97 | DO ^DIC
|
---|
| 98 | IF Y=-1 DO GOTO SRCHDN
|
---|
| 99 | . SET TMGRESULT="-1^File '"_X_"' is not valid."
|
---|
| 100 | SET DIC=+Y
|
---|
| 101 | NEW TMGFILE SET TMGFILE=$P(Y,U,2)
|
---|
| 102 | EN ;
|
---|
| 103 | IF DIC SET DIC=$G(^DIC(DIC,0,"GL"))
|
---|
| 104 | IF DIC="" DO GOTO SRCHDN
|
---|
| 105 | . SET TMGRESULT="-1^File '"_TMGFILE_"' is not valid."
|
---|
| 106 | KILL DI,DX,DY,I,J,DL,DC,DA,DTOUT,^UTILITY($J)
|
---|
| 107 | IF '$DATA(@(DIC_"0)")) DO GOTO SRCHDN
|
---|
| 108 | . SET TMGRESULT="-1^File '"_TMGFILE_"' is missing its global."
|
---|
| 109 | SET (R,DI,I(0))=DIC
|
---|
| 110 | SET DL=1 ;"DL=indent amount from left margin.
|
---|
| 111 | SET DC=1 ;"DC=search element i.e. 1=A,2=B,3=C etc.
|
---|
| 112 | SET DY=999
|
---|
| 113 | SET N=0
|
---|
| 114 | SET Q=""""
|
---|
| 115 | SET DV=""
|
---|
| 116 | R ;
|
---|
| 117 | ;"SET J(N) and DK<--file NUMBER, R<--file NAME
|
---|
| 118 | IF +R=R DO
|
---|
| 119 | . SET (J(N),DK)=R
|
---|
| 120 | . SET R=""
|
---|
| 121 | ELSE DO
|
---|
| 122 | . SET @("(J(N),DK)=+$PIECE("_R_"0),U,2)")
|
---|
| 123 | . SET R=$PIECE(^(0),U)
|
---|
| 124 | ;
|
---|
| 125 | F ;=== Get next field===
|
---|
| 126 | IF DC>58 GOTO UP
|
---|
| 127 | ;"WRITE !
|
---|
| 128 | KILL X,DIC,P
|
---|
| 129 | ;"DO W ;"Write label to screen line -A-, or -B- etc.
|
---|
| 130 | SET DIC(0)="Z" ;"WAS EZ
|
---|
| 131 | SET C=","
|
---|
| 132 | SET DIC="^DD("_DK_C
|
---|
| 133 | ;"SET DIC("W")="SET %=$PIECE(^(0),U,2) WRITE:% $SELECT($PIECE(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")"
|
---|
| 134 | SET DIC("S")="IF $PIECE(^(0),U,2)'[""m"""_$select($DATA(DICS):" "_DICS,1:""),DU=""
|
---|
| 135 | ;"WRITE "SEARCH FOR "_R_" "_$PIECE(^DD(DK,0),U)_": "
|
---|
| 136 | ;"READ X:DTIME ;"ask user FOR filed to search in, from specified file
|
---|
| 137 | ;"SET:'$T DTOUT=1
|
---|
| 138 | ;"IF X=U!'$T GOTO Q
|
---|
| 139 | SET X=$GET(TMGINFO(DC,"FLD"))
|
---|
| 140 | ;"IF X?1"[".E GOTO TEM ;"I think this is for putting all on one line. REMOVED.
|
---|
| 141 | DO
|
---|
| 142 | . NEW DISVX SET DISVX=X
|
---|
| 143 | . DO ^DIC ;"search FOR field, based on user input.
|
---|
| 144 | . IF Y=-1 SET X=DISVX
|
---|
| 145 | IF '(Y>0) GOTO HARD ;"Time to do the hard part...
|
---|
| 146 | KILL P
|
---|
| 147 | SET DE=Y(0)
|
---|
| 148 | SET O(DC)=$PIECE(DE,U) ;"Store first part of search term
|
---|
| 149 | SET DU=+Y ;"DU = field number
|
---|
| 150 | SET Z=$PIECE(DE,U,3) ;"pointers or SET data
|
---|
| 151 | SET E=$PIECE(DE,U,2) ;"field info codes, poss with subfile #
|
---|
| 152 | G ;==== Get Condition =========
|
---|
| 153 | KILL X,DIC
|
---|
| 154 | SET DIC="^DOPT(""DIS""," ;"file containing "equals","contains","greater than" etc.
|
---|
| 155 | SET DIC(0)="Z" ;"Was QEZ
|
---|
| 156 | IF E["B" SET X="" GOTO OK ;"'B'->field is a BOOLEAN COMPUTED field, so skip
|
---|
| 157 | IF +E=0 GOTO G2KT ;"E=file info code starts with # IF subfile. So skip IF not subfile
|
---|
| 158 | SET N(DL)=N
|
---|
| 159 | SET N=N+1
|
---|
| 160 | SET DV(DL)=DV
|
---|
| 161 | SET DL(DL)=DK
|
---|
| 162 | SET DK=+E
|
---|
| 163 | SET J(N)=DK
|
---|
| 164 | SET X=$PIECE($PIECE(DE,U,4),";") ;"4th piece of 0 node holds storage location
|
---|
| 165 | SET I(N)=$select(+X=X:X,1:""""_X_"""")
|
---|
| 166 | SET Y(0)=^DD(DK,.01,0)
|
---|
| 167 | SET DL=DL+1 ;"indent further
|
---|
| 168 | IF $PIECE(Y(0),U,2)["W" GOTO WP ;"Process WP fields
|
---|
| 169 | SET DV=DV_+Y_","
|
---|
| 170 | GOTO F ;"loop back to get more field info for subfile FIX!!! How is this pre-determined??
|
---|
| 171 | G2KT IF E["P" DO GOTO HARD ;"IF field points to another file, setup and GOTO HARD
|
---|
| 172 | . SET P=+Y_U_Y(0) ;"e.g. P=.02^PATIENT^P9000001'
|
---|
| 173 | . SET X="(#"_+Y_")"
|
---|
| 174 | C ;"DO W ;"Write label to screen line -A-, or -B- etc.
|
---|
| 175 | ;"READ "CONDITION: ",X:DTIME
|
---|
| 176 | ;"SET:'$T DTOUT=1
|
---|
| 177 | ;"IF X[U!'$T GOTO Q
|
---|
| 178 | SET X=$GET(TMGINFO(DC,"COND")) ;"Get pre-defined user search condition
|
---|
| 179 | IF X="" DO GOTO SRCHDN
|
---|
| 180 | . SET TMGRESULT="-1^Search condition not specified for term #"_DC
|
---|
| 181 | SET DN=$select("'-"[$E(X):"'",1:"") ;"IF NOT is specified then DN="'"
|
---|
| 182 | SET X=$E(X,DN]""+1,99) ;"remove 'NOT' symbol, IF present
|
---|
| 183 | DO ^DIC
|
---|
| 184 | ;"IF Y>0 GOTO C2
|
---|
| 185 | ;"IF X[U GOTO Q
|
---|
| 186 | ;"IF X="" GOTO B
|
---|
| 187 | ;"IF X["?" GOTO DISCDIQQQ
|
---|
| 188 | ;"GOTO C
|
---|
| 189 | IF Y=-1 DO GOTO SRCHDN
|
---|
| 190 | . SET TMGRESULT="-1^Search condition '"_X_"' is not valid."
|
---|
| 191 | C2 SET O=$PIECE("NOT ",U,DN]"")_$PIECE(Y,U,2) ;"Store search condition in O
|
---|
| 192 | IF +Y=1 DO GOTO OK ;"Handle NULL selected
|
---|
| 193 | . SET X=DN_"?."" """
|
---|
| 194 | . SET O(DC)=O(DC)_" "_O
|
---|
| 195 | SET DQ=Y
|
---|
| 196 | ;"At this point DQ (and Y) should be one of following values:
|
---|
| 197 | ;"1 for NULL, 2 for CONTAINS 3 for matches
|
---|
| 198 | ;"4 for LESS THAN 5 for EQUALS 6 for GREATER THAN
|
---|
| 199 | ;
|
---|
| 200 | ;"====Get Search Term=================
|
---|
| 201 | ;"DO W ;"Write label to screen line -A-, or -B- etc.
|
---|
| 202 | ;"WRITE O
|
---|
| 203 | IF (E'["D")!(Y<4) GOTO PT
|
---|
| 204 | ;"Handle searches for DATES
|
---|
| 205 | ;"READ " DATE: ",X:DTIME
|
---|
| 206 | SET X=$GET(INFO(DC,"VALUE"))
|
---|
| 207 | ;"SET:'$T DTOUT=1
|
---|
| 208 | ;"IF X=U!'$T GOTO Q
|
---|
| 209 | IF X="" DO GOTO SRCHDN
|
---|
| 210 | . SET TMGRESULT="-1^No search value specified for term #"_DC
|
---|
| 211 | SET %DT="T" ;"was TE
|
---|
| 212 | DO ^%DT
|
---|
| 213 | IF Y<0 DO GOTO SRCHDN
|
---|
| 214 | . SET TMGRESULT="-1^Invalid date value '"_X
|
---|
| 215 | SET X=Y_U_X
|
---|
| 216 | XECUTE ^DD("DD")
|
---|
| 217 | SET Y=X_U_Y
|
---|
| 218 | GOTO GOT
|
---|
| 219 | PT ;"POINTERS
|
---|
| 220 | IF $DATA(P),+DQ=5 DO GOTO Q:U[X!'$T DO ^DIC GOTO GOT:Y>0,PT
|
---|
| 221 | . KILL DIC,DIS($char(DC+64)_DL)
|
---|
| 222 | . SET DIC=U_$PIECE(P,U,4)
|
---|
| 223 | . SET DIC(0)="EMQ"
|
---|
| 224 | . SET DU=+P
|
---|
| 225 | . WRITE " "_$PIECE(@(DIC_"0)"),U)_": "
|
---|
| 226 | . READ X:DTIME
|
---|
| 227 | . SET:'$T DTOUT=1
|
---|
| 228 | READ ": ",Y:DTIME
|
---|
| 229 | IF '$T SET DTOUT=1 GOTO Q
|
---|
| 230 | GOTO X:Y=""
|
---|
| 231 | IF Y[U,$PIECE(DE,U,4)'[";E" GOTO Q
|
---|
| 232 | IF +DQ=3 SET X="I X?"_Y DO ^DIM GOTO GOT:$DATA(X) SET Y="?"
|
---|
| 233 | GOTO DISDIQQQ:Y?."?"
|
---|
| 234 | SET IF E["S" DO IF '$DATA(X) KILL DIS(U,DC) GOTO DISDIQQQ
|
---|
| 235 | . IF +DQ=5!(Y["""") DO kill:D="" X QUIT
|
---|
| 236 | . . SET Y=":"_Y
|
---|
| 237 | . . NEW TMGQUIT SET TMGQUIT=0
|
---|
| 238 | . . ;"FOR X=1:1 DO IF D[Y WRITE $PIECE(D,Y,2,9) SET Y=$PIECE(D,":")_U_$PIECE(D,":",2) Q
|
---|
| 239 | . . FOR X=1:1 DO QUIT:TMGQUIT=1
|
---|
| 240 | . . . SET D=$PIECE(Z,";",X)
|
---|
| 241 | . . . IF D="" SET TMGQUIT=1 QUIT
|
---|
| 242 | . . . IF D[Y DO
|
---|
| 243 | . . . . WRITE $PIECE(D,Y,2,9)
|
---|
| 244 | . . . . SET Y=$PIECE(D,":")_U_$PIECE(D,":",2)
|
---|
| 245 | . . . . SET TMGQUIT=1
|
---|
| 246 | N . NEW N,%,C
|
---|
| 247 | . WRITE !?7
|
---|
| 248 | . SET N="DE"_DN_$E(" [?<=>",DQ)_""""_Y_""""
|
---|
| 249 | . NEW TMGQUIT SET TMGQUIT=0
|
---|
| 250 | . FOR X=1:1 DO QUIT:TMGQUIT=1
|
---|
| 251 | . . SET D=$PIECE(Z,";",X)
|
---|
| 252 | . . SET DE=$PIECE(D,":",2)
|
---|
| 253 | . . IF D="" SET TMGQUIT=1
|
---|
| 254 | . . SET DIS(U,DC,$PIECE(D,":"))=DE
|
---|
| 255 | . . IF @N DO
|
---|
| 256 | . . . SET:'$DATA(%) %="[ Will match"
|
---|
| 257 | . . . WRITE %
|
---|
| 258 | . . . SET C=$G(C)+1
|
---|
| 259 | . . . SET %="'"_DE_"'"
|
---|
| 260 | . . . write:C>1 ","
|
---|
| 261 | . . . WRITE " "
|
---|
| 262 | . . . write:$X+$L(%)>73 !?7
|
---|
| 263 | . IF '$DATA(%) KILL X Q
|
---|
| 264 | . write:C>1 "and "
|
---|
| 265 | . WRITE %_" ]"
|
---|
| 266 | T IF DQ["THAN",+$PIECE(Y,U)'=$PIECE(Y,U) GOTO X
|
---|
| 267 | QUOTE IF DQ#3=2 DO ;"Equals or Contains
|
---|
| 268 | . write:$PIECE(Y,U)[""""&($L($PIECE(Y,U))>1) " (Your answer includes quotes)"
|
---|
| 269 | . SET $PIECE(Y,U)=""""_$$CONVQQ^DILIBF($PIECE(Y,U))_""""
|
---|
| 270 | . IF $PIECE(Y,U)?.E2A.E DO
|
---|
| 271 | . . SET DIS("XFORM",DC)="$$UP^DILIBF(;)"
|
---|
| 272 | . . SET O=O_" (case-insensitive)"
|
---|
| 273 | . . SET $PIECE(Y,U)=$$UP^DILIBF($PIECE(Y,U))
|
---|
| 274 | GOT ;"At this point, Y should be search value
|
---|
| 275 | SET X=DN_$E(" [?<=>",DQ)_$PIECE(Y,U)
|
---|
| 276 | IF E["D" DO
|
---|
| 277 | . SET Y=$PIECE(Y,U,3)_U_$PIECE(Y,U,2)
|
---|
| 278 | . IF $PIECE(Y,U)'["." DO
|
---|
| 279 | . . SET %=$PIECE("^^^^ any time during^ the entire day",U,DQ)
|
---|
| 280 | . . IF %]"" DO
|
---|
| 281 | . . . SET DIS("XFORM",DC)="$PIECE(;,""."")"
|
---|
| 282 | . . . SET O=O_%
|
---|
| 283 | SET O(DC)=O(DC)_" "_O_" "_Y
|
---|
| 284 | OK SET DC(DC)=DV_DU_U_X
|
---|
| 285 | SET %=DL-1_U_(N#100)
|
---|
| 286 | IF DL>1,O(DC)'[R SET O(DC)=R_" "_O(DC)
|
---|
| 287 | IF DU["W" SET %=DL-2_U_(N#100-1)
|
---|
| 288 | SET DX(DC)=%
|
---|
| 289 | SET DC=DC+1 ;"Inc logical part (i.e. 'A'->'B'->'C'->D)
|
---|
| 290 | IF DC=27 SET DC=33
|
---|
| 291 | B GOTO F:(DU'["W"&(DC<59))
|
---|
| 292 |
|
---|
| 293 | ;"==============
|
---|
| 294 | UP IF '(DC>1) GOTO Q
|
---|
| 295 | IF DL<$select('$DATA(DIARF0):2,1:2) GOTO ^TMGDIS0 ;"Done with entering conditions
|
---|
| 296 | SET DL=DL-1
|
---|
| 297 | SET DV=DV(DL)
|
---|
| 298 | SET DK=DL(DL)
|
---|
| 299 | SET N=N(DL)
|
---|
| 300 | SET R=$select($DATA(R(DL)):R(DL),1:R)
|
---|
| 301 | KILL R(DL)
|
---|
| 302 | SET %=N
|
---|
| 303 | FOR SET %=$O(I(%)) SET:%="" %=-1 GOTO F:%<0 KILL I(%),J(%)
|
---|
| 304 | FOR DO IF %<0 GOTO F
|
---|
| 305 | . SET %=$O(I(%))
|
---|
| 306 | . IF %="" SET %=-1
|
---|
| 307 | . IF %<0 QUIT
|
---|
| 308 | . KILL I(%),J(%)
|
---|
| 309 | ;"==========================================
|
---|
| 310 | ;"Q IF '$DATA(DIARU) GOTO Q^TMGDIS2
|
---|
| 311 | ;" GOTO ^TMGDIS2
|
---|
| 312 |
|
---|
| 313 | ;"==========================================
|
---|
| 314 | HARD IF X="" GOTO UP
|
---|
| 315 | ;"IF X?."?" GOTO F
|
---|
| 316 | ;"IF X=U!($DATA(DTOUT)) GOTO Q
|
---|
| 317 | GOTO COMP
|
---|
| 318 |
|
---|
| 319 | ;"==========================================
|
---|
| 320 | WP SET DIC("S")="IF Y<3"
|
---|
| 321 | SET DU=+Y_"W"
|
---|
| 322 | GOTO C
|
---|
| 323 |
|
---|
| 324 | ;"==========================================
|
---|
| 325 | X ;
|
---|
| 326 | WRITE $char(7),"??",!!
|
---|
| 327 | GOTO B
|
---|
| 328 |
|
---|
| 329 | ;"==========================================
|
---|
| 330 | W WRITE !?DL*2,"-"_$char(DC+64)_"- "
|
---|
| 331 | QUIT
|
---|
| 332 |
|
---|
| 333 | ;"==========================================
|
---|
| 334 | ENS ;" ENTRY POINT FOR RE-DOING THE SORT USING AN EXISTING SORT TEMPLATE
|
---|
| 335 | GOTO EN^DIS3
|
---|
| 336 |
|
---|
| 337 |
|
---|
| 338 |
|
---|
| 339 | ;" --- COPIED FROM DIQQQ.M to allow GOTO to return to this file, not ^DIS.
|
---|
| 340 | DISDIQQQ ;
|
---|
| 341 | WRITE !?8,"ENTER A VALUE WHICH '"_O(DC)_"'"
|
---|
| 342 | WRITE !?8,"MUST "_$P("NOT ",U,DN]"")
|
---|
| 343 | WRITE $PIECE("^CONTAIN^MATCH^BE LESS THAN^EQUAL^EXCEED^FOLLOW",U,+DQ)
|
---|
| 344 | WRITE ", IN ORDER FOR TRUTH CONDITION -"_$char(DC+64)_"- TO BE TRUE",!
|
---|
| 345 | write:+DQ=3 ?8,"(I.E., ENTER WHAT WOULD FOLLOW THE MUMPS '?' OPERATOR)",!
|
---|
| 346 | IF E["S" WRITE !,"Use EXTERNAL VALUE (from list on the right)" D EN^DIQQ1(DK,DU,"?")
|
---|
| 347 | WRITE !
|
---|
| 348 | GOTO F
|
---|
| 349 |
|
---|
| 350 | ;" --- COPIED FROM DIQQQ.M to allow GOTO to return to this file, not ^DIS
|
---|
| 351 | ;"DISCDIQQ ;
|
---|
| 352 | ;"WRITE !,"YOU CAN NEGATE ANY OF THESE CONDITIONS BY PRECEDING THEM WITH ""'"" OR ""-"""
|
---|
| 353 | ;"WRITE !,"SO THAT ""'NULL'"" MEANS ""NOT NULL""",!
|
---|
| 354 | ;"GOTO C
|
---|
| 355 | ;
|
---|
| 356 |
|
---|
| 357 | SRCHDN ;
|
---|
| 358 | ;"Purpose: New common exit point for function
|
---|
| 359 | QUIT TMGRESULT
|
---|
| 360 |
|
---|
| 361 |
|
---|
| 362 | ;===========================================================================
|
---|
| 363 | ;===========================================================================
|
---|
| 364 | ;" Below was code from DIS2
|
---|
| 365 | ;===========================================================================
|
---|
| 366 | ;===========================================================================
|
---|
| 367 |
|
---|
| 368 | DIS2 KILL DISV
|
---|
| 369 | GOTO G3:'DUZ
|
---|
| 370 | 0 DO
|
---|
| 371 | . NEW DIS,DIS0,DA,DC,DE,DJ,DL
|
---|
| 372 | . DO S3^DIBT1
|
---|
| 373 | . Q
|
---|
| 374 | KILL DIRUT,DIROUT
|
---|
| 375 | IF $D(DTOUT)!($D(DUOUT)) GOTO Q
|
---|
| 376 | IF X="" GOTO G3:'$D(DIAR)
|
---|
| 377 | IF Y<0 GOTO Q:X=U,0
|
---|
| 378 | IF $D(DIARU),DIARU-Y=0 DO GOTO 0
|
---|
| 379 | . write $C(7),!,"Archivers must not store results in the default template"
|
---|
| 380 | SET (DIARI,DISV)=+Y
|
---|
| 381 | SET A=$D(^DIBT(DISV,"DL"))
|
---|
| 382 | SET:$D(DIS0)#2 ^("DL")=DIS0
|
---|
| 383 | SET:$D(DA)#2 ^("DA")=DA
|
---|
| 384 | SET:$D(DJ)#2 ^("DJ")=DJ
|
---|
| 385 | IF $D(DIAR),'$D(DIARU) SET $P(^DIAR(1.11,DIARC,0),U,3)=DISV
|
---|
| 386 | SET Z=-1,DIS0="^DIBT(+Y,"
|
---|
| 387 | FOR P="DIS","DA","DC","DE","DJ","DL" DO
|
---|
| 388 | . SET %Y=DIS0_""""_P_""","
|
---|
| 389 | . SET %X=P_"("
|
---|
| 390 | . DO %XY^%RCR
|
---|
| 391 | SET %X="^UTILITY($J,"
|
---|
| 392 | SET %Y="^DIBT(DISV,""O"","
|
---|
| 393 | SET @(%X_"0)=U")
|
---|
| 394 | DO %XY^%RCR
|
---|
| 395 | G3 NEW DISTXT
|
---|
| 396 | SET %X="^UTILITY($J,"
|
---|
| 397 | SET %Y="DISTXT("
|
---|
| 398 | DO %XY^%RCR
|
---|
| 399 | write !
|
---|
| 400 | SET Y=DI
|
---|
| 401 | DO Q
|
---|
| 402 | SET DIC=Y
|
---|
| 403 | GOTO EN1^DIP:$D(SF)!$D(L)&'$D(DIAR),EN^DIP
|
---|
| 404 |
|
---|
| 405 | ;"==========================================
|
---|
| 406 | TEM ;
|
---|
| 407 | KILL DIC
|
---|
| 408 | SET X=$P($extract(X,2,99),"]",1)
|
---|
| 409 | SET DIC="^DIBT("
|
---|
| 410 | SET DIC(0)="EQ"
|
---|
| 411 | SET DIC("S")="IF "_$select($D(DIAR):"$P(^(0),U,8)",1:"'$P(^(0),U,8)")_",$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$D(^(""DIS""))"
|
---|
| 412 | SET DIC("W")="X ""FOR %=1:1 Q:'$D(^DIBT(Y,""""O"""",%,0)) write !?9 SET I=^(0) W:$L(I)+$X>79 !?9 write I"""
|
---|
| 413 | DO ^DIC
|
---|
| 414 | KILL DIC
|
---|
| 415 | GOTO F:Y<0
|
---|
| 416 | SET P="DIS"
|
---|
| 417 | SET Z=-1
|
---|
| 418 | SET %X="^DIBT(+Y,P,"
|
---|
| 419 | SET %Y="DIS("
|
---|
| 420 | DO %XY^%RCR
|
---|
| 421 | SET %Y="^UTILITY($J,"
|
---|
| 422 | SET P="O"
|
---|
| 423 | DO %XY^%RCR
|
---|
| 424 | GOTO DIS2
|
---|
| 425 |
|
---|
| 426 | ;"==========================================
|
---|
| 427 | COMP ;
|
---|
| 428 | SET E=X ;"e.g. X="(#.02)"
|
---|
| 429 | SET DICMX="X DIS(DIXX)"
|
---|
| 430 | SET DICOMP=N_"?"
|
---|
| 431 | SET DQI="Y("
|
---|
| 432 | SET DA="DIS("""_$C(DC+64)_DL_""","
|
---|
| 433 | IF '$D(O(DC))#2 SET O(DC)=X
|
---|
| 434 | GOTO COLON:X?.E1":"
|
---|
| 435 | IF X?.E1":.01",'$D(O(DC))#2 SET O(DC)=$extract(X,1,$L(X)-4)
|
---|
| 436 | DO EN^DICOMP ;"Eval computed expression
|
---|
| 437 | DO XA
|
---|
| 438 | GOTO X:'$D(X)
|
---|
| 439 | GOTO X:Y["m" ;"IF Y["m" SET X=E_":" GOTO COMP
|
---|
| 440 | SET DA(DC)=X
|
---|
| 441 | SET DU=-DC
|
---|
| 442 | SET E=$extract("B",Y["B")_$extract("D",Y["D")
|
---|
| 443 | GOTO G3
|
---|
| 444 |
|
---|
| 445 | ;"==========================================
|
---|
| 446 | XA SET %=0
|
---|
| 447 | FOR DO Q:%=""
|
---|
| 448 | . SET %=$O(X(%))
|
---|
| 449 | . Q:%=""
|
---|
| 450 | . SET @(DA_%_")")=X(%)
|
---|
| 451 | SET %=-1
|
---|
| 452 | QUIT
|
---|
| 453 |
|
---|
| 454 | ;"==========================================
|
---|
| 455 | COLON DO ^DICOMPW
|
---|
| 456 | GOTO X:'$D(X)
|
---|
| 457 | DO XA
|
---|
| 458 | SET R(DL)=R
|
---|
| 459 | SET N(DL)=N
|
---|
| 460 | SET N=+Y
|
---|
| 461 | SET DY=DY+1
|
---|
| 462 | SET DV(DL)=DV
|
---|
| 463 | SET DL(DL)=DK
|
---|
| 464 | SET DL=DL+1
|
---|
| 465 | SET DV=DV_-DY_C
|
---|
| 466 | SET DY(DY)=DP_U_$select(Y["m":DC_"."_DL,1:"")_U_X
|
---|
| 467 | SET R=U_$P(DP,U,2)
|
---|
| 468 | KILL X
|
---|
| 469 | GOTO R
|
---|
| 470 |
|
---|
| 471 | ;"==========================================
|
---|
| 472 | Q ;
|
---|
| 473 | KILL DIC,DA,DX,O,D,DC,DI,DK,DL,DQ,DU,DV,E,DE
|
---|
| 474 | KILL DJ,N,P,Z,R,DY,DTOUT,DIRUT,DUOUT,DIROUT
|
---|
| 475 | KILL ^UTILITY($J)
|
---|
| 476 | QUIT
|
---|
| 477 |
|
---|
| 478 | ;"==========================================
|
---|
| 479 | DIS ;"PUT SET LOGIC INTO DIS FOR SUBFILE
|
---|
| 480 | SET %X=""
|
---|
| 481 | FOR %Y=1:1 DO QUIT:'%X
|
---|
| 482 | . SET %X=$O(DIS(%X))
|
---|
| 483 | . QUIT:'%X
|
---|
| 484 | . SET %=$select($D(DIAR(DIARF,%X)):DIAR(DIARF,%X),1:DIS(%X))
|
---|
| 485 | . SET:%["X DIS(" %=$P(%,"X DIS(")_"X DIFG("_DIARF_","_$P(%,"X DIS(",2)
|
---|
| 486 | . SET ^DIAR(1.11,DIARC,"S",%Y,0)=%X
|
---|
| 487 | . SET ^(1)=%
|
---|
| 488 | IF %Y>1 DO
|
---|
| 489 | . SET %Y=%Y-1
|
---|
| 490 | . SET ^DIAR(1.11,DIARC,"S",0)="^1.1132^"_%Y_U_%Y
|
---|
| 491 | GOTO DIS2
|
---|