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

PXRRPAPI.m

Go to the documentation of this file. 
  1. PXRRPAPI ;ISL/PKR - Build the patient specific info for each patient on the list. ;6/27/97
  1.  ;;1.0;PCE PATIENT CARE ENCOUNTER;**18**;Aug 12, 1996
  1.  ;
  1. PAT ;
  1.  N ACTIVITY,BACDATE,BD,BUSY,DATE,DFN,EACDATE,ED,ERIEN,ERR
  1.  N IC,IEN,JC,FACIEN,FACNAM
  1.  N HLOCIEN,HLOCNAM,LABTEST,LOCIEN,LRDFN,NERM
  1.  N PNAME,SPEC,SSN,SSNF,UNITS
  1.  N TEMP
  1.  ;
  1.  ;Allow the task to be cleaned up upon successful completion.
  1.  S ZTREQ="@"
  1.  ;
  1.  S BACDATE=PXRRBCDT-.0001
  1.  S EACDATE=PXRRECDT+.2359
  1.  ;
  1.  ;Build a list of emergency room iens, get list from PCE parameter file.
  1.  S NERM=0
  1.  S IC=0
  1.  F  S IC=$O(^PX(815,IC)) Q:+IC=0  D
  1.  . S JC=0
  1.  . F  S JC=$O(^PX(815,IC,"RR1",JC)) Q:+JC=0  D
  1.  .. S NERM=NERM+1
  1.  .. S TEMP=^PX(815,IC,"RR1",JC,0)
  1.  .. S ERIEN(NERM)=TEMP_U_$P(^SC(TEMP,0),U,1)
  1.  ;
  1.  I '(PXRRQUE!$D(IO("S"))) D INIT^PXRRBUSY(.BUSY)
  1.  ;
  1.  S FACIEN=""
  1. NFAC1 S FACIEN=$O(^XTMP(PXRRXTMP,"APPT",FACIEN))
  1.  I +FACIEN=0 G DONE
  1.  ;
  1.  S HLOCIEN=""
  1. NHLOC1 S HLOCIEN=$O(^XTMP(PXRRXTMP,"APPT",FACIEN,HLOCIEN))
  1.  I +HLOCIEN=0 G NFAC1
  1.  ;
  1.  ;Check for a user request to stop the task.
  1.  I $$S^%ZTLOAD S ZTSTOP=1 D EXIT^PXRRGUT
  1.  ;
  1.  S DFN=0
  1. NPAT S DFN=$O(^XTMP(PXRRXTMP,"APPT",FACIEN,HLOCIEN,DFN))
  1.  I +DFN=0 G NHLOC1
  1.  S ACTIVITY=0
  1.  ;
  1.  ;If this is an interactive session let the user know that something
  1.  ;is happening.
  1.  I '(PXRRQUE!$D(IO("S"))) D SPIN^PXRRBUSY("Sorting patient information",.BUSY)
  1.  ;
  1.  ;Emergency room visits.
  1.  I NERM>0 D
  1.  . S BD=BACDATE
  1.  . S ED=EACDATE
  1.  . F  S BD=$O(^AUPNVSIT("AET",DFN,BD)) Q:((BD>EACDATE)!(BD=""))  D
  1.  .. S LOCIEN=""
  1.  .. F  S LOCIEN=$O(^AUPNVSIT("AET",DFN,BD,LOCIEN)) Q:LOCIEN=""  D
  1.  ... F IC=1:1:NERM  D
  1.  .... I $P(ERIEN(IC),U,1)=LOCIEN D
  1.  ..... S ^TMP(PXRRXTMP,$J,"ER",DFN,BD)=ERIEN(IC)
  1.  . I $D(^TMP(PXRRXTMP,$J,"ER",DFN)) S ACTIVITY=1
  1.  ;
  1.  ;Build a list of future appointments.
  1.  D KVA^VADPT
  1.  S VASD("F")=PXRRBFDT
  1.  S VASD("T")=PXRREFDT
  1.  D SDA^VADPT
  1.  S IC=0
  1.  F  S IC=$O(^UTILITY("VASD",$J,IC)) Q:+IC=0  D
  1.  . S ^TMP(PXRRXTMP,$J,"FUT",DFN,IC)=^UTILITY("VASD",$J,IC,"E")
  1.  K ^UTILITY("VASD",$J)
  1.  D KVA^VADPT
  1.  I $D(^TMP(PXRRXTMP,$J,"FUT",DFN)) S ACTIVITY=1
  1.  ;
  1.  ;Save all admissions and discharges in the date range.
  1.  ;We will need a DBIA to use the cross-ref.  Numerous similar
  1.  ;ones are already in place, i.e.,  DBIA244-D, DBIA325-B, DBIA966, DBIA1358.
  1.  S BD=BACDATE
  1.  S ED=EACDATE
  1. NADM S BD=$O(^DGPM("APTT1",DFN,BD))
  1.  ;If we have passed the ending date we are done.
  1.  I (BD>ED)!(BD="") G DIS
  1.  S IEN=$O(^DGPM("APTT1",DFN,BD,""))
  1.  S ^TMP(PXRRXTMP,$J,"ADM",DFN,BD,IEN)=""
  1.  G NADM
  1.  I $D(^TMP(PXRRXTMP,$J,"ADM",DFN)) S ACTIVITY=1
  1.  ;
  1. DIS S BD=BACDATE
  1.  S ED=EACDATE
  1. NDIS S BD=$O(^DGPM("APTT3",DFN,BD))
  1.  ;If we have passed the ending date we are done.
  1.  I (BD>ED)!(BD="") G CLAB
  1.  S IEN=$O(^DGPM("APTT3",DFN,BD,""))
  1.  S ^TMP(PXRRXTMP,$J,"DIS",DFN,BD,IEN)=""
  1.  G NDIS
  1.  I $D(^TMP(PXRRXTMP,$J,"DIS",DFN)) S ACTIVITY=1
  1.  ;
  1.  ;Get critical lab values.
  1.  ;This will probably require a DBIA to read DPT.
  1.  ;We will need a DBIA to look at lab stuff.
  1. CLAB S LRDFN=$G(^DPT(DFN,"LR"))
  1.  I LRDFN="" G SAVPAT
  1.  S ED=$$FMDFINVL^PXRMDATE(BACDATE,0)
  1.  S BD=$$FMDFINVL^PXRMDATE(EACDATE,0)
  1. NLAB S BD=$O(^LR(LRDFN,"CH",BD))
  1.  ;If we have passed the ending date we are done.
  1.  I (BD>ED)!(BD="") G SAVPAT
  1.  S IC=0
  1.  F  S IC=$O(^LR(LRDFN,"CH",BD,IC)) Q:+IC=0  D
  1.  . S TEMP=$G(^LR(LRDFN,"CH",BD,IC))
  1.  . I $P(TEMP,U,2)["*" D
  1.  .. D FIELD^DID(63.04,IC,"","LABEL","LABTEST","ERR")
  1.  ..;Try to get the units.
  1.  .. S SPEC=$P(^LR(LRDFN,"CH",BD,0),U,5)
  1.  .. S JC=$O(^LAB(60,"C","CH;"_IC_";1",""))
  1.  .. S UNITS=$P($G(^LAB(60,JC,1,SPEC,0)),U,7)
  1.  .. S ^TMP(PXRRXTMP,$J,"CLAB",DFN,BD,IC)=LABTEST("LABEL")_U_TEMP_U_UNITS
  1.  G NLAB
  1.  I $D(^TMP(PXRRXTMP,$J,"CLAB",DFN)) S ACTIVITY=1
  1.  ;
  1. SAVPAT ;Save the patient data in XTMP in a format suitable for printing.
  1.  ;We only want those patients that had some activity.
  1.  I 'ACTIVITY G NPAT
  1.  S TEMP=$G(^DPT(DFN,0))
  1.  S PNAME=$P(TEMP,U,1)
  1.  S SSN=$P(TEMP,U,9)
  1.  S FACNAM=PXRRFACN(FACIEN)_U_FACIEN
  1.  S HLOCNAM=$P($G(^SC(HLOCIEN,0)),U,1)
  1.  S ^XTMP(PXRRXTMP,"ALPHA",FACNAM,HLOCNAM_U_HLOCIEN,PNAME,SSN)=DFN
  1.  D KVA^VADPT
  1.  D ADD^VADPT
  1.  S SSNF=$$SSNFORM(SSN)
  1.  S ^XTMP(PXRRXTMP,"PATIENT",DFN)=SSNF_U_VAPA(1)_U_VAPA(2)_U_VAPA(3)_U_VAPA(4)_U_VAPA(5)_U_VAPA(6)_U_VAPA(8)
  1.  D KVA^VADPT
  1.  ;
  1.  ;Appointment data.
  1.  S IC=0
  1.  F  S IC=$O(^XTMP(PXRRXTMP,"APPT",FACIEN,HLOCIEN,DFN,IC)) Q:+IC=0  D
  1.  . S ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"APPT",IC)=^XTMP(PXRRXTMP,"APPT",FACIEN,HLOCIEN,DFN,IC)
  1.  ;
  1.  ;Process admission data, build a complete entry including discharge
  1.  ;date, last treating specialty, last provider, admitting diagnosis.
  1.  S IC=0
  1.  F  S IC=$O(^TMP(PXRRXTMP,$J,"ADM",DFN,IC)) Q:+IC=0  D
  1.  . S IEN=$O(^TMP(PXRRXTMP,$J,"ADM",DFN,IC,""))
  1.  . D ADMISS(DFN,IC,IEN)
  1.  ;
  1.  ;Process discharge admission data, build a complete entry just as for
  1.  ;admissions above.  Match the discharge to the admission, avoiding
  1.  ;duplicate entries.
  1.  S IC=0
  1.  F  S IC=$O(^TMP(PXRRXTMP,$J,"DIS",DFN,IC)) Q:+IC=0  D
  1.  . S IEN=$O(^TMP(PXRRXTMP,$J,"DIS",DFN,IC,""))
  1.  . D DISCHRG(DFN,IC,IEN)
  1.  ;
  1.  ;Look for any current inpatient data whose admission we may have
  1.  ;missed.
  1.  I '$D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS")) D
  1.  . D KVA^VADPT
  1.  . D IN5^VADPT
  1.  . I $L(VAIP(13))>0 D
  1.  .. S DATE=$P(VAIP(13,1),U,1)
  1.  ..;The admission date must be less than the beginning activity date
  1.  ..;in order for the patient to be an inpatient during the activity
  1.  ..;date range.
  1.  .. I DATE<PXRRBCDT D
  1.  ...;Ward
  1.  ... S TEMP=$P(VAIP(14,4),U,2)
  1.  ...;Last treating specialty
  1.  ... S TEMP=TEMP_U_$P(VAIP(14,6),U,2)
  1.  ... ;Last provider
  1.  ... S TEMP=TEMP_U_$P(VAIP(14,5),U,2)
  1.  ...;Admitting diagnosis
  1.  ... S TEMP=TEMP_U_VAIP(13,7)
  1.  ... S DISDATE=DT+1
  1.  ... S ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",DATE,DISDATE)=TEMP
  1.  ;
  1.  ;Critical lab data.
  1.  S IC=0
  1.  F  S IC=$O(^TMP(PXRRXTMP,$J,"CLAB",DFN,IC)) Q:+IC=0  D
  1.  . S TEMP=$$FMDFINVL^PXRMDATE(IC,1)
  1.  . S JC=0
  1.  . F  S JC=$O(^TMP(PXRRXTMP,$J,"CLAB",DFN,IC,JC)) Q:+JC=0  D
  1.  .. S ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB",TEMP,JC)=^TMP(PXRRXTMP,$J,"CLAB",DFN,IC,JC)
  1.  ;
  1.  ;Emergency room visits.
  1.  S IC=0
  1.  F  S IC=$O(^TMP(PXRRXTMP,$J,"ER",DFN,IC)) Q:+IC=0  D
  1.  . S ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ER",IC)=^TMP(PXRRXTMP,$J,"ER",DFN,IC)
  1.  ;
  1.  ;Future appointments.
  1.  S IC=0
  1.  F  S IC=$O(^TMP(PXRRXTMP,$J,"FUT",DFN,IC)) Q:+IC=0  D
  1.  . S ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"FUT",IC)=^TMP(PXRRXTMP,$J,"FUT",DFN,IC)
  1.  ;
  1.  G NPAT
  1. DONE ;
  1.  I '(PXRRQUE!$D(IO("S"))) D DONE^PXRRBUSY("done")
  1.  ;
  1. EXIT ;
  1.  K ^TMP(PXRRXTMP)
  1.  ;
  1.  ;Print the report.
  1.  I PXRRQUE D
  1.  .;Start the report that was queued but not scheduled.
  1.  . N DESC,ROUTINE,TASK
  1.  . S DESC="Patient Activity Report - print"
  1.  . S ROUTINE="PXRRPAPR"
  1.  . S ZTDTH=$$NOW^XLFDT
  1.  . S TASK=^XTMP(PXRRXTMP,"PRZTSK")
  1.  . D REQUE^PXRRQUE(DESC,ROUTINE,TASK)
  1.  E  D ^PXRRPAPR
  1.  Q
  1.  ;
  1.  ;=======================================================================
  1. ADMISS(DFN,DATE,IEN) ;Given a patient and an admission date find the
  1.  ;associated discharge, if any.  Save the other information listed
  1.  ;below.
  1.  N DISDATE,TEMP
  1.  D KVA^VADPT
  1.  S VAIP("D")=DATE
  1.  S VAIP("E")=IEN
  1.  S VAIP("M")=0
  1.  D IN5^VADPT
  1.  ;Store the information in TEMP in printing order.
  1.  ;Ward
  1.  S TEMP=$P(VAIP(14,4),U,2)
  1.  ;Last treating specialty
  1.  S TEMP=TEMP_U_$P(VAIP(14,6),U,2)
  1.  ;Last provider
  1.  S TEMP=TEMP_U_$P(VAIP(14,5),U,2)
  1.  ;Admitting diagnosis
  1.  S TEMP=TEMP_U_VAIP(13,7)
  1.  I $L(VAIP(17))>0 D
  1.  . S DISDATE=$P(VAIP(17,1),U,1)
  1.  E  D
  1.  . S DISDATE=DT+1
  1.  S ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",DATE,DISDATE)=TEMP
  1.  ;
  1. ADMDONE ;
  1.  D KVA^VADPT
  1.  Q
  1.  ;
  1.  ;=======================================================================
  1. DISCHRG(DFN,DATE,IEN) ;Given a patient and a discharge date find the
  1.  ;associated admission.  Determine if the combined admission-discharge
  1.  ;data has already been stored.  If it has quit otherwise store it.
  1.  N ADMDATE,ICD9IEN,TEMP
  1.  D KVA^VADPT
  1.  S VAIP("D")=$P(DATE,".",1)
  1.  S VAIP("E")=IEN
  1.  S VAIP("M")=0
  1.  D IN5^VADPT
  1.  S ADMDATE=$P(VAIP(13,1),U,1)
  1.  I ADMDATE="" S ADMDATE=DATE_"NA"
  1.  I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",ADMDATE,DATE)) G DISDONE
  1.  ;Information is not already there, store the data.
  1.  ;Ward
  1.  S TEMP=""
  1.  ;Last treating specialty
  1.  S TEMP=TEMP_U_$P(VAIP(17,6),U,2)
  1.  ;Last provider
  1.  S TEMP=TEMP_U_$P(VAIP(17,5),U,2)
  1.  ;Admitting diagnosis
  1.  S TEMP=TEMP_U_VAIP(13,7)
  1.  ;Will need a DBIA for these reads.
  1.  ;Try to get DXLS
  1.  I +VAIP(12)>0 S ICD9IEN=$P($G(^DGPT(VAIP(12),70)),U,10)
  1.  I +$G(ICD9IEN)>0 S TEMP=TEMP_U_$P(^ICD9(ICD9IEN,0),U,3)
  1.  ;
  1.  S ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",ADMDATE,DATE)=TEMP
  1. DISDONE ;
  1.  D KVA^VADPT
  1.  Q
  1.  ;
  1.  ;=======================================================================
  1. SSNFORM(SSN) ;Format the social security number with dashes.
  1.  N FSSN,TEMP
  1.  S TEMP=$E(SSN,1,3)
  1.  S FSSN=TEMP_"-"
  1.  S TEMP=$E(SSN,4,5)
  1.  S FSSN=FSSN_TEMP_"-"
  1.  S TEMP=$E(SSN,6,9)
  1.  S FSSN=FSSN_TEMP
  1.  Q FSSN
  1.  ;