PXRMLOCL ;SLC/PKR - Handle location findings. ;23-Mar-2015 10:37;DU
;;2.0;CLINICAL REMINDERS;**4,6,11,1001,18,1005**;Feb 04, 2005;Build 23
;This routine is for location list patient lists.
;IHS/MSC/MGH Patch 1001 changed status check
;=============================================
ALLLOCS(SUB) ;Build a list of all hospital locations associated
;with Visit file entries.
N HLOC
K ^TMP($J,SUB)
S HLOC=""
;DBIA #2028
F S HLOC=$O(^AUPNVSIT("AHL",HLOC)) Q:HLOC="" S ^TMP($J,SUB,HLOC)=""
Q
;
;=============================================
EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate location term findings
;for patient lists. Return the list in ^TMP($J,PLIST)
N BDT,EDT,ITEM,FILENUM,PFINDPA
N STATUSA,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 PFINDPA,TFINDPA
.. M TFINDPA=TERMARR(20,TFINDING)
..;Set the finding parameters.
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
.. D GPLIST(FILENUM,"IP",ITEM,.PFINDPA,PLIST)
Q
;
;=============================================
FPLIST(FILENUM,HLOCL,NOCC,BDT,EDT,PLIST) ;Find patient list data for
;a visit to a hospital location. Return the list in ^TMP($J,PLIST).
N BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED
N NFOUND,SC,TEMP,TGLIST,TIME
S TGLIST="FPLIST_PXRMLOCL"
K ^TMP($J,TGLIST)
S DEND=$S(EDT[".":EDT,1:EDT+.235959)
;"AHL" 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
;"AHL" has 6969295.104449 instead of 6969295.89555
S INVBD=9999999-$P(BDT,".",1),BTIME="."_$P(BDT,".",2)
S INVED=9999999-$P(DEND,".",1),ETIME="."_$P(DEND,".",2)
S DS=INVED-.000001
S HLOC=""
F S HLOC=$O(^TMP($J,HLOCL,HLOC)) Q:HLOC="" D
. S INVDT=DS,DONE=0
.;DBIA #2028
. F S INVDT=$O(^AUPNVSIT("AHL",HLOC,INVDT)) Q:(DONE)!(INVDT="") D
.. S INVDATE=$P(INVDT,".",1)
.. I INVDATE>INVBD 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("AHL",HLOC,INVDT,DAS)) Q:DAS="" D
...;Check the associated appointment for a valid status.
...;IHS/MSC/MGH do not use VA's status check
...;I '$$VAPSTAT^PXRMVSIT(DAS) Q
... S TEMP=^AUPNVSIT(DAS,0)
... S DATE=$P(TEMP,U,1)
... S DFN=$P(TEMP,U,5)
... S SC=$P(TEMP,U,7)
... S ^TMP($J,TGLIST,DFN,INVDT,DAS)=DATE_U_HLOC_U_SC
;Return the NOCC most recent for each patient.
S DFN=0
F S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN="" D
. S (INVDT,NFOUND)=0
. F S INVDT=$O(^TMP($J,TGLIST,DFN,INVDT)) Q:(NFOUND=NOCC)!(INVDT="") D
.. S DAS=""
.. F S DAS=$O(^TMP($J,TGLIST,DFN,INVDT,DAS)) Q:(NFOUND=NOCC)!(DAS="") D
... S NFOUND=NFOUND+1
... S ^TMP($J,PLIST,DFN,NFOUND)=DAS_U_^TMP($J,TGLIST,DFN,INVDT,DAS)
K ^TMP($J,TGLIST)
Q
;
;=============================================
GPLIST(FILENUM,SNODE,ITEM,PFINDPA,PLIST) ;Add to the patient list.
; Return the list in ^TMP($J,PLIST).
;^TMP($J,PLIST,T/F,DFN,ITEM,COUNT,FILENUM)=DAS^DATE^HLOC^VALUE
N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DFN,FIEVD,FLIST
N ICOND,IEN,IND,IPLIST,LNAME,NOCC,NFOUND,NGET,NP,SAVE,STATUSA
N TEMP,TGLIST,TPLIST,UCIFS,VALUE,VSLIST
S TGLIST="GPLIST_PXRMLOCL"
;Set the finding search parameters.
D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
;Ignore negative occurrence count, date reversal not allowed in
;patient lists.
S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
;Get a list of unique locations.
S LNAME=$P(^PXRMD(810.9,ITEM,0),U,1)
I LNAME="VA-ALL LOCATIONS" D ALLLOCS("HLOCL")
I LNAME'="VA-ALL LOCATIONS" D LOCLIST^PXRMLOCF(ITEM,"HLOCL")
D FPLIST(FILENUM,"HLOCL",NGET,BDT,EDT,TGLIST)
S DFN=""
F S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN="" D
. K TPLIST
. M TPLIST=^TMP($J,TGLIST,DFN)
. S (IND,NFOUND)=0
. K IPLIST
. F S IND=$O(TPLIST(IND)) Q:(IND="")!(NFOUND=NOCC) D
.. S TEMP=TPLIST(IND)
.. S DAS=$P(TEMP,U,1)
.. S DATE=$P(TEMP,U,2)
.. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
.. S VALUE=$G(FIEVD("VALUE"))
.. S FIEVD("DATE")=DATE
.. 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 NFOUND=NFOUND+1
... ;S IPLIST(CONVAL,DFN,NFOUND,FILENUM)=TEMP_U_VALUE
... S IPLIST(CONVAL,DFN,ITEM,NFOUND,FILENUM)=TEMP_U_VALUE
. M ^TMP($J,PLIST)=IPLIST
K ^TMP($J,"HLOCL"),^TMP($J,TGLIST)
Q
;
;=============================================
PCSTOPL ;Print the Clinic Stop list. Called by the print template PXRM
;LOCATION LIST INQUIRY.
N AMIS,CSTEXL,CSTOP,EXCLNCS,IND,JND,SKIP,TEMP
S (IND,SKIP)=0
F S IND=+$O(^PXRMD(810.9,D0,40.7,IND)) Q:IND=0 D
. S TEMP=^PXRMD(810.9,D0,40.7,IND,0)
. S CSTOP=$P(TEMP,U,1)
.;DBIA #557
. S CSTOP=$P(^DIC(40.7,CSTOP,0),U,1)
. S AMIS=$P(TEMP,U,2)
. I SKIP W ! S SKIP=0
. W !,?2,CSTOP,?34,AMIS
. I $D(^PXRMD(810.9,D0,40.7,IND,1)) D
.. S SKIP=1
.. W !,?4,"Credit Stops to Exclude:"
.. S JND=0
.. F S JND=+$O(^PXRMD(810.9,D0,40.7,IND,1,JND)) Q:JND=0 D
... S TEMP=$P(^PXRMD(810.9,D0,40.7,IND,1,JND,0),U,1)
... S TEMP=$P(^DIC(40.7,TEMP,0),U,1,2)
... S CSTOP=$P(TEMP,U,1)
... S AMIS=$P(TEMP,U,2)
... W !,?6,CSTOP,?38,AMIS
. S CSTEXL=$G(^PXRMD(810.9,D0,40.7,IND,2))
. I CSTEXL'="" D
.. W !,?4,"Credit Stops to Exclude (LIST): ",$P(^PXRMD(810.9,CSTEXL,0),U,1)
. S EXCLNCS=+$G(^PXRMD(810.9,D0,40.7,IND,3))
. W !,?4,"Exclude locations with no credit stop: ",$S(EXCLNCS:"YES",1:"NO")
. S SKIP=1
Q
;
PXRMLOCL ;SLC/PKR - Handle location findings. ;23-Mar-2015 10:37;DU
+1 ;;2.0;CLINICAL REMINDERS;**4,6,11,1001,18,1005**;Feb 04, 2005;Build 23
+2 ;This routine is for location list patient lists.
+3 ;IHS/MSC/MGH Patch 1001 changed status check
+4 ;=============================================
ALLLOCS(SUB) ;Build a list of all hospital locations associated
+1 ;with Visit file entries.
+2 NEW HLOC
+3 KILL ^TMP($JOB,SUB)
+4 SET HLOC=""
+5 ;DBIA #2028
+6 FOR
SET HLOC=$ORDER(^AUPNVSIT("AHL",HLOC))
IF HLOC=""
QUIT
SET ^TMP($JOB,SUB,HLOC)=""
+7 QUIT
+8 ;
+9 ;=============================================
EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate location term findings
+1 ;for patient lists. Return the list in ^TMP($J,PLIST)
+2 NEW BDT,EDT,ITEM,FILENUM,PFINDPA
+3 NEW STATUSA,TEMP,TFINDING,TFINDPA
+4 SET FILENUM=$$GETFNUM^PXRMDATA(ENODE)
+5 SET ITEM=""
+6 FOR
SET ITEM=$ORDER(TERMARR("E",ENODE,ITEM))
IF +ITEM=0
QUIT
Begin DoDot:1
+7 SET TFINDING=""
+8 FOR
SET TFINDING=$ORDER(TERMARR("E",ENODE,ITEM,TFINDING))
IF +TFINDING=0
QUIT
Begin DoDot:2
+9 KILL PFINDPA,TFINDPA
+10 MERGE TFINDPA=TERMARR(20,TFINDING)
+11 ;Set the finding parameters.
+12 DO SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+13 DO GPLIST(FILENUM,"IP",ITEM,.PFINDPA,PLIST)
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
+16 ;=============================================
FPLIST(FILENUM,HLOCL,NOCC,BDT,EDT,PLIST) ;Find patient list data for
+1 ;a visit to a hospital location. Return the list in ^TMP($J,PLIST).
+2 NEW BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED
+3 NEW NFOUND,SC,TEMP,TGLIST,TIME
+4 SET TGLIST="FPLIST_PXRMLOCL"
+5 KILL ^TMP($JOB,TGLIST)
+6 SET DEND=$SELECT(EDT[".":EDT,1:EDT+.235959)
+7 ;"AHL" in Visit file is inverse date_.time instead of a full inverse
+8 ;date and time. For example if the date/time is 3030704.104449 then
+9 ;"AHL" has 6969295.104449 instead of 6969295.89555
+10 SET INVBD=9999999-$PIECE(BDT,".",1)
SET BTIME="."_$PIECE(BDT,".",2)
+11 SET INVED=9999999-$PIECE(DEND,".",1)
SET ETIME="."_$PIECE(DEND,".",2)
+12 SET DS=INVED-.000001
+13 SET HLOC=""
+14 FOR
SET HLOC=$ORDER(^TMP($JOB,HLOCL,HLOC))
IF HLOC=""
QUIT
Begin DoDot:1
+15 SET INVDT=DS
SET DONE=0
+16 ;DBIA #2028
+17 FOR
SET INVDT=$ORDER(^AUPNVSIT("AHL",HLOC,INVDT))
IF (DONE)!(INVDT="")
QUIT
Begin DoDot:2
+18 SET INVDATE=$PIECE(INVDT,".",1)
+19 IF INVDATE>INVBD
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("AHL",HLOC,INVDT,DAS))
IF DAS=""
QUIT
Begin DoDot:3
+25 ;Check the associated appointment for a valid status.
+26 ;IHS/MSC/MGH do not use VA's status check
+27 ;I '$$VAPSTAT^PXRMVSIT(DAS) Q
+28 SET TEMP=^AUPNVSIT(DAS,0)
+29 SET DATE=$PIECE(TEMP,U,1)
+30 SET DFN=$PIECE(TEMP,U,5)
+31 SET SC=$PIECE(TEMP,U,7)
+32 SET ^TMP($JOB,TGLIST,DFN,INVDT,DAS)=DATE_U_HLOC_U_SC
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;Return the NOCC most recent for each patient.
+34 SET DFN=0
+35 FOR
SET DFN=$ORDER(^TMP($JOB,TGLIST,DFN))
IF DFN=""
QUIT
Begin DoDot:1
+36 SET (INVDT,NFOUND)=0
+37 FOR
SET INVDT=$ORDER(^TMP($JOB,TGLIST,DFN,INVDT))
IF (NFOUND=NOCC)!(INVDT="")
QUIT
Begin DoDot:2
+38 SET DAS=""
+39 FOR
SET DAS=$ORDER(^TMP($JOB,TGLIST,DFN,INVDT,DAS))
IF (NFOUND=NOCC)!(DAS="")
QUIT
Begin DoDot:3
+40 SET NFOUND=NFOUND+1
+41 SET ^TMP($JOB,PLIST,DFN,NFOUND)=DAS_U_^TMP($JOB,TGLIST,DFN,INVDT,DAS)
End DoDot:3
End DoDot:2
End DoDot:1
+42 KILL ^TMP($JOB,TGLIST)
+43 QUIT
+44 ;
+45 ;=============================================
GPLIST(FILENUM,SNODE,ITEM,PFINDPA,PLIST) ;Add to the patient list.
+1 ; Return the list in ^TMP($J,PLIST).
+2 ;^TMP($J,PLIST,T/F,DFN,ITEM,COUNT,FILENUM)=DAS^DATE^HLOC^VALUE
+3 NEW BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DFN,FIEVD,FLIST
+4 NEW ICOND,IEN,IND,IPLIST,LNAME,NOCC,NFOUND,NGET,NP,SAVE,STATUSA
+5 NEW TEMP,TGLIST,TPLIST,UCIFS,VALUE,VSLIST
+6 SET TGLIST="GPLIST_PXRMLOCL"
+7 ;Set the finding search parameters.
+8 DO SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
+9 ;Ignore negative occurrence count, date reversal not allowed in
+10 ;patient lists.
+11 SET NOCC=$SELECT(NOCC<0:-NOCC,1:NOCC)
+12 DO SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
+13 SET NGET=$SELECT(UCIFS:50,$DATA(STATUSA):50,1:NOCC)
+14 ;Get a list of unique locations.
+15 SET LNAME=$PIECE(^PXRMD(810.9,ITEM,0),U,1)
+16 IF LNAME="VA-ALL LOCATIONS"
DO ALLLOCS("HLOCL")
+17 IF LNAME'="VA-ALL LOCATIONS"
DO LOCLIST^PXRMLOCF(ITEM,"HLOCL")
+18 DO FPLIST(FILENUM,"HLOCL",NGET,BDT,EDT,TGLIST)
+19 SET DFN=""
+20 FOR
SET DFN=$ORDER(^TMP($JOB,TGLIST,DFN))
IF DFN=""
QUIT
Begin DoDot:1
+21 KILL TPLIST
+22 MERGE TPLIST=^TMP($JOB,TGLIST,DFN)
+23 SET (IND,NFOUND)=0
+24 KILL IPLIST
+25 FOR
SET IND=$ORDER(TPLIST(IND))
IF (IND="")!(NFOUND=NOCC)
QUIT
Begin DoDot:2
+26 SET TEMP=TPLIST(IND)
+27 SET DAS=$PIECE(TEMP,U,1)
+28 SET DATE=$PIECE(TEMP,U,2)
+29 DO GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
+30 SET VALUE=$GET(FIEVD("VALUE"))
+31 SET FIEVD("DATE")=DATE
+32 SET CONVAL=$SELECT(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
+33 SET SAVE=$SELECT('UCIFS:1,(UCIFS&CONVAL):1,1:0)
+34 IF SAVE
Begin DoDot:3
+35 SET NFOUND=NFOUND+1
+36 ;S IPLIST(CONVAL,DFN,NFOUND,FILENUM)=TEMP_U_VALUE
+37 SET IPLIST(CONVAL,DFN,ITEM,NFOUND,FILENUM)=TEMP_U_VALUE
End DoDot:3
End DoDot:2
+38 MERGE ^TMP($JOB,PLIST)=IPLIST
End DoDot:1
+39 KILL ^TMP($JOB,"HLOCL"),^TMP($JOB,TGLIST)
+40 QUIT
+41 ;
+42 ;=============================================
PCSTOPL ;Print the Clinic Stop list. Called by the print template PXRM
+1 ;LOCATION LIST INQUIRY.
+2 NEW AMIS,CSTEXL,CSTOP,EXCLNCS,IND,JND,SKIP,TEMP
+3 SET (IND,SKIP)=0
+4 FOR
SET IND=+$ORDER(^PXRMD(810.9,D0,40.7,IND))
IF IND=0
QUIT
Begin DoDot:1
+5 SET TEMP=^PXRMD(810.9,D0,40.7,IND,0)
+6 SET CSTOP=$PIECE(TEMP,U,1)
+7 ;DBIA #557
+8 SET CSTOP=$PIECE(^DIC(40.7,CSTOP,0),U,1)
+9 SET AMIS=$PIECE(TEMP,U,2)
+10 IF SKIP
WRITE !
SET SKIP=0
+11 WRITE !,?2,CSTOP,?34,AMIS
+12 IF $DATA(^PXRMD(810.9,D0,40.7,IND,1))
Begin DoDot:2
+13 SET SKIP=1
+14 WRITE !,?4,"Credit Stops to Exclude:"
+15 SET JND=0
+16 FOR
SET JND=+$ORDER(^PXRMD(810.9,D0,40.7,IND,1,JND))
IF JND=0
QUIT
Begin DoDot:3
+17 SET TEMP=$PIECE(^PXRMD(810.9,D0,40.7,IND,1,JND,0),U,1)
+18 SET TEMP=$PIECE(^DIC(40.7,TEMP,0),U,1,2)
+19 SET CSTOP=$PIECE(TEMP,U,1)
+20 SET AMIS=$PIECE(TEMP,U,2)
+21 WRITE !,?6,CSTOP,?38,AMIS
End DoDot:3
End DoDot:2
+22 SET CSTEXL=$GET(^PXRMD(810.9,D0,40.7,IND,2))
+23 IF CSTEXL'=""
Begin DoDot:2
+24 WRITE !,?4,"Credit Stops to Exclude (LIST): ",$PIECE(^PXRMD(810.9,CSTEXL,0),U,1)
End DoDot:2
+25 SET EXCLNCS=+$GET(^PXRMD(810.9,D0,40.7,IND,3))
+26 WRITE !,?4,"Exclude locations with no credit stop: ",$SELECT(EXCLNCS:"YES",1:"NO")
+27 SET SKIP=1
End DoDot:1
+28 QUIT
+29 ;
