PXRMDRGR ; SLC/PKR - Handle groups of drug findings. ;01/25/2008
;;2.0;CLINICAL REMINDERS;**4,6,12**;Feb 04, 2005;Build 73
;Groups are drug classes or VA Generic.
;==================================================
EVALFI(DFN,DEFARR,ENODE,XREF,FIEVAL) ;Evaluate drug group findings.
N DRGRIEN,FIEVT,FINDPA,FINDING,NOINDEX
S NOINDEX=0
I $G(^PXRMINDX(52,"DATE BUILT"))="" D
. D NOINDEX^PXRMERRH("D",PXRMITEM,52)
. S NOINDEX=1
I $G(^PXRMINDX(55,"DATE BUILT"))="" D
. D NOINDEX^PXRMERRH("D",PXRMITEM,55)
. S NOINDEX=1
S DRGRIEN=""
F S DRGRIEN=$O(DEFARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0 D
. S FINDING=""
. F S FINDING=$O(DEFARR("E",ENODE,DRGRIEN,FINDING)) Q:+FINDING=0 D
.. I NOINDEX S FIEVAL(FINDING)=0 Q
.. K FIEVT,FINDPA
.. M FINDPA=DEFARR(20,FINDING)
.. D FIEVAL(DFN,DRGRIEN,.FINDPA,.DEFARR,FINDING,XREF,.FIEVT)
.. M FIEVAL(FINDING)=FIEVT
.. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
Q
;
;==================================================
EVALPL(FINDPA,ENODE,XREF,TERMARR,PLIST) ;Evaluate drug group
;terms for building patient lists.
N DRGRIEN,NOINDEX,PFINDPA
N TEMP,TFINDPA,TFINDING
S NOINDEX=0
I $G(^PXRMINDX(52,"DATE BUILT"))="" D
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
. S NOINDEX=1
I $G(^PXRMINDX(55,"DATE BUILT"))="" D
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
. S NOINDEX=1
I NOINDEX Q
S DRGRIEN=""
F S DRGRIEN=$O(TERMARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0 D
. S TFINDING=""
. F S TFINDING=$O(TERMARR("E",ENODE,DRGRIEN,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(DRGRIEN,.PFINDPA,XREF,.PLIST)
Q
;
;==================================================
EVALTERM(DFN,FINDPA,ENODE,XREF,TERMARR,TFIEVAL) ;Evaluate drug
;group terms.
N DRGRIEN,FIEVT,NOINDEX,PFINDPA
N TEMP,TFINDPA,TFINDING
S NOINDEX=0
I $G(^PXRMINDX(52,"DATE BUILT"))="" D
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
. S NOINDEX=1
I $G(^PXRMINDX(55,"DATE BUILT"))="" D
. D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
. S NOINDEX=1
S DRGRIEN=""
F S DRGRIEN=$O(TERMARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0 D
. S TFINDING=""
. F S TFINDING=$O(TERMARR("E",ENODE,DRGRIEN,TFINDING)) Q:+TFINDING=0 D
.. I NOINDEX S TFIEVAL(TFINDING)=0 Q
.. K FIEVT,PFINDPA,TFINDPA
.. M TFINDPA=TERMARR(20,TFINDING)
..;Set the finding parameters.
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
.. D FIEVAL(DFN,DRGRIEN,.PFINDPA,.TERMARR,TFINDING,XREF,.FIEVT)
.. M TFIEVAL(TFINDING)=FIEVT
.. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
Q
;
;==================================================
FIEVAL(DFN,DRGRIEN,FINDPA,DEFARR,FINDING,XREF,FIEVAL) ;
;Calls to PSSCLINR covered by DBIA #5187
N DATE,DATEORDR,DRBEG,DREND,DRUG,DRUGIEN,IND,FIEVT,FIEVTL
N NOCC,NFOUND,POI,POIBEG,POIEND,POIIEN,RXTYL
N SDIR,TDATE,TIND
S NOCC=$P(FINDPA(0),U,14)
I NOCC="" S NOCC=1
S SDIR=$S(NOCC<0:+1,1:-1)
S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
;Determine where we search.
D SRXTYL^PXRMRXTY(FINDPA(0),.RXTYL)
D GETPDR(DFN,.RXTYL,.DRBEG,.DREND,.POIBEG,.POIEND)
I DREND=0,POIEND=0 S FIEVAL=0 Q
D IX^PSSCLINR(XREF,DRGRIEN)
S (DRUGIEN,NFOUND)=0
F S DRUGIEN=+$O(^TMP($J,XREF,DRGRIEN,DRUGIEN)) Q:DRUGIEN=0 D
. I DRUGIEN'<DRBEG,DRUGIEN'>DREND S DRUG=DRUGIEN
. E S DRUG=0
. S POIIEN=$$ITEM^PSSCLINR(DRUGIEN)
. I POIIEN'<POIBEG,POIIEN'>POIEND S POI=POIIEN
. E S POI=0
. K FIEVT
. D DEVAL^PXRMDRUG(DFN,.FINDPA,.DEFARR,FINDING,.RXTYL,DRUG,POI,.FIEVT)
. I FIEVT D
.. S IND=0
.. F S IND=+$O(FIEVT(IND)) Q:IND=0 D
...;Make sure this is not already on the list
... I $$ONLIST(.FIEVTL,IND,.FIEVT) Q
... S NFOUND=NFOUND+1,FIEVTL(NFOUND,"DISPENSE DRUG")=DRUGIEN
... M FIEVTL(NFOUND)=FIEVT(IND)
... S DATEORDR(FIEVT(IND,"DATE"),NFOUND)=FIEVT(IND,"FINDING")
...;Don't keep more than NOCC occurrences on the list.
... I NFOUND>NOCC D
.... S TDATE=$O(DATEORDR(""),-SDIR),TIND=$O(DATEORDR(TDATE,""))
.... K FIEVTL(TIND),DATEORDR(TDATE,TIND)
I NFOUND=0 S FIEVAL=0 Q
;Order by date.
S DATE="",NFOUND=0
F S DATE=$O(DATEORDR(DATE),SDIR) Q:(DATE="")!(NFOUND=NOCC) D
. S IND=0
. F S IND=$O(DATEORDR(DATE,IND)) Q:(IND="")!(NFOUND=NOCC) D
.. S NFOUND=NFOUND+1
.. M FIEVAL(NFOUND)=FIEVTL(IND)
;Save the finding result.
D SFRES^PXRMUTIL(SDIR,NFOUND,.FIEVAL)
K ^TMP($J,XREF)
Q
;
;==================================================
GETPDR(DFN,RXTYL,DRBEG,DREND,POIBEG,POIEND) ;Return the beginning drug and
;ending drug for a patient.
N IBEG,IEND,OBEG,OEND
I $D(RXTYL("I")) D
. S IBEG=+$O(^PXRMINDX(55,"PI",DFN,0))
. S IEND=+$O(^PXRMINDX(55,"PI",DFN,""),-1)
E S (IBEG,IEND)=0
I $D(RXTYL("O")) D
. S OBEG=+$O(^PXRMINDX(52,"PI",DFN,0))
. S OEND=+$O(^PXRMINDX(52,"PI",DFN,""),-1)
E S (OBEG,OEND)=0
S DRBEG=$S(IBEG<OBEG:IBEG,1:OBEG)
S DREND=$S(IEND>OEND:IEND,1:OEND)
I $D(RXTYL("N")) D
. S POIBEG=+$O(^PXRMINDX("55NVA","PI",DFN,0))
. S POIEND=+$O(^PXRMINDX("55NVA","PI",DFN,""),-1)
E S (POIBEG,POIEND)=0
Q
;
;==================================================
GPLIST(DRGRIEN,PFINDPA,XREF,PLIST) ;
;Calls to PSSCLINR covered by DBIA #5187
N DATE,DFN,DRUGIEN,FILENUM,IND,ITEM,NFOUND,NOCC,POI,RXTYL
N TF,TEMP,TGLIST,TLIST
S TGLIST="GPLIST_PXRMDRGR"
K ^TMP($J,TGLIST)
;Determine where we search.
D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL)
D IX^PSSCLINR(XREF,DRGRIEN)
S DRUGIEN=0
F S DRUGIEN=+$O(^TMP($J,XREF,DRGRIEN,DRUGIEN)) Q:DRUGIEN=0 D
. S POI=$$ITEM^PSSCLINR(DRUGIEN)
. I $D(RXTYL("I")) D GPLIST^PXRMINDL(55,"IP",DRUGIEN,.PFINDPA,TGLIST)
. I $D(RXTYL("N")),POI'="" D GPLIST^PXRMINDL("55NVA","IP",POI,.PFINDPA,TGLIST)
. I $D(RXTYL("O")) D GPLIST^PXRMINDL(52,"IP",DRUGIEN,.PFINDPA,TGLIST)
;Return the NOCC most recent results for each DFN.
S NOCC=$P(FINDPA(0),U,14)
S NOCC=$S(NOCC<0:-NOCC,NOCC="":1,1:NOCC)
F TF=0,1 D
. S DFN=0
. F S DFN=$O(^TMP($J,TGLIST,TF,DFN)) Q:DFN="" D
.. K TLIST
.. S ITEM=""
.. F S ITEM=$O(^TMP($J,TGLIST,TF,DFN,ITEM)) Q:ITEM="" D
... S NFOUND=""
... F S NFOUND=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND)) Q:NFOUND="" D
.... S FILENUM=""
.... F S FILENUM=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)) Q:FILENUM="" D
..... S TEMP=^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)
..... S DATE=+$P(TEMP,U,3)
..... S TLIST(TF,DATE,ITEM,NFOUND,FILENUM)=""
.. S DATE="",NFOUND=0
.. F S DATE=$O(TLIST(TF,DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D
... S ITEM=""
... F S ITEM=$O(TLIST(TF,DATE,ITEM)) Q:(ITEM="")!(NFOUND=NOCC) D
.... S IND=""
.... F S IND=$O(TLIST(TF,DATE,ITEM,IND)) Q:(IND="")!(NFOUND=NOCC) D
..... S FILENUM=""
..... F S FILENUM=$O(TLIST(TF,DATE,ITEM,IND,FILENUM)) Q:(FILENUM="")!(NFOUND=NOCC) D
...... S NFOUND=NFOUND+1
...... S ^TMP($J,PLIST,TF,DFN,ITEM,NFOUND,FILENUM)=^TMP($J,TGLIST,TF,DFN,ITEM,IND,FILENUM)
K ^TMP($J,TGLIST),^TMP($J,XREF)
Q
;
;==================================================
ONLIST(FIEVTL,IND,FIEVT) ;Return true if FIEVT(IND) is already on
;FIEVTL.
N JND,ONLIST
S (JND,ONLIST)=0
F S JND=$O(FIEVTL(JND)) Q:(ONLIST)!(JND="") D
. I FIEVTL(JND,"FILE NUMBER")'=FIEVT(IND,"FILE NUMBER") Q
. I FIEVTL(JND,"DAS")'=FIEVT(IND,"DAS") Q
. S ONLIST=1
Q ONLIST
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMDRGR 7338 printed Apr 09, 2024@20:54:41 Page 2
PXRMDRGR ; SLC/PKR - Handle groups of drug findings. ;01/25/2008
+1 ;;2.0;CLINICAL REMINDERS;**4,6,12**;Feb 04, 2005;Build 73
+2 ;Groups are drug classes or VA Generic.
+3 ;==================================================
EVALFI(DFN,DEFARR,ENODE,XREF,FIEVAL) ;Evaluate drug group findings.
+1 NEW DRGRIEN,FIEVT,FINDPA,FINDING,NOINDEX
+2 SET NOINDEX=0
+3 IF $GET(^PXRMINDX(52,"DATE BUILT"))=""
Begin DoDot:1
+4 DO NOINDEX^PXRMERRH("D",PXRMITEM,52)
+5 SET NOINDEX=1
End DoDot:1
+6 IF $GET(^PXRMINDX(55,"DATE BUILT"))=""
Begin DoDot:1
+7 DO NOINDEX^PXRMERRH("D",PXRMITEM,55)
+8 SET NOINDEX=1
End DoDot:1
+9 SET DRGRIEN=""
+10 FOR
SET DRGRIEN=$ORDER(DEFARR("E",ENODE,DRGRIEN))
if +DRGRIEN=0
QUIT
Begin DoDot:1
+11 SET FINDING=""
+12 FOR
SET FINDING=$ORDER(DEFARR("E",ENODE,DRGRIEN,FINDING))
if +FINDING=0
QUIT
Begin DoDot:2
+13 IF NOINDEX
SET FIEVAL(FINDING)=0
QUIT
+14 KILL FIEVT,FINDPA
+15 MERGE FINDPA=DEFARR(20,FINDING)
+16 DO FIEVAL(DFN,DRGRIEN,.FINDPA,.DEFARR,FINDING,XREF,.FIEVT)
+17 MERGE FIEVAL(FINDING)=FIEVT
+18 SET FIEVAL(FINDING,"FINDING")=$PIECE(FINDPA(0),U,1)
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
+21 ;==================================================
EVALPL(FINDPA,ENODE,XREF,TERMARR,PLIST) ;Evaluate drug group
+1 ;terms for building patient lists.
+2 NEW DRGRIEN,NOINDEX,PFINDPA
+3 NEW TEMP,TFINDPA,TFINDING
+4 SET NOINDEX=0
+5 IF $GET(^PXRMINDX(52,"DATE BUILT"))=""
Begin DoDot:1
+6 DO NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
+7 SET NOINDEX=1
End DoDot:1
+8 IF $GET(^PXRMINDX(55,"DATE BUILT"))=""
Begin DoDot:1
+9 DO NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
+10 SET NOINDEX=1
End DoDot:1
+11 IF NOINDEX
QUIT
+12 SET DRGRIEN=""
+13 FOR
SET DRGRIEN=$ORDER(TERMARR("E",ENODE,DRGRIEN))
if +DRGRIEN=0
QUIT
Begin DoDot:1
+14 SET TFINDING=""
+15 FOR
SET TFINDING=$ORDER(TERMARR("E",ENODE,DRGRIEN,TFINDING))
if +TFINDING=0
QUIT
Begin DoDot:2
+16 KILL PFINDPA,TFINDPA
+17 MERGE TFINDPA=TERMARR(20,TFINDING)
+18 ;Set the finding parameters.
+19 DO SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+20 DO GPLIST(DRGRIEN,.PFINDPA,XREF,.PLIST)
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
+23 ;==================================================
EVALTERM(DFN,FINDPA,ENODE,XREF,TERMARR,TFIEVAL) ;Evaluate drug
+1 ;group terms.
+2 NEW DRGRIEN,FIEVT,NOINDEX,PFINDPA
+3 NEW TEMP,TFINDPA,TFINDING
+4 SET NOINDEX=0
+5 IF $GET(^PXRMINDX(52,"DATE BUILT"))=""
Begin DoDot:1
+6 DO NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
+7 SET NOINDEX=1
End DoDot:1
+8 IF $GET(^PXRMINDX(55,"DATE BUILT"))=""
Begin DoDot:1
+9 DO NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
+10 SET NOINDEX=1
End DoDot:1
+11 SET DRGRIEN=""
+12 FOR
SET DRGRIEN=$ORDER(TERMARR("E",ENODE,DRGRIEN))
if +DRGRIEN=0
QUIT
Begin DoDot:1
+13 SET TFINDING=""
+14 FOR
SET TFINDING=$ORDER(TERMARR("E",ENODE,DRGRIEN,TFINDING))
if +TFINDING=0
QUIT
Begin DoDot:2
+15 IF NOINDEX
SET TFIEVAL(TFINDING)=0
QUIT
+16 KILL FIEVT,PFINDPA,TFINDPA
+17 MERGE TFINDPA=TERMARR(20,TFINDING)
+18 ;Set the finding parameters.
+19 DO SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+20 DO FIEVAL(DFN,DRGRIEN,.PFINDPA,.TERMARR,TFINDING,XREF,.FIEVT)
+21 MERGE TFIEVAL(TFINDING)=FIEVT
+22 SET TFIEVAL(TFINDING,"FINDING")=$PIECE(TFINDPA(0),U,1)
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
+25 ;==================================================
FIEVAL(DFN,DRGRIEN,FINDPA,DEFARR,FINDING,XREF,FIEVAL) ;
+1 ;Calls to PSSCLINR covered by DBIA #5187
+2 NEW DATE,DATEORDR,DRBEG,DREND,DRUG,DRUGIEN,IND,FIEVT,FIEVTL
+3 NEW NOCC,NFOUND,POI,POIBEG,POIEND,POIIEN,RXTYL
+4 NEW SDIR,TDATE,TIND
+5 SET NOCC=$PIECE(FINDPA(0),U,14)
+6 IF NOCC=""
SET NOCC=1
+7 SET SDIR=$SELECT(NOCC<0:+1,1:-1)
+8 SET NOCC=$SELECT(NOCC<0:-NOCC,1:NOCC)
+9 ;Determine where we search.
+10 DO SRXTYL^PXRMRXTY(FINDPA(0),.RXTYL)
+11 DO GETPDR(DFN,.RXTYL,.DRBEG,.DREND,.POIBEG,.POIEND)
+12 IF DREND=0
IF POIEND=0
SET FIEVAL=0
QUIT
+13 DO IX^PSSCLINR(XREF,DRGRIEN)
+14 SET (DRUGIEN,NFOUND)=0
+15 FOR
SET DRUGIEN=+$ORDER(^TMP($JOB,XREF,DRGRIEN,DRUGIEN))
if DRUGIEN=0
QUIT
Begin DoDot:1
+16 IF DRUGIEN'<DRBEG
IF DRUGIEN'>DREND
SET DRUG=DRUGIEN
+17 IF '$TEST
SET DRUG=0
+18 SET POIIEN=$$ITEM^PSSCLINR(DRUGIEN)
+19 IF POIIEN'<POIBEG
IF POIIEN'>POIEND
SET POI=POIIEN
+20 IF '$TEST
SET POI=0
+21 KILL FIEVT
+22 DO DEVAL^PXRMDRUG(DFN,.FINDPA,.DEFARR,FINDING,.RXTYL,DRUG,POI,.FIEVT)
+23 IF FIEVT
Begin DoDot:2
+24 SET IND=0
+25 FOR
SET IND=+$ORDER(FIEVT(IND))
if IND=0
QUIT
Begin DoDot:3
+26 ;Make sure this is not already on the list
+27 IF $$ONLIST(.FIEVTL,IND,.FIEVT)
QUIT
+28 SET NFOUND=NFOUND+1
SET FIEVTL(NFOUND,"DISPENSE DRUG")=DRUGIEN
+29 MERGE FIEVTL(NFOUND)=FIEVT(IND)
+30 SET DATEORDR(FIEVT(IND,"DATE"),NFOUND)=FIEVT(IND,"FINDING")
+31 ;Don't keep more than NOCC occurrences on the list.
+32 IF NFOUND>NOCC
Begin DoDot:4
+33 SET TDATE=$ORDER(DATEORDR(""),-SDIR)
SET TIND=$ORDER(DATEORDR(TDATE,""))
+34 KILL FIEVTL(TIND),DATEORDR(TDATE,TIND)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+35 IF NFOUND=0
SET FIEVAL=0
QUIT
+36 ;Order by date.
+37 SET DATE=""
SET NFOUND=0
+38 FOR
SET DATE=$ORDER(DATEORDR(DATE),SDIR)
if (DATE="")!(NFOUND=NOCC)
QUIT
Begin DoDot:1
+39 SET IND=0
+40 FOR
SET IND=$ORDER(DATEORDR(DATE,IND))
if (IND="")!(NFOUND=NOCC)
QUIT
Begin DoDot:2
+41 SET NFOUND=NFOUND+1
+42 MERGE FIEVAL(NFOUND)=FIEVTL(IND)
End DoDot:2
End DoDot:1
+43 ;Save the finding result.
+44 DO SFRES^PXRMUTIL(SDIR,NFOUND,.FIEVAL)
+45 KILL ^TMP($JOB,XREF)
+46 QUIT
+47 ;
+48 ;==================================================
GETPDR(DFN,RXTYL,DRBEG,DREND,POIBEG,POIEND) ;Return the beginning drug and
+1 ;ending drug for a patient.
+2 NEW IBEG,IEND,OBEG,OEND
+3 IF $DATA(RXTYL("I"))
Begin DoDot:1
+4 SET IBEG=+$ORDER(^PXRMINDX(55,"PI",DFN,0))
+5 SET IEND=+$ORDER(^PXRMINDX(55,"PI",DFN,""),-1)
End DoDot:1
+6 IF '$TEST
SET (IBEG,IEND)=0
+7 IF $DATA(RXTYL("O"))
Begin DoDot:1
+8 SET OBEG=+$ORDER(^PXRMINDX(52,"PI",DFN,0))
+9 SET OEND=+$ORDER(^PXRMINDX(52,"PI",DFN,""),-1)
End DoDot:1
+10 IF '$TEST
SET (OBEG,OEND)=0
+11 SET DRBEG=$SELECT(IBEG<OBEG:IBEG,1:OBEG)
+12 SET DREND=$SELECT(IEND>OEND:IEND,1:OEND)
+13 IF $DATA(RXTYL("N"))
Begin DoDot:1
+14 SET POIBEG=+$ORDER(^PXRMINDX("55NVA","PI",DFN,0))
+15 SET POIEND=+$ORDER(^PXRMINDX("55NVA","PI",DFN,""),-1)
End DoDot:1
+16 IF '$TEST
SET (POIBEG,POIEND)=0
+17 QUIT
+18 ;
+19 ;==================================================
GPLIST(DRGRIEN,PFINDPA,XREF,PLIST) ;
+1 ;Calls to PSSCLINR covered by DBIA #5187
+2 NEW DATE,DFN,DRUGIEN,FILENUM,IND,ITEM,NFOUND,NOCC,POI,RXTYL
+3 NEW TF,TEMP,TGLIST,TLIST
+4 SET TGLIST="GPLIST_PXRMDRGR"
+5 KILL ^TMP($JOB,TGLIST)
+6 ;Determine where we search.
+7 DO SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL)
+8 DO IX^PSSCLINR(XREF,DRGRIEN)
+9 SET DRUGIEN=0
+10 FOR
SET DRUGIEN=+$ORDER(^TMP($JOB,XREF,DRGRIEN,DRUGIEN))
if DRUGIEN=0
QUIT
Begin DoDot:1
+11 SET POI=$$ITEM^PSSCLINR(DRUGIEN)
+12 IF $DATA(RXTYL("I"))
DO GPLIST^PXRMINDL(55,"IP",DRUGIEN,.PFINDPA,TGLIST)
+13 IF $DATA(RXTYL("N"))
IF POI'=""
DO GPLIST^PXRMINDL("55NVA","IP",POI,.PFINDPA,TGLIST)
+14 IF $DATA(RXTYL("O"))
DO GPLIST^PXRMINDL(52,"IP",DRUGIEN,.PFINDPA,TGLIST)
End DoDot:1
+15 ;Return the NOCC most recent results for each DFN.
+16 SET NOCC=$PIECE(FINDPA(0),U,14)
+17 SET NOCC=$SELECT(NOCC<0:-NOCC,NOCC="":1,1:NOCC)
+18 FOR TF=0,1
Begin DoDot:1
+19 SET DFN=0
+20 FOR
SET DFN=$ORDER(^TMP($JOB,TGLIST,TF,DFN))
if DFN=""
QUIT
Begin DoDot:2
+21 KILL TLIST
+22 SET ITEM=""
+23 FOR
SET ITEM=$ORDER(^TMP($JOB,TGLIST,TF,DFN,ITEM))
if ITEM=""
QUIT
Begin DoDot:3
+24 SET NFOUND=""
+25 FOR
SET NFOUND=$ORDER(^TMP($JOB,TGLIST,TF,DFN,ITEM,NFOUND))
if NFOUND=""
QUIT
Begin DoDot:4
+26 SET FILENUM=""
+27 FOR
SET FILENUM=$ORDER(^TMP($JOB,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM))
if FILENUM=""
QUIT
Begin DoDot:5
+28 SET TEMP=^TMP($JOB,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)
+29 SET DATE=+$PIECE(TEMP,U,3)
+30 SET TLIST(TF,DATE,ITEM,NFOUND,FILENUM)=""
End DoDot:5
End DoDot:4
End DoDot:3
+31 SET DATE=""
SET NFOUND=0
+32 FOR
SET DATE=$ORDER(TLIST(TF,DATE),-1)
if (DATE="")!(NFOUND=NOCC)
QUIT
Begin DoDot:3
+33 SET ITEM=""
+34 FOR
SET ITEM=$ORDER(TLIST(TF,DATE,ITEM))
if (ITEM="")!(NFOUND=NOCC)
QUIT
Begin DoDot:4
+35 SET IND=""
+36 FOR
SET IND=$ORDER(TLIST(TF,DATE,ITEM,IND))
if (IND="")!(NFOUND=NOCC)
QUIT
Begin DoDot:5
+37 SET FILENUM=""
+38 FOR
SET FILENUM=$ORDER(TLIST(TF,DATE,ITEM,IND,FILENUM))
if (FILENUM="")!(NFOUND=NOCC)
QUIT
Begin DoDot:6
+39 SET NFOUND=NFOUND+1
+40 SET ^TMP($JOB,PLIST,TF,DFN,ITEM,NFOUND,FILENUM)=^TMP($JOB,TGLIST,TF,DFN,ITEM,IND,FILENUM)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+41 KILL ^TMP($JOB,TGLIST),^TMP($JOB,XREF)
+42 QUIT
+43 ;
+44 ;==================================================
ONLIST(FIEVTL,IND,FIEVT) ;Return true if FIEVT(IND) is already on
+1 ;FIEVTL.
+2 NEW JND,ONLIST
+3 SET (JND,ONLIST)=0
+4 FOR
SET JND=$ORDER(FIEVTL(JND))
if (ONLIST)!(JND="")
QUIT
Begin DoDot:1
+5 IF FIEVTL(JND,"FILE NUMBER")'=FIEVT(IND,"FILE NUMBER")
QUIT
+6 IF FIEVTL(JND,"DAS")'=FIEVT(IND,"DAS")
QUIT
+7 SET ONLIST=1
End DoDot:1
+8 QUIT ONLIST
+9 ;
