Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXRMDBL2

PXRMDBL2.m

Go to the documentation of this file. 
  1. PXRMDBL2 ; SLC/PJH - Reminder Dialog Generation. ;05/08/2000
  1.  ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  1.  ;
  1.  ;Process individual finding
  1.  ;--------------------------
  1. FIND(DATA) ;
  1.  ;Determine finding type
  1.  S FGLOB=$P($P(DATA,U),";",2) Q:FGLOB=""
  1.  S FITEM=$P(DATA,";") Q:FITEM=""
  1.  S FTYP=$G(DEF1(FGLOB)) Q:FTYP=""
  1.  ;Get resolution item (same as finding item)
  1.  S RESN=$P(DATA,U)
  1.  ;Mental Health Test
  1.  I FTYP="MH" Q:'$$MHOK^PXRMDBL3(FITEM)
  1.  ;Check if an entry exists in the finding item dialog file
  1.  I $D(^PXRMD(801.43,"AC",RESN)) D  Q:DIEN
  1.  .S DIEN=$$OK(RESN) Q:'DIEN
  1.  .;Create entry in array used to build reminder dialog
  1.  .S CNT=CNT+1,ARRAY(CNT)=801.43_U_DIEN
  1.  .W !!,CNT,?5,"Finding item dialog "_$$FNAM(RESN)
  1.  ;
  1.  ;Determine names/text for non-taxonomy/orderable item findings
  1.  I (FTYP'="TX")&(FTYP'="OI") D
  1.  .I FTYP="ED" S INAME=$$NAME(FGLOB,FITEM,4)
  1.  .I FTYP="VM" S INAME=$$NAME(FGLOB,FITEM,1)
  1.  .I (FTYP'="ED")&(FTYP'="VM") S INAME=$$NAME(FGLOB,FITEM,2)
  1.  .;Dialog item name root
  1.  .S DNAME=FTYP_" "_INAME
  1.  .;Create array entry for each resolution defined in #801.45
  1.  .D RESOL(FTYP,0)
  1.  ;
  1.  ;Determine names/text for orderable item findings
  1.  I FTYP="OI" D
  1.  .S INAME=$$NAME(FGLOB,FITEM,1)
  1.  .;Dialog item name root
  1.  .S DNAME=FTYP_" "_INAME
  1.  .;Create array entry
  1.  .D RESOL(FTYP,0)
  1.  ;
  1.  ;Determine names/text for taxonomy findings
  1.  I FTYP="TX" S INAME=$$NAME(FGLOB,FITEM,2) D TAXON
  1.  Q
  1.  ;
  1.  ;Get Finding Item name
  1.  ;---------------------
  1. FNAM(FIND) ;
  1.  N DATA,NAME,NODE
  1.  S NAME="Unknown"
  1.  S NODE=$O(^PXRMD(801.43,"AC",FIND,"")) Q:'NODE NAME
  1.  S DATA=$G(^PXRMD(801.43,NODE,0)) Q:DATA="" NAME
  1.  I $P(DATA,U)'="" S NAME=$P(DATA,U)
  1.  S GLOB=$P($P(FIND,U),";",2) S:GLOB]"" NAME=$G(DEF1(GLOB))_" - "_NAME
  1.  Q NAME
  1.  ;
  1.  ;additional prompts in 801.45
  1.  ;----------------------------
  1. FPROMPT(FNODE,RSUB,CNT,ARRAY) ;
  1.  ;Get all additional fields for this resolution type
  1.  N ACNT,ASUB,ATXT,DNODE,RDATA,REXC,ROVR,RREQ,RSNL
  1.  S ASUB=0,ACNT=0
  1.  F  S ASUB=$O(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB)) Q:'ASUB  D
  1.  .S RDATA=$G(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB,0)) Q:RDATA=""
  1.  .;Ignore if disabled
  1.  .I $P(RDATA,U,3)=1 Q
  1.  .S DNODE=$P(RDATA,U) Q:DNODE=""
  1.  .S ATXT=$P($G(^PXRMD(801.41,DNODE,0)),U) Q:ATXT=""
  1.  .S REXC=$P(RDATA,U,7),RSNL=$P(RDATA,U,6)
  1.  .S ROVR=$P(RDATA,U,5),RREQ=$P(RDATA,U,2)
  1.  .;S ATXT=$TR(ATXT,UPPER,LOWER)
  1.  .S ACNT=ACNT+1
  1.  .S ARRAY(CNT,ACNT)=DNODE_U_ROVR_U_RSNL_U_REXC_U_RREQ
  1.  Q
  1.  ;
  1.  ;Health Factor Resolutions
  1.  ;-------------------------
  1. HF(RNODE) ;
  1.  ;Defined in #801.95
  1.  I $D(^PXRMD(801.95,$P(RESN,";"),1,"B",RNODE)) Q 1
  1.  ;Check for local statuses if this is a national code (restricted edit)
  1.  N FOUND,LSUB S FOUND=0,LSUB=""
  1.  I $P($G(^PXRMD(801.9,RNODE,0)),U,6)=1 D
  1.  .F  S LSUB=$O(^PXRMD(801.9,RNODE,10,"B",LSUB)) Q:'LSUB  D  Q:FOUND
  1.  ..S:$D(^PXRMD(801.95,$P(RESN,";"),1,"B",LSUB)) FOUND=1
  1.  Q FOUND
  1.  ;
  1.  ;Returns item name
  1.  ;-----------------
  1. NAME(FGLOB,FITEM,POSN) ;
  1.  N NAME
  1.  S FGLOB=U_FGLOB_FITEM_",0)"
  1.  S NAME=$P($G(@FGLOB),U,POSN)
  1.  I NAME]"" D
  1.  .I FGLOB["ICD9(" S NAME=$P($$ICDDX^ICDCODE(FITEM,""),U,2)
  1.  .I FGLOB["ICPT(" S NAME=$P($$CPT^ICPTCOD(FITEM,""),U,2)_"  "_$TR(NAME,LOWER,UPPER)
  1.  .;I FGLOB["ICD9(" S NAME=NAME_" ("_$P($G(@FGLOB),U)_")"
  1.  .;I FGLOB["ICPT(" S NAME=$P($G(@FGLOB),U)_"  "_$TR(NAME,LOWER,UPPER)
  1.  I NAME="" S NAME=$P($G(@FGLOB),U)
  1.  I NAME="" S NAME=FITEM
  1.  Q NAME
  1.  ;
  1.  ;Checks if an enabled finding item dialog exists
  1.  ;-----------------------------------------------
  1. OK(FIND) ;
  1.  N DATA,DIEN,DTYP,NODE
  1.  S NODE=$O(^PXRMD(801.43,"AC",FIND,"")) Q:'NODE 0
  1.  S DATA=$G(^PXRMD(801.43,NODE,0)) Q:DATA="" 0
  1.  ;Ignore disabled entries
  1.  I $P(DATA,U,3) Q 0
  1.  ;Ignore finding item dialogs no longer valid
  1.  S DIEN=$P(DATA,U,4) Q:DIEN="" 0
  1.  S DATA=$G(^PXRMD(801.41,DIEN,0)) Q:DATA="" 0
  1.  ;Ignore disabled dialogs
  1.  I $P(DATA,U,3)=1 Q 0
  1.  ;Return dialog ien
  1.  Q DIEN
  1.  ;
  1.  ;Create array for each resolution status
  1.  ;---------------------------------------
  1. RESOL(TYP,TAX) ;
  1.  ; Predefined fields :
  1.  ; PNAME - text used in prompt
  1.  ; DNAME - text used in dialog item name
  1.  ; RESN  - finding item
  1.  ;
  1.  ; Taxonomies  TYP=CPT or POV and TAX=1 or 0
  1.  ; Others      TAX=0 (ie: 1 prompt per code)
  1.  ;
  1.  ;Get parameter file node for this finding type
  1.  S FNODE=$O(^PXRMD(801.45,"B",TYP,"")) Q:FNODE=""
  1.  ;Get each resolution type for this finding type
  1.  S RSUB=0
  1.  F  S RSUB=$O(^PXRMD(801.45,FNODE,1,RSUB)) Q:'RSUB  D
  1.  .;Check if resolution type is disabled
  1.  .I $P($G(^PXRMD(801.45,FNODE,1,RSUB,0)),U,2)=1 Q
  1.  .;Construct name for this resolution type
  1.  .S RNODE=$P($G(^PXRMD(801.45,FNODE,1,RSUB,0)),U),RNAME=""
  1.  .I RNODE S RNAME=$P($G(^PXRMD(801.9,RNODE,0)),U,2)
  1.  .I RNAME="" S RNAME=$P($G(^PXRMD(801.9,RNODE,0)),U)
  1.  .;Validate resolution
  1.  .I TYP="HF" Q:'$$HF(RNODE)
  1.  .W !
  1.  .;Create arrays
  1.  .S CNT=CNT+1
  1.  .;Convert dialog item name to UC
  1.  .S DNAME=$TR(DNAME,LOWER,UPPER)
  1.  .;Truncate the item name - without finesse
  1.  .S DSHORT=DNAME_" "_RNAME
  1.  .I $L(DSHORT)>63 S DSHORT=$E(DNAME,1,53)_" "_$E(RNAME,1,9)
  1.  .;Dialog item name,resolution status and finding item
  1.  .I TYP'="OI" S ARRAY(CNT)=DSHORT_U_RNODE_U_RESN_U
  1.  .;For orderable items the finding field is empty
  1.  .I TYP="OI" S ARRAY(CNT)=DSHORT_U_RNODE_U_U_$P(RESN,";")
  1.  .;Append prefix and suffix if NOT a condensed taxonomy
  1.  .S PNAME=INAME
  1.  .I 'TAX D
  1.  ..;Prefix text
  1.  ..S RPRE=$G(^PXRMD(801.45,FNODE,1,RSUB,3)) I RPRE]"" S RPRE=RPRE_" "
  1.  ..;Suffix text
  1.  ..S RSUF=$G(^PXRMD(801.45,FNODE,1,RSUB,4))
  1.  ..I (RSUF]"")&($E(RSUF)'=".") S RSUF=" "_RSUF
  1.  ..;Prompt text
  1.  ..S PNAME=RPRE_$TR(INAME,UPPER,LOWER)_RSUF
  1.  ..;Convert first character
  1.  ..S $E(PNAME)=$TR($E(PNAME),LOWER,UPPER)
  1.  .;Prompt text
  1.  .S WPTXT(CNT,1)=PNAME
  1.  .;test
  1.  .W !,CNT,?5,WPTXT(CNT,1)
  1.  .;Additional prompts from general finding parameters
  1.  .D FPROMPT(FNODE,RSUB,CNT,.ARRAY)
  1.  Q
  1.  ;
  1.  ;Taxonomy Dialog in #801.2
  1.  ;-------------------------
  1. TAXON ;
  1.  S TDPAR=$G(^PXD(811.2,FITEM,"SDZ")),TDTXT="",TDHTXT=""
  1.  S TPPAR=$G(^PXD(811.2,FITEM,"SDZ")),TPTXT="",TPHTXT=""
  1.  S TDMOD=$P(TDPAR,U,1),TPMOD=$P(TPPAR,U,1)
  1.  ;Check what type of taxonomy codes exist
  1.  S TDX=$O(^PXD(811.2,FITEM,80,0))
  1.  S TPR=$O(^PXD(811.2,FITEM,81,0))
  1.  ;
  1.  ;If taxonomy is to be presented as checkbox(s)
  1.  I ('TDMOD)!('TPMOD) D
  1.  .S DNAME=FTYP_" "_INAME
  1.  .;Create arrays
  1.  .S CNT=CNT+1
  1.  .;Convert dialog item name to UC
  1.  .S DNAME=$TR(DNAME,LOWER,UPPER)
  1.  .;Truncate the item name - without finesse
  1.  .S DSHORT=DNAME
  1.  .I $L(DSHORT)>40 S DSHORT=$E(DNAME,1,40)
  1.  .;Dialog item name and finding item
  1.  .S ARRAY(CNT)=DSHORT_U_U_RESN
  1.  .;Prompt text
  1.  .S WPTXT(CNT,1)=INAME
  1.  .W !!,CNT,?5,WPTXT(CNT,1)
  1.  ; 
  1.  ;Individual Diagnoses
  1.  I TDX,TDMOD D
  1.  .N NLINES,CODE,OUTPUT
  1.  .S TSEQ=0,TTYP="POV"
  1.  .F  S TSEQ=$O(^PXD(811.2,FITEM,"SDX","B",TSEQ)) Q:'TSEQ  D
  1.  ..S TSUB=$O(^PXD(811.2,FITEM,"SDX","B",TSEQ,"")) Q:'TSUB
  1.  ..S DATA=$G(^PXD(811.2,FITEM,"SDX",TSUB,0)) Q:DATA=""
  1.  ..S TITEM=$P(DATA,U) Q:'TITEM
  1.  ..;Ignore if disabled
  1.  ..Q:$P(DATA,U,3)=1
  1.  ..;Resolution becomes the diagnosis
  1.  ..S RESN=TITEM_";ICD9("
  1.  ..;Take prompt from user defined text
  1.  ..S INAME=$P(DATA,U,2)
  1.  ..;Otherwise use name of diagnosis
  1.  ..S CODE=$$ICDDX^ICDCODE(TITEM,"")
  1.  ..S NLINES=$$ICDD^ICDCODE($G(CODE),"OUTPUT","")
  1.  ..S INAME=$G(OUTPUT(1))
  1.  ..I INAME="" S FGLOB="ICD9(",INAME=$$NAME(FGLOB,TITEM,3)
  1.  ..;Dialog Item name root
  1.  ..S DNAME="POV "_INAME
  1.  ..;Create array entry for each resolution defined in #801.45
  1.  ..D RESOL(TTYP,0)
  1.  ;
  1.  ;Individual Procedures
  1.  I TPR,TPMOD D
  1.  .S TSEQ=0,TTYP="CPT"
  1.  .F  S TSEQ=$O(^PXD(811.2,FITEM,"SPR","B",TSEQ)) Q:'TSEQ  D
  1.  ..S TSUB=$O(^PXD(811.2,FITEM,"SPR","B",TSEQ,"")) Q:'TSUB
  1.  ..S DATA=$G(^PXD(811.2,FITEM,"SPR",TSUB,0)) Q:DATA=""
  1.  ..S TITEM=$P(DATA,U) Q:'TITEM
  1.  ..;Ignore if disabled
  1.  ..Q:$P(DATA,U,3)=1
  1.  ..;Resolution becomes the procedure
  1.  ..S RESN=TITEM_";ICPT("
  1.  ..;Take prompt from user defined text
  1.  ..S INAME=$P(DATA,U,2)
  1.  ..;Otherwise use name of procedure
  1.  ..I INAME="" S FGLOB="ICPT(",INAME=$$NAME(FGLOB,TITEM,2)
  1.  ..;Dialog Item name root
  1.  ..S DNAME="CPT "_INAME
  1.  ..;Create array entry for each resolution defined in #801.45
  1.  ..D RESOL(TTYP,0)
  1.  Q