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