PXRMRCPT ; SLC/PKR - Code to handle radiology CPT data. ;12/19/2012
;;2.0;CLINICAL REMINDERS;**4,12,26**;Feb 04, 2005;Build 404
;
;==============================================
FPDAT(DFN,TAXARR,NOCC,BDT,EDT,STATUSA,FLIST) ;Find radiology procedures for a
;patient from the linkage of a radiology procedure to a CPT4 code.
N CPT4P,CODE,DATE,FIEVT,IND,NOCCABS,NFOUND,PFINDPA
N RADIEN,SDIR,TE,TDATE,TIND,TF,TLIST
I TAXARR("APDS",71,"NNODES")=0 Q
I $G(^PXRMINDX(70,"DATE BUILT"))="" D Q
. D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),70)
I '$D(^PXRMINDX(70,"PI",DFN)) Q
S $P(PFINDPA(0),U,8)=BDT
S $P(PFINDPA(0),U,11)=EDT
S $P(PFINDPA(0),U,14)=NOCC
S SDIR=$S(NOCC<0:+1,1:-1)
F IND=1:1:STATUSA(0) S PFINDPA(5,IND)=STATUSA(IND)
S NFOUND=0,CPT4P=""
F S CPT4P=$O(TAXARR("AE","CPT",CPT4P)) Q:CPT4P="" D
. S RADIEN=""
.;DBIA #586
. F S RADIEN=$O(^RAMIS(71,"D",CPT4P,RADIEN)) Q:RADIEN="" D
.. I '$D(^PXRMINDX(70,"PI",DFN,RADIEN)) Q
.. K FIEVT
.. D FIEVAL^PXRMINDX(70,"PI",DFN,RADIEN,.PFINDPA,.FIEVT)
.. I FIEVT D
...;DBIA #1995
... S CODE=$P($$CPT^ICPTCOD(CPT4P),U,2)
... S IND=0
... F S IND=+$O(FIEVT(IND)) Q:IND=0 D
.... S NFOUND=NFOUND+1
.... S TLIST(FIEVT(IND,"DATE"),NFOUND)=FIEVT(IND,"DAS")_U_FIEVT(IND,"DATE")_U_"CPT4"_U_CODE_U_U_RADIEN
.... I NFOUND>NGET D
..... S TDATE=$O(TLIST(""),-SDIR),TIND=$O(TLIST(TDATE,""))
..... K TLIST(TDATE,TIND)
;Return up to NOCC of the most recent entries.
S NOCCABS=$S(NOCC<0:-NOCC,1:NOCC)
S NFOUND=0
S DATE=""
F S DATE=$O(TLIST(DATE),SDIR) Q:(DATE="")!(NFOUND=NOCCABS) D
. S IND=0
. F S IND=$O(TLIST(DATE,IND)) Q:(IND="")!(NFOUND=NOCCABS) D
.. S NFOUND=NFOUND+1
.. S FLIST(DATE,NFOUND,70)=TLIST(DATE,IND)
Q
;
;==============================================
GPLIST(TAXARR,PFINDPA,PLIST) ;Build a patient list for radiology procedures
;based on the linkage to CPT4 codes.
N CPT4P,DAS,DATE,DFN,NFOUND
N RADIEN,TEMP,TF,TLIST,VALUE
I TAXARR("APDS",71,"NNODES")=0 Q
I $G(^PXRMINDX(70,"DATE BUILT"))="" D Q
. D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),70)
S TLIST="GPLIST_PXRMRCPT"
S CPT4P=""
F S CPT4P=$O(TAXARR("AE","CPT",CPT4P)) Q:CPT4P="" D
. S RADIEN=""
.;DBIA #586
. F S RADIEN=$O(^RAMIS(71,"D",CPT4P,RADIEN)) Q:RADIEN="" D
.. I '$D(^PXRMINDX(70,"IP",RADIEN)) Q
.. S CPT4P=TAXARR("AE","RADPROC",RADIEN)
.. K ^TMP($J,TLIST)
.. D GPLIST^PXRMINDL(70,"IP",RADIEN,.PFINDPA,TLIST)
.. F TF=0,1 D
... S DFN=0
... F S DFN=$O(^TMP($J,TLIST,TF,DFN)) Q:DFN="" D
.... S NFOUND=0
.... F S NFOUND=$O(^TMP($J,TLIST,TF,DFN,RADIEN,NFOUND)) Q:NFOUND="" D
..... S TEMP=^TMP($J,TLIST,TF,DFN,RADIEN,NFOUND,70)
..... S DAS=$P(TEMP,U,1)
..... S DATE=$P(TEMP,U,2)
..... S VALUE=$P(TEMP,U,4)
..... S ^TMP($J,PLIST,TF,DFN,DATE,70)=DAS_U_DATE_U_CPT4P_U_"CPT"_U_VALUE
K ^TMP($J,TLIST)
Q
;
;==============================================
MHVOUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
N CODE,CDATA,DATE,ICPTP,IND,JND,NAME,NOUT,RESULT,TEXTIN,TEXTOUT
S NAME="Radiology Procedure = "
S IND=0
F S IND=$O(OCCLIST(IND)) Q:IND="" D
. S CODE=IFIEVAL(IND,"CODE")
. S CODESYS=IFIEVAL(IND,"CODESYS")
.;DBIA #5679
. I '$D(CODESYSN(CODESYS)) S CODESYSN(CODESYS)=$P($$CSYS^LEXU(CODESYS),U,4)
. S DATE=IFIEVAL(IND,"DATE")
. K CDATA
.;DBIA #5679
. S RESULT=$$CSDATA^LEXU(CODE,CODESYS,DATE,.CDATA)
. S DATE=IFIEVAL(IND,"DATE")
. S TEXTIN(1)=NAME_" "_IFIEVAL(IND,"PROCEDURE")_"\\"
. S TEXTIN(2)=$P(CDATA("LEX",1),U,2)_" ("_$$EDATE^PXRMDATE(DATE)_")"
. D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,2,.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,CODESYSN,DATE,IND,JND,NOUT,RESULT
N TAXIEN,TEMP,TEXTIN,TEXTOUT
S TEMP=IFIEVAL("FINDING")
S TAXIEN=$P(TEMP,";",1)
S TEMP="Radiology Procedure(s) from taxonomy "_$P(^PXD(811.2,TAXIEN,0),U,1)
S NLINES=NLINES+1
S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_TEMP
S IND=0
F S IND=$O(OCCLIST(IND)) Q:IND="" D
. S CODE=IFIEVAL(IND,"CODE")
. S CODESYS=IFIEVAL(IND,"CODESYS")
.;DBIA #5679
. I '$D(CODESYSN(CODESYS)) S CODESYSN(CODESYS)=$P($$CSYS^LEXU(CODESYS),U,4)
. S DATE=IFIEVAL(IND,"DATE")
. K CDATA
.;DBIA #5679
. S RESULT=$$CSDATA^LEXU(CODE,CODESYS,DATE,.CDATA)
. S TEXTIN(1)=$$EDATE^PXRMDATE(DATE)_" "_IFIEVAL(IND,"PROCEDURE")_"\\"
. S TEXTIN(2)=CODESYSN(CODESYS)_": "_CODE_" - "_$P(CDATA("LEX",1),U,2)_"\\"
. S TEXTIN(3)="Status: "_IFIEVAL(IND,"STATUS")
. S TEXTIN(4)="; Report Status: "_IFIEVAL(IND,"RPT STATUS")
. D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,4,.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[HPXRMRCPT 4904 printed Oct 16, 2024@17:49:35 Page 2
PXRMRCPT ; SLC/PKR - Code to handle radiology CPT data. ;12/19/2012
+1 ;;2.0;CLINICAL REMINDERS;**4,12,26**;Feb 04, 2005;Build 404
+2 ;
+3 ;==============================================
FPDAT(DFN,TAXARR,NOCC,BDT,EDT,STATUSA,FLIST) ;Find radiology procedures for a
+1 ;patient from the linkage of a radiology procedure to a CPT4 code.
+2 NEW CPT4P,CODE,DATE,FIEVT,IND,NOCCABS,NFOUND,PFINDPA
+3 NEW RADIEN,SDIR,TE,TDATE,TIND,TF,TLIST
+4 IF TAXARR("APDS",71,"NNODES")=0
QUIT
+5 IF $GET(^PXRMINDX(70,"DATE BUILT"))=""
Begin DoDot:1
+6 DO NOINDEX^PXRMERRH("TX",TAXARR("IEN"),70)
End DoDot:1
QUIT
+7 IF '$DATA(^PXRMINDX(70,"PI",DFN))
QUIT
+8 SET $PIECE(PFINDPA(0),U,8)=BDT
+9 SET $PIECE(PFINDPA(0),U,11)=EDT
+10 SET $PIECE(PFINDPA(0),U,14)=NOCC
+11 SET SDIR=$SELECT(NOCC<0:+1,1:-1)
+12 FOR IND=1:1:STATUSA(0)
SET PFINDPA(5,IND)=STATUSA(IND)
+13 SET NFOUND=0
SET CPT4P=""
+14 FOR
SET CPT4P=$ORDER(TAXARR("AE","CPT",CPT4P))
if CPT4P=""
QUIT
Begin DoDot:1
+15 SET RADIEN=""
+16 ;DBIA #586
+17 FOR
SET RADIEN=$ORDER(^RAMIS(71,"D",CPT4P,RADIEN))
if RADIEN=""
QUIT
Begin DoDot:2
+18 IF '$DATA(^PXRMINDX(70,"PI",DFN,RADIEN))
QUIT
+19 KILL FIEVT
+20 DO FIEVAL^PXRMINDX(70,"PI",DFN,RADIEN,.PFINDPA,.FIEVT)
+21 IF FIEVT
Begin DoDot:3
+22 ;DBIA #1995
+23 SET CODE=$PIECE($$CPT^ICPTCOD(CPT4P),U,2)
+24 SET IND=0
+25 FOR
SET IND=+$ORDER(FIEVT(IND))
if IND=0
QUIT
Begin DoDot:4
+26 SET NFOUND=NFOUND+1
+27 SET TLIST(FIEVT(IND,"DATE"),NFOUND)=FIEVT(IND,"DAS")_U_FIEVT(IND,"DATE")_U_"CPT4"_U_CODE_U_U_RADIEN
+28 IF NFOUND>NGET
Begin DoDot:5
+29 SET TDATE=$ORDER(TLIST(""),-SDIR)
SET TIND=$ORDER(TLIST(TDATE,""))
+30 KILL TLIST(TDATE,TIND)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+31 ;Return up to NOCC of the most recent entries.
+32 SET NOCCABS=$SELECT(NOCC<0:-NOCC,1:NOCC)
+33 SET NFOUND=0
+34 SET DATE=""
+35 FOR
SET DATE=$ORDER(TLIST(DATE),SDIR)
if (DATE="")!(NFOUND=NOCCABS)
QUIT
Begin DoDot:1
+36 SET IND=0
+37 FOR
SET IND=$ORDER(TLIST(DATE,IND))
if (IND="")!(NFOUND=NOCCABS)
QUIT
Begin DoDot:2
+38 SET NFOUND=NFOUND+1
+39 SET FLIST(DATE,NFOUND,70)=TLIST(DATE,IND)
End DoDot:2
End DoDot:1
+40 QUIT
+41 ;
+42 ;==============================================
GPLIST(TAXARR,PFINDPA,PLIST) ;Build a patient list for radiology procedures
+1 ;based on the linkage to CPT4 codes.
+2 NEW CPT4P,DAS,DATE,DFN,NFOUND
+3 NEW RADIEN,TEMP,TF,TLIST,VALUE
+4 IF TAXARR("APDS",71,"NNODES")=0
QUIT
+5 IF $GET(^PXRMINDX(70,"DATE BUILT"))=""
Begin DoDot:1
+6 DO NOINDEX^PXRMERRH("TX",TAXARR("IEN"),70)
End DoDot:1
QUIT
+7 SET TLIST="GPLIST_PXRMRCPT"
+8 SET CPT4P=""
+9 FOR
SET CPT4P=$ORDER(TAXARR("AE","CPT",CPT4P))
if CPT4P=""
QUIT
Begin DoDot:1
+10 SET RADIEN=""
+11 ;DBIA #586
+12 FOR
SET RADIEN=$ORDER(^RAMIS(71,"D",CPT4P,RADIEN))
if RADIEN=""
QUIT
Begin DoDot:2
+13 IF '$DATA(^PXRMINDX(70,"IP",RADIEN))
QUIT
+14 SET CPT4P=TAXARR("AE","RADPROC",RADIEN)
+15 KILL ^TMP($JOB,TLIST)
+16 DO GPLIST^PXRMINDL(70,"IP",RADIEN,.PFINDPA,TLIST)
+17 FOR TF=0,1
Begin DoDot:3
+18 SET DFN=0
+19 FOR
SET DFN=$ORDER(^TMP($JOB,TLIST,TF,DFN))
if DFN=""
QUIT
Begin DoDot:4
+20 SET NFOUND=0
+21 FOR
SET NFOUND=$ORDER(^TMP($JOB,TLIST,TF,DFN,RADIEN,NFOUND))
if NFOUND=""
QUIT
Begin DoDot:5
+22 SET TEMP=^TMP($JOB,TLIST,TF,DFN,RADIEN,NFOUND,70)
+23 SET DAS=$PIECE(TEMP,U,1)
+24 SET DATE=$PIECE(TEMP,U,2)
+25 SET VALUE=$PIECE(TEMP,U,4)
+26 SET ^TMP($JOB,PLIST,TF,DFN,DATE,70)=DAS_U_DATE_U_CPT4P_U_"CPT"_U_VALUE
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+27 KILL ^TMP($JOB,TLIST)
+28 QUIT
+29 ;
+30 ;==============================================
MHVOUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+1 NEW CODE,CDATA,DATE,ICPTP,IND,JND,NAME,NOUT,RESULT,TEXTIN,TEXTOUT
+2 SET NAME="Radiology Procedure = "
+3 SET IND=0
+4 FOR
SET IND=$ORDER(OCCLIST(IND))
if IND=""
QUIT
Begin DoDot:1
+5 SET CODE=IFIEVAL(IND,"CODE")
+6 SET CODESYS=IFIEVAL(IND,"CODESYS")
+7 ;DBIA #5679
+8 IF '$DATA(CODESYSN(CODESYS))
SET CODESYSN(CODESYS)=$PIECE($$CSYS^LEXU(CODESYS),U,4)
+9 SET DATE=IFIEVAL(IND,"DATE")
+10 KILL CDATA
+11 ;DBIA #5679
+12 SET RESULT=$$CSDATA^LEXU(CODE,CODESYS,DATE,.CDATA)
+13 SET DATE=IFIEVAL(IND,"DATE")
+14 SET TEXTIN(1)=NAME_" "_IFIEVAL(IND,"PROCEDURE")_"\\"
+15 SET TEXTIN(2)=$PIECE(CDATA("LEX",1),U,2)_" ("_$$EDATE^PXRMDATE(DATE)_")"
+16 DO FORMAT^PXRMTEXT(INDENT+2,PXRMRM,2,.TEXTIN,.NOUT,.TEXTOUT)
+17 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
End DoDot:1
+18 SET NLINES=NLINES+1
SET TEXT(NLINES)=""
+19 QUIT
+20 ;
+21 ;==============================================
OUTPUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+1 ;maintenance output.
+2 NEW CDATA,CODE,CODESYS,CODESYSN,DATE,IND,JND,NOUT,RESULT
+3 NEW TAXIEN,TEMP,TEXTIN,TEXTOUT
+4 SET TEMP=IFIEVAL("FINDING")
+5 SET TAXIEN=$PIECE(TEMP,";",1)
+6 SET TEMP="Radiology Procedure(s) from taxonomy "_$PIECE(^PXD(811.2,TAXIEN,0),U,1)
+7 SET NLINES=NLINES+1
+8 SET TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_TEMP
+9 SET IND=0
+10 FOR
SET IND=$ORDER(OCCLIST(IND))
if IND=""
QUIT
Begin DoDot:1
+11 SET CODE=IFIEVAL(IND,"CODE")
+12 SET CODESYS=IFIEVAL(IND,"CODESYS")
+13 ;DBIA #5679
+14 IF '$DATA(CODESYSN(CODESYS))
SET CODESYSN(CODESYS)=$PIECE($$CSYS^LEXU(CODESYS),U,4)
+15 SET DATE=IFIEVAL(IND,"DATE")
+16 KILL CDATA
+17 ;DBIA #5679
+18 SET RESULT=$$CSDATA^LEXU(CODE,CODESYS,DATE,.CDATA)
+19 SET TEXTIN(1)=$$EDATE^PXRMDATE(DATE)_" "_IFIEVAL(IND,"PROCEDURE")_"\\"
+20 SET TEXTIN(2)=CODESYSN(CODESYS)_": "_CODE_" - "_$PIECE(CDATA("LEX",1),U,2)_"\\"
+21 SET TEXTIN(3)="Status: "_IFIEVAL(IND,"STATUS")
+22 SET TEXTIN(4)="; Report Status: "_IFIEVAL(IND,"RPT STATUS")
+23 DO FORMAT^PXRMTEXT(INDENT+2,PXRMRM,4,.TEXTIN,.NOUT,.TEXTOUT)
+24 FOR JND=1:1:NOUT
SET NLINES=NLINES+1
SET TEXT(NLINES)=TEXTOUT(JND)
End DoDot:1
+25 SET NLINES=NLINES+1
SET TEXT(NLINES)=""
+26 QUIT
+27 ;
