USRRULA ; SLC/JER - Rule Browser actions ;2/6/98 17:12
;;1.0;AUTHORIZATION/SUBSCRIPTION;**3,28,29,37**;Sep 25, 2015;Build 31
;Per VA Directive 6402, this routine should not be modified
;
; External References DBIA#
; POSTX^HMPEVNT 6301
;
EDIT ; Edit an existing rule
N DUP,REDIT,USRDA,USRI,DIROUT,USRCHNG,USRLST,USRRBLD,SAVEDATA
I '$D(VALMY) D EN^VALM2(XQORNOD(0))
S (USRCHNG,USRI)=0
F S USRI=$O(VALMY(USRI)) Q:+USRI'>0 D Q:$D(DIROUT)
. S USRDA=+$O(^TMP("USRRUL",$J,"INDEX",USRI,0)) Q:+USRDA'>0
. W !!,"Editing #",+USRI,!
. S SAVEDATA=$G(^USR(8930.1,USRDA,0))
. D EDIT1
. I +$G(USRCHNG) S USRLST=$S($L($G(USRLST)):$G(USRLST)_", ",1:"")_USRI
I $G(DUP) D
. S ^USR(8930.1,USRDA,0)=$G(SAVEDATA)
. S VALMSG="** Item Not Edited - Duplicate of Another Rule **"
W !,"Refreshing the list."
I $L($G(USRLST)) D
. S USRRBLD=$P($G(@VALMAR@(0)),U,1,4) D INIT^USRRUL,HDR^USRRUL
K VALMY S VALMBCK="R"
I $G(DUP) Q
I '$G(REDIT) S VALMSG="** "_$S($L($G(USRLST)):"Item"_$S($L($G(USRLST),",")>1:"s ",1:" ")_$G(USRLST),1:"Nothing")_" Edited **"
Q
EDIT1 ; Single record edit
; Receives USRDA
N DA,DIE,DR
I '+$G(USRDA) W !,"No Classes selected." H 2 S USRCHNG=0 Q
S DIE="^USR(8930.1,",DA=USRDA,DR="[USR DEFINE AUTHORIZATIONS]"
D FULL^VALM1,^DIE S USRCHNG=1
D POSTX^HMPEVNT("asu-rule",DA) ;DBIA 6301
I '$D(DA) W !!,"<Business Rule DELETED>" H 3 Q
S XUSRQ=^USR(8930.1,+DA,0),REDIT=0
I $P(XUSRQ,"^",1)=""!($P(XUSRQ,"^",2)="")!($P(XUSRQ,"^",3)="")!(($P(XUSRQ,"^",4)="")&($P(XUSRQ,"^",6)="")) D Q
. S ^USR(8930.1,USRDA,0)=$G(SAVEDATA)
. S VALMSG="** Item Not Edited - Required Fields Missing **" S REDIT=1 Q
I $P(XUSRQ,"^",5)'="" D
. I $P(XUSRQ,"^",4)="" D Q
. . S ($P(XUSRQ,"^",5),$P(^USR(8930.1,+DA,0),"^",5))=""
. . S VALMSG="**USER CLASS REQ with AND FLAG -AND FLAG Removed**" S REDIT=1 Q
. I $P(XUSRQ,"^",6)="" D Q
. . S ($P(XUSRQ,"^",5),$P(^USR(8930.1,+DA,0),"^",5))=""
. . S VALMSG="**USER ROLE REQ with AND FLAG -AND FLAG Removed**" S REDIT=1 Q
S DUP=$$DUP
Q
ADD ; Add a member to the class
N DA,DR,DIC,DIK,DLAYGO,DUP,X,Y,USRRBLD,USRCNT,XUSRQ D FULL^VALM1
W !,"Please Enter a New Business Rule:",!
S (DIC,DLAYGO)=8930.1,DIC(0)="NL",X=$$DOCPICK
Q:+X'>0
S X=""""_"`"_+X_""""
D ^DIC K DLAYGO Q:+Y'>0 S DA=+Y
S DIE=8930.1,DR="[USR DEFINE AUTHORIZATIONS]"
D ^DIE
I $D(DA) D POSTX^HMPEVNT("asu-rule",DA) ;DBIA 6301
I '$D(DA) S VALMSG="<Business Rule DELETED>" Q
S DIK="^USR(8930.1,"
S XUSRQ=^USR(8930.1,+DA,0)
I $P(XUSRQ,"^",1)=""!($P(XUSRQ,"^",2)="")!($P(XUSRQ,"^",3)="")!(($P(XUSRQ,"^",4)="")&($P(XUSRQ,"^",6)="")) D Q
. S VALMSG="** Item Deleted - Required Fields Missing **"
. D ^DIK
K DIK
S DUP=$$DUP
S USRCNT=+$P($G(@VALMAR@(0)),U,5)
I +USRCNT D
. I 'DUP D ADD^USRRUL(DA)
. S $P(@VALMAR@(0),U,5)=+USRCNT D HDR^USRRUL I 1
E S USRRBLD=$P($G(@VALMAR@(0)),U,1,4) D INIT^USRRUL,HDR^USRRUL
S USRCNT=+$P($G(@VALMAR@(0)),U,5)
S $P(@VALMAR@("#"),":",2)=+USRCNT
S USRCHNG=1,VALMBCK="R"
I $G(DUP) D Q
. S DIK="^USR(8930.1,"
. D ^DIK
. K DIK
. S VALMSG="** Item Deleted - Duplicate Rule **" Q
S VALMSG="** Item "_+USRCNT_" Added **"
Q
DOCPICK() ; Function to pick a document for which rule will be created
N DIC,X,Y
; I +$G(^TMP("USRRUL",$J,0))
S DIC=8925.1,DIC(0)="AEMQ",DIC("A")="Select DOCUMENT DEFINITION: "
S DIC("S")="I +$$CANPICK^TIULP(+Y),$S($P($G(^TIU(8925.1,+Y,0)),U,4)=""CO"":0,$P($G(^TIU(8925.1,+Y,0)),U,4)=""O"":0,$P($G(^TIU(8925.1,+Y,0)),U)[""ADDENDUM"":0,1:1)"
D ^DIC K DIC("S")
Q Y
;
DUP() ; Function to determine if new or edited rule is a duplicate of an existing rule
N DHIT,XDA,XDATA,DIK
S (DHIT,XDA)=0 F S XDA=$O(^USR(8930.1,XDA)) Q:XDA="" Q:+XDA'>0 D Q:DHIT
. I XDA=+DA Q
. S XDATA=$G(^USR(8930.1,XDA,0))
. I $P($G(^USR(8930.1,+DA,0)),"^",1,4)=$P($G(XDATA),"^",1,4)&($P($G(^USR(8930.1,+DA,0)),"^",6)=$P($G(XDATA),"^",6)) D
. . I $P($G(^USR(8930.1,+DA,0)),"^",5)=$P($G(XDATA),"^",5) S DHIT=1 Q
. . I $P($G(^USR(8930.1,+DA,0)),"^",5)="",$P($G(XDATA),"^",5)="!" S DHIT=1 Q
. . I $P($G(^USR(8930.1,+DA,0)),"^",5)="!",$P($G(XDATA),"^",5)="" S DHIT=1 Q
Q DHIT
;
DELETE ; Delete a member to the class
N USRDA,USRCHNG,USRI,USRLST,DIE,X,Y,USRRBLD K DIROUT
D FULL^VALM1
I '$D(VALMY) D EN^VALM2(XQORNOD(0))
S USRI=0
F S USRI=$O(VALMY(USRI)) Q:+USRI'>0 D Q:$D(DIROUT)
. S USRDA=+$O(^TMP("USRRUL",$J,"INDEX",USRI,0)) Q:+USRDA'>0
. W !!,"Deleting #",+USRI,!
. D DELETE1(USRDA),POSTX^HMPEVNT("asu-rule",USRDA,"@") ;DBIA 6301
. S:+USRCHNG USRLST=$S(+$G(USRLST):USRLST_", ",1:"")_+USRI
I +$G(USRLST) D
. S USRRBLD=$P($G(@VALMAR@(0)),U,1,4) D INIT^USRRUL,HDR^USRRUL
K VALMY S VALMBCK="R"
S VALMSG="** "_$S($L($G(USRLST)):"Item"_$S($L($G(USRLST),",")>1:"s ",1:" ")_$G(USRLST),1:"Nothing")_" deleted **"
Q
DELETE1(DA) ; Delete one member from a class
N DIE,DR,USRI,USRULE D XLATE^USRAEDT(.USRULE,+DA)
I $G(USRULE)']"" W !,"Record #",DA," NOT FOUND!" Q
W !,"Removing the rule:",!
F USRI=1:1:$L(USRULE,"|") W !,$P(USRULE,"|",USRI)
W !
I '$$READ^USRU("Y","Are you SURE","NO") S USRCHNG=0 W !,"Business Rule NOT Removed." Q
W !,"Deleting Business Rule"
S USRCHNG=1
S DIK="^USR(8930.1," D ^DIK K DIK W "."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HUSRRULA 5268 printed Dec 13, 2024@01:39:05 Page 2
USRRULA ; SLC/JER - Rule Browser actions ;2/6/98 17:12
+1 ;;1.0;AUTHORIZATION/SUBSCRIPTION;**3,28,29,37**;Sep 25, 2015;Build 31
+2 ;Per VA Directive 6402, this routine should not be modified
+3 ;
+4 ; External References DBIA#
+5 ; POSTX^HMPEVNT 6301
+6 ;
EDIT ; Edit an existing rule
+1 NEW DUP,REDIT,USRDA,USRI,DIROUT,USRCHNG,USRLST,USRRBLD,SAVEDATA
+2 IF '$DATA(VALMY)
DO EN^VALM2(XQORNOD(0))
+3 SET (USRCHNG,USRI)=0
+4 FOR
SET USRI=$ORDER(VALMY(USRI))
if +USRI'>0
QUIT
Begin DoDot:1
+5 SET USRDA=+$ORDER(^TMP("USRRUL",$JOB,"INDEX",USRI,0))
if +USRDA'>0
QUIT
+6 WRITE !!,"Editing #",+USRI,!
+7 SET SAVEDATA=$GET(^USR(8930.1,USRDA,0))
+8 DO EDIT1
+9 IF +$GET(USRCHNG)
SET USRLST=$SELECT($LENGTH($GET(USRLST)):$GET(USRLST)_", ",1:"")_USRI
End DoDot:1
if $DATA(DIROUT)
QUIT
+10 IF $GET(DUP)
Begin DoDot:1
+11 SET ^USR(8930.1,USRDA,0)=$GET(SAVEDATA)
+12 SET VALMSG="** Item Not Edited - Duplicate of Another Rule **"
End DoDot:1
+13 WRITE !,"Refreshing the list."
+14 IF $LENGTH($GET(USRLST))
Begin DoDot:1
+15 SET USRRBLD=$PIECE($GET(@VALMAR@(0)),U,1,4)
DO INIT^USRRUL
DO HDR^USRRUL
End DoDot:1
+16 KILL VALMY
SET VALMBCK="R"
+17 IF $GET(DUP)
QUIT
+18 IF '$GET(REDIT)
SET VALMSG="** "_$SELECT($LENGTH($GET(USRLST)):"Item"_$SELECT($LENGTH($GET(USRLST),",")>1:"s ",1:" ")_$GET(USRLST),1:"Nothing")_" Edited **"
+19 QUIT
EDIT1 ; Single record edit
+1 ; Receives USRDA
+2 NEW DA,DIE,DR
+3 IF '+$GET(USRDA)
WRITE !,"No Classes selected."
HANG 2
SET USRCHNG=0
QUIT
+4 SET DIE="^USR(8930.1,"
SET DA=USRDA
SET DR="[USR DEFINE AUTHORIZATIONS]"
+5 DO FULL^VALM1
DO ^DIE
SET USRCHNG=1
+6 ;DBIA 6301
DO POSTX^HMPEVNT("asu-rule",DA)
+7 IF '$DATA(DA)
WRITE !!,"<Business Rule DELETED>"
HANG 3
QUIT
+8 SET XUSRQ=^USR(8930.1,+DA,0)
SET REDIT=0
+9 IF $PIECE(XUSRQ,"^",1)=""!($PIECE(XUSRQ,"^",2)="")!($PIECE(XUSRQ,"^",3)="")!(($PIECE(XUSRQ,"^",4)="")&($PIECE(XUSRQ,"^",6)=""))
Begin DoDot:1
+10 SET ^USR(8930.1,USRDA,0)=$GET(SAVEDATA)
+11 SET VALMSG="** Item Not Edited - Required Fields Missing **"
SET REDIT=1
QUIT
End DoDot:1
QUIT
+12 IF $PIECE(XUSRQ,"^",5)'=""
Begin DoDot:1
+13 IF $PIECE(XUSRQ,"^",4)=""
Begin DoDot:2
+14 SET ($PIECE(XUSRQ,"^",5),$PIECE(^USR(8930.1,+DA,0),"^",5))=""
+15 SET VALMSG="**USER CLASS REQ with AND FLAG -AND FLAG Removed**"
SET REDIT=1
QUIT
End DoDot:2
QUIT
+16 IF $PIECE(XUSRQ,"^",6)=""
Begin DoDot:2
+17 SET ($PIECE(XUSRQ,"^",5),$PIECE(^USR(8930.1,+DA,0),"^",5))=""
+18 SET VALMSG="**USER ROLE REQ with AND FLAG -AND FLAG Removed**"
SET REDIT=1
QUIT
End DoDot:2
QUIT
End DoDot:1
+19 SET DUP=$$DUP
+20 QUIT
ADD ; Add a member to the class
+1 NEW DA,DR,DIC,DIK,DLAYGO,DUP,X,Y,USRRBLD,USRCNT,XUSRQ
DO FULL^VALM1
+2 WRITE !,"Please Enter a New Business Rule:",!
+3 SET (DIC,DLAYGO)=8930.1
SET DIC(0)="NL"
SET X=$$DOCPICK
+4 if +X'>0
QUIT
+5 SET X=""""_"`"_+X_""""
+6 DO ^DIC
KILL DLAYGO
if +Y'>0
QUIT
SET DA=+Y
+7 SET DIE=8930.1
SET DR="[USR DEFINE AUTHORIZATIONS]"
+8 DO ^DIE
+9 ;DBIA 6301
IF $DATA(DA)
DO POSTX^HMPEVNT("asu-rule",DA)
+10 IF '$DATA(DA)
SET VALMSG="<Business Rule DELETED>"
QUIT
+11 SET DIK="^USR(8930.1,"
+12 SET XUSRQ=^USR(8930.1,+DA,0)
+13 IF $PIECE(XUSRQ,"^",1)=""!($PIECE(XUSRQ,"^",2)="")!($PIECE(XUSRQ,"^",3)="")!(($PIECE(XUSRQ,"^",4)="")&($PIECE(XUSRQ,"^",6)=""))
Begin DoDot:1
+14 SET VALMSG="** Item Deleted - Required Fields Missing **"
+15 DO ^DIK
End DoDot:1
QUIT
+16 KILL DIK
+17 SET DUP=$$DUP
+18 SET USRCNT=+$PIECE($GET(@VALMAR@(0)),U,5)
+19 IF +USRCNT
Begin DoDot:1
+20 IF 'DUP
DO ADD^USRRUL(DA)
+21 SET $PIECE(@VALMAR@(0),U,5)=+USRCNT
DO HDR^USRRUL
IF 1
End DoDot:1
+22 IF '$TEST
SET USRRBLD=$PIECE($GET(@VALMAR@(0)),U,1,4)
DO INIT^USRRUL
DO HDR^USRRUL
+23 SET USRCNT=+$PIECE($GET(@VALMAR@(0)),U,5)
+24 SET $PIECE(@VALMAR@("#"),":",2)=+USRCNT
+25 SET USRCHNG=1
SET VALMBCK="R"
+26 IF $GET(DUP)
Begin DoDot:1
+27 SET DIK="^USR(8930.1,"
+28 DO ^DIK
+29 KILL DIK
+30 SET VALMSG="** Item Deleted - Duplicate Rule **"
QUIT
End DoDot:1
QUIT
+31 SET VALMSG="** Item "_+USRCNT_" Added **"
+32 QUIT
DOCPICK() ; Function to pick a document for which rule will be created
+1 NEW DIC,X,Y
+2 ; I +$G(^TMP("USRRUL",$J,0))
+3 SET DIC=8925.1
SET DIC(0)="AEMQ"
SET DIC("A")="Select DOCUMENT DEFINITION: "
+4 SET DIC("S")="I +$$CANPICK^TIULP(+Y),$S($P($G(^TIU(8925.1,+Y,0)),U,4)=""CO"":0,$P($G(^TIU(8925.1,+Y,0)),U,4)=""O"":0,$P($G(^TIU(8925.1,+Y,0)),U)[""ADDENDUM"":0,1:1)"
+5 DO ^DIC
KILL DIC("S")
+6 QUIT Y
+7 ;
DUP() ; Function to determine if new or edited rule is a duplicate of an existing rule
+1 NEW DHIT,XDA,XDATA,DIK
+2 SET (DHIT,XDA)=0
FOR
SET XDA=$ORDER(^USR(8930.1,XDA))
if XDA=""
QUIT
if +XDA'>0
QUIT
Begin DoDot:1
+3 IF XDA=+DA
QUIT
+4 SET XDATA=$GET(^USR(8930.1,XDA,0))
+5 IF $PIECE($GET(^USR(8930.1,+DA,0)),"^",1,4)=$PIECE($GET(XDATA),"^",1,4)&($PIECE($GET(^USR(8930.1,+DA,0)),"^",6)=$PIECE($GET(XDATA),"^",6))
Begin DoDot:2
+6 IF $PIECE($GET(^USR(8930.1,+DA,0)),"^",5)=$PIECE($GET(XDATA),"^",5)
SET DHIT=1
QUIT
+7 IF $PIECE($GET(^USR(8930.1,+DA,0)),"^",5)=""
IF $PIECE($GET(XDATA),"^",5)="!"
SET DHIT=1
QUIT
+8 IF $PIECE($GET(^USR(8930.1,+DA,0)),"^",5)="!"
IF $PIECE($GET(XDATA),"^",5)=""
SET DHIT=1
QUIT
End DoDot:2
End DoDot:1
if DHIT
QUIT
+9 QUIT DHIT
+10 ;
DELETE ; Delete a member to the class
+1 NEW USRDA,USRCHNG,USRI,USRLST,DIE,X,Y,USRRBLD
KILL DIROUT
+2 DO FULL^VALM1
+3 IF '$DATA(VALMY)
DO EN^VALM2(XQORNOD(0))
+4 SET USRI=0
+5 FOR
SET USRI=$ORDER(VALMY(USRI))
if +USRI'>0
QUIT
Begin DoDot:1
+6 SET USRDA=+$ORDER(^TMP("USRRUL",$JOB,"INDEX",USRI,0))
if +USRDA'>0
QUIT
+7 WRITE !!,"Deleting #",+USRI,!
+8 ;DBIA 6301
DO DELETE1(USRDA)
DO POSTX^HMPEVNT("asu-rule",USRDA,"@")
+9 if +USRCHNG
SET USRLST=$SELECT(+$GET(USRLST):USRLST_", ",1:"")_+USRI
End DoDot:1
if $DATA(DIROUT)
QUIT
+10 IF +$GET(USRLST)
Begin DoDot:1
+11 SET USRRBLD=$PIECE($GET(@VALMAR@(0)),U,1,4)
DO INIT^USRRUL
DO HDR^USRRUL
End DoDot:1
+12 KILL VALMY
SET VALMBCK="R"
+13 SET VALMSG="** "_$SELECT($LENGTH($GET(USRLST)):"Item"_$SELECT($LENGTH($GET(USRLST),",")>1:"s ",1:" ")_$GET(USRLST),1:"Nothing")_" deleted **"
+14 QUIT
DELETE1(DA) ; Delete one member from a class
+1 NEW DIE,DR,USRI,USRULE
DO XLATE^USRAEDT(.USRULE,+DA)
+2 IF $GET(USRULE)']""
WRITE !,"Record #",DA," NOT FOUND!"
QUIT
+3 WRITE !,"Removing the rule:",!
+4 FOR USRI=1:1:$LENGTH(USRULE,"|")
WRITE !,$PIECE(USRULE,"|",USRI)
+5 WRITE !
+6 IF '$$READ^USRU("Y","Are you SURE","NO")
SET USRCHNG=0
WRITE !,"Business Rule NOT Removed."
QUIT
+7 WRITE !,"Deleting Business Rule"
+8 SET USRCHNG=1
+9 SET DIK="^USR(8930.1,"
DO ^DIK
KILL DIK
WRITE "."
+10 QUIT
