PXRRPAPI ;ISL/PKR - Build the patient specific info for each patient on the list. ;6/27/97
;;1.0;PCE PATIENT CARE ENCOUNTER;**18,121,165,199**;Aug 12, 1996;Build 51
;
PAT ;
N ACTIVITY,BACDATE,BD,BUSY,DATE,DFN,EACDATE,ED,ERIEN,ERR
N IC,IEN,JC,FACIEN,FACNAM
N HLOCIEN,HLOCNAM,LABTEST,LOCIEN,LRDFN,NERM
N PNAME,SPEC,SSN,SSNF,UNITS
N TEMP
;
;Allow the task to be cleaned up upon successful completion.
S ZTREQ="@"
;
S BACDATE=PXRRBCDT-.0001
S EACDATE=PXRRECDT+.2359
;
;Build a list of emergency room iens, get list from PCE parameter file.
S NERM=0
S IC=0
F S IC=$O(^PX(815,IC)) Q:+IC=0 D
. S JC=0
. F S JC=$O(^PX(815,IC,"RR1",JC)) Q:+JC=0 D
.. S NERM=NERM+1
.. S TEMP=^PX(815,IC,"RR1",JC,0)
.. S ERIEN(NERM)=TEMP_U_$P(^SC(TEMP,0),U,1)
;
I '(PXRRQUE!$D(IO("S"))) D INIT^PXRRBUSY(.BUSY)
;
S FACIEN=""
NFAC1 S FACIEN=$O(^XTMP(PXRRXTMP,"APPT",FACIEN))
I +FACIEN=0 G DONE
;
S HLOCIEN=""
NHLOC1 S HLOCIEN=$O(^XTMP(PXRRXTMP,"APPT",FACIEN,HLOCIEN))
I +HLOCIEN=0 G NFAC1
;
;Check for a user request to stop the task.
I $$S^%ZTLOAD S ZTSTOP=1 D EXIT^PXRRGUT
;
S DFN=0
NPAT S DFN=$O(^XTMP(PXRRXTMP,"APPT",FACIEN,HLOCIEN,DFN))
I +DFN=0 G NHLOC1
S ACTIVITY=0
;
;If this is an interactive session let the user know that something
;is happening.
I '(PXRRQUE!$D(IO("S"))) D SPIN^PXRRBUSY("Sorting patient information",.BUSY)
;
;Emergency room visits.
I NERM>0 D
. S BD=BACDATE
. S ED=EACDATE
. F S BD=$O(^AUPNVSIT("AET",DFN,BD)) Q:((BD>EACDATE)!(BD="")) D
.. S LOCIEN=""
.. F S LOCIEN=$O(^AUPNVSIT("AET",DFN,BD,LOCIEN)) Q:LOCIEN="" D
... F IC=1:1:NERM D
.... I $P(ERIEN(IC),U,1)=LOCIEN D
..... S ^TMP(PXRRXTMP,$J,"ER",DFN,BD)=ERIEN(IC)
. I $D(^TMP(PXRRXTMP,$J,"ER",DFN)) S ACTIVITY=1
;
;Build a list of future appointments.
D KVA^VADPT
S VASD("F")=PXRRBFDT
S VASD("T")=PXRREFDT
D SDA^VADPT
S IC=0
F S IC=$O(^UTILITY("VASD",$J,IC)) Q:+IC=0 D
. S ^TMP(PXRRXTMP,$J,"FUT",DFN,IC)=^UTILITY("VASD",$J,IC,"E")
K ^UTILITY("VASD",$J)
D KVA^VADPT
I $D(^TMP(PXRRXTMP,$J,"FUT",DFN)) S ACTIVITY=1
;
;Save all admissions and discharges in the date range.
;We will need a DBIA to use the cross-ref. Numerous similar
;ones are already in place, i.e., DBIA244-D, DBIA325-B, DBIA966, DBIA1358.
S BD=BACDATE
S ED=EACDATE
NADM S BD=$O(^DGPM("APTT1",DFN,BD))
;If we have passed the ending date we are done.
I (BD>ED)!(BD="") G DIS
S IEN=$O(^DGPM("APTT1",DFN,BD,""))
S ^TMP(PXRRXTMP,$J,"ADM",DFN,BD,IEN)=""
G NADM
I $D(^TMP(PXRRXTMP,$J,"ADM",DFN)) S ACTIVITY=1
;
DIS S BD=BACDATE
S ED=EACDATE
NDIS S BD=$O(^DGPM("APTT3",DFN,BD))
;If we have passed the ending date we are done.
I (BD>ED)!(BD="") G CLAB
S IEN=$O(^DGPM("APTT3",DFN,BD,""))
S ^TMP(PXRRXTMP,$J,"DIS",DFN,BD,IEN)=""
G NDIS
I $D(^TMP(PXRRXTMP,$J,"DIS",DFN)) S ACTIVITY=1
;
;Get critical lab values.
;This will probably require a DBIA to read DPT.
;We will need a DBIA to look at lab stuff.
CLAB S LRDFN=$G(^DPT(DFN,"LR"))
I LRDFN="" G SAVPAT
S ED=$$FMDFINVL(BACDATE,0)
S BD=$$FMDFINVL(EACDATE,0)
NLAB S BD=$O(^LR(LRDFN,"CH",BD))
;If we have passed the ending date we are done.
I (BD>ED)!(BD="") G SAVPAT
S IC=0
F S IC=$O(^LR(LRDFN,"CH",BD,IC)) Q:+IC=0 D
. S TEMP=$G(^LR(LRDFN,"CH",BD,IC))
. I $P(TEMP,U,2)["*" D
.. D FIELD^DID(63.04,IC,"","LABEL","LABTEST","ERR")
..;Try to get the units.
.. S SPEC=$P(^LR(LRDFN,"CH",BD,0),U,5)
.. S JC=$O(^LAB(60,"C","CH;"_IC_";1",""))
.. S UNITS=$P($G(^LAB(60,JC,1,SPEC,0)),U,7)
.. S ^TMP(PXRRXTMP,$J,"CLAB",DFN,BD,IC)=LABTEST("LABEL")_U_TEMP_U_UNITS
G NLAB
I $D(^TMP(PXRRXTMP,$J,"CLAB",DFN)) S ACTIVITY=1
;
SAVPAT ;Save the patient data in XTMP in a format suitable for printing.
;We only want those patients that had some activity.
I 'ACTIVITY G NPAT
S TEMP=$G(^DPT(DFN,0))
S PNAME=$P(TEMP,U,1)
S SSN=$P(TEMP,U,9)
S FACNAM=PXRRFACN(FACIEN)_U_FACIEN
S HLOCNAM=$P($G(^SC(HLOCIEN,0)),U,1)
S ^XTMP(PXRRXTMP,"ALPHA",FACNAM,HLOCNAM_U_HLOCIEN,PNAME,SSN)=DFN
D KVA^VADPT
D ADD^VADPT
S SSNF=$$SSNFORM(SSN)
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)
D KVA^VADPT
;
;Appointment data.
S IC=0
F S IC=$O(^XTMP(PXRRXTMP,"APPT",FACIEN,HLOCIEN,DFN,IC)) Q:+IC=0 D
. S ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"APPT",IC)=^XTMP(PXRRXTMP,"APPT",FACIEN,HLOCIEN,DFN,IC)
;
;Process admission data, build a complete entry including discharge
;date, last treating specialty, last provider, admitting diagnosis.
S IC=0
F S IC=$O(^TMP(PXRRXTMP,$J,"ADM",DFN,IC)) Q:+IC=0 D
. S IEN=$O(^TMP(PXRRXTMP,$J,"ADM",DFN,IC,""))
. D ADMISS(DFN,IC,IEN)
;
;Process discharge admission data, build a complete entry just as for
;admissions above. Match the discharge to the admission, avoiding
;duplicate entries.
S IC=0
F S IC=$O(^TMP(PXRRXTMP,$J,"DIS",DFN,IC)) Q:+IC=0 D
. S IEN=$O(^TMP(PXRRXTMP,$J,"DIS",DFN,IC,""))
. D DISCHRG(DFN,IC,IEN)
;
;Look for any current inpatient data whose admission we may have
;missed.
I '$D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS")) D
. D KVA^VADPT
. D IN5^VADPT
. I $L(VAIP(13))>0 D
.. S DATE=$P(VAIP(13,1),U,1)
..;The admission date must be less than the beginning activity date
..;in order for the patient to be an inpatient during the activity
..;date range.
.. I DATE<PXRRBCDT D
...;Ward
... S TEMP=$P(VAIP(14,4),U,2)
...;Last treating specialty
... S TEMP=TEMP_U_$P(VAIP(14,6),U,2)
... ;Last provider
... S TEMP=TEMP_U_$P(VAIP(14,5),U,2)
...;Admitting diagnosis
... S TEMP=TEMP_U_VAIP(13,7)
... S DISDATE=DT+1
... S ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",DATE,DISDATE)=TEMP
;
;Critical lab data.
S IC=0
F S IC=$O(^TMP(PXRRXTMP,$J,"CLAB",DFN,IC)) Q:+IC=0 D
. S TEMP=$$FMDFINVL(IC,1)
. S JC=0
. F S JC=$O(^TMP(PXRRXTMP,$J,"CLAB",DFN,IC,JC)) Q:+JC=0 D
.. S ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB",TEMP,JC)=^TMP(PXRRXTMP,$J,"CLAB",DFN,IC,JC)
;
;Emergency room visits.
S IC=0
F S IC=$O(^TMP(PXRRXTMP,$J,"ER",DFN,IC)) Q:+IC=0 D
. S ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ER",IC)=^TMP(PXRRXTMP,$J,"ER",DFN,IC)
;
;Future appointments.
S IC=0
F S IC=$O(^TMP(PXRRXTMP,$J,"FUT",DFN,IC)) Q:+IC=0 D
. S ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"FUT",IC)=^TMP(PXRRXTMP,$J,"FUT",DFN,IC)
;
G NPAT
DONE ;
I '(PXRRQUE!$D(IO("S"))) D DONE^PXRRBUSY("done")
;
EXIT ;
K ^TMP(PXRRXTMP)
;
;Print the report.
I PXRRQUE D
.;Start the report that was queued but not scheduled.
. N DESC,ROUTINE,TASK
. S DESC="Patient Activity Report - print"
. S ROUTINE="PXRRPAPR"
. S ZTDTH=$$NOW^XLFDT
. S TASK=^XTMP(PXRRXTMP,"PRZTSK")
. D REQUE^PXRRQUE(DESC,ROUTINE,TASK)
E D ^PXRRPAPR
Q
;
;======================================================================
ADMISS(DFN,DATE,IEN) ;Given a patient and an admission date find the
;associated discharge, if any. Save the other information listed
;below.
N DISDATE,TEMP
D KVA^VADPT
S VAIP("D")=DATE
S VAIP("E")=IEN
S VAIP("M")=0
D IN5^VADPT
;Store the information in TEMP in printing order.
;Ward
S TEMP=$P(VAIP(14,4),U,2)
;Last treating specialty
S TEMP=TEMP_U_$P(VAIP(14,6),U,2)
;Last provider
S TEMP=TEMP_U_$P(VAIP(14,5),U,2)
;Admitting diagnosis
S TEMP=TEMP_U_VAIP(13,7)
I $L(VAIP(17))>0 D
. S DISDATE=$P(VAIP(17,1),U,1)
E D
. S DISDATE=DT+1
S ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",DATE,DISDATE)=TEMP
;
ADMDONE ;
D KVA^VADPT
Q
;
;======================================================================
DISCHRG(DFN,DATE,IEN) ;Given a patient and a discharge date find the
;associated admission. Determine if the combined admission-discharge
;data has already been stored. If it has quit otherwise store it.
N ADMDATE,ICD9IEN,TEMP
D KVA^VADPT
S VAIP("D")=$P(DATE,".",1)
S VAIP("E")=IEN
S VAIP("M")=0
D IN5^VADPT
S ADMDATE=$P(VAIP(13,1),U,1)
I ADMDATE="" S ADMDATE=DATE_"NA"
I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",ADMDATE,DATE)) G DISDONE
;Information is not already there, store the data.
;Ward
S TEMP=""
;Last treating specialty
S TEMP=TEMP_U_$P(VAIP(17,6),U,2)
;Last provider
S TEMP=TEMP_U_$P(VAIP(17,5),U,2)
;Admitting diagnosis
S TEMP=TEMP_U_VAIP(13,7)
;Will need a DBIA for these reads.
;Try to get DXLS
I +VAIP(12)>0 S ICD9IEN=$P($G(^DGPT(VAIP(12),70)),U,10)
I +$G(ICD9IEN)>0 S TEMP=TEMP_U_$P($$ICDDATA^ICDXCODE("DIAG",ICD9IEN,DATE,"I"),U,4)
;
S ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",ADMDATE,DATE)=TEMP
DISDONE ;
D KVA^VADPT
Q
;
;======================================================================
SSNFORM(SSN) ;Format the social security number with dashes.
N FSSN,TEMP
S TEMP=$E(SSN,1,3)
S FSSN=TEMP_"-"
S TEMP=$E(SSN,4,5)
S FSSN=FSSN_TEMP_"-"
S TEMP=$E(SSN,6,9)
S FSSN=FSSN_TEMP
Q FSSN
;
;======================================================================
FMDFINVL(INVDT,DATE) ;Convert an inverse date (LABORATORY format
;9999999-date) to FileMan format.
I $L(INVDT)=0 Q INVDT
N TEMP
S TEMP=9999999-INVDT
;If DATE is TRUE return only the date portion.
I DATE S TEMP=$P(TEMP,".",1)
Q TEMP
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRRPAPI 9246 printed Apr 09, 2024@21:29:47 Page 2
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,121,165,199**;Aug 12, 1996;Build 51
+2 ;
PAT ;
+1 NEW ACTIVITY,BACDATE,BD,BUSY,DATE,DFN,EACDATE,ED,ERIEN,ERR
+2 NEW IC,IEN,JC,FACIEN,FACNAM
+3 NEW HLOCIEN,HLOCNAM,LABTEST,LOCIEN,LRDFN,NERM
+4 NEW PNAME,SPEC,SSN,SSNF,UNITS
+5 NEW TEMP
+6 ;
+7 ;Allow the task to be cleaned up upon successful completion.
+8 SET ZTREQ="@"
+9 ;
+10 SET BACDATE=PXRRBCDT-.0001
+11 SET EACDATE=PXRRECDT+.2359
+12 ;
+13 ;Build a list of emergency room iens, get list from PCE parameter file.
+14 SET NERM=0
+15 SET IC=0
+16 FOR
SET IC=$ORDER(^PX(815,IC))
if +IC=0
QUIT
Begin DoDot:1
+17 SET JC=0
+18 FOR
SET JC=$ORDER(^PX(815,IC,"RR1",JC))
if +JC=0
QUIT
Begin DoDot:2
+19 SET NERM=NERM+1
+20 SET TEMP=^PX(815,IC,"RR1",JC,0)
+21 SET ERIEN(NERM)=TEMP_U_$PIECE(^SC(TEMP,0),U,1)
End DoDot:2
End DoDot:1
+22 ;
+23 IF '(PXRRQUE!$DATA(IO("S")))
DO INIT^PXRRBUSY(.BUSY)
+24 ;
+25 SET FACIEN=""
NFAC1 SET FACIEN=$ORDER(^XTMP(PXRRXTMP,"APPT",FACIEN))
+1 IF +FACIEN=0
GOTO DONE
+2 ;
+3 SET HLOCIEN=""
NHLOC1 SET HLOCIEN=$ORDER(^XTMP(PXRRXTMP,"APPT",FACIEN,HLOCIEN))
+1 IF +HLOCIEN=0
GOTO NFAC1
+2 ;
+3 ;Check for a user request to stop the task.
+4 IF $$S^%ZTLOAD
SET ZTSTOP=1
DO EXIT^PXRRGUT
+5 ;
+6 SET DFN=0
NPAT SET DFN=$ORDER(^XTMP(PXRRXTMP,"APPT",FACIEN,HLOCIEN,DFN))
+1 IF +DFN=0
GOTO NHLOC1
+2 SET ACTIVITY=0
+3 ;
+4 ;If this is an interactive session let the user know that something
+5 ;is happening.
+6 IF '(PXRRQUE!$DATA(IO("S")))
DO SPIN^PXRRBUSY("Sorting patient information",.BUSY)
+7 ;
+8 ;Emergency room visits.
+9 IF NERM>0
Begin DoDot:1
+10 SET BD=BACDATE
+11 SET ED=EACDATE
+12 FOR
SET BD=$ORDER(^AUPNVSIT("AET",DFN,BD))
if ((BD>EACDATE)!(BD=""))
QUIT
Begin DoDot:2
+13 SET LOCIEN=""
+14 FOR
SET LOCIEN=$ORDER(^AUPNVSIT("AET",DFN,BD,LOCIEN))
if LOCIEN=""
QUIT
Begin DoDot:3
+15 FOR IC=1:1:NERM
Begin DoDot:4
+16 IF $PIECE(ERIEN(IC),U,1)=LOCIEN
Begin DoDot:5
+17 SET ^TMP(PXRRXTMP,$JOB,"ER",DFN,BD)=ERIEN(IC)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+18 IF $DATA(^TMP(PXRRXTMP,$JOB,"ER",DFN))
SET ACTIVITY=1
End DoDot:1
+19 ;
+20 ;Build a list of future appointments.
+21 DO KVA^VADPT
+22 SET VASD("F")=PXRRBFDT
+23 SET VASD("T")=PXRREFDT
+24 DO SDA^VADPT
+25 SET IC=0
+26 FOR
SET IC=$ORDER(^UTILITY("VASD",$JOB,IC))
if +IC=0
QUIT
Begin DoDot:1
+27 SET ^TMP(PXRRXTMP,$JOB,"FUT",DFN,IC)=^UTILITY("VASD",$JOB,IC,"E")
End DoDot:1
+28 KILL ^UTILITY("VASD",$JOB)
+29 DO KVA^VADPT
+30 IF $DATA(^TMP(PXRRXTMP,$JOB,"FUT",DFN))
SET ACTIVITY=1
+31 ;
+32 ;Save all admissions and discharges in the date range.
+33 ;We will need a DBIA to use the cross-ref. Numerous similar
+34 ;ones are already in place, i.e., DBIA244-D, DBIA325-B, DBIA966, DBIA1358.
+35 SET BD=BACDATE
+36 SET ED=EACDATE
NADM SET BD=$ORDER(^DGPM("APTT1",DFN,BD))
+1 ;If we have passed the ending date we are done.
+2 IF (BD>ED)!(BD="")
GOTO DIS
+3 SET IEN=$ORDER(^DGPM("APTT1",DFN,BD,""))
+4 SET ^TMP(PXRRXTMP,$JOB,"ADM",DFN,BD,IEN)=""
+5 GOTO NADM
+6 IF $DATA(^TMP(PXRRXTMP,$JOB,"ADM",DFN))
SET ACTIVITY=1
+7 ;
DIS SET BD=BACDATE
+1 SET ED=EACDATE
NDIS SET BD=$ORDER(^DGPM("APTT3",DFN,BD))
+1 ;If we have passed the ending date we are done.
+2 IF (BD>ED)!(BD="")
GOTO CLAB
+3 SET IEN=$ORDER(^DGPM("APTT3",DFN,BD,""))
+4 SET ^TMP(PXRRXTMP,$JOB,"DIS",DFN,BD,IEN)=""
+5 GOTO NDIS
+6 IF $DATA(^TMP(PXRRXTMP,$JOB,"DIS",DFN))
SET ACTIVITY=1
+7 ;
+8 ;Get critical lab values.
+9 ;This will probably require a DBIA to read DPT.
+10 ;We will need a DBIA to look at lab stuff.
CLAB SET LRDFN=$GET(^DPT(DFN,"LR"))
+1 IF LRDFN=""
GOTO SAVPAT
+2 SET ED=$$FMDFINVL(BACDATE,0)
+3 SET BD=$$FMDFINVL(EACDATE,0)
NLAB SET BD=$ORDER(^LR(LRDFN,"CH",BD))
+1 ;If we have passed the ending date we are done.
+2 IF (BD>ED)!(BD="")
GOTO SAVPAT
+3 SET IC=0
+4 FOR
SET IC=$ORDER(^LR(LRDFN,"CH",BD,IC))
if +IC=0
QUIT
Begin DoDot:1
+5 SET TEMP=$GET(^LR(LRDFN,"CH",BD,IC))
+6 IF $PIECE(TEMP,U,2)["*"
Begin DoDot:2
+7 DO FIELD^DID(63.04,IC,"","LABEL","LABTEST","ERR")
+8 ;Try to get the units.
+9 SET SPEC=$PIECE(^LR(LRDFN,"CH",BD,0),U,5)
+10 SET JC=$ORDER(^LAB(60,"C","CH;"_IC_";1",""))
+11 SET UNITS=$PIECE($GET(^LAB(60,JC,1,SPEC,0)),U,7)
+12 SET ^TMP(PXRRXTMP,$JOB,"CLAB",DFN,BD,IC)=LABTEST("LABEL")_U_TEMP_U_UNITS
End DoDot:2
End DoDot:1
+13 GOTO NLAB
+14 IF $DATA(^TMP(PXRRXTMP,$JOB,"CLAB",DFN))
SET ACTIVITY=1
+15 ;
SAVPAT ;Save the patient data in XTMP in a format suitable for printing.
+1 ;We only want those patients that had some activity.
+2 IF 'ACTIVITY
GOTO NPAT
+3 SET TEMP=$GET(^DPT(DFN,0))
+4 SET PNAME=$PIECE(TEMP,U,1)
+5 SET SSN=$PIECE(TEMP,U,9)
+6 SET FACNAM=PXRRFACN(FACIEN)_U_FACIEN
+7 SET HLOCNAM=$PIECE($GET(^SC(HLOCIEN,0)),U,1)
+8 SET ^XTMP(PXRRXTMP,"ALPHA",FACNAM,HLOCNAM_U_HLOCIEN,PNAME,SSN)=DFN
+9 DO KVA^VADPT
+10 DO ADD^VADPT
+11 SET SSNF=$$SSNFORM(SSN)
+12 SET ^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)
+13 DO KVA^VADPT
+14 ;
+15 ;Appointment data.
+16 SET IC=0
+17 FOR
SET IC=$ORDER(^XTMP(PXRRXTMP,"APPT",FACIEN,HLOCIEN,DFN,IC))
if +IC=0
QUIT
Begin DoDot:1
+18 SET ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"APPT",IC)=^XTMP(PXRRXTMP,"APPT",FACIEN,HLOCIEN,DFN,IC)
End DoDot:1
+19 ;
+20 ;Process admission data, build a complete entry including discharge
+21 ;date, last treating specialty, last provider, admitting diagnosis.
+22 SET IC=0
+23 FOR
SET IC=$ORDER(^TMP(PXRRXTMP,$JOB,"ADM",DFN,IC))
if +IC=0
QUIT
Begin DoDot:1
+24 SET IEN=$ORDER(^TMP(PXRRXTMP,$JOB,"ADM",DFN,IC,""))
+25 DO ADMISS(DFN,IC,IEN)
End DoDot:1
+26 ;
+27 ;Process discharge admission data, build a complete entry just as for
+28 ;admissions above. Match the discharge to the admission, avoiding
+29 ;duplicate entries.
+30 SET IC=0
+31 FOR
SET IC=$ORDER(^TMP(PXRRXTMP,$JOB,"DIS",DFN,IC))
if +IC=0
QUIT
Begin DoDot:1
+32 SET IEN=$ORDER(^TMP(PXRRXTMP,$JOB,"DIS",DFN,IC,""))
+33 DO DISCHRG(DFN,IC,IEN)
End DoDot:1
+34 ;
+35 ;Look for any current inpatient data whose admission we may have
+36 ;missed.
+37 IF '$DATA(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS"))
Begin DoDot:1
+38 DO KVA^VADPT
+39 DO IN5^VADPT
+40 IF $LENGTH(VAIP(13))>0
Begin DoDot:2
+41 SET DATE=$PIECE(VAIP(13,1),U,1)
+42 ;The admission date must be less than the beginning activity date
+43 ;in order for the patient to be an inpatient during the activity
+44 ;date range.
+45 IF DATE<PXRRBCDT
Begin DoDot:3
+46 ;Ward
+47 SET TEMP=$PIECE(VAIP(14,4),U,2)
+48 ;Last treating specialty
+49 SET TEMP=TEMP_U_$PIECE(VAIP(14,6),U,2)
+50 ;Last provider
+51 SET TEMP=TEMP_U_$PIECE(VAIP(14,5),U,2)
+52 ;Admitting diagnosis
+53 SET TEMP=TEMP_U_VAIP(13,7)
+54 SET DISDATE=DT+1
+55 SET ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",DATE,DISDATE)=TEMP
End DoDot:3
End DoDot:2
End DoDot:1
+56 ;
+57 ;Critical lab data.
+58 SET IC=0
+59 FOR
SET IC=$ORDER(^TMP(PXRRXTMP,$JOB,"CLAB",DFN,IC))
if +IC=0
QUIT
Begin DoDot:1
+60 SET TEMP=$$FMDFINVL(IC,1)
+61 SET JC=0
+62 FOR
SET JC=$ORDER(^TMP(PXRRXTMP,$JOB,"CLAB",DFN,IC,JC))
if +JC=0
QUIT
Begin DoDot:2
+63 SET ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB",TEMP,JC)=^TMP(PXRRXTMP,$JOB,"CLAB",DFN,IC,JC)
End DoDot:2
End DoDot:1
+64 ;
+65 ;Emergency room visits.
+66 SET IC=0
+67 FOR
SET IC=$ORDER(^TMP(PXRRXTMP,$JOB,"ER",DFN,IC))
if +IC=0
QUIT
Begin DoDot:1
+68 SET ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ER",IC)=^TMP(PXRRXTMP,$JOB,"ER",DFN,IC)
End DoDot:1
+69 ;
+70 ;Future appointments.
+71 SET IC=0
+72 FOR
SET IC=$ORDER(^TMP(PXRRXTMP,$JOB,"FUT",DFN,IC))
if +IC=0
QUIT
Begin DoDot:1
+73 SET ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"FUT",IC)=^TMP(PXRRXTMP,$JOB,"FUT",DFN,IC)
End DoDot:1
+74 ;
+75 GOTO NPAT
DONE ;
+1 IF '(PXRRQUE!$DATA(IO("S")))
DO DONE^PXRRBUSY("done")
+2 ;
EXIT ;
+1 KILL ^TMP(PXRRXTMP)
+2 ;
+3 ;Print the report.
+4 IF PXRRQUE
Begin DoDot:1
+5 ;Start the report that was queued but not scheduled.
+6 NEW DESC,ROUTINE,TASK
+7 SET DESC="Patient Activity Report - print"
+8 SET ROUTINE="PXRRPAPR"
+9 SET ZTDTH=$$NOW^XLFDT
+10 SET TASK=^XTMP(PXRRXTMP,"PRZTSK")
+11 DO REQUE^PXRRQUE(DESC,ROUTINE,TASK)
End DoDot:1
+12 IF '$TEST
DO ^PXRRPAPR
+13 QUIT
+14 ;
+15 ;======================================================================
ADMISS(DFN,DATE,IEN) ;Given a patient and an admission date find the
+1 ;associated discharge, if any. Save the other information listed
+2 ;below.
+3 NEW DISDATE,TEMP
+4 DO KVA^VADPT
+5 SET VAIP("D")=DATE
+6 SET VAIP("E")=IEN
+7 SET VAIP("M")=0
+8 DO IN5^VADPT
+9 ;Store the information in TEMP in printing order.
+10 ;Ward
+11 SET TEMP=$PIECE(VAIP(14,4),U,2)
+12 ;Last treating specialty
+13 SET TEMP=TEMP_U_$PIECE(VAIP(14,6),U,2)
+14 ;Last provider
+15 SET TEMP=TEMP_U_$PIECE(VAIP(14,5),U,2)
+16 ;Admitting diagnosis
+17 SET TEMP=TEMP_U_VAIP(13,7)
+18 IF $LENGTH(VAIP(17))>0
Begin DoDot:1
+19 SET DISDATE=$PIECE(VAIP(17,1),U,1)
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 SET DISDATE=DT+1
End DoDot:1
+22 SET ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",DATE,DISDATE)=TEMP
+23 ;
ADMDONE ;
+1 DO KVA^VADPT
+2 QUIT
+3 ;
+4 ;======================================================================
DISCHRG(DFN,DATE,IEN) ;Given a patient and a discharge date find the
+1 ;associated admission. Determine if the combined admission-discharge
+2 ;data has already been stored. If it has quit otherwise store it.
+3 NEW ADMDATE,ICD9IEN,TEMP
+4 DO KVA^VADPT
+5 SET VAIP("D")=$PIECE(DATE,".",1)
+6 SET VAIP("E")=IEN
+7 SET VAIP("M")=0
+8 DO IN5^VADPT
+9 SET ADMDATE=$PIECE(VAIP(13,1),U,1)
+10 IF ADMDATE=""
SET ADMDATE=DATE_"NA"
+11 IF $DATA(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",ADMDATE,DATE))
GOTO DISDONE
+12 ;Information is not already there, store the data.
+13 ;Ward
+14 SET TEMP=""
+15 ;Last treating specialty
+16 SET TEMP=TEMP_U_$PIECE(VAIP(17,6),U,2)
+17 ;Last provider
+18 SET TEMP=TEMP_U_$PIECE(VAIP(17,5),U,2)
+19 ;Admitting diagnosis
+20 SET TEMP=TEMP_U_VAIP(13,7)
+21 ;Will need a DBIA for these reads.
+22 ;Try to get DXLS
+23 IF +VAIP(12)>0
SET ICD9IEN=$PIECE($GET(^DGPT(VAIP(12),70)),U,10)
+24 IF +$GET(ICD9IEN)>0
SET TEMP=TEMP_U_$PIECE($$ICDDATA^ICDXCODE("DIAG",ICD9IEN,DATE,"I"),U,4)
+25 ;
+26 SET ^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",ADMDATE,DATE)=TEMP
DISDONE ;
+1 DO KVA^VADPT
+2 QUIT
+3 ;
+4 ;======================================================================
SSNFORM(SSN) ;Format the social security number with dashes.
+1 NEW FSSN,TEMP
+2 SET TEMP=$EXTRACT(SSN,1,3)
+3 SET FSSN=TEMP_"-"
+4 SET TEMP=$EXTRACT(SSN,4,5)
+5 SET FSSN=FSSN_TEMP_"-"
+6 SET TEMP=$EXTRACT(SSN,6,9)
+7 SET FSSN=FSSN_TEMP
+8 QUIT FSSN
+9 ;
+10 ;======================================================================
FMDFINVL(INVDT,DATE) ;Convert an inverse date (LABORATORY format
+1 ;9999999-date) to FileMan format.
+2 IF $LENGTH(INVDT)=0
QUIT INVDT
+3 NEW TEMP
+4 SET TEMP=9999999-INVDT
+5 ;If DATE is TRUE return only the date portion.
+6 IF DATE
SET TEMP=$PIECE(TEMP,".",1)
+7 QUIT TEMP
+8 ;
