BEHUTIL ;MSC/IND/DKM - General Purpose Utilities ;25-Nov-2007 10:49;DKM
;;1.2;BEH UTILITIES;**1**;Mar 20, 2007
;=================================================================
; Display required header for menus
TITLE(PKG,VER) ;EP
Q:$E($G(IOST),1,2)'="C-"
N X,%ZIS,IORVON,IORVOFF,MNU
S MNU=$P(XQY0,U,2),VER="Version "_$G(VER,1.1),PKG=$G(PKG,"RPMS-EHR Management")
S X="IORVON;IORVOFF"
D ENDR^%ZISS
U IO
W @IOF,IORVON,$$GET1^DIQ(4,DUZ(2),.01),?(IOM-$L(PKG)\2),PKG,?(IOM-$L(VER)),VER,!,IORVOFF,?(IOM-$L(MNU)\2-$X),MNU
Q
; Pause for user response
PAUSE ;EP
N X
R !!,"Press ENTER or RETURN to continue...",X:$G(DTIME,300),!
Q
; Edit a parameter from a menu option
EDITPAR(PARAM) ;EP
S PARAM=$G(PARAM,$P(XQY0,U))
D TITLE(),EDITPAR^XPAREDIT(PARAM):$$CHECK(8989.51,PARAM,"Parameter")
Q
; Edit a parameter template from a menu option
EDITTMPL(TMPL) ;EP
S TMPL=$G(TMPL,$P(XQY0,U))
D TITLE(),TEDH^XPAREDIT(TMPL,"BA"):$$CHECK(8989.52,TMPL,"Parameter template")
Q
; Edit a security key assignment
EDITKEY(KEY) ;EP
N USR,X,%,XQKEYT,XQPROV,XQFDA,XQIEN
S KEY=$G(KEY,$P(XQY0,U)),KEY(0)=$$FIND1^DIC(19.1,,"X",KEY)
I 'KEY(0) D Q
.W !,"Key ",KEY," was not found.",!
.R "Press ENTER to continue...",X:DTIME,!
F D Q:USR'>0
.D TITLE()
.W !!!,KEY," Key Management",!
.S USR=$$LOOKUP(200,"Select a user for key assignment")
.Q:USR'>0
.I $D(^XUSEC(KEY,USR)) D
..W !,"This user already has the ",KEY," key.",!
..S X=$$ASK^CIAU("Do you wish to remove the key assignment","N")
..Q:X'>0
..I $$DEL^XQKEY(USR,KEY(0))
..K ^XUSEC(KEY,USR)
.E D
..W !,"This user does not currently have the ",KEY," key.",!
..S X=$$ASK^CIAU("Do you wish to assign this key to the selected user","N")
..Q:X'>0
..I $$ADD^XQKEY(USR,KEY(0))
..S ^XUSEC(KEY,USR)=""
Q
; Execute an option
EXECOPT(OPT,PAUSE) ;EP
S:OPT'=+OPT OPT=+$$FIND1^DIC(19,,"X",OPT)
D EO(20),EO(25),EO(15),PAUSE:$G(PAUSE)
Q
; Check to make sure entry exists
CHECK(FIL,VAL,ENT) ;
Q:$$FIND1^DIC(FIL,,"X",VAL) 1
W !,ENT," ",VAL," was not found.",!
D PAUSE
Q 0
EO(NODE) ;
N X
S X=$G(^DIC(19,OPT,NODE))
Q:'$L(X)
S:NODE=25 X="D "_$S(X[U:"",1:U)_X
X X
Q
; Rename a file entry
RENENTRY(FIL,OLD,NEW) ;PEP - Rename file entry
N IEN,FDA
Q:$$FIND1^DIC(FIL,,"X",NEW)
S IEN=$$FIND1^DIC(FIL,,"X",OLD)
Q:'IEN
S FDA(FIL,IEN_",",.01)=NEW
D FILE^DIE("E","FDA")
Q
; Rename a parameter
; Renames the parameter definition and the associated package for
; any package-associated instances.
; OLD = Old parameter name
; NEW = New parameter name
RENPARAM(OLD,NEW) ;EP
N DEFIEN,PARIEN,OLDPKG,NEWPKG,INST,FDA
D RENENTRY(8989.51,OLD,NEW)
S DEFIEN=$$FIND1^DIC(8989.51,,"XQ",NEW)
S OLDPKG=$$PARAMPKG(OLD)
S NEWPKG=$$PARAMPKG(NEW)
Q:'DEFIEN!'OLDPKG!'NEWPKG
S INST=""
F S INST=$O(^XTV(8989.5,"AC",DEFIEN,OLDPKG,INST)),PARIEN=0 Q:'$L(INST) D
.F S PARIEN=$O(^XTV(8989.5,"AC",DEFIEN,OLDPKG,INST,PARIEN)) Q:'PARIEN D
..S FDA(8989.5,PARIEN_",",.01)=NEWPKG
D:$D(FDA) FILE^DIE(,"FDA")
Q
; Return package reference from param name
PARAMPKG(PARAM) ;
N PKG
S PKG=PARAM
F S PKG=$O(^DIC(9.4,"C",PKG),-1) Q:$E(PARAM,1,$L(PKG))=PKG
S:$L(PKG) PKG=$O(^DIC(9.4,"C",PKG,0))
Q $S(PKG:PKG_";DIC(9.4,",1:"")
; Register a submenu under parent menu
N FDA,ITM
S MNU=$$FIND1^DIC(19,,"BX",MNU),PAR=$$FIND1^DIC(19,,"BX",$G(PAR,"BEHOMENU")),SEQ=+$G(SEQ)
Q:'MNU!'PAR
S ITM=$O(^DIC(19,PAR,10,"B",MNU,0))
S:'ITM ITM="+1"
S FDA=$NA(FDA(19.01,ITM_","_PAR_","))
S @FDA@(.01)=MNU,@FDA@(2)=SYN,@FDA@(3)=$S(SEQ<1:"@",SEQ>99:99,1:SEQ)
D UPDATE^DIE("","FDA")
Q
; Lookup an entry in file #FN using prompt PM.
LOOKUP(FN,PM,FL,SC) ;EP
Q:'FN -1
N DIC,DLAYGO,X,Y
W !
F FL=''$G(FL):-1:0 D
.S DIC=FN,DIC(0)=$S(FL:"E",1:"AE"),DIC("A")=PM_": ",X="??"
.S:$L($G(SC)) DIC("S")=SC
.D ^DIC
W !
Q $S(Y>0:+Y,1:0)
BEHUTIL ;MSC/IND/DKM - General Purpose Utilities ;25-Nov-2007 10:49;DKM
+1 ;;1.2;BEH UTILITIES;**1**;Mar 20, 2007
+2 ;=================================================================
+3 ; Display required header for menus
TITLE(PKG,VER) ;EP
+1 IF $EXTRACT($GET(IOST),1,2)'="C-"
QUIT
+2 NEW X,%ZIS,IORVON,IORVOFF,MNU
+3 SET MNU=$PIECE(XQY0,U,2)
SET VER="Version "_$GET(VER,1.1)
SET PKG=$GET(PKG,"RPMS-EHR Management")
+4 SET X="IORVON;IORVOFF"
+5 DO ENDR^%ZISS
+6 USE IO
+7 WRITE @IOF,IORVON,$$GET1^DIQ(4,DUZ(2),.01),?(IOM-$LENGTH(PKG)\2),PKG,?(IOM-$LENGTH(VER)),VER,!,IORVOFF,?(IOM-$LENGTH(MNU)\2-$X),MNU
+8 QUIT
+9 ; Pause for user response
PAUSE ;EP
+1 NEW X
+2 READ !!,"Press ENTER or RETURN to continue...",X:$GET(DTIME,300),!
+3 QUIT
+4 ; Edit a parameter from a menu option
EDITPAR(PARAM) ;EP
+1 SET PARAM=$GET(PARAM,$PIECE(XQY0,U))
+2 DO TITLE()
IF $$CHECK(8989.51,PARAM,"Parameter")
DO EDITPAR^XPAREDIT(PARAM)
+3 QUIT
+4 ; Edit a parameter template from a menu option
EDITTMPL(TMPL) ;EP
+1 SET TMPL=$GET(TMPL,$PIECE(XQY0,U))
+2 DO TITLE()
IF $$CHECK(8989.52,TMPL,"Parameter template")
DO TEDH^XPAREDIT(TMPL,"BA")
+3 QUIT
+4 ; Edit a security key assignment
EDITKEY(KEY) ;EP
+1 NEW USR,X,%,XQKEYT,XQPROV,XQFDA,XQIEN
+2 SET KEY=$GET(KEY,$PIECE(XQY0,U))
SET KEY(0)=$$FIND1^DIC(19.1,,"X",KEY)
+3 IF 'KEY(0)
Begin DoDot:1
+4 WRITE !,"Key ",KEY," was not found.",!
+5 READ "Press ENTER to continue...",X:DTIME,!
End DoDot:1
QUIT
+6 FOR
Begin DoDot:1
+7 DO TITLE()
+8 WRITE !!!,KEY," Key Management",!
+9 SET USR=$$LOOKUP(200,"Select a user for key assignment")
+10 IF USR'>0
QUIT
+11 IF $DATA(^XUSEC(KEY,USR))
Begin DoDot:2
+12 WRITE !,"This user already has the ",KEY," key.",!
+13 SET X=$$ASK^CIAU("Do you wish to remove the key assignment","N")
+14 IF X'>0
QUIT
+15 IF $$DEL^XQKEY(USR,KEY(0))
+16 KILL ^XUSEC(KEY,USR)
End DoDot:2
+17 IF '$TEST
Begin DoDot:2
+18 WRITE !,"This user does not currently have the ",KEY," key.",!
+19 SET X=$$ASK^CIAU("Do you wish to assign this key to the selected user","N")
+20 IF X'>0
QUIT
+21 IF $$ADD^XQKEY(USR,KEY(0))
+22 SET ^XUSEC(KEY,USR)=""
End DoDot:2
End DoDot:1
IF USR'>0
QUIT
+23 QUIT
+24 ; Execute an option
EXECOPT(OPT,PAUSE) ;EP
+1 IF OPT'=+OPT
SET OPT=+$$FIND1^DIC(19,,"X",OPT)
+2 DO EO(20)
DO EO(25)
DO EO(15)
IF $GET(PAUSE)
DO PAUSE
+3 QUIT
+4 ; Check to make sure entry exists
CHECK(FIL,VAL,ENT) ;
+1 IF $$FIND1^DIC(FIL,,"X",VAL)
QUIT 1
+2 WRITE !,ENT," ",VAL," was not found.",!
+3 DO PAUSE
+4 QUIT 0
EO(NODE) ;
+1 NEW X
+2 SET X=$GET(^DIC(19,OPT,NODE))
+3 IF '$LENGTH(X)
QUIT
+4 IF NODE=25
SET X="D "_$SELECT(X[U:"",1:U)_X
+5 XECUTE X
+6 QUIT
+7 ; Rename a file entry
RENENTRY(FIL,OLD,NEW) ;PEP - Rename file entry
+1 NEW IEN,FDA
+2 IF $$FIND1^DIC(FIL,,"X",NEW)
QUIT
+3 SET IEN=$$FIND1^DIC(FIL,,"X",OLD)
+4 IF 'IEN
QUIT
+5 SET FDA(FIL,IEN_",",.01)=NEW
+6 DO FILE^DIE("E","FDA")
+7 QUIT
+8 ; Rename a parameter
+9 ; Renames the parameter definition and the associated package for
+10 ; any package-associated instances.
+11 ; OLD = Old parameter name
+12 ; NEW = New parameter name
RENPARAM(OLD,NEW) ;EP
+1 NEW DEFIEN,PARIEN,OLDPKG,NEWPKG,INST,FDA
+2 DO RENENTRY(8989.51,OLD,NEW)
+3 SET DEFIEN=$$FIND1^DIC(8989.51,,"XQ",NEW)
+4 SET OLDPKG=$$PARAMPKG(OLD)
+5 SET NEWPKG=$$PARAMPKG(NEW)
+6 IF 'DEFIEN!'OLDPKG!'NEWPKG
QUIT
+7 SET INST=""
+8 FOR
SET INST=$ORDER(^XTV(8989.5,"AC",DEFIEN,OLDPKG,INST))
SET PARIEN=0
IF '$LENGTH(INST)
QUIT
Begin DoDot:1
+9 FOR
SET PARIEN=$ORDER(^XTV(8989.5,"AC",DEFIEN,OLDPKG,INST,PARIEN))
IF 'PARIEN
QUIT
Begin DoDot:2
+10 SET FDA(8989.5,PARIEN_",",.01)=NEWPKG
End DoDot:2
End DoDot:1
+11 IF $DATA(FDA)
DO FILE^DIE(,"FDA")
+12 QUIT
+13 ; Return package reference from param name
PARAMPKG(PARAM) ;
+1 NEW PKG
+2 SET PKG=PARAM
+3 FOR
SET PKG=$ORDER(^DIC(9.4,"C",PKG),-1)
IF $EXTRACT(PARAM,1,$LENGTH(PKG))=PKG
QUIT
+4 IF $LENGTH(PKG)
SET PKG=$ORDER(^DIC(9.4,"C",PKG,0))
+5 QUIT $SELECT(PKG:PKG_";DIC(9.4,",1:"")
+6 ; Register a submenu under parent menu
+1 NEW FDA,ITM
+2 SET MNU=$$FIND1^DIC(19,,"BX",MNU)
SET PAR=$$FIND1^DIC(19,,"BX",$GET(PAR,"BEHOMENU"))
SET SEQ=+$GET(SEQ)
+3 IF 'MNU!'PAR
QUIT
+4 SET ITM=$ORDER(^DIC(19,PAR,10,"B",MNU,0))
+5 IF 'ITM
SET ITM="+1"
+6 SET FDA=$NAME(FDA(19.01,ITM_","_PAR_","))
+7 SET @FDA@(.01)=MNU
SET @FDA@(2)=SYN
SET @FDA@(3)=$SELECT(SEQ<1:"@",SEQ>99:99,1:SEQ)
+8 DO UPDATE^DIE("","FDA")
+9 QUIT
+10 ; Lookup an entry in file #FN using prompt PM.
LOOKUP(FN,PM,FL,SC) ;EP
+1 IF 'FN
QUIT -1
+2 NEW DIC,DLAYGO,X,Y
+3 WRITE !
+4 FOR FL=''$GET(FL):-1:0
Begin DoDot:1
+5 SET DIC=FN
SET DIC(0)=$SELECT(FL:"E",1:"AE")
SET DIC("A")=PM_": "
SET X="??"
+6 IF $LENGTH($GET(SC))
SET DIC("S")=SC
+7 DO ^DIC
End DoDot:1
+8 WRITE !
+9 QUIT $SELECT(Y>0:+Y,1:0)
