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 Sep 23, 2025@20:20:44 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
