PSOERXU6 ;ALB/BWF - eRx utilities ;Feb 10, 2022@11:04
;;7.0;OUTPATIENT PHARMACY;**508,551,581,631,617,672,715,700,746**;DEC 1997;Build 106
;
Q
; auto discontinue orders related to cancel request
; ERXIEN is the IEN of the cancel request
CANDC(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
S CNT=0
S NERXIEN=$$RESOLV^PSOERXU2(ERXIEN)
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")
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
.I ",RE,CX,"'[$$GET1^DIQ(52.49,RELMIEN,.08,"I") Q
.S REOPIEN=$$GET1^DIQ(52.49,RELMIEN,.13,"I")
.S REPNIEN=$$GET1^DIQ(52.49,RELMIEN,25.2,"E")
.S CNT=CNT+1,ARY(CNT)=REPNIEN_U_REOPIEN_U_RELMIEN
; 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)
.; if there is an associated RXIEN, this is active and the pending item no longer exists.
.I RXIEN D
..S ACOMACT=$$CANACT(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(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(NERXIEN,"CAN",$G(ARESP))
..; if this is a 'deleted' rx, update the status, cancel all related and quit.
..I $P($G(ACOMACT),U)=2 D Q
...D UPDSTAT^PSOERXU1(ERXIEN,"CAH",$P($G(ACOMACT),U,2)),CANRELHQ(NERXIEN) Q
..D UPDSTAT^PSOERXU1(ERXIEN,"CAF",ARESP)
..D CANRELHQ(NERXIEN)
.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)
.; only send the automated response if the auto-dc was successful, and the rx status is not deleted
.I '$G(VARENEW) D POST^PSOERXO1(ERXIEN,.PSSRET,,,,3,INST,ARESP)
.; if there was an error, cancel the related items and quit. we do not want to override the CAX status
.I $D(PSSRET("errorMessage")) D CANRELHQ(NERXIEN),UPDSTAT^PSOERXU1(NERXIEN,"CAN",ARESP) Q
.I RXIEN,$$VARENEW(RXIEN) D Q
..D UPDSTAT^PSOERXU1(NERXIEN,"CAN","eRx was renewed within the VA.")
..D UPDSTAT^PSOERXU1(ERXIEN,"CAH","eRx was renewed within the VA.")
..D CANRELHQ(NERXIEN)
.D UPDSTAT^PSOERXU1(NERXIEN,"CAN",ARESP)
.I '$G(FORORD) D UPDSTAT^PSOERXU1(ERXIEN,"CAO",$G(ARESP))
.I $G(FORORD) D UPDSTAT^PSOERXU1(ERXIEN,"CAH",$G(ARESP))
.D CANRELHQ(NERXIEN)
; 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)
.I RXIEN D Q
..I $G(PENDIEN),$$GET1^DIQ(52.41,PENDIEN,1,"I")=NRXVPAT D Q
...S ACOMPEND(ALOOP)=$$CANPEND(ERXIEN,PENDIEN,INST,.PSSRET)
...S ACOMACT(ALOOP)=$$CANACT(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
..S ACOMACT(ALOOP)=$$CANACT(ERXIEN,RXIEN,INST,.PSSRET)
.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(ERXIEN,PENDIEN,INST,.PSSRET)
..S ACOMPEND(ALOOP)=$$CANPEND(ERXIEN,PENDIEN,INST,.PSSRET)
..S ACOMACT(ALOOP)=$$CANACT(ERXIEN,PREVORD,INST,.PSSRET)
; 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 $G(DELFLG) D Q
.D UPDSTAT^PSOERXU1(NERXIEN,"CAN",DELTXT)
.D UPDSTAT^PSOERXU1(ERXIEN,"CAH",DELTXT)
.D CANRELHQ(NERXIEN)
I ACTFL>0!(PENFL>0) D Q
.D UPDSTAT^PSOERXU1(NERXIEN,"CAN")
.D UPDSTAT^PSOERXU1(ERXIEN,"CAF")
.D CANRELHQ(NERXIEN)
; get the last active rx status
I $D(ACTMSG) D
.S LSTMSG=$O(ACTMSG(99999),-1)
.S SENDMSG=$G(ACTMSG(LSTMSG))
I '$D(SENDMSG) D
.S LSTMSG=$O(PENMSG(99999),-1)
.S SENDMSG=$G(PENMSG(LSTMSG))
I '$G(VARENEW) D POST^PSOERXO1(ERXIEN,.PSSRET,,,,3,INST,SENDMSG)
I $G(VARENEW) D UPDSTAT^PSOERXU1(NERXIEN,"CAN","eRx was renewed within the VA.")
I '$G(VARENEW) D UPDSTAT^PSOERXU1(NERXIEN,"CAN",$G(SENDMSG))
; if there was an error, cancel the related items and quit. we do not want to override the CAX status
I $D(PSSRET("errorMessage")) D CANRELHQ(NERXIEN) Q
I '$G(VARENEW) D UPDSTAT^PSOERXU1(ERXIEN,"CAO")
I $G(VARENEW) D UPDSTAT^PSOERXU1(ERXIEN,"CAH","eRx was renewed within the VA.")
D CANRELHQ(NERXIEN)
Q
CANRELHQ(NERXIEN) ;
N RELMIEN,RRRETYPE
;I $$GET1^DIQ(52.49,NERXIEN,1,"E")'="CAN" Q
S RELMIEN=0 F S RELMIEN=$O(^PS(52.49,NERXIEN,201,"B",RELMIEN)) Q:'RELMIEN D
.S RRRETYPE=$$GET1^DIQ(52.49,RELMIEN,.08,"I")
.I RRRETYPE="RE"!(RRRETYPE="RR")!(RRRETYPE="CR")!(RRRETYPE="CX") D
..D UPDSTAT^PSOERXU1(RELMIEN,"CAN")
Q
CANACT(ERXIEN,RXIEN,INST,PSSRET) ;
N NERXIEN,RXSTAT,UPDRXSTAT,ERXIENS,UPDRXSTA,PSOSITE,PSOSYS,PSODFN,ORN,PSOOPT,VALMSG
S ERXIENS=ERXIEN_","
S RXSTAT=$$GET1^DIQ(52,RXIEN,100,"I")
S NERXIEN=$$RESOLV^PSOERXU2(ERXIEN)
I (RXSTAT=12)!(RXSTAT=13)!(RXSTAT=14)!(RXSTAT=15) D Q VALMSG
.S ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN) Q:'ERRSEQ
.I RXSTAT=13 S VALMSG="2^Prescription is already DELETED at the Pharmacy."
.I '$D(VALMSG) S VALMSG="1^Prescription is already discontinued at the Pharmacy."
.D FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$G(VALMSG))
S PSOSITE=$$GET1^DIQ(52,RXIEN,20,"I")
S PSOSYS=$G(^PS(59.7,1,40.1)) Q:PSOSYS="" ""
S PSODFN=$$GET1^DIQ(52,RXIEN,2,"I") Q:'PSODFN ""
S PSOLST(1)=52_U_RXIEN_U_$$GET1^DIQ(52,RXIEN,100,"E")
S ORN=1
S PSOOPT=0
D OERR^PSOCAN3(NERXIEN)
S UPDRXSTA=$$GET1^DIQ(52,RXIEN,100,"I")
I UPDRXSTA'=12,(UPDRXSTA'=14),(UPDRXSTA'=15) D Q VALMSG
.I UPDRXSTA=13 S VALMSG="2^Prescription has been DELETED at the Pharmacy."
.S ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN) Q:'ERRSEQ
.I $L($G(VALMSG)) S VALMSG=0_U_$G(VALMSG)
.I '$L($G(VALMSG)) S VALMSG="0^eRx auto-discontinue failed."
.D FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$G(VALMSG))
S ACOM=$$BLDRESP(RXIEN),ACOM=1_U_ACOM
Q ACOM
; auto discontinue pending orders related to cancel request
; ERXIEN - cancel reqeust IEN
; PENDIEN - IEN for the pending order in file 52.41
CANPEND(ERXIEN,PENDIEN,INST,PSSRET) ;
N ERXIENS,CANTYPE,ERRSEQ,VALMSG,PREVORD,NERXIEN,ORD,ACOM,REFL,TOTFILL,LDDATE,FFILL,PSODFN,PSONOOR,PSODFN,CANTYPEA,ORNUM,PSOPLCK
S ERXIENS=ERXIEN_","
Q:'PENDIEN
Q:'$D(^PS(52.41,PENDIEN,0)) "1^Rx no longer in pending file."
S NERXIEN=$$RESOLV^PSOERXU2(ERXIEN)
S PSODFN=$$GET1^DIQ(52.41,PENDIEN,1,"I")
S PSOPLCK=$$L^PSSLOCK(PSODFN,0)
I '$G(PSOPLCK) D Q ACOM
.D LOCK^PSOORCPY
.S ACOM=$S($P($G(PSOPLCK),"^",2)'="":"Patient record locked by "_$P($G(PSOPLCK),"^",2)_".",1:"Another person is entering orders for this patient.")
.K PSOPLCK S ACOM=0_U_ACOM
S CANTYPE=$$GET1^DIQ(52.41,PENDIEN,2,"I")
; if this is already DC'd. update status of the releated messages
I CANTYPE="DC"!(CANTYPE="DE") D Q VALMSG
.S ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN) Q:'ERRSEQ
.S VALMSG="1^Pending Order is already discontinued."
.D FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$G(VALMSG))
.D UL^PSSLOCK(PSODFN)
S ACOM="Rx was never dispensed. Canceled at Pharmacy."
S ORD=PENDIEN
S PSONOOR="W"
D DEAD^PSOPTPST
K ^PS(52.41,"AOR",$P(^PS(52.41,ORD,0),"^",2),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD),^PS(52.41,"AD",$P(^PS(52.41,ORD,0),"^",12),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD)
S $P(^PS(52.41,ORD,0),"^",3)="DC",POERR("PLACER")=$P(^(0),"^"),POERR("STAT")="OC"
S POERR("COMM")=$S($G(POERR("DEAD")):"Patient died on "_$G(PSOPTPST(2,PSODFN,.351))_".",1:ACOM),$P(^PS(52.41,ORD,4),"^")=POERR("COMM")
D EN^PSOHLSN(POERR("PLACER"),POERR("STAT"),POERR("COMM"),PSONOOR)
S CANTYPEA=$$GET1^DIQ(52.41,PENDIEN,2,"I")
I CANTYPEA'="DC" D Q VALMSG
.S ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN) Q:'ERRSEQ
.S VALMSG="0^eRx auto-discontinue failed. Please contact Pharmacy."
.D FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$G(VALMSG))
.D UL^PSSLOCK(PSODFN)
K POERR,PSOPTPST
D UL^PSSLOCK(PSODFN)
Q 1_U_ACOM
BLDRESP(RXIEN) ;
N REFL,TOTFILL,LRDATE,FFILL,ACOM
S (REFL,TOTFILL)=$$GET1^DIQ(52,RXIEN,9,"I"),I=0 F S I=$O(^PSRX(RXIEN,1,I)) Q:'I S REFL=REFL-1
; p715 Use last release date instead of last dispense date
S LRDATE=$$RXRLDT^PSOBPSUT(RXIEN),LRDATE=$$FMTE^XLFDT(LRDATE,"2D")
S FFILL=$$GET1^DIQ(52,RXIEN,22,"I"),FFILL=$$FMTE^XLFDT(FFILL,"2D")
S ACOM="First Fill:"_FFILL_", Last Fill:"_$S(LRDATE:LRDATE,1:" ")_", Refills Remaining:"_REFL
Q ACOM
; find the newRx related to a message
FINDNRX(ERXIEN) ;
N DONE,I,PREVIEN
S DONE=0,PREVIEN=0
I '$D(^PS(52.49,ERXIEN,201)) Q 0
F I=1:1 D Q:DONE
.S PREVIEN=$$RESOLV^PSOERXU2(ERXIEN)
.I 'PREVIEN S DONE=1 Q
.I PREVIEN S ERXIEN=PREVIEN
.I $$GET1^DIQ(52.49,PREVIEN,.08,"I")="N" S DONE=1 Q
Q PREVIEN
JTQ(ERXIEN) ;
N MEDA,XQY0,DFN,PATVAL,PSOFIN,POERR,PSOSORT,PTNM,PSODFN,PAT,MTYPE,PSOFINY,PSOLST,MTYPE,RESVAL
N REVLN,HIGHLN,UNDERLN,BLINKLN,HIGUNDLN
D FULL^VALM1
S VALMBCK="R"
I $G(PSOJUMP) S VALMSG="Cannot jump back, please use '^'" W $C(7) Q
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
S RESVAL=$$GET1^DIQ(52.49,ERXIEN,52.1,"I")
I MTYPE'="N",((MTYPE'="RE")&(RESVAL'="R")),MTYPE'="CX" D Q
.W !,"Jumping can only be done on 'NewRx', 'Renewal Response - Replace' and fillable 'RxChange Response' messages." D DIRE^PSOERXX1 Q
S XQY0="PSO LMOE FINISH"
I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
S DFN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
S PATVAL=$$GET1^DIQ(52.49,ERXIEN,1.14,"I") ;LAL
I 'DFN W !,"Vista patient has not been matched. Cannot jump to outpatient." D DIRE^PSOERXX1 Q
I '$G(PATVAL) W !,"Vista patient has not been validated. Cannot jump to outpatient." D DIRE^PSOERXX1 Q ;LAL
S (PSOFIN,POERR)=1
S PSOSORT="PATIENT"
S PTNM=$$GET1^DIQ(2,DFN,.01,"E")
S (PSODFN,PAT)=DFN,PSOFINY=DFN_U_PTNM
;PSO*7.0*672: Check for any pending Rx's. Do not restrict based on variable PSNPINST.
;I '$D(^PS(52.41,"AOR",PAT)) W !,"Patient has no pending prescriptions." D DIRE^PSOERXX1 Q
W !,"Patient: "_PTNM,!
; new line SPAT2^PSOORFIN has been created to jump right into pending orders with the patient pre-selected
S PSOJUMP=1
D SPAT2^PSOORFIN,EX^PSOORFI1
;S X=PAT D ULP^PSOORFIN
K PSORX,PSOJUMP
Q
;
PN(ERXIEN) ; Enter VistA Patient Progress Notes
;Input: ERXIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
;
N PSODFN S VALMBCK="R"
S PSODFN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
I 'PSODFN D Q
. S VALMSG="Vista patient has not been matched"
I '$$GET1^DIQ(52.49,+$G(ERXIEN),1.14,"I") D Q
. S VALMSG="Vista patient has not been validated"
;
D PRONTE^PSOORUT3 S VALMBCK="R"
Q
;
VARENEW(OPIEN) ;
N FORORD,VARENEW,PON
S VARENEW=0
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
Q VARENEW
SH(ERXIEN) ;
N SIEN,IENS,F,LINE,SDTTM,ISTAT,ESTAT,EBY,SCOMM,CARY,ALOOP,STDESC,SDAT,UNACC,HFFDT
D FULL^VALM1 S VALMBCK="R"
S $P(LINE,"-",80)="" W !,LINE
S F=52.4919
I '$O(^PS(52.49,ERXIEN,19,0)) W !,"No Status History Available." D DIRE^PSOERXX1 Q
S SIEN=0 F S SIEN=$O(^PS(52.49,ERXIEN,19,SIEN)) Q:'SIEN D
.S IENS=SIEN_","_ERXIEN_","
.D GETS^DIQ(F,IENS,"**","IE","SDAT")
.S SDTTM=$$GET1^DIQ(52.4919,IENS,.01,"I"),SDTTM=$$FMTE^XLFDT(SDTTM,"2Z")
.S ISTAT=$G(SDAT(F,IENS,.02,"I"))
.S ESTAT=$G(SDAT(F,IENS,.02,"E"))
.S STDESC=$$GET1^DIQ(52.45,ISTAT,.02,"E")
.S EBY=$G(SDAT(F,IENS,.03,"E"))
.S UNACC=$G(SDAT(F,IENS,.04,"I"))
.S HFFDT=$G(SDAT(F,IENS,.05,"E"))
.S SCOMM=$G(SDAT(F,IENS,1,"E")),SCOMM="Comments: "_SCOMM
.K CARY
.D TXT2ARY^PSOERXD1(.CARY,SCOMM,,80)
.W !,SDTTM,?19,ESTAT,?26,STDESC_$S(UNACC:" (eRx Un-Accepted)",HFFDT'="":" ("_HFFDT_")",1:""),!,"Entered By: "_EBY ;"Comments: "_SCOMM,!
.S ALOOP=0 F S ALOOP=$O(CARY(ALOOP)) Q:'ALOOP D
..W !,$G(CARY(ALOOP))
.W !
D DIRE^PSOERXX1
Q
LSIG(SIG) ;
N P,SGY
S SGY="" F P=1:1:$L(SIG," ") S X=$P(SIG," ",P) D:X]"" ;
.N PSOIN S PSOIN=$O(^PS(51,"B",X,0)) I PSOIN,($P(^PS(51,PSOIN,0),"^",4)<2)&($D(^PS(51,"A",X))) S %=^(X),X=$P(%,"^") I $P(%,"^",2)]"" S Y=$P(SIG,"",P-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(%,"^",2)
.S SGY=SGY_" "_X
Q $$UP^XLFSTR(SGY)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXU6 13536 printed Dec 13, 2024@02:29:07 Page 2
PSOERXU6 ;ALB/BWF - eRx utilities ;Feb 10, 2022@11:04
+1 ;;7.0;OUTPATIENT PHARMACY;**508,551,581,631,617,672,715,700,746**;DEC 1997;Build 106
+2 ;
+3 QUIT
+4 ; auto discontinue orders related to cancel request
+5 ; ERXIEN is the IEN of the cancel request
CANDC(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 SET CNT=0
+4 SET NERXIEN=$$RESOLV^PSOERXU2(ERXIEN)
+5 SET NRXVPAT=$$GET1^DIQ(52.49,NERXIEN,.05,"I")
+6 SET NRXOPIEN=$$GET1^DIQ(52.49,NERXIEN,.13,"I")
+7 SET NRXPNIEN=$$GET1^DIQ(52.49,NERXIEN,25.2,"E")
+8 SET CNT=CNT+1
SET ARY(CNT)=NRXPNIEN_U_NRXOPIEN
+9 SET RELMIEN=0
FOR
SET RELMIEN=$ORDER(^PS(52.49,NERXIEN,201,"B",RELMIEN))
if 'RELMIEN
QUIT
Begin DoDot:1
+10 IF ",RE,CX,"'[$$GET1^DIQ(52.49,RELMIEN,.08,"I")
QUIT
+11 SET REOPIEN=$$GET1^DIQ(52.49,RELMIEN,.13,"I")
+12 SET REPNIEN=$$GET1^DIQ(52.49,RELMIEN,25.2,"E")
+13 SET CNT=CNT+1
SET ARY(CNT)=REPNIEN_U_REOPIEN_U_RELMIEN
End DoDot:1
+14 ; if there is only one, it is the NewRx
+15 IF CNT=1
Begin DoDot:1
+16 SET ADAT=$GET(ARY(CNT))
+17 SET PENDIEN=$PIECE(ADAT,U)
SET RXIEN=$PIECE(ADAT,U,2)
+18 ; if there is an associated RXIEN, this is active and the pending item no longer exists.
+19 IF RXIEN
Begin DoDot:2
+20 SET ACOMACT=$$CANACT(ERXIEN,RXIEN,INST,.PSSRET)
+21 SET FORORD=$$GET1^DIQ(52,RXIEN,39.5,"I")
+22 IF FORORD
SET PON=$$GET1^DIQ(52,FORORD,39.3,"I")
+23 IF FORORD
IF '$$CHKERX^PSOERXU1(FORORD)
SET VARENEW=1
End DoDot:2
+24 IF 'RXIEN
IF PENDIEN
Begin DoDot:2
+25 IF $$GET1^DIQ(52.41,PENDIEN,1,"I")'=NRXVPAT
SET DONE=1
QUIT
+26 SET ACOMPEND=$$CANPEND(ERXIEN,PENDIEN,INST,.PSSRET)
End DoDot:2
+27 ; if either failed, update the status and do not send the response
+28 if $GET(DONE)
QUIT
+29 IF $DATA(ACOMACT)
IF '$PIECE(ACOMACT,U)
SET RXFAIL=1
+30 IF $DATA(ACOMPEND)
IF '$PIECE(ACOMPEND,U)
SET PENFAIL=1
+31 IF $GET(RXFAIL)!($GET(PENFAIL))!($PIECE($GET(ACOMACT),U)=2)
Begin DoDot:2
+32 IF $GET(RXFAIL)!($PIECE($GET(ACOMACT),U)=2)
SET ARESP=$PIECE(ACOMACT,U,2)
+33 IF $GET(PENFAIL)
IF '$DATA(ARESP)
SET ARESP=$PIECE($GET(ACOMPEND),U,2)
+34 DO UPDSTAT^PSOERXU1(NERXIEN,"CAN",$GET(ARESP))
+35 ; if this is a 'deleted' rx, update the status, cancel all related and quit.
+36 IF $PIECE($GET(ACOMACT),U)=2
Begin DoDot:3
+37 DO UPDSTAT^PSOERXU1(ERXIEN,"CAH",$PIECE($GET(ACOMACT),U,2))
DO CANRELHQ(NERXIEN)
QUIT
End DoDot:3
QUIT
+38 DO UPDSTAT^PSOERXU1(ERXIEN,"CAF",ARESP)
+39 DO CANRELHQ(NERXIEN)
End DoDot:2
QUIT
+40 IF $DATA(ACOMACT)
IF $PIECE(ACOMACT,U)
SET ARESP=$PIECE(ACOMACT,U,2)
+41 IF '$LENGTH($GET(ARESP))
IF $DATA(ACOMPEND)
IF $PIECE(ACOMPEND,U)
SET ARESP=$PIECE(ACOMPEND,U,2)
+42 ; only send the automated response if the auto-dc was successful, and the rx status is not deleted
+43 IF '$GET(VARENEW)
DO POST^PSOERXO1(ERXIEN,.PSSRET,,,,3,INST,ARESP)
+44 ; if there was an error, cancel the related items and quit. we do not want to override the CAX status
+45 IF $DATA(PSSRET("errorMessage"))
DO CANRELHQ(NERXIEN)
DO UPDSTAT^PSOERXU1(NERXIEN,"CAN",ARESP)
QUIT
+46 IF RXIEN
IF $$VARENEW(RXIEN)
Begin DoDot:2
+47 DO UPDSTAT^PSOERXU1(NERXIEN,"CAN","eRx was renewed within the VA.")
+48 DO UPDSTAT^PSOERXU1(ERXIEN,"CAH","eRx was renewed within the VA.")
+49 DO CANRELHQ(NERXIEN)
End DoDot:2
QUIT
+50 DO UPDSTAT^PSOERXU1(NERXIEN,"CAN",ARESP)
+51 IF '$GET(FORORD)
DO UPDSTAT^PSOERXU1(ERXIEN,"CAO",$GET(ARESP))
+52 IF $GET(FORORD)
DO UPDSTAT^PSOERXU1(ERXIEN,"CAH",$GET(ARESP))
+53 DO CANRELHQ(NERXIEN)
End DoDot:1
QUIT
+54 ; if there is more than one, renewals have occured.
+55 SET ALOOP=99999
SET DONE=0
+56 FOR
SET ALOOP=$ORDER(ARY(ALOOP),-1)
if 'ALOOP!(DONE)
QUIT
Begin DoDot:1
+57 SET ADAT=$GET(ARY(ALOOP))
+58 ; if there is a pending IEN and no RX IEN, we know this has not yet been processed into a live prescription
+59 ; and is a renwewal from a previous prescription.
+60 SET PENDIEN=$PIECE(ADAT,U)
SET RXIEN=$PIECE(ADAT,U,2)
SET RELIEN=$PIECE(ADAT,U,3)
+61 IF RXIEN
Begin DoDot:2
+62 IF $GET(PENDIEN)
IF $$GET1^DIQ(52.41,PENDIEN,1,"I")=NRXVPAT
Begin DoDot:3
+63 SET ACOMPEND(ALOOP)=$$CANPEND(ERXIEN,PENDIEN,INST,.PSSRET)
+64 SET ACOMACT(ALOOP)=$$CANACT(ERXIEN,RXIEN,INST,.PSSRET)
+65 SET FORORD=$$GET1^DIQ(52,RXIEN,39.5,"I")
+66 IF FORORD
SET PON=$$GET1^DIQ(52,FORORD,39.3,"I")
+67 IF FORORD
IF '$$CHKERX^PSOERXU1(PON)
SET VARENEW=1
End DoDot:3
QUIT
+68 SET ACOMACT(ALOOP)=$$CANACT(ERXIEN,RXIEN,INST,.PSSRET)
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(ERXIEN,PENDIEN,INST,.PSSRET)
End DoDot:3
QUIT
+75 SET ACOMPEND(ALOOP)=$$CANPEND(ERXIEN,PENDIEN,INST,.PSSRET)
+76 SET ACOMACT(ALOOP)=$$CANACT(ERXIEN,PREVORD,INST,.PSSRET)
End DoDot:2
QUIT
End DoDot:1
+77 ; now check all results for failures
+78 NEW ACTLP,ACTFL,ACTMSG,PENLP,PENFL,PENMSG
+79 SET (ACTLP,ACTFL)=0
FOR
SET ACTLP=$ORDER(ACOMACT(ACTLP))
if 'ACTLP
QUIT
Begin DoDot:1
+80 IF $PIECE(ACOMACT(ACTLP),U)=0
SET ACTFL=ACTFL+1
+81 IF $PIECE(ACOMACT(ACTLP),U)=1
SET ACTMSG(ACTFL)=$PIECE(ACOMACT(ACTLP),U,2)
+82 IF $PIECE(ACOMACT(ACTLP),U)=2
SET DELFLG=1
SET DELTXT=$PIECE(ACOMACT(ACTLP),U,2)
End DoDot:1
+83 SET (PENLP,PENFL)=0
FOR
SET PENLP=$ORDER(ACOMPEND(PENLP))
if 'PENLP
QUIT
Begin DoDot:1
+84 IF $PIECE(ACOMPEND(PENLP),U)=0
SET PENFL=PENFL+1
+85 IF $PIECE(ACOMPEND(PENLP),U)=1
SET PENMSG(PENFL)=$PIECE(ACOMPEND(PENLP),U,2)
End DoDot:1
+86 IF $GET(DELFLG)
Begin DoDot:1
+87 DO UPDSTAT^PSOERXU1(NERXIEN,"CAN",DELTXT)
+88 DO UPDSTAT^PSOERXU1(ERXIEN,"CAH",DELTXT)
+89 DO CANRELHQ(NERXIEN)
End DoDot:1
QUIT
+90 IF ACTFL>0!(PENFL>0)
Begin DoDot:1
+91 DO UPDSTAT^PSOERXU1(NERXIEN,"CAN")
+92 DO UPDSTAT^PSOERXU1(ERXIEN,"CAF")
+93 DO CANRELHQ(NERXIEN)
End DoDot:1
QUIT
+94 ; get the last active rx status
+95 IF $DATA(ACTMSG)
Begin DoDot:1
+96 SET LSTMSG=$ORDER(ACTMSG(99999),-1)
+97 SET SENDMSG=$GET(ACTMSG(LSTMSG))
End DoDot:1
+98 IF '$DATA(SENDMSG)
Begin DoDot:1
+99 SET LSTMSG=$ORDER(PENMSG(99999),-1)
+100 SET SENDMSG=$GET(PENMSG(LSTMSG))
End DoDot:1
+101 IF '$GET(VARENEW)
DO POST^PSOERXO1(ERXIEN,.PSSRET,,,,3,INST,SENDMSG)
+102 IF $GET(VARENEW)
DO UPDSTAT^PSOERXU1(NERXIEN,"CAN","eRx was renewed within the VA.")
+103 IF '$GET(VARENEW)
DO UPDSTAT^PSOERXU1(NERXIEN,"CAN",$GET(SENDMSG))
+104 ; if there was an error, cancel the related items and quit. we do not want to override the CAX status
+105 IF $DATA(PSSRET("errorMessage"))
DO CANRELHQ(NERXIEN)
QUIT
+106 IF '$GET(VARENEW)
DO UPDSTAT^PSOERXU1(ERXIEN,"CAO")
+107 IF $GET(VARENEW)
DO UPDSTAT^PSOERXU1(ERXIEN,"CAH","eRx was renewed within the VA.")
+108 DO CANRELHQ(NERXIEN)
+109 QUIT
CANRELHQ(NERXIEN) ;
+1 NEW RELMIEN,RRRETYPE
+2 ;I $$GET1^DIQ(52.49,NERXIEN,1,"E")'="CAN" Q
+3 SET RELMIEN=0
FOR
SET RELMIEN=$ORDER(^PS(52.49,NERXIEN,201,"B",RELMIEN))
if 'RELMIEN
QUIT
Begin DoDot:1
+4 SET RRRETYPE=$$GET1^DIQ(52.49,RELMIEN,.08,"I")
+5 IF RRRETYPE="RE"!(RRRETYPE="RR")!(RRRETYPE="CR")!(RRRETYPE="CX")
Begin DoDot:2
+6 DO UPDSTAT^PSOERXU1(RELMIEN,"CAN")
End DoDot:2
End DoDot:1
+7 QUIT
CANACT(ERXIEN,RXIEN,INST,PSSRET) ;
+1 NEW NERXIEN,RXSTAT,UPDRXSTAT,ERXIENS,UPDRXSTA,PSOSITE,PSOSYS,PSODFN,ORN,PSOOPT,VALMSG
+2 SET ERXIENS=ERXIEN_","
+3 SET RXSTAT=$$GET1^DIQ(52,RXIEN,100,"I")
+4 SET NERXIEN=$$RESOLV^PSOERXU2(ERXIEN)
+5 IF (RXSTAT=12)!(RXSTAT=13)!(RXSTAT=14)!(RXSTAT=15)
Begin DoDot:1
+6 SET ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN)
if 'ERRSEQ
QUIT
+7 IF RXSTAT=13
SET VALMSG="2^Prescription is already DELETED at the Pharmacy."
+8 IF '$DATA(VALMSG)
SET VALMSG="1^Prescription is already discontinued at the Pharmacy."
+9 DO FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$GET(VALMSG))
End DoDot:1
QUIT VALMSG
+10 SET PSOSITE=$$GET1^DIQ(52,RXIEN,20,"I")
+11 SET PSOSYS=$GET(^PS(59.7,1,40.1))
if PSOSYS=""
QUIT ""
+12 SET PSODFN=$$GET1^DIQ(52,RXIEN,2,"I")
if 'PSODFN
QUIT ""
+13 SET PSOLST(1)=52_U_RXIEN_U_$$GET1^DIQ(52,RXIEN,100,"E")
+14 SET ORN=1
+15 SET PSOOPT=0
+16 DO OERR^PSOCAN3(NERXIEN)
+17 SET UPDRXSTA=$$GET1^DIQ(52,RXIEN,100,"I")
+18 IF UPDRXSTA'=12
IF (UPDRXSTA'=14)
IF (UPDRXSTA'=15)
Begin DoDot:1
+19 IF UPDRXSTA=13
SET VALMSG="2^Prescription has been DELETED at the Pharmacy."
+20 SET ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN)
if 'ERRSEQ
QUIT
+21 IF $LENGTH($GET(VALMSG))
SET VALMSG=0_U_$GET(VALMSG)
+22 IF '$LENGTH($GET(VALMSG))
SET VALMSG="0^eRx auto-discontinue failed."
+23 DO FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$GET(VALMSG))
End DoDot:1
QUIT VALMSG
+24 SET ACOM=$$BLDRESP(RXIEN)
SET ACOM=1_U_ACOM
+25 QUIT ACOM
+26 ; auto discontinue pending orders related to cancel request
+27 ; ERXIEN - cancel reqeust IEN
+28 ; PENDIEN - IEN for the pending order in file 52.41
CANPEND(ERXIEN,PENDIEN,INST,PSSRET) ;
+1 NEW ERXIENS,CANTYPE,ERRSEQ,VALMSG,PREVORD,NERXIEN,ORD,ACOM,REFL,TOTFILL,LDDATE,FFILL,PSODFN,PSONOOR,PSODFN,CANTYPEA,ORNUM,PSOPLCK
+2 SET ERXIENS=ERXIEN_","
+3 if 'PENDIEN
QUIT
+4 if '$DATA(^PS(52.41,PENDIEN,0))
QUIT "1^Rx no longer in pending file."
+5 SET NERXIEN=$$RESOLV^PSOERXU2(ERXIEN)
+6 SET PSODFN=$$GET1^DIQ(52.41,PENDIEN,1,"I")
+7 SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)
+8 IF '$GET(PSOPLCK)
Begin DoDot:1
+9 DO LOCK^PSOORCPY
+10 SET ACOM=$SELECT($PIECE($GET(PSOPLCK),"^",2)'="":"Patient record locked by "_$PIECE($GET(PSOPLCK),"^",2)_".",1:"Another person is entering orders for this patient.")
+11 KILL PSOPLCK
SET ACOM=0_U_ACOM
End DoDot:1
QUIT ACOM
+12 SET CANTYPE=$$GET1^DIQ(52.41,PENDIEN,2,"I")
+13 ; if this is already DC'd. update status of the releated messages
+14 IF CANTYPE="DC"!(CANTYPE="DE")
Begin DoDot:1
+15 SET ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN)
if 'ERRSEQ
QUIT
+16 SET VALMSG="1^Pending Order is already discontinued."
+17 DO FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$GET(VALMSG))
+18 DO UL^PSSLOCK(PSODFN)
End DoDot:1
QUIT VALMSG
+19 SET ACOM="Rx was never dispensed. Canceled at Pharmacy."
+20 SET ORD=PENDIEN
+21 SET PSONOOR="W"
+22 DO DEAD^PSOPTPST
+23 KILL ^PS(52.41,"AOR",$PIECE(^PS(52.41,ORD,0),"^",2),+$PIECE($GET(^PS(52.41,ORD,"INI")),"^"),ORD),^PS(52.41,"AD",$PIECE(^PS(52.41,ORD,0),"^",12),+$PIECE($GET(^PS(52.41,ORD,"INI")),"^"),ORD)
+24 SET $PIECE(^PS(52.41,ORD,0),"^",3)="DC"
SET POERR("PLACER")=$PIECE(^(0),"^")
SET POERR("STAT")="OC"
+25 SET POERR("COMM")=$SELECT($GET(POERR("DEAD")):"Patient died on "_$GET(PSOPTPST(2,PSODFN,.351))_".",1:ACOM)
SET $PIECE(^PS(52.41,ORD,4),"^")=POERR("COMM")
+26 DO EN^PSOHLSN(POERR("PLACER"),POERR("STAT"),POERR("COMM"),PSONOOR)
+27 SET CANTYPEA=$$GET1^DIQ(52.41,PENDIEN,2,"I")
+28 IF CANTYPEA'="DC"
Begin DoDot:1
+29 SET ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN)
if 'ERRSEQ
QUIT
+30 SET VALMSG="0^eRx auto-discontinue failed. Please contact Pharmacy."
+31 DO FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$GET(VALMSG))
+32 DO UL^PSSLOCK(PSODFN)
End DoDot:1
QUIT VALMSG
+33 KILL POERR,PSOPTPST
+34 DO UL^PSSLOCK(PSODFN)
+35 QUIT 1_U_ACOM
BLDRESP(RXIEN) ;
+1 NEW REFL,TOTFILL,LRDATE,FFILL,ACOM
+2 SET (REFL,TOTFILL)=$$GET1^DIQ(52,RXIEN,9,"I")
SET I=0
FOR
SET I=$ORDER(^PSRX(RXIEN,1,I))
if 'I
QUIT
SET REFL=REFL-1
+3 ; p715 Use last release date instead of last dispense date
+4 SET LRDATE=$$RXRLDT^PSOBPSUT(RXIEN)
SET LRDATE=$$FMTE^XLFDT(LRDATE,"2D")
+5 SET FFILL=$$GET1^DIQ(52,RXIEN,22,"I")
SET FFILL=$$FMTE^XLFDT(FFILL,"2D")
+6 SET ACOM="First Fill:"_FFILL_", Last Fill:"_$SELECT(LRDATE:LRDATE,1:" ")_", Refills Remaining:"_REFL
+7 QUIT ACOM
+8 ; find the newRx related to a message
FINDNRX(ERXIEN) ;
+1 NEW DONE,I,PREVIEN
+2 SET DONE=0
SET PREVIEN=0
+3 IF '$DATA(^PS(52.49,ERXIEN,201))
QUIT 0
+4 FOR I=1:1
Begin DoDot:1
+5 SET PREVIEN=$$RESOLV^PSOERXU2(ERXIEN)
+6 IF 'PREVIEN
SET DONE=1
QUIT
+7 IF PREVIEN
SET ERXIEN=PREVIEN
+8 IF $$GET1^DIQ(52.49,PREVIEN,.08,"I")="N"
SET DONE=1
QUIT
End DoDot:1
if DONE
QUIT
+9 QUIT PREVIEN
JTQ(ERXIEN) ;
+1 NEW MEDA,XQY0,DFN,PATVAL,PSOFIN,POERR,PSOSORT,PTNM,PSODFN,PAT,MTYPE,PSOFINY,PSOLST,MTYPE,RESVAL
+2 NEW REVLN,HIGHLN,UNDERLN,BLINKLN,HIGUNDLN
+3 DO FULL^VALM1
+4 SET VALMBCK="R"
+5 IF $GET(PSOJUMP)
SET VALMSG="Cannot jump back, please use '^'"
WRITE $CHAR(7)
QUIT
+6 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+7 SET RESVAL=$$GET1^DIQ(52.49,ERXIEN,52.1,"I")
+8 IF MTYPE'="N"
IF ((MTYPE'="RE")&(RESVAL'="R"))
IF MTYPE'="CX"
Begin DoDot:1
+9 WRITE !,"Jumping can only be done on 'NewRx', 'Renewal Response - Replace' and fillable 'RxChange Response' messages."
DO DIRE^PSOERXX1
QUIT
End DoDot:1
QUIT
+10 SET XQY0="PSO LMOE FINISH"
+11 IF $PIECE($GET(PSOPAR),"^",2)
IF '$DATA(^XUSEC("PSORPH",DUZ))
SET PSORX("VERIFY")=1
+12 SET DFN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
+13 ;LAL
SET PATVAL=$$GET1^DIQ(52.49,ERXIEN,1.14,"I")
+14 IF 'DFN
WRITE !,"Vista patient has not been matched. Cannot jump to outpatient."
DO DIRE^PSOERXX1
QUIT
+15 ;LAL
IF '$GET(PATVAL)
WRITE !,"Vista patient has not been validated. Cannot jump to outpatient."
DO DIRE^PSOERXX1
QUIT
+16 SET (PSOFIN,POERR)=1
+17 SET PSOSORT="PATIENT"
+18 SET PTNM=$$GET1^DIQ(2,DFN,.01,"E")
+19 SET (PSODFN,PAT)=DFN
SET PSOFINY=DFN_U_PTNM
+20 ;PSO*7.0*672: Check for any pending Rx's. Do not restrict based on variable PSNPINST.
+21 ;I '$D(^PS(52.41,"AOR",PAT)) W !,"Patient has no pending prescriptions." D DIRE^PSOERXX1 Q
+22 WRITE !,"Patient: "_PTNM,!
+23 ; new line SPAT2^PSOORFIN has been created to jump right into pending orders with the patient pre-selected
+24 SET PSOJUMP=1
+25 DO SPAT2^PSOORFIN
DO EX^PSOORFI1
+26 ;S X=PAT D ULP^PSOORFIN
+27 KILL PSORX,PSOJUMP
+28 QUIT
+29 ;
PN(ERXIEN) ; Enter VistA Patient Progress Notes
+1 ;Input: ERXIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
+2 ;
+3 NEW PSODFN
SET VALMBCK="R"
+4 SET PSODFN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
+5 IF 'PSODFN
Begin DoDot:1
+6 SET VALMSG="Vista patient has not been matched"
End DoDot:1
QUIT
+7 IF '$$GET1^DIQ(52.49,+$GET(ERXIEN),1.14,"I")
Begin DoDot:1
+8 SET VALMSG="Vista patient has not been validated"
End DoDot:1
QUIT
+9 ;
+10 DO PRONTE^PSOORUT3
SET VALMBCK="R"
+11 QUIT
+12 ;
VARENEW(OPIEN) ;
+1 NEW FORORD,VARENEW,PON
+2 SET VARENEW=0
+3 SET FORORD=$$GET1^DIQ(52,RXIEN,39.5,"I")
+4 IF FORORD
SET PON=$$GET1^DIQ(52,FORORD,39.3,"I")
+5 IF FORORD
IF '$$CHKERX^PSOERXU1(PON)
SET VARENEW=1
+6 QUIT VARENEW
SH(ERXIEN) ;
+1 NEW SIEN,IENS,F,LINE,SDTTM,ISTAT,ESTAT,EBY,SCOMM,CARY,ALOOP,STDESC,SDAT,UNACC,HFFDT
+2 DO FULL^VALM1
SET VALMBCK="R"
+3 SET $PIECE(LINE,"-",80)=""
WRITE !,LINE
+4 SET F=52.4919
+5 IF '$ORDER(^PS(52.49,ERXIEN,19,0))
WRITE !,"No Status History Available."
DO DIRE^PSOERXX1
QUIT
+6 SET SIEN=0
FOR
SET SIEN=$ORDER(^PS(52.49,ERXIEN,19,SIEN))
if 'SIEN
QUIT
Begin DoDot:1
+7 SET IENS=SIEN_","_ERXIEN_","
+8 DO GETS^DIQ(F,IENS,"**","IE","SDAT")
+9 SET SDTTM=$$GET1^DIQ(52.4919,IENS,.01,"I")
SET SDTTM=$$FMTE^XLFDT(SDTTM,"2Z")
+10 SET ISTAT=$GET(SDAT(F,IENS,.02,"I"))
+11 SET ESTAT=$GET(SDAT(F,IENS,.02,"E"))
+12 SET STDESC=$$GET1^DIQ(52.45,ISTAT,.02,"E")
+13 SET EBY=$GET(SDAT(F,IENS,.03,"E"))
+14 SET UNACC=$GET(SDAT(F,IENS,.04,"I"))
+15 SET HFFDT=$GET(SDAT(F,IENS,.05,"E"))
+16 SET SCOMM=$GET(SDAT(F,IENS,1,"E"))
SET SCOMM="Comments: "_SCOMM
+17 KILL CARY
+18 DO TXT2ARY^PSOERXD1(.CARY,SCOMM,,80)
+19 ;"Comments: "_SCOMM,!
WRITE !,SDTTM,?19,ESTAT,?26,STDESC_$SELECT(UNACC:" (eRx Un-Accepted)",HFFDT'="":" ("_HFFDT_")",1:""),!,"Entered By: "_EBY
+20 SET ALOOP=0
FOR
SET ALOOP=$ORDER(CARY(ALOOP))
if 'ALOOP
QUIT
Begin DoDot:2
+21 WRITE !,$GET(CARY(ALOOP))
End DoDot:2
+22 WRITE !
End DoDot:1
+23 DO DIRE^PSOERXX1
+24 QUIT
LSIG(SIG) ;
+1 NEW P,SGY
+2 ;
SET SGY=""
FOR P=1:1:$LENGTH(SIG," ")
SET X=$PIECE(SIG," ",P)
if X]""
Begin DoDot:1
+3 NEW PSOIN
SET PSOIN=$ORDER(^PS(51,"B",X,0))
IF PSOIN
IF ($PIECE(^PS(51,PSOIN,0),"^",4)<2)&($DATA(^PS(51,"A",X)))
SET %=^(X)
SET X=$PIECE(%,"^")
IF $PIECE(%,"^",2)]""
SET Y=$PIECE(SIG,"",P-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
if Y>1
SET X=$PIECE(%,"^",2)
+4 SET SGY=SGY_" "_X
End DoDot:1
+5 QUIT $$UP^XLFSTR(SGY)
