Routine: SCMCPR1

SCMCPR1 ;ALB/SCK - API FILE FOR STAFF ASSIGNMENTS ; 9/14/05 12:10pm

 ;;5.3;Scheduling;**41,45,264,297,1015**;AUG 13, 1993;Build 21

 ;;1.0

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

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

SCMCPR1   ;ALB/SCK - API FILE FOR STAFF ASSIGNMENTS ; 9/14/05 12:10pm

 +1       ;;5.3;Scheduling;**41,45,264,297,1015**;AUG 13, 1993;Build 21

 +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

SCMCPR1.m