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

XUSER.m

Go to the documentation of this file. 
  1. XUSER ;SFISC/RWF - A common set of user functions ;11/07/2012  11:56
  1.  ;;8.0;KERNEL;**75,97,99,150,226,267,288,330,370,373,580**;Jul 10, 1995;Build 47
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;Covered under DBIA #2343
  1.  Q
  1. LOOKUP(XUF) ;Do a user lookup
  1.  ;Parameter, "Q" to NOT ask OK.
  1.  ;Parameter, "A" Don't select current users who have a termination
  1.  ;               date prior to today's date
  1.  N DIC,XUDA,DIR,Y
  1. LK1 S DIC="^VA(200,",DIC(0)="AEMQZ" D ^DIC S XUDA=Y G:Y'>0 LKX
  1.  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
  1.  G:$G(XUF)["Q" LKX
  1.  S DIR(0)="Y",DIR("A")=" Is "_$P(XUDA,U,2)_" the one you want",DIR("B")="YES" D ^DIR
  1.  I Y'=1 S XUDA=-1 G:'$D(DIRUT) LK1
  1. LKX Q XUDA
  1.  ;
  1. ACTIVE(XUDA) ;Get if a user is active.
  1.  N %,X1,X2
  1.  S X1=$G(^VA(200,+$G(XUDA),0)),X2=$S(X1="":"",1:0)
  1.  I $L($P(X1,U,3)) S X2="1^"_$S($L($P($G(^VA(200,XUDA,.1)),U,2)):"ACTIVE",1:"NEW")
  1.  S:$P(X1,U,7)=1 X2="0^DISUSER"
  1.  S:X2["ACTIVE" $P(X2,U,3)=$P($G(^VA(200,XUDA,1.1)),U) ;Return last sign-on
  1.  S %=$P(X1,U,11) I %>0,%'>DT S X2="0^TERMINATED^"_%
  1.  Q X2
  1.  ;
  1. 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
  1.  ;bulletin recipients. p580 REM
  1.  N PSD,I
  1.  S PSD=$$FIND1^DIC(19.1,"","MX","PSDMGR","","","PSDERR") Q:PSD'>0
  1.  S I=0 F  S I=$O(^VA(200,"AB",PSD,I)) Q:I'>0  S XMY(I)=""
  1.  Q
  1.  ;
  1. PROVIDER(XUDA,XUF) ;See if user qualifies as a CPRS provider
  1.  ;XUDA = IEN of Record in New Person File
  1.  ;XUF = Flag to control processing
  1.  ;      0 or not passed, do not include Visitors
  1.  ;      1 include Visitors
  1.  N %,X1,X2,XUORES
  1.  ;Test to see if XUDA Passed:
  1.  I '$D(XUDA) Q ""
  1.  ;
  1.  ;Test for valid IEN:
  1.  S X1=$G(^VA(200,+$G(XUDA),0)),X2=$S(X1="":"",1:1) Q:X2="" ""
  1.  ;
  1.  ;See if user has XUORES Security Key:
  1.  S XUORES=$D(^XUSEC("XUORES",XUDA))
  1.  ;
  1.  ;Test for Access Code:
  1.  I $P(X1,U,3)]"" Q 1
  1.  ;
  1.  ;Test for a Termination Date not in the Future
  1.  ;AND Not owner of XUORES Security Key:
  1.  S %=$P(X1,U,11) I %>0,%'>DT,'XUORES Q "0^TERMINATED^"_%
  1.  ;
  1.  ;Test if user has XUORES Security key:
  1.  I XUORES Q 1
  1.  ;
  1.  ;Tests for Visitors:
  1.  I +$G(XUF),$D(^VA(200,"BB","VISITOR",XUDA)) Q 1
  1.  I $D(^VA(200,"BB","VISITOR",XUDA)) Q "0^VISITOR"
  1.  ;
  1.  ;Default:
  1.  Q "0^NOT A PROVIDER"
  1.  ;
  1. DEA(FG,IEN) ;sr. ef. Return users DEA # or Facility DEA_"-"_user VA# or null
  1.  ;ICR #2343
  1.  ;If FG is 1: DEA# or VA#
  1.  N DEA,VA,IN,N,N1,INN,XDT,FB
  1.  S IEN=$G(IEN,DUZ),INN=+DUZ(2)
  1.  S N=$G(^VA(200,IEN,"PS")),N1=$G(^VA(200,IEN,"QAR"))
  1.  S DEA=$P(N,U,2),VA=$P(N,U,3),XDT=$P(N1,U,9)
  1.  ;I $P(N,U,6)=4!($P(N,U,6)=3) S FB=1 ;Fee Basis or C&A  provider -p609
  1.  I $L(DEA),$S('$L($P(N1,U,9)):1,1:$P(N1,U,9)>DT) Q DEA
  1.  ;I $L(DEA),$L(XDT),XDT'<DT Q DEA ;p609
  1.  ;I $G(FB) Q "" ;p609
  1.  I $G(FG) Q VA
  1.  S IN=$P($G(^DIC(4,INN,"DEA")),U) ;Check signed-in Inst.
  1.  I '$L(IN) D
  1.  . N XU1 D PARENT^XUAF4("XU1","`"_INN,"PARENT FACILITY")
  1.  . S INN=$O(XU1("P","")) I INN S IN=$P($G(^DIC(4,INN,"DEA")),U)
  1.  . Q
  1.  I $L(VA),$L(IN) Q IN_"-"_VA
  1.  Q ""
  1.  ;
  1. DETOX(IEN) ;Return the Detox/Maintenance ID in file 200 - p580/REM
  1.  ;ICR #2343
  1.  ;Return Detox# - valid detox# and DEA Xdate is valid
  1.  ;Return null - if no detox or the DEA Xdate is unpopulated
  1.  ;Return DEA Expiration Date - valid detox# but expired DEA Xdate
  1.  ;IEN is used to lookup user in file #200
  1.  N DET,XDT,N,N1
  1.  S N=$G(^VA(200,IEN,"PS")),N1=$G(^VA(200,IEN,"QAR"))
  1.  S DET=$P(N,U,11),XDT=$P(N1,U,9)
  1.  I $L(DET),$L(XDT),XDT'<DT Q DET
  1.  I $L(DET),$L(XDT),XDT<DT Q XDT
  1.  ;I $L(DET),$S('$L($P(N1,U,9)):1,1:$P(N1,U,9)>DT) Q DTX
  1.  Q ""
  1.  ;
  1. SDEA(FG,IEN,PSDEA) ;validation for new DEA regulations p580-JC(CPRS)
  1.  ;ICR #2343
  1.  ;Returns: DEA#, Facility DEA_"-"_user VA#, 1, 2, or 4^expiration date 
  1.  ;If FG is 1: DEA# or VA# - similar to $$DEA
  1.  ;IEN is used to lookup user in file #200
  1.  ;PSDEA is the DEA schedule
  1.  N DEA,N3,I,A,NALL,E,DA,XD,N,N1
  1.  S FG=$G(FG),IEN=$G(IEN),PSDEA=$G(PSDEA)
  1.  S DEA=$$DEA(FG,IEN) I DEA="" D  Q E
  1.  . S E=1
  1.  . S N=$G(^VA(200,IEN,"PS")),N1=$G(^VA(200,IEN,"QAR"))
  1.  . S DA=$P(N,U,2),XD=$P(N1,U,9)
  1.  . I $L(DA),$L(XD),XD<DT S Y=XD X ^DD("DD") S E=4_"^"_Y
  1.  I $G(PSDEA)="" Q 1
  1.  I '$D(^VA(200,IEN,"PS3")) Q DEA
  1.  S N3=^VA(200,IEN,"PS3")
  1.  S NALL=1 F I=1:1:6 S A(I)=$P(N3,"^",I) I A(I) S NALL=0
  1.  I NALL D  Q 2
  1.  . I $G(^VA(200,IEN,"PS"))="" Q
  1.  . S $P(^("PS"),"^",2)="",$P(^("PS"),"^",3)=""
  1.  I PSDEA=2 Q $S('A(1):2,1:DEA)
  1.  I PSDEA="2n" Q $S('A(2):2,1:DEA)
  1.  I PSDEA=3 Q $S('A(3):2,1:DEA)
  1.  I PSDEA="3n" Q $S('A(4):2,1:DEA)
  1.  I PSDEA=4 Q $S('A(5):2,1:DEA)
  1.  I PSDEA=5 Q $S('A(6):2,1:DEA)
  1.  Q DEA
  1.  ;
  1. 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)
  1.  ;            RETURN - Reference to an array in which text explaining
  1.  ;                     deficiencies and listing prescribable schedules
  1.  ;                     is placed, with each deficiency and the list of
  1.  ;                     schedules on a separate node
  1.  ;RETURN: 1 - Provider is properly configured for ePCS
  1.  ;        0 - Provider is not properly configured for ePCS
  1.  N STATUS,DEA,RETVAL,DATE
  1.  S RETVAL=1,STATUS=$$ACTIVE(IEN)
  1.  I STATUS="" S RETURN("User account does not exist.")="",RETVAL=0
  1.  I STATUS=0 S RETURN("User cannot sign on.")="",RETVAL=0
  1.  I +STATUS=0,($P(STATUS,U,2)'="") S RETURN("User account status: "_$P(STATUS,U,2))="",RETVAL=0
  1.  Q:STATUS="" RETVAL
  1.  I '$D(^XUSEC("ORES",IEN)) D
  1.  .S RETURN("Does not hold the ORES security key.")="",RETVAL=0
  1.  I +$P($G(^VA(200,IEN,"PS")),U,1)'=1 D
  1.  .S RETURN("Is not authorized to write medication orders.")="",RETVAL=0
  1.  I $P($G(^VA(200,IEN,"PS")),U,2)'="" D
  1.  .N DATE
  1.  .S DATE=+$P($G(^VA(200,IEN,"QAR")),U,9)
  1.  .I DATE=0 S RETURN("Has a DEA number with no expiration date.")="",RETVAL=0
  1.  .I DATE>0,(DATE<=DT) S RETURN("Has an expired DEA number.")="",RETVAL=0
  1.  I $P($G(^VA(200,IEN,"PS")),U,2)="",($P($G(^VA(200,IEN,"PS")),U,3)="") D
  1.  .S RETURN("Has neither a DEA number nor a VA number.")="",RETVAL=0
  1.  S DATE=+$P($G(^VA(200,IEN,"PS")),U,4)
  1.  I DATE>0,(DATE<=DT) D
  1.  .S RETURN("Is no longer able to write medication orders (inactive date).")="",RETVAL=0
  1.  I $D(^VA(200,IEN,"PS3")) D
  1.  .N NODE
  1.  .S NODE=$$STRIP^XLFSTR(^VA(200,IEN,"PS3"),U),NODE=$$STRIP^XLFSTR(NODE,0)
  1.  .I $G(NODE)="" S RETURN("Is not permitted to prescribe any schedules.")="",RETVAL=0 Q
  1.  .I $G(NODE)'="" D
  1.  ..N PIECE,SCHED,SPEC,ASCHED
  1.  ..S SPEC("SCHEDULE ")=""
  1.  ..S ASCHED=1
  1.  ..F PIECE=1:1:6 D
  1.  ...I +$P(^VA(200,IEN,"PS3"),U,PIECE)>0 D
  1.  ....N LABEL,ERROR
  1.  ....S LABEL=$$REPLACE^XLFSTR($$GET1^DID(200,"55."_PIECE,,"LABEL",,"ERROR"),.SPEC)
  1.  ....S:$G(LABEL)="" LABEL="Unknown field #55."_PIECE
  1.  ....S SCHED=$S($G(SCHED)'="":SCHED_U,1:"")_LABEL
  1.  ...I +$P(^VA(200,IEN,"PS3"),U,PIECE)=0 S ASCHED=0
  1.  ..I ASCHED=1 S RETURN("Is permitted to prescribe all schedules.")=""
  1.  ..I ASCHED=0 D
  1.  ...N DELIMIT,INDEX,TEXT
  1.  ...S DELIMIT=", "
  1.  ...F INDEX=1:1:$L(SCHED,U) D
  1.  ....S:INDEX=$L(SCHED,U) DELIMIT=" and "
  1.  ....S TEXT=$S($G(TEXT)'="":TEXT_DELIMIT,1:"")_$P(SCHED,U,INDEX)
  1.  ...S RETURN("Is permitted to prescribe schedule"_$S($L(SCHED,U)>1:"s",1:"")_" "_TEXT_".")=""
  1.  I '$D(^VA(200,IEN,"PS3")) S RETURN("Is permitted to prescribe all schedules.")=""
  1.  Q RETVAL
  1.  ;
  1. DIV4(XUROOT,XUDUZ) ;Return the Divisions that this user is assigned to.
  1.  ;Returns 0 - no institution for user, 1 - institution for user
  1.  ;XUROOT is passed by reference.
  1.  N %,%1 S:$G(XUDUZ)="" XUDUZ=DUZ S (%,%1)=0
  1.  F  S %=$O(^VA(200,XUDUZ,2,%)) Q:%'>0  S XUROOT(%)=$P($G(^(%,0)),U,2),%1=1
  1.  Q %1
  1.  ;
  1. NAME(IEN,FL) ;Return the full name from Name Components file
  1.  N NA S NA("FILE")=200,NA("FIELD")=.01,NA("IENS")=IEN
  1.  S FL=$G(FL,"G") ;Valid are Famly or Given
  1.  S:"FG"'[FL FL="G"
  1.  Q $$NAMEFMT^XLFNAME(.NA,FL,"CMDP")
  1.  ;
  1. HL7(IEN) ;Return a HL7 name from the components file
  1.  N NA S NA("FILE")=200,NA("FIELD")=.01,NA("IENS")=IEN
  1.  Q $$HLNAME^XLFNAME(.NA,"","~")
  1.  ;
  1. SCR200() ;Whole File Screen logic for file 200
  1.  ;
  1.  ; Test to see if FileMan can "talk" to the user, IA# 4577
  1.  I $G(DIC(0))'["E" Q 1
  1.  ;
  1.  ; Test to see if index being searched is SSN, IA# 4578
  1.  I $G(DINDEX)'="SSN" Q 1
  1.  ;
  1.  ; Test for Security Key
  1.  I $G(DUZ),$D(^XUSEC("XUSHOWSSN",DUZ)) Q 1
  1.  ;
  1.  ; Default - None of the above is TRUE
  1.  Q 0