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

PSODEAME.m

Go to the documentation of this file.
  1. PSODEAME ;ALB/BI - DEA MANUAL ENTRY ;05/15/2018
  1. ;;7.0;OUTPATIENT PHARMACY;**545,731**;DEC 1997;Build 18
  1. ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
  1. ;External reference to sub-file NEW DEA #S (#200.5321) is supported by DBIA 7000
  1. Q
  1. ;
  1. EN(DEATXT,PSOWSDWN) ; -- main entry point for PSO DEA NUMBER MANAGEMENT
  1. N CN,FG,RESPONSE,SC,FG,GETS,DNDEAIEN,POP,VALMBCK,VALMCNT,VALMSG,DTRESULT
  1. N ASTRSK S $P(ASTRSK,"*",75)="*"
  1. D CONVNAME^PSODEAUT(.CN)
  1. S DNDEAIEN=$O(^XTV(8991.9,"B",DEATXT,0))
  1. S RESPONSE=0
  1. I '$G(PSOWSDWN) S SC=$$WSGET^PSODEAUT(.FG,DEATXT)
  1. I $P($G(SC),U,3)=6059 S PSOWSDWN=1
  1. I $G(PSOWSDWN) S RESPONSE=0 D Q RESPONSE
  1. .S SC="0^Unable to Connect to Server^6059"
  1. .S RESPONSE=SC
  1. .S DNDEAIEN=$O(^XTV(8991.9,"B",DEATXT,0))
  1. .N DIR S DIR("A",1)=" "_$E(ASTRSK,1,60)
  1. .S DIR("A",2)=" Unable to Connect to PSO DOJ/DEA Web Service"
  1. .S DIR("A",3)=" "_$E(ASTRSK,1,60),DIR("A",4)=" "
  1. .S DIR("A",5)=" If you continue, the DEA information entered "
  1. .S DIR("A",6)=" will not be checked against DOJ DEA source data."
  1. .S DIR(0)="Y",DIR("A")="Continue without Web Service",DIR("B")="NO" D ^DIR
  1. .Q:'Y
  1. .W !,"DEA NUMBER: "_$G(DEATXT)
  1. .D MANLOAD(DUZ,DEATXT,.GETS,.FG)
  1. .D ACTIONE,ACTIONA
  1. .S DNDEAIEN=$O(^XTV(8991.9,"B",DEATXT,0)) S:DNDEAIEN RESPONSE=DNDEAIEN
  1. I 'SC S RESPONSE=SC W !!," ***"_$P(RESPONSE,U,2)_"***" G ENX
  1. I $G(FG("type"))="INSTITUTIONAL" D
  1. .; PREFINST = flag to indicate an automatic update of INSTITUTIONAL DEA in File 8991.9
  1. .S DNDEAIEN=$O(^XTV(8991.9,"B",DEATXT,0)) Q:'DNDEAIEN ; Only auto-update previously filed institutional DEA's
  1. .N PREFINST S PREFINST=1
  1. .D DEACOPY(.FG)
  1. .D ACTIONA
  1. .D LSCHED(.GETS) ; Get Local Schedules if Institutional DEA
  1. D EN^VALM("PSO DEA NUMBER MANAGEMENT")
  1. ENX ; -- Cleanup and Exit
  1. S DNDEAIEN=$O(^XTV(8991.9,"B",DEATXT,0)) S:DNDEAIEN RESPONSE=DNDEAIEN
  1. Q RESPONSE
  1. ;
  1. HDR ; -- header code
  1. ;S VALMHDR(1)="Asterisks ""**"" next to fields in the DOJ column indicate the local value"
  1. ;S VALMHDR(2)="value has been changed and no longer matches the value in the DOJ file"
  1. S VALMHDR(1)="The asterisks ""**"" next to fields in the DOJ column indicate that the local"
  1. S VALMHDR(2)="value has been changed and does not match the value stored in the DOJ file."
  1. S VALMHDR(3)=""
  1. Q
  1. ;
  1. INIT ; -- Build the List Array
  1. D INIT^PSODEAED
  1. Q
  1. ;
  1. HELP ; -- help code
  1. N X
  1. S X="?" D DISP^XQORM1 W !!
  1. W !,"Asterisks ""**"" indicate the DOJ value does not match the local VistA value",!
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. EXIT ; -- exit code
  1. Q
  1. ;
  1. EXPND ; -- expand code
  1. Q
  1. ;
  1. ACTIONA ; -- Perform Action A: ACCEPT AND SAVE CHANGES
  1. N FDA ; FileMan Data Array used to insert data into file #8991.9
  1. N DNDEAIEN ; The IEN for the entry in the DEA NUMBERS FILE #8991.9
  1. N IENROOT ; Variable for the IEN being returned from the ^DIE call.
  1. N IENS ; ENTRY IEN VALUE
  1. N MSGROOT ; Message Root for the error messages from the ^DIE call.
  1. I '$D(GETS) S VALMSG="NOTHING TO SAVE",VALMBCK="R" Q
  1. I '$$FIND1^DIC(8991.8,,,GETS(.02)) D
  1. .Q:$D(^XTV(8991.8,"B",GETS(.02))) ; Don't file duplicate BAC
  1. .N FDA,BACERR S FDA(8991.8,"+1,",.01)=GETS(.02)
  1. .S FDA(8991.8,"+1,",.02)=$E(GETS(.02))
  1. .S FDA(8991.8,"+1,",.03)=$E(GETS(.02),2,4)
  1. .D UPDATE^DIE("E","FDA",,"BACERR")
  1. S:$G(GETS(.01))'="" DNDEAIEN=$O(^XTV(8991.9,"B",GETS(.01),0))
  1. S IENS=$S($G(DNDEAIEN):$G(DNDEAIEN)_",",1:"+1,")
  1. ; Pre-file INSTITUTIONAL DEA without ListMan
  1. ; File INDIVIDUAL DEA when service is down without ListMan
  1. I '$G(PREFINST)&'$G(PSOWSDWN) D FULL^VALM1,CLEAN^VALM10
  1. S FDA(1,8991.9,IENS,1.1)=GETS(1.1) ; NAME
  1. S FDA(1,8991.9,IENS,1.2)=GETS(1.2) ; ADDRESS 1
  1. S FDA(1,8991.9,IENS,1.3)=GETS(1.3) ; ADDRESS 2
  1. S FDA(1,8991.9,IENS,1.4)=GETS(1.4) ; ADDRESS 3
  1. S FDA(1,8991.9,IENS,1.5)=GETS(1.5) ; CITY
  1. S FDA(1,8991.9,IENS,1.6)=GETS(1.6) ; STATE
  1. S FDA(1,8991.9,IENS,1.7)=GETS(1.7) ; ZIP CODE
  1. S FDA(1,8991.9,IENS,.02)=GETS(.02) ; BUSINESS ACTIVITY CODE AND SUBCODE
  1. S FDA(1,8991.9,IENS,.07)=GETS(.07) ; TYPE
  1. S FDA(1,8991.9,IENS,.01)=GETS(.01) ; DEA NUMBER
  1. I GETS(.03)'="" D CLEARDTX(NPIEN) ; REMOVE DETOX NUMBERS FROM OTHER DEA NUMBERS
  1. S FDA(1,8991.9,IENS,.03)=GETS(.03) ; DETOX NUMBER
  1. S FDA(1,8991.9,IENS,.04)=GETS(.04) ; EXPIRATION DATE
  1. S FDA(1,8991.9,IENS,2.1)=GETS(2.1) ; SCHEDULE II NARCOTIC
  1. S FDA(1,8991.9,IENS,2.2)=GETS(2.2) ; SCHEDULE II NON-NARCOTIC
  1. S FDA(1,8991.9,IENS,2.3)=GETS(2.3) ; SCHEDULE III NARCOTIC
  1. S FDA(1,8991.9,IENS,2.4)=GETS(2.4) ; SCHEDULE III NON-NARCOTIC
  1. S FDA(1,8991.9,IENS,2.5)=GETS(2.5) ; SCHEDULE IV
  1. S FDA(1,8991.9,IENS,2.6)=GETS(2.6) ; SCHEDULE V
  1. S FDA(1,8991.9,IENS,10.2)="N" ; LAST UPDATED DATE/TIME
  1. S FDA(1,8991.9,IENS,10.3)=GETS(10.3) ; LAST DOJ UPDATE
  1. D UPDATE^DIE("E","FDA(1)","IENROOT","MSGROOT")
  1. I $D(MSGROOT) D ACTIONAM G ACTIONAX
  1. S DNDEAIEN=$S($D(IENROOT(1)):IENROOT(1),1:IENS)
  1. S FDA(2,8991.9,DNDEAIEN,10.1)=DUZ D FILE^DIE("","FDA(2)","MSGROOT")
  1. I $G(GETS(.07))="INSTITUTIONAL" D
  1. .Q:'$D(GETS(55.1))
  1. .Q:$G(PREFINST)
  1. .K FDA
  1. .S FDA(1,200,NPIEN_",",55.1)=GETS(55.1)
  1. .S FDA(1,200,NPIEN_",",55.2)=GETS(55.2)
  1. .S FDA(1,200,NPIEN_",",55.3)=GETS(55.3)
  1. .S FDA(1,200,NPIEN_",",55.4)=GETS(55.4)
  1. .S FDA(1,200,NPIEN_",",55.5)=GETS(55.5)
  1. .S FDA(1,200,NPIEN_",",55.6)=GETS(55.6)
  1. .D UPDATE^DIE("E","FDA(1)","NPIEN","MSGROOT")
  1. ;
  1. K FDA S FDA(8991.9,IENS,10.3)=$S($G(PSOWSDWN):"",1:$$DT^XLFDT)
  1. N IENROOT,MSGROOT
  1. D UPDATE^DIE("","FDA","IENROOT","MSGROOT")
  1. ;
  1. ACTIONAX ; -- Return here to end cleanly.
  1. S VALMBCK="Q"
  1. Q
  1. ;
  1. ACTIONAM ; -- Provide filing error messge and pause.
  1. N DIR
  1. W !!,"*** The information could not be filed ***",!
  1. W:$D(MSGROOT("DIERR",1,"TEXT",1)) MSGROOT("DIERR",1,"TEXT",1),!
  1. S DIR(0)="E" D ^DIR W !
  1. Q
  1. ;
  1. ACTIONC ; -- Perform Action C: COPY DOJ/DEA VALUES TO VISTA
  1. N SC
  1. D DEACOPY(.FG)
  1. D CLEAN^VALM10
  1. D INIT
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. ACTIONE ; -- Perform Action E: EDIT VISTA VALUES
  1. N DIRUT,DIR,X,Y,PSPROCDT
  1. I '$D(GETS) S VALMSG="NOTHING TO EDIT",VALMBCK="R" Q
  1. I '$G(PSOWSDWN) D FULL^VALM1,CLEAN^VALM10
  1. ;
  1. I $D(FG("processedDate")) D DT^DILF("E",FG("processedDate"),.DTRESULT)
  1. I '$D(FG("processedDate")) D DT^DILF("E",DT,.DTRESULT)
  1. S GETS(10.3)=$G(DTRESULT(0)) ; Automatically update DOJ processed date (is now)
  1. ;
  1. ; DETOX
  1. N CDETOX,NDETOX,GETS03,DTXDEAX
  1. S DTXDEAX=""
  1. I 0 D:GETS(.07)="INDIVIDUAL" ;P731 detox/x-waiver removal
  1. . S GETS03=GETS(.03)
  1. . S CDETOX=$$GETDNDTX^PSODEAUT(NPIEN,.DTXDEAX)
  1. . 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)
  1. . S DIR("?")="^D DTXHLP^PSODEAME"
  1. . ; S DIR("?")="Response must contain 2 letters and 7 numbers. The numeric portion must satisfy the DEA number checksum rules."
  1. . D ^DIR
  1. . Q:$D(DTOUT)!($D(DUOUT))
  1. . S NDETOX=Y
  1. . I X="@" S GETS(.03)=$$UP^XLFSTR(NDETOX) Q
  1. . I CDETOX="" S GETS(.03)=$$UP^XLFSTR(NDETOX) Q
  1. . I CDETOX'=""&(NDETOX'="")&(CDETOX'=NDETOX) D
  1. .. K DTOUT,DUOUT,DIR S DIR(0)="Y"
  1. .. S DIR("A",1)="DETOX NUMBER: "_CDETOX_" already exists on DEA NUMBER: "_$G(DTXDEAX)
  1. .. S DIR("A",2)="for this provider. Only one DEA number can contain a DETOX number."
  1. .. S DIR("A",3)="Do you want to replace the existing DETOX number?"
  1. .. S DIR("A")="Enter Yes or No:"
  1. .. D ^DIR I '($D(DTOUT)!($D(DUOUT))) D
  1. ... I 'Y S GETS(.03)=$$UP^XLFSTR(GETS03)
  1. ... I Y S GETS(.03)=$$UP^XLFSTR(NDETOX)
  1. G:$D(DTOUT)!($D(DUOUT)) ACTIONEX
  1. K DTOUT,DUOUT
  1. ;
  1. ; Don't allow editing of DEA Expiration Date or Schedules if any of the following are true:
  1. ; PROVIDER TYPE NOT= 'FEE BASIS' or 'C&A'
  1. ; -OR-
  1. ; NON-VA PRESCRIBER NOT= 'YES'
  1. ; -OR-
  1. ; PHARMACY OPERATING MODE NOT= 'VAMC'
  1. ;
  1. ; Don't allow editing of DEA Expiration Date for Institutional DEA #'S
  1. ;
  1. N PSOEDCHK S PSOEDCHK=$$EDITCHK^PSOPRVW(+$G(NPIEN))
  1. I 'PSOEDCHK S DEAEDQ=1 D Q
  1. . N ASTER S $P(ASTER,"*",70)="*"
  1. . W !!?6,$E(ASTER,1,45)
  1. . W !?6,"* This provider's DEA Expiration Date *"
  1. . W !?6,"* and DEA Schedules are not editable *"
  1. . W !?6,$E(ASTER,1,45)
  1. . W !! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR W !
  1. ;
  1. ; Set NDROOT to "2" (file 8991.9 schedule fields root) if INDIVIDUAL DEA
  1. ; Set NDROOT to "55" (file 200 schedule fields root) if INSTITUTIONAL DEA
  1. ;
  1. N NDROOT S NDROOT=$S($G(GETS(.07))="INSTITUTIONAL":55,1:2)
  1. I '$D(GETS(55.1)),$G(GETS(.07))="INSTITUTIONAL" D LSCHED(.GETS) ; Get Local Schedules if Institutional DEA
  1. ;
  1. ; EXPIRATION DATE
  1. I GETS(.07)="INDIVIDUAL" D G:$D(DTOUT)!($D(DUOUT)) ACTIONEX
  1. . K DTOUT,DUOUT,DIR N DTRESULT
  1. . S DIR(0)="DO",DIR("A")="EXPIRATION DATE" S DIR("B")=GETS(.04) D ^DIR
  1. . Q:($D(DTOUT)!$D(DUOUT)) D DT^DILF("E",$G(Y),.DTRESULT)
  1. . S GETS(.04)=$G(DTRESULT(0))
  1. . W " ",GETS(.04)
  1. ;
  1. ; SCHEDULE II NARCOTIC
  1. 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
  1. G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".1")=$S(Y=1:"YES",1:"NO")
  1. ;
  1. ; SCHEDULE II NON-NARCOTIC
  1. 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
  1. G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".2")=$S(Y=1:"YES",1:"NO")
  1. ;
  1. ; SCHEDULE III NARCOTIC
  1. 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
  1. G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".3")=$S(Y=1:"YES",1:"NO")
  1. ;
  1. ; SCHEDULE III NON-NARCOTIC
  1. 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
  1. G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".4")=$S(Y=1:"YES",1:"NO")
  1. ;
  1. ; SCHEDULE IV
  1. K DTOUT,DUOUT,DIR S DIR(0)="Y",DIR("A")="SCHEDULE IV",DIR("B")=$S(GETS(NDROOT_".5")="YES":"YES",1:"NO") D ^DIR
  1. G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".5")=$S(Y=1:"YES",1:"NO")
  1. ;
  1. ; SCHEDULE V
  1. K DTOUT,DUOUT,DIR S DIR(0)="Y",DIR("A")="SCHEDULE V",DIR("B")=$S(GETS(NDROOT_".6")="YES":"YES",1:"NO") D ^DIR
  1. G:$D(DTOUT)!($D(DUOUT)) ACTIONEX S GETS(NDROOT_".6")=$S(Y=1:"YES",1:"NO")
  1. ;
  1. ACTIONEX ; -- ACTIONE Clean Exit Point
  1. K DIRUT,DIR
  1. Q:$G(PSOWSDWN)
  1. D INIT
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. ACTIONX ; -- Perform Action X: QUIT AND REJECT CHANGES
  1. D FULL^VALM1
  1. D CLEAN^VALM10
  1. S VALMBCK="Q"
  1. Q
  1. ;
  1. DEACOPY(FG) ; -- Private Subroutine to Copy import data in the GETS Array
  1. ; POSTAL^XIPUTL used in agreement with Integration Agreement: 3618
  1. ;
  1. ; INPUT: FG ;Web Service Response Global
  1. ;
  1. ; VARIABLES:
  1. N DS ;Single drug schedule field as sent from the VA DOJ Web Service.
  1. N XIP ;Used to calculate the state from a zip code.
  1. N XSTATE ;Used to calculate the state from a zip code.
  1. N BAC ;Business Activity Code
  1. N I
  1. ;
  1. S DS=$G(FG("drugSchedule"))
  1. S GETS(.01)=$G(FG("deaNumber"))
  1. S BAC=$G(FG("businessActivityCode"))_$G(FG("businessActivitySubcode"))
  1. S GETS(.02)=BAC ; Pointer to file #8991.8
  1. S GETS(.03)=$S($$GETDNDTX^PSODEAUT(NPIEN)'="":"",$$DETOXCHK^PSODEAUT(BAC):"X"_$E($G(FG("deaNumber")),2,9),1:"") ; DETOX NUMBER
  1. D DT^DILF("E",$G(FG("expirationDate")),.DTRESULT)
  1. S GETS(.04)=$G(DTRESULT(0))
  1. S GETS(.07)=$G(FG("type"))
  1. S GETS(1.1)=$G(FG("name"))
  1. S GETS(1.2)=$G(FG("additionalCompanyInfo"))
  1. S GETS(1.3)=$G(FG("address1"))
  1. S GETS(1.4)=$G(FG("address2"))
  1. S GETS(1.5)=$G(FG("city"))
  1. ;
  1. ; Special State Processing
  1. S GETS(1.6)=$G(FG("state"))
  1. D POSTAL^XIPUTIL($G(FG("zipCode")),.XIP)
  1. S XSTATE=$G(XIP("STATE"))
  1. I XSTATE'="" S GETS(1.6)=XSTATE ; Pointer to the State File #5.
  1. ;
  1. S GETS(1.7)=$G(FG("zipCode"))
  1. ;
  1. S GETS(2.1)=$S(DS["22N":"YES",(DS["2"&(DS'["2N")):"YES",1:"NO") ; SCHEDULE II NARCOTIC
  1. S GETS(2.2)=$S(DS["2N":"YES",1:"NO") ; SCHEDULE II NON-NARCOTIC
  1. S GETS(2.3)=$S(DS["33N":"YES",(DS["3"&(DS'["3N")):"YES",1:"NO") ; SCHEDULE III NARCOTIC
  1. S GETS(2.4)=$S(DS["3N":"YES",1:"NO") ; SCHEDULE III NON-NARCOTIC
  1. S GETS(2.5)=$S(DS["4":"YES",1:"NO") ; SCHEDULE IV
  1. S GETS(2.6)=$S(DS["5":"YES",1:"NO") ; SCHEDULE V
  1. ;
  1. I $G(GETS(.07))="INSTITUTIONAL" F I=2.1:.1:2.6 S GETS(55_"."_$P(I,".",2))=GETS(I)
  1. ;
  1. D DT^DILF("E",$G(DT),.DTRESULT)
  1. S GETS(10.2)=$G(DTRESULT(0)) ; LAST UPDATED DATE/TIME
  1. ;D DT^DILF("E",$G(FG("processedDate")),.DTRESULT)
  1. S GETS(10.3)=$G(DTRESULT(0)) ; LAST DOJ UPDATE DATE/TIME
  1. S GETS(10.1)=DUZ
  1. Q
  1. ;
  1. CLEARDTX(NPIEN) ; REMOVE DETOX NUMBERS FROM ALL OF A PROVIDERS DEA NUMBERS
  1. N DNDEAIEN,FDA,NPDEAIEN
  1. S NPDEAIEN=0 F S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN D
  1. . S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
  1. . K FDA S FDA(1,8991.9,DNDEAIEN_",",.03)="@" D UPDATE^DIE("","FDA(1)") K FDA
  1. Q
  1. ;
  1. DTXHLP ; Detox Number Help Text
  1. N CDETOX,DTXDEAX
  1. I $G(NPIEN) S CDETOX=$$GETDNDTX^PSODEAUT(NPIEN,.DTXDEAX)
  1. I $G(Y)'="",($G(CDETOX)'="") I Y=CDETOX D Q
  1. .I $G(DEATXT)'=$G(DTXDEAX) D Q
  1. .. W !,"The entered DETOX NUMBER already exists on DEA NUMBER: "_DTXDEAX
  1. .. W !,"for this provider."
  1. W !,"Response must contain 2 letters and 7 numbers. The numeric portion must satisfy the DEA number checksum rules."
  1. Q
  1. ;
  1. LSCHED(GETS) ; Get local provider schedules from NEW PERSON and add to GETS(55.1-55.6)
  1. Q:$G(GETS(.07))'="INSTITUTIONAL"
  1. Q:'$G(NPIEN)
  1. N LOCSCH,LOCSCH2,I
  1. D GETS^DIQ(200,NPIEN,"55.1;55.2;55.3;55.4;55.5;55.6","I","LOCSCH")
  1. M LOCSCH2=LOCSCH(200,NPIEN_",")
  1. 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")
  1. Q
  1. ;
  1. MANLOAD(DUZ,DEA,GETS,FG) ; Manually load default values when web service is down
  1. ; Load GETS()
  1. N DNDEAIEN
  1. S DNDEAIEN=$O(^XTV(8991.9,"B",DEA,0))
  1. I $G(DNDEAIEN) D GETS^PSODEAUT(DNDEAIEN,.GETS) D Q
  1. .I $G(NPIEN),($G(GETS(.07))="INSTITUTIONAL") D LSCHED^PSODEAME(.GETS) ; Get Local Schedules if Institutional DEA
  1. ;
  1. ; New DEA entered without PSO DOJ/DEA WEB SERVICE connection. Default BAC? and TYPE.
  1. S GETS(.01)=DEA
  1. S GETS(.02)="C0"
  1. S GETS(.03)=""
  1. S GETS(.04)=""
  1. S GETS(.07)="INDIVIDUAL"
  1. S GETS(1.1)=$$GET1^DIQ(200,NPIEN,.01,"E")
  1. S GETS(1.2)=""
  1. S GETS(1.3)=""
  1. S GETS(1.4)=""
  1. S GETS(1.5)=""
  1. S GETS(1.6)=""
  1. S GETS(1.7)=""
  1. S GETS(2.1)=""
  1. S GETS(2.2)=""
  1. S GETS(2.3)=""
  1. S GETS(2.4)=""
  1. S GETS(2.5)=""
  1. S GETS(2.6)=""
  1. S GETS(10.1)=DUZ
  1. S GETS(10.2)=""
  1. S GETS(10.3)=""
  1. ;
  1. ; Load FG()
  1. S FG("drugSchedule")=""
  1. S FG("deaNumber")=DEA
  1. S FG("businessActivityCode")="C"
  1. S FG("businessActivitySubcode")=0
  1. S FG("expirationDate")=""
  1. S FG("type")="INDIVIDUAL"
  1. S FG("name")=GETS(1.1)
  1. S FG("address1")=""
  1. S FG("address2")=""
  1. S FG("address3")=""
  1. S FG("city")=""
  1. S FG("state")=""
  1. S FG("zipCode")=""
  1. S FG("processedDate")=""
  1. Q