- 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 Feb 18, 2025@23:38:48 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