USRPS23 ; SLC/MAM - After installing TIU*1.0*137;6/16/03
;;1.0;AUTHORIZATION/SUBSCRIPTION;**23**;Jun 20, 1997
; Run this after installing patch 137.
;Use option: TIU137 DDEFS Rules, Anat Path
MAIN ; Create new User Class & new Business Rules
; -- Check for potential dup User Class created after install
; but before option:
K ^TMP("USR23",$J)
D SETXTMP^USREN23
N USRDUPS,TMPCNT,SILENT
S TMPCNT=0
S TMPCNT=TMPCNT+1,^TMP("USR23",$J,TMPCNT)=""
S TMPCNT=TMPCNT+1,^TMP("USR23",$J,TMPCNT)=" ***** User Class and Rules for LABORATORY REPORTS *****"
S TMPCNT=TMPCNT+1,^TMP("USR23",$J,TMPCNT)=""
S SILENT=1
S USRDUPS=$$USRDUPS^USREN23(SILENT)
I $G(USRDUPS) D G MAINX
. S TMPCNT=TMPCNT+1,^TMP("USR23",$J,TMPCNT)="Duplicate problem. See description for patch TIU*1*137,"
. S TMPCNT=TMPCNT+1,^TMP("USR23",$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("USR23","DONE"))
I DONE>0 D G MAINX
. S TMPCNT=TMPCNT+1,^TMP("USR23",$J,TMPCNT)="User Class and, presumably, Business Rules"
. S TMPCNT=TMPCNT+1,^TMP("USR23",$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("USR23",$J,TMPCNT)=""
S TMPCNT=TMPCNT+1,^TMP("USR23",$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("USR23","USRCLAS")
D UPDATE^DIE("E","FDA","USRIEN")
S CLASSDA=+$G(USRIEN(1))
I CLASSDA'>0 D Q
. S TMPCNT=TMPCNT+1,^TMP("USR23",$J,TMPCNT)="Couldn't create a User Class named "_^XTMP("USR23","USRCLAS",.01)_"."
. S TMPCNT=TMPCNT+1,^TMP("USR23",$J,TMPCNT)=" Please contact National VistA Support."
. S SUCCESS=0
S TMPCNT=TMPCNT+1,^TMP("USR23",$J,TMPCNT)="User Class named "_^XTMP("USR23","USRCLAS",.01)
S TMPCNT=TMPCNT+1,^TMP("USR23",$J,TMPCNT)=" created successfully."
; -- Set "DONE" node to IEN:
S ^XTMP("USR23","DONE")=CLASSDA
Q
;
NEWRULES(TMPCNT) ; Create new Business Rules
; Create rules for ONE User Class & ONE DDEF
; -- Set data for rules:
D SETDATA(.TMPCNT)
N NUM,SUCCESS
S SUCCESS=1,NUM=0
; -- Loop through numbered list of rules:
I '$O(^XTMP("USR23","RULES",0)) S SUCCESS=0 Q
F S NUM=$O(^XTMP("USR23","RULES",NUM)) Q:'NUM D
. N USRERR,FDA,DESC
. M FDA(8930.1,"+1,")=^XTMP("USR23","RULES",NUM)
. M DESC=^XTMP("USR23","RULESDESC")
. S FDA(8930.1,"+1,",1)="DESC"
. D UPDATE^DIE("","FDA","","USRERR")
. I $D(USRERR) S SUCCESS=0 Q
. K ^XTMP("USR23","RULES",NUM)
K ^XTMP("USR23","RULESDESC")
I '$G(SUCCESS) D Q
. S TMPCNT=TMPCNT+1,^TMP("USR23",$J,TMPCNT)=""
. S TMPCNT=TMPCNT+1,^TMP("USR23",$J,TMPCNT)="Problem creating Business Rules. Please contact National VistA Support."
S TMPCNT=TMPCNT+1,^TMP("USR23",$J,TMPCNT)=""
S TMPCNT=TMPCNT+1,^TMP("USR23",$J,TMPCNT)="Business Rules created successfully."
Q
;
SETDATA(TMPCNT) ; Set data for rules
; -- Set data for exported Rules into Rule nodes of ^XTMP.
; Use interior data since there may be dup DDEF names.
; Must set AFTER User Class is created:
N DDEFIEN,USRCLASS,RULENUM,EXACTION
; -- Get IEN of DDEF Number 2. (DDEF Number 2 is DC,
; LR ANATOMIC PATHOLOGY. See ^TIUEN137.)
S DDEFIEN=$G(^XTMP("TIU137","BASICS",2,"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("USR23","DONE"))
; -- Set data for flds .01 (DDEF) and .04 (User Class) for all rules:
F RULENUM=1:1:9 D
. S ^XTMP("USR23","RULES",RULENUM,.01)=DDEFIEN
. S ^XTMP("USR23","RULES",RULENUM,.04)=USRCLASS
; -- Set rule desc data (same for all rules):
S ^XTMP("USR23","RULESDESC",1)="Using this empty class to prevent this action on Anatomic Pathology documents."
S ^XTMP("USR23","RULESDESC",2)="These documents should be managed from the Anatomic Pathology menu only."
S ^XTMP("USR23","RULESDESC",3)="Rule created by patch USR*1*23."
; -- Set action data for each rule; set status data according
; to action:
S RULENUM=0
F EXACTION="AMENDMENT","CHANGE TITLE","COPY RECORD","DELETE RECORD","ENTRY","IDENTIFY SIGNERS","MAKE ADDENDUM","PRINT RECORD","REASSIGN" D
. N INACTION,EXSTATUS,INSTATUS
. S RULENUM=RULENUM+1
. S INACTION=$O(^USR(8930.8,"B",EXACTION,0))
. S ^XTMP("USR23","RULES",RULENUM,.03)=INACTION
. ; -- For action ENTRY, status is untranscribed:
. I EXACTION="ENTRY" D Q
. . S EXSTATUS="UNTRANSCRIBED"
. . S INSTATUS=$O(^USR(8930.6,"B",EXSTATUS,0))
. . S ^XTMP("USR23","RULES",RULENUM,.02)=INSTATUS
. ; -- For all others, status is completed:
. S EXSTATUS="COMPLETED"
. S INSTATUS=$O(^USR(8930.6,"B",EXSTATUS,0))
. S ^XTMP("USR23","RULES",RULENUM,.02)=INSTATUS
SETX ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HUSRPS23 5150 printed Apr 09, 2024@20:44:05 Page 2
USRPS23 ; SLC/MAM - After installing TIU*1.0*137;6/16/03
+1 ;;1.0;AUTHORIZATION/SUBSCRIPTION;**23**;Jun 20, 1997
+2 ; Run this after installing patch 137.
+3 ;Use option: TIU137 DDEFS Rules, Anat Path
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("USR23",$JOB)
+4 DO SETXTMP^USREN23
+5 NEW USRDUPS,TMPCNT,SILENT
+6 SET TMPCNT=0
+7 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$JOB,TMPCNT)=""
+8 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$JOB,TMPCNT)=" ***** User Class and Rules for LABORATORY REPORTS *****"
+9 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$JOB,TMPCNT)=""
+10 SET SILENT=1
+11 SET USRDUPS=$$USRDUPS^USREN23(SILENT)
+12 IF $GET(USRDUPS)
Begin DoDot:1
+13 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$JOB,TMPCNT)="Duplicate problem. See description for patch TIU*1*137,"
+14 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$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("USR23","DONE"))
+19 IF DONE>0
Begin DoDot:1
+20 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$JOB,TMPCNT)="User Class and, presumably, Business Rules"
+21 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$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("USR23",$JOB,TMPCNT)=""
+2 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$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("USR23","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("USR23",$JOB,TMPCNT)="Couldn't create a User Class named "_^XTMP("USR23","USRCLAS",.01)_"."
+9 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$JOB,TMPCNT)=" Please contact National VistA Support."
+10 SET SUCCESS=0
End DoDot:1
QUIT
+11 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$JOB,TMPCNT)="User Class named "_^XTMP("USR23","USRCLAS",.01)
+12 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$JOB,TMPCNT)=" created successfully."
+13 ; -- Set "DONE" node to IEN:
+14 SET ^XTMP("USR23","DONE")=CLASSDA
+15 QUIT
+16 ;
NEWRULES(TMPCNT) ; Create new Business Rules
+1 ; Create rules for ONE User Class & ONE DDEF
+2 ; -- Set data for rules:
+3 DO SETDATA(.TMPCNT)
+4 NEW NUM,SUCCESS
+5 SET SUCCESS=1
SET NUM=0
+6 ; -- Loop through numbered list of rules:
+7 IF '$ORDER(^XTMP("USR23","RULES",0))
SET SUCCESS=0
QUIT
+8 FOR
SET NUM=$ORDER(^XTMP("USR23","RULES",NUM))
if 'NUM
QUIT
Begin DoDot:1
+9 NEW USRERR,FDA,DESC
+10 MERGE FDA(8930.1,"+1,")=^XTMP("USR23","RULES",NUM)
+11 MERGE DESC=^XTMP("USR23","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("USR23","RULES",NUM)
End DoDot:1
+16 KILL ^XTMP("USR23","RULESDESC")
+17 IF '$GET(SUCCESS)
Begin DoDot:1
+18 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$JOB,TMPCNT)=""
+19 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$JOB,TMPCNT)="Problem creating Business Rules. Please contact National VistA Support."
End DoDot:1
QUIT
+20 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$JOB,TMPCNT)=""
+21 SET TMPCNT=TMPCNT+1
SET ^TMP("USR23",$JOB,TMPCNT)="Business Rules created successfully."
+22 QUIT
+23 ;
SETDATA(TMPCNT) ; Set data for rules
+1 ; -- Set data for exported Rules into Rule nodes 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,RULENUM,EXACTION
+5 ; -- Get IEN of DDEF Number 2. (DDEF Number 2 is DC,
+6 ; LR ANATOMIC PATHOLOGY. See ^TIUEN137.)
+7 SET DDEFIEN=$GET(^XTMP("TIU137","BASICS",2,"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("USR23","DONE"))
+13 ; -- Set data for flds .01 (DDEF) and .04 (User Class) for all rules:
+14 FOR RULENUM=1:1:9
Begin DoDot:1
+15 SET ^XTMP("USR23","RULES",RULENUM,.01)=DDEFIEN
+16 SET ^XTMP("USR23","RULES",RULENUM,.04)=USRCLASS
End DoDot:1
+17 ; -- Set rule desc data (same for all rules):
+18 SET ^XTMP("USR23","RULESDESC",1)="Using this empty class to prevent this action on Anatomic Pathology documents."
+19 SET ^XTMP("USR23","RULESDESC",2)="These documents should be managed from the Anatomic Pathology menu only."
+20 SET ^XTMP("USR23","RULESDESC",3)="Rule created by patch USR*1*23."
+21 ; -- Set action data for each rule; set status data according
+22 ; to action:
+23 SET RULENUM=0
+24 FOR EXACTION="AMENDMENT","CHANGE TITLE","COPY RECORD","DELETE RECORD","ENTRY","IDENTIFY SIGNERS","MAKE ADDENDUM","PRINT RECORD","REASSIGN"
Begin DoDot:1
+25 NEW INACTION,EXSTATUS,INSTATUS
+26 SET RULENUM=RULENUM+1
+27 SET INACTION=$ORDER(^USR(8930.8,"B",EXACTION,0))
+28 SET ^XTMP("USR23","RULES",RULENUM,.03)=INACTION
+29 ; -- For action ENTRY, status is untranscribed:
+30 IF EXACTION="ENTRY"
Begin DoDot:2
+31 SET EXSTATUS="UNTRANSCRIBED"
+32 SET INSTATUS=$ORDER(^USR(8930.6,"B",EXSTATUS,0))
+33 SET ^XTMP("USR23","RULES",RULENUM,.02)=INSTATUS
End DoDot:2
QUIT
+34 ; -- For all others, status is completed:
+35 SET EXSTATUS="COMPLETED"
+36 SET INSTATUS=$ORDER(^USR(8930.6,"B",EXSTATUS,0))
+37 SET ^XTMP("USR23","RULES",RULENUM,.02)=INSTATUS
End DoDot:1
SETX ;
+1 QUIT
