source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERBLK.m@ 1261

Last change on this file since 1261 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version

File size: 6.2 KB
Line 
1XUSERBLK ;SF/RWF - Bulk user (new person) COMPUTER ACCESS ; 5/23/2006
2 ;;8.0;KERNEL;**20,214,230,289,419**;Jul 10, 1995;Build 5
3 ; This routine allows the Cloning of one person to a group of others.
4A ;
5 I $G(DUZ)'>0 W !!,"You are not a known user and can't use this option." Q
6 N DIC,DIR,%,L,XUIOP,XUNODE,XU1,X1,X2,X3,X4,X5,X6,XUTEXT,XUNEW,XUSER,XUTMP,XUTERMDT,XUH,XUU,XUU2,M,P,XU
7 K ^TMP($J)
8B1 W @IOF,!?26,"Batch Entry of New Persons"
9 W !?26,"--------------------------",!!,"Please select a person to copy from"
10 K DIC S DIC(0)="AEQZ",DIC("A")="Template PERSON: ",DIC="^VA(200," D ^DIC
11 G QUIT:$D(DTOUT)!$D(DUOUT),B1:Y=-1
12 ; Show INFO to be copied"
13 S XUTMP=+Y,XUTMP(0)=$P(Y,U,2),DA=+Y D EN^DIQ
14 S DIR(0)="Y",DIR("A")="Is this the person data you want cloned" D ^DIR G B1:'Y
15 W !,"You may enter a date, when the users that are being created/updated",!,"will no longer have access to the system."
16 S XUTERMDT="",%DT="AEF",%DT(0)=DT,%DT("A")="Enter (optional) TERMINATION DATE: " D ^%DT S:Y>0 XUTERMDT=Y
17 K XUSER S XUSER=0
18B2 ;
19 W !!,?26,"Batch Entry of New Persons",!,?26,"--------------------------",!
20 W !,"Clone of: ",XUTMP(0) I XUTERMDT W ?50,"TERMINATION DATE: ",$$FMTE^XLFDT(XUTERMDT)
21 ;;
22B3 F S XUY=$$ADD^XUSERNEW Q:XUY<0 D ;Create new entry
23 . I '$P(XUY,U,3) D
24 . . S DIR(0)="Y",DIR("A")=$P(XUY,U,2)_" is an existing user. Do you want to include" D ^DIR I Y'=1 S XUY=-1 Q
25 . . S DIR(0)="Y",DIR("A")="Clear out KEYS, FILES, SECONDARY MENUS first" D ^DIR
26 . . S:Y=1 $P(XUY,U,4)=1
27 . . Q
28 . I XUY>0 D
29 . . S DIR(0)="Y",DIR("A")="Do You Want To Clone PERSON CLASS" D ^DIR
30 . . S:Y=1 $P(XUY,U,5)=1
31 . S:XUY>0 XUSER=XUSER+1,XUSER(XUSER)=XUY W !,"Next!",!
32 . Q
33B4 ;
34 G:XUSER'>0 QUIT
35 I XUTERMDT>0 S ZTRTN="CHECK^XUSTERM1",ZTIO="",ZTDTH=XUTERMDT D ^%ZTLOAD W !,"Automatic deactivation has been queued for this date.",!
36 W !!,"Where do you want to print the COMPUTER ACCOUNT NOTIFICATION LETTERS"
37 S %ZIS="MQ" D ^%ZIS G QUIT:POP
38 I ION["P-MESSAGE-HFS" G START
39 I '$D(IO("Q")) G CLONE
40START ;
41 S ZTRTN="CLONE^XUSERBLK" F I="XUTMP","XUTERMDT","XUSER","XUSER(" S ZTSAVE(I)=""
42 K IO("Q") D ^%ZTLOAD
43 ;;
44QUIT ;
45 K DIC,DIR,%,L,XUIOP,XUNODE,XU1,X1,X2,X3,X4,X5,X6,XUTEXT,XUNEW,XUSER,XUTMP,XUTERMDT,XUH,XUU,XUU2,M,P,XU
46 K ^TMP($J)
47 Q
48 ;;
49CLONE ;;Do work
50 S XUTEXT=$O(^DIC(9.2,"B",$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),0)),XUIOP=ION_";"_IOST_";"_IOM_";"_IOSL
51 F XU1=1:1:XUSER S %=XUSER(XU1),DA=+%,XUNEW=$P(%,U,3),XUPURGE=$P(%,U,4) D C2,UPDATE("ORD",DA)
52 G QUIT
53 ;
54C2 ;
55 N XUH,XUH2,XUU,XUU2
56 I '$D(ZTQUEUED) W !!?8,$S(XUNEW:"CREATING A NEW ACCOUNT FOR '"_$P(XUSER(XU1),U,2)_"'",1:"CONVERTING "_$P(XUSER(XU1),U,2)_"'S ACCOUNT OVER"),!!,"One moment please..."
57 D BLDFDA
58 I $P(^VA(200,DA,0),U,3)']"" S XUNEW=1 ;if no access code treat as new
59 I $P($G(^VA(200,DA,.1)),U,2)']"" S XUNEW=1 ;If no verify code treat as new
60 S (XUU,XUU2)="unchanged",$P(^VA(200,DA,0),U,11)=XUTERMDT
61 I XUNEW D ACODE S @XFDA@(200,DA_",",2)=XUH D VCODE S @XFDA@(200,DA_",",11)=XUH2
62 D UPDATE^DIE("",XFDA,XIEN,"XERR") K @XFDA
63 I XUNEW,XUTEXT>0 D LET(DA,XUTEXT)
64 I $D(^XMB(3.7,DA,0))[0 S Y=DA K XMZ D NEW^XM K XMDT,XMM,XMZ
65 Q
66 ;
67BLDFDA ;Build the FDA
68 S XFDA="^TMP($J,""XFDA"")",XIEN="^TMP($J,""XIEN"")" K ^TMP($J)
69 ;Move piece on nodes from list, Build XU only once
70 F X2=1:1 S XUNODE=$P($T(DATA+X2),";;",2) Q:XUNODE="" D
71 . F X3=1:1 S X7=$P(XUNODE,U,X3) Q:X7="" S X4=$$GETDD(200,X7),X5=$P(X4,";"),X6=$P(X4,";",2) D
72 . . I '$D(XU(2,X5)) S XU(2,X5)=$G(^VA(200,XUTMP,X5))
73 . . S:$P(XU(2,X5),U,X6)]"" @XFDA@(200,DA_",",X7)=$P(XU(2,X5),U,X6)
74 . . Q
75 . Q
76 D SUBFILE
77 Q
78 ;
79GETDD(FI,FE) ;Return node;piece for a field
80 Q $P($G(^DD(FI,FE,0)),U,4)
81 ;
82DATA ;;field#
83 ;;3^8^15^29^28
84 ;;200.04^200.05^200.06^200.09^200.1^201^
85 ;;41^41.1^41.2
86 ;;101.01^101.02
87 ;;9.21^9.22
88 ;;
89 ;
90ACODE ;
91 F Z=0:0 S XUU=$$AC^XUS4(),XUH=$$EN^XUSHSH(XUU) Q:'($D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH)))
92 Q
93 ;
94VCODE ;
95 S XUU2=$$VC^XUS4(),XUH2=$$EN^XUSHSH(XUU2)
96 Q
97 ;
98SUBFILE ;Move subfiles: Subscript, Subfile#, DINUM, Fields
99 N XCNT S XCNT=0
100KEY D MULTI(51,200.051,1,".01,3")
101PATH ;D MULTI(19.8,".01")
102FOF D MULTI("FOF",200.032,1,".01,1,2,3,4,5,6")
103DIV D MULTI(2,200.02,1,".01")
104SEC D MULTI(203,200.03,0,".01,2")
105TAB D MULTI("ORD",200.010113,0,".01,.02,.03")
106PSCLSS I $P($G(XUSER(XU1)),U,5)=1 D PRSNCL(DA)
107 Q
108 ;
109MULTI(XSS,XSF,XDN,XDD) ;Build new data
110 I XUPURGE D CLEAR(DA,XSS)
111 Q:'$D(^VA(200,XUTMP,XSS,0))
112 ;S X=^(0),Y=$S($D(^VA(200,DA,X2,0)):^(0),1:"")
113 F X1=0:0 S X1=$O(^VA(200,XUTMP,XSS,X1)) Q:X1'>0 S X=^(X1,0) D
114 . F X2=1:1 S X3=$P(XDD,",",X2) Q:X3="" D
115 . . I X3'=.01 S @XFDA@(XSF,"?+"_XCNT_","_DA_",",X3)=$$VAL(X,X3,XSF) Q
116 . . S XCNT=XCNT+1,@XFDA@(XSF,"?+"_XCNT_","_DA_",",.01)=$P(X,U,1)
117 . . S:XDN @XIEN@(XCNT)=X1
118 . . Q
119 . Q
120 Q
121 ;
122VAL(V,FE,FI) ;Get value
123 N % S %=$$GETDD(FI,FE),%=$P(%,";",2) Q $P(V,"^",%)
124 ;
125LET(DA,XUTEXT) ;Write access letter
126 N DIWF,FR,TO,BY
127 S DIWF="^DIC(9.2,"_XUTEXT_",1,",DIWF(1)=200,FR=DA,TO=DA,BY="NUMBER",IOP=XUIOP D EN2^DIWF
128 Q
129 ;
130CLEAR(X4,X2) ;Clear subfile first, IEN, Subscript
131 Q:$D(^VA(200,X4,X2,0))[0 N C,XUFN,XDEL,XMSG
132 S C=",",XDEL=$NA(^TMP($J,"XUBLK2")),XUFN=+$P(^VA(200,X4,X2,0),"^",2)
133 F X1=0:0 S X1=$O(^VA(200,X4,X2,X1)) Q:X1'>0 D
134 . I X2=51 S %=$$DEL^XQKEY(X4,X1) Q ;Special case for KEYS
135 . S @XDEL@(XUFN,X1_C_X4_C,.01)="@"
136 . Q
137 I $D(@XDEL)>1 D FILE^DIE("",XDEL,"XMSG") ;I $D(XMSG) ZW XMSG
138 Q
139 ;
140UPDATE(XX,USRIEN) ;Update effective date
141 N PC,PC1
142 S PC=$O(^VA(200,USRIEN,XX,"A"),-1) Q:PC'>0
143 S PC=0 F S PC=$O(^VA(200,USRIEN,XX,PC)) Q:PC'>0 D
144 .S PC1=$P($G(^VA(200,USRIEN,XX,PC,0)),"^",3)
145 .I (PC1="")!(PC1'<DT) D DOPD
146 Q
147 ;
148DOPD ;
149 L +^VA(200,DA,XX,PC,0):20 I '$T D Q
150 .W !,"===> The user is locked. Please try this option again."
151 S $P(^VA(200,USRIEN,XX,PC,0),"^",2)=DT
152 L -^VA(200,USRIEN,XX,PC,0)
153 Q
154 ;
155PRSNCL(USERIEN) ;
156 N XUDATA,XUPSC,XUEFDA,XUEXDA,ZZ
157 S XUDATA=$O(^VA(200,XUTMP,"USC1","A"),-1) Q:XUDATA'>0
158 S XUDATA=$G(^VA(200,XUTMP,"USC1",XUDATA,0)) Q:XUDATA=""
159 S XUPSC=$P(XUDATA,"^")
160 S XUEFDA=$P(XUDATA,"^",2) I XUEFDA'>DT S XUEFDA=DT
161 S XUEXDA=$P(XUDATA,"^",3)
162 I XUEXDA<DT,XUEXDA'="" Q
163 N XULAST,XULDATA
164 S XULAST=$O(^VA(200,USERIEN,"USC1","A"),-1)
165 S ZZ(1,200.05,"+2,"_USERIEN_",",.01)=XUPSC
166 S ZZ(1,200.05,"+2,"_USERIEN_",",2)=XUEFDA
167 S ZZ(1,200.05,"+2,"_USERIEN_",",3)=XUEXDA
168 D UPDATE^DIE("","ZZ(1)")
169 Q:XULAST'>0
170 S XULDATA=$G(^VA(200,USERIEN,"USC1",XULAST,0))
171 S XULDATA=$P(XULDATA,"^",3)
172 Q:XULDATA'>DT
173 S $P(^VA(200,USERIEN,"USC1",XULAST,0),"^",3)=DT
174 Q
Note: See TracBrowser for help on using the repository browser.