PXRRPAPR ;ISL/PKR - Patient activity report print. ;8/26/97
;;1.0;PCE PATIENT CARE ENCOUNTER;**18,47**;Aug 12, 1996
;
N BMARG,C1S,C2S,C3S,C1HS,HEAD,INDENT,PAGE
N CLIEN,CSTOP,DATE,DISDATE,DFN,DONE,ED
N FACIEN,FACILITY,FACPNAME,HLOC,HLOCIEN,HLOCNAM
N IC,JC,LOC,LOS
N NAME,POV,SD,SSN,STATUS,TEMP
;
;Allow the task to be cleaned up upon successful completion.
S ZTREQ="@"
;
U IO
S DONE=0
;Setup the formatting parameters.
S INDENT=2
S C1HS=INDENT
S C1S=C1HS+1
S C2S=C1S+22
S C3S=C2S+32
;
S HEAD=1
S PAGE=0
I ($E(IOST)="C")&(IO=IO(0)) S BMARG=3
E S BMARG=2
I 'PXRRLCNP D MHEAD(1)
;
S STATUS(0)="CANCELED OR NO-SHOWED"
;
SET ;Set up print fields
S FACILITY=0
NFAC S FACILITY=$O(^XTMP(PXRRXTMP,"ALPHA",FACILITY))
I FACILITY="" G FINAL
S HEAD=1
S FACIEN=$P(FACILITY,U,3)
S FACPNAME=$P(FACILITY,U,1)_" "_$P(FACILITY,U,2)
;Keep track of the facilities that were found.
F IC=1:1:NFAC I $P(PXRRFAC(IC),U,1)=FACIEN D Q
. S $P(PXRRFAC(IC),U,4)="M"
;
S HLOC=""
NHLOC S HLOC=$O(^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC))
I HLOC="" G NFAC
S HLOCNAM=$P(HLOC,U,1)
S HLOCIEN=$P(HLOC,U,2)
S CLIEN=$P(^SC(HLOCIEN,0),U,7)
S CSTOP=" ("_$P(^DIC(40.7,CLIEN,0),U,2)_")"
;If the user requested it start a new page.
I PXRRLCNP D MHEAD(1)
D HEAD(0)
;
;Check for a user request to stop the task.
I $$S^%ZTLOAD S ZTSTOP=1 G EXIT
;
S NAME=""
NPAT ;
S NAME=$O(^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC,NAME))
I NAME="" G NHLOC
S SSN="",SSN=$O(^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC,NAME,SSN))
S DFN=^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC,NAME,SSN)
D PPRINT
I DONE G EXIT
G NPAT
;
FINAL ;Check for facilities that were listed but had no encounters.
I $Y>(IOSL-BMARG-3) D PAGE
D FACNE^PXRRGPRT(INDENT)
EXIT ;
D EXIT^PXRRGUT
D EOR^PXRRGUT
Q
;
;=======================================================================
HEAD(NEWPAGE) ;
I NEWPAGE D PAGE
E I $Y>(IOSL-BMARG) D PAGE
I DONE Q
I HEAD D
. N CEN,LEN
. S LEN=$$MAX^XLFMTH($L(FACPNAME),$L(HLOCNAM))+10
. S CEN=(IOM-LEN)/2
. W !!,?CEN,"Facility: ",FACPNAME
. W !,?CEN,"Location: ",HLOCNAM,CSTOP
. S HEAD=0
Q
;
;=======================================================================
MHEAD(NEWPAGE) ;Write the main report header.
I NEWPAGE D PAGE
E I $Y>(IOSL-BMARG) D PAGE
W !!,"Criteria for Patient Activity Report"
W !?INDENT,"Location selection criteria:",?35,$P(PXRRLCSC,U,2)
S SD=$$FMTE^XLFDT(PXRRBADT)
S ED=$$FMTE^XLFDT(PXRREADT)
W !?INDENT,"Patient appointment date range:",?35,SD," through ",ED
S SD=$$FMTE^XLFDT(PXRRBCDT)
S ED=$$FMTE^XLFDT(PXRRECDT)
W !?INDENT,"Patient activity date range:",?35,SD," through ",ED
S SD=$$FMTE^XLFDT(PXRRBFDT)
S ED=$$FMTE^XLFDT(PXRREFDT)
W !?INDENT,"Future appointment date range:",?35,SD," through ",ED
W !,"____________________________________________________________________"
Q
;
;=======================================================================
PAGE ;form feed to new page
I ($E(IOST)="C")&(IO=IO(0)) D
. S DIR(0)="E"
. W !
. D ^DIR K DIR
I $D(DIROUT)!$D(DUOUT)!($D(DTOUT)) S DONE=1 Q
W:$D(IOF) @IOF
S PAGE=PAGE+1
D HDR^PXRRGPRT(PAGE)
S HEAD=1
Q
;
;=======================================================================
PHEAD(NEWPAGE) ;Print the patient header
D HEAD(NEWPAGE)
I DONE Q
N C2S,C3S,T1,TEMP
S TEMP=^XTMP(PXRRXTMP,"PATIENT",DFN)
S C2S=$L(NAME)+5
S C3S=C2S+14
W !,"_______________________________________________________________________________"
W !,NAME,?C2S,$P(TEMP,U,1),?C3S,$P(TEMP,U,9)
W !
S T1=$P(TEMP,U,2)
I $L(T1)>0 W T1
S T1=$P(TEMP,U,3)
I $L(T1)>0 W " ",T1
S T1=$P(TEMP,U,4)
I $L(T1)>0 W " ",T1
S T1=$P(TEMP,U,5)
I $L(T1)>0 W " ",T1
S T1=$P(TEMP,U,7)
I $L(T1)>0 W " ",T1
S T1=$P(TEMP,U,8)
I $L(T1)>0 W " ",T1
Q
;
;=======================================================================
PPRINT ;Print the information for a patient.
N DATE,DXLS,EM,IC,JC,NEWPAGE,PV,ST
I $Y>(IOSL-BMARG-5) S NEWPAGE=1
E S NEWPAGE=0
D PHEAD(NEWPAGE)
I DONE Q
;Appointments
I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"APPT")) D
. I $Y>(IOSL-BMARG-2) D PHEAD(1)
. I DONE Q
. W !!,?C1HS,"Appointment criteria met:"
. S IC=0
. F S IC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"APPT",IC)) Q:(+IC=0)!(DONE) D
.. S TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"APPT",IC)
..;We are not currently displaying status, but save this code in case
..;it is needed later.
.. ;S ST=$P(TEMP,U,1)
.. ;I $L(ST)=0 S ST=0
.. ;I '$D(STATUS(ST)) S STATUS(ST)=$$EXTERNAL^DILFD(2.98,3,"",ST,.EM)
.. S PV=$P(TEMP,U,2)
.. I '$D(POV(PV)) S POV(PV)=$$EXTERNAL^DILFD(2.98,9,"",PV,.EM)
.. S DATE=$$FMTE^XLFDT(IC,"5F")
.. S DATE=$TR(DATE,"@"," ")
.. I $Y>(IOSL-BMARG) D
... D PHEAD(1)
... I 'DONE W !!,?C1HS,"Appointment criteria met:"
.. I 'DONE W !,?C1S,DATE,?C2S,HLOCNAM,?C3S,POV(PV)
I DONE Q
;
;Future appointments
I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"FUT")) D
. I $Y>(IOSL-BMARG-2) D PHEAD(1)
. I DONE Q
. W !!,?C1HS,"Future Appointments:"
. S IC=0
. F S IC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"FUT",IC)) Q:(+IC=0)!(DONE) D
.. S TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"FUT",IC)
.. S DATE=$P(TEMP,U,1)
.. S LOC=$P(TEMP,U,2)
.. S TYPE=$P(TEMP,U,4)
.. I $Y>(IOSL-BMARG) D
... D PHEAD(1)
... I 'DONE W !!,?C1HS,"Future Appointments:"
.. I 'DONE W !,?C1S,DATE,?C2S,LOC,?C3S,TYPE
I DONE Q
;
;Admission and discharge information.
I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS")) D
. N NEEDBL
. I $Y>(IOSL-BMARG-2) D PHEAD(1)
. I DONE Q
. W ! D SHEAD(C1HS,"Inpatient Stays","-")
. S NEEDBL=0
. S IC=""
. F S IC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",IC)) Q:(+IC=0)!(DONE) D
.. S JC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",IC,""))
.. S DATE=$$FMTE^XLFDT(IC,"5DF")
.. I $L(JC)>0 S DISDATE=$$FMTE^XLFDT(JC,"5DF")
.. E S DISDATE=""
.. S LOS=$$FMDIFF^XLFDT(JC,IC,1)
..;If IC<0 then we have a discharge without any admission informtion.
.. I IC["NA" D
... S DATE=" Unknown"
... S LOS=""
..;A patient that has not been discharged will be flagged with a
..;discharge date of DT+1.
.. I JC>DT D
... S DISDATE="present"
... S LOS=LOS-1
.. S TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",IC,JC)
.. I $Y>(IOSL-BMARG) D
... D PHEAD(1)
... I 'DONE D
.... W ! D SHEAD(C1HS,"Inpatient Stays","-")
.... S NEEDBL=0
.. I 'DONE D
... I NEEDBL W !
... W !,?C1S,DATE," - ",DISDATE,?C2S,$P(TEMP,U,1),?C3S,"LOS: ",LOS
... W !,?C1S," Last Tr. Specialty: ",?C2S,$P(TEMP,U,2)
... W ?C3S,"Last Prov: ",$P($P(TEMP,U,3),",",1)
... W !,?C1S,"Admitting Diagnosis: ",?C2S,$P(TEMP,U,4)
... S DXLS=$P(TEMP,U,5)
... I $L(DXLS)>0 W !,?(C1S+15),"DXLS:",?C2S,DXLS
... S NEEDBL=1
I DONE Q
;
;Emergency room visits
I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ER")) D
. I $Y>(IOSL-BMARG-2) D PHEAD(1)
. I DONE Q
. W ! D SHEAD(C1HS,"Emergency Room Visits","-")
. S IC=0
. F S IC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ER",IC)) Q:(+IC=0)!(DONE) D
.. S TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ER",IC)
.. S DATE=$$FMTE^XLFDT(IC,"5F")
.. S DATE=$TR(DATE,"@"," ")
.. I $Y>(IOSL-BMARG) D
... D PHEAD(1)
... I 'DONE W ! D SHEAD(C1HS,"Emergency Room Visits","-")
.. I 'DONE W !?C1S,DATE,?C2S,$P(TEMP,U,2)
I DONE Q
;
;Critical Lab values.
I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB")) D
. I $Y>(IOSL-BMARG-2) D PHEAD(1)
. I DONE Q
. W ! D SHEAD(C1HS,"Critical Lab Values","-")
. S IC=0
. F S IC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB",IC)) Q:(+IC=0)!(DONE) D
.. S JC=0
.. F S JC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB",IC,JC)) Q:+JC=0 D
... S TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB",IC,JC)
... S DATE=$$FMTE^XLFDT(IC,"5F")
... S DATE=$TR(DATE,"@"," ")
... I $Y>(IOSL-BMARG) D
.... D PHEAD(1)
.... I 'DONE W ! D SHEAD(C1HS,"Critical Lab Values","-")
... I 'DONE W !,?C1S,DATE,?C2S,$P(TEMP,U,1),?C3S,$P(TEMP,U,2)," ",$P(TEMP,U,4)
Q
;
;=======================================================================
SHEAD(INDENT,TEXT,FC) ;Write a section header. INDENT is the number
;of spaces to indent on both the left and right, TEXT is the text, and
;FC is the fill character.
N FILLEND,FILLLEN,HEAD,IC,LINELEN,PTEXT,TEXTLEN
S PTEXT=" "_TEXT_" "
S TEXTLEN=$L(PTEXT)
S LINELEN=IOM-(2*INDENT)
S FILLLEN=LINELEN-TEXTLEN
S FILLEND=INDENT+(FILLLEN\2)
I FILLLEN>1 D
.S HEAD=""
.F IC=INDENT:1:FILLEND D
.. S HEAD=HEAD_FC
.S HEAD=HEAD_PTEXT
.F IC=($L(HEAD)+1):1:LINELEN D
.. S HEAD=HEAD_FC
. W !,?INDENT,HEAD
E D
. S IC=(IOM-$L(TEXT))\2
. W !,?IC,TEXT
Q
;
PXRRPAPR ;ISL/PKR - Patient activity report print. ;8/26/97
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**18,47**;Aug 12, 1996
+2 ;
+3 NEW BMARG,C1S,C2S,C3S,C1HS,HEAD,INDENT,PAGE
+4 NEW CLIEN,CSTOP,DATE,DISDATE,DFN,DONE,ED
+5 NEW FACIEN,FACILITY,FACPNAME,HLOC,HLOCIEN,HLOCNAM
+6 NEW IC,JC,LOC,LOS
+7 NEW NAME,POV,SD,SSN,STATUS,TEMP
+8 ;
+9 ;Allow the task to be cleaned up upon successful completion.
+10 SET ZTREQ="@"
+11 ;
+12 USE IO
+13 SET DONE=0
+14 ;Setup the formatting parameters.
+15 SET INDENT=2
+16 SET C1HS=INDENT
+17 SET C1S=C1HS+1
+18 SET C2S=C1S+22
+19 SET C3S=C2S+32
+20 ;
+21 SET HEAD=1
+22 SET PAGE=0
+23 IF ($EXTRACT(IOST)="C")&(IO=IO(0))
SET BMARG=3
+24 IF '$TEST
SET BMARG=2
+25 IF 'PXRRLCNP
DO MHEAD(1)
+26 ;
+27 SET STATUS(0)="CANCELED OR NO-SHOWED"
+28 ;
SET ;Set up print fields
+1 SET FACILITY=0
NFAC SET FACILITY=$ORDER(^XTMP(PXRRXTMP,"ALPHA",FACILITY))
+1 IF FACILITY=""
GOTO FINAL
+2 SET HEAD=1
+3 SET FACIEN=$PIECE(FACILITY,U,3)
+4 SET FACPNAME=$PIECE(FACILITY,U,1)_" "_$PIECE(FACILITY,U,2)
+5 ;Keep track of the facilities that were found.
+6 FOR IC=1:1:NFAC
IF $PIECE(PXRRFAC(IC),U,1)=FACIEN
Begin DoDot:1
+7 SET $PIECE(PXRRFAC(IC),U,4)="M"
End DoDot:1
QUIT
+8 ;
+9 SET HLOC=""
NHLOC SET HLOC=$ORDER(^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC))
+1 IF HLOC=""
GOTO NFAC
+2 SET HLOCNAM=$PIECE(HLOC,U,1)
+3 SET HLOCIEN=$PIECE(HLOC,U,2)
+4 SET CLIEN=$PIECE(^SC(HLOCIEN,0),U,7)
+5 SET CSTOP=" ("_$PIECE(^DIC(40.7,CLIEN,0),U,2)_")"
+6 ;If the user requested it start a new page.
+7 IF PXRRLCNP
DO MHEAD(1)
+8 DO HEAD(0)
+9 ;
+10 ;Check for a user request to stop the task.
+11 IF $$S^%ZTLOAD
SET ZTSTOP=1
GOTO EXIT
+12 ;
+13 SET NAME=""
NPAT ;
+1 SET NAME=$ORDER(^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC,NAME))
+2 IF NAME=""
GOTO NHLOC
+3 SET SSN=""
SET SSN=$ORDER(^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC,NAME,SSN))
+4 SET DFN=^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC,NAME,SSN)
+5 DO PPRINT
+6 IF DONE
GOTO EXIT
+7 GOTO NPAT
+8 ;
FINAL ;Check for facilities that were listed but had no encounters.
+1 IF $Y>(IOSL-BMARG-3)
DO PAGE
+2 DO FACNE^PXRRGPRT(INDENT)
EXIT ;
+1 DO EXIT^PXRRGUT
+2 DO EOR^PXRRGUT
+3 QUIT
+4 ;
+5 ;=======================================================================
HEAD(NEWPAGE) ;
+1 IF NEWPAGE
DO PAGE
+2 IF '$TEST
IF $Y>(IOSL-BMARG)
DO PAGE
+3 IF DONE
QUIT
+4 IF HEAD
Begin DoDot:1
+5 NEW CEN,LEN
+6 SET LEN=$$MAX^XLFMTH($LENGTH(FACPNAME),$LENGTH(HLOCNAM))+10
+7 SET CEN=(IOM-LEN)/2
+8 WRITE !!,?CEN,"Facility: ",FACPNAME
+9 WRITE !,?CEN,"Location: ",HLOCNAM,CSTOP
+10 SET HEAD=0
End DoDot:1
+11 QUIT
+12 ;
+13 ;=======================================================================
MHEAD(NEWPAGE) ;Write the main report header.
+1 IF NEWPAGE
DO PAGE
+2 IF '$TEST
IF $Y>(IOSL-BMARG)
DO PAGE
+3 WRITE !!,"Criteria for Patient Activity Report"
+4 WRITE !?INDENT,"Location selection criteria:",?35,$PIECE(PXRRLCSC,U,2)
+5 SET SD=$$FMTE^XLFDT(PXRRBADT)
+6 SET ED=$$FMTE^XLFDT(PXRREADT)
+7 WRITE !?INDENT,"Patient appointment date range:",?35,SD," through ",ED
+8 SET SD=$$FMTE^XLFDT(PXRRBCDT)
+9 SET ED=$$FMTE^XLFDT(PXRRECDT)
+10 WRITE !?INDENT,"Patient activity date range:",?35,SD," through ",ED
+11 SET SD=$$FMTE^XLFDT(PXRRBFDT)
+12 SET ED=$$FMTE^XLFDT(PXRREFDT)
+13 WRITE !?INDENT,"Future appointment date range:",?35,SD," through ",ED
+14 WRITE !,"____________________________________________________________________"
+15 QUIT
+16 ;
+17 ;=======================================================================
PAGE ;form feed to new page
+1 IF ($EXTRACT(IOST)="C")&(IO=IO(0))
Begin DoDot:1
+2 SET DIR(0)="E"
+3 WRITE !
+4 DO ^DIR
KILL DIR
End DoDot:1
+5 IF $DATA(DIROUT)!$DATA(DUOUT)!($DATA(DTOUT))
SET DONE=1
QUIT
+6 IF $DATA(IOF)
WRITE @IOF
+7 SET PAGE=PAGE+1
+8 DO HDR^PXRRGPRT(PAGE)
+9 SET HEAD=1
+10 QUIT
+11 ;
+12 ;=======================================================================
PHEAD(NEWPAGE) ;Print the patient header
+1 DO HEAD(NEWPAGE)
+2 IF DONE
QUIT
+3 NEW C2S,C3S,T1,TEMP
+4 SET TEMP=^XTMP(PXRRXTMP,"PATIENT",DFN)
+5 SET C2S=$LENGTH(NAME)+5
+6 SET C3S=C2S+14
+7 WRITE !,"_______________________________________________________________________________"
+8 WRITE !,NAME,?C2S,$PIECE(TEMP,U,1),?C3S,$PIECE(TEMP,U,9)
+9 WRITE !
+10 SET T1=$PIECE(TEMP,U,2)
+11 IF $LENGTH(T1)>0
WRITE T1
+12 SET T1=$PIECE(TEMP,U,3)
+13 IF $LENGTH(T1)>0
WRITE " ",T1
+14 SET T1=$PIECE(TEMP,U,4)
+15 IF $LENGTH(T1)>0
WRITE " ",T1
+16 SET T1=$PIECE(TEMP,U,5)
+17 IF $LENGTH(T1)>0
WRITE " ",T1
+18 SET T1=$PIECE(TEMP,U,7)
+19 IF $LENGTH(T1)>0
WRITE " ",T1
+20 SET T1=$PIECE(TEMP,U,8)
+21 IF $LENGTH(T1)>0
WRITE " ",T1
+22 QUIT
+23 ;
+24 ;=======================================================================
PPRINT ;Print the information for a patient.
+1 NEW DATE,DXLS,EM,IC,JC,NEWPAGE,PV,ST
+2 IF $Y>(IOSL-BMARG-5)
SET NEWPAGE=1
+3 IF '$TEST
SET NEWPAGE=0
+4 DO PHEAD(NEWPAGE)
+5 IF DONE
QUIT
+6 ;Appointments
+7 IF $DATA(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"APPT"))
Begin DoDot:1
+8 IF $Y>(IOSL-BMARG-2)
DO PHEAD(1)
+9 IF DONE
QUIT
+10 WRITE !!,?C1HS,"Appointment criteria met:"
+11 SET IC=0
+12 FOR
SET IC=$ORDER(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"APPT",IC))
IF (+IC=0)!(DONE)
QUIT
Begin DoDot:2
+13 SET TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"APPT",IC)
+14 ;We are not currently displaying status, but save this code in case
+15 ;it is needed later.
+16 ;S ST=$P(TEMP,U,1)
+17 ;I $L(ST)=0 S ST=0
+18 ;I '$D(STATUS(ST)) S STATUS(ST)=$$EXTERNAL^DILFD(2.98,3,"",ST,.EM)
+19 SET PV=$PIECE(TEMP,U,2)
+20 IF '$DATA(POV(PV))
SET POV(PV)=$$EXTERNAL^DILFD(2.98,9,"",PV,.EM)
+21 SET DATE=$$FMTE^XLFDT(IC,"5F")
+22 SET DATE=$TRANSLATE(DATE,"@"," ")
+23 IF $Y>(IOSL-BMARG)
Begin DoDot:3
+24 DO PHEAD(1)
+25 IF 'DONE
WRITE !!,?C1HS,"Appointment criteria met:"
End DoDot:3
+26 IF 'DONE
WRITE !,?C1S,DATE,?C2S,HLOCNAM,?C3S,POV(PV)
End DoDot:2
End DoDot:1
+27 IF DONE
QUIT
+28 ;
+29 ;Future appointments
+30 IF $DATA(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"FUT"))
Begin DoDot:1
+31 IF $Y>(IOSL-BMARG-2)
DO PHEAD(1)
+32 IF DONE
QUIT
+33 WRITE !!,?C1HS,"Future Appointments:"
+34 SET IC=0
+35 FOR
SET IC=$ORDER(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"FUT",IC))
IF (+IC=0)!(DONE)
QUIT
Begin DoDot:2
+36 SET TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"FUT",IC)
+37 SET DATE=$PIECE(TEMP,U,1)
+38 SET LOC=$PIECE(TEMP,U,2)
+39 SET TYPE=$PIECE(TEMP,U,4)
+40 IF $Y>(IOSL-BMARG)
Begin DoDot:3
+41 DO PHEAD(1)
+42 IF 'DONE
WRITE !!,?C1HS,"Future Appointments:"
End DoDot:3
+43 IF 'DONE
WRITE !,?C1S,DATE,?C2S,LOC,?C3S,TYPE
End DoDot:2
End DoDot:1
+44 IF DONE
QUIT
+45 ;
+46 ;Admission and discharge information.
+47 IF $DATA(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS"))
Begin DoDot:1
+48 NEW NEEDBL
+49 IF $Y>(IOSL-BMARG-2)
DO PHEAD(1)
+50 IF DONE
QUIT
+51 WRITE !
DO SHEAD(C1HS,"Inpatient Stays","-")
+52 SET NEEDBL=0
+53 SET IC=""
+54 FOR
SET IC=$ORDER(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",IC))
IF (+IC=0)!(DONE)
QUIT
Begin DoDot:2
+55 SET JC=$ORDER(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",IC,""))
+56 SET DATE=$$FMTE^XLFDT(IC,"5DF")
+57 IF $LENGTH(JC)>0
SET DISDATE=$$FMTE^XLFDT(JC,"5DF")
+58 IF '$TEST
SET DISDATE=""
+59 SET LOS=$$FMDIFF^XLFDT(JC,IC,1)
+60 ;If IC<0 then we have a discharge without any admission informtion.
+61 IF IC["NA"
Begin DoDot:3
+62 SET DATE=" Unknown"
+63 SET LOS=""
End DoDot:3
+64 ;A patient that has not been discharged will be flagged with a
+65 ;discharge date of DT+1.
+66 IF JC>DT
Begin DoDot:3
+67 SET DISDATE="present"
+68 SET LOS=LOS-1
End DoDot:3
+69 SET TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",IC,JC)
+70 IF $Y>(IOSL-BMARG)
Begin DoDot:3
+71 DO PHEAD(1)
+72 IF 'DONE
Begin DoDot:4
+73 WRITE !
DO SHEAD(C1HS,"Inpatient Stays","-")
+74 SET NEEDBL=0
End DoDot:4
End DoDot:3
+75 IF 'DONE
Begin DoDot:3
+76 IF NEEDBL
WRITE !
+77 WRITE !,?C1S,DATE," - ",DISDATE,?C2S,$PIECE(TEMP,U,1),?C3S,"LOS: ",LOS
+78 WRITE !,?C1S," Last Tr. Specialty: ",?C2S,$PIECE(TEMP,U,2)
+79 WRITE ?C3S,"Last Prov: ",$PIECE($PIECE(TEMP,U,3),",",1)
+80 WRITE !,?C1S,"Admitting Diagnosis: ",?C2S,$PIECE(TEMP,U,4)
+81 SET DXLS=$PIECE(TEMP,U,5)
+82 IF $LENGTH(DXLS)>0
WRITE !,?(C1S+15),"DXLS:",?C2S,DXLS
+83 SET NEEDBL=1
End DoDot:3
End DoDot:2
End DoDot:1
+84 IF DONE
QUIT
+85 ;
+86 ;Emergency room visits
+87 IF $DATA(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ER"))
Begin DoDot:1
+88 IF $Y>(IOSL-BMARG-2)
DO PHEAD(1)
+89 IF DONE
QUIT
+90 WRITE !
DO SHEAD(C1HS,"Emergency Room Visits","-")
+91 SET IC=0
+92 FOR
SET IC=$ORDER(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ER",IC))
IF (+IC=0)!(DONE)
QUIT
Begin DoDot:2
+93 SET TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ER",IC)
+94 SET DATE=$$FMTE^XLFDT(IC,"5F")
+95 SET DATE=$TRANSLATE(DATE,"@"," ")
+96 IF $Y>(IOSL-BMARG)
Begin DoDot:3
+97 DO PHEAD(1)
+98 IF 'DONE
WRITE !
DO SHEAD(C1HS,"Emergency Room Visits","-")
End DoDot:3
+99 IF 'DONE
WRITE !?C1S,DATE,?C2S,$PIECE(TEMP,U,2)
End DoDot:2
End DoDot:1
+100 IF DONE
QUIT
+101 ;
+102 ;Critical Lab values.
+103 IF $DATA(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB"))
Begin DoDot:1
+104 IF $Y>(IOSL-BMARG-2)
DO PHEAD(1)
+105 IF DONE
QUIT
+106 WRITE !
DO SHEAD(C1HS,"Critical Lab Values","-")
+107 SET IC=0
+108 FOR
SET IC=$ORDER(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB",IC))
IF (+IC=0)!(DONE)
QUIT
Begin DoDot:2
+109 SET JC=0
+110 FOR
SET JC=$ORDER(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB",IC,JC))
IF +JC=0
QUIT
Begin DoDot:3
+111 SET TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB",IC,JC)
+112 SET DATE=$$FMTE^XLFDT(IC,"5F")
+113 SET DATE=$TRANSLATE(DATE,"@"," ")
+114 IF $Y>(IOSL-BMARG)
Begin DoDot:4
+115 DO PHEAD(1)
+116 IF 'DONE
WRITE !
DO SHEAD(C1HS,"Critical Lab Values","-")
End DoDot:4
+117 IF 'DONE
WRITE !,?C1S,DATE,?C2S,$PIECE(TEMP,U,1),?C3S,$PIECE(TEMP,U,2)," ",$PIECE(TEMP,U,4)
End DoDot:3
End DoDot:2
End DoDot:1
+118 QUIT
+119 ;
+120 ;=======================================================================
SHEAD(INDENT,TEXT,FC) ;Write a section header. INDENT is the number
+1 ;of spaces to indent on both the left and right, TEXT is the text, and
+2 ;FC is the fill character.
+3 NEW FILLEND,FILLLEN,HEAD,IC,LINELEN,PTEXT,TEXTLEN
+4 SET PTEXT=" "_TEXT_" "
+5 SET TEXTLEN=$LENGTH(PTEXT)
+6 SET LINELEN=IOM-(2*INDENT)
+7 SET FILLLEN=LINELEN-TEXTLEN
+8 SET FILLEND=INDENT+(FILLLEN\2)
+9 IF FILLLEN>1
Begin DoDot:1
+10 SET HEAD=""
+11 FOR IC=INDENT:1:FILLEND
Begin DoDot:2
+12 SET HEAD=HEAD_FC
End DoDot:2
+13 SET HEAD=HEAD_PTEXT
+14 FOR IC=($LENGTH(HEAD)+1):1:LINELEN
Begin DoDot:2
+15 SET HEAD=HEAD_FC
End DoDot:2
+16 WRITE !,?INDENT,HEAD
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 SET IC=(IOM-$LENGTH(TEXT))\2
+19 WRITE !,?IC,TEXT
End DoDot:1
+20 QUIT
+21 ;
