| [613] | 1 | USREN23 ; SLC/MAM - Environment Check Rtn for USR*1*23;6/12/03
|
|---|
| 2 | ;;1.0;AUTHORIZATION/SUBSCRIPTION;**23**;Jun 20, 1997
|
|---|
| 3 | MAIN ; Check environment
|
|---|
| 4 | ; -- Set data for User Class to export:
|
|---|
| 5 | D SETXTMP
|
|---|
| 6 | ; -- Check for potential duplicate User Class at site:
|
|---|
| 7 | N USRDUPS
|
|---|
| 8 | S USRDUPS=$$USRDUPS
|
|---|
| 9 | I +USRDUPS S XPDABORT=1 W !,"Aborting Install..." Q
|
|---|
| 10 | W !,"User Classes look OK."
|
|---|
| 11 | Q
|
|---|
| 12 | ;
|
|---|
| 13 | SETXTMP ; Set data for new User Class into ^XTMP:
|
|---|
| 14 | ; Use exterior data:
|
|---|
| 15 | S ^XTMP("USR23",0)=3031201_U_DT
|
|---|
| 16 | S ^XTMP("USR23","USRCLAS",.01)="LR ANATOMIC PATH EMPTY CLASS"
|
|---|
| 17 | S ^XTMP("USR23","USRCLAS",.02)="LRAPMT"
|
|---|
| 18 | S ^XTMP("USR23","USRCLAS",.03)="Active"
|
|---|
| 19 | S ^XTMP("USR23","USRCLAS",.04)="LR Anatomic Path Empty Class"
|
|---|
| 20 | Q
|
|---|
| 21 | ;
|
|---|
| 22 | USRDUPS(SILENT) ; Return IEN if site already has User Class
|
|---|
| 23 | ; If not, return 0
|
|---|
| 24 | N NAME,USRDUPS,USRY
|
|---|
| 25 | ; -- When looking for duplicates, ignore User Class if created
|
|---|
| 26 | ; by this patch:
|
|---|
| 27 | I $G(^XTMP("USR23","DONE")) Q 0
|
|---|
| 28 | ; -- If site already has User Class w/ same name as the one we
|
|---|
| 29 | ; export, set USRDUPS=1:
|
|---|
| 30 | S USRDUPS=0,NAME=^XTMP("USR23","USRCLAS",.01)
|
|---|
| 31 | S USRY=$O(^USR(8930,"B",NAME,0))
|
|---|
| 32 | I +USRY'>0 Q 0
|
|---|
| 33 | S USRDUPS=+USRY
|
|---|
| 34 | I '$G(SILENT) D
|
|---|
| 35 | . W !,"You already have the User Class exported by this patch. I don't want"
|
|---|
| 36 | . W !,"to overwrite it. Please change its name so it no longer matches the"
|
|---|
| 37 | . W !,"exported one, or if you are not using it, delete it. For help, contact"
|
|---|
| 38 | . W !,"National VistA Support."
|
|---|
| 39 | Q USRDUPS
|
|---|
