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

ORWDPS11.m

Go to the documentation of this file.
  1. ORWDPS11 ; ALB/BI - Pharmacy Calls for Windows Dialog ;10/25/2018
  1. ;;3.0;ORDER ENTRY/RESULTS REPORTING;**499**;Dec 17, 1997;Build 165
  1. ;Reference to ^PSSOPKI supported by DBIA #3737
  1. ;Reference to ^ORD(101.43 supported by DBIA #5430
  1. ;Reference to EDITPAR^XPAREDIT supported by DBIA #2336
  1. ;
  1. Q
  1. ;
  1. 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
  1. ; DOI - DRUG ORDERABLE ITEM #101.43 INTERNAL ENTRY NUMBER
  1. ; PSTYPE - O=Outpatient, I=Inpatient
  1. ; HLIEN - HOSPITAL LOCATION INTERNAL ENTRY NUMBER in FILE #44
  1. ;
  1. ; OUTPUT: RET - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
  1. ; 1 - VALID FOR USE: 0=NO, 1=YES
  1. ; 2 - DEA NUMBER
  1. ; 3 - INDIVIDUAL DEA SUFFIX
  1. ; 4 - DEA NUMBER TYPE: INDIVIDUAL/INSTITUTIONAL
  1. ; 5 - STREET ADDRESS 1
  1. ; 6 - STREET ADDRESS 2
  1. ; 7 - STREET ADDRESS 3
  1. ; 8 - CITY
  1. ; 9 - STATE
  1. ; 10 - ZIP CODE
  1. ; 11 - DETOX NUMBER
  1. ; 12 - EXPIRATION DATE: FROM THE DEA NUMBERS FILE (#8991.9), FIELD EXPIRATION DATE (#.04)
  1. ; 13 - SCHEDULE II NARCOTIC
  1. ; 14 - SCHEDULE II NON-NARCOTIC
  1. ; 15 - SCHEDULE III NARCOTIC
  1. ; 16 - SCHEDULE III NON-NARCOTIC
  1. ; 17 - SCHEDULE IV
  1. ; 18 - SCHEDULE V
  1. ; 19 - USE FOR INPATIENT ORDERS?
  1. ; 20 - FAILOVER FLAG
  1. ; 21 - PROVIDER VA NUMBER
  1. ; 22 - PROVIDER TYPE 3=C & A, 4=FEE BASIS
  1. ; 23 - MESSAGE
  1. ;
  1. Q:'$G(NPIEN)
  1. Q:'$G(DOI)
  1. ;
  1. N TPKG,PSOI S TPKG=$P($G(^ORD(101.43,DOI,0)),U,2) Q:TPKG'["PS"
  1. S PSOI=+TPKG Q:'PSOI
  1. N SCHEDULE S SCHEDULE=$$DOIIEN(DOI) Q:'SCHEDULE
  1. S DETFLAG=$$OIDETOX^PSSOPKI(PSOI,PSTYPE)
  1. S DETPRO=$$DETOX^XUSER(NPIEN)
  1. I DETFLAG,DETPRO="" S RET(1)="-1^3" Q
  1. S:'DETFLAG DETPRO=""
  1. ;
  1. N CASEIEN,CLINIC,CNT,CSTATUS,DNDEADAT,DNDEAEXP,DNDEAIEN,DNDEATYP,EX,FAIL,FAILOVER
  1. N IENS,INDEX,NPDEADAT,NPDEAIEN,PROVTYPE,ORTMP,ORTMPX,ORTMPY,VANUMB,VANUMBEX,VDATA
  1. S (INDEX(0,1),INDEX(0,2),INDEX(0,3))=0
  1. S FAILOVER=$$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I")
  1. S VANUMB=$$GET1^DIQ(200,NPIEN,53.3),VANUMBEX=$$GET1^DIQ(200,NPIEN,53.4,"I")
  1. S PROVTYPE=$$GET1^DIQ(200,NPIEN,53.6,"I") ; PROVIDER TYPE 3=C & A, 4=FEE BASIS
  1. S NPDEAIEN=0 F S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'+NPDEAIEN D
  1. . S IENS=NPDEAIEN_","_NPIEN_","
  1. . K NPDEADAT D GETS^DIQ(200.5321,IENS,"**","","NPDEADAT") Q:'$D(NPDEADAT) ; NEW PERSON DATA SET
  1. . S DNDEAIEN=$$GET1^DIQ(200.5321,IENS,.03,"I") Q:'DNDEAIEN ; DN DEA IEN INTERNAL
  1. . S DNDEAEXP=$$GET1^DIQ(8991.9,DNDEAIEN,.04,"I") ; EXPIRATION DATE INTERNAL
  1. . S DNDEATYP=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"I") ; DN DEA TYPE INTERNAL
  1. . K DNDEADAT D GETS^DIQ(8991.9,DNDEAIEN,"**","","DNDEADAT") Q:'$D(DNDEADAT) ; DEA NUMBERS DATA SET
  1. . I $$FMDIFF^XLFDT(DT,DNDEAEXP,1)>365 Q ; IGNORE OLD DEA NUMBERS
  1. . S CNT=$G(CNT)+1
  1. . S RET(CNT)=""
  1. . S $P(RET(CNT),"^",1)=1 ; VALID FOR USE
  1. . S $P(RET(CNT),"^",2)=NPDEADAT(200.5321,IENS,.01) ; NEW PERSON DEA NUMBER
  1. . S $P(RET(CNT),"^",3)=NPDEADAT(200.5321,IENS,.02) ; INDIVIDUAL DEA SUFFIX
  1. . S $P(RET(CNT),"^",4)=DNDEADAT(8991.9,DNDEAIEN_",",.07) ; DN DEA TYPE
  1. . S $P(RET(CNT),"^",5)=DNDEADAT(8991.9,DNDEAIEN_",",1.2) ; STREET ADDRESS 1
  1. . S $P(RET(CNT),"^",6)=DNDEADAT(8991.9,DNDEAIEN_",",1.3) ; STREET ADDRESS 2
  1. . S $P(RET(CNT),"^",7)=DNDEADAT(8991.9,DNDEAIEN_",",1.4) ; STREET ADDRESS 3
  1. . S $P(RET(CNT),"^",8)=DNDEADAT(8991.9,DNDEAIEN_",",1.5) ; CITY
  1. . S $P(RET(CNT),"^",9)=DNDEADAT(8991.9,DNDEAIEN_",",1.6) ; STATE
  1. . S $P(RET(CNT),"^",10)=DNDEADAT(8991.9,DNDEAIEN_",",1.7) ; ZIP CODE
  1. .; S $P(RET(CNT),"^",11)=DNDEADAT(8991.9,DNDEAIEN_",",.03) ; DETOX NUMBER
  1. . S $P(RET(CNT),"^",11)=DETPRO ; DETOX NUMBER
  1. . S $P(RET(CNT),"^",12)=DNDEADAT(8991.9,DNDEAIEN_",",.04) ; EXPIRATION DATE
  1. . I $$GET1^DIQ(8991.9,DNDEAIEN,.07,"E")="INDIVIDUAL" D
  1. . . S $P(RET(CNT),"^",13)=DNDEADAT(8991.9,DNDEAIEN_",",2.1) ; SCHEDULE II NARCOTIC
  1. . . S $P(RET(CNT),"^",14)=DNDEADAT(8991.9,DNDEAIEN_",",2.2) ; SCHEDULE II NON-NARCOTIC
  1. . . S $P(RET(CNT),"^",15)=DNDEADAT(8991.9,DNDEAIEN_",",2.3) ; SCHEDULE III NARCOTIC
  1. . . S $P(RET(CNT),"^",16)=DNDEADAT(8991.9,DNDEAIEN_",",2.4) ; SCHEDULE III NON-NARCOTIC
  1. . . S $P(RET(CNT),"^",17)=DNDEADAT(8991.9,DNDEAIEN_",",2.5) ; SCHEDULE IV
  1. . . S $P(RET(CNT),"^",18)=DNDEADAT(8991.9,DNDEAIEN_",",2.6) ; SCHEDULE V
  1. . I $$GET1^DIQ(8991.9,DNDEAIEN,.07,"E")'="INDIVIDUAL" D
  1. . . S $P(RET(CNT),"^",13)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.1,"E")) ; SCHEDULE II NARCOTIC
  1. . . S $P(RET(CNT),"^",14)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.2,"E")) ; SCHEDULE II NON-NARCOTIC
  1. . . S $P(RET(CNT),"^",15)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.3,"E")) ; SCHEDULE III NARCOTIC
  1. . . S $P(RET(CNT),"^",16)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.4,"E")) ; SCHEDULE III NON-NARCOTIC
  1. . . S $P(RET(CNT),"^",17)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.5,"E")) ; SCHEDULE IV
  1. . . S $P(RET(CNT),"^",18)=$$UPPER^ORU($$GET1^DIQ(200,NPIEN,55.6,"E")) ; SCHEDULE V
  1. . S $P(RET(CNT),"^",19)=DNDEADAT(8991.9,DNDEAIEN_",",.06) ; USE FOR INPATIENT ORDERS?
  1. . S $P(RET(CNT),"^",20)=FAILOVER ; FAILOVER FLAG
  1. . S $P(RET(CNT),"^",21)=VANUMB ; PROVIDER VA NUMBER
  1. . S $P(RET(CNT),"^",22)=PROVTYPE ; PROVIDER TYPE 3=C & A, 4=FEE BASIS
  1. . ;
  1. . S EX=0
  1. . 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
  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
  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
  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
  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
  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
  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
  1. . I 'EX S INDEX(3,CNT)="",INDEX(0,3)=INDEX(0,3)+1
  1. ;
  1. ; 1 - Provider has a DEA# that is not expired, but not eligible.
  1. I INDEX(0,3)=0,INDEX(0,2)>0 K RET S RET(1)="-1^2^"_SCHEDULE Q
  1. ;
  1. ; 2 - Provider has no DEA# (no active/no DEA# expired within the last year) and has no VA#, return RET(1)="-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
  1. ;
  1. ; 3 - Provider is not a VA Provider
  1. I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)=0,VANUMB'="",PROVTYPE=3 K RET S RET(1)="-1^1" Q
  1. I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)=0,VANUMB'="",PROVTYPE=4 K RET S RET(1)="-1^1" Q
  1. I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)>0,VANUMB'="",PROVTYPE=3 K RET S RET(1)="-1^1" Q
  1. I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)>0,VANUMB'="",PROVTYPE=4 K RET S RET(1)="-1^1" Q
  1. I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)>0,VANUMB="",PROVTYPE=3 K RET S RET(1)="-1^1" Q
  1. I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)>0,VANUMB="",PROVTYPE=4 K RET S RET(1)="-1^1" Q
  1. ;
  1. ; 4 - Provider has no DEA# (no active/no DEA# expired within the last year) and has a VA#, a VA provider
  1. ; (provider type not 3/4) and is eligible ("PS3") to write that schedule cont...
  1. ; this provider then can use the Facility DEA # tied to the clinic provided Facility DEA # is not expired.
  1. ; If above is true then RET(1)="1^Facility-VA# with the address detail)
  1. ; If above is not true, RET(1)="-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
  1. . S CSTATUS=$$CLINIC(.CLINIC,HLIEN,NPIEN,SCHEDULE)
  1. . I CSTATUS=0 S CLINIC="-1^1" Q
  1. . I $P(CLINIC,"^",23)["Expired:" S CLINIC="-1^1" Q
  1. . I $P(CLINIC,"^",23)["NOT VALID" S CLINIC="-1^1" Q
  1. ;
  1. ; 5 - Provider has no DEA# (no active) but has an expired DEA# within the last year and FAILOVER is set to "Yes"
  1. ; and has a VA#, a VA provider (provider type not 3/4) and is eligible ("PS3") to write that schedule
  1. ; this provider then can use the Facility DEA # tied to the clinic provided Facility DEA # is not expired.
  1. ; If above is true then RET(+1)="1^Facility-VA# with the address detail)
  1. ; If above is not true, RET(1)="-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
  1. . S CSTATUS=$$CLINIC(.CLINIC,HLIEN,NPIEN,SCHEDULE)
  1. . I '$D(CLINIC) S CLINIC="-1^1" Q
  1. . I $P(CLINIC,"^",23)["Expired:" S CLINIC="-1^1" Q
  1. . I $P(CLINIC,"^",23)["NOT VALID" S CLINIC="-1^1" Q
  1. . I $D(CLINIC) S CNT=CNT+1,INDEX(3,CNT)="",INDEX(0,3)=INDEX(0,3)+1,RET(CNT)=CLINIC
  1. ;
  1. ; 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"
  1. ; then RET(1)="-1^7"
  1. I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)>0,VANUMB="",FAILOVER=0 K RET S RET(1)="-1^7" Q
  1. ;
  1. ; 7 - Provider has a VA# but has an expired DEA# within the last year and FAILOVER is set to "No"
  1. ; then RET(1)="-1^7"
  1. I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)>0,VANUMB'="",FAILOVER=0 K RET S RET(1)="-1^7" Q
  1. ;
  1. ; 8 - Provider has an expired DEA# within the last year, no VA# and FAILOVER is set to "Yes"
  1. ; then RET(1)="-1^7"
  1. I INDEX(0,3)=0,INDEX(0,2)=0,INDEX(0,1)>0,VANUMB="",FAILOVER=1 K RET S RET(1)="-1^7" Q
  1. ;
  1. ; RETURN THE FULL DEFAULT LIST
  1. K ORTMP M ORTMP=RET K RET S CNT=0
  1. S ORTMPX=0 F S ORTMPX=$O(INDEX(ORTMPX)) Q:'ORTMPX D
  1. . S ORTMPY=0 F S ORTMPY=$O(INDEX(ORTMPX,ORTMPY)) Q:'ORTMPY D
  1. .. S CNT=CNT+1,RET(CNT)=ORTMP(ORTMPY)
  1. ;
  1. Q
  1. ;
  1. 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
  1. ; DIVISION = DIVISION FIELD #3.5 POINTER TO MEDICAL CENTER DIVISION FILE (#40.8)
  1. ; FACDEA = INSTITUTION FILE #4, FACILITY DEA NUMBER FIELD #52
  1. N INSTITUT,DIVISION,FACDEA,FACDEAEX,NPDAT,PROVVAN
  1. Q:'$G(HLIEN) 0
  1. S DIVISION=$$GET1^DIQ(44,HLIEN,3.5,"I") Q:'DIVISION 0
  1. S INSTITUT=$$GET1^DIQ(40.8,DIVISION,.07,"I") Q:'INSTITUT 0
  1. S FACDEA=$$GET1^DIQ(4,INSTITUT,52) Q:FACDEA="" 0
  1. S RET=""
  1. S FACDEAEX=$$GET1^DIQ(4,INSTITUT,52.1,"I") ; FACILITY DEA EXPIRATION DATE INTERNAL
  1. I $$FMDIFF^XLFDT(DT,FACDEAEX,1)>365 Q 0 ; IGNORE OLD DEA NUMBERS
  1. S $P(RET,"^",1)=1 ; VALID FOR USE
  1. S $P(RET,"^",2)=FACDEA ; FACILITY DEA NUMBER
  1. S $P(RET,"^",3)=$$GET1^DIQ(200,NPIEN,53.3) ; PROVIDER VA NUMBER as SUFFIX
  1. S $P(RET,"^",4)="INSTITUTIONAL" ; DN DEA TYPE - INSTITUTIONAL
  1. S $P(RET,"^",5)=$$GET1^DIQ(4,INSTITUT,1.01) ; FACILITY STREET ADDRESS 1
  1. S $P(RET,"^",6)=$$GET1^DIQ(4,INSTITUT,1.02) ; FACILITY STREET ADDRESS 2
  1. S $P(RET,"^",7)="" ; FACILITY STREET ADDRESS 3 - N/A
  1. S $P(RET,"^",8)=$$GET1^DIQ(4,INSTITUT,1.03) ; FACILITY CITY
  1. S $P(RET,"^",9)=$$GET1^DIQ(4,INSTITUT,.02) ; FACILITY STATE
  1. S $P(RET,"^",10)=$$GET1^DIQ(4,INSTITUT,1.04) ; FACILITY ZIP CODE
  1. ;S $P(RET,"^",11)=$$GET1^DIQ(200,NPIEN,9001) ; DETOX NUMBER
  1. S $P(RET,"^",11)=DETPRO ; DETOX NUMBER
  1. S $P(RET,"^",12)=$$GET1^DIQ(4,INSTITUT,52.1) ; FACILITY DEA EXPIRATION DATE
  1. S $P(RET,"^",13)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.1)) ; SCHEDULE II NARCOTIC
  1. S $P(RET,"^",14)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.2)) ; SCHEDULE II NON-NARCOTIC
  1. S $P(RET,"^",15)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.3)) ; SCHEDULE III NARCOTIC
  1. S $P(RET,"^",16)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.4)) ; SCHEDULE III NON-NARCOTIC
  1. S $P(RET,"^",17)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.5)) ; SCHEDULE IV
  1. S $P(RET,"^",18)=$$UP^XLFSTR($$GET1^DIQ(200,NPIEN,55.6)) ; SCHEDULE V
  1. S $P(RET,"^",19)="" ; USE FOR INPATIENT ORDERS? - N/A
  1. S $P(RET,"^",20)=$$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I") ; FAILOVER FLAG
  1. S $P(RET,"^",21)=$$GET1^DIQ(200,NPIEN,53.3) ; PROVIDER VA NUMBER
  1. S $P(RET,"^",22)=$$GET1^DIQ(200,NPIEN,53.6,"I") ; PROVIDER TYPE 3=C & A, 4=FEE BASIS
  1. ;
  1. I FACDEAEX<DT S $P(RET,"^",2)="* "_$P(RET,"^",2),$P(RET,"^",1)=0,$P(RET,"^",23)="Expired: "_$P(RET,"^",12) G CLINICQ
  1. 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
  1. 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
  1. 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
  1. 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
  1. 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
  1. 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
  1. ;
  1. CLINICQ ; FUNCTION END POINT
  1. Q $P(RET,"^",1)
  1. ;
  1. DOIIEN(DOIIEN) ; -- DOJ DRUG SCHEDULE CALCULATOR WITH ORDER ITEM IEN INPUT
  1. Q:'$G(DOIIEN) ""
  1. N SCHEDULE,VALID,TPKG,PSOI
  1. S (VALID("2"),VALID("2n"),VALID("3"),VALID("3n"),VALID("4"),VALID("5"))=""
  1. S TPKG=$P($G(^ORD(101.43,DOIIEN,0)),U,2) Q:TPKG'["PS" ""
  1. S PSOI=+TPKG Q:'PSOI ""
  1. S SCHEDULE=$P($$OIDEA^PSSOPKI(PSOI,"I"),";",2) Q:'+SCHEDULE ""
  1. Q:'$D(VALID(SCHEDULE)) ""
  1. Q SCHEDULE
  1. ;
  1. ZIP(RETURN,OI,PSTYPE,DFN) ; -- zip code required to prescribe cs orders
  1. ; OI = ORDERABLE ITEMS (#101.43) pointer
  1. ; PSTYPE = APPLICATION CODE - O=Outpatient Pharmacy, I=IV, U=Unit Dose
  1. ; DFN = Patient IEN
  1. N VAPA,TPKG,PSOI,DEAFLG,DPKG
  1. S RETURN=1,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2)
  1. Q:TPKG'["PS"
  1. S PSOI=+TPKG Q:PSOI'>0
  1. S DEAFLG=$P($$OIDEA^PSSOPKI(PSOI,PSTYPE),";",2)
  1. I '+$G(DEAFLG) Q
  1. D ADD^VADPT
  1. I $$USA^ORWDPS11(DFN),'(VAPA(11)!VAPA(6)),$$GET^XPAR("SYS","OR ZIP CODE SWITCH") D Q
  1. . S RETURN="0^Controlled substance prescriptions require a patient address. "
  1. . S RETURN=RETURN_$$GET^XPAR("ALL","OR ZIP CODE MESSAGE",1)
  1. S RETURN="1^"_+DEAFLG_$S($E(DEAFLG,2)="n":"^n",1:"")
  1. Q
  1. ;
  1. ZIPM ; - zip code parameter message
  1. D EDITPAR^XPAREDIT("OR ZIP CODE MESSAGE")
  1. Q
  1. ;
  1. VALDEA(FAIL,OI,ORNP,PSTYPE,ORID) ; - return 1 if DEA check fails for this provider
  1. N DEAFLG,PSOI,TPKG,RT,DETFLAG,DETPRO,ORSLDEA,Y
  1. S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2)
  1. Q:'$G(ORID)
  1. S ORSLDEA=$P($G(^OR(100,ORID,11.1)),U)
  1. Q:ORSLDEA=""
  1. Q:TPKG'["PS"
  1. S PSOI=+TPKG Q:PSOI'>0
  1. S DETFLAG=$$OIDETOX^PSSOPKI(PSOI,PSTYPE)
  1. S DETPRO=$$DETOX^XUSER(+$G(ORNP))
  1. I DETFLAG,DETPRO="" S FAIL=3 Q
  1. I DETFLAG,DETPRO>0 S Y=DETPRO X ^DD("DD") S FAIL="5^"_Y Q
  1. S DEAFLG=$P($$OIDEA^PSSOPKI(PSOI,PSTYPE),";",2) Q:DEAFLG'>0
  1. I DEAFLG=1 S FAIL=6 Q
  1. S RT=$$SDEA^XUSER(,+$G(ORNP),DEAFLG,ORSLDEA,"I") ; Default to the required "Use For Inpatient" DEA# until selection from list is enabled
  1. I RT=1 S FAIL=1 Q
  1. I RT=2 S FAIL="2^"_$$UP^XLFSTR(DEAFLG) Q
  1. I RT?1"4".E S FAIL=RT
  1. Q
  1. ;
  1. USA(DFN) ; Does patient address contan a U.S. address based on Country or State?
  1. ; Input: DFN - Patient Identifier from PATIENT file (#2)
  1. ; Output: 0 - Address is not U.S.
  1. ; 1 - Address is U.S.
  1. ; -1 - Address could not be determined to be U.S.
  1. ;
  1. N COUNTRY,STATE,STATEAR,STATEIENS,VAPA
  1. Q:'$G(DFN) 0
  1. Q:'$L($G(^DPT(+DFN,0))) 0
  1. D ADD^VADPT
  1. S COUNTRY=$S($G(VAPA(25)):$P(VAPA(25),U,2),$G(VAPA(37)):$P(VAPA(37),U,2),1:"")
  1. I $L(COUNTRY) Q $S(COUNTRY="UNITED STATES":1,1:0)
  1. S STATE=$S($G(VAPA(5)):$P(VAPA(5),U),$G(VAPA(34)):$P(VAPA(34),U),1:"")
  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)
  1. Q -1