PXRMDTAX ; SLC/AGP - Reminder Dialog Taxonomy Field editor/List Manager ;Jun 22, 2021@08:09:50
;;2.0;CLINICAL REMINDERS;**26,47,65**;Feb 04, 2005;Build 438
;
;ADDTAXF1(FIELD,CODE,ARRAY) ;
ADDTAXF1(CODE,ARRAY) ;
N CURVALUE,PROMPT,RESULT,SARRAY,TEMP,TYPE,X,Y
S CURVALUE=$$GETTEXT^PXRMDTAX(.ARRAY,CODE)
;I CURVALUE="" S CURVALUE="Selectable "_$S(FIELD=2:"current ",FIELD=3:"historical ",1:"")_$S($E(TEMP)="d":TEMP_"es",1:TEMP_"s")_" codes"
Q CURVALUE
;
;central location for building array of codes when determine what codes go with an
;encounter type
BLDCODE(TYPE,CODESYS) ;
I TYPE="ALL" S (CODESYS("ICD"),CODESYS("10D"),CODESYS("CPT"),CODESYS("CPC"))="",CODESYS("SCT")="" Q
I TYPE="POV" S (CODESYS("ICD"),CODESYS("10D"))="" Q
I TYPE="CPT" S (CODESYS("CPT"),CODESYS("CPC"))="" Q
;I TYPE="SC" S CODESYS("SCT")=""
Q
;
;build FDA array for Taxonomy Fields multiple
BLDFDA(CODE,IEN,FDA,DEFAULT) ;
N DA,ENCTYPE,FIELD,IENS,NODEIEN,RESULT,TEMP,VALUE,X
S X=$S(CODE="POV":141,CODE="CPT":142,1:153)
S VALUE=$$TAXDIR(X,CODE,IEN,.DEFAULT) I VALUE[U Q VALUE
S FDA(801.41,IEN_",",X)=VALUE
Q VALUE
;
CHECKER(DIEN,TIEN,FIELD,OUTPUT) ;
N CNT,FAIL,NAME,NODE,RESULT,TAXSEL,TDX,TDXNODE,TNAME,TPR,TPRNODE,TSCT,TSCNODE,TYPE
S FAIL=""
S NODE=$G(^PXRMD(801.41,DIEN,0)),NAME=$P(NODE,U),TYPE=$S($P(NODE,U,4)="G":"Group",1:"Element")
S TNAME=$P($G(^PXD(811.2,TIEN,0)),U)
I $P($G(^PXD(811.2,TIEN,0)),U,6)=1 S OUTPUT(1)="Dialog "_TYPE_" "_NAME_" contains an inactive taxonomy "_TNAME_".",FAIL="W" Q FAIL
I '$D(^PXD(811.2,TIEN,20,"AUID")) S OUTPUT(1)="Dialog "_TYPE_" "_NAME_" contains a taxonomy "_TNAME_" that does not have codes marked to be used in a dialog.",FAIL=$S(FIELD="F":"F",1:"W") I FIELD'="" Q FAIL
;
S TAXSEL=$P($G(^PXRMD(801.41,DIEN,"TAX")),U)
S TDX=$$TOK(TIEN,"POV"),TPR=$$TOK(TIEN,"CPT"),TSC=$$TOK(TIEN,"SC")
;I TYPE="Group",TDX,TPR,TAXSEL'["N" S OUTPUT(1)="Dialog "_TYPE_" "_NAME_" cannot have a taxonomy selection field value other than 'No Pick List'.",FAIL="F" Q FAIL
;.I TAXSEL'["N" S OUTPUT(1)="Dialog "_TYPE_" "_NAME_" cannot have a taxonomy selection field value other than 'No Pick List'.",FAIL="F"
I TAXSEL="N" Q FAIL
S TDXNODE=$S($P($G(^PXRMD(801.41,DIEN,"POV")),U)'="":1,1:0),TPRNODE=$S($P($G(^PXRMD(801.41,DIEN,"CPT")),U)'="":1,1:0)
S TSCNODE=$S($P($G(^PXRMD(801.41,DIEN,"SC")),U)'="":1,1:0)
S CNT=0
I TAXSEL="A",TDX,TPR D Q FAIL
.S RESULT=$$CHCKCOMP(TDXNODE,TDX,"POV",NAME) I RESULT'="" S FAIL="W",CNT=CNT+1,OUTPUT(CNT)=RESULT
.S RESULT=$$CHCKCOMP(TPRNODE,TPR,"CPT",NAME) I RESULT'="" S FAIL="W",CNT=CNT+1,OUTPUT(CNT)=RESULT
.S RESULT=$$CHCKCOMP(TSCNODE,TSC,"SC",NAME) I RESULT'="" S FAIL="W",CNT=CNT+1,OUTPUT(CNT)=RESULT
;I TAXSEL="D" S RESULT=$$CHCKCOMP(TDXNODE,TDX,"POV",NAME) I RESULT'="" S FAIL="W",CNT=CNT+1,OUTPUT(CNT)=RESULT
;I TAXSEL="P" S RESULT=$$CHCKCOMP(TPRNODE,TPR,"CPT",NAME) I RESULT'="" S FAIL="W",CNT=CNT+1,OUTPUT(CNT)=RESULT
I $$HASACT(TIEN)=0 S FAIL="W",CNT=CNT+1,OUTPUT(CNT)="Taxonomy "_TNAME_" does not contain active codes for "_$$FMTE^XLFDT(DT)
Q FAIL
;
CHCKCOMP(DNODE,TNODE,TYPE,NAME) ;
N NODE S NODE=$S(TYPE="POV":"diagnosis",TYPE="SC":"standard codes",1:"procedure")
I DNODE=1,TNODE=0 Q "Dialog element "_NAME_" "_NODE_" Header Text is defined, but the taxonomy does not have "_NODE_" codes marked to be used in a dialog."
I DNODE=0,TNODE=1 Q "Dialog element "_NAME_" "_NODE_" Header Text is not defined, but the taxonomy does have "_NODE_" codes marked to be used in a dialog."
Q ""
;
;write out code display used by List Manager
CODES(TIEN,CODES,NLINE,HIST,ISMAIL) ;
N BDATE,CODE,DATE,DATES,DESC,DTEXT,EDATE,NLINES,STR,SUB
N TAB,TEXT,TEXTIN,TEXTOUT,X
;
S SUB=""
F S SUB=$O(CODES(SUB)) Q:SUB="" D
.S CODE=$P(CODES(SUB),U,2),DESC=$P(CODES(SUB),U,3)
.S BDATE=$$FMTE^XLFDT($P($G(CODE),":",2))
.S EDATE=$S($P($G(CODE),":",3)'="":$$FMTE^XLFDT($P($G(CODE),":",3)),1:"")
.S DATE=BDATE_"-"_EDATE
.S STR=$$LJ^XLFSTR($P($G(CODE),":"),8)
.S STR=STR_DESC
.S TEXTIN(1)=STR
.D FORMAT^PXRMTEXT(1,$S(ISMAIL:35,1:44),1,.TEXTIN,.NLINES,.TEXTOUT)
.F X=1:1:NLINES D
..S DTEXT=$S(X=1:$$LJ^XLFSTR(TEXTOUT(X),$S(ISMAIL=1:38,1:45))_DATE,1:TEXTOUT(X))
..S NLINE=NLINE+1
..S ^TMP(NODE,$J,NLINE,0)=$J("",15)_DTEXT
Q
;
;general field delete sub-routine
DELFIELD(IENS,SUB,FIELD) ;Delete a field.
N FDA,MSG
S FDA(SUB,IENS,FIELD)="@"
D FILE^DIE("","FDA","MSG")
I $D(MSG) W !,"Error in delete",! D AWRITE^PXRMUTIL("MSG")
Q
;
;Cross-reference delete when deleting Taxonomy fields in a dialog
DELLOG(DA,FIELD,OLD,NEW) ;
I OLD="" Q
N IENS,POVIEN,PROCIEN
I FIELD=123 D Q
.I NEW=""!(NEW="N") D Q
..S IENS=DA_"," D DELFIELD(IENS,801.41,141)
..S IENS=DA_"," D DELFIELD(IENS,801.41,142)
.I NEW="D" S IENS=DA_"," D Q
..D DELFIELD(IENS,801.41,142)
..D DELFIELD(IENS,801.41,153)
.I NEW="P" S IENS=DA_"," D Q
..D DELFIELD(IENS,801.41,141)
..D DELFIELD(IENS,801.41,153)
.I NEW="S" S IENS=DA_"," D Q
..D DELFIELD(IENS,801.41,141)
..D DELFIELD(IENS,801.41,142)
Q
;
GMPARAMS(TIEN) ;Return Minimum Value, Maximum Value, Maximum Decimals, and
;UCUM pointer for a taxonomy.
N IEN,N1,RESULT
S RESULT=$G(^PXD(811.2,TIEN,220))
S IEN=$P(RESULT,U,4) I IEN D
. S RESULT=RESULT_U_$G(^LEX(757.5,IEN,0))
. S N1=$P($G(^LEX(757.5,IEN,1)),U,1)
. I "^(^{^[^"'[(U_$E(N1)_U) S N1="("_N1_")"
. I N1'="" S RESULT=RESULT_" "_N1
Q RESULT
;
GETSTAT(TYPE) ;
N HIST,RESULT,STATUS
S RESULT=0
S IEN=$O(^PXRMD(801.45,"B",TYPE,"")) I IEN'>0 Q RESULT
I '$D(^PXRMD(801.45,IEN,1,"B",2)) S RESULT=1 Q RESULT
S HIST=$O(^PXRMD(801.45,IEN,1,"B",2,"")) I HIST'>0 S RESULT=1 Q RESULT
I $P($G(^PXRMD(801.45,IEN,1,HIST,0)),U,2)=1 S RESULT=1 Q RESULT
S RESULT=2
S STATUS=0 F S STATUS=$O(^PXRMD(801.45,IEN,1,"B",STATUS)) Q:STATUS'>0!(RESULT<2) I STATUS'=2 S RESULT=0
Q RESULT
;
;this returns the default values from file 801.45 for POV or Procedure
;codes.
;DEFAULT(TYPE,pointer to file 801.9)=default
;DEFAULT(TYPE,pointer to file 801.9,ADDFIND,n)=additional finding node
GETTAXDF(DEFAULT,TYPE,ISHIST) ;
N CNT,IEN,FIND,STATUS
S IEN=$O(^PXRMD(801.45,"B",TYPE,"")) I IEN'>0 Q
;get resolution status
S CNT=0 F S CNT=$O(^PXRMD(801.45,IEN,1,CNT)) Q:CNT'>0 D
.S STATUS=$P($G(^PXRMD(801.45,IEN,1,CNT,0)),U)
.I ISHIST=1,STATUS'=2 Q
.I ISHIST=0,STATUS=2 Q
.;get prefix and suffix text
.S DEFAULT(TYPE,"PREFIX")=$G(^PXRMD(801.45,IEN,1,CNT,3))
.S DEFAULT(TYPE,"SUFFIX")=$G(^PXRMD(801.45,IEN,1,CNT,4))
.;get additional findings
.S FIND=0 F S FIND=$O(^PXRMD(801.45,IEN,1,CNT,5,FIND)) Q:FIND'>0 D
..S DEFAULT(TYPE,"ADDFIND",FIND)=$G(^PXRMD(801.45,IEN,1,CNT,5,FIND,0))
Q
;
;Returns the default taxonomy checkbox header for the Encounter Type
GETTEXT(VALUES,TYPE) ;
;GETTEXT(VALUES,TYPE,CURR) ;
N ENCTYPE,IEN,TEXT
S TEXT=""
S TEXT=$G(VALUES(TYPE,"PREFIX"))_$G(VALUES(TYPE,"SUFFIX"))
Q TEXT
;
HASACT(TIEN) ;
N SYS,CODE,SDATE,EDATE,START,TODAY,FOUND,END
S TODAY=DT+1,FOUND=0
S SYS="" F S SYS=$O(^PXD(811.2,TIEN,20,"AUID",SYS)) Q:SYS=""!(FOUND=1) D
.S CODE="" F S CODE=$O(^PXD(811.2,TIEN,20,"AUID",SYS,CODE)) Q:CODE=""!(FOUND=1) D
..S SDATE=""
..F S SDATE=$O(^PXD(811.2,TIEN,20,"AUID",SYS,CODE,SDATE)) Q:SDATE=""!(FOUND=1) D
...S START=SDATE-1,EDATE=""
...F S EDATE=$O(^PXD(811.2,TIEN,20,"AUID",SYS,CODE,SDATE,EDATE)) Q:EDATE=""!(FOUND=1) D
....S END=$S(EDATE="DT":DT+1,1:EDATE+1) I DT>START,DT<END S FOUND=1 Q
Q FOUND
;
PRINT(TEXTIN,NIN) ;
N LINE,NOUT,TEXTOUT
D FORMAT^PXRMTEXT(1,75,NIN,.TEXTIN,.NOUT,.TEXTOUT)
D MES^XPDUTL(.TEXTOUT)
Q
;
;Builds a list of prompts associated with the taxonomy finding types
;Prompts the user to add the prompts to the dialog editor. Does not prompt if prompts
;are already defined to the element.
PROMPTS(DA,SEL,DEFAULT,FDA,IENCNT) ;
N CNT,CODE,DIR,DNUM,ENC,EXTVAL,FIELD,IEN,IENS,NAME,NODE,NUM,PROMPT,PROMPTS,START,VALUE,X,Y
I $D(^PXRMD(801.41,DA,10)) Q 0
S CODE="" F S CODE=$O(DEFAULT(CODE)) Q:CODE="" D
.I SEL="P"&(CODE="POV"!(CODE="SC")) Q
.I SEL="D"&(CODE="CPT"!(CODE="SC")) Q
.I SEL="S"&(CODE="CPT"!(CODE="POV")) Q
.S CNT=0 F S CNT=$O(DEFAULT(CODE,"ADDFIND",CNT)) Q:CNT'>0 D
..S NODE=DEFAULT(CODE,"ADDFIND",CNT)
..S IEN=$P(NODE,U)
..I $D(^PXRMD(801.41,DA,10,"D",IEN))>0 Q
..I $D(PROMPTS(IEN))>0 I $L(PROMPTS(IEN),U)<$L(NODE,U) S PROMPTS(IEN)=NODE
..S PROMPTS(IEN)=NODE
;
I '$D(PROMPTS) Q 0
S START=+$O(^PXRMD(801.41,DA,10,""),-1)
S DNUM=0
W !,"Default prompts for the taxonomy:"
S IEN=0,CNT=0 F S IEN=$O(PROMPTS(IEN)) Q:IEN'>0 D
.S CNT=CNT+1,START=START+1,DNUM=DNUM+1
.S IENCNT=IENCNT+1,IENS="+"_IENCNT_","_DA_","
.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 FDA(801.412,IENS,.01)=START
.S FDA(801.412,IENS,2)=IEN
.W !,"Prompt: "_NAME
.I CNT=1 Q
.F NUM=2:1:CNT D
..I NUM=3 Q
..I NUM=4 Q
..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
..S FDA(801.412,IENS,FIELD)=VALUE
..S PROMPT=$S(FIELD=.01:"Sequence",FIELD=6:"Override Prompt Caption",FIELD=7:"Start New Line",FIELD=8:"Exclude From PN Text",FIELD=9:"Required")
..I $G(PROMPT)="" Q
..I FIELD=6 S EXTVAL=VALUE
..I FIELD>6 S EXTVAL=$S(VALUE=1:"Yes",1:"No")
..W !," "_PROMPT_": "_EXTVAL
;
I CNT=0 W !,"None" Q 0
S DIR(0)="S^Y:Yes;N:No"
S DIR("A")="Add Prompts to the dialog"
S DIR("B")="Yes"
D ^DIR
I Y[U K FDA(801.412) Q 0
I Y="N" K FDA(801.412)
Q 1
;
;Prompts the user for values for the fields in the Taxonomy Fields multiple.
;Builds default values from existing values or from file 801.45
TAXDIR(FIELD,CODE,DA,ARRAY) ;
N DIR,CURVALUE,PROMPT,RESULT,SARRAY,TEMP,TYPE,X,Y
S CURVALUE=""
S DIR("A")=$S(CODE="POV":"Diagnosis Header",CODE="SC":"Standard Codes Header",1:"Procedure Header")
S DIR(0)="F^1:80"
S TEMP=$S(CODE="POV":"diagnosis",CODE="SC":"Standard Codes",1:"Procedure")
I +DA>0 S CURVALUE=$$GET1^DIQ(801.41,DA_",",FIELD)
I CURVALUE="" D
.S CURVALUE=$$GETTEXT(.ARRAY,CODE)
.I CURVALUE="" S CURVALUE="Selectable "_$S($E(TEMP)="d":TEMP_"es",TEMP="Standard Codes":TEMP,1:TEMP_"s")_$S(TEMP="Standard Codes":"",1:" codes")
S DIR("B")=CURVALUE
D ^DIR
Q Y
;
;main taxonomy fields editor entry point. Returns ^ or ^^ or 1 is fields are answer.
TAXDIAL(IEN,FIND) ;
;Protect FileMan variables
N D,D0,DA,DC,DDES,DE,DG,DH,DI,DIC,DIDEL,DIE,DIEDA,DIEL,DIEN,DIR,DIETMP
N DIEXREF,DIFLD,DIEIENS,DINUSE,DIP,DISYS,DK,DL,DM,DP,DQ,DR,DU
;
N DEF,DEFAULT,DXTYPE,FDA,FDAIEN,HTEXT,IENCNT,IENS,ISHIST,MSG,NODEIEN,NAME,NONE
N PRTYPE,RESULT,STR,TAXIEN,TAXSEL,TDX,TPR,TSC,VALUE,X,Y
;
ENTAXDL ;
;
S RESULT=1
I FIND'["PXD(811.2" Q 0
S DA=IEN,TAXIEN=+FIND I TAXIEN'>0 Q 0
S ISHIST=$S($P($G(^PXRMD(801.41,IEN,1)),U,3)=2:1,1:0)
S TDX=$$TOK(TAXIEN,"POV")
S TPR=$$TOK(TAXIEN,"CPT")
S TSC=$$TOK(TAXIEN,"SC")
S DEF=$P($G(^PXRMD(801.41,DA,"TAX")),U)
S DIR(0)="S^A:All;"
I $G(DEF)="" S DEF="N"
I TDX=1 S DIR(0)=DIR(0)_"D:ICD Diagnoses Only;"
I TPR=1 S DIR(0)=DIR(0)_"P:CPT Procedures Only;"
I TSC=1 S DIR(0)=DIR(0)_"S:Standard Codes Only;"
S DIR(0)=DIR(0)_";N:No Pick List"
D HELP^PXRMDTX1(.HTEXT)
I DIR(0)'[DEF S DEF=""
S DIR("A")="Taxonomy Pick List"
S DIR("B")=$S(DEF]"":DEF,1:"A")
S DIR("?")="Select the pick list display value or '^' to quit. Enter ?? for detail help."
S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)"
D ^DIR
I Y[U Q Y
S VALUE=Y
S FDA(801.41,DA_",",123)=VALUE
I VALUE="N" G TAXUPD
I TDX=1 D GETTAXDF(.DEFAULT,"POV",ISHIST)
I TPR=1 D GETTAXDF(.DEFAULT,"CPT",ISHIST)
I TSC=1 D GETTAXDF(.DEFAULT,"SC",ISHIST)
S IENCNT=0
I VALUE="D",TDX=1 S RESULT=$$BLDFDA("POV",IEN,.FDA,.DEFAULT) G ENTAXDL:RESULT=U
I VALUE="P",TPR=1 S RESULT=$$BLDFDA("CPT",IEN,.FDA,.DEFAULT) G ENTAXDL:RESULT=U
I VALUE="S",TSC=1 S RESULT=$$BLDFDA("SC",IEN,.FDA,.DEFAULT) G ENTAXDL:RESULT=U
I VALUE="A" D G TAXDIALX:RESULT="^^" G ENTAXDL:RESULT=U
.I TDX=1 S RESULT=$$BLDFDA("POV",IEN,.FDA,.DEFAULT) I RESULT[U Q
.I TPR=1 S RESULT=$$BLDFDA("CPT",IEN,.FDA,.DEFAULT) I RESULT[U Q
.I TSC=1 S RESULT=$$BLDFDA("SC",IEN,.FDA,.DEFAULT) I RESULT[U Q
;I TPR=1,VALUE="A" S RESULT=$$BLDFDA("CPT",IEN,.FDA,.DEFAULT) G TAXDIALX:RESULT="^^" G ENTAXDL:RESULT=U
;
S RESULT=$$PROMPTS(IEN,VALUE,.DEFAULT,.FDA,.IENCNT) I RESULT[U G TAXDIALX:RESULT="^^" G ENTAXDL:RESULT=U
K MSG
TAXUPD ;
D UPDATE^DIE("","FDA","","MSG")
I $D(MSG) W !,"Error in update",! D AWRITE^PXRMUTIL("MSG")
;
TAXDIALX ;
Q RESULT
;
;This routine is used to display Taxonomy codes in the List Manager view for Dialog Text.
;TODO should we display any codes in Dialog Text view for Additional Findings or Taxonomy Pick List of N, D, P?
TAXDISP(FIEN,SEQ,DIEN,NLINE,NODE,ADDFIND,ISMAIL) ;
N ARRAY,CNT,CODES,CODESYS,FILE,HIST,TIEN,TSEQ
N CNT,DTXT,FNODE,RSUB,TDX,TNAME,TPAR,TPR,TYP
N TCUR,TDTXT,TDHTXT,THIS,TPTXT,TPHTXT,TSC
S TIEN=$P(FIEN,";") Q:TIEN=""
S HIST=0,FILE=""
;Get associated codes
;
;Get taxonomy name
S TNAME=$P($G(^PXD(811.2,TIEN,0)),U,1)
;
;Check what type of taxonomy codes exist
S TDX=$$TOK(TIEN,"POV")
S TPR=$$TOK(TIEN,"CPT")
S TSC=$$TOK(TIEN,"SC")
;
S TAXSEL=$P($G(^PXRMD(801.41,DIEN,"TAX")),U)
I ADDFIND=1 S TAXSEL="N"
;
I TDX D
.D BLDCODE("POV",.CODESYS)
.D CODES^PXRMDLLB(TIEN,.CODESYS,.CODES)
.I '$D(CODES) Q
.S TEXT=$J("",15)_$S(TAXSEL="N":"Diagnoses Codes:",TAXSEL="P":"Procedures Codes:",1:"Selectable Diagnoses Codes:"),TAB=18
.S STR=$$LJ^XLFSTR($G(TEXT),$S(ISMAIL=1:51,1:60))
.S STR=STR_"Activation Periods"
.S NLINE=NLINE+1
.S ^TMP(NODE,$J,NLINE,0)=STR
.D CODES(TIEN,.CODES,.NLINE,HIST,ISMAIL)
.S NLINE=NLINE+1
.S ^TMP(NODE,$J,NLINE,0)=$J("",79)
;
I TPR D
.K CODESYS,CODES
.D BLDCODE("CPT",.CODESYS)
.D CODES^PXRMDLLB(TIEN,.CODESYS,.CODES)
.I '$D(CODES) Q
.S TEXT=$J("",15)_$S(TAXSEL="N":"Procedures Codes:",TAXSEL="D":"Procedures Codes:",1:"Selectable Procedures codes:"),TAB=18
.S STR=$$LJ^XLFSTR($G(TEXT),$S(ISMAIL=1:51,1:60))
.S STR=STR_"Activation Periods"
.S NLINE=NLINE+1
.S ^TMP(NODE,$J,NLINE,0)=STR
.D CODES(TIEN,.CODES,.NLINE,HIST,ISMAIL)
.S NLINE=NLINE+1
.S ^TMP(NODE,$J,NLINE,0)=$J("",79)
;
I TSC D
.K CODESYS,CODES
.D BLDCODE("SC",.CODESYS)
.D CODES^PXRMDLLB(TIEN,.CODESYS,.CODES)
.I '$D(CODES) Q
.S TEXT=$J("",15)_$S(TAXSEL="N":"Procedures Codes:",TAXSEL="D":"Procedures Codes:",1:"Selectable Procedures codes:"),TAB=18
.S STR=$$LJ^XLFSTR($G(TEXT),$S(ISMAIL=1:51,1:60))
.S STR=STR_"Activation Periods"
.S NLINE=NLINE+1
.S ^TMP(NODE,$J,NLINE,0)=STR
.D CODES(TIEN,.CODES,.NLINE,HIST,ISMAIL)
.S NLINE=NLINE+1
.S ^TMP(NODE,$J,NLINE,0)=$J("",79)
Q
;
TAXEDITC(TIEN,TEXT) ;
N DARRAY,DIEN,HEADER,IEN,NAME,OCNT,OUTPUT,RARRAY,RESULT
N TDX,TPR,TAXNODE,TAXSEL,TSC
D FINDDIAL^PXRMFRPT(.DARRAY,"PXD(811.2,",TIEN)
S TEXT(1)="Taxonomy and/or the following dialog(s) have problems."
S TEXT(2)="Correct either the taxonomy or the following dialog(s):"
S CNT=2
I '$D(DARRAY) G TXEDITCX
I '$D(^PXD(811.2,TIEN,20,"AUID")) S TEXT(1)="Taxonomy does not contain codes marked to be used in a dialog. It is assigned to the following dialog(s)." D Q
.S CNT=1,NAME="" F S NAME=$O(DARRAY(NAME)) Q:NAME="" S CNT=CNT+1,TEXT(CNT)=" "_NAME
S TDX=$$TOK(TIEN,"POV"),TPR=$$TOK(TIEN,"CPT"),TSC=$$TOK(TIEN,"SC")
S NAME="" F S NAME=$O(DARRAY(NAME)) Q:NAME="" D
.S IEN=DARRAY(NAME) S RESULT=$$CHECKER(IEN,TIEN,"",.OUTPUT) I RESULT="" Q
.S TEXT(2)="See below for descriptions of the problem(s):"
.N LINE,NIN,NOUT,TEMP
.S NIN=$O(OUTPUT(""),-1)
.D FORMAT^PXRMTEXT(1,75,NIN,.OUTPUT,.NOUT,.TEMP)
.F LINE=1:1:NOUT S CNT=CNT+1,TEXT(CNT)=TEMP(LINE)
TXEDITCX ;
I CNT=2 K TEXT
K ^TMP($J,"DLG FIND")
Q
;
;change to use AUID cross-referenc instead of the selectable node, central location for checking what codes to use
;in a dialog for encounter type.
TOK(TIEN,TYPE) ;Check if selectable codes exist
I TYPE="POV" I $D(^PXD(811.2,TIEN,20,"AUID","ICD"))>0!($D(^PXD(811.2,TIEN,20,"AUID","10D"))>0) Q 1
I TYPE="CPT" I $D(^PXD(811.2,TIEN,20,"AUID","CPT"))>0!($D(^PXD(811.2,TIEN,20,"AUID","CPC"))>0) Q 1
;I TYPE="SC" I $D(^PXD(811.2,TIEN,20,"AUID","SCT"))>0 Q 1
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMDTAX 16279 printed Apr 09, 2024@20:52:46 Page 2
PXRMDTAX ; SLC/AGP - Reminder Dialog Taxonomy Field editor/List Manager ;Jun 22, 2021@08:09:50
+1 ;;2.0;CLINICAL REMINDERS;**26,47,65**;Feb 04, 2005;Build 438
+2 ;
+3 ;ADDTAXF1(FIELD,CODE,ARRAY) ;
ADDTAXF1(CODE,ARRAY) ;
+1 NEW CURVALUE,PROMPT,RESULT,SARRAY,TEMP,TYPE,X,Y
+2 SET CURVALUE=$$GETTEXT^PXRMDTAX(.ARRAY,CODE)
+3 ;I CURVALUE="" S CURVALUE="Selectable "_$S(FIELD=2:"current ",FIELD=3:"historical ",1:"")_$S($E(TEMP)="d":TEMP_"es",1:TEMP_"s")_" codes"
+4 QUIT CURVALUE
+5 ;
+6 ;central location for building array of codes when determine what codes go with an
+7 ;encounter type
BLDCODE(TYPE,CODESYS) ;
+1 IF TYPE="ALL"
SET (CODESYS("ICD"),CODESYS("10D"),CODESYS("CPT"),CODESYS("CPC"))=""
SET CODESYS("SCT")=""
QUIT
+2 IF TYPE="POV"
SET (CODESYS("ICD"),CODESYS("10D"))=""
QUIT
+3 IF TYPE="CPT"
SET (CODESYS("CPT"),CODESYS("CPC"))=""
QUIT
+4 ;I TYPE="SC" S CODESYS("SCT")=""
+5 QUIT
+6 ;
+7 ;build FDA array for Taxonomy Fields multiple
BLDFDA(CODE,IEN,FDA,DEFAULT) ;
+1 NEW DA,ENCTYPE,FIELD,IENS,NODEIEN,RESULT,TEMP,VALUE,X
+2 SET X=$SELECT(CODE="POV":141,CODE="CPT":142,1:153)
+3 SET VALUE=$$TAXDIR(X,CODE,IEN,.DEFAULT)
IF VALUE[U
QUIT VALUE
+4 SET FDA(801.41,IEN_",",X)=VALUE
+5 QUIT VALUE
+6 ;
CHECKER(DIEN,TIEN,FIELD,OUTPUT) ;
+1 NEW CNT,FAIL,NAME,NODE,RESULT,TAXSEL,TDX,TDXNODE,TNAME,TPR,TPRNODE,TSCT,TSCNODE,TYPE
+2 SET FAIL=""
+3 SET NODE=$GET(^PXRMD(801.41,DIEN,0))
SET NAME=$PIECE(NODE,U)
SET TYPE=$SELECT($PIECE(NODE,U,4)="G":"Group",1:"Element")
+4 SET TNAME=$PIECE($GET(^PXD(811.2,TIEN,0)),U)
+5 IF $PIECE($GET(^PXD(811.2,TIEN,0)),U,6)=1
SET OUTPUT(1)="Dialog "_TYPE_" "_NAME_" contains an inactive taxonomy "_TNAME_"."
SET FAIL="W"
QUIT FAIL
+6 IF '$DATA(^PXD(811.2,TIEN,20,"AUID"))
SET OUTPUT(1)="Dialog "_TYPE_" "_NAME_" contains a taxonomy "_TNAME_" that does not have codes marked to be used in a dialog."
SET FAIL=$SELECT(FIELD="F":"F",1:"W")
IF FIELD'=""
QUIT FAIL
+7 ;
+8 SET TAXSEL=$PIECE($GET(^PXRMD(801.41,DIEN,"TAX")),U)
+9 SET TDX=$$TOK(TIEN,"POV")
SET TPR=$$TOK(TIEN,"CPT")
SET TSC=$$TOK(TIEN,"SC")
+10 ;I TYPE="Group",TDX,TPR,TAXSEL'["N" S OUTPUT(1)="Dialog "_TYPE_" "_NAME_" cannot have a taxonomy selection field value other than 'No Pick List'.",FAIL="F" Q FAIL
+11 ;.I TAXSEL'["N" S OUTPUT(1)="Dialog "_TYPE_" "_NAME_" cannot have a taxonomy selection field value other than 'No Pick List'.",FAIL="F"
+12 IF TAXSEL="N"
QUIT FAIL
+13 SET TDXNODE=$SELECT($PIECE($GET(^PXRMD(801.41,DIEN,"POV")),U)'="":1,1:0)
SET TPRNODE=$SELECT($PIECE($GET(^PXRMD(801.41,DIEN,"CPT")),U)'="":1,1:0)
+14 SET TSCNODE=$SELECT($PIECE($GET(^PXRMD(801.41,DIEN,"SC")),U)'="":1,1:0)
+15 SET CNT=0
+16 IF TAXSEL="A"
IF TDX
IF TPR
Begin DoDot:1
+17 SET RESULT=$$CHCKCOMP(TDXNODE,TDX,"POV",NAME)
IF RESULT'=""
SET FAIL="W"
SET CNT=CNT+1
SET OUTPUT(CNT)=RESULT
+18 SET RESULT=$$CHCKCOMP(TPRNODE,TPR,"CPT",NAME)
IF RESULT'=""
SET FAIL="W"
SET CNT=CNT+1
SET OUTPUT(CNT)=RESULT
+19 SET RESULT=$$CHCKCOMP(TSCNODE,TSC,"SC",NAME)
IF RESULT'=""
SET FAIL="W"
SET CNT=CNT+1
SET OUTPUT(CNT)=RESULT
End DoDot:1
QUIT FAIL
+20 ;I TAXSEL="D" S RESULT=$$CHCKCOMP(TDXNODE,TDX,"POV",NAME) I RESULT'="" S FAIL="W",CNT=CNT+1,OUTPUT(CNT)=RESULT
+21 ;I TAXSEL="P" S RESULT=$$CHCKCOMP(TPRNODE,TPR,"CPT",NAME) I RESULT'="" S FAIL="W",CNT=CNT+1,OUTPUT(CNT)=RESULT
+22 IF $$HASACT(TIEN)=0
SET FAIL="W"
SET CNT=CNT+1
SET OUTPUT(CNT)="Taxonomy "_TNAME_" does not contain active codes for "_$$FMTE^XLFDT(DT)
+23 QUIT FAIL
+24 ;
CHCKCOMP(DNODE,TNODE,TYPE,NAME) ;
+1 NEW NODE
SET NODE=$SELECT(TYPE="POV":"diagnosis",TYPE="SC":"standard codes",1:"procedure")
+2 IF DNODE=1
IF TNODE=0
QUIT "Dialog element "_NAME_" "_NODE_" Header Text is defined, but the taxonomy does not have "_NODE_" codes marked to be used in a dialog."
+3 IF DNODE=0
IF TNODE=1
QUIT "Dialog element "_NAME_" "_NODE_" Header Text is not defined, but the taxonomy does have "_NODE_" codes marked to be used in a dialog."
+4 QUIT ""
+5 ;
+6 ;write out code display used by List Manager
CODES(TIEN,CODES,NLINE,HIST,ISMAIL) ;
+1 NEW BDATE,CODE,DATE,DATES,DESC,DTEXT,EDATE,NLINES,STR,SUB
+2 NEW TAB,TEXT,TEXTIN,TEXTOUT,X
+3 ;
+4 SET SUB=""
+5 FOR
SET SUB=$ORDER(CODES(SUB))
if SUB=""
QUIT
Begin DoDot:1
+6 SET CODE=$PIECE(CODES(SUB),U,2)
SET DESC=$PIECE(CODES(SUB),U,3)
+7 SET BDATE=$$FMTE^XLFDT($PIECE($GET(CODE),":",2))
+8 SET EDATE=$SELECT($PIECE($GET(CODE),":",3)'="":$$FMTE^XLFDT($PIECE($GET(CODE),":",3)),1:"")
+9 SET DATE=BDATE_"-"_EDATE
+10 SET STR=$$LJ^XLFSTR($PIECE($GET(CODE),":"),8)
+11 SET STR=STR_DESC
+12 SET TEXTIN(1)=STR
+13 DO FORMAT^PXRMTEXT(1,$SELECT(ISMAIL:35,1:44),1,.TEXTIN,.NLINES,.TEXTOUT)
+14 FOR X=1:1:NLINES
Begin DoDot:2
+15 SET DTEXT=$SELECT(X=1:$$LJ^XLFSTR(TEXTOUT(X),$SELECT(ISMAIL=1:38,1:45))_DATE,1:TEXTOUT(X))
+16 SET NLINE=NLINE+1
+17 SET ^TMP(NODE,$JOB,NLINE,0)=$JUSTIFY("",15)_DTEXT
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
+20 ;general field delete sub-routine
DELFIELD(IENS,SUB,FIELD) ;Delete a field.
+1 NEW FDA,MSG
+2 SET FDA(SUB,IENS,FIELD)="@"
+3 DO FILE^DIE("","FDA","MSG")
+4 IF $DATA(MSG)
WRITE !,"Error in delete",!
DO AWRITE^PXRMUTIL("MSG")
+5 QUIT
+6 ;
+7 ;Cross-reference delete when deleting Taxonomy fields in a dialog
DELLOG(DA,FIELD,OLD,NEW) ;
+1 IF OLD=""
QUIT
+2 NEW IENS,POVIEN,PROCIEN
+3 IF FIELD=123
Begin DoDot:1
+4 IF NEW=""!(NEW="N")
Begin DoDot:2
+5 SET IENS=DA_","
DO DELFIELD(IENS,801.41,141)
+6 SET IENS=DA_","
DO DELFIELD(IENS,801.41,142)
End DoDot:2
QUIT
+7 IF NEW="D"
SET IENS=DA_","
Begin DoDot:2
+8 DO DELFIELD(IENS,801.41,142)
+9 DO DELFIELD(IENS,801.41,153)
End DoDot:2
QUIT
+10 IF NEW="P"
SET IENS=DA_","
Begin DoDot:2
+11 DO DELFIELD(IENS,801.41,141)
+12 DO DELFIELD(IENS,801.41,153)
End DoDot:2
QUIT
+13 IF NEW="S"
SET IENS=DA_","
Begin DoDot:2
+14 DO DELFIELD(IENS,801.41,141)
+15 DO DELFIELD(IENS,801.41,142)
End DoDot:2
QUIT
End DoDot:1
QUIT
+16 QUIT
+17 ;
GMPARAMS(TIEN) ;Return Minimum Value, Maximum Value, Maximum Decimals, and
+1 ;UCUM pointer for a taxonomy.
+2 NEW IEN,N1,RESULT
+3 SET RESULT=$GET(^PXD(811.2,TIEN,220))
+4 SET IEN=$PIECE(RESULT,U,4)
IF IEN
Begin DoDot:1
+5 SET RESULT=RESULT_U_$GET(^LEX(757.5,IEN,0))
+6 SET N1=$PIECE($GET(^LEX(757.5,IEN,1)),U,1)
+7 IF "^(^{^[^"'[(U_$EXTRACT(N1)_U)
SET N1="("_N1_")"
+8 IF N1'=""
SET RESULT=RESULT_" "_N1
End DoDot:1
+9 QUIT RESULT
+10 ;
GETSTAT(TYPE) ;
+1 NEW HIST,RESULT,STATUS
+2 SET RESULT=0
+3 SET IEN=$ORDER(^PXRMD(801.45,"B",TYPE,""))
IF IEN'>0
QUIT RESULT
+4 IF '$DATA(^PXRMD(801.45,IEN,1,"B",2))
SET RESULT=1
QUIT RESULT
+5 SET HIST=$ORDER(^PXRMD(801.45,IEN,1,"B",2,""))
IF HIST'>0
SET RESULT=1
QUIT RESULT
+6 IF $PIECE($GET(^PXRMD(801.45,IEN,1,HIST,0)),U,2)=1
SET RESULT=1
QUIT RESULT
+7 SET RESULT=2
+8 SET STATUS=0
FOR
SET STATUS=$ORDER(^PXRMD(801.45,IEN,1,"B",STATUS))
if STATUS'>0!(RESULT<2)
QUIT
IF STATUS'=2
SET RESULT=0
+9 QUIT RESULT
+10 ;
+11 ;this returns the default values from file 801.45 for POV or Procedure
+12 ;codes.
+13 ;DEFAULT(TYPE,pointer to file 801.9)=default
+14 ;DEFAULT(TYPE,pointer to file 801.9,ADDFIND,n)=additional finding node
GETTAXDF(DEFAULT,TYPE,ISHIST) ;
+1 NEW CNT,IEN,FIND,STATUS
+2 SET IEN=$ORDER(^PXRMD(801.45,"B",TYPE,""))
IF IEN'>0
QUIT
+3 ;get resolution status
+4 SET CNT=0
FOR
SET CNT=$ORDER(^PXRMD(801.45,IEN,1,CNT))
if CNT'>0
QUIT
Begin DoDot:1
+5 SET STATUS=$PIECE($GET(^PXRMD(801.45,IEN,1,CNT,0)),U)
+6 IF ISHIST=1
IF STATUS'=2
QUIT
+7 IF ISHIST=0
IF STATUS=2
QUIT
+8 ;get prefix and suffix text
+9 SET DEFAULT(TYPE,"PREFIX")=$GET(^PXRMD(801.45,IEN,1,CNT,3))
+10 SET DEFAULT(TYPE,"SUFFIX")=$GET(^PXRMD(801.45,IEN,1,CNT,4))
+11 ;get additional findings
+12 SET FIND=0
FOR
SET FIND=$ORDER(^PXRMD(801.45,IEN,1,CNT,5,FIND))
if FIND'>0
QUIT
Begin DoDot:2
+13 SET DEFAULT(TYPE,"ADDFIND",FIND)=$GET(^PXRMD(801.45,IEN,1,CNT,5,FIND,0))
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
+16 ;Returns the default taxonomy checkbox header for the Encounter Type
GETTEXT(VALUES,TYPE) ;
+1 ;GETTEXT(VALUES,TYPE,CURR) ;
+2 NEW ENCTYPE,IEN,TEXT
+3 SET TEXT=""
+4 SET TEXT=$GET(VALUES(TYPE,"PREFIX"))_$GET(VALUES(TYPE,"SUFFIX"))
+5 QUIT TEXT
+6 ;
HASACT(TIEN) ;
+1 NEW SYS,CODE,SDATE,EDATE,START,TODAY,FOUND,END
+2 SET TODAY=DT+1
SET FOUND=0
+3 SET SYS=""
FOR
SET SYS=$ORDER(^PXD(811.2,TIEN,20,"AUID",SYS))
if SYS=""!(FOUND=1)
QUIT
Begin DoDot:1
+4 SET CODE=""
FOR
SET CODE=$ORDER(^PXD(811.2,TIEN,20,"AUID",SYS,CODE))
if CODE=""!(FOUND=1)
QUIT
Begin DoDot:2
+5 SET SDATE=""
+6 FOR
SET SDATE=$ORDER(^PXD(811.2,TIEN,20,"AUID",SYS,CODE,SDATE))
if SDATE=""!(FOUND=1)
QUIT
Begin DoDot:3
+7 SET START=SDATE-1
SET EDATE=""
+8 FOR
SET EDATE=$ORDER(^PXD(811.2,TIEN,20,"AUID",SYS,CODE,SDATE,EDATE))
if EDATE=""!(FOUND=1)
QUIT
Begin DoDot:4
+9 SET END=$SELECT(EDATE="DT":DT+1,1:EDATE+1)
IF DT>START
IF DT<END
SET FOUND=1
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT FOUND
+11 ;
PRINT(TEXTIN,NIN) ;
+1 NEW LINE,NOUT,TEXTOUT
+2 DO FORMAT^PXRMTEXT(1,75,NIN,.TEXTIN,.NOUT,.TEXTOUT)
+3 DO MES^XPDUTL(.TEXTOUT)
+4 QUIT
+5 ;
+6 ;Builds a list of prompts associated with the taxonomy finding types
+7 ;Prompts the user to add the prompts to the dialog editor. Does not prompt if prompts
+8 ;are already defined to the element.
PROMPTS(DA,SEL,DEFAULT,FDA,IENCNT) ;
+1 NEW CNT,CODE,DIR,DNUM,ENC,EXTVAL,FIELD,IEN,IENS,NAME,NODE,NUM,PROMPT,PROMPTS,START,VALUE,X,Y
+2 IF $DATA(^PXRMD(801.41,DA,10))
QUIT 0
+3 SET CODE=""
FOR
SET CODE=$ORDER(DEFAULT(CODE))
if CODE=""
QUIT
Begin DoDot:1
+4 IF SEL="P"&(CODE="POV"!(CODE="SC"))
QUIT
+5 IF SEL="D"&(CODE="CPT"!(CODE="SC"))
QUIT
+6 IF SEL="S"&(CODE="CPT"!(CODE="POV"))
QUIT
+7 SET CNT=0
FOR
SET CNT=$ORDER(DEFAULT(CODE,"ADDFIND",CNT))
if CNT'>0
QUIT
Begin DoDot:2
+8 SET NODE=DEFAULT(CODE,"ADDFIND",CNT)
+9 SET IEN=$PIECE(NODE,U)
+10 IF $DATA(^PXRMD(801.41,DA,10,"D",IEN))>0
QUIT
+11 IF $DATA(PROMPTS(IEN))>0
IF $LENGTH(PROMPTS(IEN),U)<$LENGTH(NODE,U)
SET PROMPTS(IEN)=NODE
+12 SET PROMPTS(IEN)=NODE
End DoDot:2
End DoDot:1
+13 ;
+14 IF '$DATA(PROMPTS)
QUIT 0
+15 SET START=+$ORDER(^PXRMD(801.41,DA,10,""),-1)
+16 SET DNUM=0
+17 WRITE !,"Default prompts for the taxonomy:"
+18 SET IEN=0
SET CNT=0
FOR
SET IEN=$ORDER(PROMPTS(IEN))
if IEN'>0
QUIT
Begin DoDot:1
+19 SET CNT=CNT+1
SET START=START+1
SET DNUM=DNUM+1
+20 SET IENCNT=IENCNT+1
SET IENS="+"_IENCNT_","_DA_","
+21 SET NAME=$PIECE($GET(^PXRMD(801.41,IEN,0)),U)
+22 SET NODE=PROMPTS(IEN)
SET CNT=$LENGTH(NODE,U)
+23 IF $PIECE(NODE,U,3)>0
QUIT
+24 SET FDA(801.412,IENS,.01)=START
+25 SET FDA(801.412,IENS,2)=IEN
+26 WRITE !,"Prompt: "_NAME
+27 IF CNT=1
QUIT
+28 FOR NUM=2:1:CNT
Begin DoDot:2
+29 IF NUM=3
QUIT
+30 IF NUM=4
QUIT
+31 SET VALUE=$PIECE(NODE,U,NUM)
IF $GET(VALUE)=""
QUIT
+32 SET FIELD=$SELECT(NUM=2:9,NUM=4:.01,NUM=5:6,NUM=6:7,NUM=7:8,1:"")
IF $GET(FIELD)=""
QUIT
+33 SET FDA(801.412,IENS,FIELD)=VALUE
+34 SET PROMPT=$SELECT(FIELD=.01:"Sequence",FIELD=6:"Override Prompt Caption",FIELD=7:"Start New Line",FIELD=8:"Exclude From PN Text",FIELD=9:"Required")
+35 IF $GET(PROMPT)=""
QUIT
+36 IF FIELD=6
SET EXTVAL=VALUE
+37 IF FIELD>6
SET EXTVAL=$SELECT(VALUE=1:"Yes",1:"No")
+38 WRITE !," "_PROMPT_": "_EXTVAL
End DoDot:2
End DoDot:1
+39 ;
+40 IF CNT=0
WRITE !,"None"
QUIT 0
+41 SET DIR(0)="S^Y:Yes;N:No"
+42 SET DIR("A")="Add Prompts to the dialog"
+43 SET DIR("B")="Yes"
+44 DO ^DIR
+45 IF Y[U
KILL FDA(801.412)
QUIT 0
+46 IF Y="N"
KILL FDA(801.412)
+47 QUIT 1
+48 ;
+49 ;Prompts the user for values for the fields in the Taxonomy Fields multiple.
+50 ;Builds default values from existing values or from file 801.45
TAXDIR(FIELD,CODE,DA,ARRAY) ;
+1 NEW DIR,CURVALUE,PROMPT,RESULT,SARRAY,TEMP,TYPE,X,Y
+2 SET CURVALUE=""
+3 SET DIR("A")=$SELECT(CODE="POV":"Diagnosis Header",CODE="SC":"Standard Codes Header",1:"Procedure Header")
+4 SET DIR(0)="F^1:80"
+5 SET TEMP=$SELECT(CODE="POV":"diagnosis",CODE="SC":"Standard Codes",1:"Procedure")
+6 IF +DA>0
SET CURVALUE=$$GET1^DIQ(801.41,DA_",",FIELD)
+7 IF CURVALUE=""
Begin DoDot:1
+8 SET CURVALUE=$$GETTEXT(.ARRAY,CODE)
+9 IF CURVALUE=""
SET CURVALUE="Selectable "_$SELECT($EXTRACT(TEMP)="d":TEMP_"es",TEMP="Standard Codes":TEMP,1:TEMP_"s")_$SELECT(TEMP="Standard Codes":"",1:" codes")
End DoDot:1
+10 SET DIR("B")=CURVALUE
+11 DO ^DIR
+12 QUIT Y
+13 ;
+14 ;main taxonomy fields editor entry point. Returns ^ or ^^ or 1 is fields are answer.
TAXDIAL(IEN,FIND) ;
+1 ;Protect FileMan variables
+2 NEW D,D0,DA,DC,DDES,DE,DG,DH,DI,DIC,DIDEL,DIE,DIEDA,DIEL,DIEN,DIR,DIETMP
+3 NEW DIEXREF,DIFLD,DIEIENS,DINUSE,DIP,DISYS,DK,DL,DM,DP,DQ,DR,DU
+4 ;
+5 NEW DEF,DEFAULT,DXTYPE,FDA,FDAIEN,HTEXT,IENCNT,IENS,ISHIST,MSG,NODEIEN,NAME,NONE
+6 NEW PRTYPE,RESULT,STR,TAXIEN,TAXSEL,TDX,TPR,TSC,VALUE,X,Y
+7 ;
ENTAXDL ;
+1 ;
+2 SET RESULT=1
+3 IF FIND'["PXD(811.2"
QUIT 0
+4 SET DA=IEN
SET TAXIEN=+FIND
IF TAXIEN'>0
QUIT 0
+5 SET ISHIST=$SELECT($PIECE($GET(^PXRMD(801.41,IEN,1)),U,3)=2:1,1:0)
+6 SET TDX=$$TOK(TAXIEN,"POV")
+7 SET TPR=$$TOK(TAXIEN,"CPT")
+8 SET TSC=$$TOK(TAXIEN,"SC")
+9 SET DEF=$PIECE($GET(^PXRMD(801.41,DA,"TAX")),U)
+10 SET DIR(0)="S^A:All;"
+11 IF $GET(DEF)=""
SET DEF="N"
+12 IF TDX=1
SET DIR(0)=DIR(0)_"D:ICD Diagnoses Only;"
+13 IF TPR=1
SET DIR(0)=DIR(0)_"P:CPT Procedures Only;"
+14 IF TSC=1
SET DIR(0)=DIR(0)_"S:Standard Codes Only;"
+15 SET DIR(0)=DIR(0)_";N:No Pick List"
+16 DO HELP^PXRMDTX1(.HTEXT)
+17 IF DIR(0)'[DEF
SET DEF=""
+18 SET DIR("A")="Taxonomy Pick List"
+19 SET DIR("B")=$SELECT(DEF]"":DEF,1:"A")
+20 SET DIR("?")="Select the pick list display value or '^' to quit. Enter ?? for detail help."
+21 SET DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)"
+22 DO ^DIR
+23 IF Y[U
QUIT Y
+24 SET VALUE=Y
+25 SET FDA(801.41,DA_",",123)=VALUE
+26 IF VALUE="N"
GOTO TAXUPD
+27 IF TDX=1
DO GETTAXDF(.DEFAULT,"POV",ISHIST)
+28 IF TPR=1
DO GETTAXDF(.DEFAULT,"CPT",ISHIST)
+29 IF TSC=1
DO GETTAXDF(.DEFAULT,"SC",ISHIST)
+30 SET IENCNT=0
+31 IF VALUE="D"
IF TDX=1
SET RESULT=$$BLDFDA("POV",IEN,.FDA,.DEFAULT)
if RESULT=U
GOTO ENTAXDL
+32 IF VALUE="P"
IF TPR=1
SET RESULT=$$BLDFDA("CPT",IEN,.FDA,.DEFAULT)
if RESULT=U
GOTO ENTAXDL
+33 IF VALUE="S"
IF TSC=1
SET RESULT=$$BLDFDA("SC",IEN,.FDA,.DEFAULT)
if RESULT=U
GOTO ENTAXDL
+34 IF VALUE="A"
Begin DoDot:1
+35 IF TDX=1
SET RESULT=$$BLDFDA("POV",IEN,.FDA,.DEFAULT)
IF RESULT[U
QUIT
+36 IF TPR=1
SET RESULT=$$BLDFDA("CPT",IEN,.FDA,.DEFAULT)
IF RESULT[U
QUIT
+37 IF TSC=1
SET RESULT=$$BLDFDA("SC",IEN,.FDA,.DEFAULT)
IF RESULT[U
QUIT
End DoDot:1
if RESULT="^^"
GOTO TAXDIALX
if RESULT=U
GOTO ENTAXDL
+38 ;I TPR=1,VALUE="A" S RESULT=$$BLDFDA("CPT",IEN,.FDA,.DEFAULT) G TAXDIALX:RESULT="^^" G ENTAXDL:RESULT=U
+39 ;
+40 SET RESULT=$$PROMPTS(IEN,VALUE,.DEFAULT,.FDA,.IENCNT)
IF RESULT[U
if RESULT="^^"
GOTO TAXDIALX
if RESULT=U
GOTO ENTAXDL
+41 KILL MSG
TAXUPD ;
+1 DO UPDATE^DIE("","FDA","","MSG")
+2 IF $DATA(MSG)
WRITE !,"Error in update",!
DO AWRITE^PXRMUTIL("MSG")
+3 ;
TAXDIALX ;
+1 QUIT RESULT
+2 ;
+3 ;This routine is used to display Taxonomy codes in the List Manager view for Dialog Text.
+4 ;TODO should we display any codes in Dialog Text view for Additional Findings or Taxonomy Pick List of N, D, P?
TAXDISP(FIEN,SEQ,DIEN,NLINE,NODE,ADDFIND,ISMAIL) ;
+1 NEW ARRAY,CNT,CODES,CODESYS,FILE,HIST,TIEN,TSEQ
+2 NEW CNT,DTXT,FNODE,RSUB,TDX,TNAME,TPAR,TPR,TYP
+3 NEW TCUR,TDTXT,TDHTXT,THIS,TPTXT,TPHTXT,TSC
+4 SET TIEN=$PIECE(FIEN,";")
if TIEN=""
QUIT
+5 SET HIST=0
SET FILE=""
+6 ;Get associated codes
+7 ;
+8 ;Get taxonomy name
+9 SET TNAME=$PIECE($GET(^PXD(811.2,TIEN,0)),U,1)
+10 ;
+11 ;Check what type of taxonomy codes exist
+12 SET TDX=$$TOK(TIEN,"POV")
+13 SET TPR=$$TOK(TIEN,"CPT")
+14 SET TSC=$$TOK(TIEN,"SC")
+15 ;
+16 SET TAXSEL=$PIECE($GET(^PXRMD(801.41,DIEN,"TAX")),U)
+17 IF ADDFIND=1
SET TAXSEL="N"
+18 ;
+19 IF TDX
Begin DoDot:1
+20 DO BLDCODE("POV",.CODESYS)
+21 DO CODES^PXRMDLLB(TIEN,.CODESYS,.CODES)
+22 IF '$DATA(CODES)
QUIT
+23 SET TEXT=$JUSTIFY("",15)_$SELECT(TAXSEL="N":"Diagnoses Codes:",TAXSEL="P":"Procedures Codes:",1:"Selectable Diagnoses Codes:")
SET TAB=18
+24 SET STR=$$LJ^XLFSTR($GET(TEXT),$SELECT(ISMAIL=1:51,1:60))
+25 SET STR=STR_"Activation Periods"
+26 SET NLINE=NLINE+1
+27 SET ^TMP(NODE,$JOB,NLINE,0)=STR
+28 DO CODES(TIEN,.CODES,.NLINE,HIST,ISMAIL)
+29 SET NLINE=NLINE+1
+30 SET ^TMP(NODE,$JOB,NLINE,0)=$JUSTIFY("",79)
End DoDot:1
+31 ;
+32 IF TPR
Begin DoDot:1
+33 KILL CODESYS,CODES
+34 DO BLDCODE("CPT",.CODESYS)
+35 DO CODES^PXRMDLLB(TIEN,.CODESYS,.CODES)
+36 IF '$DATA(CODES)
QUIT
+37 SET TEXT=$JUSTIFY("",15)_$SELECT(TAXSEL="N":"Procedures Codes:",TAXSEL="D":"Procedures Codes:",1:"Selectable Procedures codes:")
SET TAB=18
+38 SET STR=$$LJ^XLFSTR($GET(TEXT),$SELECT(ISMAIL=1:51,1:60))
+39 SET STR=STR_"Activation Periods"
+40 SET NLINE=NLINE+1
+41 SET ^TMP(NODE,$JOB,NLINE,0)=STR
+42 DO CODES(TIEN,.CODES,.NLINE,HIST,ISMAIL)
+43 SET NLINE=NLINE+1
+44 SET ^TMP(NODE,$JOB,NLINE,0)=$JUSTIFY("",79)
End DoDot:1
+45 ;
+46 IF TSC
Begin DoDot:1
+47 KILL CODESYS,CODES
+48 DO BLDCODE("SC",.CODESYS)
+49 DO CODES^PXRMDLLB(TIEN,.CODESYS,.CODES)
+50 IF '$DATA(CODES)
QUIT
+51 SET TEXT=$JUSTIFY("",15)_$SELECT(TAXSEL="N":"Procedures Codes:",TAXSEL="D":"Procedures Codes:",1:"Selectable Procedures codes:")
SET TAB=18
+52 SET STR=$$LJ^XLFSTR($GET(TEXT),$SELECT(ISMAIL=1:51,1:60))
+53 SET STR=STR_"Activation Periods"
+54 SET NLINE=NLINE+1
+55 SET ^TMP(NODE,$JOB,NLINE,0)=STR
+56 DO CODES(TIEN,.CODES,.NLINE,HIST,ISMAIL)
+57 SET NLINE=NLINE+1
+58 SET ^TMP(NODE,$JOB,NLINE,0)=$JUSTIFY("",79)
End DoDot:1
+59 QUIT
+60 ;
TAXEDITC(TIEN,TEXT) ;
+1 NEW DARRAY,DIEN,HEADER,IEN,NAME,OCNT,OUTPUT,RARRAY,RESULT
+2 NEW TDX,TPR,TAXNODE,TAXSEL,TSC
+3 DO FINDDIAL^PXRMFRPT(.DARRAY,"PXD(811.2,",TIEN)
+4 SET TEXT(1)="Taxonomy and/or the following dialog(s) have problems."
+5 SET TEXT(2)="Correct either the taxonomy or the following dialog(s):"
+6 SET CNT=2
+7 IF '$DATA(DARRAY)
GOTO TXEDITCX
+8 IF '$DATA(^PXD(811.2,TIEN,20,"AUID"))
SET TEXT(1)="Taxonomy does not contain codes marked to be used in a dialog. It is assigned to the following dialog(s)."
Begin DoDot:1
+9 SET CNT=1
SET NAME=""
FOR
SET NAME=$ORDER(DARRAY(NAME))
if NAME=""
QUIT
SET CNT=CNT+1
SET TEXT(CNT)=" "_NAME
End DoDot:1
QUIT
+10 SET TDX=$$TOK(TIEN,"POV")
SET TPR=$$TOK(TIEN,"CPT")
SET TSC=$$TOK(TIEN,"SC")
+11 SET NAME=""
FOR
SET NAME=$ORDER(DARRAY(NAME))
if NAME=""
QUIT
Begin DoDot:1
+12 SET IEN=DARRAY(NAME)
SET RESULT=$$CHECKER(IEN,TIEN,"",.OUTPUT)
IF RESULT=""
QUIT
+13 SET TEXT(2)="See below for descriptions of the problem(s):"
+14 NEW LINE,NIN,NOUT,TEMP
+15 SET NIN=$ORDER(OUTPUT(""),-1)
+16 DO FORMAT^PXRMTEXT(1,75,NIN,.OUTPUT,.NOUT,.TEMP)
+17 FOR LINE=1:1:NOUT
SET CNT=CNT+1
SET TEXT(CNT)=TEMP(LINE)
End DoDot:1
TXEDITCX ;
+1 IF CNT=2
KILL TEXT
+2 KILL ^TMP($JOB,"DLG FIND")
+3 QUIT
+4 ;
+5 ;change to use AUID cross-referenc instead of the selectable node, central location for checking what codes to use
+6 ;in a dialog for encounter type.
TOK(TIEN,TYPE) ;Check if selectable codes exist
+1 IF TYPE="POV"
IF $DATA(^PXD(811.2,TIEN,20,"AUID","ICD"))>0!($DATA(^PXD(811.2,TIEN,20,"AUID","10D"))>0)
QUIT 1
+2 IF TYPE="CPT"
IF $DATA(^PXD(811.2,TIEN,20,"AUID","CPT"))>0!($DATA(^PXD(811.2,TIEN,20,"AUID","CPC"))>0)
QUIT 1
+3 ;I TYPE="SC" I $D(^PXD(811.2,TIEN,20,"AUID","SCT"))>0 Q 1
+4 QUIT 0
+5 ;
