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

PSODIR5.m

Go to the documentation of this file.
  1. 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
  1. ;External reference PSDRUG( supported by DBIA 221
  1. ;External reference PS(50.7 supported by DBIA 2223
  1. ;External reference to VA(200 is supported by DBIA 10060
  1. ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
  1. ;External reference to sub-file NEW DEA #'S (#200.5321) is supported by DBIA 7000
  1. ;----------------------------------------------------------------
  1. ;
  1. FAILOVER(DEARY,VA,SDEA) ;check failover flag, if expired DEA, use VA schedule
  1. N FLOV,NDEA,DCNT
  1. S FLOV=$$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I"),DCNT=0
  1. I 'FLOV D WM2,DISPONLY(.DEARY) Q ""
  1. S NDEA=$$SDEA^XUSER(FLOV,PROVIEN,SDEA)
  1. I NDEA=1!(NDEA=2)!(+NDEA=4) D WM2,DISPONLY(.DEARY) Q ""
  1. S DCNT=DCNT+1 W !,""_DCNT_". "_VA_" (VA#)" S DEARY(DCNT)=NDEA
  1. I $D(DEARY(1)) S DLOOP=0 F S DLOOP=$O(DEARY(1,DLOOP)) Q:'DLOOP D
  1. .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)
  1. Q $$DDIR^PSODIR5(DCNT)
  1. ;
  1. DISP3(IEN,ARYSEL,PSORX) ;displays dea#,detox#,address
  1. N DA,DIC,DR,DISPFLD,DISPVAL,DISPTXT,RES,DERR,ARYSEL
  1. S DA=IEN,ARYSEL=Y
  1. S DIC="^XTV(8991.9,"
  1. S DR=".01"_$S($$GET1^DIQ(50,PSODRUG("IEN"),.01,"E")["BUPREN":";.03",1:"")_";1.2:1.7"
  1. K ^UTILITY("DIQ1",$J)
  1. D EN^DIQ1
  1. W !
  1. I $D(^UTILITY("DIQ1",$J)) D
  1. . 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
  1. .. S DISPVAL=$G(^UTILITY("DIQ1",$J,8991.9,DA,DISPFLD))
  1. .. I DISPFLD=.01,$P(DEARY(2,ARYSEL),U,3)]"" S DISPVAL=DISPVAL_"-"_$P(DEARY(2,ARYSEL),U,3)
  1. .. I DISPFLD=.03 S DISPVAL=$$DETOX^XUSER(PROVIEN)
  1. .. K RES,DERR
  1. .. D FIELD^DID(8991.9,DISPFLD,"","LABEL","RES","DERR")
  1. .. I '$D(RES) Q
  1. .. S DISPTXT=$G(RES("LABEL"))_": "_DISPVAL
  1. .. W !," "_DISPTXT
  1. ;W ! I $G(PSOEDIT)!($G(ZZCOPY)) W !,"Press Return to continue: ",$C(7) R X:$S($D(DTIME):DTIME,1:300)
  1. W !!!!,"Press Return to continue: ",$C(7) R X:$S($D(DTIME):DTIME,1:300)
  1. S PSORX("RXDEA")=$P(DEARY(2,ARYSEL),U,2)
  1. S:$P(DEARY(2,ARYSEL),U,3)]"" PSORX("RXDEA")=PSORX("RXDEA")_"-"_$P(DEARY(2,ARYSEL),U,3)
  1. S DEASEL=PSORX("RXDEA")
  1. Q DEASEL
  1. ;
  1. USEVA(PROVIEN,VA,PSORX) ;Use VA# only when provider has no dea#
  1. N INN,IN,XUEXDT,DEASEL,NODEA,NVA
  1. S DEASEL=""
  1. S NVA=+$G(^VA(200,PROVIEN,"TPB"))
  1. S NODEA=$G(^VA(200,PROVIEN,"PS"))
  1. I "34"[+$P(NODEA,U,6)!NVA D WM1 Q DEASEL
  1. I '$L($P(NODEA,U,3)) D WM1 Q DEASEL
  1. S NODEA=$G(^VA(200,PROVIEN,"PS3"))
  1. S IN=$S(SDEA=2:1,SDEA="2n":2,SDEA=3:3,SDEA="3n":4,SDEA="4":5,1:6)
  1. I '$P(NODEA,U,IN) D WM3(SDEA) Q DEASEL
  1. S INN=$S($G(PSOPINST):+$G(PSOPINST),1:+DUZ(2)),IN=$P($G(^DIC(4,INN,"DEA")),U) ;signed-in Inst.
  1. I '$L(IN) D
  1. . N XU1 D PARENT^XUAF4("XU1","`"_INN,"PARENT FACILITY")
  1. . S INN=$O(XU1("P","")) I INN S IN=$P($G(^DIC(4,INN,"DEA")),U)
  1. . Q
  1. I INN S XUEXDT=$P($G(^DIC(4,INN,"DEA")),U,2) ;check FACILITY DEA EXPIRATION DATE
  1. S XUEXDT=$G(XUEXDT)
  1. I $L(VA),$L(IN),$L(XUEXDT),XUEXDT'<DT S (DEARY,DEASEL)=IN_"-"_VA
  1. I DEASEL="" D WM1 Q DEASEL
  1. D INDISP(PROVIEN,DEARY,.PSORX)
  1. S DEASEL=PSORX("RXDEA")
  1. Q DEASEL
  1. ;
  1. WM1 ;warning message
  1. W !!,"Provider must have a current DEA# or VA# to write prescriptions for this drug.",!
  1. Q
  1. ;
  1. WM2 ; Warning message
  1. W !!,"The provider's DEA# on file has Expired and must be updated.",!
  1. Q
  1. WM3(SCHED) ; Warning message
  1. W $C(7),!!,"Provider not authorized to write Federal Schedule "_SCHED_" prescriptions.",!
  1. Q
  1. ;
  1. INDISP(PROVIEN,DEARY,PSORX) ;displays institutional dea#va#, address of institution
  1. W !!,"DEA NUMBER: "_DEARY
  1. ;I $G(PSORX("DETX"))]"" W !,"DETOX NUMBER: "_PSORX("DETX") ;P731 detox/x-waiver removal
  1. N MADD1,MADD2,MCITY,MSTATE,MZIP
  1. S MADD1=$$GET1^DIQ(4,DUZ(2),1.01),MADD2=$$GET1^DIQ(4,DUZ(2),1.02)
  1. S MCITY=$$GET1^DIQ(4,DUZ(2),1.03),MSTATE=$$GET1^DIQ(4,DUZ(2),.02)
  1. S MZIP=$$GET1^DIQ(4,DUZ(2),1.04)
  1. W !,"STREET ADDRESS 1:",MADD1
  1. w !,"STREET ADDRESS 2:",MADD2
  1. W !,"CITY:",MCITY
  1. W !,"STATE:",MSTATE
  1. W !,"ZIP CODE:",MZIP
  1. W ! I $G(PSOEDIT)!($G(ZZCOPY)) W !,"Press Return to continue: ",$C(7) R X:$S($D(DTIME):DTIME,1:300)
  1. S (DEASEL,PSORX("RXDEA"))=DEARY
  1. Q DEASEL
  1. ;
  1. DEALIST(RET,NPIEN,SDEA) ; -- returns the DEA list
  1. ; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
  1. ;
  1. ; OUTPUT: RET - A STRING OF DEA INFORMATION DELIMITED BY THE "^".
  1. ; RET ***** KILLED BY THIS RPC *****
  1. ; RET(0)=TOTCNT^NEXPCNT^EXPCNT - Count of DEA Numbers for a provider, count of expired DEA numbers for provider.
  1. ; RET(1,n) - Expired DEA Numbers
  1. ; RET(2,n) - Active DEA Numbers
  1. ; RET(3,n) - Not allowed to write that schedule
  1. ; 1 - DEA IEN
  1. ; 2 - DEA NUMBER
  1. ; 3 - INDIVIDUAL DEA SUFFIX
  1. ; 4 - STATE
  1. ; 5 - DETOX NUMBER
  1. ; 6 - EXPIRATION DATE EXTERNAL: FROM THE DEA NUMBERS FILE (#8991.9), FIELD EXPIRATION DATE (#.04)
  1. ; 7 - EXPIRATION DATE INTERNAL: FROM THE DEA NUMBERS FILE (#8991.9), FIELD EXPIRATION DATE (#.04)
  1. ;
  1. N CNT,DNDEADAT,DNDEAIEN,FAIL,IENS,NPDEADAT,NPDEAIEN,EXPDATEI,EXPCNT,NODE1,DIFF,DNDEANUM,EXPFLG,DEASUFX
  1. K RET S EXPCNT=0
  1. S CNT(1)=0,CNT(2)=0,CNT(3)=0
  1. S NPDEAIEN=0 F CNT=1:1 S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'+NPDEAIEN D
  1. . S EXPFLG=0
  1. . S IENS=NPDEAIEN_","_NPIEN_","
  1. . K NPDEADAT D GETS^DIQ(200.5321,IENS,"**","","NPDEADAT") Q:'$D(NPDEADAT)
  1. . S DNDEAIEN=$$GET1^DIQ(200.5321,IENS,.03,"I") Q:'DNDEAIEN
  1. . K DNDEADAT D GETS^DIQ(8991.9,DNDEAIEN,"**","","DNDEADAT") Q:'$D(DNDEADAT)
  1. . ;
  1. . S EXPDATEI=$$GET1^DIQ(8991.9,DNDEAIEN,.04,"I"),DIFF=$$FMDIFF^XLFDT(DT,EXPDATEI,1)
  1. . I DIFF>366 S EXPCNT=EXPCNT+1,CNT(1)=CNT(1)+1 Q
  1. . I EXPDATEI,EXPDATEI<DT S EXPCNT=EXPCNT+1,NODE1=1,CNT(1)=CNT(1)+1,EXPFLG=1 ; Expired DEA Counter
  1. . S DNDEANUM=$$GET1^DIQ(200.5321,IENS,.01,"E")
  1. . 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
  1. . S NDEA=$$SDEA^XUSER($$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I"),NPIEN,SDEA,,DNDEANUM) ; Check to verify schedule permissions
  1. . I EXPFLG'=1!(NDEA=2) S NODE1=3,CNT(3)=CNT(3)+1
  1. . I EXPDATEI,'(EXPDATEI<DT),(NDEA'=2),(NDEA'=1),(EXPFLG'=1) S NODE1=2,CNT(2)=CNT(2)+1
  1. . S RET(NODE1,CNT(NODE1))=""
  1. . S RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_DNDEAIEN_"^" ; DEA IEN
  1. . S RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_NPDEADAT(200.5321,IENS,.01)_"^" ; NEW PERSON DEA NUMBER
  1. . S RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_NPDEADAT(200.5321,IENS,.02)_"^" ; INDIVIDUAL DEA SUFFIX
  1. . S RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_DNDEADAT(8991.9,DNDEAIEN_",",1.6)_"^" ; STATE
  1. . S RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_""_"^" ; DETOX NUMBER ;P731 detox/x-waiver removal
  1. . S RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_DNDEADAT(8991.9,DNDEAIEN_",",.04)_"^" ; EXPIRATION DATE EXTERNAL
  1. . S RET(NODE1,CNT(NODE1))=RET(NODE1,CNT(NODE1))_EXPDATEI_"^" ; EXPIRATION DATE INTERNAL
  1. S RET(0)=(CNT-1)_"^"_(CNT(2)+CNT(3))_"^"_CNT(1)
  1. Q
  1. ;
  1. DISPONLY(DEARY) ; Display only
  1. I $D(DEARY(1)) S DLOOP=0 F S DLOOP=$O(DEARY(1,DLOOP)) Q:'DLOOP D
  1. . 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)
  1. I $D(DEARY(3)) S DLOOP=0 F S DLOOP=$O(DEARY(3,DLOOP)) Q:'DLOOP D
  1. . W !,"* "_$P($G(DEARY(3,DLOOP)),U,2) W:$L($P($G(DEARY(3,DLOOP)),U,3)) "-"_$P($G(DEARY(3,DLOOP)),U,3)
  1. . W " "_$P($G(DEARY(3,DLOOP)),U,4)_" Not Valid for Schedule: "_SDEA
  1. S (DCNT,DLOOP)=0 F S DLOOP=$O(DEARY(2,DLOOP)) Q:'DLOOP D
  1. . 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)
  1. Q
  1. ;
  1. ;*545; DEA selection
  1. SLDEA(PROVIEN,PSORX,DFLTDEA,PSODRIEN) ;
  1. N DA,SDEA,VA,NDEA,DCNT,DLOOP,DEARY,Y,DEASEL,DFLTSEL,DL S DEASEL=""
  1. I '$D(PSODRUG("IEN")),$G(PSODRIEN) D
  1. . N PSOY S PSOY=+$G(PSODRIEN),PSOY(0)=^PSDRUG(PSOY,0) D SET^PSODRG
  1. S DA(1)=PROVIEN,SDEA=$$DRGSCH^PSODIR(),VA=$P($G(^VA(200,PROVIEN,"PS")),U,3)
  1. D DEALIST(.DEARY,PROVIEN,SDEA)
  1. ;no DEA#/VA#
  1. I $P(DEARY(0),U)=0&(('$L(VA))!'$$VAPROV(PROVIEN)) D WM1 Q ""
  1. ;no DEA# then use VA#
  1. I ($P(DEARY(0),U)=0)&($L(VA))&$$VAPROV(PROVIEN) Q $$USEVA(PROVIEN,VA,.PSORX)
  1. ;DEA# is expired, check Failover flag.
  1. I $P(DEARY(0),U)=$P(DEARY(0),U,3)&('$L(VA)!'$$VAPROV(PROVIEN)) D WM2,DISPONLY(.DEARY) Q DEASEL
  1. I $P(DEARY(0),U)=$P(DEARY(0),U,3)&($$VAPROV(PROVIEN)) S DEASEL=$$FAILOVER(.DEARY,VA,SDEA) Q DEASEL
  1. 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")
  1. I $D(DEARY(3))&('$D(DEARY(2))) D Q ""
  1. . W !,"Provider not authorized to write Federal Schedule "_SDEA_" prescriptions."
  1. . W !,"Please contact the provider.",!
  1. . D DISPONLY(.DEARY)
  1. ;743 - One active DEA# with valid schedule and another DEA# that expired more than a year ago
  1. 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)
  1. I $P(DEARY(0),U,1)>1 D
  1. . Q:$D(DEARY(3))&('$D(DEARY(2)))
  1. . W !!,"This provider has multiple DEA registrations." W !,"Please select the correct DEA number for the prescription being entered"
  1. I $D(DEARY(1)) S DLOOP=0 F S DLOOP=$O(DEARY(1,DLOOP)) Q:'DLOOP D
  1. . 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)
  1. I $D(DEARY(3)) S DLOOP=0 F S DLOOP=$O(DEARY(3,DLOOP)) Q:'DLOOP D
  1. . W !,"* "_$P($G(DEARY(3,DLOOP)),U,2) W:$L($P($G(DEARY(3,DLOOP)),U,3)) "-"_$P($G(DEARY(3,DLOOP)),U,3)
  1. . W " "_$P($G(DEARY(3,DLOOP)),U,4)_" Not Valid for Schedule: "_SDEA
  1. S (DCNT,DLOOP)=0 F S DLOOP=$O(DEARY(2,DLOOP)) Q:'DLOOP D
  1. . 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)
  1. I $G(DCNT)=0 Q ""
  1. 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
  1. S DEASEL=$$DDIR(DCNT,$G(DFLTSEL))
  1. Q DEASEL
  1. ;
  1. DDIR(DCNT,DFLT) ;
  1. N DIR,Y,DEASEL
  1. S:$G(DFLT) DIR("B")=DFLT
  1. K DIRUT S DIR(0)="NO^1:"_DCNT,DIR("A")="Choose",DIR("?",1)="Select a choice from the list above" D ^DIR K DIR
  1. I $D(DIRUT)!(Y<1) K DIRUT,DTOUT,DUOUT Q ""
  1. I $G(FLOV)=1 D INDISP(PROVIEN,DEARY(Y),.PSORX) Q DEASEL
  1. S DEASEL=$P(DEARY(2,Y),U,1)
  1. D DISP3($P(DEARY(2,Y),U,1),Y,.PSORX)
  1. Q DEASEL
  1. ;
  1. 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
  1. N NONVA,PRVTYP
  1. Q:'$G(PROVIEN)
  1. I '$L($$GET1^DIQ(200,PROVIEN,.01)) Q ""
  1. S PRVTYP=$$GET1^DIQ(200,PROVIEN,53.6,"I") I (PRVTYP=3)!(PRVTYP=4) Q 0
  1. S NONVA=$$GET1^DIQ(200,PROVIEN,53.91,"I") I NONVA Q 0
  1. Q 1