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

PXRRPAPR.m

Go to the documentation of this file. 
  1. PXRRPAPR ;ISL/PKR - Patient activity report print. ;8/26/97
  1.  ;;1.0;PCE PATIENT CARE ENCOUNTER;**18,47**;Aug 12, 1996
  1.  ;
  1.  N BMARG,C1S,C2S,C3S,C1HS,HEAD,INDENT,PAGE
  1.  N CLIEN,CSTOP,DATE,DISDATE,DFN,DONE,ED
  1.  N FACIEN,FACILITY,FACPNAME,HLOC,HLOCIEN,HLOCNAM
  1.  N IC,JC,LOC,LOS
  1.  N NAME,POV,SD,SSN,STATUS,TEMP
  1.  ;
  1.  ;Allow the task to be cleaned up upon successful completion.
  1.  S ZTREQ="@"
  1.  ;
  1.  U IO
  1.  S DONE=0
  1.  ;Setup the formatting parameters.
  1.  S INDENT=2
  1.  S C1HS=INDENT
  1.  S C1S=C1HS+1
  1.  S C2S=C1S+22
  1.  S C3S=C2S+32
  1.  ;
  1.  S HEAD=1
  1.  S PAGE=0
  1.  I ($E(IOST)="C")&(IO=IO(0)) S BMARG=3
  1.  E  S BMARG=2
  1.  I 'PXRRLCNP D MHEAD(1)
  1.  ;
  1.  S STATUS(0)="CANCELED OR NO-SHOWED"
  1.  ;
  1. SET ;Set up print fields
  1.  S FACILITY=0
  1. NFAC S FACILITY=$O(^XTMP(PXRRXTMP,"ALPHA",FACILITY))
  1.  I FACILITY="" G FINAL
  1.  S HEAD=1
  1.  S FACIEN=$P(FACILITY,U,3)
  1.  S FACPNAME=$P(FACILITY,U,1)_"  "_$P(FACILITY,U,2)
  1.  ;Keep track of the facilities that were found.
  1.  F IC=1:1:NFAC I $P(PXRRFAC(IC),U,1)=FACIEN D  Q
  1.  . S $P(PXRRFAC(IC),U,4)="M"
  1.  ;
  1.  S HLOC=""
  1. NHLOC S HLOC=$O(^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC))
  1.  I HLOC="" G NFAC
  1.  S HLOCNAM=$P(HLOC,U,1)
  1.  S HLOCIEN=$P(HLOC,U,2)
  1.  S CLIEN=$P(^SC(HLOCIEN,0),U,7)
  1.  S CSTOP=" ("_$P(^DIC(40.7,CLIEN,0),U,2)_")"
  1.  ;If the user requested it start a new page.
  1.  I PXRRLCNP D MHEAD(1)
  1.  D HEAD(0)
  1.  ;
  1.  ;Check for a user request to stop the task.
  1.  I $$S^%ZTLOAD S ZTSTOP=1 G EXIT
  1.  ;
  1.  S NAME=""
  1. NPAT ;
  1.  S NAME=$O(^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC,NAME))
  1.  I NAME="" G NHLOC
  1.  S SSN="",SSN=$O(^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC,NAME,SSN))
  1.  S DFN=^XTMP(PXRRXTMP,"ALPHA",FACILITY,HLOC,NAME,SSN)
  1.  D PPRINT
  1.  I DONE G EXIT
  1.  G NPAT
  1.  ;
  1. FINAL ;Check for facilities that were listed but had no encounters.
  1.  I $Y>(IOSL-BMARG-3) D PAGE
  1.  D FACNE^PXRRGPRT(INDENT)
  1. EXIT ;
  1.  D EXIT^PXRRGUT
  1.  D EOR^PXRRGUT
  1.  Q
  1.  ;
  1.  ;=======================================================================
  1.  I NEWPAGE D PAGE
  1.  E  I $Y>(IOSL-BMARG) D PAGE
  1.  I DONE Q
  1.  I HEAD D
  1.  . N CEN,LEN
  1.  . S LEN=$$MAX^XLFMTH($L(FACPNAME),$L(HLOCNAM))+10
  1.  . S CEN=(IOM-LEN)/2
  1.  . W !!,?CEN,"Facility: ",FACPNAME
  1.  . W !,?CEN,"Location: ",HLOCNAM,CSTOP
  1.  . S HEAD=0
  1.  Q
  1.  ;
  1.  ;=======================================================================
  1. MHEAD(NEWPAGE) ;Write the main report header.
  1.  I NEWPAGE D PAGE
  1.  E  I $Y>(IOSL-BMARG) D PAGE
  1.  W !!,"Criteria for Patient Activity Report"
  1.  W !?INDENT,"Location selection criteria:",?35,$P(PXRRLCSC,U,2)
  1.  S SD=$$FMTE^XLFDT(PXRRBADT)
  1.  S ED=$$FMTE^XLFDT(PXRREADT)
  1.  W !?INDENT,"Patient appointment date range:",?35,SD," through ",ED
  1.  S SD=$$FMTE^XLFDT(PXRRBCDT)
  1.  S ED=$$FMTE^XLFDT(PXRRECDT)
  1.  W !?INDENT,"Patient activity date range:",?35,SD," through ",ED
  1.  S SD=$$FMTE^XLFDT(PXRRBFDT)
  1.  S ED=$$FMTE^XLFDT(PXRREFDT)
  1.  W !?INDENT,"Future appointment date range:",?35,SD," through ",ED
  1.  W !,"____________________________________________________________________"
  1.  Q
  1.  ;
  1.  ;=======================================================================
  1. PAGE ;form feed to new page
  1.  I ($E(IOST)="C")&(IO=IO(0)) D
  1.  . S DIR(0)="E"
  1.  . W !
  1.  . D ^DIR K DIR
  1.  I $D(DIROUT)!$D(DUOUT)!($D(DTOUT)) S DONE=1 Q
  1.  W:$D(IOF) @IOF
  1.  S PAGE=PAGE+1
  1.  D HDR^PXRRGPRT(PAGE)
  1.  S HEAD=1
  1.  Q
  1.  ;
  1.  ;=======================================================================
  1. PHEAD(NEWPAGE) ;Print the patient header
  1.  D HEAD(NEWPAGE)
  1.  I DONE Q
  1.  N C2S,C3S,T1,TEMP
  1.  S TEMP=^XTMP(PXRRXTMP,"PATIENT",DFN)
  1.  S C2S=$L(NAME)+5
  1.  S C3S=C2S+14
  1.  W !,"_______________________________________________________________________________"
  1.  W !,NAME,?C2S,$P(TEMP,U,1),?C3S,$P(TEMP,U,9)
  1.  W !
  1.  S T1=$P(TEMP,U,2)
  1.  I $L(T1)>0 W T1
  1.  S T1=$P(TEMP,U,3)
  1.  I $L(T1)>0 W "  ",T1
  1.  S T1=$P(TEMP,U,4)
  1.  I $L(T1)>0 W "  ",T1
  1.  S T1=$P(TEMP,U,5)
  1.  I $L(T1)>0 W "  ",T1
  1.  S T1=$P(TEMP,U,7)
  1.  I $L(T1)>0 W "  ",T1
  1.  S T1=$P(TEMP,U,8)
  1.  I $L(T1)>0 W "  ",T1
  1.  Q
  1.  ;
  1.  ;=======================================================================
  1. PPRINT ;Print the information for a patient.
  1.  N DATE,DXLS,EM,IC,JC,NEWPAGE,PV,ST
  1.  I $Y>(IOSL-BMARG-5) S NEWPAGE=1
  1.  E  S NEWPAGE=0
  1.  D PHEAD(NEWPAGE)
  1.  I DONE Q
  1.  ;Appointments
  1.  I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"APPT")) D
  1.  . I $Y>(IOSL-BMARG-2) D PHEAD(1)
  1.  . I DONE Q
  1.  . W !!,?C1HS,"Appointment criteria met:"
  1.  . S IC=0
  1.  . F  S IC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"APPT",IC)) Q:(+IC=0)!(DONE)  D
  1.  .. S TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"APPT",IC)
  1.  ..;We are not currently displaying status, but save this code in case
  1.  ..;it is needed later.
  1.  .. ;S ST=$P(TEMP,U,1)
  1.  .. ;I $L(ST)=0 S ST=0
  1.  .. ;I '$D(STATUS(ST)) S STATUS(ST)=$$EXTERNAL^DILFD(2.98,3,"",ST,.EM)
  1.  .. S PV=$P(TEMP,U,2)
  1.  .. I '$D(POV(PV)) S POV(PV)=$$EXTERNAL^DILFD(2.98,9,"",PV,.EM)
  1.  .. S DATE=$$FMTE^XLFDT(IC,"5F")
  1.  .. S DATE=$TR(DATE,"@"," ")
  1.  .. I $Y>(IOSL-BMARG) D
  1.  ... D PHEAD(1)
  1.  ... I 'DONE W !!,?C1HS,"Appointment criteria met:"
  1.  .. I 'DONE W !,?C1S,DATE,?C2S,HLOCNAM,?C3S,POV(PV)
  1.  I DONE Q
  1.  ;
  1.  ;Future appointments
  1.  I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"FUT")) D
  1.  . I $Y>(IOSL-BMARG-2) D PHEAD(1)
  1.  . I DONE Q
  1.  . W !!,?C1HS,"Future Appointments:"
  1.  . S IC=0
  1.  . F  S IC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"FUT",IC)) Q:(+IC=0)!(DONE)  D
  1.  .. S TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"FUT",IC)
  1.  .. S DATE=$P(TEMP,U,1)
  1.  .. S LOC=$P(TEMP,U,2)
  1.  .. S TYPE=$P(TEMP,U,4)
  1.  .. I $Y>(IOSL-BMARG) D
  1.  ... D PHEAD(1)
  1.  ... I 'DONE W !!,?C1HS,"Future Appointments:"
  1.  .. I 'DONE W !,?C1S,DATE,?C2S,LOC,?C3S,TYPE
  1.  I DONE Q
  1.  ;
  1.  ;Admission and discharge information.
  1.  I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS")) D
  1.  . N NEEDBL
  1.  . I $Y>(IOSL-BMARG-2) D PHEAD(1)
  1.  . I DONE Q
  1.  . W ! D SHEAD(C1HS,"Inpatient Stays","-")
  1.  . S NEEDBL=0
  1.  . S IC=""
  1.  . F  S IC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",IC)) Q:(+IC=0)!(DONE)  D
  1.  .. S JC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",IC,""))
  1.  .. S DATE=$$FMTE^XLFDT(IC,"5DF")
  1.  .. I $L(JC)>0 S DISDATE=$$FMTE^XLFDT(JC,"5DF")
  1.  .. E  S DISDATE=""
  1.  .. S LOS=$$FMDIFF^XLFDT(JC,IC,1)
  1.  ..;If IC<0 then we have a discharge without any admission informtion.
  1.  .. I IC["NA" D
  1.  ... S DATE=" Unknown"
  1.  ... S LOS=""
  1.  ..;A patient that has not been discharged will be flagged with a
  1.  ..;discharge date of DT+1.
  1.  .. I JC>DT D
  1.  ... S DISDATE="present"
  1.  ... S LOS=LOS-1
  1.  .. S TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ADMDIS",IC,JC)
  1.  .. I $Y>(IOSL-BMARG) D
  1.  ... D PHEAD(1)
  1.  ... I 'DONE D
  1.  .... W ! D SHEAD(C1HS,"Inpatient Stays","-")
  1.  .... S NEEDBL=0
  1.  .. I 'DONE D
  1.  ... I NEEDBL W !
  1.  ... W !,?C1S,DATE," - ",DISDATE,?C2S,$P(TEMP,U,1),?C3S,"LOS: ",LOS
  1.  ... W !,?C1S," Last Tr. Specialty: ",?C2S,$P(TEMP,U,2)
  1.  ... W ?C3S,"Last Prov: ",$P($P(TEMP,U,3),",",1)
  1.  ... W !,?C1S,"Admitting Diagnosis: ",?C2S,$P(TEMP,U,4)
  1.  ... S DXLS=$P(TEMP,U,5)
  1.  ... I $L(DXLS)>0 W !,?(C1S+15),"DXLS:",?C2S,DXLS
  1.  ... S NEEDBL=1
  1.  I DONE Q
  1.  ;
  1.  ;Emergency room visits
  1.  I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ER")) D
  1.  . I $Y>(IOSL-BMARG-2) D PHEAD(1)
  1.  . I DONE Q
  1.  . W ! D SHEAD(C1HS,"Emergency Room Visits","-")
  1.  . S IC=0
  1.  . F  S IC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ER",IC)) Q:(+IC=0)!(DONE)  D
  1.  .. S TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"ER",IC)
  1.  .. S DATE=$$FMTE^XLFDT(IC,"5F")
  1.  .. S DATE=$TR(DATE,"@"," ")
  1.  .. I $Y>(IOSL-BMARG) D
  1.  ... D PHEAD(1)
  1.  ... I 'DONE W ! D SHEAD(C1HS,"Emergency Room Visits","-")
  1.  .. I 'DONE W !?C1S,DATE,?C2S,$P(TEMP,U,2)
  1.  I DONE Q
  1.  ;
  1.  ;Critical Lab values.
  1.  I $D(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB")) D
  1.  . I $Y>(IOSL-BMARG-2) D PHEAD(1)
  1.  . I DONE Q
  1.  . W ! D SHEAD(C1HS,"Critical Lab Values","-")
  1.  . S IC=0
  1.  . F  S IC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB",IC)) Q:(+IC=0)!(DONE)  D
  1.  .. S JC=0
  1.  .. F  S JC=$O(^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB",IC,JC)) Q:+JC=0  D
  1.  ... S TEMP=^XTMP(PXRRXTMP,FACIEN,HLOCIEN,DFN,"CLAB",IC,JC)
  1.  ... S DATE=$$FMTE^XLFDT(IC,"5F")
  1.  ... S DATE=$TR(DATE,"@"," ")
  1.  ... I $Y>(IOSL-BMARG) D
  1.  .... D PHEAD(1)
  1.  .... I 'DONE W ! D SHEAD(C1HS,"Critical Lab Values","-")
  1.  ... I 'DONE W !,?C1S,DATE,?C2S,$P(TEMP,U,1),?C3S,$P(TEMP,U,2)," ",$P(TEMP,U,4)
  1.  Q
  1.  ;
  1.  ;=======================================================================
  1. 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
  1.  ;FC is the fill character.
  1.  N FILLEND,FILLLEN,HEAD,IC,LINELEN,PTEXT,TEXTLEN
  1.  S PTEXT=" "_TEXT_" "
  1.  S TEXTLEN=$L(PTEXT)
  1.  S LINELEN=IOM-(2*INDENT)
  1.  S FILLLEN=LINELEN-TEXTLEN
  1.  S FILLEND=INDENT+(FILLLEN\2)
  1.  I FILLLEN>1 D
  1.  .S HEAD=""
  1.  .F IC=INDENT:1:FILLEND D
  1.  .. S HEAD=HEAD_FC
  1.  .S HEAD=HEAD_PTEXT
  1.  .F IC=($L(HEAD)+1):1:LINELEN D
  1.  .. S HEAD=HEAD_FC
  1.  . W !,?INDENT,HEAD
  1.  E  D
  1.  . S IC=(IOM-$L(TEXT))\2
  1.  . W !,?IC,TEXT
  1.  Q
  1.  ;