RMPR5N2 ;HIN/RVD-PRINT INVENTORY BALANCE BY LOCATION ;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.3,",DIC(0)="AEQ",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
EN1 R !!,"Enter 'ALL' for all Locations or 'RETURN' to select individual Locations: ",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
W ! F RML=1:1 S DIC("A")="Select Location "_RML_": " D ^DIC G:$D(DTOUT)!(X["^")!(X=""&(RML=1)) EXIT1 Q:X="" D
.S RMLOCI=$P(^RMPR(661.3,+Y,0),U,1)
.I $D(RMPRI(RMLOCI)) W $C(7)," ??",?40,"..Duplicate Location" S RML=RML-1 Q
.S RMPRI(RMLOCI)=+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^RMPR5N2",ZTIO=ION,ZTSAVE("RMPRI(")="",ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMDAT")="",ZTSAVE("RMPR(")=""
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT1
;
PRINT I $E(IOST)["C" W !!,"Processing report....."
S RMPAGE=1,RMPREND=0,RS=RMPR("STA") D:$D(RMPRI(0)) ALL
I '$D(RMPRI) D NONE G EXIT
C S RB="" F S RB=$O(RMPRI(RB)) Q:RB="" Q:RMPREND S RMLIEN=RMPRI(RB) D CK
G:RMPREND EXIT
W:$E(IOST)["C" @IOF
D HEAD,WRI D:'$D(^TMP($J)) NONE G EXIT
;
CK Q:'$D(^RMPR(661.3,RMLIEN,1,0))
F J=0:0 S J=$O(^RMPR(661.3,RMLIEN,1,J)) Q:J'>0 F K=0:0 S K=$O(^RMPR(661.3,RMLIEN,1,J,1,K)) Q:K'>0 S RM3=$G(^RMPR(661.3,RMLIEN,1,J,1,K,0)),RMIT=$P(RM3,U,1) D
.S RMHCPC=$P(RMIT,"-",1),RMDAIT=$P(RMIT,"-",2),RMDAHC=$O(^RMPR(661.1,"B",RMHCPC,0)) Q:'RMDAHC
.S RM1=$G(^RMPR(661.1,RMDAHC,3,RMDAIT,0)),RMITEM=$P(RM1,U,1) Q:RM1=""
.S RMBA=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMUNI=$P(RM3,U,4),RMVEN=$P(RM3,U,5)
.S RMRLE=$P(RM3,U,6),RMDI=$P(RM3,U,7),RMSO=$P(RM3,U,9),RMAV=$P(RM3,U,10)
.S ^TMP($J,RB,RMIT,RMITEM)=RMAV_"^"_RMBA_"^"_RMCO_"^"_RMUNI_"^"_RMVEN_"^"_RMRLE_"^"_RMDI_"^"_RMSO_"^"_RMLIEN
Q
;write/print report
WRI S RP="" F S RP=$O(^TMP($J,RP)) Q:RP="" Q:RMPREND K RMPRFLG S J="" F S J=$O(^TMP($J,RP,J)) Q:J="" Q:RMPREND S K="" F S K=$O(^TMP($J,RP,J,K)) Q:K="" Q:RMPREND S RMAST="",RM3=^TMP($J,RP,J,K) D
.I '$D(RMPRFLG) D HEAD1
.S RMLODA=$P(RM3,U,9)
.S RMIT=J
.S RMITEM=K
.S RMAV=$P(RM3,U,1)
.S RMBA=$P(RM3,U,2)
.S RMCO=$P(RM3,U,3)
.S RMUNI=$P(RM3,U,4)
.S RMVEN=$P(RM3,U,5)
.S RMRLE=$P(RM3,U,6)
.S RMDI=$P(RM3,U,7)
.S RMSO=$P(RM3,U,8)
.S:RMUNI RMUNI=$P($G(^PRCD(420.5,RMUNI,0)),U,1)
.S:RMVEN RMVEN=$P($G(^PRC(440,RMVEN,0)),U,1)
.S RMITEM=$E(RMITEM,1,27),RMVEN=$E(RMVEN,1,12)
.S:RMBA<RMRLE RMAST="*"
.;I RMSO="V" W !,RMHCPC,?9,RMITEM,?37,RMSO,?41,RMVEN,?55,RMUNI,?74,$J(RMBA,5)
.;I RMSO="C" W !,RMHCPC,?9,RMITEM,?37,RMSO,?41,RMVEN,?55,RMUNI,?58,$J(RMRLE,4),?65,$J(RMAV,8,2),?74,$J(RMBA,5),RMAST
.W !,RMIT,?9,RMITEM,?37,RMSO,?41,RMVEN,?55,RMUNI,?58,$J(RMRLE,4),?65,$J(RMAV,8,2),?74,$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 Q
Q
;
HEAD W !,"*** PROSTHETICS INVENTORY BALANCE BY LOCATION ***",?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 !,"Location: ",RP
W !,?54,"UNIT",?60,"RE-"
W !,?55,"OF",?59,"ORDER",?68,"AVG",?75,"CUR"
W !,"HCPCS",?9,"ITEM",?36,"SRC",?41,"VENDOR",?53,"ISSUE",?59,"LEVEL",?68,"COST",?75,"BAL"
W !,"-----",?9,"----",?36,"---",?41,"------",?53,"-----",?59,"-----",?67,"------",?74,"-----"
S RMPRFLG=1
Q
;
ALL ;PROCESS ALL LOCATION
K RMPRI(0) S RML="" F S RML=$O(^RMPR(661.3,"B",RML)) Q:RML="" D
.S RLOC=$O(^RMPR(661.3,"B",RML,0))
.I $P($G(^RMPR(661.3,RLOC,0)),U,3)=RMPR("STA") S RMPRI(RML)=RLOC
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[HRMPR5N2 4286 printed Sep 23, 2025@20:09:21 Page 2
RMPR5N2 ;HIN/RVD-PRINT INVENTORY BALANCE BY LOCATION ;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.3,"
SET DIC(0)="AEQ"
SET DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
EN1 READ !!,"Enter 'ALL' for all Locations or 'RETURN' to select individual Locations: ",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
+3 WRITE !
FOR RML=1:1
SET DIC("A")="Select Location "_RML_": "
DO ^DIC
if $DATA(DTOUT)!(X["^")!(X=""&(RML=1))
GOTO EXIT1
if X=""
QUIT
Begin DoDot:1
+4 SET RMLOCI=$PIECE(^RMPR(661.3,+Y,0),U,1)
+5 IF $DATA(RMPRI(RMLOCI))
WRITE $CHAR(7)," ??",?40,"..Duplicate Location"
SET RML=RML-1
QUIT
+6 SET RMPRI(RMLOCI)=+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^RMPR5N2"
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 EXIT1
+3 ;
PRINT IF $EXTRACT(IOST)["C"
WRITE !!,"Processing report....."
+1 SET RMPAGE=1
SET RMPREND=0
SET RS=RMPR("STA")
if $DATA(RMPRI(0))
DO ALL
+2 IF '$DATA(RMPRI)
DO NONE
GOTO EXIT
C SET RB=""
FOR
SET RB=$ORDER(RMPRI(RB))
if RB=""
QUIT
if RMPREND
QUIT
SET RMLIEN=RMPRI(RB)
DO CK
+1 if RMPREND
GOTO EXIT
+2 if $EXTRACT(IOST)["C"
WRITE @IOF
+3 DO HEAD
DO WRI
if '$DATA(^TMP($JOB))
DO NONE
GOTO EXIT
+4 ;
CK if '$DATA(^RMPR(661.3,RMLIEN,1,0))
QUIT
+1 FOR J=0:0
SET J=$ORDER(^RMPR(661.3,RMLIEN,1,J))
if J'>0
QUIT
FOR K=0:0
SET K=$ORDER(^RMPR(661.3,RMLIEN,1,J,1,K))
if K'>0
QUIT
SET RM3=$GET(^RMPR(661.3,RMLIEN,1,J,1,K,0))
SET RMIT=$PIECE(RM3,U,1)
Begin DoDot:1
+2 SET RMHCPC=$PIECE(RMIT,"-",1)
SET RMDAIT=$PIECE(RMIT,"-",2)
SET RMDAHC=$ORDER(^RMPR(661.1,"B",RMHCPC,0))
if 'RMDAHC
QUIT
+3 SET RM1=$GET(^RMPR(661.1,RMDAHC,3,RMDAIT,0))
SET RMITEM=$PIECE(RM1,U,1)
if RM1=""
QUIT
+4 SET RMBA=$PIECE(RM3,U,2)
SET RMCO=$PIECE(RM3,U,3)
SET RMUNI=$PIECE(RM3,U,4)
SET RMVEN=$PIECE(RM3,U,5)
+5 SET RMRLE=$PIECE(RM3,U,6)
SET RMDI=$PIECE(RM3,U,7)
SET RMSO=$PIECE(RM3,U,9)
SET RMAV=$PIECE(RM3,U,10)
+6 SET ^TMP($JOB,RB,RMIT,RMITEM)=RMAV_"^"_RMBA_"^"_RMCO_"^"_RMUNI_"^"_RMVEN_"^"_RMRLE_"^"_RMDI_"^"_RMSO_"^"_RMLIEN
End DoDot:1
+7 QUIT
+8 ;write/print report
WRI SET RP=""
FOR
SET RP=$ORDER(^TMP($JOB,RP))
if RP=""
QUIT
if RMPREND
QUIT
KILL RMPRFLG
SET J=""
FOR
SET J=$ORDER(^TMP($JOB,RP,J))
if J=""
QUIT
if RMPREND
QUIT
SET K=""
FOR
SET K=$ORDER(^TMP($JOB,RP,J,K))
if K=""
QUIT
if RMPREND
QUIT
SET RMAST=""
SET RM3=^TMP($JOB,RP,J,K)
Begin DoDot:1
+1 IF '$DATA(RMPRFLG)
DO HEAD1
+2 SET RMLODA=$PIECE(RM3,U,9)
+3 SET RMIT=J
+4 SET RMITEM=K
+5 SET RMAV=$PIECE(RM3,U,1)
+6 SET RMBA=$PIECE(RM3,U,2)
+7 SET RMCO=$PIECE(RM3,U,3)
+8 SET RMUNI=$PIECE(RM3,U,4)
+9 SET RMVEN=$PIECE(RM3,U,5)
+10 SET RMRLE=$PIECE(RM3,U,6)
+11 SET RMDI=$PIECE(RM3,U,7)
+12 SET RMSO=$PIECE(RM3,U,8)
+13 if RMUNI
SET RMUNI=$PIECE($GET(^PRCD(420.5,RMUNI,0)),U,1)
+14 if RMVEN
SET RMVEN=$PIECE($GET(^PRC(440,RMVEN,0)),U,1)
+15 SET RMITEM=$EXTRACT(RMITEM,1,27)
SET RMVEN=$EXTRACT(RMVEN,1,12)
+16 if RMBA<RMRLE
SET RMAST="*"
+17 ;I RMSO="V" W !,RMHCPC,?9,RMITEM,?37,RMSO,?41,RMVEN,?55,RMUNI,?74,$J(RMBA,5)
+18 ;I RMSO="C" W !,RMHCPC,?9,RMITEM,?37,RMSO,?41,RMVEN,?55,RMUNI,?58,$J(RMRLE,4),?65,$J(RMAV,8,2),?74,$J(RMBA,5),RMAST
+19 WRITE !,RMIT,?9,RMITEM,?37,RMSO,?41,RMVEN,?55,RMUNI,?58,$JUSTIFY(RMRLE,4),?65,$JUSTIFY(RMAV,8,2),?74,$JUSTIFY(RMBA,5),RMAST
+20 SET RMPRFLG=1
+21 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
+22 IF $Y>(IOSL-6)
WRITE @IOF
DO HEAD
DO HEAD1
QUIT
End DoDot:1
+23 QUIT
+24 ;
HEAD WRITE !,"*** PROSTHETICS INVENTORY BALANCE BY LOCATION ***",?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"
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 !,"Location: ",RP
+4 WRITE !,?54,"UNIT",?60,"RE-"
+5 WRITE !,?55,"OF",?59,"ORDER",?68,"AVG",?75,"CUR"
+6 WRITE !,"HCPCS",?9,"ITEM",?36,"SRC",?41,"VENDOR",?53,"ISSUE",?59,"LEVEL",?68,"COST",?75,"BAL"
+7 WRITE !,"-----",?9,"----",?36,"---",?41,"------",?53,"-----",?59,"-----",?67,"------",?74,"-----"
+8 SET RMPRFLG=1
+9 QUIT
+10 ;
ALL ;PROCESS ALL LOCATION
+1 KILL RMPRI(0)
SET RML=""
FOR
SET RML=$ORDER(^RMPR(661.3,"B",RML))
if RML=""
QUIT
Begin DoDot:1
+2 SET RLOC=$ORDER(^RMPR(661.3,"B",RML,0))
+3 IF $PIECE($GET(^RMPR(661.3,RLOC,0)),U,3)=RMPR("STA")
SET RMPRI(RML)=RLOC
End DoDot:1
+4 QUIT
+5 ;
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
