- 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 Jan 18, 2025@03:29:28 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")