PXRRPRSP ;ISL/PKR - Provider encounter summary print. ;6/03/97
;;1.0;PCE PATIENT CARE ENCOUNTER;**3,10,12,18,189**;Aug 12, 1996;Build 13
;
N BMARG,C1S,C3S,C1HS,C2HS,C3HS,C3HSMAX,DONE,HEAD
N INDENT,MID,MEWPAGE,PAGE,PCLMAX,PNMAX
N CLASSNAM,DATE,DAY,DTOTAL,GTOTAL,HLOC
N FACILITY,FACPNAME,FTOTAL
N PCLASS,PNAME,PPNAME,PTOTAL
N TEMP,VACODE,VIEN
;
;Allow the task to be cleaned up upon successful completion.
S ZTREQ="@"
;
U IO
S DONE=0
;Setup the formatting parameters.
S PCLMAX=^XTMP(PXRRXTMP,"PCLMAX")
S PNMAX=^XTMP(PXRRXTMP,"PNMAX")
S INDENT=3
S C1HS=INDENT
S C1S=INDENT
S C2HS=C1S+PNMAX+1
S C3HS=C2HS+PCLMAX+3
S C3HS=$$MAX^XLFMTH((C1HS+45),C3HS)
S C3HSMAX=C2HS+38
;If C3HS>C3HSMAX set it to C3HSMAX+2 and wrap the Person Class entries.
I C3HS>C3HSMAX S C3HS=C3HSMAX+2
;We assume that the counts will never be longer than six digits.
S MID=C3HS+6
;
S (HEAD,PAGE)=1
S BMARG=2
S GTOTAL=0
D HDR^PXRRGPRT(PAGE)
W !!,"Criteria for Provider Encounter Summary Report"
D OPRCRIT^PXRRGPRT(3)
;
SET ;Set up print fields
S FACILITY=0
FAC S FACILITY=$O(^XTMP(PXRRXTMP,FACILITY))
; Fix to include Non-VA facility - *189
I (+FACILITY=0)&(FACILITY'="*") G FINAL
S FTOTAL=0
;Mark the facility as being found.
F IC=1:1:NFAC I $P(PXRRFAC(IC),U,1)=FACILITY D Q
. S $P(PXRRFAC(IC),U,4)="M"
S FACPNAME=$P(PXRRFACN(FACILITY),U,1)_" "_$P(PXRRFACN(FACILITY),U,2)
S HEAD=1
D HEAD
;
S PNAME=0
PRV S PNAME=$O(^XTMP(PXRRXTMP,FACILITY,PNAME))
I PNAME="" D G FAC
. I $Y>(IOSL-BMARG-3) D
.. D PAGE^PXRRGPRT
.. I 'DONE W !!,"Facility: ",FACPNAME
. I 'DONE D
.. S TEMP="Total facility encounters "
.. D PTOTAL^PXRRGPRT(TEMP,FTOTAL,MID,1)
.. S GTOTAL=GTOTAL+FTOTAL
.. I $D(PXRRPECL) D CLASSNE^PXRRGPRT(INDENT)
I DONE G END
S PPNAME=$P(PNAME,U,1)
;
;Check for a user request to stop the task.
I $$S^%ZTLOAD S ZTSTOP=1 D EXIT^PXRRGUT
;
S CLASSNAM=0
CLASS ;
I DONE G END
S CLASSNAM=$O(^XTMP(PXRRXTMP,FACILITY,PNAME,CLASSNAM))
I CLASSNAM="" D G PRV
. K ^TMP(PXRRXTMP,$J,PNAME)
S VACODE=$P(CLASSNAM,U,2)
I $L(VACODE)>0 S PCLASS=$$OCCUP^PXBGPRV("","",VACODE,1)
E S PCLASS=-3
;If were are doing selected person classes keep track of the ones we
;found.
I $D(PXRRPECL) S TEMP=$$MATCH^PXRRPECU(PCLASS)
S DATE=0
;
DATE ;
S DTOTAL=0
S DATE=$O(^XTMP(PXRRXTMP,FACILITY,PNAME,CLASSNAM,DATE))
I DATE="" D G CLASS
.;Print the provider totals.
. D SPRINT(.PTOTAL)
. S FTOTAL=FTOTAL+PTOTAL
I DONE G END
;
S HLOC=0
HLO S HLOC=$O(^XTMP(PXRRXTMP,FACILITY,PNAME,CLASSNAM,DATE,HLOC))
I HLOC="" G DATE
;
;Build a ^TMP array of all the visits for the current provider.
S DAY=$P(DATE,".",1)
S VIEN=0
F S VIEN=$O(^XTMP(PXRRXTMP,FACILITY,PNAME,CLASSNAM,DATE,HLOC,VIEN)) Q:+VIEN=0 D
. S ^TMP(PXRRXTMP,$J,PNAME,DAY,HLOC,VIEN)=""
;
G HLO
;
FINAL ;Print grand totals
S TEMP="Total encounters "
I $Y>(IOSL-BMARG-3) D
. D PAGE^PXRRGPRT
. I 'DONE W !
I 'DONE D
. D PTOTAL^PXRRGPRT(TEMP,GTOTAL,MID,0)
. D FACNE^PXRRGPRT(INDENT)
END ;
D EXIT^PXRRGUT
D EOR^PXRRGUT
Q
;
;=======================================================================
FMTPCL(PCL,START,END,PCL1,PCL2) ;Format the abbreviated Person Class, PCL so
;that it fits between START and END. If it is too long break it into
;two lines, PCL1 and PCL2.
N LBC,LEN,LPLUS,LSPACE,MAXLEN
S MAXLEN=END-START
S LEN=$L(PCL)
I LEN'>MAXLEN D Q
. S PCL1="("_PCL_")"
;PCL is too long to fit on one line find a plus or a space to make the
;break.
S LSPACE=$$LASTCHAR(PCL," ",MAXLEN)
S LPLUS=$$LASTCHAR(PCL,"+",MAXLEN)
S LBC=$$MAX^XLFMTH(LPLUS,LSPACE)
S PCL1="("_$E(PCL,1,LBC)
S PCL2=" "_$E(PCL,LBC+1,LEN)_")"
Q
;
;=======================================================================
HEAD ;If necessary, write the header.
I HEAD D
. I $Y>(IOSL-BMARG-7) D PAGE^PXRRGPRT
. I DONE Q
. W !!,"Facility: ",FACPNAME
. W !!,?(C1HS+20),"Person Class"
. W !,?C1HS,"Provider (Occupation+Specialty+Subspecialty)",?C3HS,"Encounters"
. W !,?C1HS,"--------------------------------------------",?C3HS,"----------"
. S HEAD=0
Q
;
;=======================================================================
LASTCHAR(STRING,CHAR,MAX) ;Return the position of the last character, CHAR, in
;STRING ensuring that it is less than MAX.
;Return 0 if there are none.
N IC0,IC1
S IC0=$F(STRING,CHAR)
I IC0=0 Q 0
F S IC1=$F(STRING,CHAR,IC0) Q:(IC1=0)!(IC1>MAX) D
. S IC0=IC1
Q IC0-1
;
;=======================================================================
SPRINT(PTOTAL) ;Print the provider total and return the total.
N DAY,END,HLOC,PCL1,PCL2,TEMP,VACODE,VIEN
S PTOTAL=0
S DAY=0
NDAY S DAY=$O(^TMP(PXRRXTMP,$J,PNAME,DAY))
I DAY="" D Q
.;No more DAYs to sum over print the total.
. I $Y>(IOSL-BMARG-1) D
.. D PAGE^PXRRGPRT
.. D HEAD
. I 'DONE D
.. S C3S=MID-$L(PTOTAL)
.. S VACODE=$P(CLASSNAM,U,2)
.. S TEMP=$$ABBRV^PXRRPECU(VACODE)
.. D FMTPCL(TEMP,C2HS,C3HSMAX,.PCL1,.PCL2)
.. W !,?C1S,PPNAME,?C2HS,PCL1,?C3S,PTOTAL
.. I $D(PCL2) W !,?C2HS,PCL2
I DONE Q
;
S HLOC=""
NHLOC S HLOC=$O(^TMP(PXRRXTMP,$J,PNAME,DAY,HLOC))
I HLOC="" G NDAY
;
S VIEN=0
NVIEN S VIEN=$O(^TMP(PXRRXTMP,$J,PNAME,DAY,HLOC,VIEN))
I VIEN="" G NHLOC
S PTOTAL=PTOTAL+1
G NVIEN
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRRPRSP 5364 printed Apr 09, 2024@21:34:18 Page 2
PXRRPRSP ;ISL/PKR - Provider encounter summary print. ;6/03/97
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**3,10,12,18,189**;Aug 12, 1996;Build 13
+2 ;
+3 NEW BMARG,C1S,C3S,C1HS,C2HS,C3HS,C3HSMAX,DONE,HEAD
+4 NEW INDENT,MID,MEWPAGE,PAGE,PCLMAX,PNMAX
+5 NEW CLASSNAM,DATE,DAY,DTOTAL,GTOTAL,HLOC
+6 NEW FACILITY,FACPNAME,FTOTAL
+7 NEW PCLASS,PNAME,PPNAME,PTOTAL
+8 NEW TEMP,VACODE,VIEN
+9 ;
+10 ;Allow the task to be cleaned up upon successful completion.
+11 SET ZTREQ="@"
+12 ;
+13 USE IO
+14 SET DONE=0
+15 ;Setup the formatting parameters.
+16 SET PCLMAX=^XTMP(PXRRXTMP,"PCLMAX")
+17 SET PNMAX=^XTMP(PXRRXTMP,"PNMAX")
+18 SET INDENT=3
+19 SET C1HS=INDENT
+20 SET C1S=INDENT
+21 SET C2HS=C1S+PNMAX+1
+22 SET C3HS=C2HS+PCLMAX+3
+23 SET C3HS=$$MAX^XLFMTH((C1HS+45),C3HS)
+24 SET C3HSMAX=C2HS+38
+25 ;If C3HS>C3HSMAX set it to C3HSMAX+2 and wrap the Person Class entries.
+26 IF C3HS>C3HSMAX
SET C3HS=C3HSMAX+2
+27 ;We assume that the counts will never be longer than six digits.
+28 SET MID=C3HS+6
+29 ;
+30 SET (HEAD,PAGE)=1
+31 SET BMARG=2
+32 SET GTOTAL=0
+33 DO HDR^PXRRGPRT(PAGE)
+34 WRITE !!,"Criteria for Provider Encounter Summary Report"
+35 DO OPRCRIT^PXRRGPRT(3)
+36 ;
SET ;Set up print fields
+1 SET FACILITY=0
FAC SET FACILITY=$ORDER(^XTMP(PXRRXTMP,FACILITY))
+1 ; Fix to include Non-VA facility - *189
+2 IF (+FACILITY=0)&(FACILITY'="*")
GOTO FINAL
+3 SET FTOTAL=0
+4 ;Mark the facility as being found.
+5 FOR IC=1:1:NFAC
IF $PIECE(PXRRFAC(IC),U,1)=FACILITY
Begin DoDot:1
+6 SET $PIECE(PXRRFAC(IC),U,4)="M"
End DoDot:1
QUIT
+7 SET FACPNAME=$PIECE(PXRRFACN(FACILITY),U,1)_" "_$PIECE(PXRRFACN(FACILITY),U,2)
+8 SET HEAD=1
+9 DO HEAD
+10 ;
+11 SET PNAME=0
PRV SET PNAME=$ORDER(^XTMP(PXRRXTMP,FACILITY,PNAME))
+1 IF PNAME=""
Begin DoDot:1
+2 IF $Y>(IOSL-BMARG-3)
Begin DoDot:2
+3 DO PAGE^PXRRGPRT
+4 IF 'DONE
WRITE !!,"Facility: ",FACPNAME
End DoDot:2
+5 IF 'DONE
Begin DoDot:2
+6 SET TEMP="Total facility encounters "
+7 DO PTOTAL^PXRRGPRT(TEMP,FTOTAL,MID,1)
+8 SET GTOTAL=GTOTAL+FTOTAL
+9 IF $DATA(PXRRPECL)
DO CLASSNE^PXRRGPRT(INDENT)
End DoDot:2
End DoDot:1
GOTO FAC
+10 IF DONE
GOTO END
+11 SET PPNAME=$PIECE(PNAME,U,1)
+12 ;
+13 ;Check for a user request to stop the task.
+14 IF $$S^%ZTLOAD
SET ZTSTOP=1
DO EXIT^PXRRGUT
+15 ;
+16 SET CLASSNAM=0
CLASS ;
+1 IF DONE
GOTO END
+2 SET CLASSNAM=$ORDER(^XTMP(PXRRXTMP,FACILITY,PNAME,CLASSNAM))
+3 IF CLASSNAM=""
Begin DoDot:1
+4 KILL ^TMP(PXRRXTMP,$JOB,PNAME)
End DoDot:1
GOTO PRV
+5 SET VACODE=$PIECE(CLASSNAM,U,2)
+6 IF $LENGTH(VACODE)>0
SET PCLASS=$$OCCUP^PXBGPRV("","",VACODE,1)
+7 IF '$TEST
SET PCLASS=-3
+8 ;If were are doing selected person classes keep track of the ones we
+9 ;found.
+10 IF $DATA(PXRRPECL)
SET TEMP=$$MATCH^PXRRPECU(PCLASS)
+11 SET DATE=0
+12 ;
DATE ;
+1 SET DTOTAL=0
+2 SET DATE=$ORDER(^XTMP(PXRRXTMP,FACILITY,PNAME,CLASSNAM,DATE))
+3 IF DATE=""
Begin DoDot:1
+4 ;Print the provider totals.
+5 DO SPRINT(.PTOTAL)
+6 SET FTOTAL=FTOTAL+PTOTAL
End DoDot:1
GOTO CLASS
+7 IF DONE
GOTO END
+8 ;
+9 SET HLOC=0
HLO SET HLOC=$ORDER(^XTMP(PXRRXTMP,FACILITY,PNAME,CLASSNAM,DATE,HLOC))
+1 IF HLOC=""
GOTO DATE
+2 ;
+3 ;Build a ^TMP array of all the visits for the current provider.
+4 SET DAY=$PIECE(DATE,".",1)
+5 SET VIEN=0
+6 FOR
SET VIEN=$ORDER(^XTMP(PXRRXTMP,FACILITY,PNAME,CLASSNAM,DATE,HLOC,VIEN))
if +VIEN=0
QUIT
Begin DoDot:1
+7 SET ^TMP(PXRRXTMP,$JOB,PNAME,DAY,HLOC,VIEN)=""
End DoDot:1
+8 ;
+9 GOTO HLO
+10 ;
FINAL ;Print grand totals
+1 SET TEMP="Total encounters "
+2 IF $Y>(IOSL-BMARG-3)
Begin DoDot:1
+3 DO PAGE^PXRRGPRT
+4 IF 'DONE
WRITE !
End DoDot:1
+5 IF 'DONE
Begin DoDot:1
+6 DO PTOTAL^PXRRGPRT(TEMP,GTOTAL,MID,0)
+7 DO FACNE^PXRRGPRT(INDENT)
End DoDot:1
END ;
+1 DO EXIT^PXRRGUT
+2 DO EOR^PXRRGUT
+3 QUIT
+4 ;
+5 ;=======================================================================
FMTPCL(PCL,START,END,PCL1,PCL2) ;Format the abbreviated Person Class, PCL so
+1 ;that it fits between START and END. If it is too long break it into
+2 ;two lines, PCL1 and PCL2.
+3 NEW LBC,LEN,LPLUS,LSPACE,MAXLEN
+4 SET MAXLEN=END-START
+5 SET LEN=$LENGTH(PCL)
+6 IF LEN'>MAXLEN
Begin DoDot:1
+7 SET PCL1="("_PCL_")"
End DoDot:1
QUIT
+8 ;PCL is too long to fit on one line find a plus or a space to make the
+9 ;break.
+10 SET LSPACE=$$LASTCHAR(PCL," ",MAXLEN)
+11 SET LPLUS=$$LASTCHAR(PCL,"+",MAXLEN)
+12 SET LBC=$$MAX^XLFMTH(LPLUS,LSPACE)
+13 SET PCL1="("_$EXTRACT(PCL,1,LBC)
+14 SET PCL2=" "_$EXTRACT(PCL,LBC+1,LEN)_")"
+15 QUIT
+16 ;
+17 ;=======================================================================
HEAD ;If necessary, write the header.
+1 IF HEAD
Begin DoDot:1
+2 IF $Y>(IOSL-BMARG-7)
DO PAGE^PXRRGPRT
+3 IF DONE
QUIT
+4 WRITE !!,"Facility: ",FACPNAME
+5 WRITE !!,?(C1HS+20),"Person Class"
+6 WRITE !,?C1HS,"Provider (Occupation+Specialty+Subspecialty)",?C3HS,"Encounters"
+7 WRITE !,?C1HS,"--------------------------------------------",?C3HS,"----------"
+8 SET HEAD=0
End DoDot:1
+9 QUIT
+10 ;
+11 ;=======================================================================
LASTCHAR(STRING,CHAR,MAX) ;Return the position of the last character, CHAR, in
+1 ;STRING ensuring that it is less than MAX.
+2 ;Return 0 if there are none.
+3 NEW IC0,IC1
+4 SET IC0=$FIND(STRING,CHAR)
+5 IF IC0=0
QUIT 0
+6 FOR
SET IC1=$FIND(STRING,CHAR,IC0)
if (IC1=0)!(IC1>MAX)
QUIT
Begin DoDot:1
+7 SET IC0=IC1
End DoDot:1
+8 QUIT IC0-1
+9 ;
+10 ;=======================================================================
SPRINT(PTOTAL) ;Print the provider total and return the total.
+1 NEW DAY,END,HLOC,PCL1,PCL2,TEMP,VACODE,VIEN
+2 SET PTOTAL=0
+3 SET DAY=0
NDAY SET DAY=$ORDER(^TMP(PXRRXTMP,$JOB,PNAME,DAY))
+1 IF DAY=""
Begin DoDot:1
+2 ;No more DAYs to sum over print the total.
+3 IF $Y>(IOSL-BMARG-1)
Begin DoDot:2
+4 DO PAGE^PXRRGPRT
+5 DO HEAD
End DoDot:2
+6 IF 'DONE
Begin DoDot:2
+7 SET C3S=MID-$LENGTH(PTOTAL)
+8 SET VACODE=$PIECE(CLASSNAM,U,2)
+9 SET TEMP=$$ABBRV^PXRRPECU(VACODE)
+10 DO FMTPCL(TEMP,C2HS,C3HSMAX,.PCL1,.PCL2)
+11 WRITE !,?C1S,PPNAME,?C2HS,PCL1,?C3S,PTOTAL
+12 IF $DATA(PCL2)
WRITE !,?C2HS,PCL2
End DoDot:2
End DoDot:1
QUIT
+13 IF DONE
QUIT
+14 ;
+15 SET HLOC=""
NHLOC SET HLOC=$ORDER(^TMP(PXRRXTMP,$JOB,PNAME,DAY,HLOC))
+1 IF HLOC=""
GOTO NDAY
+2 ;
+3 SET VIEN=0
NVIEN SET VIEN=$ORDER(^TMP(PXRRXTMP,$JOB,PNAME,DAY,HLOC,VIEN))
+1 IF VIEN=""
GOTO NHLOC
+2 SET PTOTAL=PTOTAL+1
+3 GOTO NVIEN
+4 ;
