TMGDIS ;TMG/kst/Custom version of DIS ;03/25/06 ; 5/12/10 3:06pm ;;1.0;TMG-LIB;**1**;01/01/06 ;"-------Prior header below --------------- ;"SFISC/GFT-GATHER SEARCH CRITERIA ;05:52 PM 27 Mar 2002 ;";22.0;VA FileMan;**6,97**;Mar 30, 1999 ;" ;"Purpose: to GATHER SEARCH CRITERIA ;"------Also includes code from DIS2, with header as below. ;SFISC/GFT-SEARCH, TEMPLATES & COMPUTED FIELDS ;5:49 AM 2 Jun 1999 ;;22.0;VA FileMan;**6**;Mar 30, 1999 ; ;"Purpose: SEARCH, TEMPLATES & COMPUTED FIELDS ;"Note: Program execution can loop all the way back to ^DIS ;" SRCH(TMGINFO,TMGOUT,TMGBYROOT) ; ;"Purpose: Provide an API interface for the classic Fileman console search ;"Input: TMGINFO -- PASS BY REFERENCE. This is pre-defined search terms. Format: ;" TMGINFO("FILE") -- File name or number to be used for search ;" TMGINFO(1,...) -- Search condition 1 (corresponds to 'A' in console) ;" TMGINFO(2,...) -- Search condition 2 (corresponds to 'B' in console) ;" ... ;" --DETAILS ON SEARCH CONDITION---- ;" TMGINFO(n,"FLD") -- The Fileman field name or number to seach in ;" TMGINFO(n,"COND") -- The condition: "=,>,<,[,?,NULL" Prefix ' or - to negate ;" TMGINFO(n,"VALUE") -- the value to search for ;" TMGOUT --An OUT PARAMETER. Prior values killed. Format: ;" TMGOUT(FILENUM,IEN)="" ;" TMGOUT(FILENUM,IEN)="" ;" TMGOUT(FILENUM,IEN)="" ;" TMGBYROOT -- (Optional) If 1, then TMGOUT is treated as a variable NAME (root) ;" i.e. @TMGOUT@(FILENUM,IEN)="" ;"Results: 1 if OK, or -1^Error Message ; NEW DC ;"Variable DC stores coded search values ;"Example: ;"DC(1)="14,.01^=105" <-- field 14, sub field .01 '=' IEN 105 (in pointed to file) ;"DC(2)="14,2^=44" <-- field 14, sub field 2 '=' IEN 44 (in pointed to file) ;" ;"Example ;"DC(1)="14,-1^[""ACETA""" <-- field 14 is a multiple, '-' --> ? 1 is field '[' ACETA ;"DC(2)="14,-2^[""%""" <-- field 14 is a multiple, '-' --> ? 2 is field '[' % ;" ;"Example ;"DC=6 ;"DC(1) = 14,.01^=105 <-- field 14, sub field .01 '=' IEN 105 (in pointed to file) ;"DC(2) = 14,-2^["%" <-- field 14 is a multiple, '-' --> ? 2 is field '[' % ;" note field 2 is a pointer, so perhaps '-' means non-exact match ;"DC(3) = 14,1^["1" <-- field 14 is a multiple, 1 is field '[' ACETA ;" note field 1 is free text, so perhaps '-' not needed ;"DC(4) = 1^=211 <-- field 1 '=' IEN 211 ;"DC(5) = .01^["A" <-- field .01 '[' A ;"Values of O with above example ;"O=0 ;"O(1) = VA PRODUCT ACTIVE INGREDIENTS EQUALS 105^ACETAMINOPHEN ;"O(2) = VA PRODUCT UNITS CONTAINS "%" ;"O(3) = VA PRODUCT STRENGTH CONTAINS "1" ;"O(4) = DOSAGE FORM EQUALS 211^BAG ;"O(5) = NAME CONTAINS "A" NEW DIS,%ZIS NEW O ;"('Oh', not 'zero') Stores file & field names and values to search FOR ;"Example: ;"O=0 ;"O(1) = VA PRODUCT ACTIVE INGREDIENTS CONTAINS (case-insensitive) "ACETAMINOPHEN" ;"O(2) = VA PRODUCT ACTIVE INGREDIENTS CONTAINS (case-insensitive) "CAFF" ;"O(3) = VA GENERIC NAME CONTAINS "A" ;"Note: ;" Each node (i.e. (1),(2) etc) contains a separate search item. ;" ;"Another example ;"O="EQUALS" ;"O(1)="VA PRODUCT ACTIVE INGREDIENTS EQUALS 105^ACETAMINOPHEN" ;"O(2)="VA PRODUCT UNITS EQUALS 44^%" ;" ;"Note: ;" In above examples, ;" O(1) --> VA PRODUCT is file name, ACTIVE INGREDIENTS is .01 field ;" of ACTIVE INGREDIENTS multiple ;" 105 is IEN of ACETAMINOPHEN ;" EQUALS is chosen comparator ;" O(2)--> VA PRODUCT is file name, UNITS is field 2 of ACTIVE INGREDIENTS multiple ;" 44 is IEN of unit '%' ;" EQUALS is chosen comparator ;" The value in O (e.g. 'EQUALS') is later killed, so not used in actual search. NEW N,P,C,Z,I,J,Q NEW R ;"stores root of file being searched NEW E ;"stores field type codes (piece 2 of 0 node) NEW DIC,X,Y NEW DL ;"DL=indent amount from left margin. NEW DC ;"DC=search element i.e. 1=A,2=B,3=C etc. NEW DU ;"DU = field number NEW DA,DI,DV,DX,DY,DTOUT,DK NEW DICMX,DICOMP NEW TMGRESULT SET TMGRESULT=1 ;"Default to success SET DIC=1 SET X=$GET(TMGINFO("FILE")) DO ^DIC IF Y=-1 DO GOTO SRCHDN . SET TMGRESULT="-1^File '"_X_"' is not valid." SET DIC=+Y NEW TMGFILE SET TMGFILE=$P(Y,U,2) EN ; IF DIC SET DIC=$G(^DIC(DIC,0,"GL")) IF DIC="" DO GOTO SRCHDN . SET TMGRESULT="-1^File '"_TMGFILE_"' is not valid." KILL DI,DX,DY,I,J,DL,DC,DA,DTOUT,^UTILITY($J) IF '$DATA(@(DIC_"0)")) DO GOTO SRCHDN . SET TMGRESULT="-1^File '"_TMGFILE_"' is missing its global." SET (R,DI,I(0))=DIC SET DL=1 ;"DL=indent amount from left margin. SET DC=1 ;"DC=search element i.e. 1=A,2=B,3=C etc. SET DY=999 SET N=0 SET Q="""" SET DV="" R ; ;"SET J(N) and DK<--file NUMBER, R<--file NAME IF +R=R DO . SET (J(N),DK)=R . SET R="" ELSE DO . SET @("(J(N),DK)=+$PIECE("_R_"0),U,2)") . SET R=$PIECE(^(0),U) ; F ;=== Get next field=== IF DC>58 GOTO UP ;"WRITE ! KILL X,DIC,P ;"DO W ;"Write label to screen line -A-, or -B- etc. SET DIC(0)="Z" ;"WAS EZ SET C="," SET DIC="^DD("_DK_C ;"SET DIC("W")="SET %=$PIECE(^(0),U,2) WRITE:% $SELECT($PIECE(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")" SET DIC("S")="IF $PIECE(^(0),U,2)'[""m"""_$select($DATA(DICS):" "_DICS,1:""),DU="" ;"WRITE "SEARCH FOR "_R_" "_$PIECE(^DD(DK,0),U)_": " ;"READ X:DTIME ;"ask user FOR filed to search in, from specified file ;"SET:'$T DTOUT=1 ;"IF X=U!'$T GOTO Q SET X=$GET(TMGINFO(DC,"FLD")) ;"IF X?1"[".E GOTO TEM ;"I think this is for putting all on one line. REMOVED. DO . NEW DISVX SET DISVX=X . DO ^DIC ;"search FOR field, based on user input. . IF Y=-1 SET X=DISVX IF '(Y>0) GOTO HARD ;"Time to do the hard part... KILL P SET DE=Y(0) SET O(DC)=$PIECE(DE,U) ;"Store first part of search term SET DU=+Y ;"DU = field number SET Z=$PIECE(DE,U,3) ;"pointers or SET data SET E=$PIECE(DE,U,2) ;"field info codes, poss with subfile # G ;==== Get Condition ========= KILL X,DIC SET DIC="^DOPT(""DIS""," ;"file containing "equals","contains","greater than" etc. SET DIC(0)="Z" ;"Was QEZ IF E["B" SET X="" GOTO OK ;"'B'->field is a BOOLEAN COMPUTED field, so skip IF +E=0 GOTO G2KT ;"E=file info code starts with # IF subfile. So skip IF not subfile 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),";") ;"4th piece of 0 node holds storage location SET I(N)=$select(+X=X:X,1:""""_X_"""") SET Y(0)=^DD(DK,.01,0) SET DL=DL+1 ;"indent further IF $PIECE(Y(0),U,2)["W" GOTO WP ;"Process WP fields SET DV=DV_+Y_"," GOTO F ;"loop back to get more field info for subfile FIX!!! How is this pre-determined?? G2KT IF E["P" DO GOTO HARD ;"IF field points to another file, setup and GOTO HARD . SET P=+Y_U_Y(0) ;"e.g. P=.02^PATIENT^P9000001' . SET X="(#"_+Y_")" C ;"DO W ;"Write label to screen line -A-, or -B- etc. ;"READ "CONDITION: ",X:DTIME ;"SET:'$T DTOUT=1 ;"IF X[U!'$T GOTO Q SET X=$GET(TMGINFO(DC,"COND")) ;"Get pre-defined user search condition IF X="" DO GOTO SRCHDN . SET TMGRESULT="-1^Search condition not specified for term #"_DC SET DN=$select("'-"[$E(X):"'",1:"") ;"IF NOT is specified then DN="'" SET X=$E(X,DN]""+1,99) ;"remove 'NOT' symbol, IF present DO ^DIC ;"IF Y>0 GOTO C2 ;"IF X[U GOTO Q ;"IF X="" GOTO B ;"IF X["?" GOTO DISCDIQQQ ;"GOTO C IF Y=-1 DO GOTO SRCHDN . SET TMGRESULT="-1^Search condition '"_X_"' is not valid." C2 SET O=$PIECE("NOT ",U,DN]"")_$PIECE(Y,U,2) ;"Store search condition in O IF +Y=1 DO GOTO OK ;"Handle NULL selected . SET X=DN_"?."" """ . SET O(DC)=O(DC)_" "_O SET DQ=Y ;"At this point DQ (and Y) should be one of following values: ;"1 for NULL, 2 for CONTAINS 3 for matches ;"4 for LESS THAN 5 for EQUALS 6 for GREATER THAN ; ;"====Get Search Term================= ;"DO W ;"Write label to screen line -A-, or -B- etc. ;"WRITE O IF (E'["D")!(Y<4) GOTO PT ;"Handle searches for DATES ;"READ " DATE: ",X:DTIME SET X=$GET(INFO(DC,"VALUE")) ;"SET:'$T DTOUT=1 ;"IF X=U!'$T GOTO Q IF X="" DO GOTO SRCHDN . SET TMGRESULT="-1^No search value specified for term #"_DC SET %DT="T" ;"was TE DO ^%DT IF Y<0 DO GOTO SRCHDN . SET TMGRESULT="-1^Invalid date value '"_X SET X=Y_U_X XECUTE ^DD("DD") SET Y=X_U_Y GOTO GOT PT ;"POINTERS IF $DATA(P),+DQ=5 DO GOTO Q:U[X!'$T DO ^DIC GOTO GOT:Y>0,PT . KILL DIC,DIS($char(DC+64)_DL) . SET DIC=U_$PIECE(P,U,4) . SET DIC(0)="EMQ" . SET DU=+P . WRITE " "_$PIECE(@(DIC_"0)"),U)_": " . READ X:DTIME . SET:'$T DTOUT=1 READ ": ",Y:DTIME IF '$T SET DTOUT=1 GOTO Q GOTO X:Y="" IF Y[U,$PIECE(DE,U,4)'[";E" GOTO Q IF +DQ=3 SET X="I X?"_Y DO ^DIM GOTO GOT:$DATA(X) SET Y="?" GOTO DISDIQQQ:Y?."?" SET IF E["S" DO IF '$DATA(X) KILL DIS(U,DC) GOTO DISDIQQQ . IF +DQ=5!(Y["""") DO kill:D="" X QUIT . . SET Y=":"_Y . . NEW TMGQUIT SET TMGQUIT=0 . . ;"FOR X=1:1 DO IF D[Y WRITE $PIECE(D,Y,2,9) SET Y=$PIECE(D,":")_U_$PIECE(D,":",2) Q . . FOR X=1:1 DO QUIT:TMGQUIT=1 . . . SET D=$PIECE(Z,";",X) . . . IF D="" SET TMGQUIT=1 QUIT . . . IF D[Y DO . . . . WRITE $PIECE(D,Y,2,9) . . . . SET Y=$PIECE(D,":")_U_$PIECE(D,":",2) . . . . SET TMGQUIT=1 N . NEW N,%,C . WRITE !?7 . SET N="DE"_DN_$E(" [?<=>",DQ)_""""_Y_"""" . NEW TMGQUIT SET TMGQUIT=0 . FOR X=1:1 DO QUIT:TMGQUIT=1 . . SET D=$PIECE(Z,";",X) . . SET DE=$PIECE(D,":",2) . . IF D="" SET TMGQUIT=1 . . SET DIS(U,DC,$PIECE(D,":"))=DE . . IF @N DO . . . SET:'$DATA(%) %="[ Will match" . . . WRITE % . . . SET C=$G(C)+1 . . . SET %="'"_DE_"'" . . . write:C>1 "," . . . WRITE " " . . . write:$X+$L(%)>73 !?7 . IF '$DATA(%) KILL X Q . write:C>1 "and " . WRITE %_" ]" T IF DQ["THAN",+$PIECE(Y,U)'=$PIECE(Y,U) GOTO X QUOTE IF DQ#3=2 DO ;"Equals or Contains . write:$PIECE(Y,U)[""""&($L($PIECE(Y,U))>1) " (Your answer includes quotes)" . SET $PIECE(Y,U)=""""_$$CONVQQ^DILIBF($PIECE(Y,U))_"""" . IF $PIECE(Y,U)?.E2A.E DO . . SET DIS("XFORM",DC)="$$UP^DILIBF(;)" . . SET O=O_" (case-insensitive)" . . SET $PIECE(Y,U)=$$UP^DILIBF($PIECE(Y,U)) GOT ;"At this point, Y should be search value SET X=DN_$E(" [?<=>",DQ)_$PIECE(Y,U) IF E["D" DO . SET Y=$PIECE(Y,U,3)_U_$PIECE(Y,U,2) . IF $PIECE(Y,U)'["." DO . . SET %=$PIECE("^^^^ any time during^ the entire day",U,DQ) . . IF %]"" DO . . . SET DIS("XFORM",DC)="$PIECE(;,""."")" . . . SET O=O_% SET O(DC)=O(DC)_" "_O_" "_Y OK SET DC(DC)=DV_DU_U_X SET %=DL-1_U_(N#100) IF DL>1,O(DC)'[R SET O(DC)=R_" "_O(DC) IF DU["W" SET %=DL-2_U_(N#100-1) SET DX(DC)=% SET DC=DC+1 ;"Inc logical part (i.e. 'A'->'B'->'C'->D) IF DC=27 SET DC=33 B GOTO F:(DU'["W"&(DC<59)) ;"============== UP IF '(DC>1) GOTO Q IF DL<$select('$DATA(DIARF0):2,1:2) GOTO ^TMGDIS0 ;"Done with entering conditions 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 %=$O(I(%)) SET:%="" %=-1 GOTO F:%<0 KILL I(%),J(%) FOR DO IF %<0 GOTO F . SET %=$O(I(%)) . IF %="" SET %=-1 . IF %<0 QUIT . KILL I(%),J(%) ;"========================================== ;"Q IF '$DATA(DIARU) GOTO Q^TMGDIS2 ;" GOTO ^TMGDIS2 ;"========================================== HARD IF X="" GOTO UP ;"IF X?."?" GOTO F ;"IF X=U!($DATA(DTOUT)) GOTO Q GOTO COMP ;"========================================== WP SET DIC("S")="IF Y<3" SET DU=+Y_"W" GOTO C ;"========================================== X ; WRITE $char(7),"??",!! GOTO B ;"========================================== W WRITE !?DL*2,"-"_$char(DC+64)_"- " QUIT ;"========================================== ENS ;" ENTRY POINT FOR RE-DOING THE SORT USING AN EXISTING SORT TEMPLATE GOTO EN^DIS3 ;" --- COPIED FROM DIQQQ.M to allow GOTO to return to this file, not ^DIS. DISDIQQQ ; WRITE !?8,"ENTER A VALUE WHICH '"_O(DC)_"'" WRITE !?8,"MUST "_$P("NOT ",U,DN]"") WRITE $PIECE("^CONTAIN^MATCH^BE LESS THAN^EQUAL^EXCEED^FOLLOW",U,+DQ) WRITE ", IN ORDER FOR TRUTH CONDITION -"_$char(DC+64)_"- TO BE TRUE",! write:+DQ=3 ?8,"(I.E., ENTER WHAT WOULD FOLLOW THE MUMPS '?' OPERATOR)",! IF E["S" WRITE !,"Use EXTERNAL VALUE (from list on the right)" D EN^DIQQ1(DK,DU,"?") WRITE ! GOTO F ;" --- COPIED FROM DIQQQ.M to allow GOTO to return to this file, not ^DIS ;"DISCDIQQ ; ;"WRITE !,"YOU CAN NEGATE ANY OF THESE CONDITIONS BY PRECEDING THEM WITH ""'"" OR ""-""" ;"WRITE !,"SO THAT ""'NULL'"" MEANS ""NOT NULL""",! ;"GOTO C ; SRCHDN ; ;"Purpose: New common exit point for function QUIT TMGRESULT ;=========================================================================== ;=========================================================================== ;" Below was code from DIS2 ;=========================================================================== ;=========================================================================== DIS2 KILL DISV GOTO G3:'DUZ 0 DO . NEW DIS,DIS0,DA,DC,DE,DJ,DL . DO S3^DIBT1 . Q KILL DIRUT,DIROUT IF $D(DTOUT)!($D(DUOUT)) GOTO Q IF X="" GOTO G3:'$D(DIAR) IF Y<0 GOTO Q:X=U,0 IF $D(DIARU),DIARU-Y=0 DO GOTO 0 . write $C(7),!,"Archivers must not store results in the default template" SET (DIARI,DISV)=+Y SET A=$D(^DIBT(DISV,"DL")) SET:$D(DIS0)#2 ^("DL")=DIS0 SET:$D(DA)#2 ^("DA")=DA SET:$D(DJ)#2 ^("DJ")=DJ IF $D(DIAR),'$D(DIARU) SET $P(^DIAR(1.11,DIARC,0),U,3)=DISV SET Z=-1,DIS0="^DIBT(+Y," FOR P="DIS","DA","DC","DE","DJ","DL" DO . SET %Y=DIS0_""""_P_"""," . SET %X=P_"(" . DO %XY^%RCR SET %X="^UTILITY($J," SET %Y="^DIBT(DISV,""O""," SET @(%X_"0)=U") DO %XY^%RCR G3 NEW DISTXT SET %X="^UTILITY($J," SET %Y="DISTXT(" DO %XY^%RCR write ! SET Y=DI DO Q SET DIC=Y GOTO EN1^DIP:$D(SF)!$D(L)&'$D(DIAR),EN^DIP ;"========================================== TEM ; KILL DIC SET X=$P($extract(X,2,99),"]",1) SET DIC="^DIBT(" SET DIC(0)="EQ" 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""))" 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""" DO ^DIC KILL DIC GOTO F:Y<0 SET P="DIS" SET Z=-1 SET %X="^DIBT(+Y,P," SET %Y="DIS(" DO %XY^%RCR SET %Y="^UTILITY($J," SET P="O" DO %XY^%RCR GOTO DIS2 ;"========================================== COMP ; SET E=X ;"e.g. X="(#.02)" SET DICMX="X DIS(DIXX)" SET DICOMP=N_"?" SET DQI="Y(" SET DA="DIS("""_$C(DC+64)_DL_"""," IF '$D(O(DC))#2 SET O(DC)=X GOTO COLON:X?.E1":" IF X?.E1":.01",'$D(O(DC))#2 SET O(DC)=$extract(X,1,$L(X)-4) DO EN^DICOMP ;"Eval computed expression DO XA GOTO X:'$D(X) GOTO X:Y["m" ;"IF Y["m" SET X=E_":" GOTO COMP SET DA(DC)=X SET DU=-DC SET E=$extract("B",Y["B")_$extract("D",Y["D") GOTO G3 ;"========================================== XA SET %=0 FOR DO Q:%="" . SET %=$O(X(%)) . Q:%="" . SET @(DA_%_")")=X(%) SET %=-1 QUIT ;"========================================== COLON DO ^DICOMPW GOTO X:'$D(X) DO XA SET R(DL)=R SET N(DL)=N SET N=+Y SET DY=DY+1 SET DV(DL)=DV SET DL(DL)=DK SET DL=DL+1 SET DV=DV_-DY_C SET DY(DY)=DP_U_$select(Y["m":DC_"."_DL,1:"")_U_X SET R=U_$P(DP,U,2) KILL X GOTO R ;"========================================== Q ; KILL DIC,DA,DX,O,D,DC,DI,DK,DL,DQ,DU,DV,E,DE KILL DJ,N,P,Z,R,DY,DTOUT,DIRUT,DUOUT,DIROUT KILL ^UTILITY($J) QUIT ;"========================================== DIS ;"PUT SET LOGIC INTO DIS FOR SUBFILE SET %X="" FOR %Y=1:1 DO QUIT:'%X . SET %X=$O(DIS(%X)) . QUIT:'%X . SET %=$select($D(DIAR(DIARF,%X)):DIAR(DIARF,%X),1:DIS(%X)) . SET:%["X DIS(" %=$P(%,"X DIS(")_"X DIFG("_DIARF_","_$P(%,"X DIS(",2) . SET ^DIAR(1.11,DIARC,"S",%Y,0)=%X . SET ^(1)=% IF %Y>1 DO . SET %Y=%Y-1 . SET ^DIAR(1.11,DIARC,"S",0)="^1.1132^"_%Y_U_%Y GOTO DIS2