Routine: USRPS23

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)="                             *********"

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

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."

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 ;

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

USRPS23.m