USRPS24 ; SLC/MAM - After installing TIU*1.0*165;6/18/03
;;1.0;AUTHORIZATION/SUBSCRIPTION;**24**;Jun 20, 1997
; Run this after installing patch 165.
;Use option: TIU165 DDEFS & RULES, PRF
;
MAIN ; Create new User Class & new Business Rules
; -- Check for potential dup User Class created after install
; but before option:
K ^TMP("USR24",$J)
D SETXTMP^USREN24
N USRDUPS,TMPCNT,SILENT
S TMPCNT=0
S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)=""
S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)=" ***** User Class and Rules for PATIENT RECORD FLAGS *****"
S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)=""
S SILENT=1
S USRDUPS=$$USRDUPS^USREN24(SILENT)
I $G(USRDUPS) D G MAINX
. S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)="Duplicate problem. See description for patch TIU*1*165,"
. S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)="in the National Patch Module."
N DONE,SUCCESS
; -- If User Class previously created by this patch,
; say so and quit:
S DONE=+$G(^XTMP("USR24","DONE"))
I DONE>0 D G MAINX
. S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)="User Class and, presumably, Business Rules"
. S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)=" were already created in a previous install."
; -- Create new User Class:
D NEWCLASS(.SUCCESS,.TMPCNT)
; -- Create new Business Rules:
I SUCCESS D NEWRULES(.TMPCNT)
MAINX ; Exit
S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)=""
S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)=" *********"
Q
;
NEWCLASS(SUCCESS,TMPCNT) ; Create one new User Class in file 8930
N FDA,USRIEN,CLASSDA
S SUCCESS=1
; -- Create new User Class:
M FDA(8930,"+1,")=^XTMP("USR24","USRCLAS")
D UPDATE^DIE("E","FDA","USRIEN")
S CLASSDA=+$G(USRIEN(1))
I CLASSDA'>0 D Q
. S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)="Couldn't create a User Class named "_^XTMP("USR24","USRCLAS",.01)_"."
. S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)=" Please contact National VistA Support."
. S SUCCESS=0
S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)="User Class named "_^XTMP("USR24","USRCLAS",.01)
S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)=" created successfully."
; -- Set "DONE" node to IEN:
S ^XTMP("USR24","DONE")=CLASSDA
Q
;
NEWRULES(TMPCNT) ; Create new Business Rule
; Create rule for ONE User Class & ONE DDEF
; -- Set data for rule:
D SETDATA(.TMPCNT)
N NUM,SUCCESS
S SUCCESS=1,NUM=0
; -- Loop through numbered list of rules (one, in this case):
I '$O(^XTMP("USR24","RULES",0)) S SUCCESS=0 Q
F S NUM=$O(^XTMP("USR24","RULES",NUM)) Q:'NUM D
. N USRERR,FDA,DESC
. M FDA(8930.1,"+1,")=^XTMP("USR24","RULES",NUM)
. M DESC=^XTMP("USR24","RULESDESC")
. S FDA(8930.1,"+1,",1)="DESC"
. D UPDATE^DIE("","FDA","","USRERR")
. I $D(USRERR) S SUCCESS=0 Q
. K ^XTMP("USR24","RULES",NUM)
K ^XTMP("USR24","RULESDESC")
I '$G(SUCCESS) D Q
. S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)=""
. S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)="Problem creating Business Rule. Please contact National VistA Support."
S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)=""
S TMPCNT=TMPCNT+1,^TMP("USR24",$J,TMPCNT)="Business Rule created successfully."
Q
;
SETDATA(TMPCNT) ; Set data for rule
; -- Set data for exported Rule into Rule node of ^XTMP.
; Use interior data since there may be dup DDEF names.
; Must set AFTER User Class is created:
N DDEFIEN,USRCLASS,EXACTION,INACTION,EXSTATUS,INSTATUS
; -- Get IEN of DDEF Number 1. (DDEF Number 1 is DC,
; PATIENT RECORD FLAG CAT I. See ^TIUEN165.)
S DDEFIEN=$G(^XTMP("TIU165","BASICS",1,"DONE"))
I DDEFIEN'>0 D G SETX
. S TMPCNT=TMPCNT+1,^TMP("USR23",$J,TMPCNT)=""
. S TMPCNT=TMPCNT+1,^TMP("USR23",$J,TMPCNT)="Can't find Document Definition for rules. Contact National VistA Support."
; -- Get IEN of User Class created earlier:
S USRCLASS=+$G(^XTMP("USR24","DONE"))
; -- Set data for flds .01 (DDEF) and .04 (User Class) for rule:
S ^XTMP("USR24","RULES",1,.01)=DDEFIEN
S ^XTMP("USR24","RULES",1,.04)=USRCLASS
; -- Set rule desc data:
S ^XTMP("USR24","RULESDESC",1)="This rule limits note entry to persons specially trained to assign and"
S ^XTMP("USR24","RULESDESC",2)="document the assignment of Category I Patient Record Flags."
S ^XTMP("USR24","RULESDESC",3)="Sites must not alter or delete this User Class."
S ^XTMP("USR24","RULESDESC",4)="Sites must not alter, delete, or override this rule."
S ^XTMP("USR24","RULESDESC",5)="Rule created by patch USR*1*24."
; -- Set action and status data for rule:
S EXACTION="ENTRY"
S INACTION=$O(^USR(8930.8,"B",EXACTION,0))
S ^XTMP("USR24","RULES",1,.03)=INACTION
S EXSTATUS="UNTRANSCRIBED"
S INSTATUS=$O(^USR(8930.6,"B",EXSTATUS,0))
S ^XTMP("USR24","RULES",1,.02)=INSTATUS
SETX ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HUSRPS24 4768 printed Sep 23, 2025@19:15:01 Page 2
USRPS24 ; SLC/MAM - After installing TIU*1.0*165;6/18/03
+1 ;;1.0;AUTHORIZATION/SUBSCRIPTION;**24**;Jun 20, 1997
+2 ; Run this after installing patch 165.
+3 ;Use option: TIU165 DDEFS & RULES, PRF
+4 ;
MAIN ; Create new User Class & new Business Rules
+1 ; -- Check for potential dup User Class created after install
+2 ; but before option:
+3 KILL ^TMP("USR24",$JOB)
+4 DO SETXTMP^USREN24
+5 NEW USRDUPS,TMPCNT,SILENT
+6 SET TMPCNT=0
+7 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)=""
+8 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)=" ***** User Class and Rules for PATIENT RECORD FLAGS *****"
+9 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)=""
+10 SET SILENT=1
+11 SET USRDUPS=$$USRDUPS^USREN24(SILENT)
+12 IF $GET(USRDUPS)
Begin DoDot:1
+13 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)="Duplicate problem. See description for patch TIU*1*165,"
+14 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)="in the National Patch Module."
End DoDot:1
GOTO MAINX
+15 NEW DONE,SUCCESS
+16 ; -- If User Class previously created by this patch,
+17 ; say so and quit:
+18 SET DONE=+$GET(^XTMP("USR24","DONE"))
+19 IF DONE>0
Begin DoDot:1
+20 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)="User Class and, presumably, Business Rules"
+21 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)=" were already created in a previous install."
End DoDot:1
GOTO MAINX
+22 ; -- Create new User Class:
+23 DO NEWCLASS(.SUCCESS,.TMPCNT)
+24 ; -- Create new Business Rules:
+25 IF SUCCESS
DO NEWRULES(.TMPCNT)
MAINX ; Exit
+1 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)=""
+2 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)=" *********"
+3 QUIT
+4 ;
NEWCLASS(SUCCESS,TMPCNT) ; Create one new User Class in file 8930
+1 NEW FDA,USRIEN,CLASSDA
+2 SET SUCCESS=1
+3 ; -- Create new User Class:
+4 MERGE FDA(8930,"+1,")=^XTMP("USR24","USRCLAS")
+5 DO UPDATE^DIE("E","FDA","USRIEN")
+6 SET CLASSDA=+$GET(USRIEN(1))
+7 IF CLASSDA'>0
Begin DoDot:1
+8 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)="Couldn't create a User Class named "_^XTMP("USR24","USRCLAS",.01)_"."
+9 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)=" Please contact National VistA Support."
+10 SET SUCCESS=0
End DoDot:1
QUIT
+11 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)="User Class named "_^XTMP("USR24","USRCLAS",.01)
+12 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)=" created successfully."
+13 ; -- Set "DONE" node to IEN:
+14 SET ^XTMP("USR24","DONE")=CLASSDA
+15 QUIT
+16 ;
NEWRULES(TMPCNT) ; Create new Business Rule
+1 ; Create rule for ONE User Class & ONE DDEF
+2 ; -- Set data for rule:
+3 DO SETDATA(.TMPCNT)
+4 NEW NUM,SUCCESS
+5 SET SUCCESS=1
SET NUM=0
+6 ; -- Loop through numbered list of rules (one, in this case):
+7 IF '$ORDER(^XTMP("USR24","RULES",0))
SET SUCCESS=0
QUIT
+8 FOR
SET NUM=$ORDER(^XTMP("USR24","RULES",NUM))
if 'NUM
QUIT
Begin DoDot:1
+9 NEW USRERR,FDA,DESC
+10 MERGE FDA(8930.1,"+1,")=^XTMP("USR24","RULES",NUM)
+11 MERGE DESC=^XTMP("USR24","RULESDESC")
+12 SET FDA(8930.1,"+1,",1)="DESC"
+13 DO UPDATE^DIE("","FDA","","USRERR")
+14 IF $DATA(USRERR)
SET SUCCESS=0
QUIT
+15 KILL ^XTMP("USR24","RULES",NUM)
End DoDot:1
+16 KILL ^XTMP("USR24","RULESDESC")
+17 IF '$GET(SUCCESS)
Begin DoDot:1
+18 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)=""
+19 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)="Problem creating Business Rule. Please contact National VistA Support."
End DoDot:1
QUIT
+20 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)=""
+21 SET TMPCNT=TMPCNT+1
SET ^TMP("USR24",$JOB,TMPCNT)="Business Rule created successfully."
+22 QUIT
+23 ;
SETDATA(TMPCNT) ; Set data for rule
+1 ; -- Set data for exported Rule into Rule node of ^XTMP.
+2 ; Use interior data since there may be dup DDEF names.
+3 ; Must set AFTER User Class is created:
+4 NEW DDEFIEN,USRCLASS,EXACTION,INACTION,EXSTATUS,INSTATUS
+5 ; -- Get IEN of DDEF Number 1. (DDEF Number 1 is DC,
+6 ; PATIENT RECORD FLAG CAT I. See ^TIUEN165.)
+7 SET DDEFIEN=$GET(^XTMP("TIU165","BASICS",1,"DONE"))
+8 IF DDEFIEN'>0
Begin DoDot:1
+9 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$JOB,TMPCNT)=""
+10 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$JOB,TMPCNT)="Can't find Document Definition for rules. Contact National VistA Support."
End DoDot:1
GOTO SETX
+11 ; -- Get IEN of User Class created earlier:
+12 SET USRCLASS=+$GET(^XTMP("USR24","DONE"))
+13 ; -- Set data for flds .01 (DDEF) and .04 (User Class) for rule:
+14 SET ^XTMP("USR24","RULES",1,.01)=DDEFIEN
+15 SET ^XTMP("USR24","RULES",1,.04)=USRCLASS
+16 ; -- Set rule desc data:
+17 SET ^XTMP("USR24","RULESDESC",1)="This rule limits note entry to persons specially trained to assign and"
+18 SET ^XTMP("USR24","RULESDESC",2)="document the assignment of Category I Patient Record Flags."
+19 SET ^XTMP("USR24","RULESDESC",3)="Sites must not alter or delete this User Class."
+20 SET ^XTMP("USR24","RULESDESC",4)="Sites must not alter, delete, or override this rule."
+21 SET ^XTMP("USR24","RULESDESC",5)="Rule created by patch USR*1*24."
+22 ; -- Set action and status data for rule:
+23 SET EXACTION="ENTRY"
+24 SET INACTION=$ORDER(^USR(8930.8,"B",EXACTION,0))
+25 SET ^XTMP("USR24","RULES",1,.03)=INACTION
+26 SET EXSTATUS="UNTRANSCRIBED"
+27 SET INSTATUS=$ORDER(^USR(8930.6,"B",EXSTATUS,0))
+28 SET ^XTMP("USR24","RULES",1,.02)=INSTATUS
SETX ;
+1 QUIT
