PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;Mar 21, 2022@15:21:03
;;2.0;CLINICAL REMINDERS;**6,12,18,26,45,65**;Feb 04, 2005;Build 438
; ICR API/FILE
; 3112 ^GMRD(120.51,
; 2263 $$GET^XPAR
;
EXECLINK(DITEM,VALUE,ID) ;
N DONE,FILE,FIELD,FIND,FINDS,HASVALUE,I,LINK,LINKITEM,LINKTYPE,LINKFUNC,LINKACT
N NODE,NUM,PAT,PKG,OVALUE,PROMPT,PMPTTYPE,RESULT,RTN,SUB,VAL
S NUM=0 F S NUM=$O(^PXRMD(801.41,DITEM,10,NUM)) Q:NUM'>0 D
. S LINK=$G(^PXRMD(801.41,DITEM,10,NUM,"LINK"))
. I LINK=""!(+LINK'>0)!(+$P(LINK,U,2)'=1) Q
. D GETLINK^PXRMDLLB(+LINK,.LINKITEM,.LINKTYPE,.LINKFUNC,.LINKACT)
. I $P(LINKACT,U)'="" Q
. I LINKTYPE="ELEMENT" Q
. S FIND=$P($G(^PXRMD(801.41,+LINKITEM,1)),U,5)
. I FIND'[801.46 Q
. S NODE=$G(^PXRMD(801.46,+FIND,0))
. S PMPTTYPE=$P($G(^PXRMD(801.46,+FIND,2)),U) I PMPTTYPE'>0 Q
. I $P($G(^PXRMD(801.42,PMPTTYPE,0)),U)'=LINKTYPE Q
. S PKG=$P(NODE,U,2)
. ;S PKG=$$EXTERNAL^DILFD(801.46,2,"",$P(NODE,U,2))
. S FILE=$P(NODE,U,3),FIELD=$P($G(^PXRMD(801.46,+FIND,2)),U,2)
. ;I $D(^TMP($J,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD)) Q
. I $G(^TMP($J,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,ID))'="" Q
. S OVALUE=""
. S RTN=$P($G(^PXRMD(801.47,LINKFUNC,0)),U,2,3) Q:$P(RTN,U)="" Q:$P(RTN,U,2)=""
. S NUM=0 F S NUM=$O(^PXRMD(801.48,+LINK,2,NUM)) Q:NUM'>0 D
. .S NODE=$G(^PXRMD(801.48,+LINK,2,+NUM,0)),SUB=$P(NODE,U),VAL=$P(NODE,U,2) Q:SUB="" Q:VAL=""
. .S INPUTS(SUB)=VAL
. S PAT=0
. S TEMP="S RET=$$"_RTN_"(.RESULT,PAT,VALUE,OVALUE,.INPUTS)"
. X TEMP
. I LINKFUNC>0,RESULT="" Q
. S ^TMP($J,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,ID)=RESULT
Q
;
FREC(DFIEN,DFTYP,DITEM,PTDEF,DLGIEN,NDATA) ;Build type 3 record
N CSARRAY,CSCNT
N ARRAY,DATANODE,DCAP,DGUI,DFN,NODE,PRINT,OINAME,STATUS,START,STOP
S PRINT=$S($P($G(^PXRMD(801.41,DLGIEN,"DATA")),U,3)=1:1,1:0)
;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
.;
.I DPCE="IMM"!(DPCE="SK") D
..S DCAP=$P($G(^PXRMD(801.41,DITEM,2)),U,4)
..;S $P(ORY(OCNT),U,10)=DCAP
..S $P(ORY(OCNT),U,10)=$$CTRL^XMXUTIL1(DCAP)
..S $P(ORY(OCNT),U,13)=+$P($G(^PXRMD(801.41,DITEM,"DATA")),U,4)
.S DATANODE=$G(^PXRMD(801.41,DITEM,"DATA"))
.;S $P(ORY(OCNT),U,16)=+$P(DATANODE,U,2)
.S $P(ORY(OCNT),U,16)=+NDATA
.S $P(ORY(OCNT),U,17)=$P(DATANODE,U)
.S $P(ORY(OCNT),U,18)=$S($P(^PXRMD(801.41,DITEM,0),U,16)="IMMREAD":1,1:0)
.;
.I DPCE="GFIND" D
..N FILE,FIELD,ID,NODE,PKGNAME,VALUE,MULVAL,EXIT
..;N CID,NDATA,TYPE,VALUE,X
..N CID,TYPE,VALUE,X
..S NODE(0)=$G(^PXRMD(801.46,DFIEN,0)),NODE(2)=$G(^(2)),NODE(3)=$G(^(3))
..S PKG=$P(NODE(0),U,2)
..;S PKGNAME=$$EXTERNAL^DILFD(801.46,2,"",$P(NODE(0),U,2))
..S FILE=$P(NODE(0),U,3),MULVAL=$P(NODE(3),U)
..;S NDATA=+$P(DATANODE,U,2)
..F X=1,2 D
...S NODE(X)=$G(^PXRMD(801.46,DFIEN,X))
...S FIELD=$P(NODE(X),U,2)
...I X=1 S VALUE=$S('NDATA:$P(NODE(X),U),1:"")
...I FIELD="" Q
...I MULVAL="M",'NDATA D
....S ID="" F S ID=$O(^TMP($J,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,ID)) Q:ID=""!($G(EXIT)) D
.....I $G(^TMP($J,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,ID))=VALUE S EXIT=ID
....I $G(EXIT) S ID=EXIT
...I MULVAL="S",'NDATA S ID=$O(^TMP($J,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,""))
...;Exit Process: If mismatched values on edits
...I $G(ID)'="",X=1,$P(NODE(X),U)'="",$P(NODE(X),U)'=$G(^TMP($J,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,ID)) S $P(ORY(OCNT),U,14)=$G(ID) Q
...;Exit Process: If new values on edits
...I $G(ID)="",X=1,VALUE'="" S $P(ORY(OCNT),U,14)=$G(^TMP($J,"PXRM GEN FINDING",DLGIEN,PKG,FILE)) Q
...;Exit Process: New record
...I $G(ID)="",VALUE="",X=1 Q
...I $G(ID)="",X=2 Q
...;
...S $P(ORY(OCNT),U,14)=$G(ID)
...S $P(ORY(OCNT),U,15)=$S($G(ID)'="":$G(^TMP($J,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,ID)),1:VALUE)
...;I $D(^TMP($J,"PXRM GEN FINDING",DLGIEN,PKG,FILE))=11 S ^TMP($J,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD)=$G(ID)
...;Set default prompt values to be accessed in PROTH line tag
...I $P(NODE(2),U)>0,'NDATA,$G(ID)'="" D
....S DGUI=$P($G(^PXRMD(801.42,$P(NODE(2),U),0)),U)
....I DGUI="GF_PRINT BUTTON",PRINT=0 Q
....;S PTDEF(DGUI)=$P(ORY(OCNT),U,15)
....S PTDEF(DGUI)=$G(^TMP($J,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,ID))
...;
...I $P(ORY(OCNT),U,15)'="",$G(ID)'="" D EXECLINK(DITEM,$P(ORY(OCNT),U,15),ID)
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,DLGIEN,NDATA) ;Load dialog questions into array
N DARRAY,DCOD,DEXC,DFIND,DFIEN,DFTYP,DNAM,DPCE,DRES,DSEQ,DSUB,DTYP,OCNT
N DVIT,MAGNODE,NODE,CNT,IDENT,TAXBUILT,TAXNODE,TDX,TPR,TSC,TSEL
N PTDEF
N RFVAL,ISIMM,ISSKT
I +$G(DITEM)'>0 Q
I $E($G(DLGIEN),1)="R" S DLGIEN=$P($G(^PXD(811.9,$P($G(DLGIEN),"R",2),51)),U)
E S DLGIEN=$G(DLGIEN)
S (ISIMM,ISSKT)=0
;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("ORD(101.41,")="Q"
S DARRAY("YTT(601.71,")="MH"
;
S DARRAY("ICD9(")="POV"
S DARRAY("ICPT(")="CPT"
S DARRAY("WV(790.404,")="WH"
S DARRAY("WV(790.1,")="WHR"
S DARRAY("PXRMD(801.46,")="GFIND"
;
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)["WH" S DFIND=$G(WHFIND) K WHFIND
;
S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)
S MAGNODE=""
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="IMM" S ISIMM=1
I DPCE="SK" S ISSKT=1
S MAGNODE=$$GETMAG^PXRMDLG6(DFIEN,DFTYP)
I DPCE'="T" D
.D FREC(DFIEN,DFTYP,DITEM,.PTDEF,DLGIEN,.NDATA)
.;S MAGNODE=$$GETMAG^PXRMDLG6(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")
..S TSC=$$TOK^PXRMDTAX(DFIEN,"SC")
..I TSEL="D" S DTTYP="POV",TAXBUILT=1 Q
..I TSEL="P" S DTTYP="CPT",TAXBUILT=1 Q
..I TSEL="S" S DTTYP="SC",TAXBUILT=1 Q
..I TDX,TPR,TSC Q
..I TDX,'TPR,'TSC S DTTYP="POV",TAXBUILT=1 Q
..I TPR,'TDX,'TSC S DTTYP="CPT",TAXBUILT=1 Q
..I TSC,'TDX,'TPR S DTTYP="SC",TAXBUILT=1 Q
.I $G(DTTYP)'="" D EXP^PXRMDLLB(DITEM,DFIEN,DCUR,DTTYP,5,NDATA) I TAXBUILT=0 Q
.D EXPTAX^PXRMDLLB(DITEM,DFIEN,DCUR,NDATA)
;
;AGP BEGIN MOVE OF ADD FINDINGS
;Additional findings
N FASUB
S FASUB=0
F S FASUB=$O(^PXRMD(801.41,DITEM,3,FASUB)) Q:'FASUB D
.;new DPCE here to keep the dialog prompts based off the finding item PCE value
.N DPCE
.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,DITEM,.PTDEF,DLGIEN,NDATA)
.I DPCE'="",DPCE="T" D
..D EXP^PXRMDLLB(DITEM,DFIEN,DCUR,"CPT",3,NDATA)
..D EXP^PXRMDLLB(DITEM,DFIEN,DCUR,"POV",3,NDATA)
..D EXP^PXRMDLLB(DITEM,DFIEN,DCUR,"SC",3,NDATA)
;;AGP END MOVE OF ADD FINDINGS
;
;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",'HASVIMM D PROTH(DITEM,"","",.PTDEF,DLGIEN,MAGNODE)
I DPCE'="T",'ISSKT D PROTH(DITEM,"","",.PTDEF,DLGIEN,MAGNODE,ISIMM)
;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 MAGNODE'="" D Q
..I $G(DTTYP)'="",$G(DCUR)'="" D PROTH(DITEM,DTTYP,DCUR,.PTDEF,DLGIEN,MAGNODE,0) Q
..D PROTH(DITEM,"","",.PTDEF,DLGIEN,MAGNODE,0)
.I $D(^PXRMD(801.41,DITEM,10,"B"))>0 D Q
..I $G(DTTYP)'="",$G(DCUR)'="" D PROTH(DITEM,DTTYP,DCUR,.PTDEF,DLGIEN,MAGNODE,0) Q
..D PROTH(DITEM,"","",.PTDEF,DLGIEN,MAGNODE,0)
;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=""
.S $P(ORY(OCNT),U,20)=$G(NDATA)
.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)
..S $P(ORY(OCNT),U,20)=$G(NDATA)
;
;Get progress note text if defined
;Build Alternate progress note text for taxonomies with more then one pick list.
I DTTYP="" D:'DEXC PTXT(DITEM,.NDATA)
;Build Alternate progress note text for taxonomies with one pick list.
I DPCE="T",DTTYP'="" D:'DEXC PTXT(DITEM,.NDATA)
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
I DFTYP="PXRMD(801.46," S NAME=$P($G(^PXRMD(801.46,DFIEN,0)),U) 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,PTDEF,DLGIEN,MAGNODE,ISIMM) ; Additional prompts defined in 801.41
N CANSHOW,DDATA,DDEF,DIEN,DEXC,DGUI,DNAME,DOVR,DREQ,DSEQ,DSNL,DSUB,DFTEXT
N DTXT,DTYP,EVENT,NODE,PRINT,PRINTTYP,SRV,TAX,DVALID
N LINK,LINKITEM,LINKTYPE,LINKFUNC,LINKACT
I MAGNODE'="" D
.S DSEQ=$O(^PXRMD(801.41,IEN,10,"B",""),-1)+1
.S ARRAY(DSEQ)="UCUM"_U_0_U_""_U_"P"_U_$P(MAGNODE,U,5)_U_1_U_1
.S $P(ARRAY(DSEQ),U,27)=MAGNODE
S NODE=$G(^PXRMD(801.41,DLGIEN,"DATA"))
S CANSHOW=$S($P(NODE,U,3)="D":0,$P(NODE,U,3)="":0,1:1)
S PRINTTYP=$P(NODE,U,3)
I CANSHOW=0!(PRINTTYP="S") S PRINTTYP="N"
;
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))
.S EVENT=$S($P(NODE,U,14)'="":$P(NODE,U,14),1:"C")
.;Quit is prompt is marked disable
.I $P(NODE,U,13)=1 Q
.K LINK,LINKITEM,LINKTYPE,LINKFUNC,LINKACT
.S LINK=$G(^PXRMD(801.41,IEN,10,DSUB,"LINK")) I +LINK>0 D GETLINK^PXRMDLLB(+LINK,.LINKITEM,.LINKTYPE,.LINKFUNC,.LINKACT)
.;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)
.;I ISIMM,$P($G(^PXRMD(801.41,DIEN,0)),U,4)'="F" Q
.;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 ISIMM,$P($G(^PXRMD(801.41,DIEN,0)),U,4)'="F" Q
.I ISIMM,DGUI'="IMM_SER" Q
.I DGUI="GF_PRINT",CANSHOW=0 Q
.I $G(DGUI)="WH_NOT_PURP" D
..S SRV=$$GET1^DIQ(200,DUZ,29,"I")
..S PRINTTYP=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
.;I DGUI="GF_VIEW",$G(PRINTTYP)="" S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM PRINT/VIEW BUTTON ACTION",1,"I")
.I DGUI="GF_VIEW" S PRINTTYP="N"
.;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)
..I ISIMM,DGUI="IMM_SER",DTYP="P" S DTYP="F"
..;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()
.I $G(DGUI)'="",$G(PTDEF(DGUI))'="" S DDEF=PTDEF(DGUI)
.;I $G(RFVAL)'="" S DDEF=RFVAL K RFVAL
.I DGUI="DATE" S DVALID=$P(NODE,U,11)
.S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_$G(DFTEXT)_U_$G(PRINTTYP)_U_$G(LINKITEM)_U_$G(LINKTYPE)_U_$G(DVALID)
.S $P(ARRAY(DSEQ),U,25)=$P($G(LINKACT),U,2)
.S $P(ARRAY(DSEQ),U,26)=EVENT
.;
.I DGUI="UCUM",MAGNODE'="" S $P(ARRAY(DSEQ),U,27)=$P(MAGNODE,U,1,4)_U_$P(MAGNODE,U,6)
.;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,NDATA) ;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_U_$G(NDATA)
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMDLLA 16255 printed Dec 13, 2024@01:44:03 Page 2
PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;Mar 21, 2022@15:21:03
+1 ;;2.0;CLINICAL REMINDERS;**6,12,18,26,45,65**;Feb 04, 2005;Build 438
+2 ; ICR API/FILE
+3 ; 3112 ^GMRD(120.51,
+4 ; 2263 $$GET^XPAR
+5 ;
EXECLINK(DITEM,VALUE,ID) ;
+1 NEW DONE,FILE,FIELD,FIND,FINDS,HASVALUE,I,LINK,LINKITEM,LINKTYPE,LINKFUNC,LINKACT
+2 NEW NODE,NUM,PAT,PKG,OVALUE,PROMPT,PMPTTYPE,RESULT,RTN,SUB,VAL
+3 SET NUM=0
FOR
SET NUM=$ORDER(^PXRMD(801.41,DITEM,10,NUM))
if NUM'>0
QUIT
Begin DoDot:1
+4 SET LINK=$GET(^PXRMD(801.41,DITEM,10,NUM,"LINK"))
+5 IF LINK=""!(+LINK'>0)!(+$PIECE(LINK,U,2)'=1)
QUIT
+6 DO GETLINK^PXRMDLLB(+LINK,.LINKITEM,.LINKTYPE,.LINKFUNC,.LINKACT)
+7 IF $PIECE(LINKACT,U)'=""
QUIT
+8 IF LINKTYPE="ELEMENT"
QUIT
+9 SET FIND=$PIECE($GET(^PXRMD(801.41,+LINKITEM,1)),U,5)
+10 IF FIND'[801.46
QUIT
+11 SET NODE=$GET(^PXRMD(801.46,+FIND,0))
+12 SET PMPTTYPE=$PIECE($GET(^PXRMD(801.46,+FIND,2)),U)
IF PMPTTYPE'>0
QUIT
+13 IF $PIECE($GET(^PXRMD(801.42,PMPTTYPE,0)),U)'=LINKTYPE
QUIT
+14 SET PKG=$PIECE(NODE,U,2)
+15 ;S PKG=$$EXTERNAL^DILFD(801.46,2,"",$P(NODE,U,2))
+16 SET FILE=$PIECE(NODE,U,3)
SET FIELD=$PIECE($GET(^PXRMD(801.46,+FIND,2)),U,2)
+17 ;I $D(^TMP($J,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD)) Q
+18 IF $GET(^TMP($JOB,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,ID))'=""
QUIT
+19 SET OVALUE=""
+20 SET RTN=$PIECE($GET(^PXRMD(801.47,LINKFUNC,0)),U,2,3)
if $PIECE(RTN,U)=""
QUIT
if $PIECE(RTN,U,2)=""
QUIT
+21 SET NUM=0
FOR
SET NUM=$ORDER(^PXRMD(801.48,+LINK,2,NUM))
if NUM'>0
QUIT
Begin DoDot:2
+22 SET NODE=$GET(^PXRMD(801.48,+LINK,2,+NUM,0))
SET SUB=$PIECE(NODE,U)
SET VAL=$PIECE(NODE,U,2)
if SUB=""
QUIT
if VAL=""
QUIT
+23 SET INPUTS(SUB)=VAL
End DoDot:2
+24 SET PAT=0
+25 SET TEMP="S RET=$$"_RTN_"(.RESULT,PAT,VALUE,OVALUE,.INPUTS)"
+26 XECUTE TEMP
+27 IF LINKFUNC>0
IF RESULT=""
QUIT
+28 SET ^TMP($JOB,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,ID)=RESULT
End DoDot:1
+29 QUIT
+30 ;
FREC(DFIEN,DFTYP,DITEM,PTDEF,DLGIEN,NDATA) ;Build type 3 record
+1 NEW CSARRAY,CSCNT
+2 NEW ARRAY,DATANODE,DCAP,DGUI,DFN,NODE,PRINT,OINAME,STATUS,START,STOP
+3 SET PRINT=$SELECT($PIECE($GET(^PXRMD(801.41,DLGIEN,"DATA")),U,3)=1:1,1:0)
+4 ;Dialog type/text and resolution
+5 SET DNAM=$$NAME(DFIEN,DFTYP)
+6 ;Translate vitals ien to PCE code - This will need a DBIA
+7 SET DCOD=""
+8 IF DPCE="VIT"
Begin DoDot:1
+9 SET DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E")
+10 ;Vitals Caption
+11 SET DVIT=$PIECE($GET(^PXRMD(801.41,DITEM,2)),U,4)
End DoDot:1
+12 IF DFTYP]""
Begin DoDot:1
+13 SET OCNT=OCNT+1
+14 SET ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$GET(DCOD)_U_DNAM_U_U_DVIT
+15 ;Get order type for orderable items
+16 ;DBIA #3110
+17 if DPCE="Q"
SET $PIECE(ORY(OCNT),U,11)=$PIECE($GET(^ORD(101.41,DFIEN,0)),U,4)
+18 ;If mental health check if a GAF score and if MH test is required
+19 IF DPCE="MH"
IF DFIEN
Begin DoDot:2
+20 ;DBIA #5044
+21 IF $PIECE($GET(^YTT(601.71,DFIEN,0)),U)="GAF"
SET $PIECE(ORY(OCNT),U,12)=1
+22 ;Check to see if the MH test is required
+23 SET $PIECE(ORY(OCNT),U,13)=+$PIECE($GET(^PXRMD(801.41,DITEM,0)),U,18)
+24 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
+25 ;
+26 IF DPCE="IMM"!(DPCE="SK")
Begin DoDot:2
+27 SET DCAP=$PIECE($GET(^PXRMD(801.41,DITEM,2)),U,4)
+28 ;S $P(ORY(OCNT),U,10)=DCAP
+29 SET $PIECE(ORY(OCNT),U,10)=$$CTRL^XMXUTIL1(DCAP)
+30 SET $PIECE(ORY(OCNT),U,13)=+$PIECE($GET(^PXRMD(801.41,DITEM,"DATA")),U,4)
End DoDot:2
+31 SET DATANODE=$GET(^PXRMD(801.41,DITEM,"DATA"))
+32 ;S $P(ORY(OCNT),U,16)=+$P(DATANODE,U,2)
+33 SET $PIECE(ORY(OCNT),U,16)=+NDATA
+34 SET $PIECE(ORY(OCNT),U,17)=$PIECE(DATANODE,U)
+35 SET $PIECE(ORY(OCNT),U,18)=$SELECT($PIECE(^PXRMD(801.41,DITEM,0),U,16)="IMMREAD":1,1:0)
+36 ;
+37 IF DPCE="GFIND"
Begin DoDot:2
+38 NEW FILE,FIELD,ID,NODE,PKGNAME,VALUE,MULVAL,EXIT
+39 ;N CID,NDATA,TYPE,VALUE,X
+40 NEW CID,TYPE,VALUE,X
+41 SET NODE(0)=$GET(^PXRMD(801.46,DFIEN,0))
SET NODE(2)=$GET(^(2))
SET NODE(3)=$GET(^(3))
+42 SET PKG=$PIECE(NODE(0),U,2)
+43 ;S PKGNAME=$$EXTERNAL^DILFD(801.46,2,"",$P(NODE(0),U,2))
+44 SET FILE=$PIECE(NODE(0),U,3)
SET MULVAL=$PIECE(NODE(3),U)
+45 ;S NDATA=+$P(DATANODE,U,2)
+46 FOR X=1,2
Begin DoDot:3
+47 SET NODE(X)=$GET(^PXRMD(801.46,DFIEN,X))
+48 SET FIELD=$PIECE(NODE(X),U,2)
+49 IF X=1
SET VALUE=$SELECT('NDATA:$PIECE(NODE(X),U),1:"")
+50 IF FIELD=""
QUIT
+51 IF MULVAL="M"
IF 'NDATA
Begin DoDot:4
+52 SET ID=""
FOR
SET ID=$ORDER(^TMP($JOB,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,ID))
if ID=""!($GET(EXIT))
QUIT
Begin DoDot:5
+53 IF $GET(^TMP($JOB,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,ID))=VALUE
SET EXIT=ID
End DoDot:5
+54 IF $GET(EXIT)
SET ID=EXIT
End DoDot:4
+55 IF MULVAL="S"
IF 'NDATA
SET ID=$ORDER(^TMP($JOB,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,""))
+56 ;Exit Process: If mismatched values on edits
+57 IF $GET(ID)'=""
IF X=1
IF $PIECE(NODE(X),U)'=""
IF $PIECE(NODE(X),U)'=$GET(^TMP($JOB,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,ID))
SET $PIECE(ORY(OCNT),U,14)=$GET(ID)
QUIT
+58 ;Exit Process: If new values on edits
+59 IF $GET(ID)=""
IF X=1
IF VALUE'=""
SET $PIECE(ORY(OCNT),U,14)=$GET(^TMP($JOB,"PXRM GEN FINDING",DLGIEN,PKG,FILE))
QUIT
+60 ;Exit Process: New record
+61 IF $GET(ID)=""
IF VALUE=""
IF X=1
QUIT
+62 IF $GET(ID)=""
IF X=2
QUIT
+63 ;
+64 SET $PIECE(ORY(OCNT),U,14)=$GET(ID)
+65 SET $PIECE(ORY(OCNT),U,15)=$SELECT($GET(ID)'="":$GET(^TMP($JOB,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,ID)),1:VALUE)
+66 ;I $D(^TMP($J,"PXRM GEN FINDING",DLGIEN,PKG,FILE))=11 S ^TMP($J,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD)=$G(ID)
+67 ;Set default prompt values to be accessed in PROTH line tag
+68 IF $PIECE(NODE(2),U)>0
IF 'NDATA
IF $GET(ID)'=""
Begin DoDot:4
+69 SET DGUI=$PIECE($GET(^PXRMD(801.42,$PIECE(NODE(2),U),0)),U)
+70 IF DGUI="GF_PRINT BUTTON"
IF PRINT=0
QUIT
+71 ;S PTDEF(DGUI)=$P(ORY(OCNT),U,15)
+72 SET PTDEF(DGUI)=$GET(^TMP($JOB,"PXRM GEN FINDING",DLGIEN,PKG,FILE,FIELD,ID))
End DoDot:4
+73 ;
+74 IF $PIECE(ORY(OCNT),U,15)'=""
IF $GET(ID)'=""
DO EXECLINK(DITEM,$PIECE(ORY(OCNT),U,15),ID)
End DoDot:3
End DoDot:2
End DoDot:1
+75 QUIT
+76 ;
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,DLGIEN,NDATA) ;Load dialog questions into array
+1 NEW DARRAY,DCOD,DEXC,DFIND,DFIEN,DFTYP,DNAM,DPCE,DRES,DSEQ,DSUB,DTYP,OCNT
+2 NEW DVIT,MAGNODE,NODE,CNT,IDENT,TAXBUILT,TAXNODE,TDX,TPR,TSC,TSEL
+3 NEW PTDEF
+4 NEW RFVAL,ISIMM,ISSKT
+5 IF +$GET(DITEM)'>0
QUIT
+6 IF $EXTRACT($GET(DLGIEN),1)="R"
SET DLGIEN=$PIECE($GET(^PXD(811.9,$PIECE($GET(DLGIEN),"R",2),51)),U)
+7 IF '$TEST
SET DLGIEN=$GET(DLGIEN)
+8 SET (ISIMM,ISSKT)=0
+9 ;DBIA #3110 OR(101.41
+10 ;
+11 ;Build list of PCE codes
+12 SET DARRAY("AUTTEDT(")="PED"
+13 SET DARRAY("AUTTEXAM(")="XAM"
+14 SET DARRAY("AUTTHF(")="HF"
+15 SET DARRAY("AUTTIMM(")="IMM"
+16 SET DARRAY("AUTTSK(")="SK"
+17 ;
+18 SET DARRAY("GMRD(120.51,")="VIT"
+19 SET DARRAY("ORD(101.41,")="Q"
+20 SET DARRAY("YTT(601.71,")="MH"
+21 ;
+22 SET DARRAY("ICD9(")="POV"
+23 SET DARRAY("ICPT(")="CPT"
+24 SET DARRAY("WV(790.404,")="WH"
+25 SET DARRAY("WV(790.1,")="WHR"
+26 SET DARRAY("PXRMD(801.46,")="GFIND"
+27 ;
+28 SET DARRAY("PXD(811.2,")="T"
+29 ;
+30 ;Get the dialog element
+31 SET OCNT=0
+32 NEW TERMNODE,TERMSTAT,TERMOUT
+33 SET DTYP=$PIECE($GET(^PXRMD(801.41,DITEM,0)),U,4)
+34 ;Finding detail
+35 SET DRES=$PIECE($GET(^PXRMD(801.41,DITEM,1)),U,3)
+36 SET DFIND=$PIECE($GET(^PXRMD(801.41,DITEM,1)),U,5)
+37 ;check for WH finding
+38 IF $PIECE($GET(^PXRMD(801.41,DITEM,0)),U,16)["WH"
SET DFIND=$GET(WHFIND)
KILL WHFIND
+39 ;
+40 SET DFIEN=$PIECE(DFIND,";")
SET DFTYP=$PIECE(DFIND,";",2)
+41 SET MAGNODE=""
+42 SET DPCE=""
SET DVIT=""
IF DFTYP'=""
SET DPCE=$GET(DARRAY(DFTYP))
+43 ;Exclude from P/N
+44 SET DEXC=$PIECE($GET(^PXRMD(801.41,DITEM,2)),U,3)
+45 ;
+46 ;Non taxonomy codes (3 - finding record)
+47 IF DPCE="IMM"
SET ISIMM=1
+48 IF DPCE="SK"
SET ISSKT=1
+49 SET MAGNODE=$$GETMAG^PXRMDLG6(DFIEN,DFTYP)
+50 IF DPCE'="T"
Begin DoDot:1
+51 DO FREC(DFIEN,DFTYP,DITEM,.PTDEF,DLGIEN,.NDATA)
+52 ;S MAGNODE=$$GETMAG^PXRMDLG6(DFIEN,DFTYP)
End DoDot:1
+53 ;
+54 ;Taxonomy codes need expanding (3 - finding record)
+55 IF DPCE="T"
Begin DoDot:1
+56 SET TAXBUILT=0
+57 IF $GET(DTTYP)=""
Begin DoDot:2
+58 SET TAXNODE=$GET(^PXRMD(801.41,DITEM,"TAX"))
+59 SET TSEL=$PIECE(TAXNODE,U)
IF TSEL="N"
QUIT
+60 SET TDX=$$TOK^PXRMDTAX(DFIEN,"POV")
+61 SET TPR=$$TOK^PXRMDTAX(DFIEN,"CPT")
+62 SET TSC=$$TOK^PXRMDTAX(DFIEN,"SC")
+63 IF TSEL="D"
SET DTTYP="POV"
SET TAXBUILT=1
QUIT
+64 IF TSEL="P"
SET DTTYP="CPT"
SET TAXBUILT=1
QUIT
+65 IF TSEL="S"
SET DTTYP="SC"
SET TAXBUILT=1
QUIT
+66 IF TDX
IF TPR
IF TSC
QUIT
+67 IF TDX
IF 'TPR
IF 'TSC
SET DTTYP="POV"
SET TAXBUILT=1
QUIT
+68 IF TPR
IF 'TDX
IF 'TSC
SET DTTYP="CPT"
SET TAXBUILT=1
QUIT
+69 IF TSC
IF 'TDX
IF 'TPR
SET DTTYP="SC"
SET TAXBUILT=1
QUIT
End DoDot:2
+70 IF $GET(DTTYP)'=""
DO EXP^PXRMDLLB(DITEM,DFIEN,DCUR,DTTYP,5,NDATA)
IF TAXBUILT=0
QUIT
+71 DO EXPTAX^PXRMDLLB(DITEM,DFIEN,DCUR,NDATA)
End DoDot:1
+72 ;
+73 ;AGP BEGIN MOVE OF ADD FINDINGS
+74 ;Additional findings
+75 NEW FASUB
+76 SET FASUB=0
+77 FOR
SET FASUB=$ORDER(^PXRMD(801.41,DITEM,3,FASUB))
if 'FASUB
QUIT
Begin DoDot:1
+78 ;new DPCE here to keep the dialog prompts based off the finding item PCE value
+79 NEW DPCE
+80 SET DFIND=$PIECE($GET(^PXRMD(801.41,DITEM,3,FASUB,0)),U)
+81 SET DFIEN=$PIECE(DFIND,";")
SET DFTYP=$PIECE(DFIND,";",2)
if DFTYP=""
QUIT
if DFIEN=""
QUIT
+82 SET DVIT=""
SET DPCE=$GET(DARRAY(DFTYP))
+83 IF DPCE'=""
IF DPCE'="T"
DO FREC(DFIEN,DFTYP,DITEM,.PTDEF,DLGIEN,NDATA)
+84 IF DPCE'=""
IF DPCE="T"
Begin DoDot:2
+85 DO EXP^PXRMDLLB(DITEM,DFIEN,DCUR,"CPT",3,NDATA)
+86 DO EXP^PXRMDLLB(DITEM,DFIEN,DCUR,"POV",3,NDATA)
+87 DO EXP^PXRMDLLB(DITEM,DFIEN,DCUR,"SC",3,NDATA)
End DoDot:2
End DoDot:1
+88 ;;AGP END MOVE OF ADD FINDINGS
+89 ;
+90 ;Prompt details (4 - prompt records)
+91 NEW ARRAY,DTITLE,DREQ,DSEQ,DSSEQ,DSUB,DTYP
+92 ;If not a taxonomy get prompts from dialog file
+93 ;I DPCE'="T",'HASVIMM D PROTH(DITEM,"","",.PTDEF,DLGIEN,MAGNODE)
+94 IF DPCE'="T"
IF 'ISSKT
DO PROTH(DITEM,"","",.PTDEF,DLGIEN,MAGNODE,ISIMM)
+95 ;Check for MST findings
+96 IF (DPCE'="T")
IF (DFTYP]"")
DO MST^PXRMDLLB(DFTYP,DFIEN)
+97 ;If taxonomy use finding parameters (CPT/POV)
+98 IF DPCE="T"
Begin DoDot:1
+99 IF $GET(DTTYP)=""
IF $GET(^PXRMD(801.41,DITEM,"TAX"))'="N"
QUIT
+100 IF MAGNODE'=""
Begin DoDot:2
+101 IF $GET(DTTYP)'=""
IF $GET(DCUR)'=""
DO PROTH(DITEM,DTTYP,DCUR,.PTDEF,DLGIEN,MAGNODE,0)
QUIT
+102 DO PROTH(DITEM,"","",.PTDEF,DLGIEN,MAGNODE,0)
End DoDot:2
QUIT
+103 IF $DATA(^PXRMD(801.41,DITEM,10,"B"))>0
Begin DoDot:2
+104 IF $GET(DTTYP)'=""
IF $GET(DCUR)'=""
DO PROTH(DITEM,DTTYP,DCUR,.PTDEF,DLGIEN,MAGNODE,0)
QUIT
+105 DO PROTH(DITEM,"","",.PTDEF,DLGIEN,MAGNODE,0)
End DoDot:2
QUIT
End DoDot:1
+106 ;Return array of type 4 records
+107 SET DSEQ=""
+108 FOR
SET DSEQ=$ORDER(ARRAY(DSEQ))
if 'DSEQ
QUIT
Begin DoDot:1
+109 SET OCNT=OCNT+1
+110 SET ORY(OCNT)=4_U_DITEM_U_DSEQ_U_ARRAY(DSEQ)
+111 SET DSSEQ=""
+112 SET $PIECE(ORY(OCNT),U,20)=$GET(NDATA)
+113 FOR
SET DSSEQ=$ORDER(ARRAY(DSEQ,DSSEQ))
if 'DSSEQ
QUIT
Begin DoDot:2
+114 SET OCNT=OCNT+1
+115 SET ORY(OCNT)=4_U_DITEM_U_DSEQ_"."_DSSEQ_U_ARRAY(DSEQ,DSSEQ)
+116 SET $PIECE(ORY(OCNT),U,20)=$GET(NDATA)
End DoDot:2
End DoDot:1
+117 ;
+118 ;Get progress note text if defined
+119 ;Build Alternate progress note text for taxonomies with more then one pick list.
+120 IF DTTYP=""
if 'DEXC
DO PTXT(DITEM,.NDATA)
+121 ;Build Alternate progress note text for taxonomies with one pick list.
+122 IF DPCE="T"
IF DTTYP'=""
if 'DEXC
DO PTXT(DITEM,.NDATA)
+123 QUIT
+124 ;
+125 ;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 IF DFTYP="PXRMD(801.46,"
SET NAME=$PIECE($GET(^PXRMD(801.46,DFIEN,0)),U)
if NAME]""
QUIT NAME
+8 SET POSN=2
+9 if DFTYP["AUTT"
SET POSN=1
if DFTYP["AUTTEDT"
SET POSN=4
if DFTYP["ICD"
SET POSN=3
+10 SET FGLOB=U_DFTYP_DFIEN_",0)"
SET NAME=$PIECE($GET(@FGLOB),U,POSN)
+11 IF (POSN>1)
IF NAME=""
SET NAME=$PIECE($GET(@FGLOB),U)
+12 IF NAME=""
SET NAME=DFIEN
+13 QUIT NAME
+14 ;
PROTH(IEN,DTTYP,DCUR,PTDEF,DLGIEN,MAGNODE,ISIMM) ; Additional prompts defined in 801.41
+1 NEW CANSHOW,DDATA,DDEF,DIEN,DEXC,DGUI,DNAME,DOVR,DREQ,DSEQ,DSNL,DSUB,DFTEXT
+2 NEW DTXT,DTYP,EVENT,NODE,PRINT,PRINTTYP,SRV,TAX,DVALID
+3 NEW LINK,LINKITEM,LINKTYPE,LINKFUNC,LINKACT
+4 IF MAGNODE'=""
Begin DoDot:1
+5 SET DSEQ=$ORDER(^PXRMD(801.41,IEN,10,"B",""),-1)+1
+6 SET ARRAY(DSEQ)="UCUM"_U_0_U_""_U_"P"_U_$PIECE(MAGNODE,U,5)_U_1_U_1
+7 SET $PIECE(ARRAY(DSEQ),U,27)=MAGNODE
End DoDot:1
+8 SET NODE=$GET(^PXRMD(801.41,DLGIEN,"DATA"))
+9 SET CANSHOW=$SELECT($PIECE(NODE,U,3)="D":0,$PIECE(NODE,U,3)="":0,1:1)
+10 SET PRINTTYP=$PIECE(NODE,U,3)
+11 IF CANSHOW=0!(PRINTTYP="S")
SET PRINTTYP="N"
+12 ;
+13 SET DSEQ=0
+14 FOR
SET DSEQ=$ORDER(^PXRMD(801.41,IEN,10,"B",DSEQ))
if 'DSEQ
QUIT
Begin DoDot:1
+15 ;Get prompts in sequence
+16 SET DSUB=$ORDER(^PXRMD(801.41,IEN,10,"B",DSEQ,""))
if 'DSUB
QUIT
+17 SET NODE=$GET(^PXRMD(801.41,IEN,10,DSUB,0))
+18 SET EVENT=$SELECT($PIECE(NODE,U,14)'="":$PIECE(NODE,U,14),1:"C")
+19 ;Quit is prompt is marked disable
+20 IF $PIECE(NODE,U,13)=1
QUIT
+21 KILL LINK,LINKITEM,LINKTYPE,LINKFUNC,LINKACT
+22 SET LINK=$GET(^PXRMD(801.41,IEN,10,DSUB,"LINK"))
IF +LINK>0
DO GETLINK^PXRMDLLB(+LINK,.LINKITEM,.LINKTYPE,.LINKFUNC,.LINKACT)
+23 ;Prompt ien
+24 SET DIEN=$PIECE($GET(^PXRMD(801.41,IEN,10,DSUB,0)),U,2)
if 'DIEN
QUIT
+25 ;Ignore disabled components, and those that are not prompts
+26 IF $$ISDISAB^PXRMDLL(DIEN)=1
QUIT
+27 if "PF"'[$PIECE($GET(^PXRMD(801.41,DIEN,0)),U,4)
QUIT
+28 ;I ISIMM,$P($G(^PXRMD(801.41,DIEN,0)),U,4)'="F" Q
+29 ;check to make sure prompt is apporiate for the taxonomy encounter type
+30 IF $GET(DTTYP)'=""
IF $GET(DCUR)'=""
IF $$TAXPRMPT(DIEN,DTTYP,DCUR)=0
QUIT
+31 ;Set defaults to null
+32 SET DDEF=""
SET DEXC=""
SET DREQ=""
SET DSNL=""
+33 ;Prompt name and GUI process (quit if null)
+34 SET DNAME=$PIECE($GET(^PXRMD(801.41,DIEN,0)),U)
SET DGUI=$$GUI(DIEN)
+35 ;I ISIMM,$P($G(^PXRMD(801.41,DIEN,0)),U,4)'="F" Q
+36 IF ISIMM
IF DGUI'="IMM_SER"
QUIT
+37 IF DGUI="GF_PRINT"
IF CANSHOW=0
QUIT
+38 IF $GET(DGUI)="WH_NOT_PURP"
Begin DoDot:2
+39 SET SRV=$$GET1^DIQ(200,DUZ,29,"I")
+40 SET PRINTTYP=$$GET^XPAR($GET(DUZ)_";VA(200,^SRV.`"_+$GET(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
End DoDot:2
+41 ;I DGUI="GF_VIEW",$G(PRINTTYP)="" S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM PRINT/VIEW BUTTON ACTION",1,"I")
+42 IF DGUI="GF_VIEW"
SET PRINTTYP="N"
+43 ;Type Prompt or Forced
+44 SET DTYP=$PIECE($GET(^PXRMD(801.41,DIEN,0)),U,4)
+45 IF "PF"[DTYP
Begin DoDot:2
+46 ;Required/Prompt caption
+47 SET DDATA=$GET(^PXRMD(801.41,DIEN,2))
SET DTXT=$PIECE(DDATA,U,4)
+48 ;Default value or forced value
+49 if DTYP="P"
SET DDEF=$PIECE(DDATA,U)
if DTYP="F"
SET DDEF=$PIECE(DDATA,U,2)
+50 IF ISIMM
IF DGUI="IMM_SER"
IF DTYP="P"
SET DTYP="F"
+51 ;Override caption/start new line/exclude PN from dialog file
+52 SET DDATA=$GET(^PXRMD(801.41,IEN,10,DSUB,0))
SET DREQ=$PIECE(DDATA,U,9)
+53 SET DOVR=$PIECE(DDATA,U,6)
SET DSNL=$PIECE(DDATA,U,7)
SET DEXC=$PIECE(DDATA,U,8)
+54 SET DNAME=DTXT
IF DOVR]""
SET DNAME=DOVR
+55 ;Convert date to fileman format
+56 IF DGUI="VST_DATE"
IF DDEF["T"
SET DDEF=$$DT^XLFDT()
End DoDot:2
+57 IF $GET(DGUI)'=""
IF $GET(PTDEF(DGUI))'=""
SET DDEF=PTDEF(DGUI)
+58 ;I $G(RFVAL)'="" S DDEF=RFVAL K RFVAL
+59 IF DGUI="DATE"
SET DVALID=$PIECE(NODE,U,11)
+60 SET ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_$GET(DFTEXT)_U_$GET(PRINTTYP)_U_$GET(LINKITEM)_U_$GET(LINKTYPE)_U_$GET(DVALID)
+61 SET $PIECE(ARRAY(DSEQ),U,25)=$PIECE($GET(LINKACT),U,2)
+62 SET $PIECE(ARRAY(DSEQ),U,26)=EVENT
+63 ;
+64 IF DGUI="UCUM"
IF MAGNODE'=""
SET $PIECE(ARRAY(DSEQ),U,27)=$PIECE(MAGNODE,U,1,4)_U_$PIECE(MAGNODE,U,6)
+65 ;the following section add a comment prompt to the WH review of result
+66 ;section of the reminder dialog
+67 IF DGUI="WH_PAP_RESULT"
IF DFTYP="WV(790.1,"
IF DTYP="P"
Begin DoDot:2
+68 NEW WHCNT,WHFLAG,WHNUM,WHLOOP
+69 SET WHNUM=DSEQ+1
SET WHLOOP=0
+70 FOR WHLOOP=0
Begin DoDot:3
+71 SET (WHCNT,WHFLAG)=0
+72 FOR
SET WHCNT=$ORDER(^PXRMD(801.41,IEN,10,"B",WHCNT))
if 'WHCNT!(WHFLAG=1)
QUIT
Begin DoDot:4
+73 IF WHCNT=WHNUM
SET WHFLAG=1
SET WHNUM=WHNUM+1
End DoDot:4
+74 IF WHFLAG=0
SET WHLOOP=1
End DoDot:3
+75 SET ARRAY(WHNUM)="COM"_U_U_U_"P"_U_"Comment:"_U_U_U
End DoDot:2
+76 ;Additional checkboxes
+77 IF DGUI="COM"
IF DIEN>1
Begin DoDot:2
+78 NEW DSSEQ,DSUB,DTEXT
+79 SET DSSEQ=0
+80 FOR
SET DSSEQ=$ORDER(^PXRMD(801.41,DIEN,45,"B",DSSEQ))
if 'DSSEQ
QUIT
Begin DoDot:3
+81 SET DSUB=$ORDER(^PXRMD(801.41,DIEN,45,"B",DSSEQ,""))
if 'DSUB
QUIT
+82 SET DTEXT=$PIECE($GET(^PXRMD(801.41,DIEN,45,DSUB,0)),U,2)
if DTEXT=""
QUIT
+83 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
+84 QUIT
+85 ;
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,NDATA) ;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_U_$GET(NDATA)
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 ;
