Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DIAC1T

DIAC1T.m

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