source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLLB.m@ 1154

PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;05/01/2007
 ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
 ;
CODE(DFIEN,DFTYP,ARRAY) ;
 N ARY,CNT,CNT1
 I DFTYP["ICD9" S CODE=$P($G(^ICD9(DFIEN,0)),U) D PERIOD^ICDAPIU(CODE,.ARY)
 I DFTYP["ICPT" S CODE=$P($$CPT^ICPTCOD(DFIEN),U,2) D PERIOD^ICPTAPIU(CODE,.ARY)
 I $D(ARY)'>0 Q
 I $P($G(ARY(0)),U,2)'>0 Q
 S (CNT,CNT1)=0
 F  S CNT=$O(ARY(CNT)) Q:CNT=""  D
 . S ARRAY(CNT1)=CODE_":"_CNT_":"_$P($G(ARY(CNT)),U)
 . S CNT1=CNT1+1
 Q
 ;
CODES(FILE,TXIEN,ARRAY) ;Return selectable codes from taxonomy file
 N CNT,CODE,CSCNT,DATA,DATES,DISPLAY,IEN,INSTALL,TEMP,TEXT,NODE,SUB
 S SUB=0,CNT=0,NODE=$S(FILE=80:"SDX",FILE=81:"SPR")
 F  S SUB=$O(^PXD(811.2,TXIEN,NODE,SUB)) Q:'SUB  D
 .S DATA=$G(^PXD(811.2,TXIEN,NODE,SUB,0)) Q:DATA=""
 .;Ignore if disabled
 .S DISPLAY=""
 .I $P(DATA,U,3)=1 Q
 .;Get ien of code
 .S IEN=$P(DATA,U) Q:IEN=""
 .;get date ranges and text from period api
 .K ARY
 .I FILE=80 S CODE=$P($G(^ICD9(IEN,0)),U)
 .I FILE=81 S CODE=$P($$CPT^ICPTCOD(IEN),U,2)
 .S DISPLAY=$P($G(DATA),U,2)
 .S TEMP=$$CODE^PXRMVAL(CODE,FILE) Q:'$P(TEMP,U)  Q:$P(TEMP,U,9)=1
 .;Set display text from taxonomy selectable code text
 .S TEXT=$P(DATA,U,2)
 .;otherwise use icd9/cpt description
 .I TEXT="",FILE=80 S TEXT=$P($$ICDDX^ICDCODE(IEN),U,3)
 .I TEXT="",FILE=81 S TEXT=$P($$CPT^ICPTCOD(IEN),U,3)
 .I FILE=80 D PERIOD^ICDAPIU(CODE,.ARY)
 .I FILE=81 D PERIOD^ICPTAPIU(CODE,.ARY)
 .I $D(ARY)'>0 Q
 .I $P($G(ARY(0)),U,2)'>0 Q
 .S CSCNT=0 F  S CSCNT=$O(ARY(CSCNT)) Q:CSCNT=""  D
 ..S DATES=":"_CSCNT_":"_$P($G(ARY(CSCNT)),U)
 ..S TEXT=$P($G(ARY(CSCNT)),U,2) I $G(DISPLAY)'="" S TEXT=DISPLAY
 ..S CNT=CNT+1,ARRAY(CNT)=IEN_U_$G(CODE)_$G(DATES)_U_$G(TEXT)
 Q
 ;
EXP(TIEN,DCUR,DTTYP) ;Expand taxonomy codes
 N CODES,CNT,FILE,LIT,CAT
 S FILE=$S(DTTYP="POV":80,DTTYP="CPT":81,1:"") Q:'FILE
 S LIT="Selectable "_$S(FILE=80:"Diagnoses:",1:"Procedures:")
 S CAT=$P($G(^PXD(811.2,TIEN,0)),U)
 ;
 S OCNT=OCNT+1
 S ORY(OCNT)=3_U_DITEM_U_U_DTTYP_U_U_U_U_U_CAT_U_LIT
 ;Get selectable codes
 D CODES(FILE,TIEN,.CODES)
 S CNT=0
 ;Save selectable codes as type 5 records
 F  S CNT=$O(CODES(CNT)) Q:'CNT  D
 .S OCNT=OCNT+1,ORY(OCNT)=5_U_DITEM_U_U_DTTYP_U_U_CODES(CNT)
 Q
 ;
 ;Pass MST code as a forced value
MST(DFTYP,DFIEN) ;
 ;Validate finding ien
 Q:DFIEN=""
 ;For each MST term check if finding is mapped
 N FOUND,TCOND,TIEN,TNAM,TSUB
 S FOUND=0
 F TNAM="POSITIVE","NEGATIVE","DECLINES" D  Q:FOUND
 .;Get term IEN
 .S TIEN=$O(^PXRMD(811.5,"B","MST "_TNAM_" REPORT","")) Q:'TIEN
 .;Check if finding is mapped to term
 .Q:'$D(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN))
 .;If exam and term condition logic is null ignore
 .I DFTYP="AUTTEXAM(" D  Q:TCOND=""
 ..S TCOND="",TSUB=$O(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN,"")) Q:'TSUB
 ..S TCOND=$P($G(^PXRMD(811.5,TIEN,20,TSUB,3)),U)
 .;If it is then create additional prompt for MST
 .N DSEQ,DEXC,DDEF,DGUI,DTYP,DTEXT,DSNL,DREQ
 .;Add to end of array
 .S DSEQ=$O(ARRAY(""),-1)+1
 .;Null fields
 .S DDEF="",DEXC="",DTEXT="",DSNL="",DREQ=""
 .;MST status (exept for exams)
 .I DFTYP'="AUTTEXAM(" S DDEF=$$STCODE^PXRMMST("MST "_TNAM_" REPORT")
 .;GUI process and forced value
 .S DGUI="MST",DTYP="F"
 .;Save in array
 .S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ
 .;Quit after the first term is found
 .S FOUND=1
 Q
 ;
REPLACE(DFN,TERMNODE,DITEM,DATA,TERMSTAT) ;
 ;this section is use to compare the term evalution result against
 ;the value store in the Reminder Term Status field.
 ;If the value match and the replacement item is active then the orginal
 ;item will be replace with the new item.
 N TERMOUT
 S TERMSTAT=1 I +$P(TERMNODE,U),$P($G(TERMNODE),U,2)'="" D  Q:+TERMSTAT=0
 .N DITEMO
 .S TERMOUT=$$TERM($P(TERMNODE,U),DFN,$G(DITEM))
 .I TERMOUT'=$P(TERMNODE,U,2) Q
 .I +$P(TERMNODE,U,3)'>0 S TERMSTAT=0 Q
 .S DITEMO=DITEM,DITEM=$P(TERMNODE,U,3),DATA=$G(^PXRMD(801.41,DITEM,0))
 .I $G(DATA)=""!($P(DATA,U,3)]"") S DITEM=DITEMO Q
 Q
 ;
RESGROUP(DIEN) ;
 N CNT,RESULT,TEMP
 S RESULT=""
 I $$PATCH^XPDUTL("OR*3.0*243")=0 D  Q RESULT
 .S RESULT=$P($G(^PXRMD(801.41,DIEN,51,1,0)),U) I RESULT="" Q
 .I $P($G(^PXRMD(801.41,RESULT,0)),U,3)'="" S RESULT="" Q
 S CNT=0 F  S CNT=$O(^PXRMD(801.41,DIEN,51,CNT)) Q:CNT'>0  D
 .S TEMP=$P($G(^PXRMD(801.41,DIEN,51,CNT,0)),U) I TEMP="" Q
 .I $P($G(^PXRMD(801.41,TEMP,0)),U,3)'="" S TEMP="" Q
 .S RESULT=$S(RESULT="":TEMP,1:RESULT_"~"_TEMP)
 Q RESULT
 ;
TERM(TERMIEN,DFN,IEN) ;
 ;this section is use to for the term evaluation
 N ARRAY,CNT,NODE,RESULT,TERMARR
 N DATEORDR,ESUB,FINDPA,FIEVAL,TFIEVAL,NOCC,BDT,EDT,SDIR,SUB,WVIEN
 S (TERMARR,TFIEVAL,DATEORDR,FIEVAL)=""
 ;build term array
 D TERM^PXRMLDR(TERMIEN,.TERMARR)
 ;term evaulation
 D IEVALTER^PXRMTERM(DFN,.TERMARR,.TERMARR,1,.FIEVAL)
 S RESULT=$G(FIEVAL(1))
 ;if the item is one of the WH review reminders build finding item and
 ;text from the  the WVALERTS API in PXRMCWH
 I RESULT=1,$P($G(^PXRMD(801.41,IEN,0)),U,16)["WHR" D
 .N IDENT
 .S IDENT=$P($G(^PXRMD(801.41,IEN,0)),U,16)
 .I $G(FIEVAL(1,"LINK"))=1,$G(FIEVAL(1,"STATUS"))="OPEN",$G(FIEVAL(1,"VALUE"))="Pending" D
 ..S WVIEN=$G(FIEVAL(1,"WVIEN"))
 ..;DBIA #4102
 ..D RESULTS^WVALERTS(.ARRAY,WVIEN) D
 ...K WHFIND,WHNAME
 ...S NODE=$G(ARRAY(0)) I +$P(NODE,U)'>0 Q
 ...S WHFIND=WVIEN_";WV(790.1,",WHNAME=$P($G(NODE),U,3)
 ...S (ESUB,SUB)=0 F  S SUB=$O(DTXT(SUB)) Q:SUB'>0  S ESUB=SUB
 ...S ESUB=ESUB+1
 ...I IDENT="WHRP" D
 ....N MOD
 ....S DATE=""
 ....S DTXT(ESUB)=$P($G(NODE),U,3),ESUB=ESUB+1
 ....S DATE=$P($G(NODE),U,4),STR=$$RJ^XLFSTR("Collected: ",20)
 ....S STR=STR_$P($G(NODE),U,8)
 ....S DTXT(ESUB)=STR,ESUB=ESUB+1
 ....S STR=$$RJ^XLFSTR("Lab Accession #: ",20),STR=STR_$P($G(NODE),U,9)
 ....S DTXT(ESUB)=STR,ESUB=ESUB+1
 ....S STR=$$RJ^XLFSTR("Specimen: ",20),STR=STR_$P($G(NODE),U,10)
 ....S DTXT(ESUB)=STR
 ...I IDENT="WHRM" D
 ....S STR=$$RJ^XLFSTR("Procedure: ",20),STR=STR_$P($G(NODE),U,5)
 ....S DTXT(ESUB)=STR,ESUB=ESUB+1
 ....S STR=$$RJ^XLFSTR("Primary Diagnosis: ",20),STR=STR_$P($G(NODE),U,6)
 ....S DTXT(ESUB)=STR,ESUB=ESUB+1
 ....S STR=$$RJ^XLFSTR("Modifiers: ",20),MOD=$P($G(NODE),U,7)
 ....I $G(MOD)="" S STR=STR_"<none>"
 ....E  S STR=STR_$P($G(MOD),"~",1)
 ....S DTXT(ESUB)=STR,ESUB=ESUB+1
 ....I $P($G(MOD),"~",2)'="" S DTXT(ESUB)=$$LJ^XLFSTR($P(MOD,"~",2),23)
 Q +RESULT
 ;