source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMUTIL.m@ 1450

Last change on this file since 1450 was 623, checked in by George Lilly, 15 years ago

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