PSODEAU0 ;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
;References to Cache methods class.HttpResponse, class.Data, class.AtEnd, class.ReadLine() are supported by SAC exemption 20210601-01
Q
;
DETOXDUP(DEA,DETOX,DUPDEA) ; -- Test Business Activity Code for DEXTOX (DW)
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
;
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.
N PSOECODE ;Error Code
;
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=$$GETXOBW(REQUEST,RESOURCE,.PSOERR,.PSOECODE)
;
;S SC=$$GET^XOBWLIB(REQUEST,RESOURCE,.PSOERR,0)
;I 'SC S PSOECODE=PSOERR.code
;
; Handle a "DEA NOT FOUND" gracefully.
I 'SC I PSOECODE=404 Q "0^DEA NUMBER NOT FOUND. Please enter a valid DEA number."
; Handle a connection error gracefully.
I 'SC I PSOECODE=6059 Q "0^UNABLE TO ESTABLISH A CONNECTION TO "_SERVER_"^6059"
I 'SC Q "0^General Service Error"_$S($G(PSOECODE)]"":"^"_$G(PSOECODE),1:"")
;
; 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")
;
; Define LAST DOJ UPDATE DATE/TIME
S FG("processedDate")=DT
S:'$D(FG("address2")) FG("address2")=""
;
; 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"
;
DTXDUPIT(DEA,DETOX,NPIEN) ; Check for DETOX # on file for another provider
N DUP,DUPDEA,DTXDEAPC,DEANXT,DUPMSG
S DUP=0,DUPMSG=0
Q:($L($G(DEA))'=9)!($G(DETOX)="")!'$G(NPIEN) 0
S DUP=$$DETOXDUP^PSODEAU0(DEA,DETOX,.DUPDEA)
I DUP,($G(DUPDEA)=DEA) Q 0
F DTXDEAPC=1:1:99 S DEANXT=$P(DUPDEA,",",DTXDEAPC) Q:DEANXT="" D
.N PSOPROV S PSOPROV=0 F S PSOPROV=$O(^VA(200,"PS4",DEANXT,PSOPROV)) Q:'PSOPROV D
..Q:PSOPROV=NPIEN
..N PSOPRVNM S PSOPRVNM=$$GET1^DIQ(200,PSOPROV_",",.01)
..I 'DUPMSG W !!,"DETOX NUMBER "_$G(DETOX)_" ALREADY ASSIGNED TO "_PSOPRVNM S DUPMSG=1
..W !,"(IEN: ",PSOPROV,", DEA NUMBER: "_DEANXT_") AND CANNOT BE ASSIGNED"
..W !," TO THIS PROVIDER."
Q DUP
;
GETXOBW(REQUEST,RESOURCE,PSOERR,PSOECODE) ; Execute the HTTP Get method.
K PSOECODE S PSOECODE=""
S SC=$$GET^XOBWLIB(REQUEST,RESOURCE,.PSOERR,0)
I 'SC S PSOECODE=PSOERR.code
Q SC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODEAU0 4857 printed Dec 13, 2024@02:26:45 Page 2
PSODEAU0 ;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 ;References to Cache methods class.HttpResponse, class.Data, class.AtEnd, class.ReadLine() are supported by SAC exemption 20210601-01
+7 QUIT
+8 ;
DETOXDUP(DEA,DETOX,DUPDEA) ; -- Test Business Activity Code for DEXTOX (DW)
+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 ;
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 ;Error Code
NEW PSOECODE
+22 ;
+23 if $GET(DEA)=""
QUIT "0^No DEA Number Entered."
+24 SET SERVER="PSO DOJ/DEA WEB SERVER"
+25 SET SERVICE="PSO DOJ/DEA WEB SERVICE"
+26 SET RESOURCE=DEA
+27 ;
+28 ; Get an instance of the REST request object.
+29 SET REQUEST=$$GETREST^XOBWLIB(SERVICE,SERVER)
+30 ;
+31 ; Execute the HTTP Get method.
+32 SET SC=$$GETXOBW(REQUEST,RESOURCE,.PSOERR,.PSOECODE)
+33 ;
+34 ;S SC=$$GET^XOBWLIB(REQUEST,RESOURCE,.PSOERR,0)
+35 ;I 'SC S PSOECODE=PSOERR.code
+36 ;
+37 ; Handle a "DEA NOT FOUND" gracefully.
+38 IF 'SC
IF PSOECODE=404
QUIT "0^DEA NUMBER NOT FOUND. Please enter a valid DEA number."
+39 ; Handle a connection error gracefully.
+40 IF 'SC
IF PSOECODE=6059
QUIT "0^UNABLE TO ESTABLISH A CONNECTION TO "_SERVER_"^6059"
+41 IF 'SC
QUIT "0^General Service Error"_$SELECT($GET(PSOECODE)]"":"^"_$GET(PSOECODE),1:"")
+42 ;
+43 ; Process the response. REQUEST(O) -> RESPONSE(0) -> DATA(S) -> RESPJSON(S)
+44 SET RESPONSE=REQUEST.HttpResponse
+45 SET DATA=RESPONSE.Data
+46 SET RESPJSON=""
+47 ;
+48 FOR
if DATA.AtEnd
QUIT
SET RESPJSON=RESPJSON_DATA.ReadLine()
+49 SET RESPJSON=$TRANSLATE(RESPJSON,$CHAR(10),"")
+50 IF RESPJSON=""
QUIT "0^No Data Returned."
+51 ;
+52 ; Decode the JSON format into a MUMPS global in FG
+53 DO DECODE^XLFJSON("RESPJSON","FG","ERRORS")
+54 ;
+55 ; Define LAST DOJ UPDATE DATE/TIME
+56 SET FG("processedDate")=DT
+57 if '$DATA(FG("address2"))
SET FG("address2")=""
+58 ;
+59 ; Define the TYPE field
+60 SET FG("type")=$PIECE($$PROVTYPE^PSODEAUT(FG("businessActivityCode")),"^",2)
+61 ;
+62 ; Default the businessActivitySubcode.
+63 IF $GET(FG("businessActivitySubcode"))=""
SET FG("businessActivitySubcode")=0
+64 ;
+65 QUIT "1^Success"
+66 ;
DTXDUPIT(DEA,DETOX,NPIEN) ; Check for DETOX # on file for another provider
+1 NEW DUP,DUPDEA,DTXDEAPC,DEANXT,DUPMSG
+2 SET DUP=0
SET DUPMSG=0
+3 if ($LENGTH($GET(DEA))'=9)!($GET(DETOX)="")!'$GET(NPIEN)
QUIT 0
+4 SET DUP=$$DETOXDUP^PSODEAU0(DEA,DETOX,.DUPDEA)
+5 IF DUP
IF ($GET(DUPDEA)=DEA)
QUIT 0
+6 FOR DTXDEAPC=1:1:99
SET DEANXT=$PIECE(DUPDEA,",",DTXDEAPC)
if DEANXT=""
QUIT
Begin DoDot:1
+7 NEW PSOPROV
SET PSOPROV=0
FOR
SET PSOPROV=$ORDER(^VA(200,"PS4",DEANXT,PSOPROV))
if 'PSOPROV
QUIT
Begin DoDot:2
+8 if PSOPROV=NPIEN
QUIT
+9 NEW PSOPRVNM
SET PSOPRVNM=$$GET1^DIQ(200,PSOPROV_",",.01)
+10 IF 'DUPMSG
WRITE !!,"DETOX NUMBER "_$GET(DETOX)_" ALREADY ASSIGNED TO "_PSOPRVNM
SET DUPMSG=1
+11 WRITE !,"(IEN: ",PSOPROV,", DEA NUMBER: "_DEANXT_") AND CANNOT BE ASSIGNED"
+12 WRITE !," TO THIS PROVIDER."
End DoDot:2
End DoDot:1
+13 QUIT DUP
+14 ;
GETXOBW(REQUEST,RESOURCE,PSOERR,PSOECODE) ; Execute the HTTP Get method.
+1 KILL PSOECODE
SET PSOECODE=""
+2 SET SC=$$GET^XOBWLIB(REQUEST,RESOURCE,.PSOERR,0)
+3 IF 'SC
SET PSOECODE=PSOERR.code
+4 QUIT SC
