BPXRMREF.m

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      ;=======================================================================