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