- PSOEPUT ;ALB/BI - DEA Manual Entry ;10/30/23 13:02
- ;;7.0;OUTPATIENT PHARMACY;**545,731,743**;DEC 1997;Build 24
- ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
- ;External reference to XUEPCS DATA file (#8991.6) is supported by DBIA 7015
- ;External reference to XUEPCS PSDRPH AUDIT file (#8991.7) is supported by DBIA 7016
- ;External reference to KEYS sub-file (#200.051) is supported by DBIA 7054
- 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?
- ; 15 - EXPIRATION DATE, INTERNAL FORMAT
- ;
- Q:'$G(NPIEN)
- N CNT,DNDEADAT,DNDEAIEN,FAIL,IENS,NPDEADAT,NPDEAIEN,NPSCHED,INPAT
- 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
- . I $G(DNDEADAT(8991.9,DNDEAIEN_",",.07))'="INDIVIDUAL" D
- . . K NPSCHED D GETS^DIQ(200,NPIEN_",","55.1:55.6","E","NPSCHED")
- . . S RET(CNT)=RET(CNT)_NPSCHED(200,NPIEN_",",55.1,"E")_"^" ; SCHEDULE II NARCOTIC
- . . S RET(CNT)=RET(CNT)_NPSCHED(200,NPIEN_",",55.2,"E")_"^" ; SCHEDULE II NON-NARCOTIC
- . . S RET(CNT)=RET(CNT)_NPSCHED(200,NPIEN_",",55.3,"E")_"^" ; SCHEDULE III NARCOTIC
- . . S RET(CNT)=RET(CNT)_NPSCHED(200,NPIEN_",",55.4,"E")_"^" ; SCHEDULE III NON-NARCOTIC
- . . S RET(CNT)=RET(CNT)_NPSCHED(200,NPIEN_",",55.5,"E")_"^" ; SCHEDULE IV
- . . S RET(CNT)=RET(CNT)_NPSCHED(200,NPIEN_",",55.6,"E")_"^" ; SCHEDULE V
- . I $G(DNDEADAT(8991.9,DNDEAIEN_",",.07))="INDIVIDUAL" D
- . . 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 INPAT=DNDEADAT(8991.9,DNDEAIEN_",",.06) S:INPAT'="YES" INPAT=""
- . S RET(CNT)=RET(CNT)_INPAT_"^" ; USE FOR INPATIENT ORDERS?
- . S RET(CNT)=RET(CNT)_$P(^XTV(8991.9,DNDEAIEN,0),"^",4) ; EXPIRATION DATE - INTERNAL
- Q
- ;
- DEADOJ(RET,DEA) ; -- RPC to return DEA Information for a single DEA Number
- ; INPUT: DEA - PROPERLY FORMATTED DEA NUMBER
- ;
- ; OUTPUT: RET - 1^A STRING OF DEA INFORMATION DELIMITED BY THE "^"
- ; 1 - PROVIDER NAME
- ; 2 - ADDRESS 1
- ; 3 - ADDRESS 2
- ; 4 - ADDRESS 3
- ; 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
- ;
- ; OUTPUT WITH AN ERROR: RET - 0^ERROR NUMBER^ERROR TEXT
- ; 0^1^Missing DEA Number
- ; 0^2^Invalid DEA Number due to error in first letter
- ; 0^3^Invalid DEA Number due to error in second letter
- ; 0^4^Invalid DEA Number due to error in the numbers
- ; 0^5^DEA Number not found. Please enter the provider's DEA number.
- ; 0^6^Unable to Connect to PSO DOJ/DEA Web Service.
- ; If you continue, the DEA information will not be checked against DOJ DEA source data.
- ; 0^7^DEA number not on file
- ;
- N FG,NAME,NPIEN,VALUE,DS,BAC,SC
- I $G(DEA)="" S RET(0)="0^1^Missing DEA Number" Q
- I '$$DEANUMFL(DEA) S RET(0)="0^2^Invalid DEA Number due to error in first letter" Q
- I '$$DEANUMF2(DEA) S RET(0)="0^3^Invalid DEA Number due to error in second letter" Q
- I '$$DEANUM(DEA) S RET(0)="0^4^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^5^DEA Number not found. Please enter the provider's DEA number." Q
- I 'SC D D DNDEAGET^PSOEPU1(.RET,DEA) Q
- . S RET(0)="0^6^Unable to Connect to PSO DOJ/DEA Web Service."
- . S RET(0)=RET(0)_" If you continue, the DEA information will not be checked against DOJ DEA source data."
- ;
- S RET(1)=""
- S RET(1)=RET(1)_$G(FG("name"))_"^" ; PROVIDER NAME
- 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("address3"))_"^" ; ADDRESS 3
- 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
- N RETURN S RETURN=""
- D DELMULT^PSOEPUT2(.RETURN,NPIEN,DEATXT)
- D SETINP^PSOEPU1(NPIEN)
- S RET=RETURN
- I $L($G(DEATXT)) D
- . N NPDEA S NPDEA=$$GET1^DIQ(200,+$G(NPIEN),53.2) Q:NPDEA=""
- . I (NPDEA=DEATXT)!('$O(^VA(200,+$G(NPIEN),"PS4",0))) K DIE,DA,DR,X S DIE="^VA(200,",DA=NPIEN,DR="53.2///@" D ^DIE K DIE,DR,DA
- 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("address1"))
- S GETS(1.3)=$G(FG("address2"))
- S GETS(1.4)=$G(FG("address3"))
- 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
- ; Invoked by RPC: XU EPCS ADD DEA
- D FILEFM^PSOEPU1(.RET,.DATA,NPIEN)
- 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 IN NPFILE."
- D SETINP2^PSOEPU1(NPIEN,+IEN)
- Q "1^SUCCESSFULLY SAVED/UPDATED IN 200"
- ;
- NPSFILE(NPIEN,DATA) ; -- File the DEA institutional schedules in the NEW PERSON FILE #200.
- N FDA,IENROOT,MSGROOT
- Q:'$G(NPIEN)
- S FDA(3,200,NPIEN_",",55.1)=$E($P(DATA,U,15),1) ; 15 - SCHEDULE II NARCOTIC
- S FDA(3,200,NPIEN_",",55.2)=$E($P(DATA,U,16),1) ; 16 - SCHEDULE II NON-NARCOTIC
- S FDA(3,200,NPIEN_",",55.3)=$E($P(DATA,U,17),1) ; 17 - SCHEDULE III NARCOTIC
- S FDA(3,200,NPIEN_",",55.4)=$E($P(DATA,U,18),1) ; 18 - SCHEDULE III NON-NARCOTIC
- S FDA(3,200,NPIEN_",",55.5)=$E($P(DATA,U,19),1) ; 19 - SCHEDULE IV
- S FDA(3,200,NPIEN_",",55.6)=$E($P(DATA,U,20),1) ; 20 - SCHEDULE V
- D UPDATE^DIE("E","FDA(3)","IENROOT","MSGROOT")
- I $D(MSGROOT) Q "0^DATA DIDN'T FILE SUCCESSFULLY IN NPSFILE."
- Q "1^SCHEDULES 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("address1")="ADDRESS 1"
- S CN("address2")="ADDRESS 2"
- S CN("address3")="ADDRESS 3"
- 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)
- ;
- DEANUMF2(X) ;Check DEA # First Letter Part
- Q $S("ABCDEFGHIJKLMNOPQRSTUVWXYZ"[$E(X):2,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
- N NPIEN,DA,NPNAME
- 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)) D
- . S NPIEN=0 S NPIEN=$O(^VA(200,"PS4",DEATXT,NPIEN)) Q:NPIEN=""
- . S NPNAME=$$GET1^DIQ(200,NPIEN_",",.01)
- . S RET="0^Provider DEA number is already associated to another profile: "_NPIEN_", "_NPNAME_". Please check the number entered." Q
- I SUFFIX'="",$D(^VA(200,"F",DEATXT,SUFFIX)) D
- . 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
- ;
- MBM(RET) ; -- MEDS BY MAIL for ePCS GUI
- N SYS
- S RET=0
- S SYS=$$GET1^DIQ(59.7,1,102,"I")
- 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
- SET FDA(8991.6,"+1,",.07)=$P(LINE,U,6)
- DO UPDATE^DIE("E","FDA","IEN","MSG")
- QUIT
- ;
- CLEARDTX(NPIEN) ; REMOVE DETOX NUMBERS FROM ALL OF A PROVIDERS DEA NUMBERS
- Q "" ;P731 detox/x-waiver removal
- 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) ; 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=""
- 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)
- 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.
- ;
- ; 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 $$WSGET^PSOEPU1(.FG,DEA)
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOEPUT 17434 printed Feb 18, 2025@23:54:02 Page 2
- PSOEPUT ;ALB/BI - DEA Manual Entry ;10/30/23 13:02
- +1 ;;7.0;OUTPATIENT PHARMACY;**545,731,743**;DEC 1997;Build 24
- +2 ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
- +3 ;External reference to XUEPCS DATA file (#8991.6) is supported by DBIA 7015
- +4 ;External reference to XUEPCS PSDRPH AUDIT file (#8991.7) is supported by DBIA 7016
- +5 ;External reference to KEYS sub-file (#200.051) is supported by DBIA 7054
- +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 ; 15 - EXPIRATION DATE, INTERNAL FORMAT
- +19 ;
- +20 if '$GET(NPIEN)
- QUIT
- +21 NEW CNT,DNDEADAT,DNDEAIEN,FAIL,IENS,NPDEADAT,NPDEAIEN,NPSCHED,INPAT
- +22 SET NPDEAIEN=0
- FOR CNT=1:1
- SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
- if '+NPDEAIEN
- QUIT
- Begin DoDot:1
- +23 SET IENS=NPDEAIEN_","_NPIEN_","
- +24 KILL NPDEADAT
- DO GETS^DIQ(200.5321,IENS,"**","","NPDEADAT")
- if '$DATA(NPDEADAT)
- QUIT
- +25 SET DNDEAIEN=$$GET1^DIQ(200.5321,IENS,.03,"I")
- if 'DNDEAIEN
- QUIT
- +26 KILL DNDEADAT
- DO GETS^DIQ(8991.9,DNDEAIEN,"**","","DNDEADAT")
- if '$DATA(DNDEADAT)
- QUIT
- +27 ;
- +28 SET RET(CNT)=""
- +29 ; NEW PERSON DEA NUMBER
- SET RET(CNT)=RET(CNT)_NPDEADAT(200.5321,IENS,.01)_"^"
- +30 ; INDIVIDUAL DEA SUFFIX
- SET RET(CNT)=RET(CNT)_NPDEADAT(200.5321,IENS,.02)_"^"
- +31 ; STATE
- SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",1.6)_"^"
- +32 ; DETOX NUMBER ;P731 detox/x-waiver removal
- SET RET(CNT)=RET(CNT)_""_"^"
- +33 ; EXPIRATION DATE
- SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",.04)_"^"
- +34 ; NEW PERSON IENS
- SET RET(CNT)=RET(CNT)_IENS_"^"
- +35 ; DEA NUMBERS IEN
- SET RET(CNT)=RET(CNT)_DNDEAIEN_"^"
- +36 IF $GET(DNDEADAT(8991.9,DNDEAIEN_",",.07))'="INDIVIDUAL"
- Begin DoDot:2
- +37 KILL NPSCHED
- DO GETS^DIQ(200,NPIEN_",","55.1:55.6","E","NPSCHED")
- +38 ; SCHEDULE II NARCOTIC
- SET RET(CNT)=RET(CNT)_NPSCHED(200,NPIEN_",",55.1,"E")_"^"
- +39 ; SCHEDULE II NON-NARCOTIC
- SET RET(CNT)=RET(CNT)_NPSCHED(200,NPIEN_",",55.2,"E")_"^"
- +40 ; SCHEDULE III NARCOTIC
- SET RET(CNT)=RET(CNT)_NPSCHED(200,NPIEN_",",55.3,"E")_"^"
- +41 ; SCHEDULE III NON-NARCOTIC
- SET RET(CNT)=RET(CNT)_NPSCHED(200,NPIEN_",",55.4,"E")_"^"
- +42 ; SCHEDULE IV
- SET RET(CNT)=RET(CNT)_NPSCHED(200,NPIEN_",",55.5,"E")_"^"
- +43 ; SCHEDULE V
- SET RET(CNT)=RET(CNT)_NPSCHED(200,NPIEN_",",55.6,"E")_"^"
- End DoDot:2
- +44 IF $GET(DNDEADAT(8991.9,DNDEAIEN_",",.07))="INDIVIDUAL"
- Begin DoDot:2
- +45 ; SCHEDULE II NARCOTIC
- SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.1)_"^"
- +46 ; SCHEDULE II NON-NARCOTIC
- SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.2)_"^"
- +47 ; SCHEDULE III NARCOTIC
- SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.3)_"^"
- +48 ; SCHEDULE III NON-NARCOTIC
- SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.4)_"^"
- +49 ; SCHEDULE IV
- SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.5)_"^"
- +50 ; SCHEDULE V
- SET RET(CNT)=RET(CNT)_DNDEADAT(8991.9,DNDEAIEN_",",2.6)_"^"
- End DoDot:2
- +51 SET INPAT=DNDEADAT(8991.9,DNDEAIEN_",",.06)
- if INPAT'="YES"
- SET INPAT=""
- +52 ; USE FOR INPATIENT ORDERS?
- SET RET(CNT)=RET(CNT)_INPAT_"^"
- +53 ; EXPIRATION DATE - INTERNAL
- SET RET(CNT)=RET(CNT)_$PIECE(^XTV(8991.9,DNDEAIEN,0),"^",4)
- End DoDot:1
- +54 QUIT
- +55 ;
- DEADOJ(RET,DEA) ; -- RPC to return DEA Information for a single DEA Number
- +1 ; INPUT: DEA - PROPERLY FORMATTED DEA NUMBER
- +2 ;
- +3 ; OUTPUT: RET - 1^A STRING OF DEA INFORMATION DELIMITED BY THE "^"
- +4 ; 1 - PROVIDER NAME
- +5 ; 2 - ADDRESS 1
- +6 ; 3 - ADDRESS 2
- +7 ; 4 - ADDRESS 3
- +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 ; OUTPUT WITH AN ERROR: RET - 0^ERROR NUMBER^ERROR TEXT
- +26 ; 0^1^Missing DEA Number
- +27 ; 0^2^Invalid DEA Number due to error in first letter
- +28 ; 0^3^Invalid DEA Number due to error in second letter
- +29 ; 0^4^Invalid DEA Number due to error in the numbers
- +30 ; 0^5^DEA Number not found. Please enter the provider's DEA number.
- +31 ; 0^6^Unable to Connect to PSO DOJ/DEA Web Service.
- +32 ; If you continue, the DEA information will not be checked against DOJ DEA source data.
- +33 ; 0^7^DEA number not on file
- +34 ;
- +35 NEW FG,NAME,NPIEN,VALUE,DS,BAC,SC
- +36 IF $GET(DEA)=""
- SET RET(0)="0^1^Missing DEA Number"
- QUIT
- +37 IF '$$DEANUMFL(DEA)
- SET RET(0)="0^2^Invalid DEA Number due to error in first letter"
- QUIT
- +38 IF '$$DEANUMF2(DEA)
- SET RET(0)="0^3^Invalid DEA Number due to error in second letter"
- QUIT
- +39 IF '$$DEANUM(DEA)
- SET RET(0)="0^4^Invalid DEA Number due to error in the numbers"
- QUIT
- +40 SET SC=$$WSGET(.FG,DEA)
- +41 IF $PIECE($PIECE(SC,"^",2),".",1)="DEA NUMBER NOT FOUND"
- SET RET(0)="0^5^DEA Number not found. Please enter the provider's DEA number."
- QUIT
- +42 IF 'SC
- Begin DoDot:1
- +43 SET RET(0)="0^6^Unable to Connect to PSO DOJ/DEA Web Service."
- +44 SET RET(0)=RET(0)_" If you continue, the DEA information will not be checked against DOJ DEA source data."
- End DoDot:1
- DO DNDEAGET^PSOEPU1(.RET,DEA)
- QUIT
- +45 ;
- +46 SET RET(1)=""
- +47 ; PROVIDER NAME
- SET RET(1)=RET(1)_$GET(FG("name"))_"^"
- +48 ; ADDRESS 1
- SET RET(1)=RET(1)_$GET(FG("address1"))_"^"
- +49 ; ADDRESS 2
- SET RET(1)=RET(1)_$GET(FG("address2"))_"^"
- +50 ; ADDRESS 3
- SET RET(1)=RET(1)_$GET(FG("address3"))_"^"
- +51 ; CITY
- SET RET(1)=RET(1)_$GET(FG("city"))_"^"
- +52 ;
- +53 ; Special State Processing
- +54 ; STATE
- SET RET(1)=RET(1)_$GET(FG("state"))_"^"
- +55 NEW XSTATE,XIP
- DO POSTAL^XIPUTIL($GET(FG("zipCode")),.XIP)
- SET XSTATE=$GET(XIP("STATE"))
- +56 ; STATE POINTER
- SET RET(1)=RET(1)_$GET(XSTATE)_"^"
- +57 ;
- +58 ; ZIP CODE
- SET RET(1)=RET(1)_$GET(FG("zipCode"))_"^"
- +59 SET BAC=$GET(FG("businessActivityCode"))_$GET(FG("businessActivitySubcode"))
- +60 ; ACTIVITY CODE
- SET RET(1)=RET(1)_BAC_"^"
- +61 ; TYPE
- SET RET(1)=RET(1)_$PIECE($$PROVTYPE($GET(FG("businessActivityCode"))),"^",2)_"^"
- +62 ; DEA NUMBER
- SET RET(1)=RET(1)_$GET(FG("deaNumber"))_"^"
- +63 ; EXPIRATION DATE
- SET RET(1)=RET(1)_$GET(FG("expirationDate"))_"^"
- +64 ; PROCESSED DATE
- SET RET(1)=RET(1)_$GET(FG("processedDate"))_"^"
- +65 ;
- +66 SET DS=$GET(FG("drugSchedule"))
- +67 SET NPIEN=$ORDER(^VA(200,"PS4",DEA,0))
- +68 ; DETOX NUMBER
- SET RET(1)=RET(1)_$SELECT($$DETOXCHK^PSODEAUT(BAC):"X"_$EXTRACT(FG("deaNumber"),2,9),1:"")_"^"
- +69 ; SCHEDULE II NARCOTIC
- SET RET(1)=RET(1)_$SELECT(DS["22N":"YES",(DS["2"&(DS'["2N")):"YES",1:"NO")_"^"
- +70 ; SCHEDULE II NON-NARCOTIC
- SET RET(1)=RET(1)_$SELECT(DS["2N":"YES",1:"NO")_"^"
- +71 ; SCHEDULE III NARCOTIC
- SET RET(1)=RET(1)_$SELECT(DS["33N":"YES",DS["3"&(DS'["3N"):"YES",1:"NO")_"^"
- +72 ; SCHEDULE III NON-NARCOTIC
- SET RET(1)=RET(1)_$SELECT(DS["3N":"YES",1:"NO")_"^"
- +73 ; SCHEDULE IV
- SET RET(1)=RET(1)_$SELECT(DS["4":"YES",1:"NO")_"^"
- +74 ; SCHEDULE V
- SET RET(1)=RET(1)_$SELECT(DS["5":"YES",1:"NO")
- +75 SET RET(0)="1^SUCCESS"
- +76 QUIT
- +77 ;
- DEAREM(RET,NPIEN,DEATXT) ; Functionality to remove a DEA multiple from file #200, Field 53.21
- +1 NEW RETURN
- SET RETURN=""
- +2 DO DELMULT^PSOEPUT2(.RETURN,NPIEN,DEATXT)
- +3 DO SETINP^PSOEPU1(NPIEN)
- +4 SET RET=RETURN
- +5 IF $LENGTH($GET(DEATXT))
- Begin DoDot:1
- +6 NEW NPDEA
- SET NPDEA=$$GET1^DIQ(200,+$GET(NPIEN),53.2)
- if NPDEA=""
- QUIT
- +7 IF (NPDEA=DEATXT)!('$ORDER(^VA(200,+$GET(NPIEN),"PS4",0)))
- KILL DIE,DA,DR,X
- SET DIE="^VA(200,"
- SET DA=NPIEN
- SET DR="53.2///@"
- DO ^DIE
- KILL DIE,DR,DA
- End DoDot:1
- +8 QUIT
- +9 ;
- 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("address1"))
- +22 SET GETS(1.3)=$GET(FG("address2"))
- +23 SET GETS(1.4)=$GET(FG("address3"))
- +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 ; Invoked by RPC: XU EPCS ADD DEA
- +2 DO FILEFM^PSOEPU1(.RET,.DATA,NPIEN)
- +3 QUIT
- +4 ;
- 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 IN NPFILE."
- +10 DO SETINP2^PSOEPU1(NPIEN,+IEN)
- +11 QUIT "1^SUCCESSFULLY SAVED/UPDATED IN 200"
- +12 ;
- NPSFILE(NPIEN,DATA) ; -- File the DEA institutional schedules in the NEW PERSON FILE #200.
- +1 NEW FDA,IENROOT,MSGROOT
- +2 if '$GET(NPIEN)
- QUIT
- +3 ; 15 - SCHEDULE II NARCOTIC
- SET FDA(3,200,NPIEN_",",55.1)=$EXTRACT($PIECE(DATA,U,15),1)
- +4 ; 16 - SCHEDULE II NON-NARCOTIC
- SET FDA(3,200,NPIEN_",",55.2)=$EXTRACT($PIECE(DATA,U,16),1)
- +5 ; 17 - SCHEDULE III NARCOTIC
- SET FDA(3,200,NPIEN_",",55.3)=$EXTRACT($PIECE(DATA,U,17),1)
- +6 ; 18 - SCHEDULE III NON-NARCOTIC
- SET FDA(3,200,NPIEN_",",55.4)=$EXTRACT($PIECE(DATA,U,18),1)
- +7 ; 19 - SCHEDULE IV
- SET FDA(3,200,NPIEN_",",55.5)=$EXTRACT($PIECE(DATA,U,19),1)
- +8 ; 20 - SCHEDULE V
- SET FDA(3,200,NPIEN_",",55.6)=$EXTRACT($PIECE(DATA,U,20),1)
- +9 DO UPDATE^DIE("E","FDA(3)","IENROOT","MSGROOT")
- +10 IF $DATA(MSGROOT)
- QUIT "0^DATA DIDN'T FILE SUCCESSFULLY IN NPSFILE."
- +11 QUIT "1^SCHEDULES SUCCESSFULLY SAVED/UPDATED IN 200"
- +12 ;
- 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("address1")="ADDRESS 1"
- +2 SET CN("address2")="ADDRESS 2"
- +3 SET CN("address3")="ADDRESS 3"
- +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 ;
- DEANUMF2(X) ;Check DEA # First Letter Part
- +1 QUIT $SELECT("ABCDEFGHIJKLMNOPQRSTUVWXYZ"[$EXTRACT(X):2,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 NEW NPIEN,DA,NPNAME
- +4 IF $GET(DEATXT)=""
- SET RET="0^No DEA number supplied"
- QUIT
- +5 SET SUFFIX=$GET(SUFFIX)
- +6 SET RET="1^Success"
- +7 IF SUFFIX=""
- IF $DATA(^VA(200,"PS4",DEATXT))
- Begin DoDot:1
- +8 SET NPIEN=0
- SET NPIEN=$ORDER(^VA(200,"PS4",DEATXT,NPIEN))
- if NPIEN=""
- QUIT
- +9 SET NPNAME=$$GET1^DIQ(200,NPIEN_",",.01)
- +10 SET RET="0^Provider DEA number is already associated to another profile: "_NPIEN_", "_NPNAME_". Please check the number entered."
- QUIT
- End DoDot:1
- +11 IF SUFFIX'=""
- IF $DATA(^VA(200,"F",DEATXT,SUFFIX))
- Begin DoDot:1
- +12 SET RET="0^Duplicate Usage of a SUFFIX"
- QUIT
- End DoDot:1
- +13 QUIT
- +14 ;
- 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 ;
- MBM(RET) ; -- MEDS BY MAIL for ePCS GUI
- +1 NEW SYS
- +2 SET RET=0
- +3 SET SYS=$$GET1^DIQ(59.7,1,102,"I")
- +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 SET FDA(8991.6,"+1,",.07)=$PIECE(LINE,U,6)
- +5 DO UPDATE^DIE("E","FDA","IEN","MSG")
- +6 QUIT
- +7 ;
- CLEARDTX(NPIEN) ; REMOVE DETOX NUMBERS FROM ALL OF A PROVIDERS DEA NUMBERS
- +1 ;P731 detox/x-waiver removal
- QUIT ""
- +2 NEW DNDEAIEN,FDA,NPDEAIEN
- +3 SET NPDEAIEN=0
- FOR
- SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
- if 'NPDEAIEN
- QUIT
- Begin DoDot:1
- +4 SET DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
- +5 KILL FDA
- SET FDA(1,8991.9,DNDEAIEN_",",.03)="@"
- DO UPDATE^DIE("","FDA(1)")
- KILL FDA
- End DoDot:1
- +6 QUIT
- +7 ;
- GETDNDTX(NPIEN) ; 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 SET NPDEAIEN=0
- FOR
- SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
- if 'NPDEAIEN
- QUIT
- if $LENGTH(GETDNDTX)
- QUIT
- Begin DoDot:1
- +4 SET DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
- if 'DNDEAIEN
- QUIT
- +5 SET GETDNDTX=$$GET1^DIQ(8991.9,DNDEAIEN_",",.03)
- End DoDot:1
- +6 QUIT GETDNDTX
- +7 ;
- 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 QUIT $$WSGET^PSOEPU1(.FG,DEA)
- +23 ;