PXRMDLL.m

PXRMDLL ;SLC/PJH - REMINDER DIALOG LOADER ;05/12/2014

 ;;2.0;CLINICAL REMINDERS;**10,6,12,17,18,26**;Feb 04, 2005;Build 404

 ;

OK(DIEN) ;Check if mental health test is for GUI

 I 'DIEN Q 0

 Q $$MH^PXRMDLG5(DIEN)

 ;

TXT ;Format text

 N NULL

 S TEXT=DTXT(SUB),NULL=0

 I ($E(TEXT)=" ")!(TEXT="") S NULL=1

 I LAST,'NULL S TEXT="<br>"_TEXT

 S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")

 S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1

 Q

 ;

EXP(TIEN,DITEM,DSUB,DEXC,DMHEX,DRESL,DTXT) ;Expand taxonomy codes

 N ACNT,AHIS,ATYP,ARRAY,BOTH,CODES,CNT,DDIS,DHIST,DPCE,DSUPP,DTAX,SUB,TAXTEXT,TEXT,TSEL

 S TSEL=$P($G(^PXRMD(801.41,DITEM,"TAX")),U)

 S DSUPP=$P($G(^PXRMD(801.41,DITEM,0)),U,11)

 S DDIS=$S(DSUPP=1:"D",1:"S")

 ;

 S TEXT=""

 ;Get taxonomy file details

 I TSEL'="N" S BOTH=$$TAX(TIEN,DITEM,TEXT,.ARRAY)

 I TSEL'="N",'$D(ARRAY) Q

 S DHIS=$$AHIS(DITEM)

 ;

 ;Build dialog from the returned array

 ;

 S OCNT=OCNT+1

 ;this is new for Taxonomy selection types of N

 I TSEL="N" D  Q

 .N LAST,TEXT

 .S ORY(OCNT)=1_U_DITEM_U_DSUB_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL

 .S SUB=0,LAST=0 F  S SUB=$O(DTXT(SUB)) Q:'SUB  D

 ..D TXT

 ..S OCNT=OCNT+1,ORY(OCNT)=2_U_DITEM_U_DSUB_U_TEXT

 ;Main Taxonomy prompt

 ;Default group indents and selection entry

 S TAXTEXT=ARRAY

 ;S ORY(OCNT)=1_U_DITEM_U_DSUB_U_"S"_U_DEXC

 S ORY(OCNT)=1_U_DITEM_U_DSUB_U_DDIS_U_DEXC

 S $P(ORY(OCNT),U,16)=2,$P(ORY(OCNT),U,18)=$S(BOTH=1:2,1:0),$P(ORY(OCNT),U,8)=DHIS

 N LAST,TEXT

 S TEXT=""

 S SUB=0,LAST=0 F  S SUB=$O(DTXT(SUB)) Q:'SUB  D

 .D TXT

 .S OCNT=OCNT+1

 .S ORY(OCNT)=2_U_DITEM_U_DSUB_U_TEXT

 ;

 ;Taxonomy CPT/POV resolution prompts

 S ACNT=""

 F  S ACNT=$O(ARRAY(ACNT)) Q:ACNT=""  D

 .;Prompt text

 .S TAXTEXT=$P(ARRAY(ACNT),U),DPCE=$P(ARRAY(ACNT),U,4)

 .;Historical/Current flag

 .S AHIS=0 I $P(ARRAY(ACNT),U,3)=2 S AHIS=1

 .;CPT/POV

 .S ATYP="POV" I $P(ARRAY(ACNT),U,2)=81 S ATYP="CPT"

 .;Initial display

 .S DHIDE=0,DCHECK=0,DDIS=0

 .;Construct ien for this level

 .S DTAX=DSUB_"."_ACNT

 .S OCNT=OCNT+1

 .I BOTH=0 Q

 .S DEXC=1

 .S ORY(OCNT)=1_U_DITEM_U_DTAX_U_"T"_U_DEXC_U_U_ATYP_U_AHIS

 .S OCNT=OCNT+1

 .S ORY(OCNT)=2_U_DITEM_U_DTAX_U_TAXTEXT

 Q

 ;

GROUP(DIEN,DSUB) ;Dialog group

 N DATA,DBOX,DCAP,DCHK,DENTRY,DEXC,DCCNT,DGIEN,DGRP,DGSEQ,DGSUB,DHIDE,DIND

 N DINDPN,DMHEX,DRESL,DSHARE,SUB,DCOUNT

 ;Group caption text

 S DATA=$G(^PXRMD(801.41,DIEN,0))

 S DCAP=$P(DATA,U,5),DBOX=$P(DATA,U,6),DIND=$P(DATA,U,7)

 S DSHARE=$P(DATA,U,8),DENTRY=$P(DATA,U,9),DHIDE=$P(DATA,U,10)

 S DINDPN=$P(DATA,U,12) S:DINDPN="" DINDPN=0

 S DBOX=$S(DBOX="Y":1,1:"")

 ;group header is display only if SUPPRESS CHECKBOX

 S DCHK="S" I ('DHIDE)&(DSUPP) S DCHK="D",DHIDE=0

 ;Default group setting to hide

 I DHIDE="" S DHIDE=1

 ;

 S DEXC=$P($G(^PXRMD(801.41,DIEN,2)),U,3)

 ;

 S OCNT=OCNT+1,ORY(OCNT)=1_U_DIEN_U_DSUB_U_DCHK_U_DEXC

 S $P(ORY(OCNT),U,8)=$$AHIS(DIEN)

 S $P(ORY(OCNT),U,15)=DHIDE,$P(ORY(OCNT),U,16)=DIND

 S $P(ORY(OCNT),U,17)=DSHARE,$P(ORY(OCNT),U,18)=DENTRY

 S $P(ORY(OCNT),U,19)=DBOX,$P(ORY(OCNT),U,20)=DCAP

 S $P(ORY(OCNT),U,21)=DINDPN

 ;Create type 2 records if if here is additional group text

 N LAST,TEXT

 S SUB=0,LAST=0 F  S SUB=$O(DTXT(SUB)) Q:'SUB  D

 .D TXT

 .S OCNT=OCNT+1,ORY(OCNT)=2_U_DIEN_U_DSUB_U_TEXT

 ;Get dialog group sub-elements

 N DGCNT,DTYP,DSUPP,DDIS,IDENT S DGSEQ=0,DGCNT=0

 F  S DGSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DGSEQ)) Q:'DGSEQ  D

 .S DGSUB=$O(^PXRMD(801.41,DIEN,10,"B",DGSEQ,"")) Q:'DGSUB

 .S DGCNT=DGCNT+1

 .S DATA=$G(^PXRMD(801.41,DIEN,10,DGSUB,0))

 .S DGIEN=$P(DATA,U,2) Q:'DGIEN

 .;Check if element is disabled/invalid

 .I $$ISDISAB(DGIEN)=1 Q

 .;Branching logic call to determine if element should be suppress,

 .;replace or left as is

 .N TERMNODE,TERMSTAT

 .S TERMNODE=$G(^PXRMD(801.41,DGIEN,49))

 .I $G(TERMNODE)'="" D  Q:TERMSTAT=0

 ..S TERMSTAT=1

 ..D REPLACE^PXRMDLLB(DFN,TERMNODE,.DGIEN,.DATA,.TERMSTAT)

 .;Exclude from P/N

 .S DEXC=$P(DATA,U,8)

 .I $P($G(^PXRMD(801.41,DGIEN,0)),U,16)'["WHR" D

 ..K DTXT S SUB=0 F  S SUB=$O(^PXRMD(801.41,DGIEN,25,SUB)) Q:'SUB  D

 ...S DTXT(SUB)=$G(^PXRMD(801.41,DGIEN,25,SUB,0))

 .S DATA=$G(^PXRMD(801.41,DGIEN,0))

 .;If the actual element is exclude from P/N override

 .I $P($G(^PXRMD(801.41,DGIEN,2)),U,3) S DEXC=1

 .S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11) Q:"EG"'[DTYP

 .S DMHEX=$P(DATA,U,14)

 .S DRESL=$$RESGROUP^PXRMDLLB(DGIEN)

 .;S DRESL=$P(DATA,U,15)

 .S DRES=$P($G(^PXRMD(801.41,DGIEN,1)),U,3)

 .;Done Elsewhere (historical)

 .S DHIS=$$AHIS(DGIEN)

 .S DFIND=$P($G(^PXRMD(801.41,DGIEN,1)),U,5)

 .S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)

 .S DPCE="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))

 .;If mental Health ignore if not GUI

 .I DPCE="MH" Q:'$$OK(DFIEN)

 .S DGRP=DSUB_"."_DGSUB

 .;Taxonomy codes need expanding

 .I DPCE="T",DTYP'="G" D EXP(DFIEN,DGIEN,DGRP,DEXC,DMHEX,DRESL,.DTXT) Q

 .;Translate vitals ien to PCE code - This will need a DBIA

 .I DPCE="VIT" S DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E")

 .;Embedded Dialog Group

 .I DTYP="G" D GROUP(DGIEN,DGRP) Q

 .S DDIS="S" I DSUPP=1 S DDIS="D"

 .S DGRP=DSUB_"."_DGSUB,OCNT=OCNT+1

 .S ORY(OCNT)=1_U_DGIEN_U_DGRP_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL_U_$G(DCOUNT)

 .;

 .N LAST,TEXT

 .S SUB=0,LAST=0 F  S SUB=$O(DTXT(SUB)) Q:'SUB  D

 ..D TXT

 ..S OCNT=OCNT+1,ORY(OCNT)=2_U_DGIEN_U_DGRP_U_TEXT

 Q

 ;

ISDISAB(PXRMIEN) ;

 N CNT,PXRMDATA,ERRORTXT,HEADER,MSG,MSGCNT,RESULT,STDFILES,TYPE,ZTSAVE

 S PXRMDATA=$G(^PXRMD(801.41,PXRMIEN,0))

 I +$P(PXRMDATA,U,3)=0 Q 0

 I +$P(PXRMDATA,U,3)=2 Q 1

 S HEADER="Disabled Dialog Item is being used in CPRS."

 S TYPE=$P(PXRMDATA,U,4)

 S CNT=1

 S TYPE=$S(TYPE="E":"Element",TYPE="G":"Group",TYPE="R":"Result Group",1:"Item")

 S ERRORTXT(CNT,0)="Reminder Dialog "_TYPE_" "_$P(PXRMDATA,U)_" is inactive."

 D DIALDSAR^PXRMFRPT(.STDFILES) I '$D(STDFILES) G ISDISABX

 S RESULT=$$DISABCHK^PXRMDLG6(PXRMIEN,.STDFILES,.MSG)

 I '$D(MSG) G ISDISABX

 S CNT=CNT+1,ERRORTXT(CNT,0)="",CNT=CNT+1

 S MSGCNT=0

 F  S MSGCNT=$O(MSG(MSGCNT)) Q:MSGCNT'>0  D

 .S CNT=CNT+1

 .S ERRORTXT(CNT,0)="    "_$G(MSG(MSGCNT))

 ;

ISDISABX ;

 S ZTSAVE("HEADER")=""

 S ZTSAVE("ERRORTXT(")=""

 D ERROR("Reminder Dialog disable check",.ZTSAVE)

 Q 1

 ;

ERROR(DESC,ZTSAVE) ;

 N ZTDESC,ZTDTH,ZTRTN,ZTIO

 S ZTDESC=DESC

 S ZTRTN="ERRORQ^PXRMDLL"

 S ZTIO=""

 S ZTDTH=$$NOW^XLFDT

 D ^%ZTLOAD

 Q

ERRORQ ;

 M ^TMP("PXRMXMZ",$J)=ERRORTXT

 D SEND^PXRMMSG("PXRMXMZ",HEADER,"",DUZ)

 Q

 ;

LOAD(DIEN,DFN) ;Load dialog questions into array

 N DARRAY,DATA,DITEM,DFIND,DFIEN,DFTYP,DPCE,DRES,DSEQ,DSUB,DTXT,DTYP,OCNT

 N DDIS,DEXC,DHIDE,DCHECK,DDIS,DHIS,DMHEX,DRESL,DSUPP,SUB,IDENT,TXTCNT,REINDX

 ;Check Status of dialog

 S DATA=$G(^PXRMD(801.41,DIEN,0)) Q:DATA=""

 ;If disabled ignore

 I $$ISDISAB(DIEN)=1 Q

 ;Ignore if not a reminder dialog

 I $P(DATA,U,4)'="R" Q

 ;check for disable evaluation disable if it contains branching logic

 S REINDX=0

 I $D(^XTMP("PXRM_DISEV",0)) D

 .S ORY(1)=1_U_U_"1"_U_"D"_U_"1"_U_U_U_"0"_U_U

 .S ORY(2)=2_U_U_"1"_U_"Dialog is disable for reminder re-indexing"

 .S REINDX=1

 I REINDX=1 Q

 ;List of PCE codes

 S DARRAY("AUTTEDT(")="PED"

 S DARRAY("AUTTEXAM(")="XAM"

 S DARRAY("AUTTHF(")="HF"

 S DARRAY("AUTTIMM(")="IMM"

 S DARRAY("AUTTSK(")="SK"

 S DARRAY("GMRD(120.51,")="VIT"

 S DARRAY("ORD(101.41,")="Q"

 S DARRAY("YTT(601.71,")="MH"

 ;AGP TODO before release ICD9 and CPT can be deleted

 S DARRAY("ICD9(")="POV"

 S DARRAY("ICPT(")="CPT"

 S DARRAY("PXD(811.2,")="T"

 S DARRAY("WV(790.1,")="WHR"

 ;

 ;Get elements for the dialog

 S DSEQ=0,OCNT=0

 F  S DSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ)) Q:'DSEQ  D

 .S DSUB=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ,"")) Q:'DSUB

 .S DATA=$G(^PXRMD(801.41,DIEN,10,DSUB,0))

 .S DITEM=$P(DATA,U,2) Q:DITEM=""

 .;Ignore disabled elements

 .S DATA=$G(^PXRMD(801.41,DITEM,0)) Q:DATA=""  Q:$$ISDISAB(DITEM)=1

 .;Branching logic call to determine if element should be suppress,

 .;replace or left as is

 .S TERMNODE=$G(^PXRMD(801.41,DITEM,49))

 .N TERMSTAT

 .I $G(TERMNODE)'="" D  Q:TERMSTAT=0

 ..S TERMSTAT=1

 ..D REPLACE^PXRMDLLB(DFN,TERMNODE,.DITEM,.DATA,.TERMSTAT)

 .S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11)

 .S DMHEX=$P(DATA,U,14)

 .S DRESL=$$RESGROUP^PXRMDLLB(DITEM)

 .;S DRESL=$P(DATA,U,15)

 .K DTXT S SUB=0

 .F  S SUB=$O(^PXRMD(801.41,DITEM,25,SUB)) Q:'SUB  D

 ..S DTXT(SUB)=$G(^PXRMD(801.41,DITEM,25,SUB,0))

 .S DRES=$P($G(^PXRMD(801.41,DITEM,1)),U,3)

 .S DFIND=$P($G(^PXRMD(801.41,DITEM,1)),U,5)

 .S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)

 .S DPCE="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))

 .;If mental Health ignore if not GUI

 .I DPCE="MH" Q:'$$OK(DFIEN)

 .;Exclude from PN

 .S DEXC=$P($G(^PXRMD(801.41,DITEM,2)),U,3)

 .;Done Elsewhere (historical)

 .S DHIS=$$AHIS(DITEM)

 .;Taxonomy codes need expanding

 .I DPCE="T",DTYP'="G" D EXP(DFIEN,DITEM,DSUB,DEXC,DMHEX,DRESL,.DTXT) Q

 .;Translate vitals ien to PCE code - This will need a DBIA

 .I DPCE="VIT" S DFIEN=$P($G(^GMRD(120.51,DFIEN,0)),U,7)

 .;Dialog Group

 .I DTYP="G" D GROUP(DITEM,DSUB) Q

 .;Dialog type/text and resolution 

 .S OCNT=OCNT+1,DDIS="S"

 .I DSUPP=1 S DDIS="D"

 .S ORY(OCNT)=1_U_DITEM_U_DSUB_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL

 .N LAST,TEXT

 .S SUB=0,LAST=0 F  S SUB=$O(DTXT(SUB)) Q:'SUB  D

 ..D TXT

 ..S OCNT=OCNT+1,ORY(OCNT)=2_U_DITEM_U_DSUB_U_TEXT

 Q

 ;

TAX(TXIEN,DITEM,TEXT,ARRAY) ;Return list of resolutions/codes for taxonomy

 N CNT,DXNODE,DTXT,FAIL,HISTIEN,NODE,NUM,PRNODE,RESULT,RESVALUE,TNAME,TSEL,TYPE

 N TDTXT,TDHTXT,TPTXT,TPHTXT

 ;

 ;Get taxonomy name

 S RESULT=0

 S TNAME=$P($G(^PXD(811.2,TXIEN,0)),U,1)

 I $P($G(^PXD(811.2,TXIEN,0)),U,6)=1 D TAXERROR(DITEM,TXIEN) Q RESULT

 ;

 S TDX=$$TOK^PXRMDTAX(TXIEN,"POV")

 S TPR=$$TOK^PXRMDTAX(TXIEN,"CPT")

 S NODE=$G(^PXRMD(801.41,DITEM,"TAX"))

 S TSEL=$P(NODE,U)

 D TAXERROR(DITEM,TXIEN)

 ;

 S DTXT=""

 ;Taxonomy dialog text

 I DTXT="" S DTXT=$P(NODE,U,4)

 ;default to taxonomy description if null

 I DTXT="" S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,2)

 ;default to taxonomy name if null

 I DTXT="" S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,1)

 ;

 S CNT=0,ARRAY=DTXT

 ;

 ;make sure dialog is set to display diagnoses/procedure selection list

 I TDX S TDX=$S("AD"[TSEL:1,1:0)

 I TPR S TPR=$S("AP"[TSEL:1,1:0)

 I TDX,TPR S RESULT=1

 S HISTIEN=$O(^PXRMD(801.9,"B","DONE ELSEWHERE (HISTORICAL)",""))

 S RESVALUE=$P($G(^PXRMD(801.41,DITEM,1)),U,3)

 S TCUR=$S(RESVALUE'=HISTIEN:1,1:0)

 ;Diagnoses

 I TDX D

 .S TDTXT=$P($G(^PXRMD(801.41,DITEM,"POV")),U) S:TDTXT="" TDTXT=TNAME_$S(TCUR=1:"",1:" (HISTORICAL)")

 .S CNT=CNT+1,ARRAY(CNT)=TDTXT_U_80_U_$S(TCUR=1:1,1:2)_U_"POV"

 ;Procedures

 I TPR D

 .S TPTXT=$P($G(^PXRMD(801.41,DITEM,"CPT")),U) S:TPTXT="" TPTXT=TNAME_$S(TCUR=1:"",1:" (HISTORICAL)")

 .S CNT=CNT+1,ARRAY(CNT)=TPTXT_U_81_U_$S(TCUR=1:1,1:2)_U_"CPT"

 ;

 Q RESULT

 ;

TAXERROR(DIEN,TIEN) ;

 N CNT,DNAME,ERRORTXT,FAIL,HEADER,LINE,NIN,NOUT,OUTPUT,TEMP,TNAME

 S DNAME=$P($G(^PXRMD(801.41,DIEN,0)),U) Q:DNAME=""

 S TNAME=$P($G(^PXD(811.2,TIEN,0)),U)

 S HEADER="Problem with dialog in CPRS"

 S FAIL=$$CHECKER^PXRMDTAX(DIEN,TIEN,15,.OUTPUT) I FAIL="" Q

 S NIN=$O(OUTPUT(""),-1)

 D FORMAT^PXRMTEXT(1,75,NIN,.OUTPUT,.NOUT,.TEMP)

 S CNT=0 F LINE=1:1:NOUT S CNT=CNT+1,ERRORTXT(CNT,0)=TEMP(LINE)

 ;S CNT=1 S ERRORTXT(CNT,0)="Dialog "_DNAME_" and taxonomy "_TNAME_" structures do not match."

 S CNT=CNT+1,ERRORTXT(CNT,0)="Please review and correct either the taxonomy or the dialog."

 S ZTSAVE("HEADER")="",ZTSAVE("ERRORTXT(")=""

 D ERROR("Reminder Dialog/Taxonomy Loader check",.ZTSAVE)

 Q

 ;

AHIS(DITEM) ;

 N RSIEN,RSNAM

 S RSIEN=$P($G(^PXRMD(801.41,DITEM,1)),U,3)

 I RSIEN="" Q 0

 S RSNAM=$P($G(^PXRMD(801.9,RSIEN,0)),U)

 I RSNAM["DONE ELSEWHERE" Q 1

 N GUI,PIEN,PFOUND

 S PIEN=0,PFOUND=0

 F  S PIEN=$O(^PXRMD(801.41,DITEM,10,"D",PIEN)) Q:'PIEN  D  Q:PFOUND

 .;Ignore elements and groups

 .I "EG"[$P($G(^PXRMD(801.41,PIEN,0)),U,4) Q

 .;GUI Process

 .S GUI=$P($G(^PXRMD(801.41,PIEN,46)),U) Q:'GUI

 .;Check if this is PXRM VISIT DATE (or a copy of it)

 .I $P($G(^PXRMD(801.42,GUI,0)),U)="VST_DATE" S PFOUND=1

 Q PFOUND

PXRMDLL   ;SLC/PJH - REMINDER DIALOG LOADER ;05/12/2014

 +1       ;;2.0;CLINICAL REMINDERS;**10,6,12,17,18,26**;Feb 04, 2005;Build 404

 +2       ;

OK(DIEN)  ;Check if mental health test is for GUI

 +1        IF 'DIEN

               QUIT 0

 +2        QUIT $$MH^PXRMDLG5(DIEN)

 +3       ;

TXT       ;Format text

 +1        NEW NULL

 +2        SET TEXT=DTXT(SUB)

           SET NULL=0

 +3        IF ($EXTRACT(TEXT)=" ")!(TEXT="")

               SET NULL=1

 +4        IF LAST

               IF 'NULL

                   SET TEXT="<br>"_TEXT

 +5        SET TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")

 +6        SET LAST=0

           IF NULL

               SET TEXT="<br>"_TEXT

               SET LAST=1

 +7        QUIT 

 +8       ;

EXP(TIEN,DITEM,DSUB,DEXC,DMHEX,DRESL,DTXT) ;Expand taxonomy codes

 +1        NEW ACNT,AHIS,ATYP,ARRAY,BOTH,CODES,CNT,DDIS,DHIST,DPCE,DSUPP,DTAX,SUB,TAXTEXT,TEXT,TSEL

 +2        SET TSEL=$PIECE($GET(^PXRMD(801.41,DITEM,"TAX")),U)

 +3        SET DSUPP=$PIECE($GET(^PXRMD(801.41,DITEM,0)),U,11)

 +4        SET DDIS=$SELECT(DSUPP=1:"D",1:"S")

 +5       ;

 +6        SET TEXT=""

 +7       ;Get taxonomy file details

 +8        IF TSEL'="N"

               SET BOTH=$$TAX(TIEN,DITEM,TEXT,.ARRAY)

 +9        IF TSEL'="N"

               IF '$DATA(ARRAY)

                   QUIT 

 +10       SET DHIS=$$AHIS(DITEM)

 +11      ;

 +12      ;Build dialog from the returned array

 +13      ;

 +14       SET OCNT=OCNT+1

 +15      ;this is new for Taxonomy selection types of N

 +16       IF TSEL="N"

               Begin DoDot:1

 +17               NEW LAST,TEXT

 +18               SET ORY(OCNT)=1_U_DITEM_U_DSUB_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL

 +19               SET SUB=0

                   SET LAST=0

                   FOR 

                       SET SUB=$ORDER(DTXT(SUB))

                       IF 'SUB

                           QUIT 

                       Begin DoDot:2

 +20                       DO TXT

 +21                       SET OCNT=OCNT+1

                           SET ORY(OCNT)=2_U_DITEM_U_DSUB_U_TEXT

                       End DoDot:2

               End DoDot:1

               QUIT 

 +22      ;Main Taxonomy prompt

 +23      ;Default group indents and selection entry

 +24       SET TAXTEXT=ARRAY

 +25      ;S ORY(OCNT)=1_U_DITEM_U_DSUB_U_"S"_U_DEXC

 +26       SET ORY(OCNT)=1_U_DITEM_U_DSUB_U_DDIS_U_DEXC

 +27       SET $PIECE(ORY(OCNT),U,16)=2

           SET $PIECE(ORY(OCNT),U,18)=$SELECT(BOTH=1:2,1:0)

           SET $PIECE(ORY(OCNT),U,8)=DHIS

 +28       NEW LAST,TEXT

 +29       SET TEXT=""

 +30       SET SUB=0

           SET LAST=0

           FOR 

               SET SUB=$ORDER(DTXT(SUB))

               IF 'SUB

                   QUIT 

               Begin DoDot:1

 +31               DO TXT

 +32               SET OCNT=OCNT+1

 +33               SET ORY(OCNT)=2_U_DITEM_U_DSUB_U_TEXT

               End DoDot:1

 +34      ;

 +35      ;Taxonomy CPT/POV resolution prompts

 +36       SET ACNT=""

 +37       FOR 

               SET ACNT=$ORDER(ARRAY(ACNT))

               IF ACNT=""

                   QUIT 

               Begin DoDot:1

 +38      ;Prompt text

 +39               SET TAXTEXT=$PIECE(ARRAY(ACNT),U)

                   SET DPCE=$PIECE(ARRAY(ACNT),U,4)

 +40      ;Historical/Current flag

 +41               SET AHIS=0

                   IF $PIECE(ARRAY(ACNT),U,3)=2

                       SET AHIS=1

 +42      ;CPT/POV

 +43               SET ATYP="POV"

                   IF $PIECE(ARRAY(ACNT),U,2)=81

                       SET ATYP="CPT"

 +44      ;Initial display

 +45               SET DHIDE=0

                   SET DCHECK=0

                   SET DDIS=0

 +46      ;Construct ien for this level

 +47               SET DTAX=DSUB_"."_ACNT

 +48               SET OCNT=OCNT+1

 +49               IF BOTH=0

                       QUIT 

 +50               SET DEXC=1

 +51               SET ORY(OCNT)=1_U_DITEM_U_DTAX_U_"T"_U_DEXC_U_U_ATYP_U_AHIS

 +52               SET OCNT=OCNT+1

 +53               SET ORY(OCNT)=2_U_DITEM_U_DTAX_U_TAXTEXT

               End DoDot:1

 +54       QUIT 

 +55      ;

GROUP(DIEN,DSUB) ;Dialog group

 +1        NEW DATA,DBOX,DCAP,DCHK,DENTRY,DEXC,DCCNT,DGIEN,DGRP,DGSEQ,DGSUB,DHIDE,DIND

 +2        NEW DINDPN,DMHEX,DRESL,DSHARE,SUB,DCOUNT

 +3       ;Group caption text

 +4        SET DATA=$GET(^PXRMD(801.41,DIEN,0))

 +5        SET DCAP=$PIECE(DATA,U,5)

           SET DBOX=$PIECE(DATA,U,6)

           SET DIND=$PIECE(DATA,U,7)

 +6        SET DSHARE=$PIECE(DATA,U,8)

           SET DENTRY=$PIECE(DATA,U,9)

           SET DHIDE=$PIECE(DATA,U,10)

 +7        SET DINDPN=$PIECE(DATA,U,12)

           IF DINDPN=""

               SET DINDPN=0

 +8        SET DBOX=$SELECT(DBOX="Y":1,1:"")

 +9       ;group header is display only if SUPPRESS CHECKBOX

 +10       SET DCHK="S"

           IF ('DHIDE)&(DSUPP)

               SET DCHK="D"

               SET DHIDE=0

 +11      ;Default group setting to hide

 +12       IF DHIDE=""

               SET DHIDE=1

 +13      ;

 +14       SET DEXC=$PIECE($GET(^PXRMD(801.41,DIEN,2)),U,3)

 +15      ;

 +16       SET OCNT=OCNT+1

           SET ORY(OCNT)=1_U_DIEN_U_DSUB_U_DCHK_U_DEXC

 +17       SET $PIECE(ORY(OCNT),U,8)=$$AHIS(DIEN)

 +18       SET $PIECE(ORY(OCNT),U,15)=DHIDE

           SET $PIECE(ORY(OCNT),U,16)=DIND

 +19       SET $PIECE(ORY(OCNT),U,17)=DSHARE

           SET $PIECE(ORY(OCNT),U,18)=DENTRY

 +20       SET $PIECE(ORY(OCNT),U,19)=DBOX

           SET $PIECE(ORY(OCNT),U,20)=DCAP

 +21       SET $PIECE(ORY(OCNT),U,21)=DINDPN

 +22      ;Create type 2 records if if here is additional group text

 +23       NEW LAST,TEXT

 +24       SET SUB=0

           SET LAST=0

           FOR 

               SET SUB=$ORDER(DTXT(SUB))

               IF 'SUB

                   QUIT 

               Begin DoDot:1

 +25               DO TXT

 +26               SET OCNT=OCNT+1

                   SET ORY(OCNT)=2_U_DIEN_U_DSUB_U_TEXT

               End DoDot:1

 +27      ;Get dialog group sub-elements

 +28       NEW DGCNT,DTYP,DSUPP,DDIS,IDENT

           SET DGSEQ=0

           SET DGCNT=0

 +29       FOR 

               SET DGSEQ=$ORDER(^PXRMD(801.41,DIEN,10,"B",DGSEQ))

               IF 'DGSEQ

                   QUIT 

               Begin DoDot:1

 +30               SET DGSUB=$ORDER(^PXRMD(801.41,DIEN,10,"B",DGSEQ,""))

                   IF 'DGSUB

                       QUIT 

 +31               SET DGCNT=DGCNT+1

 +32               SET DATA=$GET(^PXRMD(801.41,DIEN,10,DGSUB,0))

 +33               SET DGIEN=$PIECE(DATA,U,2)

                   IF 'DGIEN

                       QUIT 

 +34      ;Check if element is disabled/invalid

 +35               IF $$ISDISAB(DGIEN)=1

                       QUIT 

 +36      ;Branching logic call to determine if element should be suppress,

 +37      ;replace or left as is

 +38               NEW TERMNODE,TERMSTAT

 +39               SET TERMNODE=$GET(^PXRMD(801.41,DGIEN,49))

 +40               IF $GET(TERMNODE)'=""

                       Begin DoDot:2

 +41                       SET TERMSTAT=1

 +42                       DO REPLACE^PXRMDLLB(DFN,TERMNODE,.DGIEN,.DATA,.TERMSTAT)

                       End DoDot:2

                       IF TERMSTAT=0

                           QUIT 

 +43      ;Exclude from P/N

 +44               SET DEXC=$PIECE(DATA,U,8)

 +45               IF $PIECE($GET(^PXRMD(801.41,DGIEN,0)),U,16)'["WHR"

                       Begin DoDot:2

 +46                       KILL DTXT

                           SET SUB=0

                           FOR 

                               SET SUB=$ORDER(^PXRMD(801.41,DGIEN,25,SUB))

                               IF 'SUB

                                   QUIT 

                               Begin DoDot:3

 +47                               SET DTXT(SUB)=$GET(^PXRMD(801.41,DGIEN,25,SUB,0))

                               End DoDot:3

                       End DoDot:2

 +48               SET DATA=$GET(^PXRMD(801.41,DGIEN,0))

 +49      ;If the actual element is exclude from P/N override

 +50               IF $PIECE($GET(^PXRMD(801.41,DGIEN,2)),U,3)

                       SET DEXC=1

 +51               SET DTYP=$PIECE(DATA,U,4)

                   SET DSUPP=$PIECE(DATA,U,11)

                   IF "EG"'[DTYP

                       QUIT 

 +52               SET DMHEX=$PIECE(DATA,U,14)

 +53               SET DRESL=$$RESGROUP^PXRMDLLB(DGIEN)

 +54      ;S DRESL=$P(DATA,U,15)

 +55               SET DRES=$PIECE($GET(^PXRMD(801.41,DGIEN,1)),U,3)

 +56      ;Done Elsewhere (historical)

 +57               SET DHIS=$$AHIS(DGIEN)

 +58               SET DFIND=$PIECE($GET(^PXRMD(801.41,DGIEN,1)),U,5)

 +59               SET DFIEN=$PIECE(DFIND,";")

                   SET DFTYP=$PIECE(DFIND,";",2)

 +60               SET DPCE=""

                   IF DFTYP'=""

                       SET DPCE=$GET(DARRAY(DFTYP))

 +61      ;If mental Health ignore if not GUI

 +62               IF DPCE="MH"

                       IF '$$OK(DFIEN)

                           QUIT 

 +63               SET DGRP=DSUB_"."_DGSUB

 +64      ;Taxonomy codes need expanding

 +65               IF DPCE="T"

                       IF DTYP'="G"

                           DO EXP(DFIEN,DGIEN,DGRP,DEXC,DMHEX,DRESL,.DTXT)