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

PSOERXA6.m

Go to the documentation of this file.
PSOERXA6 ;ALB/BLB - eRx Utilities/RPC's ; 8/3/2016 5:14pm
 ;;7.0;OUTPATIENT PHARMACY;**581**;DEC 1997;Build 126
 ;
 Q
CHRESP(ERXIEN,MTYPE,INST) ;
 N GL,CHFDA,RESTYPE,REFNUM,RESNOTE,I,REACODE,IENS,FDA,RESTUP,RESNODE,RESTNODE,REFRES,REFREQ,DELTAS,PSOIEN,RXIEN,CHRES
 N REQCODE,NRXIEN,CREQIEN,RXIEN,PENDIEN,NRXVPAT,RET
 S GL=$NA(^TMP($J,"PSOERXO1","Message",0,"Body",0,MTYPE,0,"Response",0))
 S RESTYPE=$O(@GL@("")),RESTUP=$$UP^XLFSTR(RESTYPE),RESTUP=$TR(RESTUP," ",""),RESTUP=$TR(RESTUP,",","")
 S RESTNODE=RESTYPE
 S REFNUM=$G(@GL@(RESTYPE,0,"ReferenceNumber",0))
 S RESTYPE=$S(RESTUP="VALIDATED":"V",RESTUP="APPROVED":"A",RESTUP="DENIED":"D",RESTUP="APPROVEDWITHCHANGES":"AWC",1:"")
 S RESNODE=$S(RESTYPE="A":"ApprovalReason",RESTYPE="R":"Replace",1:"DenialReason")
 S RESNOTE=$S(RESTYPE="A"!(RESTYPE="AWC")!(RESTYPE="R")!(RESTYPE="V"):$G(@GL@(RESTNODE,0,"Note",0)),1:$G(@GL@(RESTNODE,0,"DenialReason",0)))
 S CHFDA(52.49,ERXIEN_",",52.3)=REFNUM
 S CHFDA(52.49,ERXIEN_",",52.1)=RESTYPE
 S CHFDA(52.49,ERXIEN_",",52.2)=RESNOTE
 D FILE^DIE(,"CHFDA") K CHFDA
 S I=-1 F  S I=$O(@GL@(RESTNODE,I)) Q:I=""  D
 .S REACODE=$G(@GL@(RESTNODE,0,"ReasonCode",I))
 .S REACODE=$$PRESOLV^PSOERXA1(REACODE,"CLQ") Q:'REACODE
 .S IENS="+1,"_ERXIEN_","
 .S CHFDA(52.4955,IENS,.01)=REACODE
 .D UPDATE^DIE(,"CHFDA") K CHFDA
 S REQCODE=$$GET1^DIQ(52.49,ERXIEN,315.1,"E")
 S CREQIEN=$$RESOLV^PSOERXU2(ERXIEN)
 S NRXIEN=$$RESOLV^PSOERXU2(CREQIEN)
 S NRXVPAT=$$GET1^DIQ(52.49,NRXIEN,.05,"I")
 S RXIEN=$$GET1^DIQ(52.49,NRXIEN,.13,"I")
 S PENDIEN=$$GET1^DIQ(52.49,NRXIEN,.1,"I")
 I RESTYPE="A"!(RESTYPE="AWC"),",G,T,S,OS,D,"[REQCODE D  Q
 .I $G(RXIEN) D  Q
 ..I RESTYPE="A" D RXACT^PSOBPSU2(RXIEN,,"RxChange response from external provider - Approved.","O")
 ..I RESTYPE="AWC" D RXACT^PSOBPSU2(RXIEN,,"RxChange response from external provider - Approved with provider changes.","O")
 ..D AUTODC^PSOERXU3(ERXIEN)
 ..D DCALL(ERXIEN,INST,.RET)
 ..I $$GET1^DIQ(52.49,CREQIEN,1,"E")'="CRR" D UPDSTAT^PSOERXU1(CREQIEN,"CRR")
 .I $$GET1^DIQ(52.49,CREQIEN,1,"E")'="CRR" D UPDSTAT^PSOERXU1(CREQIEN,"CRR")
 .D DCALL(ERXIEN,INST,.RET)
 I RESTYPE="V" D
 .I $G(RXIEN) D  Q
 ..I RESTYPE="V" D RXACT^PSOBPSU2(RXIEN,,"RxChange response from external provider - Validated.","O")
 ..D AUTODC^PSOERXU3(ERXIEN)
 ..D DCALL(ERXIEN,INST,.RET)
 ..I $$GET1^DIQ(52.49,CREQIEN,1,"E")'="CRR" D UPDSTAT^PSOERXU1(CREQIEN,"CRR")
 ..I $$GET1^DIQ(52.49,ERXIEN,1,"E")'="CXE" D UPDSTAT^PSOERXU1(ERXIEN,"CXV")
 .I $$GET1^DIQ(52.49,CREQIEN,1,"E")'="CRR" D UPDSTAT^PSOERXU1(CREQIEN,"CRR")
 .D DCALL(ERXIEN,INST,.RET)
 .I $$GET1^DIQ(52.49,ERXIEN,1,"E")'="CXE" D UPDSTAT^PSOERXU1(ERXIEN,"CXV")
 I RESTYPE="D" D
 .D UPDSTAT^PSOERXU1(ERXIEN,"CXD")
 .I $G(RXIEN) D RXACT^PSOBPSU2(RXIEN,,"RxChange response from external provider - Denied","O")
 I RESTYPE="A",REQCODE="P" D
 .D UPDSTAT^PSOERXU1(ERXIEN,"CXY")
 .I $G(RXIEN) D RXACT^PSOBPSU2(RXIEN,,"RxChange response from external provider - Approved","O")
 Q
DCALL(ERXIEN,INST,PSSRET) ;
 N NERXIEN,RXIEN,RELMIEN,NRXOPIEN,NRXPNIEN,REOPIEN,REPNIEN,ACOMACT,ACOMPEND,CANTYPE,NRXVPAT,CNT,ADAT,ARY,ALOOP,DONE
 N PENDIEN,RXIEN,PSSRET,PREVORD,RRRETYPE,RXFAIL,PENFAIL,ARESP,FORORD,PON,VARENEW,LSTMSG,RELIEN,SENDMSG,DELFLG,DELTXT
 N CREQIEN,RELMTYPE,RELIEN,RETYPE,ERXTYPE,RESTYPE,RTYPE
 S CNT=0
 S CREQIEN=$$RESOLV^PSOERXU2(ERXIEN)
 S NERXIEN=$$RESOLV^PSOERXU2(CREQIEN)
 S NRXVPAT=$$GET1^DIQ(52.49,NERXIEN,.05,"I")
 S NRXOPIEN=$$GET1^DIQ(52.49,NERXIEN,.13,"I")
 S NRXPNIEN=$$GET1^DIQ(52.49,NERXIEN,25.2,"E")
 I NRXOPIEN!(NRXPNIEN) S CNT=CNT+1,ARY(CNT)=NRXPNIEN_U_NRXOPIEN
 S RELMIEN=0 F  S RELMIEN=$O(^PS(52.49,NERXIEN,201,"B",RELMIEN)) Q:'RELMIEN  D
 .S RELMTYPE=$$GET1^DIQ(52.49,RELMIEN,.08,"I")
 .S ERXTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
 .; only look for renewal response and cancel response messages
 .I RELMTYPE="RE"!(RELMTYPE="CX")!(RELMTYPE="N"&(ERXTYPE="CX")) D
 ..S REOPIEN=$$GET1^DIQ(52.49,RELMIEN,.13,"I")
 ..S REPNIEN=$$GET1^DIQ(52.49,RELMIEN,25.2,"E")
 ..S RESTYPE=$$GET1^DIQ(52.49,RELMIEN,52.1,"I")
 ..S CNT=CNT+1,ARY(CNT)=REPNIEN_U_REOPIEN_U_RELMIEN_U_RELMTYPE_U_RESTYPE
 .; If this is a refill request and there is no response, set the status to CXQ
 .I RELMTYPE="RR" D UPDSTAT^PSOERXU1(RELMIEN,"CXQ")
 ; update the newrx and change request status values
 I $$GET1^DIQ(52.49,NERXIEN,1,"E")'="CXQ" D UPDSTAT^PSOERXU1(NERXIEN,"CXQ")
 ; if there is only one, it is the NewRx
 I CNT=1 D  Q
 .S ADAT=$G(ARY(CNT))
 .S PENDIEN=$P(ADAT,U),RXIEN=$P(ADAT,U,2),RELIEN=$P(ADAT,U,3),RTYPE=$P(ADAT,U,5)
 .; if there is an associated RXIEN, this is active and the pending item no longer exists.
 .I RXIEN D
 ..S ACOMACT=$$CANACT^PSOERXU6(ERXIEN,RXIEN,INST,.PSSRET)
 ..S FORORD=$$GET1^DIQ(52,RXIEN,39.5,"I")
 ..I FORORD S PON=$$GET1^DIQ(52,FORORD,39.3,"I")
 ..I FORORD,'$$CHKERX^PSOERXU1(FORORD) S VARENEW=1
 .I 'RXIEN,PENDIEN D
 ..I $$GET1^DIQ(52.41,PENDIEN,1,"I")'=NRXVPAT S DONE=1 Q
 ..S ACOMPEND=$$CANPEND^PSOERXU6(ERXIEN,PENDIEN,INST,.PSSRET)
 .; if either failed, update the status and do not send the response
 .Q:$G(DONE)
 .I $D(ACOMACT),'$P(ACOMACT,U) S RXFAIL=1
 .I $D(ACOMPEND),'$P(ACOMPEND,U) S PENFAIL=1
 .I $G(RXFAIL)!($G(PENFAIL))!($P($G(ACOMACT),U)=2) D  Q
 ..I $G(RXFAIL)!($P($G(ACOMACT),U)=2) S ARESP=$P(ACOMACT,U,2)
 ..I $G(PENFAIL),'$D(ARESP) S ARESP=$P($G(ACOMPEND),U,2)
 ..D UPDSTAT^PSOERXU1(ERXIEN,"CXE",$G(ARESP))
 ..; if this is a 'deleted' rx, cancel all related and quit. no need to change status
 .I $D(ACOMACT),$P(ACOMACT,U) S ARESP=$P(ACOMACT,U,2)
 .I '$L($G(ARESP)),$D(ACOMPEND),$P(ACOMPEND,U) S ARESP=$P(ACOMPEND,U,2)
 .I RXIEN,$$VARENEW^PSOERXU6(RXIEN) D  Q
 ..D UPDSTAT^PSOERXU1(ERXIEN,"CXE","eRx was renewed within the VA.")
 .I $$GET1^DIQ(52.49,RELIEN,.08,"I")'="CX" D UPDSTAT^PSOERXU1(RELIEN,"CXQ","eRx cancelled due to change.")
 ; if there is more than one, renewals have occured.
 S ALOOP=99999,DONE=0
 F  S ALOOP=$O(ARY(ALOOP),-1) Q:'ALOOP!(DONE)  D
 .S ADAT=$G(ARY(ALOOP))
 .; if there is a pending IEN and no RX IEN, we know this has not yet been processed into a live prescription
 .; and is a renwewal from a previous prescription.
 .S PENDIEN=$P(ADAT,U),RXIEN=$P(ADAT,U,2),RELIEN=$P(ADAT,U,3),RETYPE=$P(ADAT,U,4),RTYPE=$P(ADAT,U,5)
 .I RXIEN D  Q
 ..I $G(PENDIEN),$$GET1^DIQ(52.41,PENDIEN,1,"I")=NRXVPAT D  Q
 ...S ACOMPEND(ALOOP)=$$CANPEND^PSOERXU6(ERXIEN,PENDIEN,INST,.PSSRET)
 ...S ACOMACT(ALOOP)=$$CANACT^PSOERXU6(ERXIEN,RXIEN,INST,.PSSRET)
 ...S FORORD=$$GET1^DIQ(52,RXIEN,39.5,"I")
 ...I FORORD S PON=$$GET1^DIQ(52,FORORD,39.3,"I")
 ...I FORORD,'$$CHKERX^PSOERXU1(PON) S VARENEW=1
 ...I '$G(VARENEW),RETYPE="RE" D UPDSTAT^PSOERXU1(RELIEN,"CXQ","eRx cancelled due to change.")
 ..S ACOMACT(ALOOP)=$$CANACT^PSOERXU6(ERXIEN,RXIEN,INST,.PSSRET)
 ..I $$GET1^DIQ(52.49,RELIEN,.08,"I")'="CX" D
 ...I $P(ACOMACT(ALOOP),U)=1 D UPDSTAT^PSOERXU1(RELIEN,"CXQ","eRx cancelled due to change.")
 .I PENDIEN,'RXIEN D  Q
 ..; if this pending item is not for the right patient, quit
 ..I $G(PENDIEN),$$GET1^DIQ(52.41,PENDIEN,1,"I")'=NRXVPAT S DONE=1 Q
 ..S PREVORD=$$GET1^DIQ(52.41,PENDIEN,22.1,"E")
 ..I '$G(PREVORD) D  Q
 ...S ACOMPEND(ALOOP)=$$CANPEND^PSOERXU6(ERXIEN,PENDIEN,INST,.PSSRET)
 ..S ACOMPEND(ALOOP)=$$CANPEND^PSOERXU6(ERXIEN,PENDIEN,INST,.PSSRET)
 ..S ACOMACT(ALOOP)=$$CANACT^PSOERXU6(ERXIEN,PREVORD,INST,.PSSRET)
 ..I $$GET1^DIQ(52.49,RELIEN,.08,"I")'="CX" D
 ...I $P(ACOMPEND(ALOOP),U)=1,$$GET1^DIQ(52.49,RELIEN,1,"E")'="CXQ" D UPDSTAT^PSOERXU1(RELIEN,"CXQ","eRx cancelled due to change.")
 .I $$GET1^DIQ(52.49,RELIEN,.08,"I")'="CX" D UPDSTAT^PSOERXU1(RELIEN,"CXQ","eRx cancelled due to change.")
 ; now check all results for failures
 N ACTLP,ACTFL,ACTMSG,PENLP,PENFL,PENMSG
 S (ACTLP,ACTFL)=0 F  S ACTLP=$O(ACOMACT(ACTLP)) Q:'ACTLP  D
 .I $P(ACOMACT(ACTLP),U)=0 S ACTFL=ACTFL+1
 .I $P(ACOMACT(ACTLP),U)=1 S ACTMSG(ACTFL)=$P(ACOMACT(ACTLP),U,2)
 .I $P(ACOMACT(ACTLP),U)=2 S DELFLG=1,DELTXT=$P(ACOMACT(ACTLP),U,2)
 S (PENLP,PENFL)=0 F  S PENLP=$O(ACOMPEND(PENLP)) Q:'PENLP  D
 .I $P(ACOMPEND(PENLP),U)=0 S PENFL=PENFL+1
 .I $P(ACOMPEND(PENLP),U)=1 S PENMSG(PENFL)=$P(ACOMPEND(PENLP),U,2)
 I ACTFL>0!(PENFL>0) D  Q
 .D UPDSTAT^PSOERXU1(ERXIEN,"CXE","One or more entries associated with this eRx failed to auto-discontinue.")
 Q