- PXRMCOPY ;SLC/PKR,PJH - Copy various reminder files. ;Jun 29, 2021@11:59:53
- ;;2.0;CLINICAL REMINDERS;**6,12,26,45,71**;Feb 04, 2005;Build 43
- ;
- ;=====================================================
- COPY(PROMPT,ROOT,WHAT) ;Copy an entry of ROOT into a new entry.
- N DIROUT,DTOUT,DUOUT
- F D GETORGR Q:$D(DIROUT) Q:$D(DTOUT)
- Q
- ;
- ;=====================================================
- GETORGR ;Look-up logic to get and copy source entry to destination.
- N DIC,IENN,IENO,Y
- S DIC=ROOT,DIC(0)="AEMQ",DIC("A")=PROMPT
- W !
- D ^DIC
- I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q
- S IENO=$P(Y,U,1)
- I IENO=-1 S DIROUT="" Q
- D GETORGRC(IENO,.IENN,ROOT,WHAT,0)
- Q
- ;
- GETORGRC(IENO,IENN,ROOT,WHAT,SKIP) ;
- N DA,DIC,DIE,DIK,DIR,DIRUT,FAIL,FDA,FIELDLEN,FILE
- N HASGF,IENS,MSG,NAME,ORGNAME,X,Y
- ; reminder dialog checks
- S DIC=ROOT,FAIL=0
- N DTYP,LFIND,LOCK
- I ROOT="^PXRMD(801.41," D
- .;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)
- .S HASGF=$$HASGF(IENO)
- .I HASGF D
- ..I $P($G(^PXRMD(801.41,IENO,0)),U)="VA-TICKLER ELEMENT" Q
- ..W !,"This item cannot be copied." S FAIL=1 H 2 Q
- .I LOCK=1,'$G(PXRMINST),DTYP="G" D Q
- ..W !,"This item cannot be copied." S FAIL=1 H 2
- .I LOCK=1,$G(LFIND)'="",$G(LFIND)'["ORD",'$G(PXRMINST),DTYP'="G" D Q
- ..W !,"This item cannot be copied." S FAIL=1 H 2
- ;
- I FAIL=1 Q
- ;Set the starting place for additions.
- D SETSTART^PXRMCOPY(DIC)
- S IENN=$$GETFOIEN(ROOT)
- D MERGE(IENN,IENO,ROOT)
- ;
- ;Get the new name.
- S ORGNAME=$P(@(ROOT_IENO_",0)"),U,1)
- S FILE=$$FNFR^PXRMUTIL(ROOT)
- S FIELDLEN=$$GET1^DID(FILE,.01,"","FIELD LENGTH")
- S DIR(0)="F"_U_"3:"_FIELDLEN_U_"K:(X?.N)!'(X'?1P.E) X"
- S DIR("A")="PLEASE ENTER A UNIQUE NAME"
- GETNAM D ^DIR
- I $D(DIRUT) D DELETE(ROOT,IENN) Q
- S NAME=Y
- ;
- ;Make sure the new name is valid.
- I '$$VNAME^PXRMINTR(NAME) G GETNAM
- ;
- ;Change to the new name.
- S IENS=IENN_","
- S FDA(FILE,IENS,.01)=NAME
- K MSG
- D FILE^DIE("","FDA","MSG")
- ;Check to make sure the name was not a duplicate.
- I $G(MSG("DIERR",1))=740 D G GETNAM
- . W !,NAME," is not a unique name!"
- ;Change the class to local and delete the sponsor.
- D SCAS(FILE,IENN,"L","")
- ;Initialize the edit history.
- D INIEH(FILE,ROOT,IENN,IENO)
- ;
- ;Reindex the cross-references.
- S DIK=ROOT,DA=IENN
- D IX^DIK
- I $G(PXRMDANY)=1 D Q
- .W !!,"Completed copy of '"_ORGNAME_"'"
- .W !,"into '"_NAME_"'",! H 2
- .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^PXRMDCPY(.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
- .S DTOUT=1,PXRMDANY=0
- W !
- ;
- I SKIP=1 W !,"The original "_WHAT_" "_ORGNAME_" has been copied into "_NAME_"." H 1 Q
- ;Tell the user what has happened and allow for editing of the new item.
- S DIR(0)="Y"
- S DIR("A")="Do you want to edit it now"
- S DIR("A",1)="The original "_WHAT_" "_ORGNAME_" has been copied into "_NAME_"."
- D ^DIR Q:$D(DIRUT)
- I Y D EDIT^PXRMEDIT(ROOT,IENN)
- Q
- ;
- ;=====================================================
- COPYLL ;Copy a location list.
- N PROMPT,ROOT,WHAT
- S WHAT="location list"
- S ROOT="^PXRMD(810.9,"
- S PROMPT="Select the reminder location list to copy: "
- D COPY(PROMPT,ROOT,WHAT)
- Q
- ;
- ;=====================================================
- COPYREM ;Copy a reminder definition.
- N PROMPT,ROOT,WHAT
- S WHAT="reminder"
- S ROOT="^PXD(811.9,"
- S PROMPT="Select the reminder definition to copy: "
- D COPY(PROMPT,ROOT,WHAT)
- Q
- ;
- ;=====================================================
- COPYTAX ;Copy a taxonomy.
- N PROMPT,ROOT,WHAT
- S WHAT="taxonomy"
- S ROOT="^PXD(811.2,"
- S PROMPT="Select the reminder taxonomy to copy: "
- D COPY(PROMPT,ROOT,WHAT)
- Q
- ;
- ;=====================================================
- COPYTERM ;Copy a reminder term.
- N PROMPT,ROOT,WHAT
- S WHAT="reminder term"
- S ROOT="^PXRMD(811.5,"
- S PROMPT="Select the reminder term to copy: "
- D COPY(PROMPT,ROOT,WHAT)
- Q
- ;
- ;=====================================================
- DELETE(DIK,DA) ;Delete the entry just added.
- D ^DIK
- W !!,"New entry not created due to invalid name!",!
- Q
- ;
- ;=====================================================
- 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
- ;
- ;
- HASGF(IEN) ;
- N ARRAY,CNT,DIEN,DARRAY,RESULT
- S CNT=0,RESULT=0
- I $G(PXRMINST)=1 Q RESULT
- S RESULT=$$ITEMHSGF(IEN) I RESULT=1 Q RESULT
- I '$D(^PXRMD(801.41,IEN,10)) Q RESULT
- D DITEMAR^PXRMDUTL(IEN,.ARRAY,.DARRAY,.CNT)
- S DIEN=0 F S DIEN=$O(DARRAY(DIEN)) Q:DIEN'>0!(RESULT=1) D
- .S RESULT=$$ITEMHSGF(DIEN)
- Q RESULT
- ;
- GFCANCPY(FIND) ;
- N NAME,RESULT
- S RESULT=1
- S NAME=$P($G(^PXRMD(801.46,FIND,0)),U)
- I NAME'="VIEW PROGRESS NOTE TEXT",$P(NAME," ")'="TICKLER" S RESULT=0
- Q RESULT
- ;
- ITEMHSGF(IEN) ;
- N FIND,RESULT
- S RESULT=0
- I $G(PXRMINST)=1 Q RESULT
- S FIND=$P($G(^PXRMD(801.41,IEN,1)),U,5)
- I FIND[801.46,'$$GFCANCPY(+FIND) Q 1
- S FOUND=0,FIND="" F S FIND=$O(^PXRMD(801.41,IEN,3,"B",FIND)) Q:FIND=""!(RESULT=1) D
- .I FIND[801.46,'$$GFCANCPY(+FIND) S RESULT=1
- Q RESULT
- ;
- ;=====================================================
- INIEH(FILENUM,ROOT,IENN,IENO) ;Initialize the edit history after a copy.
- ;First delete any existing history entries.
- N ENTRY,IND,IENS,FDA,FDAIEN,MSG,SFN,TARGET,WP
- D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
- S SFN=+$G(TARGET("SPECIFIER"))
- I SFN=0 Q
- S ENTRY=ROOT_IENN_",110)"
- S IND=0
- F S IND=$O(@ENTRY@(IND)) Q:+IND=0 D
- . S IENS=IND_","_IENN_","
- . S FDA(SFN,IENS,.01)="@"
- I $D(FDA(SFN)) D FILE^DIE("K","FDA","MSG")
- I $D(MSG) D AWRITE^PXRMUTIL("MSG")
- ;Establish an initial entry in the edit history.
- K FDA,MSG
- S IENS="+1,"_IENN_","
- S FDAIEN(IENN)=IENN
- S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
- S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
- S FDA(SFN,IENS,2)="WP(1,1)"
- S WP(1,1,1)="Copied from "_$$GET1^DIQ(FILENUM,IENO,.01)
- D UPDATE^DIE("E","FDA","FDAIEN","MSG")
- I $D(MSG) D AWRITE^PXRMUTIL("MSG")
- Q
- ;
- ;=====================================================
- MERGE(IENN,IENO,ROOT) ;Use MERGE to copy ROOT(IENO into ROOT(IENN.
- N DEST,SOURCE
- S DEST=ROOT_IENN_")"
- ;Lock the file before merging.
- L +@DEST:DILOCKTM
- S SOURCE=ROOT_IENO_")"
- M @DEST=@SOURCE
- ;Unlock the file
- L -@DEST
- Q
- ;
- ;=====================================================
- SCAS(FILENUM,IEN,CLASS,SPONSOR) ;Set the class field to CLASS and the sponsor
- ;field to SPONSOR.
- N IENS,FDA,MSG
- S IENS=IEN_","
- S FDA(FILENUM,IENS,100)=CLASS
- S FDA(FILENUM,IENS,101)=SPONSOR
- D FILE^DIE("K","FDA","MSG")
- I $D(MSG) D AWRITE^PXRMUTIL("MSG")
- Q
- ;
- ;=====================================================
- SETSTART(ROOT) ;Set the starting value to add new entries. Start
- ;at the begining so empty spaces are filled in.
- N CUR,ENTRY
- S ENTRY=ROOT_"0)"
- S $P(@ENTRY,U,3)=1
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMCOPY 7318 printed Jan 18, 2025@02:44:30 Page 2
- PXRMCOPY ;SLC/PKR,PJH - Copy various reminder files. ;Jun 29, 2021@11:59:53
- +1 ;;2.0;CLINICAL REMINDERS;**6,12,26,45,71**;Feb 04, 2005;Build 43
- +2 ;
- +3 ;=====================================================
- COPY(PROMPT,ROOT,WHAT) ;Copy an entry of ROOT into a new entry.
- +1 NEW DIROUT,DTOUT,DUOUT
- +2 FOR
- DO GETORGR
- if $DATA(DIROUT)
- QUIT
- if $DATA(DTOUT)
- QUIT
- +3 QUIT
- +4 ;
- +5 ;=====================================================
- GETORGR ;Look-up logic to get and copy source entry to destination.
- +1 NEW DIC,IENN,IENO,Y
- +2 SET DIC=ROOT
- SET DIC(0)="AEMQ"
- SET DIC("A")=PROMPT
- +3 WRITE !
- +4 DO ^DIC
- +5 IF $DATA(DUOUT)!$DATA(DTOUT)
- SET DIROUT=""
- QUIT
- +6 SET IENO=$PIECE(Y,U,1)
- +7 IF IENO=-1
- SET DIROUT=""
- QUIT
- +8 DO GETORGRC(IENO,.IENN,ROOT,WHAT,0)
- +9 QUIT
- +10 ;
- GETORGRC(IENO,IENN,ROOT,WHAT,SKIP) ;
- +1 NEW DA,DIC,DIE,DIK,DIR,DIRUT,FAIL,FDA,FIELDLEN,FILE
- +2 NEW HASGF,IENS,MSG,NAME,ORGNAME,X,Y
- +3 ; reminder dialog checks
- +4 SET DIC=ROOT
- SET FAIL=0
- +5 NEW DTYP,LFIND,LOCK
- +6 IF ROOT="^PXRMD(801.41,"
- Begin DoDot:1
- +7 ;Check for Uneditable flag
- +8 SET LOCK=$PIECE($GET(^PXRMD(801.41,IENO,100)),U,4)
- +9 SET LFIND=$PIECE($GET(^PXRMD(801.41,IENO,1)),U,5)
- +10 SET DTYP=$PIECE($GET(^PXRMD(801.41,IENO,0)),U,4)
- +11 SET HASGF=$$HASGF(IENO)
- +12 IF HASGF
- Begin DoDot:2
- +13 IF $PIECE($GET(^PXRMD(801.41,IENO,0)),U)="VA-TICKLER ELEMENT"
- QUIT
- +14 WRITE !,"This item cannot be copied."
- SET FAIL=1
- HANG 2
- QUIT
- End DoDot:2
- +15 IF LOCK=1
- IF '$GET(PXRMINST)
- IF DTYP="G"
- Begin DoDot:2
- +16 WRITE !,"This item cannot be copied."
- SET FAIL=1
- HANG 2
- End DoDot:2
- QUIT
- +17 IF LOCK=1
- IF $GET(LFIND)'=""
- IF $GET(LFIND)'["ORD"
- IF '$GET(PXRMINST)
- IF DTYP'="G"
- Begin DoDot:2
- +18 WRITE !,"This item cannot be copied."
- SET FAIL=1
- HANG 2
- End DoDot:2
- QUIT
- End DoDot:1
- +19 ;
- +20 IF FAIL=1
- QUIT
- +21 ;Set the starting place for additions.
- +22 DO SETSTART^PXRMCOPY(DIC)
- +23 SET IENN=$$GETFOIEN(ROOT)
- +24 DO MERGE(IENN,IENO,ROOT)
- +25 ;
- +26 ;Get the new name.
- +27 SET ORGNAME=$PIECE(@(ROOT_IENO_",0)"),U,1)
- +28 SET FILE=$$FNFR^PXRMUTIL(ROOT)
- +29 SET FIELDLEN=$$GET1^DID(FILE,.01,"","FIELD LENGTH")
- +30 SET DIR(0)="F"_U_"3:"_FIELDLEN_U_"K:(X?.N)!'(X'?1P.E) X"
- +31 SET DIR("A")="PLEASE ENTER A UNIQUE NAME"
- GETNAM DO ^DIR
- +1 IF $DATA(DIRUT)
- DO DELETE(ROOT,IENN)
- QUIT
- +2 SET NAME=Y
- +3 ;
- +4 ;Make sure the new name is valid.
- +5 IF '$$VNAME^PXRMINTR(NAME)
- GOTO GETNAM
- +6 ;
- +7 ;Change to the new name.
- +8 SET IENS=IENN_","
- +9 SET FDA(FILE,IENS,.01)=NAME
- +10 KILL MSG
- +11 DO FILE^DIE("","FDA","MSG")
- +12 ;Check to make sure the name was not a duplicate.
- +13 IF $GET(MSG("DIERR",1))=740
- Begin DoDot:1
- +14 WRITE !,NAME," is not a unique name!"
- End DoDot:1
- GOTO GETNAM
- +15 ;Change the class to local and delete the sponsor.
- +16 DO SCAS(FILE,IENN,"L","")
- +17 ;Initialize the edit history.
- +18 DO INIEH(FILE,ROOT,IENN,IENO)
- +19 ;
- +20 ;Reindex the cross-references.
- +21 SET DIK=ROOT
- SET DA=IENN
- +22 DO IX^DIK
- +23 IF $GET(PXRMDANY)=1
- Begin DoDot:1
- +24 WRITE !!,"Completed copy of '"_ORGNAME_"'"
- +25 WRITE !,"into '"_NAME_"'",!
- HANG 2
- +26 IF $PIECE(@(ROOT_IENN_",0)"),U,4)="P"
- Begin DoDot:2
- +27 ;Allow PXRM prompts to be changed into forced values
- +28 NEW ANS,TEXT
- +29 SET TEXT="Change the new prompt into a forced value :"
- +30 DO ASK^PXRMDCPY(.ANS,TEXT,4,"N")
- if $DATA(DUOUT)!$DATA(DTOUT)
- QUIT
- if ANS'="Y"
- QUIT
- +31 ;Store the dialog type
- +32 SET DR="4///F"
- SET DIE=ROOT
- SET DA=IENN
- +33 DO ^DIE
- End DoDot:2
- +34 SET DTOUT=1
- SET PXRMDANY=0
- End DoDot:1
- QUIT
- +35 WRITE !
- +36 ;
- +37 IF SKIP=1
- WRITE !,"The original "_WHAT_" "_ORGNAME_" has been copied into "_NAME_"."
- HANG 1
- QUIT
- +38 ;Tell the user what has happened and allow for editing of the new item.
- +39 SET DIR(0)="Y"
- +40 SET DIR("A")="Do you want to edit it now"
- +41 SET DIR("A",1)="The original "_WHAT_" "_ORGNAME_" has been copied into "_NAME_"."
- +42 DO ^DIR
- if $DATA(DIRUT)
- QUIT
- +43 IF Y
- DO EDIT^PXRMEDIT(ROOT,IENN)
- +44 QUIT
- +45 ;
- +46 ;=====================================================
- COPYLL ;Copy a location list.
- +1 NEW PROMPT,ROOT,WHAT
- +2 SET WHAT="location list"
- +3 SET ROOT="^PXRMD(810.9,"
- +4 SET PROMPT="Select the reminder location list to copy: "
- +5 DO COPY(PROMPT,ROOT,WHAT)
- +6 QUIT
- +7 ;
- +8 ;=====================================================
- COPYREM ;Copy a reminder definition.
- +1 NEW PROMPT,ROOT,WHAT
- +2 SET WHAT="reminder"
- +3 SET ROOT="^PXD(811.9,"
- +4 SET PROMPT="Select the reminder definition to copy: "
- +5 DO COPY(PROMPT,ROOT,WHAT)
- +6 QUIT
- +7 ;
- +8 ;=====================================================
- COPYTAX ;Copy a taxonomy.
- +1 NEW PROMPT,ROOT,WHAT
- +2 SET WHAT="taxonomy"
- +3 SET ROOT="^PXD(811.2,"
- +4 SET PROMPT="Select the reminder taxonomy to copy: "
- +5 DO COPY(PROMPT,ROOT,WHAT)
- +6 QUIT
- +7 ;
- +8 ;=====================================================
- COPYTERM ;Copy a reminder term.
- +1 NEW PROMPT,ROOT,WHAT
- +2 SET WHAT="reminder term"
- +3 SET ROOT="^PXRMD(811.5,"
- +4 SET PROMPT="Select the reminder term to copy: "
- +5 DO COPY(PROMPT,ROOT,WHAT)
- +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(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 ;
- HASGF(IEN) ;
- +1 NEW ARRAY,CNT,DIEN,DARRAY,RESULT
- +2 SET CNT=0
- SET RESULT=0
- +3 IF $GET(PXRMINST)=1
- QUIT RESULT
- +4 SET RESULT=$$ITEMHSGF(IEN)
- IF RESULT=1
- QUIT RESULT
- +5 IF '$DATA(^PXRMD(801.41,IEN,10))
- QUIT RESULT
- +6 DO DITEMAR^PXRMDUTL(IEN,.ARRAY,.DARRAY,.CNT)
- +7 SET DIEN=0
- FOR
- SET DIEN=$ORDER(DARRAY(DIEN))
- if DIEN'>0!(RESULT=1)
- QUIT
- Begin DoDot:1
- +8 SET RESULT=$$ITEMHSGF(DIEN)
- End DoDot:1
- +9 QUIT RESULT
- +10 ;
- GFCANCPY(FIND) ;
- +1 NEW NAME,RESULT
- +2 SET RESULT=1
- +3 SET NAME=$PIECE($GET(^PXRMD(801.46,FIND,0)),U)
- +4 IF NAME'="VIEW PROGRESS NOTE TEXT"
- IF $PIECE(NAME," ")'="TICKLER"
- SET RESULT=0
- +5 QUIT RESULT
- +6 ;
- ITEMHSGF(IEN) ;
- +1 NEW FIND,RESULT
- +2 SET RESULT=0
- +3 IF $GET(PXRMINST)=1
- QUIT RESULT
- +4 SET FIND=$PIECE($GET(^PXRMD(801.41,IEN,1)),U,5)
- +5 IF FIND[801.46
- IF '$$GFCANCPY(+FIND)
- QUIT 1
- +6 SET FOUND=0
- SET FIND=""
- FOR
- SET FIND=$ORDER(^PXRMD(801.41,IEN,3,"B",FIND))
- if FIND=""!(RESULT=1)
- QUIT
- Begin DoDot:1
- +7 IF FIND[801.46
- IF '$$GFCANCPY(+FIND)
- SET RESULT=1
- End DoDot:1
- +8 QUIT RESULT
- +9 ;
- +10 ;=====================================================
- INIEH(FILENUM,ROOT,IENN,IENO) ;Initialize the edit history after a copy.
- +1 ;First delete any existing history entries.
- +2 NEW ENTRY,IND,IENS,FDA,FDAIEN,MSG,SFN,TARGET,WP
- +3 DO FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
- +4 SET SFN=+$GET(TARGET("SPECIFIER"))
- +5 IF SFN=0
- QUIT
- +6 SET ENTRY=ROOT_IENN_",110)"
- +7 SET IND=0
- +8 FOR
- SET IND=$ORDER(@ENTRY@(IND))
- if +IND=0
- QUIT
- Begin DoDot:1
- +9 SET IENS=IND_","_IENN_","
- +10 SET FDA(SFN,IENS,.01)="@"
- End DoDot:1
- +11 IF $DATA(FDA(SFN))
- DO FILE^DIE("K","FDA","MSG")
- +12 IF $DATA(MSG)
- DO AWRITE^PXRMUTIL("MSG")
- +13 ;Establish an initial entry in the edit history.
- +14 KILL FDA,MSG
- +15 SET IENS="+1,"_IENN_","
- +16 SET FDAIEN(IENN)=IENN
- +17 SET FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
- +18 SET FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
- +19 SET FDA(SFN,IENS,2)="WP(1,1)"
- +20 SET WP(1,1,1)="Copied from "_$$GET1^DIQ(FILENUM,IENO,.01)
- +21 DO UPDATE^DIE("E","FDA","FDAIEN","MSG")
- +22 IF $DATA(MSG)
- DO AWRITE^PXRMUTIL("MSG")
- +23 QUIT
- +24 ;
- +25 ;=====================================================
- MERGE(IENN,IENO,ROOT) ;Use MERGE to copy ROOT(IENO into ROOT(IENN.
- +1 NEW DEST,SOURCE
- +2 SET DEST=ROOT_IENN_")"
- +3 ;Lock the file before merging.
- +4 LOCK +@DEST:DILOCKTM
- +5 SET SOURCE=ROOT_IENO_")"
- +6 MERGE @DEST=@SOURCE
- +7 ;Unlock the file
- +8 LOCK -@DEST
- +9 QUIT
- +10 ;
- +11 ;=====================================================
- SCAS(FILENUM,IEN,CLASS,SPONSOR) ;Set the class field to CLASS and the sponsor
- +1 ;field to SPONSOR.
- +2 NEW IENS,FDA,MSG
- +3 SET IENS=IEN_","
- +4 SET FDA(FILENUM,IENS,100)=CLASS
- +5 SET FDA(FILENUM,IENS,101)=SPONSOR
- +6 DO FILE^DIE("K","FDA","MSG")
- +7 IF $DATA(MSG)
- DO AWRITE^PXRMUTIL("MSG")
- +8 QUIT
- +9 ;
- +10 ;=====================================================
- SETSTART(ROOT) ;Set the starting value to add new entries. Start
- +1 ;at the begining so empty spaces are filled in.
- +2 NEW CUR,ENTRY
- +3 SET ENTRY=ROOT_"0)"
- +4 SET $PIECE(@ENTRY,U,3)=1
- +5 QUIT
- +6 ;