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

PSODEAU0.m

Go to the documentation of this file. 
  1. PSODEAU0 ;ALB/BI - DEA MANUAL ENTRY ;05/15/2018
  1.  ;;7.0;OUTPATIENT PHARMACY;**529,684,731**;DEC 1997;Build 18
  1.  ;External reference to sub-file NEW DEA #S (#200.5321) is supported by DBIA 7000
  1.  ;External reference to DEA BUSINESS ACTIVITY CODES file (#8991.8) is supported by DBIA 7001
  1.  ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
  1.  ;External reference to DEA NUMBERS file (#8991.6) is supported by DBIA 7015
  1.  ;References to Cache methods class.HttpResponse, class.Data, class.AtEnd, class.ReadLine() are supported by SAC exemption 20210601-01
  1.  Q
  1.  ;
  1. DETOXDUP(DEA,DETOX,DUPDEA)  ; -- Test Business Activity Code for DEXTOX (DW)
  1.  Q "" ;P731 detox/x-waiver removal
  1.  N I,NXTDET S NXTDEA=0,DUPDEA=""
  1.  I $G(DETOX)=""!($G(DEA)="") Q 0                   ; Missing required input, can't check
  1.  I '$D(^XTV(8991.9,"D",$G(DETOX))) Q 0             ; If Detox not on file, not a duplicate
  1.  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
  1.  .S DUPDEA=$O(^XTV(8991.9,"D",$G(DETOX),$G(DUPDEA)))
  1.  F  S NXTDEA=$O(^XTV(8991.9,"D",DETOX,NXTDEA)) Q:NXTDEA=""  S DUPDEA=$S($G(DUPDEA)'="":DUPDEA_","_NXTDEA,1:NXTDEA)
  1.  I $G(DUPDEA)'="" Q 1                                         ; If more than one entry on file for this Detox number, duplicate
  1.  Q 0
  1.  ;
  1. WSGET(FG,DEA) ; Function to Get the Remote DEA information, Return in FG.
  1.  ; INPUT:   DEA      ;Properly formatted DEA Number for lookup.
  1.  ;
  1.  ; OUTPUT:  FG       ;Web Service Response Global
  1.  ;
  1.  ; RETURN:  Status code with a text message.
  1.  ;          If not filled successfully a "0^Error Message" will be returned.
  1.  ;
  1.  ; VARIABLES:
  1.  N DATA      ;The body portion of the RESPONSE object.
  1.  N ERRORS    ;Errors that may be returned from the JSON to MUMPS convertion.
  1.  ; FG        ;The JSON string converted to a MUMPS global.
  1.  N REQUEST   ;The web service object.
  1.  N RESOURCE  ;Input variable for the $$GET^XOBWLIB call, in this case the DEA number.
  1.  N RESPJSON  ;Used to store the JSON response in the DATA object into a single line string.
  1.  N RESPONSE  ;The response object portion of the REQUEST object.
  1.  N SC        ;Status Code response from the $$GET^XOBWLIB call.
  1.  N SERVER    ;The web server identifier.
  1.  N SERVICE   ;The web service identifier.
  1.  N XU        ;Left over variable from the XOBWLIB processes.
  1.  N PSOERR    ;Left over variable from the XOBWLIB processes.
  1.  N PSOECODE  ;Error Code
  1.  ;
  1.  Q:$G(DEA)="" "0^No DEA Number Entered."
  1.  S SERVER="PSO DOJ/DEA WEB SERVER"
  1.  S SERVICE="PSO DOJ/DEA WEB SERVICE"
  1.  S RESOURCE=DEA
  1.  ;
  1.  ; Get an instance of the REST request object.
  1.  S REQUEST=$$GETREST^XOBWLIB(SERVICE,SERVER)
  1.  ;
  1.  ; Execute the HTTP Get method.
  1.  S SC=$$GETXOBW(REQUEST,RESOURCE,.PSOERR,.PSOECODE)
  1.  ;
  1.  ;S SC=$$GET^XOBWLIB(REQUEST,RESOURCE,.PSOERR,0)
  1.  ;I 'SC S PSOECODE=PSOERR.code
  1.  ;
  1.  ; Handle a "DEA NOT FOUND" gracefully.
  1.  I 'SC I PSOECODE=404 Q "0^DEA NUMBER NOT FOUND. Please enter a valid DEA number."
  1.  ; Handle a connection error gracefully.
  1.  I 'SC I PSOECODE=6059 Q "0^UNABLE TO ESTABLISH A CONNECTION TO "_SERVER_"^6059"
  1.  I 'SC Q "0^General Service Error"_$S($G(PSOECODE)]"":"^"_$G(PSOECODE),1:"")
  1.  ;
  1.  ; Process the response.  REQUEST(O) -> RESPONSE(0) -> DATA(S) -> RESPJSON(S)
  1.  S RESPONSE=REQUEST.HttpResponse
  1.  S DATA=RESPONSE.Data
  1.  S RESPJSON=""
  1.  ;
  1.  F  Q:DATA.AtEnd  Set RESPJSON=RESPJSON_DATA.ReadLine()
  1.  S RESPJSON=$TR(RESPJSON,$C(10),"")
  1.  I RESPJSON="" Q "0^No Data Returned."
  1.  ;
  1.  ; Decode the JSON format into a MUMPS global in FG
  1.  D DECODE^XLFJSON("RESPJSON","FG","ERRORS")
  1.  ;
  1.  ; Define LAST DOJ UPDATE DATE/TIME 
  1.  S FG("processedDate")=DT
  1.  S:'$D(FG("address2")) FG("address2")=""
  1.  ; 
  1.  ; Define the TYPE field
  1.  S FG("type")=$P($$PROVTYPE^PSODEAUT(FG("businessActivityCode")),"^",2)
  1.  ;
  1.  ; Default the businessActivitySubcode.
  1.  I $G(FG("businessActivitySubcode"))="" S FG("businessActivitySubcode")=0
  1.  ;
  1.  Q "1^Success"
  1.  ;
  1. DTXDUPIT(DEA,DETOX,NPIEN)  ; Check for DETOX # on file for another provider
  1.  N DUP,DUPDEA,DTXDEAPC,DEANXT,DUPMSG
  1.  S DUP=0,DUPMSG=0
  1.  Q:($L($G(DEA))'=9)!($G(DETOX)="")!'$G(NPIEN) 0
  1.  S DUP=$$DETOXDUP^PSODEAU0(DEA,DETOX,.DUPDEA)
  1.  I DUP,($G(DUPDEA)=DEA) Q 0
  1.  F DTXDEAPC=1:1:99 S DEANXT=$P(DUPDEA,",",DTXDEAPC) Q:DEANXT=""  D
  1.  .N PSOPROV S PSOPROV=0 F  S PSOPROV=$O(^VA(200,"PS4",DEANXT,PSOPROV)) Q:'PSOPROV  D
  1.  ..Q:PSOPROV=NPIEN
  1.  ..N PSOPRVNM S PSOPRVNM=$$GET1^DIQ(200,PSOPROV_",",.01)
  1.  ..I 'DUPMSG W !!,"DETOX NUMBER "_$G(DETOX)_" ALREADY ASSIGNED TO "_PSOPRVNM S DUPMSG=1
  1.  ..W !,"(IEN: ",PSOPROV,", DEA NUMBER: "_DEANXT_") AND CANNOT BE ASSIGNED"
  1.  ..W !," TO THIS PROVIDER."
  1.  Q DUP
  1.  ;
  1. GETXOBW(REQUEST,RESOURCE,PSOERR,PSOECODE) ; Execute the HTTP Get method.
  1.  K PSOECODE S PSOECODE=""
  1.  S SC=$$GET^XOBWLIB(REQUEST,RESOURCE,.PSOERR,0)
  1.  I 'SC S PSOECODE=PSOERR.code
  1.  Q SC