MAGJPRF1 ;WIRMFO/JHC - VistARad RPCs-User Prefs ; 10/17/2022
;;3.0;IMAGING;**18,115,341**;Dec 21, 2022;Build 28
;; Per VHA Directive 2004-038, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
;; ISI IMAGING;**103**
Q
ERR ;
N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR
D @^%ZOSF("ERRTN")
Q:$Q 1 Q
;
;+++++ VistARad Client Operations on the MAGJ USER DATA file (#2006.68).
;
RPCIN(MAGGRY,PARAMS,DATA) ; RPC: MAGJ USER DATA
;PARAMS: TXID ^ SYSUPDAT ^ TXDUZ ^ TXDIV
;TXID: Req'd--action to take; see below
;TXDUZ: Opt; if input, get data for another user
;TXDIV: Opt; if input, get data for another div
;SYSUPDAT: Opt; if input, save Sys Default data; Sec Key Req'd
; DATA--(opt) input array; depends on TXID; see subs by TXID
;Pattern for DATA input & reply is:
;*LABEL ; Start for one label
;Label_Name ; label name
;(1:N lines of XML text follow)
;*END ; end for label
;*LABEL ; Start for next label (etc.)
;Label_Name_2
;*KEY ; index keys to follow (KEY data is opt)
;KeyNam1=nnn ; 1st key (free-text)
;KeyNam2=jjj ; 2nd key (etc.)
;*END_KEY ; end of keys
; (1:N lines of XML text follow)
;*END ; end for label
;
N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJPRF1"
N GPREF,MAGLST,PDIV,PREFIEN,READONLY,REPLY,SYSUPDAT,TXDIV,TXDUZ,TXID,TXTYPE
S TXID=+PARAMS,SYSUPDAT=+$P(PARAMS,U,2),TXDUZ=$P(PARAMS,U,3),TXDIV=+$P(PARAMS,U,4)
S MAGLST="MAGJRPC" K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY
N DIQUIET S DIQUIET=1 D DT^DICRW
; no updates allowed if read another user's data, or get data for another logon division
I 'TXDUZ,(TXDUZ="sysAdmin") S TXDUZ=$$SYSUSER()
I 'TXDUZ S TXDUZ=DUZ
I 'TXDIV S TXDIV=DUZ(2)
S READONLY=(TXDUZ'=DUZ)
; I 'READONLY S READONLY=(TXDIV'=DUZ(2)) ; <*> ?? Put this check inside Div-sensitive operations <*>
I READONLY,$D(MAGJOB("KEYS","MAGJ SYSTEM USER")),SYSUPDAT,(TXDUZ=$$SYSUSER()) S READONLY=0 ; get/update SysDefault data
S PREFIEN=$$GETPRIEN(TXDUZ,READONLY)
I 'PREFIEN S REPLY="0~Unable to get/update user data ("_$$USER(TXDUZ)_") for MAGJ USER DATA rpc call." G RPCINZ
; set this level based on the TXID
S TXID=+$G(TXID)
;
;--- Workstation settings, user preferences, etc.
S TXTYPE="VR-WS",GPREF=$NA(^MAG(2006.68,PREFIEN,TXTYPE)),PDIV=""
I TXID=1 G:'READONLY SAVE S REPLY="Access for updating preferences denied." G RPCINZ ; Store prefs by label
I TXID=2 G TAGS ; Get Labels w/ assoc. Keys
I TXID=3 G PRFDATA ; Get pref data for labels
I TXID=4 G:'READONLY TAGDEL S REPLY="Access for deleting preferences denied." G RPCINZ ; Delete labels
I TXID=6 G USERS ; Get list of vrad users, including SysAdmin
;
;--- Hanging Protocols
S TXTYPE="VR-HP",GPREF=$NA(^MAG(2006.68,PREFIEN,TXTYPE)),PDIV=""
I TXID=11 G:'READONLY SAVE S REPLY="Access for updating Hanging Protocols denied." G RPCINZ ; Store HP by label
I TXID=12 G TAGS ; Get HP Labels
I TXID=13 G PRFDATA ; Get data for HP labels
I TXID=14 G:'READONLY TAGDEL S REPLY="Access for deleting Hanging Protocol denied." G RPCINZ ; Delete HP labels
;
;--- Single call batch delete of either VR-WS or VR-HP tags (MAG*3.0*115).
I TXID=15 G:'READONLY TAGDEL2 S REPLY="Access for deleting preferences denied." G RPCINZ
I TXID=16 G:'READONLY TAGDEL2 S REPLY="Access for deleting Hanging Protocols denied." G RPCINZ
;
E S REPLY="0~Invalid transaction (TX="_TXID_") requested by MAGJ USER DATA rpc call."
RPCINZ ;
S @MAGGRY@(0)=0_U_REPLY
Q
;
;+++++ Get existing or newly created IEN of a MAGJ USER DATA entry for input DUZ.
;
; Internal utility function called by RPCIN+33.
;
GETPRIEN(DUZ,READONLY) ; Lookup/create User Pref entry for input DUZ
; READONLY: True for lookup-only (no create)
N PREFIEN,T,X
S PREFIEN=$O(^MAG(2006.68,"AC",+DUZ,"")) I 'PREFIEN,'READONLY D
. L +^MAG(2006.68,0):10
. E Q
. ;
. ;--- Get next IEN & upd8 overhead node.
. S X=$G(^MAG(2006.68,0))
. S PREFIEN=+$P(X,U,3)
. F S PREFIEN=PREFIEN+1 I '$D(^MAG(2006.68,PREFIEN)) Q
. S T=$P(X,U,4)+1,$P(X,U,3)=PREFIEN,$P(X,U,4)=T
. S ^MAG(2006.68,0)=X
. ;
. ;--- Set new entry & cross references.
. S T=$$USER(+DUZ),^MAG(2006.68,PREFIEN,0)=$P(T,U)_U_+DUZ_U_$P(T,U,3)
. S ^MAG(2006.68,"B",$P(T,U),PREFIEN)=""
. S ^MAG(2006.68,"AC",+DUZ,PREFIEN)=""
. L -^MAG(2006.68,0)
Q PREFIEN
;
;+++++ Save User Preference XML data by Label.
;
; Internal entry point branched to by RPCIN if TXID=1 or TXID=11.
;
SAVE ; Save User Pref data by Label
N DUMMY,KEYCT,KEYS,LBLCT,LINCT,NEWTAG,STUFF,TAGCT,TAGIEN
S (DUMMY,KEYCT,KEYS,LBLCT,LINCT,NEWTAG,STUFF,TAGCT,TAGIEN)=0
N IDATA,LINE S (IDATA,LINE)=""
F S IDATA=$O(DATA(IDATA)) Q:IDATA="" S LINE=DATA(IDATA) I LINE]"" D
. I LINE="*LABEL" S NEWTAG=1,STUFF=0 Q
. I LINE="*END" S NEWTAG=0,STUFF=0 Q
. I NEWTAG S TAG=LINE D TAGINIT(TAG) Q ; Init the storage for this tag
. I 'STUFF S TAG="*DUM" D TAGINIT(TAG) ; got text line w/out prior label; init dummy tag
. S TAGCT=TAGCT+1,@GPREF@(TAGIEN,1,TAGCT,0)=LINE,LINCT=LINCT+1
. S $P(@GPREF@(TAGIEN,1,0),U,3,4)=TAGCT_U_TAGCT
. I TAG="*DUM" S LINCT=LINCT-1 ; don't count dummy lines/labels
. I LINE="*KEY" S KEYS=1
. I KEYS D
. . S KEYCT=+$P($G(@GPREF@(TAGIEN,2,0)),U,4)+1,^(0)="^2006.6823^"_KEYCT_U_KEYCT
. . S @GPREF@(TAGIEN,2,KEYCT,0)=LINE
. I LINE="*END_KEY" S KEYS=0
I LINCT S REPLY=1_"~"_LINCT_" Text line"_$S(LINCT-1:"s",1:"")_" were stored for "_LBLCT_" label"_$S(LBLCT-1:"s.",1:".")
E S REPLY="0~No data was stored."
S @MAGGRY@(0)=0_U_REPLY
Q
;
;+++++ Initialize a single User Preference tag, and some variables for SAVE.
;
; Internal entry point called by SAVE+7, SAVE+8.
;
TAGINIT(TAG) ; Init storage space for a tag; inits some vars for SAVE
N TAGCTRL
I PDIV,(TAG'="*DUM") S TAG=PDIV_"*DIV*"_TAG ; tags tracked by division
S TAGIEN=$O(@GPREF@("B",TAG,"")) I 'TAGIEN D ; for new tag, create a new LABEL node,
. L +@GPREF@(0):10
. E Q
. S X=$G(@GPREF@(0)) S:X="" X="^2006.682A^0^0"
. S TAGIEN=$P(X,U,3)
. F S TAGIEN=TAGIEN+1 I '$D(@GPREF@(TAGIEN)) Q
. S T=$P(X,U,4)+1,$P(X,U,3)=TAGIEN,$P(X,U,4)=T
. S @GPREF@(0)=X,@GPREF@("B",TAG,TAGIEN)=""
. L -@GPREF@(0)
. S $P(@GPREF@(TAGIEN,0),U)=TAG
I TAG'="*DUM"!((TAG="*DUM")&'DUMMY) D
. S TAGCTRL=$G(@GPREF@(TAGIEN,1,0)) K @GPREF@(TAGIEN,1),^(2) ; init Data & Keys
. S $P(TAGCTRL,U,2)=2006.6821,$P(TAGCTRL,U,3,4)=0_U_0
. S @GPREF@(TAGIEN,1,0)=TAGCTRL
. S TAGCT=0,LBLCT=LBLCT+1
I TAG="*DUM" S TAGCT=+$P(@GPREF@(TAGIEN,1,0),U,3),LBLCT=LBLCT-'DUMMY,DUMMY=1 ; don't count dummy label
S NEWTAG=0,STUFF=1
Q
;
;+++++ Return list of workstation or hanging protocol User Preference tags for a user.
;
; Internal entry point branched to by RPCIN if TXID=2 or TXID=12.
;
TAGS ; return list of tags stored
; don't report *DUM tags
N CT,OTAG,TAG,TAGCT,TAGIEN
S (CT,TAG,TAGCT)=0
F S TAG=$O(@GPREF@("B",TAG)) Q:TAG="" S TAGIEN=$O(^(TAG,"")) I TAG'="*DUM" D
. I PDIV Q:PDIV'=+TAG S OTAG=$P(TAG,"*DIV*",2,99)
. E S OTAG=TAG
. S CT=CT+1,@MAGGRY@(CT)=OTAG,TAGCT=TAGCT+1
. I $D(@GPREF@(TAGIEN,2)) D
. . N KEYCT S KEYCT=0
. . F S KEYCT=$O(@GPREF@(TAGIEN,2,KEYCT)) Q:'KEYCT S X=^(KEYCT,0),CT=CT+1,@MAGGRY@(CT)=X
I TAGCT S REPLY=1_"~"_TAGCT_" tag"_$S(TAGCT-1:"s",1:"")_" returned."
E S REPLY="0~No data found."
S @MAGGRY@(0)=CT_U_REPLY
Q
;
SYSUSER(X) ; get System user DUZ value
S X=.5 ; =Postmaster
Q:$Q X Q
;
USER(DUZ) ; get user name, initials & vrad user type
N RSL,X S RSL=DUZ
I DUZ=$$SYSUSER() S RSL="sysAdmin^SYS^9"
E I DUZ D
. S RSL=$$USERINF^MAGJUTL3(DUZ,".01;1")
. F X="S","R","T" I $D(^VA(200,"ARC",X,DUZ)) Q
. I S X=$S(X="S":3,X="R":2,X="T":1,1:0)
. E S X=0
. S RSL=RSL_U_X
Q:$Q RSL Q
;
;+++++ List MAGJ USER DATA File (#2006.28) user entries.
;
; Internal Entry Point branched to from tag RPCIN if TXID=6.
;
; Returns:
;
; ^(0)
; ^1: Count
; ^2: Reply Message
; ^(1:n)
; ^1: DUZ
; ^2: FULL NAME
; ^3: INITIALS
; ^4: USER TYPE
;
; Notes
; =====
;
; Screened off are 1) The current user & 2) terminated or DISUSER'd users.
; If a terminated/DISUSER'd user's profile is still in use as a default
; profile, their entry will only be returned as its default. A terminated
; or DISUSER'd POSTMASTER (System User) is exempted from the screen.
;
; Sorting: Default profiles/System User/Radiologists/Non-Rist's.
;
USERS ;
N CT,IEN,INIT,NAME,REPLY,TOUT,USERDUZ,USERTYP
S (CT,IEN)=0
F S IEN=$O(^MAG(2006.68,IEN)) Q:'IEN S X=^(IEN,0) D
. S USERDUZ=$P(X,U,2)
. S X=$$USER(USERDUZ),NAME=$P(X,U),INIT=$P(X,U,2),USERTYP=$P(X,U,3)
. S:NAME="" NAME="~"
. ;
. ;--- Filter Terminants & DISUSER'd Users, except System User (MAG*3.0*115).
. S:($$ZRUACTIV(USERDUZ)!(USERDUZ=$$SYSUSER())) TOUT(-USERTYP,NAME,USERDUZ)=INIT
. ;
. ;--- Create dummies if profile is a default user profile ; ISI p103
. N MAGJDUMY S MAGJDUMY=$$ZRUDFALT(IEN) Q:MAGJDUMY="" S CT=CT+1
. S TOUT(-(1000-CT),MAGJDUMY,"D*"_USERDUZ)=INIT
S CT=0,USERTYP="" F S USERTYP=$O(TOUT(USERTYP)) Q:USERTYP="" S NAME="" D
. F S NAME=$O(TOUT(USERTYP,NAME)) Q:NAME="" S USERDUZ="" D
. . F S USERDUZ=$O(TOUT(USERTYP,NAME,USERDUZ)) Q:USERDUZ="" D
. . . S CT=CT+1,@MAGGRY@(CT)=USERDUZ_U_NAME_U_TOUT(USERTYP,NAME,USERDUZ)_U_-USERTYP
I CT S REPLY=1_"~"_CT_" user"_$S(CT-1:"s",1:"")_" returned."
E S REPLY="0~No data found."
S @MAGGRY@(0)=CT_U_REPLY
Q
;
;+++++ Return XML User Preference data for input Labels.
;
; Internal entry point branched to by tag RPCIN if TXID=3 or TXID=13.
;
PRFDATA ; RETURN data stored for input Labels
N CT,IDATA,LINCT,NTAGS,OTAG,TAG,TAGCT,TAGIEN,TAGS,X
S IDATA="",(CT,LINCT,NTAGS)=0
F S IDATA=$O(DATA(IDATA)) Q:IDATA="" S TAG=DATA(IDATA) I TAG]"" D
. I PDIV,(TAG'="*DUM") S TAG=PDIV_"*DIV*"_TAG ; tags tracked by div
. S TAGS(TAG)=""
S TAG=0
F S TAG=$O(TAGS(TAG)) Q:TAG="" D
. S TAGIEN=$O(@GPREF@("B",TAG,"")),NTAGS=NTAGS+1
. S OTAG=TAG I PDIV S OTAG=$P(TAG,"*DIV*",2,99)
. S CT=CT+1,@MAGGRY@(CT)="*LABEL"
. S CT=CT+1,@MAGGRY@(CT)=OTAG
. I TAGIEN S TAGCT=0 D
. . F S TAGCT=$O(@GPREF@(TAGIEN,1,TAGCT)) Q:'TAGCT S X=^(TAGCT,0),CT=CT+1,@MAGGRY@(CT)=X,LINCT=LINCT+1
. S CT=CT+1,@MAGGRY@(CT)="*END"
I CT S REPLY=1_"~"_LINCT_" Text line"_$S(LINCT-1:"s",1:"")_" returned for "_NTAGS_" tags."
E S REPLY="0~No data found."
S @MAGGRY@(0)=CT_U_REPLY
Q
;
;+++++ Delete XML User Preference data for input Labels.
;
; Internal entry point branched to by tag RPCIN if TXID=4 or TXID=14.
;
TAGDEL ; Delete tags and assoc data. RPCIN calls only if 'READONLY.
N CT,ERR,IDATA,TAG,TAGIEN
S (CT,TAG)=0,(ERR,IDATA)=""
F S IDATA=$O(DATA(IDATA)) Q:IDATA="" S TAG=DATA(IDATA) I TAG]"" D
. I PDIV,(TAG'="*DUM") S TAG=PDIV_"*DIV*"_TAG ; tags tracked by div
. S TAGIEN=$O(@GPREF@("B",TAG,"")) I TAGIEN D
. . L +@GPREF@(0):10 I $T D
. . . K @GPREF@(TAGIEN),@GPREF@("B",TAG)
. . . S X=$G(@GPREF@(0),"^2006.682A^0^0") S T=+$P(X,U,4) S:T T=T-1 S $P(X,U,4)=T,^(0)=X
. . . S CT=CT+1
. . . L -@GPREF@(0)
. . E D
. . . S ERR="0~Unable to perform Delete operation."
I CT S REPLY=1_"~"_CT_" label"_$S(CT-1:"s",1:"")_" deleted."
E S REPLY=$S(ERR]"":ERR,1:"0~No label data found.")
S @MAGGRY@(0)=0_U_REPLY
Q
;
;+++++ DELETE ALL SUB-FILE ENTRIES FOR WORKSTATION OR HANGING PROTOCOL DATA
;
; Internal entry point branched to by tag RPCIN if TXID=15 or TXID=16.
;
; Expects DUZ,MAGGRY,TXID
;
; Returns (in @MAGGRY):
;
; ^(0)
; ^1: 0 -- normal execution w/ reply string to follow.
; ^2: reply string w/ number/type of nodes deleted, or ...
; ... reason request not processed.
;
TAGDEL2 ;
N RETMSG
D
. N SUBDATA S SUBDATA=$S(TXID=15:"VR-HP",TXID=16:"VR-WS",1:0)
. I SUBDATA=0 S RETMSG="Invalid request: "_TXID_"." Q
. ;
. ;--- Lookup D0 from DUZ via ^DIC from the "AC" x-ref, or return notFound.
. N XIEN S XIEN=$$FIND1^DIC(2006.68,"","Q",DUZ,"AC","","")
. I 'XIEN S RETMSG="No user entry in MAGJ USER DATA File." Q
. ;
. ;--- Initialize ^DIK call to delete requested tag data.
. N DA,DIK
. S DA(1)=XIEN,DIK="^MAG(2006.68,"_DA(1)_","""_SUBDATA_""","
. ;
. ;--- Quit and report if "MAGJ USER DATA sub-file not found."
. N MAGNOD S MAGNOD=DIK_"0)"
. I '$D(@MAGNOD) S RETMSG="MAGJ USER DATA sub-file not found." Q
. ;
. ;--- Lock node, initialize counter & traverse for DA values to KILL.
. L +^MAG(2006.68,DA(1),SUBDATA):5 I $T D
. . N MAGCT S MAGCT=0
. . S DA="A"
. . F S DA=$O(^MAG(2006.68,DA(1),SUBDATA,DA),-1) Q:DA=0 D ^DIK S MAGCT=MAGCT+1
. . ;
. . ;--- Clean up dangling cross-references, set reply, & unlock.
. . K:$D(^MAG(2006.68,DA(1),SUBDATA,"B")) ^MAG(2006.68,DA(1),SUBDATA,"B")
. . S RETMSG=MAGCT_" "_SUBDATA_" nodes deleted."
. . L -^MAG(2006.68,DA(1),SUBDATA)
. . Q
. E D
. . S RETMSG="Unable to lock MAGJ USER DATA File."
. . Q
. Q
;
S @MAGGRY@(0)=0_U_RETMSG
Q
;
;+++++ Check if user terminated, or inactivated by DISUSER flag (MAG*3.0*115).
;
; Internal utility function called from USERS+9.
;
; Input: DUZ of user to check.
;
; Returns: 0 ... User is inactive.
; 1 ... User is active.
;
ZRUACTIV(CHKDUZ) ;
N YNACTIVE
S YNACTIVE=0 D
. N VADISUSR,VATERMDT
. S VADISUSR=$$GET1^DIQ(200,CHKDUZ_",",7,"I") Q:VADISUSR=1
. S VATERMDT=$$GET1^DIQ(200,CHKDUZ_",",9.2,"I")
. I $D(VATERMDT) N X,X1,X2 S X1=$$DT^XLFDT(),X2=VATERMDT D ^%DTC Q:X>0
. S YNACTIVE=1
Q YNACTIVE
;
;+++++ Check if a MAGJ USER DATA entry is designated as a default profile.
;
; Internal utility function called from USERS+12.
;
; Input: CHKIEN ... IEN of a MAGJ USER DATA File (#2006.68) entry.
;
; Returns: DEFFLAG
; null ... not a default
; default radiologist profile ... default
; default non-radiologist profile ... default
;
ZRUDFALT(CHKIEN) ;
;
;--- Set the IMAGING SITE PARAMETERS IEN.
N ISPIEN S ISPIEN=+$$IMGSIT^MAGJUTL1(DUZ(2),1)
;
;--- Retrieve default profile pointers from IMAGING SITE PARAMETERS (#2006.1).
N MAGNOD S MAGNOD=$G(^MAG(2006.1,ISPIEN,5))
N DEFFLAG,DEFNON,DEFRAD S DEFRAD=$P(MAGNOD,U,7),DEFNON=$P(MAGNOD,U,8)
;
S DEFFLAG=$S(CHKIEN=DEFRAD:"RADIOLOGIST",CHKIEN=DEFNON:"NON-RADIOLOGIST",1:"")
S:DEFFLAG'="" DEFFLAG="DEFAULT "_DEFFLAG_" PROFILE"
Q DEFFLAG
;
;
END ;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGJPRF1 15424 printed Nov 22, 2024@17:17 Page 2
MAGJPRF1 ;WIRMFO/JHC - VistARad RPCs-User Prefs ; 10/17/2022
+1 ;;3.0;IMAGING;**18,115,341**;Dec 21, 2022;Build 28
+2 ;; Per VHA Directive 2004-038, this routine should not be modified.
+3 ;; +---------------------------------------------------------------+
+4 ;; | Property of the US Government. |
+5 ;; | No permission to copy or redistribute this software is given. |
+6 ;; | Use of unreleased versions of this software requires the user |
+7 ;; | to execute a written test agreement with the VistA Imaging |
+8 ;; | Development Office of the Department of Veterans Affairs, |
+9 ;; | telephone (301) 734-0100. |
+10 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 ;; ISI IMAGING;**103**
+18 QUIT
ERR ;
+1 NEW ERR
SET ERR=$$EC^%ZOSV
SET @MAGGRY@(0)="0^4~"_ERR
+2 DO @^%ZOSF("ERRTN")
+3 if $QUIT
QUIT 1
QUIT
+4 ;
+5 ;+++++ VistARad Client Operations on the MAGJ USER DATA file (#2006.68).
+6 ;
RPCIN(MAGGRY,PARAMS,DATA) ; RPC: MAGJ USER DATA
+1 ;PARAMS: TXID ^ SYSUPDAT ^ TXDUZ ^ TXDIV
+2 ;TXID: Req'd--action to take; see below
+3 ;TXDUZ: Opt; if input, get data for another user
+4 ;TXDIV: Opt; if input, get data for another div
+5 ;SYSUPDAT: Opt; if input, save Sys Default data; Sec Key Req'd
+6 ; DATA--(opt) input array; depends on TXID; see subs by TXID
+7 ;Pattern for DATA input & reply is:
+8 ;*LABEL ; Start for one label
+9 ;Label_Name ; label name
+10 ;(1:N lines of XML text follow)
+11 ;*END ; end for label
+12 ;*LABEL ; Start for next label (etc.)
+13 ;Label_Name_2
+14 ;*KEY ; index keys to follow (KEY data is opt)
+15 ;KeyNam1=nnn ; 1st key (free-text)
+16 ;KeyNam2=jjj ; 2nd key (etc.)
+17 ;*END_KEY ; end of keys
+18 ; (1:N lines of XML text follow)
+19 ;*END ; end for label
+20 ;
+21 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERR^MAGJPRF1"
+22 NEW GPREF,MAGLST,PDIV,PREFIEN,READONLY,REPLY,SYSUPDAT,TXDIV,TXDUZ,TXID,TXTYPE
+23 SET TXID=+PARAMS
SET SYSUPDAT=+$PIECE(PARAMS,U,2)
SET TXDUZ=$PIECE(PARAMS,U,3)
SET TXDIV=+$PIECE(PARAMS,U,4)
+24 SET MAGLST="MAGJRPC"
KILL MAGGRY
SET MAGGRY=$NAME(^TMP($JOB,MAGLST))
KILL @MAGGRY
+25 NEW DIQUIET
SET DIQUIET=1
DO DT^DICRW
+26 ; no updates allowed if read another user's data, or get data for another logon division
+27 IF 'TXDUZ
IF (TXDUZ="sysAdmin")
SET TXDUZ=$$SYSUSER()
+28 IF 'TXDUZ
SET TXDUZ=DUZ
+29 IF 'TXDIV
SET TXDIV=DUZ(2)
+30 SET READONLY=(TXDUZ'=DUZ)
+31 ; I 'READONLY S READONLY=(TXDIV'=DUZ(2)) ; <*> ?? Put this check inside Div-sensitive operations <*>
+32 ; get/update SysDefault data
IF READONLY
IF $DATA(MAGJOB("KEYS","MAGJ SYSTEM USER"))
IF SYSUPDAT
IF (TXDUZ=$$SYSUSER())
SET READONLY=0
+33 SET PREFIEN=$$GETPRIEN(TXDUZ,READONLY)
+34 IF 'PREFIEN
SET REPLY="0~Unable to get/update user data ("_$$USER(TXDUZ)_") for MAGJ USER DATA rpc call."
GOTO RPCINZ
+35 ; set this level based on the TXID
+36 SET TXID=+$GET(TXID)
+37 ;
+38 ;--- Workstation settings, user preferences, etc.
+39 SET TXTYPE="VR-WS"
SET GPREF=$NAME(^MAG(2006.68,PREFIEN,TXTYPE))
SET PDIV=""
+40 ; Store prefs by label
IF TXID=1
if 'READONLY
GOTO SAVE
SET REPLY="Access for updating preferences denied."
GOTO RPCINZ
+41 ; Get Labels w/ assoc. Keys
IF TXID=2
GOTO TAGS
+42 ; Get pref data for labels
IF TXID=3
GOTO PRFDATA
+43 ; Delete labels
IF TXID=4
if 'READONLY
GOTO TAGDEL
SET REPLY="Access for deleting preferences denied."
GOTO RPCINZ
+44 ; Get list of vrad users, including SysAdmin
IF TXID=6
GOTO USERS
+45 ;
+46 ;--- Hanging Protocols
+47 SET TXTYPE="VR-HP"
SET GPREF=$NAME(^MAG(2006.68,PREFIEN,TXTYPE))
SET PDIV=""
+48 ; Store HP by label
IF TXID=11
if 'READONLY
GOTO SAVE
SET REPLY="Access for updating Hanging Protocols denied."
GOTO RPCINZ
+49 ; Get HP Labels
IF TXID=12
GOTO TAGS
+50 ; Get data for HP labels
IF TXID=13
GOTO PRFDATA
+51 ; Delete HP labels
IF TXID=14
if 'READONLY
GOTO TAGDEL
SET REPLY="Access for deleting Hanging Protocol denied."
GOTO RPCINZ
+52 ;
+53 ;--- Single call batch delete of either VR-WS or VR-HP tags (MAG*3.0*115).
+54 IF TXID=15
if 'READONLY
GOTO TAGDEL2
SET REPLY="Access for deleting preferences denied."
GOTO RPCINZ
+55 IF TXID=16
if 'READONLY
GOTO TAGDEL2
SET REPLY="Access for deleting Hanging Protocols denied."
GOTO RPCINZ
+56 ;
+57 IF '$TEST
SET REPLY="0~Invalid transaction (TX="_TXID_") requested by MAGJ USER DATA rpc call."
RPCINZ ;
+1 SET @MAGGRY@(0)=0_U_REPLY
+2 QUIT
+3 ;
+4 ;+++++ Get existing or newly created IEN of a MAGJ USER DATA entry for input DUZ.
+5 ;
+6 ; Internal utility function called by RPCIN+33.
+7 ;
GETPRIEN(DUZ,READONLY) ; Lookup/create User Pref entry for input DUZ
+1 ; READONLY: True for lookup-only (no create)
+2 NEW PREFIEN,T,X
+3 SET PREFIEN=$ORDER(^MAG(2006.68,"AC",+DUZ,""))
IF 'PREFIEN
IF 'READONLY
Begin DoDot:1
+4 LOCK +^MAG(2006.68,0):10
+5 IF '$TEST
QUIT
+6 ;
+7 ;--- Get next IEN & upd8 overhead node.
+8 SET X=$GET(^MAG(2006.68,0))
+9 SET PREFIEN=+$PIECE(X,U,3)
+10 FOR
SET PREFIEN=PREFIEN+1
IF '$DATA(^MAG(2006.68,PREFIEN))
QUIT
+11 SET T=$PIECE(X,U,4)+1
SET $PIECE(X,U,3)=PREFIEN
SET $PIECE(X,U,4)=T
+12 SET ^MAG(2006.68,0)=X
+13 ;
+14 ;--- Set new entry & cross references.
+15 SET T=$$USER(+DUZ)
SET ^MAG(2006.68,PREFIEN,0)=$PIECE(T,U)_U_+DUZ_U_$PIECE(T,U,3)
+16 SET ^MAG(2006.68,"B",$PIECE(T,U),PREFIEN)=""
+17 SET ^MAG(2006.68,"AC",+DUZ,PREFIEN)=""
+18 LOCK -^MAG(2006.68,0)
End DoDot:1
+19 QUIT PREFIEN
+20 ;
+21 ;+++++ Save User Preference XML data by Label.
+22 ;
+23 ; Internal entry point branched to by RPCIN if TXID=1 or TXID=11.
+24 ;
SAVE ; Save User Pref data by Label
+1 NEW DUMMY,KEYCT,KEYS,LBLCT,LINCT,NEWTAG,STUFF,TAGCT,TAGIEN
+2 SET (DUMMY,KEYCT,KEYS,LBLCT,LINCT,NEWTAG,STUFF,TAGCT,TAGIEN)=0
+3 NEW IDATA,LINE
SET (IDATA,LINE)=""
+4 FOR
SET IDATA=$ORDER(DATA(IDATA))
if IDATA=""
QUIT
SET LINE=DATA(IDATA)
IF LINE]""
Begin DoDot:1
+5 IF LINE="*LABEL"
SET NEWTAG=1
SET STUFF=0
QUIT
+6 IF LINE="*END"
SET NEWTAG=0
SET STUFF=0
QUIT
+7 ; Init the storage for this tag
IF NEWTAG
SET TAG=LINE
DO TAGINIT(TAG)
QUIT
+8 ; got text line w/out prior label; init dummy tag
IF 'STUFF
SET TAG="*DUM"
DO TAGINIT(TAG)
+9 SET TAGCT=TAGCT+1
SET @GPREF@(TAGIEN,1,TAGCT,0)=LINE
SET LINCT=LINCT+1
+10 SET $PIECE(@GPREF@(TAGIEN,1,0),U,3,4)=TAGCT_U_TAGCT
+11 ; don't count dummy lines/labels
IF TAG="*DUM"
SET LINCT=LINCT-1
+12 IF LINE="*KEY"
SET KEYS=1
+13 IF KEYS
Begin DoDot:2
+14 SET KEYCT=+$PIECE($GET(@GPREF@(TAGIEN,2,0)),U,4)+1
SET ^(0)="^2006.6823^"_KEYCT_U_KEYCT
+15 SET @GPREF@(TAGIEN,2,KEYCT,0)=LINE
End DoDot:2
+16 IF LINE="*END_KEY"
SET KEYS=0
End DoDot:1
+17 IF LINCT
SET REPLY=1_"~"_LINCT_" Text line"_$SELECT(LINCT-1:"s",1:"")_" were stored for "_LBLCT_" label"_$SELECT(LBLCT-1:"s.",1:".")
+18 IF '$TEST
SET REPLY="0~No data was stored."
+19 SET @MAGGRY@(0)=0_U_REPLY
+20 QUIT
+21 ;
+22 ;+++++ Initialize a single User Preference tag, and some variables for SAVE.
+23 ;
+24 ; Internal entry point called by SAVE+7, SAVE+8.
+25 ;
TAGINIT(TAG) ; Init storage space for a tag; inits some vars for SAVE
+1 NEW TAGCTRL
+2 ; tags tracked by division
IF PDIV
IF (TAG'="*DUM")
SET TAG=PDIV_"*DIV*"_TAG
+3 ; for new tag, create a new LABEL node,
SET TAGIEN=$ORDER(@GPREF@("B",TAG,""))
IF 'TAGIEN
Begin DoDot:1
+4 LOCK +@GPREF@(0):10
+5 IF '$TEST
QUIT
+6 SET X=$GET(@GPREF@(0))
if X=""
SET X="^2006.682A^0^0"
+7 SET TAGIEN=$PIECE(X,U,3)
+8 FOR
SET TAGIEN=TAGIEN+1
IF '$DATA(@GPREF@(TAGIEN))
QUIT
+9 SET T=$PIECE(X,U,4)+1
SET $PIECE(X,U,3)=TAGIEN
SET $PIECE(X,U,4)=T
+10 SET @GPREF@(0)=X
SET @GPREF@("B",TAG,TAGIEN)=""
+11 LOCK -@GPREF@(0)
+12 SET $PIECE(@GPREF@(TAGIEN,0),U)=TAG
End DoDot:1
+13 IF TAG'="*DUM"!((TAG="*DUM")&'DUMMY)
Begin DoDot:1
+14 ; init Data & Keys
SET TAGCTRL=$GET(@GPREF@(TAGIEN,1,0))
KILL @GPREF@(TAGIEN,1),^(2)
+15 SET $PIECE(TAGCTRL,U,2)=2006.6821
SET $PIECE(TAGCTRL,U,3,4)=0_U_0
+16 SET @GPREF@(TAGIEN,1,0)=TAGCTRL
+17 SET TAGCT=0
SET LBLCT=LBLCT+1
End DoDot:1
+18 ; don't count dummy label
IF TAG="*DUM"
SET TAGCT=+$PIECE(@GPREF@(TAGIEN,1,0),U,3)
SET LBLCT=LBLCT-'DUMMY
SET DUMMY=1
+19 SET NEWTAG=0
SET STUFF=1
+20 QUIT
+21 ;
+22 ;+++++ Return list of workstation or hanging protocol User Preference tags for a user.
+23 ;
+24 ; Internal entry point branched to by RPCIN if TXID=2 or TXID=12.
+25 ;
TAGS ; return list of tags stored
+1 ; don't report *DUM tags
+2 NEW CT,OTAG,TAG,TAGCT,TAGIEN
+3 SET (CT,TAG,TAGCT)=0
+4 FOR
SET TAG=$ORDER(@GPREF@("B",TAG))
if TAG=""
QUIT
SET TAGIEN=$ORDER(^(TAG,""))
IF TAG'="*DUM"
Begin DoDot:1
+5 IF PDIV
if PDIV'=+TAG
QUIT
SET OTAG=$PIECE(TAG,"*DIV*",2,99)
+6 IF '$TEST
SET OTAG=TAG
+7 SET CT=CT+1
SET @MAGGRY@(CT)=OTAG
SET TAGCT=TAGCT+1
+8 IF $DATA(@GPREF@(TAGIEN,2))
Begin DoDot:2
+9 NEW KEYCT
SET KEYCT=0
+10 FOR
SET KEYCT=$ORDER(@GPREF@(TAGIEN,2,KEYCT))
if 'KEYCT
QUIT
SET X=^(KEYCT,0)
SET CT=CT+1
SET @MAGGRY@(CT)=X
End DoDot:2
End DoDot:1
+11 IF TAGCT
SET REPLY=1_"~"_TAGCT_" tag"_$SELECT(TAGCT-1:"s",1:"")_" returned."
+12 IF '$TEST
SET REPLY="0~No data found."
+13 SET @MAGGRY@(0)=CT_U_REPLY
+14 QUIT
+15 ;
SYSUSER(X) ; get System user DUZ value
+1 ; =Postmaster
SET X=.5
+2 if $QUIT
QUIT X
QUIT
+3 ;
USER(DUZ) ; get user name, initials & vrad user type
+1 NEW RSL,X
SET RSL=DUZ
+2 IF DUZ=$$SYSUSER()
SET RSL="sysAdmin^SYS^9"
+3 IF '$TEST
IF DUZ
Begin DoDot:1
+4 SET RSL=$$USERINF^MAGJUTL3(DUZ,".01;1")
+5 FOR X="S","R","T"
IF $DATA(^VA(200,"ARC",X,DUZ))
QUIT
+6 IF $TEST
SET X=$SELECT(X="S":3,X="R":2,X="T":1,1:0)
+7 IF '$TEST
SET X=0
+8 SET RSL=RSL_U_X
End DoDot:1
+9 if $QUIT
QUIT RSL
QUIT
+10 ;
+11 ;+++++ List MAGJ USER DATA File (#2006.28) user entries.
+12 ;
+13 ; Internal Entry Point branched to from tag RPCIN if TXID=6.
+14 ;
+15 ; Returns:
+16 ;
+17 ; ^(0)
+18 ; ^1: Count
+19 ; ^2: Reply Message
+20 ; ^(1:n)
+21 ; ^1: DUZ
+22 ; ^2: FULL NAME
+23 ; ^3: INITIALS
+24 ; ^4: USER TYPE
+25 ;
+26 ; Notes
+27 ; =====
+28 ;
+29 ; Screened off are 1) The current user & 2) terminated or DISUSER'd users.
+30 ; If a terminated/DISUSER'd user's profile is still in use as a default
+31 ; profile, their entry will only be returned as its default. A terminated
+32 ; or DISUSER'd POSTMASTER (System User) is exempted from the screen.
+33 ;
+34 ; Sorting: Default profiles/System User/Radiologists/Non-Rist's.
+35 ;
USERS ;
+1 NEW CT,IEN,INIT,NAME,REPLY,TOUT,USERDUZ,USERTYP
+2 SET (CT,IEN)=0
+3 FOR
SET IEN=$ORDER(^MAG(2006.68,IEN))
if 'IEN
QUIT
SET X=^(IEN,0)
Begin DoDot:1
+4 SET USERDUZ=$PIECE(X,U,2)
+5 SET X=$$USER(USERDUZ)
SET NAME=$PIECE(X,U)
SET INIT=$PIECE(X,U,2)
SET USERTYP=$PIECE(X,U,3)
+6 if NAME=""
SET NAME="~"
+7 ;
+8 ;--- Filter Terminants & DISUSER'd Users, except System User (MAG*3.0*115).
+9 if ($$ZRUACTIV(USERDUZ)!(USERDUZ=$$SYSUSER()))
SET TOUT(-USERTYP,NAME,USERDUZ)=INIT
+10 ;
+11 ;--- Create dummies if profile is a default user profile ; ISI p103
+12 NEW MAGJDUMY
SET MAGJDUMY=$$ZRUDFALT(IEN)
if MAGJDUMY=""
QUIT
SET CT=CT+1
+13 SET TOUT(-(1000-CT),MAGJDUMY,"D*"_USERDUZ)=INIT
End DoDot:1
+14 SET CT=0
SET USERTYP=""
FOR
SET USERTYP=$ORDER(TOUT(USERTYP))
if USERTYP=""
QUIT
SET NAME=""
Begin DoDot:1
+15 FOR
SET NAME=$ORDER(TOUT(USERTYP,NAME))
if NAME=""
QUIT
SET USERDUZ=""
Begin DoDot:2
+16 FOR
SET USERDUZ=$ORDER(TOUT(USERTYP,NAME,USERDUZ))
if USERDUZ=""
QUIT
Begin DoDot:3
+17 SET CT=CT+1
SET @MAGGRY@(CT)=USERDUZ_U_NAME_U_TOUT(USERTYP,NAME,USERDUZ)_U_-USERTYP
End DoDot:3
End DoDot:2
End DoDot:1
+18 IF CT
SET REPLY=1_"~"_CT_" user"_$SELECT(CT-1:"s",1:"")_" returned."
+19 IF '$TEST
SET REPLY="0~No data found."
+20 SET @MAGGRY@(0)=CT_U_REPLY
+21 QUIT
+22 ;
+23 ;+++++ Return XML User Preference data for input Labels.
+24 ;
+25 ; Internal entry point branched to by tag RPCIN if TXID=3 or TXID=13.
+26 ;
PRFDATA ; RETURN data stored for input Labels
+1 NEW CT,IDATA,LINCT,NTAGS,OTAG,TAG,TAGCT,TAGIEN,TAGS,X
+2 SET IDATA=""
SET (CT,LINCT,NTAGS)=0
+3 FOR
SET IDATA=$ORDER(DATA(IDATA))
if IDATA=""
QUIT
SET TAG=DATA(IDATA)
IF TAG]""
Begin DoDot:1
+4 ; tags tracked by div
IF PDIV
IF (TAG'="*DUM")
SET TAG=PDIV_"*DIV*"_TAG
+5 SET TAGS(TAG)=""
End DoDot:1
+6 SET TAG=0
+7 FOR
SET TAG=$ORDER(TAGS(TAG))
if TAG=""
QUIT
Begin DoDot:1
+8 SET TAGIEN=$ORDER(@GPREF@("B",TAG,""))
SET NTAGS=NTAGS+1
+9 SET OTAG=TAG
IF PDIV
SET OTAG=$PIECE(TAG,"*DIV*",2,99)
+10 SET CT=CT+1
SET @MAGGRY@(CT)="*LABEL"
+11 SET CT=CT+1
SET @MAGGRY@(CT)=OTAG
+12 IF TAGIEN
SET TAGCT=0
Begin DoDot:2
+13 FOR
SET TAGCT=$ORDER(@GPREF@(TAGIEN,1,TAGCT))
if 'TAGCT
QUIT
SET X=^(TAGCT,0)
SET CT=CT+1
SET @MAGGRY@(CT)=X
SET LINCT=LINCT+1
End DoDot:2
+14 SET CT=CT+1
SET @MAGGRY@(CT)="*END"
End DoDot:1
+15 IF CT
SET REPLY=1_"~"_LINCT_" Text line"_$SELECT(LINCT-1:"s",1:"")_" returned for "_NTAGS_" tags."
+16 IF '$TEST
SET REPLY="0~No data found."
+17 SET @MAGGRY@(0)=CT_U_REPLY
+18 QUIT
+19 ;
+20 ;+++++ Delete XML User Preference data for input Labels.
+21 ;
+22 ; Internal entry point branched to by tag RPCIN if TXID=4 or TXID=14.
+23 ;
TAGDEL ; Delete tags and assoc data. RPCIN calls only if 'READONLY.
+1 NEW CT,ERR,IDATA,TAG,TAGIEN
+2 SET (CT,TAG)=0
SET (ERR,IDATA)=""
+3 FOR
SET IDATA=$ORDER(DATA(IDATA))
if IDATA=""
QUIT
SET TAG=DATA(IDATA)
IF TAG]""
Begin DoDot:1
+4 ; tags tracked by div
IF PDIV
IF (TAG'="*DUM")
SET TAG=PDIV_"*DIV*"_TAG
+5 SET TAGIEN=$ORDER(@GPREF@("B",TAG,""))
IF TAGIEN
Begin DoDot:2
+6 LOCK +@GPREF@(0):10
IF $TEST
Begin DoDot:3
+7 KILL @GPREF@(TAGIEN),@GPREF@("B",TAG)
+8 SET X=$GET(@GPREF@(0),"^2006.682A^0^0")
SET T=+$PIECE(X,U,4)
if T
SET T=T-1
SET $PIECE(X,U,4)=T
SET ^(0)=X
+9 SET CT=CT+1
+10 LOCK -@GPREF@(0)
End DoDot:3
+11 IF '$TEST
Begin DoDot:3
+12 SET ERR="0~Unable to perform Delete operation."
End DoDot:3
End DoDot:2
End DoDot:1
+13 IF CT
SET REPLY=1_"~"_CT_" label"_$SELECT(CT-1:"s",1:"")_" deleted."
+14 IF '$TEST
SET REPLY=$SELECT(ERR]"":ERR,1:"0~No label data found.")
+15 SET @MAGGRY@(0)=0_U_REPLY
+16 QUIT
+17 ;
+18 ;+++++ DELETE ALL SUB-FILE ENTRIES FOR WORKSTATION OR HANGING PROTOCOL DATA
+19 ;
+20 ; Internal entry point branched to by tag RPCIN if TXID=15 or TXID=16.
+21 ;
+22 ; Expects DUZ,MAGGRY,TXID
+23 ;
+24 ; Returns (in @MAGGRY):
+25 ;
+26 ; ^(0)
+27 ; ^1: 0 -- normal execution w/ reply string to follow.
+28 ; ^2: reply string w/ number/type of nodes deleted, or ...
+29 ; ... reason request not processed.
+30 ;
TAGDEL2 ;
+1 NEW RETMSG
+2 Begin DoDot:1
+3 NEW SUBDATA
SET SUBDATA=$SELECT(TXID=15:"VR-HP",TXID=16:"VR-WS",1:0)
+4 IF SUBDATA=0
SET RETMSG="Invalid request: "_TXID_"."
QUIT
+5 ;
+6 ;--- Lookup D0 from DUZ via ^DIC from the "AC" x-ref, or return notFound.
+7 NEW XIEN
SET XIEN=$$FIND1^DIC(2006.68,"","Q",DUZ,"AC","","")
+8 IF 'XIEN
SET RETMSG="No user entry in MAGJ USER DATA File."
QUIT
+9 ;
+10 ;--- Initialize ^DIK call to delete requested tag data.
+11 NEW DA,DIK
+12 SET DA(1)=XIEN
SET DIK="^MAG(2006.68,"_DA(1)_","""_SUBDATA_""","
+13 ;
+14 ;--- Quit and report if "MAGJ USER DATA sub-file not found."
+15 NEW MAGNOD
SET MAGNOD=DIK_"0)"
+16 IF '$DATA(@MAGNOD)
SET RETMSG="MAGJ USER DATA sub-file not found."
QUIT
+17 ;
+18 ;--- Lock node, initialize counter & traverse for DA values to KILL.
+19 LOCK +^MAG(2006.68,DA(1),SUBDATA):5
IF $TEST
Begin DoDot:2
+20 NEW MAGCT
SET MAGCT=0
+21 SET DA="A"
+22 FOR
SET DA=$ORDER(^MAG(2006.68,DA(1),SUBDATA,DA),-1)
if DA=0
QUIT
DO ^DIK
SET MAGCT=MAGCT+1
+23 ;
+24 ;--- Clean up dangling cross-references, set reply, & unlock.
+25 if $DATA(^MAG(2006.68,DA(1),SUBDATA,"B"))
KILL ^MAG(2006.68,DA(1),SUBDATA,"B")
+26 SET RETMSG=MAGCT_" "_SUBDATA_" nodes deleted."
+27 LOCK -^MAG(2006.68,DA(1),SUBDATA)
+28 QUIT
End DoDot:2
+29 IF '$TEST
Begin DoDot:2
+30 SET RETMSG="Unable to lock MAGJ USER DATA File."
+31 QUIT
End DoDot:2
+32 QUIT
End DoDot:1
+33 ;
+34 SET @MAGGRY@(0)=0_U_RETMSG
+35 QUIT
+36 ;
+37 ;+++++ Check if user terminated, or inactivated by DISUSER flag (MAG*3.0*115).
+38 ;
+39 ; Internal utility function called from USERS+9.
+40 ;
+41 ; Input: DUZ of user to check.
+42 ;
+43 ; Returns: 0 ... User is inactive.
+44 ; 1 ... User is active.
+45 ;
ZRUACTIV(CHKDUZ) ;
+1 NEW YNACTIVE
+2 SET YNACTIVE=0
Begin DoDot:1
+3 NEW VADISUSR,VATERMDT
+4 SET VADISUSR=$$GET1^DIQ(200,CHKDUZ_",",7,"I")
if VADISUSR=1
QUIT
+5 SET VATERMDT=$$GET1^DIQ(200,CHKDUZ_",",9.2,"I")
+6 IF $DATA(VATERMDT)
NEW X,X1,X2
SET X1=$$DT^XLFDT()
SET X2=VATERMDT
DO ^%DTC
if X>0
QUIT
+7 SET YNACTIVE=1
End DoDot:1
+8 QUIT YNACTIVE
+9 ;
+10 ;+++++ Check if a MAGJ USER DATA entry is designated as a default profile.
+11 ;
+12 ; Internal utility function called from USERS+12.
+13 ;
+14 ; Input: CHKIEN ... IEN of a MAGJ USER DATA File (#2006.68) entry.
+15 ;
+16 ; Returns: DEFFLAG
+17 ; null ... not a default
+18 ; default radiologist profile ... default
+19 ; default non-radiologist profile ... default
+20 ;
ZRUDFALT(CHKIEN) ;
+1 ;
+2 ;--- Set the IMAGING SITE PARAMETERS IEN.
+3 NEW ISPIEN
SET ISPIEN=+$$IMGSIT^MAGJUTL1(DUZ(2),1)
+4 ;
+5 ;--- Retrieve default profile pointers from IMAGING SITE PARAMETERS (#2006.1).
+6 NEW MAGNOD
SET MAGNOD=$GET(^MAG(2006.1,ISPIEN,5))
+7 NEW DEFFLAG,DEFNON,DEFRAD
SET DEFRAD=$PIECE(MAGNOD,U,7)
SET DEFNON=$PIECE(MAGNOD,U,8)
+8 ;
+9 SET DEFFLAG=$SELECT(CHKIEN=DEFRAD:"RADIOLOGIST",CHKIEN=DEFNON:"NON-RADIOLOGIST",1:"")
+10 if DEFFLAG'=""
SET DEFFLAG="DEFAULT "_DEFFLAG_" PROFILE"
+11 QUIT DEFFLAG
+12 ;
+13 ;
END ;
