RMPR5N4 ;HIN/RVD-PRINT LAB ITEM SUMMARY BY EMPLOYEE ;3/13/1998
;;3.0;PROSTHETICS;**33,37,159**;Feb 09, 1996;Build 2
EN N RMEMP D DIV4^RMPRSIT
K ^TMP($J),RMPRFLG,RMPRI S RMPREND=0 D HOME^%ZIS G:$D(X) EXIT1
S DIC="^VA(200,",DIC(0)="MAEQ"
EN1 R !!,"Enter 'ALL' for all Lab Employees or 'RETURN' to select individual names: ",RMENTER:DTIME G:$D(DTOUT)!$D(DUOUT)!(RMENTER="^") EXIT1
G:RMENTER["?" EN1
S X=RMENTER X ^%ZOSF("UPPERCASE") S RMENTER=Y I RMENTER="ALL" S RMPRI(0)=1 G CONT
W ! F EMP=1:1 S DIC("A")="Select EMPLOYEE "_EMP_": " D ^DIC G:$D(DTOUT)!(X["^")!(X=""&(EMP=1)) EXIT1 Q:X="" D
.S RMEMP=$P(^VA(200,+Y,0),U,1) Q:RMEMP=""
.I $D(RMPRI(RMEMP)) W $C(7)," ??",?40,"..Duplicate employee name" S EMP=EMP-1 Q
.S RMPRI(RMEMP)=+Y
CONT G:'$D(RMPRI) EXIT1 S RMPRCOUN=0 W !! S %DT("A")="Beginning Date: ",%DT="AEPX",%DT("B")="T-30" D ^%DT S RMPRBDT=Y G:Y<0 EXIT1
ENDATE S %DT("A")="Ending Date: ",%DT="AEX",%DT("B")="TODAY" D ^%DT G:Y<0 EXIT1 I RMPRBDT>Y W !,$C(7),"Invalid Date Range Selection!!" G ENDATE
G:Y<0 EXIT1 S RMPREDT=Y,Y=RMPRBDT D DD^%DT S RMPRX=Y,Y=RMPREDT D DD^%DT S RMPRY=Y
S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT1
I '$D(IO("Q")) U IO G PRINT
K IO("Q") S ZTDESC="PROS LAB ITEM SUMMARY",ZTRTN="PRINT^RMPR5N4",ZTIO=ION,ZTSAVE("RMPRBDT")="",ZTSAVE("RMPREDT")="",ZTSAVE("RMPRI(")="",ZTSAVE("RMPRX")="",ZTSAVE("RMPRY")="",ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMPR(")=""
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT1
PRINT I $E(IOST)["C" W !!,"Processing report......"
;ENTRY POINT FOR PRINTING REPORT
W:$E(IOST)["C" @IOF S RMPAGE=1,RMPREND=0 D:$D(RMPRI(0)) ALL
I '$D(RMPRI) D NONEALL G EXIT
;D HEAD
S RMD="" F S RMD=$O(RMPRI(RMD)) Q:RMD="" S RMI=RMPRI(RMD) D PRI1
G:RMPREND EXIT D WRI D:'$D(^TMP($J)) NONEALL G EXIT
;
PRI1 F RO=0:0 S RO=$O(^RMPR(661.2,"F",RMI,RO)) Q:(RO'>0)!(RMPREND) D REST
D:'$D(^TMP($J,RMD))&'$D(RMPRI(0)) NONE
Q
;
EXIT ;Exit
;I RMPRCOUN>0,$D(RMPREDT),'$D(KILL) D W !!?32,"END OF REPORT"
;I $E(IOST)["C"&($Y<22) F W ! Q:$Y>20
I $D(RMPREDT),$E(IOST)["C",'$D(DUOUT),'$D(DTOUT),'RMPREND K DIR S DIR(0)="E" D ^DIR
EXIT1 ;
D ^%ZISC
N RMPR,RMPRSITE D KILL^XUSCLEAN
Q
;
HEAD ;write heading
W !,?18,"PROSTHETICS LAB ITEM SUMMARY BY EMPLOYEE",?64,"Page: ",RMPAGE
W !,RMPRX," to ",RMPRY
S RMPAGE=RMPAGE+1
Q
HEAD1 I $E(IOST)["C"&($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD
I $E(IOST)'["C"&($Y>(IOSL-6)) W @IOF D HEAD
W !,RMPR("L"),!,"Employee: ",I
W !," DATE",?17,"ITEM",?43,"HCPCS",?51,"TIME SPENT(hr)",?68,"LABOR COST"
W !," ----",?17,"----",?43,"-----",?51,"--------------",?68,"----------"
S RMPRFLG=1
Q
;
SUM W !,?53,"--------",?70,"--------",!,?39,"***TOTALS =",?53,$J(RMTITOT,7,2),?67,$J(RMDOTOT,10,2),!
W @IOF K RMPRFLG
Q
;
REST Q:'$D(^RMPR(661.2,RO,1))
S RM20=$G(^RMPR(661.2,RO,0)),RMDAT=$P(RM20,U,1)
Q:(RMDAT<RMPRBDT)!(RMDAT>RMPREDT)
S ^TMP($J,RMD,RO)=RMDAT
Q
WRI ;
;S RMD="" F S RMD=$O(RMPRI(RMD)) Q:RMD=""
;
S I="" F S I=$O(^TMP($J,I)) Q:I="" Q:RMPREND S (RMDOTOT,RMTITOT,RMSUF)=0 F J=0:0 S J=$O(^TMP($J,I,J)) Q:RMPREND D:J'>0 SUM Q:J'>0 D
.S RMSUF=1
.I '$D(RMPRFLG) D HEAD,HEAD1
.S RMDAT=^TMP($J,I,J)
.S RM20=$G(^RMPR(661.2,J,0)),RM21=$G(^RMPR(661.2,J,1))
.S RMPAT=$P(RM20,U,2)
.S RMIT=$P(RM20,U,9)
.S RMDAHC=$P(RM20,U,4)
.S RMDAIT=$P(RMIT,"-",2)
.Q:'RMDAHC
.S:RMDAIT RM1=$P($G(^RMPR(661.1,RMDAHC,3,RMDAIT,0)),U,1)
.S:'RMDAIT RM1=$P($G(^RMPR(661.1,RMDAHC,0)),U,2) Q:RM1=""
.S RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
.S RMITEM=$E($P(RM1,U,1),1,31)
.S RMHOUR=$P(RM21,U,1),RMDOL=$P(RM21,U,2)
.S RMDAT=$E(RMDAT,4,5)_"/"_$E(RMDAT,6,7)_"/"_$E(RMDAT,2,3)
.W !,RMDAT,?11,RMITEM,?43,RMHCPC,?56,$J(RMHOUR,4,2),?70,$J(RMDOL,7,2)
.S:RMDOL RMDOTOT=RMDOTOT+RMDOL
.S:RMHOUR RMTITOT=RMTITOT+RMHOUR
.S RMPRFLG=1
.I $E(IOST)["C"&($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD,HEAD1 Q
.I $Y>(IOSL-6) W @IOF D HEAD,HEAD1 S RMPRFLG=1
Q
;
ALL ;process all lab employees.
S RMEMP=""
F I=0:0 S I=$O(^RMPR(661.2,"F",I)) Q:I'>0 S RMEMP=$P(^VA(200,I,0),U,1) S RMPRI(RMEMP)=I
Q
;
NONE ;No data for certain employee
W !,RMPR("L"),!,"No Lab data for Employee: ",RMD," ....for this date range !!!"
Q
NONEALL W !!,"NO DATA FOR THIS DATE RANGE!!!"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5N4 4324 printed Apr 09, 2024@21:37:30 Page 2
RMPR5N4 ;HIN/RVD-PRINT LAB ITEM SUMMARY BY EMPLOYEE ;3/13/1998
+1 ;;3.0;PROSTHETICS;**33,37,159**;Feb 09, 1996;Build 2
EN NEW RMEMP
DO DIV4^RMPRSIT
+1 KILL ^TMP($JOB),RMPRFLG,RMPRI
SET RMPREND=0
DO HOME^%ZIS
if $DATA(X)
GOTO EXIT1
+2 SET DIC="^VA(200,"
SET DIC(0)="MAEQ"
EN1 READ !!,"Enter 'ALL' for all Lab Employees or 'RETURN' to select individual names: ",RMENTER:DTIME
if $DATA(DTOUT)!$DATA(DUOUT)!(RMENTER="^")
GOTO EXIT1
+1 if RMENTER["?"
GOTO EN1
+2 SET X=RMENTER
XECUTE ^%ZOSF("UPPERCASE")
SET RMENTER=Y
IF RMENTER="ALL"
SET RMPRI(0)=1
GOTO CONT
+3 WRITE !
FOR EMP=1:1
SET DIC("A")="Select EMPLOYEE "_EMP_": "
DO ^DIC
if $DATA(DTOUT)!(X["^")!(X=""&(EMP=1))
GOTO EXIT1
if X=""
QUIT
Begin DoDot:1
+4 SET RMEMP=$PIECE(^VA(200,+Y,0),U,1)
if RMEMP=""
QUIT
+5 IF $DATA(RMPRI(RMEMP))
WRITE $CHAR(7)," ??",?40,"..Duplicate employee name"
SET EMP=EMP-1
QUIT
+6 SET RMPRI(RMEMP)=+Y
End DoDot:1
CONT if '$DATA(RMPRI)
GOTO EXIT1
SET RMPRCOUN=0
WRITE !!
SET %DT("A")="Beginning Date: "
SET %DT="AEPX"
SET %DT("B")="T-30"
DO ^%DT
SET RMPRBDT=Y
if Y<0
GOTO EXIT1
ENDATE SET %DT("A")="Ending Date: "
SET %DT="AEX"
SET %DT("B")="TODAY"
DO ^%DT
if Y<0
GOTO EXIT1
IF RMPRBDT>Y
WRITE !,$CHAR(7),"Invalid Date Range Selection!!"
GOTO ENDATE
+1 if Y<0
GOTO EXIT1
SET RMPREDT=Y
SET Y=RMPRBDT
DO DD^%DT
SET RMPRX=Y
SET Y=RMPREDT
DO DD^%DT
SET RMPRY=Y
+2 SET %ZIS="MQ"
KILL IOP
DO ^%ZIS
if POP
GOTO EXIT1
+3 IF '$DATA(IO("Q"))
USE IO
GOTO PRINT
+4 KILL IO("Q")
SET ZTDESC="PROS LAB ITEM SUMMARY"
SET ZTRTN="PRINT^RMPR5N4"
SET ZTIO=ION
SET ZTSAVE("RMPRBDT")=""
SET ZTSAVE("RMPREDT")=""
SET ZTSAVE("RMPRI(")=""
SET ZTSAVE("RMPRX")=""
SET ZTSAVE("RMPRY")=""
SET ZTSAVE("RMPR(""STA"")")=""
SET ZTSAVE("RMPR(")=""
+5 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!"
HANG 1
GOTO EXIT1
PRINT IF $EXTRACT(IOST)["C"
WRITE !!,"Processing report......"
+1 ;ENTRY POINT FOR PRINTING REPORT
+2 if $EXTRACT(IOST)["C"
WRITE @IOF
SET RMPAGE=1
SET RMPREND=0
if $DATA(RMPRI(0))
DO ALL
+3 IF '$DATA(RMPRI)
DO NONEALL
GOTO EXIT
+4 ;D HEAD
+5 SET RMD=""
FOR
SET RMD=$ORDER(RMPRI(RMD))
if RMD=""
QUIT
SET RMI=RMPRI(RMD)
DO PRI1
+6 if RMPREND
GOTO EXIT
DO WRI
if '$DATA(^TMP($JOB))
DO NONEALL
GOTO EXIT
+7 ;
PRI1 FOR RO=0:0
SET RO=$ORDER(^RMPR(661.2,"F",RMI,RO))
if (RO'>0)!(RMPREND)
QUIT
DO REST
+1 if '$DATA(^TMP($JOB,RMD))&'$DATA(RMPRI(0))
DO NONE
+2 QUIT
+3 ;
EXIT ;Exit
+1 ;I RMPRCOUN>0,$D(RMPREDT),'$D(KILL) D W !!?32,"END OF REPORT"
+2 ;I $E(IOST)["C"&($Y<22) F W ! Q:$Y>20
+3 IF $DATA(RMPREDT)
IF $EXTRACT(IOST)["C"
IF '$DATA(DUOUT)
IF '$DATA(DTOUT)
IF 'RMPREND
KILL DIR
SET DIR(0)="E"
DO ^DIR
EXIT1 ;
+1 DO ^%ZISC
+2 NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
+3 QUIT
+4 ;
HEAD ;write heading
+1 WRITE !,?18,"PROSTHETICS LAB ITEM SUMMARY BY EMPLOYEE",?64,"Page: ",RMPAGE
+2 WRITE !,RMPRX," to ",RMPRY
+3 SET RMPAGE=RMPAGE+1
+4 QUIT
HEAD1 IF $EXTRACT(IOST)["C"&($Y>(IOSL-7))
SET DIR(0)="E"
DO ^DIR
if $DATA(DTOUT)!(Y=0)
SET RMPREND=1
if RMPREND
QUIT
WRITE @IOF
DO HEAD
+1 IF $EXTRACT(IOST)'["C"&($Y>(IOSL-6))
WRITE @IOF
DO HEAD
+2 WRITE !,RMPR("L"),!,"Employee: ",I
+3 WRITE !," DATE",?17,"ITEM",?43,"HCPCS",?51,"TIME SPENT(hr)",?68,"LABOR COST"
+4 WRITE !," ----",?17,"----",?43,"-----",?51,"--------------",?68,"----------"
+5 SET RMPRFLG=1
+6 QUIT
+7 ;
SUM WRITE !,?53,"--------",?70,"--------",!,?39,"***TOTALS =",?53,$JUSTIFY(RMTITOT,7,2),?67,$JUSTIFY(RMDOTOT,10,2),!
+1 WRITE @IOF
KILL RMPRFLG
+2 QUIT
+3 ;
REST if '$DATA(^RMPR(661.2,RO,1))
QUIT
+1 SET RM20=$GET(^RMPR(661.2,RO,0))
SET RMDAT=$PIECE(RM20,U,1)
+2 if (RMDAT<RMPRBDT)!(RMDAT>RMPREDT)
QUIT
+3 SET ^TMP($JOB,RMD,RO)=RMDAT
+4 QUIT
WRI ;
+1 ;S RMD="" F S RMD=$O(RMPRI(RMD)) Q:RMD=""
+2 ;
+3 SET I=""
FOR
SET I=$ORDER(^TMP($JOB,I))
if I=""
QUIT
if RMPREND
QUIT
SET (RMDOTOT,RMTITOT,RMSUF)=0
FOR J=0:0
SET J=$ORDER(^TMP($JOB,I,J))
if RMPREND
QUIT
if J'>0
DO SUM
if J'>0
QUIT
Begin DoDot:1
+4 SET RMSUF=1
+5 IF '$DATA(RMPRFLG)
DO HEAD
DO HEAD1
+6 SET RMDAT=^TMP($JOB,I,J)
+7 SET RM20=$GET(^RMPR(661.2,J,0))
SET RM21=$GET(^RMPR(661.2,J,1))
+8 SET RMPAT=$PIECE(RM20,U,2)
+9 SET RMIT=$PIECE(RM20,U,9)
+10 SET RMDAHC=$PIECE(RM20,U,4)
+11 SET RMDAIT=$PIECE(RMIT,"-",2)
+12 if 'RMDAHC
QUIT
+13 if RMDAIT
SET RM1=$PIECE($GET(^RMPR(661.1,RMDAHC,3,RMDAIT,0)),U,1)
+14 if 'RMDAIT
SET RM1=$PIECE($GET(^RMPR(661.1,RMDAHC,0)),U,2)
if RM1=""
QUIT
+15 SET RMHCPC=$PIECE(^RMPR(661.1,RMDAHC,0),U,1)
+16 SET RMITEM=$EXTRACT($PIECE(RM1,U,1),1,31)
+17 SET RMHOUR=$PIECE(RM21,U,1)
SET RMDOL=$PIECE(RM21,U,2)
+18 SET RMDAT=$EXTRACT(RMDAT,4,5)_"/"_$EXTRACT(RMDAT,6,7)_"/"_$EXTRACT(RMDAT,2,3)
+19 WRITE !,RMDAT,?11,RMITEM,?43,RMHCPC,?56,$JUSTIFY(RMHOUR,4,2),?70,$JUSTIFY(RMDOL,7,2)
+20 if RMDOL
SET RMDOTOT=RMDOTOT+RMDOL
+21 if RMHOUR
SET RMTITOT=RMTITOT+RMHOUR
+22 SET RMPRFLG=1
+23 IF $EXTRACT(IOST)["C"&($Y>(IOSL-7))
SET DIR(0)="E"
DO ^DIR
if $DATA(DTOUT)!(Y=0)
SET RMPREND=1
if RMPREND
QUIT
WRITE @IOF
DO HEAD
DO HEAD1
QUIT
+24 IF $Y>(IOSL-6)
WRITE @IOF
DO HEAD
DO HEAD1
SET RMPRFLG=1
End DoDot:1
+25 QUIT
+26 ;
ALL ;process all lab employees.
+1 SET RMEMP=""
+2 FOR I=0:0
SET I=$ORDER(^RMPR(661.2,"F",I))
if I'>0
QUIT
SET RMEMP=$PIECE(^VA(200,I,0),U,1)
SET RMPRI(RMEMP)=I
+3 QUIT
+4 ;
NONE ;No data for certain employee
+1 WRITE !,RMPR("L"),!,"No Lab data for Employee: ",RMD," ....for this date range !!!"
+2 QUIT
NONEALL WRITE !!,"NO DATA FOR THIS DATE RANGE!!!"
+1 QUIT
