PSOERXUT ;ALB/MR - eRx CS utilities ;7/21/2020 9:57am
;;7.0;OUTPATIENT PHARMACY;**617,667,651,718,700**;DEC 1997;Build 261
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
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
. . S VADEANUM=$$UP^XLFSTR($$DEA^XUSER(0,PROVIEN,RXWRDATE)),VADEADSP=$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)>2,$P(VADEANUM,"^")'=ERXPRDEA D
. . . I ($P(ERXPRDEA,"-")=VADEANUM) S ERXSUFF=1 Q
. . . S RESULT($O(RESULT(""),-1)+1)="Provider DEA mismatch (eRx: "_ERXPRDEA_" | VistA: "_VADEADSP_")."
. . ; VistA Drug Selected (Additional Checks for CS and Detox drugs)
. . I DRUGIEN D
. . . I $$VADRSCH(DRUGIEN)'="" D
. . . . S VACSDRUG=1
. . . . S VADRSCH=$$VADRSCH(DRUGIEN)
. . . . S VADEANUM=$$UP^XLFSTR($$SDEA^XUSER(0,PROVIEN,$P(VADRSCH,"^"),RXWRDATE))
. . . . S VADEADSP=$$DEA^XUSER(0,PROVIEN,RXWRDATE)
. . . . 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."
. . . I $$DETOX^PSSOPKI(DRUGIEN),$$DETOX^XUSER(PROVIEN,RXWRDATE)'?2A7N D
. . . . S VACSDRUG=1
. . . . S RESULT($O(RESULT(""),-1)+1)="VistA Provider "_$$GET1^DIQ(200,PROVIEN,.01)_" does not have a valid DETOX#."
. ; 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),1) 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
. . . S VADEANUM=$$UP^XLFSTR($$SDEA^XUSER(0,PROVIEN,$P(VADRSCH,"^"),RXWRDATE))
. . . S VADEADSP=$$DEA^XUSER(0,PROVIEN,RXWRDATE)
. . . I ERXPRDEA'="",$L($P(VADEADSP,"^",1))>2,(ERXPRDEA["-"),$P(ERXPRDEA,"-")=VADEADSP,'$G(ERXSUFF) D
. . . . S RESULT($O(RESULT(""),-1)+1)="Provider DEA suffix mismatch (eRx: "_ERXPRDEA_" | VistA: "_($G(VADEADSP))
. . . . S RESULT=$S($G(RESULT)="0^B":RESULT,1:"0^W")
. . . 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."
. . . 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."
. . . 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 ("_$P(VADEANUM,"^",2)_")."
. . . I ERXPRDEA'="",$L($P(VADEANUM,"^",1))>2,$P(VADEANUM,"^")'=$P(ERXPRDEA,"-") D
. . . . S RESULT="0^B"
. . . . S RESULT($O(RESULT(""),-1)+1)="Provider DEA mismatch (eRx: "_ERXPRDEA_" | VistA: "_VADEANUM_")."
. . ; 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
I $G(HEADER) 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
; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49)
;Output: ERXSIG - eRx SIG in one string
;
N ERXSIG,SIG,I,S2017,MSGTYPE,RESTYPE,MEDIEN
S ERXSIG=""
I '$D(^PS(52.49,+$G(ERXIEN),0)) Q ERXSIG
S S2017=+$G(^PS(52.49,ERXIEN,312))
S MSGTYPE=$P($G(^PS(52.49,ERXIEN,0)),"^",8)
S RESTYPE=$P($G(^PS(52.49,ERXIEN,52)),"^")
I S2017 D
. I MSGTYPE="CX" S MEDIEN=$O(^PS(52.49,ERXIEN,311,"C","P",0))
. I MSGTYPE="RE",(RESTYPE="R") S MEDIEN=$O(^PS(52.49,ERXIEN,311,"C","MR",0))
. I MSGTYPE="N"!'$G(MEDIEN) S MEDIEN=$O(^PS(52.49,ERXIEN,311,0))
. I '$G(MEDIEN) Q
. F I=1:1 Q:'$D(^PS(52.49,ERXIEN,311,MEDIEN,8,I)) D
. . S ERXSIG=ERXSIG_" "_$G(^PS(52.49,ERXIEN,311,MEDIEN,8,I,0))
I 'S2017 D
. S ERXSIG=$P($G(^PS(52.49,ERXIEN,7)),"^")
Q ERXSIG
;
VISTASIG(ERXIEN) ; Returns the VistA SIG, if present
; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49)
;Output: VISTASIG - VistA SIG in one string
;
N VISTASIG,SIG
S VISTASIG=""
S SIG=0 F S SIG=$O(^PS(52.49,ERXIEN,"SIG",SIG)) Q:'SIG D
. S VISTASIG=VISTASIG_$G(^PS(52.49,ERXIEN,"SIG",SIG,0))
; VA Patient Instructions
I $$GET1^DIQ(52.49,ERXIEN,27)'="" D
. S VISTASIG=VISTASIG_$S($E(VISTASIG,$L(VISTASIG))=" ":"",1:" ")_$$GET1^DIQ(52.49,ERXIEN,27)
Q VISTASIG
;
RENEWALS(ERXIEN) ; Returns whether Renewals are Prohibited or no
; Input: ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49)
;Output: RENEWALS - 1: Renewals are Allowed | 0 - Renewals are Prohibited
N RENEWALS,MTYPE,CHGMESRQ,CHGMESRI,RESPVAL
S RENEWALS=0,MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
S CHGMESRQ=$$GET1^DIQ(52.49,ERXIEN,315.1,"I")
S CHGMESRI=$$GET1^DIQ(52.45,CHGMESRQ,.01,"I")
S RESPVAL=$$GET1^DIQ(52.49,ERXIEN,52.1,"E")
I MTYPE="N"!((MTYPE="CX")&($$PROHIBIT^PSOERX1D(RESPVAL,CHGMESRI))) D
. S RENEWALS=$S($$GET1^DIQ(52.49,ERXIEN,301.3,"I"):0,1:1)
Q RENEWALS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXUT 18266 printed Apr 09, 2024@21:25:48 Page 2
PSOERXUT ;ALB/MR - eRx CS utilities ;7/21/2020 9:57am
+1 ;;7.0;OUTPATIENT PHARMACY;**617,667,651,718,700**;DEC 1997;Build 261
+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
+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 SET VADEANUM=$$UP^XLFSTR($$DEA^XUSER(0,PROVIEN,RXWRDATE))
SET VADEADSP=$PIECE(VADEANUM,"^")
+30 IF VADEANUM=""
Begin DoDot:3
+31 SET RESULT($ORDER(RESULT(""),-1)+1)="VistA Provider does not have a valid DEA# on file."
End DoDot:3
+32 IF ERXPRDEA=""
Begin DoDot:3
+33 SET RESULT($ORDER(RESULT(""),-1)+1)="eRx Provider does not have a valid DEA#."
End DoDot:3
+34 IF ERXPRDEA'=""
IF $LENGTH(VADEANUM)>2
IF $PIECE(VADEANUM,"^")'=ERXPRDEA
Begin DoDot:3
+35 IF ($PIECE(ERXPRDEA,"-")=VADEANUM)
SET ERXSUFF=1
QUIT
+36 SET RESULT($ORDER(RESULT(""),-1)+1)="Provider DEA mismatch (eRx: "_ERXPRDEA_" | VistA: "_VADEADSP_")."
End DoDot:3
+37 ; VistA Drug Selected (Additional Checks for CS and Detox drugs)
+38 IF DRUGIEN
Begin DoDot:3
+39 IF $$VADRSCH(DRUGIEN)'=""
Begin DoDot:4
+40 SET VACSDRUG=1
+41 SET VADRSCH=$$VADRSCH(DRUGIEN)
+42 SET VADEANUM=$$UP^XLFSTR($$SDEA^XUSER(0,PROVIEN,$PIECE(VADRSCH,"^"),RXWRDATE))
+43 SET VADEADSP=$$DEA^XUSER(0,PROVIEN,RXWRDATE)
+44 IF $PIECE(VADEANUM,"^")=2
Begin DoDot:5
+45 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
+46 IF $$DETOX^PSSOPKI(DRUGIEN)
IF $$DETOX^XUSER(PROVIEN,RXWRDATE)'?2A7N
Begin DoDot:4
+47 SET VACSDRUG=1
+48 SET RESULT($ORDER(RESULT(""),-1)+1)="VistA Provider "_$$GET1^DIQ(200,PROVIEN,.01)_" does not have a valid DETOX#."
End DoDot:4
End DoDot:3
End DoDot:2
+49 ; All checks are OK
+50 ; Add DEA Suffix mismatch message
+51 IF $GET(ERXSUFF)
Begin DoDot:2
+52 IF '$ORDER(RESULT(0))
DO SUFFWARN(.RESULT,ERXPRDEA,$SELECT($LENGTH($GET(VADEADSP)):VADEADSP,1:VADEANUM),0)
SET RESULT="0^W"
QUIT
+53 IF ACTION="EP"!(ACTION="VP")
IF 'VACSDRUG
DO SUFFWARN(.RESULT,ERXPRDEA,$SELECT($LENGTH($GET(VADEADSP)):VADEADSP,1:VADEANUM),0)
SET RESULT="0^W"
QUIT
+54 IF ACTION="EP"
DO SUFFWARN(.RESULT,ERXPRDEA,$SELECT($LENGTH($GET(VADEADSP)):VADEADSP,1:VADEANUM),0)
SET RESULT="0^W"
QUIT
+55 IF ACTION="VP"!(ACTION="AC")
DO SUFFWARN(.RESULT,ERXPRDEA,$SELECT($LENGTH($GET(VADEADSP)):VADEADSP,1:VADEANUM),1)
SET RESULT="0^B"
QUIT
End DoDot:2
QUIT
+56 IF '$ORDER(RESULT(0))
SET RESULT=1
QUIT
+57 ; VistA Drug is not Selected or it is not a CS Drug
+58 IF ACTION="EP"!(ACTION="VP")!(ACTION="AC")
IF 'VACSDRUG
Begin DoDot:2
+59 SET RESULT="0^W"
End DoDot:2
QUIT
+60 ; Editing Provider, VistA Drug is CS or Detox, Warning (soft stop)
+61 IF ACTION="EP"
Begin DoDot:2
+62 SET RESULT="0^W"
End DoDot:2
QUIT
+63 ; Validating Provider/Accept eRx, VistA Drug is CS or Detox, Block (hard stop)
+64 IF ACTION="VP"!(ACTION="AC")
Begin DoDot:2
+65 SET RESULT="0^B"
End DoDot:2
QUIT
End DoDot:1
QUIT
+66 ;
+67 ; Edit/Validate Drug & Accept eRx Checks
+68 IF (ACTION="ED")!(ACTION="VD")!(ACTION="AC")
Begin DoDot:1
+69 SET VADRSCH=$$VADRSCH(DRUGIEN)
IF VADRSCH'=""
SET VACSDRUG=1
+70 IF DSERXFLG
IF 'VACSDRUG
IF ACTION'="AC"
Begin DoDot:2
+71 SET RESULT="0^W"
+72 IF ERXDRSCH=""
Begin DoDot:3
+73 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
+74 IF '$TEST
Begin DoDot:3
+75 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
+76 IF 'DSERXFLG
IF VACSDRUG
Begin DoDot:2
+77 SET RESULT="0^B"
+78 IF $PIECE(VADRSCH,"^",2)="L"
Begin DoDot:3
+79 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
+80 IF '$TEST
Begin DoDot:3
+81 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
+82 IF VACSDRUG
IF ERXPRDEA=""
Begin DoDot:2
+83 SET RESULT="0^B"
+84 SET RESULT($ORDER(RESULT(""),-1)+1)="eRx Provider does not have a valid DEA#."
End DoDot:2
+85 ; VistA Provider Selected (Additional Checks)
+86 IF PROVIEN
Begin DoDot:2
+87 ; CS VistA Drug
+88 IF VACSDRUG
Begin DoDot:3
+89 SET VADEANUM=$$UP^XLFSTR($$SDEA^XUSER(0,PROVIEN,$PIECE(VADRSCH,"^"),RXWRDATE))
+90 SET VADEADSP=$$DEA^XUSER(0,PROVIEN,RXWRDATE)
+91 IF ERXPRDEA'=""
IF $LENGTH($PIECE(VADEADSP,"^",1))>2
IF (ERXPRDEA["-")
IF $PIECE(ERXPRDEA,"-")=VADEADSP
IF '$GET(ERXSUFF)
Begin DoDot:4
+92 SET RESULT($ORDER(RESULT(""),-1)+1)="Provider DEA suffix mismatch (eRx: "_ERXPRDEA_" | VistA: "_($GET(VADEADSP))
+93 SET RESULT=$SELECT($GET(RESULT)="0^B":RESULT,1:"0^W")
End DoDot:4
+94 IF $PIECE(VADEANUM,"^")=1
Begin DoDot:4
+95 SET RESULT="0^B"
+96 SET RESULT($ORDER(RESULT(""),-1)+1)="VistA Provider "_$$GET1^DIQ(200,PROVIEN,.01)_" does not have a valid DEA# on file."
End DoDot:4
QUIT
+97 IF $PIECE(VADEANUM,"^")=2
Begin DoDot:4
+98 SET RESULT="0^"_$SELECT(ACTION="ED"&($PIECE($GET(RESULT),"^",2)'="B"):"W",1:"B")
+99 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:4
QUIT
+100 IF $PIECE(VADEANUM,"^")=4
Begin DoDot:4
+101 SET RESULT="0^"_$SELECT(ACTION="ED"&($PIECE($GET(RESULT),"^",2)'="B"):"W",1:"B")
+102 SET RESULT($ORDER(RESULT(""),-1)+1)="eRx Written Date/Issue Date is after the VistA Provider DEA expiration date ("_$PIECE(VADEANUM,"^",2)_")."
End DoDot:4
QUIT
+103 IF ERXPRDEA'=""
IF $LENGTH($PIECE(VADEANUM,"^",1))>2
IF $PIECE(VADEANUM,"^")'=$PIECE(ERXPRDEA,"-")
Begin DoDot:4
+104 SET RESULT="0^B"
+105 SET RESULT($ORDER(RESULT(""),-1)+1)="Provider DEA mismatch (eRx: "_ERXPRDEA_" | VistA: "_VADEANUM_")."
End DoDot:4
End DoDot:3
+106 ; Detox VistA Drug
+107 IF $$DETOX^PSSOPKI(DRUGIEN)
IF $$DETOX^XUSER(PROVIEN,RXWRDATE)'?1"X"1A7N
Begin DoDot:3
+108 SET RESULT="0^"_$SELECT(ACTION="ED"&($PIECE($GET(RESULT),"^",2)'="B"):"W",1:"B")
+109 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
+110 ;
+111 QUIT
+112 ;
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 IF $GET(HEADER)
Begin DoDot:1
+6 SET RESULT($ORDER(RESULT(""),-1)+1)="******************************* WARNING(S) *******************************"
End DoDot:1
+7 SET RESULT($ORDER(RESULT(""),-1)+1)="Provider DEA suffix mismatch (eRx: "_ERXPRDEA_" | VistA: "_VADEADSP_")."
+8 QUIT
+9 ;
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 ; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49)
+2 ;Output: ERXSIG - eRx SIG in one string
+3 ;
+4 NEW ERXSIG,SIG,I,S2017,MSGTYPE,RESTYPE,MEDIEN
+5 SET ERXSIG=""
+6 IF '$DATA(^PS(52.49,+$GET(ERXIEN),0))
QUIT ERXSIG
+7 SET S2017=+$GET(^PS(52.49,ERXIEN,312))
+8 SET MSGTYPE=$PIECE($GET(^PS(52.49,ERXIEN,0)),"^",8)
+9 SET RESTYPE=$PIECE($GET(^PS(52.49,ERXIEN,52)),"^")
+10 IF S2017
Begin DoDot:1
+11 IF MSGTYPE="CX"
SET MEDIEN=$ORDER(^PS(52.49,ERXIEN,311,"C","P",0))
+12 IF MSGTYPE="RE"
IF (RESTYPE="R")
SET MEDIEN=$ORDER(^PS(52.49,ERXIEN,311,"C","MR",0))
+13 IF MSGTYPE="N"!'$GET(MEDIEN)
SET MEDIEN=$ORDER(^PS(52.49,ERXIEN,311,0))
+14 IF '$GET(MEDIEN)
QUIT
+15 FOR I=1:1
if '$DATA(^PS(52.49,ERXIEN,311,MEDIEN,8,I))
QUIT
Begin DoDot:2
+16 SET ERXSIG=ERXSIG_" "_$GET(^PS(52.49,ERXIEN,311,MEDIEN,8,I,0))
End DoDot:2
End DoDot:1
+17 IF 'S2017
Begin DoDot:1
+18 SET ERXSIG=$PIECE($GET(^PS(52.49,ERXIEN,7)),"^")
End DoDot:1
+19 QUIT ERXSIG
+20 ;
VISTASIG(ERXIEN) ; Returns the VistA SIG, if present
+1 ; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49)
+2 ;Output: VISTASIG - VistA SIG in one string
+3 ;
+4 NEW VISTASIG,SIG
+5 SET VISTASIG=""
+6 SET SIG=0
FOR
SET SIG=$ORDER(^PS(52.49,ERXIEN,"SIG",SIG))
if 'SIG
QUIT
Begin DoDot:1
+7 SET VISTASIG=VISTASIG_$GET(^PS(52.49,ERXIEN,"SIG",SIG,0))
End DoDot:1
+8 ; VA Patient Instructions
+9 IF $$GET1^DIQ(52.49,ERXIEN,27)'=""
Begin DoDot:1
+10 SET VISTASIG=VISTASIG_$SELECT($EXTRACT(VISTASIG,$LENGTH(VISTASIG))=" ":"",1:" ")_$$GET1^DIQ(52.49,ERXIEN,27)
End DoDot:1
+11 QUIT VISTASIG
+12 ;
RENEWALS(ERXIEN) ; Returns whether Renewals are Prohibited or no
+1 ; Input: ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49)
+2 ;Output: RENEWALS - 1: Renewals are Allowed | 0 - Renewals are Prohibited
+3 NEW RENEWALS,MTYPE,CHGMESRQ,CHGMESRI,RESPVAL
+4 SET RENEWALS=0
SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+5 SET CHGMESRQ=$$GET1^DIQ(52.49,ERXIEN,315.1,"I")
+6 SET CHGMESRI=$$GET1^DIQ(52.45,CHGMESRQ,.01,"I")
+7 SET RESPVAL=$$GET1^DIQ(52.49,ERXIEN,52.1,"E")
+8 IF MTYPE="N"!((MTYPE="CX")&($$PROHIBIT^PSOERX1D(RESPVAL,CHGMESRI)))
Begin DoDot:1
+9 SET RENEWALS=$SELECT($$GET1^DIQ(52.49,ERXIEN,301.3,"I"):0,1:1)
End DoDot:1
+10 QUIT RENEWALS
