RMPR5NU ;HIN/RVD-PROS INVENTORY SITE PARAMETERS UTILITY ;2/11/98
;;3.0;PROSTHETICS;**33,38,52,61,132**;Feb 09, 1996;Build 13
;
;DBIA #10090 - file #4.
; ODJ - patch 52 - 10/17/00 - if a 661.3 record is corrupted with a null
; HCPC code then put message in report and
; prevent routine from crashing.
; (see nois NYH-0900-12030)
;
; RVD - patch #61 - used new files for inventory balance task job.
;
ADD ;add/edit inventory SITE PARAMETER
S DIC("A")="Select Prosthetics Site Name : "
S DIR("A")="Would you like to ACTIVATE this Item (Y/N) ",DIC=669.9,DIR(0)="Y"
S DIC(0)="AEMQ" D ^DIC G:Y'>0 EXIT G:$D(DTOUT) EXIT S DA=+Y
;
;I $P(^RMPR(661,RMDA,1),U,9)'=1 W !!,$C(7),"*** Item is inactive ***" D ^DIR S:Y=1 $P(^RMPR(661,RMDA,1),U,9)=1 G:Y=0 ADD
S DIE=DIC,DR="35" D ^DIE
G ADD
;
TASK ;entry point for task job to check balances.
K ^TMP($J)
S IO=0
S Y=DT D DD^%DT S RMRDAT=Y
S RMERR=$$MES^RMPRPIUD("")
;a TMP($J global created for mail message.
Q:$G(RMERR)
D PROC S RMSUBI=5
I $D(^TMP($J,"RMX")) D BUILD
MAIL D:$D(^XMB(3.8,"B","RMPR INVENTORY")) MES1,MES2
;set Notification Date in file #669.9
S RS=0
F S RS=$O(^RMPR(669.9,RS)) Q:RS'>0 S $P(^RMPR(669.9,RS,"INV"),U,3)=DT
;D WRI ;for printing to a designated inventory printer.
G EXIT
;
PROC ;process
F I=0:0 S I=$O(^TMP($J,"RMPRPIUD",I)) Q:I'>0 S J="" F S J=$O(^TMP($J,"RMPRPIUD",I,J)) Q:J="" F K=0:0 S K=$O(^TMP($J,"RMPRPIUD",I,J,K)) Q:K'>0 D
.F L=0:0 S L=$O(^TMP($J,"RMPRPIUD",I,J,K,"L",L)) Q:L'>0 D
..S RMDATA=$G(^TMP($J,"RMPRPIUD",I,J,K,"L",L))
..S RMREOR=$P(RMDATA,U,1)
..S RMQUAN=$P(RMDATA,U,2) I RMQUAN="" S RMQUAN=0
..I RMREOR>RMQUAN D
...S RM11=$O(^RMPR(661.11,"ASHI",I,J,K,0))
...S RMITEM="xxxx"
...I RM11,$D(^RMPR(661.11,RM11,0)) Q:$P(^RMPR(661.11,RM11,0),U,9) S RMITEM=$P(^RMPR(661.11,RM11,0),U,3)
...S RML="****"
...I L,$D(^RMPR(661.5,L,0)) S RML=$P(^RMPR(661.5,L,0),U,1)
...S ^TMP($J,"RMX",I,RML,RMITEM)=RMITEM_"^"_RMREOR_"^"_RMQUAN_"^"_J_"-"_K
...I $D(^TMP($J,"RMPRPIUD",I,J,K,"M")) D
....F RMI=0:0 S RMI=$O(^TMP($J,"RMPRPIUD",I,J,K,"M",RMI)) Q:RMI'>0 D
.....S RMLEFT=0
.....F RMJ=0:0 S RMJ=$O(^TMP($J,"RMPRPIUD",I,J,K,"M",RMI,RMJ)) Q:RMJ'>0 S RM41=^TMP($J,"RMPRPIUD",I,J,K,"M",RMI,RMJ) D
......S RMORD=$P(RM41,U,1)
......S RMDATO=$P(RM41,U,2),RMRECV=$P(RM41,U,3),RMWDS=""
......S:RMRECV RMWDS=" ...received to-date: "_RMRECV
......;S RMLEF=RMORD-RMREC
......;I $G(RMLEF) S RMLEFT=RMLEFT+RMLEF
......I $G(RMORD) S ^TMP($J,"RMX",I,RML,RMITEM,"M",RMJ)=" **** Quantity = "_RMORD_" has been ordered for item..."_RMITEM_" on "_RMDATO_RMWDS
;
Q
MES1 ;
S XMY("G.RMPR INVENTORY")="",XMDUZ=.5,XMTEXT="RMX("
S XMSUB="PROSTHETICS INVENTORY MESSAGE"
S RMX(1)="Run Date: "_RMRDAT
S RMX(2)="This is a notification from the Prosthetics Department........"
S RMX(3)=""
S RMX(4)="The current balance for the following item(s) is/are below the reorder level:"
S RMX(5)="[Site] [Location] [Item] [HCPCS] [Reorder Lvl] [Bal] "
Q
MES2 ;
S RMX(RMSUBI+2)=""
S RMX(RMSUBI+3)=""
S RMX(RMSUBI+4)="Thank You!!!"
S RMX(RMSUBI+5)=""
S RMX(RMSUBI+6)="PROSTHETICS DEPARTMENT"
D ^XMD
Q
;
BUILD S I=""
F S I=$O(^TMP($J,"RMX",I)) Q:I="" S J="" F S J=$O(^TMP($J,"RMX",I,J)) Q:J="" S K="" F S K=$O(^TMP($J,"RMX",I,J,K)) Q:K="" S RM0=^TMP($J,"RMX",I,J,K) D
.S RML=$P(RM0,U,2),RMB=$P(RM0,U,3),RMSTA=I,RMLO=J,RMITEM=K,RMHCPC=$P(RM0,U,4)_" "
.S RMITEM=RMITEM_" "
.S RMSUBI=RMSUBI+1,RMLO=RMLO_" "
.S RMX(RMSUBI)=$E($P(^DIC(4,RMSTA,0),U,1),1,6)_" "_$E(RMLO,1,16)_" "_$E(RMITEM,1,28)_" "_$E(RMHCPC,1,9)_" "_$J(RML,5)_" "_$J(RMB,5)
.;S RMXI(RMSUBI)=RMX(RMSUBI)_"^"_I_"^"_J_"^"_K
.I $D(^TMP($J,"RMX",I,J,K,"M")) D
..S RMJ=0
..F S RMJ=$O(^TMP($J,"RMX",I,J,K,"M",RMJ)) Q:RMJ="" D
...S RMSUBI=RMSUBI+1,RMX(RMSUBI)=^TMP($J,"RMX",I,J,K,"M",RMJ)
Q
;
WRI ;PRINT NOTIFICATION LETTER IN SUPPLY PRINTER. This functionality is not included with this released.
;S RMDEV=$P(^RMPR(669.9,RS,"INV"),U,1)
;S RMIOS=IO,IO=$P(^%ZIS(1,RMDEV,0),U,2)
;D NOW^%DTC
;O IO U IO W !,"Run Date: ",RMRDAT,!!,"This is a notification from the Prosthetics Department..."
;W !!,"The current balance for the following item(s) is/are below the reorder level:"
;W !,"[Location] [Item] [HCPCS] [Reorder Level] [Current Balance]"
;F I=0:0 S I=$O(RMXI(I)) Q:I'>0 D
;.S RMLO=$P(RMXI(I),U,2),RMI=$P(RMXI(I),U,3)
;.W !,$P(RMXI(I),U,1)
;.S $P(^RMPR(661.3,RMLO,1,RMI,0),U,7)=%
;W !!!,"Thank You!!!!!"
;W !!,"PROSTHETICS DEPARTMENT"
;S $P(^RMPR(669.9,RS,"INV"),U,3)=DT
;D ^%ZISC S IO=RMIOS O IO U IO
;K RMB,RMD,RMI,RML,RMDO,RMDATI,RMLOCI,RMXI,I,J,XMTEXT,RMGROUP,RMHCPC
;Q
;
EXIT ;MAIN EXIT POINT
N RMPRSITE,RMPR D KILL^XUSCLEAN
K ^TMP($J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5NU 4936 printed Apr 09, 2024@21:34:29 Page 2
RMPR5NU ;HIN/RVD-PROS INVENTORY SITE PARAMETERS UTILITY ;2/11/98
+1 ;;3.0;PROSTHETICS;**33,38,52,61,132**;Feb 09, 1996;Build 13
+2 ;
+3 ;DBIA #10090 - file #4.
+4 ; ODJ - patch 52 - 10/17/00 - if a 661.3 record is corrupted with a null
+5 ; HCPC code then put message in report and
+6 ; prevent routine from crashing.
+7 ; (see nois NYH-0900-12030)
+8 ;
+9 ; RVD - patch #61 - used new files for inventory balance task job.
+10 ;
ADD ;add/edit inventory SITE PARAMETER
+1 SET DIC("A")="Select Prosthetics Site Name : "
+2 SET DIR("A")="Would you like to ACTIVATE this Item (Y/N) "
SET DIC=669.9
SET DIR(0)="Y"
+3 SET DIC(0)="AEMQ"
DO ^DIC
if Y'>0
GOTO EXIT
if $DATA(DTOUT)
GOTO EXIT
SET DA=+Y
+4 ;
+5 ;I $P(^RMPR(661,RMDA,1),U,9)'=1 W !!,$C(7),"*** Item is inactive ***" D ^DIR S:Y=1 $P(^RMPR(661,RMDA,1),U,9)=1 G:Y=0 ADD
+6 SET DIE=DIC
SET DR="35"
DO ^DIE
+7 GOTO ADD
+8 ;
TASK ;entry point for task job to check balances.
+1 KILL ^TMP($JOB)
+2 SET IO=0
+3 SET Y=DT
DO DD^%DT
SET RMRDAT=Y
+4 SET RMERR=$$MES^RMPRPIUD("")
+5 ;a TMP($J global created for mail message.
+6 if $GET(RMERR)
QUIT
+7 DO PROC
SET RMSUBI=5
+8 IF $DATA(^TMP($JOB,"RMX"))
DO BUILD
MAIL if $DATA(^XMB(3.8,"B","RMPR INVENTORY"))
DO MES1
DO MES2
+1 ;set Notification Date in file #669.9
+2 SET RS=0
+3 FOR
SET RS=$ORDER(^RMPR(669.9,RS))
if RS'>0
QUIT
SET $PIECE(^RMPR(669.9,RS,"INV"),U,3)=DT
+4 ;D WRI ;for printing to a designated inventory printer.
+5 GOTO EXIT
+6 ;
PROC ;process
+1 FOR I=0:0
SET I=$ORDER(^TMP($JOB,"RMPRPIUD",I))
if I'>0
QUIT
SET J=""
FOR
SET J=$ORDER(^TMP($JOB,"RMPRPIUD",I,J))
if J=""
QUIT
FOR K=0:0
SET K=$ORDER(^TMP($JOB,"RMPRPIUD",I,J,K))
if K'>0
QUIT
Begin DoDot:1
+2 FOR L=0:0
SET L=$ORDER(^TMP($JOB,"RMPRPIUD",I,J,K,"L",L))
if L'>0
QUIT
Begin DoDot:2
+3 SET RMDATA=$GET(^TMP($JOB,"RMPRPIUD",I,J,K,"L",L))
+4 SET RMREOR=$PIECE(RMDATA,U,1)
+5 SET RMQUAN=$PIECE(RMDATA,U,2)
IF RMQUAN=""
SET RMQUAN=0
+6 IF RMREOR>RMQUAN
Begin DoDot:3
+7 SET RM11=$ORDER(^RMPR(661.11,"ASHI",I,J,K,0))
+8 SET RMITEM="xxxx"
+9 IF RM11
IF $DATA(^RMPR(661.11,RM11,0))
if $PIECE(^RMPR(661.11,RM11,0),U,9)
QUIT
SET RMITEM=$PIECE(^RMPR(661.11,RM11,0),U,3)
+10 SET RML="****"
+11 IF L
IF $DATA(^RMPR(661.5,L,0))
SET RML=$PIECE(^RMPR(661.5,L,0),U,1)
+12 SET ^TMP($JOB,"RMX",I,RML,RMITEM)=RMITEM_"^"_RMREOR_"^"_RMQUAN_"^"_J_"-"_K
+13 IF $DATA(^TMP($JOB,"RMPRPIUD",I,J,K,"M"))
Begin DoDot:4
+14 FOR RMI=0:0
SET RMI=$ORDER(^TMP($JOB,"RMPRPIUD",I,J,K,"M",RMI))
if RMI'>0
QUIT
Begin DoDot:5
+15 SET RMLEFT=0
+16 FOR RMJ=0:0
SET RMJ=$ORDER(^TMP($JOB,"RMPRPIUD",I,J,K,"M",RMI,RMJ))
if RMJ'>0
QUIT
SET RM41=^TMP($JOB,"RMPRPIUD",I,J,K,"M",RMI,RMJ)
Begin DoDot:6
+17 SET RMORD=$PIECE(RM41,U,1)
+18 SET RMDATO=$PIECE(RM41,U,2)
SET RMRECV=$PIECE(RM41,U,3)
SET RMWDS=""
+19 if RMRECV
SET RMWDS=" ...received to-date: "_RMRECV
+20 ;S RMLEF=RMORD-RMREC
+21 ;I $G(RMLEF) S RMLEFT=RMLEFT+RMLEF
+22 IF $GET(RMORD)
SET ^TMP($JOB,"RMX",I,RML,RMITEM,"M",RMJ)=" **** Quantity = "_RMORD_" has been ordered for item..."_RMITEM_" on "_RMDATO_RMWDS
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 ;
+24 QUIT
MES1 ;
+1 SET XMY("G.RMPR INVENTORY")=""
SET XMDUZ=.5
SET XMTEXT="RMX("
+2 SET XMSUB="PROSTHETICS INVENTORY MESSAGE"
+3 SET RMX(1)="Run Date: "_RMRDAT
+4 SET RMX(2)="This is a notification from the Prosthetics Department........"
+5 SET RMX(3)=""
+6 SET RMX(4)="The current balance for the following item(s) is/are below the reorder level:"
+7 SET RMX(5)="[Site] [Location] [Item] [HCPCS] [Reorder Lvl] [Bal] "
+8 QUIT
MES2 ;
+1 SET RMX(RMSUBI+2)=""
+2 SET RMX(RMSUBI+3)=""
+3 SET RMX(RMSUBI+4)="Thank You!!!"
+4 SET RMX(RMSUBI+5)=""
+5 SET RMX(RMSUBI+6)="PROSTHETICS DEPARTMENT"
+6 DO ^XMD
+7 QUIT
+8 ;
BUILD SET I=""
+1 FOR
SET I=$ORDER(^TMP($JOB,"RMX",I))
if I=""
QUIT
SET J=""
FOR
SET J=$ORDER(^TMP($JOB,"RMX",I,J))
if J=""
QUIT
SET K=""
FOR
SET K=$ORDER(^TMP($JOB,"RMX",I,J,K))
if K=""
QUIT
SET RM0=^TMP($JOB,"RMX",I,J,K)
Begin DoDot:1
+2 SET RML=$PIECE(RM0,U,2)
SET RMB=$PIECE(RM0,U,3)
SET RMSTA=I
SET RMLO=J
SET RMITEM=K
SET RMHCPC=$PIECE(RM0,U,4)_" "
+3 SET RMITEM=RMITEM_" "
+4 SET RMSUBI=RMSUBI+1
SET RMLO=RMLO_" "
+5 SET RMX(RMSUBI)=$EXTRACT($PIECE(^DIC(4,RMSTA,0),U,1),1,6)_" "_$EXTRACT(RMLO,1,16)_" "_$EXTRACT(RMITEM,1,28)_" "_$EXTRACT(RMHCPC,1,9)_" "_$JUSTIFY(RML,5)_" "_$JUSTIFY(RMB,5)
+6 ;S RMXI(RMSUBI)=RMX(RMSUBI)_"^"_I_"^"_J_"^"_K
+7 IF $DATA(^TMP($JOB,"RMX",I,J,K,"M"))
Begin DoDot:2
+8 SET RMJ=0
+9 FOR
SET RMJ=$ORDER(^TMP($JOB,"RMX",I,J,K,"M",RMJ))
if RMJ=""
QUIT
Begin DoDot:3
+10 SET RMSUBI=RMSUBI+1
SET RMX(RMSUBI)=^TMP($JOB,"RMX",I,J,K,"M",RMJ)
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
WRI ;PRINT NOTIFICATION LETTER IN SUPPLY PRINTER. This functionality is not included with this released.
+1 ;S RMDEV=$P(^RMPR(669.9,RS,"INV"),U,1)
+2 ;S RMIOS=IO,IO=$P(^%ZIS(1,RMDEV,0),U,2)
+3 ;D NOW^%DTC
+4 ;O IO U IO W !,"Run Date: ",RMRDAT,!!,"This is a notification from the Prosthetics Department..."
+5 ;W !!,"The current balance for the following item(s) is/are below the reorder level:"
+6 ;W !,"[Location] [Item] [HCPCS] [Reorder Level] [Current Balance]"
+7 ;F I=0:0 S I=$O(RMXI(I)) Q:I'>0 D
+8 ;.S RMLO=$P(RMXI(I),U,2),RMI=$P(RMXI(I),U,3)
+9 ;.W !,$P(RMXI(I),U,1)
+10 ;.S $P(^RMPR(661.3,RMLO,1,RMI,0),U,7)=%
+11 ;W !!!,"Thank You!!!!!"
+12 ;W !!,"PROSTHETICS DEPARTMENT"
+13 ;S $P(^RMPR(669.9,RS,"INV"),U,3)=DT
+14 ;D ^%ZISC S IO=RMIOS O IO U IO
+15 ;K RMB,RMD,RMI,RML,RMDO,RMDATI,RMLOCI,RMXI,I,J,XMTEXT,RMGROUP,RMHCPC
+16 ;Q
+17 ;
EXIT ;MAIN EXIT POINT
+1 NEW RMPRSITE,RMPR
DO KILL^XUSCLEAN
+2 KILL ^TMP($JOB)
+3 QUIT
