PXRMEXLB ;SLC/PJH - Reminder Dialog Exchange. ;06/27/2013
;;2.0;CLINICAL REMINDERS;**6,12,26**;Feb 04, 2005;Build 404
;
;=====================================================================
;Build the DLOC array.
BDLOC(IEN,IND120) ;
N DDATA,DNAME,JND
S JND=0
F S JND=$O(^PXD(811.8,IEN,120,IND120,1,JND)) Q:JND="" D
.S DDATA=$G(^PXD(811.8,IEN,120,IND120,1,JND,0)) Q:DDATA=""
.S DNAME=$P(DDATA,U,1)
.;Save start and end in 100 node and 120 node IND and JND.
.S ^TMP("PXRMEXTMP",$J,"DLOC",DNAME)=$P(DDATA,U,2,3)_U_IND120_U_JND
Q
;
;Build list of dialog components
;-------------------------------
DBUILD(IEN,IND120,JND120) ;
N CNT,DARRAY,DATA,DDATA,DDLG,DEND,DIALNAM,DLOC,DMAP,DNAME,DNODE,DSEQ
N DSTRT,DSUB,FDATA,FILE,FILENAM,FILENUM,FNAME,IND,INDICES,JND,LINE
N REPARR,REPCNT,RESGRP,TEMPRESL,VERSN
K ^TMP("PXRMEXTMP",$J,"DMAP")
S LINE=^PXD(811.8,IEN,100,3,0)
S VERSN=$$GETTAGV^PXRMEXU3(LINE,"<PACKAGE_VERSION>")
S DDATA=$G(^PXD(811.8,IEN,120,IND120,1,JND120,0)) Q:DDATA=""
S ^TMP("PXRMEXTMP",$J,"PXRMDNAME")=$P(DDATA,U,1)
S DIALNAM=$P(DDATA,U,1)
S DSUB=$P(DDATA,U,2)+2
I $P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3)["100~NATIONAL" S ^TMP("PXRMEXTMP",$J,"PXRMDNAT")=""
I '$D(^TMP("PXRMEXTMP",$J,"DLOC")) D BDLOC(IEN,IND120)
S (JND,REPCNT)=0
;Scan the dialog components in 120 and save the name and type.
F S JND=$O(^PXD(811.8,IEN,120,IND120,1,JND)) Q:JND'>0!(JND>JND120) D
.S DDATA=$G(^PXD(811.8,IEN,120,IND120,1,JND,0)) Q:DDATA=""
.S (DDLG,DNAME)=$P(DDATA,U,1)
.S DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3),DSUB=DSTRT+2
.;Extract dialog type and text and findings from exchange file
.D DPARSE(IND120,JND,DNAME,DSTRT,DEND,.RESGRP,.TEMPRSEL)
.;Scan dialog components in 120 and save dialog links
.F S DSUB=$O(^PXD(811.8,IEN,100,DSUB)) Q:DSUB>DEND D
..S LINE=$G(^PXD(811.8,IEN,100,DSUB,0))
.. S INDICES=$P(LINE,"~",1)
.. S DATA=$P(LINE,"~",2)
.. S FILE=$P(INDICES,";",1)
.. S FIELD=$P(INDICES,";",3)
.. I (FILE'=801.412)&(FILE'=801.41121)&(FIELD'=118) Q
..;Handle dialogs with replacement dialogs
..I FIELD=118 D
...S DNAME=DATA Q:DNAME=""
...S DLOC=^TMP("PXRMEXTMP",$J,"DLOC",DNAME)
...S REPCNT=REPCNT+1 D
....I +$P(VERSN,"P",2)>11 S ^TMP("PXRMEXTMP",$J,"DREPL",DIALNAM,REPCNT,DDLG)=DNAME_U_DLOC
....I +$P(VERSN,"P",2)<12 S REPARR(REPCNT,DDLG)=DNAME_U_DLOC
..I FIELD'=.01 Q
..S DSEQ=DATA Q:DSEQ=""
..I FILE="801.41121" D Q
...S DNAME=DATA Q:DNAME=""
...;Quit if DLOC for the item is not defined. This should fix a problem
...;pre-patch 12 entries not containing national prompts.
...I +$P(VERSN,"P",2)<12,'$D(^TMP("PXRMEXTMP",$J,"DLOC",DNAME)) Q
...S DLOC=^TMP("PXRMEXTMP",$J,"DLOC",DNAME)
...S CNT=0
...I $D(^TMP("PXRMEXTMP",$J,"DMAP",DDLG))>0 S CNT=$O(^TMP("PXRMEXTMP",$J,"DMAP",DDLG,""),-1)
...S ^TMP("PXRMEXTMP",$J,"DMAP",DDLG,CNT+1)=DNAME
..S LINE=$G(^PXD(811.8,IEN,100,DSUB+1,0))
..I ($P(LINE,";")'="801.412") Q
.. S INDICES=$P(LINE,"~",1)
.. I $P(INDICES,";",3)'=2 Q
.. S DATA=$P(LINE,"~",2)
.. S DNAME=DATA Q:DNAME=""
..;Quit if DLOC for the item is not defined. This should fix a problem
..;pre-patch 12 entries not containing national prompts.
..I +$P(VERSN,"P",2)<12,'$D(^TMP("PXRMEXTMP",$J,"DLOC",DNAME)) Q
..S DLOC=^TMP("PXRMEXTMP",$J,"DLOC",DNAME)
..S ^TMP("PXRMEXTMP",$J,"DMAP",DDLG,DSEQ)=DNAME
;
I $D(REPARR)>0 D
.N CNT,DLG,REPCNT
.S CNT="",REPCNT=0
.F S CNT=$O(REPARR(CNT)) Q:CNT="" D
..S REPCNT=REPCNT+1,DLG=$O(REPARR(CNT,""))
..S ^TMP("PXRMEXTMP",$J,"DREPL",DIALNAM,REPCNT,DLG)=REPARR(CNT,DLG)
;
;Build index of dialog findings by name
S IND=0
F S IND=$O(^PXD(811.8,IEN,120,IND)) Q:'IND D
.S FDATA=$G(^PXD(811.8,IEN,120,IND,0)) Q:FDATA=""
.S FILENAM=$P(FDATA,U),FILENUM=$P(FDATA,U,2) Q:FILENAM="" Q:'FILENUM
.;Ignore reminder dialogs
.I FILENAM="REMINDER DIALOG" Q
.;Ignore reminder terms
.I FILENAM="REMINDER TERM" Q
.;Strip off trailing S in finding file name
.I $E(FILENAM,$L(FILENAM))="S" S $E(FILENAM,$L(FILENAM))=""
.S JND=0
.F S JND=$O(^PXD(811.8,IEN,120,IND,1,JND)) Q:'JND D
..S FNAME=$P($G(^PXD(811.8,IEN,120,IND,1,JND,0)),U) Q:FNAME=""
..;Save entry
..S ^TMP("PXRMEXFND",$J,FNAME)=FILENUM_U_FILENAM_U_IND
I $D(TEMPRESL)>0 D
.S DDLG="" F S DDLG=$O(TEMPRESL(DDLG)) Q:DDLG="" D
..S DSEQ=$O(^TMP("PXRMEXTMP",$J,"DMAP",DDLG,""),-1)
..S ^TMP("PXRMEXTMP",$J,"DMAP",DDLG,DSEQ+1)=TEMPRESL(DDLG)_U_RESGRP(TEMPRESL(DDLG))
Q
;
;---------------------------------------
;Scan exchange file to get dialog fields
;---------------------------------------
DPARSE(IND120,JND120,DNAME,DSTRT,DEND,RESGRP,TEMPRESL) ;
N DARRAY,DCNT,DDATA,DFIND,DFIAD,DFNAM,DFNUM,DFQUIT,DLCT,DLINES
N DSTRING,DSUB,DTEXT,DTXT,DTYP,RESNAME
;
;Find where all the field numbers are kept
S DSUB=DSTRT-1,DSTRING=";.01;4;5;15;24;25;55;"
F S DSUB=$O(^PXD(811.8,IEN,100,DSUB)) Q:'DSUB D Q:DSUB>DEND
.S DDATA=$G(^PXD(811.8,IEN,100,DSUB,0)) Q:DDATA=""
.I $P(DDATA,";")'=801.41 Q
.S DFNUM=$P(DDATA,";",3),DFNUM=$P(DFNUM,"~") Q:DFNUM=""
.I DSTRING[(";"_DFNUM_";") S DARRAY(DFNUM)=DSUB
.I $P(DDATA,";")="801.41121" S DARRAY(55)=DSUB
;
;Determine dialog component type
S DSUB=DARRAY(4) Q:'DSUB
S DTYP=$P($G(^PXD(811.8,IEN,100,DSUB,0)),"~",2)
I DTYP'["result" S:DTYP[" " DTYP=$P(DTYP," ",2) S:DTYP="value" DTYP="forced"
;
;Initialise text and finding fields
S DTXT="*NONE*",DFIND=""
;Get text appropriate for the type of component
I ((DTYP="element")!(DTYP="group"))&(DTYP'["result") D
.;Search for WP text
.S DSUB=$G(DARRAY(25)) D:DSUB
..S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT=""
..;Get the line count
..S DLINES=$P(DTEXT,"~",3),DCNT=0
..;Get the wp text lines
..F DLCT=DSUB+1:1:DSUB+DLINES D
...S DTEXT=$G(^PXD(811.8,IEN,100,DLCT,0))
...S DCNT=DCNT+1,DTXT(DCNT)=DTEXT
...;Check for embedded TIU templates
...D DTIU(DNAME,DTEXT)
..;Reformat text to 50 characters
..D DWP(1,50,DCNT,.DTXT)
..;Search for Result Group/Element
..S DSUB=$G(DARRAY(55)) I DSUB>0 D
...S RESNAME=$P($P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3),"~",2)
...S TEMPRESL(DNAME)=RESNAME
.;Search for finding item
.S DSUB=$G(DARRAY(15)) D:DSUB
..S DFIND=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DFIND=""
..;Finding name
..S DFIND=$P(DFIND,"~",2) Q:DFIND=""
..I $P(DFIND,".")="ICD9" S DFIND=$P(DFIND," ")
.;
.;Search for additional finding - start after WP text
.S DSUB=+$G(DARRAY(25)) D:DSUB
..S DCNT=0,DFQUIT=0
..F DLCT=DSUB+1+DLINES:1 D Q:DFQUIT Q:DLCT>DEND
...S DTEXT=$G(^PXD(811.8,IEN,100,DLCT,0))
...;Ignore line if this is not an additional finding
...I $P(DTEXT,";")'=801.4118 S:$P(DTEXT,";")>801.4118 DFQUIT=1 Q
...S DFNAM=$P(DTEXT,"~",2) Q:DFNAM=""
...I $P(DFNAM,".")="ICD9" S DFNAM=$P(DFNAM," ")
...S DCNT=DCNT+1,DFIAD(DCNT)=DFNAM
;
I DTYP["result" D
.S DSUB=$G(DARRAY(.01)) Q:'DSUB
.S DDATA=^PXD(811.8,IEN,100,DSUB,0) Q:DDATA=""
.S DTXT=$P(DDATA,"~",2)
.S RESGRP(DNAME)=DSTRT_U_DEND_U_IND120_U_JND120
;
I DTYP="prompt" D
.;search for prompt caption
.S DSUB=$G(DARRAY(24)) Q:'DSUB
.S DDATA=^PXD(811.8,IEN,100,DSUB,0) Q:DDATA=""
.S DTXT="Prompt caption: "_$P(DDATA,"~",2)
;
I DTYP="group" D
.;search for group caption
.S DSUB=$G(DARRAY(5)) Q:'DSUB
.S DDATA=^PXD(811.8,IEN,100,DSUB,0) Q:DDATA=""
.S DTXT="Group caption: "_$P(DDATA,"~",2)
;
;Save dialog type
I DTYP["result" S DTYP=$$STRREP^PXRMUTIL(DTYP,"result ","rs.")
S ^TMP("PXRMEXTMP",$J,"DTYP",DNAME)=DTYP
;Save dialog component text (first line only)
I ($G(DTXT)'=""),(DTXT'=DNAME) S ^TMP("PXRMEXTMP",$J,"DTXT",DNAME)=DTXT
;
;Save main finding
I DFIND]"" S ^TMP("PXRMEXTMP",$J,"DFND",DNAME,1)=$P(DFIND,".",2,99)
;Save additional findings
S DSUB=0
F S DSUB=$O(DFIAD(DSUB)) Q:'DSUB S ^TMP("PXRMEXTMP",$J,"DFND",DNAME,DSUB+1)=$P(DFIAD(DSUB),".",2,99)
;
;Save additional WP text lines
S DSUB=0
F S DSUB=$O(DTXT(DSUB)) Q:'DSUB S ^TMP("PXRMEXTMP",$J,"DTXT",DNAME,DSUB)=DTXT(DSUB)
Q
;
;Extract any TIU templates
;-------------------------
DTIU(DNAME,TEXT) ;
N IC,TCNT,TLIST,TNAM
;Templates are in format {FLD:fldname}
S TCNT=0 D TIUXTR^PXRMEXU1("{FLD:","}",TEXT,.TLIST,.TCNT) Q:'TCNT
;
F IC=1:1:TCNT D
.S TNAM=$G(TLIST(TCNT)) Q:TNAM=""
.S ^TMP("PXRMEXTMP",$J,"DTIU",DNAME,TNAM)=""
Q
;
;Process WP fields
;-----------------
DWP(LM,RM,NIN,TEXT) ;
N NOUT,TEXTOUT
D FORMAT^PXRMTEXT(LM,RM,NIN,.TEXT,.NOUT,.TEXTOUT)
K TEXT
M TEXT=TEXTOUT
Q
;
;-----------------
FINDSTRT(IEN,IND120,END) ;
I END=1 Q 0
N START,TEMP,ISSEL
S START=0,TEMP=0
F S END=$O(^PXD(811.8,IEN,120,IND120,END),-1) Q:END'>0!(START>0) D
.S ISSEL=$P(^PXD(811.8,IEN,120,IND120,END,0),U,7)
.I ISSEL=0 S TEMP=END Q
.S START=TEMP
Q START
;
PXRMEXLB ;SLC/PJH - Reminder Dialog Exchange. ;06/27/2013
+1 ;;2.0;CLINICAL REMINDERS;**6,12,26**;Feb 04, 2005;Build 404
+2 ;
+3 ;=====================================================================
+4 ;Build the DLOC array.
BDLOC(IEN,IND120) ;
+1 NEW DDATA,DNAME,JND
+2 SET JND=0
+3 FOR
SET JND=$ORDER(^PXD(811.8,IEN,120,IND120,1,JND))
IF JND=""
QUIT
Begin DoDot:1
+4 SET DDATA=$GET(^PXD(811.8,IEN,120,IND120,1,JND,0))
IF DDATA=""
QUIT
+5 SET DNAME=$PIECE(DDATA,U,1)
+6 ;Save start and end in 100 node and 120 node IND and JND.
+7 SET ^TMP("PXRMEXTMP",$JOB,"DLOC",DNAME)=$PIECE(DDATA,U,2,3)_U_IND120_U_JND
End DoDot:1
+8 QUIT
+9 ;
+10 ;Build list of dialog components
+11 ;-------------------------------
DBUILD(IEN,IND120,JND120) ;
+1 NEW CNT,DARRAY,DATA,DDATA,DDLG,DEND,DIALNAM,DLOC,DMAP,DNAME,DNODE,DSEQ
+2 NEW DSTRT,DSUB,FDATA,FILE,FILENAM,FILENUM,FNAME,IND,INDICES,JND,LINE
+3 NEW REPARR,REPCNT,RESGRP,TEMPRESL,VERSN
+4 KILL ^TMP("PXRMEXTMP",$JOB,"DMAP")
+5 SET LINE=^PXD(811.8,IEN,100,3,0)
+6 SET VERSN=$$GETTAGV^PXRMEXU3(LINE,"<PACKAGE_VERSION>")
+7 SET DDATA=$GET(^PXD(811.8,IEN,120,IND120,1,JND120,0))
IF DDATA=""
QUIT
+8 SET ^TMP("PXRMEXTMP",$JOB,"PXRMDNAME")=$PIECE(DDATA,U,1)
+9 SET DIALNAM=$PIECE(DDATA,U,1)
+10 SET DSUB=$PIECE(DDATA,U,2)+2
+11 IF $PIECE($GET(^PXD(811.8,IEN,100,DSUB,0)),";",3)["100~NATIONAL"
SET ^TMP("PXRMEXTMP",$JOB,"PXRMDNAT")=""
+12 IF '$DATA(^TMP("PXRMEXTMP",$JOB,"DLOC"))
DO BDLOC(IEN,IND120)
+13 SET (JND,REPCNT)=0
+14 ;Scan the dialog components in 120 and save the name and type.
+15 FOR
SET JND=$ORDER(^PXD(811.8,IEN,120,IND120,1,JND))
IF JND'>0!(JND>JND120)
QUIT
Begin DoDot:1
+16 SET DDATA=$GET(^PXD(811.8,IEN,120,IND120,1,JND,0))
IF DDATA=""
QUIT
+17 SET (DDLG,DNAME)=$PIECE(DDATA,U,1)
+18 SET DSTRT=$PIECE(DDATA,U,2)
SET DEND=$PIECE(DDATA,U,3)
SET DSUB=DSTRT+2
+19 ;Extract dialog type and text and findings from exchange file
+20 DO DPARSE(IND120,JND,DNAME,DSTRT,DEND,.RESGRP,.TEMPRSEL)
+21 ;Scan dialog components in 120 and save dialog links
+22 FOR
SET DSUB=$ORDER(^PXD(811.8,IEN,100,DSUB))
IF DSUB>DEND
QUIT
Begin DoDot:2
+23 SET LINE=$GET(^PXD(811.8,IEN,100,DSUB,0))
+24 SET INDICES=$PIECE(LINE,"~",1)
+25 SET DATA=$PIECE(LINE,"~",2)
+26 SET FILE=$PIECE(INDICES,";",1)
+27 SET FIELD=$PIECE(INDICES,";",3)
+28 IF (FILE'=801.412)&(FILE'=801.41121)&(FIELD'=118)
QUIT
+29 ;Handle dialogs with replacement dialogs
+30 IF FIELD=118
Begin DoDot:3
+31 SET DNAME=DATA
IF DNAME=""
QUIT
+32 SET DLOC=^TMP("PXRMEXTMP",$JOB,"DLOC",DNAME)
+33 SET REPCNT=REPCNT+1
Begin DoDot:4
+34 IF +$PIECE(VERSN,"P",2)>11
SET ^TMP("PXRMEXTMP",$JOB,"DREPL",DIALNAM,REPCNT,DDLG)=DNAME_U_DLOC
+35 IF +$PIECE(VERSN,"P",2)<12
SET REPARR(REPCNT,DDLG)=DNAME_U_DLOC
End DoDot:4
End DoDot:3
+36 IF FIELD'=.01
QUIT
+37 SET DSEQ=DATA
IF DSEQ=""
QUIT
+38 IF FILE="801.41121"
Begin DoDot:3
+39 SET DNAME=DATA
IF DNAME=""
QUIT
+40 ;Quit if DLOC for the item is not defined. This should fix a problem
+41 ;pre-patch 12 entries not containing national prompts.
+42 IF +$PIECE(VERSN,"P",2)<12
IF '$DATA(^TMP("PXRMEXTMP",$JOB,"DLOC",DNAME))
QUIT
+43 SET DLOC=^TMP("PXRMEXTMP",$JOB,"DLOC",DNAME)
+44 SET CNT=0
+45 IF $DATA(^TMP("PXRMEXTMP",$JOB,"DMAP",DDLG))>0
SET CNT=$ORDER(^TMP("PXRMEXTMP",$JOB,"DMAP",DDLG,""),-1)
+46 SET ^TMP("PXRMEXTMP",$JOB,"DMAP",DDLG,CNT+1)=DNAME
End DoDot:3
QUIT
+47 SET LINE=$GET(^PXD(811.8,IEN,100,DSUB+1,0))
+48 IF ($PIECE(LINE,";")'="801.412")
QUIT
+49 SET INDICES=$PIECE(LINE,"~",1)
+50 IF $PIECE(INDICES,";",3)'=2
QUIT
+51 SET DATA=$PIECE(LINE,"~",2)
+52 SET DNAME=DATA
IF DNAME=""
QUIT
+53 ;Quit if DLOC for the item is not defined. This should fix a problem
+54 ;pre-patch 12 entries not containing national prompts.
+55 IF +$PIECE(VERSN,"P",2)<12
IF '$DATA(^TMP("PXRMEXTMP",$JOB,"DLOC",DNAME))
QUIT
+56 SET DLOC=^TMP("PXRMEXTMP",$JOB,"DLOC",DNAME)
+57 SET ^TMP("PXRMEXTMP",$JOB,"DMAP",DDLG,DSEQ)=DNAME
End DoDot:2
End DoDot:1
+58 ;
+59 IF $DATA(REPARR)>0
Begin DoDot:1
+60 NEW CNT,DLG,REPCNT
+61 SET CNT=""
SET REPCNT=0
+62 FOR
SET CNT=$ORDER(REPARR(CNT))
IF CNT=""
QUIT
Begin DoDot:2
+63 SET REPCNT=REPCNT+1
SET DLG=$ORDER(REPARR(CNT,""))
+64 SET ^TMP("PXRMEXTMP",$JOB,"DREPL",DIALNAM,REPCNT,DLG)=REPARR(CNT,DLG)
End DoDot:2
End DoDot:1
+65 ;
+66 ;Build index of dialog findings by name
+67 SET IND=0
+68 FOR
SET IND=$ORDER(^PXD(811.8,IEN,120,IND))
IF 'IND
QUIT
Begin DoDot:1
+69 SET FDATA=$GET(^PXD(811.8,IEN,120,IND,0))
IF FDATA=""
QUIT
+70 SET FILENAM=$PIECE(FDATA,U)
SET FILENUM=$PIECE(FDATA,U,2)
IF FILENAM=""
QUIT
IF 'FILENUM
QUIT
+71 ;Ignore reminder dialogs
+72 IF FILENAM="REMINDER DIALOG"
QUIT
+73 ;Ignore reminder terms
+74 IF FILENAM="REMINDER TERM"
QUIT
+75 ;Strip off trailing S in finding file name
+76 IF $EXTRACT(FILENAM,$LENGTH(FILENAM))="S"
SET $EXTRACT(FILENAM,$LENGTH(FILENAM))=""
+77 SET JND=0
+78 FOR
SET JND=$ORDER(^PXD(811.8,IEN,120,IND,1,JND))
IF 'JND
QUIT
Begin DoDot:2
+79 SET FNAME=$PIECE($GET(^PXD(811.8,IEN,120,IND,1,JND,0)),U)
IF FNAME=""
QUIT
+80 ;Save entry
+81 SET ^TMP("PXRMEXFND",$JOB,FNAME)=FILENUM_U_FILENAM_U_IND
End DoDot:2
End DoDot:1
+82 IF $DATA(TEMPRESL)>0
Begin DoDot:1
+83 SET DDLG=""
FOR
SET DDLG=$ORDER(TEMPRESL(DDLG))
IF DDLG=""
QUIT
Begin DoDot:2
+84 SET DSEQ=$ORDER(^TMP("PXRMEXTMP",$JOB,"DMAP",DDLG,""),-1)
+85 SET ^TMP("PXRMEXTMP",$JOB,"DMAP",DDLG,DSEQ+1)=TEMPRESL(DDLG)_U_RESGRP(TEMPRESL(DDLG))
End DoDot:2
End DoDot:1
+86 QUIT
+87 ;
+88 ;---------------------------------------
+89 ;Scan exchange file to get dialog fields
+90 ;---------------------------------------
DPARSE(IND120,JND120,DNAME,DSTRT,DEND,RESGRP,TEMPRESL) ;
+1 NEW DARRAY,DCNT,DDATA,DFIND,DFIAD,DFNAM,DFNUM,DFQUIT,DLCT,DLINES
+2 NEW DSTRING,DSUB,DTEXT,DTXT,DTYP,RESNAME
+3 ;
+4 ;Find where all the field numbers are kept
+5 SET DSUB=DSTRT-1
SET DSTRING=";.01;4;5;15;24;25;55;"
+6 FOR
SET DSUB=$ORDER(^PXD(811.8,IEN,100,DSUB))
IF 'DSUB
QUIT
Begin DoDot:1
+7 SET DDATA=$GET(^PXD(811.8,IEN,100,DSUB,0))
IF DDATA=""
QUIT
+8 IF $PIECE(DDATA,";")'=801.41
QUIT
+9 SET DFNUM=$PIECE(DDATA,";",3)
SET DFNUM=$PIECE(DFNUM,"~")
IF DFNUM=""
QUIT
+10 IF DSTRING[(";"_DFNUM_";")
SET DARRAY(DFNUM)=DSUB
+11 IF $PIECE(DDATA,";")="801.41121"
SET DARRAY(55)=DSUB
End DoDot:1
IF DSUB>DEND
QUIT
+12 ;
+13 ;Determine dialog component type
+14 SET DSUB=DARRAY(4)
IF 'DSUB
QUIT
+15 SET DTYP=$PIECE($GET(^PXD(811.8,IEN,100,DSUB,0)),"~",2)
+16 IF DTYP'["result"
IF DTYP[" "
SET DTYP=$PIECE(DTYP," ",2)
IF DTYP="value"
SET DTYP="forced"
+17 ;
+18 ;Initialise text and finding fields
+19 SET DTXT="*NONE*"
SET DFIND=""
+20 ;Get text appropriate for the type of component
+21 IF ((DTYP="element")!(DTYP="group"))&(DTYP'["result")
Begin DoDot:1
+22 ;Search for WP text
+23 SET DSUB=$GET(DARRAY(25))
IF DSUB
Begin DoDot:2
+24 SET DTEXT=$PIECE($GET(^PXD(811.8,IEN,100,DSUB,0)),";",3)
IF DTEXT=""
QUIT
+25 ;Get the line count
+26 SET DLINES=$PIECE(DTEXT,"~",3)
SET DCNT=0
+27 ;Get the wp text lines
+28 FOR DLCT=DSUB+1:1:DSUB+DLINES
Begin DoDot:3
+29 SET DTEXT=$GET(^PXD(811.8,IEN,100,DLCT,0))
+30 SET DCNT=DCNT+1
SET DTXT(DCNT)=DTEXT
+31 ;Check for embedded TIU templates
+32 DO DTIU(DNAME,DTEXT)
End DoDot:3
+33 ;Reformat text to 50 characters
+34 DO DWP(1,50,DCNT,.DTXT)
+35 ;Search for Result Group/Element
+36 SET DSUB=$GET(DARRAY(55))
IF DSUB>0
Begin DoDot:3
+37 SET RESNAME=$PIECE($PIECE($GET(^PXD(811.8,IEN,100,DSUB,0)),";",3),"~",2)
+38 SET TEMPRESL(DNAME)=RESNAME
End DoDot:3
End DoDot:2
+39 ;Search for finding item
+40 SET DSUB=$GET(DARRAY(15))
IF DSUB
Begin DoDot:2
+41 SET DFIND=$PIECE($GET(^PXD(811.8,IEN,100,DSUB,0)),";",3)
IF DFIND=""
QUIT
+42 ;Finding name
+43 SET DFIND=$PIECE(DFIND,"~",2)
IF DFIND=""
QUIT
+44 IF $PIECE(DFIND,".")="ICD9"
SET DFIND=$PIECE(DFIND," ")
End DoDot:2
+45 ;
+46 ;Search for additional finding - start after WP text
+47 SET DSUB=+$GET(DARRAY(25))
IF DSUB
Begin DoDot:2
+48 SET DCNT=0
SET DFQUIT=0
+49 FOR DLCT=DSUB+1+DLINES:1
Begin DoDot:3
+50 SET DTEXT=$GET(^PXD(811.8,IEN,100,DLCT,0))
+51 ;Ignore line if this is not an additional finding
+52 IF $PIECE(DTEXT,";")'=801.4118
IF $PIECE(DTEXT,";")>801.4118
SET DFQUIT=1
QUIT
+53 SET DFNAM=$PIECE(DTEXT,"~",2)
IF DFNAM=""
QUIT
+54 IF $PIECE(DFNAM,".")="ICD9"
SET DFNAM=$PIECE(DFNAM," ")
+55 SET DCNT=DCNT+1
SET DFIAD(DCNT)=DFNAM
End DoDot:3
IF DFQUIT
QUIT
IF DLCT>DEND
QUIT
End DoDot:2
End DoDot:1
+56 ;
+57 IF DTYP["result"
Begin DoDot:1
+58 SET DSUB=$GET(DARRAY(.01))
IF 'DSUB
QUIT
+59 SET DDATA=^PXD(811.8,IEN,100,DSUB,0)
IF DDATA=""
QUIT
+60 SET DTXT=$PIECE(DDATA,"~",2)
+61 SET RESGRP(DNAME)=DSTRT_U_DEND_U_IND120_U_JND120
End DoDot:1
+62 ;
+63 IF DTYP="prompt"
Begin DoDot:1
+64 ;search for prompt caption
+65 SET DSUB=$GET(DARRAY(24))
IF 'DSUB
QUIT
+66 SET DDATA=^PXD(811.8,IEN,100,DSUB,0)
IF DDATA=""
QUIT
+67 SET DTXT="Prompt caption: "_$PIECE(DDATA,"~",2)
End DoDot:1
+68 ;
+69 IF DTYP="group"
Begin DoDot:1
+70 ;search for group caption
+71 SET DSUB=$GET(DARRAY(5))
IF 'DSUB
QUIT
+72 SET DDATA=^PXD(811.8,IEN,100,DSUB,0)
IF DDATA=""
QUIT
+73 SET DTXT="Group caption: "_$PIECE(DDATA,"~",2)
End DoDot:1
+74 ;
+75 ;Save dialog type
+76 IF DTYP["result"
SET DTYP=$$STRREP^PXRMUTIL(DTYP,"result ","rs.")
+77 SET ^TMP("PXRMEXTMP",$JOB,"DTYP",DNAME)=DTYP
+78 ;Save dialog component text (first line only)
+79 IF ($GET(DTXT)'="")
IF (DTXT'=DNAME)
SET ^TMP("PXRMEXTMP",$JOB,"DTXT",DNAME)=DTXT
+80 ;
+81 ;Save main finding
+82 IF DFIND]""
SET ^TMP("PXRMEXTMP",$JOB,"DFND",DNAME,1)=$PIECE(DFIND,".",2,99)
+83 ;Save additional findings
+84 SET DSUB=0
+85 FOR
SET DSUB=$ORDER(DFIAD(DSUB))
IF 'DSUB
QUIT
SET ^TMP("PXRMEXTMP",$JOB,"DFND",DNAME,DSUB+1)=$PIECE(DFIAD(DSUB),".",2,99)
+86 ;
+87 ;Save additional WP text lines
+88 SET DSUB=0
+89 FOR
SET DSUB=$ORDER(DTXT(DSUB))
IF 'DSUB
QUIT
SET ^TMP("PXRMEXTMP",$JOB,"DTXT",DNAME,DSUB)=DTXT(DSUB)
+90 QUIT
+91 ;
+92 ;Extract any TIU templates
+93 ;-------------------------
DTIU(DNAME,TEXT) ;
+1 NEW IC,TCNT,TLIST,TNAM
+2 ;Templates are in format {FLD:fldname}
+3 SET TCNT=0
DO TIUXTR^PXRMEXU1("{FLD:","}",TEXT,.TLIST,.TCNT)
IF 'TCNT
QUIT
+4 ;
+5 FOR IC=1:1:TCNT
Begin DoDot:1
+6 SET TNAM=$GET(TLIST(TCNT))
IF TNAM=""
QUIT
+7 SET ^TMP("PXRMEXTMP",$JOB,"DTIU",DNAME,TNAM)=""
End DoDot:1
+8 QUIT
+9 ;
+10 ;Process WP fields
+11 ;-----------------
DWP(LM,RM,NIN,TEXT) ;
+1 NEW NOUT,TEXTOUT
+2 DO FORMAT^PXRMTEXT(LM,RM,NIN,.TEXT,.NOUT,.TEXTOUT)
+3 KILL TEXT
+4 MERGE TEXT=TEXTOUT
+5 QUIT
+6 ;
+7 ;-----------------
FINDSTRT(IEN,IND120,END) ;
+1 IF END=1
QUIT 0
+2 NEW START,TEMP,ISSEL
+3 SET START=0
SET TEMP=0
+4 FOR
SET END=$ORDER(^PXD(811.8,IEN,120,IND120,END),-1)
IF END'>0!(START>0)
QUIT
Begin DoDot:1
+5 SET ISSEL=$PIECE(^PXD(811.8,IEN,120,IND120,END,0),U,7)
+6 IF ISSEL=0
SET TEMP=END
QUIT
+7 SET START=TEMP
End DoDot:1
+8 QUIT START
+9 ;
