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