PSOERXI1 ;ALB/BWF - eRx Utilities/RPC's ; 12/10/22 11:24am
;;7.0;OUTPATIENT PHARMACY;**581,617,692,706,700,743,746,783,770**;DEC 1997;Build 145
;
;Reference to MAKEADD^TIUSRVP2 in ICR #4795
Q
; File incoming XML into appropriate file
; XML - xml text
; PRCHK - provider check information
; PACHK - patient check information
; DACHK - drug auto check
; STATION - station #
; DIV - institution name^NPI
; ERXHID - eRx processing hub id^CANCEL/CHANGE REQUEST DENIED BY HUB (1=YES)^relates to hub ID
; ERXVALS - code values for NIST codes (potency unit code^form code^strength code^prohibit renewals - change response (y/n))
; XML2 - structured sig from the medication prescribed segment
; VADAT - DUZ^RXIEN
; XML3 - third stream of XML
INCERX(RES,XML,PRCHK,PACHK,DACHK,STATION,DIV,ERXHID,ERXVALS,XML2,VADAT,XML3) ;
N MBMSITE,CURREC,FDA,EIEN,ERRTXT,ERRSEQ,PACNT,PASCNT,PAICN,PAIEN,VAINST,NPI,VAOI,VPATINST,PRVAUTOV,VISTARX,VADRUG,DFN,ERXNDC
; This error handling prevents delays at the eRx Hub because it always returns a result
N $ESTACK,$ETRAP S $ETRAP="D ERROR^PSOERXI1"
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
S NPI=$P($G(DIV),U,2),CURREC=$$PARSE^PSOERXI2(.XML,.ERXVALS,NPI,.XML2,.XML3)
I $P(CURREC,U)<1 D Q
. I $L($P(CURREC,U,2)) S RES=CURREC Q
. S RES="0^XML received. Error creating or finding associated record in the ERX Holding queue." Q
S EIEN=CURREC
S CURREC=CURREC_","
;If this is an outbound message, file the users DUZ and quit back the response. No drug, patient, or provider auto checks will occur
I $G(VADAT)]"" D Q
. I $P($G(VADAT),U)>1 D
. . S FDA(52.49,CURREC,51.1)=DUZ D FILE^DIE(,"FDA") K FDA
. I $P(VADAT,U,2) D
. . S FDA(52.49,CURREC,.13)=$P(VADAT,U,2) D FILE^DIE(,"FDA") K FDA
. S RES="1^Erx Received."
;Process auto-validation results. Only log positive results for now
K FDA
I $P($G(VADAT),U) S RES="1^Message Filed." Q
;
;Drug Auto-Match (Moved from Hub to VistA - P-692)
;Attempting auto-match based on VistA Drug Suggestions (Uses the lastest one)
N DRUGHASH,MTCHDRUG
S MTCHDRUG=$$MTCHDRUG(),DRUGHASH=$$DRUGHASH^PSOERUT(+CURREC)
I MTCHDRUG,DRUGHASH D
. I $$GET1^DIQ(52.49,CURREC,.08,"I")="RE",$$GET1^DIQ(52.49,CURREC,52.1,"I")'="R" Q
. I $$GET1^DIQ(52.49,CURREC,.08,"I")="CX",$$GET1^DIQ(52.49,CURREC,52.1,"I")'="A",$$GET1^DIQ(52.49,CURREC,52.1,"I")'="AWC" Q
. S ERXNDC=$TR($TR($$GET1^DIQ(52.49311,"1,"_CURREC_",",1.1,"I")," "),"-")
. S VISTARX="" F S VISTARX=$O(^PS(52.49,"ADRGVRX",DRUGHASH,VISTARX),-1) Q:'VISTARX D I $$GET1^DIQ(52.49,+CURREC,3.2,"I") Q
. . S VADRUG=+$$GET1^DIQ(52,VISTARX,6,"I") I 'VADRUG Q
. . I $$GET1^DIQ(50,VADRUG,100,"I") D Q
. . . K ^PS(52.49,"ADRGVRX",DRUGHASH,VISTARX)
. . ; For pre-populating all drug fields, the incoming NDC/Name should match VistA DRUG/NDF files
. . I VADRUG'=MTCHDRUG Q
. . D SAVEDRUG^PSOERUT2(+CURREC,VISTARX)
. . I $$GET1^DIQ(52.49,+CURREC,3.2,"I") D
. . . K DACHK S DACHK("success")="true",FDA(52.49,CURREC,1.4)=1
;Auto-matching the Dispense Drug only
I '$$GET1^DIQ(52.49,+CURREC,3.2,"I"),+$G(MTCHDRUG) D
. K DACHK S DACHK("success")="true"
.;Saving the eRx Audit Log For Auto-Matched Drug
. S NEWVAL(1)=$$GET1^DIQ(50,MTCHDRUG,.01)_" (NDC#: "_$$GETNDC^PSSNDCUT(MTCHDRUG)_")"
. D AUDLOG^PSOERXUT(+CURREC,"DRUG",$$PROXYDUZ^PSOERXUT(),.NEWVAL)
.;Setting Matched Drug and Auto Match info
. S FDA(52.49,CURREC,3.2)=MTCHDRUG
. S FDA(52.49,CURREC,44)=1
. S VAOI=$$GET1^DIQ(50,MTCHDRUG,2.1,"I")
. S VPATINST=$$GET1^DIQ(50.7,VAOI,7,"E")
. I $L(VPATINST) D
. . S (NEWVAL(1),FDA(52.49,CURREC,27))=VPATINST
. . D AUDLOG^PSOERXUT(+CURREC,"PATIENT INSTRUCTIONS",$$PROXYDUZ^PSOERXUT(),.NEWVAL)
. ; Adjusting the # of refills field if over the maximum allowed
. I $$GET1^DIQ(52.49,+CURREC,20.5)>$$MAXNUMRF^PSOUTIL(MTCHDRUG,$$GET1^DIQ(52.49,+CURREC,20.2)) D
. . S FDA(52.49,+CURREC_",",20.5)=$$MAXNUMRF^PSOUTIL(MTCHDRUG,$$GET1^DIQ(52.49,+CURREC,20.2))
;
I $G(DACHK("success"))'="true" D
. S ERRTXT=$G(DACHK("error"))
. S ERRSEQ=$$ERRSEQ^PSOERXU1(EIEN) Q:'ERRSEQ
. D FILERR^PSOERXU1(CURREC,ERRSEQ,"D","E",ERRTXT)
;
;Provider Auto-Match (Moved from Hub to VistA - P-692)
I $G(PRCHK("success"))="false" D
. N TMP,MSGTYPE,MTCHPROV,TMP,NPI,DEA,CS
. S MSGTYPE=$O(^TMP($J,"PSOERXO1","Message",0,"Body",0,"")) I MSGTYPE="" Q
. S DEA=$G(^TMP($J,"PSOERXO1","Message",0,"Body",0,MSGTYPE,0,"Prescriber",0,"NonVeterinarian",0,"Identification",0,"DEANumber",0))
. S NPI=$G(^TMP($J,"PSOERXO1","Message",0,"Body",0,MSGTYPE,0,"Prescriber",0,"NonVeterinarian",0,"Identification",0,"NPI",0))
. S CS=($G(^TMP($J,"PSOERXO1","Message",0,"Header",0,"DigitalSignature",0,"SignatureValue",0))'="")
. D PRVMTCH^PSOERXA0(.MTCHPROV,NPI,DEA,CS)
. I +$G(MTCHPROV) D
. . K PRCHK S PRCHK("success")="true",PRCHK("IEN")=+MTCHPROV
;Attempting auto-match based on VistA Provider Suggestions (Uses the lastest one)
I '$G(PRCHK("IEN")) D
. N EPRV,VPRV,SUGVPRV,MTCHDT S EPRV=+$$GET1^DIQ(52.49,+CURREC,2.1,"I"),(VPRV,SUGVPRV,MTCHDT)=0
. F S VPRV=$O(^PS(52.49,"APRVVPRV",EPRV,VPRV)) Q:'VPRV D
. . I $$GET1^DIQ(200,VPRV,53.4,"I") K ^PS(52.49,"APRVVPRV",EPRV,VPRV) Q ; VistA Provider is Inactive
. . I $O(^PS(52.49,"APRVVPRV",EPRV,VPRV,""),-1)>MTCHDT D
. . . S SUGVPRV=VPRV,MTCHDT=$O(^PS(52.49,"APRVVPRV",EPRV,VPRV,""),-1)
. I SUGVPRV D
. . K PRCHK S PRCHK("success")="true",FDA(52.49,CURREC,1.2)=1,(FDA(52.49,CURREC,2.3),PRCHK("IEN"))=SUGVPRV
;Auto-Validating Provider
S PRVAUTOV=0
I $G(PRCHK("success"))="true",$G(PRCHK("IEN")) D
. S FDA(52.49,CURREC,1.2)=1
. S FDA(52.49,CURREC,2.3)=PRCHK("IEN")
. ;Auto-Validating Provider if auto-match was successful
. ;Condition: Non-CS eRx only & Last name, first letter of first name and zip code 5 digits must match
. N EPRVIEN,EPRVNAM,EPRVZC,EPRVDEA,VPRVIEN,VPRVNAM,VPRVZC
. S EPRVIEN=$$GET1^DIQ(52.49,+CURREC,2.1,"I")
. S EPRVNAM=$$UP^XLFSTR($TR($$GET1^DIQ(52.48,EPRVIEN,.01)," "))
. S EPRVZC=$P($$GET1^DIQ(52.48,EPRVIEN,4.5),"-")
. S EPRVDEA=$$UP^XLFSTR($$GET1^DIQ(52.48,EPRVIEN,1.6))
. S VPRVIEN=PRCHK("IEN") I '$$CHKPRV2^PSOERX1A(VPRVIEN) Q
. S VPRVNAM=$$UP^XLFSTR($TR($$GET1^DIQ(200,VPRVIEN,.01)," "))
. S VPRVZC=$P($$GET1^DIQ(200,VPRVIEN,.116),"-")
. I $E(EPRVNAM,1,$F(EPRVNAM,","))'=$E(VPRVNAM,1,$F(VPRVNAM,",")) Q
. I $E(EPRVZC,1,5)'=$E(VPRVZC,1,5) Q
. I $$GET1^DIQ(52.49,+CURREC,95.1,"I"),'$$DEAFOUND^PSOERXU8(EPRVDEA,VPRVIEN) Q
. S FDA(52.49,CURREC,1.3)=1
. S FDA(52.49,CURREC,1.8)=$$PROXYDUZ^PSOERXUT()
. S FDA(52.49,CURREC,1.9)=$$NOW^XLFDT()
. S FDA(52.49,CURREC,2.7)=1
. S PRVAUTOV=1
I $G(PRCHK("success"))="true",$G(PRCHK("IEN")) D
. ;Saving the eRx Audit Log for the Auto-Matched Provider
. S NEWVAL(1)=$$GET1^DIQ(200,PRCHK("IEN"),.01)_" (DEA#: "_$P($$VADEA^PSOERXU8(PRCHK("IEN"),+CURREC),"^",2)_")"_$S($G(PRVAUTOV):" - AUTO-VALIDATED",1:"")
. D AUDLOG^PSOERXUT(+CURREC,"PROVIDER",$$PROXYDUZ^PSOERXUT(),.NEWVAL)
;
I $G(PRCHK("success"))="false" D
. S ERRTXT=$G(PRCHK("error"))
. S ERRSEQ=$$ERRSEQ^PSOERXU1(EIEN) Q:'ERRSEQ
. D FILERR^PSOERXU1(CURREC,ERRSEQ,"PR","E",ERRTXT)
;
I $G(PACHK("MVIerror"))']"" D
. S PAICN=+$P($G(PACHK("ICN")),"V")
. I PAICN D
. . S (PAIEN,PACNT)=0 F S PAIEN=$O(^DPT("AICN",PAICN,PAIEN)) Q:'PAIEN D
. . . S PACNT=PACNT+1
. . . ;revisit in future build - if we find more than one match in the local system, do we log some sort of an error?
. I $G(PACNT)=1 D Q
. . S FDA(52.49,CURREC,1.6)=1
. . S FDA(52.49,CURREC,.05)=$O(^DPT("AICN",PAICN,0))
. I $L(PACHK("ssn")) D
. . S (PASCNT,PAIEN)=0 F S PAIEN=$O(^DPT("SSN",$TR(PACHK("ssn"),"-",""),PAIEN)) Q:'PAIEN D
. . . S PASCNT=PASCNT+1
. I $G(PASCNT)=1 D Q
. . S FDA(52.49,CURREC,1.6)=1
. . S FDA(52.49,CURREC,.05)=$O(^DPT("SSN",$TR(PACHK("ssn"),"-",""),0))
;Attempting auto-match based on VistA Patient Suggestions (Uses the lastest one)
I '$G(FDA(52.49,CURREC,.05)) D
. N EPAT,VPAT,SUGVPAT,MTCHDT S EPAT=+$$GET1^DIQ(52.49,+CURREC,.04,"I"),(VPAT,SUGVPAT,MTCHDT)=0
. F S VPAT=$O(^PS(52.49,"APATVPAT",EPAT,VPAT)) Q:'VPAT D
. . I $O(^PS(52.49,"APATVPAT",EPAT,VPAT,""),-1)>MTCHDT D
. . . S SUGVPAT=VPAT,MTCHDT=$O(^PS(52.49,"APATVPAT",EPAT,VPAT,""),-1)
. I SUGVPAT S FDA(52.49,CURREC,1.6)=1,FDA(52.49,CURREC,.05)=SUGVPAT
;
;Saving the eRx Audit Log For Auto-Matched Patient
S DFN=+$G(FDA(52.49,CURREC,.05))
I DFN D
. N VADM D DEM^VADPT
. S NEWVAL(1)=$$GET1^DIQ(2,DFN,.01)_" (L4SSN: "_$P($P(VADM(2),"^",2),"-",3)_" | DOB: "_$P(VADM(3),"^",2)_")"
. D AUDLOG^PSOERXUT(+CURREC,"PATIENT",$$PROXYDUZ^PSOERXUT(),.NEWVAL)
;
I $D(FDA) D FILE^DIE(,"FDA") K FDA
;
; Auto-holds for MbM
I $G(MBMSITE),DFN D
. I ",N,I,W,RXI,RXN,RXW,RXR,CXI,CXN,CXW,"'[(","_$$GET1^DIQ(52.49,CURREC,1,"I")_",") Q
. I '$$CHVAELIG^PSOERXU9(DFN) D Q
. . D UPDSTAT^PSOERXU1(CURREC,"HEL","Hold due to Eligibility Issue")
. N GMRA,GMRAL
. S GMRA="0^0^111" D EN1^GMRADPT I $G(GMRAL)'="" Q
. D UPDSTAT^PSOERXU1(CURREC,"HAL","Hold for Allergy Assessment")
;
I $G(PACHK("success"))="false" D
.; file e&e error
. S ERRTXT=$G(PACHK("EandEerror")) I ERRTXT]"" D
. . S ERRSEQ=$$ERRSEQ^PSOERXU1(EIEN) Q:'ERRSEQ
. . D FILERR^PSOERXU1(CURREC,ERRSEQ,"PA","E",ERRTXT)
.; file mvi error
. S ERRTXT=$G(PACHK("MVIerror")) I ERRTXT]"" D
. . S ERRSEQ=$$ERRSEQ^PSOERXU1(EIEN) Q:'ERRSEQ
. . D FILERR^PSOERXU1(CURREC,ERRSEQ,"PA","E",ERRTXT)
;
S RES="1^Erx Received."
;
;Create an Addendum for eRx Change Response Progress Note
I $G(EIEN)'="",$$GET1^DIQ(52.49,EIEN,.08,"I")="CX" D CREATEADD(ERXHID,EIEN)
Q
;
CREATEADD(ERXHID,EIEN) ;Create CPRS Progress Notes Addendum for this eRx Change Response
;Input: ERXHID - eRx processing hub id^CANCEL/CHANGE REQUEST DENIED BY HUB (1=YES)^relates to hub ID
; EIEN - The eRx Change Response IEN, Pointer to ERX HOLDING QUEUE file (#52.49)
;Output: Create an Addendum and attach it to the parent eRx Change Request
;
I ($G(ERXHID)="")!($G(EIEN)="") Q
N CNT,CRERXIEN,ORGERXIEN,ERXDRUG,CRMEDS,CNT,CXTARGET,ERXDRUG,PSOTIUIEN,TIUDADD,ERXTIUX
;
S CRERXIEN=$O(^PS(52.49,"B",$P(ERXHID,"^",3),0))
S ORGERXIEN=$P($G(^PS(52.49,CRERXIEN,0)),"^",14)
S ORGERXIEN=$O(^PS(52.49,"B",ORGERXIEN,0))
;
;get the parent reference IEN TIU Document
S PSOTIUIEN=$$GET1^DIQ(52.49,CRERXIEN,320.1)
I '$G(PSOTIUIEN) D Q
. N TIUTITLE S TIUTITLE="PHARMACY ERX RX CHANGE REQUEST NOTE"
. I '+$$FIND1^DIC(8925.1,"","X",TIUTITLE,"B") S TIUTITLE="ERX RX CHANGE REQUEST NOTE"
. D BLDCRMEDS(ERXHID,+$G(MTCHDRUG),TIUTITLE)
;
S CXTARGET=$NA(^TMP("TIUP",$J)) K @CXTARGET
D BUILDLST^PSOERSE4(CXTARGET,EIEN)
Q:'$D(@CXTARGET)
K ERXTIUX M ERXTIUX("TEXT")=@CXTARGET
D MAKEADD^TIUSRVP2(.TIUDADD,PSOTIUIEN,.ERXTIUX) ;PSOTIUIEN is the parent IEN from The TIU Document Definition name in File #8925.1
D UPDATEPN^PSOERX1H(.TIUDADD,$G(ORGERXIEN)) ;TIUDADD is the Addendum IEN
Q
;
BLDCRMEDS(ERXHID,VDRUG,TIUTITLE) ;Build eRx Change Response Medication array
;get the original eRx
Q:$G(ERXHID)=""
N CRERXIEN,ORGERXIEN,ERXDRUG,CRMEDS
;
S CRERXIEN=$O(^PS(52.49,"B",$P(ERXHID,"^",3),0))
S ORGERXIEN=$P($G(^PS(52.49,CRERXIEN,0)),"^",14)
S ORGERXIEN=$O(^PS(52.49,"B",ORGERXIEN,0))
S CNT=0
I $G(VDRUG) D
. S ERXDRUG=$$GET1^DIQ(50,$G(VDRUG),.01)
. S CNT=CNT+1,CRMEDS(CNT)="^"_ERXDRUG
;
D CREATEPN^PSOERX1H(ORGERXIEN,EIEN,,.CRMEDS,TIUTITLE) ;create eRx Change Response PN
;
Q
; VAL - value to resolve
; TYPE - This is the code type, which will tell which 'C' index type to get the code from
PRESOLV(VAL,TYPE) ;
N MATCH
S MATCH=""
Q:'$L(TYPE)!('$L(VAL)) "" ; avoid null subscript
S MATCH=$O(^PS(52.45,"C",TYPE,VAL,0))
; return the match found, null if no match
Q MATCH
CONVDTTM(VAL) ;
N EDATE,ETIME,X,ETZ,Y,%DT,%
I '$L(VAL) Q ""
S EDATE=$P(VAL,"T"),ETIME=$P(VAL,"T",2)
; split off time zone
S ETZ=$P(ETIME,".",2)
S ETIME=$P(ETIME,".")
S X=EDATE D ^%DT I 'Y Q ""
S VAL=Y_$S($L(ETIME):"."_$TR(ETIME,":",""),1:"")
Q VAL
;
MTCHDRUG() ; Returns the Matched Dispensed Drug based on the NDF files
;Output: MTCHDRUG - VistA Dispense Drug associated with the Name/NDC from outside (Pointer to file #50)
N MSGTYPE,MEDSEG,MTCHDRUG,PRDCODE,PRDCOQL,DRGNAME
S MTCHDRUG=0
S MSGTYPE=$O(^TMP($J,"PSOERXO1","Message",0,"Body",0,"")) I MSGTYPE="" Q 0
S MEDSEG="MedicationPrescribed"
I '$D(^TMP($J,"PSOERXO1","Message",0,"Body",0,MSGTYPE,0,MEDSEG)) D
. S MEDSEG="MedicationResponse"
S PRDCODE=$G(^TMP($J,"PSOERXO1","Message",0,"Body",0,MSGTYPE,0,MEDSEG,0,"DrugCoded",0,"ProductCode",0,"Code",0)) I PRDCODE="" Q 0
S PRDCOQL=$E($G(^TMP($J,"PSOERXO1","Message",0,"Body",0,MSGTYPE,0,MEDSEG,0,"DrugCoded",0,"ProductCode",0,"Qualifier",0)),1)
I PRDCOQL'="N",PRDCOQL'="U" Q 0
S DRGNAME=$G(^TMP($J,"PSOERXO1","Message",0,"Body",0,MSGTYPE,0,MEDSEG,0,"DrugDescription",0))
D DRGMTCH^PSOERXA0(.MTCHDRUG,PRDCOQL_"^"_PRDCODE,DRGNAME)
Q +$G(MTCHDRUG)
;
ERROR ; Error Handling
D ^%ZTER
S RES="1^eRx received but there was an error. See error trap at "_$P($TR($$SITE^VASITE(),"^","-"),"-",1,2) Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXI1 13097 printed Aug 26, 2025@22:44:39 Page 2
PSOERXI1 ;ALB/BWF - eRx Utilities/RPC's ; 12/10/22 11:24am
+1 ;;7.0;OUTPATIENT PHARMACY;**581,617,692,706,700,743,746,783,770**;DEC 1997;Build 145
+2 ;
+3 ;Reference to MAKEADD^TIUSRVP2 in ICR #4795
+4 QUIT
+5 ; File incoming XML into appropriate file
+6 ; XML - xml text
+7 ; PRCHK - provider check information
+8 ; PACHK - patient check information
+9 ; DACHK - drug auto check
+10 ; STATION - station #
+11 ; DIV - institution name^NPI
+12 ; ERXHID - eRx processing hub id^CANCEL/CHANGE REQUEST DENIED BY HUB (1=YES)^relates to hub ID
+13 ; ERXVALS - code values for NIST codes (potency unit code^form code^strength code^prohibit renewals - change response (y/n))
+14 ; XML2 - structured sig from the medication prescribed segment
+15 ; VADAT - DUZ^RXIEN
+16 ; XML3 - third stream of XML
INCERX(RES,XML,PRCHK,PACHK,DACHK,STATION,DIV,ERXHID,ERXVALS,XML2,VADAT,XML3) ;
+1 NEW MBMSITE,CURREC,FDA,EIEN,ERRTXT,ERRSEQ,PACNT,PASCNT,PAICN,PAIEN,VAINST,NPI,VAOI,VPATINST,PRVAUTOV,VISTARX,VADRUG,DFN,ERXNDC
+2 ; This error handling prevents delays at the eRx Hub because it always returns a result
+3 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERROR^PSOERXI1"
+4 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+5 SET NPI=$PIECE($GET(DIV),U,2)
SET CURREC=$$PARSE^PSOERXI2(.XML,.ERXVALS,NPI,.XML2,.XML3)
+6 IF $PIECE(CURREC,U)<1
Begin DoDot:1
+7 IF $LENGTH($PIECE(CURREC,U,2))
SET RES=CURREC
QUIT
+8 SET RES="0^XML received. Error creating or finding associated record in the ERX Holding queue."
QUIT
End DoDot:1
QUIT
+9 SET EIEN=CURREC
+10 SET CURREC=CURREC_","
+11 ;If this is an outbound message, file the users DUZ and quit back the response. No drug, patient, or provider auto checks will occur
+12 IF $GET(VADAT)]""
Begin DoDot:1
+13 IF $PIECE($GET(VADAT),U)>1
Begin DoDot:2
+14 SET FDA(52.49,CURREC,51.1)=DUZ
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:2
+15 IF $PIECE(VADAT,U,2)
Begin DoDot:2
+16 SET FDA(52.49,CURREC,.13)=$PIECE(VADAT,U,2)
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:2
+17 SET RES="1^Erx Received."
End DoDot:1
QUIT
+18 ;Process auto-validation results. Only log positive results for now
+19 KILL FDA
+20 IF $PIECE($GET(VADAT),U)
SET RES="1^Message Filed."
QUIT
+21 ;
+22 ;Drug Auto-Match (Moved from Hub to VistA - P-692)
+23 ;Attempting auto-match based on VistA Drug Suggestions (Uses the lastest one)
+24 NEW DRUGHASH,MTCHDRUG
+25 SET MTCHDRUG=$$MTCHDRUG()
SET DRUGHASH=$$DRUGHASH^PSOERUT(+CURREC)
+26 IF MTCHDRUG
IF DRUGHASH
Begin DoDot:1
+27 IF $$GET1^DIQ(52.49,CURREC,.08,"I")="RE"
IF $$GET1^DIQ(52.49,CURREC,52.1,"I")'="R"
QUIT
+28 IF $$GET1^DIQ(52.49,CURREC,.08,"I")="CX"
IF $$GET1^DIQ(52.49,CURREC,52.1,"I")'="A"
IF $$GET1^DIQ(52.49,CURREC,52.1,"I")'="AWC"
QUIT
+29 SET ERXNDC=$TRANSLATE($TRANSLATE($$GET1^DIQ(52.49311,"1,"_CURREC_",",1.1,"I")," "),"-")
+30 SET VISTARX=""
FOR
SET VISTARX=$ORDER(^PS(52.49,"ADRGVRX",DRUGHASH,VISTARX),-1)
if 'VISTARX
QUIT
Begin DoDot:2
+31 SET VADRUG=+$$GET1^DIQ(52,VISTARX,6,"I")
IF 'VADRUG
QUIT
+32 IF $$GET1^DIQ(50,VADRUG,100,"I")
Begin DoDot:3
+33 KILL ^PS(52.49,"ADRGVRX",DRUGHASH,VISTARX)
End DoDot:3
QUIT
+34 ; For pre-populating all drug fields, the incoming NDC/Name should match VistA DRUG/NDF files
+35 IF VADRUG'=MTCHDRUG
QUIT
+36 DO SAVEDRUG^PSOERUT2(+CURREC,VISTARX)
+37 IF $$GET1^DIQ(52.49,+CURREC,3.2,"I")
Begin DoDot:3
+38 KILL DACHK
SET DACHK("success")="true"
SET FDA(52.49,CURREC,1.4)=1
End DoDot:3
End DoDot:2
IF $$GET1^DIQ(52.49,+CURREC,3.2,"I")
QUIT
End DoDot:1
+39 ;Auto-matching the Dispense Drug only
+40 IF '$$GET1^DIQ(52.49,+CURREC,3.2,"I")
IF +$GET(MTCHDRUG)
Begin DoDot:1
+41 KILL DACHK
SET DACHK("success")="true"
+42 ;Saving the eRx Audit Log For Auto-Matched Drug
+43 SET NEWVAL(1)=$$GET1^DIQ(50,MTCHDRUG,.01)_" (NDC#: "_$$GETNDC^PSSNDCUT(MTCHDRUG)_")"
+44 DO AUDLOG^PSOERXUT(+CURREC,"DRUG",$$PROXYDUZ^PSOERXUT(),.NEWVAL)
+45 ;Setting Matched Drug and Auto Match info
+46 SET FDA(52.49,CURREC,3.2)=MTCHDRUG
+47 SET FDA(52.49,CURREC,44)=1
+48 SET VAOI=$$GET1^DIQ(50,MTCHDRUG,2.1,"I")
+49 SET VPATINST=$$GET1^DIQ(50.7,VAOI,7,"E")
+50 IF $LENGTH(VPATINST)
Begin DoDot:2
+51 SET (NEWVAL(1),FDA(52.49,CURREC,27))=VPATINST
+52 DO AUDLOG^PSOERXUT(+CURREC,"PATIENT INSTRUCTIONS",$$PROXYDUZ^PSOERXUT(),.NEWVAL)
End DoDot:2
+53 ; Adjusting the # of refills field if over the maximum allowed
+54 IF $$GET1^DIQ(52.49,+CURREC,20.5)>$$MAXNUMRF^PSOUTIL(MTCHDRUG,$$GET1^DIQ(52.49,+CURREC,20.2))
Begin DoDot:2
+55 SET FDA(52.49,+CURREC_",",20.5)=$$MAXNUMRF^PSOUTIL(MTCHDRUG,$$GET1^DIQ(52.49,+CURREC,20.2))
End DoDot:2
End DoDot:1
+56 ;
+57 IF $GET(DACHK("success"))'="true"
Begin DoDot:1
+58 SET ERRTXT=$GET(DACHK("error"))
+59 SET ERRSEQ=$$ERRSEQ^PSOERXU1(EIEN)
if 'ERRSEQ
QUIT
+60 DO FILERR^PSOERXU1(CURREC,ERRSEQ,"D","E",ERRTXT)
End DoDot:1
+61 ;
+62 ;Provider Auto-Match (Moved from Hub to VistA - P-692)
+63 IF $GET(PRCHK("success"))="false"
Begin DoDot:1
+64 NEW TMP,MSGTYPE,MTCHPROV,TMP,NPI,DEA,CS
+65 SET MSGTYPE=$ORDER(^TMP($JOB,"PSOERXO1","Message",0,"Body",0,""))
IF MSGTYPE=""
QUIT
+66 SET DEA=$GET(^TMP($JOB,"PSOERXO1","Message",0,"Body",0,MSGTYPE,0,"Prescriber",0,"NonVeterinarian",0,"Identification",0,"DEANumber",0))
+67 SET NPI=$GET(^TMP($JOB,"PSOERXO1","Message",0,"Body",0,MSGTYPE,0,"Prescriber",0,"NonVeterinarian",0,"Identification",0,"NPI",0))
+68 SET CS=($GET(^TMP($JOB,"PSOERXO1","Message",0,"Header",0,"DigitalSignature",0,"SignatureValue",0))'="")
+69 DO PRVMTCH^PSOERXA0(.MTCHPROV,NPI,DEA,CS)
+70 IF +$GET(MTCHPROV)
Begin DoDot:2
+71 KILL PRCHK
SET PRCHK("success")="true"
SET PRCHK("IEN")=+MTCHPROV
End DoDot:2
End DoDot:1
+72 ;Attempting auto-match based on VistA Provider Suggestions (Uses the lastest one)
+73 IF '$GET(PRCHK("IEN"))
Begin DoDot:1
+74 NEW EPRV,VPRV,SUGVPRV,MTCHDT
SET EPRV=+$$GET1^DIQ(52.49,+CURREC,2.1,"I")
SET (VPRV,SUGVPRV,MTCHDT)=0
+75 FOR
SET VPRV=$ORDER(^PS(52.49,"APRVVPRV",EPRV,VPRV))
if 'VPRV
QUIT
Begin DoDot:2
+76 ; VistA Provider is Inactive
IF $$GET1^DIQ(200,VPRV,53.4,"I")
KILL ^PS(52.49,"APRVVPRV",EPRV,VPRV)
QUIT
+77 IF $ORDER(^PS(52.49,"APRVVPRV",EPRV,VPRV,""),-1)>MTCHDT
Begin DoDot:3
+78 SET SUGVPRV=VPRV
SET MTCHDT=$ORDER(^PS(52.49,"APRVVPRV",EPRV,VPRV,""),-1)
End DoDot:3
End DoDot:2
+79 IF SUGVPRV
Begin DoDot:2
+80 KILL PRCHK
SET PRCHK("success")="true"
SET FDA(52.49,CURREC,1.2)=1
SET (FDA(52.49,CURREC,2.3),PRCHK("IEN"))=SUGVPRV
End DoDot:2
End DoDot:1
+81 ;Auto-Validating Provider
+82 SET PRVAUTOV=0
+83 IF $GET(PRCHK("success"))="true"
IF $GET(PRCHK("IEN"))
Begin DoDot:1
+84 SET FDA(52.49,CURREC,1.2)=1
+85 SET FDA(52.49,CURREC,2.3)=PRCHK("IEN")
+86 ;Auto-Validating Provider if auto-match was successful
+87 ;Condition: Non-CS eRx only & Last name, first letter of first name and zip code 5 digits must match
+88 NEW EPRVIEN,EPRVNAM,EPRVZC,EPRVDEA,VPRVIEN,VPRVNAM,VPRVZC
+89 SET EPRVIEN=$$GET1^DIQ(52.49,+CURREC,2.1,"I")
+90 SET EPRVNAM=$$UP^XLFSTR($TRANSLATE($$GET1^DIQ(52.48,EPRVIEN,.01)," "))
+91 SET EPRVZC=$PIECE($$GET1^DIQ(52.48,EPRVIEN,4.5),"-")
+92 SET EPRVDEA=$$UP^XLFSTR($$GET1^DIQ(52.48,EPRVIEN,1.6))
+93 SET VPRVIEN=PRCHK("IEN")
IF '$$CHKPRV2^PSOERX1A(VPRVIEN)
QUIT
+94 SET VPRVNAM=$$UP^XLFSTR($TRANSLATE($$GET1^DIQ(200,VPRVIEN,.01)," "))
+95 SET VPRVZC=$PIECE($$GET1^DIQ(200,VPRVIEN,.116),"-")
+96 IF $EXTRACT(EPRVNAM,1,$FIND(EPRVNAM,","))'=$EXTRACT(VPRVNAM,1,$FIND(VPRVNAM,","))
QUIT
+97 IF $EXTRACT(EPRVZC,1,5)'=$EXTRACT(VPRVZC,1,5)
QUIT
+98 IF $$GET1^DIQ(52.49,+CURREC,95.1,"I")
IF '$$DEAFOUND^PSOERXU8(EPRVDEA,VPRVIEN)
QUIT
+99 SET FDA(52.49,CURREC,1.3)=1
+100 SET FDA(52.49,CURREC,1.8)=$$PROXYDUZ^PSOERXUT()
+101 SET FDA(52.49,CURREC,1.9)=$$NOW^XLFDT()
+102 SET FDA(52.49,CURREC,2.7)=1
+103 SET PRVAUTOV=1
End DoDot:1
+104 IF $GET(PRCHK("success"))="true"
IF $GET(PRCHK("IEN"))
Begin DoDot:1
+105 ;Saving the eRx Audit Log for the Auto-Matched Provider
+106 SET NEWVAL(1)=$$GET1^DIQ(200,PRCHK("IEN"),.01)_" (DEA#: "_$PIECE($$VADEA^PSOERXU8(PRCHK("IEN"),+CURREC),"^",2)_")"_$SELECT($GET(PRVAUTOV):" - AUTO-VALIDATED",1:"")
+107 DO AUDLOG^PSOERXUT(+CURREC,"PROVIDER",$$PROXYDUZ^PSOERXUT(),.NEWVAL)
End DoDot:1
+108 ;
+109 IF $GET(PRCHK("success"))="false"
Begin DoDot:1
+110 SET ERRTXT=$GET(PRCHK("error"))
+111 SET ERRSEQ=$$ERRSEQ^PSOERXU1(EIEN)
if 'ERRSEQ
QUIT
+112 DO FILERR^PSOERXU1(CURREC,ERRSEQ,"PR","E",ERRTXT)
End DoDot:1
+113 ;
+114 IF $GET(PACHK("MVIerror"))']""
Begin DoDot:1
+115 SET PAICN=+$PIECE($GET(PACHK("ICN")),"V")
+116 IF PAICN
Begin DoDot:2
+117 SET (PAIEN,PACNT)=0
FOR
SET PAIEN=$ORDER(^DPT("AICN",PAICN,PAIEN))
if 'PAIEN
QUIT
Begin DoDot:3
+118 SET PACNT=PACNT+1
+119 ;revisit in future build - if we find more than one match in the local system, do we log some sort of an error?
End DoDot:3
End DoDot:2
+120 IF $GET(PACNT)=1
Begin DoDot:2
+121 SET FDA(52.49,CURREC,1.6)=1
+122 SET FDA(52.49,CURREC,.05)=$ORDER(^DPT("AICN",PAICN,0))
End DoDot:2
QUIT
+123 IF $LENGTH(PACHK("ssn"))
Begin DoDot:2
+124 SET (PASCNT,PAIEN)=0
FOR
SET PAIEN=$ORDER(^DPT("SSN",$TRANSLATE(PACHK("ssn"),"-",""),PAIEN))
if 'PAIEN
QUIT
Begin DoDot:3
+125 SET PASCNT=PASCNT+1
End DoDot:3
End DoDot:2
+126 IF $GET(PASCNT)=1
Begin DoDot:2
+127 SET FDA(52.49,CURREC,1.6)=1
+128 SET FDA(52.49,CURREC,.05)=$ORDER(^DPT("SSN",$TRANSLATE(PACHK("ssn"),"-",""),0))
End DoDot:2
QUIT
End DoDot:1
+129 ;Attempting auto-match based on VistA Patient Suggestions (Uses the lastest one)
+130 IF '$GET(FDA(52.49,CURREC,.05))
Begin DoDot:1
+131 NEW EPAT,VPAT,SUGVPAT,MTCHDT
SET EPAT=+$$GET1^DIQ(52.49,+CURREC,.04,"I")
SET (VPAT,SUGVPAT,MTCHDT)=0
+132 FOR
SET VPAT=$ORDER(^PS(52.49,"APATVPAT",EPAT,VPAT))
if 'VPAT
QUIT
Begin DoDot:2
+133 IF $ORDER(^PS(52.49,"APATVPAT",EPAT,VPAT,""),-1)>MTCHDT
Begin DoDot:3
+134 SET SUGVPAT=VPAT
SET MTCHDT=$ORDER(^PS(52.49,"APATVPAT",EPAT,VPAT,""),-1)
End DoDot:3
End DoDot:2
+135 IF SUGVPAT
SET FDA(52.49,CURREC,1.6)=1
SET FDA(52.49,CURREC,.05)=SUGVPAT
End DoDot:1
+136 ;
+137 ;Saving the eRx Audit Log For Auto-Matched Patient
+138 SET DFN=+$GET(FDA(52.49,CURREC,.05))
+139 IF DFN
Begin DoDot:1
+140 NEW VADM
DO DEM^VADPT
+141 SET NEWVAL(1)=$$GET1^DIQ(2,DFN,.01)_" (L4SSN: "_$PIECE($PIECE(VADM(2),"^",2),"-",3)_" | DOB: "_$PIECE(VADM(3),"^",2)_")"
+142 DO AUDLOG^PSOERXUT(+CURREC,"PATIENT",$$PROXYDUZ^PSOERXUT(),.NEWVAL)
End DoDot:1
+143 ;
+144 IF $DATA(FDA)
DO FILE^DIE(,"FDA")
KILL FDA
+145 ;
+146 ; Auto-holds for MbM
+147 IF $GET(MBMSITE)
IF DFN
Begin DoDot:1
+148 IF ",N,I,W,RXI,RXN,RXW,RXR,CXI,CXN,CXW,"'[(","_$$GET1^DIQ(52.49,CURREC,1,"I")_",")
QUIT
+149 IF '$$CHVAELIG^PSOERXU9(DFN)
Begin DoDot:2
+150 DO UPDSTAT^PSOERXU1(CURREC,"HEL","Hold due to Eligibility Issue")
End DoDot:2
QUIT
+151 NEW GMRA,GMRAL
+152 SET GMRA="0^0^111"
DO EN1^GMRADPT
IF $GET(GMRAL)'=""
QUIT
+153 DO UPDSTAT^PSOERXU1(CURREC,"HAL","Hold for Allergy Assessment")
End DoDot:1
+154 ;
+155 IF $GET(PACHK("success"))="false"
Begin DoDot:1
+156 ; file e&e error
+157 SET ERRTXT=$GET(PACHK("EandEerror"))
IF ERRTXT]""
Begin DoDot:2
+158 SET ERRSEQ=$$ERRSEQ^PSOERXU1(EIEN)
if 'ERRSEQ
QUIT
+159 DO FILERR^PSOERXU1(CURREC,ERRSEQ,"PA","E",ERRTXT)
End DoDot:2
+160 ; file mvi error
+161 SET ERRTXT=$GET(PACHK("MVIerror"))
IF ERRTXT]""
Begin DoDot:2
+162 SET ERRSEQ=$$ERRSEQ^PSOERXU1(EIEN)
if 'ERRSEQ
QUIT
+163 DO FILERR^PSOERXU1(CURREC,ERRSEQ,"PA","E",ERRTXT)
End DoDot:2
End DoDot:1
+164 ;
+165 SET RES="1^Erx Received."
+166 ;
+167 ;Create an Addendum for eRx Change Response Progress Note
+168 IF $GET(EIEN)'=""
IF $$GET1^DIQ(52.49,EIEN,.08,"I")="CX"
DO CREATEADD(ERXHID,EIEN)
+169 QUIT
+170 ;
CREATEADD(ERXHID,EIEN) ;Create CPRS Progress Notes Addendum for this eRx Change Response
+1 ;Input: ERXHID - eRx processing hub id^CANCEL/CHANGE REQUEST DENIED BY HUB (1=YES)^relates to hub ID
+2 ; EIEN - The eRx Change Response IEN, Pointer to ERX HOLDING QUEUE file (#52.49)
+3 ;Output: Create an Addendum and attach it to the parent eRx Change Request
+4 ;
+5 IF ($GET(ERXHID)="")!($GET(EIEN)="")
QUIT
+6 NEW CNT,CRERXIEN,ORGERXIEN,ERXDRUG,CRMEDS,CNT,CXTARGET,ERXDRUG,PSOTIUIEN,TIUDADD,ERXTIUX
+7 ;
+8 SET CRERXIEN=$ORDER(^PS(52.49,"B",$PIECE(ERXHID,"^",3),0))
+9 SET ORGERXIEN=$PIECE($GET(^PS(52.49,CRERXIEN,0)),"^",14)
+10 SET ORGERXIEN=$ORDER(^PS(52.49,"B",ORGERXIEN,0))
+11 ;
+12 ;get the parent reference IEN TIU Document
+13 SET PSOTIUIEN=$$GET1^DIQ(52.49,CRERXIEN,320.1)
+14 IF '$GET(PSOTIUIEN)
Begin DoDot:1
+15 NEW TIUTITLE
SET TIUTITLE="PHARMACY ERX RX CHANGE REQUEST NOTE"
+16 IF '+$$FIND1^DIC(8925.1,"","X",TIUTITLE,"B")
SET TIUTITLE="ERX RX CHANGE REQUEST NOTE"
+17 DO BLDCRMEDS(ERXHID,+$GET(MTCHDRUG),TIUTITLE)
End DoDot:1
QUIT
+18 ;
+19 SET CXTARGET=$NAME(^TMP("TIUP",$JOB))
KILL @CXTARGET
+20 DO BUILDLST^PSOERSE4(CXTARGET,EIEN)
+21 if '$DATA(@CXTARGET)
QUIT
+22 KILL ERXTIUX
MERGE ERXTIUX("TEXT")=@CXTARGET
+23 ;PSOTIUIEN is the parent IEN from The TIU Document Definition name in File #8925.1
DO MAKEADD^TIUSRVP2(.TIUDADD,PSOTIUIEN,.ERXTIUX)
+24 ;TIUDADD is the Addendum IEN
DO UPDATEPN^PSOERX1H(.TIUDADD,$GET(ORGERXIEN))
+25 QUIT
+26 ;
BLDCRMEDS(ERXHID,VDRUG,TIUTITLE) ;Build eRx Change Response Medication array
+1 ;get the original eRx
+2 if $GET(ERXHID)=""
QUIT
+3 NEW CRERXIEN,ORGERXIEN,ERXDRUG,CRMEDS
+4 ;
+5 SET CRERXIEN=$ORDER(^PS(52.49,"B",$PIECE(ERXHID,"^",3),0))
+6 SET ORGERXIEN=$PIECE($GET(^PS(52.49,CRERXIEN,0)),"^",14)
+7 SET ORGERXIEN=$ORDER(^PS(52.49,"B",ORGERXIEN,0))
+8 SET CNT=0
+9 IF $GET(VDRUG)
Begin DoDot:1
+10 SET ERXDRUG=$$GET1^DIQ(50,$GET(VDRUG),.01)
+11 SET CNT=CNT+1
SET CRMEDS(CNT)="^"_ERXDRUG
End DoDot:1
+12 ;
+13 ;create eRx Change Response PN
DO CREATEPN^PSOERX1H(ORGERXIEN,EIEN,,.CRMEDS,TIUTITLE)
+14 ;
+15 QUIT
+16 ; VAL - value to resolve
+17 ; TYPE - This is the code type, which will tell which 'C' index type to get the code from
PRESOLV(VAL,TYPE) ;
+1 NEW MATCH
+2 SET MATCH=""
+3 ; avoid null subscript
if '$LENGTH(TYPE)!('$LENGTH(VAL))
QUIT ""
+4 SET MATCH=$ORDER(^PS(52.45,"C",TYPE,VAL,0))
+5 ; return the match found, null if no match
+6 QUIT MATCH
CONVDTTM(VAL) ;
+1 NEW EDATE,ETIME,X,ETZ,Y,%DT,%
+2 IF '$LENGTH(VAL)
QUIT ""
+3 SET EDATE=$PIECE(VAL,"T")
SET ETIME=$PIECE(VAL,"T",2)
+4 ; split off time zone
+5 SET ETZ=$PIECE(ETIME,".",2)
+6 SET ETIME=$PIECE(ETIME,".")
+7 SET X=EDATE
DO ^%DT
IF 'Y
QUIT ""
+8 SET VAL=Y_$SELECT($LENGTH(ETIME):"."_$TRANSLATE(ETIME,":",""),1:"")
+9 QUIT VAL
+10 ;
MTCHDRUG() ; Returns the Matched Dispensed Drug based on the NDF files
+1 ;Output: MTCHDRUG - VistA Dispense Drug associated with the Name/NDC from outside (Pointer to file #50)
+2 NEW MSGTYPE,MEDSEG,MTCHDRUG,PRDCODE,PRDCOQL,DRGNAME
+3 SET MTCHDRUG=0
+4 SET MSGTYPE=$ORDER(^TMP($JOB,"PSOERXO1","Message",0,"Body",0,""))
IF MSGTYPE=""
QUIT 0
+5 SET MEDSEG="MedicationPrescribed"
+6 IF '$DATA(^TMP($JOB,"PSOERXO1","Message",0,"Body",0,MSGTYPE,0,MEDSEG))
Begin DoDot:1
+7 SET MEDSEG="MedicationResponse"
End DoDot:1
+8 SET PRDCODE=$GET(^TMP($JOB,"PSOERXO1","Message",0,"Body",0,MSGTYPE,0,MEDSEG,0,"DrugCoded",0,"ProductCode",0,"Code",0))
IF PRDCODE=""
QUIT 0
+9 SET PRDCOQL=$EXTRACT($GET(^TMP($JOB,"PSOERXO1","Message",0,"Body",0,MSGTYPE,0,MEDSEG,0,"DrugCoded",0,"ProductCode",0,"Qualifier",0)),1)
+10 IF PRDCOQL'="N"
IF PRDCOQL'="U"
QUIT 0
+11 SET DRGNAME=$GET(^TMP($JOB,"PSOERXO1","Message",0,"Body",0,MSGTYPE,0,MEDSEG,0,"DrugDescription",0))
+12 DO DRGMTCH^PSOERXA0(.MTCHDRUG,PRDCOQL_"^"_PRDCODE,DRGNAME)
+13 QUIT +$GET(MTCHDRUG)
+14 ;
ERROR ; Error Handling
+1 DO ^%ZTER
+2 SET RES="1^eRx received but there was an error. See error trap at "_$PIECE($TRANSLATE($$SITE^VASITE(),"^","-"),"-",1,2)
QUIT
+3 QUIT
