- 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 Mar 13, 2025@21:38:15 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
