PXRMEXLB ;SLC/PJH - Reminder Dialog Exchange ;09/27/2018
;;2.0;CLINICAL REMINDERS;**6,12,26,45**;Feb 04, 2005;Build 566
;
;=====================================================================
;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
.;Save selected dialogs 120 positions for later lookup
.I $P(DDATA,U,7)=1 S ^TMP("PXRMEXTMP",$J,"DSELECT",JND)=DDATA
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,FIELD,FILE,FILENAM,FILENUM,FNAME,IND,INDICES,ISDGRP,JND,LASTSEL,LINE
N REPARR,REPCNT,RESGRP,TEMPRSEL,VERSN
K ^TMP("PXRMEXTMP",$J,"DMAP")
S LINE=^PXD(811.8,IEN,100,3,0)
S VERSN=$$GETTAGV^PXRMEXU3(LINE,"<PACKAGE_VERSION>")
S ISDGRP=$$PATTR^PXRMEXU2(IEN,"GROUPING DIALOG COMPONENTS")
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 LASTSEL=+$O(^TMP("PXRMEXTMP",$J,"DSELECT",JND120),-1)
S DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3),DSUB=DSTRT+2
;D CHECKCMP(DNAME,DSTRT,DEND,.RESGRP,.TEMPRSEL,.DARRAY)
S REPCNT=0,JND=$S(ISDGRP=0:0,1:LASTSEL)
;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)&(FILE'=801.41143) 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 D
.....S ^TMP("PXRMEXTMP",$J,"DREPL",DIALNAM,REPCNT,DDLG)=DNAME_U_DLOC
.....S ^TMP("PXRMEXTMP",$J,"DREPL ITEMS",DDLG,DNAME)=DNAME_U_DLOC
....I +$P(VERSN,"P",2)<12 S REPARR(REPCNT,DDLG)=DNAME_U_DLOC
..I FILE=801.41143,FIELD=4 D
...S DNAME=DATA Q:DNAME=""
...S DLOC=^TMP("PXRMEXTMP",$J,"DLOC",DNAME)
...S REPCNT=REPCNT+1,^TMP("PXRMEXTMP",$J,"DREPL",DIALNAM,REPCNT,DDLG)=DNAME_U_DLOC
...S ^TMP("PXRMEXTMP",$J,"DREPL ITEMS",DDLG,DNAME)=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"
;
;Initialize 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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMEXLB 9557 printed Apr 09, 2024@20:51:19 Page 2
PXRMEXLB ;SLC/PJH - Reminder Dialog Exchange ;09/27/2018
+1 ;;2.0;CLINICAL REMINDERS;**6,12,26,45**;Feb 04, 2005;Build 566
+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
+8 ;Save selected dialogs 120 positions for later lookup
+9 IF $PIECE(DDATA,U,7)=1
SET ^TMP("PXRMEXTMP",$JOB,"DSELECT",JND)=DDATA
End DoDot:1
+10 QUIT
+11 ;
+12 ;Build list of dialog components
+13 ;-------------------------------
DBUILD(IEN,IND120,JND120) ;
+1 NEW CNT,DARRAY,DATA,DDATA,DDLG,DEND,DIALNAM,DLOC,DMAP,DNAME,DNODE,DSEQ
+2 NEW DSTRT,DSUB,FDATA,FIELD,FILE,FILENAM,FILENUM,FNAME,IND,INDICES,ISDGRP,JND,LASTSEL,LINE
+3 NEW REPARR,REPCNT,RESGRP,TEMPRSEL,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 ISDGRP=$$PATTR^PXRMEXU2(IEN,"GROUPING DIALOG COMPONENTS")
+8 SET DDATA=$GET(^PXD(811.8,IEN,120,IND120,1,JND120,0))
if DDATA=""
QUIT
+9 SET ^TMP("PXRMEXTMP",$JOB,"PXRMDNAME")=$PIECE(DDATA,U,1)
+10 SET DIALNAM=$PIECE(DDATA,U,1)
+11 SET DSUB=$PIECE(DDATA,U,2)+2
+12 IF $PIECE($GET(^PXD(811.8,IEN,100,DSUB,0)),";",3)["100~NATIONAL"
SET ^TMP("PXRMEXTMP",$JOB,"PXRMDNAT")=""
+13 IF '$DATA(^TMP("PXRMEXTMP",$JOB,"DLOC"))
DO BDLOC(IEN,IND120)
+14 SET LASTSEL=+$ORDER(^TMP("PXRMEXTMP",$JOB,"DSELECT",JND120),-1)
+15 SET DSTRT=$PIECE(DDATA,U,2)
SET DEND=$PIECE(DDATA,U,3)
SET DSUB=DSTRT+2
+16 ;D CHECKCMP(DNAME,DSTRT,DEND,.RESGRP,.TEMPRSEL,.DARRAY)
+17 SET REPCNT=0
SET JND=$SELECT(ISDGRP=0:0,1:LASTSEL)
+18 ;S (JND,REPCNT)=0
+19 ;Scan the dialog components in 120 and save the name and type.
+20 FOR
SET JND=$ORDER(^PXD(811.8,IEN,120,IND120,1,JND))
if JND'>0!(JND>JND120)
QUIT
Begin DoDot:1
+21 SET DDATA=$GET(^PXD(811.8,IEN,120,IND120,1,JND,0))
if DDATA=""
QUIT
+22 SET (DDLG,DNAME)=$PIECE(DDATA,U,1)
+23 SET DSTRT=$PIECE(DDATA,U,2)
SET DEND=$PIECE(DDATA,U,3)
SET DSUB=DSTRT+2
+24 ;Extract dialog type and text and findings from exchange file
+25 DO DPARSE(IND120,JND,DNAME,DSTRT,DEND,.RESGRP,.TEMPRSEL)
+26 ;Scan dialog components in 120 and save dialog links
+27 FOR
SET DSUB=$ORDER(^PXD(811.8,IEN,100,DSUB))
if DSUB>DEND
QUIT
Begin DoDot:2
+28 SET LINE=$GET(^PXD(811.8,IEN,100,DSUB,0))
+29 SET INDICES=$PIECE(LINE,"~",1)
+30 SET DATA=$PIECE(LINE,"~",2)
+31 SET FILE=$PIECE(INDICES,";",1)
+32 SET FIELD=$PIECE(INDICES,";",3)
+33 IF (FILE'=801.412)&(FILE'=801.41121)&(FIELD'=118)&(FILE'=801.41143)
QUIT
+34 ;Handle dialogs with replacement dialogs
+35 IF FIELD=118
Begin DoDot:3
+36 SET DNAME=DATA
if DNAME=""
QUIT
+37 SET DLOC=^TMP("PXRMEXTMP",$JOB,"DLOC",DNAME)
+38 SET REPCNT=REPCNT+1
Begin DoDot:4
+39 IF +$PIECE(VERSN,"P",2)>11
Begin DoDot:5
+40 SET ^TMP("PXRMEXTMP",$JOB,"DREPL",DIALNAM,REPCNT,DDLG)=DNAME_U_DLOC
+41 SET ^TMP("PXRMEXTMP",$JOB,"DREPL ITEMS",DDLG,DNAME)=DNAME_U_DLOC
End DoDot:5
+42 IF +$PIECE(VERSN,"P",2)<12
SET REPARR(REPCNT,DDLG)=DNAME_U_DLOC
End DoDot:4
End DoDot:3
+43 IF FILE=801.41143
IF FIELD=4
Begin DoDot:3
+44 SET DNAME=DATA
if DNAME=""
QUIT
+45 SET DLOC=^TMP("PXRMEXTMP",$JOB,"DLOC",DNAME)
+46 SET REPCNT=REPCNT+1
SET ^TMP("PXRMEXTMP",$JOB,"DREPL",DIALNAM,REPCNT,DDLG)=DNAME_U_DLOC
+47 SET ^TMP("PXRMEXTMP",$JOB,"DREPL ITEMS",DDLG,DNAME)=DNAME_U_DLOC
End DoDot:3
+48 IF FIELD'=.01
QUIT
+49 SET DSEQ=DATA
if DSEQ=""
QUIT
+50 IF FILE="801.41121"
Begin DoDot:3
+51 SET DNAME=DATA
if DNAME=""
QUIT
+52 ;Quit if DLOC for the item is not defined. This should fix a problem
+53 ;pre-patch 12 entries not containing national prompts.
+54 IF +$PIECE(VERSN,"P",2)<12
IF '$DATA(^TMP("PXRMEXTMP",$JOB,"DLOC",DNAME))
QUIT
+55 SET DLOC=^TMP("PXRMEXTMP",$JOB,"DLOC",DNAME)
+56 SET CNT=0
+57 IF $DATA(^TMP("PXRMEXTMP",$JOB,"DMAP",DDLG))>0
SET CNT=$ORDER(^TMP("PXRMEXTMP",$JOB,"DMAP",DDLG,""),-1)
+58 SET ^TMP("PXRMEXTMP",$JOB,"DMAP",DDLG,CNT+1)=DNAME
End DoDot:3
QUIT
+59 SET LINE=$GET(^PXD(811.8,IEN,100,DSUB+1,0))
+60 IF ($PIECE(LINE,";")'="801.412")
QUIT
+61 SET INDICES=$PIECE(LINE,"~",1)
+62 IF $PIECE(INDICES,";",3)'=2
QUIT
+63 SET DATA=$PIECE(LINE,"~",2)
+64 SET DNAME=DATA
if DNAME=""
QUIT
+65 ;Quit if DLOC for the item is not defined. This should fix a problem
+66 ;pre-patch 12 entries not containing national prompts.
+67 IF +$PIECE(VERSN,"P",2)<12
IF '$DATA(^TMP("PXRMEXTMP",$JOB,"DLOC",DNAME))
QUIT
+68 SET DLOC=^TMP("PXRMEXTMP",$JOB,"DLOC",DNAME)
+69 SET ^TMP("PXRMEXTMP",$JOB,"DMAP",DDLG,DSEQ)=DNAME
End DoDot:2
End DoDot:1
+70 ;
+71 IF $DATA(REPARR)>0
Begin DoDot:1
+72 NEW CNT,DLG,REPCNT
+73 SET CNT=""
SET REPCNT=0
+74 FOR
SET CNT=$ORDER(REPARR(CNT))
if CNT=""
QUIT
Begin DoDot:2
+75 SET REPCNT=REPCNT+1
SET DLG=$ORDER(REPARR(CNT,""))
+76 SET ^TMP("PXRMEXTMP",$JOB,"DREPL",DIALNAM,REPCNT,DLG)=REPARR(CNT,DLG)
End DoDot:2
End DoDot:1
+77 ;
+78 ;Build index of dialog findings by name
+79 SET IND=0
+80 FOR
SET IND=$ORDER(^PXD(811.8,IEN,120,IND))
if 'IND
QUIT
Begin DoDot:1
+81 SET FDATA=$GET(^PXD(811.8,IEN,120,IND,0))
if FDATA=""
QUIT
+82 SET FILENAM=$PIECE(FDATA,U)
SET FILENUM=$PIECE(FDATA,U,2)
if FILENAM=""
QUIT
if 'FILENUM
QUIT
+83 ;Ignore reminder dialogs
+84 IF FILENAM="REMINDER DIALOG"
QUIT
+85 ;Ignore reminder terms
+86 IF FILENAM="REMINDER TERM"
QUIT
+87 ;Strip off trailing S in finding file name
+88 IF $EXTRACT(FILENAM,$LENGTH(FILENAM))="S"
SET $EXTRACT(FILENAM,$LENGTH(FILENAM))=""
+89 SET JND=0
+90 FOR
SET JND=$ORDER(^PXD(811.8,IEN,120,IND,1,JND))
if 'JND
QUIT
Begin DoDot:2
+91 SET FNAME=$PIECE($GET(^PXD(811.8,IEN,120,IND,1,JND,0)),U)
if FNAME=""
QUIT
+92 ;Save entry
+93 SET ^TMP("PXRMEXFND",$JOB,FNAME)=FILENUM_U_FILENAM_U_IND
End DoDot:2
End DoDot:1
+94 IF $DATA(TEMPRESL)>0
Begin DoDot:1
+95 SET DDLG=""
FOR
SET DDLG=$ORDER(TEMPRESL(DDLG))
if DDLG=""
QUIT
Begin DoDot:2
+96 SET DSEQ=$ORDER(^TMP("PXRMEXTMP",$JOB,"DMAP",DDLG,""),-1)
+97 SET ^TMP("PXRMEXTMP",$JOB,"DMAP",DDLG,DSEQ+1)=TEMPRESL(DDLG)_U_RESGRP(TEMPRESL(DDLG))
End DoDot:2
End DoDot:1
+98 QUIT
+99 ;
+100 ;---------------------------------------
+101 ;Scan exchange file to get dialog fields
+102 ;---------------------------------------
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 ;Initialize 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 ;
