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