Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXIU.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXIU.m
r613 r623 1 PXRMEXIU ; SLC/PKR/PJH - Utilities for installing repository entries. ;07/27/2007 2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 3 ;=============================================== 4 DEF(FDA,NAMECHG) ;Check the reminder definition to make sure the related 5 ;reminder exists and all the findings exist. 6 N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,LRD,OFINDING,PT01 7 N RRG,SPONSOR,TEXT,VERSN 8 S IENS=$O(FDA(811.9,"")) 9 ; 10 ;Related reminder guideline field 1.4. 11 I $D(FDA(811.9,IENS,1.4)) D 12 . S RRG=FDA(811.9,IENS,1.4) 13 . S IEN=$$EXISTS^PXRMEXIU(811.9,RRG) 14 . I IEN=0 D 15 ..;Get replacement. 16 .. N DIC,X,Y 17 .. S TEXT(1)=" " 18 .. S TEXT(2)="The Related Reminder Guideline does not exist on your system!" 19 .. S TEXT(3)="It is "_RRG_" input a replacement or ^ to leave it empty." 20 .. D MES^XPDUTL(.TEXT) 21 ..;If this is being called during a KIDS install we need echoing on. 22 .. I $D(XPDNM) X ^%ZOSF("EON") 23 .. S DIC=811.9,DIC(0)="AEMQ" 24 .. D ^DIC 25 .. I $D(XPDNM) X ^%ZOSF("EOFF") 26 .. I Y=-1 K FDA(811.9,IENS,1.4) 27 .. E S FDA(811.9,IENS,1.4)=$P(Y,U,2) 28 ; 29 ;Sponsor field 101. 30 I $D(FDA(811.9,IENS,101)) D 31 . S SPONSOR=FDA(811.9,IENS,101) 32 . S IEN=$$FIND1^DIC(811.6,"","",SPONSOR) 33 . I IEN=0 D 34 ..;Get replacement. 35 .. N DIC,X,Y 36 .. S TEXT(1)=" " 37 .. S TEXT(2)="The Sponsor does not exist on your system!" 38 .. S TEXT(3)="It is "_SPONSOR_" input a replacement or ^ to leave it empty." 39 .. D MES^XPDUTL(.TEXT) 40 ..;If this is being called during a KIDS install we need echoing on. 41 .. I $D(XPDNM) X ^%ZOSF("EON") 42 .. S DIC=811.6,DIC(0)="AEMQ" 43 .. D ^DIC 44 .. I $D(XPDNM) X ^%ZOSF("EOFF") 45 .. I Y=-1 K FDA(811.9,IENS,101) 46 .. E S FDA(811.9,IENS,101)=$P(Y,U,2) 47 ; 48 ;Linked reminder dialog field 51. 49 S LRD=$G(FDA(811.9,IENS,51)) 50 S IEN=$S(LRD="":0,1:+$O(^PXRMD(801.41,"B",LRD,""))) 51 I IEN=0 K FDA(811.9,IENS,51) 52 ; 53 ;Search the finding multiple for replacements and missing findings. 54 D BLDALIST^PXRMVPTR(811.902,.01,.ALIST) 55 S IENS="" 56 F S IENS=$O(FDA(811.902,IENS)) Q:IENS="" D 57 . S (FINDING,OFINDING)=FDA(811.902,IENS,.01) 58 . S ABBR=$P(FINDING,".",1) 59 . S PT01=$P(FINDING,".",2) 60 . S FILENUM=$P(ALIST(ABBR),U,1) 61 . I $D(NAMECHG(FILENUM,PT01)) D 62 .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01) 63 .. S FDA(811.902,IENS,.01)=FINDING 64 . S IEN=+$$VFIND1(FINDING,.ALIST) 65 . I IEN>0 S FDA(811.902,IENS,.01)=ABBR_".`"_IEN 66 . I IEN=0 D 67 ..;Get replacement 68 .. N DIC,DUOUT,TEXT,X,Y 69 .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install." 70 .. W !,TEXT 71 .. S DIC=FILENUM 72 .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)" 73 .. S DIC(0)="AEMNQ" 74 .. S Y=-1 75 .. F Q:+Y'=-1 D 76 ...;If this is being called during a KIDS install we need echoing on. 77 ... I $D(XPDNM) X ^%ZOSF("EON") 78 ... D ^DIC 79 ... I $D(XPDNM) X ^%ZOSF("EOFF") 80 ... I $D(DUOUT) S Y="" K FDA 81 .. I Y="" Q 82 .. S FINDING=ABBR_"."_$P(Y,U,2),FDA(811.902,IENS,.01)=FINDING 83 .;Save the finding information for the history. 84 . S ^TMP("PXRMEXIA",$J,"DEFF",$P(IENS,",",1),OFINDING)=FINDING 85 .;Save changes to Orderable items for dialog 86 . I FILENUM=101.43,OFINDING'=FINDING 87 . S NAMECHG(FILENUM,$P(OFINDING,".",2))=$P(FINDING,".",2) 88 S VERSN=$$GETTAGV^PXRMEXU3(^PXD(811.8,PXRMRIEN,100,3,0),"<PACKAGE_VERSION>") 89 I VERSN=1.5 D CEFD^PXRMDATE(.FDA) 90 Q 91 ; 92 ;=============================================== 93 EXISTS(FILENUM,NAME,FLAG) ;Check for existence of an entry with the 94 ;same name. Return 0 for null name 95 I NAME="" Q 0 96 ;Return the ien if it does, 0 otherwise. 97 N IEN 98 I FILENUM=0 S IEN=$$EXISTS^PXRMEXCF(NAME) Q 99 N FLAGS,RESULT 100 S RESULT=NAME 101 ;Special lookup for files 80 and 80.1, they do not have a standard "B" 102 ;cross-reference. 103 I (FILENUM=80)!(FILENUM=80.1) D 104 .;Name may or may not have the necessary space appended, make sure 105 .;it does. 106 . S RESULT=$S($E(NAME,$L(NAME))'=" ":NAME_" ",1:NAME) 107 . S FLAGS="MX" 108 E S FLAGS="BX" 109 I FILENUM=811.6 S FLAGS=FLAGS_"U" 110 ;File 8927.1 only allows upper case .01s. 111 I FILENUM=8927.1 S RESULT=$$UP^XLFSTR(NAME) 112 S IEN=$$FIND1^DIC(FILENUM,"",FLAGS,RESULT) 113 I +IEN>0 Q IEN 114 ;If IEN is null then there was an error try FIND^DIC. 115 N FILENAME,LIST,MSG,NFOUND,TEXT 116 D FIND^DIC(FILENUM,"","",FLAGS,NAME,"","","","","LIST","MSG") 117 S NFOUND=+$P(LIST("DILIST",0),U,1) 118 I NFOUND=0 Q 0 119 I NFOUND=1 Q LIST("DILIST",2,1) 120 ;Multiple entries with the same name found. 121 S FILENAME=$$GET1^DID(FILENUM,"","","NAME") 122 S TEXT(1)="Warning there are "_NFOUND_" "_FILENAME_" entries with the name "_NAME_"!" 123 S TEXT(2)="If this is used as a finding, and it is not resolved by FileMan during" 124 S TEXT(3)="installation, any component using this finding will not install." 125 D EN^DDIOL(.TEXT) 126 I $G(FLAG)="W" H 3 Q LIST("DILIST",2,1) 127 I NFOUND>1 S IEN=$$GETIEN^PXRMEXU0(NFOUND,.LIST) 128 Q IEN 129 ; 130 ;=============================================== 131 GETACT(CHOICES,DIR) ;Get the action 132 ;If CHOICES is empty the only action is skip. 133 I CHOICES="" Q "S" 134 N DIROUT,DIRUT,DTOUT,DUOUT,X,Y 135 S DIR(0)="S"_U 136 I CHOICES["C" S DIR(0)=DIR(0)_"C:Create a new entry by copying to a new name" 137 I CHOICES["D" S DIR(0)=DIR(0)_";D:Delete (from the reminder/dialog)" 138 I CHOICES["I" S DIR(0)=DIR(0)_";I:Install" 139 I CHOICES["M" S DIR(0)=DIR(0)_";M:Merge findings" 140 I CHOICES["O" S DIR(0)=DIR(0)_";O:Overwrite the current entry" 141 I CHOICES["P" S DIR(0)=DIR(0)_";P:Replace (in the reminder/dialog) with an existing entry" 142 I CHOICES["Q" S DIR(0)=DIR(0)_";Q:Quit the install" 143 I CHOICES["R" S DIR(0)=DIR(0)_";R:Restart" 144 I CHOICES["S" S DIR(0)=DIR(0)_";S:Skip, do not install this entry" 145 ;If this is being called during a KIDS install we need echoing on. 146 I $D(XPDNM) X ^%ZOSF("EON") 147 D ^DIR 148 I $D(XPDNM) X ^%ZOSF("EOFF") 149 I $D(DIROUT)!$D(DIRUT) S Y="S" 150 I $D(DTOUT)!($D(DUOUT)) S Y="S" 151 Q Y 152 ; 153 ;=============================================== 154 GETNAME(MIN,MAX) ;Get a name to use. 155 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y 156 S DIR(0)="FAOU"_U_MIN_":"_MAX 157 S DIR("A")="Input the new name: " 158 D ^DIR 159 I $D(DIROUT)!$D(DIRUT) Q "" 160 I $D(DTOUT)!$D(DUOUT) Q "" 161 Q Y 162 ; 163 ;=============================================== 164 GETUNAME(ATTR) ;Get a unique name to use, ATTR holds the attributes. 165 N IEN,NEWPT01,TEXT 166 GNEW S NEWPT01=$$GETNAME(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH")) 167 S IEN=+$$EXISTS(ATTR("FILE NUMBER"),NEWPT01) 168 I IEN>0 D G GNEW 169 . S TEXT=ATTR("FILE NAME")_" entry "_NEWPT01_" already exists, what do you want to do?" 170 . D EN^DDIOL(TEXT) 171 E S ATTR("NAME")=NEWPT01 172 Q NEWPT01 173 ; 174 ;=============================================== 175 HF(FDA,NAMECHG) ;Check the health factor to make sure a category does not 176 ;have a category. 177 N IENS 178 S IENS=$O(FDA(9999999.64,"")) 179 I IENS="" Q 180 I FDA(9999999.64,IENS,.1)="CATEGORY" K FDA(9999999.64,IENS,.03) 181 Q 182 ; 183 ;=============================================== 184 LABPANEL(IEN) ; 185 N NODE 186 S NODE=^LAB(60,IEN,0) 187 I $P(NODE,U,4)'["CH" Q 1 188 I $P(NODE,U,5)="" Q 0 189 Q 1 190 ; 191 ;=============================================== 192 REXISTS(NAME,DATEP) ;See if this Exchange File entry already exists. 193 N IEN,LUVALUE 194 S LUVALUE(1)=NAME 195 S LUVALUE(2)=DATEP 196 S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE) 197 Q IEN 198 ; 199 ;=============================================== 200 TERM(FDA,NAMECHG) ;Check the reminder term to make sure all the 201 ;findings exist. 202 N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,OFINDING,PT01 203 ;Search the finding multiple for replacements and missing findings. 204 D BLDALIST^PXRMVPTR(811.52,.01,.ALIST) 205 S IENS="" 206 F S IENS=$O(FDA(811.52,IENS)) Q:IENS="" D 207 . S (FINDING,OFINDING)=FDA(811.52,IENS,.01) 208 . S ABBR=$P(FINDING,".",1) 209 . S PT01=$P(FINDING,".",2) 210 . S FILENUM=$P(ALIST(ABBR),U,1) 211 . I $D(NAMECHG(FILENUM,PT01)) D 212 .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01) 213 .. S FDA(811.52,IENS,.01)=FINDING 214 . S IEN=+$$VFIND1(FINDING,.ALIST) 215 . I IEN>0 S FDA(811.52,IENS,.01)=ABBR_".`"_IEN 216 . I IEN=0 D 217 ..;Get replacement 218 .. N DIC,DUOUT,TEXT,X,Y 219 .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install." 220 .. D BMES^XPDUTL(TEXT) 221 .. S DIC=FILENUM 222 .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)" 223 .. S DIC(0)="AEMNQ" 224 .. S Y=-1 225 .. F Q:+Y'=-1 D 226 ...;If this is being called during a KIDS install we need echoing on. 227 ... I $D(XPDNM) X ^%ZOSF("EON") 228 ... D ^DIC 229 ... I $D(XPDNM) X ^%ZOSF("EOFF") 230 ... I $D(DUOUT) D 231 .... S Y="" 232 .... K FDA 233 .. I Y="" K FDA(811.52,IENS) 234 .. E D 235 ... S FINDING=ABBR_"."_$P(Y,U,2) 236 ... S FDA(811.52,IENS,.01)=FINDING 237 .;Save the finding information for the history. 238 . S ^TMP("PXRMEXIA",$J,"TRMF",$P(IENS,",",1),OFINDING)=FINDING 239 Q 240 ; 241 ;=============================================== 242 VFIND1(VPTR,ALIST) ;Given a variable pointer of the form ABBR.NAME 243 ;and ALIST which contains the link between abbreviations and files 244 ;return the IEN if it exists and 0 if no match if found. 245 N ABBR,IEN,FILENUM,PT01,RESULT 246 S IEN=0 247 S ABBR=$P(VPTR,".",1) 248 S PT01=$P(VPTR,".",2,99) 249 S FILENUM=$P(ALIST(ABBR),U,1) 250 S IEN=$$EXISTS(FILENUM,PT01) 251 Q IEN 252 ; 1 PXRMEXIU ; SLC/PKR/PJH - Utilities for installing repository entries. ;06/23/2005 2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 3 ;=============================================== 4 DEF(FDA,NAMECHG) ;Check the reminder definition to make sure the related 5 ;reminder exists and all the findings exist. 6 N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,LRD,OFINDING,PT01 7 N RRG,SPONSOR,TEXT,VERSN 8 S IENS=$O(FDA(811.9,"")) 9 ; 10 ;Related reminder guideline field 1.4. 11 I $D(FDA(811.9,IENS,1.4)) D 12 . S RRG=FDA(811.9,IENS,1.4) 13 . S IEN=$$EXISTS^PXRMEXIU(811.9,RRG) 14 . I IEN=0 D 15 ..;Get replacement. 16 .. N DIC,X,Y 17 .. S TEXT(1)=" " 18 .. S TEXT(2)="The Related Reminder Guideline does not exist on your system!" 19 .. S TEXT(3)="It is "_RRG_" input a replacement or ^ to leave it empty." 20 .. D MES^XPDUTL(.TEXT) 21 ..;If this is being called during a KIDS install we need echoing on. 22 .. I $D(XPDNM) X ^%ZOSF("EON") 23 .. S DIC=811.9,DIC(0)="AEMQ" 24 .. D ^DIC 25 .. I $D(XPDNM) X ^%ZOSF("EOFF") 26 .. I Y=-1 K FDA(811.9,IENS,1.4) 27 .. E S FDA(811.9,IENS,1.4)=$P(Y,U,2) 28 ; 29 ;Sponsor field 101. 30 I $D(FDA(811.9,IENS,101)) D 31 . S SPONSOR=FDA(811.9,IENS,101) 32 . S IEN=$$FIND1^DIC(811.6,"","",SPONSOR) 33 . I IEN=0 D 34 ..;Get replacement. 35 .. N DIC,X,Y 36 .. S TEXT(1)=" " 37 .. S TEXT(2)="The Sponsor does not exist on your system!" 38 .. S TEXT(3)="It is "_SPONSOR_" input a replacement or ^ to leave it empty." 39 .. D MES^XPDUTL(.TEXT) 40 ..;If this is being called during a KIDS install we need echoing on. 41 .. I $D(XPDNM) X ^%ZOSF("EON") 42 .. S DIC=811.6,DIC(0)="AEMQ" 43 .. D ^DIC 44 .. I $D(XPDNM) X ^%ZOSF("EOFF") 45 .. I Y=-1 K FDA(811.9,IENS,101) 46 .. E S FDA(811.9,IENS,101)=$P(Y,U,2) 47 ; 48 ;Linked reminder dialog field 51. 49 S LRD=+$G(FDA(811.9,IENS,51)) 50 S IEN=$$EXISTS^PXRMEXIU(801.41,LRD) 51 I IEN=0 K FDA(811.9,IENS,51) 52 ; 53 ;Search the finding multiple for replacements and missing findings. 54 D BLDALIST^PXRMVPTR(811.902,.01,.ALIST) 55 S IENS="" 56 F S IENS=$O(FDA(811.902,IENS)) Q:IENS="" D 57 . S (FINDING,OFINDING)=FDA(811.902,IENS,.01) 58 . S ABBR=$P(FINDING,".",1) 59 . S PT01=$P(FINDING,".",2) 60 . S FILENUM=$P(ALIST(ABBR),U,1) 61 . I $D(NAMECHG(FILENUM,PT01)) D 62 .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01) 63 .. S FDA(811.902,IENS,.01)=FINDING 64 . S IEN=+$$VFIND1(FINDING,.ALIST) 65 . I IEN>0 S FDA(811.902,IENS,.01)=ABBR_".`"_IEN 66 . I IEN=0 D 67 ..;Get replacement 68 .. N DIC,DUOUT,TEXT,X,Y 69 .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install." 70 .. W !,TEXT 71 .. S DIC=FILENUM 72 .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)" 73 .. S DIC(0)="AEMNQ" 74 .. S Y=-1 75 .. F Q:+Y'=-1 D 76 ...;If this is being called during a KIDS install we need echoing on. 77 ... I $D(XPDNM) X ^%ZOSF("EON") 78 ... D ^DIC 79 ... I $D(XPDNM) X ^%ZOSF("EOFF") 80 ... I $D(DUOUT) S Y="" K FDA 81 .. I Y="" Q 82 .. S FINDING=ABBR_"."_$P(Y,U,2),FDA(811.902,IENS,.01)=FINDING 83 .;Save the finding information for the history. 84 . S ^TMP("PXRMEXIA",$J,"DEFF",$P(IENS,",",1),OFINDING)=FINDING 85 .;Save changes to Orderable items for dialog 86 . I FILENUM=101.43,OFINDING'=FINDING 87 . S NAMECHG(FILENUM,$P(OFINDING,".",2))=$P(FINDING,".",2) 88 S VERSN=$$GETTAGV^PXRMEXU3(^PXD(811.8,PXRMRIEN,100,3,0),"<PACKAGE_VERSION>") 89 I VERSN=1.5 D CEFD^PXRMDATE(.FDA) 90 Q 91 ; 92 ;=============================================== 93 EXISTS(FILENUM,NAME,FLAG) ;Check for existence of an entry with the 94 ;same name. Return 0 for null name 95 I NAME="" Q 0 96 ;Return the ien if it does, 0 otherwise. 97 N IEN 98 I FILENUM=0 S IEN=$$EXISTS^PXRMEXCF(NAME) Q 99 N FLAGS,RESULT 100 S RESULT=NAME 101 ;Special lookup for files 80 and 80.1, they do not have a standard "B" 102 ;cross-reference. 103 I (FILENUM=80)!(FILENUM=80.1) D 104 .;Name may or may not have the necessary space appended, make sure 105 .;it does. 106 . S RESULT=$S($E(NAME,$L(NAME))'=" ":NAME_" ",1:NAME) 107 . S FLAGS="MX" 108 E S FLAGS="BX" 109 I FILENUM=811.6 S FLAGS=FLAGS_"U" 110 ;File 8927.1 only allows upper case .01s. 111 I FILENUM=8927.1 S RESULT=$$UP^XLFSTR(NAME) 112 S IEN=$$FIND1^DIC(FILENUM,"",FLAGS,RESULT) 113 I +IEN>0 Q IEN 114 ;If IEN is null then there was an error try FIND^DIC. 115 N FILENAME,LIST,MSG,NFOUND,TEXT 116 D FIND^DIC(FILENUM,"","",FLAGS,NAME,"","","","","LIST","MSG") 117 S NFOUND=+$P(LIST("DILIST",0),U,1) 118 I NFOUND=0 Q 0 119 I NFOUND=1 Q LIST("DILIST",2,1) 120 ;Multiple entries with the same name found. 121 S FILENAME=$$GET1^DID(FILENUM,"","","NAME") 122 S TEXT(1)="Warning there are "_NFOUND_" "_FILENAME_" entries with the name "_NAME_"!" 123 S TEXT(2)="If this is used as a finding, and it is not resolved by FileMan during" 124 S TEXT(3)="installation, any component using this finding will not install." 125 D EN^DDIOL(.TEXT) 126 I $G(FLAG)="W" H 3 Q LIST("DILIST",2,1) 127 I NFOUND>1 S IEN=$$GETIEN^PXRMEXU0(NFOUND,.LIST) 128 Q IEN 129 ; 130 ;=============================================== 131 GETACT(CHOICES,DIR) ;Get the action 132 ;If CHOICES is empty the only action is skip. 133 I CHOICES="" Q "S" 134 N DIROUT,DIRUT,DTOUT,DUOUT,X,Y 135 S DIR(0)="S"_U 136 I CHOICES["C" S DIR(0)=DIR(0)_"C:Create a new entry by copying to a new name" 137 I CHOICES["D" S DIR(0)=DIR(0)_";D:Delete (from the reminder/dialog)" 138 I CHOICES["I" S DIR(0)=DIR(0)_";I:Install" 139 I CHOICES["M" S DIR(0)=DIR(0)_";M:Merge findings" 140 I CHOICES["O" S DIR(0)=DIR(0)_";O:Overwrite the current entry" 141 I CHOICES["P" S DIR(0)=DIR(0)_";P:Replace (in the reminder/dialog) with an existing entry" 142 I CHOICES["Q" S DIR(0)=DIR(0)_";Q:Quit the install" 143 I CHOICES["R" S DIR(0)=DIR(0)_";R:Restart" 144 I CHOICES["S" S DIR(0)=DIR(0)_";S:Skip, do not install this entry" 145 ;If this is being called during a KIDS install we need echoing on. 146 I $D(XPDNM) X ^%ZOSF("EON") 147 D ^DIR 148 I $D(XPDNM) X ^%ZOSF("EOFF") 149 I $D(DIROUT)!$D(DIRUT) S Y="S" 150 I $D(DTOUT)!($D(DUOUT)) S Y="S" 151 Q Y 152 ; 153 ;=============================================== 154 GETNAME(MIN,MAX) ;Get a name to use. 155 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y 156 S DIR(0)="FAOU"_U_MIN_":"_MAX 157 S DIR("A")="Input the new name: " 158 D ^DIR 159 I $D(DIROUT)!$D(DIRUT) Q "" 160 I $D(DTOUT)!$D(DUOUT) Q "" 161 Q Y 162 ; 163 ;=============================================== 164 GETUNAME(ATTR) ;Get a unique name to use, ATTR holds the attributes. 165 N IEN,NEWPT01,TEXT 166 GNEW S NEWPT01=$$GETNAME(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH")) 167 S IEN=+$$EXISTS(ATTR("FILE NUMBER"),NEWPT01) 168 I IEN>0 D G GNEW 169 . S TEXT=ATTR("FILE NAME")_" entry "_NEWPT01_" already exists, what do you want to do?" 170 . D EN^DDIOL(TEXT) 171 E S ATTR("NAME")=NEWPT01 172 Q NEWPT01 173 ; 174 ;=============================================== 175 HF(FDA,NAMECHG) ;Check the health factor to make sure a category does not 176 ;have a category. 177 N IENS 178 S IENS=$O(FDA(9999999.64,"")) 179 I IENS="" Q 180 I FDA(9999999.64,IENS,.1)="CATEGORY" K FDA(9999999.64,IENS,.03) 181 Q 182 ; 183 ;=============================================== 184 LABPANEL(IEN) ; 185 N NODE 186 S NODE=^LAB(60,IEN,0) 187 I $P(NODE,U,4)'["CH" Q 1 188 I $P(NODE,U,5)="" Q 0 189 Q 1 190 ; 191 ;=============================================== 192 REXISTS(NAME,DATEP) ;See if this Exchange File entry already exists. 193 N IEN,LUVALUE 194 S LUVALUE(1)=NAME 195 S LUVALUE(2)=DATEP 196 S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE) 197 Q IEN 198 ; 199 ;=============================================== 200 SAME(ATTR,TA,NAME) ;Check existing entry and entry in packed reminder 201 ;definition to see if they are identical. 202 ;Present version only works for computed finding routines, other 203 ;types of entries can be added later. 204 N SAME 205 I ATTR("FILE NAME")="COMPUTED FINDING ROUTINE" S SAME=$$SAME^PXRMEXCF(.ATTR,.TA,NAME) 206 E S SAME=1 207 Q SAME 208 ; 209 ;=============================================== 210 TERM(FDA,NAMECHG) ;Check the reminder term to make sure all the 211 ;findings exist. 212 N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,OFINDING,PT01 213 ;Search the finding multiple for replacements and missing findings. 214 D BLDALIST^PXRMVPTR(811.52,.01,.ALIST) 215 S IENS="" 216 F S IENS=$O(FDA(811.52,IENS)) Q:IENS="" D 217 . S (FINDING,OFINDING)=FDA(811.52,IENS,.01) 218 . S ABBR=$P(FINDING,".",1) 219 . S PT01=$P(FINDING,".",2) 220 . S FILENUM=$P(ALIST(ABBR),U,1) 221 . I $D(NAMECHG(FILENUM,PT01)) D 222 .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01) 223 .. S FDA(811.52,IENS,.01)=FINDING 224 . S IEN=+$$VFIND1(FINDING,.ALIST) 225 . I IEN>0 S FDA(811.52,IENS,.01)=ABBR_".`"_IEN 226 . I IEN=0 D 227 ..;Get replacement 228 .. N DIC,DUOUT,TEXT,X,Y 229 .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install." 230 .. D BMES^XPDUTL(TEXT) 231 .. S DIC=FILENUM 232 .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)" 233 .. S DIC(0)="AEMNQ" 234 .. S Y=-1 235 .. F Q:+Y'=-1 D 236 ...;If this is being called during a KIDS install we need echoing on. 237 ... I $D(XPDNM) X ^%ZOSF("EON") 238 ... D ^DIC 239 ... I $D(XPDNM) X ^%ZOSF("EOFF") 240 ... I $D(DUOUT) D 241 .... S Y="" 242 .... K FDA 243 .. I Y="" K FDA(811.52,IENS) 244 .. E D 245 ... S FINDING=ABBR_"."_$P(Y,U,2) 246 ... S FDA(811.52,IENS,.01)=FINDING 247 .;Save the finding information for the history. 248 . S ^TMP("PXRMEXIA",$J,"TRMF",$P(IENS,",",1),OFINDING)=FINDING 249 Q 250 ; 251 ;=============================================== 252 VFIND1(VPTR,ALIST) ;Given a variable pointer of the form ABBR.NAME 253 ;and ALIST which contains the link between abbreviations and files 254 ;return the IEN if it exists and 0 if no match if found. 255 N ABBR,IEN,FILENUM,PT01,RESULT 256 S IEN=0 257 S ABBR=$P(VPTR,".",1) 258 S PT01=$P(VPTR,".",2,99) 259 S FILENUM=$P(ALIST(ABBR),U,1) 260 S IEN=$$EXISTS(FILENUM,PT01) 261 Q IEN 262 ;
Note:
See TracChangeset
for help on using the changeset viewer.
