Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXRMRCPT

PXRMRCPT.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;==============================================
  1. 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.
  1.  N CPT4P,CODE,DATE,FIEVT,IND,NOCCABS,NFOUND,PFINDPA
  1.  N RADIEN,SDIR,TE,TDATE,TIND,TF,TLIST
  1.  I TAXARR("APDS",71,"NNODES")=0 Q
  1.  I $G(^PXRMINDX(70,"DATE BUILT"))="" D  Q
  1.  . D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),70)
  1.  I '$D(^PXRMINDX(70,"PI",DFN)) Q
  1.  S $P(PFINDPA(0),U,8)=BDT
  1.  S $P(PFINDPA(0),U,11)=EDT
  1.  S $P(PFINDPA(0),U,14)=NOCC
  1.  S SDIR=$S(NOCC<0:+1,1:-1)
  1.  F IND=1:1:STATUSA(0) S PFINDPA(5,IND)=STATUSA(IND)
  1.  S NFOUND=0,CPT4P=""
  1.  F  S CPT4P=$O(TAXARR("AE","CPT",CPT4P)) Q:CPT4P=""  D
  1.  . S RADIEN=""
  1.  .;DBIA #586
  1.  . F  S RADIEN=$O(^RAMIS(71,"D",CPT4P,RADIEN)) Q:RADIEN=""  D
  1.  .. I '$D(^PXRMINDX(70,"PI",DFN,RADIEN)) Q
  1.  .. K FIEVT
  1.  .. D FIEVAL^PXRMINDX(70,"PI",DFN,RADIEN,.PFINDPA,.FIEVT)
  1.  .. I FIEVT D
  1.  ...;DBIA #1995
  1.  ... S CODE=$P($$CPT^ICPTCOD(CPT4P),U,2)
  1.  ... S IND=0
  1.  ... F  S IND=+$O(FIEVT(IND)) Q:IND=0  D
  1.  .... S NFOUND=NFOUND+1
  1.  .... S TLIST(FIEVT(IND,"DATE"),NFOUND)=FIEVT(IND,"DAS")_U_FIEVT(IND,"DATE")_U_"CPT4"_U_CODE_U_U_RADIEN
  1.  .... I NFOUND>NGET D
  1.  ..... S TDATE=$O(TLIST(""),-SDIR),TIND=$O(TLIST(TDATE,""))
  1.  ..... K TLIST(TDATE,TIND)
  1.  ;Return up to NOCC of the most recent entries.
  1.  S NOCCABS=$S(NOCC<0:-NOCC,1:NOCC)
  1.  S NFOUND=0
  1.  S DATE=""
  1.  F  S DATE=$O(TLIST(DATE),SDIR) Q:(DATE="")!(NFOUND=NOCCABS)  D
  1.  . S IND=0
  1.  . F  S IND=$O(TLIST(DATE,IND)) Q:(IND="")!(NFOUND=NOCCABS)  D
  1.  .. S NFOUND=NFOUND+1
  1.  .. S FLIST(DATE,NFOUND,70)=TLIST(DATE,IND)
  1.  Q
  1.  ;
  1.  ;==============================================
  1. GPLIST(TAXARR,PFINDPA,PLIST) ;Build a patient list for radiology procedures
  1.  ;based on the linkage to CPT4 codes.
  1.  N CPT4P,DAS,DATE,DFN,NFOUND
  1.  N RADIEN,TEMP,TF,TLIST,VALUE
  1.  I TAXARR("APDS",71,"NNODES")=0 Q
  1.  I $G(^PXRMINDX(70,"DATE BUILT"))="" D  Q
  1.  . D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),70)
  1.  S TLIST="GPLIST_PXRMRCPT"
  1.  S CPT4P=""
  1.  F  S CPT4P=$O(TAXARR("AE","CPT",CPT4P)) Q:CPT4P=""  D
  1.  . S RADIEN=""
  1.  .;DBIA #586
  1.  . F  S RADIEN=$O(^RAMIS(71,"D",CPT4P,RADIEN)) Q:RADIEN=""  D
  1.  .. I '$D(^PXRMINDX(70,"IP",RADIEN)) Q
  1.  .. S CPT4P=TAXARR("AE","RADPROC",RADIEN)
  1.  .. K ^TMP($J,TLIST)
  1.  .. D GPLIST^PXRMINDL(70,"IP",RADIEN,.PFINDPA,TLIST)
  1.  .. F TF=0,1 D
  1.  ... S DFN=0
  1.  ... F  S DFN=$O(^TMP($J,TLIST,TF,DFN)) Q:DFN=""  D
  1.  .... S NFOUND=0
  1.  .... F  S NFOUND=$O(^TMP($J,TLIST,TF,DFN,RADIEN,NFOUND)) Q:NFOUND=""  D
  1.  ..... S TEMP=^TMP($J,TLIST,TF,DFN,RADIEN,NFOUND,70)
  1.  ..... S DAS=$P(TEMP,U,1)
  1.  ..... S DATE=$P(TEMP,U,2)
  1.  ..... S VALUE=$P(TEMP,U,4)
  1.  ..... S ^TMP($J,PLIST,TF,DFN,DATE,70)=DAS_U_DATE_U_CPT4P_U_"CPT"_U_VALUE
  1.  K ^TMP($J,TLIST)
  1.  Q
  1.  ;
  1.  ;==============================================
  1. MHVOUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
  1.  N CODE,CDATA,DATE,ICPTP,IND,JND,NAME,NOUT,RESULT,TEXTIN,TEXTOUT
  1.  S NAME="Radiology Procedure = "
  1.  S IND=0
  1.  F  S IND=$O(OCCLIST(IND)) Q:IND=""  D
  1.  . S CODE=IFIEVAL(IND,"CODE")
  1.  . S CODESYS=IFIEVAL(IND,"CODESYS")
  1.  .;DBIA #5679
  1.  . I '$D(CODESYSN(CODESYS)) S CODESYSN(CODESYS)=$P($$CSYS^LEXU(CODESYS),U,4)
  1.  . S DATE=IFIEVAL(IND,"DATE")
  1.  . K CDATA
  1.  .;DBIA #5679
  1.  . S RESULT=$$CSDATA^LEXU(CODE,CODESYS,DATE,.CDATA)
  1.  . S DATE=IFIEVAL(IND,"DATE")
  1.  . S TEXTIN(1)=NAME_" "_IFIEVAL(IND,"PROCEDURE")_"\\"
  1.  . S TEXTIN(2)=$P(CDATA("LEX",1),U,2)_" ("_$$EDATE^PXRMDATE(DATE)_")"
  1.  . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,2,.TEXTIN,.NOUT,.TEXTOUT)
  1.  . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
  1.  S NLINES=NLINES+1,TEXT(NLINES)=""
  1.  Q
  1.  ;
  1.  ;==============================================
  1. OUTPUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the clinical
  1.  ;maintenance output.
  1.  N CDATA,CODE,CODESYS,CODESYSN,DATE,IND,JND,NOUT,RESULT
  1.  N TAXIEN,TEMP,TEXTIN,TEXTOUT
  1.  S TEMP=IFIEVAL("FINDING")
  1.  S TAXIEN=$P(TEMP,";",1)
  1.  S TEMP="Radiology Procedure(s) from taxonomy "_$P(^PXD(811.2,TAXIEN,0),U,1)
  1.  S NLINES=NLINES+1
  1.  S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_TEMP
  1.  S IND=0
  1.  F  S IND=$O(OCCLIST(IND)) Q:IND=""  D
  1.  . S CODE=IFIEVAL(IND,"CODE")
  1.  . S CODESYS=IFIEVAL(IND,"CODESYS")
  1.  .;DBIA #5679
  1.  . I '$D(CODESYSN(CODESYS)) S CODESYSN(CODESYS)=$P($$CSYS^LEXU(CODESYS),U,4)
  1.  . S DATE=IFIEVAL(IND,"DATE")
  1.  . K CDATA
  1.  .;DBIA #5679
  1.  . S RESULT=$$CSDATA^LEXU(CODE,CODESYS,DATE,.CDATA)
  1.  . S TEXTIN(1)=$$EDATE^PXRMDATE(DATE)_" "_IFIEVAL(IND,"PROCEDURE")_"\\"
  1.  . S TEXTIN(2)=CODESYSN(CODESYS)_": "_CODE_" - "_$P(CDATA("LEX",1),U,2)_"\\"
  1.  . S TEXTIN(3)="Status: "_IFIEVAL(IND,"STATUS")
  1.  . S TEXTIN(4)="; Report Status: "_IFIEVAL(IND,"RPT STATUS")
  1.  . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,4,.TEXTIN,.NOUT,.TEXTOUT)
  1.  . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
  1.  S NLINES=NLINES+1,TEXT(NLINES)=""
  1.  Q
  1.  ;