ORCMEDT8 ;SLC/JM-QO, Generate quick order CRC ;Oct 20, 2021@13:26:11
;;3.0;ORDER ENTRY/RESULTS REPORTING;**245,243,280,405**;Dec 17, 1997;Build 211
Q
;
UPDQNAME(ORIEN) ; Rename personal quick order name if needed
N OLDNAME,NEWNAME,DA,DR,DIE,DIDEL
I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" Q
S OLDNAME=$P($G(^ORD(101.41,ORIEN,0)),U,1)
I $E($P(OLDNAME,U),1,6)'="ORWDQ " Q
S NEWNAME="ORWDQ "_$$CRC4QCK(ORIEN)
I OLDNAME'=NEWNAME D
. S NEWNAME=$$ENSURNEW(NEWNAME)
. S DA=ORIEN,DR=".01///"_NEWNAME,DIE="^ORD(101.41," D ^DIE
Q
;
ENSURNEW(NAME) ; Ensures the name is a new entry
N IDX,BASENAME,ABC,NEWNAME
S NEWNAME=NAME
S IDX=0,BASENAME=NEWNAME,ABC=97 ; Find an unused name
F S IDX=$O(^ORD(101.41,"B",NEWNAME,0)) Q:'IDX D
. S NEWNAME=BASENAME_$C(ABC) ; append letter 'a' - 'z'
. S ABC=ABC+1 I ABC>122 S BASENAME=BASENAME_"a",ABC=97
Q NEWNAME
RAWCRC(ORIEN) ; Get a raw CRC value to determine if a record has changed
N ORDATA,RESULT,ADDCRLF,LASTLINE,LASTIDX,OLDCRC
S (RESULT,OLDCRC)=""
I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G RWQ
I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G RWQ
D LOADRSP^ORWDX(.ORDATA,ORIEN)
D PARSE
RWQ Q RESULT
;
; The following code attemps to duplicate the CRC calculated by the Delphi code
; in CPRS for quick orders. It will not match all the time, since not all the
; data neded to make the determination is stored on the M side, but it does it's best.
;
CRC4QCK(ORIEN) ; Get CRC for a personal quick order
N ORDATA,DISPGRP,DEFDLG,FORMID,RESULT,FORMDATA,ADDCRLF
N LASTLINE,LASTIDX,OLDCRC,FORMINFO,IDINFO,NEXTFORM
S RESULT="",FORMID=0
; Must be personal quick order
I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G EXT
I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G EXT
S OLDCRC=$E($P($G(^ORD(101.41,ORIEN,0)),U,1),7,14)
F Q:(RESULT=OLDCRC)!(FORMID="") D
. K ORDATA D LOADRSP^ORWDX(.ORDATA,ORIEN)
. ; First pass don't use any form id - get baseline CRC
. I FORMID=1 D Q:FORMID=""
. . S FORMID=""
. . S DISPGRP=$P($G(^ORD(101.41,ORIEN,0)),U,5) I '+DISPGRP Q ; Must have a valid display group
. . S DEFDLG=$P($G(^ORD(100.98,DISPGRP,0)),U,4) I '+DEFDLG Q ; Display group must have a valid default dialog
. . D FORMID^ORWDXM(.FORMID,DEFDLG) I '+FORMID S FORMID="" Q ; Default dialog must have a valid windows form ID
. . I (FORMID=130)!(FORMID=140) D
. . . N NEWFORM D CHK94^ORWDPS1(.NEWFORM) I NEWFORM=1 S FORMID=135
. . D FORMINFO(.FORMINFO,.IDINFO,.NEXTFORM)
. I FORMID=0 S FORMID=1
. E D SORTDATA I FORMDATA="" S FORMID="" Q ; Updates FORMID
. D PARSE
EXT Q RESULT
;
PARSE ; Parse Data
N DATAIDX,IDX,LINE,CODE,CRCDATA,OUTPUT,DONE,ISMASTER,LASTMSTR,FIRST,P3,LK4SPACE
S DATAIDX="",(IDX,DONE,ISMASTER,LASTMSTR,LASTIDX)=0,LASTLINE=""
F D GETLINE Q:DONE D Q:DONE
. I ISMASTER D
. . S OUTPUT=+$P(LINE,U,1)_U_+$P(LINE,U,2)_U
. . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT
. . S FIRST=1,P3=$P(LINE,U,3)
. . I P3="COMMENT" S ADDCRLF=1,LK4SPACE=1
. . E D
. . . I P3="STATEMENTS" S ADDCRLF=1,LK4SPACE=0
. . . E S ADDCRLF=0,LK4SPACE=0
. . F D GETLINE Q:DONE!ISMASTER D
. . . I CODE="i" S IDX=IDX+1,CRCDATA(IDX)=LINE
. . . I CODE="t" D
. . . . I FIRST S FIRST=0,OUTPUT=LINE
. . . . E D
. . . . . I $L(LASTLINE)=0 S OUTPUT=$C(13)_$C(10)_LINE Q
. . . . . I LK4SPACE,$L(LASTLINE)>1,$E(LASTLINE,$L(LASTLINE))=" " S OUTPUT=""
. . . . . E D
. . . . . . I ADDCRLF S OUTPUT=$C(13)_$C(10) ; ,$L(LASTLINE)<65
. . . . . . E S OUTPUT=" "
. . . . . S OUTPUT=OUTPUT_LINE
. . . . S LASTLINE=LINE
. . . . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT
. . . . I ADDCRLF S LASTIDX=IDX
. . I ISMASTER,'DONE S LASTMSTR=1
S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA)
; Same data can generate 2 different CRCs - CRLF on end of comments are stripped
I OLDCRC'="",RESULT'=OLDCRC,LASTIDX>0 D
. S CRCDATA(LASTIDX)=CRCDATA(LASTIDX)_$C(13)_$C(10)
. S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA)
Q
;
SORTDATA ; Sorts data by fields according to FormID
N IN,OUT,LINE,DATA,ID,CODE,INDEX,END,IDX,RTN,SUBFORM,SUBFORM2,SUBIDX,NODE
S SUBFORM="",SUBFORM2=""
S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q
I $E(FORMDATA,1,2)'="00" S RTN="SUBID"_$E(FORMDATA,1,2) D @RTN S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q
S IN=0,OUT=0,END=1000000,IDX=0
F S IN=$O(ORDATA(IN)) Q:'+IN D
. S LINE=ORDATA(IN)
. I $E(LINE)="~" D
. . S IDX=1,ID=$P(LINE,U,3),CODE="."_IDINFO(ID)_".",NODE=$P(LINE,U,2)
. . S INDEX=$F(FORMDATA,CODE),SUBIDX=0
. . I INDEX=0,SUBFORM'="" D
. . . S INDEX=($F(FORMDATA,".ZZZ."))
. . . I INDEX>0 S SUBIDX=$F(SUBFORM,CODE) I SUBIDX<1 S INDEX=0
. . I INDEX=0,SUBFORM2'="" D
. . . S INDEX=($F(FORMDATA,".XXX."))
. . . I INDEX>0 S SUBIDX=$F(SUBFORM2,CODE) I SUBIDX<1 S INDEX=0
. . I INDEX=0 S OUT=END,END=END+1
. . E D
. . . I SUBIDX>0 D I 1
. . . . S OUT=(INDEX-4)*250
. . . . S SUBIDX=(SUBIDX-4)\4
. . . . S OUT=OUT+SUBIDX+(NODE*20)
. . . E S OUT=(INDEX-4)*250
. I IDX>0 D
. . S DATA(OUT,IDX)=LINE
. . S IDX=IDX+1
K ORDATA
S (IN,OUT,INDEX)=0
F S IN=$O(DATA(IN)) Q:'+IN D
. F S INDEX=$O(DATA(IN,INDEX)) Q:'+INDEX D
. . S OUT=OUT+1
. . S ORDATA(OUT)=DATA(IN,INDEX)
S FORMID=$G(NEXTFORM(FORMID))
Q
;
GETLINE ;
I LASTMSTR S LASTMSTR=0 Q
S DATAIDX=$O(ORDATA(DATAIDX))
S DONE=(DATAIDX="")
I 'DONE S CODE=$E(ORDATA(DATAIDX),1),LINE=$E(ORDATA(DATAIDX),2,9999),ISMASTER=(CODE="~")
Q
;
FORMINFO(FORMINFO,IDINFO,NEXTFORM) ; populates FORMINFO,IDINFO and NEXTFORM arrays
N IDX,LINE,CODE,RTN,NEXT
S IDX=1
F S LINE=$E($T(FORMTBL+IDX),21,999) Q:$L(LINE)<1 D
. S CODE=$E(LINE,1,3),NEXT=$E(LINE,5,7),LINE=$E(LINE,9,999)
. S FORMINFO(CODE)=LINE
. I NEXT'=" " S NEXTFORM(CODE)=NEXT
. S IDX=IDX+1
S IDX=1
F S LINE=$E($T(IDTABLE+IDX),4,999) Q:$L(LINE)<1 D
. S CODE=$E(LINE,1,3),LINE=$E(LINE,5,99)
. S IDINFO(LINE)=CODE,IDX=IDX+1
Q
;
HASCODE(CODE) ; scans data for code
N RESULT,IDX,LINE S IDX="",RESULT=0
F S IDX=$O(ORDATA(IDX)) Q:IDX="" D Q:IDX=""
. S LINE=ORDATA(IDX)
. I $E(LINE)="~" D
. . S LINE=$P(LINE,U,3)
. . I LINE=CODE S RESULT=1,IDX=""
Q RESULT
;
SUBID ; SubID codes are used to change the form ID depending on depending on data
; Data below is FormID;SubID.list of ID codes in order of use
; SubID's are used to change the FormID depending on data values.
Q
SUBID01 ; Generic Meds dialog
N INPT,COMPLEX
S INPT=$$HASCODE("NOW"),COMPLEX=$$HASCODE("DAYS")
I INPT D I 1
. I COMPLEX S FORMID="INX",SUBFORM=$G(FORMINFO("MDX"))
. E S FORMID="INP"
E I COMPLEX S FORMID="OPX",SUBFORM=$G(FORMINFO("MDX"))
Q
SUBID02 ; IV Meds
S SUBFORM=$G(FORMINFO("IVL"))
Q
SUBID03 ; Delphi code adds URGENCY prompt that does not exist in dialog on M side
I '$$HASCODE("URGENCY") D
. N X
. S X=$O(ORDATA(999999),-1)+1
. S ORDATA(X)="~0^1^URGENCY"
Q
SUBID04 ; Blood Bank will probably be wrong - quick orders not working in v26
S SUBFORM=$G(FORMINFO("BBK"))
S SUBFORM2=$G(FORMINFO("BBX"))
Q
SUBID05 ; Diet
I FORMID="117" S SUBFORM=$G(FORMINFO("DLN"))
I FORMID="TBF" S SUBFORM=$G(FORMINFO("TBL"))
Q
FORMTBL ; Form Table - Forms allowing personal quick orders, as of CPRS GUI v26 (OR*3*215)
;;Consult ;110;CS2;00.ORD.CLS.URG.PLA.MSC.COD.PRV.COM.ERD.
;; ;CS2; ;00.ORD.CLS.URG.PLA.MSC.COD.COM.PRV.ERD.
;;Procedure ;112;PR2;00.SER.ORD.CLS.URG.PLA.MSC.COD.PRV.COM.ERD.
;; ;PR2;PR3;00.SER.ORD.COM.CLS.URG.PLA.MSC.COD.PRV.ERD.
;; ;PR3; ;00.SER.ORD.CLS.URG.PLA.MSC.COD.COM.PRV.ERD.
;;Diet ;117;TBF;05.STT.STP.ZZZ.COM.DEL.CAN.
;; ;TBF;OPM;05.ZZZ.COM.CAN.
;; ;OPM; ;00.ORD.MEL.STT.STP.SCH.COM.DEL.
;; ;DLN; ;00.ORD.
;; ;TBL; ;00.ORD.STR.INS.
;;Lab ;120; ;00.ORD.SAM.SPE.URG.COM.COL.STT.SCH.DAY.
;;Blood Bank ;125;BB2;04.ZZZ.DTE.COL.URG.COM.STT.MSC.REA.YN0.XXX.LAB.
;; ;BB2; ;04.ZZZ.URG.COM.COL.DTE.MSC.REA.YN0.STT.XXX.
;; ;BBK; ;00.ORD.QTY.MDF.SPC.
;; ;BBX; ;00.RES.
;;Inpatient Meds ;130; ;00.ORD.DRG.INS.ROU.SCH.URG.COM.SCT.ADM
;;Generic Meds ;135; ;01.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG.IND.
;; ;INP; ;00.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.NOW.SIG.
;; ;OPX; ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG.TTR.
;; ;INX; ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.NOW.SIG.
;; ;MDX; ;00.INS.DOS.ROU.SCH.DAY.CNJ.
;;Outpatient Meds ;140; ;00.ORD.DRG.INS.MSC.ROU.SCH.QTY.REF.PCK.URG.COM.SC0.TTR.
;;Non-VA Meds ;145; ;03.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.STT.STA.NOW.SIG.
;;Radiology ;160; ;00.ORD.STT.URG.MOD.CLS.IML.PRG.YN0.PRE.COM.MDF.PRV.CON.RSH.LOC.
;;IV Meds ;180; ;02.ZZZ.RAT.URG.DAY.COM.SCH.TYP.ADM
;; ;IVL; ;00.ORD.VOL.ADD.STR.UNT.
;;
IDTABLE ; ID table - returns codes used in the form table IDINFO("LONGNAME")=SHORNAME
;;ADD;ADDITIVE
;;ADM:ADMIN
;;CAN;CANCEL
;;CLS;CLASS
;;COD;CODE
;;COL;COLLECT
;;COM;COMMENT
;;CNJ;CONJ
;;CON;CONTRACT
;;DTE;DATETIME
;;DAY;DAYS
;;DEL;DELIVERY
;;DOS;DOSE
;;DRG;DRUG
;;ERD;EARLIEST
;;IML;IMLOC
;;IND;INDICATION
;;INS;INSTR
;;ISO;ISOLATION
;;LAB;LAB
;;LOC;LOCATION
;;MEL;MEAL
;;MSC;MISC
;;MOD;MODE
;;MDF;MODIFIER
;;NAM;NAME
;;NOW;NOW
;;ORD;ORDERABLE
;;PI0;PI
;;PCK;PICKUP
;;PLA;PLACE
;;PRG;PREGNANT
;;PRE;PREOP
;;PRV;PROVIDER
;;QTY;QTY
;;RAT;RATE
;;REA;REASON
;;REF;REFILLS
;;RSH:RESEARCH
;;RES;RESULTS
;;ROU;ROUTE
;;SAM;SAMPLE
;;SC0;SC
;;SCH;SCHEDULE
;;SCT:SCHTYPE
;;SER;SERVICE
;;SIG;SIG
;;SPE;SPECIMEN
;;SPC;SPECSTS
;;STT;START
;;STA;STATEMENTS
;;STP;STOP
;;STR;STRENGTH
;;SUP;SUPPLY
;;TIM;TIME
;;TTR:TITR
;;TYP:TYPE
;;UNT;UNITS
;;URG;URGENCY
;;VIS;VISITSTR
;;VOL;VOLUME
;;XFU;XFUSION
;;YN0;YN
;;XXX;XXX
;;ZZZ;ZZZ
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCMEDT8 10015 printed Sep 02, 2024@19:13:55 Page 2
ORCMEDT8 ;SLC/JM-QO, Generate quick order CRC ;Oct 20, 2021@13:26:11
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**245,243,280,405**;Dec 17, 1997;Build 211
+2 QUIT
+3 ;
UPDQNAME(ORIEN) ; Rename personal quick order name if needed
+1 NEW OLDNAME,NEWNAME,DA,DR,DIE,DIDEL
+2 IF $PIECE($GET(^ORD(101.41,ORIEN,0)),U,4)'="Q"
QUIT
+3 SET OLDNAME=$PIECE($GET(^ORD(101.41,ORIEN,0)),U,1)
+4 IF $EXTRACT($PIECE(OLDNAME,U),1,6)'="ORWDQ "
QUIT
+5 SET NEWNAME="ORWDQ "_$$CRC4QCK(ORIEN)
+6 IF OLDNAME'=NEWNAME
Begin DoDot:1
+7 SET NEWNAME=$$ENSURNEW(NEWNAME)
+8 SET DA=ORIEN
SET DR=".01///"_NEWNAME
SET DIE="^ORD(101.41,"
DO ^DIE
End DoDot:1
+9 QUIT
+10 ;
ENSURNEW(NAME) ; Ensures the name is a new entry
+1 NEW IDX,BASENAME,ABC,NEWNAME
+2 SET NEWNAME=NAME
+3 ; Find an unused name
SET IDX=0
SET BASENAME=NEWNAME
SET ABC=97
+4 FOR
SET IDX=$ORDER(^ORD(101.41,"B",NEWNAME,0))
if 'IDX
QUIT
Begin DoDot:1
+5 ; append letter 'a' - 'z'
SET NEWNAME=BASENAME_$CHAR(ABC)
+6 SET ABC=ABC+1
IF ABC>122
SET BASENAME=BASENAME_"a"
SET ABC=97
End DoDot:1
+7 QUIT NEWNAME
RAWCRC(ORIEN) ; Get a raw CRC value to determine if a record has changed
+1 NEW ORDATA,RESULT,ADDCRLF,LASTLINE,LASTIDX,OLDCRC
+2 SET (RESULT,OLDCRC)=""
+3 IF $PIECE($GET(^ORD(101.41,ORIEN,0)),U,4)'="Q"
GOTO RWQ
+4 IF $EXTRACT($PIECE($GET(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ "
GOTO RWQ
+5 DO LOADRSP^ORWDX(.ORDATA,ORIEN)
+6 DO PARSE
RWQ QUIT RESULT
+1 ;
+2 ; The following code attemps to duplicate the CRC calculated by the Delphi code
+3 ; in CPRS for quick orders. It will not match all the time, since not all the
+4 ; data neded to make the determination is stored on the M side, but it does it's best.
+5 ;
CRC4QCK(ORIEN) ; Get CRC for a personal quick order
+1 NEW ORDATA,DISPGRP,DEFDLG,FORMID,RESULT,FORMDATA,ADDCRLF
+2 NEW LASTLINE,LASTIDX,OLDCRC,FORMINFO,IDINFO,NEXTFORM
+3 SET RESULT=""
SET FORMID=0
+4 ; Must be personal quick order
+5 IF $PIECE($GET(^ORD(101.41,ORIEN,0)),U,4)'="Q"
GOTO EXT
+6 IF $EXTRACT($PIECE($GET(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ "
GOTO EXT
+7 SET OLDCRC=$EXTRACT($PIECE($GET(^ORD(101.41,ORIEN,0)),U,1),7,14)
+8 FOR
if (RESULT=OLDCRC)!(FORMID="")
QUIT
Begin DoDot:1
+9 KILL ORDATA
DO LOADRSP^ORWDX(.ORDATA,ORIEN)
+10 ; First pass don't use any form id - get baseline CRC
+11 IF FORMID=1
Begin DoDot:2
+12 SET FORMID=""
+13 ; Must have a valid display group
SET DISPGRP=$PIECE($GET(^ORD(101.41,ORIEN,0)),U,5)
IF '+DISPGRP
QUIT
+14 ; Display group must have a valid default dialog
SET DEFDLG=$PIECE($GET(^ORD(100.98,DISPGRP,0)),U,4)
IF '+DEFDLG
QUIT
+15 ; Default dialog must have a valid windows form ID
DO FORMID^ORWDXM(.FORMID,DEFDLG)
IF '+FORMID
SET FORMID=""
QUIT
+16 IF (FORMID=130)!(FORMID=140)
Begin DoDot:3
+17 NEW NEWFORM
DO CHK94^ORWDPS1(.NEWFORM)
IF NEWFORM=1
SET FORMID=135
End DoDot:3
+18 DO FORMINFO(.FORMINFO,.IDINFO,.NEXTFORM)
End DoDot:2
if FORMID=""
QUIT
+19 IF FORMID=0
SET FORMID=1
+20 ; Updates FORMID
IF '$TEST
DO SORTDATA
IF FORMDATA=""
SET FORMID=""
QUIT
+21 DO PARSE
End DoDot:1
EXT QUIT RESULT
+1 ;
PARSE ; Parse Data
+1 NEW DATAIDX,IDX,LINE,CODE,CRCDATA,OUTPUT,DONE,ISMASTER,LASTMSTR,FIRST,P3,LK4SPACE
+2 SET DATAIDX=""
SET (IDX,DONE,ISMASTER,LASTMSTR,LASTIDX)=0
SET LASTLINE=""
+3 FOR
DO GETLINE
if DONE
QUIT
Begin DoDot:1
+4 IF ISMASTER
Begin DoDot:2
+5 SET OUTPUT=+$PIECE(LINE,U,1)_U_+$PIECE(LINE,U,2)_U
+6 SET IDX=IDX+1
SET CRCDATA(IDX)=OUTPUT
+7 SET FIRST=1
SET P3=$PIECE(LINE,U,3)
+8 IF P3="COMMENT"
SET ADDCRLF=1
SET LK4SPACE=1
+9 IF '$TEST
Begin DoDot:3
+10 IF P3="STATEMENTS"
SET ADDCRLF=1
SET LK4SPACE=0
+11 IF '$TEST
SET ADDCRLF=0
SET LK4SPACE=0
End DoDot:3
+12 FOR
DO GETLINE
if DONE!ISMASTER
QUIT
Begin DoDot:3
+13 IF CODE="i"
SET IDX=IDX+1
SET CRCDATA(IDX)=LINE
+14 IF CODE="t"
Begin DoDot:4
+15 IF FIRST
SET FIRST=0
SET OUTPUT=LINE
+16 IF '$TEST
Begin DoDot:5
+17 IF $LENGTH(LASTLINE)=0
SET OUTPUT=$CHAR(13)_$CHAR(10)_LINE
QUIT
+18 IF LK4SPACE
IF $LENGTH(LASTLINE)>1
IF $EXTRACT(LASTLINE,$LENGTH(LASTLINE))=" "
SET OUTPUT=""
+19 IF '$TEST
Begin DoDot:6
+20 ; ,$L(LASTLINE)<65
IF ADDCRLF
SET OUTPUT=$CHAR(13)_$CHAR(10)
+21 IF '$TEST
SET OUTPUT=" "
End DoDot:6
+22 SET OUTPUT=OUTPUT_LINE
End DoDot:5
+23 SET LASTLINE=LINE
+24 SET IDX=IDX+1
SET CRCDATA(IDX)=OUTPUT
+25 IF ADDCRLF
SET LASTIDX=IDX
End DoDot:4
End DoDot:3
+26 IF ISMASTER
IF 'DONE
SET LASTMSTR=1
End DoDot:2
End DoDot:1
if DONE
QUIT
+27 SET RESULT=$$CRC4ARRY^ORCRC(.CRCDATA)
+28 ; Same data can generate 2 different CRCs - CRLF on end of comments are stripped
+29 IF OLDCRC'=""
IF RESULT'=OLDCRC
IF LASTIDX>0
Begin DoDot:1
+30 SET CRCDATA(LASTIDX)=CRCDATA(LASTIDX)_$CHAR(13)_$CHAR(10)
+31 SET RESULT=$$CRC4ARRY^ORCRC(.CRCDATA)
End DoDot:1
+32 QUIT
+33 ;
SORTDATA ; Sorts data by fields according to FormID
+1 NEW IN,OUT,LINE,DATA,ID,CODE,INDEX,END,IDX,RTN,SUBFORM,SUBFORM2,SUBIDX,NODE
+2 SET SUBFORM=""
SET SUBFORM2=""
+3 SET FORMDATA=$GET(FORMINFO(FORMID))
IF FORMDATA=""
QUIT
+4 IF $EXTRACT(FORMDATA,1,2)'="00"
SET RTN="SUBID"_$EXTRACT(FORMDATA,1,2)
DO @RTN
SET FORMDATA=$GET(FORMINFO(FORMID))
IF FORMDATA=""
QUIT
+5 SET IN=0
SET OUT=0
SET END=1000000
SET IDX=0
+6 FOR
SET IN=$ORDER(ORDATA(IN))
if '+IN
QUIT
Begin DoDot:1
+7 SET LINE=ORDATA(IN)
+8 IF $EXTRACT(LINE)="~"
Begin DoDot:2
+9 SET IDX=1
SET ID=$PIECE(LINE,U,3)
SET CODE="."_IDINFO(ID)_"."
SET NODE=$PIECE(LINE,U,2)
+10 SET INDEX=$FIND(FORMDATA,CODE)
SET SUBIDX=0
+11 IF INDEX=0
IF SUBFORM'=""
Begin DoDot:3
+12 SET INDEX=($FIND(FORMDATA,".ZZZ."))
+13 IF INDEX>0
SET SUBIDX=$FIND(SUBFORM,CODE)
IF SUBIDX<1
SET INDEX=0
End DoDot:3
+14 IF INDEX=0
IF SUBFORM2'=""
Begin DoDot:3
+15 SET INDEX=($FIND(FORMDATA,".XXX."))
+16 IF INDEX>0
SET SUBIDX=$FIND(SUBFORM2,CODE)
IF SUBIDX<1
SET INDEX=0
End DoDot:3
+17 IF INDEX=0
SET OUT=END
SET END=END+1
+18 IF '$TEST
Begin DoDot:3
+19 IF SUBIDX>0
Begin DoDot:4
+20 SET OUT=(INDEX-4)*250
+21 SET SUBIDX=(SUBIDX-4)\4
+22 SET OUT=OUT+SUBIDX+(NODE*20)
End DoDot:4
IF 1
+23 IF '$TEST
SET OUT=(INDEX-4)*250
End DoDot:3
End DoDot:2
+24 IF IDX>0
Begin DoDot:2
+25 SET DATA(OUT,IDX)=LINE
+26 SET IDX=IDX+1
End DoDot:2
End DoDot:1
+27 KILL ORDATA
+28 SET (IN,OUT,INDEX)=0
+29 FOR
SET IN=$ORDER(DATA(IN))
if '+IN
QUIT
Begin DoDot:1
+30 FOR
SET INDEX=$ORDER(DATA(IN,INDEX))
if '+INDEX
QUIT
Begin DoDot:2
+31 SET OUT=OUT+1
+32 SET ORDATA(OUT)=DATA(IN,INDEX)
End DoDot:2
End DoDot:1
+33 SET FORMID=$GET(NEXTFORM(FORMID))
+34 QUIT
+35 ;
GETLINE ;
+1 IF LASTMSTR
SET LASTMSTR=0
QUIT
+2 SET DATAIDX=$ORDER(ORDATA(DATAIDX))
+3 SET DONE=(DATAIDX="")
+4 IF 'DONE
SET CODE=$EXTRACT(ORDATA(DATAIDX),1)
SET LINE=$EXTRACT(ORDATA(DATAIDX),2,9999)
SET ISMASTER=(CODE="~")
+5 QUIT
+6 ;
FORMINFO(FORMINFO,IDINFO,NEXTFORM) ; populates FORMINFO,IDINFO and NEXTFORM arrays
+1 NEW IDX,LINE,CODE,RTN,NEXT
+2 SET IDX=1
+3 FOR
SET LINE=$EXTRACT($TEXT(FORMTBL+IDX),21,999)
if $LENGTH(LINE)<1
QUIT
Begin DoDot:1
+4 SET CODE=$EXTRACT(LINE,1,3)
SET NEXT=$EXTRACT(LINE,5,7)
SET LINE=$EXTRACT(LINE,9,999)
+5 SET FORMINFO(CODE)=LINE
+6 IF NEXT'=" "
SET NEXTFORM(CODE)=NEXT
+7 SET IDX=IDX+1
End DoDot:1
+8 SET IDX=1
+9 FOR
SET LINE=$EXTRACT($TEXT(IDTABLE+IDX),4,999)
if $LENGTH(LINE)<1
QUIT
Begin DoDot:1
+10 SET CODE=$EXTRACT(LINE,1,3)
SET LINE=$EXTRACT(LINE,5,99)
+11 SET IDINFO(LINE)=CODE
SET IDX=IDX+1
End DoDot:1
+12 QUIT
+13 ;
HASCODE(CODE) ; scans data for code
+1 NEW RESULT,IDX,LINE
SET IDX=""
SET RESULT=0
+2 FOR
SET IDX=$ORDER(ORDATA(IDX))
if IDX=""
QUIT
Begin DoDot:1
+3 SET LINE=ORDATA(IDX)
+4 IF $EXTRACT(LINE)="~"
Begin DoDot:2
+5 SET LINE=$PIECE(LINE,U,3)
+6 IF LINE=CODE
SET RESULT=1
SET IDX=""
End DoDot:2
End DoDot:1
if IDX=""
QUIT
+7 QUIT RESULT
+8 ;
SUBID ; SubID codes are used to change the form ID depending on depending on data
+1 ; Data below is FormID;SubID.list of ID codes in order of use
+2 ; SubID's are used to change the FormID depending on data values.
+3 QUIT
SUBID01 ; Generic Meds dialog
+1 NEW INPT,COMPLEX
+2 SET INPT=$$HASCODE("NOW")
SET COMPLEX=$$HASCODE("DAYS")
+3 IF INPT
Begin DoDot:1
+4 IF COMPLEX
SET FORMID="INX"
SET SUBFORM=$GET(FORMINFO("MDX"))
+5 IF '$TEST
SET FORMID="INP"
End DoDot:1
IF 1
+6 IF '$TEST
IF COMPLEX
SET FORMID="OPX"
SET SUBFORM=$GET(FORMINFO("MDX"))
+7 QUIT
SUBID02 ; IV Meds
+1 SET SUBFORM=$GET(FORMINFO("IVL"))
+2 QUIT
SUBID03 ; Delphi code adds URGENCY prompt that does not exist in dialog on M side
+1 IF '$$HASCODE("URGENCY")
Begin DoDot:1
+2 NEW X
+3 SET X=$ORDER(ORDATA(999999),-1)+1
+4 SET ORDATA(X)="~0^1^URGENCY"
End DoDot:1
+5 QUIT
SUBID04 ; Blood Bank will probably be wrong - quick orders not working in v26
+1 SET SUBFORM=$GET(FORMINFO("BBK"))
+2 SET SUBFORM2=$GET(FORMINFO("BBX"))
+3 QUIT
SUBID05 ; Diet
+1 IF FORMID="117"
SET SUBFORM=$GET(FORMINFO("DLN"))
+2 IF FORMID="TBF"
SET SUBFORM=$GET(FORMINFO("TBL"))
+3 QUIT
FORMTBL ; Form Table - Forms allowing personal quick orders, as of CPRS GUI v26 (OR*3*215)
+1 ;;Consult ;110;CS2;00.ORD.CLS.URG.PLA.MSC.COD.PRV.COM.ERD.
+2 ;; ;CS2; ;00.ORD.CLS.URG.PLA.MSC.COD.COM.PRV.ERD.
+3 ;;Procedure ;112;PR2;00.SER.ORD.CLS.URG.PLA.MSC.COD.PRV.COM.ERD.
+4 ;; ;PR2;PR3;00.SER.ORD.COM.CLS.URG.PLA.MSC.COD.PRV.ERD.
+5 ;; ;PR3; ;00.SER.ORD.CLS.URG.PLA.MSC.COD.COM.PRV.ERD.
+6 ;;Diet ;117;TBF;05.STT.STP.ZZZ.COM.DEL.CAN.
+7 ;; ;TBF;OPM;05.ZZZ.COM.CAN.
+8 ;; ;OPM; ;00.ORD.MEL.STT.STP.SCH.COM.DEL.
+9 ;; ;DLN; ;00.ORD.
+10 ;; ;TBL; ;00.ORD.STR.INS.
+11 ;;Lab ;120; ;00.ORD.SAM.SPE.URG.COM.COL.STT.SCH.DAY.
+12 ;;Blood Bank ;125;BB2;04.ZZZ.DTE.COL.URG.COM.STT.MSC.REA.YN0.XXX.LAB.
+13 ;; ;BB2; ;04.ZZZ.URG.COM.COL.DTE.MSC.REA.YN0.STT.XXX.
+14 ;; ;BBK; ;00.ORD.QTY.MDF.SPC.
+15 ;; ;BBX; ;00.RES.
+16 ;;Inpatient Meds ;130; ;00.ORD.DRG.INS.ROU.SCH.URG.COM.SCT.ADM
+17 ;;Generic Meds ;135; ;01.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG.IND.
+18 ;; ;INP; ;00.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.NOW.SIG.
+19 ;; ;OPX; ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG.TTR.
+20 ;; ;INX; ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.NOW.SIG.
+21 ;; ;MDX; ;00.INS.DOS.ROU.SCH.DAY.CNJ.
+22 ;;Outpatient Meds ;140; ;00.ORD.DRG.INS.MSC.ROU.SCH.QTY.REF.PCK.URG.COM.SC0.TTR.
+23 ;;Non-VA Meds ;145; ;03.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.STT.STA.NOW.SIG.
+24 ;;Radiology ;160; ;00.ORD.STT.URG.MOD.CLS.IML.PRG.YN0.PRE.COM.MDF.PRV.CON.RSH.LOC.
+25 ;;IV Meds ;180; ;02.ZZZ.RAT.URG.DAY.COM.SCH.TYP.ADM
+26 ;; ;IVL; ;00.ORD.VOL.ADD.STR.UNT.
+27 ;;
IDTABLE ; ID table - returns codes used in the form table IDINFO("LONGNAME")=SHORNAME
+1 ;;ADD;ADDITIVE
+2 ;;ADM:ADMIN
+3 ;;CAN;CANCEL
+4 ;;CLS;CLASS
+5 ;;COD;CODE
+6 ;;COL;COLLECT
+7 ;;COM;COMMENT
+8 ;;CNJ;CONJ
+9 ;;CON;CONTRACT
+10 ;;DTE;DATETIME
+11 ;;DAY;DAYS
+12 ;;DEL;DELIVERY
+13 ;;DOS;DOSE
+14 ;;DRG;DRUG
+15 ;;ERD;EARLIEST
+16 ;;IML;IMLOC
+17 ;;IND;INDICATION
+18 ;;INS;INSTR
+19 ;;ISO;ISOLATION
+20 ;;LAB;LAB
+21 ;;LOC;LOCATION
+22 ;;MEL;MEAL
+23 ;;MSC;MISC
+24 ;;MOD;MODE
+25 ;;MDF;MODIFIER
+26 ;;NAM;NAME
+27 ;;NOW;NOW
+28 ;;ORD;ORDERABLE
+29 ;;PI0;PI
+30 ;;PCK;PICKUP
+31 ;;PLA;PLACE
+32 ;;PRG;PREGNANT
+33 ;;PRE;PREOP
+34 ;;PRV;PROVIDER
+35 ;;QTY;QTY
+36 ;;RAT;RATE
+37 ;;REA;REASON
+38 ;;REF;REFILLS
+39 ;;RSH:RESEARCH
+40 ;;RES;RESULTS
+41 ;;ROU;ROUTE
+42 ;;SAM;SAMPLE
+43 ;;SC0;SC
+44 ;;SCH;SCHEDULE
+45 ;;SCT:SCHTYPE
+46 ;;SER;SERVICE
+47 ;;SIG;SIG
+48 ;;SPE;SPECIMEN
+49 ;;SPC;SPECSTS
+50 ;;STT;START
+51 ;;STA;STATEMENTS
+52 ;;STP;STOP
+53 ;;STR;STRENGTH
+54 ;;SUP;SUPPLY
+55 ;;TIM;TIME
+56 ;;TTR:TITR
+57 ;;TYP:TYPE
+58 ;;UNT;UNITS
+59 ;;URG;URGENCY
+60 ;;VIS;VISITSTR
+61 ;;VOL;VOLUME
+62 ;;XFU;XFUSION
+63 ;;YN0;YN
+64 ;;XXX;XXX
+65 ;;ZZZ;ZZZ
+66 ;;
