source: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXIU.m

PXRMEXIU ; SLC/PKR/PJH - Utilities for installing repository entries. ;06/23/2005
 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
 ;===============================================
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,"","",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=$$EXISTS^PXRMEXIU(801.41,LRD)
 I IEN=0 K FDA(811.9,IENS,51)
 ;
 ;Search the finding multiple for replacements and missing findings.
 D BLDALIST^PXRMVPTR(811.902,.01,.ALIST)
 S IENS=""
 F  S IENS=$O(FDA(811.902,IENS)) Q:IENS=""  D
 . S (FINDING,OFINDING)=FDA(811.902,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(811.902,IENS,.01)=FINDING
 . S IEN=+$$VFIND1(FINDING,.ALIST)
 . I IEN>0 S FDA(811.902,IENS,.01)=ABBR_".`"_IEN
 . I IEN=0 D
 ..;Get replacement
 .. N DIC,DUOUT,TEXT,X,Y
 .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install."
 .. W !,TEXT
 .. S DIC=FILENUM
 .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)"
 .. 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) S Y="" K FDA
 .. I Y="" Q
 .. S FINDING=ABBR_"."_$P(Y,U,2),FDA(811.902,IENS,.01)=FINDING
 .;Save the finding information for the history.
 . S ^TMP("PXRMEXIA",$J,"DEFF",$P(IENS,",",1),OFINDING)=FINDING
 .;Save changes to Orderable items for dialog
 . I FILENUM=101.43,OFINDING'=FINDING
 . S NAMECHG(FILENUM,$P(OFINDING,".",2))=$P(FINDING,".",2)
 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
 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="BX"
 I FILENUM=811.6 S FLAGS=FLAGS_"U"
 ;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 FILENAME,LIST,MSG,NFOUND,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.
 S FILENAME=$$GET1^DID(FILENUM,"","","NAME")
 S TEXT(1)="Warning there are "_NFOUND_" "_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)
 I $G(FLAG)="W" H 3 Q LIST("DILIST",2,1)
 I NFOUND>1 S IEN=$$GETIEN^PXRMEXU0(NFOUND,.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 (from the reminder/dialog)"
 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 (in the reminder/dialog) with an existing entry"
 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=ATTR("FILE NAME")_" entry "_NEWPT01_" already exists, what do you want to do?"
 . 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
 ;
 ;===============================================
LABPANEL(IEN) ;
 N NODE
 S NODE=^LAB(60,IEN,0)
 I $P(NODE,U,4)'["CH" Q 1
 I $P(NODE,U,5)="" Q 0
 Q 1
 ;
 ;===============================================
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
 ;
 ;===============================================
SAME(ATTR,TA,NAME) ;Check existing entry and entry in packed reminder
 ;definition to see if they are identical.
 ;Present version only works for computed finding routines, other
 ;types of entries can be added later.
 N SAME
 I ATTR("FILE NAME")="COMPUTED FINDING ROUTINE" S SAME=$$SAME^PXRMEXCF(.ATTR,.TA,NAME)
 E  S SAME=1
 Q SAME
 ;
 ;===============================================
TERM(FDA,NAMECHG) ;Check the reminder term to make sure all the
 ;findings exist.
 N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,OFINDING,PT01
 ;Search the finding multiple for replacements and missing findings.
 D BLDALIST^PXRMVPTR(811.52,.01,.ALIST)
 S IENS=""
 F  S IENS=$O(FDA(811.52,IENS)) Q:IENS=""  D
 . S (FINDING,OFINDING)=FDA(811.52,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(811.52,IENS,.01)=FINDING
 . S IEN=+$$VFIND1(FINDING,.ALIST)
 . I IEN>0 S FDA(811.52,IENS,.01)=ABBR_".`"_IEN
 . I IEN=0 D
 ..;Get replacement
 .. N DIC,DUOUT,TEXT,X,Y
 .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install."
 .. D BMES^XPDUTL(TEXT)
 .. S DIC=FILENUM
 .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)"
 .. 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(811.52,IENS)
 .. E  D
 ... S FINDING=ABBR_"."_$P(Y,U,2)
 ... S FDA(811.52,IENS,.01)=FINDING
 .;Save the finding information for the history.
 . S ^TMP("PXRMEXIA",$J,"TRMF",$P(IENS,",",1),OFINDING)=FINDING
 Q
 ;
 ;===============================================
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
 ;