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

DIAC1.m

Go to the documentation of this file.
  1. DIAC1 ;SLCISC/KCM,MKB - Policy Evaluation API's ;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. CANDO(DIFN,DIENS,DIACTN,DIUSR,DIVAL,DIFLDS,DITXT,DIERROR) ;main API
  1. ; Can user take requested action on [given record in] this file?
  1. ;
  1. ; Returns 1 = Yes (permit)
  1. ; 0 = No (deny)
  1. ; "" = Undetermined/no applicable policy
  1. ; -1 = Error
  1. ;
  1. N DIPOL,DIACT,DIUSRNM,DIRESULT,Y
  1. D CLEAN^DILF K DIFLDS
  1. S DIRESULT=""
  1. ;
  1. ; validate input parameters
  1. S:$G(DIUSR)="" DIUSR=DUZ
  1. I '$D(^VA(200,+DIUSR,0)) D ERROR(202,"USER") Q
  1. S DIUSRNM=$P($G(^VA(200,+DIUSR,0)),U)
  1. ;
  1. I $G(DIACTN),DIACTN=+DIACTN D G CQ:$G(DIERR),C1 ;IEN vs name
  1. . N X0 S X0=$G(^DIAC(1.61,+DIACTN,0))
  1. . I X0="" D ERROR(202,"ACTION") Q
  1. . S DIACT=+DIACTN,DIACTN=$P(X0,U,3),DIPOL=$P(X0,U,5)
  1. . S:'$G(DIFN) DIFN=$P(X0,U,2)
  1. ;
  1. I $G(DIFN)="" D ERROR(202,"FILE") G CQ
  1. I '$$VFILE^DILFD(DIFN) D ERROR(401,DIFN) G CQ
  1. I $G(DIENS),'$$VIENS(DIENS,DIFN) G CQ
  1. I $G(DIACTN)="" D ERROR(202,"ACTION") G CQ
  1. ;
  1. C1 ; find & evaluate policy
  1. S:'$G(DIPOL) DIPOL=$$FIND(DIFN,DIACTN),DIACT=+$P(DIPOL,U,2)
  1. I DIPOL S DIPOL=+DIPOL D EN
  1. ;
  1. CQ ;return result
  1. S Y=$S($G(DIERR):-1,DIRESULT="P":1,DIRESULT="D":0,1:"")
  1. I Y>0,'$L($G(DIFLDS)) D FIELDS(DIACT,1.61)
  1. Q Y
  1. ;
  1. FIND(FILE,ACTION) ; -- find matching Event, return Policy^Event iens
  1. N I,X,Y S Y=""
  1. I $G(FILE)<1!($G(ACTION)="") G FQ
  1. S I=0 F S I=+$O(^DIAC(1.61,"C",FILE,$$UP^XLFSTR(ACTION),I)) Q:I<1 D Q:Y
  1. . S X=$P(^DIAC(1.61,I,0),U,5) ;default policy for event
  1. . I X S Y=X_U_I
  1. FQ Q Y
  1. ;
  1. EN ; -- process policy DIPOL, returns DIRESULT (P/D)
  1. ; Expects all input parameters from $$CANDO to be defined and valid
  1. ; If DIZTRACE = true, the execution trace will be captured
  1. ;
  1. I +$G(DIPOL)'>0 D ERROR(330,$G(DIPOL),"POLICY") Q
  1. I $$DISABLED(DIPOL) D:$G(DIZTRACE) TRACE(DIPOL,0,-1) Q ;error??
  1. ;
  1. N DIFCN,DITYPE,DISTK,DISEQ,DIACMSG
  1. S:'$L($G(DITXT)) DITXT=$NA(^TMP("DIMSG",$J))
  1. ;
  1. D FCN(DIPOL)
  1. S DITYPE=$P($G(^DIAC(1.6,DIPOL,0)),U,2),DISTK=0
  1. I DITYPE="P" S DIRESULT=$$POLICY(DIPOL) G ENQ
  1. I DITYPE'="S" D ERROR(330,$G(DIPOL),"primary policy") Q
  1. D:$G(DIZTRACE) TRACE(DIPOL,DISTK,1)
  1. ;
  1. ; initialize stack if a set, loop until DONE
  1. ; DISTK = stack level being processed
  1. ; DISTK(DISTK) = parent Policy IEN ^ SEQ of last member processed
  1. S DISTK=1,DISTK(DISTK)=DIPOL_"^0",DISTK(0)=0,DISEQ=0
  1. F S DISEQ=$O(^DIAC(1.6,+DISTK(DISTK),10,"AC",DISEQ)) D @$S($$DONE(+DISTK(DISTK)):"POP",+DISEQ'>0:"POP",1:"PROC") Q:DISTK<1
  1. ;
  1. ENQ ; exit
  1. I DIRESULT="" S DIRESULT=$G(DIFCN(DIPOL,"NULL"))
  1. I DIRESULT'="",$D(DIACMSG(DIRESULT)) D ;get messages
  1. . S DIMSG=+$G(DIACMSG(DIRESULT)) Q:DIMSG<1
  1. . M @DITXT=DIACMSG(DIRESULT)
  1. Q
  1. ;
  1. POP ; -- pop the stack [set]
  1. D:$G(DIZTRACE) TRACE(+DISTK(DISTK),DISTK-1,2)
  1. ;
  1. ; tie up current level
  1. I DIRESULT="" S DIRESULT=$G(DIFCN(+DISTK(DISTK),"NULL"))
  1. I $L(DIRESULT) D ADDMSG(+DISTK(DISTK),DIRESULT),OBLIG(+DISTK(DISTK),DIRESULT),FIELDS(+DISTK(DISTK),1.6)
  1. ;
  1. ; pop the stack
  1. S DISTK=DISTK-1,DISEQ=$P(DISTK(DISTK),U,2)
  1. Q
  1. ;
  1. PROC ; -- process member
  1. N DIEM
  1. S $P(DISTK(DISTK),U,2)=DISEQ
  1. S DIEM=+$O(^DIAC(1.6,+DISTK(DISTK),10,"AC",DISEQ,0)) Q:DIEM<1
  1. D FCN(DIEM)
  1. ;
  1. ; if target doesn't match, save item in Trace & quit to next sibling
  1. I '$$MATCH(DIEM) D:$G(DIZTRACE) TRACE(DIEM,DISTK,0) Q
  1. I $$DISABLED(DIEM) D:$G(DIZTRACE) TRACE(DIEM,DISTK,-1) Q
  1. ;
  1. ; if policy set, push stack and reset member loop
  1. I $P($G(^DIAC(1.6,DIEM,0)),U,2)="S" D Q
  1. . D:$G(DIZTRACE) TRACE(DIEM,DISTK,1)
  1. . S DISTK=DISTK+1,DISTK(DISTK)=DIEM_"^0",DISEQ=0
  1. ;
  1. ; else evaluate policy
  1. S DIRESULT=$$POLICY(DIEM)
  1. Q
  1. ;
  1. POLICY(DIEN) ; -- loop on matching rules of policy DIEN
  1. N DIRESULT,DISEQ,DIRULE,DIEFFECT Q:$G(DIEN)<1
  1. D:$G(DIZTRACE) TRACE(DIEN,DISTK,1)
  1. ;
  1. S DISEQ=0,DIRESULT="" ;loop on rules, process if target matches:
  1. F S DISEQ=$O(^DIAC(1.6,DIEN,10,"AC",DISEQ)) Q:DISEQ<1 D I $$DONE(DIEN) D:$G(DIZTRACE) TRACE(DIEN,DISTK,2) Q
  1. . S DIRULE=+$O(^DIAC(1.6,DIEN,10,"AC",DISEQ,0)) Q:DIRULE<1
  1. . D FCN(DIRULE)
  1. . I '$$MATCH(DIRULE) D:$G(DIZTRACE) TRACE(DIRULE,DISTK+1,0) Q
  1. . I $$DISABLED(DIRULE) D:$G(DIZTRACE) TRACE(DIRULE,DISTK+1,-1) Q
  1. . D:$G(DIZTRACE) TRACE(DIRULE,DISTK+1,1)
  1. . ;
  1. . S DIEFFECT=$P($G(^DIAC(1.6,DIRULE,0)),U,8)
  1. . I $$COND(DIRULE) S DIRESULT=DIEFFECT ; true -> return Effect
  1. . E S DIRESULT=$TR(DIEFFECT,"PD","DP") ;false -> return opposite
  1. . ;
  1. . I $L(DIRESULT) D ADDMSG(DIRULE,DIRESULT),OBLIG(DIRULE,DIRESULT),FIELDS(DIRULE,1.6)
  1. . S:$G(DIZTRACE) $P(DIZTRACE(DIZ),U,4)=DIRESULT
  1. I DISEQ<1 D:$G(DIZTRACE) TRACE(DIEN,DISTK,2) ;capture trace I '$$DONE
  1. ;
  1. ; check for quit value (if null), or Deny Message
  1. I DIRESULT="" S DIRESULT=$G(DIFCN(DIEN,"NULL"))
  1. I $L(DIRESULT) D ADDMSG(DIEN,DIRESULT),OBLIG(DIEN,DIRESULT),FIELDS(DIEN,1.6)
  1. Q DIRESULT
  1. ;
  1. MATCH(IEN) ; -- return 1 or 0, if target matches
  1. N X,Y,CONJ,KEY,DONE
  1. S IEN=+$G(IEN),CONJ=$P($G(^DIAC(1.6,IEN,0)),U,5),Y=1,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=1
  1. . E S Y=0
  1. . S DONE=$S(CONJ="!"&Y:1,CONJ="&"&'Y:1,CONJ="":Y,1:0)
  1. MQ ;done
  1. Q Y
  1. ;
  1. DISABLED(IEN) ; -- return 1 or 0, if item is disabled
  1. Q +$P($G(^DIAC(1.6,+$G(IEN),0)),U,3)
  1. ;
  1. FCN(IEN) ; -- run attribute function to accummulate DIVAL(key)=value
  1. N FCN,CODE S IEN=+$G(IEN)
  1. S FCN=+$P($G(^DIAC(1.6,IEN,0)),U,4) ;attributes
  1. I FCN S CODE=$G(^DIAC(1.62,FCN,1)) X:$L(CODE) CODE
  1. ;
  1. ; and stash quit condition code in DIFCN(IEN) for reuse in Member loop
  1. S FCN=+$P($G(^DIAC(1.6,IEN,0)),U,7) Q:FCN<1
  1. S DIFCN(IEN)=$G(^DIAC(1.62,FCN,1)) ;Result Function code
  1. S DIFCN(IEN,"NULL")=$P($G(^DIAC(1.62,FCN,0)),U,4)
  1. Q
  1. ;
  1. DONE(IEN) ; -- return 1 or 0, if quit condition is met for policy IEN
  1. N Y,CODE
  1. S IEN=+$G(IEN),Y=0
  1. S CODE=$G(DIFCN(IEN)) X:$L(CODE) CODE ;must set Y
  1. ;i.e., I DIRESULT="D" S Y=1
  1. Q $G(Y)
  1. ;
  1. COND(IEN) ; -- evaluate any rule IEN conditions [return boolean in Y]
  1. N CONJ,DONE,Y,DII,DA,X,X0,FCN,CODE
  1. S IEN=+$G(IEN),CONJ=$P($G(^DIAC(1.6,IEN,0)),U,6),DONE=0
  1. S Y=1,DII=0 ;return true if no conditions
  1. F S DII=$O(^DIAC(1.6,IEN,3,"B",DII)) Q:DII<1 S DA=+$O(^(DII,0)) D Q:DONE
  1. . S X0=$G(^DIAC(1.6,IEN,3,DA,0)),X=$P(X0,U,3)
  1. . ; Operator function may use X, must return boolean in Y
  1. . S FCN=+$P(X0,U,2) I FCN D
  1. .. S CODE=$G(^DIAC(1.62,FCN,1)) X:$L(CODE) CODE
  1. .. D:$G(DIZTRACE) TRACE(DA,DISTK+2,Y,DII)
  1. . S DONE=$S(CONJ="!"&Y:1,CONJ="&"&'Y:1,CONJ="":Y,1:0)
  1. Q Y
  1. ;
  1. ADDMSG(IEN,RES) ; -- add line to DIMSG array
  1. N I,N,X,Y Q:'$L($G(RES))
  1. S N=$S(RES="D":7,RES="P":8,1:"") Q:N<1
  1. S X=$P($G(^DIAC(1.6,+$G(IEN),N)),U,2) Q:'$L(X)
  1. I X["|" D ;look for |VAR|
  1. . F I=2:2:$L(X,"|") S Y=$P(X,"|",I) I Y?1.A D
  1. .. I $D(@Y) S $P(X,"|",I)=@Y Q
  1. .. I $D(DIVAL(Y)) S $P(X,"|",I)=DIVAL(Y) Q
  1. . S X=$TR(X,"|","")
  1. ; DIMSG=+$G(DIMSG)+1,@DITXT@(DIMSG)=X
  1. S DIACMSG(RES,$$MSG)=X
  1. Q
  1. MSG() ;
  1. N I S I=+$G(DIACMSG(RES))+1
  1. S DIACMSG(RES)=I
  1. Q I
  1. ;
  1. OBLIG(IEN,RES) ; -- execute obligation code
  1. N N,FCN,CODE Q:'$L($G(RES))
  1. S N=$S(RES="D":7,RES="P":8,1:"") Q:N<1
  1. S FCN=+$G(^DIAC(1.6,+$G(IEN),N))
  1. I FCN S CODE=$G(^DIAC(1.62,FCN,1)) X:$L(CODE) CODE
  1. Q
  1. ;
  1. FIELDS(IEN,FN) ; -- return available fields in DIFLDS
  1. Q:$G(DIRESULT)'="P" ;on permit only
  1. Q:$G(DIFLDS)'="" ;lowest level takes precedence
  1. Q:'$L($G(^DIAC(+$G(FN),+$G(IEN),5)))
  1. N I,L,S,DR S DIFLDS=$G(^DIAC(FN,IEN,5)),I=0
  1. F S I=$O(^DIAC(FN,IEN,5.1,I)) Q:I<1 S X=$G(^(I,0)) I X D
  1. . S L=+$P(X,U,2),S=$P(X,U,3),DR=$P(X,U,4) Q:DR=""
  1. . I S>0 S DIFLDS(L,+X,+S)=DR
  1. . E S DIFLDS(L,+X)=DR
  1. S:$G(DIZTRACE) DIZTRACE("FLDS")=FN_U_IEN
  1. Q
  1. ;
  1. VIENS(IENS,FN) ; -- validate IENS string for file# FN
  1. N GBL S GBL=$$ROOT^DILFD(FN,IENS,,1)
  1. I $G(DIERR) D:$D(DIERROR) Q 0
  1. . ;add message to end of provided array
  1. . N I S I=+$O(@DIERROR@(""),-1)
  1. . S:I I=I+1,@DIERROR@(I)=" "
  1. . S @DIERROR@(I+1)=$G(^TMP("DIERR",$J,1,"TEXT",1))
  1. I '$D(@(GBL_+IENS_")")) D ERROR(601) Q 0
  1. Q 1
  1. ;
  1. ERROR(CODE,PARAM,TYPE) ; -- create error message
  1. I '$L($G(TYPE)) D BLD^DIALOG(CODE,$G(PARAM),,$G(DIERROR)) Q
  1. N DIX S DIX(1)=$G(PARAM),DIX(2)=$G(TYPE)
  1. D BLD^DIALOG(CODE,.DIX,,$G(DIERROR))
  1. Q
  1. ;
  1. TRACE(IEN,STK,ACT,COND) ; -- set trace array
  1. ; DIZTRACE(#) = PolicyIEN ^ stack level ^ match? (1/0)
  1. ; or = PolicyIEN ^ stack level ^ done (2) ^ ResultFcnIEN
  1. ; DIZTRACE(#,c) = ConditionDA ^ stack level ^ result (1/0)
  1. ;
  1. I $G(COND) S DIZTRACE(+$G(DIZ),COND)=$G(IEN)_U_$G(STK)_U_$G(ACT) Q
  1. N RES S RES=$S($G(ACT)=2:$P($G(^DIAC(1.6,+$G(IEN),0)),U,7),1:"")
  1. S DIZTRACE($$NXT)=$G(IEN)_U_$G(STK)_U_$G(ACT)_U_RES
  1. Q
  1. ;
  1. NXT() ; -- increment trace array subscript
  1. S DIZ=+$G(DIZ)+1
  1. Q DIZ