Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPRPIXR

RMPRPIXR.m

Go to the documentation of this file. 
  1. RMPRPIXR ;HINES OIFO/ODJ - REMOVE/DEACTIVATE ITEM ;12/11/02  10:22
  1.  ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
  1.  Q
  1.  ;
  1. RE ;remove/deactivate an HCPCS/ITEM
  1.  ;***** STN - prompt for Site/Station
  1. STN S RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
  1.  I RMPRERR G DLX
  1.  I RMPREXC'="" G DLX
  1.  W !!,"*** Removing/Deactivating HCPCS......",!
  1.  ;
  1. HCPCS ;
  1.  K ^TMP($J),Y,DIR
  1.  K RMPR1,RMPR11,RMPR5,RMPRLCN,RMPREXC,RMPRERR,RMPRUNI,RMDEL,RMOUT
  1.  W !
  1.  S RMPR1("REMOVE")=1
  1.  D HCPCS^RMPRPIY7(RMPRSTN("IEN"),$G(RMPR1("HCPCS")),.RMPR1,.RMPR11,.RMPREXC)
  1.  I RMPREXC="T" G DLX
  1.  I RMPREXC="P" G STN
  1.  I RMPREXC="^" D  G DLX
  1.  . W !,"** No HCPCS selected." H 1
  1.  S RS=RMPRSTN("IEN"),RH=RMPR1("HCPCS")
  1.  ;
  1. ALL ;ask if all item will be remove/deactivate
  1.  S DIR(0)="Y",DIR("B")="N"
  1.  W !
  1.  S DIR("A")="Do you want to Remove/Deactivate ALL Items for this HCPCS"
  1.  D ^DIR
  1.  I $D(DTOUT)!$D(DUOUT)!(Y="^") W !!,"Nothing Remove.." G HCPCS
  1.  I Y=1 S RMDEL="ALL" D  I $G(RMOUT) H 2 G HCPCS
  1.  .S DIR(0)="Y",DIR("B")="N"
  1.  .W !
  1.  .S DIR("A")="Are you sure you want to Remove/Deactivate ALL ITEMs for HCPCS "_RMPR1("HCPCS")
  1.  .D ^DIR
  1.  .I $D(DTOUT)!$D(DUOUT)!(Y="^")!(Y=0) W !!,"Nothing Remove.." S RMOUT=1
  1.  G:$D(RMDEL) ZERO
  1.  ;
  1. ITEM ;
  1.  D ITEM^RMPRPIYP(RMPRSTN("IEN"),$G(RMPR1("HCPCS")),.RMPR11,.RMPREXC)
  1.  I RMPREXC="T" G DLX
  1.  I RMPREXC="P" G HCPCS
  1.  I RMPREXC="^" G HCPCS
  1.  ;
  1.  S DIR(0)="Y",DIR("B")="N"
  1.  W !
  1.  S DIR("A")="Are you sure you want to Remove/Deactivate this HCPCS/ITEM "_RMPR11("HCPCS-ITEM")
  1.  D ^DIR
  1.  I $D(DTOUT)!$D(DUOUT)!(Y="^")!(Y=0) W !!,"Nothing Remove.." G HCPCS
  1.  ;
  1. ZERO ;zero out
  1.  ;only delete one if item if specified
  1.  I $D(RMPR11("ITEM")) G DEL1
  1.  G:$D(RMDEL) ALLIT
  1.  ;
  1. DEL1 ;remove one item
  1.  ;
  1.  S RI=RMPR11("ITEM")
  1.  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
  1.  .Q:'$D(^RMPR(661.7,RIEN,0))
  1.  .S RMDA=^RMPR(661.7,RIEN,0)
  1.  .S RML=$P(RMDA,U,6),RMQ=$P(RMDA,U,7),RMV=$P(RMDA,U,8)
  1.  .;call update 661.6
  1.  .S RMPR11("HCPCS")=RH,RMPR11("ITEM")=RI,RMPR11("STATION")=RS
  1.  .S RMPR6("COMMENT")="",RMPR6("LOCATION")="",RMPR6("QUANTITY")=0
  1.  .S RMPR6("SEQUENCE")=0,RMPR6("TRAN TYPE")=9,RMPR6("USER")=$G(DUZ)
  1.  .S RMPR6("VALUE")=0,RMPR6("VENDOR")=""
  1.  .S RMERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
  1.  .;delete entry in #661.7
  1.  .Q:'$G(RIEN)
  1.  .K DIK S DIK="^RMPR(661.7,",DA=RIEN D ^DIK
  1.  .;update 661.9
  1.  .K R9,R9DA
  1.  .I $D(^RMPR(661.9,"ASHID",RS,RH,RI,DT)) D
  1.  ..S R9=$O(^RMPR(661.9,"ASHID",RS,RH,RI,DT,""),-1)
  1.  ..I $G(R9),$D(^RMPR(661.9,R9,0)) S R9DA=^RMPR(661.9,R9,0)
  1.  ..I $D(R9DA),$P(R9DA,U,8)=0 Q
  1.  ..D UP9
  1.  .I '$D(^RMPR(661.9,"ASHID",RS,RH,RI,DT)) D UP9
  1.  .S RHRI=RH_"-"_RI
  1.  .S ^TMP($J,RHRI)=""
  1.  ;print a message to the screen for items being removed
  1.  D MESS
  1.  ;change status of hcpcs & deactivation date in 661.11
  1.  K RMERR,RMDAT,K
  1.  S RMDAT(661.11,RMPR11("IEN")_",",8)=1
  1.  S RMDAT(661.11,RMPR11("IEN")_",",9)=DT
  1.  D FILE^DIE("K","RMDAT","RMERR")
  1.  I $D(RMERR) W !!,"*** Error updating file #661.11 update!!!",!!
  1.  G HCPCS
  1.  ;
  1. ALLIT ;remove/deactivate all items for selected HCPCS.
  1.  ;
  1.  F RI=0:0 S RI=$O(^RMPR(661.7,"XSHIDS",RS,RH,RI)) Q:RI'>0  D
  1.  .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
  1.  ..Q:'$D(^RMPR(661.7,RIEN,0))
  1.  ..S RMDA=^RMPR(661.7,RIEN,0)
  1.  ..S RML=$P(RMDA,U,6),RMQ=$P(RMDA,U,7),RMV=$P(RMDA,U,8)
  1.  ..;update 661.6
  1.  ..S RMPR11("HCPCS")=RH,RMPR11("ITEM")=RI,RMPR11("STATION")=RS
  1.  ..S RMPR6("COMMENT")="",RMPR6("LOCATION")="",RMPR6("QUANTITY")=0
  1.  ..S RMPR6("SEQUENCE")=0,RMPR6("TRAN TYPE")=9,RMPR6("USER")=$G(DUZ)
  1.  ..S RMPR6("VALUE")=0,RMPR6("VENDOR")=""
  1.  ..S RMERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
  1.  ..;delete entry from  #661.7
  1.  ..Q:'$G(RIEN)
  1.  ..K DIK S DIK="^RMPR(661.7,",DA=RIEN D ^DIK
  1.  ..; update 661.9
  1.  K R9,R9DA
  1.  F RI=0:0 S RI=$O(^RMPR(661.9,"ASHID",RS,RH,RI)) Q:RI'>0  D UP9
  1.  ;
  1.  ;print a message of items being removed/deactivated
  1.  F I=0:0 S I=$O(^RMPR(661.11,"ASHI",RS,RH,I)) Q:I'>0  D
  1.  .F J=0:0 S J=$O(^RMPR(661.11,"ASHI",RS,RH,I,J)) Q:J'>0  D
  1.  ..S RHRI=RH_"-"_I
  1.  ..S ^TMP($J,RHRI)=""
  1.  D MESS
  1.  ;change status of hcpcs & deactivation date in 661.11
  1.  ;loop through all items in a particular HCPCS
  1.  F RI=0:0 S RI=$O(^RMPR(661.11,"ASHI",RS,RH,RI)) Q:RI'>0  D
  1.  .F RJ=0:0 S RJ=$O(^RMPR(661.11,"ASHI",RS,RH,RI,RJ)) Q:RJ'>0  D
  1.  ..K RMERR,K,RMDAT
  1.  ..S RMDAT(661.11,RJ_",",8)=1
  1.  ..S RMDAT(661.11,RJ_",",9)=DT
  1.  ..D FILE^DIE("K","RMDAT","RMERR")
  1.  ..I $D(RMERR) W !!,"*** Error updating file #661.11 update!!!",!!
  1.  ;ask for another HCPCCS to remove
  1.  G HCPCS
  1.  ;
  1. UP9 ;CREATE entry in file #661.9
  1.  K RMDAT,RMERR,RIN
  1.  S RMDAT(661.9,"+1,",.01)=DT
  1.  S RMDAT(661.9,"+1,",1)=RH
  1.  S RMDAT(661.9,"+1,",2)=RI
  1.  S RMDAT(661.9,"+1,",4)=RS
  1.  S RMDAT(661.9,"+1,",7)=0
  1.  S RMDAT(661.9,"+1,",8)=0
  1.  D UPDATE^DIE("","RMDAT","RIN","RMERR")
  1.  I $D(RMERR) W !!,"*** Error updating file #661.9 !!!",!!
  1.  Q
  1.  ;
  1. MESS ;print a deleted message
  1.  S I="" F  S I=$O(^TMP($J,I)) Q:I=""  D
  1.  .W !!,"*** HCPCS/ITEM "_I_" has been Removed/Deactivated from PIP..."
  1.  K ^TMP($J)
  1.  Q
  1.  ;
  1. DLX N RMPR,RMPRSITE D KILL^XUSCLEAN
  1.  Q