PSODEAUT ;ALB/BI - DEA MANUAL ENTRY ;05/15/2018
;;7.0;OUTPATIENT PHARMACY;**529,684,731**;DEC 1997;Build 18
;External reference to sub-file NEW DEA #S (#200.5321) is supported by DBIA 7000
;External reference to DEA BUSINESS ACTIVITY CODES file (#8991.8) is supported by DBIA 7001
;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
;External reference to DEA NUMBERS file (#8991.6) is supported by DBIA 7015
Q
;
DEALIST(RET,NPIEN) ; -- RPC to return a List of DEA numbers and information for a single provider.
; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
;
; OUTPUT: RET - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
; 1 - DEA NUMBER
; 2 - INDIVIDUAL DEA SUFFIX
; 3 - STATE
; 4 - DETOX NUMBER
; 5 - EXPIRATION DATE: FROM THE DEA NUMBERS FILE (#8991.9), FIELD EXPIRATION DATE (#.04)
; 6 - NPIENS
; 7 - DNIENS
; 8 - SCHEDULE II NARCOTIC
; 9 - SCHEDULE II NON-NARCOTIC
; 10 - SCHEDULE III NARCOTIC
; 11 - SCHEDULE III NON-NARCOTIC
; 12 - SCHEDULE IV
; 13 - SCHEDULE V
; 14 - USE FOR INPATIENT ORDERS?
;
Q:'$G(NPIEN)
N CNT,DNDEADAT,DNDEAIEN,FAIL,IENS,NPDEADAT,NPDEAIEN
S NPDEAIEN=0 F CNT=1:1 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)
. S DNDEAIEN=$$GET1^DIQ(200.5321,IENS,.03,"I") Q:'DNDEAIEN
. K DNDEADAT D GETS^DIQ(8991.9,DNDEAIEN,"**","","DNDEADAT") Q:'$D(DNDEADAT)
. ;
. S RET(CNT)=""
. S RET(CNT)=RET(CNT)_NPDEADAT(200.5321,IENS,.01)_"^" ; NEW PERSON DEA NUMBER
. S RET(CNT)=RET(CNT)_NPDEADAT(200.5321,IENS,.02)_"^" ; INDIVIDUAL DEA SUFFIX
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.6)_"^" ; STATE
. S RET(CNT)=RET(CNT)_""_"^" ; DETOX NUMBER ;P731 detox/x-waiver removal
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",.04)_"^" ; EXPIRATION DATE
. S RET(CNT)=RET(CNT)_IENS_"^" ; NEW PERSON IENS
. S RET(CNT)=RET(CNT)_DNDEAIEN_"^" ; DEA NUMBERS IEN
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.1)_"^" ; SCHEDULE II NARCOTIC
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.2)_"^" ; SCHEDULE II NON-NARCOTIC
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.3)_"^" ; SCHEDULE III NARCOTIC
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.4)_"^" ; SCHEDULE III NON-NARCOTIC
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.5)_"^" ; SCHEDULE IV
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.6)_"^" ; SCHEDULE V
. S RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",.06) ; USE FOR INPATIENT ORDERS?
Q
;
DEADOJ(RET,DEA) ; -- RPC to return DEA Information for a single DEA Number
; INPUT: DEA - PROPERLY FORMATTED DEA NUMBER
;
; OUTPUT: RET - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
; 1 - PROVIDER NAME
; 2 - ADDITIONAL COMPANY INFO
; 3 - ADDRESS 1
; 4 - ADDRESS 2
; 5 - CITY
; 6 - STATE
; 7 - STATE POINTER
; 8 - ZIP CODE
; 9 - ACTIVITY CODE
; 10 - TYPE
; 11 - DEA NUMBER
; 12 - EXPIRATION DATE
; 13 - PROCESSED DATE
; 14 - DETOX NUMBER
; 15 - SCHDEULE II NARCOTIC
; 16 - SCHEDULE II NON-NARCOTIC
; 17 - SCHEDULE III NARCOTIC
; 18 - SCHEDULE III NON-NARCOTIC
; 19 - SCHEDULE IV
; 20 - SCHEDULE V
;
N FG,NAME,NPIEN,VALUE,DS,BAC,SC
I $G(DEA)="" S RET(0)="0^INVALID DEA NUMBER" Q
I '$$DEANUMFL(DEA) S RET(0)="0^Invalid DEA Number due to error in first letter" Q
I '$$DEANUM(DEA) S RET(0)="0^Invalid DEA Number due to error in the numbers" Q
S SC=$$WSGET(.FG,DEA)
I $P($P(SC,"^",2),".",1)="DEA NUMBER NOT FOUND" S RET(0)="0^DEA NUMBER NOT FOUND. Please enter the provider's DEA number." Q
I 'SC S RET(0)="0^WEB SERVICE FAILURE" Q
;
S RET(1)=""
S RET(1)=RET(1)_$G(FG("name"))_"^" ; PROVIDER NAME
S RET(1)=RET(1)_$G(FG("additionalCompanyInfo"))_"^" ; ADDITIONAL COMPANY INFO
S RET(1)=RET(1)_$G(FG("address1"))_"^" ; ADDRESS 1
S RET(1)=RET(1)_$G(FG("address2"))_"^" ; ADDRESS 2
S RET(1)=RET(1)_$G(FG("city"))_"^" ; CITY
;
; Special State Processing
S RET(1)=RET(1)_$G(FG("state"))_"^" ; STATE
N XSTATE,XIP D POSTAL^XIPUTIL($G(FG("zipCode")),.XIP) S XSTATE=$G(XIP("STATE"))
S RET(1)=RET(1)_$G(XSTATE)_"^" ; STATE POINTER
;
S RET(1)=RET(1)_$G(FG("zipCode"))_"^" ; ZIP CODE
S BAC=$G(FG("businessActivityCode"))_$G(FG("businessActivitySubcode"))
S RET(1)=RET(1)_BAC_"^" ; ACTIVITY CODE
S RET(1)=RET(1)_$P($$PROVTYPE($G(FG("businessActivityCode"))),"^",2)_"^" ; TYPE
S RET(1)=RET(1)_$G(FG("deaNumber"))_"^" ; DEA NUMBER
S RET(1)=RET(1)_$G(FG("expirationDate"))_"^" ; EXPIRATION DATE
S RET(1)=RET(1)_$G(FG("processedDate"))_"^" ; PROCESSED DATE
;
S DS=$G(FG("drugSchedule"))
S NPIEN=$O(^VA(200,"PS4",DEA,0))
S RET(1)=RET(1)_$S($$DETOXCHK^PSODEAUT(BAC):"X"_$E(FG("deaNumber"),2,9),1:"")_"^" ; DETOX NUMBER
S RET(1)=RET(1)_$S(DS["22N":"YES",(DS["2"&(DS'["2N")):"YES",1:"NO")_"^" ; SCHEDULE II NARCOTIC
S RET(1)=RET(1)_$S(DS["2N":"YES",1:"NO")_"^" ; SCHEDULE II NON-NARCOTIC
S RET(1)=RET(1)_$S(DS["33N":"YES",DS["3"&(DS'["3N"):"YES",1:"NO")_"^" ; SCHEDULE III NARCOTIC
S RET(1)=RET(1)_$S(DS["3N":"YES",1:"NO")_"^" ; SCHEDULE III NON-NARCOTIC
S RET(1)=RET(1)_$S(DS["4":"YES",1:"NO")_"^" ; SCHEDULE IV
S RET(1)=RET(1)_$S(DS["5":"YES",1:"NO") ; SCHEDULE V
S RET(0)="1^SUCCESS"
Q
;
DEAREM(RET,NPIEN,DEATXT) ; Functionality to remove a DEA multiple from file #200, Field 53.21
; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
; DEATXT - PROPERLY FORMATTED DEA NUMBER
; OUTPUT: RET - 1 for SUCCESS, 0 for UNSUCCESSFUL
N FDA,IENS,MSGROOT,NPDEAIEN,DNDEAIEN,DEATYPE,DA,DIE,DR
S RET=0 Q:'$G(NPIEN) Q:$G(DEATXT)=""
S NPDEAIEN=$O(^VA(200,NPIEN,"PS4","B",DEATXT,0)) I 'NPDEAIEN Q
S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
S DEATYPE=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")
S FDA(1,200.5321,NPDEAIEN_","_NPIEN_",",.01)="@"
S FDA(2,8991.9,DNDEAIEN_",",.01)="@"
D UPDATE^DIE(,"FDA(1)",,"MSGROOT") Q:$D(MSGROOT)
I DNDEAIEN,DEATYPE=2 D UPDATE^DIE(,"FDA(2)",,"MSGROOT") Q:$D(MSGROOT)
S RET=1
Q
;
VIEWFM(RET,DEA) ; -- Request for DEA Information stored in DEA NUMBERS FILE #8991.9, Return DEA Information in RET
N DEAIEN,GETSTMP
I $G(DEA)="" S RET(0)="0^INVALID DEA NUMBER" Q
S DEAIEN=$O(^XTV(8991.9,"B",DEA,0)) I 'DEAIEN S RET(0)="0^DEA NUMBER NOT FOUND" Q
D GETS^DIQ(8991.9,DEAIEN,"**","R","GETSTMP")
I '$D(GETSTMP) S RET(0)="0^NO DATA FOUND" Q
S RET(0)="1^SUCCESS"
S CNT=0,NAME="" F S NAME=$O(GETSTMP(8991.9,DEAIEN_",",NAME)) Q:NAME="" D
. S CNT=CNT+1,RET(CNT)=NAME_"^"_GETSTMP(8991.9,DEAIEN_",",NAME)
Q
;
FILEWS(RET,ARRAY) ; -- File DEA Information in ARRAY, Return the IEN Number from DEA NUMBERS FILE #8991.9
N FG,NAME,VALUE,CNT
F CNT=1:1:$O(ARRAY(""),-1) S FG($P(ARRAY(CNT),"^",1))=$P(ARRAY(CNT),"^",2)
I $G(FG("deaNumber"))="" S RET(0)="0^INVALID DEA NUMBER" Q
I '$$DEANUMFL(FG("deaNumber")) S RET(0)="0^Invalid DEA Number due to error in first letter" Q
I '$$DEANUM(FG("deaNumber")) S RET(0)="0^Invalid DEA Number due to error in the numbers" Q
S RET=$$DEACOPY^PSODEAUT(.FG)
Q
;
DEACOPY(FG) ; -- Private Subroutine to Copy import data in the GETS Array
; POSTAL^XIPUTL used in agreement with Integration Agreement: 3618
;
; INPUT: FG ;Web Service Response Global
;
; VARIABLES:
N DS ;Single drug schedule field as sent from the VA DOJ Web Service.
N XIP ;Used to calculate the state from a zip code.
N XSTATE ;Used to calculate the state from a zip code.
N BAC ;Business Activity Code
N DTRESULT
;
S DS=$G(FG("drugSchedule"))
S GETS(.01)=$G(FG("deaNumber"))
S BAC=$G(FG("businessActivityCode"))_$G(FG("businessActivitySubcode"))
S GETS(.02)=BAC ; Pointer to file #8991.8
S GETS(.03)=$S($$GETDNDTX^PSODEAUT(NPIEN)'="":"",$$DETOXCHK^PSODEAUT(BAC):"X"_$E($G(FG("deaNumber")),2,9),1:"") ; DETOX NUMBER
D DT^DILF("E",$G(FG("expirationDate")),.DTRESULT)
S GETS(.04)=$G(DTRESULT(0))
S GETS(.07)=$G(FG("type"))
S GETS(1.1)=$G(FG("name"))
S GETS(1.2)=$G(FG("additionalCompanyInfo"))
S GETS(1.3)=$G(FG("address1"))
S GETS(1.4)=$G(FG("address2"))
S GETS(1.5)=$G(FG("city"))
;
; Special State Processing
S GETS(1.6)=$G(FG("state"))
D POSTAL^XIPUTIL($G(FG("zipCode")),.XIP)
S XSTATE=$G(XIP("STATE"))
I XSTATE'="" S GETS(1.6)=XSTATE ; Pointer to the State File #5.
;
S GETS(1.7)=$G(FG("zipCode"))
;
S GETS(2.1)=$S(DS["22N":"YES",(DS["2"&(DS'["2N")):"YES",1:"NO") ; SCHEDULE II NARCOTIC
S GETS(2.2)=$S(DS["2N":"YES",1:"NO") ; SCHEDULE II NON-NARCOTIC
S GETS(2.3)=$S(DS["33N":"YES",(DS["3"&(DS'["3N")):"YES",1:"NO") ; SCHEDULE III NARCOTIC
S GETS(2.4)=$S(DS["3N":"YES",1:"NO") ; SCHEDULE III NON-NARCOTIC
S GETS(2.5)=$S(DS["4":"YES",1:"NO") ; SCHEDULE IV
S GETS(2.6)=$S(DS["5":"YES",1:"NO") ; SCHEDULE V
;
D DT^DILF("E",%DT,.DTRESULT)
S GETS(10.2)=$G(DTRESULT(0)) ; LAST UPDATED DATE/TIME
D DT^DILF("E",$G(FG("processedDate")),.DTRESULT)
S GETS(10.3)=$G(DTRESULT(0)) ; LAST DOJ UPDATE DATE/TIME
S GETS(10.1)=DUZ
Q
;
FILEFM(RET,DATA,NPIEN) ; -- File DEA Information in the DEA NUMBERS FILE #8991.9
N DNDEAIEN,DNDEATXT,FDA,IENROOT,IENS,MSGROOT,SUFFIX,XSTATE,XIP
S RET=0
I '$D(DATA) S RET=0 G FILEFMX
;
S DNDEATXT=$P(DATA,U,11) I DNDEATXT="" G FILEFMX
S DNDEAIEN=$O(^XTV(8991.9,"B",DNDEATXT,0))
S IENS=$S($G(DNDEAIEN):$G(DNDEAIEN)_",",1:"+1,")
;
; INPUT: DATA - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
S FDA(1,8991.9,IENS,1.1)=$P(DATA,U,1) ; 1 - PROVIDER NAME
S FDA(1,8991.9,IENS,1.2)=$P(DATA,U,2) ; 2 - ADDITIONAL COMPANY INFO
S FDA(1,8991.9,IENS,1.3)=$P(DATA,U,3) ; 3 - ADDRESS 1
S FDA(1,8991.9,IENS,1.4)=$P(DATA,U,4) ; 4 - ADDRESS 2
S FDA(1,8991.9,IENS,1.5)=$P(DATA,U,5) ; 5 - CITY
;
; Special State Processing
D POSTAL^XIPUTIL($P(DATA,U,8),.XIP)
S XSTATE=$G(XIP("STATE"))
I XSTATE'="" S FDA(1,8991.9,IENS,1.6)=XSTATE ; 6 - STATE
;
S FDA(1,8991.9,IENS,1.7)=$P(DATA,U,8) ; 8 - ZIP CODE
S FDA(1,8991.9,IENS,.02)=$P(DATA,U,9) ; 9 - ACTIVITY CODE
S FDA(1,8991.9,IENS,.07)=$P(DATA,U,10) ; 10 - TYPE
S FDA(1,8991.9,IENS,.01)=$P(DATA,U,11) ; 11 - DEA NUMBER
S FDA(1,8991.9,IENS,.04)=$P(DATA,U,12) ; 12 - EXPIRATION DATE
S FDA(1,8991.9,IENS,10.2)="N" ; 13 - PROCESSED DATE
I $$DEANUM($P(DATA,U,14)) D ; ONLY CLEAR AND SET IF VALIDATED
. I $P(DATA,U,14)'="" D CLEARDTX(NPIEN) ; REMOVE DETOX NUMBERS FROM OTHER DEA NUMBERS
. S FDA(1,8991.9,IENS,.03)=$P(DATA,U,14) ; 14 - DETOX NUMBER
S FDA(1,8991.9,IENS,2.1)=$P(DATA,U,15) ; 15 - SCHDEULE II NARCOTIC
S FDA(1,8991.9,IENS,2.2)=$P(DATA,U,16) ; 16 - SCHEDULE II NON-NARCOTIC
S FDA(1,8991.9,IENS,2.3)=$P(DATA,U,17) ; 17 - SCHEDULE III NARCOTIC
S FDA(1,8991.9,IENS,2.4)=$P(DATA,U,18) ; 18 - SCHEDULE III NON-NARCOTIC
S FDA(1,8991.9,IENS,2.5)=$P(DATA,U,19) ; 19 - SCHEDULE IV
S FDA(1,8991.9,IENS,2.6)=$P(DATA,U,20) ; 20 - SCHEDULE V
S FDA(1,8991.9,IENS,.06)=$P(DATA,U,21) ; 21 - USE FOR INPATIENT FLAG
S SUFFIX=$P(DATA,U,22) ; 22 - DEA INSTITUTIONAL SUFFIX
;
D UPDATE^DIE("E","FDA(1)","IENROOT","MSGROOT")
I $D(MSGROOT) S RET="0^DATA DIDN'T FILE SUCCESSFULLY." G FILEFMX
S DNDEAIEN=$S($D(IENROOT(1)):IENROOT(1)_",",1:IENS)
I '+DNDEAIEN S RET="0^DATA DIDN'T FILE SUCCESSFULLY." G FILEFMX
S FDA(2,8991.9,DNDEAIEN,10.1)=$G(DUZ) D FILE^DIE("","FDA(2)","MSGROOT")
S:DNDEAIEN RET=+DNDEAIEN_"^SUCCESSFULLY SAVED/UPDATED IN 8991.9"
I $L(DNDEATXT),$G(NPIEN),$G(DNDEAIEN) S RET=RET_"^"_$$NPFILE(DNDEATXT,NPIEN,DNDEAIEN,SUFFIX)
I RET,$P(DATA,U,21)="YES" S FDA(200,NPIEN_",",53.2)=$P(DATA,U,11) D UPDATE^DIE(,"FDA")
FILEFMX ; -- Subroutine Exit Point
Q
;
NPFILE(DNDEATXT,NPIEN,DNDEAIEN,SUFFIX) ; -- File the DEA NUMBER in the NEW PERSON FILE #200.
N FDA,IEN,IENROOT,MSGROOT
Q:'$G(NPIEN) Q:'$G(DNDEAIEN)
S IEN="+1,"
I $D(^VA(200,NPIEN,"PS4","B",DNDEATXT)) S IEN=$O(^VA(200,NPIEN,"PS4","B",DNDEATXT,0))_","
S FDA(1,200.5321,IEN_NPIEN_",",.01)=DNDEATXT
S FDA(1,200.5321,IEN_NPIEN_",",.02)=SUFFIX
S FDA(1,200.5321,IEN_NPIEN_",",.03)=+DNDEAIEN
D UPDATE^DIE("","FDA(1)","IENROOT","MSGROOT")
I $D(MSGROOT) Q "0^DATA DIDN'T FILE SUCCESSFULLY."
Q "1^SUCCESSFULLY SAVED/UPDATED IN 200"
;
PROVTYPE(BA) ; -- Calculate the Provider Type from the Business Activity Code.
N RESULT S RESULT="1^INSTITUTIONAL"
S:$G(BA)="" RESULT="2^INDIVIDUAL"
S:$E(BA)="C" RESULT="2^INDIVIDUAL"
S:$E(BA)="M" RESULT="2^INDIVIDUAL"
Q RESULT
;
CONVNAME(CN) ; -- Set up a NAME conversion array.
S CN("additionalCompanyInfo")="COMPANY INFO"
S CN("address1")="ADDRESS 1"
S CN("address2")="ADDRESS 2"
S CN("businessActivityCode")="ACTIVITY CODE"
S CN("businessActivitySubcode")="ACTIVITY SUB"
S CN("city")="CITY"
S CN("deaNumber")="DEA NUMBER"
S CN("drugSchedule")="DRUG SCHEDULE"
S CN("expirationDate")="EXPIRATION DATE"
S CN("name")="NAME"
S CN("processedDate")="PROCESSED DATE"
S CN("state")="STATE"
S CN("type")="TYPE"
S CN("zipCode")="ZIP CODE"
Q
;
GETS(DEAIEN,GETS) ; -- Get the existing data from the DEA NUMBERS FILE #8991.9
N GETSTMP
D GETS^DIQ(8991.9,DEAIEN,"**","","GETSTMP")
M GETS=GETSTMP(8991.9,DEAIEN_",")
Q
;
DEANUM(X) ; -- Check DEA # part
N VA1,VA2
S VA1=$E(X,3)+$E(X,5)+$E(X,7)+(2*($E(X,4)+$E(X,6)+$E(X,8)))
S VA1=VA1#10,VA2=$E(X,9)
Q VA1=VA2
;
DEANUMFL(X) ;Check DEA # First Letter Part
Q $S("ABCDEFGHIJKLMNOPQRSTUVWXYZ"[$E(X):1,1:0)
;
DUPCHK(RET,DEATXT,SUFFIX) ; -- Check for duplicate DEA number or duplicate SUFFIX usage.
; INPUTS: DEATXT - The text format of a DEA Number
; SUFFIX - The DEA suffix for an Institutional DEA number
I $G(DEATXT)="" S RET="0^No DEA number supplied" Q
S SUFFIX=$G(SUFFIX)
S RET="1^Success"
I SUFFIX="",$D(^VA(200,"PS4",DEATXT)) S RET="0^Provider DEA number is already associated to another profile. Please check the number entered." Q
I SUFFIX'="",$D(^VA(200,"F",DEATXT,SUFFIX)) S RET="0^Duplicate Usage of a SUFFIX" Q
Q
;
DETOXCHK(BAC) ; -- Test Business Activity Code for DEXTOX (DW)
Q 0 ;P731 detox/x-waiver removal
N BACIEN
I $G(BAC)="" Q 0
I '$D(^XTV(8991.8,"B",BAC)) Q 0
S BACIEN=$O(^XTV(8991.8,"B",BAC,0)) I 'BACIEN Q 0
I $$GET1^DIQ(8991.8,BACIEN,1)["DW/" Q 1
Q 0
;
DETOXDUP(DEA,DETOX,DUPDEA) ; -- Check for duplicate Detox number
Q "" ;P731 detox/x-waiver removal
N I,NXTDET S NXTDEA=0,DUPDEA=""
I $G(DETOX)=""!($G(DEA)="") Q 0 ; Missing required input, can't check
I '$D(^XTV(8991.9,"D",$G(DETOX))) Q 0 ; If Detox not on file, not a duplicate
I $D(^XTV(8991.9,"D",$G(DETOX))),'$D(^XTV(8991.9,"D",$G(DETOX),$G(DEA))) D Q 1 ; On file for another prescriber, duplicate
.S DUPDEA=$O(^XTV(8991.9,"D",$G(DETOX),$G(DUPDEA)))
F S NXTDEA=$O(^XTV(8991.9,"D",DETOX,NXTDEA)) Q:NXTDEA="" S DUPDEA=$S($G(DUPDEA)'="":DUPDEA_","_NXTDEA,1:NXTDEA)
I $G(DUPDEA)'="" Q 1 ; If more than one entry on file for this Detox number, duplicate
Q 0
;
MBM(RET) ; -- MEDS BY MAIL for ePCS GUI
N SYS
S RET=0
S SYS=$$GET^XPAR("SYS^PKG","PSO VAMC MBM PHARMACY MODE",1,"E")
I SYS="MBM" S RET=1
Q
;
ENTRY(RESULT,INPUT) ; -- remoteprocedure
NEW I,NOW
SET NOW=$P($$HTE^XLFDT($H),":",1,2)
FOR I=-1:0 SET I=$O(INPUT(I)) QUIT:I="" DO RECORD(INPUT(I),NOW)
SET RESULT=1
QUIT
;
RECORD(LINE,NOW) ;
N FDA,VALUE,IEN,MSG,I
FOR I=1:1:5 SET VALUE=$P(LINE,U,I),FDA(8991.6,"+1,",(I/100))=VALUE
SET FDA(8991.6,"+1,",.06)=NOW
DO UPDATE^DIE("E","FDA","IEN","MSG")
QUIT
;
CLEARDTX(NPIEN) ; REMOVE DETOX NUMBERS FROM ALL OF A PROVIDERS DEA NUMBERS
N DNDEAIEN,FDA,NPDEAIEN
S NPDEAIEN=0 F S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN D
. S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
. K FDA S FDA(1,8991.9,DNDEAIEN_",",.03)="@" D UPDATE^DIE("","FDA(1)") K FDA
Q
;
GETDNDTX(NPIEN,DNDEAX) ; GET A SINGLE DETOX NUMBER FROM ALL OF A PROVIDERS DEA NUMBERS IN 8991.9
Q "" ;P731 detox/x-waiver removal
N GETDNDTX,DNDEAIEN,NPDEAIEN S GETDNDTX=""
K DNDEAX
S NPDEAIEN=0 F S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN Q:$L(GETDNDTX) D
. S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I") Q:'DNDEAIEN
. S GETDNDTX=$$GET1^DIQ(8991.9,DNDEAIEN_",",.03)
. S DNDEAX=$$GET1^DIQ(8991.9,DNDEAIEN_",",.01)
Q GETDNDTX
;
WSGET(FG,DEA) ; Function to Get the Remote DEA information, Return in FG.
; INPUT: DEA ;Properly formatted DEA Number for lookup.
;
; OUTPUT: FG ;Web Service Response Global
;
; RETURN: Status code with a text message.
; If not filled successfully a "0^Error Message" will be returned.
;
Q $$WSGET^PSODEAU0(.FG,DEA)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODEAUT 17585 printed Apr 09, 2024@21:31:11 Page 2
PSODEAUT ;ALB/BI - DEA MANUAL ENTRY ;05/15/2018
+1 ;;7.0;OUTPATIENT PHARMACY;**529,684,731**;DEC 1997;Build 18
+2 ;External reference to sub-file NEW DEA #S (#200.5321) is supported by DBIA 7000
+3 ;External reference to DEA BUSINESS ACTIVITY CODES file (#8991.8) is supported by DBIA 7001
+4 ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
+5 ;External reference to DEA NUMBERS file (#8991.6) is supported by DBIA 7015
+6 QUIT
+7 ;
DEALIST(RET,NPIEN) ; -- RPC to return a List of DEA numbers and information for a single provider.
+1 ; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
+2 ;
+3 ; OUTPUT: RET - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
+4 ; 1 - DEA NUMBER
+5 ; 2 - INDIVIDUAL DEA SUFFIX
+6 ; 3 - STATE
+7 ; 4 - DETOX NUMBER
+8 ; 5 - EXPIRATION DATE: FROM THE DEA NUMBERS FILE (#8991.9), FIELD EXPIRATION DATE (#.04)
+9 ; 6 - NPIENS
+10 ; 7 - DNIENS
+11 ; 8 - SCHEDULE II NARCOTIC
+12 ; 9 - SCHEDULE II NON-NARCOTIC
+13 ; 10 - SCHEDULE III NARCOTIC
+14 ; 11 - SCHEDULE III NON-NARCOTIC
+15 ; 12 - SCHEDULE IV
+16 ; 13 - SCHEDULE V
+17 ; 14 - USE FOR INPATIENT ORDERS?
+18 ;
+19 if '$GET(NPIEN)
QUIT
+20 NEW CNT,DNDEADAT,DNDEAIEN,FAIL,IENS,NPDEADAT,NPDEAIEN
+21 SET NPDEAIEN=0
FOR CNT=1:1
SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
if '+NPDEAIEN
QUIT
Begin DoDot:1
+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 RET(CNT)=""
+28 ; NEW PERSON DEA NUMBER
SET RET(CNT)=RET(CNT)_NPDEADAT(200.5321,IENS,.01)_"^"
+29 ; INDIVIDUAL DEA SUFFIX
SET RET(CNT)=RET(CNT)_NPDEADAT(200.5321,IENS,.02)_"^"
+30 ; STATE
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.6)_"^"
+31 ; DETOX NUMBER ;P731 detox/x-waiver removal
SET RET(CNT)=RET(CNT)_""_"^"
+32 ; EXPIRATION DATE
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",.04)_"^"
+33 ; NEW PERSON IENS
SET RET(CNT)=RET(CNT)_IENS_"^"
+34 ; DEA NUMBERS IEN
SET RET(CNT)=RET(CNT)_DNDEAIEN_"^"
+35 ; SCHEDULE II NARCOTIC
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.1)_"^"
+36 ; SCHEDULE II NON-NARCOTIC
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.2)_"^"
+37 ; SCHEDULE III NARCOTIC
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.3)_"^"
+38 ; SCHEDULE III NON-NARCOTIC
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.4)_"^"
+39 ; SCHEDULE IV
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.5)_"^"
+40 ; SCHEDULE V
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.6)_"^"
+41 ; USE FOR INPATIENT ORDERS?
SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",.06)
End DoDot:1
+42 QUIT
+43 ;
DEADOJ(RET,DEA) ; -- RPC to return DEA Information for a single DEA Number
+1 ; INPUT: DEA - PROPERLY FORMATTED DEA NUMBER
+2 ;
+3 ; OUTPUT: RET - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
+4 ; 1 - PROVIDER NAME
+5 ; 2 - ADDITIONAL COMPANY INFO
+6 ; 3 - ADDRESS 1
+7 ; 4 - ADDRESS 2
+8 ; 5 - CITY
+9 ; 6 - STATE
+10 ; 7 - STATE POINTER
+11 ; 8 - ZIP CODE
+12 ; 9 - ACTIVITY CODE
+13 ; 10 - TYPE
+14 ; 11 - DEA NUMBER
+15 ; 12 - EXPIRATION DATE
+16 ; 13 - PROCESSED DATE
+17 ; 14 - DETOX NUMBER
+18 ; 15 - SCHDEULE II NARCOTIC
+19 ; 16 - SCHEDULE II NON-NARCOTIC
+20 ; 17 - SCHEDULE III NARCOTIC
+21 ; 18 - SCHEDULE III NON-NARCOTIC
+22 ; 19 - SCHEDULE IV
+23 ; 20 - SCHEDULE V
+24 ;
+25 NEW FG,NAME,NPIEN,VALUE,DS,BAC,SC
+26 IF $GET(DEA)=""
SET RET(0)="0^INVALID DEA NUMBER"
QUIT
+27 IF '$$DEANUMFL(DEA)
SET RET(0)="0^Invalid DEA Number due to error in first letter"
QUIT
+28 IF '$$DEANUM(DEA)
SET RET(0)="0^Invalid DEA Number due to error in the numbers"
QUIT
+29 SET SC=$$WSGET(.FG,DEA)
+30 IF $PIECE($PIECE(SC,"^",2),".",1)="DEA NUMBER NOT FOUND"
SET RET(0)="0^DEA NUMBER NOT FOUND. Please enter the provider's DEA number."
QUIT
+31 IF 'SC
SET RET(0)="0^WEB SERVICE FAILURE"
QUIT
+32 ;
+33 SET RET(1)=""
+34 ; PROVIDER NAME
SET RET(1)=RET(1)_$GET(FG("name"))_"^"
+35 ; ADDITIONAL COMPANY INFO
SET RET(1)=RET(1)_$GET(FG("additionalCompanyInfo"))_"^"
+36 ; ADDRESS 1
SET RET(1)=RET(1)_$GET(FG("address1"))_"^"
+37 ; ADDRESS 2
SET RET(1)=RET(1)_$GET(FG("address2"))_"^"
+38 ; CITY
SET RET(1)=RET(1)_$GET(FG("city"))_"^"
+39 ;
+40 ; Special State Processing
+41 ; STATE
SET RET(1)=RET(1)_$GET(FG("state"))_"^"
+42 NEW XSTATE,XIP
DO POSTAL^XIPUTIL($GET(FG("zipCode")),.XIP)
SET XSTATE=$GET(XIP("STATE"))
+43 ; STATE POINTER
SET RET(1)=RET(1)_$GET(XSTATE)_"^"
+44 ;
+45 ; ZIP CODE
SET RET(1)=RET(1)_$GET(FG("zipCode"))_"^"
+46 SET BAC=$GET(FG("businessActivityCode"))_$GET(FG("businessActivitySubcode"))
+47 ; ACTIVITY CODE
SET RET(1)=RET(1)_BAC_"^"
+48 ; TYPE
SET RET(1)=RET(1)_$PIECE($$PROVTYPE($GET(FG("businessActivityCode"))),"^",2)_"^"
+49 ; DEA NUMBER
SET RET(1)=RET(1)_$GET(FG("deaNumber"))_"^"
+50 ; EXPIRATION DATE
SET RET(1)=RET(1)_$GET(FG("expirationDate"))_"^"
+51 ; PROCESSED DATE
SET RET(1)=RET(1)_$GET(FG("processedDate"))_"^"
+52 ;
+53 SET DS=$GET(FG("drugSchedule"))
+54 SET NPIEN=$ORDER(^VA(200,"PS4",DEA,0))
+55 ; DETOX NUMBER
SET RET(1)=RET(1)_$SELECT($$DETOXCHK^PSODEAUT(BAC):"X"_$EXTRACT(FG("deaNumber"),2,9),1:"")_"^"
+56 ; SCHEDULE II NARCOTIC
SET RET(1)=RET(1)_$SELECT(DS["22N":"YES",(DS["2"&(DS'["2N")):"YES",1:"NO")_"^"
+57 ; SCHEDULE II NON-NARCOTIC
SET RET(1)=RET(1)_$SELECT(DS["2N":"YES",1:"NO")_"^"
+58 ; SCHEDULE III NARCOTIC
SET RET(1)=RET(1)_$SELECT(DS["33N":"YES",DS["3"&(DS'["3N"):"YES",1:"NO")_"^"
+59 ; SCHEDULE III NON-NARCOTIC
SET RET(1)=RET(1)_$SELECT(DS["3N":"YES",1:"NO")_"^"
+60 ; SCHEDULE IV
SET RET(1)=RET(1)_$SELECT(DS["4":"YES",1:"NO")_"^"
+61 ; SCHEDULE V
SET RET(1)=RET(1)_$SELECT(DS["5":"YES",1:"NO")
+62 SET RET(0)="1^SUCCESS"
+63 QUIT
+64 ;
DEAREM(RET,NPIEN,DEATXT) ; Functionality to remove a DEA multiple from file #200, Field 53.21
+1 ; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
+2 ; DEATXT - PROPERLY FORMATTED DEA NUMBER
+3 ; OUTPUT: RET - 1 for SUCCESS, 0 for UNSUCCESSFUL
+4 NEW FDA,IENS,MSGROOT,NPDEAIEN,DNDEAIEN,DEATYPE,DA,DIE,DR
+5 SET RET=0
if '$GET(NPIEN)
QUIT
if $GET(DEATXT)=""
QUIT
+6 SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4","B",DEATXT,0))
IF 'NPDEAIEN
QUIT
+7 SET DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
+8 SET DEATYPE=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")
+9 SET FDA(1,200.5321,NPDEAIEN_","_NPIEN_",",.01)="@"
+10 SET FDA(2,8991.9,DNDEAIEN_",",.01)="@"
+11 DO UPDATE^DIE(,"FDA(1)",,"MSGROOT")
if $DATA(MSGROOT)
QUIT
+12 IF DNDEAIEN
IF DEATYPE=2
DO UPDATE^DIE(,"FDA(2)",,"MSGROOT")
if $DATA(MSGROOT)
QUIT
+13 SET RET=1
+14 QUIT
+15 ;
VIEWFM(RET,DEA) ; -- Request for DEA Information stored in DEA NUMBERS FILE #8991.9, Return DEA Information in RET
+1 NEW DEAIEN,GETSTMP
+2 IF $GET(DEA)=""
SET RET(0)="0^INVALID DEA NUMBER"
QUIT
+3 SET DEAIEN=$ORDER(^XTV(8991.9,"B",DEA,0))
IF 'DEAIEN
SET RET(0)="0^DEA NUMBER NOT FOUND"
QUIT
+4 DO GETS^DIQ(8991.9,DEAIEN,"**","R","GETSTMP")
+5 IF '$DATA(GETSTMP)
SET RET(0)="0^NO DATA FOUND"
QUIT
+6 SET RET(0)="1^SUCCESS"
+7 SET CNT=0
SET NAME=""
FOR
SET NAME=$ORDER(GETSTMP(8991.9,DEAIEN_",",NAME))
if NAME=""
QUIT
Begin DoDot:1
+8 SET CNT=CNT+1
SET RET(CNT)=NAME_"^"_GETSTMP(8991.9,DEAIEN_",",NAME)
End DoDot:1
+9 QUIT
+10 ;
FILEWS(RET,ARRAY) ; -- File DEA Information in ARRAY, Return the IEN Number from DEA NUMBERS FILE #8991.9
+1 NEW FG,NAME,VALUE,CNT
+2 FOR CNT=1:1:$ORDER(ARRAY(""),-1)
SET FG($PIECE(ARRAY(CNT),"^",1))=$PIECE(ARRAY(CNT),"^",2)
+3 IF $GET(FG("deaNumber"))=""
SET RET(0)="0^INVALID DEA NUMBER"
QUIT
+4 IF '$$DEANUMFL(FG("deaNumber"))
SET RET(0)="0^Invalid DEA Number due to error in first letter"
QUIT
+5 IF '$$DEANUM(FG("deaNumber"))
SET RET(0)="0^Invalid DEA Number due to error in the numbers"
QUIT
+6 SET RET=$$DEACOPY^PSODEAUT(.FG)
+7 QUIT
+8 ;
DEACOPY(FG) ; -- Private Subroutine to Copy import data in the GETS Array
+1 ; POSTAL^XIPUTL used in agreement with Integration Agreement: 3618
+2 ;
+3 ; INPUT: FG ;Web Service Response Global
+4 ;
+5 ; VARIABLES:
+6 ;Single drug schedule field as sent from the VA DOJ Web Service.
NEW DS
+7 ;Used to calculate the state from a zip code.
NEW XIP
+8 ;Used to calculate the state from a zip code.
NEW XSTATE
+9 ;Business Activity Code
NEW BAC
+10 NEW DTRESULT
+11 ;
+12 SET DS=$GET(FG("drugSchedule"))
+13 SET GETS(.01)=$GET(FG("deaNumber"))
+14 SET BAC=$GET(FG("businessActivityCode"))_$GET(FG("businessActivitySubcode"))
+15 ; Pointer to file #8991.8
SET GETS(.02)=BAC
+16 ; DETOX NUMBER
SET GETS(.03)=$SELECT($$GETDNDTX^PSODEAUT(NPIEN)'="":"",$$DETOXCHK^PSODEAUT(BAC):"X"_$EXTRACT($GET(FG("deaNumber")),2,9),1:"")
+17 DO DT^DILF("E",$GET(FG("expirationDate")),.DTRESULT)
+18 SET GETS(.04)=$GET(DTRESULT(0))
+19 SET GETS(.07)=$GET(FG("type"))
+20 SET GETS(1.1)=$GET(FG("name"))
+21 SET GETS(1.2)=$GET(FG("additionalCompanyInfo"))
+22 SET GETS(1.3)=$GET(FG("address1"))
+23 SET GETS(1.4)=$GET(FG("address2"))
+24 SET GETS(1.5)=$GET(FG("city"))
+25 ;
+26 ; Special State Processing
+27 SET GETS(1.6)=$GET(FG("state"))
+28 DO POSTAL^XIPUTIL($GET(FG("zipCode")),.XIP)
+29 SET XSTATE=$GET(XIP("STATE"))
+30 ; Pointer to the State File #5.
IF XSTATE'=""
SET GETS(1.6)=XSTATE
+31 ;
+32 SET GETS(1.7)=$GET(FG("zipCode"))
+33 ;
+34 ; SCHEDULE II NARCOTIC
SET GETS(2.1)=$SELECT(DS["22N":"YES",(DS["2"&(DS'["2N")):"YES",1:"NO")
+35 ; SCHEDULE II NON-NARCOTIC
SET GETS(2.2)=$SELECT(DS["2N":"YES",1:"NO")
+36 ; SCHEDULE III NARCOTIC
SET GETS(2.3)=$SELECT(DS["33N":"YES",(DS["3"&(DS'["3N")):"YES",1:"NO")
+37 ; SCHEDULE III NON-NARCOTIC
SET GETS(2.4)=$SELECT(DS["3N":"YES",1:"NO")
+38 ; SCHEDULE IV
SET GETS(2.5)=$SELECT(DS["4":"YES",1:"NO")
+39 ; SCHEDULE V
SET GETS(2.6)=$SELECT(DS["5":"YES",1:"NO")
+40 ;
+41 DO DT^DILF("E",%DT,.DTRESULT)
+42 ; LAST UPDATED DATE/TIME
SET GETS(10.2)=$GET(DTRESULT(0))
+43 DO DT^DILF("E",$GET(FG("processedDate")),.DTRESULT)
+44 ; LAST DOJ UPDATE DATE/TIME
SET GETS(10.3)=$GET(DTRESULT(0))
+45 SET GETS(10.1)=DUZ
+46 QUIT
+47 ;
FILEFM(RET,DATA,NPIEN) ; -- File DEA Information in the DEA NUMBERS FILE #8991.9
+1 NEW DNDEAIEN,DNDEATXT,FDA,IENROOT,IENS,MSGROOT,SUFFIX,XSTATE,XIP
+2 SET RET=0
+3 IF '$DATA(DATA)
SET RET=0
GOTO FILEFMX
+4 ;
+5 SET DNDEATXT=$PIECE(DATA,U,11)
IF DNDEATXT=""
GOTO FILEFMX
+6 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DNDEATXT,0))
+7 SET IENS=$SELECT($GET(DNDEAIEN):$GET(DNDEAIEN)_",",1:"+1,")
+8 ;
+9 ; INPUT: DATA - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
+10 ; 1 - PROVIDER NAME
SET FDA(1,8991.9,IENS,1.1)=$PIECE(DATA,U,1)
+11 ; 2 - ADDITIONAL COMPANY INFO
SET FDA(1,8991.9,IENS,1.2)=$PIECE(DATA,U,2)
+12 ; 3 - ADDRESS 1
SET FDA(1,8991.9,IENS,1.3)=$PIECE(DATA,U,3)
+13 ; 4 - ADDRESS 2
SET FDA(1,8991.9,IENS,1.4)=$PIECE(DATA,U,4)
+14 ; 5 - CITY
SET FDA(1,8991.9,IENS,1.5)=$PIECE(DATA,U,5)
+15 ;
+16 ; Special State Processing
+17 DO POSTAL^XIPUTIL($PIECE(DATA,U,8),.XIP)
+18 SET XSTATE=$GET(XIP("STATE"))
+19 ; 6 - STATE
IF XSTATE'=""
SET FDA(1,8991.9,IENS,1.6)=XSTATE
+20 ;
+21 ; 8 - ZIP CODE
SET FDA(1,8991.9,IENS,1.7)=$PIECE(DATA,U,8)
+22 ; 9 - ACTIVITY CODE
SET FDA(1,8991.9,IENS,.02)=$PIECE(DATA,U,9)
+23 ; 10 - TYPE
SET FDA(1,8991.9,IENS,.07)=$PIECE(DATA,U,10)
+24 ; 11 - DEA NUMBER
SET FDA(1,8991.9,IENS,.01)=$PIECE(DATA,U,11)
+25 ; 12 - EXPIRATION DATE
SET FDA(1,8991.9,IENS,.04)=$PIECE(DATA,U,12)
+26 ; 13 - PROCESSED DATE
SET FDA(1,8991.9,IENS,10.2)="N"
+27 ; ONLY CLEAR AND SET IF VALIDATED
IF $$DEANUM($PIECE(DATA,U,14))
Begin DoDot:1
+28 ; REMOVE DETOX NUMBERS FROM OTHER DEA NUMBERS
IF $PIECE(DATA,U,14)'=""
DO CLEARDTX(NPIEN)
+29 ; 14 - DETOX NUMBER
SET FDA(1,8991.9,IENS,.03)=$PIECE(DATA,U,14)
End DoDot:1
+30 ; 15 - SCHDEULE II NARCOTIC
SET FDA(1,8991.9,IENS,2.1)=$PIECE(DATA,U,15)
+31 ; 16 - SCHEDULE II NON-NARCOTIC
SET FDA(1,8991.9,IENS,2.2)=$PIECE(DATA,U,16)
+32 ; 17 - SCHEDULE III NARCOTIC
SET FDA(1,8991.9,IENS,2.3)=$PIECE(DATA,U,17)
+33 ; 18 - SCHEDULE III NON-NARCOTIC
SET FDA(1,8991.9,IENS,2.4)=$PIECE(DATA,U,18)
+34 ; 19 - SCHEDULE IV
SET FDA(1,8991.9,IENS,2.5)=$PIECE(DATA,U,19)
+35 ; 20 - SCHEDULE V
SET FDA(1,8991.9,IENS,2.6)=$PIECE(DATA,U,20)
+36 ; 21 - USE FOR INPATIENT FLAG
SET FDA(1,8991.9,IENS,.06)=$PIECE(DATA,U,21)
+37 ; 22 - DEA INSTITUTIONAL SUFFIX
SET SUFFIX=$PIECE(DATA,U,22)
+38 ;
+39 DO UPDATE^DIE("E","FDA(1)","IENROOT","MSGROOT")
+40 IF $DATA(MSGROOT)
SET RET="0^DATA DIDN'T FILE SUCCESSFULLY."
GOTO FILEFMX
+41 SET DNDEAIEN=$SELECT($DATA(IENROOT(1)):IENROOT(1)_",",1:IENS)
+42 IF '+DNDEAIEN
SET RET="0^DATA DIDN'T FILE SUCCESSFULLY."
GOTO FILEFMX
+43 SET FDA(2,8991.9,DNDEAIEN,10.1)=$GET(DUZ)
DO FILE^DIE("","FDA(2)","MSGROOT")
+44 if DNDEAIEN
SET RET=+DNDEAIEN_"^SUCCESSFULLY SAVED/UPDATED IN 8991.9"
+45 IF $LENGTH(DNDEATXT)
IF $GET(NPIEN)
IF $GET(DNDEAIEN)
SET RET=RET_"^"_$$NPFILE(DNDEATXT,NPIEN,DNDEAIEN,SUFFIX)
+46 IF RET
IF $PIECE(DATA,U,21)="YES"
SET FDA(200,NPIEN_",",53.2)=$PIECE(DATA,U,11)
DO UPDATE^DIE(,"FDA")
FILEFMX ; -- Subroutine Exit Point
+1 QUIT
+2 ;
NPFILE(DNDEATXT,NPIEN,DNDEAIEN,SUFFIX) ; -- File the DEA NUMBER in the NEW PERSON FILE #200.
+1 NEW FDA,IEN,IENROOT,MSGROOT
+2 if '$GET(NPIEN)
QUIT
if '$GET(DNDEAIEN)
QUIT
+3 SET IEN="+1,"
+4 IF $DATA(^VA(200,NPIEN,"PS4","B",DNDEATXT))
SET IEN=$ORDER(^VA(200,NPIEN,"PS4","B",DNDEATXT,0))_","
+5 SET FDA(1,200.5321,IEN_NPIEN_",",.01)=DNDEATXT
+6 SET FDA(1,200.5321,IEN_NPIEN_",",.02)=SUFFIX
+7 SET FDA(1,200.5321,IEN_NPIEN_",",.03)=+DNDEAIEN
+8 DO UPDATE^DIE("","FDA(1)","IENROOT","MSGROOT")
+9 IF $DATA(MSGROOT)
QUIT "0^DATA DIDN'T FILE SUCCESSFULLY."
+10 QUIT "1^SUCCESSFULLY SAVED/UPDATED IN 200"
+11 ;
PROVTYPE(BA) ; -- Calculate the Provider Type from the Business Activity Code.
+1 NEW RESULT
SET RESULT="1^INSTITUTIONAL"
+2 if $GET(BA)=""
SET RESULT="2^INDIVIDUAL"
+3 if $EXTRACT(BA)="C"
SET RESULT="2^INDIVIDUAL"
+4 if $EXTRACT(BA)="M"
SET RESULT="2^INDIVIDUAL"
+5 QUIT RESULT
+6 ;
CONVNAME(CN) ; -- Set up a NAME conversion array.
+1 SET CN("additionalCompanyInfo")="COMPANY INFO"
+2 SET CN("address1")="ADDRESS 1"
+3 SET CN("address2")="ADDRESS 2"
+4 SET CN("businessActivityCode")="ACTIVITY CODE"
+5 SET CN("businessActivitySubcode")="ACTIVITY SUB"
+6 SET CN("city")="CITY"
+7 SET CN("deaNumber")="DEA NUMBER"
+8 SET CN("drugSchedule")="DRUG SCHEDULE"
+9 SET CN("expirationDate")="EXPIRATION DATE"
+10 SET CN("name")="NAME"
+11 SET CN("processedDate")="PROCESSED DATE"
+12 SET CN("state")="STATE"
+13 SET CN("type")="TYPE"
+14 SET CN("zipCode")="ZIP CODE"
+15 QUIT
+16 ;
GETS(DEAIEN,GETS) ; -- Get the existing data from the DEA NUMBERS FILE #8991.9
+1 NEW GETSTMP
+2 DO GETS^DIQ(8991.9,DEAIEN,"**","","GETSTMP")
+3 MERGE GETS=GETSTMP(8991.9,DEAIEN_",")
+4 QUIT
+5 ;
DEANUM(X) ; -- Check DEA # part
+1 NEW VA1,VA2
+2 SET VA1=$EXTRACT(X,3)+$EXTRACT(X,5)+$EXTRACT(X,7)+(2*($EXTRACT(X,4)+$EXTRACT(X,6)+$EXTRACT(X,8)))
+3 SET VA1=VA1#10
SET VA2=$EXTRACT(X,9)
+4 QUIT VA1=VA2
+5 ;
DEANUMFL(X) ;Check DEA # First Letter Part
+1 QUIT $SELECT("ABCDEFGHIJKLMNOPQRSTUVWXYZ"[$EXTRACT(X):1,1:0)
+2 ;
DUPCHK(RET,DEATXT,SUFFIX) ; -- Check for duplicate DEA number or duplicate SUFFIX usage.
+1 ; INPUTS: DEATXT - The text format of a DEA Number
+2 ; SUFFIX - The DEA suffix for an Institutional DEA number
+3 IF $GET(DEATXT)=""
SET RET="0^No DEA number supplied"
QUIT
+4 SET SUFFIX=$GET(SUFFIX)
+5 SET RET="1^Success"
+6 IF SUFFIX=""
IF $DATA(^VA(200,"PS4",DEATXT))
SET RET="0^Provider DEA number is already associated to another profile. Please check the number entered."
QUIT
+7 IF SUFFIX'=""
IF $DATA(^VA(200,"F",DEATXT,SUFFIX))
SET RET="0^Duplicate Usage of a SUFFIX"
QUIT
+8 QUIT
+9 ;
DETOXCHK(BAC) ; -- Test Business Activity Code for DEXTOX (DW)
+1 ;P731 detox/x-waiver removal
QUIT 0
+2 NEW BACIEN
+3 IF $GET(BAC)=""
QUIT 0
+4 IF '$DATA(^XTV(8991.8,"B",BAC))
QUIT 0
+5 SET BACIEN=$ORDER(^XTV(8991.8,"B",BAC,0))
IF 'BACIEN
QUIT 0
+6 IF $$GET1^DIQ(8991.8,BACIEN,1)["DW/"
QUIT 1
+7 QUIT 0
+8 ;
DETOXDUP(DEA,DETOX,DUPDEA) ; -- Check for duplicate Detox number
+1 ;P731 detox/x-waiver removal
QUIT ""
+2 NEW I,NXTDET
SET NXTDEA=0
SET DUPDEA=""
+3 ; Missing required input, can't check
IF $GET(DETOX)=""!($GET(DEA)="")
QUIT 0
+4 ; If Detox not on file, not a duplicate
IF '$DATA(^XTV(8991.9,"D",$GET(DETOX)))
QUIT 0
+5 ; On file for another prescriber, duplicate
IF $DATA(^XTV(8991.9,"D",$GET(DETOX)))
IF '$DATA(^XTV(8991.9,"D",$GET(DETOX),$GET(DEA)))
Begin DoDot:1
+6 SET DUPDEA=$ORDER(^XTV(8991.9,"D",$GET(DETOX),$GET(DUPDEA)))
End DoDot:1
QUIT 1
+7 FOR
SET NXTDEA=$ORDER(^XTV(8991.9,"D",DETOX,NXTDEA))
if NXTDEA=""
QUIT
SET DUPDEA=$SELECT($GET(DUPDEA)'="":DUPDEA_","_NXTDEA,1:NXTDEA)
+8 ; If more than one entry on file for this Detox number, duplicate
IF $GET(DUPDEA)'=""
QUIT 1
+9 QUIT 0
+10 ;
MBM(RET) ; -- MEDS BY MAIL for ePCS GUI
+1 NEW SYS
+2 SET RET=0
+3 SET SYS=$$GET^XPAR("SYS^PKG","PSO VAMC MBM PHARMACY MODE",1,"E")
+4 IF SYS="MBM"
SET RET=1
+5 QUIT
+6 ;
ENTRY(RESULT,INPUT) ; -- remoteprocedure
+1 NEW I,NOW
+2 SET NOW=$PIECE($$HTE^XLFDT($HOROLOG),":",1,2)
+3 FOR I=-1:0
SET I=$ORDER(INPUT(I))
if I=""
QUIT
DO RECORD(INPUT(I),NOW)
+4 SET RESULT=1
+5 QUIT
+6 ;
RECORD(LINE,NOW) ;
+1 NEW FDA,VALUE,IEN,MSG,I
+2 FOR I=1:1:5
SET VALUE=$PIECE(LINE,U,I)
SET FDA(8991.6,"+1,",(I/100))=VALUE
+3 SET FDA(8991.6,"+1,",.06)=NOW
+4 DO UPDATE^DIE("E","FDA","IEN","MSG")
+5 QUIT
+6 ;
CLEARDTX(NPIEN) ; REMOVE DETOX NUMBERS FROM ALL OF A PROVIDERS DEA NUMBERS
+1 NEW DNDEAIEN,FDA,NPDEAIEN
+2 SET NPDEAIEN=0
FOR
SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
if 'NPDEAIEN
QUIT
Begin DoDot:1
+3 SET DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
+4 KILL FDA
SET FDA(1,8991.9,DNDEAIEN_",",.03)="@"
DO UPDATE^DIE("","FDA(1)")
KILL FDA
End DoDot:1
+5 QUIT
+6 ;
GETDNDTX(NPIEN,DNDEAX) ; GET A SINGLE DETOX NUMBER FROM ALL OF A PROVIDERS DEA NUMBERS IN 8991.9
+1 ;P731 detox/x-waiver removal
QUIT ""
+2 NEW GETDNDTX,DNDEAIEN,NPDEAIEN
SET GETDNDTX=""
+3 KILL DNDEAX
+4 SET NPDEAIEN=0
FOR
SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
if 'NPDEAIEN
QUIT
if $LENGTH(GETDNDTX)
QUIT
Begin DoDot:1
+5 SET DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
if 'DNDEAIEN
QUIT
+6 SET GETDNDTX=$$GET1^DIQ(8991.9,DNDEAIEN_",",.03)
+7 SET DNDEAX=$$GET1^DIQ(8991.9,DNDEAIEN_",",.01)
End DoDot:1
+8 QUIT GETDNDTX
+9 ;
WSGET(FG,DEA) ; Function to Get the Remote DEA information, Return in FG.
+1 ; INPUT: DEA ;Properly formatted DEA Number for lookup.
+2 ;
+3 ; OUTPUT: FG ;Web Service Response Global
+4 ;
+5 ; RETURN: Status code with a text message.
+6 ; If not filled successfully a "0^Error Message" will be returned.
+7 ;
+8 QUIT $$WSGET^PSODEAU0(.FG,DEA)
