RMPR5N3 ;HIN/RVD-PRINT INVENTORY BALANCE BY HCPCS ;3/17/03 13:19
;;3.0;PROSTHETICS;**33,37,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
S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
;
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,0)),($P(^(0),U,9)=1)"
EN1 R !!,"Enter 'ALL' for all HCPCS or 'RETURN' to select individual HCPCS: ",RMENTER:DTIME G:$D(DTOUT)!$D(DUOUT)!(RMENTER="^") EXIT1
G:RMENTER["?" EN1
S X=RMENTER X ^%ZOSF("UPPERCASE") S RMENTER=Y I RMENTER="ALL" S RMPRI(0)=1 G CONT
SEL W ! F RML=1:1 S DIC("A")="Select HCPCS "_RML_": " D ^DIC G:$D(DTOUT)!(X["^")!(X=""&(RML=1)) EXIT1 Q:X="" D
.S RMI=$P(^RMPR(661.1,+Y,0),U,1)
.I $D(RMPRI(RMI)) W $C(7)," ??",?40,"..Duplicate HCPCS" S RML=RML-1 Q
.S RMPRI(RMI)=+Y
CONT G:'$D(RMPRI) 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 INVENTORY LOCATION SUMMARY",ZTRTN="PRINT^RMPR5N3",ZTIO=ION,ZTSAVE("RMPRI(")="",ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMDAT")="",ZTSAVE("RMPR(")=""
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT
;
PRINT I $E(IOST)["C" W !!,"Processing report......."
S RMPAGE=1,(RMTOBAL,RMPREND)=0,RS=RMPR("STA") M ^TMP($J,"RM")=RMPRI
D:$D(RMPRI(0)) ALL
I '$D(^TMP($J,"RM")) D NONE G EXIT
S RB="" F S RB=$O(^TMP($J,"RM",RB)) Q:RB="" S RMLIEN=^TMP($J,"RM",RB) D
.S J=0 F S J=$O(^RMPR(661.3,"C",RMLIEN,J)) Q:J'>0 S R63=$G(^RMPR(661.3,J,0)) I R63'="" S RMLO=$P(R63,U,1) S R3=$O(^RMPR(661.3,"C",RMLIEN,J,0)) I R3 D
..F R4=0:0 S R4=$O(^RMPR(661.3,J,1,R3,1,R4)) Q:R4'>0 Q:$P(R63,U,3)'=RS D
...S RM3=$G(^RMPR(661.3,J,1,R3,1,R4,0)) Q:RM3=""
...S RMIT=$P(RM3,U,1),RMHCPC=$P(RMIT,"-",1),RMDAIT=$P(RMIT,"-",2)
...S RMITEM=$P($G(^RMPR(661.1,RMLIEN,3,RMDAIT,0)),U,1) Q:RMITEM=""
...S RMUNI=$P(RM3,U,4),RMRLE=$P(RM3,U,6),RMDI=$P(RM3,U,7),RMSO=$P(RM3,U,9),RMAV=$P(RM3,U,10)
...S RMBA=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMVE=$P(RM3,U,5)
...S ^TMP($J,RB,RMITEM,RMLO)=RMAV_"^"_RMVE_"^^"_RMUNI_"^"_RMRLE_"^"_RMDI_"^"_RMSO_"^"_RMBA_"^"_RMCO
W:$E(IOST)["C" @IOF
D HEAD,WRI D:RMSUF TOTAL G EXIT
;write/print report
WRI S RP="",RMSUF=0 D HEAD1
F S RP=$O(^TMP($J,RP)) Q:(RP="")!(RMPREND) D:RMSUF TOTAL K RMPRFLG F S J=$O(^TMP($J,RP,J)) Q:(J="")!(RMPREND) S K="",RSA=RP F S K=$O(^TMP($J,RP,J,K)) Q:(K="")!(RMPREND) D
.S RMAST="",RMTMP=^TMP($J,RP,J,K),RMVE=$P(RMTMP,U,2)
.S RMUNI=$P(RMTMP,U,4),RMRLE=$P(RMTMP,U,5),RMDI=$P(RMTMP,U,6),RMSO=$P(RMTMP,U,7),RMBA=$P(RMTMP,U,8),RMCO=$P(RMTMP,U,9),RMAV=$P(RMTMP,U,1)
.S RMITEM=J,RMLOC=K,RMSUF=1,RMTOBAL=RMTOBAL+RMBA
.S:RMUNI RMUNI=$P(^PRCD(420.5,RMUNI,0),U,1)
.S:RMVE RMVE=$P($G(^PRC(440,RMVE,0)),U,1)
.S RMITEM=$E(RMITEM,1,20)
.S:RMBA<RMRLE RMAST="*"
.W !,RP,?9,RMITEM,?30,RMSO,?33,$E(RMLOC,1,8),?42,$E(RMVE,1,11),?55,RMUNI,?58,$J(RMRLE,4),?64,$J(RMAV,8,2),?73,$J(RMBA,5),RMAST
.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
Q
;
TOTAL W !,?71,"-------",!,?45,"Total ",RSA," balance = ",?71,$J(RMTOBAL,7),!,RMPR("L")
S RMSUF=0,RMTOBAL=0
Q
;
HEAD W !,"*** PROSTHETICS INVENTORY BALANCE BY HCPCS ***",?68,"PAGE: ",RMPAGE,!,"Run Date: ",RMDAT,?30,"station: ",$E($P($G(^DIC(4,RS,0)),U,1),1,20)
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 !,?54,"UNIT",?60,"RE-"
W !,?55,"OF",?59,"ORDER",?68,"AVG",?75,"CUR"
W !,"HCPCS",?9,"ITEM",?29,"SRC",?33,"LOCATION",?42,"VENDOR",?53,"ISSUE",?59,"LEVEL",?68,"COST",?75,"BAL"
W !,"-----",?9,"----",?29,"---",?33,"--------",?42,"------",?53,"-----",?59,"-----",?68,"----",?75,"---"
S RMPRFLG=1
Q
;
ALL ;process all items
K RMPRI(0),^TMP($J,"RM")
F I=0:0 S I=$O(^RMPR(661.1,I)) Q:I'>0 I $P(^RMPR(661.1,I,0),U,9)=1 S RMI=$P(^RMPR(661.1,I,0),U,1) S:RMI'="" ^TMP($J,"RM",RMI)=I
Q
;
EXIT I $E(IOST)["C",'RMPREND W ! S DIR(0)="E" D ^DIR
EXIT1 D ^%ZISC
N RMPR,RMPRSITE D KILL^XUSCLEAN
Q
NONE W !!,"NO DATA !!!!!"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5N3 4227 printed Mar 13, 2025@21:38:06 Page 2
RMPR5N3 ;HIN/RVD-PRINT INVENTORY BALANCE BY HCPCS ;3/17/03 13:19
+1 ;;3.0;PROSTHETICS;**33,37,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 SET X="NOW"
DO ^%DT
DO DD^%DT
SET RMDAT=Y
+5 ;
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,0)),($P(^(0),U,9)=1)"
EN1 READ !!,"Enter 'ALL' for all HCPCS or 'RETURN' to select individual HCPCS: ",RMENTER:DTIME
if $DATA(DTOUT)!$DATA(DUOUT)!(RMENTER="^")
GOTO EXIT1
+1 if RMENTER["?"
GOTO EN1
+2 SET X=RMENTER
XECUTE ^%ZOSF("UPPERCASE")
SET RMENTER=Y
IF RMENTER="ALL"
SET RMPRI(0)=1
GOTO CONT
SEL WRITE !
FOR RML=1:1
SET DIC("A")="Select HCPCS "_RML_": "
DO ^DIC
if $DATA(DTOUT)!(X["^")!(X=""&(RML=1))
GOTO EXIT1
if X=""
QUIT
Begin DoDot:1
+1 SET RMI=$PIECE(^RMPR(661.1,+Y,0),U,1)
+2 IF $DATA(RMPRI(RMI))
WRITE $CHAR(7)," ??",?40,"..Duplicate HCPCS"
SET RML=RML-1
QUIT
+3 SET RMPRI(RMI)=+Y
End DoDot:1
CONT if '$DATA(RMPRI)
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 INVENTORY LOCATION SUMMARY"
SET ZTRTN="PRINT^RMPR5N3"
SET ZTIO=ION
SET ZTSAVE("RMPRI(")=""
SET ZTSAVE("RMPR(""STA"")")=""
SET ZTSAVE("RMDAT")=""
SET ZTSAVE("RMPR(")=""
+2 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!"
HANG 1
GOTO EXIT
+3 ;
PRINT IF $EXTRACT(IOST)["C"
WRITE !!,"Processing report......."
+1 SET RMPAGE=1
SET (RMTOBAL,RMPREND)=0
SET RS=RMPR("STA")
MERGE ^TMP($JOB,"RM")=RMPRI
+2 if $DATA(RMPRI(0))
DO ALL
+3 IF '$DATA(^TMP($JOB,"RM"))
DO NONE
GOTO EXIT
+4 SET RB=""
FOR
SET RB=$ORDER(^TMP($JOB,"RM",RB))
if RB=""
QUIT
SET RMLIEN=^TMP($JOB,"RM",RB)
Begin DoDot:1
+5 SET J=0
FOR
SET J=$ORDER(^RMPR(661.3,"C",RMLIEN,J))
if J'>0
QUIT
SET R63=$GET(^RMPR(661.3,J,0))
IF R63'=""
SET RMLO=$PIECE(R63,U,1)
SET R3=$ORDER(^RMPR(661.3,"C",RMLIEN,J,0))
IF R3
Begin DoDot:2
+6 FOR R4=0:0
SET R4=$ORDER(^RMPR(661.3,J,1,R3,1,R4))
if R4'>0
QUIT
if $PIECE(R63,U,3)'=RS
QUIT
Begin DoDot:3
+7 SET RM3=$GET(^RMPR(661.3,J,1,R3,1,R4,0))
if RM3=""
QUIT
+8 SET RMIT=$PIECE(RM3,U,1)
SET RMHCPC=$PIECE(RMIT,"-",1)
SET RMDAIT=$PIECE(RMIT,"-",2)
+9 SET RMITEM=$PIECE($GET(^RMPR(661.1,RMLIEN,3,RMDAIT,0)),U,1)
if RMITEM=""
QUIT
+10 SET RMUNI=$PIECE(RM3,U,4)
SET RMRLE=$PIECE(RM3,U,6)
SET RMDI=$PIECE(RM3,U,7)
SET RMSO=$PIECE(RM3,U,9)
SET RMAV=$PIECE(RM3,U,10)
+11 SET RMBA=$PIECE(RM3,U,2)
SET RMCO=$PIECE(RM3,U,3)
SET RMVE=$PIECE(RM3,U,5)
+12 SET ^TMP($JOB,RB,RMITEM,RMLO)=RMAV_"^"_RMVE_"^^"_RMUNI_"^"_RMRLE_"^"_RMDI_"^"_RMSO_"^"_RMBA_"^"_RMCO
End DoDot:3
End DoDot:2
End DoDot:1
+13 if $EXTRACT(IOST)["C"
WRITE @IOF
+14 DO HEAD
DO WRI
if RMSUF
DO TOTAL
GOTO EXIT
+15 ;write/print report
WRI SET RP=""
SET RMSUF=0
DO HEAD1
+1 FOR
SET RP=$ORDER(^TMP($JOB,RP))
if (RP="")!(RMPREND)
QUIT
if RMSUF
DO TOTAL
KILL RMPRFLG
FOR
SET J=$ORDER(^TMP($JOB,RP,J))
if (J="")!(RMPREND)
QUIT
SET K=""
SET RSA=RP
FOR
SET K=$ORDER(^TMP($JOB,RP,J,K))
if (K="")!(RMPREND)
QUIT
Begin DoDot:1
+2 SET RMAST=""
SET RMTMP=^TMP($JOB,RP,J,K)
SET RMVE=$PIECE(RMTMP,U,2)
+3 SET RMUNI=$PIECE(RMTMP,U,4)
SET RMRLE=$PIECE(RMTMP,U,5)
SET RMDI=$PIECE(RMTMP,U,6)
SET RMSO=$PIECE(RMTMP,U,7)
SET RMBA=$PIECE(RMTMP,U,8)
SET RMCO=$PIECE(RMTMP,U,9)
SET RMAV=$PIECE(RMTMP,U,1)
+4 SET RMITEM=J
SET RMLOC=K
SET RMSUF=1
SET RMTOBAL=RMTOBAL+RMBA
+5 if RMUNI
SET RMUNI=$PIECE(^PRCD(420.5,RMUNI,0),U,1)
+6 if RMVE
SET RMVE=$PIECE($GET(^PRC(440,RMVE,0)),U,1)
+7 SET RMITEM=$EXTRACT(RMITEM,1,20)
+8 if RMBA<RMRLE
SET RMAST="*"
+9 WRITE !,RP,?9,RMITEM,?30,RMSO,?33,$EXTRACT(RMLOC,1,8),?42,$EXTRACT(RMVE,1,11),?55,RMUNI,?58,$JUSTIFY(RMRLE,4),?64,$JUSTIFY(RMAV,8,2),?73,$JUSTIFY(RMBA,5),RMAST
+10 SET RMPRFLG=1
+11 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
+12 IF $Y>(IOSL-6)
WRITE @IOF
DO HEAD
DO HEAD1
KILL RMPRFLG
QUIT
End DoDot:1
+13 QUIT
+14 ;
TOTAL WRITE !,?71,"-------",!,?45,"Total ",RSA," balance = ",?71,$JUSTIFY(RMTOBAL,7),!,RMPR("L")
+1 SET RMSUF=0
SET RMTOBAL=0
+2 QUIT
+3 ;
HEAD WRITE !,"*** PROSTHETICS INVENTORY BALANCE BY HCPCS ***",?68,"PAGE: ",RMPAGE,!,"Run Date: ",RMDAT,?30,"station: ",$EXTRACT($PIECE($GET(^DIC(4,RS,0)),U,1),1,20)
+1 SET RMPAGE=RMPAGE+1
+2 QUIT
+3 ;
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 !,?54,"UNIT",?60,"RE-"
+4 WRITE !,?55,"OF",?59,"ORDER",?68,"AVG",?75,"CUR"
+5 WRITE !,"HCPCS",?9,"ITEM",?29,"SRC",?33,"LOCATION",?42,"VENDOR",?53,"ISSUE",?59,"LEVEL",?68,"COST",?75,"BAL"
+6 WRITE !,"-----",?9,"----",?29,"---",?33,"--------",?42,"------",?53,"-----",?59,"-----",?68,"----",?75,"---"
+7 SET RMPRFLG=1
+8 QUIT
+9 ;
ALL ;process all items
+1 KILL RMPRI(0),^TMP($JOB,"RM")
+2 FOR I=0:0
SET I=$ORDER(^RMPR(661.1,I))
if I'>0
QUIT
IF $PIECE(^RMPR(661.1,I,0),U,9)=1
SET RMI=$PIECE(^RMPR(661.1,I,0),U,1)
if RMI'=""
SET ^TMP($JOB,"RM",RMI)=I
+3 QUIT
+4 ;
EXIT IF $EXTRACT(IOST)["C"
IF 'RMPREND
WRITE !
SET DIR(0)="E"
DO ^DIR
EXIT1 DO ^%ZISC
+1 NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
+2 QUIT
NONE WRITE !!,"NO DATA !!!!!"
+1 QUIT
