- PSOEPU1 ;ALB/BI - DEA Manual Entry ;11/3/21 14:56
- ;;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 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
- ;References to Cache methods class.HttpResponse, class.Data, class.AtEnd, class.ReadLine() are supported by SAC exemption 20210601-01
- ;
- Q
- ;
- 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.
- ;
- Q $$WSGET^PSODEAU0(.FG,DEA)
- ;
- FILEFM(RET,DATA,NPIEN) ; -- File DEA Information in the DEA NUMBERS FILE #8991.9
- ; Invoked by RPC: PSO EPCS ADD DEA
- N DNDEAIEN,DNDEATXT,FDA,IENROOT,IENS,MSGROOT,SUFFIX,XSTATE,XIP,WSDOWN
- S RET=0
- I '$D(DATA) S RET=0 G FILEFMX
- ;
- S DNDEATXT=$P(DATA,U,11) I DNDEATXT="" G FILEFMX
- S DNDEAIEN=$O(^XTV(8991.9,"B",DNDEATXT,0))
- S IENS=$S($G(DNDEAIEN):$G(DNDEAIEN)_",",1:"+1,")
- ;
- ; INPUT: DATA - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
- S FDA(1,8991.9,IENS,1.1)=$P(DATA,U,1) ; 1 - PROVIDER NAME
- S FDA(1,8991.9,IENS,1.2)=$P(DATA,U,2) ; 2 - ADDRESS 1
- S FDA(1,8991.9,IENS,1.3)=$P(DATA,U,3) ; 3 - ADDRESS 2
- S FDA(1,8991.9,IENS,1.4)=$P(DATA,U,4) ; 4 - ADDRESS 3
- S FDA(1,8991.9,IENS,1.5)=$P(DATA,U,5) ; 5 - CITY
- ;
- ; Special State Processing
- D POSTAL^XIPUTIL($P(DATA,U,8),.XIP)
- S XSTATE=$G(XIP("STATE"))
- I XSTATE'="" S FDA(1,8991.9,IENS,1.6)=XSTATE ; 6 - STATE
- ;
- S FDA(1,8991.9,IENS,1.7)=$P(DATA,U,8) ; 8 - ZIP CODE
- S FDA(1,8991.9,IENS,.02)=$P(DATA,U,9) ; 9 - ACTIVITY CODE
- I $P(DATA,U,9)]"" D
- . N BAC,FDB,ERR,SCREEN,RETURN,ERROR
- . S BAC=$P(DATA,U,9)
- . ;
- . ; Just in case there are multiple BAC's with the same name, D LIST^DIC instead of $$FIND1^DIC
- . ; Quit if this ACTIVITY CODE is already on file
- . S SCREEN="I $P($G(^(0)),U)="""_BAC_""""
- . D LIST^DIC(8991.8,,.01,,,,,,.SCREEN,,"RETURN","ERROR")
- . Q:+$G(RETURN("DILIST",0))>0
- . ;
- . S FDB(8991.8,"?+1,",.01)=BAC
- . S FDB(8991.8,"?+1,",.02)=$E(BAC)
- . S FDB(8991.8,"?+1,",.03)=$E(BAC,2,3)
- . D UPDATE^DIE("E","FDB",,"ERR")
- . Q
- S FDA(1,8991.9,IENS,.07)=$P(DATA,U,10) ; 10 - TYPE
- S FDA(1,8991.9,IENS,.01)=$P(DATA,U,11) ; 11 - DEA NUMBER
- S FDA(1,8991.9,IENS,.04)=$P(DATA,U,12) ; 12 - EXPIRATION DATE
- S FDA(1,8991.9,IENS,10.2)="N" ; 13 - PROCESSED DATE
- I ($$DEANUM^PSOEPUT($P(DATA,U,14)))!($P(DATA,U,14)="") D ; ONLY CLEAR AND SET IF VALIDATED
- . I $P(DATA,U,14)'="" D CLEARDTX^PSOEPUT(NPIEN) ; REMOVE DETOX NUMBERS FROM OTHER DEA NUMBERS
- . S FDA(1,8991.9,IENS,.03)=$P(DATA,U,14) ; 14 - DETOX NUMBER
- I $P(DATA,U,21)["Y" D CLEARINP^PSOEPU1(NPIEN) ; REMOVE INPATIENT FLAG FROM OTHER DEA NUMBERS
- I $P(DATA,U,10)="INDIVIDUAL" D
- . S FDA(1,8991.9,IENS,2.1)=$P(DATA,U,15) ; 15 - SCHEDULE II NARCOTIC
- . S FDA(1,8991.9,IENS,2.2)=$P(DATA,U,16) ; 16 - SCHEDULE II NON-NARCOTIC
- . S FDA(1,8991.9,IENS,2.3)=$P(DATA,U,17) ; 17 - SCHEDULE III NARCOTIC
- . S FDA(1,8991.9,IENS,2.4)=$P(DATA,U,18) ; 18 - SCHEDULE III NON-NARCOTIC
- . S FDA(1,8991.9,IENS,2.5)=$P(DATA,U,19) ; 19 - SCHEDULE IV
- . S FDA(1,8991.9,IENS,2.6)=$P(DATA,U,20) ; 20 - SCHEDULE V
- I $P(DATA,U,10)'="INDIVIDUAL" D
- . N SRET,SDEA
- . S SDEA=$P(DATA,U,11) ;dea number
- . D DEADOJ^PSOEPUT(.SRET,SDEA) ;call doj server for doj institutional schedules
- . I SRET(0) D ;doj server is up
- . . S FDA(1,8991.9,IENS,2.1)=$P(SRET(1),"^",15) ; 15 - SCHEDULE II NARCOTIC
- . . S FDA(1,8991.9,IENS,2.2)=$P(SRET(1),"^",16) ; 16 - SCHEDULE II NON-NARCOTIC
- . . S FDA(1,8991.9,IENS,2.3)=$P(SRET(1),"^",17) ; 17 - SCHEDULE III NARCOTIC
- . . S FDA(1,8991.9,IENS,2.4)=$P(SRET(1),"^",18) ; 18 - SCHEDULE III NON-NARCOTIC
- . . S FDA(1,8991.9,IENS,2.5)=$P(SRET(1),"^",19) ; 19 - SCHEDULE IV
- . . S FDA(1,8991.9,IENS,2.6)=$P(SRET(1),"^",20) ; 20 - SCHEDULE V
- . ;
- S FDA(1,8991.9,IENS,.06)=$P(DATA,U,21) ; 21 - USE FOR INPATIENT FLAG
- S SUFFIX=$P(DATA,U,22) ; 22 - DEA INSTITUTIONAL SUFFIX
- ;
- ; Last Date/Time updated by DEA/DOJ web service. Adds/removes the DEA number to/from the PSO EPCS MANUAL DEA REPORT
- S WSDOWN='$$CONNECT^PSODEADD
- S FDA(1,8991.9,IENS,10.3)=$S(WSDOWN:"",1:$$NOW^XLFDT)
- ;
- D UPDATE^DIE("E","FDA(1)","IENROOT","MSGROOT")
- I $D(MSGROOT) D G FILEFMX
- . S RET="0^DATA DIDN'T FILE SUCCESSFULLY."
- . S RET(1)=$G(MSGROOT("DIERR",1,"TEXT",1))
- S DNDEAIEN=$S($D(IENROOT(1)):IENROOT(1)_",",1:IENS)
- I '+DNDEAIEN S RET="0^DATA DIDN'T FILE SUCCESSFULLY." G FILEFMX
- S FDA(2,8991.9,DNDEAIEN,10.1)=$G(DUZ) D FILE^DIE("","FDA(2)","MSGROOT")
- S:DNDEAIEN RET=+DNDEAIEN_"^SUCCESSFULLY SAVED/UPDATED IN 8991.9"
- I $L(DNDEATXT),$G(NPIEN),$G(DNDEAIEN) S RET=RET_"^"_$$NPFILE^PSOEPUT(DNDEATXT,NPIEN,DNDEAIEN,SUFFIX)
- ;I RET,$P(DATA,U,21)="YES" S FDA(200,NPIEN_",",53.2)=$P(DATA,U,11) D UPDATE^DIE(,"FDA")
- I $P(RET,"^",3),$G(NPIEN),$P($G(DATA),"^",10)'="INDIVIDUAL" S RET=RET_"^"_$$NPSFILE^PSOEPUT(NPIEN,DATA)
- FILEFMX ; -- Subroutine Exit Point
- Q
- ;
- DNDEAGET(RET,DEA) ;
- I '$D(^XTV(8991.9,"B",DEA)) S RET(0)="0^7^DEA number not on file" Q
- I $D(^XTV(8991.9,"B",DEA)) S DNDEAIEN=$O(^XTV(8991.9,"B",DEA,0)) I +DNDEAIEN D
- . K DNDEADAT D GETS^DIQ(8991.9,DNDEAIEN,"**","","DNDEADAT")
- . K RET(1)
- . S RET(1)=""
- . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",1.1))_"^" ; PROVIDER NAME
- . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",1.2))_"^" ; ADDRESS 1
- . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",1.3))_"^" ; ADDRESS 2
- . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",1.4))_"^" ; ADDRESS 3
- . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",1.5))_"^" ; CITY
- . ;
- . ; Special State Processing
- . N XSTATE,XSTATEAB,XIP,BAC,X,Y D POSTAL^XIPUTIL($G(DNDEADAT(8991.9,DNDEAIEN_",",1.7)),.XIP)
- . S XSTATEAB="" I $G(XIP("ERROR"))="" S XSTATEAB=$$GET1^DIQ(5,XIP("STATE POINTER"),1)
- . S RET(1)=RET(1)_XSTATEAB_"^" ; STATE ABREVIATION
- . S XSTATE=$G(XIP("STATE"))
- . S RET(1)=RET(1)_$G(XSTATE)_"^" ; STATE
- . ;
- . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",1.7))_"^" ; ZIP CODE
- . S BAC=$G(DNDEADAT(8991.9,DNDEAIEN_",",.02)) ; ACTIVITY CODE
- . S RET(1)=RET(1)_BAC_"^" ; ACTIVITY CODE
- . S RET(1)=RET(1)_$P($$PROVTYPE^PSODEAUT($G(BAC)),"^",2)_"^" ; TYPE
- . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",.01))_"^" ; DEA NUMBER
- . S X=$P($G(DNDEADAT(8991.9,DNDEAIEN_",",.04)),"@") D ^%DT
- . S RET(1)=RET(1)_$$FMTHL7^XLFDT(Y)_"^" ; EXPIRATION DATE
- . S X=$P($G(DNDEADAT(8991.9,DNDEAIEN_",",10.2)),"@") D ^%DT
- . S RET(1)=RET(1)_$$FMTHL7^XLFDT(Y)_"^" ; PROCESSED DATE
- . S RET(1)=RET(1)_""_"^" ; DETOX NUMBER ;P731 detox/x-waiver removal
- . I $G(DNDEADAT(8991.9,DNDEAIEN_",",.07))="INDIVIDUAL" D
- . . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",2.1))_"^" ; SCHEDULE II NARCOTIC
- . . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",2.2))_"^" ; SCHEDULE II NON-NARCOTIC
- . . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",2.3))_"^" ; SCHEDULE III NARCOTIC
- . . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",2.4))_"^" ; SCHEDULE III NON-NARCOTIC
- . . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",2.5))_"^" ; SCHEDULE IV
- . . S RET(1)=RET(1)_$G(DNDEADAT(8991.9,DNDEAIEN_",",2.6)) ; SCHEDULE V
- . I $G(DNDEADAT(8991.9,DNDEAIEN_",",.07))'="INDIVIDUAL" D
- . . S RET(1)=RET(1)_"^" ; SCHEDULE II NARCOTIC
- . . S RET(1)=RET(1)_"^" ; SCHEDULE II NON-NARCOTIC
- . . S RET(1)=RET(1)_"^" ; SCHEDULE III NARCOTIC
- . . S RET(1)=RET(1)_"^" ; SCHEDULE III NON-NARCOTIC
- . . S RET(1)=RET(1)_"^" ; SCHEDULE IV
- . . S RET(1)=RET(1)_"^" ; SCHEDULE V
- ;
- CLEARINP(NPIEN) ; REMOVE INPATIENT FLAG 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_",",.06)="@" D UPDATE^DIE("","FDA(1)") K FDA
- Q
- ;
- DTXCHK(RET,DEA,DETOX) ; -- Check Detox Number
- Q 1 ;P731 detox/x-waiver removal
- S RET=0
- I $L(DETOX)>9!($L(DETOX)<9) S RET="0^1^DETOX length error" Q
- I $S("ABCDEFGHIJKLMNOPQRSTUVWXYZ"[$E(DETOX):1,1:0)=0 S RET="0^2^DETOX first character error" Q
- I $S("ABCDEFGHIJKLMNOPQRSTUVWXYZ"[$E(DETOX,2):2,1:0)=0 S RET="0^3^DETOX second character error" Q
- I $$DEANUM^PSOEPUT(DETOX)=0 S RET="0^4^DETOX number error" Q
- I $$DETOXDUP(DEA,DETOX,.DUPDEA)=1 S RET="0^5^Duplicate DETOX number with DEA number "_DUPDEA Q
- S DNDEA=$$PRVRDTX(DEA) I DNDEA]"" S RET="0^6^Provider's profile already has a DETOX number for DEA number "_DNDEA Q
- S RET=1
- Q
- ;
- DETOXDUP(DEA,DETOX,DUPDEA) ; -- Check for duplicate Detox number
- Q 0 ;P731 detox/x-waiver removal
- N I,NXTDEA,NPIEN,NPNAME 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)))
- .S NPIEN=0 S NPIEN=$O(^VA(200,"PS4",DUPDEA,NPIEN)) Q:NPIEN=""
- .S NPNAME=$$GET1^DIQ(200,NPIEN_",",.01)
- .S DUPDEA=DUPDEA_"^"_NPNAME
- F S NXTDEA=$O(^XTV(8991.9,"D",DETOX,NXTDEA)) Q:NXTDEA="" I NXTDEA'=DEA 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
- ;
- PRVRDTX(DEA) ; -- Check for DETOX numbers on provider profile
- Q "" ;P731 detox/x-waiver removal
- N NPIEN,DNDEA
- S DNDEA=""
- S NPIEN=$O(^VA(200,"PS4",DEA,0)) I NPIEN']"" Q DNDEA
- S DNDEA=$$GTDNDTX(NPIEN)
- Q DNDEA
- ;
- GTDNDTX(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,DNDEA S GETDNDTX=""
- S NPDEAIEN=0 F S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN D Q:DNDEA]""
- . S DNDEA=""
- . S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I") Q:'DNDEAIEN
- . S GETDNDTX=$$GET1^DIQ(8991.9,DNDEAIEN_",",.03)
- . I GETDNDTX]"" S DNDEA=$$GET1^DIQ(8991.9,DNDEAIEN_",",.01)
- Q DNDEA
- ;
- VANUMCHK(RET,VANUM,NPIEN) ;Check that the VA# is unique
- N IEN,PSNM
- S RET="1^Success"
- I $D(^VA(200,"PS2",VANUM)) D
- . S IEN=0
- . F S IEN=$O(^VA(200,"PS2",VANUM,IEN)) Q:'IEN I IEN'=NPIEN K VANUM Q
- . Q
- I '$D(VANUM) S PSNM=$$GET1^DIQ(200,IEN,.01) S RET="0^VA# in use by "_PSNM
- Q
- ;
- FILEFMA(RET,FIELD,DATA,NPIEN) ; -- Filer for file #200
- ; Invoked by RPC: PSO EPCS FILER
- N FDA,IENS,MSGROOT
- S RET="1^Success"
- I '$D(FIELD)!'$D(DATA)!'$D(NPIEN) S RET=0 G FILEFMAX
- ;
- ; INPUT: DATA - A SINGLE DATA ITEM
- S IENS=NPIEN_","
- S FDA(200,IENS,FIELD)=$P(DATA,U,1)
- ;
- D UPDATE^DIE("E","FDA",,"MSGROOT")
- I $D(MSGROOT) S RET="0^Data did not file successfully."
- FILEFMAX ; -- Subroutine Exit Point
- Q
- ;
- SETINP(NPIEN) ;SET THE INPATIENT FLAG IF ONLY ONE INDIVIDUAL DEA NUMBER
- N DNDEAIEN,FDA,NPDEAIEN,CNT,DNDEA
- S CNT=0,DNDEA=""
- 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")
- . Q:($$GET1^DIQ(8991.9,DNDEAIEN_",",.07,"I")'=2) ;quit not individual
- . S CNT=CNT+1
- . I $$GET1^DIQ(8991.9,DNDEAIEN_",",.06)'="YES" S DNDEA=DNDEAIEN ;candidate dea
- I (CNT=1)&(DNDEA]"") D
- . K FDA S FDA(1,8991.9,DNDEA_",",.06)=1 D UPDATE^DIE("","FDA(1)") K FDA
- Q
- ;
- SETINP2(NPIEN,NPDEAIEN) ;Set the inpatient flag if other dea has no inpat flag
- ; NPIEN - Provider ien in file #200 being filed
- ; NPDEAIEN - New dea multiple ien with no inp flag
- ;
- N NPDEAIET,FDA,CNT,DNDEA,QFLG
- S CNT=0,DNDEA="",QFLG=0
- S NPDEAIET=0 F S NPDEAIET=$O(^VA(200,NPIEN,"PS4",NPDEAIET)) Q:'NPDEAIET D Q:QFLG
- . S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIET_","_NPIEN_",",.03,"I")
- . Q:($$GET1^DIQ(8991.9,DNDEAIEN_",",.07,"I")'=2) ;quit not individual
- . I $$GET1^DIQ(8991.9,DNDEAIEN_",",.06)="YES" S QFLG=1 ;a dea is set for inpat
- . S CNT=CNT+1
- . I $$GET1^DIQ(8991.9,DNDEAIEN_",",.06)'="YES" I NPDEAIET'=NPDEAIEN S DNDEA=DNDEAIEN ;candidate dea
- I ('QFLG)&(CNT=2)&(DNDEA]"") D
- . K FDA S FDA(1,8991.9,DNDEA_",",.06)=1 D UPDATE^DIE("","FDA(1)") K FDA
- Q
- ;
- NPSCHDL(RET,NPIEN) ; -- RPC to return the file #200 schedule information for a single provider.
- ; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
- ;
- ; OUTPUT: RET - NULL OR A STRING OF SCHEDULE INFORMATION DELIMITED BY THE "^"
- ; 1 - SCHEDULE II NARCOTIC
- ; 2 - SCHEDULE II NON-NARCOTIC
- ; 3 - SCHEDULE III NARCOTIC
- ; 4 - SCHEDULE III NON-NARCOTIC
- ; 5 - SCHEDULE IV
- ; 6 - SCHEDULE V
- ;
- N NPSCHED
- K RET S RET=""
- Q:'$G(NPIEN)
- Q:'$D(^VA(200,NPIEN))
- ;
- K NPSCHED D GETS^DIQ(200,NPIEN_",","55.1:55.6","E","NPSCHED")
- S RET=RET_NPSCHED(200,NPIEN_",",55.1,"E")_"^" ; SCHEDULE II NARCOTIC
- S RET=RET_NPSCHED(200,NPIEN_",",55.2,"E")_"^" ; SCHEDULE II NON-NARCOTIC
- S RET=RET_NPSCHED(200,NPIEN_",",55.3,"E")_"^" ; SCHEDULE III NARCOTIC
- S RET=RET_NPSCHED(200,NPIEN_",",55.4,"E")_"^" ; SCHEDULE III NON-NARCOTIC
- S RET=RET_NPSCHED(200,NPIEN_",",55.5,"E")_"^" ; SCHEDULE IV
- S RET=RET_NPSCHED(200,NPIEN_",",55.6,"E") ; SCHEDULE V
- Q
- ;
- NPSCHDF(RET,NPIEN,DATA) ; -- RPC to file the file #200 schedule information for a single provider.
- ; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
- ;
- ; DATA - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
- ; 1 - SCHEDULE II NARCOTIC
- ; 2 - SCHEDULE II NON-NARCOTIC
- ; 3 - SCHEDULE III NARCOTIC
- ; 4 - SCHEDULE III NON-NARCOTIC
- ; 5 - SCHEDULE IV
- ; 6 - SCHEDULE V
- ;
- ; OUTPUT: RET - 0 OR 1^SUCCESS OR FAILURE TEXT
- ;
- N FDA,IENROOT,MSGROOT
- K RET
- I '$G(NPIEN) S RET="0^DATA DIDN'T FILE SUCCESSFULLY IN NPSFILE." Q
- I '$D(^VA(200,NPIEN)) S RET="0^DATA DIDN'T FILE SUCCESSFULLY IN NPSFILE." Q
- S FDA(3,200,NPIEN_",",55.1)=$E($P(DATA,U,1),1) ; 1 - SCHEDULE II NARCOTIC
- S FDA(3,200,NPIEN_",",55.2)=$E($P(DATA,U,2),1) ; 2 - SCHEDULE II NON-NARCOTIC
- S FDA(3,200,NPIEN_",",55.3)=$E($P(DATA,U,3),1) ; 3 - SCHEDULE III NARCOTIC
- S FDA(3,200,NPIEN_",",55.4)=$E($P(DATA,U,4),1) ; 4 - SCHEDULE III NON-NARCOTIC
- S FDA(3,200,NPIEN_",",55.5)=$E($P(DATA,U,5),1) ; 5 - SCHEDULE IV
- S FDA(3,200,NPIEN_",",55.6)=$E($P(DATA,U,6),1) ; 6 - SCHEDULE V
- D UPDATE^DIE("E","FDA(3)","IENROOT","MSGROOT")
- I $D(MSGROOT) S RET="0^DATA DIDN'T FILE SUCCESSFULLY IN NPSFILE." Q
- S RET="1^SCHEDULES SUCCESSFULLY SAVED/UPDATED IN 200"
- Q
- ;
- OPTNDESC(RET,OPTNM) ; -- RPC to return Option file #19 description word processing text
- ; INPUT: OPTNM - NAME FIELD OF THE OPTION
- ;
- ; OUTPUT: RET ARRAY - OPTION FILE #19 DESCRIPTION WORD PROCESSING TEXT
- ;
- N DA,ARR
- K RET
- S DA=$$FIND1^DIC(19,,,OPTNM)
- S ARR=$$GET1^DIQ(19,DA,3.5,"Z","ARR")
- S DA=0 F S DA=$O(ARR(DA)) Q:'DA S RET(DA)=ARR(DA,0)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOEPU1 15631 printed Feb 18, 2025@23:54:01 Page 2
- PSOEPU1 ;ALB/BI - DEA Manual Entry ;11/3/21 14:56
- +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 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 ;References to Cache methods class.HttpResponse, class.Data, class.AtEnd, class.ReadLine() are supported by SAC exemption 20210601-01
- +7 ;
- +8 QUIT
- +9 ;
- 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 QUIT $$WSGET^PSODEAU0(.FG,DEA)
- +9 ;
- FILEFM(RET,DATA,NPIEN) ; -- File DEA Information in the DEA NUMBERS FILE #8991.9
- +1 ; Invoked by RPC: PSO EPCS ADD DEA
- +2 NEW DNDEAIEN,DNDEATXT,FDA,IENROOT,IENS,MSGROOT,SUFFIX,XSTATE,XIP,WSDOWN
- +3 SET RET=0
- +4 IF '$DATA(DATA)
- SET RET=0
- GOTO FILEFMX
- +5 ;
- +6 SET DNDEATXT=$PIECE(DATA,U,11)
- IF DNDEATXT=""
- GOTO FILEFMX
- +7 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DNDEATXT,0))
- +8 SET IENS=$SELECT($GET(DNDEAIEN):$GET(DNDEAIEN)_",",1:"+1,")
- +9 ;
- +10 ; INPUT: DATA - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
- +11 ; 1 - PROVIDER NAME
- SET FDA(1,8991.9,IENS,1.1)=$PIECE(DATA,U,1)
- +12 ; 2 - ADDRESS 1
- SET FDA(1,8991.9,IENS,1.2)=$PIECE(DATA,U,2)
- +13 ; 3 - ADDRESS 2
- SET FDA(1,8991.9,IENS,1.3)=$PIECE(DATA,U,3)
- +14 ; 4 - ADDRESS 3
- SET FDA(1,8991.9,IENS,1.4)=$PIECE(DATA,U,4)
- +15 ; 5 - CITY
- SET FDA(1,8991.9,IENS,1.5)=$PIECE(DATA,U,5)
- +16 ;
- +17 ; Special State Processing
- +18 DO POSTAL^XIPUTIL($PIECE(DATA,U,8),.XIP)
- +19 SET XSTATE=$GET(XIP("STATE"))
- +20 ; 6 - STATE
- IF XSTATE'=""
- SET FDA(1,8991.9,IENS,1.6)=XSTATE
- +21 ;
- +22 ; 8 - ZIP CODE
- SET FDA(1,8991.9,IENS,1.7)=$PIECE(DATA,U,8)
- +23 ; 9 - ACTIVITY CODE
- SET FDA(1,8991.9,IENS,.02)=$PIECE(DATA,U,9)
- +24 IF $PIECE(DATA,U,9)]""
- Begin DoDot:1
- +25 NEW BAC,FDB,ERR,SCREEN,RETURN,ERROR
- +26 SET BAC=$PIECE(DATA,U,9)
- +27 ;
- +28 ; Just in case there are multiple BAC's with the same name, D LIST^DIC instead of $$FIND1^DIC
- +29 ; Quit if this ACTIVITY CODE is already on file
- +30 SET SCREEN="I $P($G(^(0)),U)="""_BAC_""""
- +31 DO LIST^DIC(8991.8,,.01,,,,,,.SCREEN,,"RETURN","ERROR")
- +32 if +$GET(RETURN("DILIST",0))>0
- QUIT
- +33 ;
- +34 SET FDB(8991.8,"?+1,",.01)=BAC
- +35 SET FDB(8991.8,"?+1,",.02)=$EXTRACT(BAC)
- +36 SET FDB(8991.8,"?+1,",.03)=$EXTRACT(BAC,2,3)
- +37 DO UPDATE^DIE("E","FDB",,"ERR")
- +38 QUIT
- End DoDot:1
- +39 ; 10 - TYPE
- SET FDA(1,8991.9,IENS,.07)=$PIECE(DATA,U,10)
- +40 ; 11 - DEA NUMBER
- SET FDA(1,8991.9,IENS,.01)=$PIECE(DATA,U,11)
- +41 ; 12 - EXPIRATION DATE
- SET FDA(1,8991.9,IENS,.04)=$PIECE(DATA,U,12)
- +42 ; 13 - PROCESSED DATE
- SET FDA(1,8991.9,IENS,10.2)="N"
- +43 ; ONLY CLEAR AND SET IF VALIDATED
- IF ($$DEANUM^PSOEPUT($PIECE(DATA,U,14)))!($PIECE(DATA,U,14)="")
- Begin DoDot:1
- +44 ; REMOVE DETOX NUMBERS FROM OTHER DEA NUMBERS
- IF $PIECE(DATA,U,14)'=""
- DO CLEARDTX^PSOEPUT(NPIEN)
- +45 ; 14 - DETOX NUMBER
- SET FDA(1,8991.9,IENS,.03)=$PIECE(DATA,U,14)
- End DoDot:1
- +46 ; REMOVE INPATIENT FLAG FROM OTHER DEA NUMBERS
- IF $PIECE(DATA,U,21)["Y"
- DO CLEARINP^PSOEPU1(NPIEN)
- +47 IF $PIECE(DATA,U,10)="INDIVIDUAL"
- Begin DoDot:1
- +48 ; 15 - SCHEDULE II NARCOTIC
- SET FDA(1,8991.9,IENS,2.1)=$PIECE(DATA,U,15)
- +49 ; 16 - SCHEDULE II NON-NARCOTIC
- SET FDA(1,8991.9,IENS,2.2)=$PIECE(DATA,U,16)
- +50 ; 17 - SCHEDULE III NARCOTIC
- SET FDA(1,8991.9,IENS,2.3)=$PIECE(DATA,U,17)
- +51 ; 18 - SCHEDULE III NON-NARCOTIC
- SET FDA(1,8991.9,IENS,2.4)=$PIECE(DATA,U,18)
- +52 ; 19 - SCHEDULE IV
- SET FDA(1,8991.9,IENS,2.5)=$PIECE(DATA,U,19)
- +53 ; 20 - SCHEDULE V
- SET FDA(1,8991.9,IENS,2.6)=$PIECE(DATA,U,20)
- End DoDot:1
- +54 IF $PIECE(DATA,U,10)'="INDIVIDUAL"
- Begin DoDot:1
- +55 NEW SRET,SDEA
- +56 ;dea number
- SET SDEA=$PIECE(DATA,U,11)
- +57 ;call doj server for doj institutional schedules
- DO DEADOJ^PSOEPUT(.SRET,SDEA)
- +58 ;doj server is up
- IF SRET(0)
- Begin DoDot:2
- +59 ; 15 - SCHEDULE II NARCOTIC
- SET FDA(1,8991.9,IENS,2.1)=$PIECE(SRET(1),"^",15)
- +60 ; 16 - SCHEDULE II NON-NARCOTIC
- SET FDA(1,8991.9,IENS,2.2)=$PIECE(SRET(1),"^",16)
- +61 ; 17 - SCHEDULE III NARCOTIC
- SET FDA(1,8991.9,IENS,2.3)=$PIECE(SRET(1),"^",17)
- +62 ; 18 - SCHEDULE III NON-NARCOTIC
- SET FDA(1,8991.9,IENS,2.4)=$PIECE(SRET(1),"^",18)
- +63 ; 19 - SCHEDULE IV
- SET FDA(1,8991.9,IENS,2.5)=$PIECE(SRET(1),"^",19)
- +64 ; 20 - SCHEDULE V
- SET FDA(1,8991.9,IENS,2.6)=$PIECE(SRET(1),"^",20)
- End DoDot:2
- +65 ;
- End DoDot:1
- +66 ; 21 - USE FOR INPATIENT FLAG
- SET FDA(1,8991.9,IENS,.06)=$PIECE(DATA,U,21)
- +67 ; 22 - DEA INSTITUTIONAL SUFFIX
- SET SUFFIX=$PIECE(DATA,U,22)
- +68 ;
- +69 ; Last Date/Time updated by DEA/DOJ web service. Adds/removes the DEA number to/from the PSO EPCS MANUAL DEA REPORT
- +70 SET WSDOWN='$$CONNECT^PSODEADD
- +71 SET FDA(1,8991.9,IENS,10.3)=$SELECT(WSDOWN:"",1:$$NOW^XLFDT)
- +72 ;
- +73 DO UPDATE^DIE("E","FDA(1)","IENROOT","MSGROOT")
- +74 IF $DATA(MSGROOT)
- Begin DoDot:1
- +75 SET RET="0^DATA DIDN'T FILE SUCCESSFULLY."
- +76 SET RET(1)=$GET(MSGROOT("DIERR",1,"TEXT",1))
- End DoDot:1
- GOTO FILEFMX
- +77 SET DNDEAIEN=$SELECT($DATA(IENROOT(1)):IENROOT(1)_",",1:IENS)
- +78 IF '+DNDEAIEN
- SET RET="0^DATA DIDN'T FILE SUCCESSFULLY."
- GOTO FILEFMX
- +79 SET FDA(2,8991.9,DNDEAIEN,10.1)=$GET(DUZ)
- DO FILE^DIE("","FDA(2)","MSGROOT")
- +80 if DNDEAIEN
- SET RET=+DNDEAIEN_"^SUCCESSFULLY SAVED/UPDATED IN 8991.9"
- +81 IF $LENGTH(DNDEATXT)
- IF $GET(NPIEN)
- IF $GET(DNDEAIEN)
- SET RET=RET_"^"_$$NPFILE^PSOEPUT(DNDEATXT,NPIEN,DNDEAIEN,SUFFIX)
- +82 ;I RET,$P(DATA,U,21)="YES" S FDA(200,NPIEN_",",53.2)=$P(DATA,U,11) D UPDATE^DIE(,"FDA")
- +83 IF $PIECE(RET,"^",3)
- IF $GET(NPIEN)
- IF $PIECE($GET(DATA),"^",10)'="INDIVIDUAL"
- SET RET=RET_"^"_$$NPSFILE^PSOEPUT(NPIEN,DATA)
- FILEFMX ; -- Subroutine Exit Point
- +1 QUIT
- +2 ;
- DNDEAGET(RET,DEA) ;
- +1 IF '$DATA(^XTV(8991.9,"B",DEA))
- SET RET(0)="0^7^DEA number not on file"
- QUIT
- +2 IF $DATA(^XTV(8991.9,"B",DEA))
- SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",DEA,0))
- IF +DNDEAIEN
- Begin DoDot:1
- +3 KILL DNDEADAT
- DO GETS^DIQ(8991.9,DNDEAIEN,"**","","DNDEADAT")
- +4 KILL RET(1)
- +5 SET RET(1)=""
- +6 ; PROVIDER NAME
- SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",1.1))_"^"
- +7 ; ADDRESS 1
- SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",1.2))_"^"
- +8 ; ADDRESS 2
- SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",1.3))_"^"
- +9 ; ADDRESS 3
- SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",1.4))_"^"
- +10 ; CITY
- SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",1.5))_"^"
- +11 ;
- +12 ; Special State Processing
- +13 NEW XSTATE,XSTATEAB,XIP,BAC,X,Y
- DO POSTAL^XIPUTIL($GET(DNDEADAT(8991.9,DNDEAIEN_",",1.7)),.XIP)
- +14 SET XSTATEAB=""
- IF $GET(XIP("ERROR"))=""
- SET XSTATEAB=$$GET1^DIQ(5,XIP("STATE POINTER"),1)
- +15 ; STATE ABREVIATION
- SET RET(1)=RET(1)_XSTATEAB_"^"
- +16 SET XSTATE=$GET(XIP("STATE"))
- +17 ; STATE
- SET RET(1)=RET(1)_$GET(XSTATE)_"^"
- +18 ;
- +19 ; ZIP CODE
- SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",1.7))_"^"
- +20 ; ACTIVITY CODE
- SET BAC=$GET(DNDEADAT(8991.9,DNDEAIEN_",",.02))
- +21 ; ACTIVITY CODE
- SET RET(1)=RET(1)_BAC_"^"
- +22 ; TYPE
- SET RET(1)=RET(1)_$PIECE($$PROVTYPE^PSODEAUT($GET(BAC)),"^",2)_"^"
- +23 ; DEA NUMBER
- SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",.01))_"^"
- +24 SET X=$PIECE($GET(DNDEADAT(8991.9,DNDEAIEN_",",.04)),"@")
- DO ^%DT
- +25 ; EXPIRATION DATE
- SET RET(1)=RET(1)_$$FMTHL7^XLFDT(Y)_"^"
- +26 SET X=$PIECE($GET(DNDEADAT(8991.9,DNDEAIEN_",",10.2)),"@")
- DO ^%DT
- +27 ; PROCESSED DATE
- SET RET(1)=RET(1)_$$FMTHL7^XLFDT(Y)_"^"
- +28 ; DETOX NUMBER ;P731 detox/x-waiver removal
- SET RET(1)=RET(1)_""_"^"
- +29 IF $GET(DNDEADAT(8991.9,DNDEAIEN_",",.07))="INDIVIDUAL"
- Begin DoDot:2
- +30 ; SCHEDULE II NARCOTIC
- SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",2.1))_"^"
- +31 ; SCHEDULE II NON-NARCOTIC
- SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",2.2))_"^"
- +32 ; SCHEDULE III NARCOTIC
- SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",2.3))_"^"
- +33 ; SCHEDULE III NON-NARCOTIC
- SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",2.4))_"^"
- +34 ; SCHEDULE IV
- SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",2.5))_"^"
- +35 ; SCHEDULE V
- SET RET(1)=RET(1)_$GET(DNDEADAT(8991.9,DNDEAIEN_",",2.6))
- End DoDot:2
- +36 IF $GET(DNDEADAT(8991.9,DNDEAIEN_",",.07))'="INDIVIDUAL"
- Begin DoDot:2
- +37 ; SCHEDULE II NARCOTIC
- SET RET(1)=RET(1)_"^"
- +38 ; SCHEDULE II NON-NARCOTIC
- SET RET(1)=RET(1)_"^"
- +39 ; SCHEDULE III NARCOTIC
- SET RET(1)=RET(1)_"^"
- +40 ; SCHEDULE III NON-NARCOTIC
- SET RET(1)=RET(1)_"^"
- +41 ; SCHEDULE IV
- SET RET(1)=RET(1)_"^"
- +42 ; SCHEDULE V
- SET RET(1)=RET(1)_"^"
- End DoDot:2
- End DoDot:1
- +43 ;
- CLEARINP(NPIEN) ; REMOVE INPATIENT FLAG 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_",",.06)="@"
- DO UPDATE^DIE("","FDA(1)")
- KILL FDA
- End DoDot:1
- +5 QUIT
- +6 ;
- DTXCHK(RET,DEA,DETOX) ; -- Check Detox Number
- +1 ;P731 detox/x-waiver removal
- QUIT 1
- +2 SET RET=0
- +3 IF $LENGTH(DETOX)>9!($LENGTH(DETOX)<9)
- SET RET="0^1^DETOX length error"
- QUIT
- +4 IF $SELECT("ABCDEFGHIJKLMNOPQRSTUVWXYZ"[$EXTRACT(DETOX):1,1:0)=0
- SET RET="0^2^DETOX first character error"
- QUIT
- +5 IF $SELECT("ABCDEFGHIJKLMNOPQRSTUVWXYZ"[$EXTRACT(DETOX,2):2,1:0)=0
- SET RET="0^3^DETOX second character error"
- QUIT
- +6 IF $$DEANUM^PSOEPUT(DETOX)=0
- SET RET="0^4^DETOX number error"
- QUIT
- +7 IF $$DETOXDUP(DEA,DETOX,.DUPDEA)=1
- SET RET="0^5^Duplicate DETOX number with DEA number "_DUPDEA
- QUIT
- +8 SET DNDEA=$$PRVRDTX(DEA)
- IF DNDEA]""
- SET RET="0^6^Provider's profile already has a DETOX number for DEA number "_DNDEA
- QUIT
- +9 SET RET=1
- +10 QUIT
- +11 ;
- DETOXDUP(DEA,DETOX,DUPDEA) ; -- Check for duplicate Detox number
- +1 ;P731 detox/x-waiver removal
- QUIT 0
- +2 NEW I,NXTDEA,NPIEN,NPNAME
- 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)))
- +7 SET NPIEN=0
- SET NPIEN=$ORDER(^VA(200,"PS4",DUPDEA,NPIEN))
- if NPIEN=""
- QUIT
- +8 SET NPNAME=$$GET1^DIQ(200,NPIEN_",",.01)
- +9 SET DUPDEA=DUPDEA_"^"_NPNAME
- End DoDot:1
- QUIT 1
- +10 FOR
- SET NXTDEA=$ORDER(^XTV(8991.9,"D",DETOX,NXTDEA))
- if NXTDEA=""
- QUIT
- IF NXTDEA'=DEA
- SET DUPDEA=$SELECT($GET(DUPDEA)'="":DUPDEA_","_NXTDEA,1:NXTDEA)
- +11 ; If more than one entry on file for this Detox number, duplicate
- IF $GET(DUPDEA)'=""
- QUIT 1
- +12 QUIT 0
- +13 ;
- PRVRDTX(DEA) ; -- Check for DETOX numbers on provider profile
- +1 ;P731 detox/x-waiver removal
- QUIT ""
- +2 NEW NPIEN,DNDEA
- +3 SET DNDEA=""
- +4 SET NPIEN=$ORDER(^VA(200,"PS4",DEA,0))
- IF NPIEN']""
- QUIT DNDEA
- +5 SET DNDEA=$$GTDNDTX(NPIEN)
- +6 QUIT DNDEA
- +7 ;
- GTDNDTX(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,DNDEA
- SET GETDNDTX=""
- +3 SET NPDEAIEN=0
- FOR
- SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
- if 'NPDEAIEN
- QUIT
- Begin DoDot:1
- +4 SET DNDEA=""
- +5 SET DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
- if 'DNDEAIEN
- QUIT
- +6 SET GETDNDTX=$$GET1^DIQ(8991.9,DNDEAIEN_",",.03)
- +7 IF GETDNDTX]""
- SET DNDEA=$$GET1^DIQ(8991.9,DNDEAIEN_",",.01)
- End DoDot:1
- if DNDEA]""
- QUIT
- +8 QUIT DNDEA
- +9 ;
- VANUMCHK(RET,VANUM,NPIEN) ;Check that the VA# is unique
- +1 NEW IEN,PSNM
- +2 SET RET="1^Success"
- +3 IF $DATA(^VA(200,"PS2",VANUM))
- Begin DoDot:1
- +4 SET IEN=0
- +5 FOR
- SET IEN=$ORDER(^VA(200,"PS2",VANUM,IEN))
- if 'IEN
- QUIT
- IF IEN'=NPIEN
- KILL VANUM
- QUIT
- +6 QUIT
- End DoDot:1
- +7 IF '$DATA(VANUM)
- SET PSNM=$$GET1^DIQ(200,IEN,.01)
- SET RET="0^VA# in use by "_PSNM
- +8 QUIT
- +9 ;
- FILEFMA(RET,FIELD,DATA,NPIEN) ; -- Filer for file #200
- +1 ; Invoked by RPC: PSO EPCS FILER
- +2 NEW FDA,IENS,MSGROOT
- +3 SET RET="1^Success"
- +4 IF '$DATA(FIELD)!'$DATA(DATA)!'$DATA(NPIEN)
- SET RET=0
- GOTO FILEFMAX
- +5 ;
- +6 ; INPUT: DATA - A SINGLE DATA ITEM
- +7 SET IENS=NPIEN_","
- +8 SET FDA(200,IENS,FIELD)=$PIECE(DATA,U,1)
- +9 ;
- +10 DO UPDATE^DIE("E","FDA",,"MSGROOT")
- +11 IF $DATA(MSGROOT)
- SET RET="0^Data did not file successfully."
- FILEFMAX ; -- Subroutine Exit Point
- +1 QUIT
- +2 ;
- SETINP(NPIEN) ;SET THE INPATIENT FLAG IF ONLY ONE INDIVIDUAL DEA NUMBER
- +1 NEW DNDEAIEN,FDA,NPDEAIEN,CNT,DNDEA
- +2 SET CNT=0
- SET DNDEA=""
- +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 ;quit not individual
- if ($$GET1^DIQ(8991.9,DNDEAIEN_",",.07,"I")'=2)
- QUIT
- +6 SET CNT=CNT+1
- +7 ;candidate dea
- IF $$GET1^DIQ(8991.9,DNDEAIEN_",",.06)'="YES"
- SET DNDEA=DNDEAIEN
- End DoDot:1
- +8 IF (CNT=1)&(DNDEA]"")
- Begin DoDot:1
- +9 KILL FDA
- SET FDA(1,8991.9,DNDEA_",",.06)=1
- DO UPDATE^DIE("","FDA(1)")
- KILL FDA
- End DoDot:1
- +10 QUIT
- +11 ;
- SETINP2(NPIEN,NPDEAIEN) ;Set the inpatient flag if other dea has no inpat flag
- +1 ; NPIEN - Provider ien in file #200 being filed
- +2 ; NPDEAIEN - New dea multiple ien with no inp flag
- +3 ;
- +4 NEW NPDEAIET,FDA,CNT,DNDEA,QFLG
- +5 SET CNT=0
- SET DNDEA=""
- SET QFLG=0
- +6 SET NPDEAIET=0
- FOR
- SET NPDEAIET=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIET))
- if 'NPDEAIET
- QUIT
- Begin DoDot:1
- +7 SET DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIET_","_NPIEN_",",.03,"I")
- +8 ;quit not individual
- if ($$GET1^DIQ(8991.9,DNDEAIEN_",",.07,"I")'=2)
- QUIT
- +9 ;a dea is set for inpat
- IF $$GET1^DIQ(8991.9,DNDEAIEN_",",.06)="YES"
- SET QFLG=1
- +10 SET CNT=CNT+1
- +11 ;candidate dea
- IF $$GET1^DIQ(8991.9,DNDEAIEN_",",.06)'="YES"
- IF NPDEAIET'=NPDEAIEN
- SET DNDEA=DNDEAIEN
- End DoDot:1
- if QFLG
- QUIT
- +12 IF ('QFLG)&(CNT=2)&(DNDEA]"")
- Begin DoDot:1
- +13 KILL FDA
- SET FDA(1,8991.9,DNDEA_",",.06)=1
- DO UPDATE^DIE("","FDA(1)")
- KILL FDA
- End DoDot:1
- +14 QUIT
- +15 ;
- NPSCHDL(RET,NPIEN) ; -- RPC to return the file #200 schedule information for a single provider.
- +1 ; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
- +2 ;
- +3 ; OUTPUT: RET - NULL OR A STRING OF SCHEDULE INFORMATION DELIMITED BY THE "^"
- +4 ; 1 - SCHEDULE II NARCOTIC
- +5 ; 2 - SCHEDULE II NON-NARCOTIC
- +6 ; 3 - SCHEDULE III NARCOTIC
- +7 ; 4 - SCHEDULE III NON-NARCOTIC
- +8 ; 5 - SCHEDULE IV
- +9 ; 6 - SCHEDULE V
- +10 ;
- +11 NEW NPSCHED
- +12 KILL RET
- SET RET=""
- +13 if '$GET(NPIEN)
- QUIT
- +14 if '$DATA(^VA(200,NPIEN))
- QUIT
- +15 ;
- +16 KILL NPSCHED
- DO GETS^DIQ(200,NPIEN_",","55.1:55.6","E","NPSCHED")
- +17 ; SCHEDULE II NARCOTIC
- SET RET=RET_NPSCHED(200,NPIEN_",",55.1,"E")_"^"
- +18 ; SCHEDULE II NON-NARCOTIC
- SET RET=RET_NPSCHED(200,NPIEN_",",55.2,"E")_"^"
- +19 ; SCHEDULE III NARCOTIC
- SET RET=RET_NPSCHED(200,NPIEN_",",55.3,"E")_"^"
- +20 ; SCHEDULE III NON-NARCOTIC
- SET RET=RET_NPSCHED(200,NPIEN_",",55.4,"E")_"^"
- +21 ; SCHEDULE IV
- SET RET=RET_NPSCHED(200,NPIEN_",",55.5,"E")_"^"
- +22 ; SCHEDULE V
- SET RET=RET_NPSCHED(200,NPIEN_",",55.6,"E")
- +23 QUIT
- +24 ;
- NPSCHDF(RET,NPIEN,DATA) ; -- RPC to file the file #200 schedule information for a single provider.
- +1 ; INPUT: NPIEN - NEW PERSON FILE #200 INTERNAL ENTRY NUMBER
- +2 ;
- +3 ; DATA - A STRING OF DEA INFORMATION DELIMITED BY THE "^"
- +4 ; 1 - SCHEDULE II NARCOTIC
- +5 ; 2 - SCHEDULE II NON-NARCOTIC
- +6 ; 3 - SCHEDULE III NARCOTIC
- +7 ; 4 - SCHEDULE III NON-NARCOTIC
- +8 ; 5 - SCHEDULE IV
- +9 ; 6 - SCHEDULE V
- +10 ;
- +11 ; OUTPUT: RET - 0 OR 1^SUCCESS OR FAILURE TEXT
- +12 ;
- +13 NEW FDA,IENROOT,MSGROOT
- +14 KILL RET
- +15 IF '$GET(NPIEN)
- SET RET="0^DATA DIDN'T FILE SUCCESSFULLY IN NPSFILE."
- QUIT
- +16 IF '$DATA(^VA(200,NPIEN))
- SET RET="0^DATA DIDN'T FILE SUCCESSFULLY IN NPSFILE."
- QUIT
- +17 ; 1 - SCHEDULE II NARCOTIC
- SET FDA(3,200,NPIEN_",",55.1)=$EXTRACT($PIECE(DATA,U,1),1)
- +18 ; 2 - SCHEDULE II NON-NARCOTIC
- SET FDA(3,200,NPIEN_",",55.2)=$EXTRACT($PIECE(DATA,U,2),1)
- +19 ; 3 - SCHEDULE III NARCOTIC
- SET FDA(3,200,NPIEN_",",55.3)=$EXTRACT($PIECE(DATA,U,3),1)
- +20 ; 4 - SCHEDULE III NON-NARCOTIC
- SET FDA(3,200,NPIEN_",",55.4)=$EXTRACT($PIECE(DATA,U,4),1)
- +21 ; 5 - SCHEDULE IV
- SET FDA(3,200,NPIEN_",",55.5)=$EXTRACT($PIECE(DATA,U,5),1)
- +22 ; 6 - SCHEDULE V
- SET FDA(3,200,NPIEN_",",55.6)=$EXTRACT($PIECE(DATA,U,6),1)
- +23 DO UPDATE^DIE("E","FDA(3)","IENROOT","MSGROOT")
- +24 IF $DATA(MSGROOT)
- SET RET="0^DATA DIDN'T FILE SUCCESSFULLY IN NPSFILE."
- QUIT
- +25 SET RET="1^SCHEDULES SUCCESSFULLY SAVED/UPDATED IN 200"
- +26 QUIT
- +27 ;
- OPTNDESC(RET,OPTNM) ; -- RPC to return Option file #19 description word processing text
- +1 ; INPUT: OPTNM - NAME FIELD OF THE OPTION
- +2 ;
- +3 ; OUTPUT: RET ARRAY - OPTION FILE #19 DESCRIPTION WORD PROCESSING TEXT
- +4 ;
- +5 NEW DA,ARR
- +6 KILL RET
- +7 SET DA=$$FIND1^DIC(19,,,OPTNM)
- +8 SET ARR=$$GET1^DIQ(19,DA,3.5,"Z","ARR")
- +9 SET DA=0
- FOR
- SET DA=$ORDER(ARR(DA))
- if 'DA
- QUIT
- SET RET(DA)=ARR(DA,0)
- +10 QUIT