- PXRMPROB ; SLC/PKR - Code for Problem List. ;10/11/2012
- ;;2.0;CLINICAL REMINDERS;**4,26**;Feb 04, 2005;Build 404
- ;
- ;===================================================
- FPDAT(DFN,TAXARR,NGET,SDIR,BDT,EDT,STATUSA,FLIST) ;Find data for a
- ;patient.
- N CODE,CODESYS,DAS,DATE,DEND,DS,DSAVE,EDATE,EDTT,IND,JND,NFOUND
- N PRIO,PRIOA,STAT,TDATE,TIND,TLIST
- I TAXARR("APDS",9000011,"NNODES")=0 Q
- I $G(^PXRMINDX(9000011,"DATE BUILT"))="" D Q
- . D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),9000011)
- I STATUSA(0)=0 Q
- ;EDATE is the evaluation date.
- S EDATE=$$NOW^PXRMDATE
- S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
- S DEND=$S(EDT[".":EDT,1:EDT+.24)
- S DS=$S(SDIR=+1:BDT-.000001,1:EDTT)
- D SPRIOA(BDT,DEND,EDATE,.TAXARR,.PRIOA)
- S CODESYS=""
- F S CODESYS=$O(TAXARR("AE",CODESYS)) Q:CODESYS="" D
- . I '$D(^PXRMINDX(9000011,CODESYS,"PSPI",DFN)) Q
- . S NFOUND=0
- . F IND=1:1:STATUSA(0) S STAT=STATUSA(IND) D
- .. I '$D(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT)) Q
- .. F JND=1:1:PRIOA(0) S PRIO=PRIOA(JND) D
- ... I '$D(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO)) Q
- ... S CODE=""
- ... F S CODE=$O(TAXARR("AE",CODESYS,CODE)) Q:CODE="" D
- .... I '$D(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO,CODE)) Q
- .... S DATE=DS
- .... F S DATE=+$O(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO,CODE,DATE),SDIR) Q:$S(DATE=0:1,DATE<BDT:1,DATE>EDTT:1,1:0) D
- ..... S DSAVE=$S(PRIO="C":EDATE,1:DATE)
- ..... I (DSAVE<BDT)!(DSAVE>DEND) Q
- ..... S DAS=""
- ..... F S DAS=$O(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO,CODE,DATE,DAS)) Q:DAS="" D
- ...... S NFOUND=NFOUND+1
- ...... S TLIST(DSAVE,NFOUND)=DAS_U_DSAVE_U_CODESYS_U_CODE_U_STAT_U_PRIO
- ...... I NFOUND>NGET D
- ....... S TDATE=$O(TLIST(""),-SDIR),TIND=$O(TLIST(TDATE,""))
- ....... K TLIST(TDATE,TIND)
- ;Return up to NGET of the most recent entries.
- S NFOUND=0
- S DATE=""
- F S DATE=$O(TLIST(DATE),SDIR) Q:(DATE="")!(NFOUND=NGET) D
- . S IND=0
- . F S IND=$O(TLIST(DATE,IND)) Q:(IND="")!(NFOUND=NGET) D
- .. S NFOUND=NFOUND+1
- .. S FLIST(DATE,NFOUND,9000011)=TLIST(DATE,IND)
- Q
- ;
- ;===================================================
- GETDATA(DAS,FIEVT) ;Return data for a specified Problem List entry.
- N DATA
- ;DBIA #5881
- D PROBDATA^GMPLPXRM(DAS,.DATA)
- M FIEVT=DATA
- Q
- ;
- ;===================================================
- GPLIST(TAXARR,NOCC,BDT,EDT,STATUSA,PLIST) ;Build patient list for
- ;Problem List entries.
- N CODE,CODESYS,DAS,DATE,DEND,DFN,DSAVE,EDATE,IND,JND,NFOUND,PRIO,PRIOA
- N STAT,TEMP,TLIST
- I $G(^PXRMINDX(9000011,"DATE BUILT"))="" D Q
- . D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),9000011)
- S TLIST="GPLIST_PXRMPROB"
- S DEND=$S(EDT[".":EDT,1:EDT+.240001)
- K ^TMP($J,TLIST)
- I STATUSA(0)=0 Q
- ;EDATE is the evaluation date.
- S EDATE=$$NOW^PXRMDATE
- D SPRIOA(BDT,DEND,EDATE,.TAXARR,.PRIOA)
- S CODESYS="",NFOUND=0
- F S CODESYS=$O(TAXARR("AE",CODESYS)) Q:CODESYS="" D
- . I '$D(^PXRMINDX(9000011,CODESYS,"ISPP")) Q
- . S CODE=""
- . F S CODE=$O(TAXARR("AE",CODESYS,CODE)) Q:(CODE="") D
- .. I '$D(^PXRMINDX(9000011,CODESYS,"ISPP",CODE)) Q
- ..;Since chronic problems will have today's date find those first.
- .. F IND=1:1:STATUSA(0) D
- ... S STAT=STATUSA(IND)
- ... I '$D(^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STAT)) Q
- ... F JND=1:1:PRIOA(0) D
- .... S PRIO=PRIOA(JND)
- .... I '$D(^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STAT,PRIO)) Q
- .... S DFN=""
- .... F S DFN=$O(^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STAT,PRIO,DFN)) Q:DFN="" D
- ..... S DATE=""
- ..... F S DATE=$O(^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STAT,PRIO,DFN,DATE)) Q:DATE="" D
- ...... S DAS=""
- ...... F S DAS=$O(^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STAT,PRIO,DFN,DATE,DAS)) Q:DAS="" D
- ....... S NFOUND=NFOUND+1
- ....... S DSAVE=$S(PRIO="C":EDATE,1:DATE)
- ....... I DSAVE'<BDT,DSAVE'>DEND S ^TMP($J,TLIST,DFN,DSAVE,DAS)=CODE_U_CODESYS_U_STAT_U_PRIO
- ;Return up to NOCC of the most recent entries.
- S DFN=0
- F S DFN=$O(^TMP($J,TLIST,DFN)) Q:DFN="" D
- . S NFOUND=0
- . S DATE=""
- . F S DATE=$O(^TMP($J,TLIST,DFN,DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D
- .. S DAS=""
- .. F S DAS=$O(^TMP($J,TLIST,DFN,DATE,DAS)) Q:DAS="" D
- ... S NFOUND=NFOUND+1
- ... S TEMP=^TMP($J,TLIST,DFN,DATE,DAS)
- ... S ^TMP($J,PLIST,1,DFN,NFOUND,9000011)=DAS_U_DATE_U_TEMP
- K ^TMP($J,TLIST)
- Q
- ;
- ;===================================================
- MHVOUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
- N CDATA,CODE,CODESYS,IND,NAME,NOUT
- N RESULT,STATUS,TEMP,TEXTOUT,VDATE
- S NAME="Problem Diagnosis = "
- S IND=0
- F S IND=$O(OCCLIST(IND)) Q:IND="" D
- . S VDATE=IFIEVAL(IND,"DATE")
- . S CODE=IFIEVAL(IND,"CODE")
- . S CODESYS=IFIEVAL(IND,"CODESYS")
- . K CDATA
- .;DBIA #5679
- . S RESULT=$$CSDATA^LEXU(CODE,CODESYS,VDATE,.CDATA)
- . S TEMP=NAME_$P(CDATA("LEX",1),U,2)
- . S TEMP=TEMP_" ("_$$EDATE^PXRMDATE(VDATE)_")"
- . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
- . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
- S NLINES=NLINES+1,TEXT(NLINES)=""
- Q
- ;
- ;===================================================
- OUTPUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the clinical
- ;maintenance output.
- N CDATA,CODE,CODEDATE,CODESYS,CODESYSN,EM,IND,JND,NIN,NOUT,PN,PRIORITY
- N RESULT,STATUS,TEXTIN,TEXTOUT,VDATE
- S NLINES=NLINES+1
- S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Problem Diagnosis:"
- S IND=0
- F S IND=$O(OCCLIST(IND)) Q:IND="" D
- . S VDATE=IFIEVAL(IND,"DATE")
- . S CODE=IFIEVAL(IND,"CODE")
- . S CODESYS=IFIEVAL(IND,"CODESYS")
- . S CODEDATE=$G(IFIEVAL(IND,"MT CODE DATE"))
- . I CODEDATE="" S CODEDATE=$G(IFIEVAL(IND,"DATE OF INTEREST"))
- . I CODEDATE="" S CODEDATE=$G(IFIEVAL(IND,"DATE ENTERED"))
- .;DBIA #5679
- . I '$D(CODESYSN(CODESYS)) S CODESYSN(CODESYS)=$P($$CSYS^LEXU(CODESYS),U,4)
- . K CDATA
- . S RESULT=$$CSDATA^LEXU(CODE,CODESYS,CODEDATE,.CDATA)
- . S PRIORITY=$G(IFIEVAL(IND,"PRIORITY"))
- . S PRIORITY=$S(PRIORITY'="":$$EXTERNAL^DILFD(9000011,1.14,"",PRIORITY,.EM),1:"UNDEFINED")
- . S STATUS=$G(IFIEVAL(IND,"STATUS"))
- . S STATUS=$S(STATUS'="":$$EXTERNAL^DILFD(9000011,.12,"",STATUS,.EM),1:"UNDEFINED")
- . S PN=$G(IFIEVAL(IND,"PROVIDER NARRATIVE"))
- . S PN=$S(PN="":"MISSING",1:$P($G(^AUTNPOV(PN,0)),U,1))
- . S TEXTIN(1)=$$EDATE^PXRMDATE(VDATE)_" "_CODE_" ("_CODESYSN(CODESYS)_")"
- . S TEXTIN(2)=$P(CDATA("LEX",1),U,2)_"\\"
- . S TEXTIN(3)=" Date Entered: "_$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE ENTERED"))_"; Date Last Modified: "_$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE LAST MODIFIED"))_"\\"
- . S TEXTIN(4)=" Status: "_STATUS_"; Priority: "_PRIORITY_"\\"
- . S TEXTIN(5)=" Prov. Narr. - "_PN
- . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,5,.TEXTIN,.NOUT,.TEXTOUT)
- . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
- S NLINES=NLINES+1,TEXT(NLINES)=""
- Q
- ;
- ;===================================================
- SPRIOA(BDT,DEND,EDATE,TAXARR,PRIOA) ;Set the priority array.
- N NPRIO,PRIOL
- S PRIOL=$P(TAXARR(15),U,1)
- I PRIOL="" S PRIOA(0)=3,PRIOA(1)="A",PRIOA(2)="U",PRIOA(3)="C" Q
- S NPRIO=0
- I PRIOL["A" S NPRIO=NPRIO+1,PRIOA(NPRIO)="A"
- I PRIOL["U" S NPRIO=NPRIO+1,PRIOA(NPRIO)="U"
- ;For chronic problems the evaluation date becomes the finding date
- ;so only search for chronic problems if the evaluation date lies in
- ;the date range.
- I PRIOL["C",EDATE'<BDT,EDATE'>DEND S NPRIO=NPRIO+1,PRIOA(NPRIO)="C"
- S PRIOA(0)=NPRIO
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMPROB 7357 printed Jan 18, 2025@02:49:51 Page 2
- PXRMPROB ; SLC/PKR - Code for Problem List. ;10/11/2012
- +1 ;;2.0;CLINICAL REMINDERS;**4,26**;Feb 04, 2005;Build 404
- +2 ;
- +3 ;===================================================
- FPDAT(DFN,TAXARR,NGET,SDIR,BDT,EDT,STATUSA,FLIST) ;Find data for a
- +1 ;patient.
- +2 NEW CODE,CODESYS,DAS,DATE,DEND,DS,DSAVE,EDATE,EDTT,IND,JND,NFOUND
- +3 NEW PRIO,PRIOA,STAT,TDATE,TIND,TLIST
- +4 IF TAXARR("APDS",9000011,"NNODES")=0
- QUIT
- +5 IF $GET(^PXRMINDX(9000011,"DATE BUILT"))=""
- Begin DoDot:1
- +6 DO NOINDEX^PXRMERRH("TX",TAXARR("IEN"),9000011)
- End DoDot:1
- QUIT
- +7 IF STATUSA(0)=0
- QUIT
- +8 ;EDATE is the evaluation date.
- +9 SET EDATE=$$NOW^PXRMDATE
- +10 SET EDTT=$SELECT(EDT[".":EDT+.0000001,1:EDT+.240001)
- +11 SET DEND=$SELECT(EDT[".":EDT,1:EDT+.24)
- +12 SET DS=$SELECT(SDIR=+1:BDT-.000001,1:EDTT)
- +13 DO SPRIOA(BDT,DEND,EDATE,.TAXARR,.PRIOA)
- +14 SET CODESYS=""
- +15 FOR
- SET CODESYS=$ORDER(TAXARR("AE",CODESYS))
- if CODESYS=""
- QUIT
- Begin DoDot:1
- +16 IF '$DATA(^PXRMINDX(9000011,CODESYS,"PSPI",DFN))
- QUIT
- +17 SET NFOUND=0
- +18 FOR IND=1:1:STATUSA(0)
- SET STAT=STATUSA(IND)
- Begin DoDot:2
- +19 IF '$DATA(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT))
- QUIT
- +20 FOR JND=1:1:PRIOA(0)
- SET PRIO=PRIOA(JND)
- Begin DoDot:3
- +21 IF '$DATA(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO))
- QUIT
- +22 SET CODE=""
- +23 FOR
- SET CODE=$ORDER(TAXARR("AE",CODESYS,CODE))
- if CODE=""
- QUIT
- Begin DoDot:4
- +24 IF '$DATA(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO,CODE))
- QUIT
- +25 SET DATE=DS
- +26 FOR
- SET DATE=+$ORDER(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO,CODE,DATE),SDIR)
- if $SELECT(DATE=0
- QUIT
- Begin DoDot:5
- +27 SET DSAVE=$SELECT(PRIO="C":EDATE,1:DATE)
- +28 IF (DSAVE<BDT)!(DSAVE>DEND)
- QUIT
- +29 SET DAS=""
- +30 FOR
- SET DAS=$ORDER(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO,CODE,DATE,DAS))
- if DAS=""
- QUIT
- Begin DoDot:6
- +31 SET NFOUND=NFOUND+1
- +32 SET TLIST(DSAVE,NFOUND)=DAS_U_DSAVE_U_CODESYS_U_CODE_U_STAT_U_PRIO
- +33 IF NFOUND>NGET
- Begin DoDot:7
- +34 SET TDATE=$ORDER(TLIST(""),-SDIR)
- SET TIND=$ORDER(TLIST(TDATE,""))
- +35 KILL TLIST(TDATE,TIND)
- End DoDot:7
- End DoDot:6
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +36 ;Return up to NGET of the most recent entries.
- +37 SET NFOUND=0
- +38 SET DATE=""
- +39 FOR
- SET DATE=$ORDER(TLIST(DATE),SDIR)
- if (DATE="")!(NFOUND=NGET)
- QUIT
- Begin DoDot:1
- +40 SET IND=0
- +41 FOR
- SET IND=$ORDER(TLIST(DATE,IND))
- if (IND="")!(NFOUND=NGET)
- QUIT
- Begin DoDot:2
- +42 SET NFOUND=NFOUND+1
- +43 SET FLIST(DATE,NFOUND,9000011)=TLIST(DATE,IND)
- End DoDot:2
- End DoDot:1
- +44 QUIT
- +45 ;
- +46 ;===================================================
- GETDATA(DAS,FIEVT) ;Return data for a specified Problem List entry.
- +1 NEW DATA
- +2 ;DBIA #5881
- +3 DO PROBDATA^GMPLPXRM(DAS,.DATA)
- +4 MERGE FIEVT=DATA
- +5 QUIT
- +6 ;
- +7 ;===================================================
- GPLIST(TAXARR,NOCC,BDT,EDT,STATUSA,PLIST) ;Build patient list for
- +1 ;Problem List entries.
- +2 NEW CODE,CODESYS,DAS,DATE,DEND,DFN,DSAVE,EDATE,IND,JND,NFOUND,PRIO,PRIOA
- +3 NEW STAT,TEMP,TLIST
- +4 IF $GET(^PXRMINDX(9000011,"DATE BUILT"))=""
- Begin DoDot:1
- +5 DO NOINDEX^PXRMERRH("TX",TAXARR("IEN"),9000011)
- End DoDot:1
- QUIT
- +6 SET TLIST="GPLIST_PXRMPROB"
- +7 SET DEND=$SELECT(EDT[".":EDT,1:EDT+.240001)
- +8 KILL ^TMP($JOB,TLIST)
- +9 IF STATUSA(0)=0
- QUIT
- +10 ;EDATE is the evaluation date.
- +11 SET EDATE=$$NOW^PXRMDATE
- +12 DO SPRIOA(BDT,DEND,EDATE,.TAXARR,.PRIOA)
- +13 SET CODESYS=""
- SET NFOUND=0
- +14 FOR
- SET CODESYS=$ORDER(TAXARR("AE",CODESYS))
- if CODESYS=""
- QUIT
- Begin DoDot:1
- +15 IF '$DATA(^PXRMINDX(9000011,CODESYS,"ISPP"))
- QUIT
- +16 SET CODE=""
- +17 FOR
- SET CODE=$ORDER(TAXARR("AE",CODESYS,CODE))
- if (CODE="")
- QUIT
- Begin DoDot:2
- +18 IF '$DATA(^PXRMINDX(9000011,CODESYS,"ISPP",CODE))
- QUIT
- +19 ;Since chronic problems will have today's date find those first.
- +20 FOR IND=1:1:STATUSA(0)
- Begin DoDot:3
- +21 SET STAT=STATUSA(IND)
- +22 IF '$DATA(^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STAT))
- QUIT
- +23 FOR JND=1:1:PRIOA(0)
- Begin DoDot:4
- +24 SET PRIO=PRIOA(JND)
- +25 IF '$DATA(^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STAT,PRIO))
- QUIT
- +26 SET DFN=""
- +27 FOR
- SET DFN=$ORDER(^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STAT,PRIO,DFN))
- if DFN=""
- QUIT
- Begin DoDot:5
- +28 SET DATE=""
- +29 FOR
- SET DATE=$ORDER(^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STAT,PRIO,DFN,DATE))
- if DATE=""
- QUIT
- Begin DoDot:6
- +30 SET DAS=""
- +31 FOR
- SET DAS=$ORDER(^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STAT,PRIO,DFN,DATE,DAS))
- if DAS=""
- QUIT
- Begin DoDot:7
- +32 SET NFOUND=NFOUND+1
- +33 SET DSAVE=$SELECT(PRIO="C":EDATE,1:DATE)
- +34 IF DSAVE'<BDT
- IF DSAVE'>DEND
- SET ^TMP($JOB,TLIST,DFN,DSAVE,DAS)=CODE_U_CODESYS_U_STAT_U_PRIO
- End DoDot:7
- End DoDot:6
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +35 ;Return up to NOCC of the most recent entries.
- +36 SET DFN=0
- +37 FOR
- SET DFN=$ORDER(^TMP($JOB,TLIST,DFN))
- if DFN=""
- QUIT
- Begin DoDot:1
- +38 SET NFOUND=0
- +39 SET DATE=""
- +40 FOR
- SET DATE=$ORDER(^TMP($JOB,TLIST,DFN,DATE),-1)
- if (DATE="")!(NFOUND=NOCC)
- QUIT
- Begin DoDot:2
- +41 SET DAS=""
- +42 FOR
- SET DAS=$ORDER(^TMP($JOB,TLIST,DFN,DATE,DAS))
- if DAS=""
- QUIT
- Begin DoDot:3
- +43 SET NFOUND=NFOUND+1
- +44 SET TEMP=^TMP($JOB,TLIST,DFN,DATE,DAS)
- +45 SET ^TMP($JOB,PLIST,1,DFN,NFOUND,9000011)=DAS_U_DATE_U_TEMP
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +46 KILL ^TMP($JOB,TLIST)
- +47 QUIT
- +48 ;
- +49 ;===================================================
- MHVOUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
- +1 NEW CDATA,CODE,CODESYS,IND,NAME,NOUT
- +2 NEW RESULT,STATUS,TEMP,TEXTOUT,VDATE
- +3 SET NAME="Problem Diagnosis = "
- +4 SET IND=0
- +5 FOR
- SET IND=$ORDER(OCCLIST(IND))
- if IND=""
- QUIT
- Begin DoDot:1
- +6 SET VDATE=IFIEVAL(IND,"DATE")
- +7 SET CODE=IFIEVAL(IND,"CODE")
- +8 SET CODESYS=IFIEVAL(IND,"CODESYS")
- +9 KILL CDATA
- +10 ;DBIA #5679
- +11 SET RESULT=$$CSDATA^LEXU(CODE,CODESYS,VDATE,.CDATA)
- +12 SET TEMP=NAME_$PIECE(CDATA("LEX",1),U,2)
- +13 SET TEMP=TEMP_" ("_$$EDATE^PXRMDATE(VDATE)_")"
- +14 DO FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
- +15 FOR JND=1:1:NOUT
- SET NLINES=NLINES+1
- SET TEXT(NLINES)=TEXTOUT(JND)
- End DoDot:1
- +16 SET NLINES=NLINES+1
- SET TEXT(NLINES)=""
- +17 QUIT
- +18 ;
- +19 ;===================================================
- OUTPUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the clinical
- +1 ;maintenance output.
- +2 NEW CDATA,CODE,CODEDATE,CODESYS,CODESYSN,EM,IND,JND,NIN,NOUT,PN,PRIORITY
- +3 NEW RESULT,STATUS,TEXTIN,TEXTOUT,VDATE
- +4 SET NLINES=NLINES+1
- +5 SET TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Problem Diagnosis:"
- +6 SET IND=0
- +7 FOR
- SET IND=$ORDER(OCCLIST(IND))
- if IND=""
- QUIT
- Begin DoDot:1
- +8 SET VDATE=IFIEVAL(IND,"DATE")
- +9 SET CODE=IFIEVAL(IND,"CODE")
- +10 SET CODESYS=IFIEVAL(IND,"CODESYS")
- +11 SET CODEDATE=$GET(IFIEVAL(IND,"MT CODE DATE"))
- +12 IF CODEDATE=""
- SET CODEDATE=$GET(IFIEVAL(IND,"DATE OF INTEREST"))
- +13 IF CODEDATE=""
- SET CODEDATE=$GET(IFIEVAL(IND,"DATE ENTERED"))
- +14 ;DBIA #5679
- +15 IF '$DATA(CODESYSN(CODESYS))
- SET CODESYSN(CODESYS)=$PIECE($$CSYS^LEXU(CODESYS),U,4)
- +16 KILL CDATA
- +17 SET RESULT=$$CSDATA^LEXU(CODE,CODESYS,CODEDATE,.CDATA)
- +18 SET PRIORITY=$GET(IFIEVAL(IND,"PRIORITY"))
- +19 SET PRIORITY=$SELECT(PRIORITY'="":$$EXTERNAL^DILFD(9000011,1.14,"",PRIORITY,.EM),1:"UNDEFINED")
- +20 SET STATUS=$GET(IFIEVAL(IND,"STATUS"))
- +21 SET STATUS=$SELECT(STATUS'="":$$EXTERNAL^DILFD(9000011,.12,"",STATUS,.EM),1:"UNDEFINED")
- +22 SET PN=$GET(IFIEVAL(IND,"PROVIDER NARRATIVE"))
- +23 SET PN=$SELECT(PN="":"MISSING",1:$PIECE($GET(^AUTNPOV(PN,0)),U,1))
- +24 SET TEXTIN(1)=$$EDATE^PXRMDATE(VDATE)_" "_CODE_" ("_CODESYSN(CODESYS)_")"
- +25 SET TEXTIN(2)=$PIECE(CDATA("LEX",1),U,2)_"\\"
- +26 SET TEXTIN(3)=" Date Entered: "_$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE ENTERED"))_"; Date Last Modified: "_$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE LAST MODIFIED"))_"\\"
- +27 SET TEXTIN(4)=" Status: "_STATUS_"; Priority: "_PRIORITY_"\\"
- +28 SET TEXTIN(5)=" Prov. Narr. - "_PN
- +29 DO FORMAT^PXRMTEXT(INDENT+2,PXRMRM,5,.TEXTIN,.NOUT,.TEXTOUT)
- +30 FOR JND=1:1:NOUT
- SET NLINES=NLINES+1
- SET TEXT(NLINES)=TEXTOUT(JND)
- End DoDot:1
- +31 SET NLINES=NLINES+1
- SET TEXT(NLINES)=""
- +32 QUIT
- +33 ;
- +34 ;===================================================
- SPRIOA(BDT,DEND,EDATE,TAXARR,PRIOA) ;Set the priority array.
- +1 NEW NPRIO,PRIOL
- +2 SET PRIOL=$PIECE(TAXARR(15),U,1)
- +3 IF PRIOL=""
- SET PRIOA(0)=3
- SET PRIOA(1)="A"
- SET PRIOA(2)="U"
- SET PRIOA(3)="C"
- QUIT
- +4 SET NPRIO=0
- +5 IF PRIOL["A"
- SET NPRIO=NPRIO+1
- SET PRIOA(NPRIO)="A"
- +6 IF PRIOL["U"
- SET NPRIO=NPRIO+1
- SET PRIOA(NPRIO)="U"
- +7 ;For chronic problems the evaluation date becomes the finding date
- +8 ;so only search for chronic problems if the evaluation date lies in
- +9 ;the date range.
- +10 IF PRIOL["C"
- IF EDATE'<BDT
- IF EDATE'>DEND
- SET NPRIO=NPRIO+1
- SET PRIOA(NPRIO)="C"
- +11 SET PRIOA(0)=NPRIO
- +12 QUIT
- +13 ;