PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;01/02/2014
;;2.0;CLINICAL REMINDERS;**6,12,16,26**;Feb 04, 2005;Build 404
;
;
CODES(TXIEN,CODESYS,ARRAY) ;
N CNT,CODE,DATES,END,IEN,NODE,START,TEXT,TYPE
S CNT=0
S TYPE="" F S TYPE=$O(CODESYS(TYPE)) Q:TYPE="" D
.S CODE="" F S CODE=$O(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE)) Q:CODE="" D
..S START="" F S START=$O(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE,START)) Q:START="" D
...S END="" F S END=$O(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE,START,END)) Q:END="" D
....S NODE=$G(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE,START,END)) I NODE="" Q
....S IEN=$P(NODE,U),TEXT=$P(NODE,U,2)
....S DATES=START_":"_$S(END>0:END,1:"")
....S CNT=CNT+1,ARRAY(CNT)=IEN_U_$G(CODE)_":"_$G(DATES)_U_$G(TEXT)
Q
;
EXPTAX(DITEM,TIEN,DCUR) ;
;this function handles taxonomy that are set to not display.
N CAT,DTTYP,FIND,FILE,NODE,TSEL
S NODE=$G(^PXRMD(801.41,DITEM,"TAX"))
S TSEL=$P(NODE,U)
I "ND"[TSEL D EXP(DITEM,TIEN,DCUR,"CPT",3)
I "NP"[TSEL D EXP(DITEM,TIEN,DCUR,"POV",3)
Q
;
;
EXP(DITEM,TIEN,DCUR,DTTYP,TYPE) ;Expand taxonomy codes
N CAT,CODES,CODETYPE,CNT,ENC,FILE,LIT
I DTTYP="" Q
;S FILE=$S(DTTYP="POV":80,DTTYP="CPT":81,1:"") Q:'FILE
S LIT="Selectable "_$S(DTTYP="POV":"Diagnoses:",1:"Procedures:")
S CAT=$P($G(^PXD(811.2,TIEN,0)),U)
;
D BLDCODE^PXRMDTAX(DTTYP,.CODETYPE)
;I FILE=80 S CODETYPE("ICD")="",CODETYPE("10D")=""
;I FILE=81 S CODETYPE("CPT")=""
S OCNT=OCNT+1
I TYPE=5 S ORY(OCNT)=3_U_DITEM_U_U_DTTYP_U_1_U_U_U_U_CAT_U_LIT
;Get selectable codes
D CODES(TIEN,.CODETYPE,.CODES)
S CNT=0
;Save selectable codes as type 5 or 3 records
F S CNT=$O(CODES(CNT)) Q:'CNT D
.S OCNT=OCNT+1,ORY(OCNT)=TYPE_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),"D")
.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)=""!($$ISDISAB^PXRMDLL(DITEM)=1) S DITEM=$O(^PXRMD(801.41,"B","VA-DISABLE BRANCHING LOGIC REPLACEMENT ELEMENT","")) 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 $$ISDISAB^PXRMDLL(RESULT)=1 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 $$ISDISAB^PXRMDLL(TEMP)=1 S TEMP="" Q
.S RESULT=$S(RESULT="":TEMP,1:RESULT_"~"_TEMP)
Q RESULT
;
TERM(TERMIEN,DFN,IEN,TYPE) ;
;this section is use to for the term evaluation
N ARRAY,CNT,NODE,RESULT,STR,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))
I TYPE="O" Q +RESULT
;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,DATE
.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
;
PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;01/02/2014
+1 ;;2.0;CLINICAL REMINDERS;**6,12,16,26**;Feb 04, 2005;Build 404
+2 ;
+3 ;
CODES(TXIEN,CODESYS,ARRAY) ;
+1 NEW CNT,CODE,DATES,END,IEN,NODE,START,TEXT,TYPE
+2 SET CNT=0
+3 SET TYPE=""
FOR
SET TYPE=$ORDER(CODESYS(TYPE))
IF TYPE=""
QUIT
Begin DoDot:1
+4 SET CODE=""
FOR
SET CODE=$ORDER(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE))
IF CODE=""
QUIT
Begin DoDot:2
+5 SET START=""
FOR
SET START=$ORDER(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE,START))
IF START=""
QUIT
Begin DoDot:3
+6 SET END=""
FOR
SET END=$ORDER(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE,START,END))
IF END=""
QUIT
Begin DoDot:4
+7 SET NODE=$GET(^PXD(811.2,TXIEN,20,"AUID",TYPE,CODE,START,END))
IF NODE=""
QUIT
+8 SET IEN=$PIECE(NODE,U)
SET TEXT=$PIECE(NODE,U,2)
+9 SET DATES=START_":"_$SELECT(END>0:END,1:"")
+10 SET CNT=CNT+1
SET ARRAY(CNT)=IEN_U_$GET(CODE)_":"_$GET(DATES)_U_$GET(TEXT)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
EXPTAX(DITEM,TIEN,DCUR) ;
+1 ;this function handles taxonomy that are set to not display.
+2 NEW CAT,DTTYP,FIND,FILE,NODE,TSEL
+3 SET NODE=$GET(^PXRMD(801.41,DITEM,"TAX"))
+4 SET TSEL=$PIECE(NODE,U)
+5 IF "ND"[TSEL
DO EXP(DITEM,TIEN,DCUR,"CPT",3)
+6 IF "NP"[TSEL
DO EXP(DITEM,TIEN,DCUR,"POV",3)
+7 QUIT
+8 ;
+9 ;
EXP(DITEM,TIEN,DCUR,DTTYP,TYPE) ;Expand taxonomy codes
+1 NEW CAT,CODES,CODETYPE,CNT,ENC,FILE,LIT
+2 IF DTTYP=""
QUIT
+3 ;S FILE=$S(DTTYP="POV":80,DTTYP="CPT":81,1:"") Q:'FILE
+4 SET LIT="Selectable "_$SELECT(DTTYP="POV":"Diagnoses:",1:"Procedures:")
+5 SET CAT=$PIECE($GET(^PXD(811.2,TIEN,0)),U)
+6 ;
+7 DO BLDCODE^PXRMDTAX(DTTYP,.CODETYPE)
+8 ;I FILE=80 S CODETYPE("ICD")="",CODETYPE("10D")=""
+9 ;I FILE=81 S CODETYPE("CPT")=""
+10 SET OCNT=OCNT+1
+11 IF TYPE=5
SET ORY(OCNT)=3_U_DITEM_U_U_DTTYP_U_1_U_U_U_U_CAT_U_LIT
+12 ;Get selectable codes
+13 DO CODES(TIEN,.CODETYPE,.CODES)
+14 SET CNT=0
+15 ;Save selectable codes as type 5 or 3 records
+16 FOR
SET CNT=$ORDER(CODES(CNT))
IF 'CNT
QUIT
Begin DoDot:1
+17 SET OCNT=OCNT+1
SET ORY(OCNT)=TYPE_U_DITEM_U_U_DTTYP_U_U_CODES(CNT)
End DoDot:1
+18 QUIT
+19 ;
+20 ;Pass MST code as a forced value
MST(DFTYP,DFIEN) ;
+1 ;Validate finding ien
+2 IF DFIEN=""
QUIT
+3 ;For each MST term check if finding is mapped
+4 NEW FOUND,TCOND,TIEN,TNAM,TSUB
+5 SET FOUND=0
+6 FOR TNAM="POSITIVE","NEGATIVE","DECLINES"
Begin DoDot:1
+7 ;Get term IEN
+8 SET TIEN=$ORDER(^PXRMD(811.5,"B","MST "_TNAM_" REPORT",""))
IF 'TIEN
QUIT
+9 ;Check if finding is mapped to term
+10 IF '$DATA(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN))
QUIT
+11 ;If exam and term condition logic is null ignore
+12 IF DFTYP="AUTTEXAM("
Begin DoDot:2
+13 SET TCOND=""
SET TSUB=$ORDER(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN,""))
IF 'TSUB
QUIT
+14 SET TCOND=$PIECE($GET(^PXRMD(811.5,TIEN,20,TSUB,3)),U)
End DoDot:2
IF TCOND=""
QUIT
+15 ;If it is then create additional prompt for MST
+16 NEW DSEQ,DEXC,DDEF,DGUI,DTYP,DTEXT,DSNL,DREQ
+17 ;Add to end of array
+18 SET DSEQ=$ORDER(ARRAY(""),-1)+1
+19 ;Null fields
+20 SET DDEF=""
SET DEXC=""
SET DTEXT=""
SET DSNL=""
SET DREQ=""
+21 ;MST status (exept for exams)
+22 IF DFTYP'="AUTTEXAM("
SET DDEF=$$STCODE^PXRMMST("MST "_TNAM_" REPORT")
+23 ;GUI process and forced value
+24 SET DGUI="MST"
SET DTYP="F"
+25 ;Save in array
+26 SET ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ
+27 ;Quit after the first term is found
+28 SET FOUND=1
End DoDot:1
IF FOUND
QUIT
+29 QUIT
+30 ;
REPLACE(DFN,TERMNODE,DITEM,DATA,TERMSTAT) ;
+1 ;this section is use to compare the term evalution result against
+2 ;the value store in the Reminder Term Status field.
+3 ;If the value match and the replacement item is active then the orginal
+4 ;item will be replace with the new item.
+5 NEW TERMOUT
+6 SET TERMSTAT=1
IF +$PIECE(TERMNODE,U)
IF $PIECE($GET(TERMNODE),U,2)'=""
Begin DoDot:1
+7 NEW DITEMO
+8 SET TERMOUT=$$TERM($PIECE(TERMNODE,U),DFN,$GET(DITEM),"D")
+9 IF TERMOUT'=$PIECE(TERMNODE,U,2)
QUIT
+10 IF +$PIECE(TERMNODE,U,3)'>0
SET TERMSTAT=0
QUIT
+11 SET DITEMO=DITEM
SET DITEM=$PIECE(TERMNODE,U,3)
SET DATA=$GET(^PXRMD(801.41,DITEM,0))
+12 IF $GET(DATA)=""!($$ISDISAB^PXRMDLL(DITEM)=1)
SET DITEM=$ORDER(^PXRMD(801.41,"B","VA-DISABLE BRANCHING LOGIC REPLACEMENT ELEMENT",""))
QUIT
End DoDot:1
IF +TERMSTAT=0
QUIT
+13 QUIT
+14 ;
RESGROUP(DIEN) ;
+1 NEW CNT,RESULT,TEMP
+2 SET RESULT=""
+3 IF $$PATCH^XPDUTL("OR*3.0*243")=0
Begin DoDot:1
+4 SET RESULT=$PIECE($GET(^PXRMD(801.41,DIEN,51,1,0)),U)
IF RESULT=""
QUIT
+5 IF $$ISDISAB^PXRMDLL(RESULT)=1
SET RESULT=""
QUIT
End DoDot:1
QUIT RESULT
+6 SET CNT=0
FOR
SET CNT=$ORDER(^PXRMD(801.41,DIEN,51,CNT))
IF CNT'>0
QUIT
Begin DoDot:1
+7 SET TEMP=$PIECE($GET(^PXRMD(801.41,DIEN,51,CNT,0)),U)
IF TEMP=""
QUIT
+8 IF $$ISDISAB^PXRMDLL(TEMP)=1
SET TEMP=""
QUIT
+9 SET RESULT=$SELECT(RESULT="":TEMP,1:RESULT_"~"_TEMP)
End DoDot:1
+10 QUIT RESULT
+11 ;
TERM(TERMIEN,DFN,IEN,TYPE) ;
+1 ;this section is use to for the term evaluation
+2 NEW ARRAY,CNT,NODE,RESULT,STR,TERMARR
+3 NEW DATEORDR,ESUB,FINDPA,FIEVAL,TFIEVAL,NOCC,BDT,EDT,SDIR,SUB,WVIEN
+4 SET (TERMARR,TFIEVAL,DATEORDR,FIEVAL)=""
+5 ;build term array
+6 DO TERM^PXRMLDR(TERMIEN,.TERMARR)
+7 ;term evaulation
+8 DO IEVALTER^PXRMTERM(DFN,.TERMARR,.TERMARR,1,.FIEVAL)
+9 SET RESULT=$GET(FIEVAL(1))
+10 IF TYPE="O"
QUIT +RESULT
+11 ;if the item is one of the WH review reminders build finding item and
+12 ;text from the the WVALERTS API in PXRMCWH
+13 IF RESULT=1
IF $PIECE($GET(^PXRMD(801.41,IEN,0)),U,16)["WHR"
Begin DoDot:1
+14 NEW IDENT,DATE
+15 SET IDENT=$PIECE($GET(^PXRMD(801.41,IEN,0)),U,16)
+16 IF $GET(FIEVAL(1,"LINK"))=1
IF $GET(FIEVAL(1,"STATUS"))="OPEN"
IF $GET(FIEVAL(1,"VALUE"))="Pending"
Begin DoDot:2
+17 SET WVIEN=$GET(FIEVAL(1,"WVIEN"))
+18 ;DBIA #4102
+19 DO RESULTS^WVALERTS(.ARRAY,WVIEN)
Begin DoDot:3
+20 KILL WHFIND,WHNAME
+21 SET NODE=$GET(ARRAY(0))
IF +$PIECE(NODE,U)'>0
QUIT
+22 SET WHFIND=WVIEN_";WV(790.1,"
SET WHNAME=$PIECE($GET(NODE),U,3)
+23 SET (ESUB,SUB)=0
FOR
SET SUB=$ORDER(DTXT(SUB))
IF SUB'>0
QUIT
SET ESUB=SUB
+24 SET ESUB=ESUB+1
+25 IF IDENT="WHRP"
Begin DoDot:4
+26 NEW MOD
+27 SET DATE=""
+28 SET DTXT(ESUB)=$PIECE($GET(NODE),U,3)
SET ESUB=ESUB+1
+29 SET DATE=$PIECE($GET(NODE),U,4)
SET STR=$$RJ^XLFSTR("Collected: ",20)
+30 SET STR=STR_$PIECE($GET(NODE),U,8)
+31 SET DTXT(ESUB)=STR
SET ESUB=ESUB+1
+32 SET STR=$$RJ^XLFSTR("Lab Accession #: ",20)
SET STR=STR_$PIECE($GET(NODE),U,9)
+33 SET DTXT(ESUB)=STR
SET ESUB=ESUB+1
+34 SET STR=$$RJ^XLFSTR("Specimen: ",20)
SET STR=STR_$PIECE($GET(NODE),U,10)
+35 SET DTXT(ESUB)=STR
End DoDot:4
+36 IF IDENT="WHRM"
Begin DoDot:4
+37 SET STR=$$RJ^XLFSTR("Procedure: ",20)
SET STR=STR_$PIECE($GET(NODE),U,5)
+38 SET DTXT(ESUB)=STR
SET ESUB=ESUB+1
+39 SET STR=$$RJ^XLFSTR("Primary Diagnosis: ",20)
SET STR=STR_$PIECE($GET(NODE),U,6)
+40 SET DTXT(ESUB)=STR
SET ESUB=ESUB+1
+41 SET STR=$$RJ^XLFSTR("Modifiers: ",20)
SET MOD=$PIECE($GET(NODE),U,7)
+42 IF $GET(MOD)=""
SET STR=STR_"<none>"
+43 IF '$TEST
SET STR=STR_$PIECE($GET(MOD),"~",1)
+44 SET DTXT(ESUB)=STR
SET ESUB=ESUB+1
+45 IF $PIECE($GET(MOD),"~",2)'=""
SET DTXT(ESUB)=$$LJ^XLFSTR($PIECE(MOD,"~",2),23)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+46 QUIT +RESULT
+47 ;
