TMGRPC3D ;TMG/kst/Support Functions for GUI_Config ;08/31/08 ; 5/12/10 4:01pm ;;1.0;TMG-LIB;**1**;08/31/08 ; ;"TMG RPC FUNCTIONS for a GUI config program ; ;"Kevin Toppenberg MD ;"GNU Lessor General Public License (LGPL) applies ;"7/20/08 ; ;"======================================================================= ;" RPC -- Public Functions. ;"======================================================================= ;" ;"======================================================================= ;"PRIVATE API FUNCTIONS ;"======================================================================= ;"QTERMUSR(XUDA) -- quietly inactive a given user ;"QTREAUSR(TMGDA) -- launch quiet reactivation code ;"GETSRLST(TMGOUT,TMGPARAMS) -- Get all .01 sub record entries for a subfile ;"CLONEUSR(TMGOUT,TMGPARAMS) -- replicate a record into a new record, including all subrecs. ;"CLONEREC(TMGOUT,TMGPARAMS) --- replicate a record into a new record, including all subrecs. ; ;"======================================================================= ;"======================================================================= ;"Dependencies: ;" TMGRPC3* only ; ;"======================================================================= ;"======================================================================= ; QTERMUSR(XUDA) ;"QUITELY TERMINATE USER ;"Purpose: to quietly inactive a given user ;" I traced through menu option XUSERDEACT --> XUSTERM to create below ;"Input: XUDA -- the IEN in 200 of user to inactivate ;"Note: based on code from XUSTERM ;"Results: 0 = OK, or 1^message if error ; NEW TMGRESULT SET TMGRESULT=0 NEW TMGFDA,TMGMSG,XUDT,DIC SET TMGFDA(200,+XUDA_",",9.2)="NOW" DO FILE^DIE("EK","TMGFDA","TMGMSG") IF $DATA(TMGMSG("DIERR")) DO GOTO QTUDONE . SET TMGRESULT="1^"_$$GETERSTR^TMGRPC3G(.TMGMSG)_";"_$GET(TMGOUT(1)) SET XUDT=$P(^VA(200,+XUDA,0),"^",11) ;" field 9.2 termination date DO GET^XUSTERM ;"load up info about mail, mailboxes, keys ? needed ? SET ZTDTH=XUDT ;"Task Start time. VA FileMan or $HOROLOG format SET ZTRTN="DQ1^XUSTERM1" ;"routine to be fired SET ZTDESC="DEACTIVATE USER" ;"description SET ZTSAVE("XUDA")="" ;"save variable XUDA for use in task SET ZTIO="" ;"no IO device needed DO ^%ZTLOAD ;"que a taskman task QTUDONE ; QUIT TMGRESULT ; ; QTREAUSR(TMGDA) ;"QUITELY REACTIVE USER ;"Purpose: launch quiet reactivation code ;" I traced through menu option XUSERREACT --> REACT^XUSERNEW to create below ;"Input: TMGDA -- the IEN in 200 to be reactivated ;"Results: 0 if OK, or 1^ErrMsg ;"NOTE: when user is deleated through VistA code, the access and verify codes ;" are deleted. This function does NOT replace these. ; NEW TMGRESULT SET TMGRESULT=0 NEW TMGFDA,TMGMSG,DIC,Y SET TMGFDA(200,TMGDA_",",9.2)="@" ;"Clear the Termination date DO FILE^DIE("EK","TMGFDA","TMGMSG") ;"Post data IF $DATA(TMGMSG("DIERR")) DO GOTO QRUDONE . SET TMGRESULT="1^"_$$GETERSTR^TMGRPC3G(.TMGMSG) ; KILL XMZ ;" if null, then user can access old mail. SET Y=TMGDA ;"set user to work on. DO NEW^XM ;"mailman driver -- create a mailbox for user Y ; IF +$PIECE($GET(^VA(200,TMGDA,201)),"^",1)'>0 DO ;"201;1 = PRIMARY MENU OPTION (#201) . SET TMGFDA(200,TMGDA_",",201)="EVE" ;"set default primary menu to EVE (high level!) . DO FILE^DIE("EK","TMGFDA","TMGMSG") . IF $DATA(TMGMSG("DIERR")) DO . . SET TMGRESULT="1^"_$$GETERSTR^TMGRPC3G(.TMGMSG) IF +TMGRESULT>0 GOTO QRUDONE ; KILL XMDT,XMM,XMZ DO REACT^XQ84(TMGDA) ;"See if this user's menu trees need to be rebuilt QRUDONE ; QUIT TMGRESULT ; ; GETSRLST(TMGOUT,TMGPARAMS) ;"GET SUB-RECS LIST ;"Purpose: Get all .01 sub record entries for a subfile ;"Input: TMGOUT -- an OUT PARAMETER, PASS BY REFERENCE. ;" TMGPARAMS -- SubFileNum^ParentIENS ;" SubFileNum - Subfile Number to get list from. ;" ParentIENS -- IENS for parent to get list from (e.g. "73," ;"Output: TMGOUT is filled as follows: ;" TMGOUT(0)="1^Success" or "-1^Message" ;" TMGOUT(1)=IEN^Value ;" TMGOUT(2)=IEN^Value ;" ... ;"Results: none ; SET TMGOUT(0)="1^Success" NEW TMGSUBFILE SET TMGSUBFILE=+$PIECE(TMGPARAMS,"^",1) IF TMGSUBFILE'>0 DO GOTO GSRLDONE . SET TMGOUT(0)="-1^No Subfile number supplied" NEW TMGPARIENTIENS SET TMGPARIENTIENS=$PIECE(TMGPARAMS,"^",2) IF TMGPARIENTIENS="" DO GOTO GSRLDONE . SET TMGOUT(0)="-1^No Parent IENS supplied" NEW TMGIENS SET TMGIENS=","_TMGPARIENTIENS ; DO LIST^DIC(TMGSUBFILE,TMGIENS,,"PU","*",,,,,,"TMGMSG","TMGERR") ; IF $DATA(TMGMSG("DIERR")) DO GOTO GSRLDONE . SET TMGOUT(0)="-1^See Fileman message" . SET TMGOUT(1)=$$GETERSTR^TMGRPC3G(.TMGMSG) ; NEW TMGCOUNT SET TMGCOUNT=1 NEW TMGI SET TMGI=0 FOR SET TMGI=$ORDER(TMGMSG("DILIST",TMGI)) QUIT:(+TMGI'>0) DO . NEW TMGONEENTRY SET TMGONEENTRY=$GET(TMGMSG("DILIST",TMGI,0)) . IF TMGONEENTRY="" QUIT . NEW TMGIEN SET TMGIEN=$PIECE(TMGONEENTRY,"^",1) . SET $PIECE(TMGONEENTRY,"^",1)=TMGIEN_","_TMGPARIENTIENS . SET TMGOUT(TMGCOUNT)=TMGONEENTRY . SET TMGCOUNT=TMGCOUNT+1 ; GSRLDONE ; QUIT ; ; CLONEUSR(TMGOUT,TMGPARAMS) ; ;"Purpose: to replicate a record into a new record, including all subrecs. ;" Implementation of "CLONE RECORD" request ;"Input: TMGOUT -- an OUT PARAMETER, PASS BY REFERENCE. ;" TMGPARAMS -- SourceIENS^New.01Value ;" FileNum - filename file that is to be worked in ;" SourceIENS -- source IENS for new record, (i.e. '123,' not '123') ;" New.01Value -- new value to be put into the .01 field (to distinguish it from the old record) ;"Output: TMGOUT is filled as follows: ;" TMGOUT(0)="1^Success^NewIENS" or "-1^Message" ;" TMGOUT(1)=Long Fileman message (if -1 error) ; SET TMGPARAMS="200^"_TMGPARAMS DO CLONEREC(.TMGOUT,TMGPARAMS) NEW TMGFDA,TMGMSG IF +TMGOUT(0)'=1 GOTO CUDONE NEW TMGNEWIEN SET TMGNEWIEN=+$PIECE(TMGOUT(0),"^",3) IF TMGNEWIEN="" DO GOTO CUDONE . SET TMGOUT(0)="-1^Can't find IEN of added record" ; ;"Set new user to inactive (needs editing before it is active) NEW TMGDATA SET TMGDATA(0)="200^"_TMGNEWIEN_",^7^^YES" DO POSTDATA^TMGRPC3C(.TMGOUT,.TMGDATA,"E") IF +TMGOUT(0)=1 SET $PIECE(TMGOUT(0),"^",3)=TMGNEWIEN ; CUDONE ; QUIT ; CLONEREC(TMGOUT,TMGPARAMS) ; ;"Purpose: to replicate a record into a NEW record, including all subrecs. ;" Implementation of "CLONE RECORD" request ;"Input: TMGOUT -- an OUT PARAMETER, PASS BY REFERENCE. ;" TMGPARAMS -- FileNum^SourceIENS^New.01Value ;" FileNum - filename file that is to be worked in ;" SourceIENS -- the source IENS for the new record, (i.e. 123, not 123) ;" New.01Value -- the new value to be put into the .01 field (to distinguish it from the old record) ;"Output: TMGOUT is filled as follows: ;" TMGOUT(0)="1^Success^NewIENS" or "-1^Message" ;" TMGOUT(1)=Long Fileman message (if -1 error) ;"NOTE: This hasn't been tested on subfiles yet... ; NEW TMGFILE,TMGIENS,TMGNEW01VALUE SET TMGOUT(0)="-1^Error" ;"default to error ; SET TMGFILE=+$PIECE(TMGPARAMS,"^",1) IF TMGFILE'>0 DO GOTO CRDONE . SET TMGOUT(0)="-1^No file number supplied" SET TMGIENS=$PIECE(TMGPARAMS,"^",2) IF TMGIENS="" DO GOTO CRDONE . SET TMGOUT(0)="-1^IENS supplied" IF +TMGIENS=TMGIENS DO . IF TMGIENS'["," SET TMGIENS=TMGIENS_"," SET TMGNEW01VALUE=$PIECE(TMGPARAMS,"^",3) IF TMGNEW01VALUE="" DO GOTO CRDONE . SET TMGOUT(0)="-1^No new value supplied for .01 value" ; NEW TMGARRAY,TMGMSG,TMGTEMP NEW TMGREF SET TMGREF="TMGARRAY" ; DO STUBNEWR^TMGRPC3E(TMGFILE,TMGNEW01VALUE,.TMGOUT) IF +TMGOUT(0)'=1 DO GOTO CRDONE . SET $PIECE(TMGOUT(0),"^",2)="Unable to stub in new record. "_$PIECE(TMGOUT(0),"^",2) NEW TMGNEWIEN SET TMGNEWIEN=$PIECE(TMGOUT(0),"^",3) ;"Write "The IENS of the new record is: ",TMGNEWIEN,! ;"TEMP!!! ; ;"Note: Using a "X" flag is VERY slow, because it reindexes ;" ALL XREFS for ALL entries in file (e.g. 60 seconds) ;"DO TRNMRG^TMGDIT("M",TMGFILE,TMGFILE,TMGIENS,TMGNEWIEN_",") ;"DO actual record copy. DO TRNMRG^DIT("M",TMGFILE,TMGFILE,TMGIENS,TMGNEWIEN_",") ;"do actual record copy. NEW DA,DIK SET DIK=$GET(^DIC(TMGFILE,0,"GL")) SET DA=TMGNEWIEN IF (+DA>0)&(DIK'="") DO IX1^DIK ;"index just the new record ; ;"OK if we got this far (can't check error from TRNMRG) SET TMGOUT(0)="1^Success^"_TMGNEWIEN ; CRDONE QUIT ; ;