- PXRMINDX ;SLC/PKR - Routines for utilizing the index. ;03/31/2022
- ;;2.0;CLINICAL REMINDERS;**4,6,12,17,18,26,65**;Feb 04, 2005;Build 438
- ;Code for patient findings.
- ;====================
- EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;General finding evaluator.
- N BDT,EDT,FIEVT,FILENUM,FINDING,FINDPA,ITEM,NOINDEX
- S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
- I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D
- . D NOINDEX^PXRMERRH("D",PXRMITEM,FILENUM)
- . S NOINDEX=1
- E S NOINDEX=0
- S ITEM=""
- F S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:ITEM="" D
- . S FINDING=""
- . F S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0 D
- .. I NOINDEX S FIEVAL(FINDING)=0 Q
- .. 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)
- .. I FILENUM=9000010.11 D CRFINDING^PXRMIMM(DFN,ITEM,FINDING,.FIEVAL)
- Q
- ;
- ;====================
- EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;General term
- ;evaluator.
- N FIEVT,FILENUM,ITEM,NOINDEX,PFINDPA
- N TFINDING,TFINDPA
- S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
- I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D
- . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),FILENUM)
- . S NOINDEX=1
- E S NOINDEX=0
- 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
- .. 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(FILENUM,"PI",DFN,ITEM,.PFINDPA,.FIEVT)
- .. M TFIEVAL(TFINDING)=FIEVT
- .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
- .. I FILENUM=9000010.11 D CRFINDING^PXRMIMM(DFN,ITEM,TFINDING,.TFIEVAL)
- Q
- ;
- ;====================
- FIEVAL(FILENUM,SNODE,DFN,ITEM,PFINDPA,FIEVAL) ;
- ;Evaluate regular patient findings.
- N BDT,CASESEN,COND,CONVAL,CRLIST,DAS,DATE,EDT,FIEVD,FLIST
- N ICOND,IEN,IND,INVFD,ISC,NFOUND,NGET,NOCC,NP
- N SAVE,SDIR,SSFIND,STATOK,STATUSA,UCIFS,USESTRT,VSLIST
- ;Set the finding search parameters.
- D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
- S FIEVAL("BDTE")=BDT,FIEVAL("EDTE")=EDT
- D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
- S SDIR=$S(NOCC<0:+1,1:-1)
- S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
- S NGET=$S(UCIFS:50,1:NOCC)
- 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
- ;Get the status list.
- D GETSTATI^PXRMSTAT(FILENUM,.PFINDPA,.STATUSA)
- I SSFIND D FPDATSS(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,USESTRT,.NFOUND,.FLIST)
- I 'SSFIND D FPDAT(FILENUM,SNODE,ISC,DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)
- I NFOUND=0 S FIEVAL=0 Q
- S INVFD=$P(PFINDPA(0),U,16)
- S NP=0
- F IND=1:1:NFOUND Q:NP=NOCC D
- . S DAS=$P(FLIST(IND),U,1)
- .;If this a Lab finding attach the item to the DAS.
- . 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)
- . I INVFD,$D(FIEVD("VISIT")) D GETDATA^PXRMVSIT(FIEVD("VISIT"),.FIEVD,0)
- . S FIEVD("DATE")=$P(FLIST(IND),U,2)
- . I ISC'="" S FIEVD("ISC")=ISC
- .;If there is a status list make sure the finding has one on the list.
- . S STATOK=$S($D(STATUSA):$$STATUSOK(.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 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(SDIR,NP,.FIEVAL)
- S FIEVAL("FILE NUMBER")=FILENUM
- Q
- ;
- ;====================
- FPDAT(FILENUM,SNODE,ISC,DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST) ;Find patient
- ;data for regular files. FLIST is returned in date order, i.e.,
- ;FLIST(1) is the most recent SDIR=-1, oldest SDIR=+1.
- I (FILENUM=9000010.11),(ISC="CVX") D CVXP^PXRMIMM(DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST) Q
- I (FILENUM=9000010.11),(ISC="VGN") D VGNP^PXRMIMM(DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST) Q
- I FILENUM=601.84 D SEVALFI^PXRMMH(DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST) Q
- N DAS,DATE,DONE,EDTT
- S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
- S (DONE,NFOUND)=0
- S DATE=$S(SDIR=+1:BDT-.000001,1:EDTT)
- F S DATE=+$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,DATE),SDIR) Q:(DATE=0)!(DONE) D
- . I DATE<BDT,SDIR=-1 S DONE=1 Q
- . I DATE>EDTT,SDIR=1 S DONE=1 Q
- . S DAS=""
- . F S DAS=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,DATE,DAS),-1) Q:DAS="" D
- .. S NFOUND=NFOUND+1
- .. S FLIST(NFOUND)=DAS_U_DATE
- .. I NFOUND=NGET S DONE=1 Q
- Q
- ;
- ;====================
- FPDATSS(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,USESTRT,NFOUND,FLIST) ;Find
- ;patient data for findings that have a start and stop date. FLIST
- ;is returned in date order, i.e., FLIST(1) is the most recent.
- N DAS,DONE,EDTT,OVERLAP,SDATE,START,STOP,TDATE,TIND,TLIST
- S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
- S (DONE,NFOUND)=0
- S START=$S(SDIR=+1:0,1:EDTT)
- F S START=+$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START),SDIR) Q:(START=0)!(DONE)!(START>EDTT) D
- . S STOP=""
- . F S STOP=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP),SDIR) Q:(STOP="")!(DONE) D
- ..;Items that do not have a stop date are flagged by "U".
- .. S SDATE=$S(USESTRT:START,STOP["U":$$NOW^PXRMDATE_"U",1:STOP)
- .. S OVERLAP=$$OVERLAP(START,SDATE,BDT,EDT)
- .. I OVERLAP="O" D
- ... S DAS=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP,""))
- ... S NFOUND=NFOUND+1,TLIST(SDATE,NFOUND)=DAS_U_SDATE
- ..;Some orders and non-VA meds may not have a Stop Date so we have
- ..;to check all entries.
- .. I FILENUM="55NVA" Q
- .. I FILENUM=100 Q
- .. I OVERLAP="L",SDIR=-1 S DONE=1 Q
- .. I OVERLAP="R",SDIR=1 S DONE=1 Q
- ;Return up to NGET of the most recent/oldest entries.
- S NFOUND=0,TDATE=""
- F S TDATE=$O(TLIST(TDATE),SDIR) Q:(TDATE="")!(NFOUND=NGET) D
- . S TIND=0
- . F S TIND=$O(TLIST(TDATE,TIND)) Q:(TIND="")!(NFOUND=NGET) D
- .. S NFOUND=NFOUND+1,FLIST(NFOUND)=TLIST(TDATE,TIND)
- Q
- ;
- ;====================
- OVERLAP(START,STOP,BDT,EDT) ;Determine if the date range defined by START and
- ;STOP overlaps with the date range defined by BDT and EDT. The return
- ;value "O" means they overlap, "L" means START, STOP is to the
- ;left of BDT, EDT and "R" means it is to the right.
- I EDT<START Q "R"
- I STOP<BDT Q "L"
- Q "O"
- ;
- ;====================
- STATUSOK(STATUSA,FIEVD) ;Return true if the status in FIEVD matches one in
- ;the list in STATUSA.
- I '$D(FIEVD("STATUS")) Q 1
- N JND,OK
- S OK=0
- F JND=1:1:STATUSA(0) Q:OK D
- . I STATUSA(JND)="*" S OK=1 Q
- . I STATUSA(JND)=FIEVD("STATUS") S OK=1 Q
- Q OK
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMINDX 7065 printed Feb 18, 2025@23:12:34 Page 2
- PXRMINDX ;SLC/PKR - Routines for utilizing the index. ;03/31/2022
- +1 ;;2.0;CLINICAL REMINDERS;**4,6,12,17,18,26,65**;Feb 04, 2005;Build 438
- +2 ;Code for patient findings.
- +3 ;====================
- EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;General finding evaluator.
- +1 NEW BDT,EDT,FIEVT,FILENUM,FINDING,FINDPA,ITEM,NOINDEX
- +2 SET FILENUM=$$GETFNUM^PXRMDATA(ENODE)
- +3 IF $GET(^PXRMINDX(FILENUM,"DATE BUILT"))=""
- Begin DoDot:1
- +4 DO NOINDEX^PXRMERRH("D",PXRMITEM,FILENUM)
- +5 SET NOINDEX=1
- End DoDot:1
- +6 IF '$TEST
- SET NOINDEX=0
- +7 SET ITEM=""
- +8 FOR
- SET ITEM=$ORDER(DEFARR("E",ENODE,ITEM))
- if ITEM=""
- QUIT
- Begin DoDot:1
- +9 SET FINDING=""
- +10 FOR
- SET FINDING=$ORDER(DEFARR("E",ENODE,ITEM,FINDING))
- if +FINDING=0
- QUIT
- Begin DoDot:2
- +11 IF NOINDEX
- SET FIEVAL(FINDING)=0
- QUIT
- +12 KILL FINDPA
- +13 MERGE FINDPA=DEFARR(20,FINDING)
- +14 KILL FIEVT
- +15 DO FIEVAL(FILENUM,"PI",DFN,ITEM,.FINDPA,.FIEVT)
- +16 MERGE FIEVAL(FINDING)=FIEVT
- +17 SET FIEVAL(FINDING,"FINDING")=$PIECE(FINDPA(0),U,1)
- +18 IF FILENUM=9000010.11
- DO CRFINDING^PXRMIMM(DFN,ITEM,FINDING,.FIEVAL)
- End DoDot:2
- End DoDot:1
- +19 QUIT
- +20 ;
- +21 ;====================
- EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;General term
- +1 ;evaluator.
- +2 NEW FIEVT,FILENUM,ITEM,NOINDEX,PFINDPA
- +3 NEW 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)
- +7 SET NOINDEX=1
- End DoDot:1
- +8 IF '$TEST
- SET NOINDEX=0
- +9 SET ITEM=""
- +10 FOR
- SET ITEM=$ORDER(TERMARR("E",ENODE,ITEM))
- if ITEM=""
- QUIT
- Begin DoDot:1
- +11 SET TFINDING=""
- +12 FOR
- SET TFINDING=$ORDER(TERMARR("E",ENODE,ITEM,TFINDING))
- if +TFINDING=0
- QUIT
- Begin DoDot:2
- +13 IF NOINDEX
- SET TFIEVAL(TFINDING)=0
- QUIT
- +14 KILL FIEVT,PFINDPA,TFINDPA
- +15 MERGE TFINDPA=TERMARR(20,TFINDING)
- +16 ;Set the finding parameters.
- +17 DO SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
- +18 DO FIEVAL(FILENUM,"PI",DFN,ITEM,.PFINDPA,.FIEVT)
- +19 MERGE TFIEVAL(TFINDING)=FIEVT
- +20 SET TFIEVAL(TFINDING,"FINDING")=$PIECE(TFINDPA(0),U,1)
- +21 IF FILENUM=9000010.11
- DO CRFINDING^PXRMIMM(DFN,ITEM,TFINDING,.TFIEVAL)
- End DoDot:2
- End DoDot:1
- +22 QUIT
- +23 ;
- +24 ;====================
- FIEVAL(FILENUM,SNODE,DFN,ITEM,PFINDPA,FIEVAL) ;
- +1 ;Evaluate regular patient findings.
- +2 NEW BDT,CASESEN,COND,CONVAL,CRLIST,DAS,DATE,EDT,FIEVD,FLIST
- +3 NEW ICOND,IEN,IND,INVFD,ISC,NFOUND,NGET,NOCC,NP
- +4 NEW SAVE,SDIR,SSFIND,STATOK,STATUSA,UCIFS,USESTRT,VSLIST
- +5 ;Set the finding search parameters.
- +6 DO SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
- +7 SET FIEVAL("BDTE")=BDT
- SET FIEVAL("EDTE")=EDT
- +8 DO SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
- +9 SET SDIR=$SELECT(NOCC<0:+1,1:-1)
- +10 SET NOCC=$SELECT(NOCC<0:-NOCC,1:NOCC)
- +11 SET NGET=$SELECT(UCIFS:50,1:NOCC)
- +12 SET ISC=$SELECT(FILENUM=9000010.11:$PIECE(PFINDPA(0),U,17),1:"")
- +13 ;Determine if this is a finding with a start and stop date.
- +14 SET SSFIND=$SELECT(FILENUM=52:1,FILENUM["55":1,FILENUM=100:1,1:0)
- +15 SET USESTRT=$SELECT(SSFIND:$PIECE(PFINDPA(0),U,15),1:0)
- +16 IF FILENUM=100
- IF USESTRT=""
- SET USESTRT=1
- +17 ;Get the status list.
- +18 DO GETSTATI^PXRMSTAT(FILENUM,.PFINDPA,.STATUSA)
- +19 IF SSFIND
- DO FPDATSS(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,USESTRT,.NFOUND,.FLIST)
- +20 IF 'SSFIND
- DO FPDAT(FILENUM,SNODE,ISC,DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)
- +21 IF NFOUND=0
- SET FIEVAL=0
- QUIT
- +22 SET INVFD=$PIECE(PFINDPA(0),U,16)
- +23 SET NP=0
- +24 FOR IND=1:1:NFOUND
- if NP=NOCC
- QUIT
- Begin DoDot:1
- +25 SET DAS=$PIECE(FLIST(IND),U,1)
- +26 ;If this a Lab finding attach the item to the DAS.
- +27 IF PFINDPA(0)["LAB(60"
- SET DAS=ITEM_"~"_DAS
- +28 ;If this is a Mental Health finding attach the scale to DAS.
- +29 IF PFINDPA(0)["YTT(601.71"
- SET DAS=DAS_"S"_$PIECE(PFINDPA(0),U,12)
- +30 DO GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
- +31 IF INVFD
- IF $DATA(FIEVD("VISIT"))
- DO GETDATA^PXRMVSIT(FIEVD("VISIT"),.FIEVD,0)
- +32 SET FIEVD("DATE")=$PIECE(FLIST(IND),U,2)
- +33 IF ISC'=""
- SET FIEVD("ISC")=ISC
- +34 ;If there is a status list make sure the finding has one on the list.
- +35 SET STATOK=$SELECT($DATA(STATUSA):$$STATUSOK(.STATUSA,.FIEVD),1:1)
- +36 IF 'STATOK
- QUIT
- +37 SET CONVAL=$SELECT(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
- +38 SET SAVE=$SELECT('UCIFS:1,(UCIFS&CONVAL):1,1:0)
- +39 IF SAVE
- Begin DoDot:2
- +40 SET NP=NP+1
- +41 SET FIEVAL(NP)=CONVAL
- +42 IF COND'=""
- SET FIEVAL(NP,"CONDITION")=CONVAL
- +43 SET FIEVAL(NP,"DAS")=$PIECE(FLIST(IND),U,1)
- +44 SET FIEVAL(NP,"DATE")=FIEVD("DATE")
- +45 MERGE FIEVAL(NP)=FIEVD
- +46 IF $GET(PXRMDEBG)
- MERGE FIEVAL(NP,"CSUB")=FIEVD
- End DoDot:2
- End DoDot:1
- +47 ;
- +48 ;Save the finding result.
- +49 DO SFRES^PXRMUTIL(SDIR,NP,.FIEVAL)
- +50 SET FIEVAL("FILE NUMBER")=FILENUM
- +51 QUIT
- +52 ;
- +53 ;====================
- FPDAT(FILENUM,SNODE,ISC,DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST) ;Find patient
- +1 ;data for regular files. FLIST is returned in date order, i.e.,
- +2 ;FLIST(1) is the most recent SDIR=-1, oldest SDIR=+1.
- +3 IF (FILENUM=9000010.11)
- IF (ISC="CVX")
- DO CVXP^PXRMIMM(DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)
- QUIT
- +4 IF (FILENUM=9000010.11)
- IF (ISC="VGN")
- DO VGNP^PXRMIMM(DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)
- QUIT
- +5 IF FILENUM=601.84
- DO SEVALFI^PXRMMH(DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)
- QUIT
- +6 NEW DAS,DATE,DONE,EDTT
- +7 SET EDTT=$SELECT(EDT[".":EDT+.0000001,1:EDT+.240001)
- +8 SET (DONE,NFOUND)=0
- +9 SET DATE=$SELECT(SDIR=+1:BDT-.000001,1:EDTT)
- +10 FOR
- SET DATE=+$ORDER(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,DATE),SDIR)
- if (DATE=0)!(DONE)
- QUIT
- Begin DoDot:1
- +11 IF DATE<BDT
- IF SDIR=-1
- SET DONE=1
- QUIT
- +12 IF DATE>EDTT
- IF SDIR=1
- SET DONE=1
- QUIT
- +13 SET DAS=""
- +14 FOR
- SET DAS=$ORDER(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,DATE,DAS),-1)
- if DAS=""
- QUIT
- Begin DoDot:2
- +15 SET NFOUND=NFOUND+1
- +16 SET FLIST(NFOUND)=DAS_U_DATE
- +17 IF NFOUND=NGET
- SET DONE=1
- QUIT
- End DoDot:2
- End DoDot:1
- +18 QUIT
- +19 ;
- +20 ;====================
- FPDATSS(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,USESTRT,NFOUND,FLIST) ;Find
- +1 ;patient data for findings that have a start and stop date. FLIST
- +2 ;is returned in date order, i.e., FLIST(1) is the most recent.
- +3 NEW DAS,DONE,EDTT,OVERLAP,SDATE,START,STOP,TDATE,TIND,TLIST
- +4 SET EDTT=$SELECT(EDT[".":EDT+.0000001,1:EDT+.240001)
- +5 SET (DONE,NFOUND)=0
- +6 SET START=$SELECT(SDIR=+1:0,1:EDTT)
- +7 FOR
- SET START=+$ORDER(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START),SDIR)
- if (START=0)!(DONE)!(START>EDTT)
- QUIT
- Begin DoDot:1
- +8 SET STOP=""
- +9 FOR
- SET STOP=$ORDER(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP),SDIR)
- if (STOP="")!(DONE)
- QUIT
- Begin DoDot:2
- +10 ;Items that do not have a stop date are flagged by "U".
- +11 SET SDATE=$SELECT(USESTRT:START,STOP["U":$$NOW^PXRMDATE_"U",1:STOP)
- +12 SET OVERLAP=$$OVERLAP(START,SDATE,BDT,EDT)
- +13 IF OVERLAP="O"
- Begin DoDot:3
- +14 SET DAS=$ORDER(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP,""))
- +15 SET NFOUND=NFOUND+1
- SET TLIST(SDATE,NFOUND)=DAS_U_SDATE
- End DoDot:3
- +16 ;Some orders and non-VA meds may not have a Stop Date so we have
- +17 ;to check all entries.
- +18 IF FILENUM="55NVA"
- QUIT
- +19 IF FILENUM=100
- QUIT
- +20 IF OVERLAP="L"
- IF SDIR=-1
- SET DONE=1
- QUIT
- +21 IF OVERLAP="R"
- IF SDIR=1
- SET DONE=1
- QUIT
- End DoDot:2
- End DoDot:1
- +22 ;Return up to NGET of the most recent/oldest entries.
- +23 SET NFOUND=0
- SET TDATE=""
- +24 FOR
- SET TDATE=$ORDER(TLIST(TDATE),SDIR)
- if (TDATE="")!(NFOUND=NGET)
- QUIT
- Begin DoDot:1
- +25 SET TIND=0
- +26 FOR
- SET TIND=$ORDER(TLIST(TDATE,TIND))
- if (TIND="")!(NFOUND=NGET)
- QUIT
- Begin DoDot:2
- +27 SET NFOUND=NFOUND+1
- SET FLIST(NFOUND)=TLIST(TDATE,TIND)
- End DoDot:2
- End DoDot:1
- +28 QUIT
- +29 ;
- +30 ;====================
- OVERLAP(START,STOP,BDT,EDT) ;Determine if the date range defined by START and
- +1 ;STOP overlaps with the date range defined by BDT and EDT. The return
- +2 ;value "O" means they overlap, "L" means START, STOP is to the
- +3 ;left of BDT, EDT and "R" means it is to the right.
- +4 IF EDT<START
- QUIT "R"
- +5 IF STOP<BDT
- QUIT "L"
- +6 QUIT "O"
- +7 ;
- +8 ;====================
- STATUSOK(STATUSA,FIEVD) ;Return true if the status in FIEVD matches one in
- +1 ;the list in STATUSA.
- +2 IF '$DATA(FIEVD("STATUS"))
- QUIT 1
- +3 NEW JND,OK
- +4 SET OK=0
- +5 FOR JND=1:1:STATUSA(0)
- if OK
- QUIT
- Begin DoDot:1
- +6 IF STATUSA(JND)="*"
- SET OK=1
- QUIT
- +7 IF STATUSA(JND)=FIEVD("STATUS")
- SET OK=1
- QUIT
- End DoDot:1
- +8 QUIT OK
- +9 ;