Routine: DPTDZKEY

DPTDZKEY ; IHS/ANMC/LJF - LIST MERGE USERS ; [ 03/16/2000  6:50 AM ]

EN ;EP -- main entry point for DPTD USER LIST

 S VALMCC=1

 D EN^VALM("DPTD IHS MERGE USERS")

 D CLEAR^VALM1,FULL^VALM1,EXIT

HDR ;EP -- header code

 NEW X S X=$$SPACE(20)

 S VALMHDR(1)=" "

 S VALMHDR(2)=X_IORVON_"ACCESS TO PATIENT MERGE SYSTEM"_IORVOFF

 S VALMCC=1

INIT ;EP -- init variables and list array

 D GATHER

 S VALMCNT=DPTDLN

 S VALMSG="- Previous Screen    Q Quit    ?? for More Actions"

HELP ;EP -- help code

 S X="?" D DISP^XQORM1,MSG^DPTDUT("",2,0,0)

EXIT ;EP -- exit code

 K ^TMP("DPTDZKEY",$J),^TMP("DPTDZKEY1",$J) K DPTDLN

 D TERM^VALM0 S VALMBCK="R"

 D CLEAR^VALM1

EXPND ;EP -- expand code

PAUSE ;EP -- end of action pause

 D PAUSE^DPTDZFIX Q

RESET ;EP -- update partition for return to list manager

 I $D(VALMQUIT) S VALMBCK="Q" Q

 D TERM^VALM0 S VALMBCK="R"

 D INIT,HDR

GATHER ; -- find all users with ob keys

 NEW DPTDNUM,KEYNM,KEY,KEYDES,LINE,USR,DPTD,SRV,IEN

 K ^TMP("DPTDZKEY",$J),^TMP("DPTDZKEY1",$J)

 S DPTDLN=0

 S KEYNM="XDQZ"

 F  S KEYNM=$O(^DIC(19.1,"B",KEYNM)) Q:KEYNM'["XDR"  D

 . S KEY=$O(^DIC(19.1,"B",KEYNM,0)) Q:KEY=""

 . S KEYDES=$$VAL^XBDIQ1(19.1,KEY,.02)

 . S LINE=$$SPACE(5)_"Access to "_KEYDES

 . S ^TMP("DPTDZKEY1",$J,KEYNM,0)=LINE

 . S USR=0

 . F  S USR=$O(^XUSEC(KEYNM,USR)) Q:USR=""  D

 .. ;Q:$D(^XUSEC("XUPROG",USR))

 .. K DPTD

 .. D ENP^XBDIQ1(200,USR,".01;8;29","DPTD(","I")

 .. S SRV=$S(DPTD(29)="":"??",1:$$VAL^XBDIQ1(49,DPTD(29,"I"),1))

 .. S LINE=" "_$$PAD(DPTD(.01),20)_$$SPACE(3)_$$PAD(SRV,10)

 .. S LINE=$$PAD(LINE,34)_$$PAD(DPTD(8),25)

 .. S ^TMP("DPTDZKEY1",$J,KEYNM,DPTD(.01),USR)=LINE

 S KEYNM=0

 F  S KEYNM=$O(^TMP("DPTDZKEY1",$J,KEYNM)) Q:KEYNM=""  D

 . D SET(""),SET(^TMP("DPTDZKEY1",$J,KEYNM,0)),SET("")

 . S USR=0

 . F  S USR=$O(^TMP("DPTDZKEY1",$J,KEYNM,USR)) Q:USR=""  D

 .. S IEN=0

 .. F  S IEN=$O(^TMP("DPTDZKEY1",$J,KEYNM,USR,IEN)) Q:IEN=""  D

 ... D SET(^TMP("DPTDZKEY1",$J,KEYNM,USR,IEN))

PAD(D,L) ; -- SUBRTN to pad length of data

 ; -- D=data, L=length

 Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)

SPACE(N) ; -- SUBRTN to pad N number of spaces

 Q $$PAD(" ",N)

SET(LINE) ; -- SUBRTN to set data line into ^tmp

 S DPTDLN=DPTDLN+1

 S ^TMP("DPTDZKEY",$J,DPTDLN,0)=LINE

 S ^TMP("DPTDZKEY",$J,"IDX",DPTDLN,DPTDLN)=""

DPTDZKEY  ; IHS/ANMC/LJF - LIST MERGE USERS ; [ 03/16/2000  6:50 AM ]

 +1       ;

EN        ;EP -- main entry point for DPTD USER LIST

 +1        SET VALMCC=1

 +2        DO EN^VALM("DPTD IHS MERGE USERS")

 +3        DO CLEAR^VALM1

           DO FULL^VALM1

           DO EXIT

 +4        QUIT

 +5       ;

HDR       ;EP -- header code

 +1        NEW X

           SET X=$$SPACE(20)

 +2        SET VALMHDR(1)=" "

 +3        SET VALMHDR(2)=X_IORVON_"ACCESS TO PATIENT MERGE SYSTEM"_IORVOFF

 +4        SET VALMCC=1

 +5        QUIT

 +6       ;

INIT      ;EP -- init variables and list array

 +1        DO GATHER

 +2        SET VALMCNT=DPTDLN

 +3        SET VALMSG="- Previous Screen    Q Quit    ?? for More Actions"

 +4        QUIT

 +5       ;

HELP      ;EP -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           DO MSG^DPTDUT("",2,0,0)

 +2        QUIT

 +3       ;

EXIT      ;EP -- exit code

 +1        KILL ^TMP("DPTDZKEY",$JOB),^TMP("DPTDZKEY1",$JOB)

           KILL DPTDLN

 +2        DO TERM^VALM0

           SET VALMBCK="R"

 +3        DO CLEAR^VALM1

 +4        QUIT

 +5       ;

EXPND     ;EP -- expand code

 +1        QUIT

 +2       ;

PAUSE     ;EP -- end of action pause

 +1        DO PAUSE^DPTDZFIX

           QUIT

 +2       ;

RESET     ;EP -- update partition for return to list manager

 +1        IF $DATA(VALMQUIT)

               SET VALMBCK="Q"

               QUIT

 +2        DO TERM^VALM0

           SET VALMBCK="R"

 +3        DO INIT

           DO HDR

 +4        QUIT

 +5       ;

GATHER    ; -- find all users with ob keys

 +1        NEW DPTDNUM,KEYNM,KEY,KEYDES,LINE,USR,DPTD,SRV,IEN

 +2        KILL ^TMP("DPTDZKEY",$JOB),^TMP("DPTDZKEY1",$JOB)

 +3        SET DPTDLN=0

 +4        SET KEYNM="XDQZ"

 +5        FOR

               SET KEYNM=$ORDER(^DIC(19.1,"B",KEYNM))

               IF KEYNM'["XDR"

                   QUIT

               Begin DoDot:1

 +6                SET KEY=$ORDER(^DIC(19.1,"B",KEYNM,0))

                   IF KEY=""

                       QUIT

 +7                SET KEYDES=$$VAL^XBDIQ1(19.1,KEY,.02)

 +8                SET LINE=$$SPACE(5)_"Access to "_KEYDES

 +9                SET ^TMP("DPTDZKEY1",$JOB,KEYNM,0)=LINE

 +10               SET USR=0

 +11               FOR

                       SET USR=$ORDER(^XUSEC(KEYNM,USR))

                       IF USR=""

                           QUIT

                       Begin DoDot:2

 +12      ;Q:$D(^XUSEC("XUPROG",USR))

 +13                       KILL DPTD

 +14                       DO ENP^XBDIQ1(200,USR,".01;8;29","DPTD(","I")

 +15                       SET SRV=$SELECT(DPTD(29)="":"??",1:$$VAL^XBDIQ1(49,DPTD(29,"I"),1))

 +16                       SET LINE=" "_$$PAD(DPTD(.01),20)_$$SPACE(3)_$$PAD(SRV,10)

 +17                       SET LINE=$$PAD(LINE,34)_$$PAD(DPTD(8),25)

 +18                       SET ^TMP("DPTDZKEY1",$JOB,KEYNM,DPTD(.01),USR)=LINE

                       End DoDot:2

               End DoDot:1

 +19      ;

 +20       SET KEYNM=0

 +21       FOR

               SET KEYNM=$ORDER(^TMP("DPTDZKEY1",$JOB,KEYNM))

               IF KEYNM=""

                   QUIT

               Begin DoDot:1

 +22               DO SET("")

                   DO SET(^TMP("DPTDZKEY1",$JOB,KEYNM,0))

                   DO SET("")

 +23               SET USR=0

 +24               FOR

                       SET USR=$ORDER(^TMP("DPTDZKEY1",$JOB,KEYNM,USR))

                       IF USR=""

                           QUIT

                       Begin DoDot:2

 +25                       SET IEN=0

 +26                       FOR

                               SET IEN=$ORDER(^TMP("DPTDZKEY1",$JOB,KEYNM,USR,IEN))

                               IF IEN=""

                                   QUIT

                               Begin DoDot:3

 +27                               DO SET(^TMP("DPTDZKEY1",$JOB,KEYNM,USR,IEN))

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +28       QUIT

 +29      ;

 +30      ;

PAD(D,L)  ; -- SUBRTN to pad length of data

 +1       ; -- D=data, L=length

 +2        QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)

 +3       ;

SPACE(N)  ; -- SUBRTN to pad N number of spaces

 +1        QUIT $$PAD(" ",N)

 +2       ;

SET(LINE) ; -- SUBRTN to set data line into ^tmp

 +1        SET DPTDLN=DPTDLN+1

 +2        SET ^TMP("DPTDZKEY",$JOB,DPTDLN,0)=LINE

 +3        SET ^TMP("DPTDZKEY",$JOB,"IDX",DPTDLN,DPTDLN)=""

 +4        QUIT

DPTDZKEY.m