USRAEDT ; SLC/JER - Business Rule Edit ;3/5/10
;;1.0;AUTHORIZATION/SUBSCRIPTION;**15,29,33**;Jun 20, 1997;Build 7
MAIN ; Controls branching
N DIC,DA,DIE,DR,DLAYGO,X,Y,DWPK,TIUFPRIV,USRY,USRI S TIUFPRIV=1
W !,"Please Enter or Edit a Business Rule:",!
S (DIC,DLAYGO)=8930.1,DIC(0)="AEMQL",DIC("A")="Select DOCUMENT DEFINITION: "
D ^DIC K DIC,DLAYGO Q:+Y'>0 S DA=+Y
S DIE=8930.1,DR="[USR DEFINE AUTHORIZATIONS]"
D ^DIE
I '$D(DA) W !!,"<Business Rule DELETED>" Q
W !!,"You defined the following rule:",!
D XLATE(.USRY,DA)
S USRI=0 F S USRI=$O(USRY(USRI)) Q:+USRI'>0 D
. W !?(2*USRI),USRY(USRI)
Q
XLATE(Y,DA) ; Translate business rule
N STATUS,USRCLASS,USROLE,USRD0,USRI
S USRD0=$G(^USR(8930.1,+DA,0))
S STATUS=$$STATUS(DA,USRD0),USRCLASS=$$CLASS(DA,USRD0)
S USROLE=$$ROLE(DA,USRD0)
S Y=$S($E(STATUS,1,2)="UN":"An",$E(STATUS,1)="A":"An",1:"A")
S Y=Y_" "_STATUS_" "
;**ID** was " may be "
S Y=Y_$$DOCUMENT(DA,USRD0)_" may "_$$ACTION(DA,USRD0)_" by "
S Y=Y_USRCLASS_$S($P(USRD0,U,5)="&":" who is also ",$P(USRD0,U,5)="!":" OR ",(($G(USRCLASS)'="")&($G(USROLE)'="")):" OR ",1:"")
S Y=Y_USROLE,Y=$$WRAP^USRLS(Y,75)
F USRI=1:1:$L(Y,"|") S Y(USRI)=$P(Y,"|",USRI)
Q
STATUS(DA,USRD0) ; to which status does the rule apply?
N Y
S Y=$P($G(^USR(8930.6,+$P(USRD0,U,2),0)),U)
Q $G(Y)
DOCUMENT(DA,USRD0) ; to which document does the rule apply?
N Y
S Y=$$DDHLEV($P($G(^TIU(8925.1,+USRD0,0)),U,4)) ;ICR 2321
S Y=Y_$$UP^XLFSTR($$PNAME^TIULC1(+USRD0)) ;ICR 2323
I $E(Y,$L(Y))="S" S Y=$E(Y,1,$L(Y)-1)
Q $G(Y)
DDHLEV(USRDTYP) ; External value of Document Definition Type
N USRY
S USRY=$S(USRDTYP="CL":"(CLASS) ",USRDTYP="DC":"(DOCUMENT CLASS) ",USRDTYP="DOC":"(TITLE) ",1:"")
Q $G(USRY)
ACTION(DA,USRD0) ; to which action does rule apply?
N Y,ACTNDA,NODE0
S ACTNDA=+$P(USRD0,U,3),NODE0=$G(^USR(8930.8,ACTNDA,0))
S Y=$P(NODE0,U,6) ;DOCMT VERB
ACTX Q $G(Y)
;
CLASS(DA,USRD0) ; to which user class does the rule apply?
N Y
;S Y=$$UP^XLFSTR($$CLNAME^USRLM($P(USRD0,U,4)))
S Y=$$UP^XLFSTR($$CLNAME^USRLM($P(USRD0,U,4),1)) ; Use .01 class name
; **ID** was "A ". Omit U to avoid "an User"
I $L(Y) S Y=$S("AEIO"[$E(Y):"an ",1:"a ")_Y
Q $G(Y)
ROLE(DA,USRD0) ; to which user role does the rule apply?
N Y,USRDA
S USRDA=$P(USRD0,U,6),Y=$P($G(^USR(8930.2,+USRDA,0)),U)
;**ID** changed A and An to lower case
I $L(Y) S Y=$S($E(Y)="A":"an ",$E(Y)="E":"an ",1:"a ")_Y
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HUSRAEDT 2449 printed Dec 13, 2024@01:38:39 Page 2
USRAEDT ; SLC/JER - Business Rule Edit ;3/5/10
+1 ;;1.0;AUTHORIZATION/SUBSCRIPTION;**15,29,33**;Jun 20, 1997;Build 7
MAIN ; Controls branching
+1 NEW DIC,DA,DIE,DR,DLAYGO,X,Y,DWPK,TIUFPRIV,USRY,USRI
SET TIUFPRIV=1
+2 WRITE !,"Please Enter or Edit a Business Rule:",!
+3 SET (DIC,DLAYGO)=8930.1
SET DIC(0)="AEMQL"
SET DIC("A")="Select DOCUMENT DEFINITION: "
+4 DO ^DIC
KILL DIC,DLAYGO
if +Y'>0
QUIT
SET DA=+Y
+5 SET DIE=8930.1
SET DR="[USR DEFINE AUTHORIZATIONS]"
+6 DO ^DIE
+7 IF '$DATA(DA)
WRITE !!,"<Business Rule DELETED>"
QUIT
+8 WRITE !!,"You defined the following rule:",!
+9 DO XLATE(.USRY,DA)
+10 SET USRI=0
FOR
SET USRI=$ORDER(USRY(USRI))
if +USRI'>0
QUIT
Begin DoDot:1
+11 WRITE !?(2*USRI),USRY(USRI)
End DoDot:1
+12 QUIT
XLATE(Y,DA) ; Translate business rule
+1 NEW STATUS,USRCLASS,USROLE,USRD0,USRI
+2 SET USRD0=$GET(^USR(8930.1,+DA,0))
+3 SET STATUS=$$STATUS(DA,USRD0)
SET USRCLASS=$$CLASS(DA,USRD0)
+4 SET USROLE=$$ROLE(DA,USRD0)
+5 SET Y=$SELECT($EXTRACT(STATUS,1,2)="UN":"An",$EXTRACT(STATUS,1)="A":"An",1:"A")
+6 SET Y=Y_" "_STATUS_" "
+7 ;**ID** was " may be "
+8 SET Y=Y_$$DOCUMENT(DA,USRD0)_" may "_$$ACTION(DA,USRD0)_" by "
+9 SET Y=Y_USRCLASS_$SELECT($PIECE(USRD0,U,5)="&":" who is also ",$PIECE(USRD0,U,5)="!":" OR ",(($GET(USRCLASS)'="")&($GET(USROLE)'="")):" OR ",1:"")
+10 SET Y=Y_USROLE
SET Y=$$WRAP^USRLS(Y,75)
+11 FOR USRI=1:1:$LENGTH(Y,"|")
SET Y(USRI)=$PIECE(Y,"|",USRI)
+12 QUIT
STATUS(DA,USRD0) ; to which status does the rule apply?
+1 NEW Y
+2 SET Y=$PIECE($GET(^USR(8930.6,+$PIECE(USRD0,U,2),0)),U)
+3 QUIT $GET(Y)
DOCUMENT(DA,USRD0) ; to which document does the rule apply?
+1 NEW Y
+2 ;ICR 2321
SET Y=$$DDHLEV($PIECE($GET(^TIU(8925.1,+USRD0,0)),U,4))
+3 ;ICR 2323
SET Y=Y_$$UP^XLFSTR($$PNAME^TIULC1(+USRD0))
+4 IF $EXTRACT(Y,$LENGTH(Y))="S"
SET Y=$EXTRACT(Y,1,$LENGTH(Y)-1)
+5 QUIT $GET(Y)
DDHLEV(USRDTYP) ; External value of Document Definition Type
+1 NEW USRY
+2 SET USRY=$SELECT(USRDTYP="CL":"(CLASS) ",USRDTYP="DC":"(DOCUMENT CLASS) ",USRDTYP="DOC":"(TITLE) ",1:"")
+3 QUIT $GET(USRY)
ACTION(DA,USRD0) ; to which action does rule apply?
+1 NEW Y,ACTNDA,NODE0
+2 SET ACTNDA=+$PIECE(USRD0,U,3)
SET NODE0=$GET(^USR(8930.8,ACTNDA,0))
+3 ;DOCMT VERB
SET Y=$PIECE(NODE0,U,6)
ACTX QUIT $GET(Y)
+1 ;
CLASS(DA,USRD0) ; to which user class does the rule apply?
+1 NEW Y
+2 ;S Y=$$UP^XLFSTR($$CLNAME^USRLM($P(USRD0,U,4)))
+3 ; Use .01 class name
SET Y=$$UP^XLFSTR($$CLNAME^USRLM($PIECE(USRD0,U,4),1))
+4 ; **ID** was "A ". Omit U to avoid "an User"
+5 IF $LENGTH(Y)
SET Y=$SELECT("AEIO"[$EXTRACT(Y):"an ",1:"a ")_Y
+6 QUIT $GET(Y)
ROLE(DA,USRD0) ; to which user role does the rule apply?
+1 NEW Y,USRDA
+2 SET USRDA=$PIECE(USRD0,U,6)
SET Y=$PIECE($GET(^USR(8930.2,+USRDA,0)),U)
+3 ;**ID** changed A and An to lower case
+4 IF $LENGTH(Y)
SET Y=$SELECT($EXTRACT(Y)="A":"an ",$EXTRACT(Y)="E":"an ",1:"a ")_Y
+5 QUIT Y
