ASDUSR1 ; IHS/ADC/PDW/ENM - DISPLAY USER SETUP ; [ 03/25/1999 11:48 AM ]
;;5.0;IHS SCHEDULING;;MAR 25, 1999
;
S ASDQ=0
D ASK I ASDQ D EXIT Q
D DEV I ASDQ D EXIT Q
I IOST["C-" D ^ASDUSL1,EXIT Q
D DISP
;
EXIT ; -- eoj
D ^%ZISC K ASDU,ASDQ,ASDLN Q
;
ASK ; -- ask for user name
NEW DIC,X,Y
S DIC=200,DIC(0)="AEMQ",DIC("A")="Select SCHEDULING USER: "
S DIC("S")="I $P(^VA(200,+Y,0),U,3)]"""",$P(^(0),U,11)="""""
D ^DIC I X=""!(X=U)!(Y<1) S ASDQ=1 Q
S ASDU=Y
Q
;
DEV ; -- ask for device
S %ZIS="Q" D ^%ZIS I POP S ASDQ=1 Q
I $D(IO("Q")) D S ASDQ=1 Q
. S ZTRTN="DISP^ASDUSR1",ZTDESC="DISPLAY SCHED USER"
. S ZTSAVE("ASDU")=""
. K IO("Q") D ^%ZTLOAD K ZTSK D HOME^%ZIS
Q
;
DISP ;EP; -- display user data
NEW ASDL
K ^TMP("ASDUSL1",$J) S ASDLN=0
S ASDL=$$PAD("Name: "_$E($P(ASDU,U,2),1,20),25)
S X=$$VAL^XBDIQ1(200,+ASDU,29)
I X]"" S ASDL=ASDL_$$PAD("Service: "_$E(X,1,22),33)
S X=$$VAL^XBDIQ1(200,+ASDU,.132)
I X]"" S ASDL=ASDL_"Phone: "_$E(X,1,12)
D SET(ASDL),SET(" ")
D KEYS,OVERBK,ACCESS
I IOST'["C-" D PRINT
Q
;
KEYS ; -- display user's sd keys and descriptions
NEW ASDX,ASDY
S ASDX="SDZ"
F S ASDX=$O(^DIC(19.1,"B",ASDX)) Q:ASDX=""!($E(ASDX,1,2)'="SD") D
. Q:'$D(^XUSEC(ASDX,+ASDU))
. S ASDY=$O(^DIC(19.1,"B",ASDX,0)) Q:ASDY=""
. D SET($$SP(5)_$$VAL^XBDIQ1(19.1,ASDY,.02))
I $D(^XUSEC("AGZDOG",+ASDU)) D
. D SET($$SP(5)_"CAN ACCESS FULL REGISTRATION EDIT")
Q
;
OVERBK ; -- display overbook level
NEW ASDX
I $D(^XUSEC("SDMOB",+ASDU)) D Q
. D SET($$SP(5)_"Has MASTER OVERBOOK in all clinics")
I $D(^XUSEC("SDOB",+ASDU)) D
. D SET($$SP(5)_"Has OVERBOOK access in all clinics")
I $D(^SC("AIHSOV",+ASDU)) D
. D SET($$SP(5)_"Has OVERBOOK access in these clinics:")
S ASDX=0 F S ASDX=$O(^SC("AIHSOV",+ASDU,ASDX)) Q:ASDX="" D
. D SET($$SP(10)_$$VAL^XBDIQ1(44,ASDX,.01)_$$MSTOV)
Q
;
MSTOV() ; -- returns whether user has master ovbk in clinic
NEW X
S X=$P($G(^SC(ASDX,"IHS OB",+ASDU,0)),U,2)
Q $S(X="M":" (Master Overbook)",1:"")
;
ACCESS ; -- display access to restricted clinics
NEW ASDX
Q:'$D(^SC("AIHSPRIV",+ASDU)) D SET(" ")
D SET($$SP(5)_"Has access to these RESTRICTED Clinics:")
S ASDX=0 F S ASDX=$O(^SC("AIHSPRIV",+ASDU,ASDX)) Q:ASDX="" D
. Q:$$VAL^XBDIQ1(44,ASDX,2500)'="YES"
. S X=$$VALI^XBDIQ1(44,ASDX,2505) I X]"",X'>DT Q
. D SET($$SP(10)_$$VAL^XBDIQ1(44,ASDX,.01))
Q
;
PRINT ; -- print list if sent to a printer
U IO NEW ASDL,ASDPG
S (ASDPG,ASDL)=0 D HDR
F S ASDL=$O(^TMP("ASDUSL1",$J,ASDL)) Q:'ASDL D
. I $Y>(IOSL-3) D HDR
. W !,^TMP("ASDUSL1",$J,ASDL,0)
D EXIT
Q
;
HDR ; -- header
W:ASDPG>0 @IOF S ASDPG=ASDPG+1
W !?30,"SCHEDULING USER SETUP",!
Q
;
SET(DATA) ; -- sets ^tmp
S ASDLN=ASDLN+1,^TMP("ASDUSL1",$J,ASDLN,0)=DATA
S ^TMP("ASDUSL1",$J,"IDX",ASDLN,ASDLN)=""
Q
;
PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data
Q $E(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
;
SP(NUM) ; -- SUBRTN to pad spaces
Q $$PAD(" ",NUM)
ASDUSR1 ; IHS/ADC/PDW/ENM - DISPLAY USER SETUP ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;IHS SCHEDULING;;MAR 25, 1999
+2 ;
+3 SET ASDQ=0
+4 DO ASK
IF ASDQ
DO EXIT
QUIT
+5 DO DEV
IF ASDQ
DO EXIT
QUIT
+6 IF IOST["C-"
DO ^ASDUSL1
DO EXIT
QUIT
+7 DO DISP
+8 ;
EXIT ; -- eoj
+1 DO ^%ZISC
KILL ASDU,ASDQ,ASDLN
QUIT
+2 ;
ASK ; -- ask for user name
+1 NEW DIC,X,Y
+2 SET DIC=200
SET DIC(0)="AEMQ"
SET DIC("A")="Select SCHEDULING USER: "
+3 SET DIC("S")="I $P(^VA(200,+Y,0),U,3)]"""",$P(^(0),U,11)="""""
+4 DO ^DIC
IF X=""!(X=U)!(Y<1)
SET ASDQ=1
QUIT
+5 SET ASDU=Y
+6 QUIT
+7 ;
DEV ; -- ask for device
+1 SET %ZIS="Q"
DO ^%ZIS
IF POP
SET ASDQ=1
QUIT
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 SET ZTRTN="DISP^ASDUSR1"
SET ZTDESC="DISPLAY SCHED USER"
+4 SET ZTSAVE("ASDU")=""
+5 KILL IO("Q")
DO ^%ZTLOAD
KILL ZTSK
DO HOME^%ZIS
End DoDot:1
SET ASDQ=1
QUIT
+6 QUIT
+7 ;
DISP ;EP; -- display user data
+1 NEW ASDL
+2 KILL ^TMP("ASDUSL1",$JOB)
SET ASDLN=0
+3 SET ASDL=$$PAD("Name: "_$EXTRACT($PIECE(ASDU,U,2),1,20),25)
+4 SET X=$$VAL^XBDIQ1(200,+ASDU,29)
+5 IF X]""
SET ASDL=ASDL_$$PAD("Service: "_$EXTRACT(X,1,22),33)
+6 SET X=$$VAL^XBDIQ1(200,+ASDU,.132)
+7 IF X]""
SET ASDL=ASDL_"Phone: "_$EXTRACT(X,1,12)
+8 DO SET(ASDL)
DO SET(" ")
+9 DO KEYS
DO OVERBK
DO ACCESS
+10 IF IOST'["C-"
DO PRINT
+11 QUIT
+12 ;
KEYS ; -- display user's sd keys and descriptions
+1 NEW ASDX,ASDY
+2 SET ASDX="SDZ"
+3 FOR
SET ASDX=$ORDER(^DIC(19.1,"B",ASDX))
IF ASDX=""!($EXTRACT(ASDX,1,2)'="SD")
QUIT
Begin DoDot:1
+4 IF '$DATA(^XUSEC(ASDX,+ASDU))
QUIT
+5 SET ASDY=$ORDER(^DIC(19.1,"B",ASDX,0))
IF ASDY=""
QUIT
+6 DO SET($$SP(5)_$$VAL^XBDIQ1(19.1,ASDY,.02))
End DoDot:1
+7 IF $DATA(^XUSEC("AGZDOG",+ASDU))
Begin DoDot:1
+8 DO SET($$SP(5)_"CAN ACCESS FULL REGISTRATION EDIT")
End DoDot:1
+9 QUIT
+10 ;
OVERBK ; -- display overbook level
+1 NEW ASDX
+2 IF $DATA(^XUSEC("SDMOB",+ASDU))
Begin DoDot:1
+3 DO SET($$SP(5)_"Has MASTER OVERBOOK in all clinics")
End DoDot:1
QUIT
+4 IF $DATA(^XUSEC("SDOB",+ASDU))
Begin DoDot:1
+5 DO SET($$SP(5)_"Has OVERBOOK access in all clinics")
End DoDot:1
+6 IF $DATA(^SC("AIHSOV",+ASDU))
Begin DoDot:1
+7 DO SET($$SP(5)_"Has OVERBOOK access in these clinics:")
End DoDot:1
+8 SET ASDX=0
FOR
SET ASDX=$ORDER(^SC("AIHSOV",+ASDU,ASDX))
IF ASDX=""
QUIT
Begin DoDot:1
+9 DO SET($$SP(10)_$$VAL^XBDIQ1(44,ASDX,.01)_$$MSTOV)
End DoDot:1
+10 QUIT
+11 ;
MSTOV() ; -- returns whether user has master ovbk in clinic
+1 NEW X
+2 SET X=$PIECE($GET(^SC(ASDX,"IHS OB",+ASDU,0)),U,2)
+3 QUIT $SELECT(X="M":" (Master Overbook)",1:"")
+4 ;
ACCESS ; -- display access to restricted clinics
+1 NEW ASDX
+2 IF '$DATA(^SC("AIHSPRIV",+ASDU))
QUIT
DO SET(" ")
+3 DO SET($$SP(5)_"Has access to these RESTRICTED Clinics:")
+4 SET ASDX=0
FOR
SET ASDX=$ORDER(^SC("AIHSPRIV",+ASDU,ASDX))
IF ASDX=""
QUIT
Begin DoDot:1
+5 IF $$VAL^XBDIQ1(44,ASDX,2500)'="YES"
QUIT
+6 SET X=$$VALI^XBDIQ1(44,ASDX,2505)
IF X]""
IF X'>DT
QUIT
+7 DO SET($$SP(10)_$$VAL^XBDIQ1(44,ASDX,.01))
End DoDot:1
+8 QUIT
+9 ;
PRINT ; -- print list if sent to a printer
+1 USE IO
NEW ASDL,ASDPG
+2 SET (ASDPG,ASDL)=0
DO HDR
+3 FOR
SET ASDL=$ORDER(^TMP("ASDUSL1",$JOB,ASDL))
IF 'ASDL
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-3)
DO HDR
+5 WRITE !,^TMP("ASDUSL1",$JOB,ASDL,0)
End DoDot:1
+6 DO EXIT
+7 QUIT
+8 ;
HDR ; -- header
+1 IF ASDPG>0
WRITE @IOF
SET ASDPG=ASDPG+1
+2 WRITE !?30,"SCHEDULING USER SETUP",!
+3 QUIT
+4 ;
SET(DATA) ; -- sets ^tmp
+1 SET ASDLN=ASDLN+1
SET ^TMP("ASDUSL1",$JOB,ASDLN,0)=DATA
+2 SET ^TMP("ASDUSL1",$JOB,"IDX",ASDLN,ASDLN)=""
+3 QUIT
+4 ;
PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data
+1 QUIT $EXTRACT(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
+2 ;
SP(NUM) ; -- SUBRTN to pad spaces
+1 QUIT $$PAD(" ",NUM)
