PXRMEXU4 ;SLC/PJH,PKR - Reminder Exchange #4, dialog changes. ;05/07/2014
;;2.0;CLINICAL REMINDERS;**6,12,22,26**;Feb 04, 2005;Build 404
;===============================================
DLG(FDA,NAMECHG) ;Check the dialog for renamed entries, called by
;silent installer. KIDSDONE is newed in INSDLG^PXRMEXSI.
N ABBR,ACTION,ALIST,DNAM,IEN,IENS,ISACT,FILENUM,FINDING,NEWNAM,OFINDING
N ORITEM,OORITEM,PT01,RESULT,RRG,SRC,TEMP,TEXT,WP
S IENS=$O(FDA(801.41,""))
;Definition .01
S (PT01,DNAM)=FDA(801.41,IENS,.01)
I $D(NAMECHG(801.41,PT01)) D
.S (FDA(801.41,IENS,.01),DNAM)=NAMECHG(801.41,PT01)
;
;Build list of finding types
D BLDALIST^PXRMVPTR(801.4118,.01,.ALIST)
;Plus field 15 files
S ALIST("MH")=601.71,ALIST("TX")=811.2
S ALIST("WH")=790.404
;Plus field 17 file
S ALIST("OI")=101.43
;
;Process SOURCE REMINDER
S SRC=$G(FDA(801.41,IENS,2))
I SRC]"" D
.S IEN=$$EXISTS^PXRMEXIU(811.9,SRC)
.I IEN=0 K FDA(801.41,IENS,2)
;
;Clear RESULT if not defined
S RESULT=$G(FDA(801.41,IENS,55))
I RESULT]"" D
.S IEN=$$EXISTS^PXRMEXIU(801.41,RESULT)
.I IEN=0 K FDA(801.41,IENS,55)
;
;Process ORDERABLE ITEM
S (ORITEM,OORITEM)=$G(FDA(801.41,IENS,17)),ACTION=""
I ORITEM'="" D I ACTION="Q" K FDA S PXRMDONE=1 Q
.S TEXT=""
.S PT01=ORITEM
.S ABBR="OI",FILENUM=$P(ALIST(ABBR),U)
.I $D(NAMECHG(FILENUM,PT01)) D
..S ORITEM=NAMECHG(FILENUM,PT01)
..S FDA(801.41,IENS,17)=ORITEM
.S IEN=+$$VFIND1^PXRMEXIU(ABBR_"."_ORITEM,.ALIST)
.I IEN>0,$$VDLGFIND^PXRMEXIU(ABBR,ORITEM,.ALIST)=0 D
..S IEN=0
..S TEXT="ORDERABLE ITEM entry "_ORITEM_" is inactive."
.I IEN>0 S FDA(801.41,IENS,17)="`"_IEN
.I IEN=0 D
..;Get replacement
..I TEXT="" S TEXT="ORDERABLE ITEM entry "_ORITEM_" does not exist."
..N DIC,DIR,DUOUT,MSG,X,Y
..S MSG(1)=" "
..S MSG(2)=TEXT
..D MES^XPDUTL(.MSG)
..S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR) I ACTION="S" S ACTION="Q"
..I ACTION="Q" Q
..I ACTION="D" K FDA(801.41,IENS,17) Q
..S DIC=FILENUM
..S DIC(0)="AEMNQ"
..S DIC("S")="I $$FILESCR^PXRMDLG6(Y,FILENUM)=1"
..S Y=-1
..F Q:+Y'=-1 D
...;If this is being called during a KIDS install we need echoing on.
...I $D(XPDNM) X ^%ZOSF("EON")
...D ^DIC
...I $D(XPDNM) X ^%ZOSF("EOFF")
...;If this is being called during a KIDS install we need echoing on.
...I $D(DUOUT) S Y="" Q
...I Y=-1 D BMES^XPDUTL("You must input a replacement!")
..I Y="" S ACTION="Q" Q
..S ORITEM=$P(Y,U,2)
..S FDA(801.41,IENS,17)=ORITEM
.;Save the finding information for the history.
.I ORITEM'=OORITEM D
.. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),ABBR_"."_OORITEM)=ABBR_"."_ORITEM
;
;check for pre-packed patch 26 codes and taxonomy.
D TAXCONV(.FDA,IENS)
;Process FINDING ITEM
;S TAXCONVD=0
S (FINDING,OFINDING)=$G(FDA(801.41,IENS,15)),ACTION=""
I FINDING'="" D I ACTION="Q" K FDA S PXRMDONE=1 Q
.S TEXT=""
.S ABBR=$P(FINDING,".",1)
.S PT01=$P(FINDING,".",2)
.S FILENUM=$P(ALIST(ABBR),U,1)
.I $D(NAMECHG(FILENUM,PT01)) D
..S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
..S FDA(801.41,IENS,15)=FINDING
.S IEN=+$$VFIND1^PXRMEXIU(FINDING,.ALIST)
.I IEN>0 S TEMP=$$VDLGFIND^PXRMEXIU(ABBR,IEN,.ALIST) I TEMP<1 D
..S IEN=0
..S TEXT="FINDING entry "_FINDING_" "_$S(TEMP=0:"is inactive.",1:" does not have codes marked to be used in a dialog.")
.I IEN>0 S FDA(801.41,IENS,15)=ABBR_".`"_IEN
.I IEN=0 D
..I TEXT="" S TEXT="FINDING entry "_FINDING_" does not exist."
..;Get replacement
..N DIC,DIR,DUOUT,MSG,X,Y
..S MSG(1)=" "
..S MSG(2)=TEXT
..D MES^XPDUTL(.MSG)
..S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR) I ACTION="S" S ACTION="Q"
..I ACTION="Q" Q
..I ACTION="D" K FDA(801.41,IENS,15) Q
..S DIC=FILENUM
..S DIC(0)="AEMNQ"
..S DIC("S")="I $$FILESCR^PXRMDLG6(Y,FILENUM)=1"
..S Y=-1
..F Q:+Y'=-1 D
...;If this is being called during a KIDS install we need echoing on.
...I $D(XPDNM) X ^%ZOSF("EON")
...D ^DIC
...I $D(XPDNM) X ^%ZOSF("EOFF")
...;If this is being called during a KIDS install we need echoing on.
...I $D(DUOUT) S Y="" Q
...I Y=-1 D BMES^XPDUTL("You must input a replacement!")
..I Y="" S ACTION="Q" Q
..S FINDING=ABBR_"."_$P(Y,U,2)
..S FDA(801.41,IENS,15)=FINDING
.;Save the finding information for the history.
.I FINDING'=OFINDING D
.. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),OFINDING)=FINDING
.;Convert ICD9 codes to `ien format
.;I $P(FINDING,".")="ICD9" S FDA(801.41,IENS,15)="ICD9."_$$ICD9(FINDING)
;
;Look for replacements of TIU templates.
I $D(NAMECHG(8927.1)) D
.S WP=$G(FDA(801.41,IENS,25))
.I WP'="" D TIURPL("{FLD:",WP,.NAMECHG,8927.1)
.S WP=$G(FDA(801.41,IENS,35))
;
;Process ADDITIONAL FINDINGS
S IENS="",ACTION=""
F S IENS=$O(FDA(801.4118,IENS)) Q:IENS="" D I ACTION="Q" K FDA S PXRMDONE=1 Q
. S TEXT=""
. S (FINDING,OFINDING)=FDA(801.4118,IENS,.01)
. S ABBR=$P(FINDING,".",1)
. S PT01=$P(FINDING,".",2)
. S FILENUM=$P(ALIST(ABBR),U,1)
. I $D(NAMECHG(FILENUM,PT01)) D
.. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
.. S FDA(801.4118,IENS,.01)=FINDING
. S IEN=+$$VFIND1^PXRMEXIU(FINDING,.ALIST)
.I IEN>0 S TEMP=$$VDLGFIND^PXRMEXIU(ABBR,IEN,.ALIST) I TEMP<1 D
..S IEN=0
..S TEXT="ADDITIONAL FINDING entry "_FINDING_" "_$S(TEMP=0:"is inactive.",1:" does not have codes marked to be used in a dialog.")
.I IEN>0 S FDA(801.4118,IENS,.01)=ABBR_".`"_IEN
. I IEN=0 D Q:ACTION="Q"
..;Get replacement
.. I TEXT="" S TEXT="ADDITIONAL FINDING entry "_FINDING_" does not exist."
.. N DIC,DIR,DUOUT,MSG,X,Y
.. S MSG(1)=" "
.. S MSG(2)=TEXT
.. D MES^XPDUTL(.MSG)
.. S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
.. I ACTION="S" S ACTION="Q"
.. I ACTION="Q" Q
.. I ACTION="D" K FDA(801.4118,IENS) Q
.. S DIC=FILENUM
.. S DIC(0)="AEMNQ"
.. S DIC("S")="I $$FILESCR^PXRMDLG6(Y,FILENUM)=1"
.. S Y=-1
.. F Q:+Y'=-1 D
...;If this is being called during a KIDS install we need echoing on.
... I $D(XPDNM) X ^%ZOSF("EON")
... D ^DIC
... I $D(XPDNM) X ^%ZOSF("EOFF")
... I $D(DUOUT) S Y="" Q
... I Y=-1 D BMES^XPDUTL("You must input a replacement!")
.. I Y="" S ACTION="Q" Q
.. S FINDING=ABBR_"."_$P(Y,U,2)
.. S FDA(801.4118,IENS,.01)=FINDING
. ;Save the finding information for the history.
. I FINDING'=OFINDING D
.. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),OFINDING)=FINDING
. ;Convert ICD9 codes to `ien format
. ;I $P(FINDING,".")="ICD9" S FDA(801.4118,IENS,.01)="ICD9."_$$ICD9(FINDING)
;
I ACTION="Q" S PXRMDONE=1 Q
;Process DIALOG COMPONENT
S IENS="",ACTION=""
F S IENS=$O(FDA(801.412,IENS)) Q:IENS="" D I ACTION="Q" K FDA S PXRMDONE=1 Q
. S PT01=$G(FDA(801.412,IENS,2)) Q:PT01=""
. S FILENUM=801.41,NEWNAM=$G(NAMECHG(FILENUM,PT01))
.I NEWNAM'="" D
.. S FDA(801.412,IENS,2)=NEWNAM,PT01=NEWNAM
.S IEN=$$EXISTS^PXRMEXIU(FILENUM,PT01)
.I IEN=0 D
..;Get replacement
.. N DIC,DIR,DUOUT,MSG,X,Y
.. S MSG(1)=" "
.. S MSG(2)="COMPONENT DIALOG entry "_PT01_" does not exist."
.. D MES^XPDUTL(.MSG)
.. S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
.. I ACTION="S" S ACTION="Q"
.. I ACTION="Q" Q
.. I ACTION="D" K FDA(801.412,IENS) Q
.. S DIC=FILENUM
.. S DIC(0)="AEMNQ"
.. S DIC("S")="I ""EG""[$P(^PXRMD(801.41,Y,0),U,4)"
.. S Y=-1
.. F Q:+Y'=-1 D
...;If this is being called during a KIDS install we need echoing on.
... I $D(XPDNM) X ^%ZOSF("EON")
... D ^DIC
... I $D(XPDNM) X ^%ZOSF("EOFF")
... I $D(DUOUT) S Y="" Q
... I Y=-1 D BMES^XPDUTL("You must input a replacement!")
.. I Y="" S ACTION="Q" Q
.. I Y'="" S FDA(801.412,IENS,2)=$P(Y,U,2)
;Process Result Groups
F S IENS=$O(FDA(801.41121,IENS)) Q:IENS="" D I ACTION="Q" K FDA S PXRMDONE=1 Q
. S PT01=$G(FDA(801.41121,IENS,.01)) Q:PT01=""
. S FILENUM=801.41,NEWNAM=$G(NAMECHG(FILENUM,PT01))
.I NEWNAM'="" D
.. S FDA(801.41121,IENS,2)=NEWNAM,PT01=NEWNAM
.S IEN=$$EXISTS^PXRMEXIU(FILENUM,PT01)
.I IEN=0 D
..;Get replacement
.. N DIC,DIR,DUOUT,MSG,X,Y
.. S MSG(1)=" "
.. S MSG(2)="RESULT GROUP entry "_PT01_" does not exist."
.. D MES^XPDUTL(.MSG)
.. S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
.. I ACTION="S" S ACTION="Q"
.. I ACTION="Q" Q
.. I ACTION="D" K FDA(801.41121,IENS) Q
.. S DIC=FILENUM
.. S DIC(0)="AEMNQ"
.. S DIC("S")="I ""S""[$P(^PXRMD(801.41,Y,0),U,4)"
.. S Y=-1
.. F Q:+Y'=-1 D
...;If this is being called during a KIDS install we need echoing on.
... I $D(XPDNM) X ^%ZOSF("EON")
... D ^DIC
... I $D(XPDNM) X ^%ZOSF("EOFF")
... I $D(DUOUT) S Y="" Q
... I Y=-1 D BMES^XPDUTL("You must input a replacement!")
.. I Y="" S ACTION="Q" Q
.. I Y'="" S FDA(801.41121,IENS,.01)=$P(Y,U,2)
Q
;
;===============================================
;Convert ICD9 codes to `ien format
ICD9(CODE) ;
N IEN
S IEN=$$FIND1^DIC(80,"","AMX",$P(CODE,".",2,99))
I 'IEN Q ""
Q IEN
;
SETWARN(TEXT) ;
S TEXT(1)="PREVIOUSLY THE DIALOG WAS SET TO BOTH CURRENT AND HISTORICAL ENCOUNTERS."
S TEXT(2)="DIALOG IS NOW SET TO CURRENT ENCOUNTER ONLY."
S TEXT(3)="REVIEW THE DIALOG BEFORE USING IN CPRS."
Q
;
TAXARRAY(FINDING,CNT,ARRAY) ;
; add to code list to create a new taxonomy
N CODE,CODESYS,IEN
S CODESYS=$P(FINDING,"."),CODE=$P(FINDING,".",2,99)
I $P(CODESYS,".")'["ICD9",$P(CODESYS,".")'["CPT" Q
S CODESYSN=$S(CODESYS[9:"ICD",1:"CPT")
S IEN=$$EXISTS^PXRMEXIU($S(CODESYSN="ICD":80,1:81),CODE)
S CNT=CNT+1,ARRAY("CODE",CODESYSN,IEN)="I"_U_1
Q
;
TAXCONV(FDA,IENS) ;
; FINDING ITEM FDA(801.41,IENS,15)
; ADDITIONAL FINDINGS FDA(801.4118,IENS)
N ADDIENS,ARRAY,CNT,ERROR,FINDING,FINDS,ISFNDFLD,LAST,NAME,OCNT,TAX,TAXNAME,TEMP,TFINDS
S ISFNDFLD=0,CNT=0
;if finding is taxonomy add the correct fields to the element
S FINDING=$G(FDA(801.41,IENS,15))
I $P(FINDING,".")="TX" D TAXCONV1(.FDA,IENS,FINDING) Q
;
I FINDING'="" D
.D TAXARRAY(FINDING,.CNT,.ARRAY)
.;if array defined then finding has a code kill the node off.
.I $D(ARRAY) S ISFNDFLD=1 K FDA(801.41,IENS,15)
;loop through additional findings
S FINDS="" F S FINDS=$O(FDA(801.4118,FINDS)) Q:FINDS="" D
. S FINDING=FDA(801.4118,FINDS,.01)
. S OCNT=CNT D TAXARRAY(FINDING,.CNT,.ARRAY) I CNT>OCNT S TFINDS(FINDS)=""
;kill off additional findings that are codes
S ADDIENS=""
S FINDS="" F S FINDS=$O(TFINDS(FINDS)) Q:FINDS="" D
.K FDA(801.4118,FINDS)
.I ADDIENS="" S ADDIENS=FINDS
I '$D(ARRAY) Q
;build values to crate a new taxonomy
S NAME=$G(FDA(801.41,IENS,.01))
S TEMP=$$RTAXNAME^PXRMDUTL(NAME)
S ARRAY("NAME")=TEMP
S ARRAY("COUNT")=CNT
S ARRAY("CLASS")=$G(FDA(801.41,IENS,100))
S ARRAY("SOURCE")="Exchange installed of dialog "_NAME
;create new taxonomy API
S TAX=$$CRETAX^PXRMTXIM("E",.ARRAY,.ERROR)
I $D(ERROR) D Q
.I $G(TAX)=0 D BMES^XPDUTL("ERROR: Taxonomy could not be created for dialog "_NAME_".") H 1 Q
.D BMES^XPDUTL("ERROR: failed to add all the codes to the Taxonomy "_TEMP_". The codes that could not be added are:")
.D BMES^XPDUTL(.ERROR)
.H 1
S TAXNAME=$P($G(^PXD(811.2,TAX,0)),U)
D BMES^XPDUTL("Taxonomy "_TAXNAME_" created") H 1
I ISFNDFLD=1 D Q
.S FDA(801.41,IENS,15)="TX.`"_TAX
.S FDA(801.41,IENS,123)="NO PICK LIST"
S FINDS=$O(FDA(801.4118,""),-1)
S LAST=$O(FDA(801.44,""),-1) I LAST="" Q
S TEMP=$P($P(LAST,"+",2),",")+1,TEMP="+"_TEMP
S FDA(801.4118,ADDIENS,.01)="TX.`"_TAX
Q
;
TAXCONV1(FDA,IENS,FINDING) ;
N CNT,CPTSTATUS,DEFAULT,ENC,ENCTYPE,IEN,NODECNT,PROMPTS,POVSTATUS,START,TAX,TEXT,TAXIEN,TDX,TPR,TYPE,VALUE,X
;if taxonomy fields defined then quit
I ($G(FDA(801.41,IENS,123))'="") Q
;if group set to not display a pick list.
I FDA(801.41,IENS,4)["group" S FDA(801.41,IENS,123)="N" Q
S TAX=$P(FINDING,".",2)
S FDA(801.41,IENS,123)="ALL"
;
S TAXIEN=$O(^PXD(811.2,"B",TAX,"")) I TAXIEN'>0 Q
;determine Taxonomy Type
S TDX=$$TOK^PXRMDTAX(TAXIEN,"POV")
S TPR=$$TOK^PXRMDTAX(TAXIEN,"CPT")
D SETWARN(.TEXT)
;build default array for taxonomy
S CPTSTATUS=$$GETSTAT^PXRMDTAX("CPT"),POVSTATUS=$$GETSTAT^PXRMDTAX("POV")
I TDX=1 D GETTAXDF^PXRMDTAX(.DEFAULT,"POV",$S(POVSTATUS=2:1,1:0))
I TPR=1 D GETTAXDF^PXRMDTAX(.DEFAULT,"CPT",$S(CPTSTATUS=2:1,1:0))
I TDX,TPR D
.I CPTSTATUS=POVSTATUS,POVSTATUS=2 S FDA(801.41,IENS,13)="2" Q
.S FDA(801.41,IENS,13)="@"
.I CPTSTATUS=0!(POVSTATUS=0) D BMES^XPDUTL(.TEXT)
I TDX,TPR=0 D
.I POVSTATUS=2 S FDA(801.41,IENS,13)="2" Q
.S FDA(801.41,IENS,13)="@" I POVSTATUS=0 D BMES^XPDUTL(.TEXT)
I TDX=0,TPR=1 D
.I CPTSTATUS=2 S FDA(801.41,IENS,13)="2" Q
.S FDA(801.41,IENS,13)="@" I CPTSTATUS=0 D BMES^XPDUTL(.TEXT)
S NODECNT=$O(FDA(801.44,""),-1) I NODECNT="" Q
;
;build encounter tax field
F TYPE="POV","CPT" D
.I TYPE="POV",TDX=0 Q
.I TYPE="CPT",TPR=0 Q
.I TYPE="POV" S X=141
.I TYPE="CPT" S X=142
.S VALUE=$$ADDTAXF1^PXRMDTAX(TYPE,.DEFAULT)
.S FDA(801.41,IENS,X)=VALUE
.;
.;build prompt array from default list
.S TYPE="" F S TYPE=$O(DEFAULT(TYPE)) Q:TYPE="" D
..;I TPR=0,CODE="CPT" Q
..;I TDX=0,CODE="POV" Q
..S CNT=0 F S CNT=$O(DEFAULT(TYPE,"ADDFIND",CNT)) Q:CNT'>0 D
...S NODE=DEFAULT(TYPE,"ADDFIND",CNT),IEN=$P(NODE,U)
...I $D(PROMPTS(IEN))>0 I $L(PROMPTS(IEN),U)<$L(NODE,U) S PROMPTS(IEN)=NODE
...S PROMPTS(IEN)=NODE
;
I $G(FDA(801.41,IENS,122))="YES" K FDA(801.41,IENS,122) Q
I $D(FDA(801.412)) Q
;
;add prompts to the dialog element.
S START=0,IEN=0,CNT=0,DNUM=0
S IEN=0,CNT=0 F S IEN=$O(PROMPTS(IEN)) Q:IEN'>0 D
.S START=START+1,DNUM=DNUM+1
.S NAME=$P($G(^PXRMD(801.41,IEN,0)),U)
.S NODE=PROMPTS(IEN),CNT=$L(NODE,U)
.I $P(NODE,U,3)>0 Q
.S NODECNT=NODECNT+1
.S FDA(801.412,"+"_NODECNT_","_IENS,.01)=START
.S FDA(801.412,"+"_NODECNT_","_IENS,2)="`"_IEN
.I CNT=1 Q
.F NUM=2:1:CNT D
..S VALUE=$P(NODE,U,NUM) I $G(VALUE)="" Q
..S FIELD=$S(NUM=2:9,NUM=4:.01,NUM=5:6,NUM=6:7,NUM=7:8,1:"") I $G(FIELD)="" Q
..I FIELD>6 S VALUE=$S(VALUE=1:"YES",1:"NO")
..S FDA(801.412,"+"_NODECNT_","_IENS,FIELD)=VALUE
Q
;
;===============================================
TIURPL(SRCH,WP,NAMEGHC,FILENUM) ;Replace TIU templates whose names have
;changed.
N IND,RS,TEXT,TS,TYPE
I FILENUM=8927.1 S TYPE="TIU TEMPLATE"
E S TYPE="TIU OBJECT"
S IND=1
F S TEXT=$G(@WP@(IND)) Q:TEXT="" D
.I TEXT[SRCH D
..S TS=""
..F S TS=$O(NAMECHG(FILENUM,TS)) Q:TS="" D
...S RS=NAMECHG(FILENUM,TS) Q:TEXT'[TS
...S @WP@(IND)=$$STRREP^PXRMUTIL(TEXT,TS,RS)
...;Save the replacement information for the history.
...S ^TMP("PXRMEXIA",$J,"DIATIU",TYPE,TS)=RS
...S ^TMP("PXRMEXIA",$J,"DIATIU",TYPE,TS,DNAM)=""
.S IND=IND+1
Q
;
PXRMEXU4 ;SLC/PJH,PKR - Reminder Exchange #4, dialog changes. ;05/07/2014
+1 ;;2.0;CLINICAL REMINDERS;**6,12,22,26**;Feb 04, 2005;Build 404
+2 ;===============================================
DLG(FDA,NAMECHG) ;Check the dialog for renamed entries, called by
+1 ;silent installer. KIDSDONE is newed in INSDLG^PXRMEXSI.
+2 NEW ABBR,ACTION,ALIST,DNAM,IEN,IENS,ISACT,FILENUM,FINDING,NEWNAM,OFINDING
+3 NEW ORITEM,OORITEM,PT01,RESULT,RRG,SRC,TEMP,TEXT,WP
+4 SET IENS=$ORDER(FDA(801.41,""))
+5 ;Definition .01
+6 SET (PT01,DNAM)=FDA(801.41,IENS,.01)
+7 IF $DATA(NAMECHG(801.41,PT01))
Begin DoDot:1
+8 SET (FDA(801.41,IENS,.01),DNAM)=NAMECHG(801.41,PT01)
End DoDot:1
+9 ;
+10 ;Build list of finding types
+11 DO BLDALIST^PXRMVPTR(801.4118,.01,.ALIST)
+12 ;Plus field 15 files
+13 SET ALIST("MH")=601.71
SET ALIST("TX")=811.2
+14 SET ALIST("WH")=790.404
+15 ;Plus field 17 file
+16 SET ALIST("OI")=101.43
+17 ;
+18 ;Process SOURCE REMINDER
+19 SET SRC=$GET(FDA(801.41,IENS,2))
+20 IF SRC]""
Begin DoDot:1
+21 SET IEN=$$EXISTS^PXRMEXIU(811.9,SRC)
+22 IF IEN=0
KILL FDA(801.41,IENS,2)
End DoDot:1
+23 ;
+24 ;Clear RESULT if not defined
+25 SET RESULT=$GET(FDA(801.41,IENS,55))
+26 IF RESULT]""
Begin DoDot:1
+27 SET IEN=$$EXISTS^PXRMEXIU(801.41,RESULT)
+28 IF IEN=0
KILL FDA(801.41,IENS,55)
End DoDot:1
+29 ;
+30 ;Process ORDERABLE ITEM
+31 SET (ORITEM,OORITEM)=$GET(FDA(801.41,IENS,17))
SET ACTION=""
+32 IF ORITEM'=""
Begin DoDot:1
+33 SET TEXT=""
+34 SET PT01=ORITEM
+35 SET ABBR="OI"
SET FILENUM=$PIECE(ALIST(ABBR),U)
+36 IF $DATA(NAMECHG(FILENUM,PT01))
Begin DoDot:2
+37 SET ORITEM=NAMECHG(FILENUM,PT01)
+38 SET FDA(801.41,IENS,17)=ORITEM
End DoDot:2
+39 SET IEN=+$$VFIND1^PXRMEXIU(ABBR_"."_ORITEM,.ALIST)
+40 IF IEN>0
IF $$VDLGFIND^PXRMEXIU(ABBR,ORITEM,.ALIST)=0
Begin DoDot:2
+41 SET IEN=0
+42 SET TEXT="ORDERABLE ITEM entry "_ORITEM_" is inactive."
End DoDot:2
+43 IF IEN>0
SET FDA(801.41,IENS,17)="`"_IEN
+44 IF IEN=0
Begin DoDot:2
+45 ;Get replacement
+46 IF TEXT=""
SET TEXT="ORDERABLE ITEM entry "_ORITEM_" does not exist."
+47 NEW DIC,DIR,DUOUT,MSG,X,Y
+48 SET MSG(1)=" "
+49 SET MSG(2)=TEXT
+50 DO MES^XPDUTL(.MSG)
+51 SET ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
IF ACTION="S"
SET ACTION="Q"
+52 IF ACTION="Q"
QUIT
+53 IF ACTION="D"
KILL FDA(801.41,IENS,17)
QUIT
+54 SET DIC=FILENUM
+55 SET DIC(0)="AEMNQ"
+56 SET DIC("S")="I $$FILESCR^PXRMDLG6(Y,FILENUM)=1"
+57 SET Y=-1
+58 FOR
IF +Y'=-1
QUIT
Begin DoDot:3
+59 ;If this is being called during a KIDS install we need echoing on.
+60 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EON")
+61 DO ^DIC
+62 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EOFF")
+63 ;If this is being called during a KIDS install we need echoing on.
+64 IF $DATA(DUOUT)
SET Y=""
QUIT
+65 IF Y=-1
DO BMES^XPDUTL("You must input a replacement!")
End DoDot:3
+66 IF Y=""
SET ACTION="Q"
QUIT
+67 SET ORITEM=$PIECE(Y,U,2)
+68 SET FDA(801.41,IENS,17)=ORITEM
End DoDot:2
+69 ;Save the finding information for the history.
+70 IF ORITEM'=OORITEM
Begin DoDot:2
+71 SET ^TMP("PXRMEXIA",$JOB,"DIAF",$PIECE(IENS,",",1),ABBR_"."_OORITEM)=ABBR_"."_ORITEM
End DoDot:2
End DoDot:1
IF ACTION="Q"
KILL FDA
SET PXRMDONE=1
QUIT
+72 ;
+73 ;check for pre-packed patch 26 codes and taxonomy.
+74 DO TAXCONV(.FDA,IENS)
+75 ;Process FINDING ITEM
+76 ;S TAXCONVD=0
+77 SET (FINDING,OFINDING)=$GET(FDA(801.41,IENS,15))
SET ACTION=""
+78 IF FINDING'=""
Begin DoDot:1
+79 SET TEXT=""
+80 SET ABBR=$PIECE(FINDING,".",1)
+81 SET PT01=$PIECE(FINDING,".",2)
+82 SET FILENUM=$PIECE(ALIST(ABBR),U,1)
+83 IF $DATA(NAMECHG(FILENUM,PT01))
Begin DoDot:2
+84 SET FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
+85 SET FDA(801.41,IENS,15)=FINDING
End DoDot:2
+86 SET IEN=+$$VFIND1^PXRMEXIU(FINDING,.ALIST)
+87 IF IEN>0
SET TEMP=$$VDLGFIND^PXRMEXIU(ABBR,IEN,.ALIST)
IF TEMP<1
Begin DoDot:2
+88 SET IEN=0
+89 SET TEXT="FINDING entry "_FINDING_" "_$SELECT(TEMP=0:"is inactive.",1:" does not have codes marked to be used in a dialog.")
End DoDot:2
+90 IF IEN>0
SET FDA(801.41,IENS,15)=ABBR_".`"_IEN
+91 IF IEN=0
Begin DoDot:2
+92 IF TEXT=""
SET TEXT="FINDING entry "_FINDING_" does not exist."
+93 ;Get replacement
+94 NEW DIC,DIR,DUOUT,MSG,X,Y
+95 SET MSG(1)=" "
+96 SET MSG(2)=TEXT
+97 DO MES^XPDUTL(.MSG)
+98 SET ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
IF ACTION="S"
SET ACTION="Q"
+99 IF ACTION="Q"
QUIT
+100 IF ACTION="D"
KILL FDA(801.41,IENS,15)
QUIT
+101 SET DIC=FILENUM
+102 SET DIC(0)="AEMNQ"
+103 SET DIC("S")="I $$FILESCR^PXRMDLG6(Y,FILENUM)=1"
+104 SET Y=-1
+105 FOR
IF +Y'=-1
QUIT
Begin DoDot:3
+106 ;If this is being called during a KIDS install we need echoing on.
+107 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EON")
+108 DO ^DIC
+109 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EOFF")
+110 ;If this is being called during a KIDS install we need echoing on.
+111 IF $DATA(DUOUT)
SET Y=""
QUIT
+112 IF Y=-1
DO BMES^XPDUTL("You must input a replacement!")
End DoDot:3
+113 IF Y=""
SET ACTION="Q"
QUIT
+114 SET FINDING=ABBR_"."_$PIECE(Y,U,2)
+115 SET FDA(801.41,IENS,15)=FINDING
End DoDot:2
+116 ;Save the finding information for the history.
+117 IF FINDING'=OFINDING
Begin DoDot:2
+118 SET ^TMP("PXRMEXIA",$JOB,"DIAF",$PIECE(IENS,",",1),OFINDING)=FINDING
End DoDot:2
+119 ;Convert ICD9 codes to `ien format
+120 ;I $P(FINDING,".")="ICD9" S FDA(801.41,IENS,15)="ICD9."_$$ICD9(FINDING)
End DoDot:1
IF ACTION="Q"
KILL FDA
SET PXRMDONE=1
QUIT
+121 ;
+122 ;Look for replacements of TIU templates.
+123 IF $DATA(NAMECHG(8927.1))
Begin DoDot:1
+124 SET WP=$GET(FDA(801.41,IENS,25))
+125 IF WP'=""
DO TIURPL("{FLD:",WP,.NAMECHG,8927.1)
+126 SET WP=$GET(FDA(801.41,IENS,35))
End DoDot:1
+127 ;
+128 ;Process ADDITIONAL FINDINGS
+129 SET IENS=""
SET ACTION=""
+130 FOR
SET IENS=$ORDER(FDA(801.4118,IENS))
IF IENS=""
QUIT
Begin DoDot:1
+131 SET TEXT=""
+132 SET (FINDING,OFINDING)=FDA(801.4118,IENS,.01)
+133 SET ABBR=$PIECE(FINDING,".",1)
+134 SET PT01=$PIECE(FINDING,".",2)
+135 SET FILENUM=$PIECE(ALIST(ABBR),U,1)
+136 IF $DATA(NAMECHG(FILENUM,PT01))
Begin DoDot:2
+137 SET FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
+138 SET FDA(801.4118,IENS,.01)=FINDING
End DoDot:2
+139 SET IEN=+$$VFIND1^PXRMEXIU(FINDING,.ALIST)
+140 IF IEN>0
SET TEMP=$$VDLGFIND^PXRMEXIU(ABBR,IEN,.ALIST)
IF TEMP<1
Begin DoDot:2
+141 SET IEN=0
+142 SET TEXT="ADDITIONAL FINDING entry "_FINDING_" "_$SELECT(TEMP=0:"is inactive.",1:" does not have codes marked to be used in a dialog.")
End DoDot:2
+143 IF IEN>0
SET FDA(801.4118,IENS,.01)=ABBR_".`"_IEN
+144 IF IEN=0
Begin DoDot:2
+145 ;Get replacement
+146 IF TEXT=""
SET TEXT="ADDITIONAL FINDING entry "_FINDING_" does not exist."
+147 NEW DIC,DIR,DUOUT,MSG,X,Y
+148 SET MSG(1)=" "
+149 SET MSG(2)=TEXT
+150 DO MES^XPDUTL(.MSG)
+151 SET ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
+152 IF ACTION="S"
SET ACTION="Q"
+153 IF ACTION="Q"
QUIT
+154 IF ACTION="D"
KILL FDA(801.4118,IENS)
QUIT
+155 SET DIC=FILENUM
+156 SET DIC(0)="AEMNQ"
+157 SET DIC("S")="I $$FILESCR^PXRMDLG6(Y,FILENUM)=1"
+158 SET Y=-1
+159 FOR
IF +Y'=-1
QUIT
Begin DoDot:3
+160 ;If this is being called during a KIDS install we need echoing on.
+161 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EON")
+162 DO ^DIC
+163 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EOFF")
+164 IF $DATA(DUOUT)
SET Y=""
QUIT
+165 IF Y=-1
DO BMES^XPDUTL("You must input a replacement!")
End DoDot:3
+166 IF Y=""
SET ACTION="Q"
QUIT
+167 SET FINDING=ABBR_"."_$PIECE(Y,U,2)
+168 SET FDA(801.4118,IENS,.01)=FINDING
End DoDot:2
IF ACTION="Q"
QUIT
+169 ;Save the finding information for the history.
+170 IF FINDING'=OFINDING
Begin DoDot:2
+171 SET ^TMP("PXRMEXIA",$JOB,"DIAF",$PIECE(IENS,",",1),OFINDING)=FINDING
End DoDot:2
+172 ;Convert ICD9 codes to `ien format
+173 ;I $P(FINDING,".")="ICD9" S FDA(801.4118,IENS,.01)="ICD9."_$$ICD9(FINDING)
End DoDot:1
IF ACTION="Q"
KILL FDA
SET PXRMDONE=1
QUIT
+174 ;
+175 IF ACTION="Q"
SET PXRMDONE=1
QUIT
+176 ;Process DIALOG COMPONENT
+177 SET IENS=""
SET ACTION=""
+178 FOR
SET IENS=$ORDER(FDA(801.412,IENS))
IF IENS=""
QUIT
Begin DoDot:1
+179 SET PT01=$GET(FDA(801.412,IENS,2))
IF PT01=""
QUIT
+180 SET FILENUM=801.41
SET NEWNAM=$GET(NAMECHG(FILENUM,PT01))
+181 IF NEWNAM'=""
Begin DoDot:2
+182 SET FDA(801.412,IENS,2)=NEWNAM
SET PT01=NEWNAM
End DoDot:2
+183 SET IEN=$$EXISTS^PXRMEXIU(FILENUM,PT01)
+184 IF IEN=0
Begin DoDot:2
+185 ;Get replacement
+186 NEW DIC,DIR,DUOUT,MSG,X,Y
+187 SET MSG(1)=" "
+188 SET MSG(2)="COMPONENT DIALOG entry "_PT01_" does not exist."
+189 DO MES^XPDUTL(.MSG)
+190 SET ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
+191 IF ACTION="S"
SET ACTION="Q"
+192 IF ACTION="Q"
QUIT
+193 IF ACTION="D"
KILL FDA(801.412,IENS)
QUIT
+194 SET DIC=FILENUM
+195 SET DIC(0)="AEMNQ"
+196 SET DIC("S")="I ""EG""[$P(^PXRMD(801.41,Y,0),U,4)"
+197 SET Y=-1
+198 FOR
IF +Y'=-1
QUIT
Begin DoDot:3
+199 ;If this is being called during a KIDS install we need echoing on.
+200 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EON")
+201 DO ^DIC
+202 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EOFF")
+203 IF $DATA(DUOUT)
SET Y=""
QUIT
+204 IF Y=-1
DO BMES^XPDUTL("You must input a replacement!")
End DoDot:3
+205 IF Y=""
SET ACTION="Q"
QUIT
+206 IF Y'=""
SET FDA(801.412,IENS,2)=$PIECE(Y,U,2)
End DoDot:2
End DoDot:1
IF ACTION="Q"
KILL FDA
SET PXRMDONE=1
QUIT
+207 ;Process Result Groups
+208 FOR
SET IENS=$ORDER(FDA(801.41121,IENS))
IF IENS=""
QUIT
Begin DoDot:1
+209 SET PT01=$GET(FDA(801.41121,IENS,.01))
IF PT01=""
QUIT
+210 SET FILENUM=801.41
SET NEWNAM=$GET(NAMECHG(FILENUM,PT01))
+211 IF NEWNAM'=""
Begin DoDot:2
+212 SET FDA(801.41121,IENS,2)=NEWNAM
SET PT01=NEWNAM
End DoDot:2
+213 SET IEN=$$EXISTS^PXRMEXIU(FILENUM,PT01)
+214 IF IEN=0
Begin DoDot:2
+215 ;Get replacement
+216 NEW DIC,DIR,DUOUT,MSG,X,Y
+217 SET MSG(1)=" "
+218 SET MSG(2)="RESULT GROUP entry "_PT01_" does not exist."
+219 DO MES^XPDUTL(.MSG)
+220 SET ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
+221 IF ACTION="S"
SET ACTION="Q"
+222 IF ACTION="Q"
QUIT
+223 IF ACTION="D"
KILL FDA(801.41121,IENS)
QUIT
+224 SET DIC=FILENUM
+225 SET DIC(0)="AEMNQ"
+226 SET DIC("S")="I ""S""[$P(^PXRMD(801.41,Y,0),U,4)"
+227 SET Y=-1
+228 FOR
IF +Y'=-1
QUIT
Begin DoDot:3
+229 ;If this is being called during a KIDS install we need echoing on.
+230 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EON")
+231 DO ^DIC
+232 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EOFF")
+233 IF $DATA(DUOUT)
SET Y=""
QUIT
+234 IF Y=-1
DO BMES^XPDUTL("You must input a replacement!")
End DoDot:3
+235 IF Y=""
SET ACTION="Q"
QUIT
+236 IF Y'=""
SET FDA(801.41121,IENS,.01)=$PIECE(Y,U,2)
End DoDot:2
End DoDot:1
IF ACTION="Q"
KILL FDA
SET PXRMDONE=1
QUIT
+237 QUIT
+238 ;
+239 ;===============================================
+240 ;Convert ICD9 codes to `ien format
ICD9(CODE) ;
+1 NEW IEN
+2 SET IEN=$$FIND1^DIC(80,"","AMX",$PIECE(CODE,".",2,99))
+3 IF 'IEN
QUIT ""
+4 QUIT IEN
+5 ;
SETWARN(TEXT) ;
+1 SET TEXT(1)="PREVIOUSLY THE DIALOG WAS SET TO BOTH CURRENT AND HISTORICAL ENCOUNTERS."
+2 SET TEXT(2)="DIALOG IS NOW SET TO CURRENT ENCOUNTER ONLY."
+3 SET TEXT(3)="REVIEW THE DIALOG BEFORE USING IN CPRS."
+4 QUIT
+5 ;
TAXARRAY(FINDING,CNT,ARRAY) ;
+1 ; add to code list to create a new taxonomy
+2 NEW CODE,CODESYS,IEN
+3 SET CODESYS=$PIECE(FINDING,".")
SET CODE=$PIECE(FINDING,".",2,99)
+4 IF $PIECE(CODESYS,".")'["ICD9"
IF $PIECE(CODESYS,".")'["CPT"
QUIT
+5 SET CODESYSN=$SELECT(CODESYS[9:"ICD",1:"CPT")
+6 SET IEN=$$EXISTS^PXRMEXIU($SELECT(CODESYSN="ICD":80,1:81),CODE)
+7 SET CNT=CNT+1
SET ARRAY("CODE",CODESYSN,IEN)="I"_U_1
+8 QUIT
+9 ;
TAXCONV(FDA,IENS) ;
+1 ; FINDING ITEM FDA(801.41,IENS,15)
+2 ; ADDITIONAL FINDINGS FDA(801.4118,IENS)
+3 NEW ADDIENS,ARRAY,CNT,ERROR,FINDING,FINDS,ISFNDFLD,LAST,NAME,OCNT,TAX,TAXNAME,TEMP,TFINDS
+4 SET ISFNDFLD=0
SET CNT=0
+5 ;if finding is taxonomy add the correct fields to the element
+6 SET FINDING=$GET(FDA(801.41,IENS,15))
+7 IF $PIECE(FINDING,".")="TX"
DO TAXCONV1(.FDA,IENS,FINDING)
QUIT
+8 ;
+9 IF FINDING'=""
Begin DoDot:1
+10 DO TAXARRAY(FINDING,.CNT,.ARRAY)
+11 ;if array defined then finding has a code kill the node off.
+12 IF $DATA(ARRAY)
SET ISFNDFLD=1
KILL FDA(801.41,IENS,15)
End DoDot:1
+13 ;loop through additional findings
+14 SET FINDS=""
FOR
SET FINDS=$ORDER(FDA(801.4118,FINDS))
IF FINDS=""
QUIT
Begin DoDot:1
+15 SET FINDING=FDA(801.4118,FINDS,.01)
+16 SET OCNT=CNT
DO TAXARRAY(FINDING,.CNT,.ARRAY)
IF CNT>OCNT
SET TFINDS(FINDS)=""
End DoDot:1
+17 ;kill off additional findings that are codes
+18 SET ADDIENS=""
+19 SET FINDS=""
FOR
SET FINDS=$ORDER(TFINDS(FINDS))
IF FINDS=""
QUIT
Begin DoDot:1
+20 KILL FDA(801.4118,FINDS)
+21 IF ADDIENS=""
SET ADDIENS=FINDS
End DoDot:1
+22 IF '$DATA(ARRAY)
QUIT
+23 ;build values to crate a new taxonomy
+24 SET NAME=$GET(FDA(801.41,IENS,.01))
+25 SET TEMP=$$RTAXNAME^PXRMDUTL(NAME)
+26 SET ARRAY("NAME")=TEMP
+27 SET ARRAY("COUNT")=CNT
+28 SET ARRAY("CLASS")=$GET(FDA(801.41,IENS,100))
+29 SET ARRAY("SOURCE")="Exchange installed of dialog "_NAME
+30 ;create new taxonomy API
+31 SET TAX=$$CRETAX^PXRMTXIM("E",.ARRAY,.ERROR)
+32 IF $DATA(ERROR)
Begin DoDot:1
+33 IF $GET(TAX)=0
DO BMES^XPDUTL("ERROR: Taxonomy could not be created for dialog "_NAME_".")
HANG 1
QUIT
+34 DO BMES^XPDUTL("ERROR: failed to add all the codes to the Taxonomy "_TEMP_". The codes that could not be added are:")
+35 DO BMES^XPDUTL(.ERROR)
+36 HANG 1
End DoDot:1
QUIT
+37 SET TAXNAME=$PIECE($GET(^PXD(811.2,TAX,0)),U)
+38 DO BMES^XPDUTL("Taxonomy "_TAXNAME_" created")
HANG 1
+39 IF ISFNDFLD=1
Begin DoDot:1
+40 SET FDA(801.41,IENS,15)="TX.`"_TAX
+41 SET FDA(801.41,IENS,123)="NO PICK LIST"
End DoDot:1
QUIT
+42 SET FINDS=$ORDER(FDA(801.4118,""),-1)
+43 SET LAST=$ORDER(FDA(801.44,""),-1)
IF LAST=""
QUIT
+44 SET TEMP=$PIECE($PIECE(LAST,"+",2),",")+1
SET TEMP="+"_TEMP
+45 SET FDA(801.4118,ADDIENS,.01)="TX.`"_TAX
+46 QUIT
+47 ;
TAXCONV1(FDA,IENS,FINDING) ;
+1 NEW CNT,CPTSTATUS,DEFAULT,ENC,ENCTYPE,IEN,NODECNT,PROMPTS,POVSTATUS,START,TAX,TEXT,TAXIEN,TDX,TPR,TYPE,VALUE,X
+2 ;if taxonomy fields defined then quit
+3 IF ($GET(FDA(801.41,IENS,123))'="")
QUIT
+4 ;if group set to not display a pick list.
+5 IF FDA(801.41,IENS,4)["group"
SET FDA(801.41,IENS,123)="N"
QUIT
+6 SET TAX=$PIECE(FINDING,".",2)
+7 SET FDA(801.41,IENS,123)="ALL"
+8 ;
+9 SET TAXIEN=$ORDER(^PXD(811.2,"B",TAX,""))
IF TAXIEN'>0
QUIT
+10 ;determine Taxonomy Type
+11 SET TDX=$$TOK^PXRMDTAX(TAXIEN,"POV")
+12 SET TPR=$$TOK^PXRMDTAX(TAXIEN,"CPT")
+13 DO SETWARN(.TEXT)
+14 ;build default array for taxonomy
+15 SET CPTSTATUS=$$GETSTAT^PXRMDTAX("CPT")
SET POVSTATUS=$$GETSTAT^PXRMDTAX("POV")
+16 IF TDX=1
DO GETTAXDF^PXRMDTAX(.DEFAULT,"POV",$SELECT(POVSTATUS=2:1,1:0))
+17 IF TPR=1
DO GETTAXDF^PXRMDTAX(.DEFAULT,"CPT",$SELECT(CPTSTATUS=2:1,1:0))
+18 IF TDX
IF TPR
Begin DoDot:1
+19 IF CPTSTATUS=POVSTATUS
IF POVSTATUS=2
SET FDA(801.41,IENS,13)="2"
QUIT
+20 SET FDA(801.41,IENS,13)="@"
+21 IF CPTSTATUS=0!(POVSTATUS=0)
DO BMES^XPDUTL(.TEXT)
End DoDot:1
+22 IF TDX
IF TPR=0
Begin DoDot:1
+23 IF POVSTATUS=2
SET FDA(801.41,IENS,13)="2"
QUIT
+24 SET FDA(801.41,IENS,13)="@"
IF POVSTATUS=0
DO BMES^XPDUTL(.TEXT)
End DoDot:1
+25 IF TDX=0
IF TPR=1
Begin DoDot:1
+26 IF CPTSTATUS=2
SET FDA(801.41,IENS,13)="2"
QUIT
+27 SET FDA(801.41,IENS,13)="@"
IF CPTSTATUS=0
DO BMES^XPDUTL(.TEXT)
End DoDot:1
+28 SET NODECNT=$ORDER(FDA(801.44,""),-1)
IF NODECNT=""
QUIT
+29 ;
+30 ;build encounter tax field
+31 FOR TYPE="POV","CPT"
Begin DoDot:1
+32 IF TYPE="POV"
IF TDX=0
QUIT
+33 IF TYPE="CPT"
IF TPR=0
QUIT
+34 IF TYPE="POV"
SET X=141
+35 IF TYPE="CPT"
SET X=142
+36 SET VALUE=$$ADDTAXF1^PXRMDTAX(TYPE,.DEFAULT)
+37 SET FDA(801.41,IENS,X)=VALUE
+38 ;
+39 ;build prompt array from default list
+40 SET TYPE=""
FOR
SET TYPE=$ORDER(DEFAULT(TYPE))
IF TYPE=""
QUIT
Begin DoDot:2
+41 ;I TPR=0,CODE="CPT" Q
+42 ;I TDX=0,CODE="POV" Q
+43 SET CNT=0
FOR
SET CNT=$ORDER(DEFAULT(TYPE,"ADDFIND",CNT))
IF CNT'>0
QUIT
Begin DoDot:3
+44 SET NODE=DEFAULT(TYPE,"ADDFIND",CNT)
SET IEN=$PIECE(NODE,U)
+45 IF $DATA(PROMPTS(IEN))>0
IF $LENGTH(PROMPTS(IEN),U)<$LENGTH(NODE,U)
SET PROMPTS(IEN)=NODE
+46 SET PROMPTS(IEN)=NODE
End DoDot:3
End DoDot:2
End DoDot:1
+47 ;
+48 IF $GET(FDA(801.41,IENS,122))="YES"
KILL FDA(801.41,IENS,122)
QUIT
+49 IF $DATA(FDA(801.412))
QUIT
+50 ;
+51 ;add prompts to the dialog element.
+52 SET START=0
SET IEN=0
SET CNT=0
SET DNUM=0
+53 SET IEN=0
SET CNT=0
FOR
SET IEN=$ORDER(PROMPTS(IEN))
IF IEN'>0
QUIT
Begin DoDot:1
+54 SET START=START+1
SET DNUM=DNUM+1
+55 SET NAME=$PIECE($GET(^PXRMD(801.41,IEN,0)),U)
+56 SET NODE=PROMPTS(IEN)
SET CNT=$LENGTH(NODE,U)
+57 IF $PIECE(NODE,U,3)>0
QUIT
+58 SET NODECNT=NODECNT+1
+59 SET FDA(801.412,"+"_NODECNT_","_IENS,.01)=START
+60 SET FDA(801.412,"+"_NODECNT_","_IENS,2)="`"_IEN
+61 IF CNT=1
QUIT
+62 FOR NUM=2:1:CNT
Begin DoDot:2
+63 SET VALUE=$PIECE(NODE,U,NUM)
IF $GET(VALUE)=""
QUIT
+64 SET FIELD=$SELECT(NUM=2:9,NUM=4:.01,NUM=5:6,NUM=6:7,NUM=7:8,1:"")
IF $GET(FIELD)=""
QUIT
+65 IF FIELD>6
SET VALUE=$SELECT(VALUE=1:"YES",1:"NO")
+66 SET FDA(801.412,"+"_NODECNT_","_IENS,FIELD)=VALUE
End DoDot:2
End DoDot:1
+67 QUIT
+68 ;
+69 ;===============================================
TIURPL(SRCH,WP,NAMEGHC,FILENUM) ;Replace TIU templates whose names have
+1 ;changed.
+2 NEW IND,RS,TEXT,TS,TYPE
+3 IF FILENUM=8927.1
SET TYPE="TIU TEMPLATE"
+4 IF '$TEST
SET TYPE="TIU OBJECT"
+5 SET IND=1
+6 FOR
SET TEXT=$GET(@WP@(IND))
IF TEXT=""
QUIT
Begin DoDot:1
+7 IF TEXT[SRCH
Begin DoDot:2
+8 SET TS=""
+9 FOR
SET TS=$ORDER(NAMECHG(FILENUM,TS))
IF TS=""
QUIT
Begin DoDot:3
+10 SET RS=NAMECHG(FILENUM,TS)
IF TEXT'[TS
QUIT
+11 SET @WP@(IND)=$$STRREP^PXRMUTIL(TEXT,TS,RS)
+12 ;Save the replacement information for the history.
+13 SET ^TMP("PXRMEXIA",$JOB,"DIATIU",TYPE,TS)=RS
+14 SET ^TMP("PXRMEXIA",$JOB,"DIATIU",TYPE,TS,DNAM)=""
End DoDot:3
End DoDot:2
+15 SET IND=IND+1
End DoDot:1
+16 QUIT
+17 ;
