- 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 Mar 13, 2025@21:33:39 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 ;;
