USRP1001.m

USRP1001 ; SLC/MAM -  After installing TIU*1.0*137;28-Feb-2006 16:13;MGH

 ;;1.0;AUTHORIZATION/SUBSCRIPTION;**1001**;Jun 20, 1997

 ; Run this after installing patch 137.

 ;Use option: TIU137 DDEFS Rules, Anat Path

 ;

ENV N PATCH

 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 ;

 S PATCH="USR*1.0*23"

 I '$$PATCH(PATCH) D  Q

 . W !,"You must first install "_PATCH_"." S XPDQUIT=2

 Q

PATCH(X) ;return 1 if patch X was installed, X=aaaa*nn.nn*nnnn

 ;copy of code from XPDUTL but modified to handle 4 digit IHS patch numb

 Q:X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.4N 0

 NEW NUM,I,J

 S I=$O(^DIC(9.4,"C",$P(X,"*"),0)) Q:'I 0

 S J=$O(^DIC(9.4,I,22,"B",$P(X,"*",2),0)),X=$P(X,"*",3) Q:'J 0

 ;check if patch is just a number

 Q:$O(^DIC(9.4,I,22,J,"PAH","B",X,0)) 1

 S NUM=$O(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))

 Q (X=+NUM)

 ;

POST ; Create new Business Rules

 ; Create rules for ONE User Class & ONE DDEF

 ; -- Set data for rules:

 ;If rules already exist, quit

 N CL,ST,ACTION,MSG,RULENUM,VIEW,PRINT,IEN,USR

 S RULENUM=0

 S CL=$$FIND1^DIC(8925.1,,,"CLINICAL DOCUMENTS",,,"MSG")

 I $D(MSG) D  Q

 .W !!,"Unable to find the class clinical documents.  Rules cannot be added"

 S ST=$$FIND1^DIC(8930.6,,,"RETRACTED",,,"MSG")

 I $D(MSG) D  Q

 .W !!,"Unable to find the status RETRACTED.  Rules cannot be added"

 S USR=$$FIND1^DIC(8930,,,"CHIEF, MIS",,,"MSG")

 I $D(MSG) D  Q

 .W !!,"Unable to find the user class CHIEF, MIS.  Rules cannot be added."

 S VIEW=$$FIND1^DIC(8930.8,,,"VIEW",,,"MSG")

 I $D(MSG) D  Q

 .W !!,"Unable to find the action, VIEW.  Rules cannot be added."

 S PRINT=$$FIND1^DIC(8930.8,,,"PRINT RECORD",,,"MSG")

 I $D(MSG) D  Q

 .W !!,"Unable to find the action PRINT RECORD.  Rules cannot be added."

 S IEN="" S IEN=$O(^USR(8930.1,"AC",CL,ST,VIEW,USR,IEN))

 ;Only add if this rule does not exist

 I IEN="" D

 . S RULENUM=RULENUM+1

 . D SETDATA(RULENUM,VIEW)

 ;Only add the print rule if its not there

 S IEN="" S IEN=$O(^USR(8930.1,"AC",CL,ST,PRINT,USR,IEN))

 I IEN="" D

 . S RULENUM=RULENUM+1

 . D SETDATA(RULENUM,PRINT)

 N NUM,SUCCESS

 S SUCCESS=1,NUM=0

 ; -- Loop through numbered list of rules:

 I '$O(^TMP("USR1001",$J,"RULES",0)) S SUCCESS=0 W "Business rules already exist" Q

 F  S NUM=$O(^TMP("USR1001",$J,"RULES",NUM)) Q:'NUM  D

 .N USRERR,FDA,DESC

 .M FDA(8930.1,"+1,")=^TMP("USR1001",$J,"RULES",NUM)

 .M DESC=^TMP("USR1001",$J,"RULESDESC")

 .S FDA(8930.1,"+1,",1)="DESC"

 .D UPDATE^DIE("","FDA","","USRERR")

 .I $D(USRERR) S SUCCESS=0 Q

 .K ^TMP("USR1001",$J,"RULES",NUM)

 K ^TMP("USR1001",$J,"RULESDESC")

 I '$G(SUCCESS) D  Q

 . W "Problem creating Business Rules. Please contact National VistA Support."

 W "Business Rules created successfully."

 Q

 ;

SETDATA(RULENUM,ACTION) ; Set data for rules

 ; -- Set data for exported Rules into Rule nodes of ^TMP.

 ;    Use interior data since there may be dup DDEF names.

 ;    Must set AFTER User Class is created:

 N DDEFIEN,USRCLASS,EXACTION

 S ^TMP("USR1001",$J,"RULES",RULENUM,.01)=CL

 S ^TMP("USR1001",$J,"RULES",RULENUM,.04)=USR

 S ^TMP("USR1001",$J,"RULES",RULENUM,.02)=ST

 S ^TMP("USR1001",$J,"RULES",RULENUM,.03)=ACTION

 S ^TMP("USR1001",$J,"RULESDESC",1)="Rule created by patch USR*1*1001."

 S ^TMP("USR1001",$J,"RULESDESC",2)="Rules allowing retracted documents to be used by only medical records."

 Q

SETX ;

 Q

USRP1001  ; SLC/MAM -  After installing TIU*1.0*137;28-Feb-2006 16:13;MGH

 +1       ;;1.0;AUTHORIZATION/SUBSCRIPTION;**1001**;Jun 20, 1997

 +2       ; Run this after installing patch 137.

 +3       ;Use option: TIU137 DDEFS Rules, Anat Path

 +4       ;

ENV        NEW PATCH

 +1        SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 +2       ;

 +3        SET PATCH="USR*1.0*23"

 +4        IF '$$PATCH(PATCH)

               Begin DoDot:1

 +5                WRITE !,"You must first install "_PATCH_"."

                   SET XPDQUIT=2

               End DoDot:1

               QUIT 

 +6        QUIT 

PATCH(X)  ;return 1 if patch X was installed, X=aaaa*nn.nn*nnnn

 +1       ;copy of code from XPDUTL but modified to handle 4 digit IHS patch numb

 +2        IF X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.4N

               QUIT 0

 +3        NEW NUM,I,J

 +4        SET I=$ORDER(^DIC(9.4,"C",$PIECE(X,"*"),0))

           IF 'I

               QUIT 0

 +5        SET J=$ORDER(^DIC(9.4,I,22,"B",$PIECE(X,"*",2),0))

           SET X=$PIECE(X,"*",3)

           IF 'J

               QUIT 0

 +6       ;check if patch is just a number

 +7        IF $ORDER(^DIC(9.4,I,22,J,"PAH","B",X,0))

               QUIT 1

 +8        SET NUM=$ORDER(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))

 +9        QUIT (X=+NUM)

 +10      ;

POST      ; Create new Business Rules

 +1       ; Create rules for ONE User Class & ONE DDEF

 +2       ; -- Set data for rules:

 +3       ;If rules already exist, quit

 +4        NEW CL,ST,ACTION,MSG,RULENUM,VIEW,PRINT,IEN,USR

 +5        SET RULENUM=0

 +6        SET CL=$$FIND1^DIC(8925.1,,,"CLINICAL DOCUMENTS",,,"MSG")

 +7        IF $DATA(MSG)

               Begin DoDot:1

 +8                WRITE !!,"Unable to find the class clinical documents.  Rules cannot be added"

               End DoDot:1

               QUIT 

 +9        SET ST=$$FIND1^DIC(8930.6,,,"RETRACTED",,,"MSG")

 +10       IF $DATA(MSG)

               Begin DoDot:1

 +11               WRITE !!,"Unable to find the status RETRACTED.  Rules cannot be added"

               End DoDot:1

               QUIT 

 +12       SET USR=$$FIND1^DIC(8930,,,"CHIEF, MIS",,,"MSG")

 +13       IF $DATA(MSG)

               Begin DoDot:1

 +14               WRITE !!,"Unable to find the user class CHIEF, MIS.  Rules cannot be added."

               End DoDot:1

               QUIT 

 +15       SET VIEW=$$FIND1^DIC(8930.8,,,"VIEW",,,"MSG")

 +16       IF $DATA(MSG)

               Begin DoDot:1

 +17               WRITE !!,"Unable to find the action, VIEW.  Rules cannot be added."

               End DoDot:1

               QUIT 

 +18       SET PRINT=$$FIND1^DIC(8930.8,,,"PRINT RECORD",,,"MSG")

 +19       IF $DATA(MSG)

               Begin DoDot:1

 +20               WRITE !!,"Unable to find the action PRINT RECORD.  Rules cannot be added."

               End DoDot:1

               QUIT 

 +21       SET IEN=""

           SET IEN=$ORDER(^USR(8930.1,"AC",CL,ST,VIEW,USR,IEN))

 +22      ;Only add if this rule does not exist

 +23       IF IEN=""

               Begin DoDot:1

 +24               SET RULENUM=RULENUM+1

 +25               DO SETDATA(RULENUM,VIEW)

               End DoDot:1

 +26      ;Only add the print rule if its not there

 +27       SET IEN=""

           SET IEN=$ORDER(^USR(8930.1,"AC",CL,ST,PRINT,USR,IEN))

 +28       IF IEN=""

               Begin DoDot:1

 +29               SET RULENUM=RULENUM+1

 +30               DO SETDATA(RULENUM,PRINT)

               End DoDot:1

 +31       NEW NUM,SUCCESS

 +32       SET SUCCESS=1

           SET NUM=0

 +33      ; -- Loop through numbered list of rules:

 +34       IF '$ORDER(^TMP("USR1001",$JOB,"RULES",0))

               SET SUCCESS=0

               WRITE "Business rules already exist"

               QUIT 

 +35       FOR 

               SET NUM=$ORDER(^TMP("USR1001",$JOB,"RULES",NUM))

               IF 'NUM

                   QUIT 

               Begin DoDot:1

 +36               NEW USRERR,FDA,DESC

 +37               MERGE FDA(8930.1,"+1,")=^TMP("USR1001",$JOB,"RULES",NUM)

 +38               MERGE DESC=^TMP("USR1001",$JOB,"RULESDESC")

 +39               SET FDA(8930.1,"+1,",1)="DESC"

 +40               DO UPDATE^DIE("","FDA","","USRERR")

 +41               IF $DATA(USRERR)

                       SET SUCCESS=0

                       QUIT 

 +42               KILL ^TMP("USR1001",$JOB,"RULES",NUM)

               End DoDot:1

 +43       KILL ^TMP("USR1001",$JOB,"RULESDESC")

 +44       IF '$GET(SUCCESS)

               Begin DoDot:1

 +45               WRITE "Problem creating Business Rules. Please contact National VistA Support."

               End DoDot:1

               QUIT 

 +46       WRITE "Business Rules created successfully."

 +47       QUIT 

 +48      ;

SETDATA(RULENUM,ACTION) ; Set data for rules

 +1       ; -- Set data for exported Rules into Rule nodes of ^TMP.

 +2       ;    Use interior data since there may be dup DDEF names.

 +3       ;    Must set AFTER User Class is created:

 +4        NEW DDEFIEN,USRCLASS,EXACTION

 +5        SET ^TMP("USR1001",$JOB,"RULES",RULENUM,.01)=CL

 +6        SET ^TMP("USR1001",$JOB,"RULES",RULENUM,.04)=USR

 +7        SET ^TMP("USR1001",$JOB,"RULES",RULENUM,.02)=ST

 +8        SET ^TMP("USR1001",$JOB,"RULES",RULENUM,.03)=ACTION

 +9        SET ^TMP("USR1001",$JOB,"RULESDESC",1)="Rule created by patch USR*1*1001."

 +10       SET ^TMP("USR1001",$JOB,"RULESDESC",2)="Rules allowing retracted documents to be used by only medical records."

 +11       QUIT 

SETX      ;

 +1        QUIT