- 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