PSODIR5 ;DAL/JCH - ASK FOR DEA RX DATA ;11/08/21 4:03pm
;;7.0;OUTPATIENT PHARMACY;**545,731,743**;DEC 1997;Build 24
;External reference PSDRUG( supported by DBIA 221
;External reference PS(50.7 supported by DBIA 2223
;External reference to VA(200 is supported by DBIA 10060
;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
;External reference to sub-file NEW DEA #'S (#200.5321) is supported by DBIA 7000
;----------------------------------------------------------------
;
FAILOVER(DEARY,VA,SDEA) ;check failover flag, if expired DEA, use VA schedule
N FLOV,NDEA,DCNT
S FLOV=$$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I"),DCNT=0
I 'FLOV D WM2,DISPONLY(.DEARY) Q ""
S NDEA=$$SDEA^XUSER(FLOV,PROVIEN,SDEA)
I NDEA=1!(NDEA=2)!(+NDEA=4) D WM2,DISPONLY(.DEARY) Q ""
S DCNT=DCNT+1 W !,""_DCNT_". "_VA_" (VA#)" S DEARY(DCNT)=NDEA
I $D(DEARY(1)) S DLOOP=0 F S DLOOP=$O(DEARY(1,DLOOP)) Q:'DLOOP D
.W !,"* "_$P($G(DEARY(1,DLOOP)),U,2) W:$L($P($G(DEARY(1,DLOOP)),U,3)) "-"_$P($G(DEARY(1,DLOOP)),U,3) W " "_$P($G(DEARY(1,DLOOP)),U,4)_" Expired: "_$P($G(DEARY(1,DLOOP)),U,6)
Q $$DDIR^PSODIR5(DCNT)
;
DISP3(IEN,ARYSEL,PSORX) ;displays dea#,detox#,address
N DA,DIC,DR,DISPFLD,DISPVAL,DISPTXT,RES,DERR,ARYSEL
S DA=IEN,ARYSEL=Y
S DIC="^XTV(8991.9,"
S DR=".01"_$S($$GET1^DIQ(50,PSODRUG("IEN"),.01,"E")["BUPREN":";.03",1:"")_";1.2:1.7"
K ^UTILITY("DIQ1",$J)
D EN^DIQ1
W !
I $D(^UTILITY("DIQ1",$J)) D
. S DISPFLD=0 F S DISPFLD=$O(^UTILITY("DIQ1",$J,8991.9,DA,DISPFLD)) Q:'DISPFLD I DISPFLD'=.03 D ;P731 detox/x-waiver removal
.. S DISPVAL=$G(^UTILITY("DIQ1",$J,8991.9,DA,DISPFLD))
.. I DISPFLD=.01,$P(DEARY(2,ARYSEL),U,3)]"" S DISPVAL=DISPVAL_"-"_$P(DEARY(2,ARYSEL),U,3)
.. I DISPFLD=.03 S DISPVAL=$$DETOX^XUSER(PROVIEN)
.. K RES,DERR
.. D FIELD^DID(8991.9,DISPFLD,"","LABEL","RES","DERR")
.. I '$D(RES) Q
.. S DISPTXT=$G(RES("LABEL"))_": "_DISPVAL
.. W !," "_DISPTXT
;W ! I $G(PSOEDIT)!($G(ZZCOPY)) W !,"Press Return to continue: ",$C(7) R X:$S($D(DTIME):DTIME,1:300)
W !!!!,"Press Return to continue: ",$C(7) R X:$S($D(DTIME):DTIME,1:300)
S PSORX("RXDEA")=$P(DEARY(2,ARYSEL),U,2)
S:$P(DEARY(2,ARYSEL),U,3)]"" PSORX("RXDEA")=PSORX("RXDEA")_"-"_$P(DEARY(2,ARYSEL),U,3)
S DEASEL=PSORX("RXDEA")
Q DEASEL
;
USEVA(PROVIEN,VA,PSORX) ;Use VA# only when provider has no dea#
N INN,IN,XUEXDT,DEASEL,NODEA,NVA
S DEASEL=""
S NVA=+$G(^VA(200,PROVIEN,"TPB"))
S NODEA=$G(^VA(200,PROVIEN,"PS"))
I "34"[+$P(NODEA,U,6)!NVA D WM1 Q DEASEL
I '$L($P(NODEA,U,3)) D WM1 Q DEASEL
S NODEA=$G(^VA(200,PROVIEN,"PS3"))
S IN=$S(SDEA=2:1,SDEA="2n":2,SDEA=3:3,SDEA="3n":4,SDEA="4":5,1:6)
I '$P(NODEA,U,IN) D WM3(SDEA) Q DEASEL
S INN=$S($G(PSOPINST):+$G(PSOPINST),1:+DUZ(2)),IN=$P($G(^DIC(4,INN,"DEA")),U) ;signed-in Inst.
I '$L(IN) D
. N XU1 D PARENT^XUAF4("XU1","`"_INN,"PARENT FACILITY")
. S INN=$O(XU1("P","")) I INN S IN=$P($G(^DIC(4,INN,"DEA")),U)
. Q
I INN S XUEXDT=$P($G(^DIC(4,INN,"DEA")),U,2) ;check FACILITY DEA EXPIRATION DATE
S XUEXDT=$G(XUEXDT)
I $L(VA),$L(IN),$L(XUEXDT),XUEXDT'<DT S (DEARY,DEASEL)=IN_"-"_VA
I DEASEL="" D WM1 Q DEASEL
D INDISP(PROVIEN,DEARY,.PSORX)
S DEASEL=PSORX("RXDEA")
Q DEASEL
;
WM1 ;warning message
W !!,"Provider must have a current DEA# or VA# to write prescriptions for this drug.",!
Q
;
WM2 ; Warning message
W !!,"The provider's DEA# on file has Expired and must be updated.",!
Q
WM3(SCHED) ; Warning message
W $C(7),!!,"Provider not authorized to write Federal Schedule "_SCHED_" prescriptions.",!
Q
;
INDISP(PROVIEN,DEARY,PSORX) ;displays institutional dea#va#, address of institution
W !!,"DEA NUMBER: "_DEARY
;I $G(PSORX("DETX"))]"" W !,"DETOX NUMBER: "_PSORX("DETX") ;P731 detox/x-waiver removal
N MADD1,MADD2,MCITY,MSTATE,MZIP
S MADD1=$$GET1^DIQ(4,DUZ(2),1.01),MADD2=$$GET1^DIQ(4,DUZ(2),1.02)
S MCITY=$$GET1^DIQ(4,DUZ(2),1.03),MSTATE=$$GET1^DIQ(4,DUZ(2),.02)
S MZIP=$$GET1^DIQ(4,DUZ(2),1.04)
W !,"STREET ADDRESS 1:",MADD1
w !,"STREET ADDRESS 2:",MADD2
W !,"CITY:",MCITY
W !,"STATE:",MSTATE
W !,"ZIP CODE:",MZIP
W ! I $G(PSOEDIT)!($G(ZZCOPY)) W !,"Press Return to continue: ",$C(7) R X:$S($D(DTIME):DTIME,1:300)
S (DEASEL,PSORX("RXDEA"))=DEARY
Q DEASEL
;
DEALIST(RET,NPIEN,SDEA) ; -- returns the DEA list
; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
;
; OUTPUT: RET - A STRING OF DEA INFORMATION DELIMITED BY THE "^".
; RET ***** KILLED BY THIS RPC *****
; RET(0)=TOTCNT^NEXPCNT^EXPCNT - Count of DEA Numbers for a provider, count of expired DEA numbers for provider.
; RET(1,n) - Expired DEA Numbers
; RET(2,n) - Active DEA Numbers
; RET(3,n) - Not allowed to write that schedule
; 1 - DEA IEN
; 2 - DEA NUMBER
; 3 - INDIVIDUAL DEA SUFFIX
; 4 - STATE
; 5 - DETOX NUMBER
; 6 - EXPIRATION DATE EXTERNAL: FROM THE DEA NUMBERS FILE (#8991.9), FIELD EXPIRATION DATE (#.04)
; 7 - EXPIRATION DATE INTERNAL: FROM THE DEA NUMBERS FILE (#8991.9), FIELD EXPIRATION DATE (#.04)
;
N CNT,DNDEADAT,DNDEAIEN,FAIL,IENS,NPDEADAT,NPDEAIEN,EXPDATEI,EXPCNT,NODE1,DIFF,DNDEANUM,EXPFLG,DEASUFX
K RET S EXPCNT=0
S CNT(1)=0,CNT(2)=0,CNT(3)=0
S NPDEAIEN=0 F CNT=1:1 S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'+NPDEAIEN D
. S EXPFLG=0
. S IENS=NPDEAIEN_","_NPIEN_","
. K NPDEADAT D GETS^DIQ(200.5321,IENS,"**","","NPDEADAT") Q:'$D(NPDEADAT)
. S DNDEAIEN=$$GET1^DIQ(200.5321,IENS,.03,"I") Q:'DNDEAIEN
. K DNDEADAT D GETS^DIQ(8991.9,DNDEAIEN,"**","","DNDEADAT") Q:'$D(DNDEADAT)
. ;
. S EXPDATEI=$$GET1^DIQ(8991.9,DNDEAIEN,.04,"I"),DIFF=$$FMDIFF^XLFDT(DT,EXPDATEI,1)
. I DIFF>366 S EXPCNT=EXPCNT+1,CNT(1)=CNT(1)+1 Q
. I EXPDATEI,EXPDATEI<DT S EXPCNT=EXPCNT+1,NODE1=1,CNT(1)=CNT(1)+1,EXPFLG=1 ; Expired DEA Counter
. S DNDEANUM=$$GET1^DIQ(200.5321,IENS,.01,"E")
. I $$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")=1 S DEASUFX=$$GET1^DIQ(200.5321,IENS,.02,"E") I $L(DEASUFX)>2 S DNDEANUM=DNDEANUM_"-"_DEASUFX
. S NDEA=$$SDEA^XUSER($$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I"),NPIEN,SDEA,,DNDEANUM) ; Check to verify schedule permissions
. I EXPFLG'=1!(NDEA=2) S NODE1=3,CNT(3)=CNT(3)+1
. I EXPDATEI,'(EXPDATEI<DT),(NDEA'=2),(NDEA'=1),(EXPFLG'=1) S NODE1=2,CNT(2)=CNT(2)+1
. S RET(NODE1,CNT(NODE1))=""
. S RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_DNDEAIEN_"^" ; DEA IEN
. S RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_NPDEADAT(200.5321,IENS,.01)_"^" ; NEW PERSON DEA NUMBER
. S RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_NPDEADAT(200.5321,IENS,.02)_"^" ; INDIVIDUAL DEA SUFFIX
. S RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_DNDEADAT(8991.9,DNDEAIEN_",",1.6)_"^" ; STATE
. S RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_""_"^" ; DETOX NUMBER ;P731 detox/x-waiver removal
. S RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_DNDEADAT(8991.9,DNDEAIEN_",",.04)_"^" ; EXPIRATION DATE EXTERNAL
. S RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_EXPDATEI_"^" ; EXPIRATION DATE INTERNAL
S RET(0)=(CNT-1)_"^"_(CNT(2)+CNT(3))_"^"_CNT(1)
Q
;
DISPONLY(DEARY) ; Display only
I $D(DEARY(1)) S DLOOP=0 F S DLOOP=$O(DEARY(1,DLOOP)) Q:'DLOOP D
. W !,"* "_$P($G(DEARY(1,DLOOP)),U,2) W:$L($P($G(DEARY(1,DLOOP)),U,3)) "-"_$P($G(DEARY(1,DLOOP)),U,3) W " "_$P($G(DEARY(1,DLOOP)),U,4)_" Expired: "_$P($G(DEARY(1,DLOOP)),U,6)
I $D(DEARY(3)) S DLOOP=0 F S DLOOP=$O(DEARY(3,DLOOP)) Q:'DLOOP D
. W !,"* "_$P($G(DEARY(3,DLOOP)),U,2) W:$L($P($G(DEARY(3,DLOOP)),U,3)) "-"_$P($G(DEARY(3,DLOOP)),U,3)
. W " "_$P($G(DEARY(3,DLOOP)),U,4)_" Not Valid for Schedule: "_SDEA
S (DCNT,DLOOP)=0 F S DLOOP=$O(DEARY(2,DLOOP)) Q:'DLOOP D
. S DCNT=DCNT+1 W !,DCNT_". "_$P($G(DEARY(2,DLOOP)),U,2) W:$L($P($G(DEARY(2,DLOOP)),U,3)) "-"_$P($G(DEARY(2,DLOOP)),U,3) W " "_$P($G(DEARY(2,DLOOP)),U,4)
Q
;
;*545; DEA selection
SLDEA(PROVIEN,PSORX,DFLTDEA,PSODRIEN) ;
N DA,SDEA,VA,NDEA,DCNT,DLOOP,DEARY,Y,DEASEL,DFLTSEL,DL S DEASEL=""
I '$D(PSODRUG("IEN")),$G(PSODRIEN) D
. N PSOY S PSOY=+$G(PSODRIEN),PSOY(0)=^PSDRUG(PSOY,0) D SET^PSODRG
S DA(1)=PROVIEN,SDEA=$$DRGSCH^PSODIR(),VA=$P($G(^VA(200,PROVIEN,"PS")),U,3)
D DEALIST(.DEARY,PROVIEN,SDEA)
;no DEA#/VA#
I $P(DEARY(0),U)=0&(('$L(VA))!'$$VAPROV(PROVIEN)) D WM1 Q ""
;no DEA# then use VA#
I ($P(DEARY(0),U)=0)&($L(VA))&$$VAPROV(PROVIEN) Q $$USEVA(PROVIEN,VA,.PSORX)
;DEA# is expired, check Failover flag.
I $P(DEARY(0),U)=$P(DEARY(0),U,3)&('$L(VA)!'$$VAPROV(PROVIEN)) D WM2,DISPONLY(.DEARY) Q DEASEL
I $P(DEARY(0),U)=$P(DEARY(0),U,3)&($$VAPROV(PROVIEN)) S DEASEL=$$FAILOVER(.DEARY,VA,SDEA) Q DEASEL
I $P(DEARY(0),U)=1&($P(DEARY(0),U,2))=1&($D(DEARY(2))) S Y=1 D DISP3($P(DEARY(2,1),U),Y,.PSORX) Q PSORX("RXDEA")
I $D(DEARY(3))&('$D(DEARY(2))) D Q ""
. W !,"Provider not authorized to write Federal Schedule "_SDEA_" prescriptions."
. W !,"Please contact the provider.",!
. D DISPONLY(.DEARY)
;743 - One active DEA# with valid schedule and another DEA# that expired more than a year ago
I '$D(DEARY(1)),('$D(DEARY(3))),($O(DEARY(2,""))=$O(DEARY(2,""),-1)) S Y=1 Q $$DISP3($P(DEARY(2,1),U),Y,.PSORX)
I $P(DEARY(0),U,1)>1 D
. Q:$D(DEARY(3))&('$D(DEARY(2)))
. W !!,"This provider has multiple DEA registrations." W !,"Please select the correct DEA number for the prescription being entered"
I $D(DEARY(1)) S DLOOP=0 F S DLOOP=$O(DEARY(1,DLOOP)) Q:'DLOOP D
. W !,"* "_$P($G(DEARY(1,DLOOP)),U,2) W:$L($P($G(DEARY(1,DLOOP)),U,3)) "-"_$P($G(DEARY(1,DLOOP)),U,3) W " "_$P($G(DEARY(1,DLOOP)),U,4)_" Expired: "_$P($G(DEARY(1,DLOOP)),U,6)
I $D(DEARY(3)) S DLOOP=0 F S DLOOP=$O(DEARY(3,DLOOP)) Q:'DLOOP D
. W !,"* "_$P($G(DEARY(3,DLOOP)),U,2) W:$L($P($G(DEARY(3,DLOOP)),U,3)) "-"_$P($G(DEARY(3,DLOOP)),U,3)
. W " "_$P($G(DEARY(3,DLOOP)),U,4)_" Not Valid for Schedule: "_SDEA
S (DCNT,DLOOP)=0 F S DLOOP=$O(DEARY(2,DLOOP)) Q:'DLOOP D
. S DCNT=DCNT+1 W !,DCNT_". "_$P($G(DEARY(2,DLOOP)),U,2) W:$L($P($G(DEARY(2,DLOOP)),U,3)) "-"_$P($G(DEARY(2,DLOOP)),U,3) W " "_$P($G(DEARY(2,DLOOP)),U,4)
I $G(DCNT)=0 Q ""
I $L($G(DFLTDEA)) S DL=0 F Q:$G(DFLTSEL) S DL=$O(DEARY(2,DL)) Q:'DL I $P(DEARY(2,DL),U,2)=DFLTDEA S DFLTSEL=DL
S DEASEL=$$DDIR(DCNT,$G(DFLTSEL))
Q DEASEL
;
DDIR(DCNT,DFLT) ;
N DIR,Y,DEASEL
S:$G(DFLT) DIR("B")=DFLT
K DIRUT S DIR(0)="NO^1:"_DCNT,DIR("A")="Choose",DIR("?",1)="Select a choice from the list above" D ^DIR K DIR
I $D(DIRUT)!(Y<1) K DIRUT,DTOUT,DUOUT Q ""
I $G(FLOV)=1 D INDISP(PROVIEN,DEARY(Y),.PSORX) Q DEASEL
S DEASEL=$P(DEARY(2,Y),U,1)
D DISP3($P(DEARY(2,Y),U,1),Y,.PSORX)
Q DEASEL
;
VAPROV(PROVIEN) ; Is PROVIEN a VA Provider? (NON-VA PRESCRIBER=NO, PROVIDER TYPE=FULL TIME, PART TIME, or HOUSE STAFF)
; INPUT: PROVIEN = Provider DUZ
N NONVA,PRVTYP
Q:'$G(PROVIEN)
I '$L($$GET1^DIQ(200,PROVIEN,.01)) Q ""
S PRVTYP=$$GET1^DIQ(200,PROVIEN,53.6,"I") I (PRVTYP=3)!(PRVTYP=4) Q 0
S NONVA=$$GET1^DIQ(200,PROVIEN,53.91,"I") I NONVA Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODIR5 11195 printed Oct 16, 2024@18:27:45 Page 2
PSODIR5 ;DAL/JCH - ASK FOR DEA RX DATA ;11/08/21 4:03pm
+1 ;;7.0;OUTPATIENT PHARMACY;**545,731,743**;DEC 1997;Build 24
+2 ;External reference PSDRUG( supported by DBIA 221
+3 ;External reference PS(50.7 supported by DBIA 2223
+4 ;External reference to VA(200 is supported by DBIA 10060
+5 ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
+6 ;External reference to sub-file NEW DEA #'S (#200.5321) is supported by DBIA 7000
+7 ;----------------------------------------------------------------
+8 ;
FAILOVER(DEARY,VA,SDEA) ;check failover flag, if expired DEA, use VA schedule
+1 NEW FLOV,NDEA,DCNT
+2 SET FLOV=$$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I")
SET DCNT=0
+3 IF 'FLOV
DO WM2
DO DISPONLY(.DEARY)
QUIT ""
+4 SET NDEA=$$SDEA^XUSER(FLOV,PROVIEN,SDEA)
+5 IF NDEA=1!(NDEA=2)!(+NDEA=4)
DO WM2
DO DISPONLY(.DEARY)
QUIT ""
+6 SET DCNT=DCNT+1
WRITE !,""_DCNT_". "_VA_" (VA#)"
SET DEARY(DCNT)=NDEA
+7 IF $DATA(DEARY(1))
SET DLOOP=0
FOR
SET DLOOP=$ORDER(DEARY(1,DLOOP))
if 'DLOOP
QUIT
Begin DoDot:1
+8 WRITE !,"* "_$PIECE($GET(DEARY(1,DLOOP)),U,2)
if $LENGTH($PIECE($GET(DEARY(1,DLOOP)),U,3))
WRITE "-"_$PIECE($GET(DEARY(1,DLOOP)),U,3)
WRITE " "_$PIECE($GET(DEARY(1,DLOOP)),U,4)_" Expired: "_$PIECE($GET(DEARY(1,DLOOP)),U,6)
End DoDot:1
+9 QUIT $$DDIR^PSODIR5(DCNT)
+10 ;
DISP3(IEN,ARYSEL,PSORX) ;displays dea#,detox#,address
+1 NEW DA,DIC,DR,DISPFLD,DISPVAL,DISPTXT,RES,DERR,ARYSEL
+2 SET DA=IEN
SET ARYSEL=Y
+3 SET DIC="^XTV(8991.9,"
+4 SET DR=".01"_$SELECT($$GET1^DIQ(50,PSODRUG("IEN"),.01,"E")["BUPREN":";.03",1:"")_";1.2:1.7"
+5 KILL ^UTILITY("DIQ1",$JOB)
+6 DO EN^DIQ1
+7 WRITE !
+8 IF $DATA(^UTILITY("DIQ1",$JOB))
Begin DoDot:1
+9 ;P731 detox/x-waiver removal
SET DISPFLD=0
FOR
SET DISPFLD=$ORDER(^UTILITY("DIQ1",$JOB,8991.9,DA,DISPFLD))
if 'DISPFLD
QUIT
IF DISPFLD'=.03
Begin DoDot:2
+10 SET DISPVAL=$GET(^UTILITY("DIQ1",$JOB,8991.9,DA,DISPFLD))
+11 IF DISPFLD=.01
IF $PIECE(DEARY(2,ARYSEL),U,3)]""
SET DISPVAL=DISPVAL_"-"_$PIECE(DEARY(2,ARYSEL),U,3)
+12 IF DISPFLD=.03
SET DISPVAL=$$DETOX^XUSER(PROVIEN)
+13 KILL RES,DERR
+14 DO FIELD^DID(8991.9,DISPFLD,"","LABEL","RES","DERR")
+15 IF '$DATA(RES)
QUIT
+16 SET DISPTXT=$GET(RES("LABEL"))_": "_DISPVAL
+17 WRITE !," "_DISPTXT
End DoDot:2
End DoDot:1
+18 ;W ! I $G(PSOEDIT)!($G(ZZCOPY)) W !,"Press Return to continue: ",$C(7) R X:$S($D(DTIME):DTIME,1:300)
+19 WRITE !!!!,"Press Return to continue: ",$CHAR(7)
READ X:$SELECT($DATA(DTIME):DTIME,1:300)
+20 SET PSORX("RXDEA")=$PIECE(DEARY(2,ARYSEL),U,2)
+21 if $PIECE(DEARY(2,ARYSEL),U,3)]""
SET PSORX("RXDEA")=PSORX("RXDEA")_"-"_$PIECE(DEARY(2,ARYSEL),U,3)
+22 SET DEASEL=PSORX("RXDEA")
+23 QUIT DEASEL
+24 ;
USEVA(PROVIEN,VA,PSORX) ;Use VA# only when provider has no dea#
+1 NEW INN,IN,XUEXDT,DEASEL,NODEA,NVA
+2 SET DEASEL=""
+3 SET NVA=+$GET(^VA(200,PROVIEN,"TPB"))
+4 SET NODEA=$GET(^VA(200,PROVIEN,"PS"))
+5 IF "34"[+$PIECE(NODEA,U,6)!NVA
DO WM1
QUIT DEASEL
+6 IF '$LENGTH($PIECE(NODEA,U,3))
DO WM1
QUIT DEASEL
+7 SET NODEA=$GET(^VA(200,PROVIEN,"PS3"))
+8 SET IN=$SELECT(SDEA=2:1,SDEA="2n":2,SDEA=3:3,SDEA="3n":4,SDEA="4":5,1:6)
+9 IF '$PIECE(NODEA,U,IN)
DO WM3(SDEA)
QUIT DEASEL
+10 ;signed-in Inst.
SET INN=$SELECT($GET(PSOPINST):+$GET(PSOPINST),1:+DUZ(2))
SET IN=$PIECE($GET(^DIC(4,INN,"DEA")),U)
+11 IF '$LENGTH(IN)
Begin DoDot:1
+12 NEW XU1
DO PARENT^XUAF4("XU1","`"_INN,"PARENT FACILITY")
+13 SET INN=$ORDER(XU1("P",""))
IF INN
SET IN=$PIECE($GET(^DIC(4,INN,"DEA")),U)
+14 QUIT
End DoDot:1
+15 ;check FACILITY DEA EXPIRATION DATE
IF INN
SET XUEXDT=$PIECE($GET(^DIC(4,INN,"DEA")),U,2)
+16 SET XUEXDT=$GET(XUEXDT)
+17 IF $LENGTH(VA)
IF $LENGTH(IN)
IF $LENGTH(XUEXDT)
IF XUEXDT'<DT
SET (DEARY,DEASEL)=IN_"-"_VA
+18 IF DEASEL=""
DO WM1
QUIT DEASEL
+19 DO INDISP(PROVIEN,DEARY,.PSORX)
+20 SET DEASEL=PSORX("RXDEA")
+21 QUIT DEASEL
+22 ;
WM1 ;warning message
+1 WRITE !!,"Provider must have a current DEA# or VA# to write prescriptions for this drug.",!
+2 QUIT
+3 ;
WM2 ; Warning message
+1 WRITE !!,"The provider's DEA# on file has Expired and must be updated.",!
+2 QUIT
WM3(SCHED) ; Warning message
+1 WRITE $CHAR(7),!!,"Provider not authorized to write Federal Schedule "_SCHED_" prescriptions.",!
+2 QUIT
+3 ;
INDISP(PROVIEN,DEARY,PSORX) ;displays institutional dea#va#, address of institution
+1 WRITE !!,"DEA NUMBER: "_DEARY
+2 ;I $G(PSORX("DETX"))]"" W !,"DETOX NUMBER: "_PSORX("DETX") ;P731 detox/x-waiver removal
+3 NEW MADD1,MADD2,MCITY,MSTATE,MZIP
+4 SET MADD1=$$GET1^DIQ(4,DUZ(2),1.01)
SET MADD2=$$GET1^DIQ(4,DUZ(2),1.02)
+5 SET MCITY=$$GET1^DIQ(4,DUZ(2),1.03)
SET MSTATE=$$GET1^DIQ(4,DUZ(2),.02)
+6 SET MZIP=$$GET1^DIQ(4,DUZ(2),1.04)
+7 WRITE !,"STREET ADDRESS 1:",MADD1
+8 WRITE !,"STREET ADDRESS 2:",MADD2
+9 WRITE !,"CITY:",MCITY
+10 WRITE !,"STATE:",MSTATE
+11 WRITE !,"ZIP CODE:",MZIP
+12 WRITE !
IF $GET(PSOEDIT)!($GET(ZZCOPY))
WRITE !,"Press Return to continue: ",$CHAR(7)
READ X:$SELECT($DATA(DTIME):DTIME,1:300)
+13 SET (DEASEL,PSORX("RXDEA"))=DEARY
+14 QUIT DEASEL
+15 ;
DEALIST(RET,NPIEN,SDEA) ; -- returns the DEA list
+1 ; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
+2 ;
+3 ; OUTPUT: RET - A STRING OF DEA INFORMATION DELIMITED BY THE "^".
+4 ; RET ***** KILLED BY THIS RPC *****
+5 ; RET(0)=TOTCNT^NEXPCNT^EXPCNT - Count of DEA Numbers for a provider, count of expired DEA numbers for provider.
+6 ; RET(1,n) - Expired DEA Numbers
+7 ; RET(2,n) - Active DEA Numbers
+8 ; RET(3,n) - Not allowed to write that schedule
+9 ; 1 - DEA IEN
+10 ; 2 - DEA NUMBER
+11 ; 3 - INDIVIDUAL DEA SUFFIX
+12 ; 4 - STATE
+13 ; 5 - DETOX NUMBER
+14 ; 6 - EXPIRATION DATE EXTERNAL: FROM THE DEA NUMBERS FILE (#8991.9), FIELD EXPIRATION DATE (#.04)
+15 ; 7 - EXPIRATION DATE INTERNAL: FROM THE DEA NUMBERS FILE (#8991.9), FIELD EXPIRATION DATE (#.04)
+16 ;
+17 NEW CNT,DNDEADAT,DNDEAIEN,FAIL,IENS,NPDEADAT,NPDEAIEN,EXPDATEI,EXPCNT,NODE1,DIFF,DNDEANUM,EXPFLG,DEASUFX
+18 KILL RET
SET EXPCNT=0
+19 SET CNT(1)=0
SET CNT(2)=0
SET CNT(3)=0
+20 SET NPDEAIEN=0
FOR CNT=1:1
SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
if '+NPDEAIEN
QUIT
Begin DoDot:1
+21 SET EXPFLG=0
+22 SET IENS=NPDEAIEN_","_NPIEN_","
+23 KILL NPDEADAT
DO GETS^DIQ(200.5321,IENS,"**","","NPDEADAT")
if '$DATA(NPDEADAT)
QUIT
+24 SET DNDEAIEN=$$GET1^DIQ(200.5321,IENS,.03,"I")
if 'DNDEAIEN
QUIT
+25 KILL DNDEADAT
DO GETS^DIQ(8991.9,DNDEAIEN,"**","","DNDEADAT")
if '$DATA(DNDEADAT)
QUIT
+26 ;
+27 SET EXPDATEI=$$GET1^DIQ(8991.9,DNDEAIEN,.04,"I")
SET DIFF=$$FMDIFF^XLFDT(DT,EXPDATEI,1)
+28 IF DIFF>366
SET EXPCNT=EXPCNT+1
SET CNT(1)=CNT(1)+1
QUIT
+29 ; Expired DEA Counter
IF EXPDATEI
IF EXPDATEI<DT
SET EXPCNT=EXPCNT+1
SET NODE1=1
SET CNT(1)=CNT(1)+1
SET EXPFLG=1
+30 SET DNDEANUM=$$GET1^DIQ(200.5321,IENS,.01,"E")
+31 IF $$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")=1
SET DEASUFX=$$GET1^DIQ(200.5321,IENS,.02,"E")
IF $LENGTH(DEASUFX)>2
SET DNDEANUM=DNDEANUM_"-"_DEASUFX
+32 ; Check to verify schedule permissions
SET NDEA=$$SDEA^XUSER($$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I"),NPIEN,SDEA,,DNDEANUM)
+33 IF EXPFLG'=1!(NDEA=2)
SET NODE1=3
SET CNT(3)=CNT(3)+1
+34 IF EXPDATEI
IF '(EXPDATEI<DT)
IF (NDEA'=2)
IF (NDEA'=1)
IF (EXPFLG'=1)
SET NODE1=2
SET CNT(2)=CNT(2)+1
+35 SET RET(NODE1,CNT(NODE1))=""
+36 ; DEA IEN
SET RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_DNDEAIEN_"^"
+37 ; NEW PERSON DEA NUMBER
SET RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_NPDEADAT(200.5321,IENS,.01)_"^"
+38 ; INDIVIDUAL DEA SUFFIX
SET RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_NPDEADAT(200.5321,IENS,.02)_"^"
+39 ; STATE
SET RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_DNDEADAT(8991.9,DNDEAIEN_",",1.6)_"^"
+40 ; DETOX NUMBER ;P731 detox/x-waiver removal
SET RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_""_"^"
+41 ; EXPIRATION DATE EXTERNAL
SET RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_DNDEADAT(8991.9,DNDEAIEN_",",.04)_"^"
+42 ; EXPIRATION DATE INTERNAL
SET RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_EXPDATEI_"^"
End DoDot:1
+43 SET RET(0)=(CNT-1)_"^"_(CNT(2)+CNT(3))_"^"_CNT(1)
+44 QUIT
+45 ;
DISPONLY(DEARY) ; Display only
+1 IF $DATA(DEARY(1))
SET DLOOP=0
FOR
SET DLOOP=$ORDER(DEARY(1,DLOOP))
if 'DLOOP
QUIT
Begin DoDot:1
+2 WRITE !,"* "_$PIECE($GET(DEARY(1,DLOOP)),U,2)
if $LENGTH($PIECE($GET(DEARY(1,DLOOP)),U,3))
WRITE "-"_$PIECE($GET(DEARY(1,DLOOP)),U,3)
WRITE " "_$PIECE($GET(DEARY(1,DLOOP)),U,4)_" Expired: "_$PIECE($GET(DEARY(1,DLOOP)),U,6)
End DoDot:1
+3 IF $DATA(DEARY(3))
SET DLOOP=0
FOR
SET DLOOP=$ORDER(DEARY(3,DLOOP))
if 'DLOOP
QUIT
Begin DoDot:1
+4 WRITE !,"* "_$PIECE($GET(DEARY(3,DLOOP)),U,2)
if $LENGTH($PIECE($GET(DEARY(3,DLOOP)),U,3))
WRITE "-"_$PIECE($GET(DEARY(3,DLOOP)),U,3)
+5 WRITE " "_$PIECE($GET(DEARY(3,DLOOP)),U,4)_" Not Valid for Schedule: "_SDEA
End DoDot:1
+6 SET (DCNT,DLOOP)=0
FOR
SET DLOOP=$ORDER(DEARY(2,DLOOP))
if 'DLOOP
QUIT
Begin DoDot:1
+7 SET DCNT=DCNT+1
WRITE !,DCNT_". "_$PIECE($GET(DEARY(2,DLOOP)),U,2)
if $LENGTH($PIECE($GET(DEARY(2,DLOOP)),U,3))
WRITE "-"_$PIECE($GET(DEARY(2,DLOOP)),U,3)
WRITE " "_$PIECE($GET(DEARY(2,DLOOP)),U,4)
End DoDot:1
+8 QUIT
+9 ;
+10 ;*545; DEA selection
SLDEA(PROVIEN,PSORX,DFLTDEA,PSODRIEN) ;
+1 NEW DA,SDEA,VA,NDEA,DCNT,DLOOP,DEARY,Y,DEASEL,DFLTSEL,DL
SET DEASEL=""
+2 IF '$DATA(PSODRUG("IEN"))
IF $GET(PSODRIEN)
Begin DoDot:1
+3 NEW PSOY
SET PSOY=+$GET(PSODRIEN)
SET PSOY(0)=^PSDRUG(PSOY,0)
DO SET^PSODRG
End DoDot:1
+4 SET DA(1)=PROVIEN
SET SDEA=$$DRGSCH^PSODIR()
SET VA=$PIECE($GET(^VA(200,PROVIEN,"PS")),U,3)
+5 DO DEALIST(.DEARY,PROVIEN,SDEA)
+6 ;no DEA#/VA#
+7 IF $PIECE(DEARY(0),U)=0&(('$LENGTH(VA))!'$$VAPROV(PROVIEN))
DO WM1
QUIT ""
+8 ;no DEA# then use VA#
+9 IF ($PIECE(DEARY(0),U)=0)&($LENGTH(VA))&$$VAPROV(PROVIEN)
QUIT $$USEVA(PROVIEN,VA,.PSORX)
+10 ;DEA# is expired, check Failover flag.
+11 IF $PIECE(DEARY(0),U)=$PIECE(DEARY(0),U,3)&('$LENGTH(VA)!'$$VAPROV(PROVIEN))
DO WM2
DO DISPONLY(.DEARY)
QUIT DEASEL
+12 IF $PIECE(DEARY(0),U)=$PIECE(DEARY(0),U,3)&($$VAPROV(PROVIEN))
SET DEASEL=$$FAILOVER(.DEARY,VA,SDEA)
QUIT DEASEL
+13 IF $PIECE(DEARY(0),U)=1&($PIECE(DEARY(0),U,2))=1&($DATA(DEARY(2)))
SET Y=1
DO DISP3($PIECE(DEARY(2,1),U),Y,.PSORX)
QUIT PSORX("RXDEA")
+14 IF $DATA(DEARY(3))&('$DATA(DEARY(2)))
Begin DoDot:1
+15 WRITE !,"Provider not authorized to write Federal Schedule "_SDEA_" prescriptions."
+16 WRITE !,"Please contact the provider.",!
+17 DO DISPONLY(.DEARY)
End DoDot:1
QUIT ""
+18 ;743 - One active DEA# with valid schedule and another DEA# that expired more than a year ago
+19 IF '$DATA(DEARY(1))
IF ('$DATA(DEARY(3)))
IF ($ORDER(DEARY(2,""))=$ORDER(DEARY(2,""),-1))
SET Y=1
QUIT $$DISP3($PIECE(DEARY(2,1),U),Y,.PSORX)
+20 IF $PIECE(DEARY(0),U,1)>1
Begin DoDot:1
+21 if $DATA(DEARY(3))&('$DATA(DEARY(2)))
QUIT
+22 WRITE !!,"This provider has multiple DEA registrations."
WRITE !,"Please select the correct DEA number for the prescription being entered"
End DoDot:1
+23 IF $DATA(DEARY(1))
SET DLOOP=0
FOR
SET DLOOP=$ORDER(DEARY(1,DLOOP))
if 'DLOOP
QUIT
Begin DoDot:1
+24 WRITE !,"* "_$PIECE($GET(DEARY(1,DLOOP)),U,2)
if $LENGTH($PIECE($GET(DEARY(1,DLOOP)),U,3))
WRITE "-"_$PIECE($GET(DEARY(1,DLOOP)),U,3)
WRITE " "_$PIECE($GET(DEARY(1,DLOOP)),U,4)_" Expired: "_$PIECE($GET(DEARY(1,DLOOP)),U,6)
End DoDot:1
+25 IF $DATA(DEARY(3))
SET DLOOP=0
FOR
SET DLOOP=$ORDER(DEARY(3,DLOOP))
if 'DLOOP
QUIT
Begin DoDot:1
+26 WRITE !,"* "_$PIECE($GET(DEARY(3,DLOOP)),U,2)
if $LENGTH($PIECE($GET(DEARY(3,DLOOP)),U,3))
WRITE "-"_$PIECE($GET(DEARY(3,DLOOP)),U,3)
+27 WRITE " "_$PIECE($GET(DEARY(3,DLOOP)),U,4)_" Not Valid for Schedule: "_SDEA
End DoDot:1
+28 SET (DCNT,DLOOP)=0
FOR
SET DLOOP=$ORDER(DEARY(2,DLOOP))
if 'DLOOP
QUIT
Begin DoDot:1
+29 SET DCNT=DCNT+1
WRITE !,DCNT_". "_$PIECE($GET(DEARY(2,DLOOP)),U,2)
if $LENGTH($PIECE($GET(DEARY(2,DLOOP)),U,3))
WRITE "-"_$PIECE($GET(DEARY(2,DLOOP)),U,3)
WRITE " "_$PIECE($GET(DEARY(2,DLOOP)),U,4)
End DoDot:1
+30 IF $GET(DCNT)=0
QUIT ""
+31 IF $LENGTH($GET(DFLTDEA))
SET DL=0
FOR
if $GET(DFLTSEL)
QUIT
SET DL=$ORDER(DEARY(2,DL))
if 'DL
QUIT
IF $PIECE(DEARY(2,DL),U,2)=DFLTDEA
SET DFLTSEL=DL
+32 SET DEASEL=$$DDIR(DCNT,$GET(DFLTSEL))
+33 QUIT DEASEL
+34 ;
DDIR(DCNT,DFLT) ;
+1 NEW DIR,Y,DEASEL
+2 if $GET(DFLT)
SET DIR("B")=DFLT
+3 KILL DIRUT
SET DIR(0)="NO^1:"_DCNT
SET DIR("A")="Choose"
SET DIR("?",1)="Select a choice from the list above"
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)!(Y<1)
KILL DIRUT,DTOUT,DUOUT
QUIT ""
+5 IF $GET(FLOV)=1
DO INDISP(PROVIEN,DEARY(Y),.PSORX)
QUIT DEASEL
+6 SET DEASEL=$PIECE(DEARY(2,Y),U,1)
+7 DO DISP3($PIECE(DEARY(2,Y),U,1),Y,.PSORX)
+8 QUIT DEASEL
+9 ;
VAPROV(PROVIEN) ; Is PROVIEN a VA Provider? (NON-VA PRESCRIBER=NO, PROVIDER TYPE=FULL TIME, PART TIME, or HOUSE STAFF)
+1 ; INPUT: PROVIEN = Provider DUZ
+2 NEW NONVA,PRVTYP
+3 if '$GET(PROVIEN)
QUIT
+4 IF '$LENGTH($$GET1^DIQ(200,PROVIEN,.01))
QUIT ""
+5 SET PRVTYP=$$GET1^DIQ(200,PROVIEN,53.6,"I")
IF (PRVTYP=3)!(PRVTYP=4)
QUIT 0
+6 SET NONVA=$$GET1^DIQ(200,PROVIEN,53.91,"I")
IF NONVA
QUIT 0
+7 QUIT 1
