ORACCESS ;SLC/AGP - User Read/Write Access to CPRS ; Apr 20, 2023@17:48
;;3.0;ORDER ENTRY/RESULTS REPORTING;**588**;Dec 17, 1997;Build 29
;
; Direct reads of PARAMETERS File (#8989.5) - IA #2686
; Direct reads of PARAMETER DEFINITION File (#8989.51) - IA #2685
; Reference to CRNRSITE^VAFCCRNR in ICR #7346
;
Q
;
PROMPT(USER) ;
N DIR,Y
S DIR(0)="S^A:Copy/Add settings;O:Copy/Overwrite settings;S:Skip User"
S DIR("A")="Select copy access for "_USER
S DIR("?")="Select the copy action, enter ?? for more information"
S DIR("??")=U_"D HELP^ORACCESS"
D ^DIR
Q Y
;
ASKYN(DEF,TEXT,RTN,HLP) ;
N DIR,X,Y
K DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="Y0"
S DIR("A")=TEXT
S DIR("B")=DEF
S DIR("?")="Enter Y or N."
I $G(RTN)'="",$G(HLP)'="" D
. S DIR("?")="Enter Y or N. For detailed help type ??"
. S DIR("??")=U_"D HELP^"_RTN_"(HLP)"
W !
D ^DIR
I $D(DTOUT)!$D(DUOUT) S Y=0
Q Y
;
ACCESS(RESULTS,USER,GETNOTES,NOTES) ;
D ACCESS^ORACCES2(.RESULTS,$G(USER),$G(GETNOTES),.NOTES)
Q
;
GETNOTES(ORY,USER) ;
N TEMP
D ACCESS^ORACCES2(.TEMP,USER,2,.ORY)
Q
;
CHECK(IEN,NAME) ;
N ACT,ARRAY,CARRAY,HASDATA,RESULT,YN
S HASDATA=0,RESULT="O"
D DATA(.ARRAY,TABS,IEN)
I $D(ARRAY) S HASDATA=1
I HASDATA=0 D
.D DATA(.ARRAY,OTHER,IEN)
.I $D(ARRAY) S HASDATA=1
I HASDATA=0 D
.D DATA(.ARRAY,ORDERS,IEN)
.I $D(ARRAY) S HASDATA=1
I HASDATA=1 D
.W !,NAME_" has settings already defined",!
.D DISPLAY^ORACCES3(IEN,.CARRAY)
.W !
.S ACT=$$PROMPT(NAME)
.I ACT=-1!(ACT="S") S RESULT="S" Q
.S RESULT=ACT
.;S YN=$$ASKYN("N","Replace "_NAME_" settings")
.;I YN'=1 S RESULT=0 W !,"Settings not copied over!"
Q RESULT
;
COPY ;
N ACT,CARRAY,IEN,INITIAL,NAME,TEXT,UARRAY,YN,CRLF
N ORPARAM,ORTABS,ORPIEN,TABS,OTHER,ORDERS,ERROR
D GETPARAMS(1) S CRLF=$C(13,10)
S TEXT=CRLF_"Only users with write access settings are selectable."_CRLF
S TEXT=TEXT_"May take a few seconds to display a list of users."_CRLF
S TEXT=TEXT_"Select user to copy from: "
S INITIAL=$$SELECT(TEXT,1)
I INITIAL=-1 Q
W !
D DISPLAY^ORACCES3(+INITIAL,.CARRAY)
W !
S YN=$$ASKYN("N","Copy "_$P(INITIAL,U,2)_" settings")
Q:$D(DTOUT) G:$D(DUOUT) COPY
I 'YN Q
W !
D GETUSER(.UARRAY)
I '$D(UARRAY) W !," No user selected" Q
S IEN=0 F S IEN=$O(UARRAY(IEN)) Q:IEN'>0 D
.S NAME=UARRAY(IEN)
.S ACT=$$CHECK(IEN,NAME)
.I ACT'="O",ACT'="A" Q
.D SETUSER(IEN,NAME,INITIAL,ACT,.CARRAY)
Q
;
CLEAR ;
N DA,DIR,DA,DIC,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DLAYGO,DINUM,USERLEVEL,LVLTXT,DONE
N ENT,ENT2,ORENT,ORCNT,LVLPREFIX,IEN,NAME,LVLNAME,USR,DIV,IDX,ORERR,TXT,CRLF
N ORPARAM,ORTABS,ORPIEN,TABS,OTHER,ORDERS,ERROR,DSPLVL,DSPNAME
D GETPARAMS(1)
S CRLF=$C(13,10)
S DONE=0 F D Q:DONE
. K DA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
. S DIR(0)="SO^S:System;D:Division;U:User"
. S DIR("A")="Remove Settings for System, Division or User?"
. D ^DIR I $D(DIRUT) S DONE=1 Q
. I $G(Y)="S" D S DONE=1 Q
. . S DSPLVL=2 D GETINST(DSPLVL,"",.DSPNAME)
. . W !!!,"Current settings for System "_DSPNAME_":",!
. . D DISPLAY^ORACCES3(0,"",0,0,DSPLVL,DSPNAME)
. . S TXT="All settings will be removed and CPRS Write Access for"_CRLF
. . S TXT=TXT_"the system will revert to package level settings."_CRLF
. . S TXT=TXT_"Are you sure you want to remove all system level settings"
. . I $$ASKYN("N",TXT) D I 1
. . . D CLEARSYS
. . . W !!,"*** System level settings removed ***",!!
. . E W !!,"System level settings not removed.",!!
. S USERLEVEL=$S($G(Y)="U":1,$G(Y)="D":0,1:-1),LVLTXT=$$LOW^XLFSTR($G(Y(0)))
. I USERLEVEL<0 S DONE=1 Q
. I USERLEVEL S ENT="VA(200,",LVLPREFIX="USR",ORCNT=3
. E S ENT="DIC(4,",LVLPREFIX="DIV",ORCNT=4
. S ORENT=";"_ENT,ENT2=LVLPREFIX_".`"
. F D Q:DONE
. . K DIC,X,Y,DTOUT,DUOUT
. . S DIC=U_ENT
. . S DIC("A")=CRLF_"Only "_LVLTXT_"s with write access settings are selectable."_CRLF
. . I USERLEVEL S DIC("A")=DIC("A")_"May take a few seconds to display a list of users."_CRLF
. . S DIC("A")=DIC("A")_"Remove all settings for which "_LVLTXT_"? ",DIC(0)="AEQM"
. . S DIC("S")="N ORX F ORX=1:1:ORCNT I $D(^XTV(8989.5,""AC"",ORPIEN(ORX),Y_ORENT)) Q"
. . D ^DIC I $D(DTOUT)!$D(DUOUT) S DONE=1 Q
. . S IEN=$P(Y,U),NAME=$P(Y,U,2),LVLNAME=LVLTXT_" "_NAME
. . I IEN'>0 S DONE=1 Q
. . S USR=$S(USERLEVEL:IEN,1:0),DIV=$S(USERLEVEL:0,1:IEN)
. . W !!!,"Current settings for "_LVLNAME_":",!
. . D DISPLAY^ORACCES3(USR,"",DIV)
. . S TXT="All settings will be removed and CPRS Write Access for "_LVLTXT_CRLF
. . S TXT=TXT_NAME_" will revert to the "_$S(USERLEVEL:"Division",1:"System")_" level settings."_CRLF
. . S TXT=TXT_"Are you sure you want to remove all settings for this "_LVLTXT
. . I $$ASKYN("N",TXT) D I 1
. . . F IDX=1:1:ORCNT D
. . . . K ORERR
. . . . D NDEL^XPAR(ENT2_IEN,ORPARAM(IDX),.ORERR)
. . . . I +$G(ORERR)'=0 W !,"ERROR: "_ORERR
. . . W !!!,"New settings for "_LVLNAME_":",!
. . . D DISPLAY^ORACCES3(USR,"",DIV)
. . . W !!,"*** Settings removed for "_LVLNAME_" ***",!!
. . E W !!,"Settings not removed for "_LVLNAME_".",!!
Q
;
GETINST(LVL,ENT,NAME) ;
I LVL=1 D
. N PKG,NAM
. S NAM=$P(^XTV(8989.51,ORPIEN(TABS),0),"^",1),PKG=NAM
. F S PKG=$O(^DIC(9.4,"C",PKG),-1) Q:$E(NAM,1,$L(PKG))=PKG
. S PKG=$O(^DIC(9.4,"C",PKG,0))
. I PKG S ENT=PKG_";DIC(9.4,",NAME=$P($G(^DIC(9.4,PKG,0)),U)
I LVL=2 D
. S ENT=$$FIND1^DIC(4.2,"","QX",$$KSP^XUPARAM("WHERE"))_";DIC(4.2,"
. S NAME=$P($G(^DIC(4.2,+ENT,0)),U)
Q
;
EDITOR ;
N INST,ORERR,TEMPLATE,ENT,DIC,DTOUT,DUOUT,IDX,Y,MESSAGE
N ORPARAM,ORTABS,ORPIEN,TABS,OTHER,ORDERS,ERROR,NAME
N USER,DIV,DSPLVL,DSPNAME,ASKLVL
S (USER,DIV,DSPLVL)=0,(DSPNAME,ASKLVL)=""
D GETPARAMS(1)
S (ENT,NAME)="",INST=$$SELECTINST
I "^U^S^P^D^"'[(U_INST_U) Q
S TEMPLATE="OR TABS WRITE ACCESS BY "_$S(INST="U":"USER",INST="S":"SYS",INST="P":"PKG",INST="D":"DIV",1:"")
I INST="P" D
. S DSPLVL=1 D GETINST(DSPLVL,.ENT,.DSPNAME)
. S ASKLVL="PKG",NAME="Package: "_DSPNAME
I INST="S" D
. S DSPLVL=2 D GETINST(DSPLVL,.ENT,.DSPNAME)
. S ASKLVL="SYS",NAME="System: "_DSPNAME
I INST="D" D
.S DIC=4,DIC(0)="AEMQ"
.D ^DIC I $D(DTOUT)!$D(DUOUT)!(Y<1) S ENT="" Q
.S DIV=+Y,DSPLVL=3,DSPNAME=$P($G(^DIC(4,DIV,0)),U)
.S ENT=+Y_";DIC(4,",NAME="Division: "_DSPNAME
I INST="U" D
.S DIC=200,DIC(0)="AEMQ"
.D ^DIC I $D(DTOUT)!$D(DUOUT)!(Y<1) S ENT="" Q
.S USER=+Y,DSPLVL=4,DSPNAME=$P($G(^VA(200,+Y,0)),U)
.S ENT=+Y_";VA(200,",NAME="User: "_DSPNAME
I ENT="" Q
D DISPLAY^ORACCES3(USER,"",DIV,0,DSPLVL,DSPNAME)
D VALUEMSG^ORACCES2(ENT,,,1,.MESSAGE,NAME)
I $D(MESSAGE) D K MESSAGE
.S IDX=0 F S IDX=$O(MESSAGE(IDX)) Q:'IDX W !,MESSAGE(IDX)
.W ! F IDX=1:1:78 W "-"
.W !
I ASKLVL'="" D ASK4RESET(ASKLVL)
D TEDH^XPAREDIT(TEMPLATE,"",ENT)
D DISPLAY^ORACCES3(USER,"",DIV,0,DSPLVL,DSPNAME)
D VALUEMSG^ORACCES2(ENT,,,1,.MESSAGE,NAME)
I $D(MESSAGE) D
.S IDX=0 F S IDX=$O(MESSAGE(IDX)) Q:'IDX W !,MESSAGE(IDX)
.W ! F IDX=1:1:78 W "-"
.W !
.R "Type <Enter> to continue: ",IDX:DTIME
Q
;
GETIINST(DESC) ;
N IDX,RESULT
S RESULT=""
S IDX=0 F S IDX=$O(ORTABS(IDX)) Q:IDX'>0!(RESULT'="") D
.I $G(ORTABS(IDX,4))=DESC S RESULT=$G(ORTABS(IDX,2))
Q RESULT
;
SELECTINST() ;
N DIR,Y
S DIR(0)=$S($G(DUZ(0))="@":"S^P:PACKAGE;S:SYSTEM;D:DIVISION;U:USER",1:"S^S:SYSTEM;D:DIVISION;U:USER")
D ^DIR
Q Y
;
GETUSER(UARRAY) ;
N STOP,USER
S STOP=0
F D Q:STOP=1
.S USER=$$SELECT("Select user to copy setting to: ")
.I +USER=-1 S STOP=1 Q
.S UARRAY($P(USER,U))=$P(USER,U,2)
Q
;
DATA(ARRAY,PARM,USER,DIV) ;
N EXT,EXT1,FILE,IEN,ORPARMS,PARAM,TYPE,TYPE1,VALUE,X
S PARAM=$G(ORPARAM(PARM))
I PARAM="" Q
D ENVAL^XPAR(.ORPARMS,PARAM,"",.ERR,0)
S DIV=$G(DIV)
S X="" F S X=$O(ORPARMS(X)) Q:X="" D
.S TYPE="" F S TYPE=$O(ORPARMS(X,TYPE)) Q:TYPE="" D
..S VALUE=$S(PARM<4:$S(ORPARMS(X,TYPE)=1:"Yes",1:"No"),1:ORPARMS(X,TYPE))
..I (PARM=1)!(PARM=2) D
...S EXT=$$TABDESC2(PARM,TYPE)
..I PARM=3 D
...S EXT=$P($G(^ORD(100.98,TYPE,0)),U)
..I PARM=4 S EXT=-1
..I $G(EXT)="" Q
..S FILE=$S(X["DIC(9.4":9.4,X["VA(200":200,X["DIC(4.2":4.2,X["DIC(4,":4,1:"")
..I FILE="" Q
..S EXT1=$S(FILE=200:+X,1:$$GET1^DIQ(FILE,+X,.01))
..S TYPE1=$S(FILE=9.4:"Package",FILE=4.2:"Systems",FILE=200:"Users",FILE=4:"Division",1:"")
..I TYPE1="" Q
..I USER>0,TYPE1'="Users" Q
..I USER>0,+X'=USER Q
..I DIV>0,TYPE1'="Division" Q
..I DIV>0,+X'=DIV Q
..S ARRAY(TYPE1,EXT1,EXT)=VALUE
Q
;
SETUSER(IEN,NAME,INITIAL,ACT,CARRAY) ;
N INST,ORERR,PARAM,PARAMID,SETINST,VALUE,ENT,RARRAY
W !,"Updating user: "_NAME
S ENT="USR.`"_IEN
I ACT="A" D DISPLAY^ORACCES3(IEN,.RARRAY,"",1)
I ACT="O" D I +$G(ORERR)'=0 Q
.F PARAMID=1,2,3 D
..S PARAM=$G(ORPARAM(PARAMID))
..I PARAM="" Q
..D NDEL^XPAR(ENT,PARAM,.ORERR)
..I +$G(ORERR)'=0 W !,"ERROR clearing user parameter: "_ORERR
F PARAMID=1,2,3 D
.S PARAM=$G(ORPARAM(PARAMID))
.I PARAM="" Q
.K ORERR
.I '$D(CARRAY(PARAMID)) Q
.S INST=""
.F S INST=$O(CARRAY(PARAMID,"Users",+INITIAL,INST)) Q:INST="" D
..I ACT="A",$G(RARRAY(PARAMID,"Users",IEN,INST))'="" Q
..S VALUE=CARRAY(PARAMID,"Users",+INITIAL,INST)
..I VALUE="" Q
..K ORERR
..S SETINST=$S(PARAMID<3:$$GETIINST(INST),1:INST)
..I SETINST="" Q
..W !,PARAM_" instance "_INST
..D EN^XPAR(ENT,PARAM,SETINST,VALUE,.ORERR)
..I +$G(ORERR)'=0 W !,"ERROR: "_ORERR Q
..W !," done"
W !,"User "_NAME_" settings:"
D DISPLAY^ORACCES3(IEN,"","",0)
Q
;
SELECT(TEXT,SCREEN) ;
N DIC,Y
S DIC="^VA(200,",DIC("A")=TEXT,DIC(0)="AEQM"
I $G(SCREEN) S DIC("S")="N ORX F ORX=1:1:3 I $D(^XTV(8989.5,""AC"",ORPIEN(ORX),Y_"";VA(200,"")) Q"
D ^DIC
Q Y
;
POST ;
N ORPARAM,ORTABS,TABS,OTHER,ORDERS,ERROR,NODEPENDENCIES
S NODEPENDENCIES=1
D GETPARAMS
D POSTTABS
D POSTDG
D POSTERR
Q
;
POSTDG ;
N IEN,ERR
S IEN=0 F S IEN=$O(^ORD(100.98,IEN)) Q:IEN'>0 D
.D EN^XPAR("PKG",ORPARAM(ORDERS),"`"_IEN,1,.ERR)
Q
;
POSTERR ;
N ERR,TXT
S TXT="New information cannot be added into CPRS. Exceptions: contact CACs."
D EN^XPAR("PKG",ORPARAM(ERROR),1,TXT,.ERR)
I +ERR>0 D
.D BMES^XPDUTL(" Problem updating error message")
Q
;
POSTTABS ;
N TAB,ERR
S TAB=0 F S TAB=$O(ORTABS(TAB)) Q:'TAB D
.D EN^XPAR("PKG",ORPARAM(ORTABS(TAB,1)),ORTABS(TAB,2),1,.ERR)
.I +ERR>0 D
..D BMES^XPDUTL(" Problem updating "_ORTABS(TAB,4)_" level")
Q
;
ASK4RESET(LEVEL) ;
N TAB,VALUE,ASK,IEN,DIR,Y,TXT,YN,LVLTXT,EXPECTED,ERR,NODEPENDENCIES
I LEVEL="PKG" S EXPECTED=1
E S EXPECTED=0
S (ASK,TAB)=0 F S TAB=$O(ORTABS(TAB)) Q:'TAB D Q:ASK
. S VALUE=$$GET^XPAR(LEVEL,ORPARAM(ORTABS(TAB,1)),ORTABS(TAB,2))
. I VALUE'=EXPECTED S ASK=1
I 'ASK D
. S IEN=0 F S IEN=$O(^ORD(100.98,IEN)) Q:IEN'>0 D Q:ASK
. . S VALUE=$$GET^XPAR(LEVEL,ORPARAM(ORDERS),"`"_IEN)
. . I VALUE'=EXPECTED S ASK=1
I 'ASK Q
I EXPECTED S YN="Yes"
E S YN="No"
I LEVEL="SYS" S LVLTXT="System"
E S LVLTXT="Package"
S DIR(0)="YO"
S TXT="Not all "_LVLTXT_" level settings are set to "_YN
S TXT=TXT_". Do you want to set all "_LVLTXT_" level settings to "_YN
S TXT=TXT_"? (Yes or No): "
D WRAP^ORUTL(TXT,"DIR(""A"")",1,0,2,0,70)
S IDX=$O(DIR("A",99999),-1) S DIR("A")=DIR("A",IDX) K DIR("A",IDX)
D ^DIR I $D(DIRUT) S Y=0
I '+Y Q
S NODEPENDENCIES=1
S TAB=0 F S TAB=$O(ORTABS(TAB)) Q:'TAB D
.D EN^XPAR(LEVEL,ORPARAM(ORTABS(TAB,1)),ORTABS(TAB,2),EXPECTED,.ERR)
S IEN=0 F S IEN=$O(^ORD(100.98,IEN)) Q:IEN'>0 D
.D EN^XPAR(LEVEL,ORPARAM(ORDERS),"`"_IEN,EXPECTED,.ERR)
W !,"Done"
Q
;
CLEARPKG ;
N ORERR,IDX,ORPARAM,ORTABS,TABS,OTHER,ORDERS,ERROR
D GETPARAMS
S IDX=0 F S IDX=$O(ORPARAM(IDX)) Q:'IDX D NDEL^XPAR("PKG",ORPARAM(IDX),.ORERR)
Q
CLEARSYS ;
N ORERR,IDX,ORPARAM,ORTABS,TABS,OTHER,ORDERS,ERROR
D GETPARAMS
S IDX=0 F S IDX=$O(ORPARAM(IDX)) Q:'IDX D NDEL^XPAR("SYS",ORPARAM(IDX),.ORERR)
Q
;
GETPARAMS(GETCODE) ;
I '$D(ORPARAM) D
. S TABS=1,ORPARAM(TABS)="OR CPRS TABS WRITE ACCESS"
. S OTHER=2,ORPARAM(OTHER)="OR CPRS OTHER WRITE ACCESS"
. S ORDERS=3,ORPARAM(ORDERS)="OR CPRS ORDERS WRITE ACCESS"
. S ERROR=4,ORPARAM(ERROR)="OR CPRS WRITE ACCESS ERROR"
I +$G(GETCODE),'$D(ORPIEN) D
. N IDX F IDX=1:1:4 S ORPIEN(IDX)=$O(^XTV(8989.51,"B",ORPARAM(IDX),0))
; ORTABS 2nd Index 1:Parameter, 2:Code 3:Internal Name 4:Display Name 5=1=Template access, 2=Cover Sheet param
I '$D(ORTABS) D
. N IDX,DATA,LINE,SUB
. S IDX=0,LINE="ORTABINFO"
. F S IDX=IDX+1,DATA=$P($T(@LINE+IDX),";;",2) Q:DATA="" D
.. F SUB=1:1:5 S ORTABS(IDX,SUB)=$P(DATA,U,SUB)
Q
;
TABIDX(PARAM,CODE) ;
N IDX,TAB
S (IDX,TAB)=0
F S TAB=$O(ORTABS(TAB)) Q:'TAB D Q:IDX
. I PARAM=ORTABS(TAB,1),CODE=ORTABS(TAB,2) S IDX=TAB
Q IDX
;
TABDESC(IDX,EXTRA) ;
N DESC
S DESC=ORTABS(IDX,4)
I +$G(EXTRA) D
. I ORTABS(IDX,5)=1 S DESC=DESC_", template access allowed"
. I ORTABS(IDX,5)=2 S DESC="Cover Sheet "_DESC
Q DESC
;
TABDESC2(PARAM,CODE,EXTRA) ;
N DESC,TAB
S TAB=0,DESC=""
F S TAB=$O(ORTABS(TAB)) Q:'TAB D Q:DESC'=""
. I PARAM=ORTABS(TAB,1),CODE=ORTABS(TAB,2) D
. . S DESC=$$TABDESC(TAB,$G(EXTRA))
Q DESC
;
;
ORTABINFO ; Pieces: 1:ORPARAM idx 2:Code 3:Internal Name 4:Display Name 5:1=Template access, 2=Cover Sheet param
;;1^C^consults^Consults^1
;;1^D^dcSumm^Discharge Summaries^1
;;1^M^meds^Meds
;;1^N^notes^Notes^1
;;1^O^orders^Orders
;;1^P^problems^Problems
;;1^S^surgery^Surgery^1
;;2^A^allergy^Allergies
;;2^D^delayedOrders^Delayed Orders
;;2^E^encounters^Encounters
;;2^I^immunization^Immunizations^2
;;2^R^reminderEditor^Reminders List Editor^2
;;2^V^vital^Vitals^2
;;2^W^womenHealth^Women's Health^2
;;
ONEHR() ;
N ORPRIMARY
;
; For testing purposes, OR SIMULATE ON EHR can be used to have this API return a 1 in a non-prod account
I '$$PROD^XUPROD,$$GET^XPAR("ALL","OR SIMULATE ON EHR",1,"I") Q 1
;
S ORPRIMARY=$P($$SITE^VASITE,U,3)
Q $$CRNRSITE^VAFCCRNR(ORPRIMARY) ;ICR #7346
;
EHRACTIVE(ORY) ;
S ORY=$$ONEHR
Q
;
TABNAMES(TABS) ;
N IDX,DATA,LINE,SUB
S IDX=0,LINE="ORTABINFO"
F S IDX=IDX+1,DATA=$P($T(@LINE+IDX),";;",2) Q:DATA="" D
.;F SUB=1:1:5 S ORTABS(IDX,SUB)=$P(DATA,U,SUB)
.S TABS($P(DATA,U,3))=$P(DATA,U,4)
Q
;
HELP ;
W !,"Select the copy action:",!
W !," Copy/Add settings - Select Copy/Add settings to add the settings"
W !," from the initial user to the receiving user, without overwriting"
W !," any existing settings.",!
W !," Copy/Overwrite settings - Select Copy/Overwrite settings to replace"
W !," the receiving user settings with the initial user settings.",!
W !," Skip User - do not copy any of the user settings."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORACCESS 14701 printed Jan 18, 2025@03:28:01 Page 2
ORACCESS ;SLC/AGP - User Read/Write Access to CPRS ; Apr 20, 2023@17:48
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**588**;Dec 17, 1997;Build 29
+2 ;
+3 ; Direct reads of PARAMETERS File (#8989.5) - IA #2686
+4 ; Direct reads of PARAMETER DEFINITION File (#8989.51) - IA #2685
+5 ; Reference to CRNRSITE^VAFCCRNR in ICR #7346
+6 ;
+7 QUIT
+8 ;
PROMPT(USER) ;
+1 NEW DIR,Y
+2 SET DIR(0)="S^A:Copy/Add settings;O:Copy/Overwrite settings;S:Skip User"
+3 SET DIR("A")="Select copy access for "_USER
+4 SET DIR("?")="Select the copy action, enter ?? for more information"
+5 SET DIR("??")=U_"D HELP^ORACCESS"
+6 DO ^DIR
+7 QUIT Y
+8 ;
ASKYN(DEF,TEXT,RTN,HLP) ;
+1 NEW DIR,X,Y
+2 KILL DIROUT,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="Y0"
+4 SET DIR("A")=TEXT
+5 SET DIR("B")=DEF
+6 SET DIR("?")="Enter Y or N."
+7 IF $GET(RTN)'=""
IF $GET(HLP)'=""
Begin DoDot:1
+8 SET DIR("?")="Enter Y or N. For detailed help type ??"
+9 SET DIR("??")=U_"D HELP^"_RTN_"(HLP)"
End DoDot:1
+10 WRITE !
+11 DO ^DIR
+12 IF $DATA(DTOUT)!$DATA(DUOUT)
SET Y=0
+13 QUIT Y
+14 ;
ACCESS(RESULTS,USER,GETNOTES,NOTES) ;
+1 DO ACCESS^ORACCES2(.RESULTS,$GET(USER),$GET(GETNOTES),.NOTES)
+2 QUIT
+3 ;
GETNOTES(ORY,USER) ;
+1 NEW TEMP
+2 DO ACCESS^ORACCES2(.TEMP,USER,2,.ORY)
+3 QUIT
+4 ;
CHECK(IEN,NAME) ;
+1 NEW ACT,ARRAY,CARRAY,HASDATA,RESULT,YN
+2 SET HASDATA=0
SET RESULT="O"
+3 DO DATA(.ARRAY,TABS,IEN)
+4 IF $DATA(ARRAY)
SET HASDATA=1
+5 IF HASDATA=0
Begin DoDot:1
+6 DO DATA(.ARRAY,OTHER,IEN)
+7 IF $DATA(ARRAY)
SET HASDATA=1
End DoDot:1
+8 IF HASDATA=0
Begin DoDot:1
+9 DO DATA(.ARRAY,ORDERS,IEN)
+10 IF $DATA(ARRAY)
SET HASDATA=1
End DoDot:1
+11 IF HASDATA=1
Begin DoDot:1
+12 WRITE !,NAME_" has settings already defined",!
+13 DO DISPLAY^ORACCES3(IEN,.CARRAY)
+14 WRITE !
+15 SET ACT=$$PROMPT(NAME)
+16 IF ACT=-1!(ACT="S")
SET RESULT="S"
QUIT
+17 SET RESULT=ACT
+18 ;S YN=$$ASKYN("N","Replace "_NAME_" settings")
+19 ;I YN'=1 S RESULT=0 W !,"Settings not copied over!"
End DoDot:1
+20 QUIT RESULT
+21 ;
COPY ;
+1 NEW ACT,CARRAY,IEN,INITIAL,NAME,TEXT,UARRAY,YN,CRLF
+2 NEW ORPARAM,ORTABS,ORPIEN,TABS,OTHER,ORDERS,ERROR
+3 DO GETPARAMS(1)
SET CRLF=$CHAR(13,10)
+4 SET TEXT=CRLF_"Only users with write access settings are selectable."_CRLF
+5 SET TEXT=TEXT_"May take a few seconds to display a list of users."_CRLF
+6 SET TEXT=TEXT_"Select user to copy from: "
+7 SET INITIAL=$$SELECT(TEXT,1)
+8 IF INITIAL=-1
QUIT
+9 WRITE !
+10 DO DISPLAY^ORACCES3(+INITIAL,.CARRAY)
+11 WRITE !
+12 SET YN=$$ASKYN("N","Copy "_$PIECE(INITIAL,U,2)_" settings")
+13 if $DATA(DTOUT)
QUIT
if $DATA(DUOUT)
GOTO COPY
+14 IF 'YN
QUIT
+15 WRITE !
+16 DO GETUSER(.UARRAY)
+17 IF '$DATA(UARRAY)
WRITE !," No user selected"
QUIT
+18 SET IEN=0
FOR
SET IEN=$ORDER(UARRAY(IEN))
if IEN'>0
QUIT
Begin DoDot:1
+19 SET NAME=UARRAY(IEN)
+20 SET ACT=$$CHECK(IEN,NAME)
+21 IF ACT'="O"
IF ACT'="A"
QUIT
+22 DO SETUSER(IEN,NAME,INITIAL,ACT,.CARRAY)
End DoDot:1
+23 QUIT
+24 ;
CLEAR ;
+1 NEW DA,DIR,DA,DIC,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DLAYGO,DINUM,USERLEVEL,LVLTXT,DONE
+2 NEW ENT,ENT2,ORENT,ORCNT,LVLPREFIX,IEN,NAME,LVLNAME,USR,DIV,IDX,ORERR,TXT,CRLF
+3 NEW ORPARAM,ORTABS,ORPIEN,TABS,OTHER,ORDERS,ERROR,DSPLVL,DSPNAME
+4 DO GETPARAMS(1)
+5 SET CRLF=$CHAR(13,10)
+6 SET DONE=0
FOR
Begin DoDot:1
+7 KILL DA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+8 SET DIR(0)="SO^S:System;D:Division;U:User"
+9 SET DIR("A")="Remove Settings for System, Division or User?"
+10 DO ^DIR
IF $DATA(DIRUT)
SET DONE=1
QUIT
+11 IF $GET(Y)="S"
Begin DoDot:2
+12 SET DSPLVL=2
DO GETINST(DSPLVL,"",.DSPNAME)
+13 WRITE !!!,"Current settings for System "_DSPNAME_":",!
+14 DO DISPLAY^ORACCES3(0,"",0,0,DSPLVL,DSPNAME)
+15 SET TXT="All settings will be removed and CPRS Write Access for"_CRLF
+16 SET TXT=TXT_"the system will revert to package level settings."_CRLF
+17 SET TXT=TXT_"Are you sure you want to remove all system level settings"
+18 IF $$ASKYN("N",TXT)
Begin DoDot:3
+19 DO CLEARSYS
+20 WRITE !!,"*** System level settings removed ***",!!
End DoDot:3
IF 1
+21 IF '$TEST
WRITE !!,"System level settings not removed.",!!
End DoDot:2
SET DONE=1
QUIT
+22 SET USERLEVEL=$SELECT($GET(Y)="U":1,$GET(Y)="D":0,1:-1)
SET LVLTXT=$$LOW^XLFSTR($GET(Y(0)))
+23 IF USERLEVEL<0
SET DONE=1
QUIT
+24 IF USERLEVEL
SET ENT="VA(200,"
SET LVLPREFIX="USR"
SET ORCNT=3
+25 IF '$TEST
SET ENT="DIC(4,"
SET LVLPREFIX="DIV"
SET ORCNT=4
+26 SET ORENT=";"_ENT
SET ENT2=LVLPREFIX_".`"
+27 FOR
Begin DoDot:2
+28 KILL DIC,X,Y,DTOUT,DUOUT
+29 SET DIC=U_ENT
+30 SET DIC("A")=CRLF_"Only "_LVLTXT_"s with write access settings are selectable."_CRLF
+31 IF USERLEVEL
SET DIC("A")=DIC("A")_"May take a few seconds to display a list of users."_CRLF
+32 SET DIC("A")=DIC("A")_"Remove all settings for which "_LVLTXT_"? "
SET DIC(0)="AEQM"
+33 SET DIC("S")="N ORX F ORX=1:1:ORCNT I $D(^XTV(8989.5,""AC"",ORPIEN(ORX),Y_ORENT)) Q"
+34 DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)
SET DONE=1
QUIT
+35 SET IEN=$PIECE(Y,U)
SET NAME=$PIECE(Y,U,2)
SET LVLNAME=LVLTXT_" "_NAME
+36 IF IEN'>0
SET DONE=1
QUIT
+37 SET USR=$SELECT(USERLEVEL:IEN,1:0)
SET DIV=$SELECT(USERLEVEL:0,1:IEN)
+38 WRITE !!!,"Current settings for "_LVLNAME_":",!
+39 DO DISPLAY^ORACCES3(USR,"",DIV)
+40 SET TXT="All settings will be removed and CPRS Write Access for "_LVLTXT_CRLF
+41 SET TXT=TXT_NAME_" will revert to the "_$SELECT(USERLEVEL:"Division",1:"System")_" level settings."_CRLF
+42 SET TXT=TXT_"Are you sure you want to remove all settings for this "_LVLTXT
+43 IF $$ASKYN("N",TXT)
Begin DoDot:3
+44 FOR IDX=1:1:ORCNT
Begin DoDot:4
+45 KILL ORERR
+46 DO NDEL^XPAR(ENT2_IEN,ORPARAM(IDX),.ORERR)
+47 IF +$GET(ORERR)'=0
WRITE !,"ERROR: "_ORERR
End DoDot:4
+48 WRITE !!!,"New settings for "_LVLNAME_":",!
+49 DO DISPLAY^ORACCES3(USR,"",DIV)
+50 WRITE !!,"*** Settings removed for "_LVLNAME_" ***",!!
End DoDot:3
IF 1
+51 IF '$TEST
WRITE !!,"Settings not removed for "_LVLNAME_".",!!
End DoDot:2
if DONE
QUIT
End DoDot:1
if DONE
QUIT
+52 QUIT
+53 ;
GETINST(LVL,ENT,NAME) ;
+1 IF LVL=1
Begin DoDot:1
+2 NEW PKG,NAM
+3 SET NAM=$PIECE(^XTV(8989.51,ORPIEN(TABS),0),"^",1)
SET PKG=NAM
+4 FOR
SET PKG=$ORDER(^DIC(9.4,"C",PKG),-1)
if $EXTRACT(NAM,1,$LENGTH(PKG))=PKG
QUIT
+5 SET PKG=$ORDER(^DIC(9.4,"C",PKG,0))
+6 IF PKG
SET ENT=PKG_";DIC(9.4,"
SET NAME=$PIECE($GET(^DIC(9.4,PKG,0)),U)
End DoDot:1
+7 IF LVL=2
Begin DoDot:1
+8 SET ENT=$$FIND1^DIC(4.2,"","QX",$$KSP^XUPARAM("WHERE"))_";DIC(4.2,"
+9 SET NAME=$PIECE($GET(^DIC(4.2,+ENT,0)),U)
End DoDot:1
+10 QUIT
+11 ;
EDITOR ;
+1 NEW INST,ORERR,TEMPLATE,ENT,DIC,DTOUT,DUOUT,IDX,Y,MESSAGE
+2 NEW ORPARAM,ORTABS,ORPIEN,TABS,OTHER,ORDERS,ERROR,NAME
+3 NEW USER,DIV,DSPLVL,DSPNAME,ASKLVL
+4 SET (USER,DIV,DSPLVL)=0
SET (DSPNAME,ASKLVL)=""
+5 DO GETPARAMS(1)
+6 SET (ENT,NAME)=""
SET INST=$$SELECTINST
+7 IF "^U^S^P^D^"'[(U_INST_U)
QUIT
+8 SET TEMPLATE="OR TABS WRITE ACCESS BY "_$SELECT(INST="U":"USER",INST="S":"SYS",INST="P":"PKG",INST="D":"DIV",1:"")
+9 IF INST="P"
Begin DoDot:1
+10 SET DSPLVL=1
DO GETINST(DSPLVL,.ENT,.DSPNAME)
+11 SET ASKLVL="PKG"
SET NAME="Package: "_DSPNAME
End DoDot:1
+12 IF INST="S"
Begin DoDot:1
+13 SET DSPLVL=2
DO GETINST(DSPLVL,.ENT,.DSPNAME)
+14 SET ASKLVL="SYS"
SET NAME="System: "_DSPNAME
End DoDot:1
+15 IF INST="D"
Begin DoDot:1
+16 SET DIC=4
SET DIC(0)="AEMQ"
+17 DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<1)
SET ENT=""
QUIT
+18 SET DIV=+Y
SET DSPLVL=3
SET DSPNAME=$PIECE($GET(^DIC(4,DIV,0)),U)
+19 SET ENT=+Y_";DIC(4,"
SET NAME="Division: "_DSPNAME
End DoDot:1
+20 IF INST="U"
Begin DoDot:1
+21 SET DIC=200
SET DIC(0)="AEMQ"
+22 DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<1)
SET ENT=""
QUIT
+23 SET USER=+Y
SET DSPLVL=4
SET DSPNAME=$PIECE($GET(^VA(200,+Y,0)),U)
+24 SET ENT=+Y_";VA(200,"
SET NAME="User: "_DSPNAME
End DoDot:1
+25 IF ENT=""
QUIT
+26 DO DISPLAY^ORACCES3(USER,"",DIV,0,DSPLVL,DSPNAME)
+27 DO VALUEMSG^ORACCES2(ENT,,,1,.MESSAGE,NAME)
+28 IF $DATA(MESSAGE)
Begin DoDot:1
+29 SET IDX=0
FOR
SET IDX=$ORDER(MESSAGE(IDX))
if 'IDX
QUIT
WRITE !,MESSAGE(IDX)
+30 WRITE !
FOR IDX=1:1:78
WRITE "-"
+31 WRITE !
End DoDot:1
KILL MESSAGE
+32 IF ASKLVL'=""
DO ASK4RESET(ASKLVL)
+33 DO TEDH^XPAREDIT(TEMPLATE,"",ENT)
+34 DO DISPLAY^ORACCES3(USER,"",DIV,0,DSPLVL,DSPNAME)
+35 DO VALUEMSG^ORACCES2(ENT,,,1,.MESSAGE,NAME)
+36 IF $DATA(MESSAGE)
Begin DoDot:1
+37 SET IDX=0
FOR
SET IDX=$ORDER(MESSAGE(IDX))
if 'IDX
QUIT
WRITE !,MESSAGE(IDX)
+38 WRITE !
FOR IDX=1:1:78
WRITE "-"
+39 WRITE !
+40 READ "Type <Enter> to continue: ",IDX:DTIME
End DoDot:1
+41 QUIT
+42 ;
GETIINST(DESC) ;
+1 NEW IDX,RESULT
+2 SET RESULT=""
+3 SET IDX=0
FOR
SET IDX=$ORDER(ORTABS(IDX))
if IDX'>0!(RESULT'="")
QUIT
Begin DoDot:1
+4 IF $GET(ORTABS(IDX,4))=DESC
SET RESULT=$GET(ORTABS(IDX,2))
End DoDot:1
+5 QUIT RESULT
+6 ;
SELECTINST() ;
+1 NEW DIR,Y
+2 SET DIR(0)=$SELECT($GET(DUZ(0))="@":"S^P:PACKAGE;S:SYSTEM;D:DIVISION;U:USER",1:"S^S:SYSTEM;D:DIVISION;U:USER")
+3 DO ^DIR
+4 QUIT Y
+5 ;
GETUSER(UARRAY) ;
+1 NEW STOP,USER
+2 SET STOP=0
+3 FOR
Begin DoDot:1
+4 SET USER=$$SELECT("Select user to copy setting to: ")
+5 IF +USER=-1
SET STOP=1
QUIT
+6 SET UARRAY($PIECE(USER,U))=$PIECE(USER,U,2)
End DoDot:1
if STOP=1
QUIT
+7 QUIT
+8 ;
DATA(ARRAY,PARM,USER,DIV) ;
+1 NEW EXT,EXT1,FILE,IEN,ORPARMS,PARAM,TYPE,TYPE1,VALUE,X
+2 SET PARAM=$GET(ORPARAM(PARM))
+3 IF PARAM=""
QUIT
+4 DO ENVAL^XPAR(.ORPARMS,PARAM,"",.ERR,0)
+5 SET DIV=$GET(DIV)
+6 SET X=""
FOR
SET X=$ORDER(ORPARMS(X))
if X=""
QUIT
Begin DoDot:1
+7 SET TYPE=""
FOR
SET TYPE=$ORDER(ORPARMS(X,TYPE))
if TYPE=""
QUIT
Begin DoDot:2
+8 SET VALUE=$SELECT(PARM<4:$SELECT(ORPARMS(X,TYPE)=1:"Yes",1:"No"),1:ORPARMS(X,TYPE))
+9 IF (PARM=1)!(PARM=2)
Begin DoDot:3
+10 SET EXT=$$TABDESC2(PARM,TYPE)
End DoDot:3
+11 IF PARM=3
Begin DoDot:3
+12 SET EXT=$PIECE($GET(^ORD(100.98,TYPE,0)),U)
End DoDot:3
+13 IF PARM=4
SET EXT=-1
+14 IF $GET(EXT)=""
QUIT
+15 SET FILE=$SELECT(X["DIC(9.4":9.4,X["VA(200":200,X["DIC(4.2":4.2,X["DIC(4,":4,1:"")
+16 IF FILE=""
QUIT
+17 SET EXT1=$SELECT(FILE=200:+X,1:$$GET1^DIQ(FILE,+X,.01))
+18 SET TYPE1=$SELECT(FILE=9.4:"Package",FILE=4.2:"Systems",FILE=200:"Users",FILE=4:"Division",1:"")
+19 IF TYPE1=""
QUIT
+20 IF USER>0
IF TYPE1'="Users"
QUIT
+21 IF USER>0
IF +X'=USER
QUIT
+22 IF DIV>0
IF TYPE1'="Division"
QUIT
+23 IF DIV>0
IF +X'=DIV
QUIT
+24 SET ARRAY(TYPE1,EXT1,EXT)=VALUE
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
SETUSER(IEN,NAME,INITIAL,ACT,CARRAY) ;
+1 NEW INST,ORERR,PARAM,PARAMID,SETINST,VALUE,ENT,RARRAY
+2 WRITE !,"Updating user: "_NAME
+3 SET ENT="USR.`"_IEN
+4 IF ACT="A"
DO DISPLAY^ORACCES3(IEN,.RARRAY,"",1)
+5 IF ACT="O"
Begin DoDot:1
+6 FOR PARAMID=1,2,3
Begin DoDot:2
+7 SET PARAM=$GET(ORPARAM(PARAMID))
+8 IF PARAM=""
QUIT
+9 DO NDEL^XPAR(ENT,PARAM,.ORERR)
+10 IF +$GET(ORERR)'=0
WRITE !,"ERROR clearing user parameter: "_ORERR
End DoDot:2
End DoDot:1
IF +$GET(ORERR)'=0
QUIT
+11 FOR PARAMID=1,2,3
Begin DoDot:1
+12 SET PARAM=$GET(ORPARAM(PARAMID))
+13 IF PARAM=""
QUIT
+14 KILL ORERR
+15 IF '$DATA(CARRAY(PARAMID))
QUIT
+16 SET INST=""
+17 FOR
SET INST=$ORDER(CARRAY(PARAMID,"Users",+INITIAL,INST))
if INST=""
QUIT
Begin DoDot:2
+18 IF ACT="A"
IF $GET(RARRAY(PARAMID,"Users",IEN,INST))'=""
QUIT
+19 SET VALUE=CARRAY(PARAMID,"Users",+INITIAL,INST)
+20 IF VALUE=""
QUIT
+21 KILL ORERR
+22 SET SETINST=$SELECT(PARAMID<3:$$GETIINST(INST),1:INST)
+23 IF SETINST=""
QUIT
+24 WRITE !,PARAM_" instance "_INST
+25 DO EN^XPAR(ENT,PARAM,SETINST,VALUE,.ORERR)
+26 IF +$GET(ORERR)'=0
WRITE !,"ERROR: "_ORERR
QUIT
+27 WRITE !," done"
End DoDot:2
End DoDot:1
+28 WRITE !,"User "_NAME_" settings:"
+29 DO DISPLAY^ORACCES3(IEN,"","",0)
+30 QUIT
+31 ;
SELECT(TEXT,SCREEN) ;
+1 NEW DIC,Y
+2 SET DIC="^VA(200,"
SET DIC("A")=TEXT
SET DIC(0)="AEQM"
+3 IF $GET(SCREEN)
SET DIC("S")="N ORX F ORX=1:1:3 I $D(^XTV(8989.5,""AC"",ORPIEN(ORX),Y_"";VA(200,"")) Q"
+4 DO ^DIC
+5 QUIT Y
+6 ;
POST ;
+1 NEW ORPARAM,ORTABS,TABS,OTHER,ORDERS,ERROR,NODEPENDENCIES
+2 SET NODEPENDENCIES=1
+3 DO GETPARAMS
+4 DO POSTTABS
+5 DO POSTDG
+6 DO POSTERR
+7 QUIT
+8 ;
POSTDG ;
+1 NEW IEN,ERR
+2 SET IEN=0
FOR
SET IEN=$ORDER(^ORD(100.98,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+3 DO EN^XPAR("PKG",ORPARAM(ORDERS),"`"_IEN,1,.ERR)
End DoDot:1
+4 QUIT
+5 ;
POSTERR ;
+1 NEW ERR,TXT
+2 SET TXT="New information cannot be added into CPRS. Exceptions: contact CACs."
+3 DO EN^XPAR("PKG",ORPARAM(ERROR),1,TXT,.ERR)
+4 IF +ERR>0
Begin DoDot:1
+5 DO BMES^XPDUTL(" Problem updating error message")
End DoDot:1
+6 QUIT
+7 ;
POSTTABS ;
+1 NEW TAB,ERR
+2 SET TAB=0
FOR
SET TAB=$ORDER(ORTABS(TAB))
if 'TAB
QUIT
Begin DoDot:1
+3 DO EN^XPAR("PKG",ORPARAM(ORTABS(TAB,1)),ORTABS(TAB,2),1,.ERR)
+4 IF +ERR>0
Begin DoDot:2
+5 DO BMES^XPDUTL(" Problem updating "_ORTABS(TAB,4)_" level")
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
ASK4RESET(LEVEL) ;
+1 NEW TAB,VALUE,ASK,IEN,DIR,Y,TXT,YN,LVLTXT,EXPECTED,ERR,NODEPENDENCIES
+2 IF LEVEL="PKG"
SET EXPECTED=1
+3 IF '$TEST
SET EXPECTED=0
+4 SET (ASK,TAB)=0
FOR
SET TAB=$ORDER(ORTABS(TAB))
if 'TAB
QUIT
Begin DoDot:1
+5 SET VALUE=$$GET^XPAR(LEVEL,ORPARAM(ORTABS(TAB,1)),ORTABS(TAB,2))
+6 IF VALUE'=EXPECTED
SET ASK=1
End DoDot:1
if ASK
QUIT
+7 IF 'ASK
Begin DoDot:1
+8 SET IEN=0
FOR
SET IEN=$ORDER(^ORD(100.98,IEN))
if IEN'>0
QUIT
Begin DoDot:2
+9 SET VALUE=$$GET^XPAR(LEVEL,ORPARAM(ORDERS),"`"_IEN)
+10 IF VALUE'=EXPECTED
SET ASK=1
End DoDot:2
if ASK
QUIT
End DoDot:1
+11 IF 'ASK
QUIT
+12 IF EXPECTED
SET YN="Yes"
+13 IF '$TEST
SET YN="No"
+14 IF LEVEL="SYS"
SET LVLTXT="System"
+15 IF '$TEST
SET LVLTXT="Package"
+16 SET DIR(0)="YO"
+17 SET TXT="Not all "_LVLTXT_" level settings are set to "_YN
+18 SET TXT=TXT_". Do you want to set all "_LVLTXT_" level settings to "_YN
+19 SET TXT=TXT_"? (Yes or No): "
+20 DO WRAP^ORUTL(TXT,"DIR(""A"")",1,0,2,0,70)
+21 SET IDX=$ORDER(DIR("A",99999),-1)
SET DIR("A")=DIR("A",IDX)
KILL DIR("A",IDX)
+22 DO ^DIR
IF $DATA(DIRUT)
SET Y=0
+23 IF '+Y
QUIT
+24 SET NODEPENDENCIES=1
+25 SET TAB=0
FOR
SET TAB=$ORDER(ORTABS(TAB))
if 'TAB
QUIT
Begin DoDot:1
+26 DO EN^XPAR(LEVEL,ORPARAM(ORTABS(TAB,1)),ORTABS(TAB,2),EXPECTED,.ERR)
End DoDot:1
+27 SET IEN=0
FOR
SET IEN=$ORDER(^ORD(100.98,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+28 DO EN^XPAR(LEVEL,ORPARAM(ORDERS),"`"_IEN,EXPECTED,.ERR)
End DoDot:1
+29 WRITE !,"Done"
+30 QUIT
+31 ;
CLEARPKG ;
+1 NEW ORERR,IDX,ORPARAM,ORTABS,TABS,OTHER,ORDERS,ERROR
+2 DO GETPARAMS
+3 SET IDX=0
FOR
SET IDX=$ORDER(ORPARAM(IDX))
if 'IDX
QUIT
DO NDEL^XPAR("PKG",ORPARAM(IDX),.ORERR)
+4 QUIT
CLEARSYS ;
+1 NEW ORERR,IDX,ORPARAM,ORTABS,TABS,OTHER,ORDERS,ERROR
+2 DO GETPARAMS
+3 SET IDX=0
FOR
SET IDX=$ORDER(ORPARAM(IDX))
if 'IDX
QUIT
DO NDEL^XPAR("SYS",ORPARAM(IDX),.ORERR)
+4 QUIT
+5 ;
GETPARAMS(GETCODE) ;
+1 IF '$DATA(ORPARAM)
Begin DoDot:1
+2 SET TABS=1
SET ORPARAM(TABS)="OR CPRS TABS WRITE ACCESS"
+3 SET OTHER=2
SET ORPARAM(OTHER)="OR CPRS OTHER WRITE ACCESS"
+4 SET ORDERS=3
SET ORPARAM(ORDERS)="OR CPRS ORDERS WRITE ACCESS"
+5 SET ERROR=4
SET ORPARAM(ERROR)="OR CPRS WRITE ACCESS ERROR"
End DoDot:1
+6 IF +$GET(GETCODE)
IF '$DATA(ORPIEN)
Begin DoDot:1
+7 NEW IDX
FOR IDX=1:1:4
SET ORPIEN(IDX)=$ORDER(^XTV(8989.51,"B",ORPARAM(IDX),0))
End DoDot:1
+8 ; ORTABS 2nd Index 1:Parameter, 2:Code 3:Internal Name 4:Display Name 5=1=Template access, 2=Cover Sheet param
+9 IF '$DATA(ORTABS)
Begin DoDot:1
+10 NEW IDX,DATA,LINE,SUB
+11 SET IDX=0
SET LINE="ORTABINFO"
+12 FOR
SET IDX=IDX+1
SET DATA=$PIECE($TEXT(@LINE+IDX),";;",2)
if DATA=""
QUIT
Begin DoDot:2
+13 FOR SUB=1:1:5
SET ORTABS(IDX,SUB)=$PIECE(DATA,U,SUB)
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
TABIDX(PARAM,CODE) ;
+1 NEW IDX,TAB
+2 SET (IDX,TAB)=0
+3 FOR
SET TAB=$ORDER(ORTABS(TAB))
if 'TAB
QUIT
Begin DoDot:1
+4 IF PARAM=ORTABS(TAB,1)
IF CODE=ORTABS(TAB,2)
SET IDX=TAB
End DoDot:1
if IDX
QUIT
+5 QUIT IDX
+6 ;
TABDESC(IDX,EXTRA) ;
+1 NEW DESC
+2 SET DESC=ORTABS(IDX,4)
+3 IF +$GET(EXTRA)
Begin DoDot:1
+4 IF ORTABS(IDX,5)=1
SET DESC=DESC_", template access allowed"
+5 IF ORTABS(IDX,5)=2
SET DESC="Cover Sheet "_DESC
End DoDot:1
+6 QUIT DESC
+7 ;
TABDESC2(PARAM,CODE,EXTRA) ;
+1 NEW DESC,TAB
+2 SET TAB=0
SET DESC=""
+3 FOR
SET TAB=$ORDER(ORTABS(TAB))
if 'TAB
QUIT
Begin DoDot:1
+4 IF PARAM=ORTABS(TAB,1)
IF CODE=ORTABS(TAB,2)
Begin DoDot:2
+5 SET DESC=$$TABDESC(TAB,$GET(EXTRA))
End DoDot:2
End DoDot:1
if DESC'=""
QUIT
+6 QUIT DESC
+7 ;
+8 ;
ORTABINFO ; Pieces: 1:ORPARAM idx 2:Code 3:Internal Name 4:Display Name 5:1=Template access, 2=Cover Sheet param
+1 ;;1^C^consults^Consults^1
+2 ;;1^D^dcSumm^Discharge Summaries^1
+3 ;;1^M^meds^Meds
+4 ;;1^N^notes^Notes^1
+5 ;;1^O^orders^Orders
+6 ;;1^P^problems^Problems
+7 ;;1^S^surgery^Surgery^1
+8 ;;2^A^allergy^Allergies
+9 ;;2^D^delayedOrders^Delayed Orders
+10 ;;2^E^encounters^Encounters
+11 ;;2^I^immunization^Immunizations^2
+12 ;;2^R^reminderEditor^Reminders List Editor^2
+13 ;;2^V^vital^Vitals^2
+14 ;;2^W^womenHealth^Women's Health^2
+15 ;;
ONEHR() ;
+1 NEW ORPRIMARY
+2 ;
+3 ; For testing purposes, OR SIMULATE ON EHR can be used to have this API return a 1 in a non-prod account
+4 IF '$$PROD^XUPROD
IF $$GET^XPAR("ALL","OR SIMULATE ON EHR",1,"I")
QUIT 1
+5 ;
+6 SET ORPRIMARY=$PIECE($$SITE^VASITE,U,3)
+7 ;ICR #7346
QUIT $$CRNRSITE^VAFCCRNR(ORPRIMARY)
+8 ;
EHRACTIVE(ORY) ;
+1 SET ORY=$$ONEHR
+2 QUIT
+3 ;
TABNAMES(TABS) ;
+1 NEW IDX,DATA,LINE,SUB
+2 SET IDX=0
SET LINE="ORTABINFO"
+3 FOR
SET IDX=IDX+1
SET DATA=$PIECE($TEXT(@LINE+IDX),";;",2)
if DATA=""
QUIT
Begin DoDot:1
+4 ;F SUB=1:1:5 S ORTABS(IDX,SUB)=$P(DATA,U,SUB)
+5 SET TABS($PIECE(DATA,U,3))=$PIECE(DATA,U,4)
End DoDot:1
+6 QUIT
+7 ;
HELP ;
+1 WRITE !,"Select the copy action:",!
+2 WRITE !," Copy/Add settings - Select Copy/Add settings to add the settings"
+3 WRITE !," from the initial user to the receiving user, without overwriting"
+4 WRITE !," any existing settings.",!
+5 WRITE !," Copy/Overwrite settings - Select Copy/Overwrite settings to replace"
+6 WRITE !," the receiving user settings with the initial user settings.",!
+7 WRITE !," Skip User - do not copy any of the user settings."
+8 QUIT
