RORRP024 ;HCIOFO/SG - RPC: VISTA USERS ; 12/15/05 4:31pm
;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
;
; This routine uses the following IAs:
;
; #10060 Read access (FileMan) to the NEW PERSON file
;
Q
;
;***** RETURNS THE DEFAULT DIVISION FOR THE USER
;
; USER User IEN in file #200 (DUZ)
;
; Return Values:
; ... Default Division
; ^01: IEN (in the INSTITUTION file)
; ^02: Name
;
DFLTDIV(USER) ;
N DIV,IENS,IR,RORBUF,RORMSG,TMP
S IENS=","_(+USER)_",",TMP="@;.01I;.01E;1I"
D LIST^DIC(200.02,IENS,TMP,"PQ",,,,"#",,,"RORBUF","RORMSG")
D:$G(DIERR) DBS^RORERR("RORMSG",-9,,,200,IENS)
S DIV=""
;--- Look for default division
D:$G(RORBUF("DILIST",0))>0
. S IR=0
. F S IR=$O(RORBUF("DILIST",IR)) Q:IR'>0 D Q:DIV'=""
. . S TMP=$G(RORBUF("DILIST",IR,0))
. . S:$P(TMP,U,4) DIV=$P(TMP,U,2,3)
. ;--- If name of the default division is not available
. ; and the only division is associated with the user
. ;--- then use this division as the default one.
. I $P(DIV,U,2)="" D:RORBUF("DILIST",0)<2
. . S DIV=$P($G(RORBUF("DILIST",1,0)),U,2,3)
;--- If default division is not available, use the site
Q $S($P(DIV,U,2)'="":DIV,1:$P($$SITE^VASITE(),U,1,2))
;
;***** RETURNS INFORMATION ABOUT THE USER
; RPC: [ROR GET USER IFNO]
;
; .RESULTS Reference to a local variable where the results
; are returned to.
;
; [USER] User IEN in the NEW PERSON file. By default
; (if $G(USER)'>0), the DUZ is used).
;
; Return Values:
;
; A negative value of the first "^"-piece of the RESULTS(0)
; indicates an error (see the RPCSTK^RORERR procedure for more
; details).
;
; Otherwise, the user info is returned in the RESULTS(0).
;
; RESULTS(0) User Info
; ^01: IEN
; ^02: Name
; ^03: Office Phone
; ^04: Nickname
; ^05: Read Timeout
; ^06: Default Division IEN
; ^07: Default Division Name
; ^08: Institution IEN
; ^09: Institution Name
; ^10: Station Number (with suffix)
;
USERINFO(RESULTS,USER) ;
N IENS,RORBUF,RORERRDL,RORMSG,TMP
D CLEAR^RORERR("USERINFO^RORRP024",1)
K RESULTS S RESULTS(0)=0
I $G(USER)'>0 S USER=+$G(DUZ) Q:USER'>0
;--- Load the data
S IENS=USER_","
D GETS^DIQ(200,IENS,".01;.132;13",,"RORBUF","RORMSG")
I $G(DIERR) D D RPCSTK^RORERR(.RESULTS,RC) Q
. S RC=$$DBS^RORERR("RORMSG",-9,,,200) K ^TMP("DILIST",$J)
;--- Compile the result
S RESULTS(0)=USER
S $P(RESULTS(0),U,2)=$G(RORBUF(200,IENS,.01)) ; Name
S $P(RESULTS(0),U,3)=$G(RORBUF(200,IENS,.132)) ; Office Phone
S $P(RESULTS(0),U,4)=$G(RORBUF(200,IENS,13)) ; Nick Name
S $P(RESULTS(0),U,5)=$$DTIME^XUP(USER) ; Read Timeout
S TMP=$$DFLTDIV(USER)
S $P(RESULTS(0),U,6,7)=$P(TMP,U,1,2) ; Default Division
S $P(RESULTS(0),U,8,10)=$$SITE^VASITE()
Q
;
;***** RETURNS THE LIST OF VISTA USERS
; RPC: [ROR LIST VISTA USERS]
;
; .RESULTS Reference to a local variable where the results
; are returned to.
;
; PART The search pattern (partial match restriction)
;
; [FLAGS] Flags that control the execution (can be combined):
; B Backwards. Traverses the index in the opposite
; direction of normal traversal.
; D Get default division for each user
; P Select providers only (check for the PROVIDER
; security key)
;
; [NUMBER] Maximum number of entries to return. A value of "*"
; or no value in this parameter designates all entries.
;
; [FROM] The index entry(s) from which to begin the list.
; You should use the pieces of the @RESULTS@(0) node
; (starting from the second one) to continue the
; listing in the subsequent procedure calls.
;
; NOTE: The FROM value itself is not included in
; the resulting list.
;
; The ^TMP("DILIST",$J) global node is used by the procedure.
;
; See description of the LIST^DIC for more details about the
; PART, NUMBER and FROM parameters.
;
; Return Values:
;
; A negative value of the first "^"-piece of the RESULTS(0)
; indicates an error (see the RPCSTK^RORERR procedure for more
; details).
;
; Otherwise, number of VistA users and the value of the FROM
; parameter for the next procedure call are returned in the
; @RESULTS@(0) and the subsequent nodes of the global array
; contain the users.
;
; @RESULTS@(0) Result Descriptor
; ^01: Number of users
; ^02: Values that comprise the FROM
; ^nn: parameter for the subsequent call
;
; @RESULTS@(i) User
; ^01: IEN
; ^02: Name
; ^03: Office Phone
; ^04: Nickname
; ^05: reserved
; ^06: Default Division IEN (only if D flag)
; ^07: Default Division Name (only if D flag)
;
USERLIST(RESULTS,PART,FLAGS,NUMBER,FROM) ;
N BUF,FIELDS,I,RC,RORERRDL,SCR,TMP
D CLEAR^RORERR("USERLIST^RORRP024",1)
K RESULTS S RESULTS=$NA(^TMP("DILIST",$J)) K @RESULTS
;--- Check the parameters
S RC=0 D I RC<0 D RPCSTK^RORERR(.RESULTS,RC) Q
. ;--- Flags
. S FLAGS=$$UP^XLFSTR($G(FLAGS))
. ;--- Others
. S PART=$G(PART),FROM=$G(FROM)
. S NUMBER=$S($G(NUMBER)>0:+NUMBER,1:"*")
;--- Setup the start point
F I=1:1 S TMP=$P(FROM,U,I) Q:TMP="" S FROM(I)=TMP
S FROM=$G(FROM(1))
;--- Compile the screen logic (be careful with naked references)
S SCR=""
S:FLAGS["P" SCR=SCR_"I $D(^XUSEC(""PROVIDER"",Y))"
;--- Query the file
S FIELDS="@;.01;.132;13",TMP="P"_$S(FLAGS["B":"B",1:"")
D LIST^DIC(200,,FIELDS,TMP,NUMBER,.FROM,PART,"B",SCR,,,"RORMSG")
I $G(DIERR) D D RPCSTK^RORERR(.RESULTS,RC) Q
. S RC=$$DBS^RORERR("RORMSG",-9,,,200) K ^TMP("DILIST",$J)
;--- Add default divisions
I FLAGS["D" S I=0 D
. F S I=$O(@RESULTS@(I)) Q:I'>0 D
. . S $P(@RESULTS@(I,0),U,6,7)=$P($$DFLTDIV(+@RESULTS@(I,0)),U,1,2)
;--- Success
S TMP=$G(^TMP("DILIST",$J,0)),BUF=+$P(TMP,U)
K ^TMP("DILIST",$J,0)
I $P(TMP,U,3) S I=0 D
. F S I=$O(FROM(I)) Q:I'>0 S TMP=FROM(I) S:TMP'="" BUF=BUF_U_TMP
S @RESULTS@(0)=BUF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORRP024 6713 printed Dec 13, 2024@01:43:07 Page 2
RORRP024 ;HCIOFO/SG - RPC: VISTA USERS ; 12/15/05 4:31pm
+1 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #10060 Read access (FileMan) to the NEW PERSON file
+6 ;
+7 QUIT
+8 ;
+9 ;***** RETURNS THE DEFAULT DIVISION FOR THE USER
+10 ;
+11 ; USER User IEN in file #200 (DUZ)
+12 ;
+13 ; Return Values:
+14 ; ... Default Division
+15 ; ^01: IEN (in the INSTITUTION file)
+16 ; ^02: Name
+17 ;
DFLTDIV(USER) ;
+1 NEW DIV,IENS,IR,RORBUF,RORMSG,TMP
+2 SET IENS=","_(+USER)_","
SET TMP="@;.01I;.01E;1I"
+3 DO LIST^DIC(200.02,IENS,TMP,"PQ",,,,"#",,,"RORBUF","RORMSG")
+4 if $GET(DIERR)
DO DBS^RORERR("RORMSG",-9,,,200,IENS)
+5 SET DIV=""
+6 ;--- Look for default division
+7 if $GET(RORBUF("DILIST",0))>0
Begin DoDot:1
+8 SET IR=0
+9 FOR
SET IR=$ORDER(RORBUF("DILIST",IR))
if IR'>0
QUIT
Begin DoDot:2
+10 SET TMP=$GET(RORBUF("DILIST",IR,0))
+11 if $PIECE(TMP,U,4)
SET DIV=$PIECE(TMP,U,2,3)
End DoDot:2
if DIV'=""
QUIT
+12 ;--- If name of the default division is not available
+13 ; and the only division is associated with the user
+14 ;--- then use this division as the default one.
+15 IF $PIECE(DIV,U,2)=""
if RORBUF("DILIST",0)<2
Begin DoDot:2
+16 SET DIV=$PIECE($GET(RORBUF("DILIST",1,0)),U,2,3)
End DoDot:2
End DoDot:1
+17 ;--- If default division is not available, use the site
+18 QUIT $SELECT($PIECE(DIV,U,2)'="":DIV,1:$PIECE($$SITE^VASITE(),U,1,2))
+19 ;
+20 ;***** RETURNS INFORMATION ABOUT THE USER
+21 ; RPC: [ROR GET USER IFNO]
+22 ;
+23 ; .RESULTS Reference to a local variable where the results
+24 ; are returned to.
+25 ;
+26 ; [USER] User IEN in the NEW PERSON file. By default
+27 ; (if $G(USER)'>0), the DUZ is used).
+28 ;
+29 ; Return Values:
+30 ;
+31 ; A negative value of the first "^"-piece of the RESULTS(0)
+32 ; indicates an error (see the RPCSTK^RORERR procedure for more
+33 ; details).
+34 ;
+35 ; Otherwise, the user info is returned in the RESULTS(0).
+36 ;
+37 ; RESULTS(0) User Info
+38 ; ^01: IEN
+39 ; ^02: Name
+40 ; ^03: Office Phone
+41 ; ^04: Nickname
+42 ; ^05: Read Timeout
+43 ; ^06: Default Division IEN
+44 ; ^07: Default Division Name
+45 ; ^08: Institution IEN
+46 ; ^09: Institution Name
+47 ; ^10: Station Number (with suffix)
+48 ;
USERINFO(RESULTS,USER) ;
+1 NEW IENS,RORBUF,RORERRDL,RORMSG,TMP
+2 DO CLEAR^RORERR("USERINFO^RORRP024",1)
+3 KILL RESULTS
SET RESULTS(0)=0
+4 IF $GET(USER)'>0
SET USER=+$GET(DUZ)
if USER'>0
QUIT
+5 ;--- Load the data
+6 SET IENS=USER_","
+7 DO GETS^DIQ(200,IENS,".01;.132;13",,"RORBUF","RORMSG")
+8 IF $GET(DIERR)
Begin DoDot:1
+9 SET RC=$$DBS^RORERR("RORMSG",-9,,,200)
KILL ^TMP("DILIST",$JOB)
End DoDot:1
DO RPCSTK^RORERR(.RESULTS,RC)
QUIT
+10 ;--- Compile the result
+11 SET RESULTS(0)=USER
+12 ; Name
SET $PIECE(RESULTS(0),U,2)=$GET(RORBUF(200,IENS,.01))
+13 ; Office Phone
SET $PIECE(RESULTS(0),U,3)=$GET(RORBUF(200,IENS,.132))
+14 ; Nick Name
SET $PIECE(RESULTS(0),U,4)=$GET(RORBUF(200,IENS,13))
+15 ; Read Timeout
SET $PIECE(RESULTS(0),U,5)=$$DTIME^XUP(USER)
+16 SET TMP=$$DFLTDIV(USER)
+17 ; Default Division
SET $PIECE(RESULTS(0),U,6,7)=$PIECE(TMP,U,1,2)
+18 SET $PIECE(RESULTS(0),U,8,10)=$$SITE^VASITE()
+19 QUIT
+20 ;
+21 ;***** RETURNS THE LIST OF VISTA USERS
+22 ; RPC: [ROR LIST VISTA USERS]
+23 ;
+24 ; .RESULTS Reference to a local variable where the results
+25 ; are returned to.
+26 ;
+27 ; PART The search pattern (partial match restriction)
+28 ;
+29 ; [FLAGS] Flags that control the execution (can be combined):
+30 ; B Backwards. Traverses the index in the opposite
+31 ; direction of normal traversal.
+32 ; D Get default division for each user
+33 ; P Select providers only (check for the PROVIDER
+34 ; security key)
+35 ;
+36 ; [NUMBER] Maximum number of entries to return. A value of "*"
+37 ; or no value in this parameter designates all entries.
+38 ;
+39 ; [FROM] The index entry(s) from which to begin the list.
+40 ; You should use the pieces of the @RESULTS@(0) node
+41 ; (starting from the second one) to continue the
+42 ; listing in the subsequent procedure calls.
+43 ;
+44 ; NOTE: The FROM value itself is not included in
+45 ; the resulting list.
+46 ;
+47 ; The ^TMP("DILIST",$J) global node is used by the procedure.
+48 ;
+49 ; See description of the LIST^DIC for more details about the
+50 ; PART, NUMBER and FROM parameters.
+51 ;
+52 ; Return Values:
+53 ;
+54 ; A negative value of the first "^"-piece of the RESULTS(0)
+55 ; indicates an error (see the RPCSTK^RORERR procedure for more
+56 ; details).
+57 ;
+58 ; Otherwise, number of VistA users and the value of the FROM
+59 ; parameter for the next procedure call are returned in the
+60 ; @RESULTS@(0) and the subsequent nodes of the global array
+61 ; contain the users.
+62 ;
+63 ; @RESULTS@(0) Result Descriptor
+64 ; ^01: Number of users
+65 ; ^02: Values that comprise the FROM
+66 ; ^nn: parameter for the subsequent call
+67 ;
+68 ; @RESULTS@(i) User
+69 ; ^01: IEN
+70 ; ^02: Name
+71 ; ^03: Office Phone
+72 ; ^04: Nickname
+73 ; ^05: reserved
+74 ; ^06: Default Division IEN (only if D flag)
+75 ; ^07: Default Division Name (only if D flag)
+76 ;
USERLIST(RESULTS,PART,FLAGS,NUMBER,FROM) ;
+1 NEW BUF,FIELDS,I,RC,RORERRDL,SCR,TMP
+2 DO CLEAR^RORERR("USERLIST^RORRP024",1)
+3 KILL RESULTS
SET RESULTS=$NAME(^TMP("DILIST",$JOB))
KILL @RESULTS
+4 ;--- Check the parameters
+5 SET RC=0
Begin DoDot:1
+6 ;--- Flags
+7 SET FLAGS=$$UP^XLFSTR($GET(FLAGS))
+8 ;--- Others
+9 SET PART=$GET(PART)
SET FROM=$GET(FROM)
+10 SET NUMBER=$SELECT($GET(NUMBER)>0:+NUMBER,1:"*")
End DoDot:1
IF RC<0
DO RPCSTK^RORERR(.RESULTS,RC)
QUIT
+11 ;--- Setup the start point
+12 FOR I=1:1
SET TMP=$PIECE(FROM,U,I)
if TMP=""
QUIT
SET FROM(I)=TMP
+13 SET FROM=$GET(FROM(1))
+14 ;--- Compile the screen logic (be careful with naked references)
+15 SET SCR=""
+16 if FLAGS["P"
SET SCR=SCR_"I $D(^XUSEC(""PROVIDER"",Y))"
+17 ;--- Query the file
+18 SET FIELDS="@;.01;.132;13"
SET TMP="P"_$SELECT(FLAGS["B":"B",1:"")
+19 DO LIST^DIC(200,,FIELDS,TMP,NUMBER,.FROM,PART,"B",SCR,,,"RORMSG")
+20 IF $GET(DIERR)
Begin DoDot:1
+21 SET RC=$$DBS^RORERR("RORMSG",-9,,,200)
KILL ^TMP("DILIST",$JOB)
End DoDot:1
DO RPCSTK^RORERR(.RESULTS,RC)
QUIT
+22 ;--- Add default divisions
+23 IF FLAGS["D"
SET I=0
Begin DoDot:1
+24 FOR
SET I=$ORDER(@RESULTS@(I))
if I'>0
QUIT
Begin DoDot:2
+25 SET $PIECE(@RESULTS@(I,0),U,6,7)=$PIECE($$DFLTDIV(+@RESULTS@(I,0)),U,1,2)
End DoDot:2
End DoDot:1
+26 ;--- Success
+27 SET TMP=$GET(^TMP("DILIST",$JOB,0))
SET BUF=+$PIECE(TMP,U)
+28 KILL ^TMP("DILIST",$JOB,0)
+29 IF $PIECE(TMP,U,3)
SET I=0
Begin DoDot:1
+30 FOR
SET I=$ORDER(FROM(I))
if I'>0
QUIT
SET TMP=FROM(I)
if TMP'=""
SET BUF=BUF_U_TMP
End DoDot:1
+31 SET @RESULTS@(0)=BUF
+32 QUIT
