RMPR5NRE ;HIN/RVD-PROS INVENTORY REMOVE UTILITY ;2/11/98
;;3.0;PROSTHETICS;**33,37**;Feb 09, 1996
D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
W @IOF
;
LOC ;get location
S RMFLG=0
S DZ="??",D="B"
K DTOUT,DUOUT,DIC("B"),DIC("S")
S DIC="^RMPR(661.3,",DIC(0)="AEQM"
S DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
S DIC(0)="AEQM"
;I $D(^RMPR(661.3,"B")) D DQ^DICQ
S DIC("A")="Enter LOCATION: " D MIX^DIC1
G:Y'>0!$D(DTOUT)!$D(DUOUT) EXIT S RMLODA=+Y
S RMLOC=$P($G(^RMPR(661.3,+Y,0)),U,1)
;
LIST ;list current HCPCS @ this Location
K DTOUT,DUOUT,DIC("S"),DIR
S DIC("A")="Select HCPCS to Remove: "
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)"
S DIC="^RMPR(661.3,"_RMLODA_",1," D ^DIC
I +Y'>0!$D(DTOUT)!$D(DUOUT) W !,"** No HCPCS selected..." H 2 G LOC
S RMHCDA=+Y,RMDAHC=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
;
ITEM G:'RMHCDA LIST K DIC
S DA(1)=RMHCDA,DA(2)=RMLODA,DZ="??",D="B"
S DIC("A")="Enter Item to Remove: "
S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="AEMNQ"
;I $D(^RMPR(661.1,RMDAHC,3,"B")) D DQ^DICQ
D ^DIC G:Y'>0!$D(DTOUT)!$D(DUOUT) LOC S RMITDA=+Y
S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
S RMIT=$P(RM3,U,1),RMBA=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMSO=$P(RM3,U,9)
S RMDAIT=$P(RMIT,"-",2)
S RM1=^RMPR(661.1,RMDAHC,3,RMDAIT,0)
S DIR("A")="Are you sure you want to DEACTIVATE/REMOVE this item (Y/N)"
S DIR(0)="Y" D ^DIR G:$D(DTOUT)!(+Y=0)!$D(DUOUT) LOC
S DA=RMITDA,DA(2)=RMLODA,DA(1)=RMHCDA,DIK=DIC D ^DIK
S DA(1)=RMLODA
I '$D(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B")) S DIK="^RMPR(661.3,"_DA(1)_",1,",DA=RMHCDA D ^DIK
I '$D(^RMPR(661.3,"C",RMDAHC)) S RMFLG=1
W !,"**** Item has been removed from Location ",$P(^RMPR(661.3,RMLODA,0),U,1),!
;
;create item stattistics in file 661.2
STAT D BAL^RMPR5NU1
K DD,DO S DIC="^RMPR(661.2,",DIC(0)="L",X=DT,DLAYGO=661.2 D FILE^DICN
G:$D(DTOUT)!(Y'>0) LOC S DA=+Y
I 'RMFLG D
.S RMMESF="Item Deactivated by "_$E($P(^VA(200,DUZ,0),U,1),1,15)_": (-"_RMBA_")"
.S ^RMPR(661.2,DA,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2)
.S DIK=DIC D IX1^DIK
;
DEAC I RMFLG D
.S RMMESF="Deactivated by "_$E($P(^VA(200,DUZ,0),U,1),1,15)_": ("
.S ^RMPR(661.2,DA,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2)
.S DIK=DIC D IX1^DIK
.S $P(^RMPR(661.1,RMDAHC,0),U,9)=0 W !,"**** HCPCS has been deactivated from Pros Inventory...."
H 1 G LOC
;
EXIT ;MAIN EXIT POINT
N RMPRSITE,RMPR D KILL^XUSCLEAN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5NRE 2744 printed Apr 09, 2024@21:36:26 Page 2
RMPR5NRE ;HIN/RVD-PROS INVENTORY REMOVE UTILITY ;2/11/98
+1 ;;3.0;PROSTHETICS;**33,37**;Feb 09, 1996
+2 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
KILL DIC("B")
QUIT
+3 SET X="NOW"
DO ^%DT
DO DD^%DT
SET RMDAT=Y
+4 WRITE @IOF
+5 ;
LOC ;get location
+1 SET RMFLG=0
+2 SET DZ="??"
SET D="B"
+3 KILL DTOUT,DUOUT,DIC("B"),DIC("S")
+4 SET DIC="^RMPR(661.3,"
SET DIC(0)="AEQM"
+5 SET DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
+6 SET DIC(0)="AEQM"
+7 ;I $D(^RMPR(661.3,"B")) D DQ^DICQ
+8 SET DIC("A")="Enter LOCATION: "
DO MIX^DIC1
+9 if Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
SET RMLODA=+Y
+10 SET RMLOC=$PIECE($GET(^RMPR(661.3,+Y,0)),U,1)
+11 ;
LIST ;list current HCPCS @ this Location
+1 KILL DTOUT,DUOUT,DIC("S"),DIR
+2 SET DIC("A")="Select HCPCS to Remove: "
+3 SET DA(1)=RMLODA
SET DIC(0)="AEMQ"
SET 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)"
+4 SET DIC="^RMPR(661.3,"_RMLODA_",1,"
DO ^DIC
+5 IF +Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
WRITE !,"** No HCPCS selected..."
HANG 2
GOTO LOC
+6 SET RMHCDA=+Y
SET RMDAHC=$PIECE(^RMPR(661.3,RMLODA,1,+Y,0),U,1)
SET RMHCPC=$PIECE(^RMPR(661.1,RMDAHC,0),U,1)
+7 ;
ITEM if 'RMHCDA
GOTO LIST
KILL DIC
+1 SET DA(1)=RMHCDA
SET DA(2)=RMLODA
SET DZ="??"
SET D="B"
+2 SET DIC("A")="Enter Item to Remove: "
+3 SET DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
SET DIC(0)="AEMNQ"
+4 ;I $D(^RMPR(661.1,RMDAHC,3,"B")) D DQ^DICQ
+5 DO ^DIC
if Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
GOTO LOC
SET RMITDA=+Y
+6 SET RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
+7 SET RMIT=$PIECE(RM3,U,1)
SET RMBA=$PIECE(RM3,U,2)
SET RMCO=$PIECE(RM3,U,3)
SET RMSO=$PIECE(RM3,U,9)
+8 SET RMDAIT=$PIECE(RMIT,"-",2)
+9 SET RM1=^RMPR(661.1,RMDAHC,3,RMDAIT,0)
+10 SET DIR("A")="Are you sure you want to DEACTIVATE/REMOVE this item (Y/N)"
+11 SET DIR(0)="Y"
DO ^DIR
if $DATA(DTOUT)!(+Y=0)!$DATA(DUOUT)
GOTO LOC
+12 SET DA=RMITDA
SET DA(2)=RMLODA
SET DA(1)=RMHCDA
SET DIK=DIC
DO ^DIK
+13 SET DA(1)=RMLODA
+14 IF '$DATA(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B"))
SET DIK="^RMPR(661.3,"_DA(1)_",1,"
SET DA=RMHCDA
DO ^DIK
+15 IF '$DATA(^RMPR(661.3,"C",RMDAHC))
SET RMFLG=1
+16 WRITE !,"**** Item has been removed from Location ",$PIECE(^RMPR(661.3,RMLODA,0),U,1),!
+17 ;
+18 ;create item stattistics in file 661.2
STAT DO BAL^RMPR5NU1
+1 KILL DD,DO
SET DIC="^RMPR(661.2,"
SET DIC(0)="L"
SET X=DT
SET DLAYGO=661.2
DO FILE^DICN
+2 if $DATA(DTOUT)!(Y'>0)
GOTO LOC
SET DA=+Y
+3 IF 'RMFLG
Begin DoDot:1
+4 SET RMMESF="Item Deactivated by "_$EXTRACT($PIECE(^VA(200,DUZ,0),U,1),1,15)_": (-"_RMBA_")"
+5 SET ^RMPR(661.2,DA,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$JUSTIFY(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$JUSTIFY(RMAVA,0,2)
+6 SET DIK=DIC
DO IX1^DIK
End DoDot:1
+7 ;
DEAC IF RMFLG
Begin DoDot:1
+1 SET RMMESF="Deactivated by "_$EXTRACT($PIECE(^VA(200,DUZ,0),U,1),1,15)_": ("
+2 SET ^RMPR(661.2,DA,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$JUSTIFY(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$JUSTIFY(RMAVA,0,2)
+3 SET DIK=DIC
DO IX1^DIK
+4 SET $PIECE(^RMPR(661.1,RMDAHC,0),U,9)=0
WRITE !,"**** HCPCS has been deactivated from Pros Inventory...."
End DoDot:1
+5 HANG 1
GOTO LOC
+6 ;
EXIT ;MAIN EXIT POINT
+1 NEW RMPRSITE,RMPR
DO KILL^XUSCLEAN
+2 QUIT
