source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT8.m@ 1607

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1ORCMEDT8 ;SLC/JM-QO, Generate quick order CRC ;3/3/06
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**245**;Dec 17, 1997;Build 2
3 Q
4 ;
5UPDQNAME(ORIEN) ; Rename personal quick order name if needed
6 N OLDNAME,NEWNAME,DA,DR,DIE,DIDEL
7 I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" Q
8 S OLDNAME=$P($G(^ORD(101.41,ORIEN,0)),U,1)
9 I $E($P(OLDNAME,U),1,6)'="ORWDQ " Q
10 S NEWNAME="ORWDQ "_$$CRC4QCK(ORIEN)
11 I OLDNAME'=NEWNAME D
12 . S NEWNAME=$$ENSURNEW(NEWNAME)
13 . S DA=ORIEN,DR=".01///"_NEWNAME,DIE="^ORD(101.41," D ^DIE
14 Q
15 ;
16ENSURNEW(NAME) ; Ensures the name is a new entry
17 N IDX,BASENAME,ABC,NEWNAME
18 S NEWNAME=NAME
19 S IDX=0,BASENAME=NEWNAME,ABC=97 ; Find an unused name
20 F S IDX=$O(^ORD(101.41,"B",NEWNAME,0)) Q:'IDX D
21 . S NEWNAME=BASENAME_$C(ABC) ; append letter 'a' - 'z'
22 . S ABC=ABC+1 I ABC>122 S BASENAME=BASENAME_"a",ABC=97
23 Q NEWNAME
24RAWCRC(ORIEN) ; Get a raw CRC value to determine if a record has changed
25 N ORDATA,RESULT,ADDCRLF,LASTLINE,LASTIDX,OLDCRC
26 S (RESULT,OLDCRC)=""
27 I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G RWQ
28 I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G RWQ
29 D LOADRSP^ORWDX(.ORDATA,ORIEN)
30 D PARSE
31RWQ Q RESULT
32 ;
33 ; The following code attemps to duplicate the CRC calculated by the Delphi code
34 ; in CPRS for quick orders. It will not match all the time, since not all the
35 ; data neded to make the determination is stored on the M side, but it does it's best.
36 ;
37CRC4QCK(ORIEN) ; Get CRC for a personal quick order
38 N ORDATA,DISPGRP,DEFDLG,FORMID,RESULT,FORMDATA,ADDCRLF
39 N LASTLINE,LASTIDX,OLDCRC,FORMINFO,IDINFO,NEXTFORM
40 S RESULT="",FORMID=0
41 ; Must be personal quick order
42 I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G EXT
43 I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G EXT
44 S OLDCRC=$E($P($G(^ORD(101.41,ORIEN,0)),U,1),7,14)
45 F Q:(RESULT=OLDCRC)!(FORMID="") D
46 . K ORDATA D LOADRSP^ORWDX(.ORDATA,ORIEN)
47 . ; First pass don't use any form id - get baseline CRC
48 . I FORMID=1 D Q:FORMID=""
49 . . S FORMID=""
50 . . S DISPGRP=$P($G(^ORD(101.41,ORIEN,0)),U,5) I '+DISPGRP Q ; Must have a valid display group
51 . . S DEFDLG=$P($G(^ORD(100.98,DISPGRP,0)),U,4) I '+DEFDLG Q ; Display group must have a valid default dialog
52 . . D FORMID^ORWDXM(.FORMID,DEFDLG) I '+FORMID S FORMID="" Q ; Default dialog must have a valid windows form ID
53 . . I (FORMID=130)!(FORMID=140) D
54 . . . N NEWFORM D CHK94^ORWDPS1(.NEWFORM) I NEWFORM=1 S FORMID=135
55 . . D FORMINFO(.FORMINFO,.IDINFO,.NEXTFORM)
56 . I FORMID=0 S FORMID=1
57 . E D SORTDATA I FORMDATA="" S FORMID="" Q ; Updates FORMID
58 . D PARSE
59EXT Q RESULT
60 ;
61PARSE ; Parse Data
62 N DATAIDX,IDX,LINE,CODE,CRCDATA,OUTPUT,DONE,ISMASTER,LASTMSTR,FIRST,P3,LK4SPACE
63 S DATAIDX="",(IDX,DONE,ISMASTER,LASTMSTR,LASTIDX)=0,LASTLINE=""
64 F D GETLINE Q:DONE D Q:DONE
65 . I ISMASTER D
66 . . S OUTPUT=+$P(LINE,U,1)_U_+$P(LINE,U,2)_U
67 . . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT
68 . . S FIRST=1,P3=$P(LINE,U,3)
69 . . I P3="COMMENT" S ADDCRLF=1,LK4SPACE=1
70 . . E D
71 . . . I P3="STATEMENTS" S ADDCRLF=1,LK4SPACE=0
72 . . . E S ADDCRLF=0,LK4SPACE=0
73 . . F D GETLINE Q:DONE!ISMASTER D
74 . . . I CODE="i" S IDX=IDX+1,CRCDATA(IDX)=LINE
75 . . . I CODE="t" D
76 . . . . I FIRST S FIRST=0,OUTPUT=LINE
77 . . . . E D
78 . . . . . I $L(LASTLINE)=0 S OUTPUT=$C(13)_$C(10)_LINE Q
79 . . . . . I LK4SPACE,$L(LASTLINE)>1,$E(LASTLINE,$L(LASTLINE))=" " S OUTPUT=""
80 . . . . . E D
81 . . . . . . I ADDCRLF S OUTPUT=$C(13)_$C(10) ; ,$L(LASTLINE)<65
82 . . . . . . E S OUTPUT=" "
83 . . . . . S OUTPUT=OUTPUT_LINE
84 . . . . S LASTLINE=LINE
85 . . . . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT
86 . . . . I ADDCRLF S LASTIDX=IDX
87 . . I ISMASTER,'DONE S LASTMSTR=1
88 S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA)
89 ; Same data can generate 2 different CRCs - CRLF on end of comments are stripped
90 I OLDCRC'="",RESULT'=OLDCRC,LASTIDX>0 D
91 . S CRCDATA(LASTIDX)=CRCDATA(LASTIDX)_$C(13)_$C(10)
92 . S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA)
93 Q
94 ;
95SORTDATA ; Sorts data by fields according to FormID
96 N IN,OUT,LINE,DATA,ID,CODE,INDEX,END,IDX,RTN,SUBFORM,SUBFORM2,SUBIDX,NODE
97 S SUBFORM="",SUBFORM2=""
98 S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q
99 I $E(FORMDATA,1,2)'="00" S RTN="SUBID"_$E(FORMDATA,1,2) D @RTN S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q
100 S IN=0,OUT=0,END=1000000,IDX=0
101 F S IN=$O(ORDATA(IN)) Q:'+IN D
102 . S LINE=ORDATA(IN)
103 . I $E(LINE)="~" D
104 . . S IDX=1,ID=$P(LINE,U,3),CODE="."_IDINFO(ID)_".",NODE=$P(LINE,U,2)
105 . . S INDEX=$F(FORMDATA,CODE),SUBIDX=0
106 . . I INDEX=0,SUBFORM'="" D
107 . . . S INDEX=($F(FORMDATA,".ZZZ."))
108 . . . I INDEX>0 S SUBIDX=$F(SUBFORM,CODE) I SUBIDX<1 S INDEX=0
109 . . I INDEX=0,SUBFORM2'="" D
110 . . . S INDEX=($F(FORMDATA,".XXX."))
111 . . . I INDEX>0 S SUBIDX=$F(SUBFORM2,CODE) I SUBIDX<1 S INDEX=0
112 . . I INDEX=0 S OUT=END,END=END+1
113 . . E D
114 . . . I SUBIDX>0 D I 1
115 . . . . S OUT=(INDEX-4)*250
116 . . . . S SUBIDX=(SUBIDX-4)\4
117 . . . . S OUT=OUT+SUBIDX+(NODE*20)
118 . . . E S OUT=(INDEX-4)*250
119 . I IDX>0 D
120 . . S DATA(OUT,IDX)=LINE
121 . . S IDX=IDX+1
122 K ORDATA
123 S (IN,OUT,INDEX)=0
124 F S IN=$O(DATA(IN)) Q:'+IN D
125 . F S INDEX=$O(DATA(IN,INDEX)) Q:'+INDEX D
126 . . S OUT=OUT+1
127 . . S ORDATA(OUT)=DATA(IN,INDEX)
128 S FORMID=$G(NEXTFORM(FORMID))
129 Q
130 ;
131GETLINE ;
132 I LASTMSTR S LASTMSTR=0 Q
133 S DATAIDX=$O(ORDATA(DATAIDX))
134 S DONE=(DATAIDX="")
135 I 'DONE S CODE=$E(ORDATA(DATAIDX),1),LINE=$E(ORDATA(DATAIDX),2,9999),ISMASTER=(CODE="~")
136 Q
137 ;
138FORMINFO(FORMINFO,IDINFO,NEXTFORM) ; populates FORMINFO,IDINFO and NEXTFORM arrays
139 N IDX,LINE,CODE,RTN,NEXT
140 S IDX=1
141 F S LINE=$E($T(FORMTBL+IDX),21,999) Q:$L(LINE)<1 D
142 . S CODE=$E(LINE,1,3),NEXT=$E(LINE,5,7),LINE=$E(LINE,9,999)
143 . S FORMINFO(CODE)=LINE
144 . I NEXT'=" " S NEXTFORM(CODE)=NEXT
145 . S IDX=IDX+1
146 S IDX=1
147 F S LINE=$E($T(IDTABLE+IDX),4,999) Q:$L(LINE)<1 D
148 . S CODE=$E(LINE,1,3),LINE=$E(LINE,5,99)
149 . S IDINFO(LINE)=CODE,IDX=IDX+1
150 Q
151 ;
152HASCODE(CODE) ; scans data for code
153 N RESULT,IDX,LINE S IDX="",RESULT=0
154 F S IDX=$O(ORDATA(IDX)) Q:IDX="" D Q:IDX=""
155 . S LINE=ORDATA(IDX)
156 . I $E(LINE)="~" D
157 . . S LINE=$P(LINE,U,3)
158 . . I LINE=CODE S RESULT=1,IDX=""
159 Q RESULT
160 ;
161SUBID ; SubID codes are used to change the form ID depending on depending on data
162 ; Data below is FormID;SubID.list of ID codes in order of use
163 ; SubID's are used to change the FormID depending on data values.
164 Q
165SUBID01 ; Generic Meds dialog
166 N INPT,COMPLEX
167 S INPT=$$HASCODE("NOW"),COMPLEX=$$HASCODE("DAYS")
168 I INPT D I 1
169 . I COMPLEX S FORMID="INX",SUBFORM=$G(FORMINFO("MDX"))
170 . E S FORMID="INP"
171 E I COMPLEX S FORMID="OPX",SUBFORM=$G(FORMINFO("MDX"))
172 Q
173SUBID02 ; IV Meds
174 S SUBFORM=$G(FORMINFO("IVL"))
175 Q
176SUBID03 ; Delphi code adds URGENCY prompt that does not exist in dialog on M side
177 I '$$HASCODE("URGENCY") D
178 . N X
179 . S X=$O(ORDATA(999999),-1)+1
180 . S ORDATA(X)="~0^1^URGENCY"
181 Q
182SUBID04 ; Blood Bank will probably be wrong - quick orders not working in v26
183 S SUBFORM=$G(FORMINFO("BBK"))
184 S SUBFORM2=$G(FORMINFO("BBX"))
185 Q
186SUBID05 ; Diet
187 I FORMID="117" S SUBFORM=$G(FORMINFO("DLN"))
188 I FORMID="TBF" S SUBFORM=$G(FORMINFO("TBL"))
189 Q
190FORMTBL ; Form Table - Forms allowing personal quick orders, as of CPRS GUI v26 (OR*3*215)
191 ;;Consult ;110;CS2;00.ORD.CLS.URG.PLA.MSC.COD.PRV.COM.
192 ;; ;CS2; ;00.ORD.CLS.URG.PLA.MSC.COD.COM.PRV.
193 ;;Procedure ;112;PR2;00.SER.ORD.CLS.URG.PLA.MSC.COD.PRV.COM.
194 ;; ;PR2;PR3;00.SER.ORD.COM.CLS.URG.PLA.MSC.COD.PRV.
195 ;; ;PR3; ;00.SER.ORD.CLS.URG.PLA.MSC.COD.COM.PRV.
196 ;;Diet ;117;TBF;05.STT.STP.ZZZ.COM.DEL.CAN.
197 ;; ;TBF;OPM;05.ZZZ.COM.CAN.
198 ;; ;OPM; ;00.ORD.MEL.STT.STP.SCH.COM.DEL.
199 ;; ;DLN; ;00.ORD.
200 ;; ;TBL; ;00.ORD.STR.INS.
201 ;;Lab ;120; ;00.ORD.SAM.SPE.URG.COM.COL.STT.SCH.DAY.
202 ;;Blood Bank ;125;BB2;04.ZZZ.DTE.COL.URG.COM.STT.MSC.REA.YN0.XXX.
203 ;; ;BB2; ;04.ZZZ.URG.COM.COL.DTE.MSC.REA.YN0.STT.XXX.
204 ;; ;BBK; ;00.ORD.QTY.MDF.SPC.
205 ;; ;BBX; ;00.RES.
206 ;;Inpatient Meds ;130; ;00.ORD.DRG.INS.ROU.SCH.URG.COM.
207 ;;Generic Meds ;135; ;01.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG.
208 ;; ;INP; ;00.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.NOW.SIG.
209 ;; ;OPX; ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG.
210 ;; ;INX; ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.NOW.SIG.
211 ;; ;MDX; ;00.INS.DOS.ROU.SCH.DAY.CNJ.
212 ;;Outpatient Meds ;140; ;00.ORD.DRG.INS.MSC.ROU.SCH.QTY.REF.PCK.URG.COM.SC0.
213 ;;Non-VA Meds ;145; ;03.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.STT.STA.NOW.SIG.
214 ;;Radiology ;160; ;00.ORD.STT.URG.MOD.CLS.IML.PRG.YN0.PRE.COM.MDF.PRV.CON.RSH.LOC.
215 ;;IV Meds ;180; ;02.ZZZ.RAT.URG.DAY.COM.SCH.
216 ;; ;IVL; ;00.ORD.VOL.ADD.STR.UNT.
217 ;;
218IDTABLE ; ID table - returns codes used in the form table IDINFO("LONGNAME")=SHORNAME
219 ;;ADD;ADDITIVE
220 ;;CAN;CANCEL
221 ;;CLS;CLASS
222 ;;COD;CODE
223 ;;COL;COLLECT
224 ;;COM;COMMENT
225 ;;CNJ;CONJ
226 ;;CON;CONTRACT
227 ;;DTE;DATETIME
228 ;;DAY;DAYS
229 ;;DEL;DELIVERY
230 ;;DOS;DOSE
231 ;;DRG;DRUG
232 ;;IML;IMLOC
233 ;;INS;INSTR
234 ;;ISO;ISOLATION
235 ;;LOC;LOCATION
236 ;;MEL;MEAL
237 ;;MSC;MISC
238 ;;MOD;MODE
239 ;;MDF;MODIFIER
240 ;;NAM;NAME
241 ;;NOW;NOW
242 ;;ORD;ORDERABLE
243 ;;PI0;PI
244 ;;PCK;PICKUP
245 ;;PLA;PLACE
246 ;;PRG;PREGNANT
247 ;;PRE;PREOP
248 ;;PRV;PROVIDER
249 ;;QTY;QTY
250 ;;RAT;RATE
251 ;;REA;REASON
252 ;;REF;REFILLS
253 ;;RSH:RESEARCH
254 ;;RES;RESULTS
255 ;;ROU;ROUTE
256 ;;SAM;SAMPLE
257 ;;SC0;SC
258 ;;SCH;SCHEDULE
259 ;;SER;SERVICE
260 ;;SIG;SIG
261 ;;SPE;SPECIMEN
262 ;;SPC;SPECSTS
263 ;;STT;START
264 ;;STA;STATEMENTS
265 ;;STP;STOP
266 ;;STR;STRENGTH
267 ;;SUP;SUPPLY
268 ;;TIM;TIME
269 ;;UNT;UNITS
270 ;;URG;URGENCY
271 ;;VIS;VISITSTR
272 ;;VOL;VOLUME
273 ;;XFU;XFUSION
274 ;;YN0;YN
275 ;;XXX;XXX
276 ;;ZZZ;ZZZ
277 ;;
Note: See TracBrowser for help on using the repository browser.