PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;23-Mar-2015 10:11;DU
;;2.0;CLINICAL REMINDERS;**6,1001,1003,12,18,26,1005**;Feb 04, 2005;Build 23
;IHS/MSC/MGH Patch 1001 add IHS files
;
FREC(DFIEN,DFTYP) ;Build type 3 record
N CSARRAY,CSCNT
;Dialog type/text and resolution
S DNAM=$$NAME(DFIEN,DFTYP)
;Translate vitals ien to PCE code - This will need a DBIA
S DCOD=""
I DPCE="VIT" D
.S DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E")
.;Vitals Caption
.S DVIT=$P($G(^PXRMD(801.41,DITEM,2)),U,4)
I DFTYP]"" D
.S OCNT=OCNT+1
.S ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$G(DCOD)_U_DNAM_U_U_DVIT
.;Get order type for orderable items
.;DBIA #3110
.S:DPCE="Q" $P(ORY(OCNT),U,11)=$P($G(^ORD(101.41,DFIEN,0)),U,4)
.;If mental health check if a GAF score and if MH test is required
.I DPCE="MH",DFIEN D
..;DBIA #5044
..I $P($G(^YTT(601.71,DFIEN,0)),U)="GAF" S $P(ORY(OCNT),U,12)=1
..;Check to see if the MH test is required
..S $P(ORY(OCNT),U,13)=+$P($G(^PXRMD(801.41,DITEM,0)),U,18)
..I $P(ORY(OCNT),U,13)=2,$$PATCH^XPDUTL("OR*3.0*243")=0 S $P(ORY(OCNT),U,13)=1
Q
;
GUI(IEN) ;Work out prompt type for PCE
Q:IEN="" ""
N SUB S SUB=$P($G(^PXRMD(801.41,IEN,46)),U)
Q:'SUB ""
Q $P($G(^PXRMD(801.42,SUB,0)),U)
;
LOAD(DITEM,DCUR,DTTYP) ;Load dialog questions into array
N DARRAY,DCOD,DEXC,DFIND,DFIEN,DFTYP,DNAM,DPCE,DRES,DSEQ,DSUB,DTYP,OCNT
N DVIT,NODE,CNT,IDENT,TAXBUILT,TAXNODE,TDX,TPR,TSEL
I +$G(DITEM)'>0 Q
;DBIA #3110 OR(101.41
;
;Build 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("AUTTMSR(")="MSR" ;IHS/MSC/MGH - Patch 1001 Support for V MEASUREMENTS
S DARRAY("ORD(101.41,")="Q"
S DARRAY("YTT(601.71,")="MH"
S DARRAY("APCDACV(")="ASM" ;IHS/MSC/MGH -Patch 1001 Support for Asthma
;
S DARRAY("ICD9(")="POV"
S DARRAY("ICPT(")="CPT"
S DARRAY("WV(790.404,")="WH"
S DARRAY("WV(790.1,")="WHR"
;
S DARRAY("PXD(811.2,")="T"
;
;Get the dialog element
S OCNT=0
N TERMNODE,TERMSTAT,TERMOUT
S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4)
;Finding detail
S DRES=$P($G(^PXRMD(801.41,DITEM,1)),U,3)
S DFIND=$P($G(^PXRMD(801.41,DITEM,1)),U,5)
;check for WH finding
I $P($G(^PXRMD(801.41,DITEM,0)),U,16)["WHR" S DFIND=$G(WHFIND)
;
S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)
S DPCE="",DVIT="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))
;Exclude from P/N
S DEXC=$P($G(^PXRMD(801.41,DITEM,2)),U,3)
;
;Non taxonomy codes (3 - finding record)
I DPCE'="T" D FREC(DFIEN,DFTYP)
;
;Taxonomy codes need expanding (3 - finding record)
I DPCE="T" D
.S TAXBUILT=0
.I $G(DTTYP)="" D
..S TAXNODE=$G(^PXRMD(801.41,DITEM,"TAX"))
..S TSEL=$P(TAXNODE,U) I TSEL="N" Q
..S TDX=$$TOK^PXRMDTAX(DFIEN,"POV")
..S TPR=$$TOK^PXRMDTAX(DFIEN,"CPT")
..I TSEL="D" S DTTYP="POV",TAXBUILT=1 Q
..I TSEL="P" S DTTYP="CPT",TAXBUILT=1 Q
..I TDX,TPR Q
..I TDX S DTTYP="POV",TAXBUILT=1 Q
..I TPR S DTTYP="CPT",TAXBUILT=1
.I $G(DTTYP)'="" D EXP^PXRMDLLB(DITEM,DFIEN,DCUR,DTTYP,5) I TAXBUILT=0 Q
.D EXPTAX^PXRMDLLB(DITEM,DFIEN,DCUR)
;
;Prompt details (4 - prompt records)
N ARRAY,DTITLE,DREQ,DSEQ,DSSEQ,DSUB,DTYP
;If not a taxonomy get prompts from dialog file
I DPCE'="T" D PROTH(DITEM,"","")
;Check for MST findings
I (DPCE'="T"),(DFTYP]"") D MST^PXRMDLLB(DFTYP,DFIEN)
;If taxonomy use finding parameters (CPT/POV)
I DPCE="T" D
.I $G(DTTYP)="",$G(^PXRMD(801.41,DITEM,"TAX"))'="N" Q
.;
.I $D(^PXRMD(801.41,DITEM,10,"B"))>0 D Q
..I $G(DTTYP)'="",$G(DCUR)'="" D PROTH(DITEM,DTTYP,DCUR) Q
..D PROTH(DITEM,"","")
;Return array of type 4 records
S DSEQ=""
F S DSEQ=$O(ARRAY(DSEQ)) Q:'DSEQ D
.S OCNT=OCNT+1
.S ORY(OCNT)=4_U_DITEM_U_DSEQ_U_ARRAY(DSEQ)
.S DSSEQ=""
.F S DSSEQ=$O(ARRAY(DSEQ,DSSEQ)) Q:'DSSEQ D
..S OCNT=OCNT+1
..S ORY(OCNT)=4_U_DITEM_U_DSEQ_"."_DSSEQ_U_ARRAY(DSEQ,DSSEQ)
;
;Get progress note text if defined
;I DPCE'="T" D:'DEXC PTXT(DITEM)
;Build Alternate progress note text for taxonomies with more then one pick list.
I DTTYP="" D:'DEXC PTXT(DITEM)
;Build Alternate progress note text for taxonomies with one pick list.
I DPCE="T",DTTYP'="" D:'DEXC PTXT(DITEM)
;Additional findings
N FASUB
S FASUB=0
F S FASUB=$O(^PXRMD(801.41,DITEM,3,FASUB)) Q:'FASUB D
.S DFIND=$P($G(^PXRMD(801.41,DITEM,3,FASUB,0)),U)
.S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2) Q:DFTYP="" Q:DFIEN=""
.S DVIT="",DPCE=$G(DARRAY(DFTYP))
.I DPCE'="",DPCE'="T" D FREC(DFIEN,DFTYP)
.I DPCE'="",DPCE="T" D
..D EXP^PXRMDLLB(DITEM,DFIEN,DCUR,"CPT",3)
..D EXP^PXRMDLLB(DITEM,DFIEN,DCUR,"POV",3)
;D EXPTAX^PXRMDLLB(DITEM,DFIEN,DCUR)
Q
;
;
;Returns item name
NAME(DFIEN,DFTYP) ;
Q:DFTYP="" ""
Q:DFIEN="" ""
N NAME,FGLOB,POSN
;DBIA #4108
I DFTYP="WV(790.404," S NAME=$P($G(^WV(790.404,DFIEN,0)),U) Q:NAME]"" NAME
I DFTYP="WV(790.1," S NAME=$G(WHNAME) K WHNAME Q:NAME]"" NAME
S POSN=2
S:DFTYP["AUTT" POSN=1 S:DFTYP["AUTTEDT" POSN=4 S:DFTYP["ICD" POSN=3
S FGLOB=U_DFTYP_DFIEN_",0)",NAME=$P($G(@FGLOB),U,POSN)
I (POSN>1),NAME="" S NAME=$P($G(@FGLOB),U)
I NAME="" S NAME=DFIEN
Q NAME
;
PROTH(IEN,DTTYP,DCUR) ; Additional prompts defined in 801.41
N DDATA,DDEF,DIEN,DEXC,DGUI,DNAME,DOVR,DREQ,DSEQ,DSNL,DSUB,DFTEXT
N DTXT,DTYP,NODE,PRINT,TAX
S DSEQ=0
F S DSEQ=$O(^PXRMD(801.41,IEN,10,"B",DSEQ)) Q:'DSEQ D
.;Get prompts in sequence
.S DSUB=$O(^PXRMD(801.41,IEN,10,"B",DSEQ,"")) Q:'DSUB
.S NODE=$G(^PXRMD(801.41,IEN,10,DSUB,0))
.;Prompt ien
.S DIEN=$P($G(^PXRMD(801.41,IEN,10,DSUB,0)),U,2) Q:'DIEN
.;Ignore disabled components, and those that are not prompts
.I $$ISDISAB^PXRMDLL(DIEN)=1 Q
.Q:"PF"'[$P($G(^PXRMD(801.41,DIEN,0)),U,4)
.;check to make sure prompt is apporiate for the taxonomy encounter type
.I $G(DTTYP)'="",$G(DCUR)'="",$$TAXPRMPT(DIEN,DTTYP,DCUR)=0 Q
.;Set defaults to null
.S DDEF="",DEXC="",DREQ="",DSNL=""
.;Prompt name and GUI process (quit if null)
.S DNAME=$P($G(^PXRMD(801.41,DIEN,0)),U),DGUI=$$GUI(DIEN)
.I $G(DGUI)="WH_NOT_PURP" D
..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
.;Type Prompt or Forced
.S DTYP=$P($G(^PXRMD(801.41,DIEN,0)),U,4)
.I "PF"[DTYP D
..;Required/Prompt caption
..S DDATA=$G(^PXRMD(801.41,DIEN,2)),DTXT=$P(DDATA,U,4)
..;Default value or forced value
..S:DTYP="P" DDEF=$P(DDATA,U) S:DTYP="F" DDEF=$P(DDATA,U,2)
..;Override caption/start new line/exclude PN from dialog file
..S DDATA=$G(^PXRMD(801.41,IEN,10,DSUB,0)),DREQ=$P(DDATA,U,9)
..S DOVR=$P(DDATA,U,6),DSNL=$P(DDATA,U,7),DEXC=$P(DDATA,U,8)
..S DNAME=DTXT I DOVR]"" S DNAME=DOVR
..;Convert date to fileman format
..I DGUI="VST_DATE",DDEF["T" S DDEF=$$DT^XLFDT()
.S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_$G(DFTEXT)_U_$G(PRINT)
.;the following section add a comment prompt to the WH review of result
.;section of the reminder dialog
.I DGUI="WH_PAP_RESULT",DFTYP="WV(790.1,",DTYP="P" D
..N WHCNT,WHFLAG,WHNUM,WHLOOP
..S WHNUM=DSEQ+1,WHLOOP=0
..F WHLOOP=0 D
...S (WHCNT,WHFLAG)=0
...F S WHCNT=$O(^PXRMD(801.41,IEN,10,"B",WHCNT)) Q:'WHCNT!(WHFLAG=1) D
....I WHCNT=WHNUM S WHFLAG=1,WHNUM=WHNUM+1
...I WHFLAG=0 S WHLOOP=1
..S ARRAY(WHNUM)="COM"_U_U_U_"P"_U_"Comment:"_U_U_U
.;Additional checkboxes
.I DGUI="COM",DIEN>1 D
..N DSSEQ,DSUB,DTEXT
..S DSSEQ=0
..F S DSSEQ=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ)) Q:'DSSEQ D
...S DSUB=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ,"")) Q:'DSUB
...S DTEXT=$P($G(^PXRMD(801.41,DIEN,45,DSUB,0)),U,2) Q:DTEXT=""
...S ARRAY(DSEQ,DSSEQ)=U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ
Q
;
PRTAX(FNODE,RSUB) ;Get all additional fields for this resolution type
N ACNT,ASUB
N DDATA,DDEF,DEXC,DGUI,DNAME,DREQ,DSEQ,DSUB,DTYP,PRINT
S ASUB=0,DSEQ=0
F S ASUB=$O(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB)) Q:'ASUB D
.S DDATA=$G(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB,0)) Q:DDATA=""
.;Ignore if disabled
.I $P(DDATA,U,3)=1 Q
.S DSUB=$P(DDATA,U) Q:DDATA=""
.S DSEQ=DSEQ+1
.;Set defaults to null
.S DDEF="",DEXC="",DREQ="",DSNL=""
.;Prompt name and GUI process (quit if null)
.S DNAME=$P($G(^PXRMD(801.41,DSUB,0)),U),DGUI=$$GUI(DSUB)
.I $G(DGUI)="WH_NOT_PURP" D
..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
.;Type Prompt or Forced
.S DTYP=$P($G(^PXRMD(801.41,DSUB,0)),U,4)
.I DTYP="P" D
..S DREQ=$P(DDATA,U,2),DTXT=$P($G(^PXRMD(801.41,DSUB,2)),U,4)
..;Override caption/start new line/exclude from PN from finding type
..S DOVR=$P(DDATA,U,5),DSNL=$P(DDATA,U,6),DEXC=$P(DDATA,U,7)
..S DNAME=DTXT I DOVR]"" S DNAME=DOVR
..;Required/Prompt caption
..S DDATA=$G(^PXRMD(801.41,DSUB,2))
.S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_U_$G(PRINT)
Q
;
PTXT(ITEM) ;Get progress note (WP) text for type 6 records
N ARRAY,LAST,NULL,SUB,TEXT,TXTCNT
S SUB=0
F S SUB=$O(^PXRMD(801.41,ITEM,35,SUB)) Q:'SUB D
.S ARRAY(SUB)=$G(^PXRMD(801.41,ITEM,35,SUB,0))
S SUB=0,LAST=0 F S SUB=$O(ARRAY(SUB)) Q:'SUB D
.S TEXT=$G(ARRAY(SUB))
.S NULL=0 I (TEXT="")!($E(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
.S OCNT=OCNT+1,ORY(OCNT)=6_U_ITEM_U_U_TEXT
Q
;
;function to determine if the prompt is valid for the taxonomy encounter type.
TAXPRMPT(DIEN,DTTYP,DCUR) ;
N FIND,IEN
S IEN=$P($G(^PXRMD(801.41,DIEN,1)),U,4) I +IEN=0 Q 1
S FIND=$P($G(^PXRMD(801.45,IEN,0)),U) I FIND="" Q 1
I FIND=DTTYP Q 1
Q 0
;
PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;23-Mar-2015 10:11;DU
+1 ;;2.0;CLINICAL REMINDERS;**6,1001,1003,12,18,26,1005**;Feb 04, 2005;Build 23
+2 ;IHS/MSC/MGH Patch 1001 add IHS files
+3 ;
FREC(DFIEN,DFTYP) ;Build type 3 record
+1 NEW CSARRAY,CSCNT
+2 ;Dialog type/text and resolution
+3 SET DNAM=$$NAME(DFIEN,DFTYP)
+4 ;Translate vitals ien to PCE code - This will need a DBIA
+5 SET DCOD=""
+6 IF DPCE="VIT"
Begin DoDot:1
+7 SET DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E")
+8 ;Vitals Caption
+9 SET DVIT=$PIECE($GET(^PXRMD(801.41,DITEM,2)),U,4)
End DoDot:1
+10 IF DFTYP]""
Begin DoDot:1
+11 SET OCNT=OCNT+1
+12 SET ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$GET(DCOD)_U_DNAM_U_U_DVIT
+13 ;Get order type for orderable items
+14 ;DBIA #3110
+15 IF DPCE="Q"
SET $PIECE(ORY(OCNT),U,11)=$PIECE($GET(^ORD(101.41,DFIEN,0)),U,4)
+16 ;If mental health check if a GAF score and if MH test is required
+17 IF DPCE="MH"
IF DFIEN
Begin DoDot:2
+18 ;DBIA #5044
+19 IF $PIECE($GET(^YTT(601.71,DFIEN,0)),U)="GAF"
SET $PIECE(ORY(OCNT),U,12)=1
+20 ;Check to see if the MH test is required
+21 SET $PIECE(ORY(OCNT),U,13)=+$PIECE($GET(^PXRMD(801.41,DITEM,0)),U,18)
+22 IF $PIECE(ORY(OCNT),U,13)=2
IF $$PATCH^XPDUTL("OR*3.0*243")=0
SET $PIECE(ORY(OCNT),U,13)=1
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
GUI(IEN) ;Work out prompt type for PCE
+1 IF IEN=""
QUIT ""
+2 NEW SUB
SET SUB=$PIECE($GET(^PXRMD(801.41,IEN,46)),U)
+3 IF 'SUB
QUIT ""
+4 QUIT $PIECE($GET(^PXRMD(801.42,SUB,0)),U)
+5 ;
LOAD(DITEM,DCUR,DTTYP) ;Load dialog questions into array
+1 NEW DARRAY,DCOD,DEXC,DFIND,DFIEN,DFTYP,DNAM,DPCE,DRES,DSEQ,DSUB,DTYP,OCNT
+2 NEW DVIT,NODE,CNT,IDENT,TAXBUILT,TAXNODE,TDX,TPR,TSEL
+3 IF +$GET(DITEM)'>0
QUIT
+4 ;DBIA #3110 OR(101.41
+5 ;
+6 ;Build list of PCE codes
+7 SET DARRAY("AUTTEDT(")="PED"
+8 SET DARRAY("AUTTEXAM(")="XAM"
+9 SET DARRAY("AUTTHF(")="HF"
+10 SET DARRAY("AUTTIMM(")="IMM"
+11 SET DARRAY("AUTTSK(")="SK"
+12 ;
+13 SET DARRAY("GMRD(120.51,")="VIT"
+14 ;IHS/MSC/MGH - Patch 1001 Support for V MEASUREMENTS
SET DARRAY("AUTTMSR(")="MSR"
+15 SET DARRAY("ORD(101.41,")="Q"
+16 SET DARRAY("YTT(601.71,")="MH"
+17 ;IHS/MSC/MGH -Patch 1001 Support for Asthma
SET DARRAY("APCDACV(")="ASM"
+18 ;
+19 SET DARRAY("ICD9(")="POV"
+20 SET DARRAY("ICPT(")="CPT"
+21 SET DARRAY("WV(790.404,")="WH"
+22 SET DARRAY("WV(790.1,")="WHR"
+23 ;
+24 SET DARRAY("PXD(811.2,")="T"
+25 ;
+26 ;Get the dialog element
+27 SET OCNT=0
+28 NEW TERMNODE,TERMSTAT,TERMOUT
+29 SET DTYP=$PIECE($GET(^PXRMD(801.41,DITEM,0)),U,4)
+30 ;Finding detail
+31 SET DRES=$PIECE($GET(^PXRMD(801.41,DITEM,1)),U,3)
+32 SET DFIND=$PIECE($GET(^PXRMD(801.41,DITEM,1)),U,5)
+33 ;check for WH finding
+34 IF $PIECE($GET(^PXRMD(801.41,DITEM,0)),U,16)["WHR"
SET DFIND=$GET(WHFIND)
+35 ;
+36 SET DFIEN=$PIECE(DFIND,";")
SET DFTYP=$PIECE(DFIND,";",2)
+37 SET DPCE=""
SET DVIT=""
IF DFTYP'=""
SET DPCE=$GET(DARRAY(DFTYP))
+38 ;Exclude from P/N
+39 SET DEXC=$PIECE($GET(^PXRMD(801.41,DITEM,2)),U,3)
+40 ;
+41 ;Non taxonomy codes (3 - finding record)
+42 IF DPCE'="T"
DO FREC(DFIEN,DFTYP)
+43 ;
+44 ;Taxonomy codes need expanding (3 - finding record)
+45 IF DPCE="T"
Begin DoDot:1
+46 SET TAXBUILT=0
+47 IF $GET(DTTYP)=""
Begin DoDot:2
+48 SET TAXNODE=$GET(^PXRMD(801.41,DITEM,"TAX"))
+49 SET TSEL=$PIECE(TAXNODE,U)
IF TSEL="N"
QUIT
+50 SET TDX=$$TOK^PXRMDTAX(DFIEN,"POV")
+51 SET TPR=$$TOK^PXRMDTAX(DFIEN,"CPT")
+52 IF TSEL="D"
SET DTTYP="POV"
SET TAXBUILT=1
QUIT
+53 IF TSEL="P"
SET DTTYP="CPT"
SET TAXBUILT=1
QUIT
+54 IF TDX
IF TPR
QUIT
+55 IF TDX
SET DTTYP="POV"
SET TAXBUILT=1
QUIT
+56 IF TPR
SET DTTYP="CPT"
SET TAXBUILT=1
End DoDot:2
+57 IF $GET(DTTYP)'=""
DO EXP^PXRMDLLB(DITEM,DFIEN,DCUR,DTTYP,5)
IF TAXBUILT=0
QUIT
+58 DO EXPTAX^PXRMDLLB(DITEM,DFIEN,DCUR)
End DoDot:1
+59 ;
+60 ;Prompt details (4 - prompt records)
+61 NEW ARRAY,DTITLE,DREQ,DSEQ,DSSEQ,DSUB,DTYP
+62 ;If not a taxonomy get prompts from dialog file
+63 IF DPCE'="T"
DO PROTH(DITEM,"","")
+64 ;Check for MST findings
+65 IF (DPCE'="T")
IF (DFTYP]"")
DO MST^PXRMDLLB(DFTYP,DFIEN)
+66 ;If taxonomy use finding parameters (CPT/POV)
+67 IF DPCE="T"
Begin DoDot:1
+68 IF $GET(DTTYP)=""
IF $GET(^PXRMD(801.41,DITEM,"TAX"))'="N"
QUIT
+69 ;
+70 IF $DATA(^PXRMD(801.41,DITEM,10,"B"))>0
Begin DoDot:2
+71 IF $GET(DTTYP)'=""
IF $GET(DCUR)'=""
DO PROTH(DITEM,DTTYP,DCUR)
QUIT
+72 DO PROTH(DITEM,"","")
End DoDot:2
QUIT
End DoDot:1
+73 ;Return array of type 4 records
+74 SET DSEQ=""
+75 FOR
SET DSEQ=$ORDER(ARRAY(DSEQ))
IF 'DSEQ
QUIT
Begin DoDot:1
+76 SET OCNT=OCNT+1
+77 SET ORY(OCNT)=4_U_DITEM_U_DSEQ_U_ARRAY(DSEQ)
+78 SET DSSEQ=""
+79 FOR
SET DSSEQ=$ORDER(ARRAY(DSEQ,DSSEQ))
IF 'DSSEQ
QUIT
Begin DoDot:2
+80 SET OCNT=OCNT+1
+81 SET ORY(OCNT)=4_U_DITEM_U_DSEQ_"."_DSSEQ_U_ARRAY(DSEQ,DSSEQ)
End DoDot:2
End DoDot:1
+82 ;
+83 ;Get progress note text if defined
+84 ;I DPCE'="T" D:'DEXC PTXT(DITEM)
+85 ;Build Alternate progress note text for taxonomies with more then one pick list.
+86 IF DTTYP=""
IF 'DEXC
DO PTXT(DITEM)
+87 ;Build Alternate progress note text for taxonomies with one pick list.
+88 IF DPCE="T"
IF DTTYP'=""
IF 'DEXC
DO PTXT(DITEM)
+89 ;Additional findings
+90 NEW FASUB
+91 SET FASUB=0
+92 FOR
SET FASUB=$ORDER(^PXRMD(801.41,DITEM,3,FASUB))
IF 'FASUB
QUIT
Begin DoDot:1
+93 SET DFIND=$PIECE($GET(^PXRMD(801.41,DITEM,3,FASUB,0)),U)
+94 SET DFIEN=$PIECE(DFIND,";")
SET DFTYP=$PIECE(DFIND,";",2)
IF DFTYP=""
QUIT
IF DFIEN=""
QUIT
+95 SET DVIT=""
SET DPCE=$GET(DARRAY(DFTYP))
+96 IF DPCE'=""
IF DPCE'="T"
DO FREC(DFIEN,DFTYP)
+97 IF DPCE'=""
IF DPCE="T"
Begin DoDot:2
+98 DO EXP^PXRMDLLB(DITEM,DFIEN,DCUR,"CPT",3)
+99 DO EXP^PXRMDLLB(DITEM,DFIEN,DCUR,"POV",3)
End DoDot:2
End DoDot:1
+100 ;D EXPTAX^PXRMDLLB(DITEM,DFIEN,DCUR)
+101 QUIT
+102 ;
+103 ;
+104 ;Returns item name
NAME(DFIEN,DFTYP) ;
+1 IF DFTYP=""
QUIT ""
+2 IF DFIEN=""
QUIT ""
+3 NEW NAME,FGLOB,POSN
+4 ;DBIA #4108
+5 IF DFTYP="WV(790.404,"
SET NAME=$PIECE($GET(^WV(790.404,DFIEN,0)),U)
IF NAME]""
QUIT NAME
+6 IF DFTYP="WV(790.1,"
SET NAME=$GET(WHNAME)
KILL WHNAME
IF NAME]""
QUIT NAME
+7 SET POSN=2
+8 IF DFTYP["AUTT"
SET POSN=1
IF DFTYP["AUTTEDT"
SET POSN=4
IF DFTYP["ICD"
SET POSN=3
+9 SET FGLOB=U_DFTYP_DFIEN_",0)"
SET NAME=$PIECE($GET(@FGLOB),U,POSN)
+10 IF (POSN>1)
IF NAME=""
SET NAME=$PIECE($GET(@FGLOB),U)
+11 IF NAME=""
SET NAME=DFIEN
+12 QUIT NAME
+13 ;
PROTH(IEN,DTTYP,DCUR) ; Additional prompts defined in 801.41
+1 NEW DDATA,DDEF,DIEN,DEXC,DGUI,DNAME,DOVR,DREQ,DSEQ,DSNL,DSUB,DFTEXT
+2 NEW DTXT,DTYP,NODE,PRINT,TAX
+3 SET DSEQ=0
+4 FOR
SET DSEQ=$ORDER(^PXRMD(801.41,IEN,10,"B",DSEQ))
IF 'DSEQ
QUIT
Begin DoDot:1
+5 ;Get prompts in sequence
+6 SET DSUB=$ORDER(^PXRMD(801.41,IEN,10,"B",DSEQ,""))
IF 'DSUB
QUIT
+7 SET NODE=$GET(^PXRMD(801.41,IEN,10,DSUB,0))
+8 ;Prompt ien
+9 SET DIEN=$PIECE($GET(^PXRMD(801.41,IEN,10,DSUB,0)),U,2)
IF 'DIEN
QUIT
+10 ;Ignore disabled components, and those that are not prompts
+11 IF $$ISDISAB^PXRMDLL(DIEN)=1
QUIT
+12 IF "PF"'[$PIECE($GET(^PXRMD(801.41,DIEN,0)),U,4)
QUIT
+13 ;check to make sure prompt is apporiate for the taxonomy encounter type
+14 IF $GET(DTTYP)'=""
IF $GET(DCUR)'=""
IF $$TAXPRMPT(DIEN,DTTYP,DCUR)=0
QUIT
+15 ;Set defaults to null
+16 SET DDEF=""
SET DEXC=""
SET DREQ=""
SET DSNL=""
+17 ;Prompt name and GUI process (quit if null)
+18 SET DNAME=$PIECE($GET(^PXRMD(801.41,DIEN,0)),U)
SET DGUI=$$GUI(DIEN)
+19 IF $GET(DGUI)="WH_NOT_PURP"
Begin DoDot:2
+20 SET PRINT=$$GET^XPAR($GET(DUZ)_";VA(200,^SRV.`"_+$GET(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
End DoDot:2
+21 ;Type Prompt or Forced
+22 SET DTYP=$PIECE($GET(^PXRMD(801.41,DIEN,0)),U,4)
+23 IF "PF"[DTYP
Begin DoDot:2
+24 ;Required/Prompt caption
+25 SET DDATA=$GET(^PXRMD(801.41,DIEN,2))
SET DTXT=$PIECE(DDATA,U,4)
+26 ;Default value or forced value
+27 IF DTYP="P"
SET DDEF=$PIECE(DDATA,U)
IF DTYP="F"
SET DDEF=$PIECE(DDATA,U,2)
+28 ;Override caption/start new line/exclude PN from dialog file
+29 SET DDATA=$GET(^PXRMD(801.41,IEN,10,DSUB,0))
SET DREQ=$PIECE(DDATA,U,9)
+30 SET DOVR=$PIECE(DDATA,U,6)
SET DSNL=$PIECE(DDATA,U,7)
SET DEXC=$PIECE(DDATA,U,8)
+31 SET DNAME=DTXT
IF DOVR]""
SET DNAME=DOVR
+32 ;Convert date to fileman format
+33 IF DGUI="VST_DATE"
IF DDEF["T"
SET DDEF=$$DT^XLFDT()
End DoDot:2
+34 SET ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_$GET(DFTEXT)_U_$GET(PRINT)
+35 ;the following section add a comment prompt to the WH review of result
+36 ;section of the reminder dialog
+37 IF DGUI="WH_PAP_RESULT"
IF DFTYP="WV(790.1,"
IF DTYP="P"
Begin DoDot:2
+38 NEW WHCNT,WHFLAG,WHNUM,WHLOOP
+39 SET WHNUM=DSEQ+1
SET WHLOOP=0
+40 FOR WHLOOP=0
Begin DoDot:3
+41 SET (WHCNT,WHFLAG)=0
+42 FOR
SET WHCNT=$ORDER(^PXRMD(801.41,IEN,10,"B",WHCNT))
IF 'WHCNT!(WHFLAG=1)
QUIT
Begin DoDot:4
+43 IF WHCNT=WHNUM
SET WHFLAG=1
SET WHNUM=WHNUM+1
End DoDot:4
+44 IF WHFLAG=0
SET WHLOOP=1
End DoDot:3
+45 SET ARRAY(WHNUM)="COM"_U_U_U_"P"_U_"Comment:"_U_U_U
End DoDot:2
+46 ;Additional checkboxes
+47 IF DGUI="COM"
IF DIEN>1
Begin DoDot:2
+48 NEW DSSEQ,DSUB,DTEXT
+49 SET DSSEQ=0
+50 FOR
SET DSSEQ=$ORDER(^PXRMD(801.41,DIEN,45,"B",DSSEQ))
IF 'DSSEQ
QUIT
Begin DoDot:3
+51 SET DSUB=$ORDER(^PXRMD(801.41,DIEN,45,"B",DSSEQ,""))
IF 'DSUB
QUIT
+52 SET DTEXT=$PIECE($GET(^PXRMD(801.41,DIEN,45,DSUB,0)),U,2)
IF DTEXT=""
QUIT
+53 SET ARRAY(DSEQ,DSSEQ)=U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ
End DoDot:3
End DoDot:2
End DoDot:1
+54 QUIT
+55 ;
PRTAX(FNODE,RSUB) ;Get all additional fields for this resolution type
+1 NEW ACNT,ASUB
+2 NEW DDATA,DDEF,DEXC,DGUI,DNAME,DREQ,DSEQ,DSUB,DTYP,PRINT
+3 SET ASUB=0
SET DSEQ=0
+4 FOR
SET ASUB=$ORDER(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB))
IF 'ASUB
QUIT
Begin DoDot:1
+5 SET DDATA=$GET(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB,0))
IF DDATA=""
QUIT
+6 ;Ignore if disabled
+7 IF $PIECE(DDATA,U,3)=1
QUIT
+8 SET DSUB=$PIECE(DDATA,U)
IF DDATA=""
QUIT
+9 SET DSEQ=DSEQ+1
+10 ;Set defaults to null
+11 SET DDEF=""
SET DEXC=""
SET DREQ=""
SET DSNL=""
+12 ;Prompt name and GUI process (quit if null)
+13 SET DNAME=$PIECE($GET(^PXRMD(801.41,DSUB,0)),U)
SET DGUI=$$GUI(DSUB)
+14 IF $GET(DGUI)="WH_NOT_PURP"
Begin DoDot:2
+15 SET PRINT=$$GET^XPAR($GET(DUZ)_";VA(200,^SRV.`"_+$GET(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
End DoDot:2
+16 ;Type Prompt or Forced
+17 SET DTYP=$PIECE($GET(^PXRMD(801.41,DSUB,0)),U,4)
+18 IF DTYP="P"
Begin DoDot:2
+19 SET DREQ=$PIECE(DDATA,U,2)
SET DTXT=$PIECE($GET(^PXRMD(801.41,DSUB,2)),U,4)
+20 ;Override caption/start new line/exclude from PN from finding type
+21 SET DOVR=$PIECE(DDATA,U,5)
SET DSNL=$PIECE(DDATA,U,6)
SET DEXC=$PIECE(DDATA,U,7)
+22 SET DNAME=DTXT
IF DOVR]""
SET DNAME=DOVR
+23 ;Required/Prompt caption
+24 SET DDATA=$GET(^PXRMD(801.41,DSUB,2))
End DoDot:2
+25 SET ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_U_$GET(PRINT)
End DoDot:1
+26 QUIT
+27 ;
PTXT(ITEM) ;Get progress note (WP) text for type 6 records
+1 NEW ARRAY,LAST,NULL,SUB,TEXT,TXTCNT
+2 SET SUB=0
+3 FOR
SET SUB=$ORDER(^PXRMD(801.41,ITEM,35,SUB))
IF 'SUB
QUIT
Begin DoDot:1
+4 SET ARRAY(SUB)=$GET(^PXRMD(801.41,ITEM,35,SUB,0))
End DoDot:1
+5 SET SUB=0
SET LAST=0
FOR
SET SUB=$ORDER(ARRAY(SUB))
IF 'SUB
QUIT
Begin DoDot:1
+6 SET TEXT=$GET(ARRAY(SUB))
+7 SET NULL=0
IF (TEXT="")!($EXTRACT(TEXT)=" ")
SET NULL=1
+8 IF LAST
IF 'NULL
SET TEXT="<br>"_TEXT
+9 SET TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
+10 SET LAST=0
IF NULL
SET TEXT="<br>"_TEXT
SET LAST=1
+11 SET OCNT=OCNT+1
SET ORY(OCNT)=6_U_ITEM_U_U_TEXT
End DoDot:1
+12 QUIT
+13 ;
+14 ;function to determine if the prompt is valid for the taxonomy encounter type.
TAXPRMPT(DIEN,DTTYP,DCUR) ;
+1 NEW FIND,IEN
+2 SET IEN=$PIECE($GET(^PXRMD(801.41,DIEN,1)),U,4)
IF +IEN=0
QUIT 1
+3 SET FIND=$PIECE($GET(^PXRMD(801.45,IEN,0)),U)
IF FIND=""
QUIT 1
+4 IF FIND=DTTYP
QUIT 1
+5 QUIT 0
+6 ;
