source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMVCPT.m@ 1470

PXRMVCPT ; SLC/PKR - Code to handle VCPT data. ;10/21/2005
 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
 ;
 ;===============================================
FPDAT(DFN,TAXARR,NGET,SDIR,BDT,EDT,FLIST) ;Find data for a patient.
 N DAS,DATE,DS,EDTT,ICPTP,NFOUND,NODE,NNODE,TDATE,TIND,TE,TLIST,TS
 I $G(^PXRMINDX(9000010.18,"DATE BUILT"))="" D  Q
 . D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),9000010.18)
 I '$D(^PXRMINDX(9000010.18,"PPI",DFN)) Q
 S NNODE=+$P($G(TAXARR("PDS",9000010.18,81)),U,2)
 I NNODE=0 Q
 ;Get the start and end of the taxonomy.
 S TS=$O(TAXARR(81,""))-1
 S TE=$O(TAXARR(81,""),-1)
 S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
 S DS=$S(SDIR=+1:BDT-.000001,1:EDTT)
 S NFOUND=0
 F IND=1:1:NNODE D
 . S NODE=TAXARR("PDS",9000010.18,81,IND)
 . S ICPTP=TS
 . F  S ICPTP=$O(^PXRMINDX(9000010.18,"PPI",DFN,NODE,ICPTP)) Q:(ICPTP>TE)!(ICPTP="")  D
 .. I '$D(TAXARR(81,ICPTP)) Q
 .. S DATE=DS
 .. F  S DATE=+$O(^PXRMINDX(9000010.18,"PPI",DFN,NODE,ICPTP,DATE),SDIR) Q:$S(DATE=0:1,DATE<BDT:1,DATE>EDTT:1,1:0)  D
 ... S DAS=$O(^PXRMINDX(9000010.18,"PPI",DFN,NODE,ICPTP,DATE,""))
 ... S NFOUND=NFOUND+1
 ... S TLIST(DATE,NFOUND)=DAS_U_ICPTP_U_NODE_U_"CPT"
 ... 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,9000010.18)=TLIST(DATE,IND)
 Q
 ;
 ;===============================================
GETDATA(DAS,FIEVT) ;Return data for a specified V CPT entry.
 ;DBIA #4250.
 D VCPT^PXPXRM(DAS,.FIEVT)
 Q
 ;
 ;===============================================
GPLIST(TAXARR,NOCC,BDT,EDT,PLIST) ;Build patient list for V CPT entries.
 N DAS,DATE,DFN,DS,ICPTP,NFOUND,NODE,NNODE,TEMP,TLIST
 I $G(^PXRMINDX(9000010.18,"DATE BUILT"))="" D  Q
 . D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),9000010.18)
 S TLIST="GPLIST_PXRMVPOV"
 K ^TMP($J,TLIST)
 S DS=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
 S NNODE=+$P($G(TAXARR("PDS",9000010.18,81)),U,2)
 I NNODE=0 Q
 S ICPTP=""
 F  S ICPTP=$O(TAXARR(81,ICPTP)) Q:(ICPTP="")  D
 . I '$D(^PXRMINDX(9000010.18,"IPP",ICPTP)) Q
 . F IND=1:1:NNODE D
 .. S NODE=TAXARR("PDS",9000010.18,81,IND)
 .. I '$D(^PXRMINDX(9000010.18,"IPP",ICPTP,NODE)) Q
 .. S DFN=0
 .. F  S DFN=$O(^PXRMINDX(9000010.18,"IPP",ICPTP,NODE,DFN)) Q:DFN=""  D
 ... S DATE=DS
 ... F  S DATE=+$O(^PXRMINDX(9000010.18,"IPP",ICPTP,NODE,DFN,DATE),-1) Q:(DATE=0)!(DATE<BDT)  D
 .... S DAS=$O(^PXRMINDX(9000010.18,"IPP",ICPTP,NODE,DFN,DATE,""))
 .... S ^TMP($J,TLIST,DFN,DATE,DAS)=ICPTP_U_"CPT"
 ;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,9000010.18)=DAS_U_DATE_U_TEMP
 K ^TMP($J,TLIST)
 Q
 ;
 ;===============================================
MHVOUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
 N CODE,CPTDATA,D0,ICPTP,IND,JND,NAME,NIN,NOUT
 N PN,PP,SNAME,TEMP,TEXTIN,TEXTOUT,VDATE
 S NAME="Encounter Procedure = "
 S IND=0
 F  S IND=$O(OCCLIST(IND)) Q:IND=""  D
 . S VDATE=IFIEVAL(IND,"DATE")
 . S D0=$G(^AUPNVCPT(IFIEVAL(IND,"DAS"),0))
 . S ICPTP=IFIEVAL(IND,"CODEP")
 . S CPTDATA=$$CPT^ICPTCOD(ICPTP,VDATE)
 . S SNAME=$P(CPTDATA,U,3)
 . S TEMP=NAME_SNAME_" ("_$$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. The VCPT information is:  DATE, ICPT CODE,
 ;SHORT NAME, PROVIDER NARRATIVE.
 N CODE,CPT,CPTDATA,D0,ICPTP,IND,JND,NIN,NOUT
 N PN,PP,SNAME,TEMP,TEXTIN,TEXTOUT,VDATE
 S NLINES=NLINES+1
 S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Encounter Procedure:"
 S IND=0
 F  S IND=$O(OCCLIST(IND)) Q:IND=""  D
 . S VDATE=IFIEVAL(IND,"DATE")
 . S TEMP=$$EDATE^PXRMDATE(VDATE)
 . S D0=$G(^AUPNVCPT(IFIEVAL(IND,"DAS"),0))
 . S ICPTP=IFIEVAL(IND,"CODEP")
 . S CPTDATA=$$CPT^ICPTCOD(ICPTP,VDATE)
 . S CODE=$P(CPTDATA,U,2)
 . S SNAME=$P(CPTDATA,U,3)
 . S TEMP=TEMP_" "_CODE
 . S TEMP=TEMP_"-"_SNAME
 . S PP=$P(IFIEVAL(IND,"FILE SPECIFIC"),U,1)
 . S PP=$S(PP="Y":"YES",1:"NO")
 . S TEMP=TEMP_" Principle Procedure: "_PP
 . S TEXTIN(1)=TEMP,NIN=1
 . S PN=$P(D0,U,4)
 . I PN'="" S PN=$P($G(^AUTNPOV(PN,0)),U,1)
 . I PN="" S PN="MISSING"
 . I PN'=SNAME S TEXTIN(2)=" Prov. Narr. - "_PN,NIN=2
 . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,NIN,.TEXTIN,.NOUT,.TEXTOUT)
 . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
 . I IFIEVAL(IND,"COMMENTS")'="" D
 .. S TEMP="Comments: "_IFIEVAL(IND,"COMMENTS")
 .. D FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT)
 .. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
 S NLINES=NLINES+1,TEXT(NLINES)=""
 Q
 ;