XUSER2.m

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 ---XUSER2   4489     printed  Mar 13, 2025@21:17:15                                                                                                                                                                                                      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