PXRMINDL ; SLC/PKR - List building routines. ;01/06/2019
;;2.0;CLINICAL REMINDERS;**4,6,12,26,65**;Feb 04, 2005;Build 438
;================================================
EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;General patient list term evaluator.
;Return the list in ^TMP($J,PLIST)
N ITEM,FILENUM,PFINDPA
N SSFIND,TEMP,TFINDING,TFINDPA
S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D Q
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),FILENUM)
S ITEM=""
F S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:ITEM="" 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,SNODE,ISC,ITEM,NOCC,BDT,EDT,PLIST) ;Find patient list data for
;regular files. Return the list in ^TMP($J,PLIST).
N DAS,DATE,DFN,DS,NFOUND
K ^TMP($J,PLIST)
I (FILENUM=9000010.11),(ISC'="") D Q
. I ISC="CVX" D CVXL^PXRMIMM(ITEM,NOCC,BDT,EDT,PLIST) Q
. I ISC="VGN" D VGNL^PXRMIMM(ITEM,NOCC,BDT,EDT,PLIST)
I FILENUM=601.84 D SEVALPL^PXRMMH(ITEM,NOCC,BDT,EDT,PLIST) Q
S DS=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
S DFN=0
F S DFN=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN)) Q:DFN="" D
. S NFOUND=0
. S DATE=DS
. F S DATE=+$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,DATE),-1) Q:(DATE=0)!(DATE<BDT)!(NFOUND=NOCC) D
.. S DAS=""
.. F S DAS=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,DATE,DAS),-1) Q:DAS="" D
... S NFOUND=NFOUND+1
... S ^TMP($J,PLIST,DFN,NFOUND)=DAS_U_DATE
Q
;
;================================================
FPLISTSS(FILENUM,SNODE,ITEM,NGET,BDT,EDT,USESTRT,PLIST) ;Find patient list
;data for a finding with a start and stop date.
;Return the list in ^TMP($J,PLIST).
N DAS,DFN,DONE,EDTT,NFOUND,OVERLAP,SDATE,START,STOP,TDATE,TIND,TLIST
K ^TMP($J,PLIST)
S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
S DFN=0
F S DFN=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN)) Q:DFN="" D
. S (DONE,NFOUND)=0
. S START=EDTT
. K TLIST
. F S START=+$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,START),-1) Q:(START=0)!(DONE) D
.. S STOP=""
.. F S STOP=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,START,STOP),-1) Q:(STOP="")!(DONE) D
... S SDATE=$S(USESTRT:START,STOP["U":$$NOW^PXRMDATE_"U",1:STOP)
... S OVERLAP=$$OVERLAP^PXRMINDX(START,SDATE,BDT,EDTT)
... I OVERLAP="O" D
.... S DAS=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,START,STOP,""))
.... S NFOUND=NFOUND+1,TLIST(SDATE,NFOUND)=DAS_U_START_U_SDATE
... I FILENUM="55NVA" Q
... I FILENUM=100 Q
... I OVERLAP="L" S DONE=1 Q
.;Return up to NGET of the most recent entries.
. S NFOUND=0,TDATE=""
. F S TDATE=$O(TLIST(TDATE)) Q:(TDATE="")!(NFOUND=NGET) D
.. S TIND=0
.. F S TIND=$O(TLIST(TDATE,TIND)) Q:(TIND="")!(NFOUND=NGET) D
... S NFOUND=NFOUND+1,^TMP($J,PLIST,DFN,NFOUND)=TLIST(TDATE,TIND)
Q
;
;================================================
GPLIST(FILENUM,SNODE,ITEM,PFINDPA,PLIST) ;Add to the patient list
;for a regular file. Return the list in ^TMP($J,PLIST):
;^TMP($J,PLIST,T/F,DFN,ITEM,COUNT,FILENUM)=DAS^DATE^VALUE
N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DFN,FIEVD,FLIST,GPLIST
N ICOND,IND,INVFD,IPLIST,ISC,NOCC,NFOUND,NGET
N SAVE,SSFIND,STATOK,STATUSA,TEMP,TGLIST,TPLIST
N UCIFS,USESTRT,VALUE,VSLIST
S TGLIST="GPLIST_PXRMINDL"
S ISC=$S(FILENUM=9000010.11:$P(PFINDPA(0),U,17),1:"")
;Determine if this is a finding with a start and stop date.
S SSFIND=$S(FILENUM=52:1,FILENUM[55:1,FILENUM=100:1,1:0)
S USESTRT=$S(SSFIND:$P(PFINDPA(0),U,15),1:0)
I FILENUM=100,USESTRT="" S USESTRT=1
;Set the finding search parameters.
D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
S INVFD=$P(PFINDPA(0),U,16)
D GETSTATI^PXRMSTAT(FILENUM,.PFINDPA,.STATUSA)
D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
;Ignore any negative occurrence counts, date reversal not allowed
;in patient lists.
S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
I SSFIND D FPLISTSS(FILENUM,SNODE,ITEM,NGET,BDT,EDT,USESTRT,TGLIST)
I 'SSFIND D FPLIST(FILENUM,SNODE,ISC,ITEM,NGET,BDT,EDT,TGLIST)
S DFN=""
F S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN="" D
. K GPLIST
. M GPLIST=^TMP($J,TGLIST,DFN)
. S (IND,NFOUND)=0
. K IPLIST
. F S IND=$O(GPLIST(IND)) Q:(IND="")!(NFOUND=NOCC) D
.. S TEMP=GPLIST(IND)
.. S DAS=$P(TEMP,U,1)
.. S DATE=$P(TEMP,U,2)
..;If this a Lab finding attach the item to the DAS.
..;THIS LOOKS LIKE A BUG SINCE ITEM DOES NOT APPEAR TO BE DEFINED BREAK
.. I PFINDPA(0)["LAB(60" S DAS=ITEM_"~"_DAS
..;If this is a Mental Health finding attach the scale to DAS.
.. I PFINDPA(0)["YTT(601.71" S DAS=DAS_"S"_$P(PFINDPA(0),U,12)
.. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
.. S VALUE=$G(FIEVD("VALUE"))
.. I INVFD,$D(FIEVD("VISIT")) D GETDATA^PXRMVSIT(FIEVD("VISIT"),.FIEVD,0)
.. S FIEVD("DATE")=DATE
..;If there is a status list make sure the finding has a status on
..;the list.
.. S STATOK=$S($D(STATUSA):$$STATUSOK^PXRMINDX(.STATUSA,.FIEVD),1:1)
.. I 'STATOK Q
.. 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,ITEM,NFOUND,FILENUM)=TEMP_U_VALUE
. M ^TMP($J,PLIST)=IPLIST
K ^TMP($J,TGLIST)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMINDL 5463 printed Apr 09, 2024@20:54:05 Page 2
PXRMINDL ; SLC/PKR - List building routines. ;01/06/2019
+1 ;;2.0;CLINICAL REMINDERS;**4,6,12,26,65**;Feb 04, 2005;Build 438
+2 ;================================================
EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;General patient list term evaluator.
+1 ;Return the list in ^TMP($J,PLIST)
+2 NEW ITEM,FILENUM,PFINDPA
+3 NEW SSFIND,TEMP,TFINDING,TFINDPA
+4 SET FILENUM=$$GETFNUM^PXRMDATA(ENODE)
+5 IF $GET(^PXRMINDX(FILENUM,"DATE BUILT"))=""
Begin DoDot:1
+6 DO NOINDEX^PXRMERRH("TR",TERMARR("IEN"),FILENUM)
End DoDot:1
QUIT
+7 SET ITEM=""
+8 FOR
SET ITEM=$ORDER(TERMARR("E",ENODE,ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+9 SET TFINDING=""
+10 FOR
SET TFINDING=$ORDER(TERMARR("E",ENODE,ITEM,TFINDING))
if +TFINDING=0
QUIT
Begin DoDot:2
+11 KILL PFINDPA,TFINDPA
+12 MERGE TFINDPA=TERMARR(20,TFINDING)
+13 ;Set the finding parameters.
+14 DO SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+15 DO GPLIST(FILENUM,"IP",ITEM,.PFINDPA,PLIST)
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
+18 ;================================================
FPLIST(FILENUM,SNODE,ISC,ITEM,NOCC,BDT,EDT,PLIST) ;Find patient list data for
+1 ;regular files. Return the list in ^TMP($J,PLIST).
+2 NEW DAS,DATE,DFN,DS,NFOUND
+3 KILL ^TMP($JOB,PLIST)
+4 IF (FILENUM=9000010.11)
IF (ISC'="")
Begin DoDot:1
+5 IF ISC="CVX"
DO CVXL^PXRMIMM(ITEM,NOCC,BDT,EDT,PLIST)
QUIT
+6 IF ISC="VGN"
DO VGNL^PXRMIMM(ITEM,NOCC,BDT,EDT,PLIST)
End DoDot:1
QUIT
+7 IF FILENUM=601.84
DO SEVALPL^PXRMMH(ITEM,NOCC,BDT,EDT,PLIST)
QUIT
+8 SET DS=$SELECT(EDT[".":EDT+.0000001,1:EDT+.240001)
+9 SET DFN=0
+10 FOR
SET DFN=$ORDER(^PXRMINDX(FILENUM,SNODE,ITEM,DFN))
if DFN=""
QUIT
Begin DoDot:1
+11 SET NFOUND=0
+12 SET DATE=DS
+13 FOR
SET DATE=+$ORDER(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,DATE),-1)
if (DATE=0)!(DATE<BDT)!(NFOUND=NOCC)
QUIT
Begin DoDot:2
+14 SET DAS=""
+15 FOR
SET DAS=$ORDER(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,DATE,DAS),-1)
if DAS=""
QUIT
Begin DoDot:3
+16 SET NFOUND=NFOUND+1
+17 SET ^TMP($JOB,PLIST,DFN,NFOUND)=DAS_U_DATE
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
+20 ;================================================
FPLISTSS(FILENUM,SNODE,ITEM,NGET,BDT,EDT,USESTRT,PLIST) ;Find patient list
+1 ;data for a finding with a start and stop date.
+2 ;Return the list in ^TMP($J,PLIST).
+3 NEW DAS,DFN,DONE,EDTT,NFOUND,OVERLAP,SDATE,START,STOP,TDATE,TIND,TLIST
+4 KILL ^TMP($JOB,PLIST)
+5 SET EDTT=$SELECT(EDT[".":EDT+.0000001,1:EDT+.240001)
+6 SET DFN=0
+7 FOR
SET DFN=$ORDER(^PXRMINDX(FILENUM,SNODE,ITEM,DFN))
if DFN=""
QUIT
Begin DoDot:1
+8 SET (DONE,NFOUND)=0
+9 SET START=EDTT
+10 KILL TLIST
+11 FOR
SET START=+$ORDER(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,START),-1)
if (START=0)!(DONE)
QUIT
Begin DoDot:2
+12 SET STOP=""
+13 FOR
SET STOP=$ORDER(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,START,STOP),-1)
if (STOP="")!(DONE)
QUIT
Begin DoDot:3
+14 SET SDATE=$SELECT(USESTRT:START,STOP["U":$$NOW^PXRMDATE_"U",1:STOP)
+15 SET OVERLAP=$$OVERLAP^PXRMINDX(START,SDATE,BDT,EDTT)
+16 IF OVERLAP="O"
Begin DoDot:4
+17 SET DAS=$ORDER(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,START,STOP,""))
+18 SET NFOUND=NFOUND+1
SET TLIST(SDATE,NFOUND)=DAS_U_START_U_SDATE
End DoDot:4
+19 IF FILENUM="55NVA"
QUIT
+20 IF FILENUM=100
QUIT
+21 IF OVERLAP="L"
SET DONE=1
QUIT
End DoDot:3
End DoDot:2
+22 ;Return up to NGET of the most recent entries.
+23 SET NFOUND=0
SET TDATE=""
+24 FOR
SET TDATE=$ORDER(TLIST(TDATE))
if (TDATE="")!(NFOUND=NGET)
QUIT
Begin DoDot:2
+25 SET TIND=0
+26 FOR
SET TIND=$ORDER(TLIST(TDATE,TIND))
if (TIND="")!(NFOUND=NGET)
QUIT
Begin DoDot:3
+27 SET NFOUND=NFOUND+1
SET ^TMP($JOB,PLIST,DFN,NFOUND)=TLIST(TDATE,TIND)
End DoDot:3
End DoDot:2
End DoDot:1
+28 QUIT
+29 ;
+30 ;================================================
GPLIST(FILENUM,SNODE,ITEM,PFINDPA,PLIST) ;Add to the patient list
+1 ;for a regular file. Return the list in ^TMP($J,PLIST):
+2 ;^TMP($J,PLIST,T/F,DFN,ITEM,COUNT,FILENUM)=DAS^DATE^VALUE
+3 NEW BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DFN,FIEVD,FLIST,GPLIST
+4 NEW ICOND,IND,INVFD,IPLIST,ISC,NOCC,NFOUND,NGET
+5 NEW SAVE,SSFIND,STATOK,STATUSA,TEMP,TGLIST,TPLIST
+6 NEW UCIFS,USESTRT,VALUE,VSLIST
+7 SET TGLIST="GPLIST_PXRMINDL"
+8 SET ISC=$SELECT(FILENUM=9000010.11:$PIECE(PFINDPA(0),U,17),1:"")
+9 ;Determine if this is a finding with a start and stop date.
+10 SET SSFIND=$SELECT(FILENUM=52:1,FILENUM[55:1,FILENUM=100:1,1:0)
+11 SET USESTRT=$SELECT(SSFIND:$PIECE(PFINDPA(0),U,15),1:0)
+12 IF FILENUM=100
IF USESTRT=""
SET USESTRT=1
+13 ;Set the finding search parameters.
+14 DO SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
+15 SET INVFD=$PIECE(PFINDPA(0),U,16)
+16 DO GETSTATI^PXRMSTAT(FILENUM,.PFINDPA,.STATUSA)
+17 DO SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
+18 ;Ignore any negative occurrence counts, date reversal not allowed
+19 ;in patient lists.
+20 SET NOCC=$SELECT(NOCC<0:-NOCC,1:NOCC)
+21 SET NGET=$SELECT(UCIFS:50,$DATA(STATUSA):50,1:NOCC)
+22 IF SSFIND
DO FPLISTSS(FILENUM,SNODE,ITEM,NGET,BDT,EDT,USESTRT,TGLIST)
+23 IF 'SSFIND
DO FPLIST(FILENUM,SNODE,ISC,ITEM,NGET,BDT,EDT,TGLIST)
+24 SET DFN=""
+25 FOR
SET DFN=$ORDER(^TMP($JOB,TGLIST,DFN))
if DFN=""
QUIT
Begin DoDot:1
+26 KILL GPLIST
+27 MERGE GPLIST=^TMP($JOB,TGLIST,DFN)
+28 SET (IND,NFOUND)=0
+29 KILL IPLIST
+30 FOR
SET IND=$ORDER(GPLIST(IND))
if (IND="")!(NFOUND=NOCC)
QUIT
Begin DoDot:2
+31 SET TEMP=GPLIST(IND)
+32 SET DAS=$PIECE(TEMP,U,1)
+33 SET DATE=$PIECE(TEMP,U,2)
+34 ;If this a Lab finding attach the item to the DAS.
+35 ;THIS LOOKS LIKE A BUG SINCE ITEM DOES NOT APPEAR TO BE DEFINED BREAK
+36 IF PFINDPA(0)["LAB(60"
SET DAS=ITEM_"~"_DAS
+37 ;If this is a Mental Health finding attach the scale to DAS.
+38 IF PFINDPA(0)["YTT(601.71"
SET DAS=DAS_"S"_$PIECE(PFINDPA(0),U,12)
+39 DO GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
+40 SET VALUE=$GET(FIEVD("VALUE"))
+41 IF INVFD
IF $DATA(FIEVD("VISIT"))
DO GETDATA^PXRMVSIT(FIEVD("VISIT"),.FIEVD,0)
+42 SET FIEVD("DATE")=DATE
+43 ;If there is a status list make sure the finding has a status on
+44 ;the list.
+45 SET STATOK=$SELECT($DATA(STATUSA):$$STATUSOK^PXRMINDX(.STATUSA,.FIEVD),1:1)
+46 IF 'STATOK
QUIT
+47 SET CONVAL=$SELECT(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
+48 SET SAVE=$SELECT('UCIFS:1,(UCIFS&CONVAL):1,1:0)
+49 IF SAVE
Begin DoDot:3
+50 SET NFOUND=NFOUND+1
+51 SET IPLIST(CONVAL,DFN,ITEM,NFOUND,FILENUM)=TEMP_U_VALUE
End DoDot:3
End DoDot:2
+52 MERGE ^TMP($JOB,PLIST)=IPLIST
End DoDot:1
+53 KILL ^TMP($JOB,TGLIST)
+54 QUIT
+55 ;
