XUSER2 ;ISF/RWF - New Person File Utilities ;02/01/2012
;;8.0;KERNEL;**267,251,344,534,580,765**;Jul 10, 1995;Build 3
;Per VHA Directive 2004-038, this routine should not be modified.
Q
VALDEA(X,F) ;Check for a valid DEA#
;Returns 0 for NOT Valid, 1 for Valid
;F = 1 for Facility DEA check.
N VAPR,VADUP,VADUPNAM,VASTER
S $P(VASTER,"*",80)="*"
I $D(X) K:$L(X)>9!($L(X)<9)!'(X?2U7N) X
S F=$G(F)
I $D(X),'F,$D(DA),$D(^VA(200,"PS1",X)) D
. S VADUP=0,VAPR=0 F S VAPR=$O(^VA(200,"PS1",X,VAPR)) Q:'VAPR I VAPR'=DA S VADUP=VAPR
. I VADUP D K X
.. D EN^DDIOL($C(7)_$E(VASTER,1,70))
.. D EN^DDIOL($C(7)_" DEA number "_X_" has already been assigned to another provider:")
.. S VADUPNAM=$P($G(^VA(200,+VADUP,0)),U)
.. D EN^DDIOL($C(7)_" NAME: "_$G(VADUPNAM))
.. D EN^DDIOL($C(7)_" IEN: "_VADUP)
.. D EN^DDIOL($C(7)_$E(VASTER,1,70))
.. D EN^DDIOL($C(7)_"Please check the number entered.")
I $D(X),'F,$D(DA),$E(X,2)'=$E($P(^VA(200,DA,0),"^")) D EN^DDIOL($C(7)_"WARNING: DEA# FORMAT MISMATCH -- CHECK SECOND LETTER")
I $D(X),'$$DEANUM(X) D EN^DDIOL($C(7)_"CAN'T FILE: DEA# FORMAT MISMATCH -- NUMERIC ALGORITHM FAILED") K X
Q $D(X)
;
DEANUM(X) ;Check DEA # part
N VA1,VA2
S VA1=$E(X,3)+$E(X,5)+$E(X,7)+(2*($E(X,4)+$E(X,6)+$E(X,8)))
S VA1=VA1#10,VA2=$E(X,9)
Q VA1=VA2
;
VANUM ;Check that the VA# is not Active for anybody else. Called from ^DD(200,53.3,0)
;Needs DA, DT and X
Q:'$D(X)!'$D(DA)
N %
I $D(^VA(200,"PS2",X)) D
. S %=0
. F S %=$O(^VA(200,"PS2",X,%)) Q:'% I %'=DA,$S('$P($G(^VA(200,%,"PS")),"^",4):1,1:$P(^("PS"),"^",4)'<DT) K X Q
. Q
I '$D(X) D EN^DDIOL($C(7)_"That VA# is in active use. ","","!,?5")
Q
;
GETUPN(RET) ;Get SUBJECT ALTERNATIVE NAME for PIV card check. -p580
S RET=$P($G(^VA(200,DUZ,501)),U,2)
Q
;
SETUPN(RET,V) ;Set the SUBJECT ALTERNATIVE NAME from the PIV card. -p580
N FDA,ERR
S RET=0,FDA(200,DUZ_",",501.2)=V
D FILE^DIE("KE","FDA","ERR") I '$D(ERR) S RET=1
Q
;
REQ(XUV,XUFLAG) ;Called from forms:
; XUEXISTING USER, XUNEW USER, XUREACT USER, XU-CLINICAL TRAINEE
;from the:
; - Form-level pre-action
; - Post action on change for "Is this person a Clinical Trainee?"
;In:
; XUV = 1 if user is a clinical trainee; 0 otherwise
; If XUV is not passed, its value is obtained from the
; CLINICAL CORE TRAINEE(#12.6).
; XUFLAG = 1 if called from the XU-CLINICAL TRAINEE form;
; otherwise, called from the other forms
;
N BLOCK,PAGE,FIELD,F126
; BLOCK = Block
; PAGE = Page number
; FIELD = Field number
I $G(XUFLAG) S BLOCK="XU-CLINICAL TRAINEE 1",PAGE=1
E D
. S BLOCK="XUEXISTING USER TRAINEE"
. S PAGE=5
;
I $G(XUV)="" D ;Value not Passed get current value
. N ZERR
. S XUV=$$GET^DDSVAL(200,DA,"CLINICAL CORE TRAINEE",.ZERR,"I")
. S XUV=$S(XUV="N":0,XUV="":0,1:1)
S F126=XUV
;
;CURRENT DEGREE LEVEL 12.1
;PROGRAM OF STUDY 12.2
;LAST TRAINING MONTH & YEAR 12.3
;VHA TRAINING FACILITY 12.4
;DATE HL7 TRAINEE RECORD BUILT 12.5
;CLINICAL CORE TRAINEE 12.6
;DATE NO LONGER TRAINEE 12.7
;START OF TRAINING 12.8
;
I F126 D Q ;Logic for when field 12.6 equals YES or Null
. N FIELD
. ;Make fields required
. F FIELD="12.2F","12.4F" D REQ^DDSUTL(FIELD,BLOCK,PAGE,1)
. ;Delete value in field 12.7 & make it uneditable
. S FIELD=12.7 D PUT^DDSVAL(200,DA,FIELD,"@","","I")
. S FIELD="12.7F" D UNED^DDSUTL(FIELD,BLOCK,PAGE,1)
. D REQ^DDSUTL(FIELD,BLOCK,PAGE,0)
. ;Make the following fields editable
. F FIELD="12.1F","12.2F","12.3F","12.4F","12.8F" D UNED^DDSUTL(FIELD,BLOCK,PAGE,0)
. Q
I 'F126 D Q ;Logic for when field 12.6 equals NO
. N FIELD,ZERR,F122,F127
. S F122=$$GET^DDSVAL(200,DA,12.2,.ZERR,"I")
. S F127=$$GET^DDSVAL(200,DA,12.7,.ZERR,"I")
. I F122="" D Q ;Not a trainee, probably a mistake
.. ;Make fields not required
.. F FIELD="12.2F","12.4F" D REQ^DDSUTL(FIELD,BLOCK,PAGE,0)
.. ;Make field uneditable
.. F FIELD="12.1F","12.2F","12.3F","12.4F","12.7F","12.8F" D UNED^DDSUTL(FIELD,BLOCK,PAGE,1)
.. Q
. I F122]"",F127]"" Q
. ;Make fields not required
. F FIELD="12.2F","12.4F" D REQ^DDSUTL(FIELD,BLOCK,PAGE,0)
. ;Make the following field required & editable
. S FIELD="12.7F" D REQ^DDSUTL(FIELD,BLOCK,PAGE,1)
. S FIELD="12.7F" D UNED^DDSUTL(FIELD,BLOCK,PAGE,0)
. ;Don't allow editing of the following fields
. F FIELD="12.1F","12.2F","12.3F","12.4F","12.8F" D UNED^DDSUTL(FIELD,BLOCK,PAGE,1)
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSER2 4489 printed Sep 23, 2025@19:48:35 Page 2
XUSER2 ;ISF/RWF - New Person File Utilities ;02/01/2012
+1 ;;8.0;KERNEL;**267,251,344,534,580,765**;Jul 10, 1995;Build 3
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
VALDEA(X,F) ;Check for a valid DEA#
+1 ;Returns 0 for NOT Valid, 1 for Valid
+2 ;F = 1 for Facility DEA check.
+3 NEW VAPR,VADUP,VADUPNAM,VASTER
+4 SET $PIECE(VASTER,"*",80)="*"
+5 IF $DATA(X)
if $LENGTH(X)>9!($LENGTH(X)<9)!'(X?2U7N)
KILL X
+6 SET F=$GET(F)
+7 IF $DATA(X)
IF 'F
IF $DATA(DA)
IF $DATA(^VA(200,"PS1",X))
Begin DoDot:1
+8 SET VADUP=0
SET VAPR=0
FOR
SET VAPR=$ORDER(^VA(200,"PS1",X,VAPR))
if 'VAPR
QUIT
IF VAPR'=DA
SET VADUP=VAPR
+9 IF VADUP
Begin DoDot:2
+10 DO EN^DDIOL($CHAR(7)_$EXTRACT(VASTER,1,70))
+11 DO EN^DDIOL($CHAR(7)_" DEA number "_X_" has already been assigned to another provider:")
+12 SET VADUPNAM=$PIECE($GET(^VA(200,+VADUP,0)),U)
+13 DO EN^DDIOL($CHAR(7)_" NAME: "_$GET(VADUPNAM))
+14 DO EN^DDIOL($CHAR(7)_" IEN: "_VADUP)
+15 DO EN^DDIOL($CHAR(7)_$EXTRACT(VASTER,1,70))
+16 DO EN^DDIOL($CHAR(7)_"Please check the number entered.")
End DoDot:2
KILL X
End DoDot:1
+17 IF $DATA(X)
IF 'F
IF $DATA(DA)
IF $EXTRACT(X,2)'=$EXTRACT($PIECE(^VA(200,DA,0),"^"))
DO EN^DDIOL($CHAR(7)_"WARNING: DEA# FORMAT MISMATCH -- CHECK SECOND LETTER")
+18 IF $DATA(X)
IF '$$DEANUM(X)
DO EN^DDIOL($CHAR(7)_"CAN'T FILE: DEA# FORMAT MISMATCH -- NUMERIC ALGORITHM FAILED")
KILL X
+19 QUIT $DATA(X)
+20 ;
DEANUM(X) ;Check DEA # part
+1 NEW VA1,VA2
+2 SET VA1=$EXTRACT(X,3)+$EXTRACT(X,5)+$EXTRACT(X,7)+(2*($EXTRACT(X,4)+$EXTRACT(X,6)+$EXTRACT(X,8)))
+3 SET VA1=VA1#10
SET VA2=$EXTRACT(X,9)
+4 QUIT VA1=VA2
+5 ;
VANUM ;Check that the VA# is not Active for anybody else. Called from ^DD(200,53.3,0)
+1 ;Needs DA, DT and X
+2 if '$DATA(X)!'$DATA(DA)
QUIT
+3 NEW %
+4 IF $DATA(^VA(200,"PS2",X))
Begin DoDot:1
+5 SET %=0
+6 FOR
SET %=$ORDER(^VA(200,"PS2",X,%))
if '%
QUIT
IF %'=DA
IF $SELECT('$PIECE($GET(^VA(200,%,"PS")),"^",4):1,1:$PIECE(^("PS"),"^",4)'<DT)
KILL X
QUIT
+7 QUIT
End DoDot:1
+8 IF '$DATA(X)
DO EN^DDIOL($CHAR(7)_"That VA# is in active use. ","","!,?5")
+9 QUIT
+10 ;
GETUPN(RET) ;Get SUBJECT ALTERNATIVE NAME for PIV card check. -p580
+1 SET RET=$PIECE($GET(^VA(200,DUZ,501)),U,2)
+2 QUIT
+3 ;
SETUPN(RET,V) ;Set the SUBJECT ALTERNATIVE NAME from the PIV card. -p580
+1 NEW FDA,ERR
+2 SET RET=0
SET FDA(200,DUZ_",",501.2)=V
+3 DO FILE^DIE("KE","FDA","ERR")
IF '$DATA(ERR)
SET RET=1
+4 QUIT
+5 ;
REQ(XUV,XUFLAG) ;Called from forms:
+1 ; XUEXISTING USER, XUNEW USER, XUREACT USER, XU-CLINICAL TRAINEE
+2 ;from the:
+3 ; - Form-level pre-action
+4 ; - Post action on change for "Is this person a Clinical Trainee?"
+5 ;In:
+6 ; XUV = 1 if user is a clinical trainee; 0 otherwise
+7 ; If XUV is not passed, its value is obtained from the
+8 ; CLINICAL CORE TRAINEE(#12.6).
+9 ; XUFLAG = 1 if called from the XU-CLINICAL TRAINEE form;
+10 ; otherwise, called from the other forms
+11 ;
+12 NEW BLOCK,PAGE,FIELD,F126
+13 ; BLOCK = Block
+14 ; PAGE = Page number
+15 ; FIELD = Field number
+16 IF $GET(XUFLAG)
SET BLOCK="XU-CLINICAL TRAINEE 1"
SET PAGE=1
+17 IF '$TEST
Begin DoDot:1
+18 SET BLOCK="XUEXISTING USER TRAINEE"
+19 SET PAGE=5
End DoDot:1
+20 ;
+21 ;Value not Passed get current value
IF $GET(XUV)=""
Begin DoDot:1
+22 NEW ZERR
+23 SET XUV=$$GET^DDSVAL(200,DA,"CLINICAL CORE TRAINEE",.ZERR,"I")
+24 SET XUV=$SELECT(XUV="N":0,XUV="":0,1:1)
End DoDot:1
+25 SET F126=XUV
+26 ;
+27 ;CURRENT DEGREE LEVEL 12.1
+28 ;PROGRAM OF STUDY 12.2
+29 ;LAST TRAINING MONTH & YEAR 12.3
+30 ;VHA TRAINING FACILITY 12.4
+31 ;DATE HL7 TRAINEE RECORD BUILT 12.5
+32 ;CLINICAL CORE TRAINEE 12.6
+33 ;DATE NO LONGER TRAINEE 12.7
+34 ;START OF TRAINING 12.8
+35 ;
+36 ;Logic for when field 12.6 equals YES or Null
IF F126
Begin DoDot:1
+37 NEW FIELD
+38 ;Make fields required
+39 FOR FIELD="12.2F","12.4F"
DO REQ^DDSUTL(FIELD,BLOCK,PAGE,1)
+40 ;Delete value in field 12.7 & make it uneditable
+41 SET FIELD=12.7
DO PUT^DDSVAL(200,DA,FIELD,"@","","I")
+42 SET FIELD="12.7F"
DO UNED^DDSUTL(FIELD,BLOCK,PAGE,1)
+43 DO REQ^DDSUTL(FIELD,BLOCK,PAGE,0)
+44 ;Make the following fields editable
+45 FOR FIELD="12.1F","12.2F","12.3F","12.4F","12.8F"
DO UNED^DDSUTL(FIELD,BLOCK,PAGE,0)
+46 QUIT
End DoDot:1
QUIT
+47 ;Logic for when field 12.6 equals NO
IF 'F126
Begin DoDot:1
+48 NEW FIELD,ZERR,F122,F127
+49 SET F122=$$GET^DDSVAL(200,DA,12.2,.ZERR,"I")
+50 SET F127=$$GET^DDSVAL(200,DA,12.7,.ZERR,"I")
+51 ;Not a trainee, probably a mistake
IF F122=""
Begin DoDot:2
+52 ;Make fields not required
+53 FOR FIELD="12.2F","12.4F"
DO REQ^DDSUTL(FIELD,BLOCK,PAGE,0)
+54 ;Make field uneditable
+55 FOR FIELD="12.1F","12.2F","12.3F","12.4F","12.7F","12.8F"
DO UNED^DDSUTL(FIELD,BLOCK,PAGE,1)
+56 QUIT
End DoDot:2
QUIT
+57 IF F122]""
IF F127]""
QUIT
+58 ;Make fields not required
+59 FOR FIELD="12.2F","12.4F"
DO REQ^DDSUTL(FIELD,BLOCK,PAGE,0)
+60 ;Make the following field required & editable
+61 SET FIELD="12.7F"
DO REQ^DDSUTL(FIELD,BLOCK,PAGE,1)
+62 SET FIELD="12.7F"
DO UNED^DDSUTL(FIELD,BLOCK,PAGE,0)
+63 ;Don't allow editing of the following fields
+64 FOR FIELD="12.1F","12.2F","12.3F","12.4F","12.8F"
DO UNED^DDSUTL(FIELD,BLOCK,PAGE,1)
+65 QUIT
End DoDot:1
QUIT
+66 QUIT
