PXRMPROB ; SLC/PKR - Code for Problem List. ;12-Aug-2015 10:13;du
;;2.0;CLINICAL REMINDERS;**4,1001,26,1005**;Feb 04, 2005;Build 23
;IHS/MSC/MGH Patch 1001 do not include deleted problems
;
;===================================================
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
.. Q:STAT="D" ;IHS/MSC/MGH
.. 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_"\\"
. ;Get the new provider narrative IHS/MSC/MGH 1005
. I PN["|" D ; no vertical equals no snomed desc id
. . NEW SDI,SDIT,SNTXT
. . S SDI=$P(PN,"|",2) ;snomed descriptive id is in piece 2
. . S SDIT=$P($$DESC^BSTSAPI(SDI_"^^1"),U,2)
. . I SDIT="" S SNTXT="*"_$P(PN,"|",1)
. . E S SNTXT=SDIT_" | "_$P(PN,"|",1)
. . S TEXTIN(5)=" Prov. Narr. - "_SNTXT
. E 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
;
PXRMPROB ; SLC/PKR - Code for Problem List. ;12-Aug-2015 10:13;du
+1 ;;2.0;CLINICAL REMINDERS;**4,1001,26,1005**;Feb 04, 2005;Build 23
+2 ;IHS/MSC/MGH Patch 1001 do not include deleted problems
+3 ;
+4 ;===================================================
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 ;IHS/MSC/MGH
IF STAT="D"
QUIT
+20 IF '$DATA(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT))
QUIT
+21 FOR JND=1:1:PRIOA(0)
SET PRIO=PRIOA(JND)
Begin DoDot:3
+22 IF '$DATA(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO))
QUIT
+23 SET CODE=""
+24 FOR
SET CODE=$ORDER(TAXARR("AE",CODESYS,CODE))
IF CODE=""
QUIT
Begin DoDot:4
+25 IF '$DATA(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO,CODE))
QUIT
+26 SET DATE=DS
+27 FOR
SET DATE=+$ORDER(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO,CODE,DATE),SDIR)
IF $SELECT(DATE=0
QUIT
Begin DoDot:5
+28 SET DSAVE=$SELECT(PRIO="C":EDATE,1:DATE)
+29 IF (DSAVE<BDT)!(DSAVE>DEND)
QUIT
+30 SET DAS=""
+31 FOR
SET DAS=$ORDER(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO,CODE,DATE,DAS))
IF DAS=""
QUIT
Begin DoDot:6
+32 SET NFOUND=NFOUND+1
+33 SET TLIST(DSAVE,NFOUND)=DAS_U_DSAVE_U_CODESYS_U_CODE_U_STAT_U_PRIO
+34 IF NFOUND>NGET
Begin DoDot:7
+35 SET TDATE=$ORDER(TLIST(""),-SDIR)
SET TIND=$ORDER(TLIST(TDATE,""))
+36 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
+37 ;Return up to NGET of the most recent entries.
+38 SET NFOUND=0
+39 SET DATE=""
+40 FOR
SET DATE=$ORDER(TLIST(DATE),SDIR)
IF (DATE="")!(NFOUND=NGET)
QUIT
Begin DoDot:1
+41 SET IND=0
+42 FOR
SET IND=$ORDER(TLIST(DATE,IND))
IF (IND="")!(NFOUND=NGET)
QUIT
Begin DoDot:2
+43 SET NFOUND=NFOUND+1
+44 SET FLIST(DATE,NFOUND,9000011)=TLIST(DATE,IND)
End DoDot:2
End DoDot:1
+45 QUIT
+46 ;
+47 ;===================================================
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 ;Get the new provider narrative IHS/MSC/MGH 1005
+29 ; no vertical equals no snomed desc id
IF PN["|"
Begin DoDot:2
+30 NEW SDI,SDIT,SNTXT
+31 ;snomed descriptive id is in piece 2
SET SDI=$PIECE(PN,"|",2)
+32 SET SDIT=$PIECE($$DESC^BSTSAPI(SDI_"^^1"),U,2)
+33 IF SDIT=""
SET SNTXT="*"_$PIECE(PN,"|",1)
+34 IF '$TEST
SET SNTXT=SDIT_" | "_$PIECE(PN,"|",1)
+35 SET TEXTIN(5)=" Prov. Narr. - "_SNTXT
End DoDot:2
+36 IF '$TEST
SET TEXTIN(5)=" Prov. Narr. -"_PN
+37 DO FORMAT^PXRMTEXT(INDENT+2,PXRMRM,5,.TEXTIN,.NOUT,.TEXTOUT)
+38 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
End DoDot:1
+39 SET NLINES=NLINES+1
SET TEXT(NLINES)=""
+40 QUIT
+41 ;
+42 ;===================================================
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 ;
