PXRMLOCF ;SLC/PKR - Handle location findings. ;02/17/2016
;;2.0;CLINICAL REMINDERS;**4,6,11,12,18,24,47**;Feb 04, 2005;Build 291
;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,SC,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,unless the
..;service category is historical.
.. S SC=$P(TEMP,U,7)
.. I (SC'="E")&('$$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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMLOCF 10997 printed Sep 23, 2025@19:22:27 Page 2
PXRMLOCF ;SLC/PKR - Handle location findings. ;02/17/2016
+1 ;;2.0;CLINICAL REMINDERS;**4,6,11,12,18,24,47**;Feb 04, 2005;Build 291
+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,SC,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,unless the
+30 ;service category is historical.
+31 SET SC=$PIECE(TEMP,U,7)
+32 IF (SC'="E")&('$$VAPSTAT^PXRMVSIT(DAS))
QUIT
+33 SET DATE=$PIECE(TEMP,U,1)
+34 SET NF=NF+1
SET NFOUND=NFOUND+1
+35 IF NFOUND=NOCC
SET DONE=1
+36 SET DLIST(INVDT,NF)=DAS_U_DATE
End DoDot:2
End DoDot:1
+37 SET INVDT=""
SET NFOUND=0
+38 FOR
SET INVDT=$ORDER(DLIST(INVDT))
if INVDT=""
QUIT
Begin DoDot:1
+39 SET NF=0
+40 FOR
SET NF=$ORDER(DLIST(INVDT,NF))
if NF=""
QUIT
Begin DoDot:2
+41 SET NFOUND=NFOUND+1
+42 SET FLIST(NFOUND)=DLIST(INVDT,NF)
End DoDot:2
End DoDot:1
+43 KILL ^TMP($JOB,"HLOCL")
+44 QUIT
+45 ;
+46 ;=================================================
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)
+10 KILL EXCL
+11 ;Check for individual credit stops to exclude entries.
+12 SET JND=0
+13 FOR
SET JND=+$ORDER(^PXRMD(810.9,IEN,40.7,IND,1,JND))
if JND=0
QUIT
Begin DoDot:2
+14 SET EXCL=$PIECE(^PXRMD(810.9,IEN,40.7,IND,1,JND,0),U,1)
+15 SET EXCL(EXCL)=""
End DoDot:2
+16 ;Check for a list of credit stops to exclude.
+17 SET EXCLP=$GET(^PXRMD(810.9,IEN,40.7,IND,2))
+18 IF EXCLP'=""
Begin DoDot:2
+19 SET JND=0
+20 FOR
SET JND=+$ORDER(^PXRMD(810.9,EXCLP,40.7,JND))
if JND=0
QUIT
Begin DoDot:3
+21 SET EXCL=$PIECE(^PXRMD(810.9,EXCLP,40.7,JND,0),U,1)
+22 SET EXCL(EXCL)=""
End DoDot:3
End DoDot:2
+23 ;See if locations with no credit stop should be excluded.
+24 SET EXCLNCS=+$GET(^PXRMD(810.9,IEN,40.7,IND,3))
+25 SET HLOC=""
+26 FOR
SET HLOC=$ORDER(^SC("AST",STOP,HLOC))
if HLOC=""
QUIT
Begin DoDot:2
+27 ;See if there are any to exclude.
+28 SET CSTOP=$PIECE(^SC(HLOC,0),U,18)
+29 IF CSTOP'=""
IF $DATA(EXCL(CSTOP))
QUIT
+30 IF CSTOP=""
IF EXCLNCS
QUIT
+31 SET ^TMP($JOB,SUB,HLOC)=""
End DoDot:2
End DoDot:1
+32 ;Process locations.
+33 SET IND=0
+34 FOR
SET IND=+$ORDER(^PXRMD(810.9,IEN,44,IND))
if IND=0
QUIT
Begin DoDot:1
+35 SET HLOC=^PXRMD(810.9,IEN,44,IND,0)
+36 SET ^TMP($JOB,SUB,HLOC)=""
End DoDot:1
+37 IF $DATA(^TMP($JOB,SUB))=0
Begin DoDot:1
+38 NEW MGIEN,MGROUP,TO
+39 SET ^TMP("PXRMXMZ",$JOB,1,0)="Warning Reminder Location List "_$PIECE(^PXRMD(810.9,IEN,0),U,1)
+40 SET ^TMP("PXRMXMZ",$JOB,2,0)="does not contain or expand to contain any hospital locations!"
+41 DO SEND^PXRMMSG("PXRMXMZ","Location List Problem",.TO,DUZ)
End DoDot:1
+42 QUIT
+43 ;
+44 ;=================================================
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+1 ;DBIAs (^DIC(4: #10090), (^DIC(40.7: #557), (^SC: #10040)
+2 NEW HLOC,IND,JND,LOC,NAME,NIN,NOUT,SC,TEMP,TEXTIN,TEXTOUT,VDATE
+3 SET NAME="Outpatient Encounter = "
+4 SET IND=0
+5 FOR
SET IND=+$ORDER(IFIEVAL(IND))
if IND=0
QUIT
Begin DoDot:1
+6 SET NIN=0
+7 SET VDATE=IFIEVAL(IND,"DATE")
+8 SET LOC=$GET(IFIEVAL(IND,"LOC. OF ENCOUNTER"))
+9 SET LOC=$SELECT(LOC="":"?",1:$PIECE($GET(^DIC(4,LOC,0)),U,1))
+10 SET SC=$GET(IFIEVAL(IND,"DSS ID"))
+11 SET SC=$SELECT(SC="":"?",1:" "_$PIECE($GET(^DIC(40.7,SC,0)),U,1))
+12 SET HLOC=$GET(IFIEVAL(IND,"HOSPITAL LOCATION"))
+13 SET HLOC=$SELECT(HLOC="":"?",1:" "_$PIECE($GET(^SC(HLOC,0)),U,1))
+14 SET TEMP=NAME_LOC_HLOC_SC_" ("_$$EDATE^PXRMDATE(VDATE)_")"
+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 ;
+20 ;=================================================
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+1 ;maintenance output.
+2 ;DBIAs (^DIC(4: #10090), (^DIC(40.7: #557), (^SC: #10040)
+3 NEW EM,HLOC,IND,JND,LOC,NIN,NOUT,SC,STATUS,TEMP,TEXTIN,TEXTOUT,VDATE
+4 SET NLINES=NLINES+1
+5 SET TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"PCE Encounter:"
+6 SET IND=0
+7 FOR
SET IND=+$ORDER(IFIEVAL(IND))
if IND=0
QUIT
Begin DoDot:1
+8 SET NIN=0
+9 SET VDATE=IFIEVAL(IND,"DATE")
+10 SET TEMP=$$EDATE^PXRMDATE(VDATE)
+11 SET LOC=$GET(IFIEVAL(IND,"LOC. OF ENCOUNTER"))
+12 SET LOC=$SELECT(LOC="":"?",1:$PIECE($GET(^DIC(4,LOC,0)),U,1))
+13 SET TEMP=TEMP_" Facility - "_LOC
+14 DO FORMATS^PXRMTEXT(INDENT+1,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+15 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
+16 SET HLOC=$GET(IFIEVAL(IND,"HLOC"))
+17 IF HLOC=""
SET HLOC="?"
+18 SET TEMP="Hospital Location: "_HLOC
+19 SET SC=$GET(IFIEVAL(IND,"STOP CODE"))
+20 IF SC=""
SET SC="?"
+21 SET TEMP=TEMP_"; Clinic Stop: "_SC
+22 SET NIN=NIN+1
SET TEXTIN(NIN)=TEMP_"\\"
+23 SET SC=$GET(IFIEVAL(IND,"SERVICE CATEGORY"))
+24 SET TEMP="Service Category: "_SC_"="_$$EXTERNAL^DILFD(9000010,.07,"",SC,.EM)
+25 SET NIN=NIN+1
SET TEXTIN(NIN)=TEMP_"\\"
+26 SET STATUS=$PIECE($GET(IFIEVAL(IND,"STATUS")),U,2)
+27 IF STATUS=""
SET STATUS="?"
+28 SET TEMP="Appointment Status: "_STATUS
+29 SET NIN=NIN+1
SET TEXTIN(NIN)=TEMP_"\\"
+30 DO FORMAT^PXRMTEXT(INDENT+2,PXRMRM,NIN,.TEXTIN,.NOUT,.TEXTOUT)
+31 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
+32 IF IFIEVAL(IND,"VISIT COMMENTS")'=""
Begin DoDot:2
+33 SET TEMP="Comments: "_IFIEVAL(IND,"VISIT COMMENTS")
+34 DO FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+35 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
End DoDot:2
End DoDot:1
+36 SET NLINES=NLINES+1
SET TEXT(NLINES)=""
+37 QUIT
+38 ;
