RMPRSP7 ;HIN/RVD-PRINT 2319 WITHOUT SUSPENSE LINK ;3/17/03 08:13
;;3.0;PROSTHETICS;**62,69,77,135**;Feb 09, 1996;Build 12
;RVD 8/27/01 patch #62 - PCE data print
;RVD 4/9/02 patch #69 - Disregard Historical data
;RVD 3/17/02 patch #77 - Fixed For Loop to include all PT 2319 records
; that are not linked
;RGB 3/22/07 patch 135 - Modified code to check issues in 660 against file 668 suspense records
; in addition to current check of complete flag in issue record.
;
D DIV4^RMPRSIT I $D(Y),(Y<0) Q
; Prompt for Start Date
STDT ;RMPRSDT is start date in FM internal form.
K %DT,X,Y
S %DT("A")="Starting Date: "
S %DT(0)=-DT
S %DT="AEP"
D ^%DT I Y<0 G EXIT1
S RMPRSDT=$P(Y,".",1)
S %DT("A")="Ending Date: ",%DT="AEX" D ^%DT G:Y<0 EXIT1
S RMPREDT=$P(Y,".",1)
I RMPRSDT>RMPREDT W !,$C(7),"Invalid Date Range Selection!!" G STDT
;
CONT G:'$D(RMPRSDT) EXIT1 S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT1 I '$D(IO("Q")) U IO G PRINT
K IO("Q") S ZTDESC="PROSTHETIC PATIENT RECORDS WITHOUT SUSPENSE",ZTRTN="PRINT^RMPRSP7",ZTIO=ION,ZTSAVE("RMPRSDT")=""
S ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMPR(")="",ZTSAVE("RMPREDT")=""
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT
;
PRINT I $E(IOST)["C" W !!,"Processing report......."
K ^TMP($J)
K %DT,X,Y
S X="NOW" D ^%DT S RMDATE=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
S RMPAGE=1,(RMTOBAL,RMPREND)=0,RS=RMPR("STA")
S RDT=RMPRSDT-1,RET=RMPREDT+1,RS=RMPR("STA")
S Y=RMPRSDT D DD^%DT S RMSDAT=Y
S Y=RMPREDT D DD^%DT S RMEDAT=Y
D BUILD
I '$D(^TMP($J)) D HEAD,NONE G EXIT
D HEAD,HEAD1
D WRITE
G EXIT
;
BUILD ;build a tmp global.
F RI=RDT:0:RET S RI=$O(^RMPR(660,"B",RI)) Q:(RI'>0)!(RMPREND)!(RI>RMPREDT) F RJ=0:0 S RJ=$O(^RMPR(660,"B",RI,RJ)) Q:(RJ'>0) D
.;don't include if O2 transactions.
.Q:$D(^RMPO(665.72,"AC",RJ))
.S RM0=$G(^RMPR(660,RJ,0))
.S RM10=$G(^RMPR(660,RJ,10))
.Q:($P(RM0,U,13)=13)!($P(RM0,U,15)="*")
.Q:($P(RM10,U,14)>0)!($P(RM0,U,10)'=RMPR("STA"))
.;FILTER SHIPPING CHARGES AND DDC TRANSACTIONS
.Q:($P(RM0,U,17)'="")!($P(RM0,U,13)=16)
.S RMIE68=$O(^RMPR(668,"F",RJ,0))
.I RMIE68,$D(^RMPR(668,RMIE68,10,"B",RJ)) Q
.I $P(RM0,U,10)=RS D
..S RMDFN=$P(RM0,U,2)
..S RMITIEN=$P(RM0,U,6)
..S (RMITEM,RMPAT)=""
..I RMITIEN,($D(^RMPR(661,RMITIEN,0))),($D(^PRC(441,$P(^RMPR(661,RMITIEN,0),U,1),0))) D
...S RMITEM=$P(^PRC(441,$P(^RMPR(661,RMITIEN,0),U,1),0),U,2)
..S RMITEM=$E(RMITEM,1,18)
..I $D(^DPT(RMDFN,0)) S RMPAT=$E($P(^DPT(RMDFN,0),U,1),U,15)
..S RMSUSP=$P(RM10,U,1)
..S RMRXDT=$P(RM10,U,2)
..S RMIADT=$P(RM10,U,3)
..S RCDT=$P(RM10,U,4)
..S RMAMT=$P(RM0,U,16)
..S RMSRC=RJ
..S RMPRDI=$P(RM10,U,7)
..S RMINIE=$P(RM0,U,27)
..S RMCOSU=$P(RM10,U,9)
..S RMSUST=$P(RM10,U,11)
..S RMPCEP=$P(RM10,U,12)
..S RPDT=$P(RM10,U,13)
..I RMINIE,$D(^VA(200,RMINIE,0)) S RMINI=$E($P(^VA(200,RMINIE,0),U,1),1,10)
..E S RMINI=""
..S RDDT=$E(RI,4,5)_"/"_$E(RI,6,7)_"/"_$E(RI,2,3)
..S:RPDT'="" RPDT=$E(RPDT,4,5)_"/"_$E(RPDT,6,7)_"/"_$E(RPDT,2,3)
..S:RCDT'="" RCDT=$E(RCDT,4,5)_"/"_$E(RCDT,6,7)_"/"_$E(RCDT,2,3)
..S ^TMP($J,RI,RMPAT,RJ)=RMITEM_"^"_RDDT_"^"_RMAMT_"^"_RMSRC_"^"_RMINI_"^"_RPDT_"^"_$E(RMPRDI,1,10)
Q
;
WRITE ;write report to a selected device
S (RMPREND,RI,RM)=0
F S RI=$O(^TMP($J,RI)) Q:(RI'>0)!(RMPREND) S RJ="" F S RJ=$O(^TMP($J,RI,RJ)) Q:(RJ="")!(RMPREND) F S RM=$O(^TMP($J,RI,RJ,RM)) Q:(RM'>0)!(RMPREND) D
.S RMDAT=$G(^TMP($J,RI,RJ,RM))
.S RMPAT=RJ
.S RMITEM=$P(RMDAT,U,1)
.S RDDT=$P(RMDAT,U,2)
.S RMAMT=$P(RMDAT,U,3)
.S RMSRC=$P(RMDAT,U,4)
.S RMINI=$P(RMDAT,U,5)
.S RPDT=$P(RMDAT,U,6)
.S RMPRDI=$E($P(RMDAT,U,7),1,12)
.W !,RDDT,?10,RMPAT,?26,RMITEM,?45,$J(RMAMT,8,2),?57,RMSRC,?67,RMINI
.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 K RMPRFLG Q
W !,RMPR("L")
W !,"<End of Report>"
Q
;
HEAD W !,"PROSTHETICS PATIENT RECORDS NOT LINKED TO SUSPENSE Run Date:",RMDATE,?70,"PAGE: ",RMPAGE
W !,"Start Date: ",RMSDAT,?26,"End Date: ",RMEDAT,?51,"station: ",$E($P($G(^DIC(4,RS,0)),U,1),1,19)
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")
W !,"DATE",?10,"PATIENT",?26,"ITEM",?49,"COST",?57,"VISTA #",?67,"INITIATOR"
W !,"----",?10,"-------",?26,"----",?49,"----",?57,"-------",?67,"---------"
S RMPRFLG=1
Q
;
EXIT I $E(IOST)["C",'RMPREND K DIR S DIR(0)="E" D ^DIR
EXIT1 D ^%ZISC
K ^TMP($J)
N RMPR,RMPRSITE D KILL^XUSCLEAN
Q
NONE W !!,"NO DATA TO PRINT !!!!!"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRSP7 4730 printed Dec 13, 2024@02:37:50 Page 2
RMPRSP7 ;HIN/RVD-PRINT 2319 WITHOUT SUSPENSE LINK ;3/17/03 08:13
+1 ;;3.0;PROSTHETICS;**62,69,77,135**;Feb 09, 1996;Build 12
+2 ;RVD 8/27/01 patch #62 - PCE data print
+3 ;RVD 4/9/02 patch #69 - Disregard Historical data
+4 ;RVD 3/17/02 patch #77 - Fixed For Loop to include all PT 2319 records
+5 ; that are not linked
+6 ;RGB 3/22/07 patch 135 - Modified code to check issues in 660 against file 668 suspense records
+7 ; in addition to current check of complete flag in issue record.
+8 ;
+9 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
QUIT
+10 ; Prompt for Start Date
STDT ;RMPRSDT is start date in FM internal form.
+1 KILL %DT,X,Y
+2 SET %DT("A")="Starting Date: "
+3 SET %DT(0)=-DT
+4 SET %DT="AEP"
+5 DO ^%DT
IF Y<0
GOTO EXIT1
+6 SET RMPRSDT=$PIECE(Y,".",1)
+7 SET %DT("A")="Ending Date: "
SET %DT="AEX"
DO ^%DT
if Y<0
GOTO EXIT1
+8 SET RMPREDT=$PIECE(Y,".",1)
+9 IF RMPRSDT>RMPREDT
WRITE !,$CHAR(7),"Invalid Date Range Selection!!"
GOTO STDT
+10 ;
CONT if '$DATA(RMPRSDT)
GOTO EXIT1
SET %ZIS="MQ"
KILL IOP
DO ^%ZIS
if POP
GOTO EXIT1
IF '$DATA(IO("Q"))
USE IO
GOTO PRINT
+1 KILL IO("Q")
SET ZTDESC="PROSTHETIC PATIENT RECORDS WITHOUT SUSPENSE"
SET ZTRTN="PRINT^RMPRSP7"
SET ZTIO=ION
SET ZTSAVE("RMPRSDT")=""
+2 SET ZTSAVE("RMPR(""STA"")")=""
SET ZTSAVE("RMPR(")=""
SET ZTSAVE("RMPREDT")=""
+3 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!"
HANG 1
GOTO EXIT
+4 ;
PRINT IF $EXTRACT(IOST)["C"
WRITE !!,"Processing report......."
+1 KILL ^TMP($JOB)
+2 KILL %DT,X,Y
+3 SET X="NOW"
DO ^%DT
SET RMDATE=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
+4 SET RMPAGE=1
SET (RMTOBAL,RMPREND)=0
SET RS=RMPR("STA")
+5 SET RDT=RMPRSDT-1
SET RET=RMPREDT+1
SET RS=RMPR("STA")
+6 SET Y=RMPRSDT
DO DD^%DT
SET RMSDAT=Y
+7 SET Y=RMPREDT
DO DD^%DT
SET RMEDAT=Y
+8 DO BUILD
+9 IF '$DATA(^TMP($JOB))
DO HEAD
DO NONE
GOTO EXIT
+10 DO HEAD
DO HEAD1
+11 DO WRITE
+12 GOTO EXIT
+13 ;
BUILD ;build a tmp global.
+1 FOR RI=RDT:0:RET
SET RI=$ORDER(^RMPR(660,"B",RI))
if (RI'>0)!(RMPREND)!(RI>RMPREDT)
QUIT
FOR RJ=0:0
SET RJ=$ORDER(^RMPR(660,"B",RI,RJ))
if (RJ'>0)
QUIT
Begin DoDot:1
+2 ;don't include if O2 transactions.
+3 if $DATA(^RMPO(665.72,"AC",RJ))
QUIT
+4 SET RM0=$GET(^RMPR(660,RJ,0))
+5 SET RM10=$GET(^RMPR(660,RJ,10))
+6 if ($PIECE(RM0,U,13)=13)!($PIECE(RM0,U,15)="*")
QUIT
+7 if ($PIECE(RM10,U,14)>0)!($PIECE(RM0,U,10)'=RMPR("STA"))
QUIT
+8 ;FILTER SHIPPING CHARGES AND DDC TRANSACTIONS
+9 if ($PIECE(RM0,U,17)'="")!($PIECE(RM0,U,13)=16)
QUIT
+10 SET RMIE68=$ORDER(^RMPR(668,"F",RJ,0))
+11 IF RMIE68
IF $DATA(^RMPR(668,RMIE68,10,"B",RJ))
QUIT
+12 IF $PIECE(RM0,U,10)=RS
Begin DoDot:2
+13 SET RMDFN=$PIECE(RM0,U,2)
+14 SET RMITIEN=$PIECE(RM0,U,6)
+15 SET (RMITEM,RMPAT)=""
+16 IF RMITIEN
IF ($DATA(^RMPR(661,RMITIEN,0)))
IF ($DATA(^PRC(441,$PIECE(^RMPR(661,RMITIEN,0),U,1),0)))
Begin DoDot:3
+17 SET RMITEM=$PIECE(^PRC(441,$PIECE(^RMPR(661,RMITIEN,0),U,1),0),U,2)
End DoDot:3
+18 SET RMITEM=$EXTRACT(RMITEM,1,18)
+19 IF $DATA(^DPT(RMDFN,0))
SET RMPAT=$EXTRACT($PIECE(^DPT(RMDFN,0),U,1),U,15)
+20 SET RMSUSP=$PIECE(RM10,U,1)
+21 SET RMRXDT=$PIECE(RM10,U,2)
+22 SET RMIADT=$PIECE(RM10,U,3)
+23 SET RCDT=$PIECE(RM10,U,4)
+24 SET RMAMT=$PIECE(RM0,U,16)
+25 SET RMSRC=RJ
+26 SET RMPRDI=$PIECE(RM10,U,7)
+27 SET RMINIE=$PIECE(RM0,U,27)
+28 SET RMCOSU=$PIECE(RM10,U,9)
+29 SET RMSUST=$PIECE(RM10,U,11)
+30 SET RMPCEP=$PIECE(RM10,U,12)
+31 SET RPDT=$PIECE(RM10,U,13)
+32 IF RMINIE
IF $DATA(^VA(200,RMINIE,0))
SET RMINI=$EXTRACT($PIECE(^VA(200,RMINIE,0),U,1),1,10)
+33 IF '$TEST
SET RMINI=""
+34 SET RDDT=$EXTRACT(RI,4,5)_"/"_$EXTRACT(RI,6,7)_"/"_$EXTRACT(RI,2,3)
+35 if RPDT'=""
SET RPDT=$EXTRACT(RPDT,4,5)_"/"_$EXTRACT(RPDT,6,7)_"/"_$EXTRACT(RPDT,2,3)
+36 if RCDT'=""
SET RCDT=$EXTRACT(RCDT,4,5)_"/"_$EXTRACT(RCDT,6,7)_"/"_$EXTRACT(RCDT,2,3)
+37 SET ^TMP($JOB,RI,RMPAT,RJ)=RMITEM_"^"_RDDT_"^"_RMAMT_"^"_RMSRC_"^"_RMINI_"^"_RPDT_"^"_$EXTRACT(RMPRDI,1,10)
End DoDot:2
End DoDot:1
+38 QUIT
+39 ;
WRITE ;write report to a selected device
+1 SET (RMPREND,RI,RM)=0
+2 FOR
SET RI=$ORDER(^TMP($JOB,RI))
if (RI'>0)!(RMPREND)
QUIT
SET RJ=""
FOR
SET RJ=$ORDER(^TMP($JOB,RI,RJ))
if (RJ="")!(RMPREND)
QUIT
FOR
SET RM=$ORDER(^TMP($JOB,RI,RJ,RM))
if (RM'>0)!(RMPREND)
QUIT
Begin DoDot:1
+3 SET RMDAT=$GET(^TMP($JOB,RI,RJ,RM))
+4 SET RMPAT=RJ
+5 SET RMITEM=$PIECE(RMDAT,U,1)
+6 SET RDDT=$PIECE(RMDAT,U,2)
+7 SET RMAMT=$PIECE(RMDAT,U,3)
+8 SET RMSRC=$PIECE(RMDAT,U,4)
+9 SET RMINI=$PIECE(RMDAT,U,5)
+10 SET RPDT=$PIECE(RMDAT,U,6)
+11 SET RMPRDI=$EXTRACT($PIECE(RMDAT,U,7),1,12)
+12 WRITE !,RDDT,?10,RMPAT,?26,RMITEM,?45,$JUSTIFY(RMAMT,8,2),?57,RMSRC,?67,RMINI
+13 SET RMPRFLG=1
+14 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
+15 IF $Y>(IOSL-6)
WRITE @IOF
DO HEAD
DO HEAD1
KILL RMPRFLG
QUIT
End DoDot:1
+16 WRITE !,RMPR("L")
+17 WRITE !,"<End of Report>"
+18 QUIT
+19 ;
HEAD WRITE !,"PROSTHETICS PATIENT RECORDS NOT LINKED TO SUSPENSE Run Date:",RMDATE,?70,"PAGE: ",RMPAGE
+1 WRITE !,"Start Date: ",RMSDAT,?26,"End Date: ",RMEDAT,?51,"station: ",$EXTRACT($PIECE($GET(^DIC(4,RS,0)),U,1),1,19)
+2 SET RMPAGE=RMPAGE+1
+3 QUIT
+4 ;
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")
+3 WRITE !,"DATE",?10,"PATIENT",?26,"ITEM",?49,"COST",?57,"VISTA #",?67,"INITIATOR"
+4 WRITE !,"----",?10,"-------",?26,"----",?49,"----",?57,"-------",?67,"---------"
+5 SET RMPRFLG=1
+6 QUIT
+7 ;
EXIT IF $EXTRACT(IOST)["C"
IF 'RMPREND
KILL DIR
SET DIR(0)="E"
DO ^DIR
EXIT1 DO ^%ZISC
+1 KILL ^TMP($JOB)
+2 NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
+3 QUIT
NONE WRITE !!,"NO DATA TO PRINT !!!!!"
+1 QUIT
