PXRMV1I ; SLC/PJH,PKR - Inits for new REMINDER package. ;06/08/2000
;;1.5;CLINICAL REMINDERS;;Jun 19, 2000
;IHS/ITSC/LJF 5/30/2003 fixed call to PXRMCOPY - has different # of parameters
; bypassed connecting the findings to the terms for the
; VA-HEP C RISK ASSESSMENT reminder - variable ptr problem
; prevented sending any data in file 811.5 - Reminder Term
;
Q
;
;------------------------
BLDLSTR ;Make sure all the logic strings get built.
D BMES^XPDUTL("Building logic strings")
N IEN
S IEN=0
F S IEN=$O(^PXD(811.9,IEN)) Q:+IEN=0 D
. I $P(^PXD(811.9,IEN,0),U,1)["VA-" Q
. D BLDPCLS^PXRMLOGX(IEN,"")
. D BLDRESLS^PXRMLOGX(IEN,"")
. D BLDAFL^PXRMLOGX(IEN,"")
. D BLDINFL^PXRMLOGX(IEN,"")
Q
;
;----------------------------------------------------------------
CHECK(ROUTINE) ;Search for routine entry point in the new computed findings
;file
N SUB,TAG,FOUND
S SUB=0,FOUND=""
F S SUB=$O(^PXRMD(811.4,SUB)) Q:'SUB D Q:FOUND]""
.S TAG=$P($G(^PXRMD(811.4,SUB,0)),U,2,3)
.I $P(TAG,U,2)_";"_$P(TAG,U)=ROUTINE S FOUND=SUB
Q FOUND
;
;--------------------------------------
COMP ;Computed findings - set up file #811.4
N ARRAY,DATA,DESC,IEN,STRING,SUB,TAG,FDA,FDAIEN
;Get each reminder in turn
S STRING="Building Computed Findings file"
D BMES^XPDUTL(STRING)
;Make sure any converted computed findings go into the site's
;number space.
;D SETSTART^PXRMCOPY("^PXRMD(811.4,",0) ;IHS/ITSC/LJF 5/30/2003
D SETSTART^PXRMCOPY("^PXRMD(811.4,") ;IHS/ITSC/LJF 5/30/2003 wrong # of parameters
S IEN=0
F S IEN=$O(^PXD(811.9,IEN)) Q:'IEN D
.;Skip VA- reminders
.I $P(^PXD(811.9,IEN,0),U,1)["VA-" Q
.I $D(REDO) Q:IEN'=REMINDER
.S SUB=0
.;Get computed findings records
.F S SUB=$O(^PXD(811.9,IEN,10,SUB)) Q:'SUB D
..S DATA=$G(^PXD(811.9,IEN,10,SUB,0)) Q:DATA=""
..;Extract description and routine entry point
..S TAG=$P(DATA,U),DESC=$P(DATA,U,5)
..;Ignore null Computed findings
..I TAG="" Q
..;Default null name to routine name
..I DESC="" S DESC=TAG
..;Create ARRAY of routine entry points
..;(using first short description found)
..I '$D(ARRAY(TAG)) S ARRAY(TAG)=DESC Q
..;If already set-up ignore
..I ARRAY(TAG)=DESC Q
..;Otherwise log duplication
..S STRING="The following CF's use the same routine"
..D BMES^XPDUTL(STRING)
..D BMES^XPDUTL(ARRAY(TAG)_" (retained)")
..D BMES^XPDUTL(DESC_" (replaced)")
;
;Create FDA for each entry in ARRAY
S TAG=""
F S TAG=$O(ARRAY(TAG)) Q:TAG="" D Q:$D(MSG)
.S DESC=ARRAY(TAG)
.;Check if entry already exists
.I $$CHECK(TAG) D Q
..S STRING="Skipping update - CF "_DESC
..D BMES^XPDUTL(STRING)
.;Build FDA array
.K FDAIEN,FDA
.;Description
.S FDA(811.4,"+1,",.01)=DESC
.;Routine
.S FDA(811.4,"+1,",.02)=$P(TAG,";",2)
.;Entry Point
.S FDA(811.4,"+1,",.03)=$P(TAG,";")
.;Print name, default to the .01 field
.S FDA(811.4,"+1,",.04)=DESC
.D UPDATE^DIE("","FDA","FDAIEN","MSG")
.I $D(MSG) D ERR
Q
;
;------------------------
DELCF ;Delete any existing entries in the computed findings file.
;Skip those in a site number space. This will apply to test
;sites only.
N DA,DIK,SNUMS
S SNUMS=100000
S DIK="^PXRMD(811.4,"
S DA=0
F S DA=$O(^PXRMD(811.4,DA)) Q:(+DA=0)!(+DA>SNUMS) D
. D ^DIK
Q
;
;------------------------
DELDD ;Delete data dictionaries
N DIU,FILENUM
S DIU(0)=""
F FILENUM=800,801.41,801.42,801.43,801.45,801.9,801.95,810.1,811.2,811.3,811.4,811.5,811.6,811.7,811.9 D
. S DIU=FILENUM
. D EN^DIU2
Q
;
;------------------------
DELMH ;Delete any existing MH result entries in dialog file.
;Skip those in a site number space. This will apply to test
;sites only.
N DA,DIK,DTYP,SNUMS
S SNUMS=100000
S DIK="^PXRMD(801.41,"
S DA=0
F S DA=$O(^PXRMD(801.41,DA)) Q:(+DA=0)!(+DA>SNUMS) D
.;Dialog type
.S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
.;Delete only result groups and result elements
.I (DTYP="T")!(DTYP="S") D ^DIK
Q
;
;------------------------
DELORD ;Delete obsolete reminder definitions.
N DA,DIK
S DIK="^PXD(811.9,"
S DA=+$O(^PXD(811.9,"B","VA-*SEAT BELT AND ACCIDENT SCREEN",""))
I DA>0 D ^DIK
S DA=+$O(^PXD(811.9,"B","VA-SEAT BELT EDUCATION",""))
I DA>0 D ^DIK
S DA=+$O(^PXD(811.9,"B","VA-*TETANUS DIPTHERIA IMMUNIZATION",""))
I DA>0 D ^DIK
Q
;
;------------------------
DELXTAX ;Delete all expanded taxonomies
N DA,DIK
S DIK="^PXD(811.3,"
S DA=0
F S DA=$O(^PXD(811.3,DA)) Q:+DA=0 D
. D ^DIK
Q
;
;----------------------------------
DPCACHE ;Delete any existing patient caches
N IND
S IND="PXRMDFN"
F S IND=$O(^XTMP(IND)) Q:IND'["PXRMDFN" D
. K ^XTMP(IND)
Q
;
;-------------
ERR ;Error Handler
N ERROR,IC,REF
S ERROR(1)="Unable to convert computed finding : "_DESC
S ERROR(2)="Reminder conversion abandoned"
S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
;Move MSG into ERROR
S REF="MSG"
F IC=4:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF
;Screen message
D BMES^XPDUTL(.ERROR)
;Mail Message
D ERR^PXRMV1IE(.ERROR)
Q
;
;----------------------------------
NEWB ;Get ready for new style B cross-references.
N FILE
F FILE=801.41,811.9 D
. D RMDUP^PXRMV1IG(FILE)
. D TMPB^PXRMV1IG(FILE)
Q
;
;----------------------------------
PARM ;Copy site disclaimer from PCE file
S STRING="Saving site disclaimer"
D BMES^XPDUTL(STRING)
M ^PXRM(800,1,"DISC2")=^PX(815,1,"HS2")
Q
;
;-------------------------------------
PRE ;These are the pre-installation actions
;Get ready for new style B cross-references.
D NEWB
;Save inactive statuses of VA reminders
D INSAV^PXRMV1IG
;Rename menu options
D CHANGE^PXRMV1IG
;Delete any existing entries in the computed findings file.
D DELCF
;Delete any existing MH test result groups or elements
D DELMH
;Delete data dictionaries for all files with a new DD or DD changes.
D DELDD
Q
;
;---------------------------------------
POST ;These are the post-installation actions
N MSG
;Parameters
D PARM
;Parameter Definitions
D ^PXRMV1X
;Computed Findings
D COMP Q:$D(MSG)
;Reminders
D RBLD^PXRMV1IA Q:$D(MSG)
D DELXTAX
D DPCACHE
;Taxonomy selectable codes
D ^PXRMV1ID
;Make sure all the logic strings get built.
D BLDLSTR
;Rebuild indexes.
D REINDEX
;Make sure no spurious duplicate entries were created with the
;new B cross-reference.
D RMDUP
;Delete obsolete reminder definitions.
D DELORD
;Restore VA reminder inactive statuses.
D INRES^PXRMV1IG
;Connect the findings to the terms for the VA-HEP C RISK ASSESSMENT
;reminder
;D CTERMS^PXRMV1IH ;IHS/ITSC/LJF 5/30/2003 bypass - could not send reminder data due to v pointer problems
;Set starting ien to site number space.
D SETSTART
Q
;
;------------------------
REDO ;Reset Selected Reminders
N MSG,PXRMREM,REDO,REMINDER
D REM(.PXRMREM)
S REMINDER=$P($G(PXRMREM(1)),U)
I REMINDER D
. S REDO=1
. D COMP Q:$D(MSG)
. D RBLD^PXRMV1IA
Q
;
;------------------
REINDEX ;Rebuild all cross-references that have been changed to the new style
N FILE
F FILE=801.41,811.2,811.4,811.5,811.6,811.7,811.9 D
. D REINDEX^PXRMV1IG(FILE)
Q
;
;------------------
REM(REM) ;Reminder Selection
N LIT,LIT1,DIC
S DIC("A")="REMINDER to convert: "
S LIT1="You must select a reminder!"
D SEL(811.9,"AEQMZ",.REM)
Q
;
;-------------------------
RMDUP ;Remove duplicate entries
N FILE
F FILE=801.41,811.9 D
. D RMDUP^PXRMV1IG(FILE)
Q
;
;Repeated Prompt using DIC
;-------------------------
SEL(FILE,MODE,ARRAY) ;
N X,Y,CNT
K DIROUT,DIRUT,DTOUT,DUOUT
S CNT=0
W !
F D Q:$D(DTOUT) Q:$D(DUOUT) Q:CNT>0 Q:(Y=-1)&(CNT>0)
.S DIC=FILE,DIC(0)=MODE
.D ^DIC
.I X=(U_U) S DTOUT=1
.I '$D(DTOUT),('$D(DUOUT)) D
..I +Y'=-1 D Q
...S CNT=CNT+1,ARRAY(CNT)=Y_U_Y(0,0)_U_$P(Y(0),U,3)
..W:CNT=0 !,LIT1
.K DIC
Q
;-------------------------
SETSTART ;Set starting ien to site number space.
N FILE,ROOT
F FILE=811.2,811.4,811.5,811.6,811.9 D
. S ROOT=$$ROOT^DILFD(FILE)
. ;D SETSTART^PXRMCOPY(ROOT,0) ;IHS/ITSC/LJF 5/30/2003
. D SETSTART^PXRMCOPY(ROOT) ;IHS/ITSC/LJF 5/30/2003 wrong # of parameters
F FILE=801.41 D
. S ROOT=$$ROOT^DILFD(FILE)
. ;D SETSTART^PXRMDCPY(ROOT,0) ;IHS/ITSC/LJF 5/30/2003
. D SETSTART^PXRMCOPY(ROOT) ;IHS/ITSC/LJF 5/30/2003 wrong routine & # of parameters
Q
;
PXRMV1I ; SLC/PJH,PKR - Inits for new REMINDER package. ;06/08/2000
+1 ;;1.5;CLINICAL REMINDERS;;Jun 19, 2000
+2 ;IHS/ITSC/LJF 5/30/2003 fixed call to PXRMCOPY - has different # of parameters
+3 ; bypassed connecting the findings to the terms for the
+4 ; VA-HEP C RISK ASSESSMENT reminder - variable ptr problem
+5 ; prevented sending any data in file 811.5 - Reminder Term
+6 ;
+7 QUIT
+8 ;
+9 ;------------------------
BLDLSTR ;Make sure all the logic strings get built.
+1 DO BMES^XPDUTL("Building logic strings")
+2 NEW IEN
+3 SET IEN=0
+4 FOR
SET IEN=$ORDER(^PXD(811.9,IEN))
IF +IEN=0
QUIT
Begin DoDot:1
+5 IF $PIECE(^PXD(811.9,IEN,0),U,1)["VA-"
QUIT
+6 DO BLDPCLS^PXRMLOGX(IEN,"")
+7 DO BLDRESLS^PXRMLOGX(IEN,"")
+8 DO BLDAFL^PXRMLOGX(IEN,"")
+9 DO BLDINFL^PXRMLOGX(IEN,"")
End DoDot:1
+10 QUIT
+11 ;
+12 ;----------------------------------------------------------------
CHECK(ROUTINE) ;Search for routine entry point in the new computed findings
+1 ;file
+2 NEW SUB,TAG,FOUND
+3 SET SUB=0
SET FOUND=""
+4 FOR
SET SUB=$ORDER(^PXRMD(811.4,SUB))
IF 'SUB
QUIT
Begin DoDot:1
+5 SET TAG=$PIECE($GET(^PXRMD(811.4,SUB,0)),U,2,3)
+6 IF $PIECE(TAG,U,2)_";"_$PIECE(TAG,U)=ROUTINE
SET FOUND=SUB
End DoDot:1
IF FOUND]""
QUIT
+7 QUIT FOUND
+8 ;
+9 ;--------------------------------------
COMP ;Computed findings - set up file #811.4
+1 NEW ARRAY,DATA,DESC,IEN,STRING,SUB,TAG,FDA,FDAIEN
+2 ;Get each reminder in turn
+3 SET STRING="Building Computed Findings file"
+4 DO BMES^XPDUTL(STRING)
+5 ;Make sure any converted computed findings go into the site's
+6 ;number space.
+7 ;D SETSTART^PXRMCOPY("^PXRMD(811.4,",0) ;IHS/ITSC/LJF 5/30/2003
+8 ;IHS/ITSC/LJF 5/30/2003 wrong # of parameters
DO SETSTART^PXRMCOPY("^PXRMD(811.4,")
+9 SET IEN=0
+10 FOR
SET IEN=$ORDER(^PXD(811.9,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+11 ;Skip VA- reminders
+12 IF $PIECE(^PXD(811.9,IEN,0),U,1)["VA-"
QUIT
+13 IF $DATA(REDO)
IF IEN'=REMINDER
QUIT
+14 SET SUB=0
+15 ;Get computed findings records
+16 FOR
SET SUB=$ORDER(^PXD(811.9,IEN,10,SUB))
IF 'SUB
QUIT
Begin DoDot:2
+17 SET DATA=$GET(^PXD(811.9,IEN,10,SUB,0))
IF DATA=""
QUIT
+18 ;Extract description and routine entry point
+19 SET TAG=$PIECE(DATA,U)
SET DESC=$PIECE(DATA,U,5)
+20 ;Ignore null Computed findings
+21 IF TAG=""
QUIT
+22 ;Default null name to routine name
+23 IF DESC=""
SET DESC=TAG
+24 ;Create ARRAY of routine entry points
+25 ;(using first short description found)
+26 IF '$DATA(ARRAY(TAG))
SET ARRAY(TAG)=DESC
QUIT
+27 ;If already set-up ignore
+28 IF ARRAY(TAG)=DESC
QUIT
+29 ;Otherwise log duplication
+30 SET STRING="The following CF's use the same routine"
+31 DO BMES^XPDUTL(STRING)
+32 DO BMES^XPDUTL(ARRAY(TAG)_" (retained)")
+33 DO BMES^XPDUTL(DESC_" (replaced)")
End DoDot:2
End DoDot:1
+34 ;
+35 ;Create FDA for each entry in ARRAY
+36 SET TAG=""
+37 FOR
SET TAG=$ORDER(ARRAY(TAG))
IF TAG=""
QUIT
Begin DoDot:1
+38 SET DESC=ARRAY(TAG)
+39 ;Check if entry already exists
+40 IF $$CHECK(TAG)
Begin DoDot:2
+41 SET STRING="Skipping update - CF "_DESC
+42 DO BMES^XPDUTL(STRING)
End DoDot:2
QUIT
+43 ;Build FDA array
+44 KILL FDAIEN,FDA
+45 ;Description
+46 SET FDA(811.4,"+1,",.01)=DESC
+47 ;Routine
+48 SET FDA(811.4,"+1,",.02)=$PIECE(TAG,";",2)
+49 ;Entry Point
+50 SET FDA(811.4,"+1,",.03)=$PIECE(TAG,";")
+51 ;Print name, default to the .01 field
+52 SET FDA(811.4,"+1,",.04)=DESC
+53 DO UPDATE^DIE("","FDA","FDAIEN","MSG")
+54 IF $DATA(MSG)
DO ERR
End DoDot:1
IF $DATA(MSG)
QUIT
+55 QUIT
+56 ;
+57 ;------------------------
DELCF ;Delete any existing entries in the computed findings file.
+1 ;Skip those in a site number space. This will apply to test
+2 ;sites only.
+3 NEW DA,DIK,SNUMS
+4 SET SNUMS=100000
+5 SET DIK="^PXRMD(811.4,"
+6 SET DA=0
+7 FOR
SET DA=$ORDER(^PXRMD(811.4,DA))
IF (+DA=0)!(+DA>SNUMS)
QUIT
Begin DoDot:1
+8 DO ^DIK
End DoDot:1
+9 QUIT
+10 ;
+11 ;------------------------
DELDD ;Delete data dictionaries
+1 NEW DIU,FILENUM
+2 SET DIU(0)=""
+3 FOR FILENUM=800,801.41,801.42,801.43,801.45,801.9,801.95,810.1,811.2,811.3,811.4,811.5,811.6,811.7,811.9
Begin DoDot:1
+4 SET DIU=FILENUM
+5 DO EN^DIU2
End DoDot:1
+6 QUIT
+7 ;
+8 ;------------------------
DELMH ;Delete any existing MH result entries in dialog file.
+1 ;Skip those in a site number space. This will apply to test
+2 ;sites only.
+3 NEW DA,DIK,DTYP,SNUMS
+4 SET SNUMS=100000
+5 SET DIK="^PXRMD(801.41,"
+6 SET DA=0
+7 FOR
SET DA=$ORDER(^PXRMD(801.41,DA))
IF (+DA=0)!(+DA>SNUMS)
QUIT
Begin DoDot:1
+8 ;Dialog type
+9 SET DTYP=$PIECE($GET(^PXRMD(801.41,DA,0)),U,4)
+10 ;Delete only result groups and result elements
+11 IF (DTYP="T")!(DTYP="S")
DO ^DIK
End DoDot:1
+12 QUIT
+13 ;
+14 ;------------------------
DELORD ;Delete obsolete reminder definitions.
+1 NEW DA,DIK
+2 SET DIK="^PXD(811.9,"
+3 SET DA=+$ORDER(^PXD(811.9,"B","VA-*SEAT BELT AND ACCIDENT SCREEN",""))
+4 IF DA>0
DO ^DIK
+5 SET DA=+$ORDER(^PXD(811.9,"B","VA-SEAT BELT EDUCATION",""))
+6 IF DA>0
DO ^DIK
+7 SET DA=+$ORDER(^PXD(811.9,"B","VA-*TETANUS DIPTHERIA IMMUNIZATION",""))
+8 IF DA>0
DO ^DIK
+9 QUIT
+10 ;
+11 ;------------------------
DELXTAX ;Delete all expanded taxonomies
+1 NEW DA,DIK
+2 SET DIK="^PXD(811.3,"
+3 SET DA=0
+4 FOR
SET DA=$ORDER(^PXD(811.3,DA))
IF +DA=0
QUIT
Begin DoDot:1
+5 DO ^DIK
End DoDot:1
+6 QUIT
+7 ;
+8 ;----------------------------------
DPCACHE ;Delete any existing patient caches
+1 NEW IND
+2 SET IND="PXRMDFN"
+3 FOR
SET IND=$ORDER(^XTMP(IND))
IF IND'["PXRMDFN"
QUIT
Begin DoDot:1
+4 KILL ^XTMP(IND)
End DoDot:1
+5 QUIT
+6 ;
+7 ;-------------
ERR ;Error Handler
+1 NEW ERROR,IC,REF
+2 SET ERROR(1)="Unable to convert computed finding : "_DESC
+3 SET ERROR(2)="Reminder conversion abandoned"
+4 SET ERROR(3)="Error in UPDATE^DIE, needs further investigation"
+5 ;Move MSG into ERROR
+6 SET REF="MSG"
+7 FOR IC=4:1
SET REF=$QUERY(@REF)
IF REF=""
QUIT
SET ERROR(IC)=REF_"="_@REF
+8 ;Screen message
+9 DO BMES^XPDUTL(.ERROR)
+10 ;Mail Message
+11 DO ERR^PXRMV1IE(.ERROR)
+12 QUIT
+13 ;
+14 ;----------------------------------
NEWB ;Get ready for new style B cross-references.
+1 NEW FILE
+2 FOR FILE=801.41,811.9
Begin DoDot:1
+3 DO RMDUP^PXRMV1IG(FILE)
+4 DO TMPB^PXRMV1IG(FILE)
End DoDot:1
+5 QUIT
+6 ;
+7 ;----------------------------------
PARM ;Copy site disclaimer from PCE file
+1 SET STRING="Saving site disclaimer"
+2 DO BMES^XPDUTL(STRING)
+3 MERGE ^PXRM(800,1,"DISC2")=^PX(815,1,"HS2")
+4 QUIT
+5 ;
+6 ;-------------------------------------
PRE ;These are the pre-installation actions
+1 ;Get ready for new style B cross-references.
+2 DO NEWB
+3 ;Save inactive statuses of VA reminders
+4 DO INSAV^PXRMV1IG
+5 ;Rename menu options
+6 DO CHANGE^PXRMV1IG
+7 ;Delete any existing entries in the computed findings file.
+8 DO DELCF
+9 ;Delete any existing MH test result groups or elements
+10 DO DELMH
+11 ;Delete data dictionaries for all files with a new DD or DD changes.
+12 DO DELDD
+13 QUIT
+14 ;
+15 ;---------------------------------------
POST ;These are the post-installation actions
+1 NEW MSG
+2 ;Parameters
+3 DO PARM
+4 ;Parameter Definitions
+5 DO ^PXRMV1X
+6 ;Computed Findings
+7 DO COMP
IF $DATA(MSG)
QUIT
+8 ;Reminders
+9 DO RBLD^PXRMV1IA
IF $DATA(MSG)
QUIT
+10 DO DELXTAX
+11 DO DPCACHE
+12 ;Taxonomy selectable codes
+13 DO ^PXRMV1ID
+14 ;Make sure all the logic strings get built.
+15 DO BLDLSTR
+16 ;Rebuild indexes.
+17 DO REINDEX
+18 ;Make sure no spurious duplicate entries were created with the
+19 ;new B cross-reference.
+20 DO RMDUP
+21 ;Delete obsolete reminder definitions.
+22 DO DELORD
+23 ;Restore VA reminder inactive statuses.
+24 DO INRES^PXRMV1IG
+25 ;Connect the findings to the terms for the VA-HEP C RISK ASSESSMENT
+26 ;reminder
+27 ;D CTERMS^PXRMV1IH ;IHS/ITSC/LJF 5/30/2003 bypass - could not send reminder data due to v pointer problems
+28 ;Set starting ien to site number space.
+29 DO SETSTART
+30 QUIT
+31 ;
+32 ;------------------------
REDO ;Reset Selected Reminders
+1 NEW MSG,PXRMREM,REDO,REMINDER
+2 DO REM(.PXRMREM)
+3 SET REMINDER=$PIECE($GET(PXRMREM(1)),U)
+4 IF REMINDER
Begin DoDot:1
+5 SET REDO=1
+6 DO COMP
IF $DATA(MSG)
QUIT
+7 DO RBLD^PXRMV1IA
End DoDot:1
+8 QUIT
+9 ;
+10 ;------------------
REINDEX ;Rebuild all cross-references that have been changed to the new style
+1 NEW FILE
+2 FOR FILE=801.41,811.2,811.4,811.5,811.6,811.7,811.9
Begin DoDot:1
+3 DO REINDEX^PXRMV1IG(FILE)
End DoDot:1
+4 QUIT
+5 ;
+6 ;------------------
REM(REM) ;Reminder Selection
+1 NEW LIT,LIT1,DIC
+2 SET DIC("A")="REMINDER to convert: "
+3 SET LIT1="You must select a reminder!"
+4 DO SEL(811.9,"AEQMZ",.REM)
+5 QUIT
+6 ;
+7 ;-------------------------
RMDUP ;Remove duplicate entries
+1 NEW FILE
+2 FOR FILE=801.41,811.9
Begin DoDot:1
+3 DO RMDUP^PXRMV1IG(FILE)
End DoDot:1
+4 QUIT
+5 ;
+6 ;Repeated Prompt using DIC
+7 ;-------------------------
SEL(FILE,MODE,ARRAY) ;
+1 NEW X,Y,CNT
+2 KILL DIROUT,DIRUT,DTOUT,DUOUT
+3 SET CNT=0
+4 WRITE !
+5 FOR
Begin DoDot:1
+6 SET DIC=FILE
SET DIC(0)=MODE
+7 DO ^DIC
+8 IF X=(U_U)
SET DTOUT=1
+9 IF '$DATA(DTOUT)
IF ('$DATA(DUOUT))
Begin DoDot:2
+10 IF +Y'=-1
Begin DoDot:3
+11 SET CNT=CNT+1
SET ARRAY(CNT)=Y_U_Y(0,0)_U_$PIECE(Y(0),U,3)
End DoDot:3
QUIT
+12 IF CNT=0
WRITE !,LIT1
End DoDot:2
+13 KILL DIC
End DoDot:1
IF $DATA(DTOUT)
QUIT
IF $DATA(DUOUT)
QUIT
IF CNT>0
QUIT
IF (Y=-1)&(CNT>0)
QUIT
+14 QUIT
+15 ;-------------------------
SETSTART ;Set starting ien to site number space.
+1 NEW FILE,ROOT
+2 FOR FILE=811.2,811.4,811.5,811.6,811.9
Begin DoDot:1
+3 SET ROOT=$$ROOT^DILFD(FILE)
+4 ;D SETSTART^PXRMCOPY(ROOT,0) ;IHS/ITSC/LJF 5/30/2003
+5 ;IHS/ITSC/LJF 5/30/2003 wrong # of parameters
DO SETSTART^PXRMCOPY(ROOT)
End DoDot:1
+6 FOR FILE=801.41
Begin DoDot:1
+7 SET ROOT=$$ROOT^DILFD(FILE)
+8 ;D SETSTART^PXRMDCPY(ROOT,0) ;IHS/ITSC/LJF 5/30/2003
+9 ;IHS/ITSC/LJF 5/30/2003 wrong routine & # of parameters
DO SETSTART^PXRMCOPY(ROOT)
End DoDot:1
+10 QUIT
+11 ;
