PXRMLOCF.m

PXRMLOCF ;SLC/PKR - Handle location findings. ;07/18/2012

 ;;2.0;CLINICAL REMINDERS;**4,6,11,12,18,24**;Feb 04, 2005;Build 193

 ;This routine is for location list patient findings.

 ;=================================================

ALL(FILENUM,DFN,PFINDPA,FIEVAL) ;Get all Visits with a location

 ;for a patient.

 N BDT,BTIME,CASESEN,COND,CONVAL,DAS,DATE,DEND,DONE,DS,EDT,ETIME,FIEVD

 N ICOND,INVBD,INVDATE,INVDT,INVED,NFOUND,NOCC

 N SAVE,SDIR,TEMP,TIME,UCIFS

 ;Set the finding search parameters.

 D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)

 I $G(PXRMDEBG) S FIEVAL("BDTE")=BDT,FIEVAL("EDTE")=EDT

 S SDIR=$S(NOCC<0:-1,1:1)

 S NOCC=$S(NOCC<0:-NOCC,1:NOCC)

 D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)

 I $G(PXRMDEBG) S FIEVAL("BDTE")=BDT,FIEVAL("EDTE")=EDT

 S (DONE,NFOUND)=0

 S DEND=$S(EDT[".":EDT,1:EDT+.235959)

 S INVBD=9999999-$P(BDT,".",1),BTIME="."_$P(BDT,".",2)

 S INVED=9999999-$P(DEND,".",1),ETIME="."_$P(DEND,".",2)

 I SDIR=1 S DS=INVED-.000001

 I SDIR=-1 S DS=INVBD+.000001

 S INVDT=DS,(DONE,NFOUND)=0

 ;DBIA 2028

 F  S INVDT=$O(^AUPNVSIT("AA",DFN,INVDT),SDIR) Q:(DONE)!(INVDT="")  D

 . S INVDATE=$P(INVDT,".",1)

 . I (SDIR=1),INVDATE>INVBD S DONE=1 Q

 . I (SDIR=-1),INVDATE<INVED S DONE=1 Q

 . S TIME="."_$P(INVDT,".",2)

 . I INVDATE=INVED,TIME>ETIME Q

 . I INVDATE=INVBD,TIME<BTIME Q

 . S DAS=0

 . F  S DAS=$O(^AUPNVSIT("AA",DFN,INVDT,DAS)) Q:(DAS="")!(DONE)  D

 .. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)

 .. S DATE=$P(^AUPNVSIT(DAS,0),U,1)

 .. S FIEVD("DATE")=DATE

 .. S CONVAL=$S(COND="":1,1:$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD))

 .. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)

 .. I SAVE D

 ... S NFOUND=NFOUND+1

 ... S FIEVAL(NFOUND)=CONVAL

 ... I COND'="" S FIEVAL(NFOUND,"CONDITION")=CONVAL

 ... S FIEVAL(NFOUND,"DAS")=DAS

 ... S FIEVAL(NFOUND,"DATE")=DATE

 ... M FIEVAL(NFOUND)=FIEVD

 ... I $G(PXRMDEBG) M FIEVAL(NFOUND,"CSUB")=FIEVD

 ... I NFOUND=NOCC S DONE=1

 ;Save the finding result.

 D SFRES^PXRMUTIL(-SDIR,NFOUND,.FIEVAL)

 S FIEVAL("FILE NUMBER")=FILENUM

 Q

 ;

 ;=================================================

EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate location findings.

 N BDT,EDT,FIEVT,FILENUM,FINDING,FINDPA,ITEM

 S FILENUM=$$GETFNUM^PXRMDATA(ENODE)

 S ITEM=""

 F  S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:+ITEM=0  D

 . S FINDING=""

 . F  S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0  D

 .. K FINDPA

 .. M FINDPA=DEFARR(20,FINDING)

 .. K FIEVT

 .. D FIEVAL(FILENUM,"PI",DFN,ITEM,.FINDPA,.FIEVT)

 .. M FIEVAL(FINDING)=FIEVT

 .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)

 Q

 ;

 ;=================================================

EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate location terms.

 N FIEVT,FILENUM,ITEM,PFINDPA

 N TEMP,TFINDING,TFINDPA

 S FILENUM=$$GETFNUM^PXRMDATA(ENODE)

 S ITEM=""

 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(FILENUM,"PI",DFN,ITEM,.PFINDPA,.FIEVT)

 .. M TFIEVAL(TFINDING)=FIEVT

 .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)

 Q

 ;

 ;=================================================

FIEVAL(FILENUM,SNODE,DFN,ITEM,PFINDPA,FIEVAL) ;

 ;Evaluate regular patient findings.

 N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,FIEVD,FLIST,HLOC

 N ICOND,IND,LNAME,NFOUND,NGET,NOCC,NP

 N SAVE,SDIR,STATUSA,TEMP,UCIFS,VSLIST

 I '$D(^PXRMD(810.9,ITEM)) D  Q

 . S FIEVAL=0

 . S ^TMP(PXRMPID,$J,PXRMITEM,"FERROR","NOLL",ITEM)="Location List with IEN="_ITEM_" does not exist."

 S LNAME=$P(^PXRMD(810.9,ITEM,0),U,1)

 I LNAME="VA-ALL LOCATIONS" D ALL(FILENUM,DFN,.PFINDPA,.FIEVAL) Q

 ;Set the finding search parameters.

 D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)

 I $G(PXRMDEBG) S FIEVAL("BDTE")=BDT,FIEVAL("EDTE")=EDT

 S SDIR=$S(NOCC<0:-1,1:1)

 D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)

 S NOCC=$S(NOCC<0:-NOCC,1:NOCC)

 S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)

 ;Get a list of unique locations.

 D LOCLIST(ITEM,"HLOCL")

 D FPDAT(DFN,"HLOCL",NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)

 I NFOUND=0 S FIEVAL=0 Q

 S NP=0

 F IND=1:1:NFOUND Q:NP=NOCC  D

 . S DAS=$P(FLIST(IND),U,1)

 . D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)

 . S FIEVD("DATE")=$P(FLIST(IND),U,2)

 . S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)

 . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)

 . 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")=FIEVD("DATE")

 .. M FIEVAL(NP)=FIEVD

 .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=FIEVD

 ;

 ;Save the finding result.

 D SFRES^PXRMUTIL(-NOCC,NP,.FIEVAL)

 S FIEVAL("FILE NUMBER")=FILENUM

 Q

 ;

 ;=================================================

FPDAT(DFN,HLOCL,NOCC,SDIR,BDT,EDT,NFOUND,FLIST) ;Find patient data for

 ;visits at a specified hospital location. Return up to NOCC most

 ;recent entries in FLIST where FLIST(1) is the most recent.

 ;"AA" in Visit file is inverse date_.time instead of a full inverse

 ;date and time. For example if the date/time is 3030704.104449 then

 ;"AA" has 6969295.104449 instead of 6969295.89555

 N BTIME,DAS,DATE,DEND,DLIST,DONE,DS,ETIME,HLOC

 N INVBD,INVDATE,INVDT,INVED,NF,TEMP,TIME

 S DEND=$S(EDT[".":EDT,1:EDT+.235959)

 S INVBD=9999999-$P(BDT,".",1),BTIME="."_$P(BDT,".",2)

 S INVED=9999999-$P(DEND,".",1),ETIME="."_$P(DEND,".",2)

 I SDIR=1 S DS=INVED-.000001

 I SDIR=-1 S DS=INVBD+.000001

 ;DBIA #2028

 S INVDT=DS,(DONE,NFOUND)=0

 F  S INVDT=$O(^AUPNVSIT("AA",DFN,INVDT),SDIR) Q:(INVDT="")!(DONE)  D

 . S NF=0

 . S INVDATE=$P(INVDT,".",1)

 . I (SDIR=1),INVDATE>INVBD S DONE=1 Q

 . I (SDIR=-1),INVDATE<INVED S DONE=1 Q

 . S TIME="."_$P(INVDT,".",2)

 . I INVDATE=INVED,TIME>ETIME Q

 . I INVDATE=INVBD,TIME<BTIME Q

 . S DAS=0

 . F  S DAS=$O(^AUPNVSIT("AA",DFN,INVDT,DAS)) Q:(DAS="")!(DONE)  D

 .. S TEMP=^AUPNVSIT(DAS,0)

 .. S HLOC=$P(TEMP,U,22)

 .. I HLOC="" Q

 .. I '$D(^TMP($J,HLOCL,HLOC)) Q

 ..;Check the associated appointment for a valid status.

 .. I '$$VAPSTAT^PXRMVSIT(DAS) Q

 .. S DATE=$P(TEMP,U,1)

 .. S NF=NF+1,NFOUND=NFOUND+1

 .. I NFOUND=NOCC S DONE=1

 .. S DLIST(INVDT,NF)=DAS_U_DATE

 S INVDT="",NFOUND=0

 F  S INVDT=$O(DLIST(INVDT)) Q:INVDT=""  D

 . S NF=0

 . F  S NF=$O(DLIST(INVDT,NF)) Q:NF=""  D

 .. S NFOUND=NFOUND+1

 .. S FLIST(NFOUND)=DLIST(INVDT,NF)

 K ^TMP($J,"HLOCL")

 Q

 ;

 ;=================================================

LOCLIST(IEN,SUB) ;Build a list of unique locations based on stop code

 ;and/or hospital location. Reads of ^SC covered by DBIA #4482.

 N CSTOP,EXCL,EXCLNCS,EXCLP,IND,JND,HLOC,STOP

 K ^TMP($J,SUB)

 I IEN="" Q

 I '$D(^PXRMD(810.9,IEN)) Q

 ;Process stop codes. EXCL is the list of credit stops to exclude.

 S IND=0

 F  S IND=+$O(^PXRMD(810.9,IEN,40.7,IND)) Q:IND=0  D

 . S STOP=$P(^PXRMD(810.9,IEN,40.7,IND,0),U,1)

 . K EXCL

 .;Check for individual credit stops to exclude entries.

 . S JND=0

 . F  S JND=+$O(^PXRMD(810.9,IEN,40.7,IND,1,JND)) Q:JND=0  D

 .. S EXCL=$P(^PXRMD(810.9,IEN,40.7,IND,1,JND,0),U,1)

 .. S EXCL(EXCL)=""

 .;Check for a list of credit stops to exclude.

 . S EXCLP=$G(^PXRMD(810.9,IEN,40.7,IND,2))

 . I EXCLP'="" D

 .. S JND=0

 .. F  S JND=+$O(^PXRMD(810.9,EXCLP,40.7,JND)) Q:JND=0  D

 ... S EXCL=$P(^PXRMD(810.9,EXCLP,40.7,JND,0),U,1)

 ... S EXCL(EXCL)=""

 .;See if locations with no credit stop should be excluded.

 . S EXCLNCS=+$G(^PXRMD(810.9,IEN,40.7,IND,3))

 . S HLOC=""

 . F  S HLOC=$O(^SC("AST",STOP,HLOC)) Q:HLOC=""  D

 .. ;See if there are any to exclude.

 .. S CSTOP=$P(^SC(HLOC,0),U,18)

 .. I CSTOP'="",$D(EXCL(CSTOP)) Q

 .. I CSTOP="",EXCLNCS Q

 .. S ^TMP($J,SUB,HLOC)=""

 ;Process locations.

 S IND=0

 F  S IND=+$O(^PXRMD(810.9,IEN,44,IND)) Q:IND=0  D

 . S HLOC=^PXRMD(810.9,IEN,44,IND,0)

 . S ^TMP($J,SUB,HLOC)=""

 I $D(^TMP($J,SUB))=0 D

 . N MGIEN,MGROUP,TO

 . S ^TMP("PXRMXMZ",$J,1,0)="Warning Reminder Location List "_$P(^PXRMD(810.9,IEN,0),U,1)

 . S ^TMP("PXRMXMZ",$J,2,0)="does not contain or expand to contain any hospital locations!"

 . D SEND^PXRMMSG("PXRMXMZ","Location List Problem",.TO,DUZ)

 Q

 ;

 ;=================================================

MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.

 ;DBIAs (^DIC(4: #10090), (^DIC(40.7: #557), (^SC: #10040)

 N HLOC,IND,JND,LOC,NAME,NIN,NOUT,SC,TEMP,TEXTIN,TEXTOUT,VDATE

 S NAME="Outpatient Encounter = "

 S IND=0

 F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D

 . S NIN=0

 . S VDATE=IFIEVAL(IND,"DATE")

 . S LOC=$G(IFIEVAL(IND,"LOC. OF ENCOUNTER"))

 . S LOC=$S(LOC="":"?",1:$P($G(^DIC(4,LOC,0)),U,1))

 . S SC=$G(IFIEVAL(IND,"DSS ID"))

 . S SC=$S(SC="":"?",1:" "_$P($G(^DIC(40.7,SC,0)),U,1))

 . S HLOC=$G(IFIEVAL(IND,"HOSPITAL LOCATION"))

 . S HLOC=$S(HLOC="":"?",1:" "_$P($G(^SC(HLOC,0)),U,1))

 . S TEMP=NAME_LOC_HLOC_SC_" ("_$$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.

 ;DBIAs (^DIC(4: #10090), (^DIC(40.7: #557), (^SC: #10040)

 N EM,HLOC,IND,JND,LOC,NIN,NOUT,SC,STATUS,TEMP,TEXTIN,TEXTOUT,VDATE

 S NLINES=NLINES+1

 S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"PCE Encounter:"

 S IND=0

 F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D

 . S NIN=0

 . S VDATE=IFIEVAL(IND,"DATE")

 . S TEMP=$$EDATE^PXRMDATE(VDATE)

 . S LOC=$G(IFIEVAL(IND,"LOC. OF ENCOUNTER"))

 . S LOC=$S(LOC="":"?",1:$P($G(^DIC(4,LOC,0)),U,1))

 . S TEMP=TEMP_" Facility - "_LOC

 . D FORMATS^PXRMTEXT(INDENT+1,PXRMRM,TEMP,.NOUT,.TEXTOUT)

 . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)

 . S HLOC=$G(IFIEVAL(IND,"HLOC"))

 . I HLOC="" S HLOC="?"

 . S TEMP="Hospital Location: "_HLOC

 . S SC=$G(IFIEVAL(IND,"STOP CODE"))

 . I SC="" S SC="?"

 . S TEMP=TEMP_"; Clinic Stop: "_SC

 . S NIN=NIN+1,TEXTIN(NIN)=TEMP_"\\"

 . S SC=$G(IFIEVAL(IND,"SERVICE CATEGORY"))

 . S TEMP="Service Category: "_SC_"="_$$EXTERNAL^DILFD(9000010,.07,"",SC,.EM)

 . S NIN=NIN+1,TEXTIN(NIN)=TEMP_"\\"

 . S STATUS=$P($G(IFIEVAL(IND,"STATUS")),U,2)

 . I STATUS="" S STATUS="?"

 . S TEMP="Appointment Status: "_STATUS

 . S NIN=NIN+1,TEXTIN(NIN)=TEMP_"\\"

 . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,NIN,.TEXTIN,.NOUT,.TEXTOUT)

 . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)

 . I IFIEVAL(IND,"VISIT COMMENTS")'="" D

 .. S TEMP="Comments: "_IFIEVAL(IND,"VISIT 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

 ;

PXRMLOCF  ;SLC/PKR - Handle location findings. ;07/18/2012

 +1       ;;2.0;CLINICAL REMINDERS;**4,6,11,12,18,24**;Feb 04, 2005;Build 193

 +2       ;This routine is for location list patient findings.

 +3       ;=================================================

ALL(FILENUM,DFN,PFINDPA,FIEVAL) ;Get all Visits with a location

 +1       ;for a patient.

 +2        NEW BDT,BTIME,CASESEN,COND,CONVAL,DAS,DATE,DEND,DONE,DS,EDT,ETIME,FIEVD

 +3        NEW ICOND,INVBD,INVDATE,INVDT,INVED,NFOUND,NOCC

 +4        NEW SAVE,SDIR,TEMP,TIME,UCIFS

 +5       ;Set the finding search parameters.

 +6        DO SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)

 +7        IF $GET(PXRMDEBG)

               SET FIEVAL("BDTE")=BDT

               SET FIEVAL("EDTE")=EDT

 +8        SET SDIR=$SELECT(NOCC<0:-1,1:1)

 +9        SET NOCC=$SELECT(NOCC<0:-NOCC,1:NOCC)

 +10       DO SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)

 +11       IF $GET(PXRMDEBG)

               SET FIEVAL("BDTE")=BDT

               SET FIEVAL("EDTE")=EDT

 +12       SET (DONE,NFOUND)=0

 +13       SET DEND=$SELECT(EDT[".":EDT,1:EDT+.235959)

 +14       SET INVBD=9999999-$PIECE(BDT,".",1)

           SET BTIME="."_$PIECE(BDT,".",2)

 +15       SET INVED=9999999-$PIECE(DEND,".",1)

           SET ETIME="."_$PIECE(DEND,".",2)

 +16       IF SDIR=1

               SET DS=INVED-.000001

 +17       IF SDIR=-1

               SET DS=INVBD+.000001

 +18       SET INVDT=DS

           SET (DONE,NFOUND)=0

 +19      ;DBIA 2028

 +20       FOR 

               SET INVDT=$ORDER(^AUPNVSIT("AA",DFN,INVDT),SDIR)

               IF (DONE)!(INVDT="")

                   QUIT 

               Begin DoDot:1

 +21               SET INVDATE=$PIECE(INVDT,".",1)

 +22               IF (SDIR=1)

                       IF INVDATE>INVBD

                           SET DONE=1

                           QUIT 

 +23               IF (SDIR=-1)

                       IF INVDATE<INVED

                           SET DONE=1

                           QUIT 

 +24               SET TIME="."_$PIECE(INVDT,".",2)

 +25               IF INVDATE=INVED

                       IF TIME>ETIME

                           QUIT 

 +26               IF INVDATE=INVBD

                       IF TIME<BTIME

                           QUIT 

 +27               SET DAS=0

 +28               FOR 

                       SET DAS=$ORDER(^AUPNVSIT("AA",DFN,INVDT,DAS))

                       IF (DAS="")!(DONE)

                           QUIT 

                       Begin DoDot:2

 +29                       DO GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)

 +30                       SET DATE=$PIECE(^AUPNVSIT(DAS,0),U,1)

 +31                       SET FIEVD("DATE")=DATE

 +32                       SET CONVAL=$SELECT(COND="":1,1:$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD))

 +33                       SET SAVE=$SELECT('UCIFS:1,(UCIFS&CONVAL):1,1:0)

 +34                       IF SAVE

                               Begin DoDot:3

 +35                               SET NFOUND=NFOUND+1

 +36                               SET FIEVAL(NFOUND)=CONVAL

 +37                               IF COND'=""

                                       SET FIEVAL(NFOUND,"CONDITION")=CONVAL

 +38                               SET FIEVAL(NFOUND,"DAS")=DAS

 +39                               SET FIEVAL(NFOUND,"DATE")=DATE

 +40                               MERGE FIEVAL(NFOUND)=FIEVD

 +41                               IF $GET(PXRMDEBG)

                                       MERGE FIEVAL(NFOUND,"CSUB")=FIEVD

 +42                               IF NFOUND=NOCC

                                       SET DONE=1

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +43      ;Save the finding result.

 +44       DO SFRES^PXRMUTIL(-SDIR,NFOUND,.FIEVAL)

 +45       SET FIEVAL("FILE NUMBER")=FILENUM

 +46       QUIT 

 +47      ;

 +48      ;=================================================

EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate location findings.

 +1        NEW BDT,EDT,FIEVT,FILENUM,FINDING,FINDPA,ITEM

 +2        SET FILENUM=$$GETFNUM^PXRMDATA(ENODE)

 +3        SET ITEM=""

 +4        FOR 

               SET ITEM=$ORDER(DEFARR("E",ENODE,ITEM))

               IF +ITEM=0

                   QUIT 

               Begin DoDot:1

 +5                SET FINDING=""

 +6                FOR 

                       SET FINDING=$ORDER(DEFARR("E",ENODE,ITEM,FINDING))

                       IF +FINDING=0

                           QUIT 

                       Begin DoDot:2

 +7                        KILL FINDPA

 +8                        MERGE FINDPA=DEFARR(20,FINDING)

 +9                        KILL FIEVT

 +10                       DO FIEVAL(FILENUM,"PI",DFN,ITEM,.FINDPA,.FIEVT)

 +11                       MERGE FIEVAL(FINDING)=FIEVT

 +12                       SET FIEVAL(FINDING,"FINDING")=$PIECE(FINDPA(0),U,1)

                       End DoDot:2

               End DoDot:1

 +13       QUIT 

 +14      ;

 +15      ;=================================================

EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate location terms.

 +1        NEW FIEVT,FILENUM,ITEM,PFINDPA

 +2        NEW TEMP,TFINDING,TFINDPA

 +3        SET FILENUM=$$GETFNUM^PXRMDATA(ENODE)

 +4        SET ITEM=""

 +5        FOR 

               SET ITEM=$ORDER(TERMARR("E",ENODE,ITEM))

               IF +ITEM=0

                   QUIT 

               Begin DoDot:1

 +6                SET TFINDING=""

 +7                FOR 

                       SET TFINDING=$ORDER(TERMARR("E",ENODE,ITEM,TFINDING))

                       IF +TFINDING=0

                           QUIT 

                       Begin DoDot:2

 +8                        KILL FIEVT,PFINDPA,TFINDPA

 +9                        MERGE TFINDPA=TERMARR(20,TFINDING)

 +10      ;Set the finding parameters.

 +11                       DO SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)

 +12                       DO FIEVAL(FILENUM,"PI",DFN,ITEM,.PFINDPA,.FIEVT)

 +13                       MERGE TFIEVAL(TFINDING)=FIEVT

 +14                       SET TFIEVAL(TFINDING,"FINDING")=$PIECE(TFINDPA(0),U,1)

                       End DoDot:2

               End DoDot:1

 +15       QUIT 

 +16      ;

 +17      ;=================================================

FIEVAL(FILENUM,SNODE,DFN,ITEM,PFINDPA,FIEVAL) ;

 +1       ;Evaluate regular patient findings.

 +2        NEW BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,FIEVD,FLIST,HLOC

 +3        NEW ICOND,IND,LNAME,NFOUND,NGET,NOCC,NP

 +4        NEW SAVE,SDIR,STATUSA,TEMP,UCIFS,VSLIST

 +5        IF '$DATA(^PXRMD(810.9,ITEM))

               Begin DoDot:1

 +6                SET FIEVAL=0

 +7                SET ^TMP(PXRMPID,$JOB,PXRMITEM,"FERROR","NOLL",ITEM)="Location List with IEN="_ITEM_" does not exist."

               End DoDot:1

               QUIT 

 +8        SET LNAME=$PIECE(^PXRMD(810.9,ITEM,0),U,1)

 +9        IF LNAME="VA-ALL LOCATIONS"

               DO ALL(FILENUM,DFN,.PFINDPA,.FIEVAL)

               QUIT 

 +10      ;Set the finding search parameters.

 +11       DO SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)

 +12       IF $GET(PXRMDEBG)

               SET FIEVAL("BDTE")=BDT

               SET FIEVAL("EDTE")=EDT

 +13       SET SDIR=$SELECT(NOCC<0:-1,1:1)

 +14       DO SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)

 +15       SET NOCC=$SELECT(NOCC<0:-NOCC,1:NOCC)

 +16       SET NGET=$SELECT(UCIFS:50,$DATA(STATUSA):50,1:NOCC)

 +17      ;Get a list of unique locations.

 +18       DO LOCLIST(ITEM,"HLOCL")

 +19       DO FPDAT(DFN,"HLOCL",NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)

 +20       IF NFOUND=0

               SET FIEVAL=0

               QUIT 

 +21       SET NP=0

 +22       FOR IND=1:1:NFOUND

               IF NP=NOCC

                   QUIT 

               Begin DoDot:1

 +23               SET DAS=$PIECE(FLIST(IND),U,1)

 +24               DO GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)

 +25               SET FIEVD("DATE")=$PIECE(FLIST(IND),U,2)

 +26               SET CONVAL=$SELECT(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)

 +27               SET SAVE=$SELECT('UCIFS:1,(UCIFS&CONVAL):1,1:0)

 +28               IF SAVE

                       Begin DoDot:2

 +29                       SET NP=NP+1

 +30                       SET FIEVAL(NP)=CONVAL

 +31                       IF COND'=""

                               SET FIEVAL(NP,"CONDITION")=CONVAL

 +32                       SET FIEVAL(NP,"DAS")=$PIECE(FLIST(IND),U,1)

 +33                       SET FIEVAL(NP,"DATE")=FIEVD("DATE")

 +34                       MERGE FIEVAL(NP)=FIEVD

 +35                       IF $GET(PXRMDEBG)

                               MERGE FIEVAL(NP,"CSUB")=FIEVD

                       End DoDot:2

               End DoDot:1

 +36      ;

 +37      ;Save the finding result.

 +38       DO SFRES^PXRMUTIL(-NOCC,NP,.FIEVAL)

 +39       SET FIEVAL("FILE NUMBER")=FILENUM

 +40       QUIT 

 +41      ;

 +42      ;=================================================

FPDAT(DFN,HLOCL,NOCC,SDIR,BDT,EDT,NFOUND,FLIST) ;Find patient data for

 +1       ;visits at a specified hospital location. Return up to NOCC most

 +2       ;recent entries in FLIST where FLIST(1) is the most recent.

 +3       ;"AA" in Visit file is inverse date_.time instead of a full inverse

 +4       ;date and time. For example if the date/time is 3030704.104449 then

 +5       ;"AA" has 6969295.104449 instead of 6969295.89555

 +6        NEW BTIME,DAS,DATE,DEND,DLIST,DONE,DS,ETIME,HLOC

 +7        NEW INVBD,INVDATE,INVDT,INVED,NF,TEMP,TIME

 +8        SET DEND=$SELECT(EDT[".":EDT,1:EDT+.235959)

 +9        SET INVBD=9999999-$PIECE(BDT,".",1)

           SET BTIME="."_$PIECE(BDT,".",2)

 +10       SET INVED=9999999-$PIECE(DEND,".",1)

           SET ETIME="."_$PIECE(DEND,".",2)

 +11       IF SDIR=1

               SET DS=INVED-.000001

 +12       IF SDIR=-1

               SET DS=INVBD+.000001

 +13      ;DBIA #2028

 +14       SET INVDT=DS

           SET (DONE,NFOUND)=0

 +15       FOR 

               SET INVDT=$ORDER(^AUPNVSIT("AA",DFN,INVDT),SDIR)

               IF (INVDT="")!(DONE)

                   QUIT 

               Begin DoDot:1

 +16               SET NF=0

 +17               SET INVDATE=$PIECE(INVDT,".",1)

 +18               IF (SDIR=1)

                       IF INVDATE>INVBD

                           SET DONE=1

                           QUIT 

 +19               IF (SDIR=-1)

                       IF INVDATE<INVED

                           SET DONE=1

                           QUIT 

 +20               SET TIME="."_$PIECE(INVDT,".",2)

 +21               IF INVDATE=INVED

                       IF TIME>ETIME

                           QUIT 

 +22               IF INVDATE=INVBD

                       IF TIME<BTIME

                           QUIT 

 +23               SET DAS=0

 +24               FOR 

                       SET DAS=$ORDER(^AUPNVSIT("AA",DFN,INVDT,DAS))

                       IF (DAS="")!(DONE)

                           QUIT 

                       Begin DoDot:2

 +25                       SET TEMP=^AUPNVSIT(DAS,0)

 +26                       SET HLOC=$PIECE(TEMP,U,22)

 +27                       IF HLOC=""

                               QUIT 

 +28                       IF '$DATA(^TMP($JOB,HLOCL,HLOC))

                               QUIT 

 +29      ;Check the associated appointment for a valid status.

 +30                       IF '$$VAPSTAT^PXRMVSIT(DAS)

                               QUIT 

 +31                       SET DATE=$PIECE(TEMP,U,1)

 +32                       SET NF=NF+1

                           SET NFOUND=NFOUND+1

 +33                       IF NFOUND=NOCC

                               SET DONE=1

 +34                       SET DLIST(INVDT,NF)=DAS_U_DATE

                       End DoDot:2

               End DoDot:1

 +35       SET INVDT=""

           SET NFOUND=0

 +36       FOR 

               SET INVDT=$ORDER(DLIST(INVDT))

               IF INVDT=""

                   QUIT 

               Begin DoDot:1

 +37               SET NF=0

 +38               FOR 

                       SET NF=$ORDER(DLIST(INVDT,NF))

                       IF NF=""

                           QUIT 

                       Begin DoDot:2

 +39                       SET NFOUND=NFOUND+1

 +40                       SET FLIST(NFOUND)=DLIST(INVDT,NF)

                       End DoDot:2

               End DoDot:1

 +41       KILL ^TMP($JOB,"HLOCL")

 +42       QUIT 

 +43      ;

 +44      ;=================================================

LOCLIST(IEN,SUB) ;Build a list of unique locations based on stop code

 +1       ;and/or hospital location. Reads of ^SC covered by DBIA #4482.

 +2        NEW CSTOP,EXCL,EXCLNCS,EXCLP,IND,JND,HLOC,STOP

 +3        KILL ^TMP($JOB,SUB)

 +4        IF IEN=""

               QUIT 

 +5        IF '$DATA(^PXRMD(810.9,IEN))

               QUIT 

 +6       ;Process stop codes. EXCL is the list of credit stops to exclude.

 +7        SET IND=0

 +8        FOR 

               SET IND=+$ORDER(^PXRMD(810.9,IEN,40.7,IND))

               IF IND=0

                   QUIT 

               Begin DoDot:1

 +9                SET STOP=$PIECE(^PXRMD(810.9,IEN,40.7,IND,0),U,1)