PSBPAR ;BIRMINGHAM/EFC-BCMA PARAMETER MANAGEMENT ;03/06/16 3:06pm
;;3.0;BAR CODE MED ADMIN;**13,28,83**;Mar 2004;Build 89
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
;*83 - Add RPC tags to store and retrieve the Body diagram.
;
EN ; Standard editting of parameters
K PSBDIV,PSBLIST,DIC
W !!,"BCMA Parameters Management",!!
W "You are currently logged onto Division: "_DUZ(2)
S DIC="^DIC(4,",DIC(0)="AEQM",DIC("A")="Select Division: " D ^DIC Q:+Y<1
S PSBDIV=+Y_";DIC(4,"
K DIR S DIR(0)="Y",DIR("A")="Edit Divisional Parameters",DIR("B")="Yes"
D ^DIR K DIR I Y D TED^XPAREDIT("PSB DIVISION","AB",PSBDIV)
K DIR S DIR(0)="Y",DIR("A")="Edit Default Lists",DIR("B")="Yes"
D ^DIR K DIR D:Y
.S DIR(0)="SO^1:Reasons Given PRN;2:Reasons Held;3:Reasons Refused;4:Injection Sites"
.S DIR("A")="Select Default List"
.F W @IOF,!,"BCMA Default Lists",! D ^DIR Q:'Y D
..N DIR
..I Y=1 D TED^XPAREDIT("PSB LIST REASONS GIVEN PRN","AB",PSBDIV) Q
..I Y=2 D TED^XPAREDIT("PSB LIST REASONS HELD","AB",PSBDIV) Q
..I Y=3 D TED^XPAREDIT("PSB LIST REASONS REFUSED","AB",PSBDIV) Q
..I Y=4 D TED^XPAREDIT("PSB LIST INJECTION SITES","AB",PSBDIV) Q
Q
;
RPC(RESULTS,PSBCMD,PSBENT,PSBPAR,PSBINS,PSBVAL) ; Main RPC Hit Point
;
; RPC: PSB PARAMETER
;
; Description:
; Called by client to return or set parameters
;
N PSBERR,PSBTMP
D:PSBCMD="GETPAR" GETPAR(PSBENT,PSBPAR)
D:PSBCMD="GETLST" GETLST(PSBENT,PSBPAR)
D:PSBCMD="SETPAR" SETPAR(PSBENT,PSBPAR,PSBINS,PSBVAL)
D:PSBCMD="DELLST" DELLST(PSBENT,PSBPAR)
D:PSBCMD="GETDIV" GETDIV(PSBENT)
S:'$D(RESULTS) RESULTS(0)="-1^Unknown Internal Error "_PSBCMD
Q
;
GETDIV(PSBENT) ; Return a valid Entity pointer from user input
S X=$$FIND1^DIC(4,"","MX",PSBENT)
I +X<1 S RESULTS(0)="-1^Error, Station # "_PSBENT_" not found." Q
S RESULTS(0)="1^"_(+X)_";DIC(4,"
S RESULTS(1)=$$GET1^DIQ(4,+X_",",.01)_" ("_$$GET1^DIQ(4,+X_",",99)_")"
S RESULTS(2)=$$GET1^DIQ(4,+X_",",1.01)
S RESULTS(3)=$$GET1^DIQ(4,+X_",",1.02)
S RESULTS(4)=$$GET1^DIQ(4,+X_",",1.03)
S RESULTS(5)=$$GET1^DIQ(4,+X_",",.02)
S RESULTS(6)=$$GET1^DIQ(4,+X_",",1.04)
S PSBEDIV=+X ;do NOT kill this variable - needed until gui context ends
Q
;
GETPAR(PSBENT,PSBPAR) ; Return a parameter
I PSBPAR="PSB 5 RIGHTS IV" S RESULTS(0)=$$GET^XPAR(PSBENT,PSBPAR,,"I") Q
I PSBPAR="PSB 5 RIGHTS UNITDOSE" S RESULTS(0)=$$GET^XPAR(PSBENT,PSBPAR,,"I") Q
S RESULTS(0)=$$GET^XPAR(PSBENT,PSBPAR,,"B")
Q
;
GETLST(PSBENT,PSBPAR) ; Return a parameter list
D GETLST^XPAR(.PSBTMP,PSBENT,PSBPAR,,.PSBERR)
I PSBERR S RESULTS(0)="-1^Error: "_(+PSBERR)_" "_$P(PSBERR,"^",2) Q
S RESULTS(0)=PSBTMP
F Y=0:0 S Y=$O(PSBTMP(Y)) Q:'Y S RESULTS(Y)=$P(PSBTMP(Y),"^",2)
Q
;
SETPAR(PSBENT,PSBPAR,PSBINS,PSBVAL) ; Set a new parameter
D EN^XPAR(PSBENT,PSBPAR,PSBINS,PSBVAL,.PSBERR)
I 'PSBERR S RESULTS(0)="1^Success"
E S RESULTS(0)="-1^Error: "_(+PSBERR)_" "_$P(PSBERR,"^",2)
Q
;
DELLST(PSBENT,PSBPAR) ; Clear a list
D NDEL^XPAR(PSBENT,PSBPAR,.PSBERR)
I 'PSBERR S RESULTS(0)="1^Success"
E S RESULTS(0)="-1^Error: "_(+PSBERR)_" "_$P(PSBERR,"^",2)
Q
;
USRDEF(PSBPAR) ; Return a parameter for the user
Q $$GET^XPAR("ALL",PSBPAR)
;
RSTUSR ; Reset all a users parameters
N PSBUSR,PSBENT,RESULTS
S DIC="^VA(200,",DIC(0)="AEQM",DIC("A")="Select User to Reset: "
D ^DIC K DIC Q:+Y<1 S PSBUSR=+Y
W !!,"Are you sure you want to reset all parameters for this user"
S %=2 D YN^DICN Q:%'=1
W !,"Resetting..."
S PSBENT=PSBUSR_";VA(200,"
D DEL^XPAR(PSBENT,"PSB PRINTER USER DEFAULT",1)
D DEL^XPAR(PSBENT,"PSB VDL INCL BLANKS",1)
D DEL^XPAR(PSBENT,"PSB VDL INCL CONT",1)
D DEL^XPAR(PSBENT,"PSB VDL INCL IV MEDS",1)
D DEL^XPAR(PSBENT,"PSB VDL INCL ON-CALL",1)
D DEL^XPAR(PSBENT,"PSB VDL INCL ONE-TIME",1)
D DEL^XPAR(PSBENT,"PSB VDL INCL PRN",1)
D DEL^XPAR(PSBENT,"PSB VDL INCL UD MEDS",1)
D DEL^XPAR(PSBENT,"PSB VDL START TIME",1)
D DEL^XPAR(PSBENT,"PSB VDL STOP TIME",1)
D DEL^XPAR(PSBENT,"PSB WINDOW",1)
D DEL^XPAR(PSBENT,"PSB UNIT DOSE COLUMN WIDTHS",1)
D DEL^XPAR(PSBENT,"PSB VDL SORT COLUMN",1)
D DEL^XPAR(PSBENT,"PSB VDL PB SORT COLUMN",1)
D DEL^XPAR(PSBENT,"PSB VDL IV SORT COLUMN",1)
D DEL^XPAR(PSBENT,"PSB IV COLUMN WIDTHS",1)
D DEL^XPAR(PSBENT,"PSB IVPB COLUMN WIDTHS",1)
D DEL^XPAR(PSBENT,"PSB HKEY",1)
D DEL^XPAR(PSBENT,"PSB IDLE TIMEOUT",1)
D DEL^XPAR(PSBENT,"PSB GUI DEFAULT PRINTER",1)
D DEL^XPAR(PSBENT,"PSB COVERSHEET VIEWS COL SORT",1)
D DEL^XPAR(PSBENT,"PSB COVERSHEET V1 COL WIDTHS",1)
D DEL^XPAR(PSBENT,"PSB COVERSHEET V2 COL WIDTHS",1)
D DEL^XPAR(PSBENT,"PSB COVERSHEET V3 COL WIDTHS",1)
D DEL^XPAR(PSBENT,"PSB COVERSHEET V4 COL WIDTHS",1)
W "Done.",!
Q
;
;*83 Below tags for Body diagram map
MDRPC(RESULTS,OPTION,ENT,PAR,INST,VAL) ; [Procedure] Main RPC Hit Point *83
;
; Input parameters
; 1. RESULTS [Literal/Required] No description
; 2. OPTION [Literal/Required] No description
; 3. ENT [Literal/Required] No description
; 4. PAR [Literal/Required] No description
; 5. INST [Literal/Required] No description
; 6. VAL [Literal/Required] No description
;
N ERR,TMP,RET,TXT,IEN,IENS,ROOT,MDD
S INST=$G(INST,1)
S PAR=$G(PAR)
S RESULTS=$NA(^TMP($J)) K @RESULTS
I PAR'?1"PSB".E S ^TMP($J,0)="-1^Non PSB Parameter" Q
D:OPTION="SETWP" SETWP
D:OPTION="GETWP" GETWP
I +$G(ERR) K ^TMP($J,0) S ^(0)="-1^Error: "_(+ERR)_" "_$P(ERR,U,2)
S:'$D(^TMP($J)) @RESULTS@(0)="-1^Error calling RPC: PSB GETSETWP at "_OPTION
D CLEAN^DILF
Q
;
SETWP ; [Procedure] Set WP text into a parameter *83
S TXT=INST,TMP=""
F S TMP=$O(VAL(TMP)) Q:TMP="" D
.S TXT($O(TXT(""),-1)+1,0)=VAL(TMP)
D EN^XPAR(ENT,PAR,INST,.TXT,.ERR)
S:'$G(ERR) @RESULTS@(0)="1^WP Text Saved"
Q
;
GETWP ; [Procedure] Returns WP text for a parameter *83
D GETWP^XPAR(.RET,ENT,PAR,INST,.ERR)
Q:$G(ERR,0)
S TMP="RET"
F S TMP=$Q(@TMP) Q:TMP="" D
.S @RESULTS@($O(@RESULTS@(""),-1)+1)=@TMP
S @RESULTS@(0)=$O(@RESULTS@(""),-1)_U_INST
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBPAR 6096 printed Oct 16, 2024@17:41:50 Page 2
PSBPAR ;BIRMINGHAM/EFC-BCMA PARAMETER MANAGEMENT ;03/06/16 3:06pm
+1 ;;3.0;BAR CODE MED ADMIN;**13,28,83**;Mar 2004;Build 89
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ;*83 - Add RPC tags to store and retrieve the Body diagram.
+5 ;
EN ; Standard editting of parameters
+1 KILL PSBDIV,PSBLIST,DIC
+2 WRITE !!,"BCMA Parameters Management",!!
+3 WRITE "You are currently logged onto Division: "_DUZ(2)
+4 SET DIC="^DIC(4,"
SET DIC(0)="AEQM"
SET DIC("A")="Select Division: "
DO ^DIC
if +Y<1
QUIT
+5 SET PSBDIV=+Y_";DIC(4,"
+6 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Edit Divisional Parameters"
SET DIR("B")="Yes"
+7 DO ^DIR
KILL DIR
IF Y
DO TED^XPAREDIT("PSB DIVISION","AB",PSBDIV)
+8 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Edit Default Lists"
SET DIR("B")="Yes"
+9 DO ^DIR
KILL DIR
if Y
Begin DoDot:1
+10 SET DIR(0)="SO^1:Reasons Given PRN;2:Reasons Held;3:Reasons Refused;4:Injection Sites"
+11 SET DIR("A")="Select Default List"
+12 FOR
WRITE @IOF,!,"BCMA Default Lists",!
DO ^DIR
if 'Y
QUIT
Begin DoDot:2
+13 NEW DIR
+14 IF Y=1
DO TED^XPAREDIT("PSB LIST REASONS GIVEN PRN","AB",PSBDIV)
QUIT
+15 IF Y=2
DO TED^XPAREDIT("PSB LIST REASONS HELD","AB",PSBDIV)
QUIT
+16 IF Y=3
DO TED^XPAREDIT("PSB LIST REASONS REFUSED","AB",PSBDIV)
QUIT
+17 IF Y=4
DO TED^XPAREDIT("PSB LIST INJECTION SITES","AB",PSBDIV)
QUIT
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
RPC(RESULTS,PSBCMD,PSBENT,PSBPAR,PSBINS,PSBVAL) ; Main RPC Hit Point
+1 ;
+2 ; RPC: PSB PARAMETER
+3 ;
+4 ; Description:
+5 ; Called by client to return or set parameters
+6 ;
+7 NEW PSBERR,PSBTMP
+8 if PSBCMD="GETPAR"
DO GETPAR(PSBENT,PSBPAR)
+9 if PSBCMD="GETLST"
DO GETLST(PSBENT,PSBPAR)
+10 if PSBCMD="SETPAR"
DO SETPAR(PSBENT,PSBPAR,PSBINS,PSBVAL)
+11 if PSBCMD="DELLST"
DO DELLST(PSBENT,PSBPAR)
+12 if PSBCMD="GETDIV"
DO GETDIV(PSBENT)
+13 if '$DATA(RESULTS)
SET RESULTS(0)="-1^Unknown Internal Error "_PSBCMD
+14 QUIT
+15 ;
GETDIV(PSBENT) ; Return a valid Entity pointer from user input
+1 SET X=$$FIND1^DIC(4,"","MX",PSBENT)
+2 IF +X<1
SET RESULTS(0)="-1^Error, Station # "_PSBENT_" not found."
QUIT
+3 SET RESULTS(0)="1^"_(+X)_";DIC(4,"
+4 SET RESULTS(1)=$$GET1^DIQ(4,+X_",",.01)_" ("_$$GET1^DIQ(4,+X_",",99)_")"
+5 SET RESULTS(2)=$$GET1^DIQ(4,+X_",",1.01)
+6 SET RESULTS(3)=$$GET1^DIQ(4,+X_",",1.02)
+7 SET RESULTS(4)=$$GET1^DIQ(4,+X_",",1.03)
+8 SET RESULTS(5)=$$GET1^DIQ(4,+X_",",.02)
+9 SET RESULTS(6)=$$GET1^DIQ(4,+X_",",1.04)
+10 ;do NOT kill this variable - needed until gui context ends
SET PSBEDIV=+X
+11 QUIT
+12 ;
GETPAR(PSBENT,PSBPAR) ; Return a parameter
+1 IF PSBPAR="PSB 5 RIGHTS IV"
SET RESULTS(0)=$$GET^XPAR(PSBENT,PSBPAR,,"I")
QUIT
+2 IF PSBPAR="PSB 5 RIGHTS UNITDOSE"
SET RESULTS(0)=$$GET^XPAR(PSBENT,PSBPAR,,"I")
QUIT
+3 SET RESULTS(0)=$$GET^XPAR(PSBENT,PSBPAR,,"B")
+4 QUIT
+5 ;
GETLST(PSBENT,PSBPAR) ; Return a parameter list
+1 DO GETLST^XPAR(.PSBTMP,PSBENT,PSBPAR,,.PSBERR)
+2 IF PSBERR
SET RESULTS(0)="-1^Error: "_(+PSBERR)_" "_$PIECE(PSBERR,"^",2)
QUIT
+3 SET RESULTS(0)=PSBTMP
+4 FOR Y=0:0
SET Y=$ORDER(PSBTMP(Y))
if 'Y
QUIT
SET RESULTS(Y)=$PIECE(PSBTMP(Y),"^",2)
+5 QUIT
+6 ;
SETPAR(PSBENT,PSBPAR,PSBINS,PSBVAL) ; Set a new parameter
+1 DO EN^XPAR(PSBENT,PSBPAR,PSBINS,PSBVAL,.PSBERR)
+2 IF 'PSBERR
SET RESULTS(0)="1^Success"
+3 IF '$TEST
SET RESULTS(0)="-1^Error: "_(+PSBERR)_" "_$PIECE(PSBERR,"^",2)
+4 QUIT
+5 ;
DELLST(PSBENT,PSBPAR) ; Clear a list
+1 DO NDEL^XPAR(PSBENT,PSBPAR,.PSBERR)
+2 IF 'PSBERR
SET RESULTS(0)="1^Success"
+3 IF '$TEST
SET RESULTS(0)="-1^Error: "_(+PSBERR)_" "_$PIECE(PSBERR,"^",2)
+4 QUIT
+5 ;
USRDEF(PSBPAR) ; Return a parameter for the user
+1 QUIT $$GET^XPAR("ALL",PSBPAR)
+2 ;
RSTUSR ; Reset all a users parameters
+1 NEW PSBUSR,PSBENT,RESULTS
+2 SET DIC="^VA(200,"
SET DIC(0)="AEQM"
SET DIC("A")="Select User to Reset: "
+3 DO ^DIC
KILL DIC
if +Y<1
QUIT
SET PSBUSR=+Y
+4 WRITE !!,"Are you sure you want to reset all parameters for this user"
+5 SET %=2
DO YN^DICN
if %'=1
QUIT
+6 WRITE !,"Resetting..."
+7 SET PSBENT=PSBUSR_";VA(200,"
+8 DO DEL^XPAR(PSBENT,"PSB PRINTER USER DEFAULT",1)
+9 DO DEL^XPAR(PSBENT,"PSB VDL INCL BLANKS",1)
+10 DO DEL^XPAR(PSBENT,"PSB VDL INCL CONT",1)
+11 DO DEL^XPAR(PSBENT,"PSB VDL INCL IV MEDS",1)
+12 DO DEL^XPAR(PSBENT,"PSB VDL INCL ON-CALL",1)
+13 DO DEL^XPAR(PSBENT,"PSB VDL INCL ONE-TIME",1)
+14 DO DEL^XPAR(PSBENT,"PSB VDL INCL PRN",1)
+15 DO DEL^XPAR(PSBENT,"PSB VDL INCL UD MEDS",1)
+16 DO DEL^XPAR(PSBENT,"PSB VDL START TIME",1)
+17 DO DEL^XPAR(PSBENT,"PSB VDL STOP TIME",1)
+18 DO DEL^XPAR(PSBENT,"PSB WINDOW",1)
+19 DO DEL^XPAR(PSBENT,"PSB UNIT DOSE COLUMN WIDTHS",1)
+20 DO DEL^XPAR(PSBENT,"PSB VDL SORT COLUMN",1)
+21 DO DEL^XPAR(PSBENT,"PSB VDL PB SORT COLUMN",1)
+22 DO DEL^XPAR(PSBENT,"PSB VDL IV SORT COLUMN",1)
+23 DO DEL^XPAR(PSBENT,"PSB IV COLUMN WIDTHS",1)
+24 DO DEL^XPAR(PSBENT,"PSB IVPB COLUMN WIDTHS",1)
+25 DO DEL^XPAR(PSBENT,"PSB HKEY",1)
+26 DO DEL^XPAR(PSBENT,"PSB IDLE TIMEOUT",1)
+27 DO DEL^XPAR(PSBENT,"PSB GUI DEFAULT PRINTER",1)
+28 DO DEL^XPAR(PSBENT,"PSB COVERSHEET VIEWS COL SORT",1)
+29 DO DEL^XPAR(PSBENT,"PSB COVERSHEET V1 COL WIDTHS",1)
+30 DO DEL^XPAR(PSBENT,"PSB COVERSHEET V2 COL WIDTHS",1)
+31 DO DEL^XPAR(PSBENT,"PSB COVERSHEET V3 COL WIDTHS",1)
+32 DO DEL^XPAR(PSBENT,"PSB COVERSHEET V4 COL WIDTHS",1)
+33 WRITE "Done.",!
+34 QUIT
+35 ;
+36 ;*83 Below tags for Body diagram map
MDRPC(RESULTS,OPTION,ENT,PAR,INST,VAL) ; [Procedure] Main RPC Hit Point *83
+1 ;
+2 ; Input parameters
+3 ; 1. RESULTS [Literal/Required] No description
+4 ; 2. OPTION [Literal/Required] No description
+5 ; 3. ENT [Literal/Required] No description
+6 ; 4. PAR [Literal/Required] No description
+7 ; 5. INST [Literal/Required] No description
+8 ; 6. VAL [Literal/Required] No description
+9 ;
+10 NEW ERR,TMP,RET,TXT,IEN,IENS,ROOT,MDD
+11 SET INST=$GET(INST,1)
+12 SET PAR=$GET(PAR)
+13 SET RESULTS=$NAME(^TMP($JOB))
KILL @RESULTS
+14 IF PAR'?1"PSB".E
SET ^TMP($JOB,0)="-1^Non PSB Parameter"
QUIT
+15 if OPTION="SETWP"
DO SETWP
+16 if OPTION="GETWP"
DO GETWP
+17 IF +$GET(ERR)
KILL ^TMP($JOB,0)
SET ^(0)="-1^Error: "_(+ERR)_" "_$PIECE(ERR,U,2)
+18 if '$DATA(^TMP($JOB))
SET @RESULTS@(0)="-1^Error calling RPC: PSB GETSETWP at "_OPTION
+19 DO CLEAN^DILF
+20 QUIT
+21 ;
SETWP ; [Procedure] Set WP text into a parameter *83
+1 SET TXT=INST
SET TMP=""
+2 FOR
SET TMP=$ORDER(VAL(TMP))
if TMP=""
QUIT
Begin DoDot:1
+3 SET TXT($ORDER(TXT(""),-1)+1,0)=VAL(TMP)
End DoDot:1
+4 DO EN^XPAR(ENT,PAR,INST,.TXT,.ERR)
+5 if '$GET(ERR)
SET @RESULTS@(0)="1^WP Text Saved"
+6 QUIT
+7 ;
GETWP ; [Procedure] Returns WP text for a parameter *83
+1 DO GETWP^XPAR(.RET,ENT,PAR,INST,.ERR)
+2 if $GET(ERR,0)
QUIT
+3 SET TMP="RET"
+4 FOR
SET TMP=$QUERY(@TMP)
if TMP=""
QUIT
Begin DoDot:1
+5 SET @RESULTS@($ORDER(@RESULTS@(""),-1)+1)=@TMP
End DoDot:1
+6 SET @RESULTS@(0)=$ORDER(@RESULTS@(""),-1)_U_INST
+7 QUIT
+8 ;
