BPXRMREF ; IHS/MSC/MGH - Handle Refusal findings. ;16-Aug-2013 12:38;DU
;;2.0;CLINICAL REMINDERS;**1001**;Feb 04 2005;Build 21
;
;Entries in the refuals file can be used in findings for the EHR reminder terms
;=======================================================================
EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate refusal findings.
N ITEM,INVDATE,REFTYP,FINDING,FIEVT
S ITEM=""
F S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:ITEM="" D
. S FINDING=""
. F S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0 D
..M FINDPA=DEFARR(20,FINDING)
..K FIEVT
..D FIEVAL(DFN,ITEM,FINDING,.FINDPA,.FIEVT)
..M FIEVAL(FINDING)=FIEVT
..S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
Q
;
;=======================================================================
EVALTERM(DFN,FINDING,TERMIEN,TFIEVAL) ;Evaluate refusal terms.
N REFIEN,FIND0,FIND3,INVDATE,LFIEVAL,TFIND0,TFIND3,TFINDING
F S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0 D
. S TFINDING=""
. F S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0 D
.. K FIEVT,PFINDPA,TFINDPA
.. M TFINDPA=TERMARR(20,TFINDING)
..;Set the finding parameters.
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
.. D FIEVAL(DFN,ITEM,.PFINDPA,.FIEVT)
.. M TFIEVAL(TFINDING)=FIEVT
.. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
Q
;
;=======================================================================
FIEVAL(DFN,ITEM,FINDING,PFINDPA,FIEVAL) ;
N CONVAL,DATE,IEN,IND,USESTRT,RSLT,TEMP,VALID,VIEN,FIEN,FINISHED,INVDATE
;Set finding to zero to start
;Set the finding search parameters.
N NFOUND,NGET,NOCC,NP,SDIR,SAVE,SSFIND,COND,CASESEN,UCIFS,ICOND,VSLIST
N NP,DAS,IND
D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
S SDIR=$S(NOCC<0:+1,1:-1)
S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
S NGET=$S(UCIFS:50,1:NOCC)
S SSFIND=0,USESTRT=0
S REFTYP=$P($G(DEFARR(20,FINDING,0)),";",1)
D FPDAT(DFN,REFTYP,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)
;If there is a type of refusal to be examined (and there should be),evaluate it
;If there is no condition, then the first finging of this type is sufficient
;If there is a condition for this finding evaluate it.
I NFOUND=0 S FIEVAL=0 Q
S NP=0
S SAVE=0
F IND=1:1:NFOUND Q:NP=NOCC D
. S DAS=$P(FLIST(IND),U,1)
. D GETDATA(DAS,.FIEVD)
. S COND=$G(FIEVD("RESULT"))
. I COND="" S SAVE=1
. E S CONVAL=$$COND(CASESEN,ICOND,.FIEVD)
. I +CONVAL S SAVE=1
. I SAVE D
.. S NP=NP+1
.. S FIEVAL(NP)=CONVAL
.. I COND'="" S FIEVAL(NP,"CONDITION")=CONVAL
.. S FIEVAL(NP,"DAS")=$P(FLIST(IND),U,1)
.. S FIEVAL(NP,"DATE")=$P(FLIST(IND),U,2)
.. M FIEVAL(NP)=FIEVD
.. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=FIEVD
;Save the finding result.
D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL)
S FIEVAL("FILE NUMBER")=9000022
Q
;=======================================================================
FPDAT(DFN,REFTYP,NGET,SDIR,BDT,EDT,NFOUND,FLIST) ;Find pt data
N DAS,DATE,DONE,EDTT,FIEN
S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
S (FINISHED,NFOUND)=0
S DATE=$S(SDIR=+1:BDT-.000001,1:EDTT)
S FIEN="" F S FIEN=$O(^AUPNPREF("AC",DFN,FIEN)) Q:FIEN="" D
.S TEMP=$G(^AUPNPREF(FIEN,0))
.Q:REFTYP'=$P(TEMP,U,1)
.Q:$P(TEMP,U,3)<BDT
.Q:$P(TEMP,U,3)>EDTT
.S NFOUND=NFOUND+1
.S FLIST(NFOUND)=FIEN_U_DATE
Q
;===========================================================
GETDATA(DAS,FIEVD) ;Get refusal data
N TEMP
S TEMP=^AUPNPREF(DAS,0)
S FIEVD("TYPE")=$P(TEMP,U,1)
S FIEVD("DATE")=$P(TEMP,U,3)
S FIEVD("RESULT")=$P(TEMP,U,4)
S FIEVD("POINTER")=$P(TEMP,U,6)
Q
;============================================================
COND(CASESEN,ICOND,FIEVD) ;Check condition for refusal name
N V,CONVAL,BPXFIND,BPXTYPE,BPXTEST,BPXFILE,TERM
S V=FIEVD("RESULT")
S V=$TR(V," ","~")
I 'CASESEN D
.S ICOND=$$UP^XLFSTR(ICOND)
.S V=$$UP^XLFSTR(V)
X ICOND
S CONVAL=$T
I CONVAL=0 D
.;CHECK FOR A REMINDER TERM
.S ICOND=$P(ICOND,"=",2)
.Q:ICOND=""
.S ICOND=$TR(ICOND,"""","")
.S TERM="" S TERM=$O(^PXRMD(811.5,"B",ICOND,TERM))
.Q:TERM=""
.S BPXFIND=0 F S BPXFIND=$O(^PXRMD(811.5,TERM,20,BPXFIND)) Q:BPXFIND="" D
..S BPXTYPE=$P($G(^PXRMD(811.5,TERM,20,BPXFIND,0)),U,1)
..S BPXTEST=$P(BPXTYPE,";",1),BPXFILE=$P(BPXTYPE,";",2)
..I $G(FIEVD("POINTER"))=BPXTEST S CONVAL=1
Q CONVAL
;============================================================
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output
N EM,FIEN,IND,JND,NAME,NOUT,PNAME,RESULT,TEMP,TEXTOUT,VDATE
S FIEN=$P(IFIEVAL("FINDING"),";",1)
S TEMP=^AUPNPREF(FIEN,0)
S PNAME=$P(TEMP,U,1)
S PNAME=$P(^AUTTREFT(PNAME,0),U,1)
S NAME=$$INSCHR^PXRMEXLC(INDENT," ")_"Refusal Type: "_PNAME_" = "
S IND=0
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
. S RESULT=$G(IFIEVAL(IND,"RESULT"))
. I RESULT'="" S RESULT=$$EXTERNAL^DILFD(9000022,.04,"",RESULT,.EM)
. S VDATE=IFIEVAL(IND,"DATE")
. S TEMP=NAME_RESULT_" ("_$$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 REFIEN,EM,FIEN,IND,PNAME,RSLT,TEMP,VDATE
S FIEN=$P(IFIEVAL("FINDING"),";",1)
S PNAME=$P(^AUTTREFT(FIEN,0),U,1)
S NLINES=NLINES+1
S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Refusal Type: "_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 RESULT=$G(IFIEVAL(IND,"RESULT"))
. I RESULT'="" D
.. S TEMP=TEMP_" Service not done - "
.. S TEMP=TEMP_$$EXTERNAL^DILFD(9000022,.04,"",RESULT,.EM)
. 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
;=======================================================================
BPXRMREF ; IHS/MSC/MGH - Handle Refusal findings. ;16-Aug-2013 12:38;DU
+1 ;;2.0;CLINICAL REMINDERS;**1001**;Feb 04 2005;Build 21
+2 ;
+3 ;Entries in the refuals file can be used in findings for the EHR reminder terms
+4 ;=======================================================================
EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate refusal findings.
+1 NEW ITEM,INVDATE,REFTYP,FINDING,FIEVT
+2 SET ITEM=""
+3 FOR
SET ITEM=$ORDER(DEFARR("E",ENODE,ITEM))
IF ITEM=""
QUIT
Begin DoDot:1
+4 SET FINDING=""
+5 FOR
SET FINDING=$ORDER(DEFARR("E",ENODE,ITEM,FINDING))
IF +FINDING=0
QUIT
Begin DoDot:2
+6 MERGE FINDPA=DEFARR(20,FINDING)
+7 KILL FIEVT
+8 DO FIEVAL(DFN,ITEM,FINDING,.FINDPA,.FIEVT)
+9 MERGE FIEVAL(FINDING)=FIEVT
+10 SET FIEVAL(FINDING,"FINDING")=$PIECE(FINDPA(0),U,1)
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
+13 ;=======================================================================
EVALTERM(DFN,FINDING,TERMIEN,TFIEVAL) ;Evaluate refusal terms.
+1 NEW REFIEN,FIND0,FIND3,INVDATE,LFIEVAL,TFIND0,TFIND3,TFINDING
+2 FOR
SET ITEM=$ORDER(TERMARR("E",ENODE,ITEM))
IF +ITEM=0
QUIT
Begin DoDot:1
+3 SET TFINDING=""
+4 FOR
SET TFINDING=$ORDER(TERMARR("E",ENODE,ITEM,TFINDING))
IF +TFINDING=0
QUIT
Begin DoDot:2
+5 KILL FIEVT,PFINDPA,TFINDPA
+6 MERGE TFINDPA=TERMARR(20,TFINDING)
+7 ;Set the finding parameters.
+8 DO SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+9 DO FIEVAL(DFN,ITEM,.PFINDPA,.FIEVT)
+10 MERGE TFIEVAL(TFINDING)=FIEVT
+11 SET TFIEVAL(TFINDING,"FINDING")=$PIECE(TFINDPA(0),U,1)
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
+14 ;=======================================================================
FIEVAL(DFN,ITEM,FINDING,PFINDPA,FIEVAL) ;
+1 NEW CONVAL,DATE,IEN,IND,USESTRT,RSLT,TEMP,VALID,VIEN,FIEN,FINISHED,INVDATE
+2 ;Set finding to zero to start
+3 ;Set the finding search parameters.
+4 NEW NFOUND,NGET,NOCC,NP,SDIR,SAVE,SSFIND,COND,CASESEN,UCIFS,ICOND,VSLIST
+5 NEW NP,DAS,IND
+6 DO SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
+7 DO SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
+8 SET SDIR=$SELECT(NOCC<0:+1,1:-1)
+9 SET NOCC=$SELECT(NOCC<0:-NOCC,1:NOCC)
+10 SET NGET=$SELECT(UCIFS:50,1:NOCC)
+11 SET SSFIND=0
SET USESTRT=0
+12 SET REFTYP=$PIECE($GET(DEFARR(20,FINDING,0)),";",1)
+13 DO FPDAT(DFN,REFTYP,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)
+14 ;If there is a type of refusal to be examined (and there should be),evaluate it
+15 ;If there is no condition, then the first finging of this type is sufficient
+16 ;If there is a condition for this finding evaluate it.
+17 IF NFOUND=0
SET FIEVAL=0
QUIT
+18 SET NP=0
+19 SET SAVE=0
+20 FOR IND=1:1:NFOUND
IF NP=NOCC
QUIT
Begin DoDot:1
+21 SET DAS=$PIECE(FLIST(IND),U,1)
+22 DO GETDATA(DAS,.FIEVD)
+23 SET COND=$GET(FIEVD("RESULT"))
+24 IF COND=""
SET SAVE=1
+25 IF '$TEST
SET CONVAL=$$COND(CASESEN,ICOND,.FIEVD)
+26 IF +CONVAL
SET SAVE=1
+27 IF SAVE
Begin DoDot:2
+28 SET NP=NP+1
+29 SET FIEVAL(NP)=CONVAL
+30 IF COND'=""
SET FIEVAL(NP,"CONDITION")=CONVAL
+31 SET FIEVAL(NP,"DAS")=$PIECE(FLIST(IND),U,1)
+32 SET FIEVAL(NP,"DATE")=$PIECE(FLIST(IND),U,2)
+33 MERGE FIEVAL(NP)=FIEVD
+34 IF $GET(PXRMDEBG)
MERGE FIEVAL(NP,"CSUB")=FIEVD
End DoDot:2
End DoDot:1
+35 ;Save the finding result.
+36 DO SFRES^PXRMUTIL(SDIR,NP,.FIEVAL)
+37 SET FIEVAL("FILE NUMBER")=9000022
+38 QUIT
+39 ;=======================================================================
FPDAT(DFN,REFTYP,NGET,SDIR,BDT,EDT,NFOUND,FLIST) ;Find pt data
+1 NEW DAS,DATE,DONE,EDTT,FIEN
+2 SET EDTT=$SELECT(EDT[".":EDT+.0000001,1:EDT+.240001)
+3 SET (FINISHED,NFOUND)=0
+4 SET DATE=$SELECT(SDIR=+1:BDT-.000001,1:EDTT)
+5 SET FIEN=""
FOR
SET FIEN=$ORDER(^AUPNPREF("AC",DFN,FIEN))
IF FIEN=""
QUIT
Begin DoDot:1
+6 SET TEMP=$GET(^AUPNPREF(FIEN,0))
+7 IF REFTYP'=$PIECE(TEMP,U,1)
QUIT
+8 IF $PIECE(TEMP,U,3)<BDT
QUIT
+9 IF $PIECE(TEMP,U,3)>EDTT
QUIT
+10 SET NFOUND=NFOUND+1
+11 SET FLIST(NFOUND)=FIEN_U_DATE
End DoDot:1
+12 QUIT
+13 ;===========================================================
GETDATA(DAS,FIEVD) ;Get refusal data
+1 NEW TEMP
+2 SET TEMP=^AUPNPREF(DAS,0)
+3 SET FIEVD("TYPE")=$PIECE(TEMP,U,1)
+4 SET FIEVD("DATE")=$PIECE(TEMP,U,3)
+5 SET FIEVD("RESULT")=$PIECE(TEMP,U,4)
+6 SET FIEVD("POINTER")=$PIECE(TEMP,U,6)
+7 QUIT
+8 ;============================================================
COND(CASESEN,ICOND,FIEVD) ;Check condition for refusal name
+1 NEW V,CONVAL,BPXFIND,BPXTYPE,BPXTEST,BPXFILE,TERM
+2 SET V=FIEVD("RESULT")
+3 SET V=$TRANSLATE(V," ","~")
+4 IF 'CASESEN
Begin DoDot:1
+5 SET ICOND=$$UP^XLFSTR(ICOND)
+6 SET V=$$UP^XLFSTR(V)
End DoDot:1
+7 XECUTE ICOND
+8 SET CONVAL=$TEST
+9 IF CONVAL=0
Begin DoDot:1
+10 ;CHECK FOR A REMINDER TERM
+11 SET ICOND=$PIECE(ICOND,"=",2)
+12 IF ICOND=""
QUIT
+13 SET ICOND=$TRANSLATE(ICOND,"""","")
+14 SET TERM=""
SET TERM=$ORDER(^PXRMD(811.5,"B",ICOND,TERM))
+15 IF TERM=""
QUIT
+16 SET BPXFIND=0
FOR
SET BPXFIND=$ORDER(^PXRMD(811.5,TERM,20,BPXFIND))
IF BPXFIND=""
QUIT
Begin DoDot:2
+17 SET BPXTYPE=$PIECE($GET(^PXRMD(811.5,TERM,20,BPXFIND,0)),U,1)
+18 SET BPXTEST=$PIECE(BPXTYPE,";",1)
SET BPXFILE=$PIECE(BPXTYPE,";",2)
+19 IF $GET(FIEVD("POINTER"))=BPXTEST
SET CONVAL=1
End DoDot:2
End DoDot:1
+20 QUIT CONVAL
+21 ;============================================================
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output
+1 NEW EM,FIEN,IND,JND,NAME,NOUT,PNAME,RESULT,TEMP,TEXTOUT,VDATE
+2 SET FIEN=$PIECE(IFIEVAL("FINDING"),";",1)
+3 SET TEMP=^AUPNPREF(FIEN,0)
+4 SET PNAME=$PIECE(TEMP,U,1)
+5 SET PNAME=$PIECE(^AUTTREFT(PNAME,0),U,1)
+6 SET NAME=$$INSCHR^PXRMEXLC(INDENT," ")_"Refusal Type: "_PNAME_" = "
+7 SET IND=0
+8 FOR
SET IND=+$ORDER(IFIEVAL(IND))
IF IND=0
QUIT
Begin DoDot:1
+9 SET RESULT=$GET(IFIEVAL(IND,"RESULT"))
+10 IF RESULT'=""
SET RESULT=$$EXTERNAL^DILFD(9000022,.04,"",RESULT,.EM)
+11 SET VDATE=IFIEVAL(IND,"DATE")
+12 SET TEMP=NAME_RESULT_" ("_$$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 ;============================================================
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+1 ;maintenance output.
+2 NEW REFIEN,EM,FIEN,IND,PNAME,RSLT,TEMP,VDATE
+3 SET FIEN=$PIECE(IFIEVAL("FINDING"),";",1)
+4 SET PNAME=$PIECE(^AUTTREFT(FIEN,0),U,1)
+5 SET NLINES=NLINES+1
+6 SET TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Refusal Type: "_PNAME
+7 SET IND=0
+8 FOR
SET IND=+$ORDER(IFIEVAL(IND))
IF IND=0
QUIT
Begin DoDot:1
+9 SET VDATE=IFIEVAL(IND,"DATE")
+10 SET TEMP=$$EDATE^PXRMDATE(VDATE)
+11 SET RESULT=$GET(IFIEVAL(IND,"RESULT"))
+12 IF RESULT'=""
Begin DoDot:2
+13 SET TEMP=TEMP_" Service not done - "
+14 SET TEMP=TEMP_$$EXTERNAL^DILFD(9000022,.04,"",RESULT,.EM)
End DoDot:2
+15 DO FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+16 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
End DoDot:1
+17 SET NLINES=NLINES+1
SET TEXT(NLINES)=""
+18 QUIT
+19 ;=======================================================================
