PXRMEXIU ;SLC/PKR/PJH - Utilities for installing repository entries. ;03/30/2018
;;2.0;CLINICAL REMINDERS;**4,6,12,17,18,24,26,47,45**;Feb 04, 2005;Build 566
;===================
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 RNAME,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 RNAME=$G(FDA(811.9,IENS,.01))
I LRD'="",RNAME'="" S ^TMP("PXRMEXDL",$J,LRD,RNAME)=""
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
;
;===================
DELFIND(SFN,IENS,FDA) ;Delete a finding from the FDA.
N IENSD,SFND
S SFND=""
F S SFND=$O(FDA(SFND)) Q:SFND="" D
. S IENSD=""
. F S IENSD=$O(FDA(SFND,IENSD)) Q:IENSD="" I IENSD[IENS K FDA(SFND,IENSD)
K FDA(SFN,IENS)
Q
;
;===================
EDU(FDA,EDULIST) ;Education Topics special handling. Add national education
;topics to EDULIST.
N CDEF,IENS,MSG
S IENS=$O(FDA(9999999.09,""))
I IENS="" Q
S EDULIST(FDA(TOPFNUM,IENS,.01))=""
;If the Class field exists, make sure there is a value for it
;in the FDA.
I $G(FDA(9999999.09,IENS,100))'="" D Q
. I FDA(9999999.09,IENS,100)="NATIONAL" S EDULIST(FDA(TOPFNUM,IENS,.01))=""
S CDEF=$S($$GET1^DID(9999999.09,100,"","LABEL","","MSG")="CLASS":1,1:0)
I 'CDEF Q
S FDA(9999999.09,IENS,100)=$S($G(PXRMNAT):"NATIONAL",1:"LOCAL")
I FDA(9999999.09,IENS,100)="NATIONAL" S EDULIST(FDA(TOPFNUM,IENS,.01))=""
Q
;
;===================
EXAM(FDA) ;Check the health factor to make sure a category does not
;have a category.
N CDEF,IENS,MSG
S IENS=$O(FDA(9999999.15,""))
I IENS="" Q
;If the Class field exists, make sure there is a value for it
;in the FDA.
I $G(FDA(9999999.15,IENS,100))'="" Q
S CDEF=$S($$GET1^DID(9999999.15,100,"","LABEL","","MSG")="CLASS":1,1:0)
I 'CDEF Q
S FDA(9999999.15,IENS,100)=$S($G(PXRMNAT):"NATIONAL",1:"LOCAL")
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,MSG
I FILENUM=0 S IEN=$$EXISTS^PXRMEXCF(NAME) Q
N FLAGS,RESULT,SCREEN
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 SCREEN=$S(FILENUM=50.6:"I $$VAGENSCR^PXRMEXIU(Y)",1:"")
S IEN=$$FIND1^DIC(FILENUM,"",FLAGS,RESULT,"",SCREEN,"MSG")
I +IEN>0 Q IEN
;If IEN is null then there was an error try FIND^DIC.
N IND,FILENAME,LIST,MLIST,NFOUND,NMATCH,TEXT
K MSG
D FIND^DIC(FILENUM,"","",FLAGS,NAME,"","",SCREEN,"","LIST","MSG")
I $D(MSG) D Q 0
. K TEXT
. S TEXT(1)=""
. S TEXT(2)="Cannot install the entry named "_NAME
. S TEXT(3)="In file number "_FILENUM
. S TEXT(4)="For the reason see the error message below."
. S TEXT(5)=""
. D EN^DDIOL(.TEXT)
. D AWRITE^PXRMUTIL("MSG")
. H 2
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")
. K TEXT
. S TEXT(1)=""
. S TEXT(2)="Warning there are "_NMATCH_" "_FILENAME_" entries with the name "_NAME_"!"
. S TEXT(3)="If this is used as a finding, and it is not resolved by FileMan during"
. S TEXT(4)="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) ;Health factor special handling.
N CDEF,IENS,MSG
S IENS=$O(FDA(9999999.64,""))
I IENS="" Q
;Make sure a category does not have a category.
I FDA(9999999.64,IENS,.1)="CATEGORY" K FDA(9999999.64,IENS,.03)
;If the Class field exists, make sure there is a value for it
;in the FDA.
I $G(FDA(9999999.64,IENS,100))'="" Q
S CDEF=$S($$GET1^DID(9999999.64,100,"","LABEL","","MSG")="CLASS":1,1:0)
I 'CDEF Q
S FDA(9999999.64,IENS,100)=$S($G(PXRMNAT):"NATIONAL",1:"LOCAL")
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
N REPFI,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,REPFI=""
.;Check if a replacement already exists.
. I IEN=0 S REPFI=$G(^TMP($J,"PXRM FINDING REPLACE",FINDING))
. I REPFI'="" S (FINDING,FDA(SFN,IENS,.01))=REPFI
. I (IEN=0),(REPFI="") 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" D DELFIND(SFN,IENS,.FDA) 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 REPFI=ABBR_"."_$P(Y,U,2)
... S FDA(SFN,IENS,.01)=REPFI
... S ^TMP($J,"PXRM FINDING REPLACE",FINDING)=REPFI
.;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 COWN,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)
;Make sure either the Personal Owner (.05) or Class Owner (.06) is set.
;If CLINICAL COORDINATOR is defined use it as the Class Owner.
S COWN=+$$EXISTS(8930,"CLINICAL COORDINATOR")
I COWN=0 S FDA(8925.1,IENS,.05)="`"_DUZ
I COWN>0 S FDA(8925.1,IENS,.06)="`"_COWN
S FDA(8925.1,IENS,9)="S X=$$TIU^GMTSOBJ(DFN,"_HSOBJIEN_")"
S FDA(8925.1,IENS,99)=$H
Q
;
;===================
VAGENSCR(IEN) ;Screen for VA Generic, file #50.6, return true only for
;active entries.
N OK
;DBIA #4540
D ZERO^PSN50P6(IEN,"",1,"","LIST")
;If ^TMP($J,"LIST",IEN,1) is null then then entry is active.
S OK=$S(^TMP($J,"LIST",IEN,1)="":1,1:0)
K ^TMP($J,"LIST")
Q OK
;
;===================
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMEXIU 12340 printed Oct 16, 2024@17:45:51 Page 2
PXRMEXIU ;SLC/PKR/PJH - Utilities for installing repository entries. ;03/30/2018
+1 ;;2.0;CLINICAL REMINDERS;**4,6,12,17,18,24,26,47,45**;Feb 04, 2005;Build 566
+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 RNAME,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 RNAME=$GET(FDA(811.9,IENS,.01))
+46 IF LRD'=""
IF RNAME'=""
SET ^TMP("PXRMEXDL",$JOB,LRD,RNAME)=""
+47 SET IEN=$SELECT(LRD="":0,1:+$ORDER(^PXRMD(801.41,"B",LRD,"")))
+48 IF IEN=0
KILL FDA(811.9,IENS,51)
+49 ;
+50 ;Search the finding multiple for replacements and missing findings.
+51 DO SFMVPI(.FDA,.NAMECHG,811.902)
+52 SET VERSN=$$GETTAGV^PXRMEXU3(^PXD(811.8,PXRMRIEN,100,3,0),"<PACKAGE_VERSION>")
+53 IF VERSN=1.5
DO CEFD^PXRMDATE(.FDA)
+54 QUIT
+55 ;
+56 ;===================
DELFIND(SFN,IENS,FDA) ;Delete a finding from the FDA.
+1 NEW IENSD,SFND
+2 SET SFND=""
+3 FOR
SET SFND=$ORDER(FDA(SFND))
if SFND=""
QUIT
Begin DoDot:1
+4 SET IENSD=""
+5 FOR
SET IENSD=$ORDER(FDA(SFND,IENSD))
if IENSD=""
QUIT
IF IENSD[IENS
KILL FDA(SFND,IENSD)
End DoDot:1
+6 KILL FDA(SFN,IENS)
+7 QUIT
+8 ;
+9 ;===================
EDU(FDA,EDULIST) ;Education Topics special handling. Add national education
+1 ;topics to EDULIST.
+2 NEW CDEF,IENS,MSG
+3 SET IENS=$ORDER(FDA(9999999.09,""))
+4 IF IENS=""
QUIT
+5 SET EDULIST(FDA(TOPFNUM,IENS,.01))=""
+6 ;If the Class field exists, make sure there is a value for it
+7 ;in the FDA.
+8 IF $GET(FDA(9999999.09,IENS,100))'=""
Begin DoDot:1
+9 IF FDA(9999999.09,IENS,100)="NATIONAL"
SET EDULIST(FDA(TOPFNUM,IENS,.01))=""
End DoDot:1
QUIT
+10 SET CDEF=$SELECT($$GET1^DID(9999999.09,100,"","LABEL","","MSG")="CLASS":1,1:0)
+11 IF 'CDEF
QUIT
+12 SET FDA(9999999.09,IENS,100)=$SELECT($GET(PXRMNAT):"NATIONAL",1:"LOCAL")
+13 IF FDA(9999999.09,IENS,100)="NATIONAL"
SET EDULIST(FDA(TOPFNUM,IENS,.01))=""
+14 QUIT
+15 ;
+16 ;===================
EXAM(FDA) ;Check the health factor to make sure a category does not
+1 ;have a category.
+2 NEW CDEF,IENS,MSG
+3 SET IENS=$ORDER(FDA(9999999.15,""))
+4 IF IENS=""
QUIT
+5 ;If the Class field exists, make sure there is a value for it
+6 ;in the FDA.
+7 IF $GET(FDA(9999999.15,IENS,100))'=""
QUIT
+8 SET CDEF=$SELECT($$GET1^DID(9999999.15,100,"","LABEL","","MSG")="CLASS":1,1:0)
+9 IF 'CDEF
QUIT
+10 SET FDA(9999999.15,IENS,100)=$SELECT($GET(PXRMNAT):"NATIONAL",1:"LOCAL")
+11 QUIT
+12 ;
+13 ;===================
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,MSG
+6 IF FILENUM=0
SET IEN=$$EXISTS^PXRMEXCF(NAME)
QUIT
+7 NEW FLAGS,RESULT,SCREEN
+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 SCREEN=$SELECT(FILENUM=50.6:"I $$VAGENSCR^PXRMEXIU(Y)",1:"")
+20 SET IEN=$$FIND1^DIC(FILENUM,"",FLAGS,RESULT,"",SCREEN,"MSG")
+21 IF +IEN>0
QUIT IEN
+22 ;If IEN is null then there was an error try FIND^DIC.
+23 NEW IND,FILENAME,LIST,MLIST,NFOUND,NMATCH,TEXT
+24 KILL MSG
+25 DO FIND^DIC(FILENUM,"","",FLAGS,NAME,"","",SCREEN,"","LIST","MSG")
+26 IF $DATA(MSG)
Begin DoDot:1
+27 KILL TEXT
+28 SET TEXT(1)=""
+29 SET TEXT(2)="Cannot install the entry named "_NAME
+30 SET TEXT(3)="In file number "_FILENUM
+31 SET TEXT(4)="For the reason see the error message below."
+32 SET TEXT(5)=""
+33 DO EN^DDIOL(.TEXT)
+34 DO AWRITE^PXRMUTIL("MSG")
+35 HANG 2
End DoDot:1
QUIT 0
+36 SET NFOUND=+$PIECE(LIST("DILIST",0),U,1)
+37 IF NFOUND=0
QUIT 0
+38 IF NFOUND=1
QUIT LIST("DILIST",2,1)
+39 ;Multiple entries with the same name found, search for a match with
+40 ;the .01.
+41 SET NMATCH=0
+42 FOR IND=1:1:NFOUND
Begin DoDot:1
+43 IF LIST("DILIST",1,IND)=NAME
SET NMATCH=NMATCH+1
SET MLIST(NMATCH)=IND
End DoDot:1
+44 IF NMATCH=1
QUIT LIST("DILIST",2,MLIST(1))
+45 IF NMATCH=0
QUIT 0
+46 ;If FLAG="W" display the warning message, return the first entry on
+47 ;the list and quit.
+48 IF (NMATCH>1)
IF $GET(FLAG)="W"
Begin DoDot:1
+49 SET FILENAME=$$GET1^DID(FILENUM,"","","NAME")
+50 KILL TEXT
+51 SET TEXT(1)=""
+52 SET TEXT(2)="Warning there are "_NMATCH_" "_FILENAME_" entries with the name "_NAME_"!"
+53 SET TEXT(3)="If this is used as a finding, and it is not resolved by FileMan during"
+54 SET TEXT(4)="installation, any component using this finding will not install."
+55 DO EN^DDIOL(.TEXT)
+56 HANG 3
End DoDot:1
QUIT LIST("DILIST",2,1)
+57 ;If FLAG is not "W" prompt the user for the replacement.
+58 IF NMATCH>1
SET IEN=$$GETIEN^PXRMEXU0(NMATCH,.LIST)
+59 QUIT IEN
+60 ;
+61 ;===================
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) ;Health factor special handling.
+1 NEW CDEF,IENS,MSG
+2 SET IENS=$ORDER(FDA(9999999.64,""))
+3 IF IENS=""
QUIT
+4 ;Make sure a category does not have a category.
+5 IF FDA(9999999.64,IENS,.1)="CATEGORY"
KILL FDA(9999999.64,IENS,.03)
+6 ;If the Class field exists, make sure there is a value for it
+7 ;in the FDA.
+8 IF $GET(FDA(9999999.64,IENS,100))'=""
QUIT
+9 SET CDEF=$SELECT($$GET1^DID(9999999.64,100,"","LABEL","","MSG")="CLASS":1,1:0)
+10 IF 'CDEF
QUIT
+11 SET FDA(9999999.64,IENS,100)=$SELECT($GET(PXRMNAT):"NATIONAL",1:"LOCAL")
+12 QUIT
+13 ;
+14 ;===================
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
+4 NEW REPFI,TYPE
+5 ;Search the finding multiple for replacements and missing findings.
+6 SET HSUB=$SELECT(SFN=142.14:"HSTI",SFN=811.52:"TRMF",1:"DEFF")
+7 SET TYPE=$SELECT(SFN=142.14:"Selection item",1:"Finding")
+8 DO BLDALIST^PXRMVPTR(SFN,.01,.ALIST)
+9 SET (ACTION,IENS)=""
+10 FOR
SET IENS=$ORDER(FDA(SFN,IENS))
if (IENS="")!(ACTION="Q")
QUIT
Begin DoDot:1
+11 SET (FINDING,OFINDING)=FDA(SFN,IENS,.01)
+12 SET ABBR=$PIECE(FINDING,".",1)
+13 SET PT01=$PIECE(FINDING,".",2)
+14 SET FILENUM=$PIECE(ALIST(ABBR),U,1)
+15 IF $DATA(NAMECHG(FILENUM,PT01))
Begin DoDot:2
+16 SET FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
+17 SET FDA(SFN,IENS,.01)=FINDING
End DoDot:2
+18 SET IEN=+$$VFIND1(FINDING,.ALIST)
+19 IF IEN>0
SET FDA(SFN,IENS,.01)=ABBR_".`"_IEN
SET REPFI=""
+20 ;Check if a replacement already exists.
+21 IF IEN=0
SET REPFI=$GET(^TMP($JOB,"PXRM FINDING REPLACE",FINDING))
+22 IF REPFI'=""
SET (FINDING,FDA(SFN,IENS,.01))=REPFI
+23 IF (IEN=0)
IF (REPFI="")
Begin DoDot:2
+24 ;Get replacement
+25 NEW DIC,DUOUT,ROOT,TEXT,X,Y,YY
+26 SET TEXT(1)=TYPE_" "_FINDING_" does not exist, what do you want to do?"
+27 DO BMES^XPDUTL(.TEXT)
+28 SET ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
+29 IF ACTION="Q"
KILL FDA
QUIT
+30 IF ACTION="D"
DO DELFIND(SFN,IENS,.FDA)
QUIT
+31 SET DIC=FILENUM
+32 SET ROOT=$PIECE($$ROOT^DILFD(FILENUM),U,2)
+33 SET DIC("S")="S YY=Y_"";""_ROOT I $$VFINDING^PXRMINTR(YY)"
+34 SET DIC(0)="AEMNQ"
+35 SET Y=-1
+36 FOR
if +Y'=-1
QUIT
Begin DoDot:3
+37 ;If this is being called during a KIDS install we need echoing on.
+38 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EON")
+39 DO ^DIC
+40 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EOFF")
+41 IF $DATA(DUOUT)
Begin DoDot:4
+42 SET Y=""
+43 KILL FDA
End DoDot:4
End DoDot:3
+44 IF Y=""
KILL FDA(SFN,IENS)
+45 IF '$TEST
Begin DoDot:3
+46 SET REPFI=ABBR_"."_$PIECE(Y,U,2)
+47 SET FDA(SFN,IENS,.01)=REPFI
+48 SET ^TMP($JOB,"PXRM FINDING REPLACE",FINDING)=REPFI
End DoDot:3
End DoDot:2
+49 ;Save the finding information for the history.
+50 SET ^TMP("PXRMEXIA",$JOB,HSUB,$PIECE(IENS,",",1),OFINDING)=FINDING
End DoDot:1
+51 QUIT
+52 ;
+53 ;===================
TIUOBJ(FDA) ;Resolve the name of the health summary object.
+1 NEW COWN,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 ;Make sure either the Personal Owner (.05) or Class Owner (.06) is set.
+19 ;If CLINICAL COORDINATOR is defined use it as the Class Owner.
+20 SET COWN=+$$EXISTS(8930,"CLINICAL COORDINATOR")
+21 IF COWN=0
SET FDA(8925.1,IENS,.05)="`"_DUZ
+22 IF COWN>0
SET FDA(8925.1,IENS,.06)="`"_COWN
+23 SET FDA(8925.1,IENS,9)="S X=$$TIU^GMTSOBJ(DFN,"_HSOBJIEN_")"
+24 SET FDA(8925.1,IENS,99)=$HOROLOG
+25 QUIT
+26 ;
+27 ;===================
VAGENSCR(IEN) ;Screen for VA Generic, file #50.6, return true only for
+1 ;active entries.
+2 NEW OK
+3 ;DBIA #4540
+4 DO ZERO^PSN50P6(IEN,"",1,"","LIST")
+5 ;If ^TMP($J,"LIST",IEN,1) is null then then entry is active.
+6 SET OK=$SELECT(^TMP($JOB,"LIST",IEN,1)="":1,1:0)
+7 KILL ^TMP($JOB,"LIST")
+8 QUIT OK
+9 ;
+10 ;===================
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 ;