PXRMDGPT ; SLC/PKR - Code to handle DGPT (Patient Treatment File) data. ;10/11/2012
;;2.0;CLINICAL REMINDERS;**4,26**;Feb 04, 2005;Build 404
;
;============================================
FPDAT(DFN,TAXARR,NGET,SDIR,BDT,EDT,FLIST) ;Find data for a patient.
N CODE,CODESYS,DA,DAS,DATE,DNODE,DS,EDTT,IND
N NFOUND,NODE,NODEAT,NNODES,TDATE,TIND,TLIST
S NNODES=TAXARR("APDS",45,"NNODES")
I NNODES=0 Q
I $G(^PXRMINDX(45,"DATE BUILT"))="" D Q
. D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),45)
S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
S DS=$S(SDIR=+1:BDT-.000001,1:EDTT)
S CODESYS="",NFOUND=0
F S CODESYS=$O(TAXARR("AE",CODESYS)) Q:CODESYS="" D
. I '$D(^PXRMINDX(45,CODESYS,"PNI",DFN)) Q
. F IND=1:1:NNODES D
.. S NODE=TAXARR("APDS",45,IND)
.. I '$D(^PXRMINDX(45,CODESYS,"PNI",DFN,NODE)) Q
.. S CODE=""
.. F S CODE=$O(TAXARR("AE",CODESYS,CODE)) Q:CODE="" D
... I '$D(^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE)) Q
... S DATE=DS
... F S DATE=+$O(^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE),SDIR) Q:$S(DATE=0:1,DATE<BDT:1,DATE>EDTT:1,1:0) D
.... S DAS=""
.... F S DAS=$O(^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)) Q:DAS="" D
..... S NFOUND=NFOUND+1
..... S TLIST(DATE,NFOUND)=DAS_U_DATE_U_CODESYS_U_CODE_U_NODE
..... 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,45)=TLIST(DATE,IND)
Q
;
;============================================
GETDATA(DAS,FIEVT) ;Return data for a specificed PTF entry.
;DBIA #4457
D PTF^DGPTPXRM(DAS,.FIEVT)
Q
;
;============================================
GPLIST(TAXARR,NOCC,BDT,EDT,PLIST) ;Get data for a patient.
N CODE,CODESYS,DA,DA1,DAS,DATE,DFN,DNODE,DS
N NFOUND,NODE,NNODES,TEMP,TLIST
I $G(^PXRMINDX(45,"DATE BUILT"))="" D Q
. D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),45)
S TLIST="GPLIST_PXRMDGPT"
K ^TMP($J,TLIST)
S NNODES=TAXARR("APDS",45,"NNODES")
I NNODES=0 Q
S DS=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
S CODESYS=""
F S CODESYS=$O(TAXARR("AE",CODESYS)) Q:CODESYS="" D
. I '$D(^PXRMINDX(45,CODESYS,"INP")) Q
. S CODE=""
. F S CODE=$O(TAXARR("AE",CODESYS,CODE)) Q:CODE="" D
.. I '$D(^PXRMINDX(45,CODESYS,"INP",CODE)) Q
.. F IND=1:1:NNODES D
... S NODE=TAXARR("APDS",45,IND)
... I '$D(^PXRMINDX(45,CODESYS,"INP",CODE,NODE)) Q
... S DFN=0
... F S DFN=$O(^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN)) Q:DFN="" D
.... S DATE=DS
.... F S DATE=+$O(^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE),-1) Q:(DATE=0)!(DATE<BDT) D
..... S DAS=$O(^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,""))
..... S ^TMP($J,TLIST,DFN,DATE,DAS)=CODE_U_CODESYS_U_NODE
;Return up to NOCC of the most recent entries for each patient.
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,DATE,45)=DAS_U_DATE_U_TEMP
K ^TMP($J,TLIST)
Q
;
;============================================
MHVOUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
N CDATA,CODE,CODESYS,CODESYSA,CODESYSL,CODESYSN,DATE,IND,JND,NAME,NOUT
N RESULT,TEMP,TEXTIN,TEXTOUT
;Since the results may contain both diagnosis and procedures group
;them for display.
S IND=0
F S IND=$O(OCCLIST(IND)) Q:IND="" S CODESYSL(IFIEVAL(IND,"CODESYS"),IND)=""
S CODESYS=""
F S CODESYS=$O(CODESYSL(CODESYS)) Q:CODESYS="" D
.;DBIA #5679
. S TEMP=$$CSYS^LEXU(CODESYS)
. S CODESYSA=$P(TEMP,U,4)
. S CODESYSN=$$UP^XLFSTR($P(TEMP,U,5))
. S TEMP=$S(CODESYSN["PROCEDURE":"Procedure",CODESYSN["DIAGNOSIS":"Diagnosis",1:"Unknown")
. S NAME="Hospitalization "_TEMP
. S IND=""
. F S IND=$O(CODESYSL(CODESYS,IND)) Q:IND="" D
.. S CODE=IFIEVAL(IND,"CODE")
.. S DATE=IFIEVAL(IND,"DATE")
.. K CDATA
.. ;DBIA #5679
.. S RESULT=$$CSDATA^LEXU(CODE,CODESYS,DATE,.CDATA)
.. S TEXTIN(1)=NAME
.. S TEXTIN(2)=$P(CDATA("LEX",1),U,2)
.. S TEXTIN(3)=" ("_$$EDATE^PXRMDATE(DATE)_")"
.. D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,3,.TEXTIN,.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,CODESYS,CODESYSA,CODESYSL,CODESYSN,DATE,IND
N JND,NODE,NOUT,RESULT,TEMP,TEXTIN,TEXTOUT
;Since the results may contain both diagnosis and procedures group
;them for display.
S IND=0
F S IND=$O(OCCLIST(IND)) Q:IND="" S CODESYSL(IFIEVAL(IND,"CODESYS"),IND)=""
S CODESYS=""
F S CODESYS=$O(CODESYSL(CODESYS)) Q:CODESYS="" D
.;DBIA #5679
. S TEMP=$$CSYS^LEXU(CODESYS)
. S CODESYSA=$P(TEMP,U,4)
. S CODESYSN=$$UP^XLFSTR($P(TEMP,U,5))
. S TEMP=$S(CODESYSN["PROCEDURE":"Procedure",CODESYSN["DIAGNOSIS":"Diagnosis",1:"Unknown")
. S NLINES=NLINES+1
. S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Hospitalization "_TEMP
. S IND=""
. F S IND=$O(CODESYSL(CODESYS,IND)) Q:IND="" D
.. S CODE=IFIEVAL(IND,"CODE")
.. S DATE=IFIEVAL(IND,"DATE")
.. S NODE=IFIEVAL(IND,"NODE")
.. K CDATA
.. ;DBIA #5679
.. S RESULT=$$CSDATA^LEXU(CODE,CODESYS,DATE,.CDATA)
.. S TEXTIN(1)=$$EDATE^PXRMDATE(DATE)_" "_CODE_" ("_CODESYSA_")"
.. S TEXTIN(2)=$P(CDATA("LEX",1),U,2)_";"
.. S TEXTIN(3)="data node: "_NODE
.. I $G(IFIEVAL(IND,"FEE BASIS")) S TEXTIN(3)=TEXTIN(3)_"; (Fee)"
.. D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,3,.TEXTIN,.NOUT,.TEXTOUT)
.. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
S NLINES=NLINES+1,TEXT(NLINES)=""
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMDGPT 6010 printed Dec 13, 2024@01:43:45 Page 2
PXRMDGPT ; SLC/PKR - Code to handle DGPT (Patient Treatment File) data. ;10/11/2012
+1 ;;2.0;CLINICAL REMINDERS;**4,26**;Feb 04, 2005;Build 404
+2 ;
+3 ;============================================
FPDAT(DFN,TAXARR,NGET,SDIR,BDT,EDT,FLIST) ;Find data for a patient.
+1 NEW CODE,CODESYS,DA,DAS,DATE,DNODE,DS,EDTT,IND
+2 NEW NFOUND,NODE,NODEAT,NNODES,TDATE,TIND,TLIST
+3 SET NNODES=TAXARR("APDS",45,"NNODES")
+4 IF NNODES=0
QUIT
+5 IF $GET(^PXRMINDX(45,"DATE BUILT"))=""
Begin DoDot:1
+6 DO NOINDEX^PXRMERRH("TX",TAXARR("IEN"),45)
End DoDot:1
QUIT
+7 SET EDTT=$SELECT(EDT[".":EDT+.0000001,1:EDT+.240001)
+8 SET DS=$SELECT(SDIR=+1:BDT-.000001,1:EDTT)
+9 SET CODESYS=""
SET NFOUND=0
+10 FOR
SET CODESYS=$ORDER(TAXARR("AE",CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+11 IF '$DATA(^PXRMINDX(45,CODESYS,"PNI",DFN))
QUIT
+12 FOR IND=1:1:NNODES
Begin DoDot:2
+13 SET NODE=TAXARR("APDS",45,IND)
+14 IF '$DATA(^PXRMINDX(45,CODESYS,"PNI",DFN,NODE))
QUIT
+15 SET CODE=""
+16 FOR
SET CODE=$ORDER(TAXARR("AE",CODESYS,CODE))
if CODE=""
QUIT
Begin DoDot:3
+17 IF '$DATA(^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE))
QUIT
+18 SET DATE=DS
+19 FOR
SET DATE=+$ORDER(^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE),SDIR)
if $SELECT(DATE=0
QUIT
Begin DoDot:4
+20 SET DAS=""
+21 FOR
SET DAS=$ORDER(^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS))
if DAS=""
QUIT
Begin DoDot:5
+22 SET NFOUND=NFOUND+1
+23 SET TLIST(DATE,NFOUND)=DAS_U_DATE_U_CODESYS_U_CODE_U_NODE
+24 IF NFOUND>NGET
Begin DoDot:6
+25 SET TDATE=$ORDER(TLIST(""),-SDIR)
SET TIND=$ORDER(TLIST(TDATE,""))
+26 KILL TLIST(TDATE,TIND)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+27 ;
+28 ;Return up to NGET of the most recent entries.
+29 SET NFOUND=0
+30 SET DATE=""
+31 FOR
SET DATE=$ORDER(TLIST(DATE),SDIR)
if (DATE="")!(NFOUND=NGET)
QUIT
Begin DoDot:1
+32 SET IND=0
+33 FOR
SET IND=$ORDER(TLIST(DATE,IND))
if (IND="")!(NFOUND=NGET)
QUIT
Begin DoDot:2
+34 SET NFOUND=NFOUND+1
+35 SET FLIST(DATE,NFOUND,45)=TLIST(DATE,IND)
End DoDot:2
End DoDot:1
+36 QUIT
+37 ;
+38 ;============================================
GETDATA(DAS,FIEVT) ;Return data for a specificed PTF entry.
+1 ;DBIA #4457
+2 DO PTF^DGPTPXRM(DAS,.FIEVT)
+3 QUIT
+4 ;
+5 ;============================================
GPLIST(TAXARR,NOCC,BDT,EDT,PLIST) ;Get data for a patient.
+1 NEW CODE,CODESYS,DA,DA1,DAS,DATE,DFN,DNODE,DS
+2 NEW NFOUND,NODE,NNODES,TEMP,TLIST
+3 IF $GET(^PXRMINDX(45,"DATE BUILT"))=""
Begin DoDot:1
+4 DO NOINDEX^PXRMERRH("TX",TAXARR("IEN"),45)
End DoDot:1
QUIT
+5 SET TLIST="GPLIST_PXRMDGPT"
+6 KILL ^TMP($JOB,TLIST)
+7 SET NNODES=TAXARR("APDS",45,"NNODES")
+8 IF NNODES=0
QUIT
+9 SET DS=$SELECT(EDT[".":EDT+.0000001,1:EDT+.240001)
+10 SET CODESYS=""
+11 FOR
SET CODESYS=$ORDER(TAXARR("AE",CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+12 IF '$DATA(^PXRMINDX(45,CODESYS,"INP"))
QUIT
+13 SET CODE=""
+14 FOR
SET CODE=$ORDER(TAXARR("AE",CODESYS,CODE))
if CODE=""
QUIT
Begin DoDot:2
+15 IF '$DATA(^PXRMINDX(45,CODESYS,"INP",CODE))
QUIT
+16 FOR IND=1:1:NNODES
Begin DoDot:3
+17 SET NODE=TAXARR("APDS",45,IND)
+18 IF '$DATA(^PXRMINDX(45,CODESYS,"INP",CODE,NODE))
QUIT
+19 SET DFN=0
+20 FOR
SET DFN=$ORDER(^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN))
if DFN=""
QUIT
Begin DoDot:4
+21 SET DATE=DS
+22 FOR
SET DATE=+$ORDER(^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE),-1)
if (DATE=0)!(DATE<BDT)
QUIT
Begin DoDot:5
+23 SET DAS=$ORDER(^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,""))
+24 SET ^TMP($JOB,TLIST,DFN,DATE,DAS)=CODE_U_CODESYS_U_NODE
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+25 ;Return up to NOCC of the most recent entries for each patient.
+26 SET DFN=0
+27 FOR
SET DFN=$ORDER(^TMP($JOB,TLIST,DFN))
if DFN=""
QUIT
Begin DoDot:1
+28 SET NFOUND=0
+29 SET DATE=""
+30 FOR
SET DATE=$ORDER(^TMP($JOB,TLIST,DFN,DATE),-1)
if (DATE="")!(NFOUND=NOCC)
QUIT
Begin DoDot:2
+31 SET DAS=""
+32 FOR
SET DAS=$ORDER(^TMP($JOB,TLIST,DFN,DATE,DAS))
if DAS=""
QUIT
Begin DoDot:3
+33 SET NFOUND=NFOUND+1
+34 SET TEMP=^TMP($JOB,TLIST,DFN,DATE,DAS)
+35 SET ^TMP($JOB,PLIST,1,DFN,DATE,45)=DAS_U_DATE_U_TEMP
End DoDot:3
End DoDot:2
End DoDot:1
+36 KILL ^TMP($JOB,TLIST)
+37 QUIT
+38 ;
+39 ;============================================
MHVOUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+1 NEW CDATA,CODE,CODESYS,CODESYSA,CODESYSL,CODESYSN,DATE,IND,JND,NAME,NOUT
+2 NEW RESULT,TEMP,TEXTIN,TEXTOUT
+3 ;Since the results may contain both diagnosis and procedures group
+4 ;them for display.
+5 SET IND=0
+6 FOR
SET IND=$ORDER(OCCLIST(IND))
if IND=""
QUIT
SET CODESYSL(IFIEVAL(IND,"CODESYS"),IND)=""
+7 SET CODESYS=""
+8 FOR
SET CODESYS=$ORDER(CODESYSL(CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+9 ;DBIA #5679
+10 SET TEMP=$$CSYS^LEXU(CODESYS)
+11 SET CODESYSA=$PIECE(TEMP,U,4)
+12 SET CODESYSN=$$UP^XLFSTR($PIECE(TEMP,U,5))
+13 SET TEMP=$SELECT(CODESYSN["PROCEDURE":"Procedure",CODESYSN["DIAGNOSIS":"Diagnosis",1:"Unknown")
+14 SET NAME="Hospitalization "_TEMP
+15 SET IND=""
+16 FOR
SET IND=$ORDER(CODESYSL(CODESYS,IND))
if IND=""
QUIT
Begin DoDot:2
+17 SET CODE=IFIEVAL(IND,"CODE")
+18 SET DATE=IFIEVAL(IND,"DATE")
+19 KILL CDATA
+20 ;DBIA #5679
+21 SET RESULT=$$CSDATA^LEXU(CODE,CODESYS,DATE,.CDATA)
+22 SET TEXTIN(1)=NAME
+23 SET TEXTIN(2)=$PIECE(CDATA("LEX",1),U,2)
+24 SET TEXTIN(3)=" ("_$$EDATE^PXRMDATE(DATE)_")"
+25 DO FORMAT^PXRMTEXT(INDENT+2,PXRMRM,3,.TEXTIN,.NOUT,.TEXTOUT)
+26 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
End DoDot:2
End DoDot:1
+27 SET NLINES=NLINES+1
SET TEXT(NLINES)=""
+28 QUIT
+29 ;
+30 ;============================================
OUTPUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+1 ;maintenance output.
+2 NEW CDATA,CODE,CODESYS,CODESYSA,CODESYSL,CODESYSN,DATE,IND
+3 NEW JND,NODE,NOUT,RESULT,TEMP,TEXTIN,TEXTOUT
+4 ;Since the results may contain both diagnosis and procedures group
+5 ;them for display.
+6 SET IND=0
+7 FOR
SET IND=$ORDER(OCCLIST(IND))
if IND=""
QUIT
SET CODESYSL(IFIEVAL(IND,"CODESYS"),IND)=""
+8 SET CODESYS=""
+9 FOR
SET CODESYS=$ORDER(CODESYSL(CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+10 ;DBIA #5679
+11 SET TEMP=$$CSYS^LEXU(CODESYS)
+12 SET CODESYSA=$PIECE(TEMP,U,4)
+13 SET CODESYSN=$$UP^XLFSTR($PIECE(TEMP,U,5))
+14 SET TEMP=$SELECT(CODESYSN["PROCEDURE":"Procedure",CODESYSN["DIAGNOSIS":"Diagnosis",1:"Unknown")
+15 SET NLINES=NLINES+1
+16 SET TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Hospitalization "_TEMP
+17 SET IND=""
+18 FOR
SET IND=$ORDER(CODESYSL(CODESYS,IND))
if IND=""
QUIT
Begin DoDot:2
+19 SET CODE=IFIEVAL(IND,"CODE")
+20 SET DATE=IFIEVAL(IND,"DATE")
+21 SET NODE=IFIEVAL(IND,"NODE")
+22 KILL CDATA
+23 ;DBIA #5679
+24 SET RESULT=$$CSDATA^LEXU(CODE,CODESYS,DATE,.CDATA)
+25 SET TEXTIN(1)=$$EDATE^PXRMDATE(DATE)_" "_CODE_" ("_CODESYSA_")"
+26 SET TEXTIN(2)=$PIECE(CDATA("LEX",1),U,2)_";"
+27 SET TEXTIN(3)="data node: "_NODE
+28 IF $GET(IFIEVAL(IND,"FEE BASIS"))
SET TEXTIN(3)=TEXTIN(3)_"; (Fee)"
+29 DO FORMAT^PXRMTEXT(INDENT+2,PXRMRM,3,.TEXTIN,.NOUT,.TEXTOUT)
+30 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
End DoDot:2
End DoDot:1
+31 SET NLINES=NLINES+1
SET TEXT(NLINES)=""
+32 QUIT
+33 ;
