PXRMDCPY ; SLC/PJH - Copy dialog files. ;06/12/2009
;;2.0;CLINICAL REMINDERS;**4,12**;Feb 04, 2005;Build 73
;
;Called by label from PXRMDEDT
;
;Yes/No prompts
;--------------
ASK(YESNO,TEXT,HLP,DEFAULT) ;
N X,Y,DIR
K DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="YA0"
S DIR("A")=TEXT
S DIR("B")=DEFAULT
S DIR("?")="Enter Y or N. For detailed help type ??"
S DIR("??")=U_"D HELP^PXRMDEDT(HLP)"
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!($D(DUOUT)) Q
S YESNO=$E(Y(0))
Q
;
;Copy any dialog
;---------------
ANY W IORESET
N DIC,DUOUT,DTOUT,DIROUT,DIRUT,DTYP,LFIND,LOCK,SIEN,IENN,IENO,X,Y
N PROMPT,ROOT,WHAT
S WHAT="dialog",ROOT="^PXRMD(801.41,",PROMPT="Select the dialog to copy: "
;
S DIC=ROOT,DIC(0)="AEQ",DIC("A")=PROMPT
S DIC("S")="I $P(^(0),U,4)=PXRMDTYP"
W !
D ^DIC
I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q
S IENO=$P(Y,U,1) I IENO=-1 S DIROUT="" Q
;
;Check for Uneditable flag
S LOCK=$P($G(^PXRMD(801.41,IENO,100)),U,4)
S LFIND=$P($G(^PXRMD(801.41,IENO,1)),U,5)
S DTYP=$P($G(^PXRMD(801.41,IENO,0)),U,4)
I LOCK=1,'$G(PXRMINST),DTYP="G" D Q
.W !,"This item cannot be copied." H 2
I LOCK=1,$G(LFIND)'="",$G(LFIND)'["ORD",'$G(PXRMINST),DTYP'="G" D Q
.W !,"This item cannot be copied." H 2
;
;Copy the dialog
D COPY(IENO,.IENN,0) Q:$D(DUOUT)
;
;Prompts may become forced values
I "PF"[$P(@(ROOT_IENN_",0)"),U,4) D
.;Get original process ID
.N SUB S SUB=$P($G(^PXRMD(801.41,IENO,46)),U)
.;Update GUI process in 801.41
.I SUB S DR="46///"_SUB,DIE=ROOT,DA=IENN D ^DIE
.;check if a prompt
.I $P(@(ROOT_IENN_",0)"),U,4)="P" D
..;Allow PXRM prompts to be changed into forced values
..N ANS,TEXT
..S TEXT="Change the new prompt into a forced value :"
..D ASK(.ANS,TEXT,4,"N") Q:$D(DUOUT)!$D(DTOUT) Q:ANS'="Y"
..;Store the dialog type
..S DR="4///F",DIE=ROOT,DA=IENN
..D ^DIE
.Q
;
Q
;
;Copy original dialog
;--------------------
COPY(IENO,IENN,RDIEN) ;
D SETSTART^PXRMCOPY(ROOT)
S IENN=$$GETFOIEN(ROOT)
D MERGE(IENN,IENO,ROOT) Q:$D(DUOUT)
;
S DPOS=$G(SEQ)
N DA,DIE,DIK,DIR,DR,NAME,ORGNAME,X
S ORGNAME=$P(@(ROOT_IENO_",0)"),U,1),NAME=""
;Get the new name.
F D Q:$D(DTOUT)!$D(DUOUT) Q:NAME]""
.S DIR(0)="F"_U_"3:63"_U_"K:(X?.N)!'(X'?1P.E) X"
.S DIR("A")="ENTER A UNIQUE NAME"
.;If give a default name
.S:RDIEN DIR("B")=$$NAME(IENO,ORGNAME)
.D ^DIR Q:$D(DTOUT)!$D(DUOUT)
.I Y["""" D EN^DDIOL(" name cannot contain quotes!") Q
.I $E(Y,1,4)="PXRM" D EN^DDIOL(" name cannot begin with PXRM!") Q
.I '$$VNAME^PXRMINTR(Y) Q
.I $$UNIQNAME(Y,ROOT) S NAME=Y Q
.D EN^DDIOL(" is not a unique name!")
;
Q:$D(DTOUT)!$D(DUOUT)
;
;Store the unique name
S DR=".01///^S X=NAME",DIE=ROOT,DA=IENN
D ^DIE
;
;Change the class to local and delete the sponsor
D SCAS^PXRMCOPY(801.41,IENN,"L","")
;Initialize the edit history
D INIEH^PXRMCOPY(801.41,ROOT,IENN,IENO)
;Reindex the cross-references.
S DIK=ROOT,DA=IENN
D IX^DIK
;
W !!,"Completed copy of '"_ORGNAME_"'"
W !,"into '"_NAME_"'",! H 2
;
Q
;
;Delete the entry just added
;---------------------------
DELETE S DIK=ROOT,DA=IENN D ^DIK
W !!,"New entry not created due to invalid name!",!
Q
;
;Error Handler
;-------------
ERR(DESC) ;
N ERROR,IC,REF
S ERROR(1)="Unable to update GUI PROCESS file : "_DESC
S ERROR(2)="Error in UPDATE^DIE, needs further investigation"
;Move MSG into ERROR
S REF="MSG"
F IC=3:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF
;Screen message
D BMES^XPDUTL(.ERROR)
Q
;
;Given ROOT return the first
;---------------------------
GETFOIEN(ROOT) ;Return the first open IEN in ROOT. This should be called
;after a call to SETSTART.
N ENTRY,NIEN,OIEN
S ENTRY=ROOT_0_")"
S OIEN=$P(@ENTRY,U,3)
S ENTRY=ROOT_OIEN_")"
F S NIEN=$O(@ENTRY) Q:+(NIEN-OIEN)>1 Q:+NIEN'>0 S OIEN=NIEN,ENTRY=ROOT_NIEN_")"
Q OIEN+1
;
;Use MERGE to copy ROOT(IENO into ROOT(IENN
;------------------------------------------
MERGE(IENN,IENO,ROOT) ;
N DEST,SOURCE
;
S DEST=ROOT_IENN_")"
;Lock the file before merging.
L +@DEST:10
E W !,"Another user is editing this file, try later" H 2 S DUOUT=1 Q
S SOURCE=ROOT_IENO_")"
M @DEST=@SOURCE
;Unlock the file
L -@DEST
Q
;
;Get default name
;----------------
NAME(IEN,ORG) ;
N CNT,NAME,PREV
;
S PREV=0
I $E(ORG,$L(ORG))=")",ORG[" (" D
.S PREV=+$P(ORG," (",2) S:PREV>0 ORG=$P(ORG," (",1)
F CNT=PREV+1:1 S NAME=ORG_" ("_CNT_")" Q:'$D(^PXRMD(801.41,"B",NAME))
Q NAME
;
;Copy selected dialog element OR reminder dialog
;-----------------------------------------------
SEL(IENO,RDIEN) ;
W IORESET S VALMBCK="R"
N ANS,IENN,PROMPT,ROOT,TEXT,WHAT,DPOS
S WHAT="dialog element"
S ROOT="^PXRMD(801.41,"
S PROMPT="Select the dialog to copy: "
S TEXT=$P($G(^PXRMD(801.41,IENO,0)),U)
;
I RDIEN S TEXT="Copy and replace '"_TEXT_"' "
I 'RDIEN S TEXT="Copy reminder dialog '"_TEXT_"' "
D ASK(.ANS,TEXT,2,"Y") Q:$D(DUOUT)!$D(DTOUT) Q:ANS'="Y"
;Copy
D COPY(IENO,.IENN,RDIEN) Q:$D(DUOUT)!$D(DTOUT)
;Replace dialog element in reminder dialog
I RDIEN D
.N DR,DA,DIE
.S DA=0
.F S DA=$O(^PXRMD(801.41,RDIEN,10,"D",IENO,DA)) Q:DA="" D
. . I $P($G(^PXRMD(801.41,RDIEN,10,DA,0)),U)=$G(DPOS) D
. . . S DA(1)=RDIEN
. . . S DR="2///"_IENN
. . . S DIE=ROOT_RDIEN_",10,"
. . . D ^DIE
.W !,"Replaced element'"_$P(@(ROOT_IENO_",0)"),U)_"'"
.W !,"with '"_$P(@(ROOT_IENN_",0)"),U)_"'"
.W !,"on this dialog.",!
;
;Quit screen for edit = yes
I 'RDIEN S VALMBCK="Q" Q
;
N DIR
S DIR(0)="YAO"
S DIR("A")="Do you want to edit now "
S DIR("B")="Y"
D ^DIR
I $D(DIRUT) S DUOUT=1 Q
I $E(Y(0))'="Y" S DUOUT=1 Q
W !
;Reset dialog element ien
S IENO=IENN
Q
;
;Return TRUE (1) if NAME is unique
;---------------------------------
UNIQNAME(NAME,ROOT) ;
N RETVAL,REF
S RETVAL=1,REF=ROOT_"""B"""_","_""""_NAME_""""_")"
I $D(@REF) S RETVAL=0
Q RETVAL
PXRMDCPY ; SLC/PJH - Copy dialog files. ;06/12/2009
+1 ;;2.0;CLINICAL REMINDERS;**4,12**;Feb 04, 2005;Build 73
+2 ;
+3 ;Called by label from PXRMDEDT
+4 ;
+5 ;Yes/No prompts
+6 ;--------------
ASK(YESNO,TEXT,HLP,DEFAULT) ;
+1 NEW X,Y,DIR
+2 KILL DIROUT,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="YA0"
+4 SET DIR("A")=TEXT
+5 SET DIR("B")=DEFAULT
+6 SET DIR("?")="Enter Y or N. For detailed help type ??"
+7 SET DIR("??")=U_"D HELP^PXRMDEDT(HLP)"
+8 DO ^DIR
KILL DIR
+9 IF $DATA(DIROUT)
SET DTOUT=1
+10 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+11 SET YESNO=$EXTRACT(Y(0))
+12 QUIT
+13 ;
+14 ;Copy any dialog
+15 ;---------------
ANY WRITE IORESET
+1 NEW DIC,DUOUT,DTOUT,DIROUT,DIRUT,DTYP,LFIND,LOCK,SIEN,IENN,IENO,X,Y
+2 NEW PROMPT,ROOT,WHAT
+3 SET WHAT="dialog"
SET ROOT="^PXRMD(801.41,"
SET PROMPT="Select the dialog to copy: "
+4 ;
+5 SET DIC=ROOT
SET DIC(0)="AEQ"
SET DIC("A")=PROMPT
+6 SET DIC("S")="I $P(^(0),U,4)=PXRMDTYP"
+7 WRITE !
+8 DO ^DIC
+9 IF $DATA(DUOUT)!$DATA(DTOUT)
SET DIROUT=""
QUIT
+10 SET IENO=$PIECE(Y,U,1)
IF IENO=-1
SET DIROUT=""
QUIT
+11 ;
+12 ;Check for Uneditable flag
+13 SET LOCK=$PIECE($GET(^PXRMD(801.41,IENO,100)),U,4)
+14 SET LFIND=$PIECE($GET(^PXRMD(801.41,IENO,1)),U,5)
+15 SET DTYP=$PIECE($GET(^PXRMD(801.41,IENO,0)),U,4)
+16 IF LOCK=1
IF '$GET(PXRMINST)
IF DTYP="G"
Begin DoDot:1
+17 WRITE !,"This item cannot be copied."
HANG 2
End DoDot:1
QUIT
+18 IF LOCK=1
IF $GET(LFIND)'=""
IF $GET(LFIND)'["ORD"
IF '$GET(PXRMINST)
IF DTYP'="G"
Begin DoDot:1
+19 WRITE !,"This item cannot be copied."
HANG 2
End DoDot:1
QUIT
+20 ;
+21 ;Copy the dialog
+22 DO COPY(IENO,.IENN,0)
IF $DATA(DUOUT)
QUIT
+23 ;
+24 ;Prompts may become forced values
+25 IF "PF"[$PIECE(@(ROOT_IENN_",0)"),U,4)
Begin DoDot:1
+26 ;Get original process ID
+27 NEW SUB
SET SUB=$PIECE($GET(^PXRMD(801.41,IENO,46)),U)
+28 ;Update GUI process in 801.41
+29 IF SUB
SET DR="46///"_SUB
SET DIE=ROOT
SET DA=IENN
DO ^DIE
+30 ;check if a prompt
+31 IF $PIECE(@(ROOT_IENN_",0)"),U,4)="P"
Begin DoDot:2
+32 ;Allow PXRM prompts to be changed into forced values
+33 NEW ANS,TEXT
+34 SET TEXT="Change the new prompt into a forced value :"
+35 DO ASK(.ANS,TEXT,4,"N")
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
IF ANS'="Y"
QUIT
+36 ;Store the dialog type
+37 SET DR="4///F"
SET DIE=ROOT
SET DA=IENN
+38 DO ^DIE
End DoDot:2
+39 QUIT
End DoDot:1
+40 ;
+41 QUIT
+42 ;
+43 ;Copy original dialog
+44 ;--------------------
COPY(IENO,IENN,RDIEN) ;
+1 DO SETSTART^PXRMCOPY(ROOT)
+2 SET IENN=$$GETFOIEN(ROOT)
+3 DO MERGE(IENN,IENO,ROOT)
IF $DATA(DUOUT)
QUIT
+4 ;
+5 SET DPOS=$GET(SEQ)
+6 NEW DA,DIE,DIK,DIR,DR,NAME,ORGNAME,X
+7 SET ORGNAME=$PIECE(@(ROOT_IENO_",0)"),U,1)
SET NAME=""
+8 ;Get the new name.
+9 FOR
Begin DoDot:1
+10 SET DIR(0)="F"_U_"3:63"_U_"K:(X?.N)!'(X'?1P.E) X"
+11 SET DIR("A")="ENTER A UNIQUE NAME"
+12 ;If give a default name
+13 IF RDIEN
SET DIR("B")=$$NAME(IENO,ORGNAME)
+14 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+15 IF Y[""""
DO EN^DDIOL(" name cannot contain quotes!")
QUIT
+16 IF $EXTRACT(Y,1,4)="PXRM"
DO EN^DDIOL(" name cannot begin with PXRM!")
QUIT
+17 IF '$$VNAME^PXRMINTR(Y)
QUIT
+18 IF $$UNIQNAME(Y,ROOT)
SET NAME=Y
QUIT
+19 DO EN^DDIOL(" is not a unique name!")
End DoDot:1
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
IF NAME]""
QUIT
+20 ;
+21 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+22 ;
+23 ;Store the unique name
+24 SET DR=".01///^S X=NAME"
SET DIE=ROOT
SET DA=IENN
+25 DO ^DIE
+26 ;
+27 ;Change the class to local and delete the sponsor
+28 DO SCAS^PXRMCOPY(801.41,IENN,"L","")
+29 ;Initialize the edit history
+30 DO INIEH^PXRMCOPY(801.41,ROOT,IENN,IENO)
+31 ;Reindex the cross-references.
+32 SET DIK=ROOT
SET DA=IENN
+33 DO IX^DIK
+34 ;
+35 WRITE !!,"Completed copy of '"_ORGNAME_"'"
+36 WRITE !,"into '"_NAME_"'",!
HANG 2
+37 ;
+38 QUIT
+39 ;
+40 ;Delete the entry just added
+41 ;---------------------------
DELETE SET DIK=ROOT
SET DA=IENN
DO ^DIK
+1 WRITE !!,"New entry not created due to invalid name!",!
+2 QUIT
+3 ;
+4 ;Error Handler
+5 ;-------------
ERR(DESC) ;
+1 NEW ERROR,IC,REF
+2 SET ERROR(1)="Unable to update GUI PROCESS file : "_DESC
+3 SET ERROR(2)="Error in UPDATE^DIE, needs further investigation"
+4 ;Move MSG into ERROR
+5 SET REF="MSG"
+6 FOR IC=3:1
SET REF=$QUERY(@REF)
IF REF=""
QUIT
SET ERROR(IC)=REF_"="_@REF
+7 ;Screen message
+8 DO BMES^XPDUTL(.ERROR)
+9 QUIT
+10 ;
+11 ;Given ROOT return the first
+12 ;---------------------------
GETFOIEN(ROOT) ;Return the first open IEN in ROOT. This should be called
+1 ;after a call to SETSTART.
+2 NEW ENTRY,NIEN,OIEN
+3 SET ENTRY=ROOT_0_")"
+4 SET OIEN=$PIECE(@ENTRY,U,3)
+5 SET ENTRY=ROOT_OIEN_")"
+6 FOR
SET NIEN=$ORDER(@ENTRY)
IF +(NIEN-OIEN)>1
QUIT
IF +NIEN'>0
QUIT
SET OIEN=NIEN
SET ENTRY=ROOT_NIEN_")"
+7 QUIT OIEN+1
+8 ;
+9 ;Use MERGE to copy ROOT(IENO into ROOT(IENN
+10 ;------------------------------------------
MERGE(IENN,IENO,ROOT) ;
+1 NEW DEST,SOURCE
+2 ;
+3 SET DEST=ROOT_IENN_")"
+4 ;Lock the file before merging.
+5 LOCK +@DEST:10
+6 IF '$TEST
WRITE !,"Another user is editing this file, try later"
HANG 2
SET DUOUT=1
QUIT
+7 SET SOURCE=ROOT_IENO_")"
+8 MERGE @DEST=@SOURCE
+9 ;Unlock the file
+10 LOCK -@DEST
+11 QUIT
+12 ;
+13 ;Get default name
+14 ;----------------
NAME(IEN,ORG) ;
+1 NEW CNT,NAME,PREV
+2 ;
+3 SET PREV=0
+4 IF $EXTRACT(ORG,$LENGTH(ORG))=")"
IF ORG[" ("
Begin DoDot:1
+5 SET PREV=+$PIECE(ORG," (",2)
IF PREV>0
SET ORG=$PIECE(ORG," (",1)
End DoDot:1
+6 FOR CNT=PREV+1:1
SET NAME=ORG_" ("_CNT_")"
IF '$DATA(^PXRMD(801.41,"B",NAME))
QUIT
+7 QUIT NAME
+8 ;
+9 ;Copy selected dialog element OR reminder dialog
+10 ;-----------------------------------------------
SEL(IENO,RDIEN) ;
+1 WRITE IORESET
SET VALMBCK="R"
+2 NEW ANS,IENN,PROMPT,ROOT,TEXT,WHAT,DPOS
+3 SET WHAT="dialog element"
+4 SET ROOT="^PXRMD(801.41,"
+5 SET PROMPT="Select the dialog to copy: "
+6 SET TEXT=$PIECE($GET(^PXRMD(801.41,IENO,0)),U)
+7 ;
+8 IF RDIEN
SET TEXT="Copy and replace '"_TEXT_"' "
+9 IF 'RDIEN
SET TEXT="Copy reminder dialog '"_TEXT_"' "
+10 DO ASK(.ANS,TEXT,2,"Y")
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
IF ANS'="Y"
QUIT
+11 ;Copy
+12 DO COPY(IENO,.IENN,RDIEN)
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+13 ;Replace dialog element in reminder dialog
+14 IF RDIEN
Begin DoDot:1
+15 NEW DR,DA,DIE
+16 SET DA=0
+17 FOR
SET DA=$ORDER(^PXRMD(801.41,RDIEN,10,"D",IENO,DA))
IF DA=""
QUIT
Begin DoDot:2
+18 IF $PIECE($GET(^PXRMD(801.41,RDIEN,10,DA,0)),U)=$GET(DPOS)
Begin DoDot:3
+19 SET DA(1)=RDIEN
+20 SET DR="2///"_IENN
+21 SET DIE=ROOT_RDIEN_",10,"
+22 DO ^DIE
End DoDot:3
End DoDot:2
+23 WRITE !,"Replaced element'"_$PIECE(@(ROOT_IENO_",0)"),U)_"'"
+24 WRITE !,"with '"_$PIECE(@(ROOT_IENN_",0)"),U)_"'"
+25 WRITE !,"on this dialog.",!
End DoDot:1
+26 ;
+27 ;Quit screen for edit = yes
+28 IF 'RDIEN
SET VALMBCK="Q"
QUIT
+29 ;
+30 NEW DIR
+31 SET DIR(0)="YAO"
+32 SET DIR("A")="Do you want to edit now "
+33 SET DIR("B")="Y"
+34 DO ^DIR
+35 IF $DATA(DIRUT)
SET DUOUT=1
QUIT
+36 IF $EXTRACT(Y(0))'="Y"
SET DUOUT=1
QUIT
+37 WRITE !
+38 ;Reset dialog element ien
+39 SET IENO=IENN
+40 QUIT
+41 ;
+42 ;Return TRUE (1) if NAME is unique
+43 ;---------------------------------
UNIQNAME(NAME,ROOT) ;
+1 NEW RETVAL,REF
+2 SET RETVAL=1
SET REF=ROOT_"""B"""_","_""""_NAME_""""_")"
+3 IF $DATA(@REF)
SET RETVAL=0
+4 QUIT RETVAL
