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

PSODEART.m

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