RMPRPIYL ;HINES OIFO/ODJ - PIP - DL - DEACTIVATE LOCATION ;9/19/02 08:22
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
;
;***** DL - Replaces DL option in old PIP (cf RMPR5NDL)
; Callable from VISTA menu, no vars required other than
; global VISTA vars (DUZ, etc)
;
DL N RMPRERR,RMPRSTN,RMPRLCN,RMPREXC,RMPR5,RMPR5U,DIR,X,Y,DA
I '$D(DUZ) W !,"VISTA User parameter (DUZ) does not exist, can't continue with this option" R RMPRERR:3 G DLX
;
;***** STN - prompt for Site/Station
STN S RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
I RMPRERR G DLX
I RMPREXC'="" G DLX
;
;***** LOCN - prompt for Location
LOCN W @IOF,!!,"Deactivate an Inventory Location.....",!
W !,"This option requires the electronic signatures of 2 users"
W !,"holding the RMPRMANAGER key to be entered before a location"
W !,"will be deactivated.",!
;
D LOCNM^RMPRPIY7(RMPRSTN("IEN"),.RMPR5,.RMPREXC)
I RMPREXC="T"!(RMPREXC="^") G DLX
I RMPREXC="P" G STN
;
; display stock position and get esigs. to confirm deactivation
CHK D STOCK(RMPRSTN("IEN"),RMPR5("IEN")) ;display stock position
OSIG I '$$GETO(DUZ) G DLX ;get other signature, exit if not OK
ESIG I $D(XQUSER) D
. W !!,XQUSER," please..."
. Q
E D
. W !!,$$GETUSR^RMPRPIU0(DUZ)," please..."
. Q
D SIG^XUSESIG G:X1="" DLX ;get electronic sig. of main user
DEL ;delete a location
S DIR(0)="Y",DIR("B")="N"
W !
S DIR("A")="Are you sure you want to DEACTIVATE this LOCATION (Y/N) "
D ^DIR
I $D(DTOUT)!$D(DUOUT)!(Y="^")!(Y=0) W !,"Nothing Deactivated.." H 2 G DLX
;
ZERO ;***** zeroed all item in a location.
;
N RI,RH,RD,RV,R6
S RS=RMPRSTN("IEN")
S RL=RMPR5("IEN")
S RH=""
F S RH=$O(^RMPR(661.7,"XSLHIDS",RS,RL,RH)) Q:RH="" F RI=0:0 S RI=$O(^RMPR(661.7,"XSLHIDS",RS,RL,RH,RI)) Q:RI'>0 F RD=0:0 S RD=$O(^RMPR(661.7,"XSLHIDS",RS,RL,RH,RI,RD)) Q:RD'>0 D
.S RMPR11("STATION")=RS
.S RMPR11("STATION IEN")=RS
.S RMPR6("QUANTITY")=0
.Q:'$G(RD)!(RD="")
.Q:'$D(^RMPR(661.6,"ASLD",RS,RL,RD))
.S R6=$O(^RMPR(661.6,"ASLD",RS,RL,RD,0)) I $D(^RMPR(661.6,R6,0)) S RV=$P(^RMPR(661.6,R6,0),U,12)
.Q:'$G(RV)
.S RMPR6("VENDOR")=RV
.S RMPR6("VENDOR IEN")=RV
.S RMPR11("HCPCS")=RH,RMPR11("ITEM")=RI,RMPR5("IEN")=RL
.S RMPRERR=$$REC^RMPRPIU9(.RMPR6,.RMPR11,.RMPR5)
.I RMPRERR=1 W !!,"*** ERROR IN API RMPRPIU9 ***",!
.K R6,RV
;
;***** TRANS - Now deactivate the location
TRANS K RMPR5U
S RMPR5U("IEN")=RMPR5("IEN")
S RMPR5U("STATUS")="I"
D NOW^%DTC
S RMPR5U("STATUS DATE")=$P(%,".",1)
S RMPRERR=$$UPD^RMPRPIX5(.RMPR5U)
I 'RMPRERR D
. W !,"Location is deactivated" H 2
. Q
E D
. W !,"There was a problem deactivating the location" H 2
. Q
DLX D KILL^XUSCLEAN
Q
;
;***** STOCK - get and display the total number of items
; quantity and cost at a location
;
STOCK(RMPRSTN,RMPRLCN) ;
N RMPRQ,RMPRH,RMPRI,RMPRERR,RMPRIC,RMPRTQ,RMPRTC
S RMPRIC=0 ;item count
S RMPRTC=0 ;total cost
S RMPRTQ=0 ;total quantity
S RMPRH=""
F S RMPRH=$O(^RMPR(661.7,"XSLHIDS",RMPRSTN,RMPRLCN,RMPRH)) Q:RMPRH="" D
. S RMPRI=""
. F S RMPRI=$O(^RMPR(661.7,"XSLHIDS",RMPRSTN,RMPRLCN,RMPRH,RMPRI)) Q:RMPRI="" D
.. K RMPRQ
.. S RMPRQ("STATION IEN")=RMPRSTN
.. S RMPRQ("LOCATION IEN")=RMPRLCN
.. S RMPRQ("HCPCS")=RMPRH
.. S RMPRQ("ITEM")=RMPRI
.. S RMPRQ("VENDOR IEN")=""
.. S RMPRERR=$$STOCK^RMPRPIUE(.RMPRQ)
.. S RMPRIC=RMPRIC+1
.. S RMPRTQ=RMPRTQ+RMPRQ("QOH")
.. S RMPRTC=RMPRTC+(RMPRQ("QOH")*RMPRQ("UNIT COST"))
.. Q
. Q
W !,"The above location contains "_RMPRIC_" types of items"
I RMPRIC=0 D
. W "."
. Q
E D
. W ", ",!,"with a total quantity of ",RMPRTQ
. W " and cost of $",RMPRTC,"."
. Q
W !
Q
;
;***** GETO - prompt for a 2nd user's electronic signature
GETO(RMPRDUZ) ;
N RMPRMGR,RMPROK,RMPRUSR1,RMPRUSR2,X,X1,DUZ,RMPRKEYS
W !!,"Pease ask another user with the RMPRMANAGER key to"
W !,"enter their user name and electronic signature.",!
S RMPROK=0
S RMPRKEYS("RMPRMANAGER")=""
S RMPRUSR1("DUZ")=RMPRDUZ
I $$GETUSR2(.RMPRUSR2,.RMPRKEYS,.RMPRUSR1)'="" G GETOKX
S DUZ=RMPRUSR2("DUZ")
W !,RMPRUSR2("NAME")," please..."
D SIG^XUSESIG I X1="" G GETOKX
S RMPROK=1
GETOKX Q RMPROK
;
; Get 2nd User and ensure they have RMPRMANAGER key
GETUSR2(RMPRUSR2,RMPRKEYS,RMPRUSR1) ;
N DIC,X,Y,DLAYGO,DTOUT,DUOUT,RMPREXC,RMPRKEY,DUZ
S DUZ=RMPRUSR1("DUZ")
USR2E K RMPRUSR2
S DIC="^VA(200,"
S DIC(0)="ABEQ"
S DIC("A")="Enter user name of 2nd manager:"
D ^DIC
I Y=-1 S RMPREXC="^" G USR2X
S RMPRUSR2("DUZ")=$P(Y,U,1)
;
; User 2 can't be same as user 1
I RMPRUSR2("DUZ")=RMPRUSR1("DUZ") D G USR2E
. W !,"The 2nd manager must be different to the manager logged on."
. Q
;
; User 2 must have defined security keys
S RMPRKEY=""
F S RMPRKEY=$O(RMPRKEYS(RMPRKEY)) Q:RMPRKEY="" Q:$D(^XUSEC(RMPRKEY,RMPRUSR2("DUZ")))
I RMPRKEY="" D G USR2E
. W !,"The 2nd manager does not have the correct security key set up."
. Q
;
; User 2 verified
S RMPRUSR2("NAME")=$P(Y,U,2)
S RMPREXC=""
USR2X Q RMPREXC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYL 5071 printed Dec 13, 2024@02:37:09 Page 2
RMPRPIYL ;HINES OIFO/ODJ - PIP - DL - DEACTIVATE LOCATION ;9/19/02 08:22
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ;
+4 ;***** DL - Replaces DL option in old PIP (cf RMPR5NDL)
+5 ; Callable from VISTA menu, no vars required other than
+6 ; global VISTA vars (DUZ, etc)
+7 ;
DL NEW RMPRERR,RMPRSTN,RMPRLCN,RMPREXC,RMPR5,RMPR5U,DIR,X,Y,DA
+1 IF '$DATA(DUZ)
WRITE !,"VISTA User parameter (DUZ) does not exist, can't continue with this option"
READ RMPRERR:3
GOTO DLX
+2 ;
+3 ;***** STN - prompt for Site/Station
STN SET RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
+1 IF RMPRERR
GOTO DLX
+2 IF RMPREXC'=""
GOTO DLX
+3 ;
+4 ;***** LOCN - prompt for Location
LOCN WRITE @IOF,!!,"Deactivate an Inventory Location.....",!
+1 WRITE !,"This option requires the electronic signatures of 2 users"
+2 WRITE !,"holding the RMPRMANAGER key to be entered before a location"
+3 WRITE !,"will be deactivated.",!
+4 ;
+5 DO LOCNM^RMPRPIY7(RMPRSTN("IEN"),.RMPR5,.RMPREXC)
+6 IF RMPREXC="T"!(RMPREXC="^")
GOTO DLX
+7 IF RMPREXC="P"
GOTO STN
+8 ;
+9 ; display stock position and get esigs. to confirm deactivation
CHK ;display stock position
DO STOCK(RMPRSTN("IEN"),RMPR5("IEN"))
OSIG ;get other signature, exit if not OK
IF '$$GETO(DUZ)
GOTO DLX
ESIG IF $DATA(XQUSER)
Begin DoDot:1
+1 WRITE !!,XQUSER," please..."
+2 QUIT
End DoDot:1
+3 IF '$TEST
Begin DoDot:1
+4 WRITE !!,$$GETUSR^RMPRPIU0(DUZ)," please..."
+5 QUIT
End DoDot:1
+6 ;get electronic sig. of main user
DO SIG^XUSESIG
if X1=""
GOTO DLX
DEL ;delete a location
+1 SET DIR(0)="Y"
SET DIR("B")="N"
+2 WRITE !
+3 SET DIR("A")="Are you sure you want to DEACTIVATE this LOCATION (Y/N) "
+4 DO ^DIR
+5 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="^")!(Y=0)
WRITE !,"Nothing Deactivated.."
HANG 2
GOTO DLX
+6 ;
ZERO ;***** zeroed all item in a location.
+1 ;
+2 NEW RI,RH,RD,RV,R6
+3 SET RS=RMPRSTN("IEN")
+4 SET RL=RMPR5("IEN")
+5 SET RH=""
+6 FOR
SET RH=$ORDER(^RMPR(661.7,"XSLHIDS",RS,RL,RH))
if RH=""
QUIT
FOR RI=0:0
SET RI=$ORDER(^RMPR(661.7,"XSLHIDS",RS,RL,RH,RI))
if RI'>0
QUIT
FOR RD=0:0
SET RD=$ORDER(^RMPR(661.7,"XSLHIDS",RS,RL,RH,RI,RD))
if RD'>0
QUIT
Begin DoDot:1
+7 SET RMPR11("STATION")=RS
+8 SET RMPR11("STATION IEN")=RS
+9 SET RMPR6("QUANTITY")=0
+10 if '$GET(RD)!(RD="")
QUIT
+11 if '$DATA(^RMPR(661.6,"ASLD",RS,RL,RD))
QUIT
+12 SET R6=$ORDER(^RMPR(661.6,"ASLD",RS,RL,RD,0))
IF $DATA(^RMPR(661.6,R6,0))
SET RV=$PIECE(^RMPR(661.6,R6,0),U,12)
+13 if '$GET(RV)
QUIT
+14 SET RMPR6("VENDOR")=RV
+15 SET RMPR6("VENDOR IEN")=RV
+16 SET RMPR11("HCPCS")=RH
SET RMPR11("ITEM")=RI
SET RMPR5("IEN")=RL
+17 SET RMPRERR=$$REC^RMPRPIU9(.RMPR6,.RMPR11,.RMPR5)
+18 IF RMPRERR=1
WRITE !!,"*** ERROR IN API RMPRPIU9 ***",!
+19 KILL R6,RV
End DoDot:1
+20 ;
+21 ;***** TRANS - Now deactivate the location
TRANS KILL RMPR5U
+1 SET RMPR5U("IEN")=RMPR5("IEN")
+2 SET RMPR5U("STATUS")="I"
+3 DO NOW^%DTC
+4 SET RMPR5U("STATUS DATE")=$PIECE(%,".",1)
+5 SET RMPRERR=$$UPD^RMPRPIX5(.RMPR5U)
+6 IF 'RMPRERR
Begin DoDot:1
+7 WRITE !,"Location is deactivated"
HANG 2
+8 QUIT
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 WRITE !,"There was a problem deactivating the location"
HANG 2
+11 QUIT
End DoDot:1
DLX DO KILL^XUSCLEAN
+1 QUIT
+2 ;
+3 ;***** STOCK - get and display the total number of items
+4 ; quantity and cost at a location
+5 ;
STOCK(RMPRSTN,RMPRLCN) ;
+1 NEW RMPRQ,RMPRH,RMPRI,RMPRERR,RMPRIC,RMPRTQ,RMPRTC
+2 ;item count
SET RMPRIC=0
+3 ;total cost
SET RMPRTC=0
+4 ;total quantity
SET RMPRTQ=0
+5 SET RMPRH=""
+6 FOR
SET RMPRH=$ORDER(^RMPR(661.7,"XSLHIDS",RMPRSTN,RMPRLCN,RMPRH))
if RMPRH=""
QUIT
Begin DoDot:1
+7 SET RMPRI=""
+8 FOR
SET RMPRI=$ORDER(^RMPR(661.7,"XSLHIDS",RMPRSTN,RMPRLCN,RMPRH,RMPRI))
if RMPRI=""
QUIT
Begin DoDot:2
+9 KILL RMPRQ
+10 SET RMPRQ("STATION IEN")=RMPRSTN
+11 SET RMPRQ("LOCATION IEN")=RMPRLCN
+12 SET RMPRQ("HCPCS")=RMPRH
+13 SET RMPRQ("ITEM")=RMPRI
+14 SET RMPRQ("VENDOR IEN")=""
+15 SET RMPRERR=$$STOCK^RMPRPIUE(.RMPRQ)
+16 SET RMPRIC=RMPRIC+1
+17 SET RMPRTQ=RMPRTQ+RMPRQ("QOH")
+18 SET RMPRTC=RMPRTC+(RMPRQ("QOH")*RMPRQ("UNIT COST"))
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 WRITE !,"The above location contains "_RMPRIC_" types of items"
+22 IF RMPRIC=0
Begin DoDot:1
+23 WRITE "."
+24 QUIT
End DoDot:1
+25 IF '$TEST
Begin DoDot:1
+26 WRITE ", ",!,"with a total quantity of ",RMPRTQ
+27 WRITE " and cost of $",RMPRTC,"."
+28 QUIT
End DoDot:1
+29 WRITE !
+30 QUIT
+31 ;
+32 ;***** GETO - prompt for a 2nd user's electronic signature
GETO(RMPRDUZ) ;
+1 NEW RMPRMGR,RMPROK,RMPRUSR1,RMPRUSR2,X,X1,DUZ,RMPRKEYS
+2 WRITE !!,"Pease ask another user with the RMPRMANAGER key to"
+3 WRITE !,"enter their user name and electronic signature.",!
+4 SET RMPROK=0
+5 SET RMPRKEYS("RMPRMANAGER")=""
+6 SET RMPRUSR1("DUZ")=RMPRDUZ
+7 IF $$GETUSR2(.RMPRUSR2,.RMPRKEYS,.RMPRUSR1)'=""
GOTO GETOKX
+8 SET DUZ=RMPRUSR2("DUZ")
+9 WRITE !,RMPRUSR2("NAME")," please..."
+10 DO SIG^XUSESIG
IF X1=""
GOTO GETOKX
+11 SET RMPROK=1
GETOKX QUIT RMPROK
+1 ;
+2 ; Get 2nd User and ensure they have RMPRMANAGER key
GETUSR2(RMPRUSR2,RMPRKEYS,RMPRUSR1) ;
+1 NEW DIC,X,Y,DLAYGO,DTOUT,DUOUT,RMPREXC,RMPRKEY,DUZ
+2 SET DUZ=RMPRUSR1("DUZ")
USR2E KILL RMPRUSR2
+1 SET DIC="^VA(200,"
+2 SET DIC(0)="ABEQ"
+3 SET DIC("A")="Enter user name of 2nd manager:"
+4 DO ^DIC
+5 IF Y=-1
SET RMPREXC="^"
GOTO USR2X
+6 SET RMPRUSR2("DUZ")=$PIECE(Y,U,1)
+7 ;
+8 ; User 2 can't be same as user 1
+9 IF RMPRUSR2("DUZ")=RMPRUSR1("DUZ")
Begin DoDot:1
+10 WRITE !,"The 2nd manager must be different to the manager logged on."
+11 QUIT
End DoDot:1
GOTO USR2E
+12 ;
+13 ; User 2 must have defined security keys
+14 SET RMPRKEY=""
+15 FOR
SET RMPRKEY=$ORDER(RMPRKEYS(RMPRKEY))
if RMPRKEY=""
QUIT
if $DATA(^XUSEC(RMPRKEY,RMPRUSR2("DUZ")))
QUIT
+16 IF RMPRKEY=""
Begin DoDot:1
+17 WRITE !,"The 2nd manager does not have the correct security key set up."
+18 QUIT
End DoDot:1
GOTO USR2E
+19 ;
+20 ; User 2 verified
+21 SET RMPRUSR2("NAME")=$PIECE(Y,U,2)
+22 SET RMPREXC=""
USR2X QUIT RMPREXC
