PSOERXUT ;ALB/MR - eRx CS utilities ;7/21/2020 9:57am
;;7.0;OUTPATIENT PHARMACY;**617,667,651,718,700,743**;DEC 1997;Build 24
Q
;
CSFILTER(ERXIEN) ; Check eRx against CS Filter Prompt Answers
; Global variables: PSOCSERX: CS Filter Selection | PSOCSSCH: Drug Schedule Filter Selection
; Input: (r)ERXIEN - Pointer to ERX HOLDING QUEUE (#52.49)
;Output: 1 - Include the eRx | 0 - Exclude the eRx
;
N DRGCSCH,ERXCSFLG
I $G(PSOCSERX)="B",$G(PSOCSSCH)=3 Q 1
S DRGCSCH=$P($G(^PS(52.49,ERXIEN,4)),"^",9)
S ERXCSFLG=+$G(^PS(52.49,ERXIEN,95))
I $G(PSOCSERX)="CS",'ERXCSFLG Q 0
I $G(PSOCSERX)="Non-CS",ERXCSFLG Q 0
I $G(PSOCSERX)="CS",+$G(PSOCSSCH)=1,DRGCSCH'="C48675" Q 0
I $G(PSOCSERX)="CS",+$G(PSOCSSCH)=2,"C48676 C48677 C48679"'[DRGCSCH Q 0
I $G(PSOCSERX)="B",ERXCSFLG,+$G(PSOCSSCH)=1,DRGCSCH'="C48675" Q 0
I $G(PSOCSERX)="B",ERXCSFLG,+$G(PSOCSSCH)=2,"C48676 C48677 C48679"'[DRGCSCH Q 0
Q 1
;
VALPTADD(DFN) ; Returns whether the patient has a valid address or not
; Input: (r)DFN - Pointer to the PATIENT file (#2)
;Output: 1: Valid Address on File (Zip Code or Postal Code value present) | 0: No Valid Address on File
;
N VAPA,I I '$G(DFN) Q 0
D ADD^VADPT I ((+$G(VAPA(25))=1!($G(VAPA(25))=""))&($G(VAPA(11))=""))!((+$G(VAPA(25))>1)&($G(VAPA(24))="")) Q 0
Q 1
;
CSKEYS(USER) ; Checks whether the user has a valid Security Key for CS Orders
; Input: (r)USER - Pointer to the NEW PERSON file (#200)
;Output: 1 - Yes, user is authorized to edit and Validate for CS eRx's | 0: Not authorized
;
I '$D(^XUSEC("PSDRPH",USER)),'$D(^XUSEC("PSO ERX ADV TECH",USER)),'$D(^XUSEC("PSO ERX TECH",USER)) Q 0
Q 1
;
PRDRVAL(RESULT,ACTION,ERXIEN,PROVIEN,DRUGIEN) ; API used to Verify Provider and Drug Selection/Validation for CS Prescriptions
; Input:(r)ACTION - Ation being peformed ("EP": Edit Provider | "VP": Validate Provider | "ED": Edit Drug | "VD": Validate Drug | "AC": Accept eRx)
; (r)ERXIEN - eRx IEN. Pointer to the ERX HOLDING QUEUE file (#52.49)
; (o)PROVIEN - Provider IEN. Pointer to the NEW PERSON file (#200)
; (o)DRUGIEN - Dispense Drug IEN. Pointer to the DRUG file (#50)
;Output: RESULT - 1 (Valid Selection) | 0 (Invalid Selection) ^ Compiled Restriction ("W": Warning / "B": Block)
; RESULT(1..n)=[Invalid Selection Reason]^Restriction (e.g., RESULT(1)="eRx Provider does not have a valid DEA#.")
N ERXPROV,DSERXFLG,ERXPRNPI,ERXPRDEA,VAPRNPI,RXWRDATE,VADRSCH,ERXDRSCH,VADEANUM,VACSDRUG,VADEADSP,VADEASUF,VADEASTR,VADEAEXP,VADEADFL
K RESULT S RESULT=1 S ERXIEN=+$G(ERXIEN),PROVIEN=+$G(PROVIEN),DRUGIEN=+$G(DRUGIEN)
I 'PROVIEN,$$GET1^DIQ(52.49,ERXIEN,2.3,"I")>0 S PROVIEN=+$$GET1^DIQ(52.49,ERXIEN,2.3,"I")
I 'DRUGIEN,$$GET1^DIQ(52.49,ERXIEN,3.2,"I")>0 S DRUGIEN=+$$GET1^DIQ(52.49,ERXIEN,3.2,"I")
I 'ERXIEN!('PROVIEN&'DRUGIEN) S RESULT="0^B",RESULT(1)="Invalid Parameters" Q
;
S ERXPROV=$$GET1^DIQ(52.49,ERXIEN,2.1,"I") ; eRx Provider IEN
S ERXPRNPI=$$GET1^DIQ(52.48,ERXPROV,1.5) ; eRx Provider NPI
S ERXPRDEA=$$UP^XLFSTR($$GET1^DIQ(52.48,ERXPROV,1.6)) ; eRx Provider DEA#
S DSERXFLG=$$GET1^DIQ(52.49,ERXIEN,95.1,"I") ; eRx Digitally Signed Flag
S ERXDRSCH=$$ERXDRSCH(ERXIEN) ; eRx DEA Drug Schedule
S RXWRDATE=$$GET1^DIQ(52.49,ERXIEN,5.9,"I") ; eRx Written Date
S VACSDRUG=0 ; VistA Drug is CS Flag
;
; Edit/Validate Provider & Accept eRx Checks
I ACTION="EP"!(ACTION="VP")!(ACTION="AC") D Q
. N ERXSUFF S ERXSUFF=0
. S VAPRNPI=$P($$NPI^XUSNPI("Individual_ID",PROVIEN),"^") S:VAPRNPI'>0 VAPRNPI=""
. I VAPRNPI'=ERXPRNPI,ACTION'="AC" D
. . S RESULT($O(RESULT(""),-1)+1)="Provider NPI mismatch (eRx: "_ERXPRNPI_" | VistA: "_VAPRNPI_")"
. ; Digitally Signed Order
. I DSERXFLG D
. . ; 743 - Check provider's profile for eRx DEA
. . S VADEADFL=$P($$UP^XLFSTR($$VADEA^PSOERXU8(PROVIEN,ERXIEN)),"^"),(VADEANUM,VADEADSP)=VADEADFL
. . S VADEAEXP=$$DEAXDT^XUSER($P(VADEANUM,"-"))
. . I VADEANUM="" D
. . . S RESULT($O(RESULT(""),-1)+1)="VistA Provider does not have a valid DEA# on file."
. . I ERXPRDEA="" D
. . . S RESULT($O(RESULT(""),-1)+1)="eRx Provider does not have a valid DEA#."
. . I ERXPRDEA'="",$L(VADEANUM)>3,(VADEANUM'=ERXPRDEA) D ; PSO*7*743
. . . I ($P(ERXPRDEA,"-")=$P(VADEANUM,"-")) S ERXSUFF=1 Q
. . . S RESULT($O(RESULT(""),-1)+1)="Provider DEA mismatch (eRx: "_ERXPRDEA_" | VistA: "_VADEADSP_")."
. . I ERXPRDEA'="",$L(VADEANUM)>3,($P(VADEANUM,"-")=$P(ERXPRDEA,"-")),(RXWRDATE>VADEAEXP) D ; PSO*7*743
. . . S RESULT($O(RESULT(""),-1)+1)="eRx Written Date/Issue Date is after the VistA Provider DEA expiration date ("_$$FMTE^XLFDT(VADEAEXP)_")."
. . ; VistA Drug Selected (Additional Checks for CS and Detox drugs)
. . I DRUGIEN D
. . . I $$VADRSCH(DRUGIEN)'="" D
. . . . N DEAFOUND S DEAFOUND=0
. . . . S VACSDRUG=1
. . . . S VADRSCH=$$VADRSCH(DRUGIEN)
. . . . I ERXPRDEA'="" S DEAFOUND=$$DEAFOUND^PSOERXU8(ERXPRDEA,PROVIEN) ; Does the DEA# exist on the provider's profile?
. . . . I DEAFOUND S VADEANUM=$$UP^XLFSTR($$SDEA^XUSER(0,PROVIEN,$P(VADRSCH,"^"),RXWRDATE,$P(ERXPRDEA,"-"))),VADEADSP=$P($$VADEA^PSOERXU8(PROVIEN,ERXIEN),"^") ; PSO*7*743 - If found, valid for drug?
. . . . I 'DEAFOUND D ; PSO*7*743 Begin - If eRx DEA is not found on provider's profile, find default DEA to display
. . . . . S:VADEADFL="" VADEADFL=$$DEA^XUSER(0,PROVIEN)
. . . . . S:VADEADFL="" (VADEANUM,VADEADSP)=1 ; No DEA on file
. . . . . I VADEADFL'="" S (VADEANUM,VADEADSP)=VADEADFL ; PSO*7*743 - Use matching DEA if present, default DEA if no match
. . . . . ; PSO*7*743 End
. . . . I $P(VADEANUM,"^")=2 D
. . . . . S RESULT($O(RESULT(""),-1)+1)="VistA Provider "_$$GET1^DIQ(200,PROVIEN,.01)_" is NOT authorized to write to the schedule ("_$P(VADRSCH,"^",3)_") of the VistA Drug selected."
. ; All checks are OK
. ; Add DEA Suffix mismatch message
. I $G(ERXSUFF) D Q
. . I '$O(RESULT(0)) D SUFFWARN(.RESULT,ERXPRDEA,$S($L($G(VADEADSP)):VADEADSP,1:VADEANUM),0) S RESULT="0^W" Q
. . I ACTION="EP"!(ACTION="VP"),'VACSDRUG D SUFFWARN(.RESULT,ERXPRDEA,$S($L($G(VADEADSP)):VADEADSP,1:VADEANUM),0) S RESULT="0^W" Q
. . I ACTION="EP" D SUFFWARN(.RESULT,ERXPRDEA,$S($L($G(VADEADSP)):VADEADSP,1:VADEANUM),0) S RESULT="0^W" Q
. . I ACTION="VP"!(ACTION="AC") D SUFFWARN(.RESULT,ERXPRDEA,$S($L($G(VADEADSP)):VADEADSP,1:VADEANUM),0) S RESULT="0^B" Q
. I '$O(RESULT(0)) S RESULT=1 Q
. ; VistA Drug is not Selected or it is not a CS Drug
. I ACTION="EP"!(ACTION="VP")!(ACTION="AC"),'VACSDRUG D Q
. . S RESULT="0^W"
. ; Editing Provider, VistA Drug is CS or Detox, Warning (soft stop)
. I ACTION="EP" D Q
. . S RESULT="0^W"
. ; Validating Provider/Accept eRx, VistA Drug is CS or Detox, Block (hard stop)
. I ACTION="VP"!(ACTION="AC") D Q
. . S RESULT="0^B"
;
; Edit/Validate Drug & Accept eRx Checks
I (ACTION="ED")!(ACTION="VD")!(ACTION="AC") D
. S VADRSCH=$$VADRSCH(DRUGIEN) I VADRSCH'="" S VACSDRUG=1
. I DSERXFLG,'VACSDRUG,ACTION'="AC" D
. . S RESULT="0^W"
. . I ERXDRSCH="" D
. . . S RESULT($O(RESULT(""),-1)+1)="eRx was digitally signed by the prescriber and VistA Drug selected is Non-CS. Please, review and make sure you selected the correct drug."
. . E D
. . . S RESULT($O(RESULT(""),-1)+1)="eRx Drug is indicated by the prescriber as CS ("_$P(ERXDRSCH,"^",2)_") and VistA Drug selected is Non-CS. Please, review and make sure you selected the correct drug."
. I 'DSERXFLG,VACSDRUG D
. . S RESULT="0^B"
. . I $P(VADRSCH,"^",2)="L" D
. . . S RESULT($O(RESULT(""),-1)+1)="eRx is not digitally signed and VistA drug is not matched to an NDF item marked with a CS Federal Schedule but is locally marked as a controlled substance ("_$P(VADRSCH,"^",3)_")."
. . E DO
. . . S RESULT($O(RESULT(""),-1)+1)="eRx is not digitally signed and VistA Drug is marked as CS ("_$P(VADRSCH,"^",3)_")."
. I VACSDRUG,ERXPRDEA="" D
. . S RESULT="0^B"
. . S RESULT($O(RESULT(""),-1)+1)="eRx Provider does not have a valid DEA#."
. ; VistA Provider Selected (Additional Checks)
. I PROVIEN D
. . ; CS VistA Drug
. . I VACSDRUG D
. . . N DEAFOUND S DEAFOUND=0 ; PSO*7*743 Begin
. . . I ERXPRDEA'="" S DEAFOUND=$$DEAFOUND^PSOERXU8(ERXPRDEA,PROVIEN) ; Does the DEA# exist on the provider's profile?
. . . I DEAFOUND S VADEANUM=$$UP^XLFSTR($$SDEA^XUSER(0,PROVIEN,$P(VADRSCH,"^"),RXWRDATE,$P(ERXPRDEA,"-"))),(VADEADSP,VADEADFL)=$P($$VADEA^PSOERXU8(PROVIEN,ERXIEN),"^") ; PSO*7*743 - If found, valid for drug?
. . . I 'DEAFOUND D ; PSO*7*743 Begin - If eRx DEA is not found on provider's profile, find default DEA to display
. . . . S VADEADFL=$P($$UP^XLFSTR($$VADEA^PSOERXU8(PROVIEN,ERXIEN)),"^") ; PSO*7*743
. . . . S:VADEADFL="" VADEADFL=$$DEA^XUSER(0,PROVIEN)
. . . . S:VADEADFL="" (VADEANUM,VADEADSP)=1 ; No DEA on file
. . . . I VADEADFL'="" S (VADEANUM,VADEADSP)=VADEADFL ; PSO*7*743 - Use matching DEA if present, default DEA if no match
. . . I $P(VADEANUM,"^")=1 D Q
. . . . S RESULT="0^B"
. . . . S RESULT($O(RESULT(""),-1)+1)="VistA Provider "_$$GET1^DIQ(200,PROVIEN,.01)_" does not have a valid DEA# on file."
. . . . D SUFCHK^PSOERXU8(.RESULT,ERXPRDEA,VADEADFL,$G(ERXSUFF))
. . . I $P(VADEANUM,"^")=2 D Q
. . . . S RESULT="0^"_$S(ACTION="ED"&($P($G(RESULT),"^",2)'="B"):"W",1:"B")
. . . . S RESULT($O(RESULT(""),-1)+1)="VistA Provider "_$$GET1^DIQ(200,PROVIEN,.01)_" is NOT authorized to write to the schedule ("_$P(VADRSCH,"^",3)_") of the VistA Drug selected."
. . . . D SUFCHK^PSOERXU8(.RESULT,ERXPRDEA,VADEADFL,$G(ERXSUFF))
. . . I $P(VADEANUM,"^")=4 D Q
. . . . S RESULT="0^"_$S(ACTION="ED"&($P($G(RESULT),"^",2)'="B"):"W",1:"B")
. . . . S RESULT($O(RESULT(""),-1)+1)="eRx Written Date/Issue Date is after the VistA Provider DEA expiration date ("_$$FMTE^XLFDT($P(VADEANUM,"^",2))_")." ; PSO*7*743
. . . . D SUFCHK^PSOERXU8(.RESULT,ERXPRDEA,VADEADFL,$G(ERXSUFF))
. . . I ERXPRDEA'="",$L($P(VADEANUM,"^",1))>8,($P($P(VADEANUM,"^"),"-")'=$P(ERXPRDEA,"-")) D Q
. . . . S RESULT="0^B"
. . . . S RESULT($O(RESULT(""),-1)+1)="Provider DEA mismatch (eRx: "_ERXPRDEA_" | VistA: "_VADEANUM_")."
. . . . D SUFCHK^PSOERXU8(.RESULT,ERXPRDEA,VADEADFL,$G(ERXSUFF))
. . . D SUFCHK^PSOERXU8(.RESULT,ERXPRDEA,VADEADFL,$G(ERXSUFF))
. . . ; PSO*7*743 End
. . ; Detox VistA Drug
. . I $$DETOX^PSSOPKI(DRUGIEN),$$DETOX^XUSER(PROVIEN,RXWRDATE)'?1"X"1A7N D
. . . S RESULT="0^"_$S(ACTION="ED"&($P($G(RESULT),"^",2)'="B"):"W",1:"B")
. . . S RESULT($O(RESULT(""),-1)+1)="VistA Provider "_$$GET1^DIQ(200,PROVIEN,.01)_" does not have a valid DETOX#."
;
Q
;
ERXDRSCH(ERXIEN) ; Returns the CS Schedule for the eRx Drug (Internal^External Format)
; Input: (r) ERXIEN - Pointer to the ERX HOLDING QUEUE file (52.49)
;Output: ERXDRSCH - eRx DEA Schedule ^ Formatted eRx DEA Schedule (e.g., "2^[C-II]", "4^[C-IV], "", etc...)
;
N ERXDRSCH
I '$G(ERXIEN) Q ""
S ERXDRSCH=$$GET1^DIQ(52.49,+ERXIEN,4.9) I ERXDRSCH="" Q ""
Q (ERXDRSCH_"^[C-"_$S(ERXDRSCH="C48675":"II",ERXDRSCH="C48676":"III",ERXDRSCH="C48677":"IV",ERXDRSCH="C48679":"V",1:"")_"]")
;
VADRSCH(DRUGIEN) ; Returns the CS Schedule for the VistA Dispense Drug (Internal^External Format)
; Input: (r) DRUGIEN - Pointer to the DRUG file (#50)
;Output: VADRSCH - P1: Schedule (2, 2n, 3, ..5) | P2: "F"ederal or "L"ocally Marked CS | P3: Formatted eRx DEA Schedule (e.g., "3n^F^[C-II]", "5^L^[C-V]", "", etc...)
;
N VADRSCH,VAPRDIEN
I '$G(DRUGIEN) Q ""
S VAPRDIEN=+$$GET1^DIQ(50,+DRUGIEN,22,"I")
S VADRSCH=$S(VAPRDIEN:$$GET1^DIQ(50.68,VAPRDIEN,19,"I"),1:+$$GET1^DIQ(50,DRUGIEN,3))
I VADRSCH<1!(VADRSCH>5) Q ""
Q (VADRSCH_"^"_$S(VAPRDIEN:"F",1:"L")_"^[C-"_$S(VADRSCH=2:"II",VADRSCH="2n":"IIn",VADRSCH=3:"III",VADRSCH="3n":"IIIn",+VADRSCH=4:"IV",+VADRSCH=5:"V",1:"")_"]")
;
PAUSE ; Pauses screen until user hits Return
K DIR S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR
Q
;
ERXIEN(PORXIEN) ; Given the Pending Order (#52.41) or Prescription (#52) IEN, returns the eRx (#52.49) IEN or "" (null)
; Input: (r) PORXIEN - Pointer to either the PENDING ORDERS file (#52.41) (e.g., "139839P") or PRESCRIPTION file (#52) (e.g., 12930984)
;Output: ERXIEN - Pointer to the ERX HOLDING QUEUE file (#52.49) or "" (Not an eRx prescription)
;
N OR100IEN
I '$G(PORXIEN) Q ""
I PORXIEN'["P" S OR100IEN=$$GET1^DIQ(52,+PORXIEN,39.3,"I")
I PORXIEN["P" S OR100IEN=+$$GET1^DIQ(52.41,+PORXIEN,.01,"I")
I '$G(OR100IEN) Q ""
Q $S($$CHKERX^PSOERXU1(OR100IEN):$$CHKERX^PSOERXU1(OR100IEN),1:"")
;
AUDLOG(ERXIEN,FIELD,EDITBY,NEWVAL) ; Sets eRx Edit Audit Log
; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49). eRx record being edited.
; (r) FIELD - Freetext eRx Field Name (e.g.,"DRUG", "PROVIDER", "PATIENT", Etc...). Field being edited.
; (r) EDITBY - Pointer to NEW PERSON File (#200). User who made the edit.
; (r) NEWVAL - Array containing the new value for the field being edited (Passed in by Reference)
;
N AUDLOG,SAVERES
S ERXIEN=+$G(ERXIEN),EDITBY=+$G(EDITBY)
I '$D(^PS(52.49,ERXIEN,0)) Q ; Invalid eRx IEN
I $G(FIELD)="" Q ; Invalid Field Name
I '$D(^VA(200,EDITBY,0)) Q ; Invalid Edit By value
I '$D(NEWVAL) Q ; No New Value
;
; Old value and new value are the same (no edit)
I $$EQUAL(ERXIEN,FIELD,.NEWVAL) Q
;
; Saving Data Element
S AUDLOG(52.4920,"+1,"_ERXIEN_",",.01)=$$NOW^XLFDT() ;Audit Log Date/Time
S AUDLOG(52.4920,"+1,"_ERXIEN_",",.02)=FIELD ;Element Name
S AUDLOG(52.4920,"+1,"_ERXIEN_",",.03)=EDITBY ;Data Format
S AUDLOG(52.4920,"+1,"_ERXIEN_",",.04)="NEWVAL" ;New Value
D UPDATE^DIE("","AUDLOG","SAVERES","")
Q
;
EQUAL(ERXIEN,FIELD,NEWVAL) ; Compare if the OLD and NEW values are the same
;Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49). eRx record being edited.
; (r) FIELD - Freetext eRx Field Name (e.g.,"DRUG", "PROVIDER", "PATIENT", Etc...). Field being edited.
; (r) NEWVAL - Array containing the new/current value for the field (Passed by Reference)
;Output: 1 - Values are equal | 0 - Values are different
;
N EQUAL,OLDVAL,I S EQUAL=1
; Retrieving the old/previous value
D OLDVAL(ERXIEN,FIELD,,.OLDVAL)
F I=1:1 Q:'$D(OLDVAL(I)) I $G(OLDVAL(I))'=$G(NEWVAL(I)) S EQUAL=0
I EQUAL F I=1:1 Q:'$D(NEWVAL(I)) I $G(NEWVAL(I))'=$G(OLDVAL(I)) S EQUAL=0
Q EQUAL
;
OLDVAL(ERXIEN,FIELD,STRTFROM,OLDVAL) ; Retrieves the Previous/Old Value for the eRx Field
; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49). eRx record being edited.
; (r) FIELD - Freetext eRx Field Name (e.g.,"DRUG", "PROVIDER", "PATIENT", Etc...). Field being edited.
; (o) STRTFROM - Start From Audit Log IEN. Default: Lastest value for the field.
;Output: OLDVAL - Array containing the old/previous value for the field (Returned by Reference)
;
N AUDLOG,X K OLDVAL
S AUDLOG=$S(+$G(STRTFROM):STRTFROM,1:999999999)
F S AUDLOG=$O(^PS(52.49,ERXIEN,"AUD",AUDLOG),-1) Q:'AUDLOG D I $O(OLDVAL(0)) Q
. I $$GET1^DIQ(52.4920,AUDLOG_","_ERXIEN,.02)=FIELD D
. . F I=1:1 Q:'$D(^PS(52.49,ERXIEN,"AUD",AUDLOG,"VAL",I)) D
. . . S OLDVAL(I)=^PS(52.49,ERXIEN,"AUD",AUDLOG,"VAL",I,0)
Q
;
PROXYDUZ() ; Returns the Proxy DUZ for Audit Log entries from Auto-Matching
; Output: PROXYDUZ - Pointer to NEW PERSON file (#200)
N DIC,X,Y
S DIC="^VA(200,",DIC(0)="X",X="PSOAPPLICATIONPROXY,PSO" D ^DIC
Q $S(+$G(Y):+$G(Y),1:.5)
;
DONOTFIL(ERXIEN) ; Do Not Fill record
; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49). eRx record being edited.
;Output: 1: 'Do Not Fill' eRx Record (Display Message on the Scrren) ! 0: Not a 'Do Not Fill' eRx Record
;
I $$GET1^DIQ(52.49,+$G(ERXIEN),10.5,"I")=2 D Q 1
. W !!,"This is a DO NOT FILL record. The only actions available are REMOVE or REJECT.",$C(7)
. D PAUSE^VALM1
Q 0
;
SUFFWARN(RESULT,ERXPRDEA,VADEADSP,HEADER) ; Append suffix warning to end of RESULT array
; Input: (r) ERXPRDEA - eRx DEA number
; (r) VADEADSP - VA DEA #
; (o) HEADER - Print Message Heading
; Output: RESULT - DEA Number suffix mismatch warning text
N RESCNT S RESCNT=$O(RESULT(""),-1)
I $G(HEADER)!RESCNT D
. S RESULT($O(RESULT(""),-1)+1)="******************************* WARNING(S) *******************************"
S RESULT($O(RESULT(""),-1)+1)="Provider DEA suffix mismatch (eRx: "_ERXPRDEA_" | VistA: "_VADEADSP_")."
Q
;
DEFROUTE(OIIEN) ; Returns the Default Route for Orderable Item
; Input: OIIEN - Orderable Item IEN - Pointer to PHARMACY ORDERABLE ITEM file (#50.7)
;Output: DEFROUTE - Default Route (e.g., "ORAL", "TOPICAL", etc..) or "" (No default route found)
I '$G(OIIEN)!'$D(^PS(50.7,+$G(OIIEN))) Q ""
N DEFROUTE,DFIEN,RTIEN S DEFROUTE=""
I $$GET1^DIQ(50.7,OIIEN,10,"I")="N" D ; OI uses Possible Med Route(s)
. S RTIEN=$O(^PS(50.7,OIIEN,3,0)) I 'RTIEN Q ; No Possible Routes Found
. I $O(^PS(50.7,OIIEN,3,RTIEN)) Q ; More than one Possible Med Route Found
. S DEFROUTE=$$GET1^DIQ(50.711,RTIEN_","_OIIEN,.01)
I $$GET1^DIQ(50.7,OIIEN,10,"I")="Y" D ; OI uses Dosage Form Med Route(s)
. S DFIEN=$$GET1^DIQ(50.7,OIIEN,.02,"I") I 'DFIEN Q ; No Dosage Form pointer Found
. S RTIEN=$O(^PS(50.606,DFIEN,"MR",0)) I 'RTIEN Q ; No Med Route for Dosage Form Found
. I $O(^PS(50.606,DFIEN,"MR",RTIEN)) Q ; More than one Med Route Found
. S DEFROUTE=$$GET1^DIQ(50.6061,RTIEN_","_DFIEN,.01)
;
; No Route Found above and Orderable Item has a Default Route
I DEFROUTE="",$$GET1^DIQ(50.7,OIIEN,.06)'="" Q $$GET1^DIQ(50.7,OIIEN,.06)
; Orderable Item has a Default Route that does not match the one found
I DEFROUTE'="",$$GET1^DIQ(50.7,OIIEN,.06)'="",DEFROUTE'=$$GET1^DIQ(50.7,OIIEN,.06) Q ""
;
Q DEFROUTE
;
ERXSIG(ERXIEN) ; Returns the eRx SIG
Q $$ERXSIG^PSOERXU8(ERXIEN)
;
VISTASIG(ERXIEN) ; Returns the VistA SIG, if present
Q $$VISTASIG^PSOERXU8(ERXIEN)
;
RENEWALS(ERXIEN) ; Returns whether Renewals are Prohibited or no
Q $$RENEWALS^PSOERXU8(ERXIEN)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXUT 18304 printed Sep 23, 2025@20:05:35 Page 2
PSOERXUT ;ALB/MR - eRx CS utilities ;7/21/2020 9:57am
+1 ;;7.0;OUTPATIENT PHARMACY;**617,667,651,718,700,743**;DEC 1997;Build 24
+2 QUIT
+3 ;
CSFILTER(ERXIEN) ; Check eRx against CS Filter Prompt Answers
+1 ; Global variables: PSOCSERX: CS Filter Selection | PSOCSSCH: Drug Schedule Filter Selection
+2 ; Input: (r)ERXIEN - Pointer to ERX HOLDING QUEUE (#52.49)
+3 ;Output: 1 - Include the eRx | 0 - Exclude the eRx
+4 ;
+5 NEW DRGCSCH,ERXCSFLG
+6 IF $GET(PSOCSERX)="B"
IF $GET(PSOCSSCH)=3
QUIT 1
+7 SET DRGCSCH=$PIECE($GET(^PS(52.49,ERXIEN,4)),"^",9)
+8 SET ERXCSFLG=+$GET(^PS(52.49,ERXIEN,95))
+9 IF $GET(PSOCSERX)="CS"
IF 'ERXCSFLG
QUIT 0
+10 IF $GET(PSOCSERX)="Non-CS"
IF ERXCSFLG
QUIT 0
+11 IF $GET(PSOCSERX)="CS"
IF +$GET(PSOCSSCH)=1
IF DRGCSCH'="C48675"
QUIT 0
+12 IF $GET(PSOCSERX)="CS"
IF +$GET(PSOCSSCH)=2
IF "C48676 C48677 C48679"'[DRGCSCH
QUIT 0
+13 IF $GET(PSOCSERX)="B"
IF ERXCSFLG
IF +$GET(PSOCSSCH)=1
IF DRGCSCH'="C48675"
QUIT 0
+14 IF $GET(PSOCSERX)="B"
IF ERXCSFLG
IF +$GET(PSOCSSCH)=2
IF "C48676 C48677 C48679"'[DRGCSCH
QUIT 0
+15 QUIT 1
+16 ;
VALPTADD(DFN) ; Returns whether the patient has a valid address or not
+1 ; Input: (r)DFN - Pointer to the PATIENT file (#2)
+2 ;Output: 1: Valid Address on File (Zip Code or Postal Code value present) | 0: No Valid Address on File
+3 ;
+4 NEW VAPA,I
IF '$GET(DFN)
QUIT 0
+5 DO ADD^VADPT
IF ((+$GET(VAPA(25))=1!($GET(VAPA(25))=""))&($GET(VAPA(11))=""))!((+$GET(VAPA(25))>1)&($GET(VAPA(24))=""))
QUIT 0
+6 QUIT 1
+7 ;
CSKEYS(USER) ; Checks whether the user has a valid Security Key for CS Orders
+1 ; Input: (r)USER - Pointer to the NEW PERSON file (#200)
+2 ;Output: 1 - Yes, user is authorized to edit and Validate for CS eRx's | 0: Not authorized
+3 ;
+4 IF '$DATA(^XUSEC("PSDRPH",USER))
IF '$DATA(^XUSEC("PSO ERX ADV TECH",USER))
IF '$DATA(^XUSEC("PSO ERX TECH",USER))
QUIT 0
+5 QUIT 1
+6 ;
PRDRVAL(RESULT,ACTION,ERXIEN,PROVIEN,DRUGIEN) ; API used to Verify Provider and Drug Selection/Validation for CS Prescriptions
+1 ; Input:(r)ACTION - Ation being peformed ("EP": Edit Provider | "VP": Validate Provider | "ED": Edit Drug | "VD": Validate Drug | "AC": Accept eRx)
+2 ; (r)ERXIEN - eRx IEN. Pointer to the ERX HOLDING QUEUE file (#52.49)
+3 ; (o)PROVIEN - Provider IEN. Pointer to the NEW PERSON file (#200)
+4 ; (o)DRUGIEN - Dispense Drug IEN. Pointer to the DRUG file (#50)
+5 ;Output: RESULT - 1 (Valid Selection) | 0 (Invalid Selection) ^ Compiled Restriction ("W": Warning / "B": Block)
+6 ; RESULT(1..n)=[Invalid Selection Reason]^Restriction (e.g., RESULT(1)="eRx Provider does not have a valid DEA#.")
+7 NEW ERXPROV,DSERXFLG,ERXPRNPI,ERXPRDEA,VAPRNPI,RXWRDATE,VADRSCH,ERXDRSCH,VADEANUM,VACSDRUG,VADEADSP,VADEASUF,VADEASTR,VADEAEXP,VADEADFL
+8 KILL RESULT
SET RESULT=1
SET ERXIEN=+$GET(ERXIEN)
SET PROVIEN=+$GET(PROVIEN)
SET DRUGIEN=+$GET(DRUGIEN)
+9 IF 'PROVIEN
IF $$GET1^DIQ(52.49,ERXIEN,2.3,"I")>0
SET PROVIEN=+$$GET1^DIQ(52.49,ERXIEN,2.3,"I")
+10 IF 'DRUGIEN
IF $$GET1^DIQ(52.49,ERXIEN,3.2,"I")>0
SET DRUGIEN=+$$GET1^DIQ(52.49,ERXIEN,3.2,"I")
+11 IF 'ERXIEN!('PROVIEN&'DRUGIEN)
SET RESULT="0^B"
SET RESULT(1)="Invalid Parameters"
QUIT
+12 ;
+13 ; eRx Provider IEN
SET ERXPROV=$$GET1^DIQ(52.49,ERXIEN,2.1,"I")
+14 ; eRx Provider NPI
SET ERXPRNPI=$$GET1^DIQ(52.48,ERXPROV,1.5)
+15 ; eRx Provider DEA#
SET ERXPRDEA=$$UP^XLFSTR($$GET1^DIQ(52.48,ERXPROV,1.6))
+16 ; eRx Digitally Signed Flag
SET DSERXFLG=$$GET1^DIQ(52.49,ERXIEN,95.1,"I")
+17 ; eRx DEA Drug Schedule
SET ERXDRSCH=$$ERXDRSCH(ERXIEN)
+18 ; eRx Written Date
SET RXWRDATE=$$GET1^DIQ(52.49,ERXIEN,5.9,"I")
+19 ; VistA Drug is CS Flag
SET VACSDRUG=0
+20 ;
+21 ; Edit/Validate Provider & Accept eRx Checks
+22 IF ACTION="EP"!(ACTION="VP")!(ACTION="AC")
Begin DoDot:1
+23 NEW ERXSUFF
SET ERXSUFF=0
+24 SET VAPRNPI=$PIECE($$NPI^XUSNPI("Individual_ID",PROVIEN),"^")
if VAPRNPI'>0
SET VAPRNPI=""
+25 IF VAPRNPI'=ERXPRNPI
IF ACTION'="AC"
Begin DoDot:2
+26 SET RESULT($ORDER(RESULT(""),-1)+1)="Provider NPI mismatch (eRx: "_ERXPRNPI_" | VistA: "_VAPRNPI_")"
End DoDot:2
+27 ; Digitally Signed Order
+28 IF DSERXFLG
Begin DoDot:2
+29 ; 743 - Check provider's profile for eRx DEA
+30 SET VADEADFL=$PIECE($$UP^XLFSTR($$VADEA^PSOERXU8(PROVIEN,ERXIEN)),"^")
SET (VADEANUM,VADEADSP)=VADEADFL
+31 SET VADEAEXP=$$DEAXDT^XUSER($PIECE(VADEANUM,"-"))
+32 IF VADEANUM=""
Begin DoDot:3
+33 SET RESULT($ORDER(RESULT(""),-1)+1)="VistA Provider does not have a valid DEA# on file."
End DoDot:3
+34 IF ERXPRDEA=""
Begin DoDot:3
+35 SET RESULT($ORDER(RESULT(""),-1)+1)="eRx Provider does not have a valid DEA#."
End DoDot:3
+36 ; PSO*7*743
IF ERXPRDEA'=""
IF $LENGTH(VADEANUM)>3
IF (VADEANUM'=ERXPRDEA)
Begin DoDot:3
+37 IF ($PIECE(ERXPRDEA,"-")=$PIECE(VADEANUM,"-"))
SET ERXSUFF=1
QUIT
+38 SET RESULT($ORDER(RESULT(""),-1)+1)="Provider DEA mismatch (eRx: "_ERXPRDEA_" | VistA: "_VADEADSP_")."
End DoDot:3
+39 ; PSO*7*743
IF ERXPRDEA'=""
IF $LENGTH(VADEANUM)>3
IF ($PIECE(VADEANUM,"-")=$PIECE(ERXPRDEA,"-"))
IF (RXWRDATE>VADEAEXP)
Begin DoDot:3
+40 SET RESULT($ORDER(RESULT(""),-1)+1)="eRx Written Date/Issue Date is after the VistA Provider DEA expiration date ("_$$FMTE^XLFDT(VADEAEXP)_")."
End DoDot:3
+41 ; VistA Drug Selected (Additional Checks for CS and Detox drugs)
+42 IF DRUGIEN
Begin DoDot:3
+43 IF $$VADRSCH(DRUGIEN)'=""
Begin DoDot:4
+44 NEW DEAFOUND
SET DEAFOUND=0
+45 SET VACSDRUG=1
+46 SET VADRSCH=$$VADRSCH(DRUGIEN)
+47 ; Does the DEA# exist on the provider's profile?
IF ERXPRDEA'=""
SET DEAFOUND=$$DEAFOUND^PSOERXU8(ERXPRDEA,PROVIEN)
+48 ; PSO*7*743 - If found, valid for drug?
IF DEAFOUND
SET VADEANUM=$$UP^XLFSTR($$SDEA^XUSER(0,PROVIEN,$PIECE(VADRSCH,"^"),RXWRDATE,$PIECE(ERXPRDEA,"-")))
SET VADEADSP=$PIECE($$VADEA^PSOERXU8(PROVIEN,ERXIEN),"^")
+49 ; PSO*7*743 Begin - If eRx DEA is not found on provider's profile, find default DEA to display
IF 'DEAFOUND
Begin DoDot:5
+50 if VADEADFL=""
SET VADEADFL=$$DEA^XUSER(0,PROVIEN)
+51 ; No DEA on file
if VADEADFL=""
SET (VADEANUM,VADEADSP)=1
+52 ; PSO*7*743 - Use matching DEA if present, default DEA if no match
IF VADEADFL'=""
SET (VADEANUM,VADEADSP)=VADEADFL
+53 ; PSO*7*743 End
End DoDot:5
+54 IF $PIECE(VADEANUM,"^")=2
Begin DoDot:5
+55 SET RESULT($ORDER(RESULT(""),-1)+1)="VistA Provider "_$$GET1^DIQ(200,PROVIEN,.01)_" is NOT authorized to write to the schedule ("_$PIECE(VADRSCH,"^",3)_") of the VistA Drug selected."
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+56 ; All checks are OK
+57 ; Add DEA Suffix mismatch message
+58 IF $GET(ERXSUFF)
Begin DoDot:2
+59 IF '$ORDER(RESULT(0))
DO SUFFWARN(.RESULT,ERXPRDEA,$SELECT($LENGTH($GET(VADEADSP)):VADEADSP,1:VADEANUM),0)
SET RESULT="0^W"
QUIT
+60 IF ACTION="EP"!(ACTION="VP")
IF 'VACSDRUG
DO SUFFWARN(.RESULT,ERXPRDEA,$SELECT($LENGTH($GET(VADEADSP)):VADEADSP,1:VADEANUM),0)
SET RESULT="0^W"
QUIT
+61 IF ACTION="EP"
DO SUFFWARN(.RESULT,ERXPRDEA,$SELECT($LENGTH($GET(VADEADSP)):VADEADSP,1:VADEANUM),0)
SET RESULT="0^W"
QUIT
+62 IF ACTION="VP"!(ACTION="AC")
DO SUFFWARN(.RESULT,ERXPRDEA,$SELECT($LENGTH($GET(VADEADSP)):VADEADSP,1:VADEANUM),0)
SET RESULT="0^B"
QUIT
End DoDot:2
QUIT
+63 IF '$ORDER(RESULT(0))
SET RESULT=1
QUIT
+64 ; VistA Drug is not Selected or it is not a CS Drug
+65 IF ACTION="EP"!(ACTION="VP")!(ACTION="AC")
IF 'VACSDRUG
Begin DoDot:2
+66 SET RESULT="0^W"
End DoDot:2
QUIT
+67 ; Editing Provider, VistA Drug is CS or Detox, Warning (soft stop)
+68 IF ACTION="EP"
Begin DoDot:2
+69 SET RESULT="0^W"
End DoDot:2
QUIT
+70 ; Validating Provider/Accept eRx, VistA Drug is CS or Detox, Block (hard stop)
+71 IF ACTION="VP"!(ACTION="AC")
Begin DoDot:2
+72 SET RESULT="0^B"
End DoDot:2
QUIT
End DoDot:1
QUIT
+73 ;
+74 ; Edit/Validate Drug & Accept eRx Checks
+75 IF (ACTION="ED")!(ACTION="VD")!(ACTION="AC")
Begin DoDot:1
+76 SET VADRSCH=$$VADRSCH(DRUGIEN)
IF VADRSCH'=""
SET VACSDRUG=1
+77 IF DSERXFLG
IF 'VACSDRUG
IF ACTION'="AC"
Begin DoDot:2
+78 SET RESULT="0^W"
+79 IF ERXDRSCH=""
Begin DoDot:3
+80 SET RESULT($ORDER(RESULT(""),-1)+1)="eRx was digitally signed by the prescriber and VistA Drug selected is Non-CS. Please, review and make sure you selected the correct drug."
End DoDot:3
+81 IF '$TEST
Begin DoDot:3
+82 SET RESULT($ORDER(RESULT(""),-1)+1)="eRx Drug is indicated by the prescriber as CS ("_$PIECE(ERXDRSCH,"^",2)_") and VistA Drug selected is Non-CS. Please, review and make sure you selected the correct drug."
End DoDot:3
End DoDot:2
+83 IF 'DSERXFLG
IF VACSDRUG
Begin DoDot:2
+84 SET RESULT="0^B"
+85 IF $PIECE(VADRSCH,"^",2)="L"
Begin DoDot:3
+86 SET RESULT($ORDER(RESULT(""),-1)+1)="eRx is not digitally signed and VistA drug is not matched to an NDF item marked with a CS Federal Schedule but is locally marked as a controlled substance ("_$PIECE(VADRSCH,"^",3)
_")."
End DoDot:3
+87 IF '$TEST
Begin DoDot:3
+88 SET RESULT($ORDER(RESULT(""),-1)+1)="eRx is not digitally signed and VistA Drug is marked as CS ("_$PIECE(VADRSCH,"^",3)_")."
End DoDot:3
End DoDot:2
+89 IF VACSDRUG
IF ERXPRDEA=""
Begin DoDot:2
+90 SET RESULT="0^B"
+91 SET RESULT($ORDER(RESULT(""),-1)+1)="eRx Provider does not have a valid DEA#."
End DoDot:2
+92 ; VistA Provider Selected (Additional Checks)
+93 IF PROVIEN
Begin DoDot:2
+94 ; CS VistA Drug
+95 IF VACSDRUG
Begin DoDot:3
+96 ; PSO*7*743 Begin
NEW DEAFOUND
SET DEAFOUND=0
+97 ; Does the DEA# exist on the provider's profile?
IF ERXPRDEA'=""
SET DEAFOUND=$$DEAFOUND^PSOERXU8(ERXPRDEA,PROVIEN)
+98 ; PSO*7*743 - If found, valid for drug?
IF DEAFOUND
SET VADEANUM=$$UP^XLFSTR($$SDEA^XUSER(0,PROVIEN,$PIECE(VADRSCH,"^"),RXWRDATE,$PIECE(ERXPRDEA,"-")))
SET (VADEADSP,VADEADFL)=$PIECE($$VADEA^PSOERXU8(PROVIEN,ERXIEN),"^")
+99 ; PSO*7*743 Begin - If eRx DEA is not found on provider's profile, find default DEA to display
IF 'DEAFOUND
Begin DoDot:4
+100 ; PSO*7*743
SET VADEADFL=$PIECE($$UP^XLFSTR($$VADEA^PSOERXU8(PROVIEN,ERXIEN)),"^")
+101 if VADEADFL=""
SET VADEADFL=$$DEA^XUSER(0,PROVIEN)
+102 ; No DEA on file
if VADEADFL=""
SET (VADEANUM,VADEADSP)=1
+103 ; PSO*7*743 - Use matching DEA if present, default DEA if no match
IF VADEADFL'=""
SET (VADEANUM,VADEADSP)=VADEADFL
End DoDot:4
+104 IF $PIECE(VADEANUM,"^")=1
Begin DoDot:4
+105 SET RESULT="0^B"
+106 SET RESULT($ORDER(RESULT(""),-1)+1)="VistA Provider "_$$GET1^DIQ(200,PROVIEN,.01)_" does not have a valid DEA# on file."
+107 DO SUFCHK^PSOERXU8(.RESULT,ERXPRDEA,VADEADFL,$GET(ERXSUFF))
End DoDot:4
QUIT
+108 IF $PIECE(VADEANUM,"^")=2
Begin DoDot:4
+109 SET RESULT="0^"_$SELECT(ACTION="ED"&($PIECE($GET(RESULT),"^",2)'="B"):"W",1:"B")
+110 SET RESULT($ORDER(RESULT(""),-1)+1)="VistA Provider "_$$GET1^DIQ(200,PROVIEN,.01)_" is NOT authorized to write to the schedule ("_$PIECE(VADRSCH,"^",3)_") of the VistA Drug selected."
+111 DO SUFCHK^PSOERXU8(.RESULT,ERXPRDEA,VADEADFL,$GET(ERXSUFF))
End DoDot:4
QUIT
+112 IF $PIECE(VADEANUM,"^")=4
Begin DoDot:4
+113 SET RESULT="0^"_$SELECT(ACTION="ED"&($PIECE($GET(RESULT),"^",2)'="B"):"W",1:"B")
+114 ; PSO*7*743
SET RESULT($ORDER(RESULT(""),-1)+1)="eRx Written Date/Issue Date is after the VistA Provider DEA expiration date ("_$$FMTE^XLFDT($PIECE(VADEANUM,"^",2))_")."
+115 DO SUFCHK^PSOERXU8(.RESULT,ERXPRDEA,VADEADFL,$GET(ERXSUFF))
End DoDot:4
QUIT
+116 IF ERXPRDEA'=""
IF $LENGTH($PIECE(VADEANUM,"^",1))>8
IF ($PIECE($PIECE(VADEANUM,"^"),"-")'=$PIECE(ERXPRDEA,"-"))
Begin DoDot:4
+117 SET RESULT="0^B"
+118 SET RESULT($ORDER(RESULT(""),-1)+1)="Provider DEA mismatch (eRx: "_ERXPRDEA_" | VistA: "_VADEANUM_")."
+119 DO SUFCHK^PSOERXU8(.RESULT,ERXPRDEA,VADEADFL,$GET(ERXSUFF))
End DoDot:4
QUIT
+120 DO SUFCHK^PSOERXU8(.RESULT,ERXPRDEA,VADEADFL,$GET(ERXSUFF))
+121 ; PSO*7*743 End
End DoDot:3
+122 ; Detox VistA Drug
+123 IF $$DETOX^PSSOPKI(DRUGIEN)
IF $$DETOX^XUSER(PROVIEN,RXWRDATE)'?1"X"1A7N
Begin DoDot:3
+124 SET RESULT="0^"_$SELECT(ACTION="ED"&($PIECE($GET(RESULT),"^",2)'="B"):"W",1:"B")
+125 SET RESULT($ORDER(RESULT(""),-1)+1)="VistA Provider "_$$GET1^DIQ(200,PROVIEN,.01)_" does not have a valid DETOX#."
End DoDot:3
End DoDot:2
End DoDot:1
+126 ;
+127 QUIT
+128 ;
ERXDRSCH(ERXIEN) ; Returns the CS Schedule for the eRx Drug (Internal^External Format)
+1 ; Input: (r) ERXIEN - Pointer to the ERX HOLDING QUEUE file (52.49)
+2 ;Output: ERXDRSCH - eRx DEA Schedule ^ Formatted eRx DEA Schedule (e.g., "2^[C-II]", "4^[C-IV], "", etc...)
+3 ;
+4 NEW ERXDRSCH
+5 IF '$GET(ERXIEN)
QUIT ""
+6 SET ERXDRSCH=$$GET1^DIQ(52.49,+ERXIEN,4.9)
IF ERXDRSCH=""
QUIT ""
+7 QUIT (ERXDRSCH_"^[C-"_$SELECT(ERXDRSCH="C48675":"II",ERXDRSCH="C48676":"III",ERXDRSCH="C48677":"IV",ERXDRSCH="C48679":"V",1:"")_"]")
+8 ;
VADRSCH(DRUGIEN) ; Returns the CS Schedule for the VistA Dispense Drug (Internal^External Format)
+1 ; Input: (r) DRUGIEN - Pointer to the DRUG file (#50)
+2 ;Output: VADRSCH - P1: Schedule (2, 2n, 3, ..5) | P2: "F"ederal or "L"ocally Marked CS | P3: Formatted eRx DEA Schedule (e.g., "3n^F^[C-II]", "5^L^[C-V]", "", etc...)
+3 ;
+4 NEW VADRSCH,VAPRDIEN
+5 IF '$GET(DRUGIEN)
QUIT ""
+6 SET VAPRDIEN=+$$GET1^DIQ(50,+DRUGIEN,22,"I")
+7 SET VADRSCH=$SELECT(VAPRDIEN:$$GET1^DIQ(50.68,VAPRDIEN,19,"I"),1:+$$GET1^DIQ(50,DRUGIEN,3))
+8 IF VADRSCH<1!(VADRSCH>5)
QUIT ""
+9 QUIT (VADRSCH_"^"_$SELECT(VAPRDIEN:"F",1:"L")_"^[C-"_$SELECT(VADRSCH=2:"II",VADRSCH="2n":"IIn",VADRSCH=3:"III",VADRSCH="3n":"IIIn",+VADRSCH=4:"IV",+VADRSCH=5:"V",1:"")_"]")
+10 ;
PAUSE ; Pauses screen until user hits Return
+1 KILL DIR
SET DIR("A")="Press Return to continue"
SET DIR(0)="E"
DO ^DIR
+2 QUIT
+3 ;
ERXIEN(PORXIEN) ; Given the Pending Order (#52.41) or Prescription (#52) IEN, returns the eRx (#52.49) IEN or "" (null)
+1 ; Input: (r) PORXIEN - Pointer to either the PENDING ORDERS file (#52.41) (e.g., "139839P") or PRESCRIPTION file (#52) (e.g., 12930984)
+2 ;Output: ERXIEN - Pointer to the ERX HOLDING QUEUE file (#52.49) or "" (Not an eRx prescription)
+3 ;
+4 NEW OR100IEN
+5 IF '$GET(PORXIEN)
QUIT ""
+6 IF PORXIEN'["P"
SET OR100IEN=$$GET1^DIQ(52,+PORXIEN,39.3,"I")
+7 IF PORXIEN["P"
SET OR100IEN=+$$GET1^DIQ(52.41,+PORXIEN,.01,"I")
+8 IF '$GET(OR100IEN)
QUIT ""
+9 QUIT $SELECT($$CHKERX^PSOERXU1(OR100IEN):$$CHKERX^PSOERXU1(OR100IEN),1:"")
+10 ;
AUDLOG(ERXIEN,FIELD,EDITBY,NEWVAL) ; Sets eRx Edit Audit Log
+1 ; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49). eRx record being edited.
+2 ; (r) FIELD - Freetext eRx Field Name (e.g.,"DRUG", "PROVIDER", "PATIENT", Etc...). Field being edited.
+3 ; (r) EDITBY - Pointer to NEW PERSON File (#200). User who made the edit.
+4 ; (r) NEWVAL - Array containing the new value for the field being edited (Passed in by Reference)
+5 ;
+6 NEW AUDLOG,SAVERES
+7 SET ERXIEN=+$GET(ERXIEN)
SET EDITBY=+$GET(EDITBY)
+8 ; Invalid eRx IEN
IF '$DATA(^PS(52.49,ERXIEN,0))
QUIT
+9 ; Invalid Field Name
IF $GET(FIELD)=""
QUIT
+10 ; Invalid Edit By value
IF '$DATA(^VA(200,EDITBY,0))
QUIT
+11 ; No New Value
IF '$DATA(NEWVAL)
QUIT
+12 ;
+13 ; Old value and new value are the same (no edit)
+14 IF $$EQUAL(ERXIEN,FIELD,.NEWVAL)
QUIT
+15 ;
+16 ; Saving Data Element
+17 ;Audit Log Date/Time
SET AUDLOG(52.4920,"+1,"_ERXIEN_",",.01)=$$NOW^XLFDT()
+18 ;Element Name
SET AUDLOG(52.4920,"+1,"_ERXIEN_",",.02)=FIELD
+19 ;Data Format
SET AUDLOG(52.4920,"+1,"_ERXIEN_",",.03)=EDITBY
+20 ;New Value
SET AUDLOG(52.4920,"+1,"_ERXIEN_",",.04)="NEWVAL"
+21 DO UPDATE^DIE("","AUDLOG","SAVERES","")
+22 QUIT
+23 ;
EQUAL(ERXIEN,FIELD,NEWVAL) ; Compare if the OLD and NEW values are the same
+1 ;Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49). eRx record being edited.
+2 ; (r) FIELD - Freetext eRx Field Name (e.g.,"DRUG", "PROVIDER", "PATIENT", Etc...). Field being edited.
+3 ; (r) NEWVAL - Array containing the new/current value for the field (Passed by Reference)
+4 ;Output: 1 - Values are equal | 0 - Values are different
+5 ;
+6 NEW EQUAL,OLDVAL,I
SET EQUAL=1
+7 ; Retrieving the old/previous value
+8 DO OLDVAL(ERXIEN,FIELD,,.OLDVAL)
+9 FOR I=1:1
if '$DATA(OLDVAL(I))
QUIT
IF $GET(OLDVAL(I))'=$GET(NEWVAL(I))
SET EQUAL=0
+10 IF EQUAL
FOR I=1:1
if '$DATA(NEWVAL(I))
QUIT
IF $GET(NEWVAL(I))'=$GET(OLDVAL(I))
SET EQUAL=0
+11 QUIT EQUAL
+12 ;
OLDVAL(ERXIEN,FIELD,STRTFROM,OLDVAL) ; Retrieves the Previous/Old Value for the eRx Field
+1 ; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49). eRx record being edited.
+2 ; (r) FIELD - Freetext eRx Field Name (e.g.,"DRUG", "PROVIDER", "PATIENT", Etc...). Field being edited.
+3 ; (o) STRTFROM - Start From Audit Log IEN. Default: Lastest value for the field.
+4 ;Output: OLDVAL - Array containing the old/previous value for the field (Returned by Reference)
+5 ;
+6 NEW AUDLOG,X
KILL OLDVAL
+7 SET AUDLOG=$SELECT(+$GET(STRTFROM):STRTFROM,1:999999999)
+8 FOR
SET AUDLOG=$ORDER(^PS(52.49,ERXIEN,"AUD",AUDLOG),-1)
if 'AUDLOG
QUIT
Begin DoDot:1
+9 IF $$GET1^DIQ(52.4920,AUDLOG_","_ERXIEN,.02)=FIELD
Begin DoDot:2
+10 FOR I=1:1
if '$DATA(^PS(52.49,ERXIEN,"AUD",AUDLOG,"VAL",I))
QUIT
Begin DoDot:3
+11 SET OLDVAL(I)=^PS(52.49,ERXIEN,"AUD",AUDLOG,"VAL",I,0)
End DoDot:3
End DoDot:2
End DoDot:1
IF $ORDER(OLDVAL(0))
QUIT
+12 QUIT
+13 ;
PROXYDUZ() ; Returns the Proxy DUZ for Audit Log entries from Auto-Matching
+1 ; Output: PROXYDUZ - Pointer to NEW PERSON file (#200)
+2 NEW DIC,X,Y
+3 SET DIC="^VA(200,"
SET DIC(0)="X"
SET X="PSOAPPLICATIONPROXY,PSO"
DO ^DIC
+4 QUIT $SELECT(+$GET(Y):+$GET(Y),1:.5)
+5 ;
DONOTFIL(ERXIEN) ; Do Not Fill record
+1 ; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49). eRx record being edited.
+2 ;Output: 1: 'Do Not Fill' eRx Record (Display Message on the Scrren) ! 0: Not a 'Do Not Fill' eRx Record
+3 ;
+4 IF $$GET1^DIQ(52.49,+$GET(ERXIEN),10.5,"I")=2
Begin DoDot:1
+5 WRITE !!,"This is a DO NOT FILL record. The only actions available are REMOVE or REJECT.",$CHAR(7)
+6 DO PAUSE^VALM1
End DoDot:1
QUIT 1
+7 QUIT 0
+8 ;
SUFFWARN(RESULT,ERXPRDEA,VADEADSP,HEADER) ; Append suffix warning to end of RESULT array
+1 ; Input: (r) ERXPRDEA - eRx DEA number
+2 ; (r) VADEADSP - VA DEA #
+3 ; (o) HEADER - Print Message Heading
+4 ; Output: RESULT - DEA Number suffix mismatch warning text
+5 NEW RESCNT
SET RESCNT=$ORDER(RESULT(""),-1)
+6 IF $GET(HEADER)!RESCNT
Begin DoDot:1
+7 SET RESULT($ORDER(RESULT(""),-1)+1)="******************************* WARNING(S) *******************************"
End DoDot:1
+8 SET RESULT($ORDER(RESULT(""),-1)+1)="Provider DEA suffix mismatch (eRx: "_ERXPRDEA_" | VistA: "_VADEADSP_")."
+9 QUIT
+10 ;
DEFROUTE(OIIEN) ; Returns the Default Route for Orderable Item
+1 ; Input: OIIEN - Orderable Item IEN - Pointer to PHARMACY ORDERABLE ITEM file (#50.7)
+2 ;Output: DEFROUTE - Default Route (e.g., "ORAL", "TOPICAL", etc..) or "" (No default route found)
+3 IF '$GET(OIIEN)!'$DATA(^PS(50.7,+$GET(OIIEN)))
QUIT ""
+4 NEW DEFROUTE,DFIEN,RTIEN
SET DEFROUTE=""
+5 ; OI uses Possible Med Route(s)
IF $$GET1^DIQ(50.7,OIIEN,10,"I")="N"
Begin DoDot:1
+6 ; No Possible Routes Found
SET RTIEN=$ORDER(^PS(50.7,OIIEN,3,0))
IF 'RTIEN
QUIT
+7 ; More than one Possible Med Route Found
IF $ORDER(^PS(50.7,OIIEN,3,RTIEN))
QUIT
+8 SET DEFROUTE=$$GET1^DIQ(50.711,RTIEN_","_OIIEN,.01)
End DoDot:1
+9 ; OI uses Dosage Form Med Route(s)
IF $$GET1^DIQ(50.7,OIIEN,10,"I")="Y"
Begin DoDot:1
+10 ; No Dosage Form pointer Found
SET DFIEN=$$GET1^DIQ(50.7,OIIEN,.02,"I")
IF 'DFIEN
QUIT
+11 ; No Med Route for Dosage Form Found
SET RTIEN=$ORDER(^PS(50.606,DFIEN,"MR",0))
IF 'RTIEN
QUIT
+12 ; More than one Med Route Found
IF $ORDER(^PS(50.606,DFIEN,"MR",RTIEN))
QUIT
+13 SET DEFROUTE=$$GET1^DIQ(50.6061,RTIEN_","_DFIEN,.01)
End DoDot:1
+14 ;
+15 ; No Route Found above and Orderable Item has a Default Route
+16 IF DEFROUTE=""
IF $$GET1^DIQ(50.7,OIIEN,.06)'=""
QUIT $$GET1^DIQ(50.7,OIIEN,.06)
+17 ; Orderable Item has a Default Route that does not match the one found
+18 IF DEFROUTE'=""
IF $$GET1^DIQ(50.7,OIIEN,.06)'=""
IF DEFROUTE'=$$GET1^DIQ(50.7,OIIEN,.06)
QUIT ""
+19 ;
+20 QUIT DEFROUTE
+21 ;
ERXSIG(ERXIEN) ; Returns the eRx SIG
+1 QUIT $$ERXSIG^PSOERXU8(ERXIEN)
+2 ;
VISTASIG(ERXIEN) ; Returns the VistA SIG, if present
+1 QUIT $$VISTASIG^PSOERXU8(ERXIEN)
+2 ;
RENEWALS(ERXIEN) ; Returns whether Renewals are Prohibited or no
+1 QUIT $$RENEWALS^PSOERXU8(ERXIEN)
