RMPRPIXR ;HINES OIFO/ODJ - REMOVE/DEACTIVATE ITEM ;12/11/02 10:22
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
;
RE ;remove/deactivate an HCPCS/ITEM
;***** STN - prompt for Site/Station
STN S RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
I RMPRERR G DLX
I RMPREXC'="" G DLX
W !!,"*** Removing/Deactivating HCPCS......",!
;
HCPCS ;
K ^TMP($J),Y,DIR
K RMPR1,RMPR11,RMPR5,RMPRLCN,RMPREXC,RMPRERR,RMPRUNI,RMDEL,RMOUT
W !
S RMPR1("REMOVE")=1
D HCPCS^RMPRPIY7(RMPRSTN("IEN"),$G(RMPR1("HCPCS")),.RMPR1,.RMPR11,.RMPREXC)
I RMPREXC="T" G DLX
I RMPREXC="P" G STN
I RMPREXC="^" D G DLX
. W !,"** No HCPCS selected." H 1
S RS=RMPRSTN("IEN"),RH=RMPR1("HCPCS")
;
ALL ;ask if all item will be remove/deactivate
S DIR(0)="Y",DIR("B")="N"
W !
S DIR("A")="Do you want to Remove/Deactivate ALL Items for this HCPCS"
D ^DIR
I $D(DTOUT)!$D(DUOUT)!(Y="^") W !!,"Nothing Remove.." G HCPCS
I Y=1 S RMDEL="ALL" D I $G(RMOUT) H 2 G HCPCS
.S DIR(0)="Y",DIR("B")="N"
.W !
.S DIR("A")="Are you sure you want to Remove/Deactivate ALL ITEMs for HCPCS "_RMPR1("HCPCS")
.D ^DIR
.I $D(DTOUT)!$D(DUOUT)!(Y="^")!(Y=0) W !!,"Nothing Remove.." S RMOUT=1
G:$D(RMDEL) ZERO
;
ITEM ;
D ITEM^RMPRPIYP(RMPRSTN("IEN"),$G(RMPR1("HCPCS")),.RMPR11,.RMPREXC)
I RMPREXC="T" G DLX
I RMPREXC="P" G HCPCS
I RMPREXC="^" G HCPCS
;
S DIR(0)="Y",DIR("B")="N"
W !
S DIR("A")="Are you sure you want to Remove/Deactivate this HCPCS/ITEM "_RMPR11("HCPCS-ITEM")
D ^DIR
I $D(DTOUT)!$D(DUOUT)!(Y="^")!(Y=0) W !!,"Nothing Remove.." G HCPCS
;
ZERO ;zero out
;only delete one if item if specified
I $D(RMPR11("ITEM")) G DEL1
G:$D(RMDEL) ALLIT
;
DEL1 ;remove one item
;
S RI=RMPR11("ITEM")
F RD=0:0 S RD=$O(^RMPR(661.7,"XSHIDS",RS,RH,RI,RD)) Q:RD'>0 F RIEN=0:0 S RIEN=$O(^RMPR(661.7,"XSHIDS",RS,RH,RI,RD,1,RIEN)) Q:RIEN'>0 D
.Q:'$D(^RMPR(661.7,RIEN,0))
.S RMDA=^RMPR(661.7,RIEN,0)
.S RML=$P(RMDA,U,6),RMQ=$P(RMDA,U,7),RMV=$P(RMDA,U,8)
.;call update 661.6
.S RMPR11("HCPCS")=RH,RMPR11("ITEM")=RI,RMPR11("STATION")=RS
.S RMPR6("COMMENT")="",RMPR6("LOCATION")="",RMPR6("QUANTITY")=0
.S RMPR6("SEQUENCE")=0,RMPR6("TRAN TYPE")=9,RMPR6("USER")=$G(DUZ)
.S RMPR6("VALUE")=0,RMPR6("VENDOR")=""
.S RMERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
.;delete entry in #661.7
.Q:'$G(RIEN)
.K DIK S DIK="^RMPR(661.7,",DA=RIEN D ^DIK
.;update 661.9
.K R9,R9DA
.I $D(^RMPR(661.9,"ASHID",RS,RH,RI,DT)) D
..S R9=$O(^RMPR(661.9,"ASHID",RS,RH,RI,DT,""),-1)
..I $G(R9),$D(^RMPR(661.9,R9,0)) S R9DA=^RMPR(661.9,R9,0)
..I $D(R9DA),$P(R9DA,U,8)=0 Q
..D UP9
.I '$D(^RMPR(661.9,"ASHID",RS,RH,RI,DT)) D UP9
.S RHRI=RH_"-"_RI
.S ^TMP($J,RHRI)=""
;print a message to the screen for items being removed
D MESS
;change status of hcpcs & deactivation date in 661.11
K RMERR,RMDAT,K
S RMDAT(661.11,RMPR11("IEN")_",",8)=1
S RMDAT(661.11,RMPR11("IEN")_",",9)=DT
D FILE^DIE("K","RMDAT","RMERR")
I $D(RMERR) W !!,"*** Error updating file #661.11 update!!!",!!
G HCPCS
;
ALLIT ;remove/deactivate all items for selected HCPCS.
;
F RI=0:0 S RI=$O(^RMPR(661.7,"XSHIDS",RS,RH,RI)) Q:RI'>0 D
.F RD=0:0 S RD=$O(^RMPR(661.7,"XSHIDS",RS,RH,RI,RD)) Q:RD'>0 F RIEN=0:0 S RIEN=$O(^RMPR(661.7,"XSHIDS",RS,RH,RI,RD,1,RIEN)) Q:RIEN'>0 D
..Q:'$D(^RMPR(661.7,RIEN,0))
..S RMDA=^RMPR(661.7,RIEN,0)
..S RML=$P(RMDA,U,6),RMQ=$P(RMDA,U,7),RMV=$P(RMDA,U,8)
..;update 661.6
..S RMPR11("HCPCS")=RH,RMPR11("ITEM")=RI,RMPR11("STATION")=RS
..S RMPR6("COMMENT")="",RMPR6("LOCATION")="",RMPR6("QUANTITY")=0
..S RMPR6("SEQUENCE")=0,RMPR6("TRAN TYPE")=9,RMPR6("USER")=$G(DUZ)
..S RMPR6("VALUE")=0,RMPR6("VENDOR")=""
..S RMERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
..;delete entry from #661.7
..Q:'$G(RIEN)
..K DIK S DIK="^RMPR(661.7,",DA=RIEN D ^DIK
..; update 661.9
K R9,R9DA
F RI=0:0 S RI=$O(^RMPR(661.9,"ASHID",RS,RH,RI)) Q:RI'>0 D UP9
;
;print a message of items being removed/deactivated
F I=0:0 S I=$O(^RMPR(661.11,"ASHI",RS,RH,I)) Q:I'>0 D
.F J=0:0 S J=$O(^RMPR(661.11,"ASHI",RS,RH,I,J)) Q:J'>0 D
..S RHRI=RH_"-"_I
..S ^TMP($J,RHRI)=""
D MESS
;change status of hcpcs & deactivation date in 661.11
;loop through all items in a particular HCPCS
F RI=0:0 S RI=$O(^RMPR(661.11,"ASHI",RS,RH,RI)) Q:RI'>0 D
.F RJ=0:0 S RJ=$O(^RMPR(661.11,"ASHI",RS,RH,RI,RJ)) Q:RJ'>0 D
..K RMERR,K,RMDAT
..S RMDAT(661.11,RJ_",",8)=1
..S RMDAT(661.11,RJ_",",9)=DT
..D FILE^DIE("K","RMDAT","RMERR")
..I $D(RMERR) W !!,"*** Error updating file #661.11 update!!!",!!
;ask for another HCPCCS to remove
G HCPCS
;
UP9 ;CREATE entry in file #661.9
K RMDAT,RMERR,RIN
S RMDAT(661.9,"+1,",.01)=DT
S RMDAT(661.9,"+1,",1)=RH
S RMDAT(661.9,"+1,",2)=RI
S RMDAT(661.9,"+1,",4)=RS
S RMDAT(661.9,"+1,",7)=0
S RMDAT(661.9,"+1,",8)=0
D UPDATE^DIE("","RMDAT","RIN","RMERR")
I $D(RMERR) W !!,"*** Error updating file #661.9 !!!",!!
Q
;
MESS ;print a deleted message
S I="" F S I=$O(^TMP($J,I)) Q:I="" D
.W !!,"*** HCPCS/ITEM "_I_" has been Removed/Deactivated from PIP..."
K ^TMP($J)
Q
;
DLX N RMPR,RMPRSITE D KILL^XUSCLEAN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIXR 5123 printed Dec 13, 2024@02:36:48 Page 2
RMPRPIXR ;HINES OIFO/ODJ - REMOVE/DEACTIVATE ITEM ;12/11/02 10:22
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ;
RE ;remove/deactivate an HCPCS/ITEM
+1 ;***** STN - prompt for Site/Station
STN SET RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
+1 IF RMPRERR
GOTO DLX
+2 IF RMPREXC'=""
GOTO DLX
+3 WRITE !!,"*** Removing/Deactivating HCPCS......",!
+4 ;
HCPCS ;
+1 KILL ^TMP($JOB),Y,DIR
+2 KILL RMPR1,RMPR11,RMPR5,RMPRLCN,RMPREXC,RMPRERR,RMPRUNI,RMDEL,RMOUT
+3 WRITE !
+4 SET RMPR1("REMOVE")=1
+5 DO HCPCS^RMPRPIY7(RMPRSTN("IEN"),$GET(RMPR1("HCPCS")),.RMPR1,.RMPR11,.RMPREXC)
+6 IF RMPREXC="T"
GOTO DLX
+7 IF RMPREXC="P"
GOTO STN
+8 IF RMPREXC="^"
Begin DoDot:1
+9 WRITE !,"** No HCPCS selected."
HANG 1
End DoDot:1
GOTO DLX
+10 SET RS=RMPRSTN("IEN")
SET RH=RMPR1("HCPCS")
+11 ;
ALL ;ask if all item will be remove/deactivate
+1 SET DIR(0)="Y"
SET DIR("B")="N"
+2 WRITE !
+3 SET DIR("A")="Do you want to Remove/Deactivate ALL Items for this HCPCS"
+4 DO ^DIR
+5 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="^")
WRITE !!,"Nothing Remove.."
GOTO HCPCS
+6 IF Y=1
SET RMDEL="ALL"
Begin DoDot:1
+7 SET DIR(0)="Y"
SET DIR("B")="N"
+8 WRITE !
+9 SET DIR("A")="Are you sure you want to Remove/Deactivate ALL ITEMs for HCPCS "_RMPR1("HCPCS")
+10 DO ^DIR
+11 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="^")!(Y=0)
WRITE !!,"Nothing Remove.."
SET RMOUT=1
End DoDot:1
IF $GET(RMOUT)
HANG 2
GOTO HCPCS
+12 if $DATA(RMDEL)
GOTO ZERO
+13 ;
ITEM ;
+1 DO ITEM^RMPRPIYP(RMPRSTN("IEN"),$GET(RMPR1("HCPCS")),.RMPR11,.RMPREXC)
+2 IF RMPREXC="T"
GOTO DLX
+3 IF RMPREXC="P"
GOTO HCPCS
+4 IF RMPREXC="^"
GOTO HCPCS
+5 ;
+6 SET DIR(0)="Y"
SET DIR("B")="N"
+7 WRITE !
+8 SET DIR("A")="Are you sure you want to Remove/Deactivate this HCPCS/ITEM "_RMPR11("HCPCS-ITEM")
+9 DO ^DIR
+10 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="^")!(Y=0)
WRITE !!,"Nothing Remove.."
GOTO HCPCS
+11 ;
ZERO ;zero out
+1 ;only delete one if item if specified
+2 IF $DATA(RMPR11("ITEM"))
GOTO DEL1
+3 if $DATA(RMDEL)
GOTO ALLIT
+4 ;
DEL1 ;remove one item
+1 ;
+2 SET RI=RMPR11("ITEM")
+3 FOR RD=0:0
SET RD=$ORDER(^RMPR(661.7,"XSHIDS",RS,RH,RI,RD))
if RD'>0
QUIT
FOR RIEN=0:0
SET RIEN=$ORDER(^RMPR(661.7,"XSHIDS",RS,RH,RI,RD,1,RIEN))
if RIEN'>0
QUIT
Begin DoDot:1
+4 if '$DATA(^RMPR(661.7,RIEN,0))
QUIT
+5 SET RMDA=^RMPR(661.7,RIEN,0)
+6 SET RML=$PIECE(RMDA,U,6)
SET RMQ=$PIECE(RMDA,U,7)
SET RMV=$PIECE(RMDA,U,8)
+7 ;call update 661.6
+8 SET RMPR11("HCPCS")=RH
SET RMPR11("ITEM")=RI
SET RMPR11("STATION")=RS
+9 SET RMPR6("COMMENT")=""
SET RMPR6("LOCATION")=""
SET RMPR6("QUANTITY")=0
+10 SET RMPR6("SEQUENCE")=0
SET RMPR6("TRAN TYPE")=9
SET RMPR6("USER")=$GET(DUZ)
+11 SET RMPR6("VALUE")=0
SET RMPR6("VENDOR")=""
+12 SET RMERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
+13 ;delete entry in #661.7
+14 if '$GET(RIEN)
QUIT
+15 KILL DIK
SET DIK="^RMPR(661.7,"
SET DA=RIEN
DO ^DIK
+16 ;update 661.9
+17 KILL R9,R9DA
+18 IF $DATA(^RMPR(661.9,"ASHID",RS,RH,RI,DT))
Begin DoDot:2
+19 SET R9=$ORDER(^RMPR(661.9,"ASHID",RS,RH,RI,DT,""),-1)
+20 IF $GET(R9)
IF $DATA(^RMPR(661.9,R9,0))
SET R9DA=^RMPR(661.9,R9,0)
+21 IF $DATA(R9DA)
IF $PIECE(R9DA,U,8)=0
QUIT
+22 DO UP9
End DoDot:2
+23 IF '$DATA(^RMPR(661.9,"ASHID",RS,RH,RI,DT))
DO UP9
+24 SET RHRI=RH_"-"_RI
+25 SET ^TMP($JOB,RHRI)=""
End DoDot:1
+26 ;print a message to the screen for items being removed
+27 DO MESS
+28 ;change status of hcpcs & deactivation date in 661.11
+29 KILL RMERR,RMDAT,K
+30 SET RMDAT(661.11,RMPR11("IEN")_",",8)=1
+31 SET RMDAT(661.11,RMPR11("IEN")_",",9)=DT
+32 DO FILE^DIE("K","RMDAT","RMERR")
+33 IF $DATA(RMERR)
WRITE !!,"*** Error updating file #661.11 update!!!",!!
+34 GOTO HCPCS
+35 ;
ALLIT ;remove/deactivate all items for selected HCPCS.
+1 ;
+2 FOR RI=0:0
SET RI=$ORDER(^RMPR(661.7,"XSHIDS",RS,RH,RI))
if RI'>0
QUIT
Begin DoDot:1
+3 FOR RD=0:0
SET RD=$ORDER(^RMPR(661.7,"XSHIDS",RS,RH,RI,RD))
if RD'>0
QUIT
FOR RIEN=0:0
SET RIEN=$ORDER(^RMPR(661.7,"XSHIDS",RS,RH,RI,RD,1,RIEN))
if RIEN'>0
QUIT
Begin DoDot:2
+4 if '$DATA(^RMPR(661.7,RIEN,0))
QUIT
+5 SET RMDA=^RMPR(661.7,RIEN,0)
+6 SET RML=$PIECE(RMDA,U,6)
SET RMQ=$PIECE(RMDA,U,7)
SET RMV=$PIECE(RMDA,U,8)
+7 ;update 661.6
+8 SET RMPR11("HCPCS")=RH
SET RMPR11("ITEM")=RI
SET RMPR11("STATION")=RS
+9 SET RMPR6("COMMENT")=""
SET RMPR6("LOCATION")=""
SET RMPR6("QUANTITY")=0
+10 SET RMPR6("SEQUENCE")=0
SET RMPR6("TRAN TYPE")=9
SET RMPR6("USER")=$GET(DUZ)
+11 SET RMPR6("VALUE")=0
SET RMPR6("VENDOR")=""
+12 SET RMERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
+13 ;delete entry from #661.7
+14 if '$GET(RIEN)
QUIT
+15 KILL DIK
SET DIK="^RMPR(661.7,"
SET DA=RIEN
DO ^DIK
+16 ; update 661.9
End DoDot:2
End DoDot:1
+17 KILL R9,R9DA
+18 FOR RI=0:0
SET RI=$ORDER(^RMPR(661.9,"ASHID",RS,RH,RI))
if RI'>0
QUIT
DO UP9
+19 ;
+20 ;print a message of items being removed/deactivated
+21 FOR I=0:0
SET I=$ORDER(^RMPR(661.11,"ASHI",RS,RH,I))
if I'>0
QUIT
Begin DoDot:1
+22 FOR J=0:0
SET J=$ORDER(^RMPR(661.11,"ASHI",RS,RH,I,J))
if J'>0
QUIT
Begin DoDot:2
+23 SET RHRI=RH_"-"_I
+24 SET ^TMP($JOB,RHRI)=""
End DoDot:2
End DoDot:1
+25 DO MESS
+26 ;change status of hcpcs & deactivation date in 661.11
+27 ;loop through all items in a particular HCPCS
+28 FOR RI=0:0
SET RI=$ORDER(^RMPR(661.11,"ASHI",RS,RH,RI))
if RI'>0
QUIT
Begin DoDot:1
+29 FOR RJ=0:0
SET RJ=$ORDER(^RMPR(661.11,"ASHI",RS,RH,RI,RJ))
if RJ'>0
QUIT
Begin DoDot:2
+30 KILL RMERR,K,RMDAT
+31 SET RMDAT(661.11,RJ_",",8)=1
+32 SET RMDAT(661.11,RJ_",",9)=DT
+33 DO FILE^DIE("K","RMDAT","RMERR")
+34 IF $DATA(RMERR)
WRITE !!,"*** Error updating file #661.11 update!!!",!!
End DoDot:2
End DoDot:1
+35 ;ask for another HCPCCS to remove
+36 GOTO HCPCS
+37 ;
UP9 ;CREATE entry in file #661.9
+1 KILL RMDAT,RMERR,RIN
+2 SET RMDAT(661.9,"+1,",.01)=DT
+3 SET RMDAT(661.9,"+1,",1)=RH
+4 SET RMDAT(661.9,"+1,",2)=RI
+5 SET RMDAT(661.9,"+1,",4)=RS
+6 SET RMDAT(661.9,"+1,",7)=0
+7 SET RMDAT(661.9,"+1,",8)=0
+8 DO UPDATE^DIE("","RMDAT","RIN","RMERR")
+9 IF $DATA(RMERR)
WRITE !!,"*** Error updating file #661.9 !!!",!!
+10 QUIT
+11 ;
MESS ;print a deleted message
+1 SET I=""
FOR
SET I=$ORDER(^TMP($JOB,I))
if I=""
QUIT
Begin DoDot:1
+2 WRITE !!,"*** HCPCS/ITEM "_I_" has been Removed/Deactivated from PIP..."
End DoDot:1
+3 KILL ^TMP($JOB)
+4 QUIT
+5 ;
DLX NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
+1 QUIT
