PXRMEXIU ;SLC/PKR/PJH - Utilities for installing repository entries. ;01/18/2013
;;2.0;CLINICAL REMINDERS;**4,6,12,17,18,24,26**;Feb 04, 2005;Build 404
;===============================================
DEF(FDA,NAMECHG) ;Check the reminder definition to make sure the related
;reminder exists and all the findings exist.
N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,LRD,OFINDING,PT01
N RRG,SPONSOR,TEXT,VERSN
S IENS=$O(FDA(811.9,""))
;Related reminder guideline field 1.4.
I $D(FDA(811.9,IENS,1.4)) D
. S RRG=FDA(811.9,IENS,1.4)
. S IEN=$$EXISTS^PXRMEXIU(811.9,RRG)
. I IEN=0 D
..;Get replacement.
.. N DIC,X,Y
.. S TEXT(1)=" "
.. S TEXT(2)="The Related Reminder Guideline does not exist on your system!"
.. S TEXT(3)="It is "_RRG_" input a replacement or ^ to leave it empty."
.. D MES^XPDUTL(.TEXT)
..;If this is being called during a KIDS install we need echoing on.
.. I $D(XPDNM) X ^%ZOSF("EON")
.. S DIC=811.9,DIC(0)="AEMQ"
.. D ^DIC
.. I $D(XPDNM) X ^%ZOSF("EOFF")
.. I Y=-1 K FDA(811.9,IENS,1.4)
.. E S FDA(811.9,IENS,1.4)=$P(Y,U,2)
;
;Sponsor field 101.
I $D(FDA(811.9,IENS,101)) D
. S SPONSOR=FDA(811.9,IENS,101)
. S IEN=$$FIND1^DIC(811.6,"","U",SPONSOR)
. I IEN=0 D
..;Get replacement.
.. N DIC,X,Y
.. S TEXT(1)=" "
.. S TEXT(2)="The Sponsor does not exist on your system!"
.. S TEXT(3)="It is "_SPONSOR_" input a replacement or ^ to leave it empty."
.. D MES^XPDUTL(.TEXT)
..;If this is being called during a KIDS install we need echoing on.
.. I $D(XPDNM) X ^%ZOSF("EON")
.. S DIC=811.6,DIC(0)="AEMQ"
.. D ^DIC
.. I $D(XPDNM) X ^%ZOSF("EOFF")
.. I Y=-1 K FDA(811.9,IENS,101)
.. E S FDA(811.9,IENS,101)=$P(Y,U,2)
;
;Linked reminder dialog field 51.
S LRD=$G(FDA(811.9,IENS,51))
S IEN=$S(LRD="":0,1:+$O(^PXRMD(801.41,"B",LRD,"")))
I IEN=0 K FDA(811.9,IENS,51)
;
;Search the finding multiple for replacements and missing findings.
D SFMVPI(.FDA,.NAMECHG,811.902)
S VERSN=$$GETTAGV^PXRMEXU3(^PXD(811.8,PXRMRIEN,100,3,0),"<PACKAGE_VERSION>")
I VERSN=1.5 D CEFD^PXRMDATE(.FDA)
Q
;
;===============================================
EXISTS(FILENUM,NAME,FLAG) ;Check for existence of an entry with the
;same name. Return 0 for null name. If FLAG="W" then if necessary
;display the warning message.
I NAME="" Q 0
;Return the ien if it does, 0 otherwise.
N IEN
I FILENUM=0 S IEN=$$EXISTS^PXRMEXCF(NAME) Q
N FLAGS,RESULT
S RESULT=NAME
;Special lookup for files 80 and 80.1, they do not have a standard "B"
;cross-reference.
I (FILENUM=80)!(FILENUM=80.1) D
.;Name may or may not have the necessary space appended, make sure
.;it does.
. S RESULT=$S($E(NAME,$L(NAME))'=" ":NAME_" ",1:NAME)
. S FLAGS="MX"
E S FLAGS="BXU"
;File 8927.1 only allows upper case .01s.
I FILENUM=8927.1 S RESULT=$$UP^XLFSTR(NAME)
S IEN=$$FIND1^DIC(FILENUM,"",FLAGS,RESULT)
I +IEN>0 Q IEN
;If IEN is null then there was an error try FIND^DIC.
N IND,FILENAME,LIST,MLIST,MSG,NFOUND,NMATCH,TEXT
D FIND^DIC(FILENUM,"","",FLAGS,NAME,"","","","","LIST","MSG")
S NFOUND=+$P(LIST("DILIST",0),U,1)
I NFOUND=0 Q 0
I NFOUND=1 Q LIST("DILIST",2,1)
;Multiple entries with the same name found, search for a match with
;the .01.
S NMATCH=0
F IND=1:1:NFOUND D
. I LIST("DILIST",1,IND)=NAME S NMATCH=NMATCH+1,MLIST(NMATCH)=IND
I NMATCH=1 Q LIST("DILIST",2,MLIST(1))
I NMATCH=0 Q 0
;If FLAG="W" display the warning message, return the first entry on
;the list and quit.
I (NMATCH>1),$G(FLAG)="W" D Q LIST("DILIST",2,1)
. S FILENAME=$$GET1^DID(FILENUM,"","","NAME")
. S TEXT(1)="Warning there are "_NMATCH_" "_FILENAME_" entries with the name "_NAME_"!"
. S TEXT(2)="If this is used as a finding, and it is not resolved by FileMan during"
. S TEXT(3)="installation, any component using this finding will not install."
. D EN^DDIOL(.TEXT)
. H 3
;If FLAG is not "W" prompt the user for the replacement.
I NMATCH>1 S IEN=$$GETIEN^PXRMEXU0(NMATCH,.LIST)
Q IEN
;
;===============================================
GETACT(CHOICES,DIR) ;Get the action
;If CHOICES is empty the only action is skip.
I CHOICES="" Q "S"
N DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="S"_U
I CHOICES["C" S DIR(0)=DIR(0)_"C:Create a new entry by copying to a new name"
I CHOICES["D" S DIR(0)=DIR(0)_";D:Delete"
I CHOICES["I" S DIR(0)=DIR(0)_";I:Install"
I CHOICES["M" S DIR(0)=DIR(0)_";M:Merge findings"
I CHOICES["O" S DIR(0)=DIR(0)_";O:Overwrite the current entry"
I CHOICES["P" S DIR(0)=DIR(0)_";P:Replace with an existing entry"
I CHOICES["U" S DIR(0)=DIR(0)_";U:Update"
I CHOICES["Q" S DIR(0)=DIR(0)_";Q:Quit the install"
I CHOICES["R" S DIR(0)=DIR(0)_";R:Restart"
I CHOICES["S" S DIR(0)=DIR(0)_";S:Skip, do not install this entry"
;If this is being called during a KIDS install we need echoing on.
I $D(XPDNM) X ^%ZOSF("EON")
D ^DIR
I $D(XPDNM) X ^%ZOSF("EOFF")
I $D(DIROUT)!$D(DIRUT) S Y="S"
I $D(DTOUT)!($D(DUOUT)) S Y="S"
Q Y
;
;===============================================
GETNAME(MIN,MAX) ;Get a name to use.
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="FAOU"_U_MIN_":"_MAX
S DIR("A")="Input the new name: "
D ^DIR
I $D(DIROUT)!$D(DIRUT) Q ""
I $D(DTOUT)!$D(DUOUT) Q ""
Q Y
;
;===============================================
GETUNAME(ATTR) ;Get a unique name to use, ATTR holds the attributes.
N IEN,NEWPT01,TEXT
GNEW S NEWPT01=$$GETNAME(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH"))
S IEN=+$$EXISTS(ATTR("FILE NUMBER"),NEWPT01)
I IEN>0 D G GNEW
. S TEXT(1)=ATTR("FILE NAME")_" entry "_NEWPT01_" already exists."
. S TEXT(2)="Input a different name or type <ENTER> to quit."
. D EN^DDIOL(.TEXT)
E S ATTR("NAME")=NEWPT01
Q NEWPT01
;
;===============================================
HF(FDA,NAMECHG) ;Check the health factor to make sure a category does not
;have a category.
N IENS
S IENS=$O(FDA(9999999.64,""))
I IENS="" Q
I FDA(9999999.64,IENS,.1)="CATEGORY" K FDA(9999999.64,IENS,.03)
Q
;
;===============================================
REXISTS(NAME,DATEP) ;See if this Exchange File entry already exists.
N IEN,LUVALUE
S LUVALUE(1)=NAME
S LUVALUE(2)=DATEP
S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
Q IEN
;
;===============================================
SFMVPI(FDA,NAMECHG,SFN) ;Search a variable pointer list for items that do not
;exist and prompt the user for a replacement. Works for definitions,
;terms, and health summary types.
N ABBR,ACTION,ALIST,DIR,IEN,IENS,FILENUM,FINDING,HSUB,OFINDING,PT01,TYPE
;Search the finding multiple for replacements and missing findings.
S HSUB=$S(SFN=142.14:"HSTI",SFN=811.52:"TRMF",1:"DEFF")
S TYPE=$S(SFN=142.14:"Selection item",1:"Finding")
D BLDALIST^PXRMVPTR(SFN,.01,.ALIST)
S (ACTION,IENS)=""
F S IENS=$O(FDA(SFN,IENS)) Q:(IENS="")!(ACTION="Q") D
. S (FINDING,OFINDING)=FDA(SFN,IENS,.01)
. S ABBR=$P(FINDING,".",1)
. S PT01=$P(FINDING,".",2)
. S FILENUM=$P(ALIST(ABBR),U,1)
. I $D(NAMECHG(FILENUM,PT01)) D
.. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
.. S FDA(SFN,IENS,.01)=FINDING
. S IEN=+$$VFIND1(FINDING,.ALIST)
. I IEN>0 S FDA(SFN,IENS,.01)=ABBR_".`"_IEN
. I IEN=0 D
..;Get replacement
.. N DIC,DUOUT,ROOT,TEXT,X,Y,YY
.. S TEXT(1)=TYPE_" "_FINDING_" does not exist, what do you want to do?"
.. D BMES^XPDUTL(.TEXT)
.. S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
.. I ACTION="Q" K FDA Q
.. I ACTION="D" K FDA(SFN,IENS) Q
.. S DIC=FILENUM
.. S ROOT=$P($$ROOT^DILFD(FILENUM),U,2)
.. S DIC("S")="S YY=Y_"";""_ROOT I $$VFINDING^PXRMINTR(YY)"
.. S DIC(0)="AEMNQ"
.. S Y=-1
.. F Q:+Y'=-1 D
...;If this is being called during a KIDS install we need echoing on.
... I $D(XPDNM) X ^%ZOSF("EON")
... D ^DIC
... I $D(XPDNM) X ^%ZOSF("EOFF")
... I $D(DUOUT) D
.... S Y=""
.... K FDA
.. I Y="" K FDA(SFN,IENS)
.. E D
... S FINDING=ABBR_"."_$P(Y,U,2)
... S FDA(SFN,IENS,.01)=FINDING
.;Save the finding information for the history.
. S ^TMP("PXRMEXIA",$J,HSUB,$P(IENS,",",1),OFINDING)=FINDING
Q
;
;===============================================
TIUOBJ(FDA) ;Resolve the name of the health summary object.
N END,HSOBJIEN,IENS,START,TEMP
S IENS=$O(FDA(8925.1,""))
S TEMP=$G(FDA(8925.1,IENS,9))
I TEMP'["TIU^GMTSOBJ" Q
S START=$F(TEMP,"DFN,")
S END=$L(TEMP)-1
S TEMP=$E(TEMP,START,END)
S HSOBJIEN=$O(^GMT(142.5,"B",TEMP,""))
I HSOBJIEN="" D Q
. N TEXT
. S TEXT(1)="Health Summary Object "_TEMP_" does not exist."
. S TEXT(2)="It must be installed before this TIU Health Summary Object can be installed."
. S TEXT(3)="Please go back and install it, making sure the corresponding Health Summary"
. S TEXT(4)="Type has been installed first."
. S TEXT(5)=" "
. I '$D(XPDNM) D EN^DDIOL(.TEXT)
. I $D(XPDNM) D BMES^XPDUTL(.TEXT)
S FDA(8925.1,IENS,9)="S X=$$TIU^GMTSOBJ(DFN,"_HSOBJIEN_")"
S FDA(8925.1,IENS,99)=$H
Q
;
;===============================================
VDLGFIND(ABBR,IEN,ALIST) ;Determine if the finding item associated with a
;reminder dialog is active. Returns a 1 if it is active otherwise
;returns a 0.
N FILENUM
S FILENUM=$P(ALIST(ABBR),U,1)
Q $$FILESCR^PXRMDLG6(IEN,FILENUM)
;
;===============================================
VFIND1(VPTR,ALIST) ;Given a variable pointer of the form ABBR.NAME
;and ALIST which contains the link between abbreviations and files
;return the IEN if it exists and 0 if no match if found.
N ABBR,IEN,FILENUM,PT01,RESULT
S IEN=0
S ABBR=$P(VPTR,".",1)
S PT01=$P(VPTR,".",2,99)
S FILENUM=$P(ALIST(ABBR),U,1)
S IEN=$$EXISTS(FILENUM,PT01)
Q IEN
;
PXRMEXIU ;SLC/PKR/PJH - Utilities for installing repository entries. ;01/18/2013
+1 ;;2.0;CLINICAL REMINDERS;**4,6,12,17,18,24,26**;Feb 04, 2005;Build 404
+2 ;===============================================
DEF(FDA,NAMECHG) ;Check the reminder definition to make sure the related
+1 ;reminder exists and all the findings exist.
+2 NEW ABBR,ALIST,IEN,IENS,FILENUM,FINDING,LRD,OFINDING,PT01
+3 NEW RRG,SPONSOR,TEXT,VERSN
+4 SET IENS=$ORDER(FDA(811.9,""))
+5 ;Related reminder guideline field 1.4.
+6 IF $DATA(FDA(811.9,IENS,1.4))
Begin DoDot:1
+7 SET RRG=FDA(811.9,IENS,1.4)
+8 SET IEN=$$EXISTS^PXRMEXIU(811.9,RRG)
+9 IF IEN=0
Begin DoDot:2
+10 ;Get replacement.
+11 NEW DIC,X,Y
+12 SET TEXT(1)=" "
+13 SET TEXT(2)="The Related Reminder Guideline does not exist on your system!"
+14 SET TEXT(3)="It is "_RRG_" input a replacement or ^ to leave it empty."
+15 DO MES^XPDUTL(.TEXT)
+16 ;If this is being called during a KIDS install we need echoing on.
+17 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EON")
+18 SET DIC=811.9
SET DIC(0)="AEMQ"
+19 DO ^DIC
+20 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EOFF")
+21 IF Y=-1
KILL FDA(811.9,IENS,1.4)
+22 IF '$TEST
SET FDA(811.9,IENS,1.4)=$PIECE(Y,U,2)
End DoDot:2
End DoDot:1
+23 ;
+24 ;Sponsor field 101.
+25 IF $DATA(FDA(811.9,IENS,101))
Begin DoDot:1
+26 SET SPONSOR=FDA(811.9,IENS,101)
+27 SET IEN=$$FIND1^DIC(811.6,"","U",SPONSOR)
+28 IF IEN=0
Begin DoDot:2
+29 ;Get replacement.
+30 NEW DIC,X,Y
+31 SET TEXT(1)=" "
+32 SET TEXT(2)="The Sponsor does not exist on your system!"
+33 SET TEXT(3)="It is "_SPONSOR_" input a replacement or ^ to leave it empty."
+34 DO MES^XPDUTL(.TEXT)
+35 ;If this is being called during a KIDS install we need echoing on.
+36 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EON")
+37 SET DIC=811.6
SET DIC(0)="AEMQ"
+38 DO ^DIC
+39 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EOFF")
+40 IF Y=-1
KILL FDA(811.9,IENS,101)
+41 IF '$TEST
SET FDA(811.9,IENS,101)=$PIECE(Y,U,2)
End DoDot:2
End DoDot:1
+42 ;
+43 ;Linked reminder dialog field 51.
+44 SET LRD=$GET(FDA(811.9,IENS,51))
+45 SET IEN=$SELECT(LRD="":0,1:+$ORDER(^PXRMD(801.41,"B",LRD,"")))
+46 IF IEN=0
KILL FDA(811.9,IENS,51)
+47 ;
+48 ;Search the finding multiple for replacements and missing findings.
+49 DO SFMVPI(.FDA,.NAMECHG,811.902)
+50 SET VERSN=$$GETTAGV^PXRMEXU3(^PXD(811.8,PXRMRIEN,100,3,0),"<PACKAGE_VERSION>")
+51 IF VERSN=1.5
DO CEFD^PXRMDATE(.FDA)
+52 QUIT
+53 ;
+54 ;===============================================
EXISTS(FILENUM,NAME,FLAG) ;Check for existence of an entry with the
+1 ;same name. Return 0 for null name. If FLAG="W" then if necessary
+2 ;display the warning message.
+3 IF NAME=""
QUIT 0
+4 ;Return the ien if it does, 0 otherwise.
+5 NEW IEN
+6 IF FILENUM=0
SET IEN=$$EXISTS^PXRMEXCF(NAME)
QUIT
+7 NEW FLAGS,RESULT
+8 SET RESULT=NAME
+9 ;Special lookup for files 80 and 80.1, they do not have a standard "B"
+10 ;cross-reference.
+11 IF (FILENUM=80)!(FILENUM=80.1)
Begin DoDot:1
+12 ;Name may or may not have the necessary space appended, make sure
+13 ;it does.
+14 SET RESULT=$SELECT($EXTRACT(NAME,$LENGTH(NAME))'=" ":NAME_" ",1:NAME)
+15 SET FLAGS="MX"
End DoDot:1
+16 IF '$TEST
SET FLAGS="BXU"
+17 ;File 8927.1 only allows upper case .01s.
+18 IF FILENUM=8927.1
SET RESULT=$$UP^XLFSTR(NAME)
+19 SET IEN=$$FIND1^DIC(FILENUM,"",FLAGS,RESULT)
+20 IF +IEN>0
QUIT IEN
+21 ;If IEN is null then there was an error try FIND^DIC.
+22 NEW IND,FILENAME,LIST,MLIST,MSG,NFOUND,NMATCH,TEXT
+23 DO FIND^DIC(FILENUM,"","",FLAGS,NAME,"","","","","LIST","MSG")
+24 SET NFOUND=+$PIECE(LIST("DILIST",0),U,1)
+25 IF NFOUND=0
QUIT 0
+26 IF NFOUND=1
QUIT LIST("DILIST",2,1)
+27 ;Multiple entries with the same name found, search for a match with
+28 ;the .01.
+29 SET NMATCH=0
+30 FOR IND=1:1:NFOUND
Begin DoDot:1
+31 IF LIST("DILIST",1,IND)=NAME
SET NMATCH=NMATCH+1
SET MLIST(NMATCH)=IND
End DoDot:1
+32 IF NMATCH=1
QUIT LIST("DILIST",2,MLIST(1))
+33 IF NMATCH=0
QUIT 0
+34 ;If FLAG="W" display the warning message, return the first entry on
+35 ;the list and quit.
+36 IF (NMATCH>1)
IF $GET(FLAG)="W"
Begin DoDot:1
+37 SET FILENAME=$$GET1^DID(FILENUM,"","","NAME")
+38 SET TEXT(1)="Warning there are "_NMATCH_" "_FILENAME_" entries with the name "_NAME_"!"
+39 SET TEXT(2)="If this is used as a finding, and it is not resolved by FileMan during"
+40 SET TEXT(3)="installation, any component using this finding will not install."
+41 DO EN^DDIOL(.TEXT)
+42 HANG 3
End DoDot:1
QUIT LIST("DILIST",2,1)
+43 ;If FLAG is not "W" prompt the user for the replacement.
+44 IF NMATCH>1
SET IEN=$$GETIEN^PXRMEXU0(NMATCH,.LIST)
+45 QUIT IEN
+46 ;
+47 ;===============================================
GETACT(CHOICES,DIR) ;Get the action
+1 ;If CHOICES is empty the only action is skip.
+2 IF CHOICES=""
QUIT "S"
+3 NEW DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+4 SET DIR(0)="S"_U
+5 IF CHOICES["C"
SET DIR(0)=DIR(0)_"C:Create a new entry by copying to a new name"
+6 IF CHOICES["D"
SET DIR(0)=DIR(0)_";D:Delete"
+7 IF CHOICES["I"
SET DIR(0)=DIR(0)_";I:Install"
+8 IF CHOICES["M"
SET DIR(0)=DIR(0)_";M:Merge findings"
+9 IF CHOICES["O"
SET DIR(0)=DIR(0)_";O:Overwrite the current entry"
+10 IF CHOICES["P"
SET DIR(0)=DIR(0)_";P:Replace with an existing entry"
+11 IF CHOICES["U"
SET DIR(0)=DIR(0)_";U:Update"
+12 IF CHOICES["Q"
SET DIR(0)=DIR(0)_";Q:Quit the install"
+13 IF CHOICES["R"
SET DIR(0)=DIR(0)_";R:Restart"
+14 IF CHOICES["S"
SET DIR(0)=DIR(0)_";S:Skip, do not install this entry"
+15 ;If this is being called during a KIDS install we need echoing on.
+16 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EON")
+17 DO ^DIR
+18 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EOFF")
+19 IF $DATA(DIROUT)!$DATA(DIRUT)
SET Y="S"
+20 IF $DATA(DTOUT)!($DATA(DUOUT))
SET Y="S"
+21 QUIT Y
+22 ;
+23 ;===============================================
GETNAME(MIN,MAX) ;Get a name to use.
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="FAOU"_U_MIN_":"_MAX
+3 SET DIR("A")="Input the new name: "
+4 DO ^DIR
+5 IF $DATA(DIROUT)!$DATA(DIRUT)
QUIT ""
+6 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT ""
+7 QUIT Y
+8 ;
+9 ;===============================================
GETUNAME(ATTR) ;Get a unique name to use, ATTR holds the attributes.
+1 NEW IEN,NEWPT01,TEXT
GNEW SET NEWPT01=$$GETNAME(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH"))
+1 SET IEN=+$$EXISTS(ATTR("FILE NUMBER"),NEWPT01)
+2 IF IEN>0
Begin DoDot:1
+3 SET TEXT(1)=ATTR("FILE NAME")_" entry "_NEWPT01_" already exists."
+4 SET TEXT(2)="Input a different name or type <ENTER> to quit."
+5 DO EN^DDIOL(.TEXT)
End DoDot:1
GOTO GNEW
+6 IF '$TEST
SET ATTR("NAME")=NEWPT01
+7 QUIT NEWPT01
+8 ;
+9 ;===============================================
HF(FDA,NAMECHG) ;Check the health factor to make sure a category does not
+1 ;have a category.
+2 NEW IENS
+3 SET IENS=$ORDER(FDA(9999999.64,""))
+4 IF IENS=""
QUIT
+5 IF FDA(9999999.64,IENS,.1)="CATEGORY"
KILL FDA(9999999.64,IENS,.03)
+6 QUIT
+7 ;
+8 ;===============================================
REXISTS(NAME,DATEP) ;See if this Exchange File entry already exists.
+1 NEW IEN,LUVALUE
+2 SET LUVALUE(1)=NAME
+3 SET LUVALUE(2)=DATEP
+4 SET IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
+5 QUIT IEN
+6 ;
+7 ;===============================================
SFMVPI(FDA,NAMECHG,SFN) ;Search a variable pointer list for items that do not
+1 ;exist and prompt the user for a replacement. Works for definitions,
+2 ;terms, and health summary types.
+3 NEW ABBR,ACTION,ALIST,DIR,IEN,IENS,FILENUM,FINDING,HSUB,OFINDING,PT01,TYPE
+4 ;Search the finding multiple for replacements and missing findings.
+5 SET HSUB=$SELECT(SFN=142.14:"HSTI",SFN=811.52:"TRMF",1:"DEFF")
+6 SET TYPE=$SELECT(SFN=142.14:"Selection item",1:"Finding")
+7 DO BLDALIST^PXRMVPTR(SFN,.01,.ALIST)
+8 SET (ACTION,IENS)=""
+9 FOR
SET IENS=$ORDER(FDA(SFN,IENS))
IF (IENS="")!(ACTION="Q")
QUIT
Begin DoDot:1
+10 SET (FINDING,OFINDING)=FDA(SFN,IENS,.01)
+11 SET ABBR=$PIECE(FINDING,".",1)
+12 SET PT01=$PIECE(FINDING,".",2)
+13 SET FILENUM=$PIECE(ALIST(ABBR),U,1)
+14 IF $DATA(NAMECHG(FILENUM,PT01))
Begin DoDot:2
+15 SET FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
+16 SET FDA(SFN,IENS,.01)=FINDING
End DoDot:2
+17 SET IEN=+$$VFIND1(FINDING,.ALIST)
+18 IF IEN>0
SET FDA(SFN,IENS,.01)=ABBR_".`"_IEN
+19 IF IEN=0
Begin DoDot:2
+20 ;Get replacement
+21 NEW DIC,DUOUT,ROOT,TEXT,X,Y,YY
+22 SET TEXT(1)=TYPE_" "_FINDING_" does not exist, what do you want to do?"
+23 DO BMES^XPDUTL(.TEXT)
+24 SET ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
+25 IF ACTION="Q"
KILL FDA
QUIT
+26 IF ACTION="D"
KILL FDA(SFN,IENS)
QUIT
+27 SET DIC=FILENUM
+28 SET ROOT=$PIECE($$ROOT^DILFD(FILENUM),U,2)
+29 SET DIC("S")="S YY=Y_"";""_ROOT I $$VFINDING^PXRMINTR(YY)"
+30 SET DIC(0)="AEMNQ"
+31 SET Y=-1
+32 FOR
IF +Y'=-1
QUIT
Begin DoDot:3
+33 ;If this is being called during a KIDS install we need echoing on.
+34 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EON")
+35 DO ^DIC
+36 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EOFF")
+37 IF $DATA(DUOUT)
Begin DoDot:4
+38 SET Y=""
+39 KILL FDA
End DoDot:4
End DoDot:3
+40 IF Y=""
KILL FDA(SFN,IENS)
+41 IF '$TEST
Begin DoDot:3
+42 SET FINDING=ABBR_"."_$PIECE(Y,U,2)
+43 SET FDA(SFN,IENS,.01)=FINDING
End DoDot:3
End DoDot:2
+44 ;Save the finding information for the history.
+45 SET ^TMP("PXRMEXIA",$JOB,HSUB,$PIECE(IENS,",",1),OFINDING)=FINDING
End DoDot:1
+46 QUIT
+47 ;
+48 ;===============================================
TIUOBJ(FDA) ;Resolve the name of the health summary object.
+1 NEW END,HSOBJIEN,IENS,START,TEMP
+2 SET IENS=$ORDER(FDA(8925.1,""))
+3 SET TEMP=$GET(FDA(8925.1,IENS,9))
+4 IF TEMP'["TIU^GMTSOBJ"
QUIT
+5 SET START=$FIND(TEMP,"DFN,")
+6 SET END=$LENGTH(TEMP)-1
+7 SET TEMP=$EXTRACT(TEMP,START,END)
+8 SET HSOBJIEN=$ORDER(^GMT(142.5,"B",TEMP,""))
+9 IF HSOBJIEN=""
Begin DoDot:1
+10 NEW TEXT
+11 SET TEXT(1)="Health Summary Object "_TEMP_" does not exist."
+12 SET TEXT(2)="It must be installed before this TIU Health Summary Object can be installed."
+13 SET TEXT(3)="Please go back and install it, making sure the corresponding Health Summary"
+14 SET TEXT(4)="Type has been installed first."
+15 SET TEXT(5)=" "
+16 IF '$DATA(XPDNM)
DO EN^DDIOL(.TEXT)
+17 IF $DATA(XPDNM)
DO BMES^XPDUTL(.TEXT)
End DoDot:1
QUIT
+18 SET FDA(8925.1,IENS,9)="S X=$$TIU^GMTSOBJ(DFN,"_HSOBJIEN_")"
+19 SET FDA(8925.1,IENS,99)=$HOROLOG
+20 QUIT
+21 ;
+22 ;===============================================
VDLGFIND(ABBR,IEN,ALIST) ;Determine if the finding item associated with a
+1 ;reminder dialog is active. Returns a 1 if it is active otherwise
+2 ;returns a 0.
+3 NEW FILENUM
+4 SET FILENUM=$PIECE(ALIST(ABBR),U,1)
+5 QUIT $$FILESCR^PXRMDLG6(IEN,FILENUM)
+6 ;
+7 ;===============================================
VFIND1(VPTR,ALIST) ;Given a variable pointer of the form ABBR.NAME
+1 ;and ALIST which contains the link between abbreviations and files
+2 ;return the IEN if it exists and 0 if no match if found.
+3 NEW ABBR,IEN,FILENUM,PT01,RESULT
+4 SET IEN=0
+5 SET ABBR=$PIECE(VPTR,".",1)
+6 SET PT01=$PIECE(VPTR,".",2,99)
+7 SET FILENUM=$PIECE(ALIST(ABBR),U,1)
+8 SET IEN=$$EXISTS(FILENUM,PT01)
+9 QUIT IEN
+10 ;
