GMPLCOPY ;ISP/TC - Copy Problem Selection Lists/Categories ;09/21/16 09:03
;;2.0;Problem List;**49**;Aug 25, 1994;Build 43
;
;=====================================================
SETCLDLM(GMPFLNM,GMPIEN,GMPCLASS) ;Set the class field to GMPCLASS and update Date Last Modified
N GMPIENS,GMPFDA,GMPMSG,GMPFLD
S GMPIENS=GMPIEN_","
S GMPFLD=$S(GMPFLNM="125":".04",GMPFLNM="125.11":".03")
S GMPFDA(GMPFLNM,GMPIENS,GMPFLD)=GMPCLASS
S GMPFDA(GMPFLNM,GMPIENS,.02)=$$DT^XLFDT
D FILE^DIE("K","GMPFDA","GMPMSG")
I $D(GMPMSG) D AWRITE("GMPMSG")
Q
;
;=====================================================
COPY(GMPPRMPT,GMPROOT,GMPWHAT,GMPVAL) ;Copy an entry of GMPROOT into a new entry.
N DIROUT,DTOUT,DUOUT
F D GETORIG Q:$D(DIROUT) Q:$D(DTOUT)
Q
;
;=====================================================
COPYCAT(GMPVAL) ;Copy a selection list category.
N GMPPRMPT,GMPROOT,GMPWHAT
S GMPWHAT="category"
S GMPROOT="^GMPL(125.11,"
S GMPPRMPT="Select the category to copy: "
D COPY(GMPPRMPT,GMPROOT,GMPWHAT,.GMPVAL)
Q
;
;=====================================================
COPYLIST ;Copy a selection list.
N GMPPRMPT,GMPROOT,GMPWHAT
S GMPWHAT="selection list"
S GMPROOT="^GMPL(125,"
S GMPPRMPT="Select the list to copy: "
D COPY(GMPPRMPT,GMPROOT,GMPWHAT)
Q
;
;=====================================================
DELETE(DIK,DA) ;Delete the entry just added.
D ^DIK
W !!,"New entry not created due to invalid name!",!
Q
;
;=====================================================
GETFOIEN(GMPROOT) ;Return the first open IEN in GMPROOT. This should be called
;after a call to SETSTART.
N GMPENTRY,GMPNIEN,GMPOIEN
S GMPENTRY=GMPROOT_0_")"
S GMPOIEN=+$P(@GMPENTRY,U,3)
S GMPENTRY=GMPROOT_GMPOIEN_")"
F S GMPNIEN=$O(@GMPENTRY) Q:+(GMPNIEN-GMPOIEN)>1 Q:+GMPNIEN'>0 S GMPOIEN=GMPNIEN,GMPENTRY=GMPROOT_GMPNIEN_")"
Q GMPOIEN+1
;
;=====================================================
GETORIG ;Look-up logic to get and copy source entry to destination.
N DIC,GMPIENN,GMPIENO,Y
S DIC=GMPROOT,DIC(0)="AEMQ",DIC("A")=GMPPRMPT
W !
D ^DIC
I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q
S GMPIENO=$P(Y,U,1)
I GMPIENO=-1 S DIROUT="" Q
D GETORIGC(GMPIENO,.GMPIENN,GMPROOT,GMPWHAT,.GMPVAL)
Q
;
GETORIGC(GMPIENO,GMPIENN,GMPROOT,GMPWHAT,GMPVAL) ;
N DA,DIC,DIE,DIK,DIR,DIRUT,GMPFDA,GMPFLDLN,GMPFILE
N GMPIENS,GMPMSG,GMPNAME,GMPORGNM,X,Y,GMPL0
S DIC=GMPROOT
;Set the starting place for additions.
D SETSTART(DIC)
S GMPIENN=$$GETFOIEN(GMPROOT)
D MERGE(GMPIENN,GMPIENO,GMPROOT)
;
;Get the new name.
S GMPORGNM=$P(@(GMPROOT_GMPIENO_",0)"),U,1)
S GMPFILE=+$P(@(GMPROOT_"0)"),U,2)
S GMPFLDLN=$$GET1^DID(GMPFILE,.01,"","FIELD LENGTH")
S DIR(0)="F"_U_"3:"_GMPFLDLN_U_"K:(X?.N)!'(X'?1P.E) X"
S DIR("A")="PLEASE ENTER A UNIQUE NAME"
GETNAM D ^DIR
I $D(DIRUT) D DELETE(GMPROOT,GMPIENN) Q
S GMPNAME=Y
;
;Make sure the new name is valid.
I '$$VNAME^GMPLINTR(GMPNAME) G GETNAM
;
;Change to the new name.
S GMPIENS=GMPIENN_","
S GMPFDA(GMPFILE,GMPIENS,.01)=GMPNAME
K GMPMSG
D FILE^DIE("","GMPFDA","GMPMSG")
;Check to make sure the name was not a duplicate.
I $G(GMPMSG("DIERR",1))=740 D G GETNAM
. W !,GMPNAME," is not a unique name!"
;Change the class to local and update Date Last Modified.
D SETCLDLM(GMPFILE,GMPIENN,"L")
;
;Reindex the cross-references.
S DIK=GMPROOT,DA=GMPIENN
D IX^DIK
;
S GMPL0=$G(@(GMPROOT_GMPIENN_",0)"))
S GMPVAL=GMPIENN_U_GMPL0
W !!,"The original "_GMPWHAT_" "_GMPORGNM_" has been copied into "_GMPNAME_"." H 1
Q
;
;=====================================================
MERGE(GMPIENN,GMPIENO,GMPROOT) ;Use MERGE to copy GMPROOT(GMPIENO into GMPROOT(GMPIENN.
N GMPDEST,GMPSRCE
S GMPDEST=GMPROOT_GMPIENN_")"
;Lock the file before merging.
L +@GMPDEST:DILOCKTM
S GMPSRCE=GMPROOT_GMPIENO_")"
M @GMPDEST=@GMPSRCE
;Unlock the file
L -@GMPDEST
Q
;
;=====================================================
SETSTART(GMPROOT) ;Set the starting value to add new entries. Start
;at the begining so empty spaces are filled in.
N GMPCUR,GMPENTRY
S GMPENTRY=GMPROOT_"0)"
S $P(@GMPENTRY,U,3)=1
Q
;
;=================================
AWRITE(GMPREF) ;Write all the descendants of the array reference, including the
;array. REF is the starting array reference, for example A or
;^TMP("PXRM",$J).
N GMPDONE,GMPIND,GMPLEN,GMPLN,GMPPRT,GMPROOT,GMPSTRT,GMPTMP,GMPTXT
I GMPREF="" Q
S GMPLN=0
S GMPPRT=$P(GMPREF,")",1)
;Build the root so we can tell when we are done.
S GMPTMP=$NA(@GMPREF)
S GMPROOT=$P(GMPTMP,")",1)
S GMPREF=$Q(@GMPREF)
I GMPREF'[GMPROOT Q
S GMPDONE=0
F Q:(GMPREF="")!(GMPDONE) D
. S GMPSTRT=$F(GMPREF,GMPROOT)
. S GMPLEN=$L(GMPREF)
. S GMPIND=$E(GMPREF,GMPSTRT,GMPLEN)
. S GMPLN=GMPLN+1,GMPTXT(GMPLN)=GMPPRT_GMPIND_"="_@GMPREF
. S GMPREF=$Q(@GMPREF)
. I GMPREF'[GMPROOT S GMPDONE=1
D MES^XPDUTL(.GMPTXT)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLCOPY 4965 printed Sep 23, 2025@20:06:02 Page 2
GMPLCOPY ;ISP/TC - Copy Problem Selection Lists/Categories ;09/21/16 09:03
+1 ;;2.0;Problem List;**49**;Aug 25, 1994;Build 43
+2 ;
+3 ;=====================================================
SETCLDLM(GMPFLNM,GMPIEN,GMPCLASS) ;Set the class field to GMPCLASS and update Date Last Modified
+1 NEW GMPIENS,GMPFDA,GMPMSG,GMPFLD
+2 SET GMPIENS=GMPIEN_","
+3 SET GMPFLD=$SELECT(GMPFLNM="125":".04",GMPFLNM="125.11":".03")
+4 SET GMPFDA(GMPFLNM,GMPIENS,GMPFLD)=GMPCLASS
+5 SET GMPFDA(GMPFLNM,GMPIENS,.02)=$$DT^XLFDT
+6 DO FILE^DIE("K","GMPFDA","GMPMSG")
+7 IF $DATA(GMPMSG)
DO AWRITE("GMPMSG")
+8 QUIT
+9 ;
+10 ;=====================================================
COPY(GMPPRMPT,GMPROOT,GMPWHAT,GMPVAL) ;Copy an entry of GMPROOT into a new entry.
+1 NEW DIROUT,DTOUT,DUOUT
+2 FOR
DO GETORIG
if $DATA(DIROUT)
QUIT
if $DATA(DTOUT)
QUIT
+3 QUIT
+4 ;
+5 ;=====================================================
COPYCAT(GMPVAL) ;Copy a selection list category.
+1 NEW GMPPRMPT,GMPROOT,GMPWHAT
+2 SET GMPWHAT="category"
+3 SET GMPROOT="^GMPL(125.11,"
+4 SET GMPPRMPT="Select the category to copy: "
+5 DO COPY(GMPPRMPT,GMPROOT,GMPWHAT,.GMPVAL)
+6 QUIT
+7 ;
+8 ;=====================================================
COPYLIST ;Copy a selection list.
+1 NEW GMPPRMPT,GMPROOT,GMPWHAT
+2 SET GMPWHAT="selection list"
+3 SET GMPROOT="^GMPL(125,"
+4 SET GMPPRMPT="Select the list to copy: "
+5 DO COPY(GMPPRMPT,GMPROOT,GMPWHAT)
+6 QUIT
+7 ;
+8 ;=====================================================
DELETE(DIK,DA) ;Delete the entry just added.
+1 DO ^DIK
+2 WRITE !!,"New entry not created due to invalid name!",!
+3 QUIT
+4 ;
+5 ;=====================================================
GETFOIEN(GMPROOT) ;Return the first open IEN in GMPROOT. This should be called
+1 ;after a call to SETSTART.
+2 NEW GMPENTRY,GMPNIEN,GMPOIEN
+3 SET GMPENTRY=GMPROOT_0_")"
+4 SET GMPOIEN=+$PIECE(@GMPENTRY,U,3)
+5 SET GMPENTRY=GMPROOT_GMPOIEN_")"
+6 FOR
SET GMPNIEN=$ORDER(@GMPENTRY)
if +(GMPNIEN-GMPOIEN)>1
QUIT
if +GMPNIEN'>0
QUIT
SET GMPOIEN=GMPNIEN
SET GMPENTRY=GMPROOT_GMPNIEN_")"
+7 QUIT GMPOIEN+1
+8 ;
+9 ;=====================================================
GETORIG ;Look-up logic to get and copy source entry to destination.
+1 NEW DIC,GMPIENN,GMPIENO,Y
+2 SET DIC=GMPROOT
SET DIC(0)="AEMQ"
SET DIC("A")=GMPPRMPT
+3 WRITE !
+4 DO ^DIC
+5 IF $DATA(DUOUT)!$DATA(DTOUT)
SET DIROUT=""
QUIT
+6 SET GMPIENO=$PIECE(Y,U,1)
+7 IF GMPIENO=-1
SET DIROUT=""
QUIT
+8 DO GETORIGC(GMPIENO,.GMPIENN,GMPROOT,GMPWHAT,.GMPVAL)
+9 QUIT
+10 ;
GETORIGC(GMPIENO,GMPIENN,GMPROOT,GMPWHAT,GMPVAL) ;
+1 NEW DA,DIC,DIE,DIK,DIR,DIRUT,GMPFDA,GMPFLDLN,GMPFILE
+2 NEW GMPIENS,GMPMSG,GMPNAME,GMPORGNM,X,Y,GMPL0
+3 SET DIC=GMPROOT
+4 ;Set the starting place for additions.
+5 DO SETSTART(DIC)
+6 SET GMPIENN=$$GETFOIEN(GMPROOT)
+7 DO MERGE(GMPIENN,GMPIENO,GMPROOT)
+8 ;
+9 ;Get the new name.
+10 SET GMPORGNM=$PIECE(@(GMPROOT_GMPIENO_",0)"),U,1)
+11 SET GMPFILE=+$PIECE(@(GMPROOT_"0)"),U,2)
+12 SET GMPFLDLN=$$GET1^DID(GMPFILE,.01,"","FIELD LENGTH")
+13 SET DIR(0)="F"_U_"3:"_GMPFLDLN_U_"K:(X?.N)!'(X'?1P.E) X"
+14 SET DIR("A")="PLEASE ENTER A UNIQUE NAME"
GETNAM DO ^DIR
+1 IF $DATA(DIRUT)
DO DELETE(GMPROOT,GMPIENN)
QUIT
+2 SET GMPNAME=Y
+3 ;
+4 ;Make sure the new name is valid.
+5 IF '$$VNAME^GMPLINTR(GMPNAME)
GOTO GETNAM
+6 ;
+7 ;Change to the new name.
+8 SET GMPIENS=GMPIENN_","
+9 SET GMPFDA(GMPFILE,GMPIENS,.01)=GMPNAME
+10 KILL GMPMSG
+11 DO FILE^DIE("","GMPFDA","GMPMSG")
+12 ;Check to make sure the name was not a duplicate.
+13 IF $GET(GMPMSG("DIERR",1))=740
Begin DoDot:1
+14 WRITE !,GMPNAME," is not a unique name!"
End DoDot:1
GOTO GETNAM
+15 ;Change the class to local and update Date Last Modified.
+16 DO SETCLDLM(GMPFILE,GMPIENN,"L")
+17 ;
+18 ;Reindex the cross-references.
+19 SET DIK=GMPROOT
SET DA=GMPIENN
+20 DO IX^DIK
+21 ;
+22 SET GMPL0=$GET(@(GMPROOT_GMPIENN_",0)"))
+23 SET GMPVAL=GMPIENN_U_GMPL0
+24 WRITE !!,"The original "_GMPWHAT_" "_GMPORGNM_" has been copied into "_GMPNAME_"."
HANG 1
+25 QUIT
+26 ;
+27 ;=====================================================
MERGE(GMPIENN,GMPIENO,GMPROOT) ;Use MERGE to copy GMPROOT(GMPIENO into GMPROOT(GMPIENN.
+1 NEW GMPDEST,GMPSRCE
+2 SET GMPDEST=GMPROOT_GMPIENN_")"
+3 ;Lock the file before merging.
+4 LOCK +@GMPDEST:DILOCKTM
+5 SET GMPSRCE=GMPROOT_GMPIENO_")"
+6 MERGE @GMPDEST=@GMPSRCE
+7 ;Unlock the file
+8 LOCK -@GMPDEST
+9 QUIT
+10 ;
+11 ;=====================================================
SETSTART(GMPROOT) ;Set the starting value to add new entries. Start
+1 ;at the begining so empty spaces are filled in.
+2 NEW GMPCUR,GMPENTRY
+3 SET GMPENTRY=GMPROOT_"0)"
+4 SET $PIECE(@GMPENTRY,U,3)=1
+5 QUIT
+6 ;
+7 ;=================================
AWRITE(GMPREF) ;Write all the descendants of the array reference, including the
+1 ;array. REF is the starting array reference, for example A or
+2 ;^TMP("PXRM",$J).
+3 NEW GMPDONE,GMPIND,GMPLEN,GMPLN,GMPPRT,GMPROOT,GMPSTRT,GMPTMP,GMPTXT
+4 IF GMPREF=""
QUIT
+5 SET GMPLN=0
+6 SET GMPPRT=$PIECE(GMPREF,")",1)
+7 ;Build the root so we can tell when we are done.
+8 SET GMPTMP=$NAME(@GMPREF)
+9 SET GMPROOT=$PIECE(GMPTMP,")",1)
+10 SET GMPREF=$QUERY(@GMPREF)
+11 IF GMPREF'[GMPROOT
QUIT
+12 SET GMPDONE=0
+13 FOR
if (GMPREF="")!(GMPDONE)
QUIT
Begin DoDot:1
+14 SET GMPSTRT=$FIND(GMPREF,GMPROOT)
+15 SET GMPLEN=$LENGTH(GMPREF)
+16 SET GMPIND=$EXTRACT(GMPREF,GMPSTRT,GMPLEN)
+17 SET GMPLN=GMPLN+1
SET GMPTXT(GMPLN)=GMPPRT_GMPIND_"="_@GMPREF
+18 SET GMPREF=$QUERY(@GMPREF)
+19 IF GMPREF'[GMPROOT
SET GMPDONE=1
End DoDot:1
+20 DO MES^XPDUTL(.GMPTXT)
+21 QUIT
+22 ;
