- 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 Feb 18, 2025@23:05:25 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