- 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 Feb 18, 2025@23:55:34 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)