XUSER3 ;ISF/RWF - New Person File Utilities ;02/01/2022
;;8.0;KERNEL;**688,689**;Jul 10, 1995;Build 113
;;Per VA Directive 6402, this routine should not be modified.
Q
;
VALN1DEA(X,F) ;Check for a valid DEA# in the NEW DEA FIELD OF FILE #200, 53.21, .01
;Returns 0 for NOT Valid, 1 for Valid
;F = 1 for Facility DEA check.
S F=$$FACILITY(X)
I $D(X) I $L(X)>9 K X D EN^DDIOL($C(7)_"Exceeds maximum length (9).")
I $D(X) I $L(X)<9 K X D EN^DDIOL($C(7)_"Less than minimum length (9).")
I $D(X) I '(X?2U7N) K X D EN^DDIOL($C(7)_"Invalid format. Must be 2 upper case letters followed by 7 digits.")
S F=$G(F)
I $D(X),'F,$D(DA(1)),$D(^VA(200,"PS4",X)),$O(^(X,0))'=DA(1) D EN^DDIOL($C(7)_"Provider DEA number is already associated to another profile. Please check the number entered.") K X
I $D(X),'$$DEANUM(X) D EN^DDIOL($C(7)_"DEA number is invalid. Please check the number entered.") K X
I $D(X),'F,$D(DA(1)),$E(X,2)'=$E($P(^VA(200,DA(1),0),"^")) D EN^DDIOL($C(7)_"DEA number doesn't match provider's last name. Please verify the information.") D VALN1P
Q $D(X)
;
VALN1P ; PAUSE AFTER CHECK SECOND LETTER MESSAGE
N DIR,X,Y
S DIR("A")="Type <Enter> to continue",DIR(0)="E" D ^DIR
Q
;
VALN2DEA(X,F,DEADA) ;Check for a valid DEA# in the (NEW) DEA NUMBERS FILE #8991.9
;Returns 0 for NOT Valid, 1 for Valid
;F = 1 for Facility DEA check.
I $D(X) I $L(X)>9 K X D EN^DDIOL($C(7)_"Exceeds maximum length (9).")
I $D(X) I $L(X)<9 K X D EN^DDIOL($C(7)_"Less than minimum length (9).")
I $D(X) I '(X?2U7N) K X D EN^DDIOL($C(7)_"Invalid format. Must be 2 upper case letters followed by 7 digits.")
S F=$G(F)
S DEADA=$G(DEADA)
I $D(X),'$$DEANUM(X) D EN^DDIOL($C(7)_"DEA number is invalid. Please check the number entered.") K X
Q $D(X)
;
DEANUM(X) ;Check DEA # Numeric 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
;
FACILITY(X) ;
N DNDEAIEN
S DNDEAIEN=$O(^XTV(8991.9,"B",X,0)) Q:'DNDEAIEN 0
Q $$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")=1
;
SUFCHK(X,DA) ;Check for a unique suffix. Called from Sub-File #200.5321 field #.02
N RESPONSE S RESPONSE=0
G:'$D(X) SUFCHKQ G:'$D(DA) SUFCHKQ G:'$D(DA(1)) SUFCHKQ
N NPDEATXT S NPDEATXT=$$GET1^DIQ(200.5321,DA_","_DA(1),.01) G:NPDEATXT="" SUFCHKQ
I $D(^VA(200,"F",NPDEATXT,X)) D EN^DDIOL($C(7)_"That Suffix is in use. ","","!,?5") S RESPONSE=1
SUFCHKQ ; Unique Suffix Quit Tag
Q RESPONSE
;
VDEADNM(RETURN,NPIEN) ;ISP/RFR - Verify a provider is properly configured for ePCS
;PARAMETERS: NPIEN - 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 CNT,NPDEAIEN,DNDEAIEN,DNDEATXT,NPDEALST,X,Y,DEA,RETVAL,USING
S RETVAL=1,USING=""
S NPDEALST(0)=0
S NPDEAIEN=0 F S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN D
. S NPDEALST(0)=NPDEALST(0)+1
. S NPDEALST(NPDEALST(0))=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.01)
. S $P(NPDEALST(NPDEALST(0)),U,2)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.02)
. S $P(NPDEALST(NPDEALST(0)),U,3)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
. S $P(NPDEALST(NPDEALST(0)),U,4)=NPDEAIEN_","_NPIEN_","
. S:$P(NPDEALST(NPDEALST(0)),U,3) $P(NPDEALST(NPDEALST(0)),U,5)=$$GET1^DIQ(8991.9,$P(NPDEALST(NPDEALST(0)),U,3)_",",1.6)
. S NPDEALST("B",$P(NPDEALST(NPDEALST(0)),U,1))=NPDEALST(NPDEALST(0))
I NPDEALST(0)=0 S RETVAL=0 Q $$VDEADNX(RETVAL,USING)
I NPDEALST(0)=1 D Q $$VDEADNX(RETVAL,USING)
. S USING=$P(NPDEALST(1),U,1)
. S DNDEAIEN=$P(NPDEALST(1),U,3)
. I 'DNDEAIEN S RETURN("No link to the DEA NUMBERS FILE.")="",RETVAL=0
. S RETVAL=$$VDEADNA^XUSER3(.RETURN,NPIEN,DNDEAIEN)
W !!,"This provider has multiple DEA registrations.",!
W "Please select the DEA number you wish to check:",!!
F CNT=1:1:NPDEALST(0) D
. W $E(" ",1,5-$L(CNT)),CNT," - ",$P(NPDEALST(CNT),U,1)
. W:$P(NPDEALST(CNT),U,2)'="" "-",$P(NPDEALST(CNT),U,2)
. W " ",$P(NPDEALST(CNT),U,5)
. W:$O(NPDEALST(CNT)) !
K DIRUT,DIR S DIR(0)="F^1:2^K:'$D(NPDEALST(X))!(X=0) X"
S DIR("A")="Choose 1 - "_NPDEALST(0)
S DIR("A",1)=" "
S DIR("?")="Select a choice from the list above."
D ^DIR
W !!
I $G(DIRUT) S RETVAL=0 Q $$VDEADNX(RETVAL,USING)
I '$G(X) S RETVAL=0 Q $$VDEADNX(RETVAL,USING)
S USING=$P(NPDEALST(X),U,1)
S DNDEAIEN=$P(NPDEALST(X),U,3)
I 'DNDEAIEN S RETURN("No link to the DEA NUMBERS FILE.")="",RETVAL=0 Q RETVAL
S RETVAL=$$VDEADNA^XUSER3(.RETURN,NPIEN,DNDEAIEN)
Q RETVAL_U_USING
;
VDEADNX(RETVAL,USING) ; -- Common Quit Point.
Q RETVAL_U_USING
;
VDEADNA(RETURN,NPIEN,DNDEAIEN) ; -- ENTRY POINT for a single DEA Number
N DATE,DELIMIT,DNDEATXT,INDEX,NODEA,RETVAL,SCH,STATUS,USING
S RETVAL=1
I +$G(NPIEN)=0 S RETVAL=0 Q RETVAL
I +$G(DNDEAIEN)=0 S RETVAL=0 Q RETVAL
S DNDEATXT=$$GET1^DIQ(8991.9,DNDEAIEN,.01)
I '$D(^VA(200,NPIEN,"PS4","B",DNDEATXT)) S RETURN("User isn't linked to the DEA Number.")="" S RETVAL=0 Q RETVAL
S USING="Using DEA # "_DNDEATXT_","
S STATUS=$$ACTIVE^XUSER(NPIEN)
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",NPIEN)) D
. S RETURN("Does not hold the ORES security key.")="",RETVAL=0
I $$GET1^DIQ(200,NPIEN,53.1,"I")'=1 D
. S RETURN("Is not authorized to write medication orders.")="",RETVAL=0
I $$GET1^DIQ(8991.9,DNDEAIEN,.01)'="" D
. S DATE=+$$GET1^DIQ(8991.9,DNDEAIEN,.04,"I")
. 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 $$GET1^DIQ(8991.9,DNDEAIEN,.01)="" D
. S NODEA=1
. I $$GET1^DIQ(200,NPIEN,53.3)="" D
.. S RETURN("Has neither a DEA number nor a VA number.")="",RETVAL=0
I +$G(NODEA),$$GET1^DIQ(200,NPIEN,53.3)'="" S RETVAL=1
S DATE=+$$GET1^DIQ(200,NPIEN,53.4,"I")
I DATE>0,DATE<=DT S RETURN("Is no longer able to write medication orders (inactive date).")="",RETVAL=0
I $$GET1^DIQ(8991.9,DNDEAIEN,.07,"E")="INDIVIDUAL" D
. S SCH("2")=$$GET1^DIQ(8991.9,DNDEAIEN,2.1,"I"),SCH("2N")=$$GET1^DIQ(8991.9,DNDEAIEN,2.2,"I")
. S SCH("3")=$$GET1^DIQ(8991.9,DNDEAIEN,2.3,"I"),SCH("3N")=$$GET1^DIQ(8991.9,DNDEAIEN,2.4,"I")
. S SCH("4")=$$GET1^DIQ(8991.9,DNDEAIEN,2.5,"I"),SCH("5")=$$GET1^DIQ(8991.9,DNDEAIEN,2.6,"I")
I $$GET1^DIQ(8991.9,DNDEAIEN,.07,"E")'="INDIVIDUAL" D
. S SCH("2")=$$GET1^DIQ(200,NPIEN,55.1,"I"),SCH("2N")=$$GET1^DIQ(200,NPIEN,55.2,"I")
. S SCH("3")=$$GET1^DIQ(200,NPIEN,55.3,"I"),SCH("3N")=$$GET1^DIQ(200,NPIEN,55.4,"I")
. S SCH("4")=$$GET1^DIQ(200,NPIEN,55.5,"I"),SCH("5")=$$GET1^DIQ(200,NPIEN,55.6,"I")
I SCH("2")+SCH("2N")+SCH("3")+SCH("3N")+SCH("4")+SCH("5")=0 S RETURN("Is not permitted to prescribe any schedules.")="",RETVAL=0 Q RETVAL
I SCH("2")+SCH("2N")+SCH("3")+SCH("3N")+SCH("4")+SCH("5")=6 S RETURN("Is permitted to prescribe all schedules.")="",RETVAL=1 Q RETVAL
S SCH("TOTAL")=""
S:SCH("2") SCH("TOTAL")=SCH("TOTAL")_"II NARCOTIC^"
S:SCH("2N") SCH("TOTAL")=SCH("TOTAL")_"II NON-NARCOTIC^"
S:SCH("3") SCH("TOTAL")=SCH("TOTAL")_"III NARCOTIC^"
S:SCH("3N") SCH("TOTAL")=SCH("TOTAL")_"III NON-NARCOTIC^"
S:SCH("4") SCH("TOTAL")=SCH("TOTAL")_"IV^"
S:SCH("5") SCH("TOTAL")=SCH("TOTAL")_"V^"
S DELIMIT=", "
S SCH("TEXT")=""
F INDEX=1:1:($L(SCH("TOTAL"),U)-1) D
. S:INDEX=($L(SCH("TOTAL"),U)-1) DELIMIT=$S(($L(SCH("TOTAL"),U)-1)=2:" and ",1:", and ")
. S SCH("TEXT")=$S(SCH("TEXT")'="":SCH("TEXT")_DELIMIT,1:"")_$P(SCH("TOTAL"),U,INDEX)
S RETURN("Is permitted to prescribe schedule"_$S(($L(SCH("TOTAL"),U)-1)>1:"s",1:"")_" "_SCH("TEXT")_".")=""
Q RETVAL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSER3 8110 printed Sep 23, 2025@19:48:36 Page 2
XUSER3 ;ISF/RWF - New Person File Utilities ;02/01/2022
+1 ;;8.0;KERNEL;**688,689**;Jul 10, 1995;Build 113
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
VALN1DEA(X,F) ;Check for a valid DEA# in the NEW DEA FIELD OF FILE #200, 53.21, .01
+1 ;Returns 0 for NOT Valid, 1 for Valid
+2 ;F = 1 for Facility DEA check.
+3 SET F=$$FACILITY(X)
+4 IF $DATA(X)
IF $LENGTH(X)>9
KILL X
DO EN^DDIOL($CHAR(7)_"Exceeds maximum length (9).")
+5 IF $DATA(X)
IF $LENGTH(X)<9
KILL X
DO EN^DDIOL($CHAR(7)_"Less than minimum length (9).")
+6 IF $DATA(X)
IF '(X?2U7N)
KILL X
DO EN^DDIOL($CHAR(7)_"Invalid format. Must be 2 upper case letters followed by 7 digits.")
+7 SET F=$GET(F)
+8 IF $DATA(X)
IF 'F
IF $DATA(DA(1))
IF $DATA(^VA(200,"PS4",X))
IF $ORDER(^(X,0))'=DA(1)
DO EN^DDIOL($CHAR(7)_"Provider DEA number is already associated to another profile. Please check the number entered.")
KILL X
+9 IF $DATA(X)
IF '$$DEANUM(X)
DO EN^DDIOL($CHAR(7)_"DEA number is invalid. Please check the number entered.")
KILL X
+10 IF $DATA(X)
IF 'F
IF $DATA(DA(1))
IF $EXTRACT(X,2)'=$EXTRACT($PIECE(^VA(200,DA(1),0),"^"))
DO EN^DDIOL($CHAR(7)_"DEA number doesn't match provider's last name. Please verify the information.")
DO VALN1P
+11 QUIT $DATA(X)
+12 ;
VALN1P ; PAUSE AFTER CHECK SECOND LETTER MESSAGE
+1 NEW DIR,X,Y
+2 SET DIR("A")="Type <Enter> to continue"
SET DIR(0)="E"
DO ^DIR
+3 QUIT
+4 ;
VALN2DEA(X,F,DEADA) ;Check for a valid DEA# in the (NEW) DEA NUMBERS FILE #8991.9
+1 ;Returns 0 for NOT Valid, 1 for Valid
+2 ;F = 1 for Facility DEA check.
+3 IF $DATA(X)
IF $LENGTH(X)>9
KILL X
DO EN^DDIOL($CHAR(7)_"Exceeds maximum length (9).")
+4 IF $DATA(X)
IF $LENGTH(X)<9
KILL X
DO EN^DDIOL($CHAR(7)_"Less than minimum length (9).")
+5 IF $DATA(X)
IF '(X?2U7N)
KILL X
DO EN^DDIOL($CHAR(7)_"Invalid format. Must be 2 upper case letters followed by 7 digits.")
+6 SET F=$GET(F)
+7 SET DEADA=$GET(DEADA)
+8 IF $DATA(X)
IF '$$DEANUM(X)
DO EN^DDIOL($CHAR(7)_"DEA number is invalid. Please check the number entered.")
KILL X
+9 QUIT $DATA(X)
+10 ;
DEANUM(X) ;Check DEA # Numeric 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 ;
FACILITY(X) ;
+1 NEW DNDEAIEN
+2 SET DNDEAIEN=$ORDER(^XTV(8991.9,"B",X,0))
if 'DNDEAIEN
QUIT 0
+3 QUIT $$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")=1
+4 ;
SUFCHK(X,DA) ;Check for a unique suffix. Called from Sub-File #200.5321 field #.02
+1 NEW RESPONSE
SET RESPONSE=0
+2 if '$DATA(X)
GOTO SUFCHKQ
if '$DATA(DA)
GOTO SUFCHKQ
if '$DATA(DA(1))
GOTO SUFCHKQ
+3 NEW NPDEATXT
SET NPDEATXT=$$GET1^DIQ(200.5321,DA_","_DA(1),.01)
if NPDEATXT=""
GOTO SUFCHKQ
+4 IF $DATA(^VA(200,"F",NPDEATXT,X))
DO EN^DDIOL($CHAR(7)_"That Suffix is in use. ","","!,?5")
SET RESPONSE=1
SUFCHKQ ; Unique Suffix Quit Tag
+1 QUIT RESPONSE
+2 ;
VDEADNM(RETURN,NPIEN) ;ISP/RFR - Verify a provider is properly configured for ePCS
+1 ;PARAMETERS: NPIEN - 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 ;
+9 NEW CNT,NPDEAIEN,DNDEAIEN,DNDEATXT,NPDEALST,X,Y,DEA,RETVAL,USING
+10 SET RETVAL=1
SET USING=""
+11 SET NPDEALST(0)=0
+12 SET NPDEAIEN=0
FOR
SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
if 'NPDEAIEN
QUIT
Begin DoDot:1
+13 SET NPDEALST(0)=NPDEALST(0)+1
+14 SET NPDEALST(NPDEALST(0))=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.01)
+15 SET $PIECE(NPDEALST(NPDEALST(0)),U,2)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.02)
+16 SET $PIECE(NPDEALST(NPDEALST(0)),U,3)=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
+17 SET $PIECE(NPDEALST(NPDEALST(0)),U,4)=NPDEAIEN_","_NPIEN_","
+18 if $PIECE(NPDEALST(NPDEALST(0)),U,3)
SET $PIECE(NPDEALST(NPDEALST(0)),U,5)=$$GET1^DIQ(8991.9,$PIECE(NPDEALST(NPDEALST(0)),U,3)_",",1.6)
+19 SET NPDEALST("B",$PIECE(NPDEALST(NPDEALST(0)),U,1))=NPDEALST(NPDEALST(0))
End DoDot:1
+20 IF NPDEALST(0)=0
SET RETVAL=0
QUIT $$VDEADNX(RETVAL,USING)
+21 IF NPDEALST(0)=1
Begin DoDot:1
+22 SET USING=$PIECE(NPDEALST(1),U,1)
+23 SET DNDEAIEN=$PIECE(NPDEALST(1),U,3)
+24 IF 'DNDEAIEN
SET RETURN("No link to the DEA NUMBERS FILE.")=""
SET RETVAL=0
+25 SET RETVAL=$$VDEADNA^XUSER3(.RETURN,NPIEN,DNDEAIEN)
End DoDot:1
QUIT $$VDEADNX(RETVAL,USING)
+26 WRITE !!,"This provider has multiple DEA registrations.",!
+27 WRITE "Please select the DEA number you wish to check:",!!
+28 FOR CNT=1:1:NPDEALST(0)
Begin DoDot:1
+29 WRITE $EXTRACT(" ",1,5-$LENGTH(CNT)),CNT," - ",$PIECE(NPDEALST(CNT),U,1)
+30 if $PIECE(NPDEALST(CNT),U,2)'=""
WRITE "-",$PIECE(NPDEALST(CNT),U,2)
+31 WRITE " ",$PIECE(NPDEALST(CNT),U,5)
+32 if $ORDER(NPDEALST(CNT))
WRITE !
End DoDot:1
+33 KILL DIRUT,DIR
SET DIR(0)="F^1:2^K:'$D(NPDEALST(X))!(X=0) X"
+34 SET DIR("A")="Choose 1 - "_NPDEALST(0)
+35 SET DIR("A",1)=" "
+36 SET DIR("?")="Select a choice from the list above."
+37 DO ^DIR
+38 WRITE !!
+39 IF $GET(DIRUT)
SET RETVAL=0
QUIT $$VDEADNX(RETVAL,USING)
+40 IF '$GET(X)
SET RETVAL=0
QUIT $$VDEADNX(RETVAL,USING)
+41 SET USING=$PIECE(NPDEALST(X),U,1)
+42 SET DNDEAIEN=$PIECE(NPDEALST(X),U,3)
+43 IF 'DNDEAIEN
SET RETURN("No link to the DEA NUMBERS FILE.")=""
SET RETVAL=0
QUIT RETVAL
+44 SET RETVAL=$$VDEADNA^XUSER3(.RETURN,NPIEN,DNDEAIEN)
+45 QUIT RETVAL_U_USING
+46 ;
VDEADNX(RETVAL,USING) ; -- Common Quit Point.
+1 QUIT RETVAL_U_USING
+2 ;
VDEADNA(RETURN,NPIEN,DNDEAIEN) ; -- ENTRY POINT for a single DEA Number
+1 NEW DATE,DELIMIT,DNDEATXT,INDEX,NODEA,RETVAL,SCH,STATUS,USING
+2 SET RETVAL=1
+3 IF +$GET(NPIEN)=0
SET RETVAL=0
QUIT RETVAL
+4 IF +$GET(DNDEAIEN)=0
SET RETVAL=0
QUIT RETVAL
+5 SET DNDEATXT=$$GET1^DIQ(8991.9,DNDEAIEN,.01)
+6 IF '$DATA(^VA(200,NPIEN,"PS4","B",DNDEATXT))
SET RETURN("User isn't linked to the DEA Number.")=""
SET RETVAL=0
QUIT RETVAL
+7 SET USING="Using DEA # "_DNDEATXT_","
+8 SET STATUS=$$ACTIVE^XUSER(NPIEN)
+9 IF STATUS=""
SET RETURN("User account does not exist.")=""
SET RETVAL=0
+10 IF STATUS=0
SET RETURN("User cannot sign on.")=""
SET RETVAL=0
+11 IF +STATUS=0
IF ($PIECE(STATUS,U,2)'="")
SET RETURN("User account status: "_$PIECE(STATUS,U,2))=""
SET RETVAL=0
+12 if STATUS=""
QUIT RETVAL
+13 IF '$DATA(^XUSEC("ORES",NPIEN))
Begin DoDot:1
+14 SET RETURN("Does not hold the ORES security key.")=""
SET RETVAL=0
End DoDot:1
+15 IF $$GET1^DIQ(200,NPIEN,53.1,"I")'=1
Begin DoDot:1
+16 SET RETURN("Is not authorized to write medication orders.")=""
SET RETVAL=0
End DoDot:1
+17 IF $$GET1^DIQ(8991.9,DNDEAIEN,.01)'=""
Begin DoDot:1
+18 SET DATE=+$$GET1^DIQ(8991.9,DNDEAIEN,.04,"I")
+19 IF DATE=0
SET RETURN("Has a DEA number with no expiration date.")=""
SET RETVAL=0
SET NODEA=1
+20 IF DATE>0
IF (DATE<=DT)
SET RETURN("Has an expired DEA number.")=""
SET RETVAL=0
SET NODEA=1
End DoDot:1
+21 IF $$GET1^DIQ(8991.9,DNDEAIEN,.01)=""
Begin DoDot:1
+22 SET NODEA=1
+23 IF $$GET1^DIQ(200,NPIEN,53.3)=""
Begin DoDot:2
+24 SET RETURN("Has neither a DEA number nor a VA number.")=""
SET RETVAL=0
End DoDot:2
End DoDot:1
+25 IF +$GET(NODEA)
IF $$GET1^DIQ(200,NPIEN,53.3)'=""
SET RETVAL=1
+26 SET DATE=+$$GET1^DIQ(200,NPIEN,53.4,"I")
+27 IF DATE>0
IF DATE<=DT
SET RETURN("Is no longer able to write medication orders (inactive date).")=""
SET RETVAL=0
+28 IF $$GET1^DIQ(8991.9,DNDEAIEN,.07,"E")="INDIVIDUAL"
Begin DoDot:1
+29 SET SCH("2")=$$GET1^DIQ(8991.9,DNDEAIEN,2.1,"I")
SET SCH("2N")=$$GET1^DIQ(8991.9,DNDEAIEN,2.2,"I")
+30 SET SCH("3")=$$GET1^DIQ(8991.9,DNDEAIEN,2.3,"I")
SET SCH("3N")=$$GET1^DIQ(8991.9,DNDEAIEN,2.4,"I")
+31 SET SCH("4")=$$GET1^DIQ(8991.9,DNDEAIEN,2.5,"I")
SET SCH("5")=$$GET1^DIQ(8991.9,DNDEAIEN,2.6,"I")
End DoDot:1
+32 IF $$GET1^DIQ(8991.9,DNDEAIEN,.07,"E")'="INDIVIDUAL"
Begin DoDot:1
+33 SET SCH("2")=$$GET1^DIQ(200,NPIEN,55.1,"I")
SET SCH("2N")=$$GET1^DIQ(200,NPIEN,55.2,"I")
+34 SET SCH("3")=$$GET1^DIQ(200,NPIEN,55.3,"I")
SET SCH("3N")=$$GET1^DIQ(200,NPIEN,55.4,"I")
+35 SET SCH("4")=$$GET1^DIQ(200,NPIEN,55.5,"I")
SET SCH("5")=$$GET1^DIQ(200,NPIEN,55.6,"I")
End DoDot:1
+36 IF SCH("2")+SCH("2N")+SCH("3")+SCH("3N")+SCH("4")+SCH("5")=0
SET RETURN("Is not permitted to prescribe any schedules.")=""
SET RETVAL=0
QUIT RETVAL
+37 IF SCH("2")+SCH("2N")+SCH("3")+SCH("3N")+SCH("4")+SCH("5")=6
SET RETURN("Is permitted to prescribe all schedules.")=""
SET RETVAL=1
QUIT RETVAL
+38 SET SCH("TOTAL")=""
+39 if SCH("2")
SET SCH("TOTAL")=SCH("TOTAL")_"II NARCOTIC^"
+40 if SCH("2N")
SET SCH("TOTAL")=SCH("TOTAL")_"II NON-NARCOTIC^"
+41 if SCH("3")
SET SCH("TOTAL")=SCH("TOTAL")_"III NARCOTIC^"
+42 if SCH("3N")
SET SCH("TOTAL")=SCH("TOTAL")_"III NON-NARCOTIC^"
+43 if SCH("4")
SET SCH("TOTAL")=SCH("TOTAL")_"IV^"
+44 if SCH("5")
SET SCH("TOTAL")=SCH("TOTAL")_"V^"
+45 SET DELIMIT=", "
+46 SET SCH("TEXT")=""
+47 FOR INDEX=1:1:($LENGTH(SCH("TOTAL"),U)-1)
Begin DoDot:1
+48 if INDEX=($LENGTH(SCH("TOTAL"),U)-1)
SET DELIMIT=$SELECT(($LENGTH(SCH("TOTAL"),U)-1)=2:" and ",1:", and ")
+49 SET SCH("TEXT")=$SELECT(SCH("TEXT")'="":SCH("TEXT")_DELIMIT,1:"")_$PIECE(SCH("TOTAL"),U,INDEX)
End DoDot:1
+50 SET RETURN("Is permitted to prescribe schedule"_$SELECT(($LENGTH(SCH("TOTAL"),U)-1)>1:"s",1:"")_" "_SCH("TEXT")_".")=""
+51 QUIT RETVAL
