source: cprs/branches/tmg-cprs/m_files/TMGDIS0.m

TMGDIS0 ;TMG/kst/Custom DIS0, non-interactive SEARCH, IF STATEMENT AND MULTIPLE COMBO'S ;5/13/10 ; 5/16/10 10:01pm
     ;;1.0;TMG-LIB;**1**;01/01/06
     ;-----Prior header below -------------
     ;SFISC/GFT-SEARCH, IF STATEMENT AND MULTIPLE COMBO'S ;30JAN2005     
     ;;22.0;VA FileMan;**144**;Mar 30, 1999;Build 5
     ;
DIS0(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) 
        ;"           TMGINFO("LOGIC-IF")=(OPTIONAL) Logic string that would be normally
        ;"                                 entered at 'IF: ' prompt
        ;"                                 e.g. "1&2", or "A&B", or "AB" <--- all the same
        ;"                                 Default is logic string ANDing all search terms.
        ;"           TMGINFO("LOGIC-OR",1)=(OPTIONAL) Logic string that would be normally 
        ;"                                 entered at 'OR: ' prompt
        ;"           TMGINFO("LOGIC-OR",#)=(OPTIONAL) Logic string that would be normally 
        ;"                                 entered at 'OR: ' prompt.  #=2,3,4... For multiple
        ;"                                 lines of OR logic
        ;"                 NOTE: Fileman console labels search terms as "A","B","C",...
        ;"                       But the above numbering system uses "1","2","3",...
        ;"                       When entering in logic strings, one may use either letters
        ;"                       or numbers. A=1, B=2 etc.  Note that Fileman allows AB to
        ;"                       mean the same as A&B.  This is not possible with numbers.
        ;"           ...
        ;"           --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)=""
        ;"Globally-Scoped variables uses: O,DC,DA  (and probably others)
        ;"Results: 1 if OK, or -1^Error Message
        ;
     ;"WRITE !
     NEW TMGRESULT SET TMGRESULT=1 ;"Default to success
     NEW R,N,DL,DE,DJ  ;"WAS KILL initially
     NEW P,LOGIC,NLOG
     NEW DU 
     SET O=0
     SET E=$DATA(DC(2))  ;"E>0 IF MORE THAN ONE SRCH TERM
     SET N="IF: A// "
     SET DE=$SELECT(E:"IF: ",1:N)
     NEW TMGLMODE SET TMGLMODE=1  ;"1="LOGIC-IF" 2=LOGIC-OR
     NEW TMGLORN SET TMGLORN=0  ;"Logic OR line number
     SET DL=0
     SET C=","
R    ;"WRITE !,DE 
     KILL DV
     IF TMGLMODE=1 DO
     . SET X=$GET(INFO("LOGIC-IF"))
     . IF X'="" QUIT
     . NEW I SET I=0
     . FOR  SET I=$ORDER(INFO(I)) QUIT:+I'>0  SET X=X_$CHAR(I+64)
     . SET INFO("LOGIC-IF")=X
     ELSE  DO
     . SET TMGLORN=TMGLORN+1
     . SET X=$GET(INFO("LOGIC-OR",TMGLORN))
     IF X'="" GOTO R2
     ;"READ X:DTIME SET:'$T DTOUT=1 GOTO Q:X[U!'$T
     SET DV=1,DU=X 
     GOTO 1:DL 
     SET DQ="TYPE '^' TO EXIT"
     SET Y="^1^"
     SET DL=1 
     ;"GOTO BAD:E 
     IF E="" DO  GOTO TMGDONE
     . SET TMGRESULT="-1^Bad/absent logic string."     
     DO ASKQ(.DC,.DV,.DU) 
     GOTO L
     ;
R2   SET Y=U,P=0,DU="",D=""
     SET DL=DL+1
P    ;"PARSE LOGIC STRING
     SET LOGIC=X,LOGN=0
     FOR  QUIT:(LOGIC="")!(+TMGRESULT=-1)  DO
     . SET DV=0
     . IF +LOGIC>0 DO
     . . SET (DV,DQ)=+LOGIC
     . . SET LOGIC=$EXTRACT($LENGTH(DQ)+1,9999)
     . ELSE  DO
     . . SET DQ=$EXTRACT(LOGIC,1) 
     . . SET LOGIC=$EXTRACT(LOGIC,2,9999)
     . . IF DQ?.A SET DV=$ASCII(DQ)-64 
     . IF (DV>0)&($DATA(DC(DV))>0) DO  QUIT
     . . SET LOGN=LOGN+1
     . . DO ASKQ(.DC,.DV,.DU) 
     . . SET TMGRESULT=$$CHK(DV)
     . IF "&+ "[DQ QUIT
     . IF ((DU="")&("'-"[DQ)) SET DU="'" QUIT
     . SET TMGRESULT="-1^Bad entry '"_DQ_"' found in logic phrase '"_X_"'"
     IF LOGN'>0 SET TMGRESULT="-1^No valid logic terms found in '"_X_"'" 
     IF +TMGRESULT=-1 GOTO TMGDONE
     GOTO L
     ;
 ;"BAD  DO  
 ;"     . IF DQ?."?" DO  QUIT
 ;"     . . DO BLD^DIALOG($SELECT($DATA(DC(2)):8004.2,1:8004.1))
 ;"     . . DO MSG^DIALOG("WH")   ;HELP depending on whether there is a CONDITION B
 ;"     . WRITE "   <",DQ,">??"
 ;"     WRITE !! 
 ;"     KILL DJ(DL),DE(DL) 
 ;"     SET DL=DL-1 
 ;"     GOTO R
     ;
ASKQ(DC,DV,DU) ;"-------------
     NEW J,%,I
     SET J=DC(DV)
     SET %=J["?."" """
     SET I=J["^'"+(DU["'")#2 
     IF J["W^" DO  QUIT
     . SET DV(DV)=$SELECT(I:2-%,1:%+%+1) 
     . IF % SET DC(DV)=$EXTRACT(J,1,$LENGTH(J)-5)_"=""""" 
     IF $PIECE(J,U)[C SET DV(DV)=J?.E1",.01^".E&%+(I+%#2) 
     QUIT
     ;
CHK(DV) ;Check search term
     ;"Result: 1 if OK, -1^ErrorMessage
     NEW %
     NEW RSLT SET RSLT=1 ;"Default to success
     SET %=$F(Y,U_DV) 
     IF % DO  GOTO CKDN ;"Was BAD
     . SET %=$PIECE($EXTRACT(Y,%),U,1)'=DU
     . SET DQ=""""_DQ_""" AND """_$EXTRACT("'",%)_DQ_""" IS "_$PIECE("REDUNDANT^CONTRADICTORY",U,%+1)
     . SET RSLT="-1^"_DQ
     SET %=1
     SET Y=Y_DV_DU_U
     SET DU=""
     SET J=$PIECE(DC(DV),U,1) 
     IF J'[C GOTO CKDN ;"WAS P 
     FOR Z=2:1 IF $PIECE(J,C,Z,99)'[C SET J=$PIECE(J,C,1,Z-1)_C QUIT
     IF J=D DO
     . DO SAMEQ  ;"result in %
     . IF %=1 SET DJ(DL,DV)=DX(DV)
     SET D=J,DJ=DV 
     ;"IF %>0 GOTO P
     IF %'>0 DO  GOTO CKDN
     . SET RSLT="-1^Error checking search term #"_DV
CKDN QUIT RSLT     
 ;"Q    GOTO Q^DIS2
     ;
SAMEQ ;----
     IF (J<0),$PIECE(DY(-J),U,3)="" QUIT
     ;"NOTE!!!: Answer to question below FORCED TO BE 'YES' FOR NOW.  Later figure how to specify in INFO array
     ;"WRITE !?8,"CONDITION -"_$C(DV+64)_"- WILL APPLY TO THE SAME MULTIPLE AS CONDITION -"_$C(DJ+64)_"-",!?8,"...OK" 
     ;"DO YN^DICN
     SET %=1 ;"FORCE 'YES' answer
     QUIT
     ;
     ;-----------------
L    SET P=O
     SET DL(DL)=Y
     SET DE="OR: "
     SET TMGLMODE=2 ;"OR mode
     FOR %=2:1 SET X=$PIECE(Y,U,%) QUIT:X=""  DO
     . SET O=O+1
     . NEW S SET S=$SELECT($DATA(DJ(DL,+X)):"  together with ",1:"   and ")
     . SET ^UTILITY($J,O,0)=$SELECT(%>2:S,O=1:"",1:" Or ")_$PIECE("not ",U,X["'")_O(+X)
     ;"WRITE:$X>18 ! 
     ;"WRITE "   " 
     ;"FOR %=P+1:1 Q:'$DATA(^UTILITY($J,%,0))  DO
     ;". SET X=^(0) 
     ;". IF $LENGTH(X)+$X>77 WRITE !?13 
     ;". WRITE " "_$PIECE(X,U) 
     ;". IF $PIECE(X,U,2)'="" WRITE " ("_$PIECE(X,U,2)_")"
     SET DV=0
DV   SET DV=$ORDER(DV(DV)) 
     IF DV="" SET DV=-1 
     ;"GOTO:DV'>0 R:E,1 
     IF (DV'>0)&E GOTO R  ;"Go back and ask for OR" logic phrase
     IF (DV'>0) GOTO 1
     IF $DATA(DJ(DL,DV)) GOTO DV 
     SET I=$PIECE(DC(DV),U,1),D=DK,DN=0
     SET Y="DO YOU WANT THIS SEARCH SPECIFICATION TO BE CONSIDERED TRUE FOR CONDITION -"_$C(DV+64)_"-"
G    SET DN=DN+1
     SET P=$PIECE(I,C,1)
     SET I=$PIECE(I,C,2,99) 
     IF P["W" GOTO W
     IF I="" GOTO DV 
     IF P<0 DO  GOTO G:'$PIECE(J,U,3)
     . SET J=DY(-P)
     . SET D=+J
     . SET R=" '"_$PIECE(^DIC(D,0),U,1)_"' ENTRIES " 
     ELSE  DO
     . SET D=+$PIECE(^DD(D,P,0),U,2),R=" '"_$ORDER(^DD(D,0,"NM",0))_"' MULTIPLES "
HOW  ;
     ;"NOTE!!! -- I am forcing answers to be the default ones for now.  Later figure out how to 
     ;"           specify pre-defined answers in the INFO array
     ;"
     ;"WRITE !!,Y,!?8,"1) WHEN AT LEAST ONE OF THE"_R_"SATISFIES IT"
     ;"WRITE !?8,"2) WHEN ALL OF THE"_R_"SATISFY IT" SET X=2
     ;"IF DV(DV) DO
     ;". WRITE !?8,"3) WHEN ALL OF THE"_R_"SATISFY IT,",!?16,"OR WHEN THERE ARE NO"_R
     ;". SET X=3
     ;"WRITE !?4,"CHOOSE 1-"_X_": " 
     IF DV(DV)>1 DO
     . ;"WRITE 3 
     . SET %1=3
     ELSE  DO
     . ;"WRITE 1 
     . SET %1=1
     ;"READ "// ",%:DTIME,! 
     ;"SET:'$T DTOUT=1 SET:%="" %=%1
     SET %=%1  ;"//KT
     KILL %1 
     ;"GOTO Q:%=U!'$T
     ;"GOTO HOW:%>X!'% 
     IF %>1 DO
     . SET DE(DL,DV,DN)=%
     . SET O=O+1
     . SET ^UTILITY($J,O,0)="   for all"_R_$PIECE(", or when no"_R_"exist",U,%>2)
     GOTO G
     ;
W    IF DV(DV)-2 DO  GOTO DV
     . SET DE(DL,DV,DN)=DV(DV)
     ;"NOTE!!! I am setting the answer to the question below to the default value.
     ;"        Later figure out how to pass predefined answer in INFO array from programmer
     ;"WRITE !!,Y,!?7,"WHEN THERE IS NO '"_$PIECE(^DD(D,+P,0),U,1)_"' TEXT AT ALL"
     SET %=1 
     ;"DO YN^DICN 
     ;"GOTO Q:%<0
     ;"GOTO W:'% 
     SET DE(DL,DV,DN)=4-% 
     GOTO DV
     ;
1    KILL DX,Y ;"removed O from kill
     DO DIS1^TMGDIS1   ;"Sets TMGRESULT,  WAS GOTO ^DIS1
     GOTO TMGDONE
     ;
TMGDONE ;
     QUIT