Routine: GMPLCOPY

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")

 ;=====================================================

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)

 ;=====================================================

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)

 ;=====================================================

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)

 ;=====================================================

DELETE(DIK,DA) ;Delete the entry just added.

 D ^DIK

 W !!,"New entry not created due to invalid name!",!

 ;=====================================================

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)

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

 ;=====================================================

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

 ;=====================================================

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

 ;=================================

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)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLCOPY   4965     printed  Apr 23, 2025@18:44:23                                                                                                                                                                                                    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      ;

GMPLCOPY.m