XUSER ;ISP/RFR - A common set of user functions ;06/09/15 10:51
;;8.0;KERNEL;**75,97,99,150,226,267,288,330,370,373,580,609,642,739,751,689**;Jul 10, 1995;Build 113
;Per VA Directive 6402, this routine should not be modified.
;Covered under DBIA #2343
Q
LOOKUP(XUF) ;Do a user lookup
;Parameter, "Q" to NOT ask OK.
;Parameter, "A" Don't select current users who have a termination
; date prior to today's date
N DIC,XUDA,DIR,Y
LK1 S DIC="^VA(200,",DIC(0)="AEMQZ" D ^DIC S XUDA=Y G:Y'>0 LKX
S Y=$P(Y(0),U,11) I Y>0,Y<DT W !?15,"This user was terminated on ",$$FMTE^XLFDT(Y) I $G(XUF)["A" S XUDA=-1 G LK1
G:$G(XUF)["Q" LKX
S DIR(0)="Y",DIR("A")=" Is "_$P(XUDA,U,2)_" the one you want",DIR("B")="YES" D ^DIR
I Y'=1 S XUDA=-1 G:'$D(DIRUT) LK1
;
LKX Q XUDA
;
ACTIVE(XUDA) ;Get if a user is active.
N %,X1,X2
S X1=$G(^VA(200,+$G(XUDA),0)),X2=$S(X1="":"",1:0)
I $L($P(X1,U,3)) S X2="1^"_$S($L($P($G(^VA(200,XUDA,.1)),U,2)):"ACTIVE",1:"NEW")
S:$P(X1,U,7)=1 X2="0^DISUSER"
S:X2["ACTIVE" $P(X2,U,3)=$P($G(^VA(200,XUDA,1.1)),U) ;Return last sign-on
S %=$P(X1,U,11) I %>0,%'>DT S X2="0^TERMINATED^"_%
Q X2
;
BULL ;Called from bulletin in DD of file #200 for 'Sub Alt Name' fld.
;This will find users with PSDMGR keys and setup the XMY array for
;bulletin recipients. p580 REM
; ZEXCEPT: XMY - Kernel exemption
N PSD,I
S PSD=$$FIND1^DIC(19.1,"","MX","PSDMGR","","","PSDERR") Q:PSD'>0
S I=0 F S I=$O(^VA(200,"AB",PSD,I)) Q:I'>0 S XMY(I)=""
Q
;
PROVIDER(XUDA,XUF) ;See if user qualifies as a CPRS provider
;XUDA = IEN of Record in New Person File
;XUF = Flag to control processing
; 0 or not passed, do not include Visitors
; 1 include Visitors
N %,X1,X2,XUORES
;Test to see if XUDA Passed:
I '$D(XUDA) Q ""
;
;Test for valid IEN:
S X1=$G(^VA(200,+$G(XUDA),0)),X2=$S(X1="":"",1:1) Q:X2="" ""
;
;See if user has XUORES Security Key:
S XUORES=$D(^XUSEC("XUORES",XUDA))
;
;Test for Access Code:
I $P(X1,U,3)]"" Q 1
;
;Test for a Termination Date not in the Future
;AND Not owner of XUORES Security Key:
S %=$P(X1,U,11) I %>0,%'>DT,'XUORES Q "0^TERMINATED^"_%
;
;Test if user has XUORES Security key:
I XUORES Q 1
;
;Tests for Visitors:
I +$G(XUF),$D(^VA(200,"BB","VISITOR",XUDA)) Q 1
I $D(^VA(200,"BB","VISITOR",XUDA)) Q "0^VISITOR"
;
;Default:
Q "0^NOT A PROVIDER"
;
DEA(FG,IEN,DATE,RXDEA) ;sr. ef. Return users DEA # or Facility DEA_"-"_user VA# or null
;ICR #2343
;If FG is 1: DEA# or VA#
;Fee Basis, C&A providers only return DEA# or null - p609/REM
;Non-VA prescriber only return DEA# or null - p545
;Add XDT=DEA expiration date. If XDT unpopulated, its expired. - p609/REM
;DATE is the date to be checked against the DEA# Expiration Date (Default: Today)-p739
;If a DEA# is passed in RXDEA, check if that # has all the credentials.
N DEA,FB,IN,INN,N,N1,XDT,VA,FAIL,I,J,K,RET,ALTRET,NVA
S IEN=$G(IEN,DUZ),INN=+DUZ(2) S:'$G(FG) FG="" S:'$D(RXDEA) RXDEA=""
S:'$G(DATE) DATE=DT ;p739
S N=$G(^VA(200,IEN,"PS"))
S NVA=$G(^VA(200,IEN,"TPB")) ;p545
S VA=$P(N,U,3)
I $P(N,U,6)=4!($P(N,U,6)=3)!($P(NVA,U,1)=1) S FB=1 ;Fee Basis or C&A provider -p609 or NON-VA prescriber
S RET="",ALTRET=""
I $L(RXDEA)>1 D Q:RET]"" RXDEA Q ""
. S I=$O(^VA(200,IEN,"PS4","B",$P(RXDEA,"-"),0)) D:I
.. S J=$P($G(^VA(200,IEN,"PS4",I,0)),U,3) D:J
... S XDT=$P($G(^XTV(8991.9,J,0)),U,4) Q:'XDT
... I XDT'<DATE S RET=RXDEA
S J=0 F S J=$O(^VA(200,IEN,"PS4",J)) Q:'J D
. S NP=1,K=$P($G(^VA(200,IEN,"PS4",J,0)),U,3) D:K
.. I $P($G(^XTV(8991.9,K,0)),U,6)=1 D
... S XDT=$P($G(^XTV(8991.9,K,0)),U,4)
... I 'XDT S RET="Q" Q
... I RET'="Q" D
.... I XDT'<DATE S RET=$P(^VA(200,IEN,"PS4",J,0),U)
.... I XDT<DATE S RET="E"
.. ; Alternate return (ALTRET) value when FB=1 (non-va provider), no valid individual DEA's, use institutional DEA
.. I '($L(RET)>6),'$L(ALTRET),($P($G(^XTV(8991.9,K,0)),U,7)=1) D
... S XDT=$P($G(^XTV(8991.9,K,0)),U,4)
... Q:'XDT Q:XDT<DATE
... N SUF S ALTRET=$P(^VA(200,IEN,"PS4",J,0),U),SUF=$P(^VA(200,IEN,"PS4",J,0),U,2)
... I $L(SUF) S ALTRET=ALTRET_"-"_SUF
.. ; If there's an individual DEA, use it as the preferred alternate, regardless of 'use for inpatient' flag
.. I '($L(RET)>6),($P($G(^XTV(8991.9,K,0)),U,7)=2) I '$L(ALTRET)!(ALTRET["-") D
... S XDT=$P($G(^XTV(8991.9,K,0)),U,4)
... Q:'XDT Q:XDT<DATE
... S ALTRET=$P(^VA(200,IEN,"PS4",J,0),U)
I '($L(RET)>6),$L(ALTRET) Q ALTRET
Q:RET="Q" ""
Q:$L(RET)>6 RET
Q:$G(FB) ""
Q:$G(FG) VA
;*689 - prevent failover
S FAIL=$$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I")
I FAIL=0,RET="E" Q ""
S IN=$P($G(^DIC(4,INN,"DEA")),U) ;Check signed-in Inst.
I '$L(IN) D
. N XU1 D PARENT^XUAF4("XU1","`"_INN,"PARENT FACILITY")
. S INN=$O(XU1("P","")) I INN S IN=$P($G(^DIC(4,INN,"DEA")),U)
. Q
N XUEXDT I INN S XUEXDT=$P($G(^DIC(4,INN,"DEA")),U,2) ;check DEA EXPIRATION DATE
S XUEXDT=$G(XUEXDT)
I $L(VA),$L(IN),$L(XUEXDT),XUEXDT'<DATE Q IN_"-"_VA ;check DEA EXPIRATION DATE
Q ""
;
DETOX(IEN,DATE) ;*689 - Returns the Detox # from file 8991.9/200 - p580/REM
;ICR #2343
;Return Detox# - valid detox# and DEA Xdate is valid
;Return null - if no detox or the DEA Xdate is unpopulated
;Return DEA Expiration Date - valid detox# but expired DEA Xdate
;IEN is used to lookup user in file #200
;DATE is the date to be checked against the Detox# Expiration Date (Default: Today)-p739
Q:'IEN ""
N DET,XDT,N,N1,I,NP,J,AR1,AR2,AR3,AR4,VDEA S (N,NP,VDEA)=0,DET=""
S:'$G(DATE) DATE=DT ;p739
S I=0 F S I=$O(^VA(200,IEN,"PS4",I)) Q:'I D
.S NP=1,J=$$GET1^DIQ(200.5321,I_","_IEN,.03,"I") Q:'J D
.. Q:$$GET1^DIQ(8991.9,J,.07,"I")=1
.. S XDT=$$GET1^DIQ(8991.9,J,.04,"I") Q:'XDT
.. S DET=$$GET1^DIQ(8991.9,J,.03)
.. S N=N+1
.. I XDT<DATE,$L(DET) S:N=1 AR4(XDT)="" S AR3(9999999-XDT,DET)="" Q
.. S:XDT'<DATE VDEA=1
.. Q:'$L(DET)
.. I $$GET1^DIQ(8991.9,J,.06,"I")=1 S AR1(9999999-XDT,DET)=""
.. E S AR2(9999999-XDT,DET)=""
S I="",I=$O(AR1(I)) Q:I $O(AR1(I,""))
S I="",I=$O(AR2(I)) Q:I $O(AR2(I,""))
;I VDEA,N S I="",I=$O(AR3(I)) Q:I $O(AR3(I,""))
S I="",I=$O(AR3(I)) Q:I $O(AR3(I,""))
S I="",I=$O(AR4(I)) Q:I I
Q:NP ""
S N=$G(^VA(200,IEN,"PS")),N1=$G(^VA(200,IEN,"QAR"))
S DET=$P(N,U,11),XDT=$P(N1,U,9)
I $L(DET),$L(XDT),XDT'<DATE Q DET ;p739
I $L(DET),$L(XDT),XDT<DATE Q XDT ;p739
Q ""
;
SDEA(FG,IEN,PSDEA,DATE,IDEA,INIEN) ;validation for new DEA regulations p580-JC(CPRS)
;ICR #2343
;Returns: DEA#, Facility DEA_"-"_user VA#, 1, 2, or 4^expiration date
;No longer used - Retained for backward compatibility
;IEN is used to lookup user in file #200
;PSDEA is the DEA schedule
;DATE is the date to be checked against the DEA# Expiration Date (Default: Today); p739
;IDEA is the DEA# or an "I" for Inpatient use to check for schedule
;*689
N DEA,N,N3,I,J,K,A,E,FOVR,XDT,Y,VA,FB,DEATYP,NVA,SMATCHNP,SMATCHIP,SMATCH,SMATCHVA,DEARR
S:'$G(DATE) DATE=DT ;p739
S:'$G(INIEN) INIEN=""
S SMATCH="",SMATCHNP="",SMATCHIP="",E="",DEARR=""
S N=$G(^VA(200,IEN,"PS")),VA=$P(N,U,3),(DEA,N3,E,FB)=""
S NVA=$G(^VA(200,IEN,"TPB")) ;p545
I $P(N,U,6)=4!($P(N,U,6)=3)!($P(NVA,U,1)=1) S FB=1 ;Fee Basis or C&A provider -p609 or NON-VA prescriber
S IDEA=$G(IDEA),FG=$G(FG),IEN=$G(IEN),PSDEA=$G(PSDEA)
I $G(PSDEA)="" Q 1
S FOVR=$$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I")
I $L(IDEA),$L(IDEA,"-")=2,$P(IDEA,"-",2)=VA G CVA
I ($L(IDEA)<2),'$O(^VA(200,IEN,"PS4",0)) G CVA
I $L(IDEA)<2 D Q:E E Q SMATCH
. S J=0 F S J=$O(^VA(200,IEN,"PS4",J)) Q:'J D Q:$L(SMATCH)
.. S K=$P($G(^VA(200,IEN,"PS4",J,0)),U,3) D:K
... S DEATYP=$P($G(^XTV(8991.9,K,0)),U,7)
... S N=$G(^XTV(8991.9,K,0))
... S XDT=$P(N,U,4) Q:'XDT
... I $P(N,U,6)=1 S DEA=$P(N,U) D ; 'Use for Inpatient' DEA is preferred
.... I XDT<DATE S SMATCHIP=1 S Y=XDT X ^DD("DD") S DEARR=4_U_Y
.... I XDT'<DATE S N3=$S(DEATYP=2:$G(^XTV(8991.9,K,2)),1:$G(^VA(200,IEN,"PS3"))) D Q
..... S SMATCHIP=$$SCHK(DEA,PSDEA,N3)
.... I 'FOVR,XDT<DATE S Y=XDT X ^DD("DD") S E=DEARR Q
.... I FB!'$L(VA) S E=DEARR Q
.... D GVA(INIEN) S:DEA["-" N3=$G(^VA(200,IEN,"PS3")) S SMATCHVA=$$SCHK(DEA,PSDEA,N3)
.... S E=$S($L(SMATCHVA)>1:"",1:2)
... I '$P(N,U,6),(IDEA'="I"),'$L(SMATCHNP) S DEA=$P(N,U) D ; Not Inpatient DEA - ignore if IDEA="I"
.... I XDT'<DATE S N3=$S(DEATYP=2:$G(^XTV(8991.9,K,2)),1:$G(^VA(200,IEN,"PS3"))) D
..... S SMATCHNP=$$SCHK(DEA,PSDEA,N3)
. I $L(SMATCHIP)>1 S SMATCH=SMATCHIP S E="" ; 'Use for Inpatient' DEA
. I ($L(SMATCHIP)<2)&($L(SMATCHNP)>1) S SMATCH=SMATCHNP S E="" ; Non-Inpatient DEA
. I $L(SMATCH)<2 S SMATCH=$S($L($G(SMATCHVA))&'E:$G(SMATCHVA),$G(SMATCHIP)=2:2,1:1) ; Failover - Facility DEA
I $L(IDEA)>1 S DEA=$P(IDEA,"-")
Q:$G(DEA)="" 1
S N=$O(^XTV(8991.9,"B",DEA,0))
Q:'N 1
S XDT=$P($G(^XTV(8991.9,N,0)),U,4) I 'XDT!(XDT<$$FMADD^XLFDT(DATE,1)) Q 4_"^"_XDT
I XDT'<DATE D Q $$SCHK(DEA,$G(PSDEA),$G(N3))
. N DEATYP S DEATYP=$P($G(^XTV(8991.9,N,0)),U,7)
. S N3=$S(DEATYP=1:$G(^VA(200,IEN,"PS3")),1:$G(^XTV(8991.9,N,2)))
I 'FOVR,(XDT<DATE) S Y=XDT X ^DD("DD") Q 4_U_Y
CVA ; VA number
S INIEN=+$G(INIEN)
Q:FB 1
Q:'$L(VA) 1
D GVA(INIEN) S:DEA["-" N3=$G(^VA(200,IEN,"PS3"))
Q:$G(DEA)="" 1
S SMATCH=$$SCHK(DEA,PSDEA,N3)
Q SMATCH
SCHK(DEA,PSDEA,N3) ;
I $G(N3)=""!(N3'[1) Q 2
I $G(PSDEA)="" Q 2
I $L(N3,"^")'=6 Q 2
F I=1:1:6 S A(I)=$P(N3,U,I)
I PSDEA=2 Q $S('A(1):2,1:DEA)
I PSDEA="2n" Q $S('A(2):2,1:DEA)
I PSDEA=3 Q $S('A(3):2,1:DEA)
I PSDEA="3n" Q $S('A(4):2,1:DEA)
I PSDEA=4 Q $S('A(5):2,1:DEA)
I PSDEA=5 Q $S('A(6):2,1:DEA)
Q DEA
;
GVA(INIEN) ; Find Facility DEA and VA #
; INN - Pointer to INSTITUTION file (#4)
N IN,INN,ININN
S INN=$S($G(INIEN):INIEN,1:+DUZ(2))
S IN=$P($G(^DIC(4,INN,"DEA")),U) ;Check signed-in Inst.
I '$L(IN) D
. N XU1 D PARENT^XUAF4("XU1","`"_INN,"PARENT FACILITY")
. S INN=$O(XU1("P","")) I INN S IN=$P($G(^DIC(4,INN,"DEA")),U)
. Q
N XUEXDT I INN S XUEXDT=$P($G(^DIC(4,INN,"DEA")),U,2) ;check DEA EXPIRATION DATE
S XUEXDT=$G(XUEXDT)
I $L(VA),$L(IN),$L(XUEXDT),(XUEXDT'<DATE) S DEA=IN_"-"_VA ;check DEA EXPIRATION DATE
Q
;
VDEA(RETURN,IEN) ;ISP/RFR - Verify a provider is properly configured for ePCS
;PARAMETERS: IEN - Internal Entry Number in the NEW PERSON file (#200)
; RETURN - Reference to an array in which text explaining
; deficiencies and listing prescribable schedules
; is placed, with each deficiency and the list of
; schedules on a separate node
;RETURN: 1 - Provider is properly configured for ePCS
; 0 - Provider is not properly configured for ePCS
N STATUS,DEA,RETVAL,DATE,NODEA
; p499 - Use new DEA NUMBERS file (#8991.9)
I $O(^VA(200,IEN,"PS4",0)) S STATUS=$$VDEADNM^XUSER3(.RETURN,IEN) Q STATUS
;
S RETVAL=1,STATUS=$$ACTIVE(IEN)
I STATUS="" S RETURN("User account does not exist.")="",RETVAL=0
I STATUS=0 S RETURN("User cannot sign on.")="",RETVAL=0
I +STATUS=0,($P(STATUS,U,2)'="") S RETURN("User account status: "_$P(STATUS,U,2))="",RETVAL=0
Q:STATUS="" RETVAL
I '$D(^XUSEC("ORES",IEN)) D
. S RETURN("Does not hold the ORES security key.")="",RETVAL=0
I +$P($G(^VA(200,IEN,"PS")),U,1)'=1 D
. S RETURN("Is not authorized to write medication orders.")="",RETVAL=0
S NODEA=1
I $P($G(^VA(200,IEN,"PS")),U,3)="" D
. S RETURN("Has neither a DEA number nor a VA number.")="",RETVAL=0
;I +$G(NODEA),($P($G(^VA(200,IEN,"PS")),U,3)'="") S RETVAL=1
S DATE=+$P($G(^VA(200,IEN,"PS")),U,4)
I DATE>0,(DATE<=DT) D
. S RETURN("Is no longer able to write medication orders (inactive date).")="",RETVAL=0
I $D(^VA(200,IEN,"PS3")) D
. N NODE
. S NODE=$$STRIP^XLFSTR(^VA(200,IEN,"PS3"),U),NODE=$$STRIP^XLFSTR(NODE,0)
. I $G(NODE)="" S RETURN("Is not permitted to prescribe any schedules.")="",RETVAL=0 Q
. I $G(NODE)'="" D
. . N PIECE,SCHED,SPEC,ASCHED
. . S SPEC("SCHEDULE ")=""
. . S ASCHED=1
. . F PIECE=1:1:6 D
. . . I +$P(^VA(200,IEN,"PS3"),U,PIECE)>0 D
. . . . N LABEL,ERROR
. . . . S LABEL=$$REPLACE^XLFSTR($$GET1^DID(200,"55."_PIECE,,"LABEL",,"ERROR"),.SPEC)
. . . . S:$G(LABEL)="" LABEL="Unknown field #55."_PIECE
. . . . S SCHED=$S($G(SCHED)'="":SCHED_U,1:"")_LABEL
. . . I +$P(^VA(200,IEN,"PS3"),U,PIECE)=0 S ASCHED=0
. . I ASCHED=1 S RETURN("Is permitted to prescribe all schedules.")=""
. . I ASCHED=0 D
. . . N DELIMIT,INDEX,TEXT
. . . S DELIMIT=", "
. . . F INDEX=1:1:$L(SCHED,U) D
. . . . S:INDEX=$L(SCHED,U) DELIMIT=" and "
. . . . S TEXT=$S($G(TEXT)'="":TEXT_DELIMIT,1:"")_$P(SCHED,U,INDEX)
. . . S RETURN("Is permitted to prescribe schedule"_$S($L(SCHED,U)>1:"s",1:"")_" "_TEXT_".")=""
;*689
I '$D(^VA(200,IEN,"PS3")) S RETURN("Is not permitted to prescribe any schedules.")="",RETVAL=0
Q RETVAL
;
DIV4(XUROOT,XUDUZ) ;Return the Divisions that this user is assigned to.
;Returns 0 - no institution for user, 1 - institution for user
;XUROOT is passed by reference.
N %,%1 S:$G(XUDUZ)="" XUDUZ=DUZ S (%,%1)=0
F S %=$O(^VA(200,XUDUZ,2,%)) Q:%'>0 S XUROOT(%)=$P($G(^(%,0)),U,2),%1=1
Q %1
;
VDEADNA(RETURN,NPIEN,DNDEAIEN) ; -- ENTRY POINT for a single DEA Number
Q $$VDEADNA^XUSER3(.RETURN,NPIEN,DNDEAIEN)
;
VDEADNM(RETURN,NPIEN) ;ISP/RFR - Verify a provider is properly configured for ePCS
Q $$VDEADNM^XUSER3(.RETURN,NPIEN)
;
NAME(IEN,FL) ;Return the full name from Name Components file
N NA S NA("FILE")=200,NA("FIELD")=.01,NA("IENS")=IEN
S FL=$G(FL,"G") ;Valid are Famly or Given
S:"FG"'[FL FL="G"
Q $$NAMEFMT^XLFNAME(.NA,FL,"CMDP")
;
HL7(IEN) ;Return a HL7 name from the components file
N NA S NA("FILE")=200,NA("FIELD")=.01,NA("IENS")=IEN
Q $$HLNAME^XLFNAME(.NA,"","~")
;
SCR200() ;Whole File Screen logic for file 200
; ZEXCEPT: DIC,DINDEX - Kernel exemption
;
; Test to see if FileMan can "talk" to the user, IA# 4577
I $G(DIC(0))'["E" Q 1
;
; Test to see if index being searched is SSN, IA# 4578
I $G(DINDEX)'="SSN" Q 1
;
; Test for Security Key
I $G(DUZ),$D(^XUSEC("XUSHOWSSN",DUZ)) Q 1
;
; Default - None of the above is TRUE
Q 0
;
PRDEA(IEN) ; 689 - Return Prescriber's active DEA
; IEN-Prescriber DUZ from file 200
Q $$PRDEA^XUPSPRA(IEN)
;
PRXDT(IEN) ; 689 - Return Prescriber's default DEA Expiration Date
; IEN-Prescriber DUZ from file 200
Q $$PRXDT^XUPSPRA(IEN)
;
PRSCH(IEN) ; 689 - Return Prescriber's default DEA schedules
; IEN-Prescriber DUZ from file 200
Q $$PRSCH^XUPSPRA(IEN)
;
DEAXDT(DEA) ; 689 - Return Expiration Date for DEA
; DEA-DEA Number. Example: AH1966007
Q $$DEAXDT^XUPSPRA(DEA)
;
DEASCH(DEA) ; 689 - Return DEA Schedules for DEA number
; DEA-DEA Number. Example: AH1966007
Q $$DEASCH^XUPSPRA(DEA)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSER 14892 printed Oct 16, 2024@18:13:07 Page 2
XUSER ;ISP/RFR - A common set of user functions ;06/09/15 10:51
+1 ;;8.0;KERNEL;**75,97,99,150,226,267,288,330,370,373,580,609,642,739,751,689**;Jul 10, 1995;Build 113
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;Covered under DBIA #2343
+4 QUIT
LOOKUP(XUF) ;Do a user lookup
+1 ;Parameter, "Q" to NOT ask OK.
+2 ;Parameter, "A" Don't select current users who have a termination
+3 ; date prior to today's date
+4 NEW DIC,XUDA,DIR,Y
LK1 SET DIC="^VA(200,"
SET DIC(0)="AEMQZ"
DO ^DIC
SET XUDA=Y
if Y'>0
GOTO LKX
+1 SET Y=$PIECE(Y(0),U,11)
IF Y>0
IF Y<DT
WRITE !?15,"This user was terminated on ",$$FMTE^XLFDT(Y)
IF $GET(XUF)["A"
SET XUDA=-1
GOTO LK1
+2 if $GET(XUF)["Q"
GOTO LKX
+3 SET DIR(0)="Y"
SET DIR("A")=" Is "_$PIECE(XUDA,U,2)_" the one you want"
SET DIR("B")="YES"
DO ^DIR
+4 IF Y'=1
SET XUDA=-1
if '$DATA(DIRUT)
GOTO LK1
+5 ;
LKX QUIT XUDA
+1 ;
ACTIVE(XUDA) ;Get if a user is active.
+1 NEW %,X1,X2
+2 SET X1=$GET(^VA(200,+$GET(XUDA),0))
SET X2=$SELECT(X1="":"",1:0)
+3 IF $LENGTH($PIECE(X1,U,3))
SET X2="1^"_$SELECT($LENGTH($PIECE($GET(^VA(200,XUDA,.1)),U,2)):"ACTIVE",1:"NEW")
+4 if $PIECE(X1,U,7)=1
SET X2="0^DISUSER"
+5 ;Return last sign-on
if X2["ACTIVE"
SET $PIECE(X2,U,3)=$PIECE($GET(^VA(200,XUDA,1.1)),U)
+6 SET %=$PIECE(X1,U,11)
IF %>0
IF %'>DT
SET X2="0^TERMINATED^"_%
+7 QUIT X2
+8 ;
BULL ;Called from bulletin in DD of file #200 for 'Sub Alt Name' fld.
+1 ;This will find users with PSDMGR keys and setup the XMY array for
+2 ;bulletin recipients. p580 REM
+3 ; ZEXCEPT: XMY - Kernel exemption
+4 NEW PSD,I
+5 SET PSD=$$FIND1^DIC(19.1,"","MX","PSDMGR","","","PSDERR")
if PSD'>0
QUIT
+6 SET I=0
FOR
SET I=$ORDER(^VA(200,"AB",PSD,I))
if I'>0
QUIT
SET XMY(I)=""
+7 QUIT
+8 ;
PROVIDER(XUDA,XUF) ;See if user qualifies as a CPRS provider
+1 ;XUDA = IEN of Record in New Person File
+2 ;XUF = Flag to control processing
+3 ; 0 or not passed, do not include Visitors
+4 ; 1 include Visitors
+5 NEW %,X1,X2,XUORES
+6 ;Test to see if XUDA Passed:
+7 IF '$DATA(XUDA)
QUIT ""
+8 ;
+9 ;Test for valid IEN:
+10 SET X1=$GET(^VA(200,+$GET(XUDA),0))
SET X2=$SELECT(X1="":"",1:1)
if X2=""
QUIT ""
+11 ;
+12 ;See if user has XUORES Security Key:
+13 SET XUORES=$DATA(^XUSEC("XUORES",XUDA))
+14 ;
+15 ;Test for Access Code:
+16 IF $PIECE(X1,U,3)]""
QUIT 1
+17 ;
+18 ;Test for a Termination Date not in the Future
+19 ;AND Not owner of XUORES Security Key:
+20 SET %=$PIECE(X1,U,11)
IF %>0
IF %'>DT
IF 'XUORES
QUIT "0^TERMINATED^"_%
+21 ;
+22 ;Test if user has XUORES Security key:
+23 IF XUORES
QUIT 1
+24 ;
+25 ;Tests for Visitors:
+26 IF +$GET(XUF)
IF $DATA(^VA(200,"BB","VISITOR",XUDA))
QUIT 1
+27 IF $DATA(^VA(200,"BB","VISITOR",XUDA))
QUIT "0^VISITOR"
+28 ;
+29 ;Default:
+30 QUIT "0^NOT A PROVIDER"
+31 ;
DEA(FG,IEN,DATE,RXDEA) ;sr. ef. Return users DEA # or Facility DEA_"-"_user VA# or null
+1 ;ICR #2343
+2 ;If FG is 1: DEA# or VA#
+3 ;Fee Basis, C&A providers only return DEA# or null - p609/REM
+4 ;Non-VA prescriber only return DEA# or null - p545
+5 ;Add XDT=DEA expiration date. If XDT unpopulated, its expired. - p609/REM
+6 ;DATE is the date to be checked against the DEA# Expiration Date (Default: Today)-p739
+7 ;If a DEA# is passed in RXDEA, check if that # has all the credentials.
+8 NEW DEA,FB,IN,INN,N,N1,XDT,VA,FAIL,I,J,K,RET,ALTRET,NVA
+9 SET IEN=$GET(IEN,DUZ)
SET INN=+DUZ(2)
if '$GET(FG)
SET FG=""
if '$DATA(RXDEA)
SET RXDEA=""
+10 ;p739
if '$GET(DATE)
SET DATE=DT
+11 SET N=$GET(^VA(200,IEN,"PS"))
+12 ;p545
SET NVA=$GET(^VA(200,IEN,"TPB"))
+13 SET VA=$PIECE(N,U,3)
+14 ;Fee Basis or C&A provider -p609 or NON-VA prescriber
IF $PIECE(N,U,6)=4!($PIECE(N,U,6)=3)!($PIECE(NVA,U,1)=1)
SET FB=1
+15 SET RET=""
SET ALTRET=""
+16 IF $LENGTH(RXDEA)>1
Begin DoDot:1
+17 SET I=$ORDER(^VA(200,IEN,"PS4","B",$PIECE(RXDEA,"-"),0))
if I
Begin DoDot:2
+18 SET J=$PIECE($GET(^VA(200,IEN,"PS4",I,0)),U,3)
if J
Begin DoDot:3
+19 SET XDT=$PIECE($GET(^XTV(8991.9,J,0)),U,4)
if 'XDT
QUIT
+20 IF XDT'<DATE
SET RET=RXDEA
End DoDot:3
End DoDot:2
End DoDot:1
if RET]""
QUIT RXDEA
QUIT ""
+21 SET J=0
FOR
SET J=$ORDER(^VA(200,IEN,"PS4",J))
if 'J
QUIT
Begin DoDot:1
+22 SET NP=1
SET K=$PIECE($GET(^VA(200,IEN,"PS4",J,0)),U,3)
if K
Begin DoDot:2
+23 IF $PIECE($GET(^XTV(8991.9,K,0)),U,6)=1
Begin DoDot:3
+24 SET XDT=$PIECE($GET(^XTV(8991.9,K,0)),U,4)
+25 IF 'XDT
SET RET="Q"
QUIT
+26 IF RET'="Q"
Begin DoDot:4
+27 IF XDT'<DATE
SET RET=$PIECE(^VA(200,IEN,"PS4",J,0),U)
+28 IF XDT<DATE
SET RET="E"
End DoDot:4
End DoDot:3
+29 ; Alternate return (ALTRET) value when FB=1 (non-va provider), no valid individual DEA's, use institutional DEA
+30 IF '($LENGTH(RET)>6)
IF '$LENGTH(ALTRET)
IF ($PIECE($GET(^XTV(8991.9,K,0)),U,7)=1)
Begin DoDot:3
+31 SET XDT=$PIECE($GET(^XTV(8991.9,K,0)),U,4)
+32 if 'XDT
QUIT
if XDT<DATE
QUIT
+33 NEW SUF
SET ALTRET=$PIECE(^VA(200,IEN,"PS4",J,0),U)
SET SUF=$PIECE(^VA(200,IEN,"PS4",J,0),U,2)
+34 IF $LENGTH(SUF)
SET ALTRET=ALTRET_"-"_SUF
End DoDot:3
+35 ; If there's an individual DEA, use it as the preferred alternate, regardless of 'use for inpatient' flag
+36 IF '($LENGTH(RET)>6)
IF ($PIECE($GET(^XTV(8991.9,K,0)),U,7)=2)
IF '$LENGTH(ALTRET)!(ALTRET["-")
Begin DoDot:3
+37 SET XDT=$PIECE($GET(^XTV(8991.9,K,0)),U,4)
+38 if 'XDT
QUIT
if XDT<DATE
QUIT
+39 SET ALTRET=$PIECE(^VA(200,IEN,"PS4",J,0),U)
End DoDot:3
End DoDot:2
End DoDot:1
+40 IF '($LENGTH(RET)>6)
IF $LENGTH(ALTRET)
QUIT ALTRET
+41 if RET="Q"
QUIT ""
+42 if $LENGTH(RET)>6
QUIT RET
+43 if $GET(FB)
QUIT ""
+44 if $GET(FG)
QUIT VA
+45 ;*689 - prevent failover
+46 SET FAIL=$$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I")
+47 IF FAIL=0
IF RET="E"
QUIT ""
+48 ;Check signed-in Inst.
SET IN=$PIECE($GET(^DIC(4,INN,"DEA")),U)
+49 IF '$LENGTH(IN)
Begin DoDot:1
+50 NEW XU1
DO PARENT^XUAF4("XU1","`"_INN,"PARENT FACILITY")
+51 SET INN=$ORDER(XU1("P",""))
IF INN
SET IN=$PIECE($GET(^DIC(4,INN,"DEA")),U)
+52 QUIT
End DoDot:1
+53 ;check DEA EXPIRATION DATE
NEW XUEXDT
IF INN
SET XUEXDT=$PIECE($GET(^DIC(4,INN,"DEA")),U,2)
+54 SET XUEXDT=$GET(XUEXDT)
+55 ;check DEA EXPIRATION DATE
IF $LENGTH(VA)
IF $LENGTH(IN)
IF $LENGTH(XUEXDT)
IF XUEXDT'<DATE
QUIT IN_"-"_VA
+56 QUIT ""
+57 ;
DETOX(IEN,DATE) ;*689 - Returns the Detox # from file 8991.9/200 - p580/REM
+1 ;ICR #2343
+2 ;Return Detox# - valid detox# and DEA Xdate is valid
+3 ;Return null - if no detox or the DEA Xdate is unpopulated
+4 ;Return DEA Expiration Date - valid detox# but expired DEA Xdate
+5 ;IEN is used to lookup user in file #200
+6 ;DATE is the date to be checked against the Detox# Expiration Date (Default: Today)-p739
+7 if 'IEN
QUIT ""
+8 NEW DET,XDT,N,N1,I,NP,J,AR1,AR2,AR3,AR4,VDEA
SET (N,NP,VDEA)=0
SET DET=""
+9 ;p739
if '$GET(DATE)
SET DATE=DT
+10 SET I=0
FOR
SET I=$ORDER(^VA(200,IEN,"PS4",I))
if 'I
QUIT
Begin DoDot:1
+11 SET NP=1
SET J=$$GET1^DIQ(200.5321,I_","_IEN,.03,"I")
if 'J
QUIT
Begin DoDot:2
+12 if $$GET1^DIQ(8991.9,J,.07,"I")=1
QUIT
+13 SET XDT=$$GET1^DIQ(8991.9,J,.04,"I")
if 'XDT
QUIT
+14 SET DET=$$GET1^DIQ(8991.9,J,.03)
+15 SET N=N+1
+16 IF XDT<DATE
IF $LENGTH(DET)
if N=1
SET AR4(XDT)=""
SET AR3(9999999-XDT,DET)=""
QUIT
+17 if XDT'<DATE
SET VDEA=1
+18 if '$LENGTH(DET)
QUIT
+19 IF $$GET1^DIQ(8991.9,J,.06,"I")=1
SET AR1(9999999-XDT,DET)=""
+20 IF '$TEST
SET AR2(9999999-XDT,DET)=""
End DoDot:2
End DoDot:1
+21 SET I=""
SET I=$ORDER(AR1(I))
if I
QUIT $ORDER(AR1(I,""))
+22 SET I=""
SET I=$ORDER(AR2(I))
if I
QUIT $ORDER(AR2(I,""))
+23 ;I VDEA,N S I="",I=$O(AR3(I)) Q:I $O(AR3(I,""))
+24 SET I=""
SET I=$ORDER(AR3(I))
if I
QUIT $ORDER(AR3(I,""))
+25 SET I=""
SET I=$ORDER(AR4(I))
if I
QUIT I
+26 if NP
QUIT ""
+27 SET N=$GET(^VA(200,IEN,"PS"))
SET N1=$GET(^VA(200,IEN,"QAR"))
+28 SET DET=$PIECE(N,U,11)
SET XDT=$PIECE(N1,U,9)
+29 ;p739
IF $LENGTH(DET)
IF $LENGTH(XDT)
IF XDT'<DATE
QUIT DET
+30 ;p739
IF $LENGTH(DET)
IF $LENGTH(XDT)
IF XDT<DATE
QUIT XDT
+31 QUIT ""
+32 ;
SDEA(FG,IEN,PSDEA,DATE,IDEA,INIEN) ;validation for new DEA regulations p580-JC(CPRS)
+1 ;ICR #2343
+2 ;Returns: DEA#, Facility DEA_"-"_user VA#, 1, 2, or 4^expiration date
+3 ;No longer used - Retained for backward compatibility
+4 ;IEN is used to lookup user in file #200
+5 ;PSDEA is the DEA schedule
+6 ;DATE is the date to be checked against the DEA# Expiration Date (Default: Today); p739
+7 ;IDEA is the DEA# or an "I" for Inpatient use to check for schedule
+8 ;*689
+9 NEW DEA,N,N3,I,J,K,A,E,FOVR,XDT,Y,VA,FB,DEATYP,NVA,SMATCHNP,SMATCHIP,SMATCH,SMATCHVA,DEARR
+10 ;p739
if '$GET(DATE)
SET DATE=DT
+11 if '$GET(INIEN)
SET INIEN=""
+12 SET SMATCH=""
SET SMATCHNP=""
SET SMATCHIP=""
SET E=""
SET DEARR=""
+13 SET N=$GET(^VA(200,IEN,"PS"))
SET VA=$PIECE(N,U,3)
SET (DEA,N3,E,FB)=""
+14 ;p545
SET NVA=$GET(^VA(200,IEN,"TPB"))
+15 ;Fee Basis or C&A provider -p609 or NON-VA prescriber
IF $PIECE(N,U,6)=4!($PIECE(N,U,6)=3)!($PIECE(NVA,U,1)=1)
SET FB=1
+16 SET IDEA=$GET(IDEA)
SET FG=$GET(FG)
SET IEN=$GET(IEN)
SET PSDEA=$GET(PSDEA)
+17 IF $GET(PSDEA)=""
QUIT 1
+18 SET FOVR=$$GET^XPAR("SYS","PSOEPCS EXPIRED DEA FAILOVER",1,"I")
+19 IF $LENGTH(IDEA)
IF $LENGTH(IDEA,"-")=2
IF $PIECE(IDEA,"-",2)=VA
GOTO CVA
+20 IF ($LENGTH(IDEA)<2)
IF '$ORDER(^VA(200,IEN,"PS4",0))
GOTO CVA
+21 IF $LENGTH(IDEA)<2
Begin DoDot:1
+22 SET J=0
FOR
SET J=$ORDER(^VA(200,IEN,"PS4",J))
if 'J
QUIT
Begin DoDot:2
+23 SET K=$PIECE($GET(^VA(200,IEN,"PS4",J,0)),U,3)
if K
Begin DoDot:3
+24 SET DEATYP=$PIECE($GET(^XTV(8991.9,K,0)),U,7)
+25 SET N=$GET(^XTV(8991.9,K,0))
+26 SET XDT=$PIECE(N,U,4)
if 'XDT
QUIT
+27 ; 'Use for Inpatient' DEA is preferred
IF $PIECE(N,U,6)=1
SET DEA=$PIECE(N,U)
Begin DoDot:4
+28 IF XDT<DATE
SET SMATCHIP=1
SET Y=XDT
XECUTE ^DD("DD")
SET DEARR=4_U_Y
+29 IF XDT'<DATE
SET N3=$SELECT(DEATYP=2:$GET(^XTV(8991.9,K,2)),1:$GET(^VA(200,IEN,"PS3")))
Begin DoDot:5
+30 SET SMATCHIP=$$SCHK(DEA,PSDEA,N3)
End DoDot:5
QUIT
+31 IF 'FOVR
IF XDT<DATE
SET Y=XDT
XECUTE ^DD("DD")
SET E=DEARR
QUIT
+32 IF FB!'$LENGTH(VA)
SET E=DEARR
QUIT
+33 DO GVA(INIEN)
if DEA["-"
SET N3=$GET(^VA(200,IEN,"PS3"))
SET SMATCHVA=$$SCHK(DEA,PSDEA,N3)
+34 SET E=$SELECT($LENGTH(SMATCHVA)>1:"",1:2)
End DoDot:4
+35 ; Not Inpatient DEA - ignore if IDEA="I"
IF '$PIECE(N,U,6)
IF (IDEA'="I")
IF '$LENGTH(SMATCHNP)
SET DEA=$PIECE(N,U)
Begin DoDot:4
+36 IF XDT'<DATE
SET N3=$SELECT(DEATYP=2:$GET(^XTV(8991.9,K,2)),1:$GET(^VA(200,IEN,"PS3")))
Begin DoDot:5
+37 SET SMATCHNP=$$SCHK(DEA,PSDEA,N3)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
if $LENGTH(SMATCH)
QUIT
+38 ; 'Use for Inpatient' DEA
IF $LENGTH(SMATCHIP)>1
SET SMATCH=SMATCHIP
SET E=""
+39 ; Non-Inpatient DEA
IF ($LENGTH(SMATCHIP)<2)&($LENGTH(SMATCHNP)>1)
SET SMATCH=SMATCHNP
SET E=""
+40 ; Failover - Facility DEA
IF $LENGTH(SMATCH)<2
SET SMATCH=$SELECT($LENGTH($GET(SMATCHVA))&'E:$GET(SMATCHVA),$GET(SMATCHIP)=2:2,1:1)
End DoDot:1
if E
QUIT E
QUIT SMATCH
+41 IF $LENGTH(IDEA)>1
SET DEA=$PIECE(IDEA,"-")
+42 if $GET(DEA)=""
QUIT 1
+43 SET N=$ORDER(^XTV(8991.9,"B",DEA,0))
+44 if 'N
QUIT 1
+45 SET XDT=$PIECE($GET(^XTV(8991.9,N,0)),U,4)
IF 'XDT!(XDT<$$FMADD^XLFDT(DATE,1))
QUIT 4_"^"_XDT
+46 IF XDT'<DATE
Begin DoDot:1
+47 NEW DEATYP
SET DEATYP=$PIECE($GET(^XTV(8991.9,N,0)),U,7)
+48 SET N3=$SELECT(DEATYP=1:$GET(^VA(200,IEN,"PS3")),1:$GET(^XTV(8991.9,N,2)))
End DoDot:1
QUIT $$SCHK(DEA,$GET(PSDEA),$GET(N3))
+49 IF 'FOVR
IF (XDT<DATE)
SET Y=XDT
XECUTE ^DD("DD")
QUIT 4_U_Y
CVA ; VA number
+1 SET INIEN=+$GET(INIEN)
+2 if FB
QUIT 1
+3 if '$LENGTH(VA)
QUIT 1
+4 DO GVA(INIEN)
if DEA["-"
SET N3=$GET(^VA(200,IEN,"PS3"))
+5 if $GET(DEA)=""
QUIT 1
+6 SET SMATCH=$$SCHK(DEA,PSDEA,N3)
+7 QUIT SMATCH
SCHK(DEA,PSDEA,N3) ;
+1 IF $GET(N3)=""!(N3'[1)
QUIT 2
+2 IF $GET(PSDEA)=""
QUIT 2
+3 IF $LENGTH(N3,"^")'=6
QUIT 2
+4 FOR I=1:1:6
SET A(I)=$PIECE(N3,U,I)
+5 IF PSDEA=2
QUIT $SELECT('A(1):2,1:DEA)
+6 IF PSDEA="2n"
QUIT $SELECT('A(2):2,1:DEA)
+7 IF PSDEA=3
QUIT $SELECT('A(3):2,1:DEA)
+8 IF PSDEA="3n"
QUIT $SELECT('A(4):2,1:DEA)
+9 IF PSDEA=4
QUIT $SELECT('A(5):2,1:DEA)
+10 IF PSDEA=5
QUIT $SELECT('A(6):2,1:DEA)
+11 QUIT DEA
+12 ;
GVA(INIEN) ; Find Facility DEA and VA #
+1 ; INN - Pointer to INSTITUTION file (#4)
+2 NEW IN,INN,ININN
+3 SET INN=$SELECT($GET(INIEN):INIEN,1:+DUZ(2))
+4 ;Check signed-in Inst.
SET IN=$PIECE($GET(^DIC(4,INN,"DEA")),U)
+5 IF '$LENGTH(IN)
Begin DoDot:1
+6 NEW XU1
DO PARENT^XUAF4("XU1","`"_INN,"PARENT FACILITY")
+7 SET INN=$ORDER(XU1("P",""))
IF INN
SET IN=$PIECE($GET(^DIC(4,INN,"DEA")),U)
+8 QUIT
End DoDot:1
+9 ;check DEA EXPIRATION DATE
NEW XUEXDT
IF INN
SET XUEXDT=$PIECE($GET(^DIC(4,INN,"DEA")),U,2)
+10 SET XUEXDT=$GET(XUEXDT)
+11 ;check DEA EXPIRATION DATE
IF $LENGTH(VA)
IF $LENGTH(IN)
IF $LENGTH(XUEXDT)
IF (XUEXDT'<DATE)
SET DEA=IN_"-"_VA
+12 QUIT
+13 ;
VDEA(RETURN,IEN) ;ISP/RFR - Verify a provider is properly configured for ePCS
+1 ;PARAMETERS: IEN - Internal Entry Number in the NEW PERSON file (#200)
+2 ; RETURN - Reference to an array in which text explaining
+3 ; deficiencies and listing prescribable schedules
+4 ; is placed, with each deficiency and the list of
+5 ; schedules on a separate node
+6 ;RETURN: 1 - Provider is properly configured for ePCS
+7 ; 0 - Provider is not properly configured for ePCS
+8 NEW STATUS,DEA,RETVAL,DATE,NODEA
+9 ; p499 - Use new DEA NUMBERS file (#8991.9)
+10 IF $ORDER(^VA(200,IEN,"PS4",0))
SET STATUS=$$VDEADNM^XUSER3(.RETURN,IEN)
QUIT STATUS
+11 ;
+12 SET RETVAL=1
SET STATUS=$$ACTIVE(IEN)
+13 IF STATUS=""
SET RETURN("User account does not exist.")=""
SET RETVAL=0
+14 IF STATUS=0
SET RETURN("User cannot sign on.")=""
SET RETVAL=0
+15 IF +STATUS=0
IF ($PIECE(STATUS,U,2)'="")
SET RETURN("User account status: "_$PIECE(STATUS,U,2))=""
SET RETVAL=0
+16 if STATUS=""
QUIT RETVAL
+17 IF '$DATA(^XUSEC("ORES",IEN))
Begin DoDot:1
+18 SET RETURN("Does not hold the ORES security key.")=""
SET RETVAL=0
End DoDot:1
+19 IF +$PIECE($GET(^VA(200,IEN,"PS")),U,1)'=1
Begin DoDot:1
+20 SET RETURN("Is not authorized to write medication orders.")=""
SET RETVAL=0
End DoDot:1
+21 SET NODEA=1
+22 IF $PIECE($GET(^VA(200,IEN,"PS")),U,3)=""
Begin DoDot:1
+23 SET RETURN("Has neither a DEA number nor a VA number.")=""
SET RETVAL=0
End DoDot:1
+24 ;I +$G(NODEA),($P($G(^VA(200,IEN,"PS")),U,3)'="") S RETVAL=1
+25 SET DATE=+$PIECE($GET(^VA(200,IEN,"PS")),U,4)
+26 IF DATE>0
IF (DATE<=DT)
Begin DoDot:1
+27 SET RETURN("Is no longer able to write medication orders (inactive date).")=""
SET RETVAL=0
End DoDot:1
+28 IF $DATA(^VA(200,IEN,"PS3"))
Begin DoDot:1
+29 NEW NODE
+30 SET NODE=$$STRIP^XLFSTR(^VA(200,IEN,"PS3"),U)
SET NODE=$$STRIP^XLFSTR(NODE,0)
+31 IF $GET(NODE)=""
SET RETURN("Is not permitted to prescribe any schedules.")=""
SET RETVAL=0
QUIT
+32 IF $GET(NODE)'=""
Begin DoDot:2
+33 NEW PIECE,SCHED,SPEC,ASCHED
+34 SET SPEC("SCHEDULE ")=""
+35 SET ASCHED=1
+36 FOR PIECE=1:1:6
Begin DoDot:3
+37 IF +$PIECE(^VA(200,IEN,"PS3"),U,PIECE)>0
Begin DoDot:4
+38 NEW LABEL,ERROR
+39 SET LABEL=$$REPLACE^XLFSTR($$GET1^DID(200,"55."_PIECE,,"LABEL",,"ERROR"),.SPEC)
+40 if $GET(LABEL)=""
SET LABEL="Unknown field #55."_PIECE
+41 SET SCHED=$SELECT($GET(SCHED)'="":SCHED_U,1:"")_LABEL
End DoDot:4
+42 IF +$PIECE(^VA(200,IEN,"PS3"),U,PIECE)=0
SET ASCHED=0
End DoDot:3
+43 IF ASCHED=1
SET RETURN("Is permitted to prescribe all schedules.")=""
+44 IF ASCHED=0
Begin DoDot:3
+45 NEW DELIMIT,INDEX,TEXT
+46 SET DELIMIT=", "
+47 FOR INDEX=1:1:$LENGTH(SCHED,U)
Begin DoDot:4
+48 if INDEX=$LENGTH(SCHED,U)
SET DELIMIT=" and "
+49 SET TEXT=$SELECT($GET(TEXT)'="":TEXT_DELIMIT,1:"")_$PIECE(SCHED,U,INDEX)
End DoDot:4
+50 SET RETURN("Is permitted to prescribe schedule"_$SELECT($LENGTH(SCHED,U)>1:"s",1:"")_" "_TEXT_".")=""
End DoDot:3
End DoDot:2
End DoDot:1
+51 ;*689
+52 IF '$DATA(^VA(200,IEN,"PS3"))
SET RETURN("Is not permitted to prescribe any schedules.")=""
SET RETVAL=0
+53 QUIT RETVAL
+54 ;
DIV4(XUROOT,XUDUZ) ;Return the Divisions that this user is assigned to.
+1 ;Returns 0 - no institution for user, 1 - institution for user
+2 ;XUROOT is passed by reference.
+3 NEW %,%1
if $GET(XUDUZ)=""
SET XUDUZ=DUZ
SET (%,%1)=0
+4 FOR
SET %=$ORDER(^VA(200,XUDUZ,2,%))
if %'>0
QUIT
SET XUROOT(%)=$PIECE($GET(^(%,0)),U,2)
SET %1=1
+5 QUIT %1
+6 ;
VDEADNA(RETURN,NPIEN,DNDEAIEN) ; -- ENTRY POINT for a single DEA Number
+1 QUIT $$VDEADNA^XUSER3(.RETURN,NPIEN,DNDEAIEN)
+2 ;
VDEADNM(RETURN,NPIEN) ;ISP/RFR - Verify a provider is properly configured for ePCS
+1 QUIT $$VDEADNM^XUSER3(.RETURN,NPIEN)
+2 ;
NAME(IEN,FL) ;Return the full name from Name Components file
+1 NEW NA
SET NA("FILE")=200
SET NA("FIELD")=.01
SET NA("IENS")=IEN
+2 ;Valid are Famly or Given
SET FL=$GET(FL,"G")
+3 if "FG"'[FL
SET FL="G"
+4 QUIT $$NAMEFMT^XLFNAME(.NA,FL,"CMDP")
+5 ;
HL7(IEN) ;Return a HL7 name from the components file
+1 NEW NA
SET NA("FILE")=200
SET NA("FIELD")=.01
SET NA("IENS")=IEN
+2 QUIT $$HLNAME^XLFNAME(.NA,"","~")
+3 ;
SCR200() ;Whole File Screen logic for file 200
+1 ; ZEXCEPT: DIC,DINDEX - Kernel exemption
+2 ;
+3 ; Test to see if FileMan can "talk" to the user, IA# 4577
+4 IF $GET(DIC(0))'["E"
QUIT 1
+5 ;
+6 ; Test to see if index being searched is SSN, IA# 4578
+7 IF $GET(DINDEX)'="SSN"
QUIT 1
+8 ;
+9 ; Test for Security Key
+10 IF $GET(DUZ)
IF $DATA(^XUSEC("XUSHOWSSN",DUZ))
QUIT 1
+11 ;
+12 ; Default - None of the above is TRUE
+13 QUIT 0
+14 ;
PRDEA(IEN) ; 689 - Return Prescriber's active DEA
+1 ; IEN-Prescriber DUZ from file 200
+2 QUIT $$PRDEA^XUPSPRA(IEN)
+3 ;
PRXDT(IEN) ; 689 - Return Prescriber's default DEA Expiration Date
+1 ; IEN-Prescriber DUZ from file 200
+2 QUIT $$PRXDT^XUPSPRA(IEN)
+3 ;
PRSCH(IEN) ; 689 - Return Prescriber's default DEA schedules
+1 ; IEN-Prescriber DUZ from file 200
+2 QUIT $$PRSCH^XUPSPRA(IEN)
+3 ;
DEAXDT(DEA) ; 689 - Return Expiration Date for DEA
+1 ; DEA-DEA Number. Example: AH1966007
+2 QUIT $$DEAXDT^XUPSPRA(DEA)
+3 ;
DEASCH(DEA) ; 689 - Return DEA Schedules for DEA number
+1 ; DEA-DEA Number. Example: AH1966007
+2 QUIT $$DEASCH^XUPSPRA(DEA)
