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

BDGSPT2.m

Go to the documentation of this file. 
  1. BDGSPT2 ; IHS/OIT/LJF - LIST TEMPLATE CODE FOR USER ACCESS RESTRICTIONS
  1.  ;;5.3;PIMS;**1008,1009**;MAY 28, 2004
  1.  ;IHS/OIT/LJF 08/23/2007 ROUTINE ADDED with Patch 1008
  1.  ;
  1. USER ;EP; Select User whose access will be restricted
  1.  ; called by option BDG SECURITY RESTRICTIONS
  1.  NEW BDGUSR,SCREEN,HELP
  1.  ;restrict person from accessing their own user record
  1.  S SCREEN="I (+Y'=DUZ),($P(^VA(200,+Y,0),U,11)=""""),($P(^VA(200,+Y,0),U,3)]"""")"
  1.  S HELP="Select an active user.  Cannot select yourself."
  1.  S BDGUSR=+$$READ^BDGF("PO^200:EMQZ","Select USER",,HELP,SCREEN) Q:BDGUSR<1
  1.  D EN,USER
  1.  Q
  1.  ;
  1. EN ;EP; -- main entry point for BDG SECURITY RESTRICTIONS list template
  1.  NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
  1.  D EN^VALM("BDG SECURITY RESTRICTIONS")
  1.  D CLEAR^VALM1
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  NEW X
  1.  S X=$$GET1^DIQ(200,+$G(BDGUSR),.01)
  1.  S VALMHDR(1)=$$PAD("User:",12)_X_$$SP(7)_$$GET1^DIQ(200,+$G(BDGUSR),8)
  1.  S VALMHDR(2)=$$SP(12)_"Last Signed on "_$$GET1^DIQ(200,+$G(BDGUSR),202)
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  S VALMCNT=0 K ^TMP("BDGSPT2",$J),^TMP("BDGSPT2A",$J)
  1.  ;
  1.  ; find entries and sort by status and then by patient name
  1.  NEW STATUS,DFN,PATNM,SORT
  1.  S DFN=0 F  S DFN=$O(^BDGSPT(BDGUSR,1,DFN)) Q:'DFN  D
  1.  . S PATNM=$$GET1^DIQ(2,DFN,.01)
  1.  . S STATUS=$$STATUS(BDGUSR,DFN,2)  ;2=long format
  1.  . S SORT=$S(STATUS["RESTRICTED":1,STATUS["TEMPORARY":2,1:3)
  1.  . S ^TMP("BDGSPT2A",$J,SORT,PATNM,DFN)=STATUS
  1.  ;
  1.  ; now take sorted list and create display array
  1.  S COUNT=0
  1.  S SORT=0 F  S SORT=$O(^TMP("BDGSPT2A",$J,SORT)) Q:'SORT  D
  1.  . I VALMCNT>0 D SET("",.VALMCNT,$G(COUNT),0)
  1.  . S PATNM=0 F  S PATNM=$O(^TMP("BDGSPT2A",$J,SORT,PATNM)) Q:PATNM=""  D
  1.  . . S DFN=0 F  S DFN=$O(^TMP("BDGSPT2A",$J,SORT,PATNM,DFN)) Q:'DFN  D
  1.  . . . S COUNT=COUNT+1
  1.  . . . S LINE=$$PAD($J(COUNT,3)_$$SP(3)_$E(PATNM,1,25),33)
  1.  . . . S LINE=$$PAD(LINE_$J($$HRCN^BDGF2(DFN,DUZ(2)),6),43)
  1.  . . . S LINE=LINE_^TMP("BDGSPT2A",$J,SORT,PATNM,DFN)
  1.  . . . D SET(LINE,.VALMCNT,COUNT,DFN)
  1.  ;
  1.  I '$D(^TMP("BDGSPT2",$J)) S VALMCNT=1,^TMP("BDGSPT2",$J,1,0)=$$SP(15)_"NO RESTRICTED RECORDS FOUND"
  1.  K ^TMP("BDGSPT2A",$J)
  1.  Q
  1.  ;
  1. SET(LINE,NUM,COUNT,IEN) ; put display line into array
  1.  S NUM=NUM+1
  1.  S ^TMP("BDGSPT2",$J,NUM,0)=LINE
  1.  S ^TMP("BDGSPT2",$J,"IDX",NUM,COUNT)=IEN
  1.  Q
  1.  ;
  1. ADD ;EP; called by BDG RESTRICTED ADD protocol
  1.  D FULL^VALM1
  1.  I '$D(^BDGSPT(BDGUSR)) D ADDUSER
  1.  I '$D(^BDGSPT(BDGUSR)) D  Q
  1.  . W !!,"PROBLEM ADDING USER TO FILE - CONTACT IT DEPARTMENT"
  1.  . S VALMBCK="R"
  1.  . D PAUSE^BDGF
  1.  ;
  1.  S DA(1)=BDGUSR,DIC="^BDGSPT("_DA(1)_",1,",DIC(0)="AEMQLZ",DLAYGO=9009018.11
  1.  S DIC("P")=$P(^DD(9009018.1,1,0),U,2)
  1.  S DIC("DR")=".02///"_$$NOW^XLFDT_";.03///`"_DUZ
  1.  D ^DIC
  1.  D RESET
  1.  Q
  1.  ;
  1. LIFT ;EP; called by BDG RESTRICTED LIFT protocol
  1.  D FULL^VALM1
  1.  NEW DATE,DFN
  1.  D GETPAT Q:'$G(DFN)
  1.  ;
  1.  ; code if restriction already lifted
  1.  S DATE=$O(^BDGSPT(BDGUSR,1,DFN,1,"A"),-1)
  1.  I DATE,$P($G(^BDGSPT(BDGUSR,1,DFN,1,DATE,0)),U,4)="" D  D RESET Q
  1.  . W !!,$$STATUS(BDGUSR,DFN,2)
  1.  . Q:'$$READ^BDGF("Y","Do You Want to Change the EFFECTIVE DATE","NO")
  1.  . NEW DIE,DA,DR
  1.  . S DIE="^BDGSPT("_BDGUSR_",1,"_DFN_",1,",DA=DATE,DA(1)=DFN,DA(2)=BDGUSR
  1.  . S DR=".03R;.07///"_$$NOW^XLFDT_";.08///`"_DUZ
  1.  . D ^DIE
  1.  ;
  1.  ; and if new restriction being added
  1.  NEW DIC,DA,X,Y
  1.  S DIC="^BDGSPT("_BDGUSR_",1,"_DFN_",1,",DIC(0)="L",DLAYGO=9009018.111
  1.  S DIC("P")=$P(^DD(9009018.11,1,0),U,2)
  1.  S X=$$NOW^XLFDT,DA(1)=DFN,DA(2)=BDGUSR
  1.  S DIC("DR")=".02///`"_DUZ_";.03R"
  1.  D ^DIC
  1.  D RESET
  1.  Q
  1.  ;
  1. RESUME ;EP; called by BDG RESTRICTED RESUME protocol
  1.  D FULL^VALM1
  1.  NEW DATE,DFN
  1.  D GETPAT Q:'$G(DFN)
  1.  ;
  1.  S DATE=$O(^BDGSPT(BDGUSR,1,DFN,1,"A"),-1)
  1.  I 'DATE D  Q
  1.  . W !!,"ACCESS CURRENTLY RESTRICTED; NOTHING TO RESUME"
  1.  . D PAUSE^BDGF,RESET
  1.  ;
  1.  NEW X,QUIT
  1.  S X=$$GET1^DIQ(9009018.111,DATE_","_DFN_","_BDGUSR,.04) I X]"" D  I $G(QUIT) D RESET Q
  1.  . W !!,"RESTRICTION LAST RESUMED ON "_X
  1.  . I '$$READ^BDGF("Y","Do You Want to Edit the Last RESUME DATE","NO") S QUIT=1
  1.  ;
  1.  ; enter or edit resume date
  1.  NEW DIE,DA,DR,X,Y
  1.  S DIE="^BDGSPT("_BDGUSR_",1,"_DFN_",1,"
  1.  S DA=DATE,DA(1)=DFN,DA(2)=BDGUSR
  1.  S DR=".04;.05///"_$$NOW^XLFDT_";.06///`"_DUZ
  1.  D ^DIE
  1.  D RESET
  1.  Q
  1.  ;
  1. VIEW ;EP; called by BDG RESTRICTED VIEW protocol
  1.  D FULL^VALM1
  1.  NEW DFN
  1.  D GETPAT Q:'$G(DFN)
  1.  ;
  1.  D EN^BDGSPT3
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. ADDUSER ; adds user to file if not already there
  1.  NEW DIC,DLAYGO,X,Y
  1.  S (DIC,DLAYGO)=9009018.1,DIC(0)="L",X="`"_BDGUSR D ^DIC
  1.  Q
  1.  ;
  1. GETPAT ; -- select patient from listing
  1.  NEW X,Y,Z,BDGPAT
  1.  D FULL^VALM1
  1.  S BDGPAT=""
  1.  D EN^VALM2(XQORNOD(0),"OS")
  1.  I '$D(VALMY) Q
  1.  S X=$O(VALMY(0))
  1.  S Y=0 F  S Y=$O(^TMP("BDGSPT2",$J,"IDX",Y)) Q:Y=""  Q:BDGPAT]""  D
  1.  . S Z=$O(^TMP("BDGSPT2",$J,"IDX",Y,0))
  1.  . Q:^TMP("BDGSPT2",$J,"IDX",Y,Z)=""
  1.  . I Z=X S BDGPAT=^TMP("BDGSPT2",$J,"IDX",Y,Z)
  1.  S DFN=BDGPAT
  1.  Q
  1.  ;
  1. RESET ;EP; return from protocol & rebuild list
  1.  S VALMBCK="R" D TERM^VALM0,HDR,INIT Q
  1.  ;
  1. HELP ;EP -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ;EP -- exit code
  1.  K ^TMP("BDGSPT2",$J)
  1.  Q
  1.  ;
  1. EXPND ;EP -- expand code
  1.  Q
  1.  ;
  1.  ;
  1. PAD(D,L) ; -- SUBRTN to pad length of data
  1.  ; -- D=data L=length
  1.  Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
  1.  ;
  1. SP(N) ; -- SUBRTN to pad N number of spaces
  1.  Q $$PAD(" ",N)
  1.  ;
  1. STATUS(USR,PAT,MODE) ;EP; returns restriction status for user/patient pair
  1.  ; called by this routine and computed field STATUS
  1.  ; also called by ^DGSEC to determine access for user to this patient
  1.  ; If MODE=1, then return short format (default)
  1.  ; If MODE=2, then return long format
  1.  I ('$G(USR))!('$G(PAT)) Q "UNKNOWN"
  1.  I '$D(^BDGSPT(USR,1,PAT)) Q "ACCESS ALLOWED"
  1.  I '$O(^BDGSPT(USR,1,PAT,0)) Q "RESTRICTED ACCESS"
  1.  ;
  1.  ; find last restriction lifted edit date
  1.  NEW DATE,END
  1.  S DATE=$O(^BDGSPT(USR,1,PAT,1,"A"),-1)
  1.  I 'DATE Q "RESTRICTED ACCESS"
  1.  I $P(^BDGSPT(USR,1,PAT,1,DATE,0),U,3)>$$NOW^XLFDT Q "RESTRICTED ACCESS UNTIL "_$$GET1^DIQ(9009018.111,DATE_","_PAT_","_USR,.03)
  1.  S END=$P(^BDGSPT(USR,1,PAT,1,DATE,0),U,4)
  1.  I END="" Q "ACCESS REINSTATED"_$S($G(MODE)=2:" on "_$$GET1^DIQ(9009018.111,DATE_","_PAT_","_USR,.03),1:"")
  1.  I END>DT Q "TEMPORARY ACCESS"_$S(MODE=2:" until "_$$GET1^DIQ(9009018.111,DATE_","_PAT_","_USR,.04),1:"")
  1.  Q "RESTRICTED ACCESS"
  1.  ;
  1. LIFTCHK(USER,DFN,DTIEN,LIFT) ;EP; called by input transform
  1.  ; make sure date restriction lifted is not before first restriction
  1.  ; AND not before last time restriction resumed
  1.  I LIFT<($P(^BDGSPT(USER,1,DFN,0),U,2)\1) Q 0   ;check against first restriction
  1.  NEW LAST S LAST=$O(^BDGSPT(USER,1,DFN,1,DTIEN),-1)
  1.  I (LAST),(LIFT<$P(^BDGSPT(USER,1,DFN,1,LAST,0),U,4)) Q 0  ;check aginst last resumption
  1.  Q 1
  1.  ;
  1. RESUMCHK(USER,DFN,DTIEN,RESUME) ;EP; called by input transform
  1.  ; Make sure date restriction resumes is not before date lifted
  1.  I RESUME<$P(^BDGSPT(USER,1,DFN,1,DTIEN,0),U,3) Q 0
  1.  Q 1