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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXA6 8297 printed Nov 22, 2024@17:38:24 Page 2
PSOERXA6 ;ALB/BLB - eRx Utilities/RPC's ; 8/3/2016 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**581**;DEC 1997;Build 126
+2 ;
+3 QUIT
CHRESP(ERXIEN,MTYPE,INST) ;
+1 NEW GL,CHFDA,RESTYPE,REFNUM,RESNOTE,I,REACODE,IENS,FDA,RESTUP,RESNODE,RESTNODE,REFRES,REFREQ,DELTAS,PSOIEN,RXIEN,CHRES
+2 NEW REQCODE,NRXIEN,CREQIEN,RXIEN,PENDIEN,NRXVPAT,RET
+3 SET GL=$NAME(^TMP($JOB,"PSOERXO1","Message",0,"Body",0,MTYPE,0,"Response",0))
+4 SET RESTYPE=$ORDER(@GL@(""))
SET RESTUP=$$UP^XLFSTR(RESTYPE)
SET RESTUP=$TRANSLATE(RESTUP," ","")
SET RESTUP=$TRANSLATE(RESTUP,",","")
+5 SET RESTNODE=RESTYPE
+6 SET REFNUM=$GET(@GL@(RESTYPE,0,"ReferenceNumber",0))
+7 SET RESTYPE=$SELECT(RESTUP="VALIDATED":"V",RESTUP="APPROVED":"A",RESTUP="DENIED":"D",RESTUP="APPROVEDWITHCHANGES":"AWC",1:"")
+8 SET RESNODE=$SELECT(RESTYPE="A":"ApprovalReason",RESTYPE="R":"Replace",1:"DenialReason")
+9 SET RESNOTE=$SELECT(RESTYPE="A"!(RESTYPE="AWC")!(RESTYPE="R")!(RESTYPE="V"):$GET(@GL@(RESTNODE,0,"Note",0)),1:$GET(@GL@(RESTNODE,0,"DenialReason",0)))
+10 SET CHFDA(52.49,ERXIEN_",",52.3)=REFNUM
+11 SET CHFDA(52.49,ERXIEN_",",52.1)=RESTYPE
+12 SET CHFDA(52.49,ERXIEN_",",52.2)=RESNOTE
+13 DO FILE^DIE(,"CHFDA")
KILL CHFDA
+14 SET I=-1
FOR
SET I=$ORDER(@GL@(RESTNODE,I))
if I=""
QUIT
Begin DoDot:1
+15 SET REACODE=$GET(@GL@(RESTNODE,0,"ReasonCode",I))
+16 SET REACODE=$$PRESOLV^PSOERXA1(REACODE,"CLQ")
if 'REACODE
QUIT
+17 SET IENS="+1,"_ERXIEN_","
+18 SET CHFDA(52.4955,IENS,.01)=REACODE
+19 DO UPDATE^DIE(,"CHFDA")
KILL CHFDA
End DoDot:1
+20 SET REQCODE=$$GET1^DIQ(52.49,ERXIEN,315.1,"E")
+21 SET CREQIEN=$$RESOLV^PSOERXU2(ERXIEN)
+22 SET NRXIEN=$$RESOLV^PSOERXU2(CREQIEN)
+23 SET NRXVPAT=$$GET1^DIQ(52.49,NRXIEN,.05,"I")
+24 SET RXIEN=$$GET1^DIQ(52.49,NRXIEN,.13,"I")
+25 SET PENDIEN=$$GET1^DIQ(52.49,NRXIEN,.1,"I")
+26 IF RESTYPE="A"!(RESTYPE="AWC")
IF ",G,T,S,OS,D,"[REQCODE
Begin DoDot:1
+27 IF $GET(RXIEN)
Begin DoDot:2
+28 IF RESTYPE="A"
DO RXACT^PSOBPSU2(RXIEN,,"RxChange response from external provider - Approved.","O")
+29 IF RESTYPE="AWC"
DO RXACT^PSOBPSU2(RXIEN,,"RxChange response from external provider - Approved with provider changes.","O")
+30 DO AUTODC^PSOERXU3(ERXIEN)
+31 DO DCALL(ERXIEN,INST,.RET)
+32 IF $$GET1^DIQ(52.49,CREQIEN,1,"E")'="CRR"
DO UPDSTAT^PSOERXU1(CREQIEN,"CRR")
End DoDot:2
QUIT
+33 IF $$GET1^DIQ(52.49,CREQIEN,1,"E")'="CRR"
DO UPDSTAT^PSOERXU1(CREQIEN,"CRR")
+34 DO DCALL(ERXIEN,INST,.RET)
End DoDot:1
QUIT
+35 IF RESTYPE="V"
Begin DoDot:1
+36 IF $GET(RXIEN)
Begin DoDot:2
+37 IF RESTYPE="V"
DO RXACT^PSOBPSU2(RXIEN,,"RxChange response from external provider - Validated.","O")
+38 DO AUTODC^PSOERXU3(ERXIEN)
+39 DO DCALL(ERXIEN,INST,.RET)
+40 IF $$GET1^DIQ(52.49,CREQIEN,1,"E")'="CRR"
DO UPDSTAT^PSOERXU1(CREQIEN,"CRR")
+41 IF $$GET1^DIQ(52.49,ERXIEN,1,"E")'="CXE"
DO UPDSTAT^PSOERXU1(ERXIEN,"CXV")
End DoDot:2
QUIT
+42 IF $$GET1^DIQ(52.49,CREQIEN,1,"E")'="CRR"
DO UPDSTAT^PSOERXU1(CREQIEN,"CRR")
+43 DO DCALL(ERXIEN,INST,.RET)
+44 IF $$GET1^DIQ(52.49,ERXIEN,1,"E")'="CXE"
DO UPDSTAT^PSOERXU1(ERXIEN,"CXV")
End DoDot:1
+45 IF RESTYPE="D"
Begin DoDot:1
+46 DO UPDSTAT^PSOERXU1(ERXIEN,"CXD")
+47 IF $GET(RXIEN)
DO RXACT^PSOBPSU2(RXIEN,,"RxChange response from external provider - Denied","O")
End DoDot:1
+48 IF RESTYPE="A"
IF REQCODE="P"
Begin DoDot:1
+49 DO UPDSTAT^PSOERXU1(ERXIEN,"CXY")
+50 IF $GET(RXIEN)
DO RXACT^PSOBPSU2(RXIEN,,"RxChange response from external provider - Approved","O")
End DoDot:1
+51 QUIT
DCALL(ERXIEN,INST,PSSRET) ;
+1 NEW NERXIEN,RXIEN,RELMIEN,NRXOPIEN,NRXPNIEN,REOPIEN,REPNIEN,ACOMACT,ACOMPEND,CANTYPE,NRXVPAT,CNT,ADAT,ARY,ALOOP,DONE
+2 NEW PENDIEN,RXIEN,PSSRET,PREVORD,RRRETYPE,RXFAIL,PENFAIL,ARESP,FORORD,PON,VARENEW,LSTMSG,RELIEN,SENDMSG,DELFLG,DELTXT
+3 NEW CREQIEN,RELMTYPE,RELIEN,RETYPE,ERXTYPE,RESTYPE,RTYPE
+4 SET CNT=0
+5 SET CREQIEN=$$RESOLV^PSOERXU2(ERXIEN)
+6 SET NERXIEN=$$RESOLV^PSOERXU2(CREQIEN)
+7 SET NRXVPAT=$$GET1^DIQ(52.49,NERXIEN,.05,"I")
+8 SET NRXOPIEN=$$GET1^DIQ(52.49,NERXIEN,.13,"I")
+9 SET NRXPNIEN=$$GET1^DIQ(52.49,NERXIEN,25.2,"E")
+10 IF NRXOPIEN!(NRXPNIEN)
SET CNT=CNT+1
SET ARY(CNT)=NRXPNIEN_U_NRXOPIEN
+11 SET RELMIEN=0
FOR
SET RELMIEN=$ORDER(^PS(52.49,NERXIEN,201,"B",RELMIEN))
if 'RELMIEN
QUIT
Begin DoDot:1
+12 SET RELMTYPE=$$GET1^DIQ(52.49,RELMIEN,.08,"I")
+13 SET ERXTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+14 ; only look for renewal response and cancel response messages
+15 IF RELMTYPE="RE"!(RELMTYPE="CX")!(RELMTYPE="N"&(ERXTYPE="CX"))
Begin DoDot:2
+16 SET REOPIEN=$$GET1^DIQ(52.49,RELMIEN,.13,"I")
+17 SET REPNIEN=$$GET1^DIQ(52.49,RELMIEN,25.2,"E")
+18 SET RESTYPE=$$GET1^DIQ(52.49,RELMIEN,52.1,"I")
+19 SET CNT=CNT+1
SET ARY(CNT)=REPNIEN_U_REOPIEN_U_RELMIEN_U_RELMTYPE_U_RESTYPE
End DoDot:2
+20 ; If this is a refill request and there is no response, set the status to CXQ
+21 IF RELMTYPE="RR"
DO UPDSTAT^PSOERXU1(RELMIEN,"CXQ")
End DoDot:1
+22 ; update the newrx and change request status values
+23 IF $$GET1^DIQ(52.49,NERXIEN,1,"E")'="CXQ"
DO UPDSTAT^PSOERXU1(NERXIEN,"CXQ")
+24 ; if there is only one, it is the NewRx
+25 IF CNT=1
Begin DoDot:1
+26 SET ADAT=$GET(ARY(CNT))
+27 SET PENDIEN=$PIECE(ADAT,U)
SET RXIEN=$PIECE(ADAT,U,2)
SET RELIEN=$PIECE(ADAT,U,3)
SET RTYPE=$PIECE(ADAT,U,5)
+28 ; if there is an associated RXIEN, this is active and the pending item no longer exists.
+29 IF RXIEN
Begin DoDot:2
+30 SET ACOMACT=$$CANACT^PSOERXU6(ERXIEN,RXIEN,INST,.PSSRET)
+31 SET FORORD=$$GET1^DIQ(52,RXIEN,39.5,"I")
+32 IF FORORD
SET PON=$$GET1^DIQ(52,FORORD,39.3,"I")
+33 IF FORORD
IF '$$CHKERX^PSOERXU1(FORORD)
SET VARENEW=1
End DoDot:2
+34 IF 'RXIEN
IF PENDIEN
Begin DoDot:2
+35 IF $$GET1^DIQ(52.41,PENDIEN,1,"I")'=NRXVPAT
SET DONE=1
QUIT
+36 SET ACOMPEND=$$CANPEND^PSOERXU6(ERXIEN,PENDIEN,INST,.PSSRET)
End DoDot:2
+37 ; if either failed, update the status and do not send the response
+38 if $GET(DONE)
QUIT
+39 IF $DATA(ACOMACT)
IF '$PIECE(ACOMACT,U)
SET RXFAIL=1
+40 IF $DATA(ACOMPEND)
IF '$PIECE(ACOMPEND,U)
SET PENFAIL=1
+41 IF $GET(RXFAIL)!($GET(PENFAIL))!($PIECE($GET(ACOMACT),U)=2)
Begin DoDot:2
+42 IF $GET(RXFAIL)!($PIECE($GET(ACOMACT),U)=2)
SET ARESP=$PIECE(ACOMACT,U,2)
+43 IF $GET(PENFAIL)
IF '$DATA(ARESP)
SET ARESP=$PIECE($GET(ACOMPEND),U,2)
+44 DO UPDSTAT^PSOERXU1(ERXIEN,"CXE",$GET(ARESP))
+45 ; if this is a 'deleted' rx, cancel all related and quit. no need to change status
End DoDot:2
QUIT
+46 IF $DATA(ACOMACT)
IF $PIECE(ACOMACT,U)
SET ARESP=$PIECE(ACOMACT,U,2)
+47 IF '$LENGTH($GET(ARESP))
IF $DATA(ACOMPEND)
IF $PIECE(ACOMPEND,U)
SET ARESP=$PIECE(ACOMPEND,U,2)
+48 IF RXIEN
IF $$VARENEW^PSOERXU6(RXIEN)
Begin DoDot:2
+49 DO UPDSTAT^PSOERXU1(ERXIEN,"CXE","eRx was renewed within the VA.")
End DoDot:2
QUIT
+50 IF $$GET1^DIQ(52.49,RELIEN,.08,"I")'="CX"
DO UPDSTAT^PSOERXU1(RELIEN,"CXQ","eRx cancelled due to change.")
End DoDot:1
QUIT
+51 ; if there is more than one, renewals have occured.
+52 SET ALOOP=99999
SET DONE=0
+53 FOR
SET ALOOP=$ORDER(ARY(ALOOP),-1)
if 'ALOOP!(DONE)
QUIT
Begin DoDot:1
+54 SET ADAT=$GET(ARY(ALOOP))
+55 ; if there is a pending IEN and no RX IEN, we know this has not yet been processed into a live prescription
+56 ; and is a renwewal from a previous prescription.
+57 SET PENDIEN=$PIECE(ADAT,U)
SET RXIEN=$PIECE(ADAT,U,2)
SET RELIEN=$PIECE(ADAT,U,3)
SET RETYPE=$PIECE(ADAT,U,4)
SET RTYPE=$PIECE(ADAT,U,5)
+58 IF RXIEN
Begin DoDot:2
+59 IF $GET(PENDIEN)
IF $$GET1^DIQ(52.41,PENDIEN,1,"I")=NRXVPAT
Begin DoDot:3
+60 SET ACOMPEND(ALOOP)=$$CANPEND^PSOERXU6(ERXIEN,PENDIEN,INST,.PSSRET)
+61 SET ACOMACT(ALOOP)=$$CANACT^PSOERXU6(ERXIEN,RXIEN,INST,.PSSRET)
+62 SET FORORD=$$GET1^DIQ(52,RXIEN,39.5,"I")
+63 IF FORORD
SET PON=$$GET1^DIQ(52,FORORD,39.3,"I")
+64 IF FORORD
IF '$$CHKERX^PSOERXU1(PON)
SET VARENEW=1
+65 IF '$GET(VARENEW)
IF RETYPE="RE"
DO UPDSTAT^PSOERXU1(RELIEN,"CXQ","eRx cancelled due to change.")
End DoDot:3
QUIT
+66 SET ACOMACT(ALOOP)=$$CANACT^PSOERXU6(ERXIEN,RXIEN,INST,.PSSRET)
+67 IF $$GET1^DIQ(52.49,RELIEN,.08,"I")'="CX"
Begin DoDot:3
+68 IF $PIECE(ACOMACT(ALOOP),U)=1
DO UPDSTAT^PSOERXU1(RELIEN,"CXQ","eRx cancelled due to change.")
End DoDot:3
End DoDot:2
QUIT
+69 IF PENDIEN
IF 'RXIEN
Begin DoDot:2
+70 ; if this pending item is not for the right patient, quit
+71 IF $GET(PENDIEN)
IF $$GET1^DIQ(52.41,PENDIEN,1,"I")'=NRXVPAT
SET DONE=1
QUIT
+72 SET PREVORD=$$GET1^DIQ(52.41,PENDIEN,22.1,"E")
+73 IF '$GET(PREVORD)
Begin DoDot:3
+74 SET ACOMPEND(ALOOP)=$$CANPEND^PSOERXU6(ERXIEN,PENDIEN,INST,.PSSRET)
End DoDot:3
QUIT
+75 SET ACOMPEND(ALOOP)=$$CANPEND^PSOERXU6(ERXIEN,PENDIEN,INST,.PSSRET)
+76 SET ACOMACT(ALOOP)=$$CANACT^PSOERXU6(ERXIEN,PREVORD,INST,.PSSRET)
+77 IF $$GET1^DIQ(52.49,RELIEN,.08,"I")'="CX"
Begin DoDot:3
+78 IF $PIECE(ACOMPEND(ALOOP),U)=1
IF $$GET1^DIQ(52.49,RELIEN,1,"E")'="CXQ"
DO UPDSTAT^PSOERXU1(RELIEN,"CXQ","eRx cancelled due to change.")
End DoDot:3
End DoDot:2
QUIT
+79 IF $$GET1^DIQ(52.49,RELIEN,.08,"I")'="CX"
DO UPDSTAT^PSOERXU1(RELIEN,"CXQ","eRx cancelled due to change.")
End DoDot:1
+80 ; now check all results for failures
+81 NEW ACTLP,ACTFL,ACTMSG,PENLP,PENFL,PENMSG
+82 SET (ACTLP,ACTFL)=0
FOR
SET ACTLP=$ORDER(ACOMACT(ACTLP))
if 'ACTLP
QUIT
Begin DoDot:1
+83 IF $PIECE(ACOMACT(ACTLP),U)=0
SET ACTFL=ACTFL+1
+84 IF $PIECE(ACOMACT(ACTLP),U)=1
SET ACTMSG(ACTFL)=$PIECE(ACOMACT(ACTLP),U,2)
+85 IF $PIECE(ACOMACT(ACTLP),U)=2
SET DELFLG=1
SET DELTXT=$PIECE(ACOMACT(ACTLP),U,2)
End DoDot:1
+86 SET (PENLP,PENFL)=0
FOR
SET PENLP=$ORDER(ACOMPEND(PENLP))
if 'PENLP
QUIT
Begin DoDot:1
+87 IF $PIECE(ACOMPEND(PENLP),U)=0
SET PENFL=PENFL+1
+88 IF $PIECE(ACOMPEND(PENLP),U)=1
SET PENMSG(PENFL)=$PIECE(ACOMPEND(PENLP),U,2)
End DoDot:1
+89 IF ACTFL>0!(PENFL>0)
Begin DoDot:1
+90 DO UPDSTAT^PSOERXU1(ERXIEN,"CXE","One or more entries associated with this eRx failed to auto-discontinue.")
End DoDot:1
QUIT
+91 QUIT
