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. ;03/30/2018
  1. ;;2.0;CLINICAL REMINDERS;**4,6,12,17,18,24,26,47,45**;Feb 04, 2005;Build 566
  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 RNAME,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 RNAME=$G(FDA(811.9,IENS,.01))
  1. I LRD'="",RNAME'="" S ^TMP("PXRMEXDL",$J,LRD,RNAME)=""
  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. DELFIND(SFN,IENS,FDA) ;Delete a finding from the FDA.
  1. N IENSD,SFND
  1. S SFND=""
  1. F S SFND=$O(FDA(SFND)) Q:SFND="" D
  1. . S IENSD=""
  1. . F S IENSD=$O(FDA(SFND,IENSD)) Q:IENSD="" I IENSD[IENS K FDA(SFND,IENSD)
  1. K FDA(SFN,IENS)
  1. Q
  1. ;
  1. ;===================
  1. EDU(FDA,EDULIST) ;Education Topics special handling. Add national education
  1. ;topics to EDULIST.
  1. N CDEF,IENS,MSG
  1. S IENS=$O(FDA(9999999.09,""))
  1. I IENS="" Q
  1. S EDULIST(FDA(TOPFNUM,IENS,.01))=""
  1. ;If the Class field exists, make sure there is a value for it
  1. ;in the FDA.
  1. I $G(FDA(9999999.09,IENS,100))'="" D Q
  1. . I FDA(9999999.09,IENS,100)="NATIONAL" S EDULIST(FDA(TOPFNUM,IENS,.01))=""
  1. S CDEF=$S($$GET1^DID(9999999.09,100,"","LABEL","","MSG")="CLASS":1,1:0)
  1. I 'CDEF Q
  1. S FDA(9999999.09,IENS,100)=$S($G(PXRMNAT):"NATIONAL",1:"LOCAL")
  1. I FDA(9999999.09,IENS,100)="NATIONAL" S EDULIST(FDA(TOPFNUM,IENS,.01))=""
  1. Q
  1. ;
  1. ;===================
  1. EXAM(FDA) ;Check the health factor to make sure a category does not
  1. ;have a category.
  1. N CDEF,IENS,MSG
  1. S IENS=$O(FDA(9999999.15,""))
  1. I IENS="" Q
  1. ;If the Class field exists, make sure there is a value for it
  1. ;in the FDA.
  1. I $G(FDA(9999999.15,IENS,100))'="" Q
  1. S CDEF=$S($$GET1^DID(9999999.15,100,"","LABEL","","MSG")="CLASS":1,1:0)
  1. I 'CDEF Q
  1. S FDA(9999999.15,IENS,100)=$S($G(PXRMNAT):"NATIONAL",1:"LOCAL")
  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,MSG
  1. I FILENUM=0 S IEN=$$EXISTS^PXRMEXCF(NAME) Q
  1. N FLAGS,RESULT,SCREEN
  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 SCREEN=$S(FILENUM=50.6:"I $$VAGENSCR^PXRMEXIU(Y)",1:"")
  1. S IEN=$$FIND1^DIC(FILENUM,"",FLAGS,RESULT,"",SCREEN,"MSG")
  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,NFOUND,NMATCH,TEXT
  1. K MSG
  1. D FIND^DIC(FILENUM,"","",FLAGS,NAME,"","",SCREEN,"","LIST","MSG")
  1. I $D(MSG) D Q 0
  1. . K TEXT
  1. . S TEXT(1)=""
  1. . S TEXT(2)="Cannot install the entry named "_NAME
  1. . S TEXT(3)="In file number "_FILENUM
  1. . S TEXT(4)="For the reason see the error message below."
  1. . S TEXT(5)=""
  1. . D EN^DDIOL(.TEXT)
  1. . D AWRITE^PXRMUTIL("MSG")
  1. . H 2
  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. . K TEXT
  1. . S TEXT(1)=""
  1. . S TEXT(2)="Warning there are "_NMATCH_" "_FILENAME_" entries with the name "_NAME_"!"
  1. . S TEXT(3)="If this is used as a finding, and it is not resolved by FileMan during"
  1. . S TEXT(4)="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) ;Health factor special handling.
  1. N CDEF,IENS,MSG
  1. S IENS=$O(FDA(9999999.64,""))
  1. I IENS="" Q
  1. ;Make sure a category does not have a category.
  1. I FDA(9999999.64,IENS,.1)="CATEGORY" K FDA(9999999.64,IENS,.03)
  1. ;If the Class field exists, make sure there is a value for it
  1. ;in the FDA.
  1. I $G(FDA(9999999.64,IENS,100))'="" Q
  1. S CDEF=$S($$GET1^DID(9999999.64,100,"","LABEL","","MSG")="CLASS":1,1:0)
  1. I 'CDEF Q
  1. S FDA(9999999.64,IENS,100)=$S($G(PXRMNAT):"NATIONAL",1:"LOCAL")
  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
  1. N REPFI,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,REPFI=""
  1. .;Check if a replacement already exists.
  1. . I IEN=0 S REPFI=$G(^TMP($J,"PXRM FINDING REPLACE",FINDING))
  1. . I REPFI'="" S (FINDING,FDA(SFN,IENS,.01))=REPFI
  1. . I (IEN=0),(REPFI="") 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" D DELFIND(SFN,IENS,.FDA) 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 REPFI=ABBR_"."_$P(Y,U,2)
  1. ... S FDA(SFN,IENS,.01)=REPFI
  1. ... S ^TMP($J,"PXRM FINDING REPLACE",FINDING)=REPFI
  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 COWN,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. ;Make sure either the Personal Owner (.05) or Class Owner (.06) is set.
  1. ;If CLINICAL COORDINATOR is defined use it as the Class Owner.
  1. S COWN=+$$EXISTS(8930,"CLINICAL COORDINATOR")
  1. I COWN=0 S FDA(8925.1,IENS,.05)="`"_DUZ
  1. I COWN>0 S FDA(8925.1,IENS,.06)="`"_COWN
  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. VAGENSCR(IEN) ;Screen for VA Generic, file #50.6, return true only for
  1. ;active entries.
  1. N OK
  1. ;DBIA #4540
  1. D ZERO^PSN50P6(IEN,"",1,"","LIST")
  1. ;If ^TMP($J,"LIST",IEN,1) is null then then entry is active.
  1. S OK=$S(^TMP($J,"LIST",IEN,1)="":1,1:0)
  1. K ^TMP($J,"LIST")
  1. Q OK
  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. ;