- 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 Feb 18, 2025@23:11:23 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 ;