- 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 Jan 18, 2025@03:27:49 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