- DIAC1T ;SLCISC/MKB - Test utility for Policies ;17FEB2017
- ;;22.2;VA FileMan;**8**;Jan 05, 2016;Build 19
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- EN ; -- test the current policy set [expects DITOP]
- N DIACT,DIPOL,DIFN,DIACTN,DIENS,DIUSR,DIUSRNM,DIZ,DIZTRACE,DIVAL,DITXT,DIRESULT,DIMSG,DIERR,DIFLDS
- S DIPOL=+$G(DITOP) I DIPOL<1 S VALMBCK="" Q
- D FULL^VALM1 S VALMBCK="R"
- S DIACT=$$ACTION Q:DIACT="^"
- I DIACT<1 W !!,"NOTE: This policy is not tied to an Application Action (file and action)."
- S DIFN=$P($G(^DIAC(1.61,+DIACT,0)),U,2),DIACTN=$P($G(^(0)),U,3)
- ;
- W !!,"Enter values to use for testing evaluation of "_$P(DITOP,U,2)_","
- W !,"either a valid IENS string and/or target attributes.",!
- S DIENS=$$IENS(DIFN) Q:DIENS="^"
- D ATTRBS ;get DIVAL(att)=value
- I DIENS<1,'$D(DIVAL) Q ;no values to test against
- S DIUSR=$$USER Q:DIUSR<1 ;=NP#200 ien
- S DIUSRNM=$P($G(^VA(200,+DIUSR,0)),U)
- ;
- S DIZTRACE=$$TRACE Q:"^"[DIZTRACE
- S DIRESULT="" D EN^DIAC1
- I DIRESULT="P",'$L($G(DIFLDS)) D FIELDS^DIAC1(DIACT,1.61)
- ;
- ; build output array ^TMP("DIACT",$J) and display
- N DIT K ^TMP("DIACT",$J)
- I $G(DIZTRACE) D SHOWVAR,SHOWTRC,OUT("")
- D OUT("Result: "_$S(DIRESULT="P":"PERMIT",DIRESULT="D":"DENY",$G(DIERR):"ERROR",1:"INDETERMINATE"))
- I $G(DIERR) D SHOWTMP("DIERR")
- I $G(DIMSG) D SHOWTMP("DIMSG")
- I $L($G(DIFLDS)) D SHOWFLDS
- I $$TEST^DDBRT D BROWSE Q
- D WRITE
- Q
- ;
- ACTION() ; -- select App Action to use for testing
- N I,X,Y,CNT,DIR,DIACT
- S (I,CNT)=0 F S I=$O(^DIAC(1.61,"D",DIPOL,I)) Q:I<1 D
- . S CNT=CNT+1,X=$G(^DIAC(1.61,I,0)),Y=$G(^(1)),DIACT(CNT)=I
- . S:Y="" Y=$P(X,U)_" (#"_$P(X,U,2)_$S($L($P(X,U,3)):" "_$P(X,U,3),1:"")_")"
- . S DIR("A",CNT)=$$RJ^XLFSTR(CNT,3)_" "_Y
- I CNT<1 S Y=""
- I CNT=1 S Y=+$G(DIACT(1))
- I CNT>1 D S:Y>0 Y=+$G(DIACT(Y))
- . S DIR(0)="NAO^1:"_CNT,DIR("A")="Use action: " K X,Y
- . S DIR("?")="This policy is linked to multiple actions; select the one to use for this test."
- . D ^DIR I Y<1 S Y="^"
- Q Y
- ;
- IENS(FN) ; -- get IENS string for file number FN [lookup if FN?]
- N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
- I1 S DIR(0)="FAO^1:30",DIR("A")="IENS: " D ^DIR
- I $G(Y),$G(FN),'$$VIENS(Y,FN) G I1
- Q Y
- ;
- VIENS(IENS,FN) ; -- validate IENS string for file# FN
- N GBL,DIERR S GBL=$$ROOT^DILFD(FN,IENS,,1)
- I $G(DIERR) W !,$G(^TMP("DIERR",$J,1,"TEXT",1)) Q 0
- I '$D(@(GBL_+IENS_")")) D Q 0
- . W "The entry identified by "_FN_" and "_IENS
- . W " does not exist in the database."
- Q 1
- ;
- ATTRBS ; -- prompt for test attributes
- N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
- N ATT,DILIST D LIST
- S DIR(0)="FAO^1:30" F D Q:"^"[Y
- . S DIR("?")="^D HELPATT^DIAC1T"
- . S DIR("A")="ATTRIBUTE: " D ^DIR Q:"^"[Y
- . S ATT=Y,DIR("A")=" VALUE: " K X,Y D ^DIR
- . S:"^"'[Y DIVAL(ATT)=Y K ATT
- Q
- ;
- LIST ; -- return DILIST("attribute") of targets used by DIPOL
- N DISTK,DIMEM K DILIST
- S DISTK=1,DISTK(DISTK)=DIPOL_"^0",DISTK(0)=0,DIMEM=0
- F S DIMEM=$O(^DIAC(1.6,+DISTK(DISTK),10,DIMEM)) D @$S(+DIMEM'>0:"POP",1:"PROC") Q:DISTK<1
- Q
- ;
- POP ; -- pop the stack [set]
- S DISTK=DISTK-1,DIMEM=$P(DISTK(DISTK),U,2)
- Q
- ;
- PROC ; -- process member DIMEM
- N DIEN,I,X
- S $P(DISTK(DISTK),U,2)=DIMEM
- S DIEN=+$G(^DIAC(1.6,+DISTK(DISTK),10,DIMEM,0))
- S I=0 F S I=$O(^DIAC(1.6,DIEN,2,I)) Q:I<1 S X=$G(^(I,0)) I $L($P(X,U,2)) D
- . S DILIST($P(X,U,2))=""
- . S:$L($P(X,U,3)) DILIST($P(X,U,2),$P(X,U,3))=""
- S DISTK=DISTK+1,DISTK(DISTK)=DIEN_"^0",DIMEM=0
- Q
- ;
- HELPATT ; -- help for ATTRBS
- W !,"Enter an attribute/value pair for testing evaluation of this policy."
- Q:'$D(DILIST) I '$D(ATT) D Q ;show attributes
- . W !,"Target attributes used within this policy are:"
- . N I S I="" F S I=$O(DILIST(I)) Q:I="" W !?5,I
- I $L(ATT),$D(DILIST(ATT)) D ;show values for ATTribute
- . W !,"Values used with this attribute are:"
- . N I S I="" F S I=$O(DILIST(ATT,I)) Q:I="" W !?5,I
- Q
- ;
- USER() ; -- select test user from #200
- N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
- N DIVAL ;protect from embedded ^DIC call
- S DIR(0)="PAO^200:AEQM",DIR("A")="Select Test User: "
- S DIR("B")=$P($G(^VA(200,DUZ,0)),U)
- S DIR("?")="Select a user for testing evaluation of this policy."
- W ! D ^DIR
- Q +Y
- ;
- TRACE() ; -- show trace of policies/rules evaluated?
- N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
- S DIR(0)="Y",DIR("A")="Show a trace of all policies and rules evaluated"
- S DIR("?")="Enter YES to see all rules and results displayed as they are processed."
- D ^DIR
- Q Y
- ;
- SHOWVAR ; -- show variables
- N X
- F X="DIACT","DIACTN","DIENS","DIFN","DIPOL","DIUSR" D OUT(X_" = "_$S($D(@X):@X,1:"<undefined>"))
- S X="" F S X=$O(DIVAL(X)) Q:X="" D OUT("DIVAL("""_X_""") = "_DIVAL(X))
- Q
- ;
- SHOWTMP(TYPE) ; -- display messages from ^TMP
- Q:'$L($G(TYPE))
- N I,J D OUT(""),OUT(TYPE_": "_@TYPE)
- S I=0 F S I=$O(^TMP(TYPE,$J,I)) Q:I<1 D
- . I TYPE="DIMSG" D OUT($G(^TMP(TYPE,$J,I))) Q
- . S J=0 F S J=$O(^TMP(TYPE,$J,I,"TEXT",J)) Q:J<1 D OUT(^(J))
- Q
- ;
- SHOWTRC ; -- display DIZTRACE of processing
- ; DIZTRACE(DIZ) = PolicyIEN ^ stack level ^ match? (1/0) ^ result (P/D)
- ; or = PolicyIEN ^ stack level ^ done (2) ^ ResultFcnIEN
- ; DIZTRACE(#,i) = ConditionDA ^ stack level ^ result (1/0)
- ;
- N DII,DIJ,DISTK,X,Y,DIEN,DIX D OUT("")
- F DII=1:1:DIZ I $D(DIZTRACE(DII)) D
- . S X=$G(DIZTRACE(DII)),DIEN=+X,DISTK=$P(X,U,2)
- . S DIX=$$REPEAT^XLFSTR(" ",DISTK*3)_$P($G(^DIAC(1.6,DIEN,0)),U)_": "
- . I $P(X,U,3)<0 D OUT(DIX_"<disabled>") Q
- . I $P(X,U,3)=0 D OUT(DIX_"<not a match>") Q
- . I $P(X,U,3)=2 D OUT(DIX_$P($G(^DIAC(1.62,+$P(X,U,4),0)),U,2)) Q
- . I DIEN=+$G(DITOP) S DIX=DIX_"DIPOL="_DIEN S:$G(DIFN) DIX=DIX_" (DIFN="_DIFN_" & DIACTN="_DIACTN_")"
- . E S DIX=DIX_$$TARGET(DIEN)
- . D OUT(DIX)
- . ;show conditions, if DIEN is a rule
- . S DIJ=0 F S DIJ=$O(DIZTRACE(DII,DIJ)) Q:DIJ<1 D
- .. S Y=$G(DIZTRACE(DII,DIJ)),DISTK=$P(Y,U,2)
- .. S DIX=$$REPEAT^XLFSTR(" ",DISTK*3)_$$FCNM(DIEN,+Y)_": "_$P(Y,U,3)
- .. D OUT(DIX)
- . I $L($P(X,U,4)) S DIX=$$REPEAT^XLFSTR(" ",DISTK*3)_"DIRESULT: "_$P(X,U,4) D OUT(DIX)
- Q
- ;
- FCNM(IEN,CON) ; -- return NAME(X1,X2,X3) for a function in use
- N X0,X,Y
- S X0=$G(^DIAC(1.6,IEN,3,CON,0))
- S Y=$P($G(^DIAC(1.62,+$P(X0,U,2),0)),U)
- S X=$P(X0,U,3) I $L(X) S Y=Y_"("_X_")"
- Q Y
- ;
- TARGET(IEN) ; -- return target(s) that matched
- N X,Y,CONJ,KEY,DONE
- S Y="",CONJ=$P($G(^DIAC(1.6,IEN,0)),U,5),DONE=0
- S KEY="" F S KEY=$O(^DIAC(1.6,IEN,2,"AKEY",KEY)) Q:KEY="" D Q:DONE
- . S X=$G(DIVAL(KEY))
- . I $L(X),$D(^DIAC(1.6,IEN,2,"AKEY",KEY,X)) S Y=Y_$S($L(Y):" & ",1:"")_KEY_"="_X
- . I $L(Y),CONJ'="&" S DONE=1
- Q Y
- ;
- SHOWFLDS ; -- display DIFLDS string of available fields to access
- ; DIZTRACE("DR") = ien ^ file# returning the string
- ; DIFLDS = DR string
- ; DIFLDS(level,subfile#,n) = DR string
- ;
- Q:'$L($G(DIFLDS))
- N I,X,FN,IEN
- S X=$G(DIZTRACE("FLDS")),FN=+X,IEN=+$P(X,U,2)
- D OUT(""),OUT("DIFLDS("_$P($G(^DIAC(FN,IEN,0)),U)_"): "_$G(DIFLDS))
- S I="DIFLDS" F S I=$Q(@I) Q:I'?1"DIFLDS(".E D OUT(I_": "_@I)
- Q
- ;
- OUT(X) ; -- add line to output
- S DIT=+$G(DIT)+1,^TMP("DIACT",$J,DIT)=$G(X)
- Q
- ;
- WRITE ; -- write ^TMP output to screen
- N I,LCNT,STOP S I=0,LCNT=2,STOP=0
- W !!,$$REPEAT^XLFSTR(" ",29-$L($P(DITOP,U,2)))
- W "---------- "_$P(DITOP,U,2)_" ----------",!
- F S I=$O(^TMP("DIACT",$J,I)) Q:I<1 D Q:STOP
- . S LCNT=LCNT+1 I LCNT>23 D WAIT Q:STOP S LCNT=1
- . W !,^TMP("DIACT",$J,I)
- I 'STOP D WAIT
- Q
- ;
- WAIT ; -- wait for ok [returns STOP]
- N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
- S DIR(0)="E" D ^DIR ;Y=1 to continue
- S STOP='Y
- Q
- ;
- BROWSE ; -- use Browser to show output
- D BROWSE^DDBR("^TMP(""DIACT"",$J)","N",$P(DITOP,U,2))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIAC1T 7686 printed Feb 19, 2025@00:10:53 Page 2
- DIAC1T ;SLCISC/MKB - Test utility for Policies ;17FEB2017
- +1 ;;22.2;VA FileMan;**8**;Jan 05, 2016;Build 19
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- EN ; -- test the current policy set [expects DITOP]
- +1 NEW DIACT,DIPOL,DIFN,DIACTN,DIENS,DIUSR,DIUSRNM,DIZ,DIZTRACE,DIVAL,DITXT,DIRESULT,DIMSG,DIERR,DIFLDS
- +2 SET DIPOL=+$GET(DITOP)
- IF DIPOL<1
- SET VALMBCK=""
- QUIT
- +3 DO FULL^VALM1
- SET VALMBCK="R"
- +4 SET DIACT=$$ACTION
- if DIACT="^"
- QUIT
- +5 IF DIACT<1
- WRITE !!,"NOTE: This policy is not tied to an Application Action (file and action)."
- +6 SET DIFN=$PIECE($GET(^DIAC(1.61,+DIACT,0)),U,2)
- SET DIACTN=$PIECE($GET(^(0)),U,3)
- +7 ;
- +8 WRITE !!,"Enter values to use for testing evaluation of "_$PIECE(DITOP,U,2)_","
- +9 WRITE !,"either a valid IENS string and/or target attributes.",!
- +10 SET DIENS=$$IENS(DIFN)
- if DIENS="^"
- QUIT
- +11 ;get DIVAL(att)=value
- DO ATTRBS
- +12 ;no values to test against
- IF DIENS<1
- IF '$DATA(DIVAL)
- QUIT
- +13 ;=NP#200 ien
- SET DIUSR=$$USER
- if DIUSR<1
- QUIT
- +14 SET DIUSRNM=$PIECE($GET(^VA(200,+DIUSR,0)),U)
- +15 ;
- +16 SET DIZTRACE=$$TRACE
- if "^"[DIZTRACE
- QUIT
- +17 SET DIRESULT=""
- DO EN^DIAC1
- +18 IF DIRESULT="P"
- IF '$LENGTH($GET(DIFLDS))
- DO FIELDS^DIAC1(DIACT,1.61)
- +19 ;
- +20 ; build output array ^TMP("DIACT",$J) and display
- +21 NEW DIT
- KILL ^TMP("DIACT",$JOB)
- +22 IF $GET(DIZTRACE)
- DO SHOWVAR
- DO SHOWTRC
- DO OUT("")
- +23 DO OUT("Result: "_$SELECT(DIRESULT="P":"PERMIT",DIRESULT="D":"DENY",$GET(DIERR):"ERROR",1:"INDETERMINATE"))
- +24 IF $GET(DIERR)
- DO SHOWTMP("DIERR")
- +25 IF $GET(DIMSG)
- DO SHOWTMP("DIMSG")
- +26 IF $LENGTH($GET(DIFLDS))
- DO SHOWFLDS
- +27 IF $$TEST^DDBRT
- DO BROWSE
- QUIT
- +28 DO WRITE
- +29 QUIT
- +30 ;
- ACTION() ; -- select App Action to use for testing
- +1 NEW I,X,Y,CNT,DIR,DIACT
- +2 SET (I,CNT)=0
- FOR
- SET I=$ORDER(^DIAC(1.61,"D",DIPOL,I))
- if I<1
- QUIT
- Begin DoDot:1
- +3 SET CNT=CNT+1
- SET X=$GET(^DIAC(1.61,I,0))
- SET Y=$GET(^(1))
- SET DIACT(CNT)=I
- +4 if Y=""
- SET Y=$PIECE(X,U)_" (#"_$PIECE(X,U,2)_$SELECT($LENGTH($PIECE(X,U,3)):" "_$PIECE(X,U,3),1:"")_")"
- +5 SET DIR("A",CNT)=$$RJ^XLFSTR(CNT,3)_" "_Y
- End DoDot:1
- +6 IF CNT<1
- SET Y=""
- +7 IF CNT=1
- SET Y=+$GET(DIACT(1))
- +8 IF CNT>1
- Begin DoDot:1
- +9 SET DIR(0)="NAO^1:"_CNT
- SET DIR("A")="Use action: "
- KILL X,Y
- +10 SET DIR("?")="This policy is linked to multiple actions; select the one to use for this test."
- +11 DO ^DIR
- IF Y<1
- SET Y="^"
- End DoDot:1
- if Y>0
- SET Y=+$GET(DIACT(Y))
- +12 QUIT Y
- +13 ;
- IENS(FN) ; -- get IENS string for file number FN [lookup if FN?]
- +1 NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
- I1 SET DIR(0)="FAO^1:30"
- SET DIR("A")="IENS: "
- DO ^DIR
- +1 IF $GET(Y)
- IF $GET(FN)
- IF '$$VIENS(Y,FN)
- GOTO I1
- +2 QUIT Y
- +3 ;
- VIENS(IENS,FN) ; -- validate IENS string for file# FN
- +1 NEW GBL,DIERR
- SET GBL=$$ROOT^DILFD(FN,IENS,,1)
- +2 IF $GET(DIERR)
- WRITE !,$GET(^TMP("DIERR",$JOB,1,"TEXT",1))
- QUIT 0
- +3 IF '$DATA(@(GBL_+IENS_")"))
- Begin DoDot:1
- +4 WRITE "The entry identified by "_FN_" and "_IENS
- +5 WRITE " does not exist in the database."
- End DoDot:1
- QUIT 0
- +6 QUIT 1
- +7 ;
- ATTRBS ; -- prompt for test attributes
- +1 NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
- +2 NEW ATT,DILIST
- DO LIST
- +3 SET DIR(0)="FAO^1:30"
- FOR
- Begin DoDot:1
- +4 SET DIR("?")="^D HELPATT^DIAC1T"
- +5 SET DIR("A")="ATTRIBUTE: "
- DO ^DIR
- if "^"[Y
- QUIT
- +6 SET ATT=Y
- SET DIR("A")=" VALUE: "
- KILL X,Y
- DO ^DIR
- +7 if "^"'[Y
- SET DIVAL(ATT)=Y
- KILL ATT
- End DoDot:1
- if "^"[Y
- QUIT
- +8 QUIT
- +9 ;
- LIST ; -- return DILIST("attribute") of targets used by DIPOL
- +1 NEW DISTK,DIMEM
- KILL DILIST
- +2 SET DISTK=1
- SET DISTK(DISTK)=DIPOL_"^0"
- SET DISTK(0)=0
- SET DIMEM=0
- +3 FOR
- SET DIMEM=$ORDER(^DIAC(1.6,+DISTK(DISTK),10,DIMEM))
- DO @$SELECT(+DIMEM'>0:"POP",1:"PROC")
- if DISTK<1
- QUIT
- +4 QUIT
- +5 ;
- POP ; -- pop the stack [set]
- +1 SET DISTK=DISTK-1
- SET DIMEM=$PIECE(DISTK(DISTK),U,2)
- +2 QUIT
- +3 ;
- PROC ; -- process member DIMEM
- +1 NEW DIEN,I,X
- +2 SET $PIECE(DISTK(DISTK),U,2)=DIMEM
- +3 SET DIEN=+$GET(^DIAC(1.6,+DISTK(DISTK),10,DIMEM,0))
- +4 SET I=0
- FOR
- SET I=$ORDER(^DIAC(1.6,DIEN,2,I))
- if I<1
- QUIT
- SET X=$GET(^(I,0))
- IF $LENGTH($PIECE(X,U,2))
- Begin DoDot:1
- +5 SET DILIST($PIECE(X,U,2))=""
- +6 if $LENGTH($PIECE(X,U,3))
- SET DILIST($PIECE(X,U,2),$PIECE(X,U,3))=""
- End DoDot:1
- +7 SET DISTK=DISTK+1
- SET DISTK(DISTK)=DIEN_"^0"
- SET DIMEM=0
- +8 QUIT
- +9 ;
- HELPATT ; -- help for ATTRBS
- +1 WRITE !,"Enter an attribute/value pair for testing evaluation of this policy."
- +2 ;show attributes
- if '$DATA(DILIST)
- QUIT
- IF '$DATA(ATT)
- Begin DoDot:1
- +3 WRITE !,"Target attributes used within this policy are:"
- +4 NEW I
- SET I=""
- FOR
- SET I=$ORDER(DILIST(I))
- if I=""
- QUIT
- WRITE !?5,I
- End DoDot:1
- QUIT
- +5 ;show values for ATTribute
- IF $LENGTH(ATT)
- IF $DATA(DILIST(ATT))
- Begin DoDot:1
- +6 WRITE !,"Values used with this attribute are:"
- +7 NEW I
- SET I=""
- FOR
- SET I=$ORDER(DILIST(ATT,I))
- if I=""
- QUIT
- WRITE !?5,I
- End DoDot:1
- +8 QUIT
- +9 ;
- USER() ; -- select test user from #200
- +1 NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
- +2 ;protect from embedded ^DIC call
- NEW DIVAL
- +3 SET DIR(0)="PAO^200:AEQM"
- SET DIR("A")="Select Test User: "
- +4 SET DIR("B")=$PIECE($GET(^VA(200,DUZ,0)),U)
- +5 SET DIR("?")="Select a user for testing evaluation of this policy."
- +6 WRITE !
- DO ^DIR
- +7 QUIT +Y
- +8 ;
- TRACE() ; -- show trace of policies/rules evaluated?
- +1 NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
- +2 SET DIR(0)="Y"
- SET DIR("A")="Show a trace of all policies and rules evaluated"
- +3 SET DIR("?")="Enter YES to see all rules and results displayed as they are processed."
- +4 DO ^DIR
- +5 QUIT Y
- +6 ;
- SHOWVAR ; -- show variables
- +1 NEW X
- +2 FOR X="DIACT","DIACTN","DIENS","DIFN","DIPOL","DIUSR"
- DO OUT(X_" = "_$SELECT($DATA(@X):@X,1:"<undefined>"))
- +3 SET X=""
- FOR
- SET X=$ORDER(DIVAL(X))
- if X=""
- QUIT
- DO OUT("DIVAL("""_X_""") = "_DIVAL(X))
- +4 QUIT
- +5 ;
- SHOWTMP(TYPE) ; -- display messages from ^TMP
- +1 if '$LENGTH($GET(TYPE))
- QUIT
- +2 NEW I,J
- DO OUT("")
- DO OUT(TYPE_": "_@TYPE)
- +3 SET I=0
- FOR
- SET I=$ORDER(^TMP(TYPE,$JOB,I))
- if I<1
- QUIT
- Begin DoDot:1
- +4 IF TYPE="DIMSG"
- DO OUT($GET(^TMP(TYPE,$JOB,I)))
- QUIT
- +5 SET J=0
- FOR
- SET J=$ORDER(^TMP(TYPE,$JOB,I,"TEXT",J))
- if J<1
- QUIT
- DO OUT(^(J))
- End DoDot:1
- +6 QUIT
- +7 ;
- SHOWTRC ; -- display DIZTRACE of processing
- +1 ; DIZTRACE(DIZ) = PolicyIEN ^ stack level ^ match? (1/0) ^ result (P/D)
- +2 ; or = PolicyIEN ^ stack level ^ done (2) ^ ResultFcnIEN
- +3 ; DIZTRACE(#,i) = ConditionDA ^ stack level ^ result (1/0)
- +4 ;
- +5 NEW DII,DIJ,DISTK,X,Y,DIEN,DIX
- DO OUT("")
- +6 FOR DII=1:1:DIZ
- IF $DATA(DIZTRACE(DII))
- Begin DoDot:1
- +7 SET X=$GET(DIZTRACE(DII))
- SET DIEN=+X
- SET DISTK=$PIECE(X,U,2)
- +8 SET DIX=$$REPEAT^XLFSTR(" ",DISTK*3)_$PIECE($GET(^DIAC(1.6,DIEN,0)),U)_": "
- +9 IF $PIECE(X,U,3)<0
- DO OUT(DIX_"<disabled>")
- QUIT
- +10 IF $PIECE(X,U,3)=0
- DO OUT(DIX_"<not a match>")
- QUIT
- +11 IF $PIECE(X,U,3)=2
- DO OUT(DIX_$PIECE($GET(^DIAC(1.62,+$PIECE(X,U,4),0)),U,2))
- QUIT
- +12 IF DIEN=+$GET(DITOP)
- SET DIX=DIX_"DIPOL="_DIEN
- if $GET(DIFN)
- SET DIX=DIX_" (DIFN="_DIFN_" & DIACTN="_DIACTN_")"
- +13 IF '$TEST
- SET DIX=DIX_$$TARGET(DIEN)
- +14 DO OUT(DIX)
- +15 ;show conditions, if DIEN is a rule
- +16 SET DIJ=0
- FOR
- SET DIJ=$ORDER(DIZTRACE(DII,DIJ))
- if DIJ<1
- QUIT
- Begin DoDot:2
- +17 SET Y=$GET(DIZTRACE(DII,DIJ))
- SET DISTK=$PIECE(Y,U,2)
- +18 SET DIX=$$REPEAT^XLFSTR(" ",DISTK*3)_$$FCNM(DIEN,+Y)_": "_$PIECE(Y,U,3)
- +19 DO OUT(DIX)
- End DoDot:2
- +20 IF $LENGTH($PIECE(X,U,4))
- SET DIX=$$REPEAT^XLFSTR(" ",DISTK*3)_"DIRESULT: "_$PIECE(X,U,4)
- DO OUT(DIX)
- End DoDot:1
- +21 QUIT
- +22 ;
- FCNM(IEN,CON) ; -- return NAME(X1,X2,X3) for a function in use
- +1 NEW X0,X,Y
- +2 SET X0=$GET(^DIAC(1.6,IEN,3,CON,0))
- +3 SET Y=$PIECE($GET(^DIAC(1.62,+$PIECE(X0,U,2),0)),U)
- +4 SET X=$PIECE(X0,U,3)
- IF $LENGTH(X)
- SET Y=Y_"("_X_")"
- +5 QUIT Y
- +6 ;
- TARGET(IEN) ; -- return target(s) that matched
- +1 NEW X,Y,CONJ,KEY,DONE
- +2 SET Y=""
- SET CONJ=$PIECE($GET(^DIAC(1.6,IEN,0)),U,5)
- SET DONE=0
- +3 SET KEY=""
- FOR
- SET KEY=$ORDER(^DIAC(1.6,IEN,2,"AKEY",KEY))
- if KEY=""
- QUIT
- Begin DoDot:1
- +4 SET X=$GET(DIVAL(KEY))
- +5 IF $LENGTH(X)
- IF $DATA(^DIAC(1.6,IEN,2,"AKEY",KEY,X))
- SET Y=Y_$SELECT($LENGTH(Y):" & ",1:"")_KEY_"="_X
- +6 IF $LENGTH(Y)
- IF CONJ'="&"
- SET DONE=1
- End DoDot:1
- if DONE
- QUIT
- +7 QUIT Y
- +8 ;
- SHOWFLDS ; -- display DIFLDS string of available fields to access
- +1 ; DIZTRACE("DR") = ien ^ file# returning the string
- +2 ; DIFLDS = DR string
- +3 ; DIFLDS(level,subfile#,n) = DR string
- +4 ;
- +5 if '$LENGTH($GET(DIFLDS))
- QUIT
- +6 NEW I,X,FN,IEN
- +7 SET X=$GET(DIZTRACE("FLDS"))
- SET FN=+X
- SET IEN=+$PIECE(X,U,2)
- +8 DO OUT("")
- DO OUT("DIFLDS("_$PIECE($GET(^DIAC(FN,IEN,0)),U)_"): "_$GET(DIFLDS))
- +9 SET I="DIFLDS"
- FOR
- SET I=$QUERY(@I)
- if I'?1"DIFLDS(".E
- QUIT
- DO OUT(I_": "_@I)
- +10 QUIT
- +11 ;
- OUT(X) ; -- add line to output
- +1 SET DIT=+$GET(DIT)+1
- SET ^TMP("DIACT",$JOB,DIT)=$GET(X)
- +2 QUIT
- +3 ;
- WRITE ; -- write ^TMP output to screen
- +1 NEW I,LCNT,STOP
- SET I=0
- SET LCNT=2
- SET STOP=0
- +2 WRITE !!,$$REPEAT^XLFSTR(" ",29-$LENGTH($PIECE(DITOP,U,2)))
- +3 WRITE "---------- "_$PIECE(DITOP,U,2)_" ----------",!
- +4 FOR
- SET I=$ORDER(^TMP("DIACT",$JOB,I))
- if I<1
- QUIT
- Begin DoDot:1
- +5 SET LCNT=LCNT+1
- IF LCNT>23
- DO WAIT
- if STOP
- QUIT
- SET LCNT=1
- +6 WRITE !,^TMP("DIACT",$JOB,I)
- End DoDot:1
- if STOP
- QUIT
- +7 IF 'STOP
- DO WAIT
- +8 QUIT
- +9 ;
- WAIT ; -- wait for ok [returns STOP]
- +1 NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
- +2 ;Y=1 to continue
- SET DIR(0)="E"
- DO ^DIR
- +3 SET STOP='Y
- +4 QUIT
- +5 ;
- BROWSE ; -- use Browser to show output
- +1 DO BROWSE^DDBR("^TMP(""DIACT"",$J)","N",$PIECE(DITOP,U,2))
- +2 QUIT