- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT8.m
r613 r623 1 ORCMEDT8 ;SLC/JM-QO, Generate quick order CRC ;10/18/07 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**245,243**;Dec 17, 1997;Build 242 3 Q 4 ; 5 UPDQNAME(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 ; 16 ENSURNEW(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 24 RAWCRC(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 31 RWQ 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 ; 37 CRC4QCK(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 59 EXT Q RESULT 60 ; 61 PARSE ; 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 ; 95 SORTDATA ; 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 ; 131 GETLINE ; 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 ; 138 FORMINFO(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 ; 152 HASCODE(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 ; 161 SUBID ; 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 165 SUBID01 ; 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 173 SUBID02 ; IV Meds 174 S SUBFORM=$G(FORMINFO("IVL")) 175 Q 176 SUBID03 ; 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 182 SUBID04 ; 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 186 SUBID05 ; Diet 187 I FORMID="117" S SUBFORM=$G(FORMINFO("DLN")) 188 I FORMID="TBF" S SUBFORM=$G(FORMINFO("TBL")) 189 Q 190 FORMTBL ; 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.LAB. 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.SCT.ADM 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.TYP.ADM 216 ;; ;IVL; ;00.ORD.VOL.ADD.STR.UNT. 217 ;; 218 IDTABLE ; ID table - returns codes used in the form table IDINFO("LONGNAME")=SHORNAME 219 ;;ADD;ADDITIVE 220 ;;ADM:ADMIN 221 ;;CAN;CANCEL 222 ;;CLS;CLASS 223 ;;COD;CODE 224 ;;COL;COLLECT 225 ;;COM;COMMENT 226 ;;CNJ;CONJ 227 ;;CON;CONTRACT 228 ;;DTE;DATETIME 229 ;;DAY;DAYS 230 ;;DEL;DELIVERY 231 ;;DOS;DOSE 232 ;;DRG;DRUG 233 ;;IML;IMLOC 234 ;;INS;INSTR 235 ;;ISO;ISOLATION 236 ;;LAB;LAB 237 ;;LOC;LOCATION 238 ;;MEL;MEAL 239 ;;MSC;MISC 240 ;;MOD;MODE 241 ;;MDF;MODIFIER 242 ;;NAM;NAME 243 ;;NOW;NOW 244 ;;ORD;ORDERABLE 245 ;;PI0;PI 246 ;;PCK;PICKUP 247 ;;PLA;PLACE 248 ;;PRG;PREGNANT 249 ;;PRE;PREOP 250 ;;PRV;PROVIDER 251 ;;QTY;QTY 252 ;;RAT;RATE 253 ;;REA;REASON 254 ;;REF;REFILLS 255 ;;RSH:RESEARCH 256 ;;RES;RESULTS 257 ;;ROU;ROUTE 258 ;;SAM;SAMPLE 259 ;;SC0;SC 260 ;;SCH;SCHEDULE 261 ;;SCT:SCHTYPE 262 ;;SER;SERVICE 263 ;;SIG;SIG 264 ;;SPE;SPECIMEN 265 ;;SPC;SPECSTS 266 ;;STT;START 267 ;;STA;STATEMENTS 268 ;;STP;STOP 269 ;;STR;STRENGTH 270 ;;SUP;SUPPLY 271 ;;TIM;TIME 272 ;;TYP:TYPE 273 ;;UNT;UNITS 274 ;;URG;URGENCY 275 ;;VIS;VISITSTR 276 ;;VOL;VOLUME 277 ;;XFU;XFUSION 278 ;;YN0;YN 279 ;;XXX;XXX 280 ;;ZZZ;ZZZ 281 ;; 1 ORCMEDT8 ;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 ; 5 UPDQNAME(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 ; 16 ENSURNEW(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 24 RAWCRC(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 31 RWQ 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 ; 37 CRC4QCK(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 59 EXT Q RESULT 60 ; 61 PARSE ; 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 ; 95 SORTDATA ; 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 ; 131 GETLINE ; 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 ; 138 FORMINFO(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 ; 152 HASCODE(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 ; 161 SUBID ; 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 165 SUBID01 ; 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 173 SUBID02 ; IV Meds 174 S SUBFORM=$G(FORMINFO("IVL")) 175 Q 176 SUBID03 ; 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 182 SUBID04 ; 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 186 SUBID05 ; Diet 187 I FORMID="117" S SUBFORM=$G(FORMINFO("DLN")) 188 I FORMID="TBF" S SUBFORM=$G(FORMINFO("TBL")) 189 Q 190 FORMTBL ; 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 ;; 218 IDTABLE ; 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 TracChangeset
for help on using the changeset viewer.
