RMPRPI09 ;HIN/RVD-PRINT ORDER AND RECIEVE ITEM REPORT ;9/18/02 15:13
;;3.0;PROSTHETICS;**61,132**;Feb 09, 1996;Build 13
;
;DBIA #800 - global read of file #440.
;
D DIV4^RMPRSIT I $D(Y),(Y<0) Q
S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
;
EN K RMPRI S RMPREND=0 D HOME^%ZIS
;
TYPE ;select type of report
K DIR
S DIR(0)="S^1:30 Days Old or Less;2:60 Days Old or Less;3:90 Days Old or Less;4:Over 90 Days Old or Less "
S DIR("A")="Select number of days old",DIR("B")="30 Days Old or Less"
D ^DIR
I Y="",$D(DTOUT) G EXIT1
I Y="^"!(Y="^^") G EXIT1
S RMTY=Y
;
;
CAT ;select STATUS of report
K DIR
S DIR(0)="S^O:OPEN;R:RECIEVED;C:CANCEL"
S DIR("A")="Select Category of report",DIR("B")="OPEN"
D ^DIR
I Y="",$D(DTOUT) G EXIT1
I Y="^"!(Y="^^") G EXIT1
S RMCAT=Y
K DIR
;
DT ;
S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT1
I '$D(IO("Q")) U IO G PRINT
K IO("Q") S ZTDESC="PIP ORDER AND RECEIVE ITEM REPORT"
S ZTRTN="PRINT^RMPRPI09",ZTIO=ION,ZTSAVE("RMPR(")=""
S ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMDAT")=""
S ZTSAVE("RMTY")="",ZTSAVE("RMDRA")="",ZTSAVE("RMCAT")=""
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT1
;
PRINT I $E(IOST)["C" W !!,"Processing report....."
K RMPRT,RMPRFLG,^TMP($J)
S RMCAL=$S(RMTY=1:30,RMTY=2:60,RMTY=3:90,RMTY=4:"OVER 90")
S X="T-"_RMCAL D ^%DT S RDT=Y-1 K Y S:'RDT RDT=0
S RMCAY=$S(RMCAT="O":"OPEN",RMCAT="R":"RECIEVED",RMCAT="C":"CANCEL")
S RS=RMPR("STA")
S RMPAGE=1,RMPREND=0
W:$E(IOST)["C" @IOF
D HEAD
G:RMCAT="R" REC
;
OPCA ;for open and cancel order
S RI=""
F STS=RMCAT,"R" Q:STS="R"&(RMCAT="C") F S RI=$O(^RMPR(661.41,"ASSHID",RS,STS,RI)) Q:RI=""!RMPREND=1 F RK=0:0 S RK=$O(^RMPR(661.41,"ASSHID",RS,STS,RI,RK)) Q:RK'>0!RMPREND=1 D
.F RM=RDT:0 S RM=$O(^RMPR(661.41,"ASSHID",RS,STS,RI,RK,RM)) Q:RM'>0!RMPREND=1 D
..F RN=0:0 S RN=$O(^RMPR(661.41,"ASSHID",RS,STS,RI,RK,RM,RN)) Q:RN'>0!RMPREND=1 D
...S RM3=$G(^RMPR(661.41,RN,0))
...I $P(RM3,U,8)-$P(RM3,U,9)<1 Q
...S ^TMP($J,"RMPRPI09",RS,RMCAT,RI,RK,RM,RN)=""
...Q
S RI=""
F S RI=$O(^TMP($J,"RMPRPI09",RS,RMCAT,RI)) Q:RI=""!RMPREND=1 F RK=0:0 S RK=$O(^TMP($J,"RMPRPI09",RS,RMCAT,RI,RK)) Q:RK'>0!RMPREND=1 D
.F RM=RDT:0 S RM=$O(^TMP($J,"RMPRPI09",RS,RMCAT,RI,RK,RM)) Q:RM'>0!RMPREND=1 D
..F RN=0:0 S RN=$O(^TMP($J,"RMPRPI09",RS,RMCAT,RI,RK,RM,RN)) Q:RN'>0!RMPREND=1 D
...S RM3=$G(^RMPR(661.41,RN,0))
...S (RMVNAM,RMIDE)=""
...S RMDOR=$P(RM3,U,1)
...S RMIT=$P(RM3,U,2)
...S RMVEN=$P(RM3,U,5)
...S RMHCPC=$P(RM3,U,6)
...S RMDRE=$P(RM3,U,7)
...S RMQOR=$P(RM3,U,8)
...S RMQRE=$P(RM3,U,9)
...S RMCOM=$P(RM3,U,10)
...S RMSTA=$P(RM3,U,11)
...I '$D(RMPRFLG) D HEAD1
...S:RMDOR RMDOR=$E(RMDOR,4,5)_"/"_$E(RMDOR,6,7)_"/"_$E(RMDOR,2,3)
...S:RMDRE RMDRE=$E(RMDRE,4,5)_"/"_$E(RMDRE,6,7)_"/"_$E(RMDRE,2,3)
...S:RMVEN RMVNAM=$P($G(^PRC(440,RMVEN,0)),U,1)
...S RMIDA=$O(^RMPR(661.11,"ASHI",RS,RMHCPC,RMIT,0))
...S:RMIDA RMIDE=$P($G(^RMPR(661.11,RMIDA,0)),U,3)
...W !,RMHCPC_"-"_RMIT,?10,$E(RMIDE,1,20),?31,$E(RMVNAM,1,11),?44,RMDOR,?54,RMDRE,?64,$J(RMQOR,6),?72,$J(RMQRE,6)
...W:RMCOM'="" !,?5,"Comment: ",RMCOM
...S (RMPRFLG,RMPRT)=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 Q
W:$G(RMPRT) !,RMPR("L"),!,"<End of Report>"
G EXIT
;
REC ;process a Recieved order.
S RI=""
F S RI=$O(^RMPR(661.6,"ASTHIDS",RS,1,RI)) Q:RI=""!RMPREND=1 F RK=0:0 S RK=$O(^RMPR(661.6,"ASTHIDS",RS,1,RI,RK)) Q:RK'>0!RMPREND=1 D
.F RM=RDT:0 S RM=$O(^RMPR(661.6,"ASTHIDS",RS,1,RI,RK,RM)) Q:RM'>0!RMPREND=1 D
..F RN=0:0 S RN=$O(^RMPR(661.6,"ASTHIDS",RS,1,RI,RK,RM,RN)) Q:RN'>0!RMPREND=1 F RP=0:0 S RP=$O(^RMPR(661.6,"ASTHIDS",RS,1,RI,RK,RM,RN,RP)) Q:RP'>0!RMPREND=1 D
...S RM3=$G(^RMPR(661.6,RP,0))
...S (RMVNAM,RMIDE)=""
...S RMDOR=$P(RM3,U,1)
...S RMIT=RK
...S RMVEN=$P(RM3,U,12)
...S RMHCPC=RI
...S RMDRE=RM
...S RMQOR=""
...S RMQRE=$P(RM3,U,5)
...S RMCOM=$P(RM3,U,8)
...S RMSTA=RS
...I '$D(RMPRFLG) D HEAD1
...;S:RMDOR RMDOR=$E(RMDOR,4,5)_"/"_$E(RMDOR,6,7)_"/"_$E(RMDOR,2,3)
...S:RMDRE RMDRE=$E(RMDRE,4,5)_"/"_$E(RMDRE,6,7)_"/"_$E(RMDRE,2,3)
...S:RMVEN RMVNAM=$P($G(^PRC(440,RMVEN,0)),U,1)
...S RMIDA=$O(^RMPR(661.11,"ASHI",RS,RMHCPC,RMIT,0))
...S:RMIDA RMIDE=$P($G(^RMPR(661.11,RMIDA,0)),U,3)
...W !,RMHCPC_"-"_RMIT,?10,$E(RMIDE,1,20),?31,$E(RMVNAM,1,11),?54,RMDRE,?64,$J(RMQOR,6),?72,$J(RMQRE,6)
...W:RMCOM'="" !,?5,"Comment: ",RMCOM
...S (RMPRFLG,RMPRT)=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 Q
W:$G(RMPRT) !,RMPR("L"),!,"<End of Report>"
G EXIT
;
HEAD W !,"*** PIP ORDER AND RECEIVE ITEM REPORT ***"," for ",RMCAL," days old or Less, ",RMCAY," order"
W !,"Station: ",$E($P($G(^DIC(4,RS,0)),U,1),1,20),?30,"Run Date: ",RMDAT
W ?68,"PAGE: ",RMPAGE
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 !,?45,"DATE",?56,"DATE",?66,"QTY",?75,"QTY"
W !,"HCPCS",?10,"ITEM",?31,"VENDOR",?44,"ORDERED",?54,"RECIEVED"
W ?64,"ORDERED",?72,"RECIEVED"
W !,"-----",?10,"----",?31,"------",?44,"-------",?54,"--------"
W ?64,"-------",?72,"--------"
S RMPRFLG=1
Q
;
EXIT W:'$G(RMPRT) !,RMPR("L"),!!,"No DATA to print !!!"
I $E(IOST)["C",'RMPREND W ! S DIR(0)="E" D ^DIR
;
EXIT1 D ^%ZISC
K ^TMP($J)
N RMPR,RMPRSITE D KILL^XUSCLEAN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPI09 5591 printed Apr 09, 2024@21:35:08 Page 2
RMPRPI09 ;HIN/RVD-PRINT ORDER AND RECIEVE ITEM REPORT ;9/18/02 15:13
+1 ;;3.0;PROSTHETICS;**61,132**;Feb 09, 1996;Build 13
+2 ;
+3 ;DBIA #800 - global read of file #440.
+4 ;
+5 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
QUIT
+6 SET X="NOW"
DO ^%DT
DO DD^%DT
SET RMDAT=Y
+7 ;
EN KILL RMPRI
SET RMPREND=0
DO HOME^%ZIS
+1 ;
TYPE ;select type of report
+1 KILL DIR
+2 SET DIR(0)="S^1:30 Days Old or Less;2:60 Days Old or Less;3:90 Days Old or Less;4:Over 90 Days Old or Less "
+3 SET DIR("A")="Select number of days old"
SET DIR("B")="30 Days Old or Less"
+4 DO ^DIR
+5 IF Y=""
IF $DATA(DTOUT)
GOTO EXIT1
+6 IF Y="^"!(Y="^^")
GOTO EXIT1
+7 SET RMTY=Y
+8 ;
+9 ;
CAT ;select STATUS of report
+1 KILL DIR
+2 SET DIR(0)="S^O:OPEN;R:RECIEVED;C:CANCEL"
+3 SET DIR("A")="Select Category of report"
SET DIR("B")="OPEN"
+4 DO ^DIR
+5 IF Y=""
IF $DATA(DTOUT)
GOTO EXIT1
+6 IF Y="^"!(Y="^^")
GOTO EXIT1
+7 SET RMCAT=Y
+8 KILL DIR
+9 ;
DT ;
+1 SET %ZIS="MQ"
KILL IOP
DO ^%ZIS
if POP
GOTO EXIT1
+2 IF '$DATA(IO("Q"))
USE IO
GOTO PRINT
+3 KILL IO("Q")
SET ZTDESC="PIP ORDER AND RECEIVE ITEM REPORT"
+4 SET ZTRTN="PRINT^RMPRPI09"
SET ZTIO=ION
SET ZTSAVE("RMPR(")=""
+5 SET ZTSAVE("RMPR(""STA"")")=""
SET ZTSAVE("RMDAT")=""
+6 SET ZTSAVE("RMTY")=""
SET ZTSAVE("RMDRA")=""
SET ZTSAVE("RMCAT")=""
+7 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!"
HANG 1
GOTO EXIT1
+8 ;
PRINT IF $EXTRACT(IOST)["C"
WRITE !!,"Processing report....."
+1 KILL RMPRT,RMPRFLG,^TMP($JOB)
+2 SET RMCAL=$SELECT(RMTY=1:30,RMTY=2:60,RMTY=3:90,RMTY=4:"OVER 90")
+3 SET X="T-"_RMCAL
DO ^%DT
SET RDT=Y-1
KILL Y
if 'RDT
SET RDT=0
+4 SET RMCAY=$SELECT(RMCAT="O":"OPEN",RMCAT="R":"RECIEVED",RMCAT="C":"CANCEL")
+5 SET RS=RMPR("STA")
+6 SET RMPAGE=1
SET RMPREND=0
+7 if $EXTRACT(IOST)["C"
WRITE @IOF
+8 DO HEAD
+9 if RMCAT="R"
GOTO REC
+10 ;
OPCA ;for open and cancel order
+1 SET RI=""
+2 FOR STS=RMCAT,"R"
if STS="R"&(RMCAT="C")
QUIT
FOR
SET RI=$ORDER(^RMPR(661.41,"ASSHID",RS,STS,RI))
if RI=""!RMPREND=1
QUIT
FOR RK=0:0
SET RK=$ORDER(^RMPR(661.41,"ASSHID",RS,STS,RI,RK))
if RK'>0!RMPREND=1
QUIT
Begin DoDot:1
+3 FOR RM=RDT:0
SET RM=$ORDER(^RMPR(661.41,"ASSHID",RS,STS,RI,RK,RM))
if RM'>0!RMPREND=1
QUIT
Begin DoDot:2
+4 FOR RN=0:0
SET RN=$ORDER(^RMPR(661.41,"ASSHID",RS,STS,RI,RK,RM,RN))
if RN'>0!RMPREND=1
QUIT
Begin DoDot:3
+5 SET RM3=$GET(^RMPR(661.41,RN,0))
+6 IF $PIECE(RM3,U,8)-$PIECE(RM3,U,9)<1
QUIT
+7 SET ^TMP($JOB,"RMPRPI09",RS,RMCAT,RI,RK,RM,RN)=""
+8 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+9 SET RI=""
+10 FOR
SET RI=$ORDER(^TMP($JOB,"RMPRPI09",RS,RMCAT,RI))
if RI=""!RMPREND=1
QUIT
FOR RK=0:0
SET RK=$ORDER(^TMP($JOB,"RMPRPI09",RS,RMCAT,RI,RK))
if RK'>0!RMPREND=1
QUIT
Begin DoDot:1
+11 FOR RM=RDT:0
SET RM=$ORDER(^TMP($JOB,"RMPRPI09",RS,RMCAT,RI,RK,RM))
if RM'>0!RMPREND=1
QUIT
Begin DoDot:2
+12 FOR RN=0:0
SET RN=$ORDER(^TMP($JOB,"RMPRPI09",RS,RMCAT,RI,RK,RM,RN))
if RN'>0!RMPREND=1
QUIT
Begin DoDot:3
+13 SET RM3=$GET(^RMPR(661.41,RN,0))
+14 SET (RMVNAM,RMIDE)=""
+15 SET RMDOR=$PIECE(RM3,U,1)
+16 SET RMIT=$PIECE(RM3,U,2)
+17 SET RMVEN=$PIECE(RM3,U,5)
+18 SET RMHCPC=$PIECE(RM3,U,6)
+19 SET RMDRE=$PIECE(RM3,U,7)
+20 SET RMQOR=$PIECE(RM3,U,8)
+21 SET RMQRE=$PIECE(RM3,U,9)
+22 SET RMCOM=$PIECE(RM3,U,10)
+23 SET RMSTA=$PIECE(RM3,U,11)
+24 IF '$DATA(RMPRFLG)
DO HEAD1
+25 if RMDOR
SET RMDOR=$EXTRACT(RMDOR,4,5)_"/"_$EXTRACT(RMDOR,6,7)_"/"_$EXTRACT(RMDOR,2,3)
+26 if RMDRE
SET RMDRE=$EXTRACT(RMDRE,4,5)_"/"_$EXTRACT(RMDRE,6,7)_"/"_$EXTRACT(RMDRE,2,3)
+27 if RMVEN
SET RMVNAM=$PIECE($GET(^PRC(440,RMVEN,0)),U,1)
+28 SET RMIDA=$ORDER(^RMPR(661.11,"ASHI",RS,RMHCPC,RMIT,0))
+29 if RMIDA
SET RMIDE=$PIECE($GET(^RMPR(661.11,RMIDA,0)),U,3)
+30 WRITE !,RMHCPC_"-"_RMIT,?10,$EXTRACT(RMIDE,1,20),?31,$EXTRACT(RMVNAM,1,11),?44,RMDOR,?54,RMDRE,?64,$JUSTIFY(RMQOR,6),?72,$JUSTIFY(RMQRE,6)
+31 if RMCOM'=""
WRITE !,?5,"Comment: ",RMCOM
+32 SET (RMPRFLG,RMPRT)=1
+33 IF $EXTRACT(IOST)["C"
IF ($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
+34 IF $Y>(IOSL-6)
WRITE @IOF
DO HEAD
DO HEAD1
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+35 if $GET(RMPRT)
WRITE !,RMPR("L"),!,"<End of Report>"
+36 GOTO EXIT
+37 ;
REC ;process a Recieved order.
+1 SET RI=""
+2 FOR
SET RI=$ORDER(^RMPR(661.6,"ASTHIDS",RS,1,RI))
if RI=""!RMPREND=1
QUIT
FOR RK=0:0
SET RK=$ORDER(^RMPR(661.6,"ASTHIDS",RS,1,RI,RK))
if RK'>0!RMPREND=1
QUIT
Begin DoDot:1
+3 FOR RM=RDT:0
SET RM=$ORDER(^RMPR(661.6,"ASTHIDS",RS,1,RI,RK,RM))
if RM'>0!RMPREND=1
QUIT
Begin DoDot:2
+4 FOR RN=0:0
SET RN=$ORDER(^RMPR(661.6,"ASTHIDS",RS,1,RI,RK,RM,RN))
if RN'>0!RMPREND=1
QUIT
FOR RP=0:0
SET RP=$ORDER(^RMPR(661.6,"ASTHIDS",RS,1,RI,RK,RM,RN,RP))
if RP'>0!RMPREND=1
QUIT
Begin DoDot:3
+5 SET RM3=$GET(^RMPR(661.6,RP,0))
+6 SET (RMVNAM,RMIDE)=""
+7 SET RMDOR=$PIECE(RM3,U,1)
+8 SET RMIT=RK
+9 SET RMVEN=$PIECE(RM3,U,12)
+10 SET RMHCPC=RI
+11 SET RMDRE=RM
+12 SET RMQOR=""
+13 SET RMQRE=$PIECE(RM3,U,5)
+14 SET RMCOM=$PIECE(RM3,U,8)
+15 SET RMSTA=RS
+16 IF '$DATA(RMPRFLG)
DO HEAD1
+17 ;S:RMDOR RMDOR=$E(RMDOR,4,5)_"/"_$E(RMDOR,6,7)_"/"_$E(RMDOR,2,3)
+18 if RMDRE
SET RMDRE=$EXTRACT(RMDRE,4,5)_"/"_$EXTRACT(RMDRE,6,7)_"/"_$EXTRACT(RMDRE,2,3)
+19 if RMVEN
SET RMVNAM=$PIECE($GET(^PRC(440,RMVEN,0)),U,1)
+20 SET RMIDA=$ORDER(^RMPR(661.11,"ASHI",RS,RMHCPC,RMIT,0))
+21 if RMIDA
SET RMIDE=$PIECE($GET(^RMPR(661.11,RMIDA,0)),U,3)
+22 WRITE !,RMHCPC_"-"_RMIT,?10,$EXTRACT(RMIDE,1,20),?31,$EXTRACT(RMVNAM,1,11),?54,RMDRE,?64,$JUSTIFY(RMQOR,6),?72,$JUSTIFY(RMQRE,6)
+23 if RMCOM'=""
WRITE !,?5,"Comment: ",RMCOM
+24 SET (RMPRFLG,RMPRT)=1
+25 IF $EXTRACT(IOST)["C"
IF ($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
+26 IF $Y>(IOSL-6)
WRITE @IOF
DO HEAD
DO HEAD1
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+27 if $GET(RMPRT)
WRITE !,RMPR("L"),!,"<End of Report>"
+28 GOTO EXIT
+29 ;
HEAD WRITE !,"*** PIP ORDER AND RECEIVE ITEM REPORT ***"," for ",RMCAL," days old or Less, ",RMCAY," order"
+1 WRITE !,"Station: ",$EXTRACT($PIECE($GET(^DIC(4,RS,0)),U,1),1,20),?30,"Run Date: ",RMDAT
+2 WRITE ?68,"PAGE: ",RMPAGE
+3 SET RMPAGE=RMPAGE+1
+4 QUIT
+5 ;
HEAD1 IF $EXTRACT(IOST)["C"
IF ($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"
IF ($Y>(IOSL-6))
WRITE @IOF
DO HEAD
+2 WRITE !,RMPR("L")
+3 WRITE !,?45,"DATE",?56,"DATE",?66,"QTY",?75,"QTY"
+4 WRITE !,"HCPCS",?10,"ITEM",?31,"VENDOR",?44,"ORDERED",?54,"RECIEVED"
+5 WRITE ?64,"ORDERED",?72,"RECIEVED"
+6 WRITE !,"-----",?10,"----",?31,"------",?44,"-------",?54,"--------"
+7 WRITE ?64,"-------",?72,"--------"
+8 SET RMPRFLG=1
+9 QUIT
+10 ;
EXIT if '$GET(RMPRT)
WRITE !,RMPR("L"),!!,"No DATA to print !!!"
+1 IF $EXTRACT(IOST)["C"
IF 'RMPREND
WRITE !
SET DIR(0)="E"
DO ^DIR
+2 ;
EXIT1 DO ^%ZISC
+1 KILL ^TMP($JOB)
+2 NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
+3 QUIT
