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

XUEPCSRT.m

Go to the documentation of this file.
  1. XUEPCSRT ;FO-OAKAND/REM - EPCS Utilities and Reports; [5/7/02 5:53am] ;08/06/2012
  1. ;;8.0;KERNEL;**580**;Jul 10, 1995;Build 46
  1. ;Per VHA Directive 2004-038, this routine should not be modified
  1. ;
  1. Q
  1. ;
  1. PRESCBR(XUSD0) ;called from print option - XU EPCS PRIVS
  1. ;XUSD0 is D0
  1. ; screening for prescribers with DEA# or VA#
  1. N XUSPS
  1. S XUSPS=$G(^VA(200,XUSD0,"PS"))
  1. Q:($P(XUSPS,U,2)'="")!($P(XUSPS,U,3)'="") 1
  1. Q 0
  1. ;
  1. PRIVS(XUSD0) ;called from print option - XU EPCS PRIVS
  1. ;XUSD0 is D0
  1. ;user with controlled substance privileges?
  1. ;based on 6 sub-schedules, PS3 node, pieces 1-6
  1. N XUSPS3
  1. S XUSPS3=$G(^VA(200,XUSD0,"PS3"))
  1. Q:($P(XUSPS3,U,1,6)[1) 1 ; yes, if at least one explicit Yes
  1. Q:($P(XUSPS3,U,1,6)[0) 0 ; no, if explicit No
  1. Q 1 ; default, when all NULL
  1. ;
  1. XT30(XUSD0,ACT) ;called from print option - XU EPCS XDATE EXPIRES
  1. ;chk user ACTIVE,with DEA# and xdate expires in 30 days
  1. ;XUSD0=IEN, ACT=(1 or 0) active user of not
  1. N XDT,DT30,DEA,CNT
  1. S CNT=0
  1. S XDT=$P($G(^VA(200,XUSD0,"QAR")),U,9),DT30=$$FMADD^XLFDT(DT,30),DEA=$P($G(^VA(200,XUSD0,"PS")),U,2)
  1. I (DEA'=""),(XDT'>DT30),(XDT'<DT) S CNT=CNT+1
  1. I ACT D
  1. .I $$ACTIVE^XUSER(XUSD0) S CNT=CNT+1
  1. I 'ACT D
  1. .I '$$ACTIVE^XUSER(XUSD0) S CNT=CNT+1
  1. I CNT=2 Q 1
  1. Q 0
  1. ;
  1. RPT1 ;ePCS report - setting or modifing to logical access controls.
  1. ;called from option - XU EPCS LOGICAL ACCESS
  1. ;Only runs if data has changed from previous day.
  1. ;FLG=records exist for previous day.
  1. N X,DEV,X1,X2,YT,%,FLG
  1. S (FLG,%)=0
  1. D NOW^%DTC S X1=X,X2="-1" D C^%DTC S YT=X ;Get the previous day date
  1. S %=0 F S %=$O(^XTV(8991.6,"DT",%)) Q:%=""!(FLG=1) D
  1. .S:YT=$P($G(%),".",1) FLG=1
  1. Q:FLG=0
  1. S DEV=$$GET^XPAR("SYS","XUEPCS REPORT DEVICE",1,"E")
  1. I DEV="" W !!,"DEVICE NOT DEFINED! Set the parameter XUEPCS REPORT DEVICE." Q
  1. S IOP=DEV
  1. S DISUPNO=1
  1. K DIC
  1. S DIC="^XTV(8991.6,",FLDS="[XU EPCS LOGICAL ACCESS PRINT]",BY="@DATE/TIME EDITED",(FR,TO)=YT,L=0
  1. D EN1^DIP
  1. Q
  1. ;
  1. RPT2 ;ePCS report - allocation history for PSDRPH key
  1. ;called from option - XU EPCS PSDRPH AUDIT
  1. ;Only runs if data has changed from previous day.
  1. ;FLG=records exist for previous day
  1. N X,DEV,X1,X2,YT,%,FLG
  1. S (FLG,%)=0
  1. D NOW^%DTC S X1=X,X2="-1" D C^%DTC S YT=X ;Get the previous day date
  1. S %=0 F S %=$O(^XTV(8991.7,"DT",%)) Q:%=""!(FLG=1) D
  1. .S:YT=$P($G(%),".",1) FLG=1
  1. Q:FLG=0
  1. S DEV=$$GET^XPAR("SYS","XUEPCS REPORT DEVICE",1,"E")
  1. I DEV="" W !!,"DEVICE NOT DEFINED! Set the parameter XUEPCS REPORT DEVICE." Q
  1. S IOP=DEV
  1. S DISUPNO=1
  1. ;D NOW^%DTC S X1=X,X2="-1" D C^%DTC S YT=X ;Get the previous day date
  1. K DIC
  1. S DIC="^XTV(8991.7,",FLDS="[XU EPCS PSDRPH KEY PRINT]",BY="@DATE/TIME EDITED",(FR,TO)=YT,L=0
  1. D EN1^DIP
  1. Q
  1. ;
  1. PSDKEY ;Allocated/de-allocate the PSDRPH key option
  1. ;called from option - XU EPCS PSDRPH KEY
  1. N XUBOSS,XUDA,XUKEY,XURET,XUNAME,ZZ,OK,NOW,IEN,MSG,INPUT,NOW
  1. S XUBOSS=0 S:(DUZ(0)["@"!($D(^XUSEC("XUMGR",DUZ)))) XUBOSS=1
  1. I 'XUBOSS W !,"You don't have privileges. See your package coordinator or site manager." Q
  1. S XUKEY=$$LKUP^XPDKEY("PSDRPH") I XUKEY="" W !,"PSDRPH key does not exist" Q
  1. K DIC S DIC="^VA(200,",DIC(0)="AEMQZ",DIC("A")="Enter User Name: " D ^DIC Q:Y<0
  1. S XUDA=+Y,XUNAME=$P(Y,U,2)
  1. D OWNSKEY^XUSRB(.ZZ,"PSDRPH",XUDA) S XURET=ZZ(0) ;chk if user had key
  1. S OK=$$ASK(XURET,XUNAME) I 'OK W !,"Nothing done..." Q
  1. ;De-allocate key
  1. I XURET K DIK S DIK="^VA(200,XUDA,51,",DA(1)=XUDA,DA=XUKEY D ^DIK
  1. ;Allocate key
  1. I 'XURET S FDA(200.051,"+1,"_XUDA_",",.01)="PSDRPH" D UPDATE^DIE("E","FDA","IEN","MSG")
  1. ;Set and record audit data
  1. S NOW=$P($$HTE^XLFDT($H),":",1,2)
  1. S INPUT="`"_XUDA_"^"_"`"_$G(DUZ)_"^"_$S(XURET:0,1:1) D RECORD(INPUT,NOW)
  1. Q
  1. ;
  1. ASK(TYPE,NAME) ;Ask user if Allocate/De-allocate - returns y/n
  1. ;TYPE - flag weather Allocate or De-allocate
  1. ;Name - user's name
  1. N FL,%
  1. S FL=0,%=0
  1. F D Q:FL=1
  1. .W !,$S(TYPE:"De-allocate",1:"Allocate")," PSDRPH for ",NAME,"?"
  1. .R " YES// ",X:DTIME S:'$T X=U S:X[U FL=1 Q:X[U S:(X="") X="Y" I "YyNn"'[$E(X,1) W $C(7)," ??",!,"Please enter 'Y' or 'N'"
  1. .I $E(X,1)="N"!($E(X,1)="n") S %=0 S FL=1
  1. .I $E(X,1)="Y"!($E(X,1)="y") S %=1 S FL=1
  1. Q %
  1. ;
  1. RECORD(LINE,NOW) ;Record the edited data into audit file #8991.7
  1. N FDA,VALUE,IEN,MSG,I
  1. F I=1:1:3 S VALUE=$P(LINE,U,I),FDA(8991.7,"+1,",(I/100))=VALUE
  1. S FDA(8991.7,"+1,",.04)=NOW
  1. D UPDATE^DIE("E","FDA","IEN","MSG")
  1. Q
  1. ;
  1. VUSER1(XUSD0,ACT) ;called from option - XU EPCS DISUSER EXP DATE,XU EPCS EXP DATE
  1. ;chk user ACTIVE, with DEA# and null DEA Exp Date
  1. ;XUSD0=IEN, ACT=(1 or 0) active user or not
  1. N CNT
  1. S CNT=0
  1. I $P($G(^VA(200,XUSD0,"PS")),U,2)'="" S CNT=CNT+1
  1. I $P($G(^VA(200,XUSD0,"QAR")),U,9)="" S CNT=CNT+1
  1. I ACT D
  1. .I $$ACTIVE^XUSER(XUSD0) S CNT=CNT+1
  1. I 'ACT D
  1. .I '$$ACTIVE^XUSER(XUSD0) S CNT=CNT+1
  1. I CNT=3 Q 1
  1. Q 0
  1. ;
  1. VUSER2(XUSD0,ACT) ;called from option - XU EPCS PRIVS,XU EPCS DISUSER PRIVS
  1. ;chk user ACTIVE, with DEA# or VA# with privilages - sch II-V
  1. ;XUSD0=IEN, ACT=(1 or 0) active user or not
  1. N CNT
  1. S CNT=0
  1. I $$PRESCBR^XUEPCSRT(XUSD0) S CNT=CNT+1
  1. I $$PRIVS^XUEPCSRT(XUSD0) S CNT=CNT+1
  1. I ACT D
  1. .I $$ACTIVE^XUSER(XUSD0) S CNT=CNT+1
  1. I 'ACT D
  1. .I '$$ACTIVE^XUSER(XUSD0) S CNT=CNT+1
  1. I CNT=3 Q CNT
  1. Q 0