Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ASDUSR1

ASDUSR1.m

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