RMPR5N1 ;HIN/RVD-PROS STOCK ITEM RECORDS ;3/17/03 13:19
;;3.0;PROSTHETICS;**33,77**;Feb 09, 1996
;RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION
D DIV4^RMPRSIT I $D(Y),(Y<0) Q
;
EN K ^TMP($J),RMPRI,RMPRFLG S RMPREND=0 D HOME^%ZIS S DIC="^RMPR(661.1,",DIC(0)="AEQM",DIC("S")="I $D(^RMPR(661.1,+Y,3,0))"
F HCPCS=1:1 S DIC("A")="Select HCPCS "_HCPCS_": " D ^DIC G:$D(DTOUT)!(X["^")!(X=""&(HCPCS=1)) EXIT1 Q:X="" D
.Q:'$D(^RMPR(661.1,+Y,0)) S RMHCPC=$P(^RMPR(661.1,+Y,0),U,1)
.I $D(RMPRI(RMHCPC)) W $C(7)," ??",?40,"..Duplicate HCPCS" S HCPCS=HCPCS-1 Q
.S:RMHCPC'="" RMPRI(RMHCPC)=+Y
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 EXIT 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 EXIT
I '$D(IO("Q")) U IO G PRINT
K IO("Q") S ZTDESC="STOCK ITEM REPORT",ZTRTN="PRINT^RMPR5N1",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 @IOF,!!,"Processing report......"
;Entry point of printing report.
S RMBDATE=$E(RMPRBDT,4,5)_"/"_$E(RMPRBDT,6,7)_"/"_$E(RMPRBDT,2,3)
I '$D(RMPRI) D NONEALL G EXIT
S RMPAGE=1,(RMPREND,RP,QTYT,RMIFL,RMCO,RMTOCO,RMTOCOH)=0
D HEAD
;
PRI S RQ="" F S RQ=$O(RMPRI(RQ)) Q:RQ="" S RMD=RMPRI(RQ) D PRI1
S R0="" D WRI
G EXIT
;
PRI1 S (RMSTAFL,RMSUF,RMQTYT)=0
S RO=0 F S RO=$O(^RMPR(661.2,"D",RMD,RO)) Q:(RO'>0)!(RMPREND) D REST
D:'RMSTAFL NONE
Q
;
EXIT ;EXIT FROM REPORT HERE
;I $E(IOST)["C"&($Y<22) F W ! Q:$Y>20
I $E(IOST)["C",'$D(DUOUT),'RMPREND K DIR S DIR(0)="E" D ^DIR
EXIT1 D ^%ZISC
N RMPR,RMPRSITE D KILL^XUSCLEAN
Q
;
REST ;
S RMSUF=1
S RMSSN=""
S RM2=$G(^RMPR(661.2,RO,0)) Q:RM2=""
Q:'$P(RM2,U,16)
S RMDAT=$P(RM2,U,1),RMSTA=$P(RM2,U,15) Q:RMSTA'=RMPR("STA")
Q:RMDAT<RMPRBDT!(RMDAT>RMPREDT)
S:RMSTA=RMPR("STA") RMSTAFL=1
S RMPAT=$P(RM2,U,2),RMSO=$P(RM2,U,3),RMUNI=$P(RM2,U,5),RMAVCO=$P(RM2,U,17)
S RMUSR=$P(RM2,U,7),RMBA=$P(RM2,U,8),RMCOM=$P(RM2,U,13),RMHI=$P(RM2,U,9)
S RMHCPC=$P(RMHI,"-",1),RMONO=$P(RM2,U,10),RMREC=$P(RM2,U,11),RMCUB=$P(RM2,U,12)
S RMDAHC=$O(^RMPR(661.1,"B",RMHCPC,0)) Q:'RMDAHC
S RMDAIT=$P(RMHI,"-",2),RMSER=$P(RM2,U,6)
S RMDAT=$E(RMDAT,4,5)_"/"_$E(RMDAT,6,7)_"/"_$E(RMDAT,2,3)
S RM1=$G(^RMPR(661.1,RMDAHC,3,RMDAIT,0))
Q:RM1=""
S RMITEM=$P(RM1,U,1)
SET ;
S ^TMP($J,RQ,RMITEM,RO)="^^"_RMPAT_"^"_RMSO_"^"_RMUSR_"^"_RMBA_"^"_RMONO_"^"_RMREC_"^"_RMCUB_"^"_RMCOM_"^"_RMAVCO_"^"_RMDAT_"^"_RMSER
Q
;
WRI S (RMFH,RMFI,RMPRFLG,RMTOCOH,RMTOCOI)=0
S RMITEM=""
F S R0=$O(^TMP($J,R0)) D:RMFH HTOTAL D:R0'="" HEAD1 Q:R0="" S R1="" F S R1=$O(^TMP($J,R0,R1)) D:RMFI ITOTAL Q:R1="" D:RMITEM'=R1 IHEAD F R2=0:0 S R2=$O(^TMP($J,R0,R1,R2)) Q:(R2'>0)!(RMPREND) D
.S RDATA=^TMP($J,R0,R1,R2)
.S RMDAT=$P(RDATA,U,12),RMAV=$P(RDATA,U,1),RMUNI=$P(RDATA,U,2)
.S RMPAT=$P(RDATA,U,3),RMSO=$P(RDATA,U,4)
.S RMUSR=$P(RDATA,U,5),RMQTY=$P(RDATA,U,6),RMONO=$P(RDATA,U,7)
.S RMREC=$P(RDATA,U,8),RMCUB=$P(RDATA,U,9),RMCOM=$P(RDATA,U,10)
.S RMSER=$E($P(RDATA,U,13),1,14)
.S RMAVCO=$P(RDATA,U,11) S:RMAVCO'="" RMCO=RMAVCO*RMQTY
.S RMITEM=R1
.I 'RMPRFLG D HEAD1
.S:RMUSR RMUSR=$E($P(^VA(200,RMUSR,0),U,1),1,12)
.S:RMPAT RMSSN=$E($P(^DPT(RMPAT,0),U,9),6,9)
.S (RMFH,RMFI)=1
.W !,RMDAT
.I RMPAT W ?9,$E($P(^DPT(RMPAT,0),U,1),1,14),?26,RMSSN,?31,RMUSR,?47,RMQTY,?59,RMSER,?73,$J(RMCUB,7,0) S:$G(RMCO) RMTOCO=RMTOCO+RMCO
.I 'RMPAT W ?11,"**Note: ",RMCOM,?49,$J(RMONO,4),?54,$J(RMREC,4),?73,$J(RMCUB,7,0) I RMCOM["Returned" S:$G(RMCO) RMTOCO=RMTOCO+RMCO
.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
;
HEAD W !,"*** ISSUE and STOCK CONTROL RECORD - PROSTHETICS STOCK ITEMS ***",?65,"Page: ",RMPAGE,!,?30,"station: ",$E($P($G(^DIC(4,RMPR("STA"),0)),U,1),1,20)
N X,% S Y=RMPRBDT D DD^%DT W !,Y," to " S Y=RMPREDT D DD^%DT W Y
S RMPAGE=RMPAGE+1
Q
;
IHEAD S RMDAHC=$O(^RMPR(661.1,"B",R0,0))
S RMITEM=$E(RMITEM,1,26)
W !,"HCPCS: ",R0,?16,"Item: ",R1
S RMI=1
Q
;
HEAD1 ;write heading
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
W !,RMPR("L")
W !,?44,"QTY",?50,"QTY",?55,"QTY",?63,"SERIAL"
W !," DATE",?9,"PATIENT",?26,"SSN",?31,"USER",?44,"ISSUE",?50,"ORDR",?55,"REC",?63,"NUMBER",?73,"BALANCE"
W !," ----",?9,"-------",?26,"---",?31,"----",?44,"-----",?50,"----",?55,"---",?63,"------",?73,"-------"
S RMPRFLG=1
Q
;
HTOTAL ;
I RMFH,'RMPREND W !!,?23,"*** Dollar Value of HCPCS Issued",?60,"=",?62,$J(RMTOCOH,11,2)
S (RMTOCOH,RMFH)=0
Q
;
ITOTAL ;
I RMFI,'RMPREND W !,?42,"--------------------------------------",!,?23,"*** Dollar Value of Item Issued",?60,"=",?62,$J(RMTOCO,11,2)
S RMTOCOH=RMTOCOH+RMTOCO,(RMTOCO,RMCO,RMFI)=0
Q
;
NONE ;nothing to report.
W !,RMPR("L"),!,"No Item Statistics for HCPCS: ",RQ,"...for this date range !!!"
Q
NONEALL W !!,"NO DATA AT THIS DATE RANGE!!!!"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5N1 5360 printed Dec 13, 2024@02:33:10 Page 2
RMPR5N1 ;HIN/RVD-PROS STOCK ITEM RECORDS ;3/17/03 13:19
+1 ;;3.0;PROSTHETICS;**33,77**;Feb 09, 1996
+2 ;RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION
+3 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
QUIT
+4 ;
EN KILL ^TMP($JOB),RMPRI,RMPRFLG
SET RMPREND=0
DO HOME^%ZIS
SET DIC="^RMPR(661.1,"
SET DIC(0)="AEQM"
SET DIC("S")="I $D(^RMPR(661.1,+Y,3,0))"
+1 FOR HCPCS=1:1
SET DIC("A")="Select HCPCS "_HCPCS_": "
DO ^DIC
if $DATA(DTOUT)!(X["^")!(X=""&(HCPCS=1))
GOTO EXIT1
if X=""
QUIT
Begin DoDot:1
+2 if '$DATA(^RMPR(661.1,+Y,0))
QUIT
SET RMHCPC=$PIECE(^RMPR(661.1,+Y,0),U,1)
+3 IF $DATA(RMPRI(RMHCPC))
WRITE $CHAR(7)," ??",?40,"..Duplicate HCPCS"
SET HCPCS=HCPCS-1
QUIT
+4 if RMHCPC'=""
SET RMPRI(RMHCPC)=+Y
End DoDot:1
+5 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 EXIT
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 EXIT
+3 IF '$DATA(IO("Q"))
USE IO
GOTO PRINT
+4 KILL IO("Q")
SET ZTDESC="STOCK ITEM REPORT"
SET ZTRTN="PRINT^RMPR5N1"
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
+6 ;
PRINT IF $EXTRACT(IOST)["C"
WRITE @IOF,!!,"Processing report......"
+1 ;Entry point of printing report.
+2 SET RMBDATE=$EXTRACT(RMPRBDT,4,5)_"/"_$EXTRACT(RMPRBDT,6,7)_"/"_$EXTRACT(RMPRBDT,2,3)
+3 IF '$DATA(RMPRI)
DO NONEALL
GOTO EXIT
+4 SET RMPAGE=1
SET (RMPREND,RP,QTYT,RMIFL,RMCO,RMTOCO,RMTOCOH)=0
+5 DO HEAD
+6 ;
PRI SET RQ=""
FOR
SET RQ=$ORDER(RMPRI(RQ))
if RQ=""
QUIT
SET RMD=RMPRI(RQ)
DO PRI1
+1 SET R0=""
DO WRI
+2 GOTO EXIT
+3 ;
PRI1 SET (RMSTAFL,RMSUF,RMQTYT)=0
+1 SET RO=0
FOR
SET RO=$ORDER(^RMPR(661.2,"D",RMD,RO))
if (RO'>0)!(RMPREND)
QUIT
DO REST
+2 if 'RMSTAFL
DO NONE
+3 QUIT
+4 ;
EXIT ;EXIT FROM REPORT HERE
+1 ;I $E(IOST)["C"&($Y<22) F W ! Q:$Y>20
+2 IF $EXTRACT(IOST)["C"
IF '$DATA(DUOUT)
IF 'RMPREND
KILL DIR
SET DIR(0)="E"
DO ^DIR
EXIT1 DO ^%ZISC
+1 NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
+2 QUIT
+3 ;
REST ;
+1 SET RMSUF=1
+2 SET RMSSN=""
+3 SET RM2=$GET(^RMPR(661.2,RO,0))
if RM2=""
QUIT
+4 if '$PIECE(RM2,U,16)
QUIT
+5 SET RMDAT=$PIECE(RM2,U,1)
SET RMSTA=$PIECE(RM2,U,15)
if RMSTA'=RMPR("STA")
QUIT
+6 if RMDAT<RMPRBDT!(RMDAT>RMPREDT)
QUIT
+7 if RMSTA=RMPR("STA")
SET RMSTAFL=1
+8 SET RMPAT=$PIECE(RM2,U,2)
SET RMSO=$PIECE(RM2,U,3)
SET RMUNI=$PIECE(RM2,U,5)
SET RMAVCO=$PIECE(RM2,U,17)
+9 SET RMUSR=$PIECE(RM2,U,7)
SET RMBA=$PIECE(RM2,U,8)
SET RMCOM=$PIECE(RM2,U,13)
SET RMHI=$PIECE(RM2,U,9)
+10 SET RMHCPC=$PIECE(RMHI,"-",1)
SET RMONO=$PIECE(RM2,U,10)
SET RMREC=$PIECE(RM2,U,11)
SET RMCUB=$PIECE(RM2,U,12)
+11 SET RMDAHC=$ORDER(^RMPR(661.1,"B",RMHCPC,0))
if 'RMDAHC
QUIT
+12 SET RMDAIT=$PIECE(RMHI,"-",2)
SET RMSER=$PIECE(RM2,U,6)
+13 SET RMDAT=$EXTRACT(RMDAT,4,5)_"/"_$EXTRACT(RMDAT,6,7)_"/"_$EXTRACT(RMDAT,2,3)
+14 SET RM1=$GET(^RMPR(661.1,RMDAHC,3,RMDAIT,0))
+15 if RM1=""
QUIT
+16 SET RMITEM=$PIECE(RM1,U,1)
SET ;
+1 SET ^TMP($JOB,RQ,RMITEM,RO)="^^"_RMPAT_"^"_RMSO_"^"_RMUSR_"^"_RMBA_"^"_RMONO_"^"_RMREC_"^"_RMCUB_"^"_RMCOM_"^"_RMAVCO_"^"_RMDAT_"^"_RMSER
+2 QUIT
+3 ;
WRI SET (RMFH,RMFI,RMPRFLG,RMTOCOH,RMTOCOI)=0
+1 SET RMITEM=""
+2 FOR
SET R0=$ORDER(^TMP($JOB,R0))
if RMFH
DO HTOTAL
if R0'=""
DO HEAD1
if R0=""
QUIT
SET R1=""
FOR
SET R1=$ORDER(^TMP($JOB,R0,R1))
if RMFI
DO ITOTAL
if R1=""
QUIT
if RMITEM'=R1
DO IHEAD
FOR R2=0:0
SET R2=$ORDER(^TMP($JOB,R0,R1,R2))
if (R2'>0)!(RMPREND)
QUIT
Begin DoDot:1
+3 SET RDATA=^TMP($JOB,R0,R1,R2)
+4 SET RMDAT=$PIECE(RDATA,U,12)
SET RMAV=$PIECE(RDATA,U,1)
SET RMUNI=$PIECE(RDATA,U,2)
+5 SET RMPAT=$PIECE(RDATA,U,3)
SET RMSO=$PIECE(RDATA,U,4)
+6 SET RMUSR=$PIECE(RDATA,U,5)
SET RMQTY=$PIECE(RDATA,U,6)
SET RMONO=$PIECE(RDATA,U,7)
+7 SET RMREC=$PIECE(RDATA,U,8)
SET RMCUB=$PIECE(RDATA,U,9)
SET RMCOM=$PIECE(RDATA,U,10)
+8 SET RMSER=$EXTRACT($PIECE(RDATA,U,13),1,14)
+9 SET RMAVCO=$PIECE(RDATA,U,11)
if RMAVCO'=""
SET RMCO=RMAVCO*RMQTY
+10 SET RMITEM=R1
+11 IF 'RMPRFLG
DO HEAD1
+12 if RMUSR
SET RMUSR=$EXTRACT($PIECE(^VA(200,RMUSR,0),U,1),1,12)
+13 if RMPAT
SET RMSSN=$EXTRACT($PIECE(^DPT(RMPAT,0),U,9),6,9)
+14 SET (RMFH,RMFI)=1
+15 WRITE !,RMDAT
+16 IF RMPAT
WRITE ?9,$EXTRACT($PIECE(^DPT(RMPAT,0),U,1),1,14),?26,RMSSN,?31,RMUSR,?47,RMQTY,?59,RMSER,?73,$JUSTIFY(RMCUB,7,0)
if $GET(RMCO)
SET RMTOCO=RMTOCO+RMCO
+17 IF 'RMPAT
WRITE ?11,"**Note: ",RMCOM,?49,$JUSTIFY(RMONO,4),?54,$JUSTIFY(RMREC,4),?73,$JUSTIFY(RMCUB,7,0)
IF RMCOM["Returned"
if $GET(RMCO)
SET RMTOCO=RMTOCO+RMCO
+18 SET RMPRFLG=1
+19 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
+20 IF $Y>(IOSL-6)
WRITE @IOF
DO HEAD
DO HEAD1
SET RMPRFLG=1
End DoDot:1
+21 QUIT
+22 ;
HEAD WRITE !,"*** ISSUE and STOCK CONTROL RECORD - PROSTHETICS STOCK ITEMS ***",?65,"Page: ",RMPAGE,!,?30,"station: ",$EXTRACT($PIECE($GET(^DIC(4,RMPR("STA"),0)),U,1),1,20)
+1 NEW X,%
SET Y=RMPRBDT
DO DD^%DT
WRITE !,Y," to "
SET Y=RMPREDT
DO DD^%DT
WRITE Y
+2 SET RMPAGE=RMPAGE+1
+3 QUIT
+4 ;
IHEAD SET RMDAHC=$ORDER(^RMPR(661.1,"B",R0,0))
+1 SET RMITEM=$EXTRACT(RMITEM,1,26)
+2 WRITE !,"HCPCS: ",R0,?16,"Item: ",R1
+3 SET RMI=1
+4 QUIT
+5 ;
HEAD1 ;write heading
+1 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
+2 WRITE !,RMPR("L")
+3 WRITE !,?44,"QTY",?50,"QTY",?55,"QTY",?63,"SERIAL"
+4 WRITE !," DATE",?9,"PATIENT",?26,"SSN",?31,"USER",?44,"ISSUE",?50,"ORDR",?55,"REC",?63,"NUMBER",?73,"BALANCE"
+5 WRITE !," ----",?9,"-------",?26,"---",?31,"----",?44,"-----",?50,"----",?55,"---",?63,"------",?73,"-------"
+6 SET RMPRFLG=1
+7 QUIT
+8 ;
HTOTAL ;
+1 IF RMFH
IF 'RMPREND
WRITE !!,?23,"*** Dollar Value of HCPCS Issued",?60,"=",?62,$JUSTIFY(RMTOCOH,11,2)
+2 SET (RMTOCOH,RMFH)=0
+3 QUIT
+4 ;
ITOTAL ;
+1 IF RMFI
IF 'RMPREND
WRITE !,?42,"--------------------------------------",!,?23,"*** Dollar Value of Item Issued",?60,"=",?62,$JUSTIFY(RMTOCO,11,2)
+2 SET RMTOCOH=RMTOCOH+RMTOCO
SET (RMTOCO,RMCO,RMFI)=0
+3 QUIT
+4 ;
NONE ;nothing to report.
+1 WRITE !,RMPR("L"),!,"No Item Statistics for HCPCS: ",RQ,"...for this date range !!!"
+2 QUIT
NONEALL WRITE !!,"NO DATA AT THIS DATE RANGE!!!!"
+1 QUIT
