- 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 Feb 19, 2025@00:10:52 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