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**;Jul 10, 1995;Build 4
;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),"^",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) ;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
;Add XDT=DEA expiration date. If XDT unpopulated, its expired. -p609
;DATE is the date to be checked against the DEA# Expiration Date (Default: Today)-p739
N DEA,FB,IN,INN,N,N1,XDT,VA
S IEN=$G(IEN,DUZ),INN=+DUZ(2)
S:'$G(DATE) DATE=DT ;p739
S N=$G(^VA(200,IEN,"PS")),N1=$G(^VA(200,IEN,"QAR"))
S DEA=$P(N,U,2),VA=$P(N,U,3),XDT=$P(N1,U,9)
I $P(N,U,6)=4!($P(N,U,6)=3) S FB=1 ;Fee Basis or C&A provider -p609
;I $L(DEA),$S('$L($P(N1,U,9)):1,1:$P(N1,U,9)>DT) Q DEA
I $L(DEA),$L(XDT),XDT'<DATE Q DEA ;p609,p739
I $G(FB) Q "" ;p609
I $G(FG) Q VA
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'<DT Q IN_"-"_VA ;check DEA EXPIRATION DATE
;I $L(VA),$L(IN) Q IN_"-"_VA
Q ""
;
DETOX(IEN,DATE) ;Return the Detox/Maintenance ID in file 200 - p580,p739
;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
N DET,XDT,N,N1
S:'$G(DATE) DATE=DT ;p739
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
;I $L(DET),$S('$L($P(N1,U,9)):1,1:$P(N1,U,9)>DT) Q DTX
Q ""
;
SDEA(FG,IEN,PSDEA,DATE) ;validation for new DEA regulations p580-JC(CPRS)
;ICR #2343
;Returns: DEA#, Facility DEA_"-"_user VA#, 1, 2, or 4^expiration date
;If FG is 1: DEA# or VA# - similar to $$DEA
;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
N DEA,N3,I,A,NALL,E,DA,XD,N,N1,Y
S:'$G(DATE) DATE=DT ;p739
S FG=$G(FG),IEN=$G(IEN),PSDEA=$G(PSDEA)
S DEA=$$DEA(FG,IEN,DATE) I DEA="" D Q E ;p736
. S E=1
. S N=$G(^VA(200,IEN,"PS")),N1=$G(^VA(200,IEN,"QAR"))
. S DA=$P(N,U,2),XD=$P(N1,U,9)
. I $L(DA),$L(XD),XD<DATE S Y=XD X ^DD("DD") S E=4_"^"_Y ;p739
I $G(PSDEA)="" Q 1
; I '$D(^VA(200,IEN,"PS3")) Q DEA ;XU*8*751 - Remove Grandfathering
S N3=$G(^VA(200,IEN,"PS3")) ;XU*8*751 - Formerly Grandfathered Providers are not authorized for any schedules.
S NALL=1 F I=1:1:6 S A(I)=$P(N3,"^",I) I A(I) S NALL=0
I NALL Q 2 ; D Q 2 ; XU*8*751 - No longer delete DEA# field (#53.2) and VA# field (#53.3)
; . I $G(^VA(200,IEN,"PS"))="" Q ; from NEW PERSON (#200) when the provider is not defined for any CS
; . S $P(^("PS"),"^",2)="",$P(^("PS"),"^",3)="" ; Federal Schedule fields (#55.1-#55.6) in NEW PERSON file
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
;
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
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
I $P($G(^VA(200,IEN,"PS")),U,2)'="" D
. N DATE
. S DATE=+$P($G(^VA(200,IEN,"QAR")),U,9)
. I DATE=0 S RETURN("Has a DEA number with no expiration date.")="",RETVAL=0,NODEA=1
. I DATE>0,(DATE<=DT) S RETURN("Has an expired DEA number.")="",RETVAL=0,NODEA=1
I $P($G(^VA(200,IEN,"PS")),U,2)="" D
. 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_".")=""
;XU*8*751 - Remove Grandfathering
;I '$D(^VA(200,IEN,"PS3")) S RETURN("Is permitted to prescribe all schedules due to grandfathering.")=""
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
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSER 9835 printed Jan 19, 2023@21:37:43 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**;Jul 10, 1995;Build 4
+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),"^",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) ;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
+4 ;Add XDT=DEA expiration date. If XDT unpopulated, its expired. -p609
+5 ;DATE is the date to be checked against the DEA# Expiration Date (Default: Today)-p739
+6 NEW DEA,FB,IN,INN,N,N1,XDT,VA
+7 SET IEN=$GET(IEN,DUZ)
SET INN=+DUZ(2)
+8 ;p739
if '$GET(DATE)
SET DATE=DT
+9 SET N=$GET(^VA(200,IEN,"PS"))
SET N1=$GET(^VA(200,IEN,"QAR"))
+10 SET DEA=$PIECE(N,U,2)
SET VA=$PIECE(N,U,3)
SET XDT=$PIECE(N1,U,9)
+11 ;Fee Basis or C&A provider -p609
IF $PIECE(N,U,6)=4!($PIECE(N,U,6)=3)
SET FB=1
+12 ;I $L(DEA),$S('$L($P(N1,U,9)):1,1:$P(N1,U,9)>DT) Q DEA
+13 ;p609,p739
IF $LENGTH(DEA)
IF $LENGTH(XDT)
IF XDT'<DATE
QUIT DEA
+14 ;p609
IF $GET(FB)
QUIT ""
+15 IF $GET(FG)
QUIT VA
+16 ;Check signed-in Inst.
SET IN=$PIECE($GET(^DIC(4,INN,"DEA")),U)
+17 IF '$LENGTH(IN)
Begin DoDot:1
+18 NEW XU1
DO PARENT^XUAF4("XU1","`"_INN,"PARENT FACILITY")
+19 SET INN=$ORDER(XU1("P",""))
IF INN
SET IN=$PIECE($GET(^DIC(4,INN,"DEA")),U)
+20 QUIT
End DoDot:1
+21 ;check DEA EXPIRATION DATE
NEW XUEXDT
IF INN
SET XUEXDT=$PIECE($GET(^DIC(4,INN,"DEA")),U,2)
+22 SET XUEXDT=$GET(XUEXDT)
+23 ;check DEA EXPIRATION DATE
IF $LENGTH(VA)
IF $LENGTH(IN)
IF $LENGTH(XUEXDT)
IF XUEXDT'<DT
QUIT IN_"-"_VA
+24 ;I $L(VA),$L(IN) Q IN_"-"_VA
+25 QUIT ""
+26 ;
DETOX(IEN,DATE) ;Return the Detox/Maintenance ID in file 200 - p580,p739
+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 NEW DET,XDT,N,N1
+8 ;p739
if '$GET(DATE)
SET DATE=DT
+9 SET N=$GET(^VA(200,IEN,"PS"))
SET N1=$GET(^VA(200,IEN,"QAR"))
+10 SET DET=$PIECE(N,U,11)
SET XDT=$PIECE(N1,U,9)
+11 ;p739
IF $LENGTH(DET)
IF $LENGTH(XDT)
IF XDT'<DATE
QUIT DET
+12 ;p739
IF $LENGTH(DET)
IF $LENGTH(XDT)
IF XDT<DATE
QUIT XDT
+13 ;I $L(DET),$S('$L($P(N1,U,9)):1,1:$P(N1,U,9)>DT) Q DTX
+14 QUIT ""
+15 ;
SDEA(FG,IEN,PSDEA,DATE) ;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 ;If FG is 1: DEA# or VA# - similar to $$DEA
+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 NEW DEA,N3,I,A,NALL,E,DA,XD,N,N1,Y
+8 ;p739
if '$GET(DATE)
SET DATE=DT
+9 SET FG=$GET(FG)
SET IEN=$GET(IEN)
SET PSDEA=$GET(PSDEA)
+10 ;p736
SET DEA=$$DEA(FG,IEN,DATE)
IF DEA=""
Begin DoDot:1
+11 SET E=1
+12 SET N=$GET(^VA(200,IEN,"PS"))
SET N1=$GET(^VA(200,IEN,"QAR"))
+13 SET DA=$PIECE(N,U,2)
SET XD=$PIECE(N1,U,9)
+14 ;p739
IF $LENGTH(DA)
IF $LENGTH(XD)
IF XD<DATE
SET Y=XD
XECUTE ^DD("DD")
SET E=4_"^"_Y
End DoDot:1
QUIT E
+15 IF $GET(PSDEA)=""
QUIT 1
+16 ; I '$D(^VA(200,IEN,"PS3")) Q DEA ;XU*8*751 - Remove Grandfathering
+17 ;XU*8*751 - Formerly Grandfathered Providers are not authorized for any schedules.
SET N3=$GET(^VA(200,IEN,"PS3"))
+18 SET NALL=1
FOR I=1:1:6
SET A(I)=$PIECE(N3,"^",I)
IF A(I)
SET NALL=0
+19 ; D Q 2 ; XU*8*751 - No longer delete DEA# field (#53.2) and VA# field (#53.3)
IF NALL
QUIT 2
+20 ; . I $G(^VA(200,IEN,"PS"))="" Q ; from NEW PERSON (#200) when the provider is not defined for any CS
+21 ; . S $P(^("PS"),"^",2)="",$P(^("PS"),"^",3)="" ; Federal Schedule fields (#55.1-#55.6) in NEW PERSON file
+22 IF PSDEA=2
QUIT $SELECT('A(1):2,1:DEA)
+23 IF PSDEA="2n"
QUIT $SELECT('A(2):2,1:DEA)
+24 IF PSDEA=3
QUIT $SELECT('A(3):2,1:DEA)
+25 IF PSDEA="3n"
QUIT $SELECT('A(4):2,1:DEA)
+26 IF PSDEA=4
QUIT $SELECT('A(5):2,1:DEA)
+27 IF PSDEA=5
QUIT $SELECT('A(6):2,1:DEA)
+28 QUIT DEA
+29 ;
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 SET RETVAL=1
SET STATUS=$$ACTIVE(IEN)
+10 IF STATUS=""
SET RETURN("User account does not exist.")=""
SET RETVAL=0
+11 IF STATUS=0
SET RETURN("User cannot sign on.")=""
SET RETVAL=0
+12 IF +STATUS=0
IF ($PIECE(STATUS,U,2)'="")
SET RETURN("User account status: "_$PIECE(STATUS,U,2))=""
SET RETVAL=0
+13 if STATUS=""
QUIT RETVAL
+14 IF '$DATA(^XUSEC("ORES",IEN))
Begin DoDot:1
+15 SET RETURN("Does not hold the ORES security key.")=""
SET RETVAL=0
End DoDot:1
+16 IF +$PIECE($GET(^VA(200,IEN,"PS")),U,1)'=1
Begin DoDot:1
+17 SET RETURN("Is not authorized to write medication orders.")=""
SET RETVAL=0
End DoDot:1
+18 IF $PIECE($GET(^VA(200,IEN,"PS")),U,2)'=""
Begin DoDot:1
+19 NEW DATE
+20 SET DATE=+$PIECE($GET(^VA(200,IEN,"QAR")),U,9)
+21 IF DATE=0
SET RETURN("Has a DEA number with no expiration date.")=""
SET RETVAL=0
SET NODEA=1
+22 IF DATE>0
IF (DATE<=DT)
SET RETURN("Has an expired DEA number.")=""
SET RETVAL=0
SET NODEA=1
End DoDot:1
+23 IF $PIECE($GET(^VA(200,IEN,"PS")),U,2)=""
Begin DoDot:1
+24 SET NODEA=1
+25 IF $PIECE($GET(^VA(200,IEN,"PS")),U,3)=""
Begin DoDot:2
+26 SET RETURN("Has neither a DEA number nor a VA number.")=""
SET RETVAL=0
End DoDot:2
End DoDot:1
+27 IF +$GET(NODEA)
IF ($PIECE($GET(^VA(200,IEN,"PS")),U,3)'="")
SET RETVAL=1
+28 SET DATE=+$PIECE($GET(^VA(200,IEN,"PS")),U,4)
+29 IF DATE>0
IF (DATE<=DT)
Begin DoDot:1
+30 SET RETURN("Is no longer able to write medication orders (inactive date).")=""
SET RETVAL=0
End DoDot:1
+31 IF $DATA(^VA(200,IEN,"PS3"))
Begin DoDot:1
+32 NEW NODE
+33 SET NODE=$$STRIP^XLFSTR(^VA(200,IEN,"PS3"),U)
SET NODE=$$STRIP^XLFSTR(NODE,0)
+34 IF $GET(NODE)=""
SET RETURN("Is not permitted to prescribe any schedules.")=""
SET RETVAL=0
QUIT
+35 IF $GET(NODE)'=""
Begin DoDot:2
+36 NEW PIECE,SCHED,SPEC,ASCHED
+37 SET SPEC("SCHEDULE ")=""
+38 SET ASCHED=1
+39 FOR PIECE=1:1:6
Begin DoDot:3
+40 IF +$PIECE(^VA(200,IEN,"PS3"),U,PIECE)>0
Begin DoDot:4
+41 NEW LABEL,ERROR
+42 SET LABEL=$$REPLACE^XLFSTR($$GET1^DID(200,"55."_PIECE,,"LABEL",,"ERROR"),.SPEC)
+43 if $GET(LABEL)=""
SET LABEL="Unknown field #55."_PIECE
+44 SET SCHED=$SELECT($GET(SCHED)'="":SCHED_U,1:"")_LABEL
End DoDot:4
+45 IF +$PIECE(^VA(200,IEN,"PS3"),U,PIECE)=0
SET ASCHED=0
End DoDot:3
+46 IF ASCHED=1
SET RETURN("Is permitted to prescribe all schedules.")=""
+47 IF ASCHED=0
Begin DoDot:3
+48 NEW DELIMIT,INDEX,TEXT
+49 SET DELIMIT=", "
+50 FOR INDEX=1:1:$LENGTH(SCHED,U)
Begin DoDot:4
+51 if INDEX=$LENGTH(SCHED,U)
SET DELIMIT=" and "
+52 SET TEXT=$SELECT($GET(TEXT)'="":TEXT_DELIMIT,1:"")_$PIECE(SCHED,U,INDEX)
End DoDot:4
+53 SET RETURN("Is permitted to prescribe schedule"_$SELECT($LENGTH(SCHED,U)>1:"s",1:"")_" "_TEXT_".")=""
End DoDot:3
End DoDot:2
End DoDot:1
+54 ;XU*8*751 - Remove Grandfathering
+55 ;I '$D(^VA(200,IEN,"PS3")) S RETURN("Is permitted to prescribe all schedules due to grandfathering.")=""
+56 IF '$DATA(^VA(200,IEN,"PS3"))
SET RETURN("Is not permitted to prescribe any schedules.")=""
SET RETVAL=0
+57 QUIT RETVAL
+58 ;
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 ;
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
