| [613] | 1 | PXRMUTIL ; SLC/PKR/PJH - Utility routines for use by PXRM. ;10/02/2007
|
|---|
| 2 | ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
|
|---|
| 3 | ;
|
|---|
| 4 | ;=================================
|
|---|
| 5 | ATTVALUE(STRING,ATTR,SEP,AVSEP) ;STRING contains a list of attribute value
|
|---|
| 6 | ;pairs. Each pair is separated by SEP and the attribute value pair
|
|---|
| 7 | ;is separated by AVSEP. Return the value for the attribute ATTR.
|
|---|
| 8 | N AVPAIR,IND,NUMAVP,VALUE
|
|---|
| 9 | S NUMAVP=$L(STRING,SEP)
|
|---|
| 10 | S VALUE=""
|
|---|
| 11 | F IND=1:1:NUMAVP Q:VALUE'="" D
|
|---|
| 12 | . S AVPAIR=$P(STRING,SEP,IND)
|
|---|
| 13 | . I AVPAIR[ATTR S VALUE=$P(AVPAIR,AVSEP,2)
|
|---|
| 14 | Q VALUE
|
|---|
| 15 | ;
|
|---|
| 16 | ;=================================
|
|---|
| 17 | ACOPY(REF,OUTPUT) ;Copy all the descendants of the array reference into a linear
|
|---|
| 18 | ;array. REF is the starting array reference, for example A or
|
|---|
| 19 | ;^TMP("PXRM",$J). OUTPUT is the linear array for the output. It
|
|---|
| 20 | ;should be in the form of a closed root, i.e., A() or ^TMP($J,).
|
|---|
| 21 | ;Note OUTPUT cannot be used as the name of the output array.
|
|---|
| 22 | N DONE,IND,LEN,NL,OROOT,OUT,PROOT,ROOT,START,TEMP
|
|---|
| 23 | I REF="" Q
|
|---|
| 24 | S NL=0
|
|---|
| 25 | S OROOT=$P(OUTPUT,")",1)
|
|---|
| 26 | S PROOT=$P(REF,")",1)
|
|---|
| 27 | ;Build the root so we can tell when we are done.
|
|---|
| 28 | S TEMP=$NA(@REF)
|
|---|
| 29 | S ROOT=$P(TEMP,")",1)
|
|---|
| 30 | S REF=$Q(@REF)
|
|---|
| 31 | I REF'[ROOT Q
|
|---|
| 32 | S DONE=0
|
|---|
| 33 | F Q:(REF="")!(DONE) D
|
|---|
| 34 | . S START=$F(REF,ROOT)
|
|---|
| 35 | . S LEN=$L(REF)
|
|---|
| 36 | . S IND=$E(REF,START,LEN)
|
|---|
| 37 | . S NL=NL+1
|
|---|
| 38 | . S OUT=OROOT_NL_")"
|
|---|
| 39 | . S @OUT=PROOT_IND_"="_@REF
|
|---|
| 40 | . S REF=$Q(@REF)
|
|---|
| 41 | . I REF'[ROOT S DONE=1
|
|---|
| 42 | Q
|
|---|
| 43 | ;
|
|---|
| 44 | ;=================================
|
|---|
| 45 | AWRITE(REF) ;Write all the descendants of the array reference.
|
|---|
| 46 | ;REF is the starting array reference, for example A or ^TMP("PXRM",$J).
|
|---|
| 47 | N DONE,IND,LEN,PROOT,ROOT,START,TEMP
|
|---|
| 48 | I REF="" Q
|
|---|
| 49 | S PROOT=$P(REF,")",1)
|
|---|
| 50 | ;Build the root so we can tell when we are done.
|
|---|
| 51 | S TEMP=$NA(@REF)
|
|---|
| 52 | S ROOT=$P(TEMP,")",1)
|
|---|
| 53 | S REF=$Q(@REF)
|
|---|
| 54 | I REF'[ROOT Q
|
|---|
| 55 | S DONE=0
|
|---|
| 56 | F Q:(REF="")!(DONE) D
|
|---|
| 57 | . S START=$F(REF,ROOT)
|
|---|
| 58 | . S LEN=$L(REF)
|
|---|
| 59 | . S IND=$E(REF,START,LEN)
|
|---|
| 60 | . W !,PROOT_IND,"=",@REF
|
|---|
| 61 | . S REF=$Q(@REF)
|
|---|
| 62 | . I REF'[ROOT S DONE=1
|
|---|
| 63 | Q
|
|---|
| 64 | ;
|
|---|
| 65 | ;=================================
|
|---|
| 66 | DIP(VAR,IEN,PXRMROOT,FLDS) ;Do general inquiry for IEN return formatted
|
|---|
| 67 | ;output in VAR. VAR can be either a local variable or a global.
|
|---|
| 68 | ;If it is a local it is indexed for the broker. If it is a global
|
|---|
| 69 | ;it should be passed in closed form i.e., ^TMP("PXRMTEST",$J).
|
|---|
| 70 | ;It will be returned formatted for ListMan i.e.,
|
|---|
| 71 | ;^TMP("PXRMTEST",$J,N,0).
|
|---|
| 72 | N %ZIS,ARRAY,BY,DC,DHD,DIC,DONE,FF,FILENAME,FILESPEC,FR,GBL,HFNAME
|
|---|
| 73 | N IND,IOP,L,NOW,PATH,SUCCESS,TO,UNIQN
|
|---|
| 74 | S BY="NUMBER",(FR,TO)=+$P(IEN,U,1),DHD="@@"
|
|---|
| 75 | ;Make sure the PXRM WORKSTATION device exists.
|
|---|
| 76 | D MKWSDEV^PXRMHOST
|
|---|
| 77 | ;Set up the output file before DIP is called.
|
|---|
| 78 | S PATH=$$PWD^%ZISH
|
|---|
| 79 | S NOW=$$NOW^XLFDT
|
|---|
| 80 | S NOW=$TR(NOW,".","")
|
|---|
| 81 | S UNIQN=$J_NOW
|
|---|
| 82 | S FILENAME="PXRMWSD"_UNIQN_".DAT"
|
|---|
| 83 | S HFNAME=PATH_FILENAME
|
|---|
| 84 | S IOP="PXRM WORKSTATION;80"
|
|---|
| 85 | S %ZIS("HFSMODE")="W"
|
|---|
| 86 | S %ZIS("HFSNAME")=HFNAME
|
|---|
| 87 | S L=0,DIC=PXRMROOT
|
|---|
| 88 | D EN1^DIP
|
|---|
| 89 | ;Move the host file into a global.
|
|---|
| 90 | S GBL="^TMP(""PXRMUTIL"",$J,1,0)"
|
|---|
| 91 | S GBL=$NA(@GBL)
|
|---|
| 92 | K ^TMP("PXRMUTIL",$J)
|
|---|
| 93 | S SUCCESS=$$FTG^%ZISH(PATH,FILENAME,GBL,3)
|
|---|
| 94 | ;Look for a form feed, remove it and all subsequent lines.
|
|---|
| 95 | S FF=$C(12)
|
|---|
| 96 | I $G(VAR)["^" D
|
|---|
| 97 | . S VAR=$NA(@VAR)
|
|---|
| 98 | . S VAR=$P(VAR,")",1)
|
|---|
| 99 | . S VAR=VAR_",IND,0)"
|
|---|
| 100 | . S (DONE,IND)=0
|
|---|
| 101 | . F Q:DONE S IND=$O(^TMP("PXRMUTIL",$J,IND)) Q:+IND=0 D
|
|---|
| 102 | .. I ^TMP("PXRMUTIL",$J,IND,0)=FF S DONE=1 Q
|
|---|
| 103 | .. S @VAR=^TMP("PXRMUTIL",$J,IND,0)
|
|---|
| 104 | E D
|
|---|
| 105 | . S (DONE,IND)=0
|
|---|
| 106 | . F Q:DONE S IND=$O(^TMP("PXRMUTIL",$J,IND)) Q:+IND=0 D
|
|---|
| 107 | .. S VAR(IND)=^TMP("PXRMUTIL",$J,IND,0)
|
|---|
| 108 | .. I VAR(IND)=FF K ARRAY(IND) S DONE=1
|
|---|
| 109 | K ^TMP("PXRMUTIL",$J)
|
|---|
| 110 | ;Delete the host file.
|
|---|
| 111 | S FILESPEC(FILENAME)=""
|
|---|
| 112 | S SUCCESS=$$DEL^%ZISH(PATH,$NA(FILESPEC))
|
|---|
| 113 | Q
|
|---|
| 114 | ;
|
|---|
| 115 | ;=================================
|
|---|
| 116 | FNFR(ROOT) ;Given the root of a file return the file number.
|
|---|
| 117 | Q +$P(@(ROOT_"0)"),U,2)
|
|---|
| 118 | ;
|
|---|
| 119 | ;=================================
|
|---|
| 120 | NTOAN(NUMBER) ;Given an integer N return an alphabetic string that can be
|
|---|
| 121 | ;used for sorting. This will be modulus 26. For example N=0 returns
|
|---|
| 122 | ;A, N=26 returns BA etc.
|
|---|
| 123 | N ALPH
|
|---|
| 124 | S ALPH(0)="A",ALPH(1)="B",ALPH(2)="C",ALPH(3)="D",ALPH(4)="E"
|
|---|
| 125 | S ALPH(5)="F",ALPH(6)="G",ALPH(7)="H",ALPH(8)="I",ALPH(9)="J"
|
|---|
| 126 | S ALPH(10)="K",ALPH(11)="L",ALPH(12)="M",ALPH(13)="N",ALPH(14)="O"
|
|---|
| 127 | S ALPH(15)="P",ALPH(16)="Q",ALPH(17)="R",ALPH(18)="S",ALPH(19)="T"
|
|---|
| 128 | S ALPH(20)="U",ALPH(21)="V",ALPH(22)="W",ALPH(23)="X",ALPH(24)="Y"
|
|---|
| 129 | S ALPH(25)="Z"
|
|---|
| 130 | ;
|
|---|
| 131 | N ANUM,DIGIT,NUM,P26,PC,PWR
|
|---|
| 132 | S ANUM="",NUM=NUMBER,PWR=0
|
|---|
| 133 | S P26(PWR)=1
|
|---|
| 134 | F PWR=1:1 S P26(PWR)=26*P26(PWR-1) I P26(PWR)>NUMBER Q
|
|---|
| 135 | S PWR=PWR-1
|
|---|
| 136 | F PC=PWR:-1:0 D
|
|---|
| 137 | . S DIGIT=NUM\P26(PC)
|
|---|
| 138 | . S ANUM=ANUM_ALPH(DIGIT)
|
|---|
| 139 | . S NUM=NUM-(DIGIT*P26(PC))
|
|---|
| 140 | Q ANUM
|
|---|
| 141 | ;
|
|---|
| 142 | ;=================================
|
|---|
| 143 | RMEHIST(FILENUM,IEN) ;Remove the edit history for a reminder file.
|
|---|
| 144 | I (FILENUM<800)!(FILENUM>811.9)!(FILENUM=811.8) Q
|
|---|
| 145 | N DA,DIK,GLOBAL,ROOT
|
|---|
| 146 | S GLOBAL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
|
|---|
| 147 | ;Edit History is stored in node 110 for all files.
|
|---|
| 148 | S DA(1)=IEN
|
|---|
| 149 | S DIK=GLOBAL_IEN_",110,"
|
|---|
| 150 | S ROOT=GLOBAL_IEN_",110,DA)"
|
|---|
| 151 | S DA=0
|
|---|
| 152 | F S DA=+$O(@ROOT) Q:DA=0 D ^DIK
|
|---|
| 153 | Q
|
|---|
| 154 | ;
|
|---|
| 155 | ;=================================
|
|---|
| 156 | SEHIST(FILENUM,ROOT,IEN) ;Set the edit date and edit by and prompt the
|
|---|
| 157 | ;user for the edit comment.
|
|---|
| 158 | N DIC,DIR,DWLW,DWPK,ENTRY,FDA,FDAIEN,IENS,IND,MSG,SFN,TARGET,X,Y
|
|---|
| 159 | K ^TMP("PXRMWP",$J)
|
|---|
| 160 | D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
|
|---|
| 161 | S SFN=+$G(TARGET("SPECIFIER"))
|
|---|
| 162 | I SFN=0 Q
|
|---|
| 163 | S ENTRY=ROOT_IEN_",110)"
|
|---|
| 164 | S IND=$O(@ENTRY@("B"),-1)
|
|---|
| 165 | S IND=IND+1
|
|---|
| 166 | S IENS="+"_IND_","_IEN_","
|
|---|
| 167 | S FDAIEN(IEN)=IEN
|
|---|
| 168 | S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
|
|---|
| 169 | S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
|
|---|
| 170 | ;Prompt the user for edit comments.
|
|---|
| 171 | S DIC="^TMP(""PXRMWP"",$J,"
|
|---|
| 172 | S DWLW=72
|
|---|
| 173 | S DWPK=1
|
|---|
| 174 | W !,"Input your edit comments."
|
|---|
| 175 | S DIR(0)="Y"_U_"AO"
|
|---|
| 176 | S DIR("A")="Edit"
|
|---|
| 177 | S DIR("B")="NO"
|
|---|
| 178 | D ^DIR
|
|---|
| 179 | I Y D
|
|---|
| 180 | . D EN^DIWE
|
|---|
| 181 | . K ^TMP("PXRMWP",$J,0)
|
|---|
| 182 | . I $D(^TMP("PXRMWP",$J)) S FDA(SFN,IENS,2)="^TMP(""PXRMWP"",$J)"
|
|---|
| 183 | D UPDATE^DIE("E","FDA","FDAIEN","MSG")
|
|---|
| 184 | I $D(MSG) D AWRITE^PXRMUTIL("MSG")
|
|---|
| 185 | K ^TMP("PXRMWP",$J)
|
|---|
| 186 | Q
|
|---|
| 187 | ;
|
|---|
| 188 | ;=================================
|
|---|
| 189 | SFRES(SDIR,NRES,FIEVAL) ;Save the finding result.
|
|---|
| 190 | I NRES=0 S FIEVAL=0 Q
|
|---|
| 191 | N DATE,IND,OA,SUB,TF
|
|---|
| 192 | F IND=1:1:NRES S OA(FIEVAL(IND,"DATE"),FIEVAL(IND),IND)=""
|
|---|
| 193 | ;If SDIR is positive get the oldest date otherwise get the most
|
|---|
| 194 | ;recent date.
|
|---|
| 195 | S DATE=$S(SDIR>0:$O(OA("")),1:$O(OA(""),-1))
|
|---|
| 196 | ;If there is a true finding on DATE get it.
|
|---|
| 197 | S TF=$O(OA(DATE,""),-1)
|
|---|
| 198 | S IND=$O(OA(DATE,TF,""))
|
|---|
| 199 | S FIEVAL=TF
|
|---|
| 200 | S SUB=""
|
|---|
| 201 | F S SUB=$O(FIEVAL(IND,SUB)) Q:SUB="" M FIEVAL(SUB)=FIEVAL(IND,SUB)
|
|---|
| 202 | Q
|
|---|
| 203 | ;
|
|---|
| 204 | ;=================================
|
|---|
| 205 | SSPAR(FIND0,NOCC,BDT,EDT) ;Set the finding search parameters.
|
|---|
| 206 | S BDT=$P(FIND0,U,8),EDT=$P(FIND0,U,11),NOCC=$P(FIND0,U,14)
|
|---|
| 207 | I +NOCC=0 S NOCC=1
|
|---|
| 208 | ;Convert the dates to FileMan dates.
|
|---|
| 209 | S BDT=$S(BDT="":0,BDT=0:0,1:$$CTFMD^PXRMDATE(BDT))
|
|---|
| 210 | I EDT="" S EDT="T"
|
|---|
| 211 | S EDT=$$CTFMD^PXRMDATE(EDT)
|
|---|
| 212 | ;If EDT does not contain a time set it to the end of the day.
|
|---|
| 213 | I EDT'["." S EDT=EDT_".235959"
|
|---|
| 214 | I $G(PXRMDDOC)'=1 Q
|
|---|
| 215 | S ^TMP("PXRMDDOC",$J,$P(FIND0,U,1,11))=BDT_U_EDT
|
|---|
| 216 | Q
|
|---|
| 217 | ;
|
|---|
| 218 | ;=================================
|
|---|
| 219 | STRREP(STRING,TS,RS) ;Replace every occurrence of the target string (TS)
|
|---|
| 220 | ;in STRING with the replacement string (RS).
|
|---|
| 221 | ;Example 9.19 (page 220) in "The Complete Mumps" by John Lewkowicz:
|
|---|
| 222 | ; F Q:STRING'[TS S STRING=$P(STRING,TS)_RS_$P(STRING,TS,2,999)
|
|---|
| 223 | ;fails if any portion of the target string is contained in the with
|
|---|
| 224 | ;string. Therefore a more elaborate version is required.
|
|---|
| 225 | ;
|
|---|
| 226 | N IND,NPCS,STR
|
|---|
| 227 | I STRING'[TS Q STRING
|
|---|
| 228 | ;Count the number of pieces using the target string as the delimiter.
|
|---|
| 229 | S NPCS=$L(STRING,TS)
|
|---|
| 230 | ;Extract the pieces and concatenate RS
|
|---|
| 231 | S STR=""
|
|---|
| 232 | F IND=1:1:NPCS-1 S STR=STR_$P(STRING,TS,IND)_RS
|
|---|
| 233 | S STR=STR_$P(STRING,TS,NPCS)
|
|---|
| 234 | Q STR
|
|---|
| 235 | ;
|
|---|
| 236 | ;=================================
|
|---|
| 237 | VEDIT(ROOT,IEN) ;This is used as a DIC("S") screen to select which entries
|
|---|
| 238 | ;a user can edit.
|
|---|
| 239 | N CLASS,ENTRY,VALID
|
|---|
| 240 | S ENTRY=ROOT_IEN_")"
|
|---|
| 241 | S CLASS=$P($G(@ENTRY@(100)),U,1)
|
|---|
| 242 | I CLASS="N" D
|
|---|
| 243 | . I ($G(PXRMINST)=1),(DUZ(0)="@") S VALID=1
|
|---|
| 244 | . E S VALID=0
|
|---|
| 245 | E S VALID=1
|
|---|
| 246 | Q VALID
|
|---|
| 247 | ;
|
|---|
