RMPR5SRV ;HIN/RVD-PROS INVENTORY SERVER ;7/23/99
;;3.0;PROSTHETICS;**37**;Feb 09, 1996
;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
;
S RMPREND=0 D ALL
I '$D(RMPRI) D NONE G EXIT
C F RMSTA=0:0 S RMSTA=$O(RMPRI(RMSTA)) Q:RMSTA'>0 S RB="" F S RB=$O(RMPRI(RMSTA,RB)) Q:RB="" Q:RMPREND S RMLIEN=RMPRI(RMSTA,RB) D CK
G:RMPREND EXIT
D 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,"RM",RB,RMIT,RMITEM)=RMAV_"^"_RMBA_"^"_RMCO_"^"_RMUNI_"^"_RMVEN_"^"_RMRLE_"^"_RMDI_"^"_RMSO_"^"_RMLIEN_"^"_RMSTA
Q
;Set Tmp global for mailman message.
WRI S RP="",RIJ=0 F S RP=$O(^TMP($J,"RM",RP)) Q:RP="" S RMLOC=RP K RMPRFLG S J="" F S J=$O(^TMP($J,"RM",RP,J)) Q:J="" S K="" F S K=$O(^TMP($J,"RM",RP,J,K)) Q:K="" S RMAST="",RM3=^TMP($J,"RM",RP,J,K) D
.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 RMST=$P(RM3,U,10)
.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 RIJ=RIJ+1
.S ^TMP($J,RIJ)=RMST_"^"_RMLOC_"^"_RMIT_"^"_RMITEM_"^"_RMSO_"^"_RMVEN_"^"_RMUNI_"^"_RMRLE_"^"_RMAV_"^"_RMBA
.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))
.S RMSTA=$P($G(^RMPR(661.3,RLOC,0)),U,3) S RMPRI(RMSTA,RML)=RLOC
Q
;
EXIT ;I $E(IOST)["C" W ! S DIR(0)="E" D ^DIR
D ^%ZISC K ^TMP($J,"RM")
N RMPR,RMPRSITE D KILL^XUSCLEAN
Q
NONE S ^TMP($J,0)="NO DATA FOR THIS DATE RANGE"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5SRV 2263 printed Dec 13, 2024@02:33:21 Page 2
RMPR5SRV ;HIN/RVD-PROS INVENTORY SERVER ;7/23/99
+1 ;;3.0;PROSTHETICS;**37**;Feb 09, 1996
+2 ;D DIV4^RMPRSIT I $D(Y),(Y<0) Q
+3 SET X="NOW"
DO ^%DT
DO DD^%DT
SET RMDAT=Y
+4 ;
EN KILL ^TMP($JOB),RMPRI,RMPRFLG
SET RMPREND=0
+1 ;
+2 SET RMPREND=0
DO ALL
+3 IF '$DATA(RMPRI)
DO NONE
GOTO EXIT
C FOR RMSTA=0:0
SET RMSTA=$ORDER(RMPRI(RMSTA))
if RMSTA'>0
QUIT
SET RB=""
FOR
SET RB=$ORDER(RMPRI(RMSTA,RB))
if RB=""
QUIT
if RMPREND
QUIT
SET RMLIEN=RMPRI(RMSTA,RB)
DO CK
+1 if RMPREND
GOTO EXIT
+2 DO WRI
if '$DATA(^TMP($JOB))
DO NONE
GOTO EXIT
+3 ;
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,"RM",RB,RMIT,RMITEM)=RMAV_"^"_RMBA_"^"_RMCO_"^"_RMUNI_"^"_RMVEN_"^"_RMRLE_"^"_RMDI_"^"_RMSO_"^"_RMLIEN_"^"_RMSTA
End DoDot:1
+7 QUIT
+8 ;Set Tmp global for mailman message.
WRI SET RP=""
SET RIJ=0
FOR
SET RP=$ORDER(^TMP($JOB,"RM",RP))
if RP=""
QUIT
SET RMLOC=RP
KILL RMPRFLG
SET J=""
FOR
SET J=$ORDER(^TMP($JOB,"RM",RP,J))
if J=""
QUIT
SET K=""
FOR
SET K=$ORDER(^TMP($JOB,"RM",RP,J,K))
if K=""
QUIT
SET RMAST=""
SET RM3=^TMP($JOB,"RM",RP,J,K)
Begin DoDot:1
+1 SET RMLODA=$PIECE(RM3,U,9)
+2 SET RMIT=J
+3 SET RMITEM=K
+4 SET RMAV=$PIECE(RM3,U,1)
+5 SET RMBA=$PIECE(RM3,U,2)
+6 SET RMCO=$PIECE(RM3,U,3)
+7 SET RMUNI=$PIECE(RM3,U,4)
+8 SET RMVEN=$PIECE(RM3,U,5)
+9 SET RMRLE=$PIECE(RM3,U,6)
+10 SET RMDI=$PIECE(RM3,U,7)
+11 SET RMSO=$PIECE(RM3,U,8)
+12 SET RMST=$PIECE(RM3,U,10)
+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 SET RIJ=RIJ+1
+17 SET ^TMP($JOB,RIJ)=RMST_"^"_RMLOC_"^"_RMIT_"^"_RMITEM_"^"_RMSO_"^"_RMVEN_"^"_RMUNI_"^"_RMRLE_"^"_RMAV_"^"_RMBA
+18 SET RMPRFLG=1
End DoDot:1
+19 QUIT
+20 ;
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 SET RMSTA=$PIECE($GET(^RMPR(661.3,RLOC,0)),U,3)
SET RMPRI(RMSTA,RML)=RLOC
End DoDot:1
+4 QUIT
+5 ;
EXIT ;I $E(IOST)["C" W ! S DIR(0)="E" D ^DIR
+1 DO ^%ZISC
KILL ^TMP($JOB,"RM")
+2 NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
+3 QUIT
NONE SET ^TMP($JOB,0)="NO DATA FOR THIS DATE RANGE"
+1 QUIT
