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

DIACLM1.m

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