Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XUSERBLK

XUSERBLK.m

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