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

RMPR5NRE.m

Go to the documentation of this file.
  1. RMPR5NRE ;HIN/RVD-PROS INVENTORY REMOVE UTILITY ;2/11/98
  1. ;;3.0;PROSTHETICS;**33,37**;Feb 09, 1996
  1. D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
  1. S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
  1. W @IOF
  1. ;
  1. LOC ;get location
  1. S RMFLG=0
  1. S DZ="??",D="B"
  1. K DTOUT,DUOUT,DIC("B"),DIC("S")
  1. S DIC="^RMPR(661.3,",DIC(0)="AEQM"
  1. S DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
  1. S DIC(0)="AEQM"
  1. ;I $D(^RMPR(661.3,"B")) D DQ^DICQ
  1. S DIC("A")="Enter LOCATION: " D MIX^DIC1
  1. G:Y'>0!$D(DTOUT)!$D(DUOUT) EXIT S RMLODA=+Y
  1. S RMLOC=$P($G(^RMPR(661.3,+Y,0)),U,1)
  1. ;
  1. LIST ;list current HCPCS @ this Location
  1. K DTOUT,DUOUT,DIC("S"),DIR
  1. S DIC("A")="Select HCPCS to Remove: "
  1. S DA(1)=RMLODA,DIC(0)="AEMQ",DIC("W")="S RZ=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1) I RZ W ?15,$P(^RMPR(661.1,RZ,0),U,2)"
  1. S DIC="^RMPR(661.3,"_RMLODA_",1," D ^DIC
  1. I +Y'>0!$D(DTOUT)!$D(DUOUT) W !,"** No HCPCS selected..." H 2 G LOC
  1. S RMHCDA=+Y,RMDAHC=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
  1. ;
  1. ITEM G:'RMHCDA LIST K DIC
  1. S DA(1)=RMHCDA,DA(2)=RMLODA,DZ="??",D="B"
  1. S DIC("A")="Enter Item to Remove: "
  1. S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="AEMNQ"
  1. ;I $D(^RMPR(661.1,RMDAHC,3,"B")) D DQ^DICQ
  1. D ^DIC G:Y'>0!$D(DTOUT)!$D(DUOUT) LOC S RMITDA=+Y
  1. S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
  1. S RMIT=$P(RM3,U,1),RMBA=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMSO=$P(RM3,U,9)
  1. S RMDAIT=$P(RMIT,"-",2)
  1. S RM1=^RMPR(661.1,RMDAHC,3,RMDAIT,0)
  1. S DIR("A")="Are you sure you want to DEACTIVATE/REMOVE this item (Y/N)"
  1. S DIR(0)="Y" D ^DIR G:$D(DTOUT)!(+Y=0)!$D(DUOUT) LOC
  1. S DA=RMITDA,DA(2)=RMLODA,DA(1)=RMHCDA,DIK=DIC D ^DIK
  1. S DA(1)=RMLODA
  1. I '$D(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B")) S DIK="^RMPR(661.3,"_DA(1)_",1,",DA=RMHCDA D ^DIK
  1. I '$D(^RMPR(661.3,"C",RMDAHC)) S RMFLG=1
  1. W !,"**** Item has been removed from Location ",$P(^RMPR(661.3,RMLODA,0),U,1),!
  1. ;
  1. ;create item stattistics in file 661.2
  1. STAT D BAL^RMPR5NU1
  1. K DD,DO S DIC="^RMPR(661.2,",DIC(0)="L",X=DT,DLAYGO=661.2 D FILE^DICN
  1. G:$D(DTOUT)!(Y'>0) LOC S DA=+Y
  1. I 'RMFLG D
  1. .S RMMESF="Item Deactivated by "_$E($P(^VA(200,DUZ,0),U,1),1,15)_": (-"_RMBA_")"
  1. .S ^RMPR(661.2,DA,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2)
  1. .S DIK=DIC D IX1^DIK
  1. ;
  1. DEAC I RMFLG D
  1. .S RMMESF="Deactivated by "_$E($P(^VA(200,DUZ,0),U,1),1,15)_": ("
  1. .S ^RMPR(661.2,DA,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2)
  1. .S DIK=DIC D IX1^DIK
  1. .S $P(^RMPR(661.1,RMDAHC,0),U,9)=0 W !,"**** HCPCS has been deactivated from Pros Inventory...."
  1. H 1 G LOC
  1. ;
  1. EXIT ;MAIN EXIT POINT
  1. N RMPRSITE,RMPR D KILL^XUSCLEAN
  1. Q