PSODEAME ;ALB/BI - DEA MANUAL ENTRY ;05/15/2018
;;7.0;OUTPATIENT PHARMACY;**545,731**;DEC 1997;Build 18
;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
;External reference to sub-file NEW DEA #S (#200.5321) is supported by DBIA 7000
Q
;
EN(DEATXT,PSOWSDWN) ; -- main entry point for PSO DEA NUMBER MANAGEMENT
N CN,FG,RESPONSE,SC,FG,GETS,DNDEAIEN,POP,VALMBCK,VALMCNT,VALMSG,DTRESULT
N ASTRSK S $P(ASTRSK,"*",75)="*"
D CONVNAME^PSODEAUT(.CN)
S DNDEAIEN=$O(^XTV(8991.9,"B",DEATXT,0))
S RESPONSE=0
I '$G(PSOWSDWN) S SC=$$WSGET^PSODEAUT(.FG,DEATXT)
I $P($G(SC),U,3)=6059 S PSOWSDWN=1
I $G(PSOWSDWN) S RESPONSE=0 D Q RESPONSE
.S SC="0^Unable to Connect to Server^6059"
.S RESPONSE=SC
.S DNDEAIEN=$O(^XTV(8991.9,"B",DEATXT,0))
.N DIR S DIR("A",1)=" "_$E(ASTRSK,1,60)
.S DIR("A",2)=" Unable to Connect to PSO DOJ/DEA Web Service"
.S DIR("A",3)=" "_$E(ASTRSK,1,60),DIR("A",4)=" "
.S DIR("A",5)=" If you continue, the DEA information entered "
.S DIR("A",6)=" will not be checked against DOJ DEA source data."
.S DIR(0)="Y",DIR("A")="Continue without Web Service",DIR("B")="NO" D ^DIR
.Q:'Y
.W !,"DEA NUMBER: "_$G(DEATXT)
.D MANLOAD(DUZ,DEATXT,.GETS,.FG)
.D ACTIONE,ACTIONA
.S DNDEAIEN=$O(^XTV(8991.9,"B",DEATXT,0)) S:DNDEAIEN RESPONSE=DNDEAIEN
I 'SC S RESPONSE=SC W !!," ***"_$P(RESPONSE,U,2)_"***" G ENX
I $G(FG("type"))="INSTITUTIONAL" D
.; PREFINST = flag to indicate an automatic update of INSTITUTIONAL DEA in File 8991.9
.S DNDEAIEN=$O(^XTV(8991.9,"B",DEATXT,0)) Q:'DNDEAIEN ; Only auto-update previously filed institutional DEA's
.N PREFINST S PREFINST=1
.D DEACOPY(.FG)
.D ACTIONA
.D LSCHED(.GETS) ; Get Local Schedules if Institutional DEA
D EN^VALM("PSO DEA NUMBER MANAGEMENT")
ENX ; -- Cleanup and Exit
S DNDEAIEN=$O(^XTV(8991.9,"B",DEATXT,0)) S:DNDEAIEN RESPONSE=DNDEAIEN
Q RESPONSE
;
HDR ; -- header code
;S VALMHDR(1)="Asterisks ""**"" next to fields in the DOJ column indicate the local value"
;S VALMHDR(2)="value has been changed and no longer matches the value in the DOJ file"
S VALMHDR(1)="The asterisks ""**"" next to fields in the DOJ column indicate that the local"
S VALMHDR(2)="value has been changed and does not match the value stored in the DOJ file."
S VALMHDR(3)=""
Q
;
INIT ; -- Build the List Array
D INIT^PSODEAED
Q
;
HELP ; -- help code
N X
S X="?" D DISP^XQORM1 W !!
W !,"Asterisks ""**"" indicate the DOJ value does not match the local VistA value",!
S VALMBCK="R"
Q
;
EXIT ; -- exit code
Q
;
EXPND ; -- expand code
Q
;
ACTIONA ; -- Perform Action A: ACCEPT AND SAVE CHANGES
N FDA ; FileMan Data Array used to insert data into file #8991.9
N DNDEAIEN ; The IEN for the entry in the DEA NUMBERS FILE #8991.9
N IENROOT ; Variable for the IEN being returned from the ^DIE call.
N IENS ; ENTRY IEN VALUE
N MSGROOT ; Message Root for the error messages from the ^DIE call.
I '$D(GETS) S VALMSG="NOTHING TO SAVE",VALMBCK="R" Q
I '$$FIND1^DIC(8991.8,,,GETS(.02)) D
.Q:$D(^XTV(8991.8,"B",GETS(.02))) ; Don't file duplicate BAC
.N FDA,BACERR S FDA(8991.8,"+1,",.01)=GETS(.02)
.S FDA(8991.8,"+1,",.02)=$E(GETS(.02))
.S FDA(8991.8,"+1,",.03)=$E(GETS(.02),2,4)
.D UPDATE^DIE("E","FDA",,"BACERR")
S:$G(GETS(.01))'="" DNDEAIEN=$O(^XTV(8991.9,"B",GETS(.01),0))
S IENS=$S($G(DNDEAIEN):$G(DNDEAIEN)_",",1:"+1,")
; Pre-file INSTITUTIONAL DEA without ListMan
; File INDIVIDUAL DEA when service is down without ListMan
I '$G(PREFINST)&'$G(PSOWSDWN) D FULL^VALM1,CLEAN^VALM10
S FDA(1,8991.9,IENS,1.1)=GETS(1.1) ; NAME
S FDA(1,8991.9,IENS,1.2)=GETS(1.2) ; ADDRESS 1
S FDA(1,8991.9,IENS,1.3)=GETS(1.3) ; ADDRESS 2
S FDA(1,8991.9,IENS,1.4)=GETS(1.4) ; ADDRESS 3
S FDA(1,8991.9,IENS,1.5)=GETS(1.5) ; CITY
S FDA(1,8991.9,IENS,1.6)=GETS(1.6) ; STATE
S FDA(1,8991.9,IENS,1.7)=GETS(1.7) ; ZIP CODE
S FDA(1,8991.9,IENS,.02)=GETS(.02) ; BUSINESS ACTIVITY CODE AND SUBCODE
S FDA(1,8991.9,IENS,.07)=GETS(.07) ; TYPE
S FDA(1,8991.9,IENS,.01)=GETS(.01) ; DEA NUMBER
I GETS(.03)'="" D CLEARDTX(NPIEN) ; REMOVE DETOX NUMBERS FROM OTHER DEA NUMBERS
S FDA(1,8991.9,IENS,.03)=GETS(.03) ; DETOX NUMBER
S FDA(1,8991.9,IENS,.04)=GETS(.04) ; EXPIRATION DATE
S FDA(1,8991.9,IENS,2.1)=GETS(2.1) ; SCHEDULE II NARCOTIC
S FDA(1,8991.9,IENS,2.2)=GETS(2.2) ; SCHEDULE II NON-NARCOTIC
S FDA(1,8991.9,IENS,2.3)=GETS(2.3) ; SCHEDULE III NARCOTIC
S FDA(1,8991.9,IENS,2.4)=GETS(2.4) ; SCHEDULE III NON-NARCOTIC
S FDA(1,8991.9,IENS,2.5)=GETS(2.5) ; SCHEDULE IV
S FDA(1,8991.9,IENS,2.6)=GETS(2.6) ; SCHEDULE V
S FDA(1,8991.9,IENS,10.2)="N" ; LAST UPDATED DATE/TIME
S FDA(1,8991.9,IENS,10.3)=GETS(10.3) ; LAST DOJ UPDATE
D UPDATE^DIE("E","FDA(1)","IENROOT","MSGROOT")
I $D(MSGROOT) D ACTIONAM G ACTIONAX
S DNDEAIEN=$S($D(IENROOT(1)):IENROOT(1),1:IENS)
S FDA(2,8991.9,DNDEAIEN,10.1)=DUZ D FILE^DIE("","FDA(2)","MSGROOT")
I $G(GETS(.07))="INSTITUTIONAL" D
.Q:'$D(GETS(55.1))
.Q:$G(PREFINST)
.K FDA
.S FDA(1,200,NPIEN_",",55.1)=GETS(55.1)
.S FDA(1,200,NPIEN_",",55.2)=GETS(55.2)
.S FDA(1,200,NPIEN_",",55.3)=GETS(55.3)
.S FDA(1,200,NPIEN_",",55.4)=GETS(55.4)
.S FDA(1,200,NPIEN_",",55.5)=GETS(55.5)
.S FDA(1,200,NPIEN_",",55.6)=GETS(55.6)
.D UPDATE^DIE("E","FDA(1)","NPIEN","MSGROOT")
;
K FDA S FDA(8991.9,IENS,10.3)=$S($G(PSOWSDWN):"",1:$$DT^XLFDT)
N IENROOT,MSGROOT
D UPDATE^DIE("","FDA","IENROOT","MSGROOT")
;
ACTIONAX ; -- Return here to end cleanly.
S VALMBCK="Q"
Q
;
ACTIONAM ; -- Provide filing error messge and pause.
N DIR
W !!,"*** The information could not be filed ***",!
W:$D(MSGROOT("DIERR",1,"TEXT",1)) MSGROOT("DIERR",1,"TEXT",1),!
S DIR(0)="E" D ^DIR W !
Q
;
ACTIONC ; -- Perform Action C: COPY DOJ/DEA VALUES TO VISTA
N SC
D DEACOPY(.FG)
D CLEAN^VALM10
D INIT
S VALMBCK="R"
Q
;
ACTIONE ; -- Perform Action E: EDIT VISTA VALUES
N DIRUT,DIR,X,Y,PSPROCDT
I '$D(GETS) S VALMSG="NOTHING TO EDIT",VALMBCK="R" Q
I '$G(PSOWSDWN) D FULL^VALM1,CLEAN^VALM10
;
I $D(FG("processedDate")) D DT^DILF("E",FG("processedDate"),.DTRESULT)
I '$D(FG("processedDate")) D DT^DILF("E",DT,.DTRESULT)
S GETS(10.3)=$G(DTRESULT(0)) ; Automatically update DOJ processed date (is now)
;
; DETOX
N CDETOX,NDETOX,GETS03,DTXDEAX
S DTXDEAX=""
I 0 D:GETS(.07)="INDIVIDUAL" ;P731 detox/x-waiver removal
. S GETS03=GETS(.03)
. S CDETOX=$$GETDNDTX^PSODEAUT(NPIEN,.DTXDEAX)
. K DTOUT,DUOUT,DIR S DIR(0)="FO^9:9^K:'$$DEANUM^PSODEAUT(X)!$$DTXDUPIT^PSODEAU0(GETS(.01),$G(X),NPIEN) X",DIR("A")="DETOX",DIR("B")=GETS(.03)
. S DIR("?")="^D DTXHLP^PSODEAME"
. ; S DIR("?")="Response must contain 2 letters and 7 numbers. The numeric portion must satisfy the DEA number checksum rules."
. D ^DIR
. Q:$D(DTOUT)!($D(DUOUT))
. S NDETOX=Y
. I X="@" S GETS(.03)=$$UP^XLFSTR(NDETOX) Q
. I CDETOX="" S GETS(.03)=$$UP^XLFSTR(NDETOX) Q
. I CDETOX'=""&(NDETOX'="")&(CDETOX'=NDETOX) D
.. K DTOUT,DUOUT,DIR S DIR(0)="Y"
.. S DIR("A",1)="DETOX NUMBER: "_CDETOX_" already exists on DEA NUMBER: "_$G(DTXDEAX)
.. S DIR("A",2)="for this provider. Only one DEA number can contain a DETOX number."
.. S DIR("A",3)="Do you want to replace the existing DETOX number?"
.. S DIR("A")="Enter Yes or No:"
.. D ^DIR I '($D(DTOUT)!($D(DUOUT))) D
... I 'Y S GETS(.03)=$$UP^XLFSTR(GETS03)
... I Y S GETS(.03)=$$UP^XLFSTR(NDETOX)
G:$D(DTOUT)!($D(DUOUT)) ACTIONEX
K DTOUT,DUOUT
;
; Don't allow editing of DEA Expiration Date or Schedules if any of the following are true:
; PROVIDER TYPE NOT= 'FEE BASIS' or 'C&A'
; -OR-
; NON-VA PRESCRIBER NOT= 'YES'
; -OR-
; PHARMACY OPERATING MODE NOT= 'VAMC'
;
; Don't allow editing of DEA Expiration Date for Institutional DEA #'S
;
N PSOEDCHK S PSOEDCHK=$$EDITCHK^PSOPRVW(+$G(NPIEN))
I 'PSOEDCHK S DEAEDQ=1 D Q
. N ASTER S $P(ASTER,"*",70)="*"
. W !!?6,$E(ASTER,1,45)
. W !?6,"* This provider's DEA Expiration Date *"
. W !?6,"* and DEA Schedules are not editable *"
. W !?6,$E(ASTER,1,45)
. W !! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR W !
;
; Set NDROOT to "2" (file 8991.9 schedule fields root) if INDIVIDUAL DEA
; Set NDROOT to "55" (file 200 schedule fields root) if INSTITUTIONAL DEA
;
N NDROOT S NDROOT=$S($G(GETS(.07))="INSTITUTIONAL":55,1:2)
I '$D(GETS(55.1)),$G(GETS(.07))="INSTITUTIONAL" D LSCHED(.GETS) ; Get Local Schedules if Institutional DEA
;
; EXPIRATION DATE
I GETS(.07)="INDIVIDUAL" D G:$D(DTOUT)!($D(DUOUT)) ACTIONEX
. K DTOUT,DUOUT,DIR N DTRESULT
. S DIR(0)="DO",DIR("A")="EXPIRATION DATE" S DIR("B")=GETS(.04) D ^DIR
. Q:($D(DTOUT)!$D(DUOUT)) D DT^DILF("E",$G(Y),.DTRESULT)
. S GETS(.04)=$G(DTRESULT(0))
. W " ",GETS(.04)
;
; SCHEDULE II NARCOTIC
K DTOUT,DUOUT,DIR S DIR(0)="Y",DIR("A")="SCHEDULE II NARCOTIC",DIR("B")=$S(GETS(NDROOT_".1")="YES":"YES",1:"NO") D ^DIR
G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".1")=$S(Y=1:"YES",1:"NO")
;
; SCHEDULE II NON-NARCOTIC
K DTOUT,DUOUT,DIR S DIR(0)="Y",DIR("A")="SCHEDULE II NON-NARCOTIC",DIR("B")=$S(GETS(NDROOT_".2")="YES":"YES",1:"NO") D ^DIR
G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".2")=$S(Y=1:"YES",1:"NO")
;
; SCHEDULE III NARCOTIC
K DTOUT,DUOUT,DIR S DIR(0)="Y",DIR("A")="SCHEDULE III NARCOTIC",DIR("B")=$S(GETS(NDROOT_".3")="YES":"YES",1:"NO") D ^DIR
G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".3")=$S(Y=1:"YES",1:"NO")
;
; SCHEDULE III NON-NARCOTIC
K DTOUT,DUOUT,DIR S DIR(0)="Y",DIR("A")="SCHEDULE III NON-NARCOTIC",DIR("B")=$S(GETS(NDROOT_".4")="YES":"YES",1:"NO") D ^DIR
G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".4")=$S(Y=1:"YES",1:"NO")
;
; SCHEDULE IV
K DTOUT,DUOUT,DIR S DIR(0)="Y",DIR("A")="SCHEDULE IV",DIR("B")=$S(GETS(NDROOT_".5")="YES":"YES",1:"NO") D ^DIR
G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".5")=$S(Y=1:"YES",1:"NO")
;
; SCHEDULE V
K DTOUT,DUOUT,DIR S DIR(0)="Y",DIR("A")="SCHEDULE V",DIR("B")=$S(GETS(NDROOT_".6")="YES":"YES",1:"NO") D ^DIR
G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".6")=$S(Y=1:"YES",1:"NO")
;
ACTIONEX ; -- ACTIONE Clean Exit Point
K DIRUT,DIR
Q:$G(PSOWSDWN)
D INIT
S VALMBCK="R"
Q
;
ACTIONX ; -- Perform Action X: QUIT AND REJECT CHANGES
D FULL^VALM1
D CLEAN^VALM10
S VALMBCK="Q"
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 I
;
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("additionalCompanyInfo"))
S GETS(1.3)=$G(FG("address1"))
S GETS(1.4)=$G(FG("address2"))
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
;
I $G(GETS(.07))="INSTITUTIONAL" F I=2.1:.1:2.6 S GETS(55_"."_$P(I,".",2))=GETS(I)
;
D DT^DILF("E",$G(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
;
CLEARDTX(NPIEN) ; REMOVE DETOX NUMBERS FROM ALL OF A PROVIDERS DEA NUMBERS
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
;
DTXHLP ; Detox Number Help Text
N CDETOX,DTXDEAX
I $G(NPIEN) S CDETOX=$$GETDNDTX^PSODEAUT(NPIEN,.DTXDEAX)
I $G(Y)'="",($G(CDETOX)'="") I Y=CDETOX D Q
.I $G(DEATXT)'=$G(DTXDEAX) D Q
.. W !,"The entered DETOX NUMBER already exists on DEA NUMBER: "_DTXDEAX
.. W !,"for this provider."
W !,"Response must contain 2 letters and 7 numbers. The numeric portion must satisfy the DEA number checksum rules."
Q
;
LSCHED(GETS) ; Get local provider schedules from NEW PERSON and add to GETS(55.1-55.6)
Q:$G(GETS(.07))'="INSTITUTIONAL"
Q:'$G(NPIEN)
N LOCSCH,LOCSCH2,I
D GETS^DIQ(200,NPIEN,"55.1;55.2;55.3;55.4;55.5;55.6","I","LOCSCH")
M LOCSCH2=LOCSCH(200,NPIEN_",")
F I=55.1,55.2,55.3,55.4,55.5,55.6 S GETS(I)=$S($G(LOCSCH2(I,"I")):"YES",1:"NO")
Q
;
MANLOAD(DUZ,DEA,GETS,FG) ; Manually load default values when web service is down
; Load GETS()
N DNDEAIEN
S DNDEAIEN=$O(^XTV(8991.9,"B",DEA,0))
I $G(DNDEAIEN) D GETS^PSODEAUT(DNDEAIEN,.GETS) D Q
.I $G(NPIEN),($G(GETS(.07))="INSTITUTIONAL") D LSCHED^PSODEAME(.GETS) ; Get Local Schedules if Institutional DEA
;
; New DEA entered without PSO DOJ/DEA WEB SERVICE connection. Default BAC? and TYPE.
S GETS(.01)=DEA
S GETS(.02)="C0"
S GETS(.03)=""
S GETS(.04)=""
S GETS(.07)="INDIVIDUAL"
S GETS(1.1)=$$GET1^DIQ(200,NPIEN,.01,"E")
S GETS(1.2)=""
S GETS(1.3)=""
S GETS(1.4)=""
S GETS(1.5)=""
S GETS(1.6)=""
S GETS(1.7)=""
S GETS(2.1)=""
S GETS(2.2)=""
S GETS(2.3)=""
S GETS(2.4)=""
S GETS(2.5)=""
S GETS(2.6)=""
S GETS(10.1)=DUZ
S GETS(10.2)=""
S GETS(10.3)=""
;
; Load FG()
S FG("drugSchedule")=""
S FG("deaNumber")=DEA
S FG("businessActivityCode")="C"
S FG("businessActivitySubcode")=0
S FG("expirationDate")=""
S FG("type")="INDIVIDUAL"
S FG("name")=GETS(1.1)
S FG("address1")=""
S FG("address2")=""
S FG("address3")=""
S FG("city")=""
S FG("state")=""
S FG("zipCode")=""
S FG("processedDate")=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODEAME 14789 printed Dec 13, 2024@02:26:36 Page 2
PSODEAME ;ALB/BI - DEA MANUAL ENTRY ;05/15/2018
+1 ;;7.0;OUTPATIENT PHARMACY;**545,731**;DEC 1997;Build 18
+2 ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
+3 ;External reference to sub-file NEW DEA #S (#200.5321) is supported by DBIA 7000
+4 QUIT
+5 ;
EN(DEATXT,PSOWSDWN) ; -- main entry point for PSO DEA NUMBER MANAGEMENT
+1 NEW CN,FG,RESPONSE,SC,FG,GETS,DNDEAIEN,POP,VALMBCK,VALMCNT,VALMSG,DTRESULT
+2 NEW ASTRSK
SET $PIECE(ASTRSK,"*",75)="*"
+3 DO CONVNAME^PSODEAUT(.CN)
+4 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DEATXT,0))
+5 SET RESPONSE=0
+6 IF '$GET(PSOWSDWN)
SET SC=$$WSGET^PSODEAUT(.FG,DEATXT)
+7 IF $PIECE($GET(SC),U,3)=6059
SET PSOWSDWN=1
+8 IF $GET(PSOWSDWN)
SET RESPONSE=0
Begin DoDot:1
+9 SET SC="0^Unable to Connect to Server^6059"
+10 SET RESPONSE=SC
+11 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DEATXT,0))
+12 NEW DIR
SET DIR("A",1)=" "_$EXTRACT(ASTRSK,1,60)
+13 SET DIR("A",2)=" Unable to Connect to PSO DOJ/DEA Web Service"
+14 SET DIR("A",3)=" "_$EXTRACT(ASTRSK,1,60)
SET DIR("A",4)=" "
+15 SET DIR("A",5)=" If you continue, the DEA information entered "
+16 SET DIR("A",6)=" will not be checked against DOJ DEA source data."
+17 SET DIR(0)="Y"
SET DIR("A")="Continue without Web Service"
SET DIR("B")="NO"
DO ^DIR
+18 if 'Y
QUIT
+19 WRITE !,"DEA NUMBER: "_$GET(DEATXT)
+20 DO MANLOAD(DUZ,DEATXT,.GETS,.FG)
+21 DO ACTIONE
DO ACTIONA
+22 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DEATXT,0))
if DNDEAIEN
SET RESPONSE=DNDEAIEN
End DoDot:1
QUIT RESPONSE
+23 IF 'SC
SET RESPONSE=SC
WRITE !!," ***"_$PIECE(RESPONSE,U,2)_"***"
GOTO ENX
+24 IF $GET(FG("type"))="INSTITUTIONAL"
Begin DoDot:1
+25 ; PREFINST = flag to indicate an automatic update of INSTITUTIONAL DEA in File 8991.9
+26 ; Only auto-update previously filed institutional DEA's
SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DEATXT,0))
if 'DNDEAIEN
QUIT
+27 NEW PREFINST
SET PREFINST=1
+28 DO DEACOPY(.FG)
+29 DO ACTIONA
+30 ; Get Local Schedules if Institutional DEA
DO LSCHED(.GETS)
End DoDot:1
+31 DO EN^VALM("PSO DEA NUMBER MANAGEMENT")
ENX ; -- Cleanup and Exit
+1 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DEATXT,0))
if DNDEAIEN
SET RESPONSE=DNDEAIEN
+2 QUIT RESPONSE
+3 ;
HDR ; -- header code
+1 ;S VALMHDR(1)="Asterisks ""**"" next to fields in the DOJ column indicate the local value"
+2 ;S VALMHDR(2)="value has been changed and no longer matches the value in the DOJ file"
+3 SET VALMHDR(1)="The asterisks ""**"" next to fields in the DOJ column indicate that the local"
+4 SET VALMHDR(2)="value has been changed and does not match the value stored in the DOJ file."
+5 SET VALMHDR(3)=""
+6 QUIT
+7 ;
INIT ; -- Build the List Array
+1 DO INIT^PSODEAED
+2 QUIT
+3 ;
HELP ; -- help code
+1 NEW X
+2 SET X="?"
DO DISP^XQORM1
WRITE !!
+3 WRITE !,"Asterisks ""**"" indicate the DOJ value does not match the local VistA value",!
+4 SET VALMBCK="R"
+5 QUIT
+6 ;
EXIT ; -- exit code
+1 QUIT
+2 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
ACTIONA ; -- Perform Action A: ACCEPT AND SAVE CHANGES
+1 ; FileMan Data Array used to insert data into file #8991.9
NEW FDA
+2 ; The IEN for the entry in the DEA NUMBERS FILE #8991.9
NEW DNDEAIEN
+3 ; Variable for the IEN being returned from the ^DIE call.
NEW IENROOT
+4 ; ENTRY IEN VALUE
NEW IENS
+5 ; Message Root for the error messages from the ^DIE call.
NEW MSGROOT
+6 IF '$DATA(GETS)
SET VALMSG="NOTHING TO SAVE"
SET VALMBCK="R"
QUIT
+7 IF '$$FIND1^DIC(8991.8,,,GETS(.02))
Begin DoDot:1
+8 ; Don't file duplicate BAC
if $DATA(^XTV(8991.8,"B",GETS(.02)))
QUIT
+9 NEW FDA,BACERR
SET FDA(8991.8,"+1,",.01)=GETS(.02)
+10 SET FDA(8991.8,"+1,",.02)=$EXTRACT(GETS(.02))
+11 SET FDA(8991.8,"+1,",.03)=$EXTRACT(GETS(.02),2,4)
+12 DO UPDATE^DIE("E","FDA",,"BACERR")
End DoDot:1
+13 if $GET(GETS(.01))'=""
SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",GETS(.01),0))
+14 SET IENS=$SELECT($GET(DNDEAIEN):$GET(DNDEAIEN)_",",1:"+1,")
+15 ; Pre-file INSTITUTIONAL DEA without ListMan
+16 ; File INDIVIDUAL DEA when service is down without ListMan
+17 IF '$GET(PREFINST)&'$GET(PSOWSDWN)
DO FULL^VALM1
DO CLEAN^VALM10
+18 ; NAME
SET FDA(1,8991.9,IENS,1.1)=GETS(1.1)
+19 ; ADDRESS 1
SET FDA(1,8991.9,IENS,1.2)=GETS(1.2)
+20 ; ADDRESS 2
SET FDA(1,8991.9,IENS,1.3)=GETS(1.3)
+21 ; ADDRESS 3
SET FDA(1,8991.9,IENS,1.4)=GETS(1.4)
+22 ; CITY
SET FDA(1,8991.9,IENS,1.5)=GETS(1.5)
+23 ; STATE
SET FDA(1,8991.9,IENS,1.6)=GETS(1.6)
+24 ; ZIP CODE
SET FDA(1,8991.9,IENS,1.7)=GETS(1.7)
+25 ; BUSINESS ACTIVITY CODE AND SUBCODE
SET FDA(1,8991.9,IENS,.02)=GETS(.02)
+26 ; TYPE
SET FDA(1,8991.9,IENS,.07)=GETS(.07)
+27 ; DEA NUMBER
SET FDA(1,8991.9,IENS,.01)=GETS(.01)
+28 ; REMOVE DETOX NUMBERS FROM OTHER DEA NUMBERS
IF GETS(.03)'=""
DO CLEARDTX(NPIEN)
+29 ; DETOX NUMBER
SET FDA(1,8991.9,IENS,.03)=GETS(.03)
+30 ; EXPIRATION DATE
SET FDA(1,8991.9,IENS,.04)=GETS(.04)
+31 ; SCHEDULE II NARCOTIC
SET FDA(1,8991.9,IENS,2.1)=GETS(2.1)
+32 ; SCHEDULE II NON-NARCOTIC
SET FDA(1,8991.9,IENS,2.2)=GETS(2.2)
+33 ; SCHEDULE III NARCOTIC
SET FDA(1,8991.9,IENS,2.3)=GETS(2.3)
+34 ; SCHEDULE III NON-NARCOTIC
SET FDA(1,8991.9,IENS,2.4)=GETS(2.4)
+35 ; SCHEDULE IV
SET FDA(1,8991.9,IENS,2.5)=GETS(2.5)
+36 ; SCHEDULE V
SET FDA(1,8991.9,IENS,2.6)=GETS(2.6)
+37 ; LAST UPDATED DATE/TIME
SET FDA(1,8991.9,IENS,10.2)="N"
+38 ; LAST DOJ UPDATE
SET FDA(1,8991.9,IENS,10.3)=GETS(10.3)
+39 DO UPDATE^DIE("E","FDA(1)","IENROOT","MSGROOT")
+40 IF $DATA(MSGROOT)
DO ACTIONAM
GOTO ACTIONAX
+41 SET DNDEAIEN=$SELECT($DATA(IENROOT(1)):IENROOT(1),1:IENS)
+42 SET FDA(2,8991.9,DNDEAIEN,10.1)=DUZ
DO FILE^DIE("","FDA(2)","MSGROOT")
+43 IF $GET(GETS(.07))="INSTITUTIONAL"
Begin DoDot:1
+44 if '$DATA(GETS(55.1))
QUIT
+45 if $GET(PREFINST)
QUIT
+46 KILL FDA
+47 SET FDA(1,200,NPIEN_",",55.1)=GETS(55.1)
+48 SET FDA(1,200,NPIEN_",",55.2)=GETS(55.2)
+49 SET FDA(1,200,NPIEN_",",55.3)=GETS(55.3)
+50 SET FDA(1,200,NPIEN_",",55.4)=GETS(55.4)
+51 SET FDA(1,200,NPIEN_",",55.5)=GETS(55.5)
+52 SET FDA(1,200,NPIEN_",",55.6)=GETS(55.6)
+53 DO UPDATE^DIE("E","FDA(1)","NPIEN","MSGROOT")
End DoDot:1
+54 ;
+55 KILL FDA
SET FDA(8991.9,IENS,10.3)=$SELECT($GET(PSOWSDWN):"",1:$$DT^XLFDT)
+56 NEW IENROOT,MSGROOT
+57 DO UPDATE^DIE("","FDA","IENROOT","MSGROOT")
+58 ;
ACTIONAX ; -- Return here to end cleanly.
+1 SET VALMBCK="Q"
+2 QUIT
+3 ;
ACTIONAM ; -- Provide filing error messge and pause.
+1 NEW DIR
+2 WRITE !!,"*** The information could not be filed ***",!
+3 if $DATA(MSGROOT("DIERR",1,"TEXT",1))
WRITE MSGROOT("DIERR",1,"TEXT",1),!
+4 SET DIR(0)="E"
DO ^DIR
WRITE !
+5 QUIT
+6 ;
ACTIONC ; -- Perform Action C: COPY DOJ/DEA VALUES TO VISTA
+1 NEW SC
+2 DO DEACOPY(.FG)
+3 DO CLEAN^VALM10
+4 DO INIT
+5 SET VALMBCK="R"
+6 QUIT
+7 ;
ACTIONE ; -- Perform Action E: EDIT VISTA VALUES
+1 NEW DIRUT,DIR,X,Y,PSPROCDT
+2 IF '$DATA(GETS)
SET VALMSG="NOTHING TO EDIT"
SET VALMBCK="R"
QUIT
+3 IF '$GET(PSOWSDWN)
DO FULL^VALM1
DO CLEAN^VALM10
+4 ;
+5 IF $DATA(FG("processedDate"))
DO DT^DILF("E",FG("processedDate"),.DTRESULT)
+6 IF '$DATA(FG("processedDate"))
DO DT^DILF("E",DT,.DTRESULT)
+7 ; Automatically update DOJ processed date (is now)
SET GETS(10.3)=$GET(DTRESULT(0))
+8 ;
+9 ; DETOX
+10 NEW CDETOX,NDETOX,GETS03,DTXDEAX
+11 SET DTXDEAX=""
+12 ;P731 detox/x-waiver removal
IF 0
if GETS(.07)="INDIVIDUAL"
Begin DoDot:1
+13 SET GETS03=GETS(.03)
+14 SET CDETOX=$$GETDNDTX^PSODEAUT(NPIEN,.DTXDEAX)
+15 KILL DTOUT,DUOUT,DIR
SET DIR(0)="FO^9:9^K:'$$DEANUM^PSODEAUT(X)!$$DTXDUPIT^PSODEAU0(GETS(.01),$G(X),NPIEN) X"
SET DIR("A")="DETOX"
SET DIR("B")=GETS(.03)
+16 SET DIR("?")="^D DTXHLP^PSODEAME"
+17 ; S DIR("?")="Response must contain 2 letters and 7 numbers. The numeric portion must satisfy the DEA number checksum rules."
+18 DO ^DIR
+19 if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+20 SET NDETOX=Y
+21 IF X="@"
SET GETS(.03)=$$UP^XLFSTR(NDETOX)
QUIT
+22 IF CDETOX=""
SET GETS(.03)=$$UP^XLFSTR(NDETOX)
QUIT
+23 IF CDETOX'=""&(NDETOX'="")&(CDETOX'=NDETOX)
Begin DoDot:2
+24 KILL DTOUT,DUOUT,DIR
SET DIR(0)="Y"
+25 SET DIR("A",1)="DETOX NUMBER: "_CDETOX_" already exists on DEA NUMBER: "_$GET(DTXDEAX)
+26 SET DIR("A",2)="for this provider. Only one DEA number can contain a DETOX number."
+27 SET DIR("A",3)="Do you want to replace the existing DETOX number?"
+28 SET DIR("A")="Enter Yes or No:"
+29 DO ^DIR
IF '($DATA(DTOUT)!($DATA(DUOUT)))
Begin DoDot:3
+30 IF 'Y
SET GETS(.03)=$$UP^XLFSTR(GETS03)
+31 IF Y
SET GETS(.03)=$$UP^XLFSTR(NDETOX)
End DoDot:3
End DoDot:2
End DoDot:1
+32 if $DATA(DTOUT)!($DATA(DUOUT))
GOTO ACTIONEX
+33 KILL DTOUT,DUOUT
+34 ;
+35 ; Don't allow editing of DEA Expiration Date or Schedules if any of the following are true:
+36 ; PROVIDER TYPE NOT= 'FEE BASIS' or 'C&A'
+37 ; -OR-
+38 ; NON-VA PRESCRIBER NOT= 'YES'
+39 ; -OR-
+40 ; PHARMACY OPERATING MODE NOT= 'VAMC'
+41 ;
+42 ; Don't allow editing of DEA Expiration Date for Institutional DEA #'S
+43 ;
+44 NEW PSOEDCHK
SET PSOEDCHK=$$EDITCHK^PSOPRVW(+$GET(NPIEN))
+45 IF 'PSOEDCHK
SET DEAEDQ=1
Begin DoDot:1
+46 NEW ASTER
SET $PIECE(ASTER,"*",70)="*"
+47 WRITE !!?6,$EXTRACT(ASTER,1,45)
+48 WRITE !?6,"* This provider's DEA Expiration Date *"
+49 WRITE !?6,"* and DEA Schedules are not editable *"
+50 WRITE !?6,$EXTRACT(ASTER,1,45)
+51 WRITE !!
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
WRITE !
End DoDot:1
QUIT
+52 ;
+53 ; Set NDROOT to "2" (file 8991.9 schedule fields root) if INDIVIDUAL DEA
+54 ; Set NDROOT to "55" (file 200 schedule fields root) if INSTITUTIONAL DEA
+55 ;
+56 NEW NDROOT
SET NDROOT=$SELECT($GET(GETS(.07))="INSTITUTIONAL":55,1:2)
+57 ; Get Local Schedules if Institutional DEA
IF '$DATA(GETS(55.1))
IF $GET(GETS(.07))="INSTITUTIONAL"
DO LSCHED(.GETS)
+58 ;
+59 ; EXPIRATION DATE
+60 IF GETS(.07)="INDIVIDUAL"
Begin DoDot:1
+61 KILL DTOUT,DUOUT,DIR
NEW DTRESULT
+62 SET DIR(0)="DO"
SET DIR("A")="EXPIRATION DATE"
SET DIR("B")=GETS(.04)
DO ^DIR
+63 if ($DATA(DTOUT)!$DATA(DUOUT))
QUIT
DO DT^DILF("E",$GET(Y),.DTRESULT)
+64 SET GETS(.04)=$GET(DTRESULT(0))
+65 WRITE " ",GETS(.04)
End DoDot:1
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO ACTIONEX
+66 ;
+67 ; SCHEDULE II NARCOTIC
+68 KILL DTOUT,DUOUT,DIR
SET DIR(0)="Y"
SET DIR("A")="SCHEDULE II NARCOTIC"
SET DIR("B")=$SELECT(GETS(NDROOT_".1")="YES":"YES",1:"NO")
DO ^DIR
+69 if $DATA(DTOUT)!($DATA(DUOUT))
GOTO ACTIONEX
SET GETS(NDROOT_".1")=$SELECT(Y=1:"YES",1:"NO")
+70 ;
+71 ; SCHEDULE II NON-NARCOTIC
+72 KILL DTOUT,DUOUT,DIR
SET DIR(0)="Y"
SET DIR("A")="SCHEDULE II NON-NARCOTIC"
SET DIR("B")=$SELECT(GETS(NDROOT_".2")="YES":"YES",1:"NO")
DO ^DIR
+73 if $DATA(DTOUT)!($DATA(DUOUT))
GOTO ACTIONEX
SET GETS(NDROOT_".2")=$SELECT(Y=1:"YES",1:"NO")
+74 ;
+75 ; SCHEDULE III NARCOTIC
+76 KILL DTOUT,DUOUT,DIR
SET DIR(0)="Y"
SET DIR("A")="SCHEDULE III NARCOTIC"
SET DIR("B")=$SELECT(GETS(NDROOT_".3")="YES":"YES",1:"NO")
DO ^DIR
+77 if $DATA(DTOUT)!($DATA(DUOUT))
GOTO ACTIONEX
SET GETS(NDROOT_".3")=$SELECT(Y=1:"YES",1:"NO")
+78 ;
+79 ; SCHEDULE III NON-NARCOTIC
+80 KILL DTOUT,DUOUT,DIR
SET DIR(0)="Y"
SET DIR("A")="SCHEDULE III NON-NARCOTIC"
SET DIR("B")=$SELECT(GETS(NDROOT_".4")="YES":"YES",1:"NO")
DO ^DIR
+81 if $DATA(DTOUT)!($DATA(DUOUT))
GOTO ACTIONEX
SET GETS(NDROOT_".4")=$SELECT(Y=1:"YES",1:"NO")
+82 ;
+83 ; SCHEDULE IV
+84 KILL DTOUT,DUOUT,DIR
SET DIR(0)="Y"
SET DIR("A")="SCHEDULE IV"
SET DIR("B")=$SELECT(GETS(NDROOT_".5")="YES":"YES",1:"NO")
DO ^DIR
+85 if $DATA(DTOUT)!($DATA(DUOUT))
GOTO ACTIONEX
SET GETS(NDROOT_".5")=$SELECT(Y=1:"YES",1:"NO")
+86 ;
+87 ; SCHEDULE V
+88 KILL DTOUT,DUOUT,DIR
SET DIR(0)="Y"
SET DIR("A")="SCHEDULE V"
SET DIR("B")=$SELECT(GETS(NDROOT_".6")="YES":"YES",1:"NO")
DO ^DIR
+89 if $DATA(DTOUT)!($DATA(DUOUT))
GOTO ACTIONEX
SET GETS(NDROOT_".6")=$SELECT(Y=1:"YES",1:"NO")
+90 ;
ACTIONEX ; -- ACTIONE Clean Exit Point
+1 KILL DIRUT,DIR
+2 if $GET(PSOWSDWN)
QUIT
+3 DO INIT
+4 SET VALMBCK="R"
+5 QUIT
+6 ;
ACTIONX ; -- Perform Action X: QUIT AND REJECT CHANGES
+1 DO FULL^VALM1
+2 DO CLEAN^VALM10
+3 SET VALMBCK="Q"
+4 QUIT
+5 ;
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 I
+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("additionalCompanyInfo"))
+22 SET GETS(1.3)=$GET(FG("address1"))
+23 SET GETS(1.4)=$GET(FG("address2"))
+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 IF $GET(GETS(.07))="INSTITUTIONAL"
FOR I=2.1:.1:2.6
SET GETS(55_"."_$PIECE(I,".",2))=GETS(I)
+42 ;
+43 DO DT^DILF("E",$GET(DT),.DTRESULT)
+44 ; LAST UPDATED DATE/TIME
SET GETS(10.2)=$GET(DTRESULT(0))
+45 ;D DT^DILF("E",$G(FG("processedDate")),.DTRESULT)
+46 ; LAST DOJ UPDATE DATE/TIME
SET GETS(10.3)=$GET(DTRESULT(0))
+47 SET GETS(10.1)=DUZ
+48 QUIT
+49 ;
CLEARDTX(NPIEN) ; REMOVE DETOX NUMBERS FROM ALL OF A PROVIDERS DEA NUMBERS
+1 NEW DNDEAIEN,FDA,NPDEAIEN
+2 SET NPDEAIEN=0
FOR
SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
if 'NPDEAIEN
QUIT
Begin DoDot:1
+3 SET DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
+4 KILL FDA
SET FDA(1,8991.9,DNDEAIEN_",",.03)="@"
DO UPDATE^DIE("","FDA(1)")
KILL FDA
End DoDot:1
+5 QUIT
+6 ;
DTXHLP ; Detox Number Help Text
+1 NEW CDETOX,DTXDEAX
+2 IF $GET(NPIEN)
SET CDETOX=$$GETDNDTX^PSODEAUT(NPIEN,.DTXDEAX)
+3 IF $GET(Y)'=""
IF ($GET(CDETOX)'="")
IF Y=CDETOX
Begin DoDot:1
+4 IF $GET(DEATXT)'=$GET(DTXDEAX)
Begin DoDot:2
+5 WRITE !,"The entered DETOX NUMBER already exists on DEA NUMBER: "_DTXDEAX
+6 WRITE !,"for this provider."
End DoDot:2
QUIT
End DoDot:1
QUIT
+7 WRITE !,"Response must contain 2 letters and 7 numbers. The numeric portion must satisfy the DEA number checksum rules."
+8 QUIT
+9 ;
LSCHED(GETS) ; Get local provider schedules from NEW PERSON and add to GETS(55.1-55.6)
+1 if $GET(GETS(.07))'="INSTITUTIONAL"
QUIT
+2 if '$GET(NPIEN)
QUIT
+3 NEW LOCSCH,LOCSCH2,I
+4 DO GETS^DIQ(200,NPIEN,"55.1;55.2;55.3;55.4;55.5;55.6","I","LOCSCH")
+5 MERGE LOCSCH2=LOCSCH(200,NPIEN_",")
+6 FOR I=55.1,55.2,55.3,55.4,55.5,55.6
SET GETS(I)=$SELECT($GET(LOCSCH2(I,"I")):"YES",1:"NO")
+7 QUIT
+8 ;
MANLOAD(DUZ,DEA,GETS,FG) ; Manually load default values when web service is down
+1 ; Load GETS()
+2 NEW DNDEAIEN
+3 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DEA,0))
+4 IF $GET(DNDEAIEN)
DO GETS^PSODEAUT(DNDEAIEN,.GETS)
Begin DoDot:1
+5 ; Get Local Schedules if Institutional DEA
IF $GET(NPIEN)
IF ($GET(GETS(.07))="INSTITUTIONAL")
DO LSCHED^PSODEAME(.GETS)
End DoDot:1
QUIT
+6 ;
+7 ; New DEA entered without PSO DOJ/DEA WEB SERVICE connection. Default BAC? and TYPE.
+8 SET GETS(.01)=DEA
+9 SET GETS(.02)="C0"
+10 SET GETS(.03)=""
+11 SET GETS(.04)=""
+12 SET GETS(.07)="INDIVIDUAL"
+13 SET GETS(1.1)=$$GET1^DIQ(200,NPIEN,.01,"E")
+14 SET GETS(1.2)=""
+15 SET GETS(1.3)=""
+16 SET GETS(1.4)=""
+17 SET GETS(1.5)=""
+18 SET GETS(1.6)=""
+19 SET GETS(1.7)=""
+20 SET GETS(2.1)=""
+21 SET GETS(2.2)=""
+22 SET GETS(2.3)=""
+23 SET GETS(2.4)=""
+24 SET GETS(2.5)=""
+25 SET GETS(2.6)=""
+26 SET GETS(10.1)=DUZ
+27 SET GETS(10.2)=""
+28 SET GETS(10.3)=""
+29 ;
+30 ; Load FG()
+31 SET FG("drugSchedule")=""
+32 SET FG("deaNumber")=DEA
+33 SET FG("businessActivityCode")="C"
+34 SET FG("businessActivitySubcode")=0
+35 SET FG("expirationDate")=""
+36 SET FG("type")="INDIVIDUAL"
+37 SET FG("name")=GETS(1.1)
+38 SET FG("address1")=""
+39 SET FG("address2")=""
+40 SET FG("address3")=""
+41 SET FG("city")=""
+42 SET FG("state")=""
+43 SET FG("zipCode")=""
+44 SET FG("processedDate")=""
+45 QUIT
