SCMCPR1 ;ALB/SCK - API FILE FOR STAFF ASSIGNMENTS ; 9/14/05 12:10pm
;;5.3;Scheduling;**41,45,264,297**;AUG 13, 1993
;;1.0
Q
;
URSLKUP(SCDAT,SCUSR,SCVAL,SCREEN,SCINST,SCPC) ;
; Does a lookup in the USR #8930.3 file based on the user class match passed in
;
; Input
; SCUSR User class to use for lookup
; SCVAL Partial User name to lookup on
;
; Returns an array of matches found, or an error array.
; Format for array:
; SCDATA(1)=[Data]
; SCDATA(x)=IEN^New Users Name^Title
;
; Format for Error:
; SCDATA(1)=[Errors]
; SCDATA(x)=" message "
;
N SCI,N,SCRTN,SCTMP,SCTITLE,SCIEN,SCN,SCUERR
;
I SCUSR']""&(SCINST=1) D G USRQ
. S N=0
. D SETF("[Errors]")
. D SETF("No User Class Defined")
;
IF $L(SCVAL)<3&(SCINST=0) D G USRQ
. S N=0
.D SETF("[Errors]")
.D SETF("Insufficient characters to match")
;
S N=0
IF SCINST=1 D
. D LIST^DIC(200,"",".01;8;28","","","",SCVAL,"","IF $$ISA^USRLM(Y,SCUSR,.SCUERR)","","")
;
IF SCINST=0 D
.D LIST^DIC(200,"",".01;8;28","","","",SCVAL,"",SCREEN,"","")
;
S N=0
D SETF("[Data]")
S I="" F S I=$O(^TMP("DILIST",$J,1,I)) Q:'I D
. S SCTMP=^TMP("DILIST",$J,2,I)_U
. I $G(SCPC) I $O(^SD(403.46,+SCPC,2,0)) N PC S PC=0 D Q:'PC ;Put back for provider by role
.. N CODE S CODE=$$GET^XUA4A72(+SCTMP) D Q:PC
... I $D(^SD(403.46,+SCPC,2,+CODE)) S PC=1
. S:SCINST SCTMP=SCTMP_$$CLNAME^USRLM(+SCUSR)
. S SCTMP=SCTMP_U_U_U_U_^TMP("DILIST",$J,1,I)
. S SCTMP=SCTMP_U_^TMP("DILIST",$J,"ID",I,8)
. S SCTMP=SCTMP_U_^TMP("DILIST",$J,"ID",I,28)
. D SETF(SCTMP)
;
K ^TMP("DILIST",$J)
USRQ Q
;
SETF(X) ;
S N=N+1
S SCDAT(N)=X
Q
;
;
TEST(CHK) ;
N SC,SCCHECK
K SCK
IF CHK=1 D
. S DIC="^USR(8930,",DIC("A")="Enter User Class: ",DIC(0)="AEMZ"
. D ^DIC
. W !,Y,!
. R "Lookup: ",X:60
. Q:'$G(Y)>0
. D URSLKUP(.SCK,$P(Y,U),X,"",CHK)
;
IF CHK=0 D
. R "Name: ",X:60
. D URSLKUP(.SCK,"",X,"",CHK)
;
;;;W ! ZW SCK
TESTQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCPR1 2042 printed Sep 15, 2024@22:05:10 Page 2
SCMCPR1 ;ALB/SCK - API FILE FOR STAFF ASSIGNMENTS ; 9/14/05 12:10pm
+1 ;;5.3;Scheduling;**41,45,264,297**;AUG 13, 1993
+2 ;;1.0
+3 QUIT
+4 ;
URSLKUP(SCDAT,SCUSR,SCVAL,SCREEN,SCINST,SCPC) ;
+1 ; Does a lookup in the USR #8930.3 file based on the user class match passed in
+2 ;
+3 ; Input
+4 ; SCUSR User class to use for lookup
+5 ; SCVAL Partial User name to lookup on
+6 ;
+7 ; Returns an array of matches found, or an error array.
+8 ; Format for array:
+9 ; SCDATA(1)=[Data]
+10 ; SCDATA(x)=IEN^New Users Name^Title
+11 ;
+12 ; Format for Error:
+13 ; SCDATA(1)=[Errors]
+14 ; SCDATA(x)=" message "
+15 ;
+16 NEW SCI,N,SCRTN,SCTMP,SCTITLE,SCIEN,SCN,SCUERR
+17 ;
+18 IF SCUSR']""&(SCINST=1)
Begin DoDot:1
+19 SET N=0
+20 DO SETF("[Errors]")
+21 DO SETF("No User Class Defined")
End DoDot:1
GOTO USRQ
+22 ;
+23 IF $LENGTH(SCVAL)<3&(SCINST=0)
Begin DoDot:1
+24 SET N=0
+25 DO SETF("[Errors]")
+26 DO SETF("Insufficient characters to match")
End DoDot:1
GOTO USRQ
+27 ;
+28 SET N=0
+29 IF SCINST=1
Begin DoDot:1
+30 DO LIST^DIC(200,"",".01;8;28","","","",SCVAL,"","IF $$ISA^USRLM(Y,SCUSR,.SCUERR)","","")
End DoDot:1
+31 ;
+32 IF SCINST=0
Begin DoDot:1
+33 DO LIST^DIC(200,"",".01;8;28","","","",SCVAL,"",SCREEN,"","")
End DoDot:1
+34 ;
+35 SET N=0
+36 DO SETF("[Data]")
+37 SET I=""
FOR
SET I=$ORDER(^TMP("DILIST",$JOB,1,I))
if 'I
QUIT
Begin DoDot:1
+38 SET SCTMP=^TMP("DILIST",$JOB,2,I)_U
+39 ;Put back for provider by role
IF $GET(SCPC)
IF $ORDER(^SD(403.46,+SCPC,2,0))
NEW PC
SET PC=0
Begin DoDot:2
+40 NEW CODE
SET CODE=$$GET^XUA4A72(+SCTMP)
Begin DoDot:3
+41 IF $DATA(^SD(403.46,+SCPC,2,+CODE))
SET PC=1
End DoDot:3
if PC
QUIT
End DoDot:2
if 'PC
QUIT
+42 if SCINST
SET SCTMP=SCTMP_$$CLNAME^USRLM(+SCUSR)
+43 SET SCTMP=SCTMP_U_U_U_U_^TMP("DILIST",$JOB,1,I)
+44 SET SCTMP=SCTMP_U_^TMP("DILIST",$JOB,"ID",I,8)
+45 SET SCTMP=SCTMP_U_^TMP("DILIST",$JOB,"ID",I,28)
+46 DO SETF(SCTMP)
End DoDot:1
+47 ;
+48 KILL ^TMP("DILIST",$JOB)
USRQ QUIT
+1 ;
SETF(X) ;
+1 SET N=N+1
+2 SET SCDAT(N)=X
+3 QUIT
+4 ;
+5 ;
TEST(CHK) ;
+1 NEW SC,SCCHECK
+2 KILL SCK
+3 IF CHK=1
Begin DoDot:1
+4 SET DIC="^USR(8930,"
SET DIC("A")="Enter User Class: "
SET DIC(0)="AEMZ"
+5 DO ^DIC
+6 WRITE !,Y,!
+7 READ "Lookup: ",X:60
+8 if '$GET(Y)>0
QUIT
+9 DO URSLKUP(.SCK,$PIECE(Y,U),X,"",CHK)
End DoDot:1
+10 ;
+11 IF CHK=0
Begin DoDot:1
+12 READ "Name: ",X:60
+13 DO URSLKUP(.SCK,"",X,"",CHK)
End DoDot:1
+14 ;
+15 ;;;W ! ZW SCK
TESTQ QUIT
