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
Q
;
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
Q
;
INIT ;EP -- init variables and list array
D GATHER
S VALMCNT=DPTDLN
S VALMSG="- Previous Screen Q Quit ?? for More Actions"
Q
;
HELP ;EP -- help code
S X="?" D DISP^XQORM1,MSG^DPTDUT("",2,0,0)
Q
;
EXIT ;EP -- exit code
K ^TMP("DPTDZKEY",$J),^TMP("DPTDZKEY1",$J) K DPTDLN
D TERM^VALM0 S VALMBCK="R"
D CLEAR^VALM1
Q
;
EXPND ;EP -- expand code
Q
;
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
Q
;
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))
Q
;
;
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)=""
Q
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
