PXRMHF ;SLC/PKR - Handle Health Factor findings. ;23-Mar-2015 10:36;DU
;;2.0;CLINICAL REMINDERS;**6,1001,17,18,1005**;Feb 04, 2005;Build 23
;IHS/MSC/MGH Patch 1001 wrap lookup with $G
;
;=====================================================
CATSORT(FIEVAL,FIND0,FARR) ;Sort all the true health factor findings
;according to the category criteria. FIND0 will be defined only
;for terms.
N CAT,CATLIST,DATE,IND,FI,HFIEN,LDATE,NTRUE,WCR
S HFIEN=""
F S HFIEN=$O(FARR("E","AUTTHF(",HFIEN)) Q:HFIEN="" D
. S FI=0
. F S FI=$O(FARR("E","AUTTHF(",HFIEN,FI)) Q:FI="" D
.. I 'FIEVAL(FI) Q
..;Get the Within Category Rank
.. S WCR=$P(FARR(20,FI,0),U,10)
.. I WCR="" S WCR=$P(FIND0,U,10)
.. I WCR="" S WCR=9999
..;If Within Category Rank is 0 ignore the category and treat it like
..;regular finding (exclude it from the list).
.. I WCR>0 D
... S CAT=$P(^AUTTHF(HFIEN,0),U,3)
...;If the category is null then send a warning.
... I CAT="" D WARN(^AUTTHF(HFIEN,0)) Q
... S CATLIST(CAT,FIEVAL(FI,"DATE"),WCR,FI)=""
... I $G(PXRMDEBG) S FIEVAL(FI,"CAT^WCR")=CAT_U_WCR
;No health factors to categorize then quit.
I '$D(CATLIST) Q
;Only the most recent HF in a category can be true.
S CAT=""
F S CAT=$O(CATLIST(CAT)) Q:CAT="" D
. S LDATE=$O(CATLIST(CAT,""),-1)
.;For each category set all but the most recent HF false.
. S DATE=""
. F S DATE=$O(CATLIST(CAT,DATE)) Q:DATE=LDATE D
.. S WCR=""
.. F S WCR=$O(CATLIST(CAT,DATE,WCR)) Q:WCR="" D
... S FI=""
... F S FI=$O(CATLIST(CAT,DATE,WCR,FI)) Q:FI="" D
.... S FIEVAL(FI)=0
....;If there are multiple occurrences set them all false.
.... S IND=0
.... F S IND=+$O(FIEVAL(FI,IND)) Q:IND=0 S FIEVAL(FI,IND)=0
.;
.;If there is more than on HF on the most recent date then only the
.;one with the highest WCR can be true. The highest possible WCR is 1.
.;Set all with lower WCRs false.
.;If the most recent health factor has multiple occurrences only
.;the first occurrence can be true.
. S (NTRUE,WCR)=0
. F S WCR=$O(CATLIST(CAT,LDATE,WCR)) Q:WCR="" D
.. S FI=""
.. F S FI=$O(CATLIST(CAT,LDATE,WCR,FI)) Q:FI="" D
... I NTRUE=0 D Q
....;If there are multiple sub-occurrences set them all false.
.... S (IND,NTRUE)=1
.... F S IND=+$O(FIEVAL(FI,IND)) Q:IND=0 S FIEVAL(FI,IND)=0
... S FIEVAL(FI)=0
...;If there are multiple sub-occurrences set them all false.
... S IND=0
... F S IND=+$O(FIEVAL(FI,IND)) Q:IND=0 S FIEVAL(FI,IND)=0
Q
;
;=====================================================
EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate health factor findings.
N FIEVT,FILENUM,FINDPA,FINDING,HFIEN,NOINDEX
S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D
. D NOINDEX^PXRMERRH("D",PXRMITEM,FILENUM)
. S NOINDEX=1
E S NOINDEX=0
S HFIEN=""
F S HFIEN=$O(DEFARR("E",ENODE,HFIEN)) Q:+HFIEN=0 D
. S FINDING=""
. F S FINDING=$O(DEFARR("E",ENODE,HFIEN,FINDING)) Q:+FINDING=0 D
.. I NOINDEX S FIEVAL(FINDING)=0 Q
.. K FINDPA
.. M FINDPA=DEFARR(20,FINDING)
.. K FIEVT
.. D FIEVAL^PXRMINDX(FILENUM,"PI",DFN,HFIEN,.FINDPA,.FIEVT)
.. M FIEVAL(FINDING)=FIEVT
.. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
;Sort all the true true findings by category.
D CATSORT(.FIEVAL,"",.DEFARR)
Q
;
;=====================================================
EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate health factor term findings
;for patient lists.
D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST)
Q
;
;=====================================================
EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate health factor terms.
N BDT,EDT,FIEVT,HFIEN,NOINDEX,PFINDPA
N TFINDPA,TFINDING
I $G(^PXRMINDX(9000010.23,"DATE BUILT"))="" D
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),9000010.23)
. S NOINDEX=1
E S NOINDEX=0
S HFIEN=""
F S HFIEN=$O(TERMARR("E",ENODE,HFIEN)) Q:+HFIEN=0 D
. S TFINDING=""
. F S TFINDING=$O(TERMARR("E",ENODE,HFIEN,TFINDING)) Q:+TFINDING=0 D
.. I NOINDEX S TFIEVAL(TFINDING)=0 Q
.. K FIEVT,PFINDPA,TFINDPA
.. M TFINDPA=TERMARR(20,TFINDING)
..;Set the finding parameters.
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
.. D FIEVAL^PXRMINDX(9000010.23,"PI",DFN,HFIEN,.PFINDPA,.FIEVT)
.. M TFIEVAL(TFINDING)=FIEVT
.. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
;Sort all the true true findings by category.
D CATSORT(.TFIEVAL,FINDPA(0),.TERMARR)
Q
;
;=====================================================
GETDATA(DAS,FIEVT) ;Return data for a specified V Health Factor entry.
;DBIA #4250
D VHF^PXPXRM(DAS,.FIEVT)
Q
;
;=====================================================
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
N EM,FIEN,IND,JND,LVL,NAME,NOUT,PNAME,TEMP,TEXTOUT,VDATE
S FIEN=$P(IFIEVAL("FINDING"),";",1)
;IHS/MSC/MGH Patch 1001 wrap with $G
S PNAME=$P($G(^AUTTHF(FIEN,0)),U,1)
;S PNAME=$P(^AUTTHF(FIEN,0),U,1)
S NAME="Health Factor: "_PNAME_" = "
S IND=0
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
. S LVL=$G(IFIEVAL(IND,"VALUE"))
. I LVL'="" S LVL=$$EXTERNAL^DILFD(9000010.23,.04,"",LVL,.EM)
. S VDATE=IFIEVAL(IND,"DATE")
. S TEMP=NAME_LVL_" ("_$$EDATE^PXRMDATE(VDATE)_")"
. D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
S NLINES=NLINES+1,TEXT(NLINES)=""
Q
;
;=====================================================
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
;maintenance output.
N EM,FIEN,IND,JND,LVL,NOUT,PNAME,TEMP,TEXTOUT,VDATE
S FIEN=$P(IFIEVAL("FINDING"),";",1)
;DBIA #3083
;IHS/MSC/MGH PATCH 1001 wrap with $G
S PNAME=$P($G(^AUTTHF(FIEN,0)),U,1)
;S PNAME=$P(^AUTTHF(FIEN,0),U,1)
S NLINES=NLINES+1
S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Health Factor: "_PNAME
S IND=0
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
. S VDATE=IFIEVAL(IND,"DATE")
. S TEMP=$$EDATE^PXRMDATE(VDATE)
. S LVL=$G(IFIEVAL(IND,"VALUE"))
. I LVL'="" D
.. S TEMP=TEMP_" level/severity - "
.. S TEMP=TEMP_$$EXTERNAL^DILFD(9000010.23,.04,"",LVL,.EM)
. D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
. I IFIEVAL(IND,"COMMENTS")'="" D
.. S TEMP="Comments: "_IFIEVAL(IND,"COMMENTS")
.. D FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT)
.. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
S NLINES=NLINES+1,TEXT(NLINES)=""
Q
;
;=====================================================
WARN(HF0) ;Issue a warning if a health factor is missing its category.
N XMSUB
K ^TMP("PXRMXMZ",$J)
S XMSUB="CLINICAL REMINDER DATA PROBLEM, HEALTH FACTOR"
S ^TMP("PXRMXMZ",$J,1,0)="Health Factor "_$P(HF0,U,1)
S ^TMP("PXRMXMZ",$J,2,0)="does not have a category, this is a required field."
S ^TMP("PXRMXMZ",$J,3,0)="This health factor will be ignored for all patients until the problem is fixed."
D SEND^PXRMMSG("PXRMXMZ",XMSUB,"",DUZ)
Q
;
PXRMHF ;SLC/PKR - Handle Health Factor findings. ;23-Mar-2015 10:36;DU
+1 ;;2.0;CLINICAL REMINDERS;**6,1001,17,18,1005**;Feb 04, 2005;Build 23
+2 ;IHS/MSC/MGH Patch 1001 wrap lookup with $G
+3 ;
+4 ;=====================================================
CATSORT(FIEVAL,FIND0,FARR) ;Sort all the true health factor findings
+1 ;according to the category criteria. FIND0 will be defined only
+2 ;for terms.
+3 NEW CAT,CATLIST,DATE,IND,FI,HFIEN,LDATE,NTRUE,WCR
+4 SET HFIEN=""
+5 FOR
SET HFIEN=$ORDER(FARR("E","AUTTHF(",HFIEN))
IF HFIEN=""
QUIT
Begin DoDot:1
+6 SET FI=0
+7 FOR
SET FI=$ORDER(FARR("E","AUTTHF(",HFIEN,FI))
IF FI=""
QUIT
Begin DoDot:2
+8 IF 'FIEVAL(FI)
QUIT
+9 ;Get the Within Category Rank
+10 SET WCR=$PIECE(FARR(20,FI,0),U,10)
+11 IF WCR=""
SET WCR=$PIECE(FIND0,U,10)
+12 IF WCR=""
SET WCR=9999
+13 ;If Within Category Rank is 0 ignore the category and treat it like
+14 ;regular finding (exclude it from the list).
+15 IF WCR>0
Begin DoDot:3
+16 SET CAT=$PIECE(^AUTTHF(HFIEN,0),U,3)
+17 ;If the category is null then send a warning.
+18 IF CAT=""
DO WARN(^AUTTHF(HFIEN,0))
QUIT
+19 SET CATLIST(CAT,FIEVAL(FI,"DATE"),WCR,FI)=""
+20 IF $GET(PXRMDEBG)
SET FIEVAL(FI,"CAT^WCR")=CAT_U_WCR
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;No health factors to categorize then quit.
+22 IF '$DATA(CATLIST)
QUIT
+23 ;Only the most recent HF in a category can be true.
+24 SET CAT=""
+25 FOR
SET CAT=$ORDER(CATLIST(CAT))
IF CAT=""
QUIT
Begin DoDot:1
+26 SET LDATE=$ORDER(CATLIST(CAT,""),-1)
+27 ;For each category set all but the most recent HF false.
+28 SET DATE=""
+29 FOR
SET DATE=$ORDER(CATLIST(CAT,DATE))
IF DATE=LDATE
QUIT
Begin DoDot:2
+30 SET WCR=""
+31 FOR
SET WCR=$ORDER(CATLIST(CAT,DATE,WCR))
IF WCR=""
QUIT
Begin DoDot:3
+32 SET FI=""
+33 FOR
SET FI=$ORDER(CATLIST(CAT,DATE,WCR,FI))
IF FI=""
QUIT
Begin DoDot:4
+34 SET FIEVAL(FI)=0
+35 ;If there are multiple occurrences set them all false.
+36 SET IND=0
+37 FOR
SET IND=+$ORDER(FIEVAL(FI,IND))
IF IND=0
QUIT
SET FIEVAL(FI,IND)=0
End DoDot:4
End DoDot:3
End DoDot:2
+38 ;
+39 ;If there is more than on HF on the most recent date then only the
+40 ;one with the highest WCR can be true. The highest possible WCR is 1.
+41 ;Set all with lower WCRs false.
+42 ;If the most recent health factor has multiple occurrences only
+43 ;the first occurrence can be true.
+44 SET (NTRUE,WCR)=0
+45 FOR
SET WCR=$ORDER(CATLIST(CAT,LDATE,WCR))
IF WCR=""
QUIT
Begin DoDot:2
+46 SET FI=""
+47 FOR
SET FI=$ORDER(CATLIST(CAT,LDATE,WCR,FI))
IF FI=""
QUIT
Begin DoDot:3
+48 IF NTRUE=0
Begin DoDot:4
+49 ;If there are multiple sub-occurrences set them all false.
+50 SET (IND,NTRUE)=1
+51 FOR
SET IND=+$ORDER(FIEVAL(FI,IND))
IF IND=0
QUIT
SET FIEVAL(FI,IND)=0
End DoDot:4
QUIT
+52 SET FIEVAL(FI)=0
+53 ;If there are multiple sub-occurrences set them all false.
+54 SET IND=0
+55 FOR
SET IND=+$ORDER(FIEVAL(FI,IND))
IF IND=0
QUIT
SET FIEVAL(FI,IND)=0
End DoDot:3
End DoDot:2
End DoDot:1
+56 QUIT
+57 ;
+58 ;=====================================================
EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate health factor findings.
+1 NEW FIEVT,FILENUM,FINDPA,FINDING,HFIEN,NOINDEX
+2 SET FILENUM=$$GETFNUM^PXRMDATA(ENODE)
+3 IF $GET(^PXRMINDX(FILENUM,"DATE BUILT"))=""
Begin DoDot:1
+4 DO NOINDEX^PXRMERRH("D",PXRMITEM,FILENUM)
+5 SET NOINDEX=1
End DoDot:1
+6 IF '$TEST
SET NOINDEX=0
+7 SET HFIEN=""
+8 FOR
SET HFIEN=$ORDER(DEFARR("E",ENODE,HFIEN))
IF +HFIEN=0
QUIT
Begin DoDot:1
+9 SET FINDING=""
+10 FOR
SET FINDING=$ORDER(DEFARR("E",ENODE,HFIEN,FINDING))
IF +FINDING=0
QUIT
Begin DoDot:2
+11 IF NOINDEX
SET FIEVAL(FINDING)=0
QUIT
+12 KILL FINDPA
+13 MERGE FINDPA=DEFARR(20,FINDING)
+14 KILL FIEVT
+15 DO FIEVAL^PXRMINDX(FILENUM,"PI",DFN,HFIEN,.FINDPA,.FIEVT)
+16 MERGE FIEVAL(FINDING)=FIEVT
+17 SET FIEVAL(FINDING,"FINDING")=$PIECE(FINDPA(0),U,1)
End DoDot:2
End DoDot:1
+18 ;Sort all the true true findings by category.
+19 DO CATSORT(.FIEVAL,"",.DEFARR)
+20 QUIT
+21 ;
+22 ;=====================================================
EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate health factor term findings
+1 ;for patient lists.
+2 DO EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST)
+3 QUIT
+4 ;
+5 ;=====================================================
EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate health factor terms.
+1 NEW BDT,EDT,FIEVT,HFIEN,NOINDEX,PFINDPA
+2 NEW TFINDPA,TFINDING
+3 IF $GET(^PXRMINDX(9000010.23,"DATE BUILT"))=""
Begin DoDot:1
+4 DO NOINDEX^PXRMERRH("TR",TERMARR("IEN"),9000010.23)
+5 SET NOINDEX=1
End DoDot:1
+6 IF '$TEST
SET NOINDEX=0
+7 SET HFIEN=""
+8 FOR
SET HFIEN=$ORDER(TERMARR("E",ENODE,HFIEN))
IF +HFIEN=0
QUIT
Begin DoDot:1
+9 SET TFINDING=""
+10 FOR
SET TFINDING=$ORDER(TERMARR("E",ENODE,HFIEN,TFINDING))
IF +TFINDING=0
QUIT
Begin DoDot:2
+11 IF NOINDEX
SET TFIEVAL(TFINDING)=0
QUIT
+12 KILL FIEVT,PFINDPA,TFINDPA
+13 MERGE TFINDPA=TERMARR(20,TFINDING)
+14 ;Set the finding parameters.
+15 DO SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+16 DO FIEVAL^PXRMINDX(9000010.23,"PI",DFN,HFIEN,.PFINDPA,.FIEVT)
+17 MERGE TFIEVAL(TFINDING)=FIEVT
+18 SET TFIEVAL(TFINDING,"FINDING")=$PIECE(TFINDPA(0),U,1)
End DoDot:2
End DoDot:1
+19 ;Sort all the true true findings by category.
+20 DO CATSORT(.TFIEVAL,FINDPA(0),.TERMARR)
+21 QUIT
+22 ;
+23 ;=====================================================
GETDATA(DAS,FIEVT) ;Return data for a specified V Health Factor entry.
+1 ;DBIA #4250
+2 DO VHF^PXPXRM(DAS,.FIEVT)
+3 QUIT
+4 ;
+5 ;=====================================================
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+1 NEW EM,FIEN,IND,JND,LVL,NAME,NOUT,PNAME,TEMP,TEXTOUT,VDATE
+2 SET FIEN=$PIECE(IFIEVAL("FINDING"),";",1)
+3 ;IHS/MSC/MGH Patch 1001 wrap with $G
+4 SET PNAME=$PIECE($GET(^AUTTHF(FIEN,0)),U,1)
+5 ;S PNAME=$P(^AUTTHF(FIEN,0),U,1)
+6 SET NAME="Health Factor: "_PNAME_" = "
+7 SET IND=0
+8 FOR
SET IND=+$ORDER(IFIEVAL(IND))
IF IND=0
QUIT
Begin DoDot:1
+9 SET LVL=$GET(IFIEVAL(IND,"VALUE"))
+10 IF LVL'=""
SET LVL=$$EXTERNAL^DILFD(9000010.23,.04,"",LVL,.EM)
+11 SET VDATE=IFIEVAL(IND,"DATE")
+12 SET TEMP=NAME_LVL_" ("_$$EDATE^PXRMDATE(VDATE)_")"
+13 DO FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+14 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
End DoDot:1
+15 SET NLINES=NLINES+1
SET TEXT(NLINES)=""
+16 QUIT
+17 ;
+18 ;=====================================================
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+1 ;maintenance output.
+2 NEW EM,FIEN,IND,JND,LVL,NOUT,PNAME,TEMP,TEXTOUT,VDATE
+3 SET FIEN=$PIECE(IFIEVAL("FINDING"),";",1)
+4 ;DBIA #3083
+5 ;IHS/MSC/MGH PATCH 1001 wrap with $G
+6 SET PNAME=$PIECE($GET(^AUTTHF(FIEN,0)),U,1)
+7 ;S PNAME=$P(^AUTTHF(FIEN,0),U,1)
+8 SET NLINES=NLINES+1
+9 SET TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Health Factor: "_PNAME
+10 SET IND=0
+11 FOR
SET IND=+$ORDER(IFIEVAL(IND))
IF IND=0
QUIT
Begin DoDot:1
+12 SET VDATE=IFIEVAL(IND,"DATE")
+13 SET TEMP=$$EDATE^PXRMDATE(VDATE)
+14 SET LVL=$GET(IFIEVAL(IND,"VALUE"))
+15 IF LVL'=""
Begin DoDot:2
+16 SET TEMP=TEMP_" level/severity - "
+17 SET TEMP=TEMP_$$EXTERNAL^DILFD(9000010.23,.04,"",LVL,.EM)
End DoDot:2
+18 DO FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+19 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
+20 IF IFIEVAL(IND,"COMMENTS")'=""
Begin DoDot:2
+21 SET TEMP="Comments: "_IFIEVAL(IND,"COMMENTS")
+22 DO FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+23 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
End DoDot:2
End DoDot:1
+24 SET NLINES=NLINES+1
SET TEXT(NLINES)=""
+25 QUIT
+26 ;
+27 ;=====================================================
WARN(HF0) ;Issue a warning if a health factor is missing its category.
+1 NEW XMSUB
+2 KILL ^TMP("PXRMXMZ",$JOB)
+3 SET XMSUB="CLINICAL REMINDER DATA PROBLEM, HEALTH FACTOR"
+4 SET ^TMP("PXRMXMZ",$JOB,1,0)="Health Factor "_$PIECE(HF0,U,1)
+5 SET ^TMP("PXRMXMZ",$JOB,2,0)="does not have a category, this is a required field."
+6 SET ^TMP("PXRMXMZ",$JOB,3,0)="This health factor will be ignored for all patients until the problem is fixed."
+7 DO SEND^PXRMMSG("PXRMXMZ",XMSUB,"",DUZ)
+8 QUIT
+9 ;
