ORWDPS11 ; ALB/BI - Pharmacy Calls for Windows Dialog ;10/25/2018
;;3.0;ORDER ENTRY/RESULTS REPORTING;**499**;Dec 17, 1997;Build 165
;Reference to ^PSSOPKI supported by DBIA #3737
;Reference to ^ORD(101.43 supported by DBIA #5430
;Reference to EDITPAR^XPAREDIT supported by DBIA #2336
;
Q
;
DEALIST(RET,NPIEN,DOI,PSTYPE,HLIEN) ; -- RPC to return a List of DEA numbers and information for a single provider and a clinic DEA number.
; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
; DOI - DRUG ORDERABLE ITEM #101.43 INTERNAL ENTRY NUMBER
; PSTYPE - O=Outpatient, I=Inpatient
; HLIEN - HOSPITAL LOCATION INTERNAL ENTRY NUMBER in FILE #44
;
; OUTPUT: RET - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
; 1 - VALID FOR USE: 0=NO, 1=YES
; 2 - DEA NUMBER
; 3 - INDIVIDUAL DEA SUFFIX
; 4 - DEA NUMBER TYPE: INDIVIDUAL/INSTITUTIONAL
; 5 - STREET ADDRESS 1
; 6 - STREET ADDRESS 2
; 7 - STREET ADDRESS 3
; 8 - CITY
; 9 - STATE
; 10 - ZIP CODE
; 11 - DETOX NUMBER
; 12 - EXPIRATION DATE: FROM THE DEA NUMBERS FILE (#8991.9), FIELD EXPIRATION DATE (#.04)
; 13 - SCHEDULE II NARCOTIC
; 14 - SCHEDULE II NON-NARCOTIC
; 15 - SCHEDULE III NARCOTIC
; 16 - SCHEDULE III NON-NARCOTIC
; 17 - SCHEDULE IV
; 18 - SCHEDULE V
; 19 - USE FOR INPATIENT ORDERS?
; 20 - FAILOVER FLAG
; 21 - PROVIDER VA NUMBER
; 22 - PROVIDER TYPE 3=C & A, 4=FEE BASIS
; 23 - MESSAGE
;
Q:'$G(NPIEN)
Q:'$G(DOI)
;
N TPKG,PSOI S TPKG=$P($G(^ORD(101.43,DOI,0)),U,2) Q:TPKG'["PS"
S PSOI=+TPKG Q:'PSOI
N SCHEDULE S SCHEDULE=$$DOIIEN(DOI) Q:'SCHEDULE
S DETFLAG=$$OIDETOX^PSSOPKI(PSOI,PSTYPE)
S DETPRO=$$DETOX^XUSER(NPIEN)
I DETFLAG,DETPRO="" S RET(1)="-1^3" Q
S:'DETFLAG DETPRO=""
;
N CASEIEN,CLINIC,CNT,CSTATUS,DNDEADAT,DNDEAEXP,DNDEAIEN,DNDEATYP,EX,FAIL,FAILOVER
N IENS,INDEX,NPDEADAT,NPDEAIEN,PROVTYPE,ORTMP,ORTMPX,ORTMPY,VANUMB,VANUMBEX,VDATA
S (INDEX(0,1),INDEX(0,2),INDEX(0,3))=0
S FAILOVER=$$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I")
S VANUMB=$$GET1^DIQ(200,NPIEN,53.3),VANUMBEX=$$GET1^DIQ(200,NPIEN,53.4,"I")
S PROVTYPE=$$GET1^DIQ(200,NPIEN,53.6,"I") ; PROVIDER TYPE 3=C & A, 4=FEE BASIS
S NPDEAIEN=0 F S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'+NPDEAIEN D
. S IENS=NPDEAIEN_","_NPIEN_","
. K NPDEADAT D GETS^DIQ(200.5321,IENS,"**","","NPDEADAT") Q:'$D(NPDEADAT) ; NEW PERSON DATA SET
. S DNDEAIEN=$$GET1^DIQ(200.5321,IENS,.03,"I") Q:'DNDEAIEN ; DN DEA IEN INTERNAL
. S DNDEAEXP=$$GET1^DIQ(8991.9,DNDEAIEN,.04,"I") ; EXPIRATION DATE INTERNAL
. S DNDEATYP=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"I") ; DN DEA TYPE INTERNAL
. K DNDEADAT D GETS^DIQ(8991.9,DNDEAIEN,"**","","DNDEADAT") Q:'$D(DNDEADAT) ; DEA NUMBERS DATA SET
. I $$FMDIFF^XLFDT(DT,DNDEAEXP,1)>365 Q ; IGNORE OLD DEA NUMBERS
. S CNT=$G(CNT)+1
. S RET(CNT)=""
. S $P(RET(CNT),"^",1)=1 ; VALID FOR USE
. S $P(RET(CNT),"^",2)=NPDEADAT(200.5321,IENS,.01) ; NEW PERSON DEA NUMBER
. S $P(RET(CNT),"^",3)=NPDEADAT(200.5321,IENS,.02) ; INDIVIDUAL DEA SUFFIX
. S $P(RET(CNT),"^",4)=DNDEADAT(8991.9,DNDEAIEN_",",.07) ; DN DEA TYPE
. S $P(RET(CNT),"^",5)=DNDEADAT(8991.9,DNDEAIEN_",",1.2) ; STREET ADDRESS 1
. S $P(RET(CNT),"^",6)=DNDEADAT(8991.9,DNDEAIEN_",",1.3) ; STREET ADDRESS 2
. S $P(RET(CNT),"^",7)=DNDEADAT(8991.9,DNDEAIEN_",",1.4) ; STREET ADDRESS 3
. S $P(RET(CNT),"^",8)=DNDEADAT(8991.9,DNDEAIEN_",",1.5) ; CITY
. S $P(RET(CNT),"^",9)=DNDEADAT(8991.9,DNDEAIEN_",",1.6) ; STATE
. S $P(RET(CNT),"^",10)=DNDEADAT(8991.9,DNDEAIEN_",",1.7) ; ZIP CODE
.; S $P(RET(CNT),"^",11)=DNDEADAT(8991.9,DNDEAIEN_",",.03) ; DETOX NUMBER
. S $P(RET(CNT),"^",11)=DETPRO ; DETOX NUMBER
. S $P(RET(CNT),"^",12)=DNDEADAT(8991.9,DNDEAIEN_",",.04) ; EXPIRATION DATE
. I $$GET1^DIQ(8991.9,DNDEAIEN,.07,"E")="INDIVIDUAL" D
. . S $P(RET(CNT),"^",13)=DNDEADAT(8991.9,DNDEAIEN_",",2.1) ; SCHEDULE II NARCOTIC
. . S $P(RET(CNT),"^",14)=DNDEADAT(8991.9,DNDEAIEN_",",2.2) ; SCHEDULE II NON-NARCOTIC
. . S $P(RET(CNT),"^",15)=DNDEADAT(8991.9,DNDEAIEN_",",2.3) ; SCHEDULE III NARCOTIC
. . S $P(RET(CNT),"^",16)=DNDEADAT(8991.9,DNDEAIEN_",",2.4) ; SCHEDULE III NON-NARCOTIC
. . S $P(RET(CNT),"^",17)=DNDEADAT(8991.9,DNDEAIEN_",",2.5) ; SCHEDULE IV
. . S $P(RET(CNT),"^",18)=DNDEADAT(8991.9,DNDEAIEN_",",2.6) ; SCHEDULE V
. I $$GET1^DIQ(8991.9,DNDEAIEN,.07,"E")'="INDIVIDUAL" D
. . S $P(RET(CNT),"^",13)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.1,"E")) ; SCHEDULE II NARCOTIC
. . S $P(RET(CNT),"^",14)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.2,"E")) ; SCHEDULE II NON-NARCOTIC
. . S $P(RET(CNT),"^",15)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.3,"E")) ; SCHEDULE III NARCOTIC
. . S $P(RET(CNT),"^",16)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.4,"E")) ; SCHEDULE III NON-NARCOTIC
. . S $P(RET(CNT),"^",17)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.5,"E")) ; SCHEDULE IV
. . S $P(RET(CNT),"^",18)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.6,"E")) ; SCHEDULE V
. S $P(RET(CNT),"^",19)=DNDEADAT(8991.9,DNDEAIEN_",",.06) ; USE FOR INPATIENT ORDERS?
. S $P(RET(CNT),"^",20)=FAILOVER ; FAILOVER FLAG
. S $P(RET(CNT),"^",21)=VANUMB ; PROVIDER VA NUMBER
. S $P(RET(CNT),"^",22)=PROVTYPE ; PROVIDER TYPE 3=C & A, 4=FEE BASIS
. ;
. S EX=0
. I DNDEAEXP<DT S $P(RET(CNT),"^",2)="* "_$P(RET(CNT),"^",2),$P(RET(CNT),"^",1)=0,$P(RET(CNT),"^",23)="Expired: "_$P(RET(CNT),"^",12) S INDEX(1,CNT)="",INDEX(0,1)=INDEX(0,1)+1,EX=1
. I 'EX,SCHEDULE="2",$P(RET(CNT),"^",13)'="YES" S $P(RET(CNT),"^",2)="* "_$P(RET(CNT),"^",2),$P(RET(CNT),"^",1)=0,$P(RET(CNT),"^",23)="NOT VALID FOR SCHEDULE II" S INDEX(2,CNT)="",INDEX(0,2)=INDEX(0,2)+1,EX=1
. I 'EX,SCHEDULE="2n",$P(RET(CNT),"^",14)'="YES" S $P(RET(CNT),"^",2)="* "_$P(RET(CNT),"^",2),$P(RET(CNT),"^",1)=0,$P(RET(CNT),"^",23)="NOT VALID FOR SCHEDULE II NON NARCOTIC" S INDEX(2,CNT)="",INDEX(0,2)=INDEX(0,2)+1,EX=1
. I 'EX,SCHEDULE="3",$P(RET(CNT),"^",15)'="YES" S $P(RET(CNT),"^",2)="* "_$P(RET(CNT),"^",2),$P(RET(CNT),"^",1)=0,$P(RET(CNT),"^",23)="NOT VALID FOR SCHEDULE III" S INDEX(2,CNT)="",INDEX(0,2)=INDEX(0,2)+1,EX=1
. I 'EX,SCHEDULE="3n",$P(RET(CNT),"^",16)'="YES" S $P(RET(CNT),"^",2)="* "_$P(RET(CNT),"^",2),$P(RET(CNT),"^",1)=0,$P(RET(CNT),"^",23)="NOT VALID FOR SCHEDULE III NON NARCOTIC" S INDEX(2,CNT)="",INDEX(0,2)=INDEX(0,2)+1,EX=1
. I 'EX,SCHEDULE="4",$P(RET(CNT),"^",17)'="YES" S $P(RET(CNT),"^",2)="* "_$P(RET(CNT),"^",2),$P(RET(CNT),"^",1)=0,$P(RET(CNT),"^",23)="NOT VALID FOR SCHEDULE IV" S INDEX(2,CNT)="",INDEX(0,2)=INDEX(0,2)+1,EX=1
. I 'EX,SCHEDULE="5",$P(RET(CNT),"^",18)'="YES" S $P(RET(CNT),"^",2)="* "_$P(RET(CNT),"^",2),$P(RET(CNT),"^",1)=0,$P(RET(CNT),"^",23)="NOT VALID FOR SCHEDULE V" S INDEX(2,CNT)="",INDEX(0,2)=INDEX(0,2)+1,EX=1
. I 'EX S INDEX(3,CNT)="",INDEX(0,3)=INDEX(0,3)+1
;
; 1 - Provider has a DEA# that is not expired, but not eligible.
I INDEX(0,3)=0,INDEX(0,2)>0 K RET S RET(1)="-1^2^"_SCHEDULE Q
;
; 2 - Provider has no DEA# (no active/no DEA# expired within the last year) and has no VA#, return RET(1)="-1^1"
I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)=0,VANUMB="" K RET S RET(1)="-1^1" Q
;
; 3 - Provider is not a VA Provider
I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)=0,VANUMB'="",PROVTYPE=3 K RET S RET(1)="-1^1" Q
I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)=0,VANUMB'="",PROVTYPE=4 K RET S RET(1)="-1^1" Q
I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)>0,VANUMB'="",PROVTYPE=3 K RET S RET(1)="-1^1" Q
I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)>0,VANUMB'="",PROVTYPE=4 K RET S RET(1)="-1^1" Q
I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)>0,VANUMB="",PROVTYPE=3 K RET S RET(1)="-1^1" Q
I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)>0,VANUMB="",PROVTYPE=4 K RET S RET(1)="-1^1" Q
;
; 4 - Provider has no DEA# (no active/no DEA# expired within the last year) and has a VA#, a VA provider
; (provider type not 3/4) and is eligible ("PS3") to write that schedule cont...
; this provider then can use the Facility DEA # tied to the clinic provided Facility DEA # is not expired.
; If above is true then RET(1)="1^Facility-VA# with the address detail)
; If above is not true, RET(1)="-1^1"
I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)=0,VANUMB'="",((PROVTYPE'=3)&(PROVTYPE'=4)) D K RET S RET(1)=CLINIC Q
. S CSTATUS=$$CLINIC(.CLINIC,HLIEN,NPIEN,SCHEDULE)
. I CSTATUS=0 S CLINIC="-1^1" Q
. I $P(CLINIC,"^",23)["Expired:" S CLINIC="-1^1" Q
. I $P(CLINIC,"^",23)["NOT VALID" S CLINIC="-1^1" Q
;
; 5 - Provider has no DEA# (no active) but has an expired DEA# within the last year and FAILOVER is set to "Yes"
; and has a VA#, a VA provider (provider type not 3/4) and is eligible ("PS3") to write that schedule
; this provider then can use the Facility DEA # tied to the clinic provided Facility DEA # is not expired.
; If above is true then RET(+1)="1^Facility-VA# with the address detail)
; If above is not true, RET(1)="-1^1"
I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)>0,FAILOVER=1,VANUMB'="",((PROVTYPE'=3)&(PROVTYPE'=4)) D I +CLINIC=-1 K RET S RET(1)=CLINIC Q
. S CSTATUS=$$CLINIC(.CLINIC,HLIEN,NPIEN,SCHEDULE)
. I '$D(CLINIC) S CLINIC="-1^1" Q
. I $P(CLINIC,"^",23)["Expired:" S CLINIC="-1^1" Q
. I $P(CLINIC,"^",23)["NOT VALID" S CLINIC="-1^1" Q
. I $D(CLINIC) S CNT=CNT+1,INDEX(3,CNT)="",INDEX(0,3)=INDEX(0,3)+1,RET(CNT)=CLINIC
;
; 6 - Provider has no DEA# (no active) and no VA# but has an expired DEA# within the last year and FAILOVER is set to "No"
; then RET(1)="-1^7"
I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)>0,VANUMB="",FAILOVER=0 K RET S RET(1)="-1^7" Q
;
; 7 - Provider has a VA# but has an expired DEA# within the last year and FAILOVER is set to "No"
; then RET(1)="-1^7"
I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)>0,VANUMB'="",FAILOVER=0 K RET S RET(1)="-1^7" Q
;
; 8 - Provider has an expired DEA# within the last year, no VA# and FAILOVER is set to "Yes"
; then RET(1)="-1^7"
I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)>0,VANUMB="",FAILOVER=1 K RET S RET(1)="-1^7" Q
;
; RETURN THE FULL DEFAULT LIST
K ORTMP M ORTMP=RET K RET S CNT=0
S ORTMPX=0 F S ORTMPX=$O(INDEX(ORTMPX)) Q:'ORTMPX D
. S ORTMPY=0 F S ORTMPY=$O(INDEX(ORTMPX,ORTMPY)) Q:'ORTMPY D
.. S CNT=CNT+1,RET(CNT)=ORTMP(ORTMPY)
;
Q
;
CLINIC(RET,HLIEN,NPIEN,SCHEDULE) ; -- Functionality to return a Clinic DEA number for a provider.
; HLIEN = HOSPITAL LOCATION FILE #44 IEN PROVIDED AS AN INPUT
; DIVISION = DIVISION FIELD #3.5 POINTER TO MEDICAL CENTER DIVISION FILE (#40.8)
; FACDEA = INSTITUTION FILE #4, FACILITY DEA NUMBER FIELD #52
N INSTITUT,DIVISION,FACDEA,FACDEAEX,NPDAT,PROVVAN
Q:'$G(HLIEN) 0
S DIVISION=$$GET1^DIQ(44,HLIEN,3.5,"I") Q:'DIVISION 0
S INSTITUT=$$GET1^DIQ(40.8,DIVISION,.07,"I") Q:'INSTITUT 0
S FACDEA=$$GET1^DIQ(4,INSTITUT,52) Q:FACDEA="" 0
S RET=""
S FACDEAEX=$$GET1^DIQ(4,INSTITUT,52.1,"I") ; FACILITY DEA EXPIRATION DATE INTERNAL
I $$FMDIFF^XLFDT(DT,FACDEAEX,1)>365 Q 0 ; IGNORE OLD DEA NUMBERS
S $P(RET,"^",1)=1 ; VALID FOR USE
S $P(RET,"^",2)=FACDEA ; FACILITY DEA NUMBER
S $P(RET,"^",3)=$$GET1^DIQ(200,NPIEN,53.3) ; PROVIDER VA NUMBER as SUFFIX
S $P(RET,"^",4)="INSTITUTIONAL" ; DN DEA TYPE - INSTITUTIONAL
S $P(RET,"^",5)=$$GET1^DIQ(4,INSTITUT,1.01) ; FACILITY STREET ADDRESS 1
S $P(RET,"^",6)=$$GET1^DIQ(4,INSTITUT,1.02) ; FACILITY STREET ADDRESS 2
S $P(RET,"^",7)="" ; FACILITY STREET ADDRESS 3 - N/A
S $P(RET,"^",8)=$$GET1^DIQ(4,INSTITUT,1.03) ; FACILITY CITY
S $P(RET,"^",9)=$$GET1^DIQ(4,INSTITUT,.02) ; FACILITY STATE
S $P(RET,"^",10)=$$GET1^DIQ(4,INSTITUT,1.04) ; FACILITY ZIP CODE
;S $P(RET,"^",11)=$$GET1^DIQ(200,NPIEN,9001) ; DETOX NUMBER
S $P(RET,"^",11)=DETPRO ; DETOX NUMBER
S $P(RET,"^",12)=$$GET1^DIQ(4,INSTITUT,52.1) ; FACILITY DEA EXPIRATION DATE
S $P(RET,"^",13)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.1)) ; SCHEDULE II NARCOTIC
S $P(RET,"^",14)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.2)) ; SCHEDULE II NON-NARCOTIC
S $P(RET,"^",15)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.3)) ; SCHEDULE III NARCOTIC
S $P(RET,"^",16)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.4)) ; SCHEDULE III NON-NARCOTIC
S $P(RET,"^",17)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.5)) ; SCHEDULE IV
S $P(RET,"^",18)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.6)) ; SCHEDULE V
S $P(RET,"^",19)="" ; USE FOR INPATIENT ORDERS? - N/A
S $P(RET,"^",20)=$$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I") ; FAILOVER FLAG
S $P(RET,"^",21)=$$GET1^DIQ(200,NPIEN,53.3) ; PROVIDER VA NUMBER
S $P(RET,"^",22)=$$GET1^DIQ(200,NPIEN,53.6,"I") ; PROVIDER TYPE 3=C & A, 4=FEE BASIS
;
I FACDEAEX<DT S $P(RET,"^",2)="* "_$P(RET,"^",2),$P(RET,"^",1)=0,$P(RET,"^",23)="Expired: "_$P(RET,"^",12) G CLINICQ
I SCHEDULE="2",$P(RET,"^",13)'="YES" S $P(RET,"^",2)="* "_$P(RET,"^",2),$P(RET,"^",1)=0,$P(RET,"^",23)="NOT VALID FOR SCHEDULE II" G CLINICQ
I SCHEDULE="2n",$P(RET,"^",14)'="YES" S $P(RET,"^",2)="* "_$P(RET,"^",2),$P(RET,"^",1)=0,$P(RET,"^",23)="NOT VALID FOR SCHEDULE II NON NARCOTIC" G CLINICQ
I SCHEDULE="3",$P(RET,"^",15)'="YES" S $P(RET,"^",2)="* "_$P(RET,"^",2),$P(RET,"^",1)=0,$P(RET,"^",23)="NOT VALID FOR SCHEDULE III" G CLINICQ
I SCHEDULE="3n",$P(RET,"^",16)'="YES" S $P(RET,"^",2)="* "_$P(RET,"^",2),$P(RET,"^",1)=0,$P(RET,"^",23)="NOT VALID FOR SCHEDULE III NON NARCOTIC" G CLINICQ
I SCHEDULE="4",$P(RET,"^",17)'="YES" S $P(RET,"^",2)="* "_$P(RET,"^",2),$P(RET,"^",1)=0,$P(RET,"^",23)="NOT VALID FOR SCHEDULE IV" G CLINICQ
I SCHEDULE="5",$P(RET,"^",18)'="YES" S $P(RET,"^",2)="* "_$P(RET,"^",2),$P(RET,"^",1)=0,$P(RET,"^",23)="NOT VALID FOR SCHEDULE V" G CLINICQ
;
CLINICQ ; FUNCTION END POINT
Q $P(RET,"^",1)
;
DOIIEN(DOIIEN) ; -- DOJ DRUG SCHEDULE CALCULATOR WITH ORDER ITEM IEN INPUT
Q:'$G(DOIIEN) ""
N SCHEDULE,VALID,TPKG,PSOI
S (VALID("2"),VALID("2n"),VALID("3"),VALID("3n"),VALID("4"),VALID("5"))=""
S TPKG=$P($G(^ORD(101.43,DOIIEN,0)),U,2) Q:TPKG'["PS" ""
S PSOI=+TPKG Q:'PSOI ""
S SCHEDULE=$P($$OIDEA^PSSOPKI(PSOI,"I"),";",2) Q:'+SCHEDULE ""
Q:'$D(VALID(SCHEDULE)) ""
Q SCHEDULE
;
ZIP(RETURN,OI,PSTYPE,DFN) ; -- zip code required to prescribe cs orders
; OI = ORDERABLE ITEMS (#101.43) pointer
; PSTYPE = APPLICATION CODE - O=Outpatient Pharmacy, I=IV, U=Unit Dose
; DFN = Patient IEN
N VAPA,TPKG,PSOI,DEAFLG,DPKG
S RETURN=1,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2)
Q:TPKG'["PS"
S PSOI=+TPKG Q:PSOI'>0
S DEAFLG=$P($$OIDEA^PSSOPKI(PSOI,PSTYPE),";",2)
I '+$G(DEAFLG) Q
D ADD^VADPT
I $$USA^ORWDPS11(DFN),'(VAPA(11)!VAPA(6)),$$GET^XPAR("SYS","OR ZIP CODE SWITCH") D Q
. S RETURN="0^Controlled substance prescriptions require a patient address. "
. S RETURN=RETURN_$$GET^XPAR("ALL","OR ZIP CODE MESSAGE",1)
S RETURN="1^"_+DEAFLG_$S($E(DEAFLG,2)="n":"^n",1:"")
Q
;
ZIPM ; - zip code parameter message
D EDITPAR^XPAREDIT("OR ZIP CODE MESSAGE")
Q
;
VALDEA(FAIL,OI,ORNP,PSTYPE,ORID) ; - return 1 if DEA check fails for this provider
N DEAFLG,PSOI,TPKG,RT,DETFLAG,DETPRO,ORSLDEA,Y
S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2)
Q:'$G(ORID)
S ORSLDEA=$P($G(^OR(100,ORID,11.1)),U)
Q:ORSLDEA=""
Q:TPKG'["PS"
S PSOI=+TPKG Q:PSOI'>0
S DETFLAG=$$OIDETOX^PSSOPKI(PSOI,PSTYPE)
S DETPRO=$$DETOX^XUSER(+$G(ORNP))
I DETFLAG,DETPRO="" S FAIL=3 Q
I DETFLAG,DETPRO>0 S Y=DETPRO X ^DD("DD") S FAIL="5^"_Y Q
S DEAFLG=$P($$OIDEA^PSSOPKI(PSOI,PSTYPE),";",2) Q:DEAFLG'>0
I DEAFLG=1 S FAIL=6 Q
S RT=$$SDEA^XUSER(,+$G(ORNP),DEAFLG,ORSLDEA,"I") ; Default to the required "Use For Inpatient" DEA# until selection from list is enabled
I RT=1 S FAIL=1 Q
I RT=2 S FAIL="2^"_$$UP^XLFSTR(DEAFLG) Q
I RT?1"4".E S FAIL=RT
Q
;
USA(DFN) ; Does patient address contan a U.S. address based on Country or State?
; Input: DFN - Patient Identifier from PATIENT file (#2)
; Output: 0 - Address is not U.S.
; 1 - Address is U.S.
; -1 - Address could not be determined to be U.S.
;
N COUNTRY,STATE,STATEAR,STATEIENS,VAPA
Q:'$G(DFN) 0
Q:'$L($G(^DPT(+DFN,0))) 0
D ADD^VADPT
S COUNTRY=$S($G(VAPA(25)):$P(VAPA(25),U,2),$G(VAPA(37)):$P(VAPA(37),U,2),1:"")
I $L(COUNTRY) Q $S(COUNTRY="UNITED STATES":1,1:0)
S STATE=$S($G(VAPA(5)):$P(VAPA(5),U),$G(VAPA(34)):$P(VAPA(34),U),1:"")
I STATE S STATEIENS=STATE_"," D GETS^DIQ(5,STATEIENS,"2.2","I","STATEAR") Q $S($G(STATEAR(5,STATEIENS,2.2,"I")):1,1:0)
Q -1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDPS11 17632 printed Oct 16, 2024@18:36:14 Page 2
ORWDPS11 ; ALB/BI - Pharmacy Calls for Windows Dialog ;10/25/2018
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**499**;Dec 17, 1997;Build 165
+2 ;Reference to ^PSSOPKI supported by DBIA #3737
+3 ;Reference to ^ORD(101.43 supported by DBIA #5430
+4 ;Reference to EDITPAR^XPAREDIT supported by DBIA #2336
+5 ;
+6 QUIT
+7 ;
DEALIST(RET,NPIEN,DOI,PSTYPE,HLIEN) ; -- RPC to return a List of DEA numbers and information for a single provider and a clinic DEA number.
+1 ; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
+2 ; DOI - DRUG ORDERABLE ITEM #101.43 INTERNAL ENTRY NUMBER
+3 ; PSTYPE - O=Outpatient, I=Inpatient
+4 ; HLIEN - HOSPITAL LOCATION INTERNAL ENTRY NUMBER in FILE #44
+5 ;
+6 ; OUTPUT: RET - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
+7 ; 1 - VALID FOR USE: 0=NO, 1=YES
+8 ; 2 - DEA NUMBER
+9 ; 3 - INDIVIDUAL DEA SUFFIX
+10 ; 4 - DEA NUMBER TYPE: INDIVIDUAL/INSTITUTIONAL
+11 ; 5 - STREET ADDRESS 1
+12 ; 6 - STREET ADDRESS 2
+13 ; 7 - STREET ADDRESS 3
+14 ; 8 - CITY
+15 ; 9 - STATE
+16 ; 10 - ZIP CODE
+17 ; 11 - DETOX NUMBER
+18 ; 12 - EXPIRATION DATE: FROM THE DEA NUMBERS FILE (#8991.9), FIELD EXPIRATION DATE (#.04)
+19 ; 13 - SCHEDULE II NARCOTIC
+20 ; 14 - SCHEDULE II NON-NARCOTIC
+21 ; 15 - SCHEDULE III NARCOTIC
+22 ; 16 - SCHEDULE III NON-NARCOTIC
+23 ; 17 - SCHEDULE IV
+24 ; 18 - SCHEDULE V
+25 ; 19 - USE FOR INPATIENT ORDERS?
+26 ; 20 - FAILOVER FLAG
+27 ; 21 - PROVIDER VA NUMBER
+28 ; 22 - PROVIDER TYPE 3=C & A, 4=FEE BASIS
+29 ; 23 - MESSAGE
+30 ;
+31 if '$GET(NPIEN)
QUIT
+32 if '$GET(DOI)
QUIT
+33 ;
+34 NEW TPKG,PSOI
SET TPKG=$PIECE($GET(^ORD(101.43,DOI,0)),U,2)
if TPKG'["PS"
QUIT
+35 SET PSOI=+TPKG
if 'PSOI
QUIT
+36 NEW SCHEDULE
SET SCHEDULE=$$DOIIEN(DOI)
if 'SCHEDULE
QUIT
+37 SET DETFLAG=$$OIDETOX^PSSOPKI(PSOI,PSTYPE)
+38 SET DETPRO=$$DETOX^XUSER(NPIEN)
+39 IF DETFLAG
IF DETPRO=""
SET RET(1)="-1^3"
QUIT
+40 if 'DETFLAG
SET DETPRO=""
+41 ;
+42 NEW CASEIEN,CLINIC,CNT,CSTATUS,DNDEADAT,DNDEAEXP,DNDEAIEN,DNDEATYP,EX,FAIL,FAILOVER
+43 NEW IENS,INDEX,NPDEADAT,NPDEAIEN,PROVTYPE,ORTMP,ORTMPX,ORTMPY,VANUMB,VANUMBEX,VDATA
+44 SET (INDEX(0,1),INDEX(0,2),INDEX(0,3))=0
+45 SET FAILOVER=$$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I")
+46 SET VANUMB=$$GET1^DIQ(200,NPIEN,53.3)
SET VANUMBEX=$$GET1^DIQ(200,NPIEN,53.4,"I")
+47 ; PROVIDER TYPE 3=C & A, 4=FEE BASIS
SET PROVTYPE=$$GET1^DIQ(200,NPIEN,53.6,"I")
+48 SET NPDEAIEN=0
FOR
SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
if '+NPDEAIEN
QUIT
Begin DoDot:1
+49 SET IENS=NPDEAIEN_","_NPIEN_","
+50 ; NEW PERSON DATA SET
KILL NPDEADAT
DO GETS^DIQ(200.5321,IENS,"**","","NPDEADAT")
if '$DATA(NPDEADAT)
QUIT
+51 ; DN DEA IEN INTERNAL
SET DNDEAIEN=$$GET1^DIQ(200.5321,IENS,.03,"I")
if 'DNDEAIEN
QUIT
+52 ; EXPIRATION DATE INTERNAL
SET DNDEAEXP=$$GET1^DIQ(8991.9,DNDEAIEN,.04,"I")
+53 ; DN DEA TYPE INTERNAL
SET DNDEATYP=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")
+54 ; DEA NUMBERS DATA SET
KILL DNDEADAT
DO GETS^DIQ(8991.9,DNDEAIEN,"**","","DNDEADAT")
if '$DATA(DNDEADAT)
QUIT
+55 ; IGNORE OLD DEA NUMBERS
IF $$FMDIFF^XLFDT(DT,DNDEAEXP,1)>365
QUIT
+56 SET CNT=$GET(CNT)+1
+57 SET RET(CNT)=""
+58 ; VALID FOR USE
SET $PIECE(RET(CNT),"^",1)=1
+59 ; NEW PERSON DEA NUMBER
SET $PIECE(RET(CNT),"^",2)=NPDEADAT(200.5321,IENS,.01)
+60 ; INDIVIDUAL DEA SUFFIX
SET $PIECE(RET(CNT),"^",3)=NPDEADAT(200.5321,IENS,.02)
+61 ; DN DEA TYPE
SET $PIECE(RET(CNT),"^",4)=DNDEADAT(8991.9,DNDEAIEN_",",.07)
+62 ; STREET ADDRESS 1
SET $PIECE(RET(CNT),"^",5)=DNDEADAT(8991.9,DNDEAIEN_",",1.2)
+63 ; STREET ADDRESS 2
SET $PIECE(RET(CNT),"^",6)=DNDEADAT(8991.9,DNDEAIEN_",",1.3)
+64 ; STREET ADDRESS 3
SET $PIECE(RET(CNT),"^",7)=DNDEADAT(8991.9,DNDEAIEN_",",1.4)
+65 ; CITY
SET $PIECE(RET(CNT),"^",8)=DNDEADAT(8991.9,DNDEAIEN_",",1.5)
+66 ; STATE
SET $PIECE(RET(CNT),"^",9)=DNDEADAT(8991.9,DNDEAIEN_",",1.6)
+67 ; ZIP CODE
SET $PIECE(RET(CNT),"^",10)=DNDEADAT(8991.9,DNDEAIEN_",",1.7)
+68 ; S $P(RET(CNT),"^",11)=DNDEADAT(8991.9,DNDEAIEN_",",.03) ; DETOX NUMBER
+69 ; DETOX NUMBER
SET $PIECE(RET(CNT),"^",11)=DETPRO
+70 ; EXPIRATION DATE
SET $PIECE(RET(CNT),"^",12)=DNDEADAT(8991.9,DNDEAIEN_",",.04)
+71 IF $$GET1^DIQ(8991.9,DNDEAIEN,.07,"E")="INDIVIDUAL"
Begin DoDot:2
+72 ; SCHEDULE II NARCOTIC
SET $PIECE(RET(CNT),"^",13)=DNDEADAT(8991.9,DNDEAIEN_",",2.1)
+73 ; SCHEDULE II NON-NARCOTIC
SET $PIECE(RET(CNT),"^",14)=DNDEADAT(8991.9,DNDEAIEN_",",2.2)
+74 ; SCHEDULE III NARCOTIC
SET $PIECE(RET(CNT),"^",15)=DNDEADAT(8991.9,DNDEAIEN_",",2.3)
+75 ; SCHEDULE III NON-NARCOTIC
SET $PIECE(RET(CNT),"^",16)=DNDEADAT(8991.9,DNDEAIEN_",",2.4)
+76 ; SCHEDULE IV
SET $PIECE(RET(CNT),"^",17)=DNDEADAT(8991.9,DNDEAIEN_",",2.5)
+77 ; SCHEDULE V
SET $PIECE(RET(CNT),"^",18)=DNDEADAT(8991.9,DNDEAIEN_",",2.6)
End DoDot:2
+78 IF $$GET1^DIQ(8991.9,DNDEAIEN,.07,"E")'="INDIVIDUAL"
Begin DoDot:2
+79 ; SCHEDULE II NARCOTIC
SET $PIECE(RET(CNT),"^",13)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.1,"E"))
+80 ; SCHEDULE II NON-NARCOTIC
SET $PIECE(RET(CNT),"^",14)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.2,"E"))
+81 ; SCHEDULE III NARCOTIC
SET $PIECE(RET(CNT),"^",15)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.3,"E"))
+82 ; SCHEDULE III NON-NARCOTIC
SET $PIECE(RET(CNT),"^",16)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.4,"E"))
+83 ; SCHEDULE IV
SET $PIECE(RET(CNT),"^",17)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.5,"E"))
+84 ; SCHEDULE V
SET $PIECE(RET(CNT),"^",18)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.6,"E"))
End DoDot:2
+85 ; USE FOR INPATIENT ORDERS?
SET $PIECE(RET(CNT),"^",19)=DNDEADAT(8991.9,DNDEAIEN_",",.06)
+86 ; FAILOVER FLAG
SET $PIECE(RET(CNT),"^",20)=FAILOVER
+87 ; PROVIDER VA NUMBER
SET $PIECE(RET(CNT),"^",21)=VANUMB
+88 ; PROVIDER TYPE 3=C & A, 4=FEE BASIS
SET $PIECE(RET(CNT),"^",22)=PROVTYPE
+89 ;
+90 SET EX=0
+91 IF DNDEAEXP<DT
SET $PIECE(RET(CNT),"^",2)="* "_$PIECE(RET(CNT),"^",2)
SET $PIECE(RET(CNT),"^",1)=0
SET $PIECE(RET(CNT),"^",23)="Expired: "_$PIECE(RET(CNT),"^",12)
SET INDEX(1,CNT)=""
SET INDEX(0,1)=INDEX(0,1)+1
SET EX=1
+92 IF 'EX
IF SCHEDULE="2"
IF $PIECE(RET(CNT),"^",13)'="YES"
SET $PIECE(RET(CNT),"^",2)="* "_$PIECE(RET(CNT),"^",2)
SET $PIECE(RET(CNT),"^",1)=0
SET $PIECE(RET(CNT),"^",23)="NOT VALID FOR SCHEDULE II"
SET INDEX(2,CNT)=""
SET INDEX(0,2)=INDEX(0,2)+1
SET EX=1
+93 IF 'EX
IF SCHEDULE="2n"
IF $PIECE(RET(CNT),"^",14)'="YES"
SET $PIECE(RET(CNT),"^",2)="* "_$PIECE(RET(CNT),"^",2)
SET $PIECE(RET(CNT),"^",1)=0
SET $PIECE(RET(CNT),"^",23)="NOT VALID FOR SCHEDULE II NON NARCOTIC"
SET INDEX(2,CNT)=""
SET INDEX(0,2)=INDEX(0,2)+1
SET EX=1
+94 IF 'EX
IF SCHEDULE="3"
IF $PIECE(RET(CNT),"^",15)'="YES"
SET $PIECE(RET(CNT),"^",2)="* "_$PIECE(RET(CNT),"^",2)
SET $PIECE(RET(CNT),"^",1)=0
SET $PIECE(RET(CNT),"^",23)="NOT VALID FOR SCHEDULE III"
SET INDEX(2,CNT)=""
SET INDEX(0,2)=INDEX(0,2)+1
SET EX=1
+95 IF 'EX
IF SCHEDULE="3n"
IF $PIECE(RET(CNT),"^",16)'="YES"
SET $PIECE(RET(CNT),"^",2)="* "_$PIECE(RET(CNT),"^",2)
SET $PIECE(RET(CNT),"^",1)=0
SET $PIECE(RET(CNT),"^",23)="NOT VALID FOR SCHEDULE III NON NARCOTIC"
SET INDEX(2,CNT)=""
SET INDEX(0,2)=INDEX(0,2)+1
SET EX=1
+96 IF 'EX
IF SCHEDULE="4"
IF $PIECE(RET(CNT),"^",17)'="YES"
SET $PIECE(RET(CNT),"^",2)="* "_$PIECE(RET(CNT),"^",2)
SET $PIECE(RET(CNT),"^",1)=0
SET $PIECE(RET(CNT),"^",23)="NOT VALID FOR SCHEDULE IV"
SET INDEX(2,CNT)=""
SET INDEX(0,2)=INDEX(0,2)+1
SET EX=1
+97 IF 'EX
IF SCHEDULE="5"
IF $PIECE(RET(CNT),"^",18)'="YES"
SET $PIECE(RET(CNT),"^",2)="* "_$PIECE(RET(CNT),"^",2)
SET $PIECE(RET(CNT),"^",1)=0
SET $PIECE(RET(CNT),"^",23)="NOT VALID FOR SCHEDULE V"
SET INDEX(2,CNT)=""
SET INDEX(0,2)=INDEX(0,2)+1
SET EX=1
+98 IF 'EX
SET INDEX(3,CNT)=""
SET INDEX(0,3)=INDEX(0,3)+1
End DoDot:1
+99 ;
+100 ; 1 - Provider has a DEA# that is not expired, but not eligible.
+101 IF INDEX(0,3)=0
IF INDEX(0,2)>0
KILL RET
SET RET(1)="-1^2^"_SCHEDULE
QUIT
+102 ;
+103 ; 2 - Provider has no DEA# (no active/no DEA# expired within the last year) and has no VA#, return RET(1)="-1^1"
+104 IF INDEX(0,3)=0
IF INDEX(0,2)=0
IF INDEX(0,1)=0
IF VANUMB=""
KILL RET
SET RET(1)="-1^1"
QUIT
+105 ;
+106 ; 3 - Provider is not a VA Provider
+107 IF INDEX(0,3)=0
IF INDEX(0,2)=0
IF INDEX(0,1)=0
IF VANUMB'=""
IF PROVTYPE=3
KILL RET
SET RET(1)="-1^1"
QUIT
+108 IF INDEX(0,3)=0
IF INDEX(0,2)=0
IF INDEX(0,1)=0
IF VANUMB'=""
IF PROVTYPE=4
KILL RET
SET RET(1)="-1^1"
QUIT
+109 IF INDEX(0,3)=0
IF INDEX(0,2)=0
IF INDEX(0,1)>0
IF VANUMB'=""
IF PROVTYPE=3
KILL RET
SET RET(1)="-1^1"
QUIT
+110 IF INDEX(0,3)=0
IF INDEX(0,2)=0
IF INDEX(0,1)>0
IF VANUMB'=""
IF PROVTYPE=4
KILL RET
SET RET(1)="-1^1"
QUIT
+111 IF INDEX(0,3)=0
IF INDEX(0,2)=0
IF INDEX(0,1)>0
IF VANUMB=""
IF PROVTYPE=3
KILL RET
SET RET(1)="-1^1"
QUIT
+112 IF INDEX(0,3)=0
IF INDEX(0,2)=0
IF INDEX(0,1)>0
IF VANUMB=""
IF PROVTYPE=4
KILL RET
SET RET(1)="-1^1"
QUIT
+113 ;
+114 ; 4 - Provider has no DEA# (no active/no DEA# expired within the last year) and has a VA#, a VA provider
+115 ; (provider type not 3/4) and is eligible ("PS3") to write that schedule cont...
+116 ; this provider then can use the Facility DEA # tied to the clinic provided Facility DEA # is not expired.
+117 ; If above is true then RET(1)="1^Facility-VA# with the address detail)
+118 ; If above is not true, RET(1)="-1^1"
+119 IF INDEX(0,3)=0
IF INDEX(0,2)=0
IF INDEX(0,1)=0
IF VANUMB'=""
IF ((PROVTYPE'=3)&(PROVTYPE'=4))
Begin DoDot:1
+120 SET CSTATUS=$$CLINIC(.CLINIC,HLIEN,NPIEN,SCHEDULE)
+121 IF CSTATUS=0
SET CLINIC="-1^1"
QUIT
+122 IF $PIECE(CLINIC,"^",23)["Expired:"
SET CLINIC="-1^1"
QUIT
+123 IF $PIECE(CLINIC,"^",23)["NOT VALID"
SET CLINIC="-1^1"
QUIT
End DoDot:1
KILL RET
SET RET(1)=CLINIC
QUIT
+124 ;
+125 ; 5 - Provider has no DEA# (no active) but has an expired DEA# within the last year and FAILOVER is set to "Yes"
+126 ; and has a VA#, a VA provider (provider type not 3/4) and is eligible ("PS3") to write that schedule
+127 ; this provider then can use the Facility DEA # tied to the clinic provided Facility DEA # is not expired.
+128 ; If above is true then RET(+1)="1^Facility-VA# with the address detail)
+129 ; If above is not true, RET(1)="-1^1"
+130 IF INDEX(0,3)=0
IF INDEX(0,2)=0
IF INDEX(0,1)>0
IF FAILOVER=1
IF VANUMB'=""
IF ((PROVTYPE'=3)&(PROVTYPE'=4))
Begin DoDot:1
+131 SET CSTATUS=$$CLINIC(.CLINIC,HLIEN,NPIEN,SCHEDULE)
+132 IF '$DATA(CLINIC)
SET CLINIC="-1^1"
QUIT
+133 IF $PIECE(CLINIC,"^",23)["Expired:"
SET CLINIC="-1^1"
QUIT
+134 IF $PIECE(CLINIC,"^",23)["NOT VALID"
SET CLINIC="-1^1"
QUIT
+135 IF $DATA(CLINIC)
SET CNT=CNT+1
SET INDEX(3,CNT)=""
SET INDEX(0,3)=INDEX(0,3)+1
SET RET(CNT)=CLINIC
End DoDot:1
IF +CLINIC=-1
KILL RET
SET RET(1)=CLINIC
QUIT
+136 ;
+137 ; 6 - Provider has no DEA# (no active) and no VA# but has an expired DEA# within the last year and FAILOVER is set to "No"
+138 ; then RET(1)="-1^7"
+139 IF INDEX(0,3)=0
IF INDEX(0,2)=0
IF INDEX(0,1)>0
IF VANUMB=""
IF FAILOVER=0
KILL RET
SET RET(1)="-1^7"
QUIT
+140 ;
+141 ; 7 - Provider has a VA# but has an expired DEA# within the last year and FAILOVER is set to "No"
+142 ; then RET(1)="-1^7"
+143 IF INDEX(0,3)=0
IF INDEX(0,2)=0
IF INDEX(0,1)>0
IF VANUMB'=""
IF FAILOVER=0
KILL RET
SET RET(1)="-1^7"
QUIT
+144 ;
+145 ; 8 - Provider has an expired DEA# within the last year, no VA# and FAILOVER is set to "Yes"
+146 ; then RET(1)="-1^7"
+147 IF INDEX(0,3)=0
IF INDEX(0,2)=0
IF INDEX(0,1)>0
IF VANUMB=""
IF FAILOVER=1
KILL RET
SET RET(1)="-1^7"
QUIT
+148 ;
+149 ; RETURN THE FULL DEFAULT LIST
+150 KILL ORTMP
MERGE ORTMP=RET
KILL RET
SET CNT=0
+151 SET ORTMPX=0
FOR
SET ORTMPX=$ORDER(INDEX(ORTMPX))
if 'ORTMPX
QUIT
Begin DoDot:1
+152 SET ORTMPY=0
FOR
SET ORTMPY=$ORDER(INDEX(ORTMPX,ORTMPY))
if 'ORTMPY
QUIT
Begin DoDot:2
+153 SET CNT=CNT+1
SET RET(CNT)=ORTMP(ORTMPY)
End DoDot:2
End DoDot:1
+154 ;
+155 QUIT
+156 ;
CLINIC(RET,HLIEN,NPIEN,SCHEDULE) ; -- Functionality to return a Clinic DEA number for a provider.
+1 ; HLIEN = HOSPITAL LOCATION FILE #44 IEN PROVIDED AS AN INPUT
+2 ; DIVISION = DIVISION FIELD #3.5 POINTER TO MEDICAL CENTER DIVISION FILE (#40.8)
+3 ; FACDEA = INSTITUTION FILE #4, FACILITY DEA NUMBER FIELD #52
+4 NEW INSTITUT,DIVISION,FACDEA,FACDEAEX,NPDAT,PROVVAN
+5 if '$GET(HLIEN)
QUIT 0
+6 SET DIVISION=$$GET1^DIQ(44,HLIEN,3.5,"I")
if 'DIVISION
QUIT 0
+7 SET INSTITUT=$$GET1^DIQ(40.8,DIVISION,.07,"I")
if 'INSTITUT
QUIT 0
+8 SET FACDEA=$$GET1^DIQ(4,INSTITUT,52)
if FACDEA=""
QUIT 0
+9 SET RET=""
+10 ; FACILITY DEA EXPIRATION DATE INTERNAL
SET FACDEAEX=$$GET1^DIQ(4,INSTITUT,52.1,"I")
+11 ; IGNORE OLD DEA NUMBERS
IF $$FMDIFF^XLFDT(DT,FACDEAEX,1)>365
QUIT 0
+12 ; VALID FOR USE
SET $PIECE(RET,"^",1)=1
+13 ; FACILITY DEA NUMBER
SET $PIECE(RET,"^",2)=FACDEA
+14 ; PROVIDER VA NUMBER as SUFFIX
SET $PIECE(RET,"^",3)=$$GET1^DIQ(200,NPIEN,53.3)
+15 ; DN DEA TYPE - INSTITUTIONAL
SET $PIECE(RET,"^",4)="INSTITUTIONAL"
+16 ; FACILITY STREET ADDRESS 1
SET $PIECE(RET,"^",5)=$$GET1^DIQ(4,INSTITUT,1.01)
+17 ; FACILITY STREET ADDRESS 2
SET $PIECE(RET,"^",6)=$$GET1^DIQ(4,INSTITUT,1.02)
+18 ; FACILITY STREET ADDRESS 3 - N/A
SET $PIECE(RET,"^",7)=""
+19 ; FACILITY CITY
SET $PIECE(RET,"^",8)=$$GET1^DIQ(4,INSTITUT,1.03)
+20 ; FACILITY STATE
SET $PIECE(RET,"^",9)=$$GET1^DIQ(4,INSTITUT,.02)
+21 ; FACILITY ZIP CODE
SET $PIECE(RET,"^",10)=$$GET1^DIQ(4,INSTITUT,1.04)
+22 ;S $P(RET,"^",11)=$$GET1^DIQ(200,NPIEN,9001) ; DETOX NUMBER
+23 ; DETOX NUMBER
SET $PIECE(RET,"^",11)=DETPRO
+24 ; FACILITY DEA EXPIRATION DATE
SET $PIECE(RET,"^",12)=$$GET1^DIQ(4,INSTITUT,52.1)
+25 ; SCHEDULE II NARCOTIC
SET $PIECE(RET,"^",13)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.1))
+26 ; SCHEDULE II NON-NARCOTIC
SET $PIECE(RET,"^",14)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.2))
+27 ; SCHEDULE III NARCOTIC
SET $PIECE(RET,"^",15)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.3))
+28 ; SCHEDULE III NON-NARCOTIC
SET $PIECE(RET,"^",16)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.4))
+29 ; SCHEDULE IV
SET $PIECE(RET,"^",17)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.5))
+30 ; SCHEDULE V
SET $PIECE(RET,"^",18)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.6))
+31 ; USE FOR INPATIENT ORDERS? - N/A
SET $PIECE(RET,"^",19)=""
+32 ; FAILOVER FLAG
SET $PIECE(RET,"^",20)=$$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I")
+33 ; PROVIDER VA NUMBER
SET $PIECE(RET,"^",21)=$$GET1^DIQ(200,NPIEN,53.3)
+34 ; PROVIDER TYPE 3=C & A, 4=FEE BASIS
SET $PIECE(RET,"^",22)=$$GET1^DIQ(200,NPIEN,53.6,"I")
+35 ;
+36 IF FACDEAEX<DT
SET $PIECE(RET,"^",2)="* "_$PIECE(RET,"^",2)
SET $PIECE(RET,"^",1)=0
SET $PIECE(RET,"^",23)="Expired: "_$PIECE(RET,"^",12)
GOTO CLINICQ
+37 IF SCHEDULE="2"
IF $PIECE(RET,"^",13)'="YES"
SET $PIECE(RET,"^",2)="* "_$PIECE(RET,"^",2)
SET $PIECE(RET,"^",1)=0
SET $PIECE(RET,"^",23)="NOT VALID FOR SCHEDULE II"
GOTO CLINICQ
+38 IF SCHEDULE="2n"
IF $PIECE(RET,"^",14)'="YES"
SET $PIECE(RET,"^",2)="* "_$PIECE(RET,"^",2)
SET $PIECE(RET,"^",1)=0
SET $PIECE(RET,"^",23)="NOT VALID FOR SCHEDULE II NON NARCOTIC"
GOTO CLINICQ
+39 IF SCHEDULE="3"
IF $PIECE(RET,"^",15)'="YES"
SET $PIECE(RET,"^",2)="* "_$PIECE(RET,"^",2)
SET $PIECE(RET,"^",1)=0
SET $PIECE(RET,"^",23)="NOT VALID FOR SCHEDULE III"
GOTO CLINICQ
+40 IF SCHEDULE="3n"
IF $PIECE(RET,"^",16)'="YES"
SET $PIECE(RET,"^",2)="* "_$PIECE(RET,"^",2)
SET $PIECE(RET,"^",1)=0
SET $PIECE(RET,"^",23)="NOT VALID FOR SCHEDULE III NON NARCOTIC"
GOTO CLINICQ
+41 IF SCHEDULE="4"
IF $PIECE(RET,"^",17)'="YES"
SET $PIECE(RET,"^",2)="* "_$PIECE(RET,"^",2)
SET $PIECE(RET,"^",1)=0
SET $PIECE(RET,"^",23)="NOT VALID FOR SCHEDULE IV"
GOTO CLINICQ
+42 IF SCHEDULE="5"
IF $PIECE(RET,"^",18)'="YES"
SET $PIECE(RET,"^",2)="* "_$PIECE(RET,"^",2)
SET $PIECE(RET,"^",1)=0
SET $PIECE(RET,"^",23)="NOT VALID FOR SCHEDULE V"
GOTO CLINICQ
+43 ;
CLINICQ ; FUNCTION END POINT
+1 QUIT $PIECE(RET,"^",1)
+2 ;
DOIIEN(DOIIEN) ; -- DOJ DRUG SCHEDULE CALCULATOR WITH ORDER ITEM IEN INPUT
+1 if '$GET(DOIIEN)
QUIT ""
+2 NEW SCHEDULE,VALID,TPKG,PSOI
+3 SET (VALID("2"),VALID("2n"),VALID("3"),VALID("3n"),VALID("4"),VALID("5"))=""
+4 SET TPKG=$PIECE($GET(^ORD(101.43,DOIIEN,0)),U,2)
if TPKG'["PS"
QUIT ""
+5 SET PSOI=+TPKG
if 'PSOI
QUIT ""
+6 SET SCHEDULE=$PIECE($$OIDEA^PSSOPKI(PSOI,"I"),";",2)
if '+SCHEDULE
QUIT ""
+7 if '$DATA(VALID(SCHEDULE))
QUIT ""
+8 QUIT SCHEDULE
+9 ;
ZIP(RETURN,OI,PSTYPE,DFN) ; -- zip code required to prescribe cs orders
+1 ; OI = ORDERABLE ITEMS (#101.43) pointer
+2 ; PSTYPE = APPLICATION CODE - O=Outpatient Pharmacy, I=IV, U=Unit Dose
+3 ; DFN = Patient IEN
+4 NEW VAPA,TPKG,PSOI,DEAFLG,DPKG
+5 SET RETURN=1
SET TPKG=$PIECE($GET(^ORD(101.43,+$GET(OI),0)),U,2)
+6 if TPKG'["PS"
QUIT
+7 SET PSOI=+TPKG
if PSOI'>0
QUIT
+8 SET DEAFLG=$PIECE($$OIDEA^PSSOPKI(PSOI,PSTYPE),";",2)
+9 IF '+$GET(DEAFLG)
QUIT
+10 DO ADD^VADPT
+11 IF $$USA^ORWDPS11(DFN)
IF '(VAPA(11)!VAPA(6))
IF $$GET^XPAR("SYS","OR ZIP CODE SWITCH")
Begin DoDot:1
+12 SET RETURN="0^Controlled substance prescriptions require a patient address. "
+13 SET RETURN=RETURN_$$GET^XPAR("ALL","OR ZIP CODE MESSAGE",1)
End DoDot:1
QUIT
+14 SET RETURN="1^"_+DEAFLG_$SELECT($EXTRACT(DEAFLG,2)="n":"^n",1:"")
+15 QUIT
+16 ;
ZIPM ; - zip code parameter message
+1 DO EDITPAR^XPAREDIT("OR ZIP CODE MESSAGE")
+2 QUIT
+3 ;
VALDEA(FAIL,OI,ORNP,PSTYPE,ORID) ; - return 1 if DEA check fails for this provider
+1 NEW DEAFLG,PSOI,TPKG,RT,DETFLAG,DETPRO,ORSLDEA,Y
+2 SET FAIL=0
SET TPKG=$PIECE($GET(^ORD(101.43,+$GET(OI),0)),U,2)
+3 if '$GET(ORID)
QUIT
+4 SET ORSLDEA=$PIECE($GET(^OR(100,ORID,11.1)),U)
+5 if ORSLDEA=""
QUIT
+6 if TPKG'["PS"
QUIT
+7 SET PSOI=+TPKG
if PSOI'>0
QUIT
+8 SET DETFLAG=$$OIDETOX^PSSOPKI(PSOI,PSTYPE)
+9 SET DETPRO=$$DETOX^XUSER(+$GET(ORNP))
+10 IF DETFLAG
IF DETPRO=""
SET FAIL=3
QUIT
+11 IF DETFLAG
IF DETPRO>0
SET Y=DETPRO
XECUTE ^DD("DD")
SET FAIL="5^"_Y
QUIT
+12 SET DEAFLG=$PIECE($$OIDEA^PSSOPKI(PSOI,PSTYPE),";",2)
if DEAFLG'>0
QUIT
+13 IF DEAFLG=1
SET FAIL=6
QUIT
+14 ; Default to the required "Use For Inpatient" DEA# until selection from list is enabled
SET RT=$$SDEA^XUSER(,+$GET(ORNP),DEAFLG,ORSLDEA,"I")
+15 IF RT=1
SET FAIL=1
QUIT
+16 IF RT=2
SET FAIL="2^"_$$UP^XLFSTR(DEAFLG)
QUIT
+17 IF RT?1"4".E
SET FAIL=RT
+18 QUIT
+19 ;
USA(DFN) ; Does patient address contan a U.S. address based on Country or State?
+1 ; Input: DFN - Patient Identifier from PATIENT file (#2)
+2 ; Output: 0 - Address is not U.S.
+3 ; 1 - Address is U.S.
+4 ; -1 - Address could not be determined to be U.S.
+5 ;
+6 NEW COUNTRY,STATE,STATEAR,STATEIENS,VAPA
+7 if '$GET(DFN)
QUIT 0
+8 if '$LENGTH($GET(^DPT(+DFN,0)))
QUIT 0
+9 DO ADD^VADPT
+10 SET COUNTRY=$SELECT($GET(VAPA(25)):$PIECE(VAPA(25),U,2),$GET(VAPA(37)):$PIECE(VAPA(37),U,2),1:"")
+11 IF $LENGTH(COUNTRY)
QUIT $SELECT(COUNTRY="UNITED STATES":1,1:0)
+12 SET STATE=$SELECT($GET(VAPA(5)):$PIECE(VAPA(5),U),$GET(VAPA(34)):$PIECE(VAPA(34),U),1:"")
+13 IF STATE
SET STATEIENS=STATE_","
DO GETS^DIQ(5,STATEIENS,"2.2","I","STATEAR")
QUIT $SELECT($GET(STATEAR(5,STATEIENS,2.2,"I")):1,1:0)
+14 QUIT -1
