Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXRMEXIU

PXRMEXIU.m

Go to the documentation of this file. 
  1. 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
  1.  ;===============================================
  1. DEF(FDA,NAMECHG) ;Check the reminder definition to make sure the related
  1.  ;reminder exists and all the findings exist.
  1.  N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,LRD,OFINDING,PT01
  1.  N RRG,SPONSOR,TEXT,VERSN
  1.  S IENS=$O(FDA(811.9,""))
  1.  ;Related reminder guideline field 1.4.
  1.  I $D(FDA(811.9,IENS,1.4)) D
  1.  . S RRG=FDA(811.9,IENS,1.4)
  1.  . S IEN=$$EXISTS^PXRMEXIU(811.9,RRG)
  1.  . I IEN=0 D
  1.  ..;Get replacement.
  1.  .. N DIC,X,Y
  1.  .. S TEXT(1)=" "
  1.  .. S TEXT(2)="The Related Reminder Guideline does not exist on your system!"
  1.  .. S TEXT(3)="It is "_RRG_" input a replacement or ^ to leave it empty."
  1.  .. D MES^XPDUTL(.TEXT)
  1.  ..;If this is being called during a KIDS install we need echoing on.
  1.  .. I $D(XPDNM) X ^%ZOSF("EON")
  1.  .. S DIC=811.9,DIC(0)="AEMQ"
  1.  .. D ^DIC
  1.  .. I $D(XPDNM) X ^%ZOSF("EOFF")
  1.  .. I Y=-1 K FDA(811.9,IENS,1.4)
  1.  .. E  S FDA(811.9,IENS,1.4)=$P(Y,U,2)
  1.  ;
  1.  ;Sponsor field 101.
  1.  I $D(FDA(811.9,IENS,101)) D
  1.  . S SPONSOR=FDA(811.9,IENS,101)
  1.  . S IEN=$$FIND1^DIC(811.6,"","U",SPONSOR)
  1.  . I IEN=0 D
  1.  ..;Get replacement.
  1.  .. N DIC,X,Y
  1.  .. S TEXT(1)=" "
  1.  .. S TEXT(2)="The Sponsor does not exist on your system!"
  1.  .. S TEXT(3)="It is "_SPONSOR_" input a replacement or ^ to leave it empty."
  1.  .. D MES^XPDUTL(.TEXT)
  1.  ..;If this is being called during a KIDS install we need echoing on.
  1.  .. I $D(XPDNM) X ^%ZOSF("EON")
  1.  .. S DIC=811.6,DIC(0)="AEMQ"
  1.  .. D ^DIC
  1.  .. I $D(XPDNM) X ^%ZOSF("EOFF")
  1.  .. I Y=-1 K FDA(811.9,IENS,101)
  1.  .. E  S FDA(811.9,IENS,101)=$P(Y,U,2)
  1.  ;
  1.  ;Linked reminder dialog field 51.
  1.  S LRD=$G(FDA(811.9,IENS,51))
  1.  S IEN=$S(LRD="":0,1:+$O(^PXRMD(801.41,"B",LRD,"")))
  1.  I IEN=0 K FDA(811.9,IENS,51)
  1.  ;
  1.  ;Search the finding multiple for replacements and missing findings.
  1.  D SFMVPI(.FDA,.NAMECHG,811.902)
  1.  S VERSN=$$GETTAGV^PXRMEXU3(^PXD(811.8,PXRMRIEN,100,3,0),"<PACKAGE_VERSION>")
  1.  I VERSN=1.5 D CEFD^PXRMDATE(.FDA)
  1.  Q
  1.  ;
  1.  ;===============================================
  1. 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
  1.  ;display the warning message.
  1.  I NAME="" Q 0
  1.  ;Return the ien if it does, 0 otherwise.
  1.  N IEN
  1.  I FILENUM=0 S IEN=$$EXISTS^PXRMEXCF(NAME) Q
  1.  N FLAGS,RESULT
  1.  S RESULT=NAME
  1.  ;Special lookup for files 80 and 80.1, they do not have a standard "B"
  1.  ;cross-reference.
  1.  I (FILENUM=80)!(FILENUM=80.1) D
  1.  .;Name may or may not have the necessary space appended, make sure
  1.  .;it does.
  1.  . S RESULT=$S($E(NAME,$L(NAME))'=" ":NAME_" ",1:NAME)
  1.  . S FLAGS="MX"
  1.  E  S FLAGS="BXU"
  1.  ;File 8927.1 only allows upper case .01s.
  1.  I FILENUM=8927.1 S RESULT=$$UP^XLFSTR(NAME)
  1.  S IEN=$$FIND1^DIC(FILENUM,"",FLAGS,RESULT)
  1.  I +IEN>0 Q IEN
  1.  ;If IEN is null then there was an error try FIND^DIC.
  1.  N IND,FILENAME,LIST,MLIST,MSG,NFOUND,NMATCH,TEXT
  1.  D FIND^DIC(FILENUM,"","",FLAGS,NAME,"","","","","LIST","MSG")
  1.  S NFOUND=+$P(LIST("DILIST",0),U,1)
  1.  I NFOUND=0 Q 0
  1.  I NFOUND=1 Q LIST("DILIST",2,1)
  1.  ;Multiple entries with the same name found, search for a match with
  1.  ;the .01.
  1.  S NMATCH=0
  1.  F IND=1:1:NFOUND D
  1.  . I LIST("DILIST",1,IND)=NAME S NMATCH=NMATCH+1,MLIST(NMATCH)=IND
  1.  I NMATCH=1 Q LIST("DILIST",2,MLIST(1))
  1.  I NMATCH=0 Q 0
  1.  ;If FLAG="W" display the warning message, return the first entry on 
  1.  ;the list and quit.
  1.  I (NMATCH>1),$G(FLAG)="W" D  Q LIST("DILIST",2,1)
  1.  . S FILENAME=$$GET1^DID(FILENUM,"","","NAME")
  1.  . S TEXT(1)="Warning there are "_NMATCH_" "_FILENAME_" entries with the name "_NAME_"!"
  1.  . S TEXT(2)="If this is used as a finding, and it is not resolved by FileMan during"
  1.  . S TEXT(3)="installation, any component using this finding will not install."
  1.  . D EN^DDIOL(.TEXT)
  1.  . H 3
  1.  ;If FLAG is not "W" prompt the user for the replacement.
  1.  I NMATCH>1 S IEN=$$GETIEN^PXRMEXU0(NMATCH,.LIST)
  1.  Q IEN
  1.  ;
  1.  ;===============================================
  1. GETACT(CHOICES,DIR) ;Get the action
  1.  ;If CHOICES is empty the only action is skip.
  1.  I CHOICES="" Q "S"
  1.  N DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DIR(0)="S"_U
  1.  I CHOICES["C" S DIR(0)=DIR(0)_"C:Create a new entry by copying to a new name"
  1.  I CHOICES["D" S DIR(0)=DIR(0)_";D:Delete"
  1.  I CHOICES["I" S DIR(0)=DIR(0)_";I:Install"
  1.  I CHOICES["M" S DIR(0)=DIR(0)_";M:Merge findings"
  1.  I CHOICES["O" S DIR(0)=DIR(0)_";O:Overwrite the current entry"
  1.  I CHOICES["P" S DIR(0)=DIR(0)_";P:Replace with an existing entry"
  1.  I CHOICES["U" S DIR(0)=DIR(0)_";U:Update"
  1.  I CHOICES["Q" S DIR(0)=DIR(0)_";Q:Quit the install"
  1.  I CHOICES["R" S DIR(0)=DIR(0)_";R:Restart"
  1.  I CHOICES["S" S DIR(0)=DIR(0)_";S:Skip, do not install this entry"
  1.  ;If this is being called during a KIDS install we need echoing on.
  1.  I $D(XPDNM) X ^%ZOSF("EON")
  1.  D ^DIR
  1.  I $D(XPDNM) X ^%ZOSF("EOFF")
  1.  I $D(DIROUT)!$D(DIRUT) S Y="S"
  1.  I $D(DTOUT)!($D(DUOUT)) S Y="S"
  1.  Q Y
  1.  ;
  1.  ;===============================================
  1. GETNAME(MIN,MAX) ;Get a name to use.
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DIR(0)="FAOU"_U_MIN_":"_MAX
  1.  S DIR("A")="Input the new name: "
  1.  D ^DIR
  1.  I $D(DIROUT)!$D(DIRUT) Q ""
  1.  I $D(DTOUT)!$D(DUOUT) Q ""
  1.  Q Y
  1.  ;
  1.  ;===============================================
  1. GETUNAME(ATTR) ;Get a unique name to use, ATTR holds the attributes.
  1.  N IEN,NEWPT01,TEXT
  1. GNEW S NEWPT01=$$GETNAME(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH"))
  1.  S IEN=+$$EXISTS(ATTR("FILE NUMBER"),NEWPT01)
  1.  I IEN>0 D  G GNEW
  1.  . S TEXT(1)=ATTR("FILE NAME")_" entry "_NEWPT01_" already exists."
  1.  . S TEXT(2)="Input a different name or type <ENTER> to quit."
  1.  . D EN^DDIOL(.TEXT)
  1.  E  S ATTR("NAME")=NEWPT01
  1.  Q NEWPT01
  1.  ;
  1.  ;===============================================
  1. HF(FDA,NAMECHG) ;Check the health factor to make sure a category does not
  1.  ;have a category.
  1.  N IENS
  1.  S IENS=$O(FDA(9999999.64,""))
  1.  I IENS="" Q
  1.  I FDA(9999999.64,IENS,.1)="CATEGORY" K FDA(9999999.64,IENS,.03)
  1.  Q
  1.  ;
  1.  ;===============================================
  1. REXISTS(NAME,DATEP) ;See if this Exchange File entry already exists.
  1.  N IEN,LUVALUE
  1.  S LUVALUE(1)=NAME
  1.  S LUVALUE(2)=DATEP
  1.  S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
  1.  Q IEN
  1.  ;
  1.  ;===============================================
  1. 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,
  1.  ;terms, and health summary types.
  1.  N ABBR,ACTION,ALIST,DIR,IEN,IENS,FILENUM,FINDING,HSUB,OFINDING,PT01,TYPE
  1.  ;Search the finding multiple for replacements and missing findings.
  1.  S HSUB=$S(SFN=142.14:"HSTI",SFN=811.52:"TRMF",1:"DEFF")
  1.  S TYPE=$S(SFN=142.14:"Selection item",1:"Finding")
  1.  D BLDALIST^PXRMVPTR(SFN,.01,.ALIST)
  1.  S (ACTION,IENS)=""
  1.  F  S IENS=$O(FDA(SFN,IENS)) Q:(IENS="")!(ACTION="Q")  D
  1.  . S (FINDING,OFINDING)=FDA(SFN,IENS,.01)
  1.  . S ABBR=$P(FINDING,".",1)
  1.  . S PT01=$P(FINDING,".",2)
  1.  . S FILENUM=$P(ALIST(ABBR),U,1)
  1.  . I $D(NAMECHG(FILENUM,PT01)) D
  1.  .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
  1.  .. S FDA(SFN,IENS,.01)=FINDING
  1.  . S IEN=+$$VFIND1(FINDING,.ALIST)
  1.  . I IEN>0 S FDA(SFN,IENS,.01)=ABBR_".`"_IEN
  1.  . I IEN=0 D
  1.  ..;Get replacement
  1.  .. N DIC,DUOUT,ROOT,TEXT,X,Y,YY
  1.  .. S TEXT(1)=TYPE_" "_FINDING_" does not exist, what do you want to do?"
  1.  .. D BMES^XPDUTL(.TEXT)
  1.  .. S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
  1.  .. I ACTION="Q" K FDA Q
  1.  .. I ACTION="D" K FDA(SFN,IENS) Q 
  1.  .. S DIC=FILENUM
  1.  .. S ROOT=$P($$ROOT^DILFD(FILENUM),U,2)
  1.  .. S DIC("S")="S YY=Y_"";""_ROOT I $$VFINDING^PXRMINTR(YY)"
  1.  .. S DIC(0)="AEMNQ"
  1.  .. S Y=-1
  1.  .. F  Q:+Y'=-1  D
  1.  ...;If this is being called during a KIDS install we need echoing on.
  1.  ... I $D(XPDNM) X ^%ZOSF("EON")
  1.  ... D ^DIC
  1.  ... I $D(XPDNM) X ^%ZOSF("EOFF")
  1.  ... I $D(DUOUT) D
  1.  .... S Y=""
  1.  .... K FDA
  1.  .. I Y="" K FDA(SFN,IENS)
  1.  .. E  D
  1.  ... S FINDING=ABBR_"."_$P(Y,U,2)
  1.  ... S FDA(SFN,IENS,.01)=FINDING
  1.  .;Save the finding information for the history.
  1.  . S ^TMP("PXRMEXIA",$J,HSUB,$P(IENS,",",1),OFINDING)=FINDING
  1.  Q
  1.  ;
  1.  ;===============================================
  1. TIUOBJ(FDA) ;Resolve the name of the health summary object.
  1.  N END,HSOBJIEN,IENS,START,TEMP
  1.  S IENS=$O(FDA(8925.1,""))
  1.  S TEMP=$G(FDA(8925.1,IENS,9))
  1.  I TEMP'["TIU^GMTSOBJ" Q
  1.  S START=$F(TEMP,"DFN,")
  1.  S END=$L(TEMP)-1
  1.  S TEMP=$E(TEMP,START,END)
  1.  S HSOBJIEN=$O(^GMT(142.5,"B",TEMP,""))
  1.  I HSOBJIEN="" D  Q
  1.  . N TEXT
  1.  . S TEXT(1)="Health Summary Object "_TEMP_" does not exist."
  1.  . S TEXT(2)="It must be installed before this TIU Health Summary Object can be installed."
  1.  . S TEXT(3)="Please go back and install it, making sure the corresponding Health Summary"
  1.  . S TEXT(4)="Type has been installed first."
  1.  . S TEXT(5)=" "
  1.  . I '$D(XPDNM) D EN^DDIOL(.TEXT)
  1.  . I $D(XPDNM) D BMES^XPDUTL(.TEXT)
  1.  S FDA(8925.1,IENS,9)="S X=$$TIU^GMTSOBJ(DFN,"_HSOBJIEN_")"
  1.  S FDA(8925.1,IENS,99)=$H
  1.  Q
  1.  ;
  1.  ;===============================================
  1. 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
  1.  ;returns a 0.
  1.  N FILENUM
  1.  S FILENUM=$P(ALIST(ABBR),U,1)
  1.  Q $$FILESCR^PXRMDLG6(IEN,FILENUM)
  1.  ;
  1.  ;===============================================
  1. VFIND1(VPTR,ALIST) ;Given a variable pointer of the form ABBR.NAME
  1.  ;and ALIST which contains the link between abbreviations and files
  1.  ;return the IEN if it exists and 0 if no match if found.
  1.  N ABBR,IEN,FILENUM,PT01,RESULT
  1.  S IEN=0
  1.  S ABBR=$P(VPTR,".",1)
  1.  S PT01=$P(VPTR,".",2,99)
  1.  S FILENUM=$P(ALIST(ABBR),U,1)
  1.  S IEN=$$EXISTS(FILENUM,PT01)
  1.  Q IEN
  1.  ;