XUEPCSU1 ;ALB/BI - DEA Manual Entry ;05/15/2018
;;8.0;KERNEL;**689**;Jul 10, 1995;Build 113
Q
;
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.
;
; VARIABLES:
N DATA ;The body portion of the RESPONSE object.
N ERRORS ;Errors that may be returned from the JSON to MUMPS convertion.
; FG ;The JSON string converted to a MUMPS global.
N REQUEST ;The web service object.
N RESOURCE ;Input variable for the $$GET^XOBWLIB call, in this case the DEA number.
N RESPJSON ;Used to store the JSON response in the DATA object into a single line string.
N RESPONSE ;The response object portion of the REQUEST object.
N SC ;Status Code response from the $$GET^XOBWLIB call.
N SERVER ;The web server identifier.
N SERVICE ;The web service identifier.
N XU ;Left over variable from the XOBWLIB processes.
N PSOERR ;Left over variable from the XOBWLIB processes.
;
Q:$G(DEA)="" "0^No DEA Number Entered."
S SERVER="PSO DOJ/DEA WEB SERVER"
S SERVICE="PSO DOJ/DEA WEB SERVICE"
S RESOURCE=DEA
;
; Get an instance of the REST request object.
S REQUEST=$$GETREST^XOBWLIB(SERVICE,SERVER)
;
; Execute the HTTP Get method.
S SC=$$GET^XOBWLIB(REQUEST,RESOURCE,.PSOERR,0)
I 'SC Q "0^General Service Error"
;
; Process the response. REQUEST(O) -> RESPONSE(0) -> DATA(S) -> RESPJSON(S)
S RESPONSE=REQUEST.HttpResponse
S DATA=RESPONSE.Data
S RESPJSON=""
;
F Q:DATA.AtEnd Set RESPJSON=RESPJSON_DATA.ReadLine()
S RESPJSON=$TR(RESPJSON,$C(10),"")
I RESPJSON="" Q "0^No Data Returned."
;
; Decode the JSON format into a MUMPS global in FG
D DECODE^XLFJSON("RESPJSON","FG","ERRORS")
;
; Handle a "DEA NOT FOUND" gracefully.
I FG("deaNumber")="DEA NOT FOUND" Q "0^DEA NUMBER NOT FOUND. Please enter the provider's DEA number."
;
; Define the TYPE field
S FG("type")=$P($$PROVTYPE^PSODEAUT(FG("businessActivityCode")),"^",2)
;
; Default the businessActivitySubcode.
I $G(FG("businessActivitySubcode"))="" S FG("businessActivitySubcode")=0
;
Q "1^Success"
;
FILEFM(RET,DATA,NPIEN) ; -- File DEA Information in the DEA NUMBERS FILE #8991.9
; Invoked by RPC: XU EPCS ADD DEA
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 - ADDRESS 1
S FDA(1,8991.9,IENS,1.3)=$P(DATA,U,3) ; 3 - ADDRESS 2
S FDA(1,8991.9,IENS,1.4)=$P(DATA,U,4) ; 4 - ADDRESS 3
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^XUEPCSUT($P(DATA,U,14)) D ; ONLY CLEAR AND SET IF VALIDATED
. I $P(DATA,U,14)'="" D CLEARDTX^XUEPCSUT(NPIEN) ; REMOVE DETOX NUMBERS FROM OTHER DEA NUMBERS
. S FDA(1,8991.9,IENS,.03)=$P(DATA,U,14) ; 14 - DETOX NUMBER
I $P(DATA,U,10)="INDIVIDUAL" D
. S FDA(1,8991.9,IENS,2.1)=$P(DATA,U,15) ; 15 - SCHEDULE 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
I $P(DATA,U,10)'="INDIVIDUAL" D
. N SRET,SDEA
. S SDEA=$P(DATA,U,11) ;dea number
. D DEADOJ^XUEPCSUT(.SRET,SDEA) ;call doj server for doj institutional schedules
. I SRET(0) D ;doj server is up
. . S FDA(1,8991.9,IENS,2.1)=$P(SRET(1),"^",15) ; 15 - SCHEDULE II NARCOTIC
. . S FDA(1,8991.9,IENS,2.2)=$P(SRET(1),"^",16) ; 16 - SCHEDULE II NON-NARCOTIC
. . S FDA(1,8991.9,IENS,2.3)=$P(SRET(1),"^",17) ; 17 - SCHEDULE III NARCOTIC
. . S FDA(1,8991.9,IENS,2.4)=$P(SRET(1),"^",18) ; 18 - SCHEDULE III NON-NARCOTIC
. . S FDA(1,8991.9,IENS,2.5)=$P(SRET(1),"^",19) ; 19 - SCHEDULE IV
. . S FDA(1,8991.9,IENS,2.6)=$P(SRET(1),"^",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^XUEPCSUT(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")
I $P(RET,"^",3),$G(NPIEN),$P($G(DATA),"^",10)'="INDIVIDUAL" S RET=RET_"^"_$$NPSFILE^XUEPCSUT(NPIEN,DATA)
FILEFMX ; -- Subroutine Exit Point
Q
;
DNDEAGET(RET,DEA) ;
I '$D(^XTV(8991.9,"B",DEA)) S RET(0)="0^DEA NOT ON FILE" Q
I $D(^XTV(8991.9,"B",DEA)) S DNDEAIEN=$O(^XTV(8991.9,"B",DEA,0)) I +DNDEAIEN D
. K DNDEADAT D GETS^DIQ(8991.9,DNDEAIEN,"**","","DNDEADAT")
. K RET(1)
. S RET(1)=""
. S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",1.1))_"^" ; PROVIDER NAME
. S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",1.2))_"^" ; ADDRESS 1
. S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",1.3))_"^" ; ADDRESS 2
. S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",1.4))_"^" ; ADDRESS 3
. S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",1.5))_"^" ; CITY
. ;
. ; Special State Processing
. N XSTATE,XSTATEAB,XIP,BAC,X,Y D POSTAL^XIPUTIL($G(DNDEADAT(8991.9,DNDEAIEN_",",1.7)),.XIP)
. S XSTATEAB=$$GET1^DIQ(5,XIP("STATE POINTER"),1)
. S RET(1)=RET(1)_XSTATEAB_"^" ; STATE ABREVIATION
. S XSTATE=$G(XIP("STATE"))
. S RET(1)=RET(1)_$G(XSTATE)_"^" ; STATE
. ;
. S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",1.7))_"^" ; ZIP CODE
. S BAC=$G(DNDEADAT(8991.9,DNDEAIEN_",",.02)) ; ACTIVITY CODE
. S RET(1)=RET(1)_BAC_"^" ; ACTIVITY CODE
. S RET(1)=RET(1)_$P($$PROVTYPE^XUEPCSUT($G(BAC)),"^",2)_"^" ; TYPE
. S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",.01))_"^" ; DEA NUMBER
. S X=$P($G(DNDEADAT(8991.9,DNDEAIEN_",",.04)),"@") D ^%DT
. S RET(1)=RET(1)_$$FMTHL7^XLFDT(Y)_"^" ; EXPIRATION DATE
. S X=$P($G(DNDEADAT(8991.9,DNDEAIEN_",",10.2)),"@") D ^%DT
. S RET(1)=RET(1)_$$FMTHL7^XLFDT(Y)_"^" ; PROCESSED DATE
. S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",.03))_"^" ; DETOX NUMBER
. I $G(DNDEADAT(8991.9,DNDEAIEN_",",.07))="INDIVIDUAL" D
. . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",2.1))_"^" ; SCHEDULE II NARCOTIC
. . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",2.2))_"^" ; SCHEDULE II NON-NARCOTIC
. . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",2.3))_"^" ; SCHEDULE III NARCOTIC
. . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",2.4))_"^" ; SCHEDULE III NON-NARCOTIC
. . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",2.5))_"^" ; SCHEDULE IV
. . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",2.6)) ; SCHEDULE V
. I $G(DNDEADAT(8991.9,DNDEAIEN_",",.07))'="INDIVIDUAL" D
. . S RET(1)=RET(1)_"^" ; SCHEDULE II NARCOTIC
. . S RET(1)=RET(1)_"^" ; SCHEDULE II NON-NARCOTIC
. . S RET(1)=RET(1)_"^" ; SCHEDULE III NARCOTIC
. . S RET(1)=RET(1)_"^" ; SCHEDULE III NON-NARCOTIC
. . S RET(1)=RET(1)_"^" ; SCHEDULE IV
. . S RET(1)=RET(1)_"^" ; SCHEDULE V
S RET(0)=RET(0)_"; OFFLINE DEA DATA IN USE"
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUEPCSU1 8665 printed Sep 23, 2025@19:45:29 Page 2
XUEPCSU1 ;ALB/BI - DEA Manual Entry ;05/15/2018
+1 ;;8.0;KERNEL;**689**;Jul 10, 1995;Build 113
+2 QUIT
+3 ;
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 ; VARIABLES:
+9 ;The body portion of the RESPONSE object.
NEW DATA
+10 ;Errors that may be returned from the JSON to MUMPS convertion.
NEW ERRORS
+11 ; FG ;The JSON string converted to a MUMPS global.
+12 ;The web service object.
NEW REQUEST
+13 ;Input variable for the $$GET^XOBWLIB call, in this case the DEA number.
NEW RESOURCE
+14 ;Used to store the JSON response in the DATA object into a single line string.
NEW RESPJSON
+15 ;The response object portion of the REQUEST object.
NEW RESPONSE
+16 ;Status Code response from the $$GET^XOBWLIB call.
NEW SC
+17 ;The web server identifier.
NEW SERVER
+18 ;The web service identifier.
NEW SERVICE
+19 ;Left over variable from the XOBWLIB processes.
NEW XU
+20 ;Left over variable from the XOBWLIB processes.
NEW PSOERR
+21 ;
+22 if $GET(DEA)=""
QUIT "0^No DEA Number Entered."
+23 SET SERVER="PSO DOJ/DEA WEB SERVER"
+24 SET SERVICE="PSO DOJ/DEA WEB SERVICE"
+25 SET RESOURCE=DEA
+26 ;
+27 ; Get an instance of the REST request object.
+28 SET REQUEST=$$GETREST^XOBWLIB(SERVICE,SERVER)
+29 ;
+30 ; Execute the HTTP Get method.
+31 SET SC=$$GET^XOBWLIB(REQUEST,RESOURCE,.PSOERR,0)
+32 IF 'SC
QUIT "0^General Service Error"
+33 ;
+34 ; Process the response. REQUEST(O) -> RESPONSE(0) -> DATA(S) -> RESPJSON(S)
+35 SET RESPONSE=REQUEST.HttpResponse
+36 SET DATA=RESPONSE.Data
+37 SET RESPJSON=""
+38 ;
+39 FOR
if DATA.AtEnd
QUIT
SET RESPJSON=RESPJSON_DATA.ReadLine()
+40 SET RESPJSON=$TRANSLATE(RESPJSON,$CHAR(10),"")
+41 IF RESPJSON=""
QUIT "0^No Data Returned."
+42 ;
+43 ; Decode the JSON format into a MUMPS global in FG
+44 DO DECODE^XLFJSON("RESPJSON","FG","ERRORS")
+45 ;
+46 ; Handle a "DEA NOT FOUND" gracefully.
+47 IF FG("deaNumber")="DEA NOT FOUND"
QUIT "0^DEA NUMBER NOT FOUND. Please enter the provider's DEA number."
+48 ;
+49 ; Define the TYPE field
+50 SET FG("type")=$PIECE($$PROVTYPE^PSODEAUT(FG("businessActivityCode")),"^",2)
+51 ;
+52 ; Default the businessActivitySubcode.
+53 IF $GET(FG("businessActivitySubcode"))=""
SET FG("businessActivitySubcode")=0
+54 ;
+55 QUIT "1^Success"
+56 ;
FILEFM(RET,DATA,NPIEN) ; -- File DEA Information in the DEA NUMBERS FILE #8991.9
+1 ; Invoked by RPC: XU EPCS ADD DEA
+2 NEW DNDEAIEN,DNDEATXT,FDA,IENROOT,IENS,MSGROOT,SUFFIX,XSTATE,XIP
+3 SET RET=0
+4 IF '$DATA(DATA)
SET RET=0
GOTO FILEFMX
+5 ;
+6 SET DNDEATXT=$PIECE(DATA,U,11)
IF DNDEATXT=""
GOTO FILEFMX
+7 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DNDEATXT,0))
+8 SET IENS=$SELECT($GET(DNDEAIEN):$GET(DNDEAIEN)_",",1:"+1,")
+9 ;
+10 ; INPUT: DATA - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
+11 ; 1 - PROVIDER NAME
SET FDA(1,8991.9,IENS,1.1)=$PIECE(DATA,U,1)
+12 ; 2 - ADDRESS 1
SET FDA(1,8991.9,IENS,1.2)=$PIECE(DATA,U,2)
+13 ; 3 - ADDRESS 2
SET FDA(1,8991.9,IENS,1.3)=$PIECE(DATA,U,3)
+14 ; 4 - ADDRESS 3
SET FDA(1,8991.9,IENS,1.4)=$PIECE(DATA,U,4)
+15 ; 5 - CITY
SET FDA(1,8991.9,IENS,1.5)=$PIECE(DATA,U,5)
+16 ;
+17 ; Special State Processing
+18 DO POSTAL^XIPUTIL($PIECE(DATA,U,8),.XIP)
+19 SET XSTATE=$GET(XIP("STATE"))
+20 ; 6 - STATE
IF XSTATE'=""
SET FDA(1,8991.9,IENS,1.6)=XSTATE
+21 ;
+22 ; 8 - ZIP CODE
SET FDA(1,8991.9,IENS,1.7)=$PIECE(DATA,U,8)
+23 ; 9 - ACTIVITY CODE
SET FDA(1,8991.9,IENS,.02)=$PIECE(DATA,U,9)
+24 ; 10 - TYPE
SET FDA(1,8991.9,IENS,.07)=$PIECE(DATA,U,10)
+25 ; 11 - DEA NUMBER
SET FDA(1,8991.9,IENS,.01)=$PIECE(DATA,U,11)
+26 ; 12 - EXPIRATION DATE
SET FDA(1,8991.9,IENS,.04)=$PIECE(DATA,U,12)
+27 ; 13 - PROCESSED DATE
SET FDA(1,8991.9,IENS,10.2)="N"
+28 ; ONLY CLEAR AND SET IF VALIDATED
IF $$DEANUM^XUEPCSUT($PIECE(DATA,U,14))
Begin DoDot:1
+29 ; REMOVE DETOX NUMBERS FROM OTHER DEA NUMBERS
IF $PIECE(DATA,U,14)'=""
DO CLEARDTX^XUEPCSUT(NPIEN)
+30 ; 14 - DETOX NUMBER
SET FDA(1,8991.9,IENS,.03)=$PIECE(DATA,U,14)
End DoDot:1
+31 IF $PIECE(DATA,U,10)="INDIVIDUAL"
Begin DoDot:1
+32 ; 15 - SCHEDULE II NARCOTIC
SET FDA(1,8991.9,IENS,2.1)=$PIECE(DATA,U,15)
+33 ; 16 - SCHEDULE II NON-NARCOTIC
SET FDA(1,8991.9,IENS,2.2)=$PIECE(DATA,U,16)
+34 ; 17 - SCHEDULE III NARCOTIC
SET FDA(1,8991.9,IENS,2.3)=$PIECE(DATA,U,17)
+35 ; 18 - SCHEDULE III NON-NARCOTIC
SET FDA(1,8991.9,IENS,2.4)=$PIECE(DATA,U,18)
+36 ; 19 - SCHEDULE IV
SET FDA(1,8991.9,IENS,2.5)=$PIECE(DATA,U,19)
+37 ; 20 - SCHEDULE V
SET FDA(1,8991.9,IENS,2.6)=$PIECE(DATA,U,20)
End DoDot:1
+38 IF $PIECE(DATA,U,10)'="INDIVIDUAL"
Begin DoDot:1
+39 NEW SRET,SDEA
+40 ;dea number
SET SDEA=$PIECE(DATA,U,11)
+41 ;call doj server for doj institutional schedules
DO DEADOJ^XUEPCSUT(.SRET,SDEA)
+42 ;doj server is up
IF SRET(0)
Begin DoDot:2
+43 ; 15 - SCHEDULE II NARCOTIC
SET FDA(1,8991.9,IENS,2.1)=$PIECE(SRET(1),"^",15)
+44 ; 16 - SCHEDULE II NON-NARCOTIC
SET FDA(1,8991.9,IENS,2.2)=$PIECE(SRET(1),"^",16)
+45 ; 17 - SCHEDULE III NARCOTIC
SET FDA(1,8991.9,IENS,2.3)=$PIECE(SRET(1),"^",17)
+46 ; 18 - SCHEDULE III NON-NARCOTIC
SET FDA(1,8991.9,IENS,2.4)=$PIECE(SRET(1),"^",18)
+47 ; 19 - SCHEDULE IV
SET FDA(1,8991.9,IENS,2.5)=$PIECE(SRET(1),"^",19)
+48 ; 20 - SCHEDULE V
SET FDA(1,8991.9,IENS,2.6)=$PIECE(SRET(1),"^",20)
End DoDot:2
+49 ;
End DoDot:1
+50 ; 21 - USE FOR INPATIENT FLAG
SET FDA(1,8991.9,IENS,.06)=$PIECE(DATA,U,21)
+51 ; 22 - DEA INSTITUTIONAL SUFFIX
SET SUFFIX=$PIECE(DATA,U,22)
+52 ;
+53 DO UPDATE^DIE("E","FDA(1)","IENROOT","MSGROOT")
+54 IF $DATA(MSGROOT)
SET RET="0^DATA DIDN'T FILE SUCCESSFULLY."
GOTO FILEFMX
+55 SET DNDEAIEN=$SELECT($DATA(IENROOT(1)):IENROOT(1)_",",1:IENS)
+56 IF '+DNDEAIEN
SET RET="0^DATA DIDN'T FILE SUCCESSFULLY."
GOTO FILEFMX
+57 SET FDA(2,8991.9,DNDEAIEN,10.1)=$GET(DUZ)
DO FILE^DIE("","FDA(2)","MSGROOT")
+58 if DNDEAIEN
SET RET=+DNDEAIEN_"^SUCCESSFULLY SAVED/UPDATED IN 8991.9"
+59 IF $LENGTH(DNDEATXT)
IF $GET(NPIEN)
IF $GET(DNDEAIEN)
SET RET=RET_"^"_$$NPFILE^XUEPCSUT(DNDEATXT,NPIEN,DNDEAIEN,SUFFIX)
+60 IF RET
IF $PIECE(DATA,U,21)="YES"
SET FDA(200,NPIEN_",",53.2)=$PIECE(DATA,U,11)
DO UPDATE^DIE(,"FDA")
+61 IF $PIECE(RET,"^",3)
IF $GET(NPIEN)
IF $PIECE($GET(DATA),"^",10)'="INDIVIDUAL"
SET RET=RET_"^"_$$NPSFILE^XUEPCSUT(NPIEN,DATA)
FILEFMX ; -- Subroutine Exit Point
+1 QUIT
+2 ;
DNDEAGET(RET,DEA) ;
+1 IF '$DATA(^XTV(8991.9,"B",DEA))
SET RET(0)="0^DEA NOT ON FILE"
QUIT
+2 IF $DATA(^XTV(8991.9,"B",DEA))
SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DEA,0))
IF +DNDEAIEN
Begin DoDot:1
+3 KILL DNDEADAT
DO GETS^DIQ(8991.9,DNDEAIEN,"**","","DNDEADAT")
+4 KILL RET(1)
+5 SET RET(1)=""
+6 ; PROVIDER NAME
SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",1.1))_"^"
+7 ; ADDRESS 1
SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",1.2))_"^"
+8 ; ADDRESS 2
SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",1.3))_"^"
+9 ; ADDRESS 3
SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",1.4))_"^"
+10 ; CITY
SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",1.5))_"^"
+11 ;
+12 ; Special State Processing
+13 NEW XSTATE,XSTATEAB,XIP,BAC,X,Y
DO POSTAL^XIPUTIL($GET(DNDEADAT(8991.9,DNDEAIEN_",",1.7)),.XIP)
+14 SET XSTATEAB=$$GET1^DIQ(5,XIP("STATE POINTER"),1)
+15 ; STATE ABREVIATION
SET RET(1)=RET(1)_XSTATEAB_"^"
+16 SET XSTATE=$GET(XIP("STATE"))
+17 ; STATE
SET RET(1)=RET(1)_$GET(XSTATE)_"^"
+18 ;
+19 ; ZIP CODE
SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",1.7))_"^"
+20 ; ACTIVITY CODE
SET BAC=$GET(DNDEADAT(8991.9,DNDEAIEN_",",.02))
+21 ; ACTIVITY CODE
SET RET(1)=RET(1)_BAC_"^"
+22 ; TYPE
SET RET(1)=RET(1)_$PIECE($$PROVTYPE^XUEPCSUT($GET(BAC)),"^",2)_"^"
+23 ; DEA NUMBER
SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",.01))_"^"
+24 SET X=$PIECE($GET(DNDEADAT(8991.9,DNDEAIEN_",",.04)),"@")
DO ^%DT
+25 ; EXPIRATION DATE
SET RET(1)=RET(1)_$$FMTHL7^XLFDT(Y)_"^"
+26 SET X=$PIECE($GET(DNDEADAT(8991.9,DNDEAIEN_",",10.2)),"@")
DO ^%DT
+27 ; PROCESSED DATE
SET RET(1)=RET(1)_$$FMTHL7^XLFDT(Y)_"^"
+28 ; DETOX NUMBER
SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",.03))_"^"
+29 IF $GET(DNDEADAT(8991.9,DNDEAIEN_",",.07))="INDIVIDUAL"
Begin DoDot:2
+30 ; SCHEDULE II NARCOTIC
SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",2.1))_"^"
+31 ; SCHEDULE II NON-NARCOTIC
SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",2.2))_"^"
+32 ; SCHEDULE III NARCOTIC
SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",2.3))_"^"
+33 ; SCHEDULE III NON-NARCOTIC
SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",2.4))_"^"
+34 ; SCHEDULE IV
SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",2.5))_"^"
+35 ; SCHEDULE V
SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",2.6))
End DoDot:2
+36 IF $GET(DNDEADAT(8991.9,DNDEAIEN_",",.07))'="INDIVIDUAL"
Begin DoDot:2
+37 ; SCHEDULE II NARCOTIC
SET RET(1)=RET(1)_"^"
+38 ; SCHEDULE II NON-NARCOTIC
SET RET(1)=RET(1)_"^"
+39 ; SCHEDULE III NARCOTIC
SET RET(1)=RET(1)_"^"
+40 ; SCHEDULE III NON-NARCOTIC
SET RET(1)=RET(1)_"^"
+41 ; SCHEDULE IV
SET RET(1)=RET(1)_"^"
+42 ; SCHEDULE V
SET RET(1)=RET(1)_"^"
End DoDot:2
End DoDot:1
+43 SET RET(0)=RET(0)_"; OFFLINE DEA DATA IN USE"
+44 ;
