RMPRSP6 ;HIN/RVD-PRINT 2319 WITH SUSPENSE LINK ;8/27/01
;;3.0;PROSTHETICS;**62**;Feb 09, 1996
;RVD 8/27/01 patch #62 - PCE data print
;
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 WITH SUSPENSE",ZTRTN="PRINT^RMPRSP6",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.
S RMPR("ROUTINE")=0
S RMPR("EYEGLASS")=0
S RMPR("CONTACT")=0
S RMPR("OXYGEN")=0
S RMPR("MANUAL")=0
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
.S RM0=$G(^RMPR(660,RJ,0))
.S RM10=$G(^RMPR(660,RJ,10))
.Q:$P(RM10,U,14)'>0
.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,10)
..S RMINIE=$P(RM0,U,27)
..I RMINIE,$D(^VA(200,RMINIE,0)) S RMINI=$E($P(^VA(200,RMINIE,0),U,1),1,10)
..E S RMINI=""
..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 RMTYRE=$P(RM10,U,5)
..S RMSURE=$P(RM10,U,6)
..S RMPRDI=$P(RM10,U,7)
..S RMICD9=$P(RM10,U,8)
..S RMCOSU=$P(RM10,U,9)
..S RMSUST=$P(RM10,U,11)
..S RMPCEP=$P(RM10,U,12)
..S RPDT=$P(RM10,U,13)
..D SUMTYP
..I RMICD9,($D(^ICD9(RMICD9,0))) S RMICD=$P(^ICD9(RMICD9,0),U,1)
..E S RMICD=""
..S:RMTYRE'="" RMTYRE=$E(RMTYRE,1,8)
..I RMSURE,($D(^VA(200,RMSURE,0))) S RMSURE=$E($P(^VA(200,RMSURE,0),U,1),1,10)
..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_"^"_RMTYRE_"^"_RMSURE_"^"_RMINI_"^"_RPDT_"^"_$E(RMPRDI,1,10)
Q
;
WRITE ;write report to a selected device
S (RI,RM,RMPREND)=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 RMTYRE=$P(RMDAT,U,3)
.S RMSURE=$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,?21,RMITEM,?40,RMTYRE,?50,RMSURE,?68,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 !,"Totals:",?10,"Routine Prosthetics = ",$J(RMPR("ROUTINE"),5)
W ?40,"Eyeglass = ",$J(RMPR("EYEGLASS"),5)
W ?59,"Contact Lens = ",$J(RMPR("CONTACT"),5)
W !,?17," Oxygen = ",$J(RMPR("OXYGEN"),5)
W ?42,"Manual = ",$J(RMPR("MANUAL"),5)
W !,"<End of Report>"
Q
;
HEAD W !,"PROSTHETICS PATIENT RECORDS 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 !?40,"TYPE OF",?52,"CPRS"
W !,"DATE",?10,"PATIENT",?21,"ITEM",?40,"REQUEST",?50,"REQUESTOR",?68,"INITIATOR"
W !,"----",?10,"-------",?21,"----",?40,"-------",?50,"---------",?68,"---------"
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
;
SUMTYP ;get total of each type of request
S:RMTYRE["ROUTINE" RMPR("ROUTINE")=RMPR("ROUTINE")+1
S:RMTYRE["EYEGLASS" RMPR("EYEGLASS")=RMPR("EYEGLASS")+1
S:RMTYRE["CONTACT" RMPR("CONTACT")=RMPR("CONTACT")+1
S:RMTYRE["OXYGEN" RMPR("OXYGEN")=RMPR("OXYGEN")+1
S:RMTYRE["MANUAL" RMPR("MANUAL")=RMPR("MANUAL")+1
Q
;
NONE W !!,"NO DATA TO PRINT !!!!!"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRSP6 5002 printed Nov 22, 2024@17:47:49 Page 2
RMPRSP6 ;HIN/RVD-PRINT 2319 WITH SUSPENSE LINK ;8/27/01
+1 ;;3.0;PROSTHETICS;**62**;Feb 09, 1996
+2 ;RVD 8/27/01 patch #62 - PCE data print
+3 ;
+4 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
QUIT
+5 ; 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 WITH SUSPENSE"
SET ZTRTN="PRINT^RMPRSP6"
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 SET RMPR("ROUTINE")=0
+2 SET RMPR("EYEGLASS")=0
+3 SET RMPR("CONTACT")=0
+4 SET RMPR("OXYGEN")=0
+5 SET RMPR("MANUAL")=0
+6 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
+7 SET RM0=$GET(^RMPR(660,RJ,0))
+8 SET RM10=$GET(^RMPR(660,RJ,10))
+9 if $PIECE(RM10,U,14)'>0
QUIT
+10 IF $PIECE(RM0,U,10)=RS
Begin DoDot:2
+11 SET RMDFN=$PIECE(RM0,U,2)
+12 SET RMITIEN=$PIECE(RM0,U,6)
+13 SET (RMITEM,RMPAT)=""
+14 IF RMITIEN
IF ($DATA(^RMPR(661,RMITIEN,0)))
IF ($DATA(^PRC(441,$PIECE(^RMPR(661,RMITIEN,0),U,1),0)))
Begin DoDot:3
+15 SET RMITEM=$PIECE(^PRC(441,$PIECE(^RMPR(661,RMITIEN,0),U,1),0),U,2)
End DoDot:3
+16 SET RMITEM=$EXTRACT(RMITEM,1,18)
+17 IF $DATA(^DPT(RMDFN,0))
SET RMPAT=$EXTRACT($PIECE(^DPT(RMDFN,0),U,1),U,10)
+18 SET RMINIE=$PIECE(RM0,U,27)
+19 IF RMINIE
IF $DATA(^VA(200,RMINIE,0))
SET RMINI=$EXTRACT($PIECE(^VA(200,RMINIE,0),U,1),1,10)
+20 IF '$TEST
SET RMINI=""
+21 SET RMSUSP=$PIECE(RM10,U,1)
+22 SET RMRXDT=$PIECE(RM10,U,2)
+23 SET RMIADT=$PIECE(RM10,U,3)
+24 SET RCDT=$PIECE(RM10,U,4)
+25 SET RMTYRE=$PIECE(RM10,U,5)
+26 SET RMSURE=$PIECE(RM10,U,6)
+27 SET RMPRDI=$PIECE(RM10,U,7)
+28 SET RMICD9=$PIECE(RM10,U,8)
+29 SET RMCOSU=$PIECE(RM10,U,9)
+30 SET RMSUST=$PIECE(RM10,U,11)
+31 SET RMPCEP=$PIECE(RM10,U,12)
+32 SET RPDT=$PIECE(RM10,U,13)
+33 DO SUMTYP
+34 IF RMICD9
IF ($DATA(^ICD9(RMICD9,0)))
SET RMICD=$PIECE(^ICD9(RMICD9,0),U,1)
+35 IF '$TEST
SET RMICD=""
+36 if RMTYRE'=""
SET RMTYRE=$EXTRACT(RMTYRE,1,8)
+37 IF RMSURE
IF ($DATA(^VA(200,RMSURE,0)))
SET RMSURE=$EXTRACT($PIECE(^VA(200,RMSURE,0),U,1),1,10)
+38 SET RDDT=$EXTRACT(RI,4,5)_"/"_$EXTRACT(RI,6,7)_"/"_$EXTRACT(RI,2,3)
+39 if RPDT'=""
SET RPDT=$EXTRACT(RPDT,4,5)_"/"_$EXTRACT(RPDT,6,7)_"/"_$EXTRACT(RPDT,2,3)
+40 if RCDT'=""
SET RCDT=$EXTRACT(RCDT,4,5)_"/"_$EXTRACT(RCDT,6,7)_"/"_$EXTRACT(RCDT,2,3)
+41 SET ^TMP($JOB,RI,RMPAT,RJ)=RMITEM_"^"_RDDT_"^"_RMTYRE_"^"_RMSURE_"^"_RMINI_"^"_RPDT_"^"_$EXTRACT(RMPRDI,1,10)
End DoDot:2
End DoDot:1
+42 QUIT
+43 ;
WRITE ;write report to a selected device
+1 SET (RI,RM,RMPREND)=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 RMTYRE=$PIECE(RMDAT,U,3)
+8 SET RMSURE=$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,?21,RMITEM,?40,RMTYRE,?50,RMSURE,?68,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 !,"Totals:",?10,"Routine Prosthetics = ",$JUSTIFY(RMPR("ROUTINE"),5)
+18 WRITE ?40,"Eyeglass = ",$JUSTIFY(RMPR("EYEGLASS"),5)
+19 WRITE ?59,"Contact Lens = ",$JUSTIFY(RMPR("CONTACT"),5)
+20 WRITE !,?17," Oxygen = ",$JUSTIFY(RMPR("OXYGEN"),5)
+21 WRITE ?42,"Manual = ",$JUSTIFY(RMPR("MANUAL"),5)
+22 WRITE !,"<End of Report>"
+23 QUIT
+24 ;
HEAD WRITE !,"PROSTHETICS PATIENT RECORDS 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 !?40,"TYPE OF",?52,"CPRS"
+4 WRITE !,"DATE",?10,"PATIENT",?21,"ITEM",?40,"REQUEST",?50,"REQUESTOR",?68,"INITIATOR"
+5 WRITE !,"----",?10,"-------",?21,"----",?40,"-------",?50,"---------",?68,"---------"
+6 SET RMPRFLG=1
+7 QUIT
+8 ;
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
+4 ;
SUMTYP ;get total of each type of request
+1 if RMTYRE["ROUTINE"
SET RMPR("ROUTINE")=RMPR("ROUTINE")+1
+2 if RMTYRE["EYEGLASS"
SET RMPR("EYEGLASS")=RMPR("EYEGLASS")+1
+3 if RMTYRE["CONTACT"
SET RMPR("CONTACT")=RMPR("CONTACT")+1
+4 if RMTYRE["OXYGEN"
SET RMPR("OXYGEN")=RMPR("OXYGEN")+1
+5 if RMTYRE["MANUAL"
SET RMPR("MANUAL")=RMPR("MANUAL")+1
+6 QUIT
+7 ;
NONE WRITE !!,"NO DATA TO PRINT !!!!!"
+1 QUIT
