XUSERBLK ;SF/RWF - Bulk user (new person) COMPUTER ACCESS ;02/26/2008
;;8.0;KERNEL;**20,214,230,289,419,490,775**;Jul 10, 1995;Build 11
; Per VHA Directive 2004-038, this routine should not be modified.
; Option: XUSERBLK
; This routine allows the Cloning of one person to a group of others.
A ;
I $G(DUZ)'>0 W !!,"You are not a known user and can't use this option." Q
N DIC,X,Y,XUTMP,DA,DIR,XUTERMDT,XUSER,XUY,%ZIS,XUIOP,XMQUIET,DIRUT,DTOUT,DUOUT,POP
K ^TMP($J)
B1 W @IOF,!?26,"Batch Entry of New Persons"
W !?26,"--------------------------",!!,"Please select a person to copy from"
K DIC S DIC(0)="AEQZ",DIC("A")="Template PERSON: ",DIC="^VA(200," D ^DIC
Q:$D(DTOUT)!$D(DUOUT)
G B1:Y=-1
; Show INFO to be copied"
S XUTMP=+Y,XUTMP(0)=$P(Y,U,2),DA=+Y D EN^DIQ
S DIR(0)="Y",DIR("A")="Is this the person whose data you want cloned" D ^DIR Q:$D(DIRUT) G B1:'Y
W !!,"You may enter a date, when the users that are being created/updated",!,"will no longer have access to the system."
S DIR(0)="DAO^DT::AEF"
S DIR("A")="Enter (optional) TERMINATION DATE: "
D ^DIR Q:$D(DTOUT)!$D(DUOUT)
S XUTERMDT=Y
K XUSER S XUSER=0
I $$PSDRPH(DA) D ; XU*8.0*775
. W !!,"The PSDRPH key cannot be allocated / de-allocated by this option. Please"
. W !,"use the option 'Allocate/De-Allocate of PSDRPH Key (Audited)' if necessary."
. W !,"The PSDRPH key will not be copied to the new user.",!
. S DIR(0)="E",DIR("A")="Press ENTER to continue" D ^DIR
B2 ;
W !!,?26,"Batch Entry of New Persons",!,?26,"--------------------------",!
W !,"Clone of: ",XUTMP(0) I XUTERMDT W ?49,"TERMINATION DATE: ",$$FMTE^XLFDT(XUTERMDT)
;;
B3 F S XUY=$$ADD^XUSERNEW Q:XUY<0 D ;Create new entry
. I '$P(XUY,U,3) D
. . 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
. . S DIR(0)="Y",DIR("A")="Clear out KEYS, FILES, SECONDARY MENUS first" D ^DIR
. . S:Y=1 $P(XUY,U,4)=1
. . Q
. I XUY>0 D
. . S DIR(0)="Y",DIR("A")="Do You Want To Clone PERSON CLASS" D ^DIR
. . S:Y=1 $P(XUY,U,5)=1
. S:XUY>0 XUSER=XUSER+1,XUSER(XUSER)=XUY W !!,"Next!"
. Q
B4 ;
Q:XUSER'>0
I XUTERMDT D
. N XUZT
. S XUZT("ZTDTH")=XUTERMDT
. W !!,"Queueing automatic deactivation for ",$$FMTE^XLFDT(XUTERMDT)
. S X=$$NODEV^XUTMDEVQ("CHECK^XUSTERM1",,,.XUZT,1)
W !!,"Where do you want to print the COMPUTER ACCOUNT NOTIFICATION LETTERS?"
S XMQUIET=1
S %ZIS="NMQ" D ^%ZIS Q:POP ; "N" means don't open device
K XMQUIET
S XUIOP=ION_";"_IOST_";"_IOM_";"_IOSL
D HOME^%ZIS
;I ION["P-MESSAGE-HFS" G START
I '$D(IO("Q")) G CLONE
START ;
N XUZT
S XUZT("ZTDTH")=$H
S X=$$NODEV^XUTMDEVQ("CLONE^XUSERBLK",,"XUIOP;XUTMP;XUTERMDT;XUSER;XUSER(",.XUZT,1)
Q
;;
CLONE ;;Do work
N XUTEXT,XU1,%,DA,XUNEW,XUPURGE
S XUTEXT=$O(^DIC(9.2,"B",$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),0))
F XU1=1:1:XUSER S %=XUSER(XU1),DA=+%,XUNEW=$P(%,U,3),XUPURGE=$P(%,U,4) D C2,UPDATE("ORD",DA)
K ^TMP($J)
Q
C2 ;
N XUU,XUU2,XFDA,XUH,XUH2,XIEN,XERR,Y,XMZ,XMM,XMDT
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..."
D BLDFDA
I $P(^VA(200,DA,0),U,3)']"" S XUNEW=1 ;if no access code treat as new
I $P($G(^VA(200,DA,.1)),U,2)']"" S XUNEW=1 ;If no verify code treat as new
S (XUU,XUU2)="unchanged",$P(^VA(200,DA,0),U,11)=XUTERMDT
I XUNEW D ACODE S @XFDA@(200,DA_",",2)=XUH D VCODE S @XFDA@(200,DA_",",11)=XUH2
D UPDATE^DIE("",XFDA,XIEN,"XERR") K @XFDA
I XUNEW,XUTEXT>0 D LET(DA,XUTEXT)
I $D(^XMB(3.7,DA,0))[0 S Y=DA K XMZ D NEW^XM K XMDT,XMM,XMZ
Q
;
BLDFDA ;Build the FDA
N X2,X3,X4,X5,X6,X7,XUNODE,XU,X1
S XFDA="^TMP($J,""XFDA"")",XIEN="^TMP($J,""XIEN"")" K ^TMP($J)
;Move piece on nodes from list, Build XU only once
F X2=1:1 S XUNODE=$P($T(DATA+X2),";;",2) Q:XUNODE="" D
. 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
. . I '$D(XU(2,X5)) S XU(2,X5)=$G(^VA(200,XUTMP,X5))
. . S:$P(XU(2,X5),U,X6)]"" @XFDA@(200,DA_",",X7)=$P(XU(2,X5),U,X6)
. . Q
. Q
D SUBFILE
Q
;
GETDD(FI,FE) ;Return node;piece for a field
Q $P($G(^DD(FI,FE,0)),U,4)
;
DATA ;;field#
;;3^8^15^29^28
;;200.04^200.05^200.06^200.09^200.1^201^
;;41^41.1^41.2
;;101.01^101.02
;;9.21^9.22
;;
;
ACODE ;
N Z
F Z=0:0 S XUU=$$AC^XUS4(),XUH=$$EN^XUSHSH(XUU) Q:'($D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH)))
Q
;
VCODE ;
S XUU2=$$VC^XUS4(),XUH2=$$EN^XUSHSH(XUU2)
Q
;
SUBFILE ;Move subfiles: Subscript, Subfile#, DINUM, Fields
N XCNT S XCNT=0
N XNOCLONE
D NOCLONE(.XNOCLONE)
KEY D MULTI(51,200.051,1,".01,3",.XNOCLONE)
PATH ;D MULTI(19.8,".01")
FOF D MULTI("FOF",200.032,1,".01,1,2,3,4,5,6")
DIV D MULTI(2,200.02,1,".01")
SEC D MULTI(203,200.03,0,".01,2")
TAB D MULTI("ORD",200.010113,0,".01,.02,.03")
PSCLSS I $P($G(XUSER(XU1)),U,5)=1 D PRSNCL(DA)
Q
;
MULTI(XSS,XSF,XDN,XDD,XNOCLONE) ;Build new data
I XUPURGE D CLEAR(DA,XSS)
Q:'$D(^VA(200,XUTMP,XSS,0))
;S X=^(0),Y=$S($D(^VA(200,DA,X2,0)):^(0),1:"")
F X1=0:0 S X1=$O(^VA(200,XUTMP,XSS,X1)) Q:X1'>0 S X=^(X1,0) D
. Q:$D(XNOCLONE(XSF,X1)) ;
. F X2=1:1 S X3=$P(XDD,",",X2) Q:X3="" D
. . I X3'=.01 S @XFDA@(XSF,"?+"_XCNT_","_DA_",",X3)=$$VAL(X,X3,XSF) Q
. . S XCNT=XCNT+1,@XFDA@(XSF,"?+"_XCNT_","_DA_",",.01)=$P(X,U,1)
. . S:XDN @XIEN@(XCNT)=X1
. . Q
. Q
Q
;
VAL(V,FE,FI) ;Get value
N % S %=$$GETDD(FI,FE),%=$P(%,";",2) Q $P(V,"^",%)
;
LET(DA,XUTEXT) ;Write access letter
N DIWF,FR,TO,BY,IOP
S DIWF="^DIC(9.2,"_XUTEXT_",1,",DIWF(1)=200,FR=DA,TO=DA,BY="NUMBER",IOP=XUIOP D EN2^DIWF
Q
;
CLEAR(X4,X2) ;Clear subfile first, IEN, Subscript
Q:$D(^VA(200,X4,X2,0))[0 N C,XUFN,XDEL,XMSG
S C=",",XDEL=$NA(^TMP($J,"XUBLK2")),XUFN=+$P(^VA(200,X4,X2,0),"^",2)
F X1=0:0 S X1=$O(^VA(200,X4,X2,X1)) Q:X1'>0 D
. I X2=51 S %=$$DEL^XQKEY(X4,X1) Q ;Special case for KEYS
. S @XDEL@(XUFN,X1_C_X4_C,.01)="@"
. Q
I $D(@XDEL)>1 D FILE^DIE("",XDEL,"XMSG") ;I $D(XMSG) ZW XMSG
Q
;
UPDATE(XX,USRIEN) ;Update effective date
N PC,PC1
S PC=$O(^VA(200,USRIEN,XX,"A"),-1) Q:PC'>0
S PC=0 F S PC=$O(^VA(200,USRIEN,XX,PC)) Q:PC'>0 D
.S PC1=$P($G(^VA(200,USRIEN,XX,PC,0)),"^",3)
.I (PC1="")!(PC1'<DT) D DOPD
Q
;
DOPD ;
L +^VA(200,DA,XX,PC,0):20 I '$T D Q
.W !,"===> The user is locked. Please try this option again."
S $P(^VA(200,USRIEN,XX,PC,0),"^",2)=DT
L -^VA(200,USRIEN,XX,PC,0)
Q
;
PRSNCL(USERIEN) ;
N XUDATA,XUPSC,XUEFDA,XUEXDA,ZZ
S XUDATA=$O(^VA(200,XUTMP,"USC1","A"),-1) Q:XUDATA'>0
S XUDATA=$G(^VA(200,XUTMP,"USC1",XUDATA,0)) Q:XUDATA=""
S XUPSC=$P(XUDATA,"^")
S XUEFDA=$P(XUDATA,"^",2) I XUEFDA'>DT S XUEFDA=DT
S XUEXDA=$P(XUDATA,"^",3)
I XUEXDA<DT,XUEXDA'="" Q
N XULAST,XULDATA
S XULAST=$O(^VA(200,USERIEN,"USC1","A"),-1)
S ZZ(1,200.05,"+2,"_USERIEN_",",.01)=XUPSC
S ZZ(1,200.05,"+2,"_USERIEN_",",2)=XUEFDA
S ZZ(1,200.05,"+2,"_USERIEN_",",3)=XUEXDA
D UPDATE^DIE("","ZZ(1)")
Q:XULAST'>0
S XULDATA=$G(^VA(200,USERIEN,"USC1",XULAST,0))
S XULDATA=$P(XULDATA,"^",3)
Q:XULDATA'>DT
S $P(^VA(200,USERIEN,"USC1",XULAST,0),"^",3)=DT
Q
;
PSDRPH(USERIEN) ; Check if source user has PSDRPH key ; XU*8.0*775
Q:'$G(USERIEN) 0
Q:'$D(^VA(200,USERIEN)) 0
Q $$FIND1^DIC(200.051,","_USERIEN_",","X","PSDRPH")
;
NOCLONE(XNOCLONE) ; Array of items that can't be cloned ; XU*8.0*775
N XNOCLOIEN
S XNOCLOIEN=$$FIND1^DIC(19.1,,"X","PSDRPH") I XNOCLOIEN S XNOCLONE(200.051,XNOCLOIEN)="" ; PSDRPH key
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSERBLK 7550 printed Dec 13, 2024@02:12:23 Page 2
XUSERBLK ;SF/RWF - Bulk user (new person) COMPUTER ACCESS ;02/26/2008
+1 ;;8.0;KERNEL;**20,214,230,289,419,490,775**;Jul 10, 1995;Build 11
+2 ; Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Option: XUSERBLK
+4 ; This routine allows the Cloning of one person to a group of others.
A ;
+1 IF $GET(DUZ)'>0
WRITE !!,"You are not a known user and can't use this option."
QUIT
+2 NEW DIC,X,Y,XUTMP,DA,DIR,XUTERMDT,XUSER,XUY,%ZIS,XUIOP,XMQUIET,DIRUT,DTOUT,DUOUT,POP
+3 KILL ^TMP($JOB)
B1 WRITE @IOF,!?26,"Batch Entry of New Persons"
+1 WRITE !?26,"--------------------------",!!,"Please select a person to copy from"
+2 KILL DIC
SET DIC(0)="AEQZ"
SET DIC("A")="Template PERSON: "
SET DIC="^VA(200,"
DO ^DIC
+3 if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+4 if Y=-1
GOTO B1
+5 ; Show INFO to be copied"
+6 SET XUTMP=+Y
SET XUTMP(0)=$PIECE(Y,U,2)
SET DA=+Y
DO EN^DIQ
+7 SET DIR(0)="Y"
SET DIR("A")="Is this the person whose data you want cloned"
DO ^DIR
if $DATA(DIRUT)
QUIT
if 'Y
GOTO B1
+8 WRITE !!,"You may enter a date, when the users that are being created/updated",!,"will no longer have access to the system."
+9 SET DIR(0)="DAO^DT::AEF"
+10 SET DIR("A")="Enter (optional) TERMINATION DATE: "
+11 DO ^DIR
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+12 SET XUTERMDT=Y
+13 KILL XUSER
SET XUSER=0
+14 ; XU*8.0*775
IF $$PSDRPH(DA)
Begin DoDot:1
+15 WRITE !!,"The PSDRPH key cannot be allocated / de-allocated by this option. Please"
+16 WRITE !,"use the option 'Allocate/De-Allocate of PSDRPH Key (Audited)' if necessary."
+17 WRITE !,"The PSDRPH key will not be copied to the new user.",!
+18 SET DIR(0)="E"
SET DIR("A")="Press ENTER to continue"
DO ^DIR
End DoDot:1
B2 ;
+1 WRITE !!,?26,"Batch Entry of New Persons",!,?26,"--------------------------",!
+2 WRITE !,"Clone of: ",XUTMP(0)
IF XUTERMDT
WRITE ?49,"TERMINATION DATE: ",$$FMTE^XLFDT(XUTERMDT)
+3 ;;
B3 ;Create new entry
FOR
SET XUY=$$ADD^XUSERNEW
if XUY<0
QUIT
Begin DoDot:1
+1 IF '$PIECE(XUY,U,3)
Begin DoDot:2
+2 SET DIR(0)="Y"
SET DIR("A")=$PIECE(XUY,U,2)_" is an existing user. Do you want to include"
DO ^DIR
IF Y'=1
SET XUY=-1
QUIT
+3 SET DIR(0)="Y"
SET DIR("A")="Clear out KEYS, FILES, SECONDARY MENUS first"
DO ^DIR
+4 if Y=1
SET $PIECE(XUY,U,4)=1
+5 QUIT
End DoDot:2
+6 IF XUY>0
Begin DoDot:2
+7 SET DIR(0)="Y"
SET DIR("A")="Do You Want To Clone PERSON CLASS"
DO ^DIR
+8 if Y=1
SET $PIECE(XUY,U,5)=1
End DoDot:2
+9 if XUY>0
SET XUSER=XUSER+1
SET XUSER(XUSER)=XUY
WRITE !!,"Next!"
+10 QUIT
End DoDot:1
B4 ;
+1 if XUSER'>0
QUIT
+2 IF XUTERMDT
Begin DoDot:1
+3 NEW XUZT
+4 SET XUZT("ZTDTH")=XUTERMDT
+5 WRITE !!,"Queueing automatic deactivation for ",$$FMTE^XLFDT(XUTERMDT)
+6 SET X=$$NODEV^XUTMDEVQ("CHECK^XUSTERM1",,,.XUZT,1)
End DoDot:1
+7 WRITE !!,"Where do you want to print the COMPUTER ACCOUNT NOTIFICATION LETTERS?"
+8 SET XMQUIET=1
+9 ; "N" means don't open device
SET %ZIS="NMQ"
DO ^%ZIS
if POP
QUIT
+10 KILL XMQUIET
+11 SET XUIOP=ION_";"_IOST_";"_IOM_";"_IOSL
+12 DO HOME^%ZIS
+13 ;I ION["P-MESSAGE-HFS" G START
+14 IF '$DATA(IO("Q"))
GOTO CLONE
START ;
+1 NEW XUZT
+2 SET XUZT("ZTDTH")=$HOROLOG
+3 SET X=$$NODEV^XUTMDEVQ("CLONE^XUSERBLK",,"XUIOP;XUTMP;XUTERMDT;XUSER;XUSER(",.XUZT,1)
+4 QUIT
+5 ;;
CLONE ;;Do work
+1 NEW XUTEXT,XU1,%,DA,XUNEW,XUPURGE
+2 SET XUTEXT=$ORDER(^DIC(9.2,"B",$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),0))
+3 FOR XU1=1:1:XUSER
SET %=XUSER(XU1)
SET DA=+%
SET XUNEW=$PIECE(%,U,3)
SET XUPURGE=$PIECE(%,U,4)
DO C2
DO UPDATE("ORD",DA)
+4 KILL ^TMP($JOB)
+5 QUIT
C2 ;
+1 NEW XUU,XUU2,XFDA,XUH,XUH2,XIEN,XERR,Y,XMZ,XMM,XMDT
+2 IF '$DATA(ZTQUEUED)
WRITE !!?8,$SELECT(XUNEW:"CREATING A NEW ACCOUNT FOR '"_$PIECE(XUSER(XU1),U,2)_"'",1:"CONVERTING "_$PIECE(XUSER(XU1),U,2)_"'S ACCOUNT OVER"),!!,"One moment please..."
+3 DO BLDFDA
+4 ;if no access code treat as new
IF $PIECE(^VA(200,DA,0),U,3)']""
SET XUNEW=1
+5 ;If no verify code treat as new
IF $PIECE($GET(^VA(200,DA,.1)),U,2)']""
SET XUNEW=1
+6 SET (XUU,XUU2)="unchanged"
SET $PIECE(^VA(200,DA,0),U,11)=XUTERMDT
+7 IF XUNEW
DO ACODE
SET @XFDA@(200,DA_",",2)=XUH
DO VCODE
SET @XFDA@(200,DA_",",11)=XUH2
+8 DO UPDATE^DIE("",XFDA,XIEN,"XERR")
KILL @XFDA
+9 IF XUNEW
IF XUTEXT>0
DO LET(DA,XUTEXT)
+10 IF $DATA(^XMB(3.7,DA,0))[0
SET Y=DA
KILL XMZ
DO NEW^XM
KILL XMDT,XMM,XMZ
+11 QUIT
+12 ;
BLDFDA ;Build the FDA
+1 NEW X2,X3,X4,X5,X6,X7,XUNODE,XU,X1
+2 SET XFDA="^TMP($J,""XFDA"")"
SET XIEN="^TMP($J,""XIEN"")"
KILL ^TMP($JOB)
+3 ;Move piece on nodes from list, Build XU only once
+4 FOR X2=1:1
SET XUNODE=$PIECE($TEXT(DATA+X2),";;",2)
if XUNODE=""
QUIT
Begin DoDot:1
+5 FOR X3=1:1
SET X7=$PIECE(XUNODE,U,X3)
if X7=""
QUIT
SET X4=$$GETDD(200,X7)
SET X5=$PIECE(X4,";")
SET X6=$PIECE(X4,";",2)
Begin DoDot:2
+6 IF '$DATA(XU(2,X5))
SET XU(2,X5)=$GET(^VA(200,XUTMP,X5))
+7 if $PIECE(XU(2,X5),U,X6)]""
SET @XFDA@(200,DA_",",X7)=$PIECE(XU(2,X5),U,X6)
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 DO SUBFILE
+11 QUIT
+12 ;
GETDD(FI,FE) ;Return node;piece for a field
+1 QUIT $PIECE($GET(^DD(FI,FE,0)),U,4)
+2 ;
DATA ;;field#
+1 ;;3^8^15^29^28
+2 ;;200.04^200.05^200.06^200.09^200.1^201^
+3 ;;41^41.1^41.2
+4 ;;101.01^101.02
+5 ;;9.21^9.22
+6 ;;
+7 ;
ACODE ;
+1 NEW Z
+2 FOR Z=0:0
SET XUU=$$AC^XUS4()
SET XUH=$$EN^XUSHSH(XUU)
if '($DATA(^VA(200,"AOLD",XUH))!$DATA(^VA(200,"A",XUH)))
QUIT
+3 QUIT
+4 ;
VCODE ;
+1 SET XUU2=$$VC^XUS4()
SET XUH2=$$EN^XUSHSH(XUU2)
+2 QUIT
+3 ;
SUBFILE ;Move subfiles: Subscript, Subfile#, DINUM, Fields
+1 NEW XCNT
SET XCNT=0
+2 NEW XNOCLONE
+3 DO NOCLONE(.XNOCLONE)
KEY DO MULTI(51,200.051,1,".01,3",.XNOCLONE)
PATH ;D MULTI(19.8,".01")
FOF DO MULTI("FOF",200.032,1,".01,1,2,3,4,5,6")
DIV DO MULTI(2,200.02,1,".01")
SEC DO MULTI(203,200.03,0,".01,2")
TAB DO MULTI("ORD",200.010113,0,".01,.02,.03")
PSCLSS IF $PIECE($GET(XUSER(XU1)),U,5)=1
DO PRSNCL(DA)
+1 QUIT
+2 ;
MULTI(XSS,XSF,XDN,XDD,XNOCLONE) ;Build new data
+1 IF XUPURGE
DO CLEAR(DA,XSS)
+2 if '$DATA(^VA(200,XUTMP,XSS,0))
QUIT
+3 ;S X=^(0),Y=$S($D(^VA(200,DA,X2,0)):^(0),1:"")
+4 FOR X1=0:0
SET X1=$ORDER(^VA(200,XUTMP,XSS,X1))
if X1'>0
QUIT
SET X=^(X1,0)
Begin DoDot:1
+5 ;
if $DATA(XNOCLONE(XSF,X1))
QUIT
+6 FOR X2=1:1
SET X3=$PIECE(XDD,",",X2)
if X3=""
QUIT
Begin DoDot:2
+7 IF X3'=.01
SET @XFDA@(XSF,"?+"_XCNT_","_DA_",",X3)=$$VAL(X,X3,XSF)
QUIT
+8 SET XCNT=XCNT+1
SET @XFDA@(XSF,"?+"_XCNT_","_DA_",",.01)=$PIECE(X,U,1)
+9 if XDN
SET @XIEN@(XCNT)=X1
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
VAL(V,FE,FI) ;Get value
+1 NEW %
SET %=$$GETDD(FI,FE)
SET %=$PIECE(%,";",2)
QUIT $PIECE(V,"^",%)
+2 ;
LET(DA,XUTEXT) ;Write access letter
+1 NEW DIWF,FR,TO,BY,IOP
+2 SET DIWF="^DIC(9.2,"_XUTEXT_",1,"
SET DIWF(1)=200
SET FR=DA
SET TO=DA
SET BY="NUMBER"
SET IOP=XUIOP
DO EN2^DIWF
+3 QUIT
+4 ;
CLEAR(X4,X2) ;Clear subfile first, IEN, Subscript
+1 if $DATA(^VA(200,X4,X2,0))[0
QUIT
NEW C,XUFN,XDEL,XMSG
+2 SET C=","
SET XDEL=$NAME(^TMP($JOB,"XUBLK2"))
SET XUFN=+$PIECE(^VA(200,X4,X2,0),"^",2)
+3 FOR X1=0:0
SET X1=$ORDER(^VA(200,X4,X2,X1))
if X1'>0
QUIT
Begin DoDot:1
+4 ;Special case for KEYS
IF X2=51
SET %=$$DEL^XQKEY(X4,X1)
QUIT
+5 SET @XDEL@(XUFN,X1_C_X4_C,.01)="@"
+6 QUIT
End DoDot:1
+7 ;I $D(XMSG) ZW XMSG
IF $DATA(@XDEL)>1
DO FILE^DIE("",XDEL,"XMSG")
+8 QUIT
+9 ;
UPDATE(XX,USRIEN) ;Update effective date
+1 NEW PC,PC1
+2 SET PC=$ORDER(^VA(200,USRIEN,XX,"A"),-1)
if PC'>0
QUIT
+3 SET PC=0
FOR
SET PC=$ORDER(^VA(200,USRIEN,XX,PC))
if PC'>0
QUIT
Begin DoDot:1
+4 SET PC1=$PIECE($GET(^VA(200,USRIEN,XX,PC,0)),"^",3)
+5 IF (PC1="")!(PC1'<DT)
DO DOPD
End DoDot:1
+6 QUIT
+7 ;
DOPD ;
+1 LOCK +^VA(200,DA,XX,PC,0):20
IF '$TEST
Begin DoDot:1
+2 WRITE !,"===> The user is locked. Please try this option again."
End DoDot:1
QUIT
+3 SET $PIECE(^VA(200,USRIEN,XX,PC,0),"^",2)=DT
+4 LOCK -^VA(200,USRIEN,XX,PC,0)
+5 QUIT
+6 ;
PRSNCL(USERIEN) ;
+1 NEW XUDATA,XUPSC,XUEFDA,XUEXDA,ZZ
+2 SET XUDATA=$ORDER(^VA(200,XUTMP,"USC1","A"),-1)
if XUDATA'>0
QUIT
+3 SET XUDATA=$GET(^VA(200,XUTMP,"USC1",XUDATA,0))
if XUDATA=""
QUIT
+4 SET XUPSC=$PIECE(XUDATA,"^")
+5 SET XUEFDA=$PIECE(XUDATA,"^",2)
IF XUEFDA'>DT
SET XUEFDA=DT
+6 SET XUEXDA=$PIECE(XUDATA,"^",3)
+7 IF XUEXDA<DT
IF XUEXDA'=""
QUIT
+8 NEW XULAST,XULDATA
+9 SET XULAST=$ORDER(^VA(200,USERIEN,"USC1","A"),-1)
+10 SET ZZ(1,200.05,"+2,"_USERIEN_",",.01)=XUPSC
+11 SET ZZ(1,200.05,"+2,"_USERIEN_",",2)=XUEFDA
+12 SET ZZ(1,200.05,"+2,"_USERIEN_",",3)=XUEXDA
+13 DO UPDATE^DIE("","ZZ(1)")
+14 if XULAST'>0
QUIT
+15 SET XULDATA=$GET(^VA(200,USERIEN,"USC1",XULAST,0))
+16 SET XULDATA=$PIECE(XULDATA,"^",3)
+17 if XULDATA'>DT
QUIT
+18 SET $PIECE(^VA(200,USERIEN,"USC1",XULAST,0),"^",3)=DT
+19 QUIT
+20 ;
PSDRPH(USERIEN) ; Check if source user has PSDRPH key ; XU*8.0*775
+1 if '$GET(USERIEN)
QUIT 0
+2 if '$DATA(^VA(200,USERIEN))
QUIT 0
+3 QUIT $$FIND1^DIC(200.051,","_USERIEN_",","X","PSDRPH")
+4 ;
NOCLONE(XNOCLONE) ; Array of items that can't be cloned ; XU*8.0*775
+1 NEW XNOCLOIEN
+2 ; PSDRPH key
SET XNOCLOIEN=$$FIND1^DIC(19.1,,"X","PSDRPH")
IF XNOCLOIEN
SET XNOCLONE(200.051,XNOCLOIEN)=""
+3 QUIT
