RMPRPI04 ;HIN/RVD-PROS STOCK ITEM RECORDS ;3/8/05 11:24
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
; DBIA #10090 - Read Access to entire file #4.
;
D DIV4^RMPRSIT I $D(Y),(Y<0) Q
S RS=RMPR("STA")
;
EN K ^TMP($J),RMPRI,RMPRFLG S RMPREND=0 D HOME^%ZIS
S DIC="^RMPR(661.1,",DIC(0)="AEQM"
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"
S %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^RMPRPI04",ZTIO=ION
S ZTSAVE("RMPRBDT")="",ZTSAVE("RMPREDT")="",ZTSAVE("RMPRI(")=""
S ZTSAVE("RMPRX")="",ZTSAVE("RMPRY")="",ZTSAVE("RMPR(""STA"")")=""
S ZTSAVE("RMPR(")=""
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT1
;
;Entry point for printing report.
PRINT I $E(IOST)["C" W @IOF,!!,"Processing report......"
I '$D(RMPRI) D NONEALL G EXIT
;call API
;input variables:
; RM = 'RM' subscript
; RS = station
; RMPRI = array of HCPCS
; RMPRBDT = beginning date
; RMPREDT = ending date
;
S RS=RMPR("STA"),RM="RM"
S RMCHK=$$THIS^RMPRPI03(RM,RS,RMPRBDT,RMPREDT,.RMPRI)
I RMCHK W !!,"ERROR NUMBER = ",RMCHK,!,"*** Error in API RMPRPI03 !!!" G EXIT
;
S RMBDATE=$E(RMPRBDT,4,5)_"/"_$E(RMPRBDT,6,7)_"/"_$E(RMPRBDT,2,3)
S RMPAGE=1
S (RMPREND,RP,QTYT,RMIFL,RMCO,RMTOCO,RMTOCOH,RMSTAFL,RMSUF,RMQTYT)=0
D HEAD
S RQ="" F S RQ=$O(RMPRI(RQ)) Q:RQ="" I '$D(^TMP($J,"RM",RQ)) D NONE
D WRI
W !,"<End of Report>"
;
EXIT ;exit here if report prints in home device.
I $E(IOST)["C",'$D(DUOUT),'$G(RMPREND) K DIR S DIR(0)="E" D ^DIR
;
EXIT1 ;close device and clean-up variables.
D ^%ZISC
N RMPR,RMPRSITE D KILL^XUSCLEAN
K ^TMP($J)
Q
;end of processing (exit program)
;
; RH = HCPCS
; RI = HCPCS ITEM NAME
; R2 = ITEM NUMBER
; R3 =SEQUENCE
;
WRI S (RMFH,RMFI,RMPRFLG,RMTOCO,RMTOCOH,RMTOCOI)=0
S (RMITEM,RH)=""
F S RH=$O(^TMP($J,"RM",RH)) D:RMFH HTOTAL D:RH'="" HEAD1 Q:RH="" S (RIT2,RI)="" F S RI=$O(^TMP($J,"RM",RH,RI)) Q:RI="" D
.F R2=0:0 S R2=$O(^TMP($J,"RM",RH,RI,R2)) D:RMFI ITOTAL Q:(R2'>0)!(RMPREND) D:RIT2'=R2 IHEAD F R3=0:0 S R3=$O(^TMP($J,"RM",RH,RI,R2,R3)) Q:(R3'>0)!(RMPREND) D
..S RDATA=^TMP($J,"RM",RH,RI,R2,R3)
..S RMDAT=$P(RDATA,U,1),RMTIM=$P(RDATA,U,2),RMOPE=$P(RDATA,U,3)
..S RMCLO=$P(RDATA,U,4),RMQTY=$P(RDATA,U,5)
..S RMVAL=$P(RDATA,U,6),RMTRA=$P(RDATA,U,7),RMPAT=$P(RDATA,U,8)
..S RMSSN=$P(RDATA,U,9),RMUSE=$E($P(RDATA,U,10),1,10)
..S RMITE=$P(RDATA,U,11)
..S RMAVCO=$P(RDATA,U,11) S:RMAVCO'="" RMCO=RMAVCO*RMQTY
..S RIT2=R2
..I 'RMPRFLG D HEAD1
..S (RMFH,RMFI)=1
..W !,RMDAT
..I RMPAT'="" D
...W ?9,$E(RMPAT,1,14),?26,$P(RMSSN,"-",3),?31,RMUSE,?45,$J(RMQTY,4)
...W ?69,$J(RMVAL,9,2)
..I RMTRA="PATIENT ISSUE" S RMTOCO=RMTOCO+RMVAL
..I RMTRA="RETURN IN" S RMTOCO=RMTOCO-RMVAL
..I RMPAT="" D
...W:RMTRA="RECEIPT" ?9,"**Note: ",RMTRA,?31,RMUSE,?60,$J(RMQTY,4),?69,$J(RMVAL,9,2)
...W:RMTRA="ORDER" ?9,"**Note: ",RMTRA,?31,RMUSE,?54,$J(RMQTY,4),?69,$J(RMVAL,9,2)
...I (RMTRA'="RECEIPT"),(RMTRA'="ORDER") W ?9,"**Note: ",RMTRA,?31,RMUSE,?45,$J(RMQTY,4),?69,$J(RMVAL,9,2)
..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 ;print headers
W !,"*** ISSUE and STOCK CONTROL RECORD - PROSTHETICS STOCK ITEMS ***"
W ?65,"Page: ",RMPAGE,!,?30,"station: "
W $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",RH,0))
S RMITEM=$E(RMITEM,1,26)
W !,"HCPCS: ",RH,"-",R2,?16,"Item: ",RI
S RMI=1
Q
;
HEAD1 ;write column headers
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 !,?45,"QTY",?54,"QTY",?61,"QTY",?72,"DOLLAR"
W !," DATE",?9,"PATIENT",?26,"SSN",?31,"USER",?44,"ISSUE"
W ?53,"ORDER",?61,"REC",?72,"VALUE"
W !," ----",?9,"-------",?26,"---",?31,"----",?44,"-----"
W ?53,"-----",?61,"---",?72,"------"
S RMPRFLG=1
Q
;
HTOTAL ;
I RMFH,'RMPREND D
.W !!,?23,"*** Dollar Value of HCPCS Issued",?60,"="
.W ?60,$J(RMTOCOH,10,2)
S (RMTOCOH,RMFH)=0
Q
;
ITOTAL ;prints totals.
I RMFI,'RMPREND D
.W !,?42,"--------------------------------------",!
.W ?23,"*** Dollar Value of Item Issued",?60,"=",?60,$J(RMTOCO,10,2)
S RMTOCOH=RMTOCOH+RMTOCO,(RMTOCO,RMCO,RMFI)=0
Q
;
NONE ;nothing to report.
W !,RMPR("L"),!,"No Item Statistics for HCPCS: "
W RQ,"...for this date range !!!"
Q
;
NONEALL W !!,"NO DATA AT THIS DATE RANGE!!!!"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPI04 5246 printed Dec 13, 2024@02:35:58 Page 2
RMPRPI04 ;HIN/RVD-PROS STOCK ITEM RECORDS ;3/8/05 11:24
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 ; DBIA #10090 - Read Access to entire file #4.
+3 ;
+4 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
QUIT
+5 SET RS=RMPR("STA")
+6 ;
EN KILL ^TMP($JOB),RMPRI,RMPRFLG
SET RMPREND=0
DO HOME^%ZIS
+1 SET DIC="^RMPR(661.1,"
SET DIC(0)="AEQM"
+2 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
+3 if '$DATA(^RMPR(661.1,+Y,0))
QUIT
SET RMHCPC=$PIECE(^RMPR(661.1,+Y,0),U,1)
+4 IF $DATA(RMPRI(RMHCPC))
WRITE $CHAR(7)," ??",?40,"..Duplicate HCPCS"
SET HCPCS=HCPCS-1
QUIT
+5 if RMHCPC'=""
SET RMPRI(RMHCPC)=+Y
End DoDot:1
+6 SET RMPRCOUN=0
WRITE !!
SET %DT("A")="Beginning Date: "
SET %DT="AEPX"
+7 SET %DT("B")="T-30"
DO ^%DT
SET RMPRBDT=Y
if Y<0
GOTO EXIT1
+8 ;
ENDATE SET %DT("A")="Ending Date: "
SET %DT="AEX"
SET %DT("B")="TODAY"
DO ^%DT
+1 if Y<0
GOTO EXIT1
+2 IF RMPRBDT>Y
WRITE !,$CHAR(7),"Invalid Date Range Selection!!"
GOTO ENDATE
+3 if Y<0
GOTO EXIT
SET RMPREDT=Y
SET Y=RMPRBDT
DO DD^%DT
SET RMPRX=Y
SET Y=RMPREDT
+4 DO DD^%DT
SET RMPRY=Y
+5 SET %ZIS="MQ"
KILL IOP
DO ^%ZIS
if POP
GOTO EXIT
+6 IF '$DATA(IO("Q"))
USE IO
GOTO PRINT
+7 KILL IO("Q")
SET ZTDESC="STOCK ITEM REPORT"
SET ZTRTN="PRINT^RMPRPI04"
SET ZTIO=ION
+8 SET ZTSAVE("RMPRBDT")=""
SET ZTSAVE("RMPREDT")=""
SET ZTSAVE("RMPRI(")=""
+9 SET ZTSAVE("RMPRX")=""
SET ZTSAVE("RMPRY")=""
SET ZTSAVE("RMPR(""STA"")")=""
+10 SET ZTSAVE("RMPR(")=""
+11 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!"
HANG 1
GOTO EXIT1
+12 ;
+13 ;Entry point for printing report.
PRINT IF $EXTRACT(IOST)["C"
WRITE @IOF,!!,"Processing report......"
+1 IF '$DATA(RMPRI)
DO NONEALL
GOTO EXIT
+2 ;call API
+3 ;input variables:
+4 ; RM = 'RM' subscript
+5 ; RS = station
+6 ; RMPRI = array of HCPCS
+7 ; RMPRBDT = beginning date
+8 ; RMPREDT = ending date
+9 ;
+10 SET RS=RMPR("STA")
SET RM="RM"
+11 SET RMCHK=$$THIS^RMPRPI03(RM,RS,RMPRBDT,RMPREDT,.RMPRI)
+12 IF RMCHK
WRITE !!,"ERROR NUMBER = ",RMCHK,!,"*** Error in API RMPRPI03 !!!"
GOTO EXIT
+13 ;
+14 SET RMBDATE=$EXTRACT(RMPRBDT,4,5)_"/"_$EXTRACT(RMPRBDT,6,7)_"/"_$EXTRACT(RMPRBDT,2,3)
+15 SET RMPAGE=1
+16 SET (RMPREND,RP,QTYT,RMIFL,RMCO,RMTOCO,RMTOCOH,RMSTAFL,RMSUF,RMQTYT)=0
+17 DO HEAD
+18 SET RQ=""
FOR
SET RQ=$ORDER(RMPRI(RQ))
if RQ=""
QUIT
IF '$DATA(^TMP($JOB,"RM",RQ))
DO NONE
+19 DO WRI
+20 WRITE !,"<End of Report>"
+21 ;
EXIT ;exit here if report prints in home device.
+1 IF $EXTRACT(IOST)["C"
IF '$DATA(DUOUT)
IF '$GET(RMPREND)
KILL DIR
SET DIR(0)="E"
DO ^DIR
+2 ;
EXIT1 ;close device and clean-up variables.
+1 DO ^%ZISC
+2 NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
+3 KILL ^TMP($JOB)
+4 QUIT
+5 ;end of processing (exit program)
+6 ;
+7 ; RH = HCPCS
+8 ; RI = HCPCS ITEM NAME
+9 ; R2 = ITEM NUMBER
+10 ; R3 =SEQUENCE
+11 ;
WRI SET (RMFH,RMFI,RMPRFLG,RMTOCO,RMTOCOH,RMTOCOI)=0
+1 SET (RMITEM,RH)=""
+2 FOR
SET RH=$ORDER(^TMP($JOB,"RM",RH))
if RMFH
DO HTOTAL
if RH'=""
DO HEAD1
if RH=""
QUIT
SET (RIT2,RI)=""
FOR
SET RI=$ORDER(^TMP($JOB,"RM",RH,RI))
if RI=""
QUIT
Begin DoDot:1
+3 FOR R2=0:0
SET R2=$ORDER(^TMP($JOB,"RM",RH,RI,R2))
if RMFI
DO ITOTAL
if (R2'>0)!(RMPREND)
QUIT
if RIT2'=R2
DO IHEAD
FOR R3=0:0
SET R3=$ORDER(^TMP($JOB,"RM",RH,RI,R2,R3))
if (R3'>0)!(RMPREND)
QUIT
Begin DoDot:2
+4 SET RDATA=^TMP($JOB,"RM",RH,RI,R2,R3)
+5 SET RMDAT=$PIECE(RDATA,U,1)
SET RMTIM=$PIECE(RDATA,U,2)
SET RMOPE=$PIECE(RDATA,U,3)
+6 SET RMCLO=$PIECE(RDATA,U,4)
SET RMQTY=$PIECE(RDATA,U,5)
+7 SET RMVAL=$PIECE(RDATA,U,6)
SET RMTRA=$PIECE(RDATA,U,7)
SET RMPAT=$PIECE(RDATA,U,8)
+8 SET RMSSN=$PIECE(RDATA,U,9)
SET RMUSE=$EXTRACT($PIECE(RDATA,U,10),1,10)
+9 SET RMITE=$PIECE(RDATA,U,11)
+10 SET RMAVCO=$PIECE(RDATA,U,11)
if RMAVCO'=""
SET RMCO=RMAVCO*RMQTY
+11 SET RIT2=R2
+12 IF 'RMPRFLG
DO HEAD1
+13 SET (RMFH,RMFI)=1
+14 WRITE !,RMDAT
+15 IF RMPAT'=""
Begin DoDot:3
+16 WRITE ?9,$EXTRACT(RMPAT,1,14),?26,$PIECE(RMSSN,"-",3),?31,RMUSE,?45,$JUSTIFY(RMQTY,4)
+17 WRITE ?69,$JUSTIFY(RMVAL,9,2)
End DoDot:3
+18 IF RMTRA="PATIENT ISSUE"
SET RMTOCO=RMTOCO+RMVAL
+19 IF RMTRA="RETURN IN"
SET RMTOCO=RMTOCO-RMVAL
+20 IF RMPAT=""
Begin DoDot:3
+21 if RMTRA="RECEIPT"
WRITE ?9,"**Note: ",RMTRA,?31,RMUSE,?60,$JUSTIFY(RMQTY,4),?69,$JUSTIFY(RMVAL,9,2)
+22 if RMTRA="ORDER"
WRITE ?9,"**Note: ",RMTRA,?31,RMUSE,?54,$JUSTIFY(RMQTY,4),?69,$JUSTIFY(RMVAL,9,2)
+23 IF (RMTRA'="RECEIPT")
IF (RMTRA'="ORDER")
WRITE ?9,"**Note: ",RMTRA,?31,RMUSE,?45,$JUSTIFY(RMQTY,4),?69,$JUSTIFY(RMVAL,9,2)
End DoDot:3
+24 SET RMPRFLG=1
+25 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
+26 IF $Y>(IOSL-6)
WRITE @IOF
DO HEAD
DO HEAD1
SET RMPRFLG=1
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
HEAD ;print headers
+1 WRITE !,"*** ISSUE and STOCK CONTROL RECORD - PROSTHETICS STOCK ITEMS ***"
+2 WRITE ?65,"Page: ",RMPAGE,!,?30,"station: "
+3 WRITE $EXTRACT($PIECE($GET(^DIC(4,RMPR("STA"),0)),U,1),1,20)
+4 NEW X,%
SET Y=RMPRBDT
DO DD^%DT
WRITE !,Y," to "
SET Y=RMPREDT
DO DD^%DT
WRITE Y
+5 SET RMPAGE=RMPAGE+1
+6 QUIT
+7 ;
IHEAD SET RMDAHC=$ORDER(^RMPR(661.1,"B",RH,0))
+1 SET RMITEM=$EXTRACT(RMITEM,1,26)
+2 WRITE !,"HCPCS: ",RH,"-",R2,?16,"Item: ",RI
+3 SET RMI=1
+4 QUIT
+5 ;
HEAD1 ;write column headers
+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 !,?45,"QTY",?54,"QTY",?61,"QTY",?72,"DOLLAR"
+4 WRITE !," DATE",?9,"PATIENT",?26,"SSN",?31,"USER",?44,"ISSUE"
+5 WRITE ?53,"ORDER",?61,"REC",?72,"VALUE"
+6 WRITE !," ----",?9,"-------",?26,"---",?31,"----",?44,"-----"
+7 WRITE ?53,"-----",?61,"---",?72,"------"
+8 SET RMPRFLG=1
+9 QUIT
+10 ;
HTOTAL ;
+1 IF RMFH
IF 'RMPREND
Begin DoDot:1
+2 WRITE !!,?23,"*** Dollar Value of HCPCS Issued",?60,"="
+3 WRITE ?60,$JUSTIFY(RMTOCOH,10,2)
End DoDot:1
+4 SET (RMTOCOH,RMFH)=0
+5 QUIT
+6 ;
ITOTAL ;prints totals.
+1 IF RMFI
IF 'RMPREND
Begin DoDot:1
+2 WRITE !,?42,"--------------------------------------",!
+3 WRITE ?23,"*** Dollar Value of Item Issued",?60,"=",?60,$JUSTIFY(RMTOCO,10,2)
End DoDot:1
+4 SET RMTOCOH=RMTOCOH+RMTOCO
SET (RMTOCO,RMCO,RMFI)=0
+5 QUIT
+6 ;
NONE ;nothing to report.
+1 WRITE !,RMPR("L"),!,"No Item Statistics for HCPCS: "
+2 WRITE RQ,"...for this date range !!!"
+3 QUIT
+4 ;
NONEALL WRITE !!,"NO DATA AT THIS DATE RANGE!!!!"
+1 QUIT
