- 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 Jan 18, 2025@03:13:34 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