PSOERXA0 ;ALB/BWF - eRx Utilities/RPC's ; 8/3/2016 5:14pm
;;7.0;OUTPATIENT PHARMACY;**467,586,617,651,545,743,769**;DEC 1997;Build 26
;
Q
; All parameters are optional, however at least one needs to be passed in for processing to be sucessful.
; NDCUPN - This is the NDC/UPN for the drug (optional)
; DGDESC - Drug description (optional)
DRGMTCH(PSORES,NDCUPN,DGDESC) ;
N VAPRID,NDCUPNT,NDCUPNV,NDCUXREF,NUIEN,PSMIEN,PSMIEN,PSDRG,PSDRGCNT,PSDGLST,I,VAMATCH
S PSORES=0
I $G(DGDESC)]"" D
.S DGDESC=$$UP^XLFSTR(DGDESC)
.I $D(^PSDRUG("B",DGDESC)) D
..S (PSDRG,PSDRGCNT)=0 F S PSDRG=$O(^PSDRUG("B",DGDESC,PSDRG)) Q:'PSDRG D
...I '$$ACTIVE(PSDRG)!('$$OUTPAT(PSDRG)) Q
...S PSDRGCNT=PSDRGCNT+1,PSDGLST(PSDRG)=""
..I PSDRGCNT>1 S PSORES="0^More than one possible drug match found. Pharmacist review required."
..I PSDRGCNT=1 S PSMIEN=$O(^PSDRUG("B",DGDESC,0)),PSORES=PSMIEN_U_$$GET1^DIQ(50,PSMIEN,.01,"E") Q
.I $D(^PSNDF(50.68,"B",DGDESC)) S VAPRID=$O(^PSNDF(50.68,"B",DGDESC,0)) Q
.; is it possible to have more than one drug or va product match here? .01 fields are unique!
; direct match in DRUG file
I $P(PSORES,U)>1 Q
; direct match in VA PRODUCT file
I $G(VAPRID) D VAPRID(.PSORES,VAPRID) I $P(PSORES,U) Q
I $G(NDCUPN)']"",$P(PSORES,U,2)]"" Q
; check the NDC/UPN if passed in
S PSORES=""
I $G(NDCUPN)]"" D
.S NDCUPNT=$P(NDCUPN,U),NDCUPNV=$P(NDCUPN,U,2),NDCUXREF=$S(NDCUPNT="N":"NDC",NDCUPNT="U":"UPN",1:"")
.; if NDC is less than 12 in length, pad front with zeros until a length of 12 is achieved.
.I NDCUPNT="N",$L(NDCUPNV)<12 D
..F I=1:1:12-$L(NDCUPNV) S NDCUPNV=0_NDCUPNV
.I NDCUXREF=""!(NDCUPNV="") Q
.I '$D(^PSNDF(50.67,NDCUXREF,NDCUPNV)) S PSORES="0^NDC/UPN match not found." Q
.S NUIEN=0 K VAMATCH
.F S NUIEN=$O(^PSNDF(50.67,NDCUXREF,NDCUPNV,NUIEN)) Q:'NUIEN D I $P(PSORES,"^")=0 Q
..I $$GET1^DIQ(50.67,NUIEN,7,"I") Q ; NDC/UPN is Inactive
..S VAPRID=$$GET1^DIQ(50.67,NUIEN,5,"I") I 'VAPRID Q
..I $$GET1^DIQ(50.68,VAPRID,21,"I") Q ; VA PRODUCT is Inactive
..I $D(VAMATCH(VAPRID)) Q ; VA PRODUCT already matched
..I VAPRID D VAPRID(.PSORES,VAPRID)
..I $P(PSORES,"^")=0!(+$G(PSORES)&$O(VAMATCH(0))) D Q ; Multiple Dispense Drugs or Unique Dispense Drug Not Found
...S PSORES="0^No unique matches found."
..S VAMATCH(VAPRID)=""
I $P(PSORES,U) Q
I PSORES="" S PSORES="0^No matches found."
Q
;
VAPRID(PSORES,VAPID) I '$G(VAPRID) S PSORES="0^No VA PRODUCT associated with this NDC/UPN." Q
N VAPMTCH,VAPCNT,VAPDRG,PSODRG
S (VAPMTCH,VAPCNT)=0
F S VAPMTCH=$O(^PSDRUG("APR",VAPRID,VAPMTCH)) Q:'VAPMTCH D
.; ONLY GET MEDICATIONS FOR OUTPATIENT USE, AND ARE NOT MARKED INACTIVE
.I '$$OUTPAT(VAPMTCH)!('$$ACTIVE(VAPMTCH))!($$INVCOMP(VAPMTCH)) Q
.S VAPDRG(VAPMTCH)="",VAPCNT=VAPCNT+1
I VAPCNT=1 S PSODRG=$O(VAPDRG(0)),PSORES=PSODRG_U_$$GET1^DIQ(50,PSODRG,.01,"E") Q
I VAPCNT>1 S PSORES="0^Multiple matched drugs found. Pharmacist review required." Q
Q
; active drug check
ACTIVE(DIEN) ;
N INACTDT
S INACTDT=$P($G(^PSDRUG(DIEN,"I")),U) I INACTDT,INACTDT<DT Q 0
Q 1
; check to see if this is drug is marked for outpatient use
OUTPAT(DIEN) ;
I $P($G(^PSDRUG(DIEN,2)),U,3)["O" Q 1
Q 0
; check to see if the drug is investigational or compond
INVCOMP(DIEN) ;
N X
S X=$P($G(^PSDRUG(DIEN,0)),U,3)
; if a supply, not controlled substance
I X="S" Q 0
I X["I"!(X["0")!(X["M") Q 1
Q 0
CS(DIEN) ;
N X
S X=$P($G(^PSDRUG(DIEN,0)),U,3)
I X["S" Q 0
I X]"",(X["1")!(X["2")!(X["3")!(X["4")!(X["5") Q 1 ; PSO*7*586
Q 0
CHKSTR() ;
Q
TPRVMTCH ;
N X,Y,TRES
S X="" F S X=$O(^VA(200,"PS1",X)) Q:X="" D
.S Y=0 F S Y=$O(^VA(200,"PS1",X,Y)) Q:'Y D
..K TRES D PRVMTCH(.TRES,"",X) I $P(TRES,U)=0 W !,TRES_" "_X Q
..I $P(TRES,U) W !,X,?20,$$GET1^DIQ(200,Y,.01,"E")
Q
; Match provider given NPI, DEA, or provider name.
; NPI - NPI value for the provider
; DEA - Providers' DEA number
; CS - controlled substance (1-yes, 0 or "" - no)
PRVMTCH(PSORES,NPI,DEA,CS) ;
N NPIEN,MATCH,VAL,NVAL,INDEX,NPCNT,NPLIST,DEACNT,SRCH,DEACNT,DEAMTCH,NDMTCH,DEAIEN,DEABASE
N DEACHK
S (PSORES,MATCH)=0
S NPI=$G(NPI,""),DEA=$G(DEA,""),DEABASE=$P(DEA,"-")
I NPI="",DEA="" S PSORES="0^NPI and DEA# missing." Q
I $G(CS),DEA="" S PSORES="0^DEA # must be provided with controlled substances." Q
I $G(CS),NPI="" S PSORES="0^NPI must be provided with controlled substances." Q
I $G(CS),'$D(^VA(200,"ANPI",NPI)) S PSORES="0^NPI# does not exist in this system." Q
I $G(CS),'$D(^VA(200,"PS4",DEABASE)) S PSORES="0^DEA# does not exist in this system." Q ; PSO*7*743
I '$G(CS),NPI="" D Q
.I DEA="" S PSORES="0^Missing DEA number." Q
.I '$D(^VA(200,"PS4",DEABASE)) S PSORES="0^DEA# does not exist at this location." Q ; PSO*7*743
.S (DEACHK,DEACNT)=0 F S DEACHK=$O(^VA(200,"PS4",DEABASE,DEACHK)) Q:'DEACHK D ; PSO*7*743
..I DEA["-" N DEAFIEN,DEASUF,DEATYPE,DEANPIEN D Q ; PSO*7*743 Begin - Institutional DEA suffix check
...S DEAFIEN=$O(^XTV(8991.9,"B",DEABASE,0)) Q:'DEAFIEN
...S DEATYPE=$P($G(^XTV(8991.9,DEAFIEN,0)),"^",7)
...Q:DEATYPE=2 S DEANPIEN=$O(^VA(200,DEACHK,"PS4","B",DEABASE,0))
...Q:'DEANPIEN
...S DEACNT=$G(DEACNT)+1,DEAIEN=DEACHK ; PSO*7*743 End
..S DEACNT=$G(DEACNT)+1
.I DEACNT=0 S PSORES="0^DEA# does not exist at this location." Q
.I DEACNT>1 S PSORES="0^Multiple DEA matches found." Q
.I DEACNT=1,'$G(DEAIEN) S DEAIEN=$O(^VA(200,"PS4",DEA,0)) ; PSO*7*743
.I '$$MEDAUTH(DEAIEN) S PSORES="0^DEA match, not authorized to write medication orders." Q
.S PSORES=DEAIEN_U_$$GET1^DIQ(200,DEAIEN,.01,"E")
I '$D(^VA(200,"ANPI",NPI)) S PSORES="0^No matching NPI." Q
; get a list of providers that match the NPI#
S (NPIEN,NPCNT)=0 F S NPIEN=$O(^VA(200,"ANPI",NPI,NPIEN)) Q:'NPIEN D
.S NPLIST(NPIEN)="",NPCNT=$G(NPCNT)+1
; no matches
I '$D(NPLIST) S PSORES="0^Could not match provided NPI." Q
I '$G(CS),NPCNT>1 S PSORES="0^Multiple provider matches found." Q
I NPCNT=0 S PSORES="0^No NPI match found." Q
I '$G(CS),NPCNT=1 D Q
.S NDMTCH=$O(NPLIST(0))
.I '$$MEDAUTH(NDMTCH) S PSORES="0^NPI match found, not authorized to write medication orders." Q
.S PSORES=NDMTCH_U_$$GET1^DIQ(200,$O(NPLIST(0)),.01,"E")
; if this is a controlled substance, we must match both the NPI and the DEA#
S (SRCH,DEACNT)=0 F S SRCH=$O(NPLIST(SRCH)) Q:'SRCH D
.I '$D(^VA(200,"PS4",DEABASE,SRCH)) Q
.I DEA["-" N DEAFIEN,DEASUF,DEATYPE,DEANPIEN D Q ; PSO*7*743 Begin - Institutional DEA suffix check
..S DEAFIEN=$O(^XTV(8991.9,"B",DEABASE,0)) Q:'DEAFIEN
..S DEATYPE=$P($G(^XTV(8991.9,DEAFIEN,0)),"^",7)
..Q:DEATYPE=2 S DEANPIEN=$O(^VA(200,SRCH,"PS4","B",DEABASE,0))
..Q:'DEANPIEN S DEASUF=$P(^VA(200,SRCH,"PS4",DEANPIEN,0),"^",2)
..S DEACNT=$G(DEACNT)+1,DEAMTCH(SRCH)="" ; PSO*7*743 End
.S DEAMTCH(SRCH)="",DEACNT=$G(DEACNT)+1
I DEACNT>1 S PSORES="0^Multiple DEA matches found." Q
I DEACNT=0 S PSORES="0^NPI match, DEA mismatch." Q
S NDMTCH=$O(DEAMTCH(0))
I '$$MEDAUTH(NDMTCH) S PSORES="0^NPI/DEA match, not authorized to write medication orders." Q
I NDMTCH S PSORES=NDMTCH_U_$$GET1^DIQ(200,NDMTCH,.01,"E") Q
S PSORES="0^Matching procedure completed with no results."
Q
; ensure the dea# is active
DEACTIVE(USER) ;
N EXPDT
; *545
S EXPDT=$$PRXDT^XUSER(USER)
I EXPDT,EXPDT<DT Q 0
Q 1
; check to ensure the provider is authorized to write med orders
MEDAUTH(USER) ;
Q $$GET1^DIQ(200,USER,53.1,"I")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXA0 7544 printed Dec 13, 2024@02:28:19 Page 2
PSOERXA0 ;ALB/BWF - eRx Utilities/RPC's ; 8/3/2016 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**467,586,617,651,545,743,769**;DEC 1997;Build 26
+2 ;
+3 QUIT
+4 ; All parameters are optional, however at least one needs to be passed in for processing to be sucessful.
+5 ; NDCUPN - This is the NDC/UPN for the drug (optional)
+6 ; DGDESC - Drug description (optional)
DRGMTCH(PSORES,NDCUPN,DGDESC) ;
+1 NEW VAPRID,NDCUPNT,NDCUPNV,NDCUXREF,NUIEN,PSMIEN,PSMIEN,PSDRG,PSDRGCNT,PSDGLST,I,VAMATCH
+2 SET PSORES=0
+3 IF $GET(DGDESC)]""
Begin DoDot:1
+4 SET DGDESC=$$UP^XLFSTR(DGDESC)
+5 IF $DATA(^PSDRUG("B",DGDESC))
Begin DoDot:2
+6 SET (PSDRG,PSDRGCNT)=0
FOR
SET PSDRG=$ORDER(^PSDRUG("B",DGDESC,PSDRG))
if 'PSDRG
QUIT
Begin DoDot:3
+7 IF '$$ACTIVE(PSDRG)!('$$OUTPAT(PSDRG))
QUIT
+8 SET PSDRGCNT=PSDRGCNT+1
SET PSDGLST(PSDRG)=""
End DoDot:3
+9 IF PSDRGCNT>1
SET PSORES="0^More than one possible drug match found. Pharmacist review required."
+10 IF PSDRGCNT=1
SET PSMIEN=$ORDER(^PSDRUG("B",DGDESC,0))
SET PSORES=PSMIEN_U_$$GET1^DIQ(50,PSMIEN,.01,"E")
QUIT
End DoDot:2
+11 IF $DATA(^PSNDF(50.68,"B",DGDESC))
SET VAPRID=$ORDER(^PSNDF(50.68,"B",DGDESC,0))
QUIT
+12 ; is it possible to have more than one drug or va product match here? .01 fields are unique!
End DoDot:1
+13 ; direct match in DRUG file
+14 IF $PIECE(PSORES,U)>1
QUIT
+15 ; direct match in VA PRODUCT file
+16 IF $GET(VAPRID)
DO VAPRID(.PSORES,VAPRID)
IF $PIECE(PSORES,U)
QUIT
+17 IF $GET(NDCUPN)']""
IF $PIECE(PSORES,U,2)]""
QUIT
+18 ; check the NDC/UPN if passed in
+19 SET PSORES=""
+20 IF $GET(NDCUPN)]""
Begin DoDot:1
+21 SET NDCUPNT=$PIECE(NDCUPN,U)
SET NDCUPNV=$PIECE(NDCUPN,U,2)
SET NDCUXREF=$SELECT(NDCUPNT="N":"NDC",NDCUPNT="U":"UPN",1:"")
+22 ; if NDC is less than 12 in length, pad front with zeros until a length of 12 is achieved.
+23 IF NDCUPNT="N"
IF $LENGTH(NDCUPNV)<12
Begin DoDot:2
+24 FOR I=1:1:12-$LENGTH(NDCUPNV)
SET NDCUPNV=0_NDCUPNV
End DoDot:2
+25 IF NDCUXREF=""!(NDCUPNV="")
QUIT
+26 IF '$DATA(^PSNDF(50.67,NDCUXREF,NDCUPNV))
SET PSORES="0^NDC/UPN match not found."
QUIT
+27 SET NUIEN=0
KILL VAMATCH
+28 FOR
SET NUIEN=$ORDER(^PSNDF(50.67,NDCUXREF,NDCUPNV,NUIEN))
if 'NUIEN
QUIT
Begin DoDot:2
+29 ; NDC/UPN is Inactive
IF $$GET1^DIQ(50.67,NUIEN,7,"I")
QUIT
+30 SET VAPRID=$$GET1^DIQ(50.67,NUIEN,5,"I")
IF 'VAPRID
QUIT
+31 ; VA PRODUCT is Inactive
IF $$GET1^DIQ(50.68,VAPRID,21,"I")
QUIT
+32 ; VA PRODUCT already matched
IF $DATA(VAMATCH(VAPRID))
QUIT
+33 IF VAPRID
DO VAPRID(.PSORES,VAPRID)
+34 ; Multiple Dispense Drugs or Unique Dispense Drug Not Found
IF $PIECE(PSORES,"^")=0!(+$GET(PSORES)&$ORDER(VAMATCH(0)))
Begin DoDot:3
+35 SET PSORES="0^No unique matches found."
End DoDot:3
QUIT
+36 SET VAMATCH(VAPRID)=""
End DoDot:2
IF $PIECE(PSORES,"^")=0
QUIT
End DoDot:1
+37 IF $PIECE(PSORES,U)
QUIT
+38 IF PSORES=""
SET PSORES="0^No matches found."
+39 QUIT
+40 ;
VAPRID(PSORES,VAPID) IF '$GET(VAPRID)
SET PSORES="0^No VA PRODUCT associated with this NDC/UPN."
QUIT
+1 NEW VAPMTCH,VAPCNT,VAPDRG,PSODRG
+2 SET (VAPMTCH,VAPCNT)=0
+3 FOR
SET VAPMTCH=$ORDER(^PSDRUG("APR",VAPRID,VAPMTCH))
if 'VAPMTCH
QUIT
Begin DoDot:1
+4 ; ONLY GET MEDICATIONS FOR OUTPATIENT USE, AND ARE NOT MARKED INACTIVE
+5 IF '$$OUTPAT(VAPMTCH)!('$$ACTIVE(VAPMTCH))!($$INVCOMP(VAPMTCH))
QUIT
+6 SET VAPDRG(VAPMTCH)=""
SET VAPCNT=VAPCNT+1
End DoDot:1
+7 IF VAPCNT=1
SET PSODRG=$ORDER(VAPDRG(0))
SET PSORES=PSODRG_U_$$GET1^DIQ(50,PSODRG,.01,"E")
QUIT
+8 IF VAPCNT>1
SET PSORES="0^Multiple matched drugs found. Pharmacist review required."
QUIT
+9 QUIT
+10 ; active drug check
ACTIVE(DIEN) ;
+1 NEW INACTDT
+2 SET INACTDT=$PIECE($GET(^PSDRUG(DIEN,"I")),U)
IF INACTDT
IF INACTDT<DT
QUIT 0
+3 QUIT 1
+4 ; check to see if this is drug is marked for outpatient use
OUTPAT(DIEN) ;
+1 IF $PIECE($GET(^PSDRUG(DIEN,2)),U,3)["O"
QUIT 1
+2 QUIT 0
+3 ; check to see if the drug is investigational or compond
INVCOMP(DIEN) ;
+1 NEW X
+2 SET X=$PIECE($GET(^PSDRUG(DIEN,0)),U,3)
+3 ; if a supply, not controlled substance
+4 IF X="S"
QUIT 0
+5 IF X["I"!(X["0")!(X["M")
QUIT 1
+6 QUIT 0
CS(DIEN) ;
+1 NEW X
+2 SET X=$PIECE($GET(^PSDRUG(DIEN,0)),U,3)
+3 IF X["S"
QUIT 0
+4 ; PSO*7*586
IF X]""
IF (X["1")!(X["2")!(X["3")!(X["4")!(X["5")
QUIT 1
+5 QUIT 0
CHKSTR() ;
+1 QUIT
TPRVMTCH ;
+1 NEW X,Y,TRES
+2 SET X=""
FOR
SET X=$ORDER(^VA(200,"PS1",X))
if X=""
QUIT
Begin DoDot:1
+3 SET Y=0
FOR
SET Y=$ORDER(^VA(200,"PS1",X,Y))
if 'Y
QUIT
Begin DoDot:2
+4 KILL TRES
DO PRVMTCH(.TRES,"",X)
IF $PIECE(TRES,U)=0
WRITE !,TRES_" "_X
QUIT
+5 IF $PIECE(TRES,U)
WRITE !,X,?20,$$GET1^DIQ(200,Y,.01,"E")
End DoDot:2
End DoDot:1
+6 QUIT
+7 ; Match provider given NPI, DEA, or provider name.
+8 ; NPI - NPI value for the provider
+9 ; DEA - Providers' DEA number
+10 ; CS - controlled substance (1-yes, 0 or "" - no)
PRVMTCH(PSORES,NPI,DEA,CS) ;
+1 NEW NPIEN,MATCH,VAL,NVAL,INDEX,NPCNT,NPLIST,DEACNT,SRCH,DEACNT,DEAMTCH,NDMTCH,DEAIEN,DEABASE
+2 NEW DEACHK
+3 SET (PSORES,MATCH)=0
+4 SET NPI=$GET(NPI,"")
SET DEA=$GET(DEA,"")
SET DEABASE=$PIECE(DEA,"-")
+5 IF NPI=""
IF DEA=""
SET PSORES="0^NPI and DEA# missing."
QUIT
+6 IF $GET(CS)
IF DEA=""
SET PSORES="0^DEA # must be provided with controlled substances."
QUIT
+7 IF $GET(CS)
IF NPI=""
SET PSORES="0^NPI must be provided with controlled substances."
QUIT
+8 IF $GET(CS)
IF '$DATA(^VA(200,"ANPI",NPI))
SET PSORES="0^NPI# does not exist in this system."
QUIT
+9 ; PSO*7*743
IF $GET(CS)
IF '$DATA(^VA(200,"PS4",DEABASE))
SET PSORES="0^DEA# does not exist in this system."
QUIT
+10 IF '$GET(CS)
IF NPI=""
Begin DoDot:1
+11 IF DEA=""
SET PSORES="0^Missing DEA number."
QUIT
+12 ; PSO*7*743
IF '$DATA(^VA(200,"PS4",DEABASE))
SET PSORES="0^DEA# does not exist at this location."
QUIT
+13 ; PSO*7*743
SET (DEACHK,DEACNT)=0
FOR
SET DEACHK=$ORDER(^VA(200,"PS4",DEABASE,DEACHK))
if 'DEACHK
QUIT
Begin DoDot:2
+14 ; PSO*7*743 Begin - Institutional DEA suffix check
IF DEA["-"
NEW DEAFIEN,DEASUF,DEATYPE,DEANPIEN
Begin DoDot:3
+15 SET DEAFIEN=$ORDER(^XTV(8991.9,"B",DEABASE,0))
if 'DEAFIEN
QUIT
+16 SET DEATYPE=$PIECE($GET(^XTV(8991.9,DEAFIEN,0)),"^",7)
+17 if DEATYPE=2
QUIT
SET DEANPIEN=$ORDER(^VA(200,DEACHK,"PS4","B",DEABASE,0))
+18 if 'DEANPIEN
QUIT
+19 ; PSO*7*743 End
SET DEACNT=$GET(DEACNT)+1
SET DEAIEN=DEACHK
End DoDot:3
QUIT
+20 SET DEACNT=$GET(DEACNT)+1
End DoDot:2
+21 IF DEACNT=0
SET PSORES="0^DEA# does not exist at this location."
QUIT
+22 IF DEACNT>1
SET PSORES="0^Multiple DEA matches found."
QUIT
+23 ; PSO*7*743
IF DEACNT=1
IF '$GET(DEAIEN)
SET DEAIEN=$ORDER(^VA(200,"PS4",DEA,0))
+24 IF '$$MEDAUTH(DEAIEN)
SET PSORES="0^DEA match, not authorized to write medication orders."
QUIT
+25 SET PSORES=DEAIEN_U_$$GET1^DIQ(200,DEAIEN,.01,"E")
End DoDot:1
QUIT
+26 IF '$DATA(^VA(200,"ANPI",NPI))
SET PSORES="0^No matching NPI."
QUIT
+27 ; get a list of providers that match the NPI#
+28 SET (NPIEN,NPCNT)=0
FOR
SET NPIEN=$ORDER(^VA(200,"ANPI",NPI,NPIEN))
if 'NPIEN
QUIT
Begin DoDot:1
+29 SET NPLIST(NPIEN)=""
SET NPCNT=$GET(NPCNT)+1
End DoDot:1
+30 ; no matches
+31 IF '$DATA(NPLIST)
SET PSORES="0^Could not match provided NPI."
QUIT
+32 IF '$GET(CS)
IF NPCNT>1
SET PSORES="0^Multiple provider matches found."
QUIT
+33 IF NPCNT=0
SET PSORES="0^No NPI match found."
QUIT
+34 IF '$GET(CS)
IF NPCNT=1
Begin DoDot:1
+35 SET NDMTCH=$ORDER(NPLIST(0))
+36 IF '$$MEDAUTH(NDMTCH)
SET PSORES="0^NPI match found, not authorized to write medication orders."
QUIT
+37 SET PSORES=NDMTCH_U_$$GET1^DIQ(200,$ORDER(NPLIST(0)),.01,"E")
End DoDot:1
QUIT
+38 ; if this is a controlled substance, we must match both the NPI and the DEA#
+39 SET (SRCH,DEACNT)=0
FOR
SET SRCH=$ORDER(NPLIST(SRCH))
if 'SRCH
QUIT
Begin DoDot:1
+40 IF '$DATA(^VA(200,"PS4",DEABASE,SRCH))
QUIT
+41 ; PSO*7*743 Begin - Institutional DEA suffix check
IF DEA["-"
NEW DEAFIEN,DEASUF,DEATYPE,DEANPIEN
Begin DoDot:2
+42 SET DEAFIEN=$ORDER(^XTV(8991.9,"B",DEABASE,0))
if 'DEAFIEN
QUIT
+43 SET DEATYPE=$PIECE($GET(^XTV(8991.9,DEAFIEN,0)),"^",7)
+44 if DEATYPE=2
QUIT
SET DEANPIEN=$ORDER(^VA(200,SRCH,"PS4","B",DEABASE,0))
+45 if 'DEANPIEN
QUIT
SET DEASUF=$PIECE(^VA(200,SRCH,"PS4",DEANPIEN,0),"^",2)
+46 ; PSO*7*743 End
SET DEACNT=$GET(DEACNT)+1
SET DEAMTCH(SRCH)=""
End DoDot:2
QUIT
+47 SET DEAMTCH(SRCH)=""
SET DEACNT=$GET(DEACNT)+1
End DoDot:1
+48 IF DEACNT>1
SET PSORES="0^Multiple DEA matches found."
QUIT
+49 IF DEACNT=0
SET PSORES="0^NPI match, DEA mismatch."
QUIT
+50 SET NDMTCH=$ORDER(DEAMTCH(0))
+51 IF '$$MEDAUTH(NDMTCH)
SET PSORES="0^NPI/DEA match, not authorized to write medication orders."
QUIT
+52 IF NDMTCH
SET PSORES=NDMTCH_U_$$GET1^DIQ(200,NDMTCH,.01,"E")
QUIT
+53 SET PSORES="0^Matching procedure completed with no results."
+54 QUIT
+55 ; ensure the dea# is active
DEACTIVE(USER) ;
+1 NEW EXPDT
+2 ; *545
+3 SET EXPDT=$$PRXDT^XUSER(USER)
+4 IF EXPDT
IF EXPDT<DT
QUIT 0
+5 QUIT 1
+6 ; check to ensure the provider is authorized to write med orders
MEDAUTH(USER) ;
+1 QUIT $$GET1^DIQ(200,USER,53.1,"I")
