Routine: XUEPCSU1

XUEPCSU1 ;ALB/BI - DEA Manual Entry ;05/15/2018

 ;;8.0;KERNEL;**689**;Jul 10, 1995;Build 113

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

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  Mar 13, 2025@21:14:15                                                                                                                                                                                                    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      ;

XUEPCSU1.m