- 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 Feb 18, 2025@23:12:33 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 ;