Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOERXA0

PSOERXA0.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. Q
  1. ; All parameters are optional, however at least one needs to be passed in for processing to be sucessful.
  1. ; NDCUPN - This is the NDC/UPN for the drug (optional)
  1. ; DGDESC - Drug description (optional)
  1. DRGMTCH(PSORES,NDCUPN,DGDESC) ;
  1. N VAPRID,NDCUPNT,NDCUPNV,NDCUXREF,NUIEN,PSMIEN,PSMIEN,PSDRG,PSDRGCNT,PSDGLST,I,VAMATCH
  1. S PSORES=0
  1. I $G(DGDESC)]"" D
  1. .S DGDESC=$$UP^XLFSTR(DGDESC)
  1. .I $D(^PSDRUG("B",DGDESC)) D
  1. ..S (PSDRG,PSDRGCNT)=0 F S PSDRG=$O(^PSDRUG("B",DGDESC,PSDRG)) Q:'PSDRG D
  1. ...I '$$ACTIVE(PSDRG)!('$$OUTPAT(PSDRG)) Q
  1. ...S PSDRGCNT=PSDRGCNT+1,PSDGLST(PSDRG)=""
  1. ..I PSDRGCNT>1 S PSORES="0^More than one possible drug match found. Pharmacist review required."
  1. ..I PSDRGCNT=1 S PSMIEN=$O(^PSDRUG("B",DGDESC,0)),PSORES=PSMIEN_U_$$GET1^DIQ(50,PSMIEN,.01,"E") Q
  1. .I $D(^PSNDF(50.68,"B",DGDESC)) S VAPRID=$O(^PSNDF(50.68,"B",DGDESC,0)) Q
  1. .; is it possible to have more than one drug or va product match here? .01 fields are unique!
  1. ; direct match in DRUG file
  1. I $P(PSORES,U)>1 Q
  1. ; direct match in VA PRODUCT file
  1. I $G(VAPRID) D VAPRID(.PSORES,VAPRID) I $P(PSORES,U) Q
  1. I $G(NDCUPN)']"",$P(PSORES,U,2)]"" Q
  1. ; check the NDC/UPN if passed in
  1. S PSORES=""
  1. I $G(NDCUPN)]"" D
  1. .S NDCUPNT=$P(NDCUPN,U),NDCUPNV=$P(NDCUPN,U,2),NDCUXREF=$S(NDCUPNT="N":"NDC",NDCUPNT="U":"UPN",1:"")
  1. .; if NDC is less than 12 in length, pad front with zeros until a length of 12 is achieved.
  1. .I NDCUPNT="N",$L(NDCUPNV)<12 D
  1. ..F I=1:1:12-$L(NDCUPNV) S NDCUPNV=0_NDCUPNV
  1. .I NDCUXREF=""!(NDCUPNV="") Q
  1. .I '$D(^PSNDF(50.67,NDCUXREF,NDCUPNV)) S PSORES="0^NDC/UPN match not found." Q
  1. .S NUIEN=0 K VAMATCH
  1. .F S NUIEN=$O(^PSNDF(50.67,NDCUXREF,NDCUPNV,NUIEN)) Q:'NUIEN D I $P(PSORES,"^")=0 Q
  1. ..I $$GET1^DIQ(50.67,NUIEN,7,"I") Q ; NDC/UPN is Inactive
  1. ..S VAPRID=$$GET1^DIQ(50.67,NUIEN,5,"I") I 'VAPRID Q
  1. ..I $$GET1^DIQ(50.68,VAPRID,21,"I") Q ; VA PRODUCT is Inactive
  1. ..I $D(VAMATCH(VAPRID)) Q ; VA PRODUCT already matched
  1. ..I VAPRID D VAPRID(.PSORES,VAPRID)
  1. ..I $P(PSORES,"^")=0!(+$G(PSORES)&$O(VAMATCH(0))) D Q ; Multiple Dispense Drugs or Unique Dispense Drug Not Found
  1. ...S PSORES="0^No unique matches found."
  1. ..S VAMATCH(VAPRID)=""
  1. I $P(PSORES,U) Q
  1. I PSORES="" S PSORES="0^No matches found."
  1. Q
  1. ;
  1. VAPRID(PSORES,VAPID) I '$G(VAPRID) S PSORES="0^No VA PRODUCT associated with this NDC/UPN." Q
  1. N VAPMTCH,VAPCNT,VAPDRG,PSODRG
  1. S (VAPMTCH,VAPCNT)=0
  1. F S VAPMTCH=$O(^PSDRUG("APR",VAPRID,VAPMTCH)) Q:'VAPMTCH D
  1. .; ONLY GET MEDICATIONS FOR OUTPATIENT USE, AND ARE NOT MARKED INACTIVE
  1. .I '$$OUTPAT(VAPMTCH)!('$$ACTIVE(VAPMTCH))!($$INVCOMP(VAPMTCH)) Q
  1. .S VAPDRG(VAPMTCH)="",VAPCNT=VAPCNT+1
  1. I VAPCNT=1 S PSODRG=$O(VAPDRG(0)),PSORES=PSODRG_U_$$GET1^DIQ(50,PSODRG,.01,"E") Q
  1. I VAPCNT>1 S PSORES="0^Multiple matched drugs found. Pharmacist review required." Q
  1. Q
  1. ; active drug check
  1. ACTIVE(DIEN) ;
  1. N INACTDT
  1. S INACTDT=$P($G(^PSDRUG(DIEN,"I")),U) I INACTDT,INACTDT<DT Q 0
  1. Q 1
  1. ; check to see if this is drug is marked for outpatient use
  1. OUTPAT(DIEN) ;
  1. I $P($G(^PSDRUG(DIEN,2)),U,3)["O" Q 1
  1. Q 0
  1. ; check to see if the drug is investigational or compond
  1. INVCOMP(DIEN) ;
  1. N X
  1. S X=$P($G(^PSDRUG(DIEN,0)),U,3)
  1. ; if a supply, not controlled substance
  1. I X="S" Q 0
  1. I X["I"!(X["0")!(X["M") Q 1
  1. Q 0
  1. CS(DIEN) ;
  1. N X
  1. S X=$P($G(^PSDRUG(DIEN,0)),U,3)
  1. I X["S" Q 0
  1. I X]"",(X["1")!(X["2")!(X["3")!(X["4")!(X["5") Q 1 ; PSO*7*586
  1. Q 0
  1. CHKSTR() ;
  1. Q
  1. TPRVMTCH ;
  1. N X,Y,TRES
  1. S X="" F S X=$O(^VA(200,"PS1",X)) Q:X="" D
  1. .S Y=0 F S Y=$O(^VA(200,"PS1",X,Y)) Q:'Y D
  1. ..K TRES D PRVMTCH(.TRES,"",X) I $P(TRES,U)=0 W !,TRES_" "_X Q
  1. ..I $P(TRES,U) W !,X,?20,$$GET1^DIQ(200,Y,.01,"E")
  1. Q
  1. ; Match provider given NPI, DEA, or provider name.
  1. ; NPI - NPI value for the provider
  1. ; DEA - Providers' DEA number
  1. ; CS - controlled substance (1-yes, 0 or "" - no)
  1. PRVMTCH(PSORES,NPI,DEA,CS) ;
  1. N NPIEN,MATCH,VAL,NVAL,INDEX,NPCNT,NPLIST,DEACNT,SRCH,DEACNT,DEAMTCH,NDMTCH,DEAIEN,DEABASE
  1. N DEACHK
  1. S (PSORES,MATCH)=0
  1. S NPI=$G(NPI,""),DEA=$G(DEA,""),DEABASE=$P(DEA,"-")
  1. I NPI="",DEA="" S PSORES="0^NPI and DEA# missing." Q
  1. I $G(CS),DEA="" S PSORES="0^DEA # must be provided with controlled substances." Q
  1. I $G(CS),NPI="" S PSORES="0^NPI must be provided with controlled substances." Q
  1. I $G(CS),'$D(^VA(200,"ANPI",NPI)) S PSORES="0^NPI# does not exist in this system." Q
  1. I $G(CS),'$D(^VA(200,"PS4",DEABASE)) S PSORES="0^DEA# does not exist in this system." Q ; PSO*7*743
  1. I '$G(CS),NPI="" D Q
  1. .I DEA="" S PSORES="0^Missing DEA number." Q
  1. .I '$D(^VA(200,"PS4",DEABASE)) S PSORES="0^DEA# does not exist at this location." Q ; PSO*7*743
  1. .S (DEACHK,DEACNT)=0 F S DEACHK=$O(^VA(200,"PS4",DEABASE,DEACHK)) Q:'DEACHK D ; PSO*7*743
  1. ..I DEA["-" N DEAFIEN,DEASUF,DEATYPE,DEANPIEN D Q ; PSO*7*743 Begin - Institutional DEA suffix check
  1. ...S DEAFIEN=$O(^XTV(8991.9,"B",DEABASE,0)) Q:'DEAFIEN
  1. ...S DEATYPE=$P($G(^XTV(8991.9,DEAFIEN,0)),"^",7)
  1. ...Q:DEATYPE=2 S DEANPIEN=$O(^VA(200,DEACHK,"PS4","B",DEABASE,0))
  1. ...Q:'DEANPIEN
  1. ...S DEACNT=$G(DEACNT)+1,DEAIEN=DEACHK ; PSO*7*743 End
  1. ..S DEACNT=$G(DEACNT)+1
  1. .I DEACNT=0 S PSORES="0^DEA# does not exist at this location." Q
  1. .I DEACNT>1 S PSORES="0^Multiple DEA matches found." Q
  1. .I DEACNT=1,'$G(DEAIEN) S DEAIEN=$O(^VA(200,"PS4",DEA,0)) ; PSO*7*743
  1. .I '$$MEDAUTH(DEAIEN) S PSORES="0^DEA match, not authorized to write medication orders." Q
  1. .S PSORES=DEAIEN_U_$$GET1^DIQ(200,DEAIEN,.01,"E")
  1. I '$D(^VA(200,"ANPI",NPI)) S PSORES="0^No matching NPI." Q
  1. ; get a list of providers that match the NPI#
  1. S (NPIEN,NPCNT)=0 F S NPIEN=$O(^VA(200,"ANPI",NPI,NPIEN)) Q:'NPIEN D
  1. .S NPLIST(NPIEN)="",NPCNT=$G(NPCNT)+1
  1. ; no matches
  1. I '$D(NPLIST) S PSORES="0^Could not match provided NPI." Q
  1. I '$G(CS),NPCNT>1 S PSORES="0^Multiple provider matches found." Q
  1. I NPCNT=0 S PSORES="0^No NPI match found." Q
  1. I '$G(CS),NPCNT=1 D Q
  1. .S NDMTCH=$O(NPLIST(0))
  1. .I '$$MEDAUTH(NDMTCH) S PSORES="0^NPI match found, not authorized to write medication orders." Q
  1. .S PSORES=NDMTCH_U_$$GET1^DIQ(200,$O(NPLIST(0)),.01,"E")
  1. ; if this is a controlled substance, we must match both the NPI and the DEA#
  1. S (SRCH,DEACNT)=0 F S SRCH=$O(NPLIST(SRCH)) Q:'SRCH D
  1. .I '$D(^VA(200,"PS4",DEABASE,SRCH)) Q
  1. .I DEA["-" N DEAFIEN,DEASUF,DEATYPE,DEANPIEN D Q ; PSO*7*743 Begin - Institutional DEA suffix check
  1. ..S DEAFIEN=$O(^XTV(8991.9,"B",DEABASE,0)) Q:'DEAFIEN
  1. ..S DEATYPE=$P($G(^XTV(8991.9,DEAFIEN,0)),"^",7)
  1. ..Q:DEATYPE=2 S DEANPIEN=$O(^VA(200,SRCH,"PS4","B",DEABASE,0))
  1. ..Q:'DEANPIEN S DEASUF=$P(^VA(200,SRCH,"PS4",DEANPIEN,0),"^",2)
  1. ..S DEACNT=$G(DEACNT)+1,DEAMTCH(SRCH)="" ; PSO*7*743 End
  1. .S DEAMTCH(SRCH)="",DEACNT=$G(DEACNT)+1
  1. I DEACNT>1 S PSORES="0^Multiple DEA matches found." Q
  1. I DEACNT=0 S PSORES="0^NPI match, DEA mismatch." Q
  1. S NDMTCH=$O(DEAMTCH(0))
  1. I '$$MEDAUTH(NDMTCH) S PSORES="0^NPI/DEA match, not authorized to write medication orders." Q
  1. I NDMTCH S PSORES=NDMTCH_U_$$GET1^DIQ(200,NDMTCH,.01,"E") Q
  1. S PSORES="0^Matching procedure completed with no results."
  1. Q
  1. ; ensure the dea# is active
  1. DEACTIVE(USER) ;
  1. N EXPDT
  1. ; *545
  1. S EXPDT=$$PRXDT^XUSER(USER)
  1. I EXPDT,EXPDT<DT Q 0
  1. Q 1
  1. ; check to ensure the provider is authorized to write med orders
  1. MEDAUTH(USER) ;
  1. Q $$GET1^DIQ(200,USER,53.1,"I")