PSODEART ;FO-OAKAND/REM - EPCS Utilities and Reports; [5/7/02 5:53am] ;10/5/21 09:42
;;7.0;OUTPATIENT PHARMACY;**667,545,714,731**;DEC 1997;Build 18
;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
;External reference to XUEPCS DATA file (#8991.6) is supported by DBIA 7015
;External reference to XUEPCS PSDRPH AUDIT file (#8991.7) is supported by DBIA 7016
;External reference to KEYS sub-file (#200.051) is supported by DBIA 7054
;
; PSO*7.0*714 - Liberty ITS/RJH - Add K DIC commands to the PSDKEY tag to
; prevent showing the "Enter User Name:" prompt incorrectly
; upon exit of the option.
Q
;
PRESCBR(PSOSD0) ;called from print option - PSO EPCS PRIVS
;PSOSD0 is D0
; screening for prescribers with DEA# or VA#
N PSOSPS
S PSOSPS=$G(^VA(200,PSOSD0,"PS"))
Q:$L(($$PRDEA^XUSER(0,PSOSD0)))!($P(PSOSPS,U,3)'="") 1
Q 0
;
PRIVS(PSOSD0) ;called from print option - PSO EPCS PRIVS
;PSOSD0 is D0
;user with controlled substance privileges?
;based on 6 sub-schedules, PS3 node, pieces 1-6
N PSOSPS3
S PSOSPS3=$$PRSCH^XUSER(PSOSD0)
Q:($P(PSOSPS3,U,1,6)[1) 1 ; yes, if at least one explicit Yes
Q:($P(PSOSPS3,U,1,6)[0) 0 ; no, if explicit No
Q 1 ; default, when all NULL
;
XT30(PSOSD0,ACT) ;called from print option - PSO EPCS XDATE EXPIRES
;chk user ACTIVE,with DEA# and xdate expires in 30 days
;PSOSD0=IEN, ACT=(1 or 0) active user of not
N XDT,DT30,DEA,CNT
S CNT=0
S XDT=$$PRXDT^XUSER(PSOSD0),DT30=$$FMADD^XLFDT(DT,30),DEA=$$PRDEA^XUSER(PSOSD0)
I (DEA'=""),(XDT'>DT30),(XDT'<DT) S CNT=CNT+1
I ACT D
.I $$ACTIVE^XUSER(PSOSD0) S CNT=CNT+1
I 'ACT D
.I '$$ACTIVE^XUSER(PSOSD0) S CNT=CNT+1
I CNT=2 Q 1
Q 0
;
RPT1 ;ePCS report - setting or modifing to logical access controls.
;called from option - PSO EPCS LOGICAL ACCESS
;Only runs if data has changed from previous day.
;FLG=records exist for previous day.
;Generate report & Mail message to PSDMGR key holders
N BDT,LD,EDT,FLG,DEV,FN,PSONS,ZPR,FSP,RHD,RT,PSORPT,OPT,X1,X2,FE S PSORPT=1 D INIT
D NOW^%DTC S X1=X,X2="-1" D C^%DTC S (BDT,LD)=X,EDT=X_".999999" ;Get the previous day date
F S LD=$O(^XTV(FN,"DT",LD)) Q:LD=""!(FLG=1) D
. S:LD<EDT FLG=1
D:$G(ZPR) AUTPRT D GMAIL
EXIT K ^TMP(PSONS,$J),^XTMP(PSONS,$J)
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
;
RPT2 ;ePCS report - allocation history for PSDRPH key
;called from option - PSO DEA PSDRPH AUDIT
;Only runs if data has changed from previous day.
;FLG=records exist for previous day
;Generate report & Mail message to PSDMGR key holders
N BDT,ST,EDT,FLG,DEV,FN,PSONS,ZPR,RHD,RT,PSORPT,OPT,X1,X2,FE S PSORPT=2 D INIT Q:'FN
D NOW^%DTC S X1=X,X2="-1" D C^%DTC S (BDT,ST)=X,EDT=X_".999999" ;Get the previous day date
F S ST=$O(^XTV(FN,"DT",ST)) Q:ST=""!(FLG=1) D
. S:ST<EDT FLG=1
D:$G(ZPR) AUTPRT D GMAIL
D EXIT
Q
;
PSDKEY ;Allocated/de-allocate the PSDRPH key option
;called from option - PSO EPCS PSDRPH KEY
N PSOBOSS,PSODA,PSOKEY,PSORET,PSONAME,PSONS,OK,NOW,IEN,MSG,INPUT,NOW,DA
S PSOKEY=$$LKUP^XPDKEY("PSDRPH")
I PSOKEY="" W !,"PSDRPH key does not exist" Q
S PSOBOSS=0
;PSDRPH KEY check - delegate & holders
S PSONS=$$GET1^DIQ(200.052,PSOKEY_","_DUZ_",",".01","",,"MSG")
S:PSONS="PSDRPH" PSOBOSS=2 K PSONS,MSG
S:(DUZ(0)["@"!($D(^XUSEC("XUMGR",DUZ)))!($D(^XUSEC("PSDRPH",DUZ)))) PSOBOSS=1
I 'PSOBOSS W !,"You don't have privileges. See your package coordinator or site manager." Q
;
; *** Begin PSO*7.0*714 changes ***
; K DIC S DIC="^VA(200,",DIC(0)="AEMQZ",DIC("A")="Enter User Name: " D ^DIC Q:Y<0
K DIC S DIC="^VA(200,",DIC(0)="AEMQZ",DIC("A")="Enter User Name: " D ^DIC I Y<0 K DIC Q
; I PSOBOSS=2,(DUZ=+Y) W !!,$C(7),"==> Sorry, you can't give yourself keys. See your IRM staff." Q
I PSOBOSS=2,(DUZ=+Y) W !!,$C(7),"==> Sorry, you can't give yourself keys. See your IRM staff." K DIC Q
S PSODA=+Y,PSONAME=$P(Y,U,2)
D OWNSKEY^XUSRB(.PSONS,"PSDRPH",PSODA) S PSORET=PSONS(0) ;chk if user had key
; S OK=$$ASK(PSORET,PSONAME) I 'OK W !,"Nothing done..." Q
S OK=$$ASK(PSORET,PSONAME) K DIC I 'OK W !,"Nothing done..." Q
; *** End PSO*7.0*714 changes ***
;
;De-allocate key
I PSORET K DIK S DIK="^VA(200,PSODA,51,",DA(1)=PSODA,DA=PSOKEY D ^DIK
;Allocate key
I 'PSORET S FDA(200.051,"+1,"_PSODA_",",.01)="PSDRPH" D UPDATE^DIE("E","FDA","IEN","MSG")
;Set and record audit data
S NOW=$P($$HTE^XLFDT($H),":",1,2)
S INPUT="`"_PSODA_"^"_"`"_$G(DUZ)_"^"_$S(PSORET:0,1:1) D RECORD(INPUT,NOW)
Q
;
ASK(TYPE,NAME,DELEG) ;Ask user if Allocate/De-allocate or Delegate/Un-delegate - returns y/n
;TYPE - flag weather Allocate/De-allocate or Delegate/Un-delegate
;Name - user's name
N DIR,Y
S DELEG=$G(DELEG,"")
I DELEG S DIR("A")=$S(TYPE=1:"Un-delegate",1:"Delegate")_" PSDRPH for "_NAME
I 'DELEG S DIR("A")=$S(TYPE=1:"De-allocate",1:"Allocate")_" PSDRPH for "_NAME
S DIR("B")="Y"
S DIR(0)="Y" D ^DIR K DIR
Q Y
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(PSOSD0,ACT) ;called from option - PSO EPCS DISUSER EXP DATE,PSO EPCS EXP DATE
;chk user ACTIVE, with DEA# and null DEA Exp Date
;PSOSD0=IEN, ACT=(1 or 0) active user or not
N CNT
S CNT=0
I $$PRDEA^XUSER(PSOSD0)'="" S CNT=CNT+1
I $$PRXDT^XUSER(PSOSD0)="" S CNT=CNT+1
I ACT D
.I $$ACTIVE^XUSER(PSOSD0) S CNT=CNT+1
I 'ACT D
.I '$$ACTIVE^XUSER(PSOSD0) S CNT=CNT+1
I CNT=3 Q 1
Q 0
;
VUSER2(PSOSD0,ACT) ;called from option - PSO EPCS PRIVS,PSO EPCS DISUSER PRIVS
;chk user ACTIVE, with DEA# or VA# with privilages - sch II-V
;PSOSD0=IEN, ACT=(1 or 0) active user or not
N CNT
S CNT=0
I $$PRESCBR^PSODEART(PSOSD0) S CNT=CNT+1
I $$PRIVS^PSODEART(PSOSD0) S CNT=CNT+1
I ACT D
.I $$ACTIVE^XUSER(PSOSD0) S CNT=CNT+1
I 'ACT D
.I '$$ACTIVE^XUSER(PSOSD0) S CNT=CNT+1
I CNT=3 Q CNT
Q 0
;
INIT ;
S PSONS="PSODEA",$P(FSP," ",25)=""
S FLG=0,FN=$S(PSORPT=1:8991.6,1:8991.7)
S RHD=$S(PSORPT=1:"SETTING OR CHANGES TO DEA PRESCRIBING PRIVILEGES",1:"PSDRPH KEY AUDIT LIST")
S OPT=$S(PSORPT=1:"PSO EPCS LOGICAL ACCESS",1:"PSO EPCS PHARMACIST ACCESS")
S ZPR=$$GET^XPAR("SYS",$S(PSORPT=1:"PSOEPCS LOGICAL ACC REPORT DEV",1:"PSOEPCS PHARM ACC RPT DEVICE",1:""),1,"I")
S RT=$$NOW^XLFDT
K ^XTMP(PSONS,$J),^TMP(PSONS,$J)
Q
;
GMAIL ;
N LC,ND,DAT,ARR,I,J,P1,P2,P3,P4,P5,P6,P6L,P6S,RT,XTV,DV,P8L,P8S D INIT
S LD=BDT F S LD=$O(^XTV(FN,"DT",LD)) Q:'LD!(LD>EDT) D
. S ND=0 F S ND=$O(^XTV(FN,"DT",LD,ND)) Q:'ND D
.. Q:'$D(^XTV(FN,ND,0))
.. S DAT=^XTV(FN,ND,0)
.. S IEN=$P(DAT,"^")
.. ;S DV=$O(^VA(200,IEN,2,0)) S:'DV DV=999999
.. ;S ^XTMP(PSONS,$J,DV,LD,ND)=""
.. ;S:$O(^VA(200,IEN,2,DV)) ^XTMP(PSONS,$J,"Z",IEN)=""
.. S (DV,DVS)=0 F S DV=$O(^VA(200,IEN,2,DV)) Q:('DV)&(DVS>0) S:'DV DV=999999 D
... S DVS=DVS+1
... S ^XTMP(PSONS,$J,DV,LD,ND)=""
... S:$O(^VA(200,IEN,2,DV)) ^XTMP(PSONS,$J,"Z",IEN)=""
SMAIL ;
S XMSUB="PSO EPCS "_$S(PSORPT=1:"LOGICAL",1:"PHARMACIST")_" ACCESS REPORT",XMDUZ=.5
S LC=1,^TMP(PSONS,$J,LC)=RHD,$E(^TMP(PSONS,$J,LC),60)=$$UP^XLFSTR($$FMTE^XLFDT(RT,"M")),LC=LC+1
I '$D(^XTMP(PSONS,$J)) D G MGRP
. S ^TMP(PSONS,$J,LC)="",LC=LC+1
. S ^TMP(PSONS,$J,LC)=" *************** NO MATCHING DATA ***************",LC=LC+1
. S ^TMP(PSONS,$J,LC)="",LC=LC+1
I PSORPT=1 D
. S ^TMP(PSONS,$J,LC)="NAME",$E(^TMP(PSONS,$J,LC),28)="EDITED BY",$E(^TMP(PSONS,$J,LC),55)="FIELD EDITED",LC=LC+1
E D
. S ^TMP(PSONS,$J,LC)="NAME",$E(^TMP(PSONS,$J,LC),48)="ALLOCATION",LC=LC+1
. S $E(^TMP(PSONS,$J,LC),24)="EDITED BY",$E(^TMP(PSONS,$J,LC),48)="STATUS",$E(^TMP(PSONS,$J,LC),60)="DATE/TIME EDITED",LC=LC+1
S $P(^TMP(PSONS,$J,LC),"-",79)="",LC=LC+1
S DV="" F S DV=$O(^XTMP(PSONS,$J,DV)) Q:'DV D
. K ARR
. S ^TMP(PSONS,$J,LC)="",LC=LC+1
. S ^TMP(PSONS,$J,LC)="Division: "_$S(DV=999999:"NO DIVISION",1:$$GET1^DIQ(4,DV,.01)),LEN=$L(^TMP(PSONS,$J,LC))+1,LC=LC+1
. S $P(^TMP(PSONS,$J,LC),"-",LEN)="",LC=LC+1
. S LD=0 F S LD=$O(^XTMP(PSONS,$J,DV,LD)) Q:'LD D
.. S ND=0 F S ND=$O(^XTMP(PSONS,$J,DV,LD,ND)) Q:'ND D BMAIL
. S J=0 F S J=$O(ARR(J)) Q:'J D:$D(^XTMP(PSONS,$J,"Z",J)) MFT
MGRP ;
N XMY,MDUZ
I PSORPT=1 S DEV=$$GET^XPAR("SYS","PSOEPCS LOGICAL ACC RPT EMAIL",1,"E")
E S DEV=$$GET^XPAR("SYS","PSOEPCS PHARM ACC REPORT EMAIL",1,"E")
I DEV]"" S XMY("G."_DEV)=""
E D
. S MDUZ=0
. I $D(^XUSEC("PSDMGR")) D
.. F S MDUZ=$O(^XUSEC("PSDMGR",MDUZ)) Q:MDUZ'>0 S XMY(MDUZ)=""
S:'$O(XMY(0)) XMY(DUZ)=""
S XMTEXT="^TMP(PSONS,$J," N DIFROM D ^XMD K XMDUZ,XMTEXT,XMSUB
Q
;
BMAIL ;
S DAT=^XTV(FN,ND,0),IEN=$P(DAT,"^"),ARR(IEN)=""
I FN=8991.6 I $P(DAT,"^",3)=.03 Q ;P731 detox/x-waiver removal
D GETS^DIQ(FN,ND,".01;.02;.04;.05;.06;.08","E","XTV")
D GETS^DIQ(FN,ND,".03","IE","XTV")
S P1=$G(XTV(FN,ND_",",.01,"E"))_FSP
S P2=$G(XTV(FN,ND_",",.02,"E"))_FSP
S FE=$G(XTV(FN,ND_",",.03,"I"))
I PSORPT=1 S P3=$P($G(^DD($S(FE>50:200,1:8991.9),FE,0)),U)
I PSORPT=2 S P3=$G(XTV(FN,ND_",",.03,"E"))_FSP
S P4=$G(XTV(FN,ND_",",.04,"E"))
S P5=$G(XTV(FN,ND_",",.05,"E"))
S P6=$G(XTV(FN,ND_",",.06,"E")),P6=$P(P6,"@",1)
I PSORPT=1 D
. I $L(P4)=7 S Y=P4 D DT^DIO2 S P4=Y,Y=P5 D DT^DIO2 S P5=Y
. I $L(P4)<7 D
.. S P4=$S($G(XTV(FN,ND_",",.04,"E"))="True":1,$G(XTV(FN,ND_",",.04,"E"))="False":0,1:$G(XTV(FN,ND_",",.04,"E")))
.. S P5=$S($G(XTV(FN,ND_",",.05,"E"))="True":1,$G(XTV(FN,ND_",",.05,"E"))="False":0,1:$G(XTV(FN,ND_",",.05,"E")))
. S ^TMP(PSONS,$J,LC)=$E(P1,1,28)_$E(P2,1,26)_$E(P3_FSP,1,24),LC=LC+1
. S ^TMP(PSONS,$J,LC)=" ORIGINAL DATA: "_P4
. I $G(XTV(FN,ND_",",.08,"E"))]"" D ;1749***
.. S P8L=$L(^TMP(PSONS,$J,LC)) ;1749***
.. S P8S=$E(FSP_FSP,1,56-P8L) ;1749***
.. S ^TMP(PSONS,$J,LC)=^TMP(PSONS,$J,LC)_P8S_"For DEA#: "_$G(XTV(FN,ND_",",.08,"E")) ;1749***
. S LC=LC+1
. S ^TMP(PSONS,$J,LC)=" EDITED DATA: "_P5_$S(FE>50:" (Source: File #200)",1:"")
. S P6L=$L(^TMP(PSONS,$J,LC))
. S P6S=$E(FSP_FSP,1,60-P6L)
. S ^TMP(PSONS,$J,LC)=^TMP(PSONS,$J,LC)_P6S_"DATE: "_P6 S LC=LC+1
E S ^TMP(PSONS,$J,LC)=$E(P1,1,22)_" "_$E(P2,1,22)_" "_$E(P3,1,12)_" "_P4,LC=LC+1
Q
;
MFT ;
S ^TMP(PSONS,$J,LC)="",LC=LC+1
S ^TMP(PSONS,$J,LC)="**Note: This user is defined under these divisions",LEN=$L(^TMP(PSONS,$J,LC))+1,LC=LC+1
S $P(^TMP(PSONS,$J,LC),"-",LEN)="",LC=LC+1
S (DAT,ND)=0 F S ND=$O(^VA(200,J,2,ND)) Q:'ND D
. S DAT=DAT+1 S:DAT=1 ^TMP(PSONS,$J,LC)=$$GET1^DIQ(200,J,.01) S $E(^TMP(PSONS,$J,LC),32)=$$GET1^DIQ(4,ND,.01),LC=LC+1
Q
;
ODRPT ;
;ePCS on demand report - setting or modifing to logical access controls/allocation history for PSDRPH key
;called from option - PSO EPCS LOGICAL ACCESS/PSO EPCS PSDRPH AUDIT
;provide a date range
N BDT,EDT,FLG,ST,FN,PSONS,POD,RHD,RT,OPT,PSOION,PSOOUT,PSOTYP D INIT K %DT,DTOUT,ZPR
W ! S %DT(0)=-DT,%DT("A")="Beginning Date: ",%DT="APE" D ^%DT I Y<0!($D(DTOUT)) G EXIT
S POD=1,(%DT(0),BDT)=Y
W ! S %DT("A")="Ending Date: " D ^%DT I Y<0!($D(DTOUT)) G EXIT
S EDT=Y_".9999"
S ST=BDT,FLG=0 F S ST=$O(^XTV(FN,"DT",ST)) Q:ST=""!(FLG=1) D
. S:ST<EDT FLG=1
I FLG=0 W !!?18,"********** NO DATA TO PRINT **********" H 2 G EXIT
I PSORPT=1 D G:$G(PSOTYP)="D" EXIT G:$G(PSOOUT) EXIT
. D TYPE^PSODEARU I $G(PSOOUT) Q
. I $G(PSOTYP)="D" D DL^PSODEARU I $G(PSOOUT) Q
. I $G(PSOTYP)="D" D OENDL^PSODEARU(PSONS,BDT,EDT,FN)
K IOP,%ZIS,POP S PSOION=ION,%ZIS="MQ" D ^%ZIS I POP S IOP=PSOION D ^%ZIS G EXIT
AUTPRT ;
I $G(ZPR)!$D(IO("Q")) D G EXIT
. N ZTRTN,ZTDESC,ZTIO,ZTSAVE,ZTDTH,ZTSK,ZTREQ,ZTQUEUED
. S:$G(ZPR) ZTIO="`"_ZPR,ZTDTH=$H S ZTRTN="OEN^PSODEART",ZTDESC=OPT,ZTSAVE("BDT")="",ZTSAVE("EDT")="",ZTSAVE("PSORPT")="",ZTSAVE("POD")=""
. S ZTSAVE("FN")="",ZTSAVE("PSONS")="",ZTSAVE("FLG")="",ZTSAVE("RHD")="",ZTSAVE("OPT")="",ZTSAVE("RT")="",ZTSAVE("FSP")=""
. D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!"
OEN ;
U IO
N PAGE,LINE,LEN,XTV,ARR,I,J,RHD,HCL,FSP,RDT,DV,FE
N DV,ND,DAT,IEN,DVS K DIRUT
K ^XTMP(PSONS,$J)
S LD=BDT F S LD=$O(^XTV(FN,"DT",LD)) Q:'LD!(LD>EDT) D
. S ND=0 F S ND=$O(^XTV(FN,"DT",LD,ND)) Q:'ND D
.. Q:'$D(^XTV(FN,ND,0))
.. S DAT=^XTV(FN,ND,0)
..I PSORPT=1 I $P(DAT,"^",3)=.03 Q ;P731 detox/x-waiver removal
.. S IEN=$P(DAT,"^")
.. S (DV,DVS)=0 F S DV=$O(^VA(200,IEN,2,DV)) Q:('DV)&(DVS>0) S:'DV DV=999999 D
... S DVS=DVS+1
... S ^XTMP(PSONS,$J,DV,LD,ND)=""
... S:$O(^VA(200,IEN,2,DV)) ^XTMP(PSONS,$J,"Z",IEN)=""
S RHD=$S(PSORPT=1:"SETTING OR CHANGES TO DEA PRESCRIBING PRIVILEGES",1:"PSDRPH KEY AUDIT LIST")
S HCL=(80-$L(RHD))\2,RDT=$$FMTE^XLFDT($$NOW^XLFDT,"1M")
S PAGE=1,$P(LINE,"-",79)="",$P(FSP," ",25)=""
D HD
I '$D(^XTMP(PSONS,$J)) D G QT
. W !!," *************** NO MATCHING DATA ***************",!!
S DV="" F S DV=$O(^XTMP(PSONS,$J,DV)) Q:'DV D G:$D(DIRUT) QT
. K ARR S LEN="Division: "_$S(DV=999999:"NO DIVISION",1:$$GET1^DIQ(4,DV,.01))
. W !!,LEN,! F I=1:1:$L(LEN) W "-"
. S LD=0 F S LD=$O(^XTMP(PSONS,$J,DV,LD)) Q:'LD D Q:$D(DIRUT)
.. S ND=0 F S ND=$O(^XTMP(PSONS,$J,DV,LD,ND)) Q:'ND D Q:$D(DIRUT)
... S DAT=^XTV(FN,ND,0),IEN=$P(DAT,"^"),FE=$P(DAT,"^",3)
... D GETS^DIQ(FN,ND,".01;.02;.03;.04;.05;.06;.08","E","XTV")
... S ARR(IEN)=""
... I PSORPT=1 D
.... W !,$E($G(XTV(FN,ND_",",.01,"E"))_FSP,1,25),?28,$E($G(XTV(FN,ND_",",.02,"E"))_FSP,1,25),?55,$E($P($G(^DD($S(FE>50:200,1:8991.9),FE,0)),U)_FSP,1,24)
.... W !,?3,"ORIGINAL DATA: "
.... I FE=.04 S Y=$P(DAT,"^",4) D DT^DIO2 I $G(XTV(FN,ND_",",.08,"E"))]"" D ;1749 ***
..... W ?58,"For DEA#: ",$G(XTV(FN,ND_",",.08,"E")) ;1749 ***
.... I FE'=.04 W $S($G(XTV(FN,ND_",",.04,"E"))="True":1,$G(XTV(FN,ND_",",.04,"E"))="False":0,1:$G(XTV(FN,ND_",",.04,"E"))) I $G(XTV(FN,ND_",",.08,"E"))]"" D ;1749 ***
..... W ?58,"For DEA#: ",$G(XTV(FN,ND_",",.08,"E")) ;1749 ***
.... W !,?3," EDITED DATA: "
.... I FE=.04 S Y=$P(DAT,"^",5) D DT^DIO2
.... I FE'=.04 W $S($G(XTV(FN,ND_",",.05,"E"))="True":1,$G(XTV(FN,ND_",",.05,"E"))="False":0,1:$G(XTV(FN,ND_",",.05,"E")))_$S(FE>50:" (Source: File #200)",1:"")
.... S Y=$P($P(DAT,"^",6),".",1) W ?62,"DATE: " D DT^DIO2
... I PSORPT'=1 W !,$G(XTV(FN,ND_",",.01,"E")),?24,$G(XTV(FN,ND_",",.02,"E")),?48,$G(XTV(FN,ND_",",.03,"E")),?61,$G(XTV(FN,ND_",",.04,"E"))
... S ARR(IEN)=""
... D:($Y+4)>IOSL HD
. S J=0 F S J=$O(ARR(J)) Q:'J D:$D(^XTMP(PSONS,$J,"Z",J)) FT
QT ;
K DIR,DTOUT,DUOUT,DIRUT
D EXIT
Q
;
GUI ; Entry point for ePCS GUI Report
N PSORPT,PSONS,FLG,FN,OPT,ZPR,RT,PSOSCR,BDT,EDT,PSOION
S PSORPT=1 ; Tells the INIT section to set FN to '8991.6'
D INIT K %DT,DTOUT,ZPR
;
S PSOSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
;
S BDT=EPCSSD S EDT=EPCSED ; Set the date values based on input parameters
I $G(EPCSPTYP)="E" D EXPORT^PSODEARU(PSONS,BDT,EDT,FN) Q ;,^EPCSKILL Q ; This report will be exported
;I $G(EPCSPTYP)="E" D EXPORT^PSODEARU Q
D OEN ; Run Report
;I $D(EPCSGUI) D ^EPCSKILL Q // Kill variables...
Q
;
HD ;
I PAGE>1,$E(IOST)="C" S DIR(0)="E",DIR("A")=" Press Return to Continue or ^ to Exit" D ^DIR K DIR
Q:$D(DIRUT)
W @IOF
I $G(POD) D
. W !,?HCL,RHD,!,"For the Period: " S Y=BDT D DT^DIO2
. W " to " S Y=$E(EDT,1,7) D DT^DIO2 W " Run Date: " S Y=DT D DT^DIO2 W ?72,"Page "_PAGE,! S PAGE=PAGE+1
E W !,RHD,?50,RDT,?72,"Page "_PAGE,! S PAGE=PAGE+1
I PSORPT=1 W !,"NAME",?28,"EDITED BY",?55,"FIELD EDITED"
I PSORPT=2 W !,"NAME",?48,"ALLOCATION",!,?24,"EDITED BY",?48,"STATUS",?61,"DATE/TIME EDITED"
W !,LINE
Q
;
FT ; Find Divisions for specific user
S LEN="**Note: This user is defined under these divisions"
W !!,LEN
W ! F I=1:1:$L(LEN) W "-"
S (DAT,ND)=0 F S ND=$O(^VA(200,J,2,ND)) Q:'ND D
. S DAT=DAT+1 W ! W:DAT=1 $$GET1^DIQ(200,J,.01) W ?32,$$GET1^DIQ(4,ND,.01)
I $E(IOST)="C" S DIR(0)="E" D ^DIR K DIR
Q
;
PARAM ;Allow user to edit parameters
N DIR,Y
S VALMBCK="R" D FULL^VALM1
F D Q:'Y
.S DIR(0)="SO^1:PSOEPCS LOGICAL ACC REPORT DEV;2:PSOEPCS LOGICAL ACC RPT EMAIL;3:PSOEPCS PHARM ACC RPT DEVICE;4:PSOEPCS PHARM ACC REPORT EMAIL"
.S DIR("A")="Select parameter to edit"
.D ^DIR K DIR Q:'Y
.D EDITPAR^XPAREDIT(Y(0))
Q
;
FAIL ; Failover parameter edit
D EDITPAR^XPAREDIT("PSOEPCS EXPIRED DEA FAILOVER")
Q
;
MBM ; Pharmacy Operating Mode
N DIR,Y,X,PSOFDA,PSOERR
S DIR(0)="SAO^MBM:MEDS BY MAIL;VAMC:VA MEDICAL CENTER"
S DIR("A")="PHARMACY OPERATING MODE: "
S DIR("?",1)="Choose Pharmacy Operating Mode as VAMC to utilize business rules appropriate"
S DIR("?",2)="to the traditional VA pharmacy setting. Choose Pharmacy Operating Mode as MBM"
S DIR("?",3)="to utilize business rules specific and appropriate for the Meds by Mail pharmacy"
S DIR("?",4)="setting only. VistA behavior will follow the rules of the VAMC Operating Mode"
S DIR("?")="if this value is not set."
S DIR("B")=$$GET1^DIQ(59.7,1_",",102,"E")
D ^DIR K DIR
I Y="MBM"!(Y="VAMC") D Q
. S PSOFDA(59.7,1_",",102)=Y D FILE^DIE("","PSOFDA","PSOERR")
I X="@" S (X,Y)="" D Q
.N DIR S DIR(0)="Y",DIR("A")="SURE YOU WANT TO DELETE"
.D ^DIR Q:'$G(Y)
.S PSOFDA(59.7,1_",",102)="" D FILE^DIE("","PSOFDA","PSOERR")
Q
;
FOM() ; Failover Message
Q:'$D(DIR("B"))
I DIR("B")="YES",Y=0 D
. W !!,"***************************** WARNING ******************************************"
. W !,"A value of NO prevents providers with an expired DEA number from prescribing"
. W !,"controlled substances. A provider without a DEA number will still be able to"
. W !,"prescribe controlled substances if they have a VA number entered in VistA.",!
Q
;
PRIVSRT ; Print Prescribers with Privileges report
N DIS,FLDS,L,BY
S DIC="^VA(200,",L=0,BY="[PSO DEA DIV SORT]",FLDS="[PSO DEA PRIVS PRINT]"
S DIS(0)="I $$VUSER2^PSODEART(D0,1)"
S IOP=";80;9999"
D EN1^DIP
Q
;
PRIVSDRT ; Print Prescribers with Privileges report
N DIS,FLDS,L,BY
S DIC="^VA(200,",L=0,BY="[PSO DEA DISUSER2 SORT]",FLDS="[PSO DEA DISUSER PRIVS PRINT]"
S DIS(0)="I $$VUSER2^PSODEART(D0,0)"
S IOP=";80;9999"
D EN1^DIP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODEART 18204 printed Oct 16, 2024@18:27:20 Page 2
PSODEART ;FO-OAKAND/REM - EPCS Utilities and Reports; [5/7/02 5:53am] ;10/5/21 09:42
+1 ;;7.0;OUTPATIENT PHARMACY;**667,545,714,731**;DEC 1997;Build 18
+2 ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
+3 ;External reference to XUEPCS DATA file (#8991.6) is supported by DBIA 7015
+4 ;External reference to XUEPCS PSDRPH AUDIT file (#8991.7) is supported by DBIA 7016
+5 ;External reference to KEYS sub-file (#200.051) is supported by DBIA 7054
+6 ;
+7 ; PSO*7.0*714 - Liberty ITS/RJH - Add K DIC commands to the PSDKEY tag to
+8 ; prevent showing the "Enter User Name:" prompt incorrectly
+9 ; upon exit of the option.
+10 QUIT
+11 ;
PRESCBR(PSOSD0) ;called from print option - PSO EPCS PRIVS
+1 ;PSOSD0 is D0
+2 ; screening for prescribers with DEA# or VA#
+3 NEW PSOSPS
+4 SET PSOSPS=$GET(^VA(200,PSOSD0,"PS"))
+5 if $LENGTH(($$PRDEA^XUSER(0,PSOSD0)))!($PIECE(PSOSPS,U,3)'="")
QUIT 1
+6 QUIT 0
+7 ;
PRIVS(PSOSD0) ;called from print option - PSO EPCS PRIVS
+1 ;PSOSD0 is D0
+2 ;user with controlled substance privileges?
+3 ;based on 6 sub-schedules, PS3 node, pieces 1-6
+4 NEW PSOSPS3
+5 SET PSOSPS3=$$PRSCH^XUSER(PSOSD0)
+6 ; yes, if at least one explicit Yes
if ($PIECE(PSOSPS3,U,1,6)[1)
QUIT 1
+7 ; no, if explicit No
if ($PIECE(PSOSPS3,U,1,6)[0)
QUIT 0
+8 ; default, when all NULL
QUIT 1
+9 ;
XT30(PSOSD0,ACT) ;called from print option - PSO EPCS XDATE EXPIRES
+1 ;chk user ACTIVE,with DEA# and xdate expires in 30 days
+2 ;PSOSD0=IEN, ACT=(1 or 0) active user of not
+3 NEW XDT,DT30,DEA,CNT
+4 SET CNT=0
+5 SET XDT=$$PRXDT^XUSER(PSOSD0)
SET DT30=$$FMADD^XLFDT(DT,30)
SET DEA=$$PRDEA^XUSER(PSOSD0)
+6 IF (DEA'="")
IF (XDT'>DT30)
IF (XDT'<DT)
SET CNT=CNT+1
+7 IF ACT
Begin DoDot:1
+8 IF $$ACTIVE^XUSER(PSOSD0)
SET CNT=CNT+1
End DoDot:1
+9 IF 'ACT
Begin DoDot:1
+10 IF '$$ACTIVE^XUSER(PSOSD0)
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 - PSO EPCS LOGICAL ACCESS
+2 ;Only runs if data has changed from previous day.
+3 ;FLG=records exist for previous day.
+4 ;Generate report & Mail message to PSDMGR key holders
+5 NEW BDT,LD,EDT,FLG,DEV,FN,PSONS,ZPR,FSP,RHD,RT,PSORPT,OPT,X1,X2,FE
SET PSORPT=1
DO INIT
+6 ;Get the previous day date
DO NOW^%DTC
SET X1=X
SET X2="-1"
DO C^%DTC
SET (BDT,LD)=X
SET EDT=X_".999999"
+7 FOR
SET LD=$ORDER(^XTV(FN,"DT",LD))
if LD=""!(FLG=1)
QUIT
Begin DoDot:1
+8 if LD<EDT
SET FLG=1
End DoDot:1
+9 if $GET(ZPR)
DO AUTPRT
DO GMAIL
EXIT KILL ^TMP(PSONS,$JOB),^XTMP(PSONS,$JOB)
+1 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
+3 ;
RPT2 ;ePCS report - allocation history for PSDRPH key
+1 ;called from option - PSO DEA PSDRPH AUDIT
+2 ;Only runs if data has changed from previous day.
+3 ;FLG=records exist for previous day
+4 ;Generate report & Mail message to PSDMGR key holders
+5 NEW BDT,ST,EDT,FLG,DEV,FN,PSONS,ZPR,RHD,RT,PSORPT,OPT,X1,X2,FE
SET PSORPT=2
DO INIT
if 'FN
QUIT
+6 ;Get the previous day date
DO NOW^%DTC
SET X1=X
SET X2="-1"
DO C^%DTC
SET (BDT,ST)=X
SET EDT=X_".999999"
+7 FOR
SET ST=$ORDER(^XTV(FN,"DT",ST))
if ST=""!(FLG=1)
QUIT
Begin DoDot:1
+8 if ST<EDT
SET FLG=1
End DoDot:1
+9 if $GET(ZPR)
DO AUTPRT
DO GMAIL
+10 DO EXIT
+11 QUIT
+12 ;
PSDKEY ;Allocated/de-allocate the PSDRPH key option
+1 ;called from option - PSO EPCS PSDRPH KEY
+2 NEW PSOBOSS,PSODA,PSOKEY,PSORET,PSONAME,PSONS,OK,NOW,IEN,MSG,INPUT,NOW,DA
+3 SET PSOKEY=$$LKUP^XPDKEY("PSDRPH")
+4 IF PSOKEY=""
WRITE !,"PSDRPH key does not exist"
QUIT
+5 SET PSOBOSS=0
+6 ;PSDRPH KEY check - delegate & holders
+7 SET PSONS=$$GET1^DIQ(200.052,PSOKEY_","_DUZ_",",".01","",,"MSG")
+8 if PSONS="PSDRPH"
SET PSOBOSS=2
KILL PSONS,MSG
+9 if (DUZ(0)["@"!($DATA(^XUSEC("XUMGR",DUZ)))!($DATA(^XUSEC("PSDRPH",DUZ))))
SET PSOBOSS=1
+10 IF 'PSOBOSS
WRITE !,"You don't have privileges. See your package coordinator or site manager."
QUIT
+11 ;
+12 ; *** Begin PSO*7.0*714 changes ***
+13 ; K DIC S DIC="^VA(200,",DIC(0)="AEMQZ",DIC("A")="Enter User Name: " D ^DIC Q:Y<0
+14 KILL DIC
SET DIC="^VA(200,"
SET DIC(0)="AEMQZ"
SET DIC("A")="Enter User Name: "
DO ^DIC
IF Y<0
KILL DIC
QUIT
+15 ; I PSOBOSS=2,(DUZ=+Y) W !!,$C(7),"==> Sorry, you can't give yourself keys. See your IRM staff." Q
+16 IF PSOBOSS=2
IF (DUZ=+Y)
WRITE !!,$CHAR(7),"==> Sorry, you can't give yourself keys. See your IRM staff."
KILL DIC
QUIT
+17 SET PSODA=+Y
SET PSONAME=$PIECE(Y,U,2)
+18 ;chk if user had key
DO OWNSKEY^XUSRB(.PSONS,"PSDRPH",PSODA)
SET PSORET=PSONS(0)
+19 ; S OK=$$ASK(PSORET,PSONAME) I 'OK W !,"Nothing done..." Q
+20 SET OK=$$ASK(PSORET,PSONAME)
KILL DIC
IF 'OK
WRITE !,"Nothing done..."
QUIT
+21 ; *** End PSO*7.0*714 changes ***
+22 ;
+23 ;De-allocate key
+24 IF PSORET
KILL DIK
SET DIK="^VA(200,PSODA,51,"
SET DA(1)=PSODA
SET DA=PSOKEY
DO ^DIK
+25 ;Allocate key
+26 IF 'PSORET
SET FDA(200.051,"+1,"_PSODA_",",.01)="PSDRPH"
DO UPDATE^DIE("E","FDA","IEN","MSG")
+27 ;Set and record audit data
+28 SET NOW=$PIECE($$HTE^XLFDT($HOROLOG),":",1,2)
+29 SET INPUT="`"_PSODA_"^"_"`"_$GET(DUZ)_"^"_$SELECT(PSORET:0,1:1)
DO RECORD(INPUT,NOW)
+30 QUIT
+31 ;
ASK(TYPE,NAME,DELEG) ;Ask user if Allocate/De-allocate or Delegate/Un-delegate - returns y/n
+1 ;TYPE - flag weather Allocate/De-allocate or Delegate/Un-delegate
+2 ;Name - user's name
+3 NEW DIR,Y
+4 SET DELEG=$GET(DELEG,"")
+5 IF DELEG
SET DIR("A")=$SELECT(TYPE=1:"Un-delegate",1:"Delegate")_" PSDRPH for "_NAME
+6 IF 'DELEG
SET DIR("A")=$SELECT(TYPE=1:"De-allocate",1:"Allocate")_" PSDRPH for "_NAME
+7 SET DIR("B")="Y"
+8 SET DIR(0)="Y"
DO ^DIR
KILL DIR
+9 QUIT Y
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(PSOSD0,ACT) ;called from option - PSO EPCS DISUSER EXP DATE,PSO EPCS EXP DATE
+1 ;chk user ACTIVE, with DEA# and null DEA Exp Date
+2 ;PSOSD0=IEN, ACT=(1 or 0) active user or not
+3 NEW CNT
+4 SET CNT=0
+5 IF $$PRDEA^XUSER(PSOSD0)'=""
SET CNT=CNT+1
+6 IF $$PRXDT^XUSER(PSOSD0)=""
SET CNT=CNT+1
+7 IF ACT
Begin DoDot:1
+8 IF $$ACTIVE^XUSER(PSOSD0)
SET CNT=CNT+1
End DoDot:1
+9 IF 'ACT
Begin DoDot:1
+10 IF '$$ACTIVE^XUSER(PSOSD0)
SET CNT=CNT+1
End DoDot:1
+11 IF CNT=3
QUIT 1
+12 QUIT 0
+13 ;
VUSER2(PSOSD0,ACT) ;called from option - PSO EPCS PRIVS,PSO EPCS DISUSER PRIVS
+1 ;chk user ACTIVE, with DEA# or VA# with privilages - sch II-V
+2 ;PSOSD0=IEN, ACT=(1 or 0) active user or not
+3 NEW CNT
+4 SET CNT=0
+5 IF $$PRESCBR^PSODEART(PSOSD0)
SET CNT=CNT+1
+6 IF $$PRIVS^PSODEART(PSOSD0)
SET CNT=CNT+1
+7 IF ACT
Begin DoDot:1
+8 IF $$ACTIVE^XUSER(PSOSD0)
SET CNT=CNT+1
End DoDot:1
+9 IF 'ACT
Begin DoDot:1
+10 IF '$$ACTIVE^XUSER(PSOSD0)
SET CNT=CNT+1
End DoDot:1
+11 IF CNT=3
QUIT CNT
+12 QUIT 0
+13 ;
INIT ;
+1 SET PSONS="PSODEA"
SET $PIECE(FSP," ",25)=""
+2 SET FLG=0
SET FN=$SELECT(PSORPT=1:8991.6,1:8991.7)
+3 SET RHD=$SELECT(PSORPT=1:"SETTING OR CHANGES TO DEA PRESCRIBING PRIVILEGES",1:"PSDRPH KEY AUDIT LIST")
+4 SET OPT=$SELECT(PSORPT=1:"PSO EPCS LOGICAL ACCESS",1:"PSO EPCS PHARMACIST ACCESS")
+5 SET ZPR=$$GET^XPAR("SYS",$SELECT(PSORPT=1:"PSOEPCS LOGICAL ACC REPORT DEV",1:"PSOEPCS PHARM ACC RPT DEVICE",1:""),1,"I")
+6 SET RT=$$NOW^XLFDT
+7 KILL ^XTMP(PSONS,$JOB),^TMP(PSONS,$JOB)
+8 QUIT
+9 ;
GMAIL ;
+1 NEW LC,ND,DAT,ARR,I,J,P1,P2,P3,P4,P5,P6,P6L,P6S,RT,XTV,DV,P8L,P8S
DO INIT
+2 SET LD=BDT
FOR
SET LD=$ORDER(^XTV(FN,"DT",LD))
if 'LD!(LD>EDT)
QUIT
Begin DoDot:1
+3 SET ND=0
FOR
SET ND=$ORDER(^XTV(FN,"DT",LD,ND))
if 'ND
QUIT
Begin DoDot:2
+4 if '$DATA(^XTV(FN,ND,0))
QUIT
+5 SET DAT=^XTV(FN,ND,0)
+6 SET IEN=$PIECE(DAT,"^")
+7 ;S DV=$O(^VA(200,IEN,2,0)) S:'DV DV=999999
+8 ;S ^XTMP(PSONS,$J,DV,LD,ND)=""
+9 ;S:$O(^VA(200,IEN,2,DV)) ^XTMP(PSONS,$J,"Z",IEN)=""
+10 SET (DV,DVS)=0
FOR
SET DV=$ORDER(^VA(200,IEN,2,DV))
if ('DV)&(DVS>0)
QUIT
if 'DV
SET DV=999999
Begin DoDot:3
+11 SET DVS=DVS+1
+12 SET ^XTMP(PSONS,$JOB,DV,LD,ND)=""
+13 if $ORDER(^VA(200,IEN,2,DV))
SET ^XTMP(PSONS,$JOB,"Z",IEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
SMAIL ;
+1 SET XMSUB="PSO EPCS "_$SELECT(PSORPT=1:"LOGICAL",1:"PHARMACIST")_" ACCESS REPORT"
SET XMDUZ=.5
+2 SET LC=1
SET ^TMP(PSONS,$JOB,LC)=RHD
SET $EXTRACT(^TMP(PSONS,$JOB,LC),60)=$$UP^XLFSTR($$FMTE^XLFDT(RT,"M"))
SET LC=LC+1
+3 IF '$DATA(^XTMP(PSONS,$JOB))
Begin DoDot:1
+4 SET ^TMP(PSONS,$JOB,LC)=""
SET LC=LC+1
+5 SET ^TMP(PSONS,$JOB,LC)=" *************** NO MATCHING DATA ***************"
SET LC=LC+1
+6 SET ^TMP(PSONS,$JOB,LC)=""
SET LC=LC+1
End DoDot:1
GOTO MGRP
+7 IF PSORPT=1
Begin DoDot:1
+8 SET ^TMP(PSONS,$JOB,LC)="NAME"
SET $EXTRACT(^TMP(PSONS,$JOB,LC),28)="EDITED BY"
SET $EXTRACT(^TMP(PSONS,$JOB,LC),55)="FIELD EDITED"
SET LC=LC+1
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 SET ^TMP(PSONS,$JOB,LC)="NAME"
SET $EXTRACT(^TMP(PSONS,$JOB,LC),48)="ALLOCATION"
SET LC=LC+1
+11 SET $EXTRACT(^TMP(PSONS,$JOB,LC),24)="EDITED BY"
SET $EXTRACT(^TMP(PSONS,$JOB,LC),48)="STATUS"
SET $EXTRACT(^TMP(PSONS,$JOB,LC),60)="DATE/TIME EDITED"
SET LC=LC+1
End DoDot:1
+12 SET $PIECE(^TMP(PSONS,$JOB,LC),"-",79)=""
SET LC=LC+1
+13 SET DV=""
FOR
SET DV=$ORDER(^XTMP(PSONS,$JOB,DV))
if 'DV
QUIT
Begin DoDot:1
+14 KILL ARR
+15 SET ^TMP(PSONS,$JOB,LC)=""
SET LC=LC+1
+16 SET ^TMP(PSONS,$JOB,LC)="Division: "_$SELECT(DV=999999:"NO DIVISION",1:$$GET1^DIQ(4,DV,.01))
SET LEN=$LENGTH(^TMP(PSONS,$JOB,LC))+1
SET LC=LC+1
+17 SET $PIECE(^TMP(PSONS,$JOB,LC),"-",LEN)=""
SET LC=LC+1
+18 SET LD=0
FOR
SET LD=$ORDER(^XTMP(PSONS,$JOB,DV,LD))
if 'LD
QUIT
Begin DoDot:2
+19 SET ND=0
FOR
SET ND=$ORDER(^XTMP(PSONS,$JOB,DV,LD,ND))
if 'ND
QUIT
DO BMAIL
End DoDot:2
+20 SET J=0
FOR
SET J=$ORDER(ARR(J))
if 'J
QUIT
if $DATA(^XTMP(PSONS,$JOB,"Z",J))
DO MFT
End DoDot:1
MGRP ;
+1 NEW XMY,MDUZ
+2 IF PSORPT=1
SET DEV=$$GET^XPAR("SYS","PSOEPCS LOGICAL ACC RPT EMAIL",1,"E")
+3 IF '$TEST
SET DEV=$$GET^XPAR("SYS","PSOEPCS PHARM ACC REPORT EMAIL",1,"E")
+4 IF DEV]""
SET XMY("G."_DEV)=""
+5 IF '$TEST
Begin DoDot:1
+6 SET MDUZ=0
+7 IF $DATA(^XUSEC("PSDMGR"))
Begin DoDot:2
+8 FOR
SET MDUZ=$ORDER(^XUSEC("PSDMGR",MDUZ))
if MDUZ'>0
QUIT
SET XMY(MDUZ)=""
End DoDot:2
End DoDot:1
+9 if '$ORDER(XMY(0))
SET XMY(DUZ)=""
+10 SET XMTEXT="^TMP(PSONS,$J,"
NEW DIFROM
DO ^XMD
KILL XMDUZ,XMTEXT,XMSUB
+11 QUIT
+12 ;
BMAIL ;
+1 SET DAT=^XTV(FN,ND,0)
SET IEN=$PIECE(DAT,"^")
SET ARR(IEN)=""
+2 ;P731 detox/x-waiver removal
IF FN=8991.6
IF $PIECE(DAT,"^",3)=.03
QUIT
+3 DO GETS^DIQ(FN,ND,".01;.02;.04;.05;.06;.08","E","XTV")
+4 DO GETS^DIQ(FN,ND,".03","IE","XTV")
+5 SET P1=$GET(XTV(FN,ND_",",.01,"E"))_FSP
+6 SET P2=$GET(XTV(FN,ND_",",.02,"E"))_FSP
+7 SET FE=$GET(XTV(FN,ND_",",.03,"I"))
+8 IF PSORPT=1
SET P3=$PIECE($GET(^DD($SELECT(FE>50:200,1:8991.9),FE,0)),U)
+9 IF PSORPT=2
SET P3=$GET(XTV(FN,ND_",",.03,"E"))_FSP
+10 SET P4=$GET(XTV(FN,ND_",",.04,"E"))
+11 SET P5=$GET(XTV(FN,ND_",",.05,"E"))
+12 SET P6=$GET(XTV(FN,ND_",",.06,"E"))
SET P6=$PIECE(P6,"@",1)
+13 IF PSORPT=1
Begin DoDot:1
+14 IF $LENGTH(P4)=7
SET Y=P4
DO DT^DIO2
SET P4=Y
SET Y=P5
DO DT^DIO2
SET P5=Y
+15 IF $LENGTH(P4)<7
Begin DoDot:2
+16 SET P4=$SELECT($GET(XTV(FN,ND_",",.04,"E"))="True":1,$GET(XTV(FN,ND_",",.04,"E"))="False":0,1:$GET(XTV(FN,ND_",",.04,"E")))
+17 SET P5=$SELECT($GET(XTV(FN,ND_",",.05,"E"))="True":1,$GET(XTV(FN,ND_",",.05,"E"))="False":0,1:$GET(XTV(FN,ND_",",.05,"E")))
End DoDot:2
+18 SET ^TMP(PSONS,$JOB,LC)=$EXTRACT(P1,1,28)_$EXTRACT(P2,1,26)_$EXTRACT(P3_FSP,1,24)
SET LC=LC+1
+19 SET ^TMP(PSONS,$JOB,LC)=" ORIGINAL DATA: "_P4
+20 ;1749***
IF $GET(XTV(FN,ND_",",.08,"E"))]""
Begin DoDot:2
+21 ;1749***
SET P8L=$LENGTH(^TMP(PSONS,$JOB,LC))
+22 ;1749***
SET P8S=$EXTRACT(FSP_FSP,1,56-P8L)
+23 ;1749***
SET ^TMP(PSONS,$JOB,LC)=^TMP(PSONS,$JOB,LC)_P8S_"For DEA#: "_$GET(XTV(FN,ND_",",.08,"E"))
End DoDot:2
+24 SET LC=LC+1
+25 SET ^TMP(PSONS,$JOB,LC)=" EDITED DATA: "_P5_$SELECT(FE>50:" (Source: File #200)",1:"")
+26 SET P6L=$LENGTH(^TMP(PSONS,$JOB,LC))
+27 SET P6S=$EXTRACT(FSP_FSP,1,60-P6L)
+28 SET ^TMP(PSONS,$JOB,LC)=^TMP(PSONS,$JOB,LC)_P6S_"DATE: "_P6
SET LC=LC+1
End DoDot:1
+29 IF '$TEST
SET ^TMP(PSONS,$JOB,LC)=$EXTRACT(P1,1,22)_" "_$EXTRACT(P2,1,22)_" "_$EXTRACT(P3,1,12)_" "_P4
SET LC=LC+1
+30 QUIT
+31 ;
MFT ;
+1 SET ^TMP(PSONS,$JOB,LC)=""
SET LC=LC+1
+2 SET ^TMP(PSONS,$JOB,LC)="**Note: This user is defined under these divisions"
SET LEN=$LENGTH(^TMP(PSONS,$JOB,LC))+1
SET LC=LC+1
+3 SET $PIECE(^TMP(PSONS,$JOB,LC),"-",LEN)=""
SET LC=LC+1
+4 SET (DAT,ND)=0
FOR
SET ND=$ORDER(^VA(200,J,2,ND))
if 'ND
QUIT
Begin DoDot:1
+5 SET DAT=DAT+1
if DAT=1
SET ^TMP(PSONS,$JOB,LC)=$$GET1^DIQ(200,J,.01)
SET $EXTRACT(^TMP(PSONS,$JOB,LC),32)=$$GET1^DIQ(4,ND,.01)
SET LC=LC+1
End DoDot:1
+6 QUIT
+7 ;
ODRPT ;
+1 ;ePCS on demand report - setting or modifing to logical access controls/allocation history for PSDRPH key
+2 ;called from option - PSO EPCS LOGICAL ACCESS/PSO EPCS PSDRPH AUDIT
+3 ;provide a date range
+4 NEW BDT,EDT,FLG,ST,FN,PSONS,POD,RHD,RT,OPT,PSOION,PSOOUT,PSOTYP
DO INIT
KILL %DT,DTOUT,ZPR
+5 WRITE !
SET %DT(0)=-DT
SET %DT("A")="Beginning Date: "
SET %DT="APE"
DO ^%DT
IF Y<0!($DATA(DTOUT))
GOTO EXIT
+6 SET POD=1
SET (%DT(0),BDT)=Y
+7 WRITE !
SET %DT("A")="Ending Date: "
DO ^%DT
IF Y<0!($DATA(DTOUT))
GOTO EXIT
+8 SET EDT=Y_".9999"
+9 SET ST=BDT
SET FLG=0
FOR
SET ST=$ORDER(^XTV(FN,"DT",ST))
if ST=""!(FLG=1)
QUIT
Begin DoDot:1
+10 if ST<EDT
SET FLG=1
End DoDot:1
+11 IF FLG=0
WRITE !!?18,"********** NO DATA TO PRINT **********"
HANG 2
GOTO EXIT
+12 IF PSORPT=1
Begin DoDot:1
+13 DO TYPE^PSODEARU
IF $GET(PSOOUT)
QUIT
+14 IF $GET(PSOTYP)="D"
DO DL^PSODEARU
IF $GET(PSOOUT)
QUIT
+15 IF $GET(PSOTYP)="D"
DO OENDL^PSODEARU(PSONS,BDT,EDT,FN)
End DoDot:1
if $GET(PSOTYP)="D"
GOTO EXIT
if $GET(PSOOUT)
GOTO EXIT
+16 KILL IOP,%ZIS,POP
SET PSOION=ION
SET %ZIS="MQ"
DO ^%ZIS
IF POP
SET IOP=PSOION
DO ^%ZIS
GOTO EXIT
AUTPRT ;
+1 IF $GET(ZPR)!$DATA(IO("Q"))
Begin DoDot:1
+2 NEW ZTRTN,ZTDESC,ZTIO,ZTSAVE,ZTDTH,ZTSK,ZTREQ,ZTQUEUED
+3 if $GET(ZPR)
SET ZTIO="`"_ZPR
SET ZTDTH=$HOROLOG
SET ZTRTN="OEN^PSODEART"
SET ZTDESC=OPT
SET ZTSAVE("BDT")=""
SET ZTSAVE("EDT")=""
SET ZTSAVE("PSORPT")=""
SET ZTSAVE("POD")=""
+4 SET ZTSAVE("FN")=""
SET ZTSAVE("PSONS")=""
SET ZTSAVE("FLG")=""
SET ZTSAVE("RHD")=""
SET ZTSAVE("OPT")=""
SET ZTSAVE("RT")=""
SET ZTSAVE("FSP")=""
+5 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report is Queued to print !!"
End DoDot:1
GOTO EXIT
OEN ;
+1 USE IO
+2 NEW PAGE,LINE,LEN,XTV,ARR,I,J,RHD,HCL,FSP,RDT,DV,FE
+3 NEW DV,ND,DAT,IEN,DVS
KILL DIRUT
+4 KILL ^XTMP(PSONS,$JOB)
+5 SET LD=BDT
FOR
SET LD=$ORDER(^XTV(FN,"DT",LD))
if 'LD!(LD>EDT)
QUIT
Begin DoDot:1
+6 SET ND=0
FOR
SET ND=$ORDER(^XTV(FN,"DT",LD,ND))
if 'ND
QUIT
Begin DoDot:2
+7 if '$DATA(^XTV(FN,ND,0))
QUIT
+8 SET DAT=^XTV(FN,ND,0)
+9 ;P731 detox/x-waiver removal
IF PSORPT=1
IF $PIECE(DAT,"^",3)=.03
QUIT
+10 SET IEN=$PIECE(DAT,"^")
+11 SET (DV,DVS)=0
FOR
SET DV=$ORDER(^VA(200,IEN,2,DV))
if ('DV)&(DVS>0)
QUIT
if 'DV
SET DV=999999
Begin DoDot:3
+12 SET DVS=DVS+1
+13 SET ^XTMP(PSONS,$JOB,DV,LD,ND)=""
+14 if $ORDER(^VA(200,IEN,2,DV))
SET ^XTMP(PSONS,$JOB,"Z",IEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+15 SET RHD=$SELECT(PSORPT=1:"SETTING OR CHANGES TO DEA PRESCRIBING PRIVILEGES",1:"PSDRPH KEY AUDIT LIST")
+16 SET HCL=(80-$LENGTH(RHD))\2
SET RDT=$$FMTE^XLFDT($$NOW^XLFDT,"1M")
+17 SET PAGE=1
SET $PIECE(LINE,"-",79)=""
SET $PIECE(FSP," ",25)=""
+18 DO HD
+19 IF '$DATA(^XTMP(PSONS,$JOB))
Begin DoDot:1
+20 WRITE !!," *************** NO MATCHING DATA ***************",!!
End DoDot:1
GOTO QT
+21 SET DV=""
FOR
SET DV=$ORDER(^XTMP(PSONS,$JOB,DV))
if 'DV
QUIT
Begin DoDot:1
+22 KILL ARR
SET LEN="Division: "_$SELECT(DV=999999:"NO DIVISION",1:$$GET1^DIQ(4,DV,.01))
+23 WRITE !!,LEN,!
FOR I=1:1:$LENGTH(LEN)
WRITE "-"
+24 SET LD=0
FOR
SET LD=$ORDER(^XTMP(PSONS,$JOB,DV,LD))
if 'LD
QUIT
Begin DoDot:2
+25 SET ND=0
FOR
SET ND=$ORDER(^XTMP(PSONS,$JOB,DV,LD,ND))
if 'ND
QUIT
Begin DoDot:3
+26 SET DAT=^XTV(FN,ND,0)
SET IEN=$PIECE(DAT,"^")
SET FE=$PIECE(DAT,"^",3)
+27 DO GETS^DIQ(FN,ND,".01;.02;.03;.04;.05;.06;.08","E","XTV")
+28 SET ARR(IEN)=""
+29 IF PSORPT=1
Begin DoDot:4
+30 WRITE !,$EXTRACT($GET(XTV(FN,ND_",",.01,"E"))_FSP,1,25),?28,$EXTRACT($GET(XTV(FN,ND_",",.02,"E"))_FSP,1,25),?55,$EXTRACT($PIECE($GET(^DD($SELECT(FE>50:200,1:8991.9),FE,0)),U)_FSP,1,24)
+31 WRITE !,?3,"ORIGINAL DATA: "
+32 ;1749 ***
IF FE=.04
SET Y=$PIECE(DAT,"^",4)
DO DT^DIO2
IF $GET(XTV(FN,ND_",",.08,"E"))]""
Begin DoDot:5
+33 ;1749 ***
WRITE ?58,"For DEA#: ",$GET(XTV(FN,ND_",",.08,"E"))
End DoDot:5
+34 ;1749 ***
IF FE'=.04
WRITE $SELECT($GET(XTV(FN,ND_",",.04,"E"))="True":1,$GET(XTV(FN,ND_",",.04,"E"))="False":0,1:$GET(XTV(FN,ND_",",.04,"E")))
IF $GET(XTV(FN,ND_",",.08,"E"))]""
Begin DoDot:5
+35 ;1749 ***
WRITE ?58,"For DEA#: ",$GET(XTV(FN,ND_",",.08,"E"))
End DoDot:5
+36 WRITE !,?3," EDITED DATA: "
+37 IF FE=.04
SET Y=$PIECE(DAT,"^",5)
DO DT^DIO2
+38 IF FE'=.04
WRITE $SELECT($GET(XTV(FN,ND_",",.05,"E"))="True":1,$GET(XTV(FN,ND_",",.05,"E"))="False":0,1:$GET(XTV(FN,ND_",",.05,"E")))_$SELECT(FE>50:" (Source: File #200)",1:"")
+39 SET Y=$PIECE($PIECE(DAT,"^",6),".",1)
WRITE ?62,"DATE: "
DO DT^DIO2
End DoDot:4
+40 IF PSORPT'=1
WRITE !,$GET(XTV(FN,ND_",",.01,"E")),?24,$GET(XTV(FN,ND_",",.02,"E")),?48,$GET(XTV(FN,ND_",",.03,"E")),?61,$GET(XTV(FN,ND_",",.04,"E"))
+41 SET ARR(IEN)=""
+42 if ($Y+4)>IOSL
DO HD
End DoDot:3
if $DATA(DIRUT)
QUIT
End DoDot:2
if $DATA(DIRUT)
QUIT
+43 SET J=0
FOR
SET J=$ORDER(ARR(J))
if 'J
QUIT
if $DATA(^XTMP(PSONS,$JOB,"Z",J))
DO FT
End DoDot:1
if $DATA(DIRUT)
GOTO QT
QT ;
+1 KILL DIR,DTOUT,DUOUT,DIRUT
+2 DO EXIT
+3 QUIT
+4 ;
GUI ; Entry point for ePCS GUI Report
+1 NEW PSORPT,PSONS,FLG,FN,OPT,ZPR,RT,PSOSCR,BDT,EDT,PSOION
+2 ; Tells the INIT section to set FN to '8991.6'
SET PSORPT=1
+3 DO INIT
KILL %DT,DTOUT,ZPR
+4 ;
+5 SET PSOSCR=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)
+6 ;
+7 ; Set the date values based on input parameters
SET BDT=EPCSSD
SET EDT=EPCSED
+8 ;,^EPCSKILL Q ; This report will be exported
IF $GET(EPCSPTYP)="E"
DO EXPORT^PSODEARU(PSONS,BDT,EDT,FN)
QUIT
+9 ;I $G(EPCSPTYP)="E" D EXPORT^PSODEARU Q
+10 ; Run Report
DO OEN
+11 ;I $D(EPCSGUI) D ^EPCSKILL Q // Kill variables...
+12 QUIT
+13 ;
HD ;
+1 IF PAGE>1
IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
SET DIR("A")=" Press Return to Continue or ^ to Exit"
DO ^DIR
KILL DIR
+2 if $DATA(DIRUT)
QUIT
+3 WRITE @IOF
+4 IF $GET(POD)
Begin DoDot:1
+5 WRITE !,?HCL,RHD,!,"For the Period: "
SET Y=BDT
DO DT^DIO2
+6 WRITE " to "
SET Y=$EXTRACT(EDT,1,7)
DO DT^DIO2
WRITE " Run Date: "
SET Y=DT
DO DT^DIO2
WRITE ?72,"Page "_PAGE,!
SET PAGE=PAGE+1
End DoDot:1
+7 IF '$TEST
WRITE !,RHD,?50,RDT,?72,"Page "_PAGE,!
SET PAGE=PAGE+1
+8 IF PSORPT=1
WRITE !,"NAME",?28,"EDITED BY",?55,"FIELD EDITED"
+9 IF PSORPT=2
WRITE !,"NAME",?48,"ALLOCATION",!,?24,"EDITED BY",?48,"STATUS",?61,"DATE/TIME EDITED"
+10 WRITE !,LINE
+11 QUIT
+12 ;
FT ; Find Divisions for specific user
+1 SET LEN="**Note: This user is defined under these divisions"
+2 WRITE !!,LEN
+3 WRITE !
FOR I=1:1:$LENGTH(LEN)
WRITE "-"
+4 SET (DAT,ND)=0
FOR
SET ND=$ORDER(^VA(200,J,2,ND))
if 'ND
QUIT
Begin DoDot:1
+5 SET DAT=DAT+1
WRITE !
if DAT=1
WRITE $$GET1^DIQ(200,J,.01)
WRITE ?32,$$GET1^DIQ(4,ND,.01)
End DoDot:1
+6 IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
DO ^DIR
KILL DIR
+7 QUIT
+8 ;
PARAM ;Allow user to edit parameters
+1 NEW DIR,Y
+2 SET VALMBCK="R"
DO FULL^VALM1
+3 FOR
Begin DoDot:1
+4 SET DIR(0)="SO^1:PSOEPCS LOGICAL ACC REPORT DEV;2:PSOEPCS LOGICAL ACC RPT EMAIL;3:PSOEPCS PHARM ACC RPT DEVICE;4:PSOEPCS PHARM ACC REPORT EMAIL"
+5 SET DIR("A")="Select parameter to edit"
+6 DO ^DIR
KILL DIR
if 'Y
QUIT
+7 DO EDITPAR^XPAREDIT(Y(0))
End DoDot:1
if 'Y
QUIT
+8 QUIT
+9 ;
FAIL ; Failover parameter edit
+1 DO EDITPAR^XPAREDIT("PSOEPCS EXPIRED DEA FAILOVER")
+2 QUIT
+3 ;
MBM ; Pharmacy Operating Mode
+1 NEW DIR,Y,X,PSOFDA,PSOERR
+2 SET DIR(0)="SAO^MBM:MEDS BY MAIL;VAMC:VA MEDICAL CENTER"
+3 SET DIR("A")="PHARMACY OPERATING MODE: "
+4 SET DIR("?",1)="Choose Pharmacy Operating Mode as VAMC to utilize business rules appropriate"
+5 SET DIR("?",2)="to the traditional VA pharmacy setting. Choose Pharmacy Operating Mode as MBM"
+6 SET DIR("?",3)="to utilize business rules specific and appropriate for the Meds by Mail pharmacy"
+7 SET DIR("?",4)="setting only. VistA behavior will follow the rules of the VAMC Operating Mode"
+8 SET DIR("?")="if this value is not set."
+9 SET DIR("B")=$$GET1^DIQ(59.7,1_",",102,"E")
+10 DO ^DIR
KILL DIR
+11 IF Y="MBM"!(Y="VAMC")
Begin DoDot:1
+12 SET PSOFDA(59.7,1_",",102)=Y
DO FILE^DIE("","PSOFDA","PSOERR")
End DoDot:1
QUIT
+13 IF X="@"
SET (X,Y)=""
Begin DoDot:1
+14 NEW DIR
SET DIR(0)="Y"
SET DIR("A")="SURE YOU WANT TO DELETE"
+15 DO ^DIR
if '$GET(Y)
QUIT
+16 SET PSOFDA(59.7,1_",",102)=""
DO FILE^DIE("","PSOFDA","PSOERR")
End DoDot:1
QUIT
+17 QUIT
+18 ;
FOM() ; Failover Message
+1 if '$DATA(DIR("B"))
QUIT
+2 IF DIR("B")="YES"
IF Y=0
Begin DoDot:1
+3 WRITE !!,"***************************** WARNING ******************************************"
+4 WRITE !,"A value of NO prevents providers with an expired DEA number from prescribing"
+5 WRITE !,"controlled substances. A provider without a DEA number will still be able to"
+6 WRITE !,"prescribe controlled substances if they have a VA number entered in VistA.",!
End DoDot:1
+7 QUIT
+8 ;
PRIVSRT ; Print Prescribers with Privileges report
+1 NEW DIS,FLDS,L,BY
+2 SET DIC="^VA(200,"
SET L=0
SET BY="[PSO DEA DIV SORT]"
SET FLDS="[PSO DEA PRIVS PRINT]"
+3 SET DIS(0)="I $$VUSER2^PSODEART(D0,1)"
+4 SET IOP=";80;9999"
+5 DO EN1^DIP
+6 QUIT
+7 ;
PRIVSDRT ; Print Prescribers with Privileges report
+1 NEW DIS,FLDS,L,BY
+2 SET DIC="^VA(200,"
SET L=0
SET BY="[PSO DEA DISUSER2 SORT]"
SET FLDS="[PSO DEA DISUSER PRIVS PRINT]"
+3 SET DIS(0)="I $$VUSER2^PSODEART(D0,0)"
+4 SET IOP=";80;9999"
+5 DO EN1^DIP
+6 QUIT
