DIACLM1 ;SLCISC/MKB - Policy Editor actions ;17FEB2017
;;22.2;VA FileMan;**8**;Jan 05, 2016;Build 19
;;Per VA Directive 6402, this routine should not be modified.
;
ADD ; -- add/remove members
N X,Y,DAD,TYPE,DONE,DIFF,ITM,DIE,DA,DR,DIC S VALMBCK=""
L +^DIAC(1.6,0):DILOCKTM I '$T W !,"Another user is editing policies." H 2 Q
I VALMCNT=1 S DAD=+$G(^TMP("DIAC",$J,"IEN",1)) Q:DAD<1
E S DAD=+$$SELECT("To policy") Q:DAD<1
I $P($G(^DIAC(1.6,DAD,0)),U,2)="R" W !,"Rules may not have members.",! H 2 Q
L +^DIAC(1.6,DAD):DILOCKTM I '$T W !,"Another user is editing "_$P(DAD,U,2) H 2 Q
S TYPE=$P($G(^DIAC(1.6,DAD,0)),U,2),(DONE,DIFF)=0
;
D FULL^VALM1 S VALMBCK="R"
F D Q:DONE
. S ITM=$$DIR I ITM<1 S DONE=1 Q
. I $P(ITM,U,3) D Q:'$D(DA) ;deleted
.. S DR=".01;2;I $P($G(^DIAC(1.6,+DA,2,0)),U,4)<2 S Y=""@1"";.05R;@1;"
.. I $G(TYPE)="P" S DR=DR_"3;I $P($G(^DIAC(1.6,+DA,3,0)),U,4)<2 S Y=""@2"";.06R;@2;.08R;7.1;7;8.1;8"
.. E S DR=DR_".07R;7.1;7;8.1;8"
.. K DA,DIC S DIE="^DIAC(1.6,",DA=+ITM D ^DIE
. ;
. K DA,DIC S DA=$O(^DIAC(1.6,DAD,10,"B",+ITM,0)),DA(1)=+DAD,DIFF=1
. I 'DA D Q ;add new member
.. N LAST S LAST=$O(^DIAC(1.6,DA(1),10,"AC",""),-1)\1 ;integer
.. S DIC="^DIAC(1.6,"_DA(1)_",10,",DIC(0)="AEQ",X=+ITM,DIC("DR")=".02//"_(LAST+1)
.. D FILE^DICN S DA=+Y
. S DR=".01;.02",DIE="^DIAC(1.6,"_DA(1)_",10," D ^DIE
;
L -^DIAC(1.6,DAD),-^DIAC(1.6,0)
I DIFF S ^TMP("DIACX",$J,+DAD)="" D INIT^DIACLM ;rebuild
Q
;
DIR() ; -- find member policy (return X & Y as if ^DIC)
N X,Y,DIR
S DIR(0)="FAO^3:30^D DIC^DIACLM1"
S DIR("A")="Select MEMBER: "
S DIR("?")="Enter a unique name, 3-30 characters, beginning with the package namespace"
S DIR("??")="^D MEMHLP^DIACLM1"
W ! D ^DIR
Q Y
;
DIC ; -- input transform to look up X in #1.6, return Y=ien^name[^1]
N DIC,DLAYGO,DA
S DIC=1.6,DIC(0)="ELQZ",DLAYGO=1.6,DA(1)=DAD
S DIC("S")="I $P(^(0),U,2)"_$S(TYPE="P":"=""R""",1:"'=""R"",'$$TREE^DIACX")
S DIC("DR")=$S(TYPE="P":".02////R",1:".02;I X=""R"" W !,""A Rule may not be a member of a set!"" S Y=.02")
D ^DIC I Y<1 K X Q
S X=$P(Y,U,2) ;return Y=ien^name[^1 if new]
Q
;
MEMHLP ; -- Xecutable help to show current members of policy DAD
N X,Y,D,DZ,DIC
S DIC="^DIAC(1.6,"_DAD_",10,",DIC(0)="EQ",D="B",DZ="??" D DQ^DICQ
W !?8,"You may enter a new MEMBER, if you wish."
W !?8,"Enter a policy, set, or rule that is not an ancestor of this item."
W !?8,"Members of a policy must be rules; sets may include policies or sets.",!
S DIC("S")="I $P(^(0),U,2)"_$S($G(TYPE)="P":"=",1:"'=")_"""R"""
S DIC="^DIAC(1.6,",X="?" K DZ D ^DIC
Q
;
EDIT ; -- edit item
N VALMY,DDSFILE,DDSPARM,DDSCHANG,DII,DA,DR,DIFF,DTOUT
D EN^VALM2(XQORNOD(0)) I '$O(VALMY(0)) S VALMBCK="" Q
D FULL^VALM1 S VALMBCK="R"
S DDSFILE=1.6,DDSPARM="C",DIFF=0
S DII=0 F S DII=$O(VALMY(DII)) Q:DII<1 D
. S DA=+$G(^TMP("DIAC",$J,"IEN",DII)) Q:DA<1
. L +^DIAC(1.6,DA):DILOCKTM I '$T W !,"Another user is editing #"_I H 2 Q
. S DR="[DIAC "_$$UP^XLFSTR($$GET1^DIQ(1.6,DA_",",.02))_"]" K DDSCHANG
. W !,"Loading form to edit #"_DII_" ..." H 1
. D ^DDS S:$G(DDSCHANG) DIFF=1 I '$G(DA) D ;deleted
.. S DA=+$G(^TMP("DIAC",$J,"IEN",DII)),DIFF=1 Q:DA<1
.. D DELDAD(DA) ;remove members
.. Q:DA'=+DITOP ;select a new policy to display, if needed
.. S DITOP=$$SELECT^DIACLM I DITOP<1 S VALMBCK="Q" Q
.. K VALMHDR,^TMP("DIACX",$J)
.. S VALMBCK="R",^TMP("DIACX",$J,+DITOP)=""
. L -^DIAC(1.6,DA)
D:DIFF INIT^DIACLM
Q
;
DELETE ; -- delete item
N DA S VALMBCK=""
S DA=+$$SELECT Q:DA<1
I $O(^DIAC(1.6,"AD",DA,0))!(DA=+DITOP) D FULL^VALM1 S VALMBCK="R"
D DEL Q:$D(^DIAC(1.6,DA,0)) ;quit - not deleted
S VALMBCK="R"
I DA=+DITOP D Q:VALMBCK="Q" ; select a new policy to display, if needed
. S DITOP=$$SELECT^DIACLM I DITOP<1 S VALMBCK="Q" Q
. K VALMHDR,^TMP("DIACX",$J)
. S VALMBCK="R",^TMP("DIACX",$J,+DITOP)=""
D INIT^DIACLM
Q
DEL ; enter here from option with DA
N DIK,DAD,DAC
I $O(^DIAC(1.6,"AD",DA,0)) D W !
. W !,$P($G(^DIAC(1.6,DA,0)),U)_" will also be removed as a member from:"
. S DAD=0 F S DAD=$O(^DIAC(1.6,"AD",DA,DAD)) Q:DAD<1 W !?3,$P(^DIAC(1.6,DAD,0),U)
I $O(^DIAC(1.61,"D",DA,0)) D W !
. W !,$P($G(^DIAC(1.6,DA,0)),U)_" will also be unlinked as a policy for:"
. S DAC=0 F S DAC=$O(^DIAC(1.61,"D",DA,DAC)) Q:DAC<1 W !?3,$P(^DIAC(1.61,DAC,0),U)
I '$$SURE(DA) W !,"Nothing deleted!" Q
L +^DIAC(1.6,0):DILOCKTM I '$T W !,"Another user is editing policies." H 2 Q
L +^DIAC(1.6,DA):DILOCKTM I '$T W !,"Another user is editing this policy." H 2 Q
S DIK="^DIAC(1.6," D ^DIK
L -^DIAC(1.6,DA)
D DELDAD(DA) ;clean up ancestors
D DELACT(DA) ;clean up actions
L -^DIAC(1.6,0)
Q
DELDAD(IEN) ; -- remove IEN as a member from parent policies
N DA,DIK,DAD S DAD=0
F S DAD=$O(^DIAC(1.6,"AD",+$G(IEN),DAD)) Q:DAD<1 S DA=+$O(^(DAD,0)) D
. L +^DIAC(1.6,DAD):DILOCKTM I '$T W !,"Another user is editing policy #"_DAD H 2 Q
. S DA(1)=DAD,DIK="^DIAC(1.6,"_DA(1)_",10,"
. D ^DIK
. L -^DIAC(1.6,DAD)
Q
DELACT(IEN) ; -- remove IEN as a policy for Application Actions
N DA,DIE,DR S DA=0
F S DA=$O(^DIAC(1.61,"D",+$G(IEN),DA)) Q:DA<1 D
. L +^DIAC(1.61,DA):DILOCKTM I '$T W !,"Another user is editing action #"_DA H 2 Q
. S DIE="^DIAC(1.61,",DR=".05////@"
. D ^DIE
. L -^DIAC(1.61,DA)
Q
;
SURE(IEN) ; -- are you sure?
N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="YA",DIR("A")="Are you sure? ",DIR("B")="NO"
S DIR("?",1)="Enter NO if you only want to remove this item as a member of a policy."
S DIR("?")="Enter YES to delete this item from the file"
I $G(IEN),$O(^DIAC(1.6,"AD",IEN,0)) S DIR("?")=DIR("?")_"; it will also be removed as a Member from its parent policies"
S DIR("?")=DIR("?")_".",DIR("?",2)=" "
D ^DIR
Q +Y
;
DISABLE ; -- disable item
D FULL^VALM1 S VALMBCK="R"
N DA S DA=+$$SELECT Q:DA<1
D DIS,INIT^DIACLM
Q
DIS ;enter here from option with DA
N X,Y,DIE,DR,DUOUT,DTOUT,DIRUT
W !!,"WARNING: Disabling a policy will prevent it and ALL its members from being"
W !,"processed when data access is being evaluated!",!
L +^DIAC(1.6,DA):DILOCKTM I '$T W !,"Another user is editing this policy." H 2 Q
S DIE="^DIAC(1.6,",DR=.03 D ^DIE
L -^DIAC(1.6,DA)
Q
;
EXPAND ; -- expand/collapse items
N I,VALMY,DA
D EN^VALM2(XQORNOD(0)) I '$O(VALMY(0)) S VALMBCK="" Q
S I=0 F S I=$O(VALMY(I)) Q:I<1 D
. S DA=+$G(^TMP("DIAC",$J,"IEN",I)) Q:DA<1
. Q:'$O(^DIAC(1.6,DA,10,0)) ;no members
. I $D(^TMP("DIACX",$J,DA)) K ^(DA)
. E S ^TMP("DIACX",$J,DA)=""
W !!,"Re-building the list..." H 1
D INIT^DIACLM S VALMBCK="R"
Q
;
DETAIL ; -- show details
N DA,DIC,DAD
S DIC="^DIAC(1.6,",VALMBCK=""
S DA=+$$SELECT Q:DA<1
W ! D FULL^VALM1,EN^DIQ
I $O(^DIAC(1.6,"AD",DA,0)) D
. W !,"MEMBER OF: "
. S DAD=0 F S DAD=$O(^DIAC(1.6,"AD",DA,DAD)) Q:DAD<1 W !?3,$P(^DIAC(1.6,DAD,0),U)
D WAIT S VALMBCK="R"
Q
;
CHANGE ; -- select a different policy/set to manage
S VALMBCK=""
N X S X=$$SELECT^DIACLM Q:X<1 Q:+X=+DITOP
K VALMHDR,^TMP("DIACX",$J)
S DITOP=X,VALMBCK="R",^TMP("DIACX",$J,+DITOP)=""
D INIT^DIACLM
Q
;
TYPE() ; -- select type
N X,Y,DIR
S DIR(0)="1.6,.02" D ^DIR
I Y?1U S Y=Y_U_Y(0)
Q Y
;
SELECT(PROMPT) ; -- select 1 item from list
N X,Y,DIR
S DIR("A")=$S($L($G(PROMPT)):PROMPT,1:"Select Item")_" (1-"_VALMCNT_"): "
S DIR(0)="NAO^1:"_VALMCNT D ^DIR
I Y S Y=$G(^TMP("DIAC",$J,"IEN",Y)) W " "_$P(Y,U,2)
E S Y=""
Q Y
;
WAIT ; -- hold screen
N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="E" D ^DIR
S VALMBCK=$S(Y="":"Q",1:"R")
Q
;
TEST ; -- test current policy
D EN^DIAC1T S VALMBCK="R"
Q
;
EXIT ; -- exit editor
S VALMBCK="Q"
Q
;
LINK ; -- link policy to actions
N X,Y,DLAYGO,DIC,DIE,DR,DA
I '$O(^DIAC(1.61,"D",+DITOP,0)) W !!,"No Application Actions are linked to "_$P(DITOP,U,2)_"."
E D
. W !!,"The following Application Actions are linked to policy "_$P(DITOP,U,2)_":"
. S Y=0 F S Y=$O(^DIAC(1.61,"D",+DITOP,Y)) Q:Y<1 D
.. S X=$G(^DIAC(1.61,Y,0))
.. W !?3,$P(X,U)_" "_$P(X,U,2)_" "_$P(X,U,3)
L +^DIAC(1.61,0):DILOCKTM I '$T W !,"Another user is editing Application Actions." H 2 Q
L1 ;loop back
S DIC=1.61,DIC(0)="AELMQ",DLAYGO=1.61,DIC("DR")=".02:.04;1"
W ! D ^DIC I Y<1 L -^DIAC(1.61,0) Q
S DIE=DIC,DA=+Y,DR=.05 D ^DIE
K X,Y,DR,VALMHDR
G L1
Q
;
ACTIONS ; -- edit Actions [Option]
N X,Y,DIC,DIE,DA,DR,DLAYGO
L +^DIAC(1.61,0):DILOCKTM I '$T W !,"Another user is editing Application Actions." H 2 Q
ACT1 ; loop back here
S DIC=1.61,DIC(0)="AEQL",DLAYGO=1.61,DIC("A")="Select APPLICATION ACTION: "
D ^DIC I Y<1 L -^DIAC(1.61,0) Q
S DA=+Y I '$P(Y,U,3) W ! D EN^DIQ ;display
S DIE=DIC,DR=".01:.04;1;5;I X="""" S Y="""";5.1" D ^DIE
K X,Y,DLAYGO,DIC,DIE,DA,DR
W ! G ACT1
Q
;
FCNS ; -- edit Functions
N X,Y,DIC,DIE,DA,DR,DLAYGO,TYPE
L +^DIAC(1.62,0):DILOCKTM I '$T W !,"Another user is editing Functions." H 2 Q
FC1 ; loop back here
S DIC=1.62,DIC(0)="AEQLZ",DLAYGO=1.62,DIC("A")="Select POLICY FUNCTION: "
D ^DIC I Y<1 L -^DIAC(1.62,0) Q
S TYPE=$P(Y(0),U,3)
S DA=+Y I '$P(Y,U,3) W ! D EN^DIQ ;display
I DA<1000 W $C(7),!,"VA FILEMAN functions are uneditable!"
E S DIE=DIC,DR=".01;.02;I X'=""R"" S Y=1;.04;1;2" D ^DIE K X,Y,DLAYGO,DIC,DR
I $G(DA),$$ASSIGN(TYPE) D ADDPOL(TYPE)
W !! G FC1
Q
;
ADDPOL(T) ; -- add a function to a policy
N X,Y,DIC,DA,DR,DIE,DONE,DIAT S DIAT=$G(T)
S DR=$S(DIAT="A":.04,DIAT="R":.07,DIAT="O":"7;8",DIAT="C":3,1:"")
S:DIAT="C" DIC("S")="I $P(^(0),U,2)=""R"""
S:DIAT="R" DIC("S")="I $P(^(0),U,2)'=""R"""
S DONE=0 F D Q:DONE
. S DIC=1.6,DIC(0)="AEQZ" W !
. D ^DIC I $G(Y)<1 S DONE=1 Q
. S DIE="^DIAC(1.6,",DA=+Y D ^DIE
D:DIAT="R" INIT^DIACLM
Q
;
ASSIGN(T) ; -- want to assign a function to a policy?
N X,Y,DIR,NAME S T=$G(T)
S NAME=$S(T="A":"ATTRIBUTE",T="R":"RESULT",T="O":"OBLIGATION",T="C":"CONDITION",1:"")
S DIR("?")="Enter YES to edit the "_NAME_" FUNCTION of selected policies"
S DIR("A")="Do you want to assign this "_NAME_" function to a policy? "
S DIR(0)="YAO" W ! D ^DIR
Q +Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIACLM1 10156 printed Apr 09, 2024@21:51:45 Page 2
DIACLM1 ;SLCISC/MKB - Policy Editor actions ;17FEB2017
+1 ;;22.2;VA FileMan;**8**;Jan 05, 2016;Build 19
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
ADD ; -- add/remove members
+1 NEW X,Y,DAD,TYPE,DONE,DIFF,ITM,DIE,DA,DR,DIC
SET VALMBCK=""
+2 LOCK +^DIAC(1.6,0):DILOCKTM
IF '$TEST
WRITE !,"Another user is editing policies."
HANG 2
QUIT
+3 IF VALMCNT=1
SET DAD=+$GET(^TMP("DIAC",$JOB,"IEN",1))
if DAD<1
QUIT
+4 IF '$TEST
SET DAD=+$$SELECT("To policy")
if DAD<1
QUIT
+5 IF $PIECE($GET(^DIAC(1.6,DAD,0)),U,2)="R"
WRITE !,"Rules may not have members.",!
HANG 2
QUIT
+6 LOCK +^DIAC(1.6,DAD):DILOCKTM
IF '$TEST
WRITE !,"Another user is editing "_$PIECE(DAD,U,2)
HANG 2
QUIT
+7 SET TYPE=$PIECE($GET(^DIAC(1.6,DAD,0)),U,2)
SET (DONE,DIFF)=0
+8 ;
+9 DO FULL^VALM1
SET VALMBCK="R"
+10 FOR
Begin DoDot:1
+11 SET ITM=$$DIR
IF ITM<1
SET DONE=1
QUIT
+12 ;deleted
IF $PIECE(ITM,U,3)
Begin DoDot:2
+13 SET DR=".01;2;I $P($G(^DIAC(1.6,+DA,2,0)),U,4)<2 S Y=""@1"";.05R;@1;"
+14 IF $GET(TYPE)="P"
SET DR=DR_"3;I $P($G(^DIAC(1.6,+DA,3,0)),U,4)<2 S Y=""@2"";.06R;@2;.08R;7.1;7;8.1;8"
+15 IF '$TEST
SET DR=DR_".07R;7.1;7;8.1;8"
+16 KILL DA,DIC
SET DIE="^DIAC(1.6,"
SET DA=+ITM
DO ^DIE
End DoDot:2
if '$DATA(DA)
QUIT
+17 ;
+18 KILL DA,DIC
SET DA=$ORDER(^DIAC(1.6,DAD,10,"B",+ITM,0))
SET DA(1)=+DAD
SET DIFF=1
+19 ;add new member
IF 'DA
Begin DoDot:2
+20 ;integer
NEW LAST
SET LAST=$ORDER(^DIAC(1.6,DA(1),10,"AC",""),-1)\1
+21 SET DIC="^DIAC(1.6,"_DA(1)_",10,"
SET DIC(0)="AEQ"
SET X=+ITM
SET DIC("DR")=".02//"_(LAST+1)
+22 DO FILE^DICN
SET DA=+Y
End DoDot:2
QUIT
+23 SET DR=".01;.02"
SET DIE="^DIAC(1.6,"_DA(1)_",10,"
DO ^DIE
End DoDot:1
if DONE
QUIT
+24 ;
+25 LOCK -^DIAC(1.6,DAD),-^DIAC(1.6,0)
+26 ;rebuild
IF DIFF
SET ^TMP("DIACX",$JOB,+DAD)=""
DO INIT^DIACLM
+27 QUIT
+28 ;
DIR() ; -- find member policy (return X & Y as if ^DIC)
+1 NEW X,Y,DIR
+2 SET DIR(0)="FAO^3:30^D DIC^DIACLM1"
+3 SET DIR("A")="Select MEMBER: "
+4 SET DIR("?")="Enter a unique name, 3-30 characters, beginning with the package namespace"
+5 SET DIR("??")="^D MEMHLP^DIACLM1"
+6 WRITE !
DO ^DIR
+7 QUIT Y
+8 ;
DIC ; -- input transform to look up X in #1.6, return Y=ien^name[^1]
+1 NEW DIC,DLAYGO,DA
+2 SET DIC=1.6
SET DIC(0)="ELQZ"
SET DLAYGO=1.6
SET DA(1)=DAD
+3 SET DIC("S")="I $P(^(0),U,2)"_$SELECT(TYPE="P":"=""R""",1:"'=""R"",'$$TREE^DIACX")
+4 SET DIC("DR")=$SELECT(TYPE="P":".02////R",1:".02;I X=""R"" W !,""A Rule may not be a member of a set!"" S Y=.02")
+5 DO ^DIC
IF Y<1
KILL X
QUIT
+6 ;return Y=ien^name[^1 if new]
SET X=$PIECE(Y,U,2)
+7 QUIT
+8 ;
MEMHLP ; -- Xecutable help to show current members of policy DAD
+1 NEW X,Y,D,DZ,DIC
+2 SET DIC="^DIAC(1.6,"_DAD_",10,"
SET DIC(0)="EQ"
SET D="B"
SET DZ="??"
DO DQ^DICQ
+3 WRITE !?8,"You may enter a new MEMBER, if you wish."
+4 WRITE !?8,"Enter a policy, set, or rule that is not an ancestor of this item."
+5 WRITE !?8,"Members of a policy must be rules; sets may include policies or sets.",!
+6 SET DIC("S")="I $P(^(0),U,2)"_$SELECT($GET(TYPE)="P":"=",1:"'=")_"""R"""
+7 SET DIC="^DIAC(1.6,"
SET X="?"
KILL DZ
DO ^DIC
+8 QUIT
+9 ;
EDIT ; -- edit item
+1 NEW VALMY,DDSFILE,DDSPARM,DDSCHANG,DII,DA,DR,DIFF,DTOUT
+2 DO EN^VALM2(XQORNOD(0))
IF '$ORDER(VALMY(0))
SET VALMBCK=""
QUIT
+3 DO FULL^VALM1
SET VALMBCK="R"
+4 SET DDSFILE=1.6
SET DDSPARM="C"
SET DIFF=0
+5 SET DII=0
FOR
SET DII=$ORDER(VALMY(DII))
if DII<1
QUIT
Begin DoDot:1
+6 SET DA=+$GET(^TMP("DIAC",$JOB,"IEN",DII))
if DA<1
QUIT
+7 LOCK +^DIAC(1.6,DA):DILOCKTM
IF '$TEST
WRITE !,"Another user is editing #"_I
HANG 2
QUIT
+8 SET DR="[DIAC "_$$UP^XLFSTR($$GET1^DIQ(1.6,DA_",",.02))_"]"
KILL DDSCHANG
+9 WRITE !,"Loading form to edit #"_DII_" ..."
HANG 1
+10 ;deleted
DO ^DDS
if $GET(DDSCHANG)
SET DIFF=1
IF '$GET(DA)
Begin DoDot:2
+11 SET DA=+$GET(^TMP("DIAC",$JOB,"IEN",DII))
SET DIFF=1
if DA<1
QUIT
+12 ;remove members
DO DELDAD(DA)
+13 ;select a new policy to display, if needed
if DA'=+DITOP
QUIT
+14 SET DITOP=$$SELECT^DIACLM
IF DITOP<1
SET VALMBCK="Q"
QUIT
+15 KILL VALMHDR,^TMP("DIACX",$JOB)
+16 SET VALMBCK="R"
SET ^TMP("DIACX",$JOB,+DITOP)=""
End DoDot:2
+17 LOCK -^DIAC(1.6,DA)
End DoDot:1
+18 if DIFF
DO INIT^DIACLM
+19 QUIT
+20 ;
DELETE ; -- delete item
+1 NEW DA
SET VALMBCK=""
+2 SET DA=+$$SELECT
if DA<1
QUIT
+3 IF $ORDER(^DIAC(1.6,"AD",DA,0))!(DA=+DITOP)
DO FULL^VALM1
SET VALMBCK="R"
+4 ;quit - not deleted
DO DEL
if $DATA(^DIAC(1.6,DA,0))
QUIT
+5 SET VALMBCK="R"
+6 ; select a new policy to display, if needed
IF DA=+DITOP
Begin DoDot:1
+7 SET DITOP=$$SELECT^DIACLM
IF DITOP<1
SET VALMBCK="Q"
QUIT
+8 KILL VALMHDR,^TMP("DIACX",$JOB)
+9 SET VALMBCK="R"
SET ^TMP("DIACX",$JOB,+DITOP)=""
End DoDot:1
if VALMBCK="Q"
QUIT
+10 DO INIT^DIACLM
+11 QUIT
DEL ; enter here from option with DA
+1 NEW DIK,DAD,DAC
+2 IF $ORDER(^DIAC(1.6,"AD",DA,0))
Begin DoDot:1
+3 WRITE !,$PIECE($GET(^DIAC(1.6,DA,0)),U)_" will also be removed as a member from:"
+4 SET DAD=0
FOR
SET DAD=$ORDER(^DIAC(1.6,"AD",DA,DAD))
if DAD<1
QUIT
WRITE !?3,$PIECE(^DIAC(1.6,DAD,0),U)
End DoDot:1
WRITE !
+5 IF $ORDER(^DIAC(1.61,"D",DA,0))
Begin DoDot:1
+6 WRITE !,$PIECE($GET(^DIAC(1.6,DA,0)),U)_" will also be unlinked as a policy for:"
+7 SET DAC=0
FOR
SET DAC=$ORDER(^DIAC(1.61,"D",DA,DAC))
if DAC<1
QUIT
WRITE !?3,$PIECE(^DIAC(1.61,DAC,0),U)
End DoDot:1
WRITE !
+8 IF '$$SURE(DA)
WRITE !,"Nothing deleted!"
QUIT
+9 LOCK +^DIAC(1.6,0):DILOCKTM
IF '$TEST
WRITE !,"Another user is editing policies."
HANG 2
QUIT
+10 LOCK +^DIAC(1.6,DA):DILOCKTM
IF '$TEST
WRITE !,"Another user is editing this policy."
HANG 2
QUIT
+11 SET DIK="^DIAC(1.6,"
DO ^DIK
+12 LOCK -^DIAC(1.6,DA)
+13 ;clean up ancestors
DO DELDAD(DA)
+14 ;clean up actions
DO DELACT(DA)
+15 LOCK -^DIAC(1.6,0)
+16 QUIT
DELDAD(IEN) ; -- remove IEN as a member from parent policies
+1 NEW DA,DIK,DAD
SET DAD=0
+2 FOR
SET DAD=$ORDER(^DIAC(1.6,"AD",+$GET(IEN),DAD))
if DAD<1
QUIT
SET DA=+$ORDER(^(DAD,0))
Begin DoDot:1
+3 LOCK +^DIAC(1.6,DAD):DILOCKTM
IF '$TEST
WRITE !,"Another user is editing policy #"_DAD
HANG 2
QUIT
+4 SET DA(1)=DAD
SET DIK="^DIAC(1.6,"_DA(1)_",10,"
+5 DO ^DIK
+6 LOCK -^DIAC(1.6,DAD)
End DoDot:1
+7 QUIT
DELACT(IEN) ; -- remove IEN as a policy for Application Actions
+1 NEW DA,DIE,DR
SET DA=0
+2 FOR
SET DA=$ORDER(^DIAC(1.61,"D",+$GET(IEN),DA))
if DA<1
QUIT
Begin DoDot:1
+3 LOCK +^DIAC(1.61,DA):DILOCKTM
IF '$TEST
WRITE !,"Another user is editing action #"_DA
HANG 2
QUIT
+4 SET DIE="^DIAC(1.61,"
SET DR=".05////@"
+5 DO ^DIE
+6 LOCK -^DIAC(1.61,DA)
End DoDot:1
+7 QUIT
+8 ;
SURE(IEN) ; -- are you sure?
+1 NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET DIR(0)="YA"
SET DIR("A")="Are you sure? "
SET DIR("B")="NO"
+3 SET DIR("?",1)="Enter NO if you only want to remove this item as a member of a policy."
+4 SET DIR("?")="Enter YES to delete this item from the file"
+5 IF $GET(IEN)
IF $ORDER(^DIAC(1.6,"AD",IEN,0))
SET DIR("?")=DIR("?")_"; it will also be removed as a Member from its parent policies"
+6 SET DIR("?")=DIR("?")_"."
SET DIR("?",2)=" "
+7 DO ^DIR
+8 QUIT +Y
+9 ;
DISABLE ; -- disable item
+1 DO FULL^VALM1
SET VALMBCK="R"
+2 NEW DA
SET DA=+$$SELECT
if DA<1
QUIT
+3 DO DIS
DO INIT^DIACLM
+4 QUIT
DIS ;enter here from option with DA
+1 NEW X,Y,DIE,DR,DUOUT,DTOUT,DIRUT
+2 WRITE !!,"WARNING: Disabling a policy will prevent it and ALL its members from being"
+3 WRITE !,"processed when data access is being evaluated!",!
+4 LOCK +^DIAC(1.6,DA):DILOCKTM
IF '$TEST
WRITE !,"Another user is editing this policy."
HANG 2
QUIT
+5 SET DIE="^DIAC(1.6,"
SET DR=.03
DO ^DIE
+6 LOCK -^DIAC(1.6,DA)
+7 QUIT
+8 ;
EXPAND ; -- expand/collapse items
+1 NEW I,VALMY,DA
+2 DO EN^VALM2(XQORNOD(0))
IF '$ORDER(VALMY(0))
SET VALMBCK=""
QUIT
+3 SET I=0
FOR
SET I=$ORDER(VALMY(I))
if I<1
QUIT
Begin DoDot:1
+4 SET DA=+$GET(^TMP("DIAC",$JOB,"IEN",I))
if DA<1
QUIT
+5 ;no members
if '$ORDER(^DIAC(1.6,DA,10,0))
QUIT
+6 IF $DATA(^TMP("DIACX",$JOB,DA))
KILL ^(DA)
+7 IF '$TEST
SET ^TMP("DIACX",$JOB,DA)=""
End DoDot:1
+8 WRITE !!,"Re-building the list..."
HANG 1
+9 DO INIT^DIACLM
SET VALMBCK="R"
+10 QUIT
+11 ;
DETAIL ; -- show details
+1 NEW DA,DIC,DAD
+2 SET DIC="^DIAC(1.6,"
SET VALMBCK=""
+3 SET DA=+$$SELECT
if DA<1
QUIT
+4 WRITE !
DO FULL^VALM1
DO EN^DIQ
+5 IF $ORDER(^DIAC(1.6,"AD",DA,0))
Begin DoDot:1
+6 WRITE !,"MEMBER OF: "
+7 SET DAD=0
FOR
SET DAD=$ORDER(^DIAC(1.6,"AD",DA,DAD))
if DAD<1
QUIT
WRITE !?3,$PIECE(^DIAC(1.6,DAD,0),U)
End DoDot:1
+8 DO WAIT
SET VALMBCK="R"
+9 QUIT
+10 ;
CHANGE ; -- select a different policy/set to manage
+1 SET VALMBCK=""
+2 NEW X
SET X=$$SELECT^DIACLM
if X<1
QUIT
if +X=+DITOP
QUIT
+3 KILL VALMHDR,^TMP("DIACX",$JOB)
+4 SET DITOP=X
SET VALMBCK="R"
SET ^TMP("DIACX",$JOB,+DITOP)=""
+5 DO INIT^DIACLM
+6 QUIT
+7 ;
TYPE() ; -- select type
+1 NEW X,Y,DIR
+2 SET DIR(0)="1.6,.02"
DO ^DIR
+3 IF Y?1U
SET Y=Y_U_Y(0)
+4 QUIT Y
+5 ;
SELECT(PROMPT) ; -- select 1 item from list
+1 NEW X,Y,DIR
+2 SET DIR("A")=$SELECT($LENGTH($GET(PROMPT)):PROMPT,1:"Select Item")_" (1-"_VALMCNT_"): "
+3 SET DIR(0)="NAO^1:"_VALMCNT
DO ^DIR
+4 IF Y
SET Y=$GET(^TMP("DIAC",$JOB,"IEN",Y))
WRITE " "_$PIECE(Y,U,2)
+5 IF '$TEST
SET Y=""
+6 QUIT Y
+7 ;
WAIT ; -- hold screen
+1 NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET DIR(0)="E"
DO ^DIR
+3 SET VALMBCK=$SELECT(Y="":"Q",1:"R")
+4 QUIT
+5 ;
TEST ; -- test current policy
+1 DO EN^DIAC1T
SET VALMBCK="R"
+2 QUIT
+3 ;
EXIT ; -- exit editor
+1 SET VALMBCK="Q"
+2 QUIT
+3 ;
LINK ; -- link policy to actions
+1 NEW X,Y,DLAYGO,DIC,DIE,DR,DA
+2 IF '$ORDER(^DIAC(1.61,"D",+DITOP,0))
WRITE !!,"No Application Actions are linked to "_$PIECE(DITOP,U,2)_"."
+3 IF '$TEST
Begin DoDot:1
+4 WRITE !!,"The following Application Actions are linked to policy "_$PIECE(DITOP,U,2)_":"
+5 SET Y=0
FOR
SET Y=$ORDER(^DIAC(1.61,"D",+DITOP,Y))
if Y<1
QUIT
Begin DoDot:2
+6 SET X=$GET(^DIAC(1.61,Y,0))
+7 WRITE !?3,$PIECE(X,U)_" "_$PIECE(X,U,2)_" "_$PIECE(X,U,3)
End DoDot:2
End DoDot:1
+8 LOCK +^DIAC(1.61,0):DILOCKTM
IF '$TEST
WRITE !,"Another user is editing Application Actions."
HANG 2
QUIT
L1 ;loop back
+1 SET DIC=1.61
SET DIC(0)="AELMQ"
SET DLAYGO=1.61
SET DIC("DR")=".02:.04;1"
+2 WRITE !
DO ^DIC
IF Y<1
LOCK -^DIAC(1.61,0)
QUIT
+3 SET DIE=DIC
SET DA=+Y
SET DR=.05
DO ^DIE
+4 KILL X,Y,DR,VALMHDR
+5 GOTO L1
+6 QUIT
+7 ;
ACTIONS ; -- edit Actions [Option]
+1 NEW X,Y,DIC,DIE,DA,DR,DLAYGO
+2 LOCK +^DIAC(1.61,0):DILOCKTM
IF '$TEST
WRITE !,"Another user is editing Application Actions."
HANG 2
QUIT
ACT1 ; loop back here
+1 SET DIC=1.61
SET DIC(0)="AEQL"
SET DLAYGO=1.61
SET DIC("A")="Select APPLICATION ACTION: "
+2 DO ^DIC
IF Y<1
LOCK -^DIAC(1.61,0)
QUIT
+3 ;display
SET DA=+Y
IF '$PIECE(Y,U,3)
WRITE !
DO EN^DIQ
+4 SET DIE=DIC
SET DR=".01:.04;1;5;I X="""" S Y="""";5.1"
DO ^DIE
+5 KILL X,Y,DLAYGO,DIC,DIE,DA,DR
+6 WRITE !
GOTO ACT1
+7 QUIT
+8 ;
FCNS ; -- edit Functions
+1 NEW X,Y,DIC,DIE,DA,DR,DLAYGO,TYPE
+2 LOCK +^DIAC(1.62,0):DILOCKTM
IF '$TEST
WRITE !,"Another user is editing Functions."
HANG 2
QUIT
FC1 ; loop back here
+1 SET DIC=1.62
SET DIC(0)="AEQLZ"
SET DLAYGO=1.62
SET DIC("A")="Select POLICY FUNCTION: "
+2 DO ^DIC
IF Y<1
LOCK -^DIAC(1.62,0)
QUIT
+3 SET TYPE=$PIECE(Y(0),U,3)
+4 ;display
SET DA=+Y
IF '$PIECE(Y,U,3)
WRITE !
DO EN^DIQ
+5 IF DA<1000
WRITE $CHAR(7),!,"VA FILEMAN functions are uneditable!"
+6 IF '$TEST
SET DIE=DIC
SET DR=".01;.02;I X'=""R"" S Y=1;.04;1;2"
DO ^DIE
KILL X,Y,DLAYGO,DIC,DR
+7 IF $GET(DA)
IF $$ASSIGN(TYPE)
DO ADDPOL(TYPE)
+8 WRITE !!
GOTO FC1
+9 QUIT
+10 ;
ADDPOL(T) ; -- add a function to a policy
+1 NEW X,Y,DIC,DA,DR,DIE,DONE,DIAT
SET DIAT=$GET(T)
+2 SET DR=$SELECT(DIAT="A":.04,DIAT="R":.07,DIAT="O":"7;8",DIAT="C":3,1:"")
+3 if DIAT="C"
SET DIC("S")="I $P(^(0),U,2)=""R"""
+4 if DIAT="R"
SET DIC("S")="I $P(^(0),U,2)'=""R"""
+5 SET DONE=0
FOR
Begin DoDot:1
+6 SET DIC=1.6
SET DIC(0)="AEQZ"
WRITE !
+7 DO ^DIC
IF $GET(Y)<1
SET DONE=1
QUIT
+8 SET DIE="^DIAC(1.6,"
SET DA=+Y
DO ^DIE
End DoDot:1
if DONE
QUIT
+9 if DIAT="R"
DO INIT^DIACLM
+10 QUIT
+11 ;
ASSIGN(T) ; -- want to assign a function to a policy?
+1 NEW X,Y,DIR,NAME
SET T=$GET(T)
+2 SET NAME=$SELECT(T="A":"ATTRIBUTE",T="R":"RESULT",T="O":"OBLIGATION",T="C":"CONDITION",1:"")
+3 SET DIR("?")="Enter YES to edit the "_NAME_" FUNCTION of selected policies"
+4 SET DIR("A")="Do you want to assign this "_NAME_" function to a policy? "
+5 SET DIR(0)="YAO"
WRITE !
DO ^DIR
+6 QUIT +Y
