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