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

PSOERXU6.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. Q
  1. ; auto discontinue orders related to cancel request
  1. ; ERXIEN is the IEN of the cancel request
  1. CANDC(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. S CNT=0
  1. S NERXIEN=$$RESOLV^PSOERXU2(ERXIEN)
  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. 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. .I ",RE,CX,"'[$$GET1^DIQ(52.49,RELMIEN,.08,"I") Q
  1. .S REOPIEN=$$GET1^DIQ(52.49,RELMIEN,.13,"I")
  1. .S REPNIEN=$$GET1^DIQ(52.49,RELMIEN,25.2,"E")
  1. .S CNT=CNT+1,ARY(CNT)=REPNIEN_U_REOPIEN_U_RELMIEN
  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)
  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(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(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(NERXIEN,"CAN",$G(ARESP))
  1. ..; if this is a 'deleted' rx, update the status, cancel all related and quit.
  1. ..I $P($G(ACOMACT),U)=2 D Q
  1. ...D UPDSTAT^PSOERXU1(ERXIEN,"CAH",$P($G(ACOMACT),U,2)),CANRELHQ(NERXIEN) Q
  1. ..D UPDSTAT^PSOERXU1(ERXIEN,"CAF",ARESP)
  1. ..D CANRELHQ(NERXIEN)
  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. .; only send the automated response if the auto-dc was successful, and the rx status is not deleted
  1. .I '$G(VARENEW) D POST^PSOERXO1(ERXIEN,.PSSRET,,,,3,INST,ARESP)
  1. .; if there was an error, cancel the related items and quit. we do not want to override the CAX status
  1. .I $D(PSSRET("errorMessage")) D CANRELHQ(NERXIEN),UPDSTAT^PSOERXU1(NERXIEN,"CAN",ARESP) Q
  1. .I RXIEN,$$VARENEW(RXIEN) D Q
  1. ..D UPDSTAT^PSOERXU1(NERXIEN,"CAN","eRx was renewed within the VA.")
  1. ..D UPDSTAT^PSOERXU1(ERXIEN,"CAH","eRx was renewed within the VA.")
  1. ..D CANRELHQ(NERXIEN)
  1. .D UPDSTAT^PSOERXU1(NERXIEN,"CAN",ARESP)
  1. .I '$G(FORORD) D UPDSTAT^PSOERXU1(ERXIEN,"CAO",$G(ARESP))
  1. .I $G(FORORD) D UPDSTAT^PSOERXU1(ERXIEN,"CAH",$G(ARESP))
  1. .D CANRELHQ(NERXIEN)
  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)
  1. .I RXIEN D Q
  1. ..I $G(PENDIEN),$$GET1^DIQ(52.41,PENDIEN,1,"I")=NRXVPAT D Q
  1. ...S ACOMPEND(ALOOP)=$$CANPEND(ERXIEN,PENDIEN,INST,.PSSRET)
  1. ...S ACOMACT(ALOOP)=$$CANACT(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. ..S ACOMACT(ALOOP)=$$CANACT(ERXIEN,RXIEN,INST,.PSSRET)
  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(ERXIEN,PENDIEN,INST,.PSSRET)
  1. ..S ACOMPEND(ALOOP)=$$CANPEND(ERXIEN,PENDIEN,INST,.PSSRET)
  1. ..S ACOMACT(ALOOP)=$$CANACT(ERXIEN,PREVORD,INST,.PSSRET)
  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 $G(DELFLG) D Q
  1. .D UPDSTAT^PSOERXU1(NERXIEN,"CAN",DELTXT)
  1. .D UPDSTAT^PSOERXU1(ERXIEN,"CAH",DELTXT)
  1. .D CANRELHQ(NERXIEN)
  1. I ACTFL>0!(PENFL>0) D Q
  1. .D UPDSTAT^PSOERXU1(NERXIEN,"CAN")
  1. .D UPDSTAT^PSOERXU1(ERXIEN,"CAF")
  1. .D CANRELHQ(NERXIEN)
  1. ; get the last active rx status
  1. I $D(ACTMSG) D
  1. .S LSTMSG=$O(ACTMSG(99999),-1)
  1. .S SENDMSG=$G(ACTMSG(LSTMSG))
  1. I '$D(SENDMSG) D
  1. .S LSTMSG=$O(PENMSG(99999),-1)
  1. .S SENDMSG=$G(PENMSG(LSTMSG))
  1. I '$G(VARENEW) D POST^PSOERXO1(ERXIEN,.PSSRET,,,,3,INST,SENDMSG)
  1. I $G(VARENEW) D UPDSTAT^PSOERXU1(NERXIEN,"CAN","eRx was renewed within the VA.")
  1. I '$G(VARENEW) D UPDSTAT^PSOERXU1(NERXIEN,"CAN",$G(SENDMSG))
  1. ; if there was an error, cancel the related items and quit. we do not want to override the CAX status
  1. I $D(PSSRET("errorMessage")) D CANRELHQ(NERXIEN) Q
  1. I '$G(VARENEW) D UPDSTAT^PSOERXU1(ERXIEN,"CAO")
  1. I $G(VARENEW) D UPDSTAT^PSOERXU1(ERXIEN,"CAH","eRx was renewed within the VA.")
  1. D CANRELHQ(NERXIEN)
  1. Q
  1. CANRELHQ(NERXIEN) ;
  1. N RELMIEN,RRRETYPE
  1. ;I $$GET1^DIQ(52.49,NERXIEN,1,"E")'="CAN" Q
  1. S RELMIEN=0 F S RELMIEN=$O(^PS(52.49,NERXIEN,201,"B",RELMIEN)) Q:'RELMIEN D
  1. .S RRRETYPE=$$GET1^DIQ(52.49,RELMIEN,.08,"I")
  1. .I RRRETYPE="RE"!(RRRETYPE="RR")!(RRRETYPE="CR")!(RRRETYPE="CX") D
  1. ..D UPDSTAT^PSOERXU1(RELMIEN,"CAN")
  1. Q
  1. CANACT(ERXIEN,RXIEN,INST,PSSRET) ;
  1. N NERXIEN,RXSTAT,UPDRXSTAT,ERXIENS,UPDRXSTA,PSOSITE,PSOSYS,PSODFN,ORN,PSOOPT,VALMSG
  1. S ERXIENS=ERXIEN_","
  1. S RXSTAT=$$GET1^DIQ(52,RXIEN,100,"I")
  1. S NERXIEN=$$RESOLV^PSOERXU2(ERXIEN)
  1. I (RXSTAT=12)!(RXSTAT=13)!(RXSTAT=14)!(RXSTAT=15) D Q VALMSG
  1. .S ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN) Q:'ERRSEQ
  1. .I RXSTAT=13 S VALMSG="2^Prescription is already DELETED at the Pharmacy."
  1. .I '$D(VALMSG) S VALMSG="1^Prescription is already discontinued at the Pharmacy."
  1. .D FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$G(VALMSG))
  1. S PSOSITE=$$GET1^DIQ(52,RXIEN,20,"I")
  1. S PSOSYS=$G(^PS(59.7,1,40.1)) Q:PSOSYS="" ""
  1. S PSODFN=$$GET1^DIQ(52,RXIEN,2,"I") Q:'PSODFN ""
  1. S PSOLST(1)=52_U_RXIEN_U_$$GET1^DIQ(52,RXIEN,100,"E")
  1. S ORN=1
  1. S PSOOPT=0
  1. D OERR^PSOCAN3(NERXIEN)
  1. S UPDRXSTA=$$GET1^DIQ(52,RXIEN,100,"I")
  1. I UPDRXSTA'=12,(UPDRXSTA'=14),(UPDRXSTA'=15) D Q VALMSG
  1. .I UPDRXSTA=13 S VALMSG="2^Prescription has been DELETED at the Pharmacy."
  1. .S ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN) Q:'ERRSEQ
  1. .I $L($G(VALMSG)) S VALMSG=0_U_$G(VALMSG)
  1. .I '$L($G(VALMSG)) S VALMSG="0^eRx auto-discontinue failed."
  1. .D FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$G(VALMSG))
  1. S ACOM=$$BLDRESP(RXIEN),ACOM=1_U_ACOM
  1. Q ACOM
  1. ; auto discontinue pending orders related to cancel request
  1. ; ERXIEN - cancel reqeust IEN
  1. ; PENDIEN - IEN for the pending order in file 52.41
  1. CANPEND(ERXIEN,PENDIEN,INST,PSSRET) ;
  1. N ERXIENS,CANTYPE,ERRSEQ,VALMSG,PREVORD,NERXIEN,ORD,ACOM,REFL,TOTFILL,LDDATE,FFILL,PSODFN,PSONOOR,PSODFN,CANTYPEA,ORNUM,PSOPLCK
  1. S ERXIENS=ERXIEN_","
  1. Q:'PENDIEN
  1. Q:'$D(^PS(52.41,PENDIEN,0)) "1^Rx no longer in pending file."
  1. S NERXIEN=$$RESOLV^PSOERXU2(ERXIEN)
  1. S PSODFN=$$GET1^DIQ(52.41,PENDIEN,1,"I")
  1. S PSOPLCK=$$L^PSSLOCK(PSODFN,0)
  1. I '$G(PSOPLCK) D Q ACOM
  1. .D LOCK^PSOORCPY
  1. .S ACOM=$S($P($G(PSOPLCK),"^",2)'="":"Patient record locked by "_$P($G(PSOPLCK),"^",2)_".",1:"Another person is entering orders for this patient.")
  1. .K PSOPLCK S ACOM=0_U_ACOM
  1. S CANTYPE=$$GET1^DIQ(52.41,PENDIEN,2,"I")
  1. ; if this is already DC'd. update status of the releated messages
  1. I CANTYPE="DC"!(CANTYPE="DE") D Q VALMSG
  1. .S ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN) Q:'ERRSEQ
  1. .S VALMSG="1^Pending Order is already discontinued."
  1. .D FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$G(VALMSG))
  1. .D UL^PSSLOCK(PSODFN)
  1. S ACOM="Rx was never dispensed. Canceled at Pharmacy."
  1. S ORD=PENDIEN
  1. S PSONOOR="W"
  1. D DEAD^PSOPTPST
  1. 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)
  1. S $P(^PS(52.41,ORD,0),"^",3)="DC",POERR("PLACER")=$P(^(0),"^"),POERR("STAT")="OC"
  1. 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")
  1. D EN^PSOHLSN(POERR("PLACER"),POERR("STAT"),POERR("COMM"),PSONOOR)
  1. S CANTYPEA=$$GET1^DIQ(52.41,PENDIEN,2,"I")
  1. I CANTYPEA'="DC" D Q VALMSG
  1. .S ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN) Q:'ERRSEQ
  1. .S VALMSG="0^eRx auto-discontinue failed. Please contact Pharmacy."
  1. .D FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$G(VALMSG))
  1. .D UL^PSSLOCK(PSODFN)
  1. K POERR,PSOPTPST
  1. D UL^PSSLOCK(PSODFN)
  1. Q 1_U_ACOM
  1. BLDRESP(RXIEN) ;
  1. N REFL,TOTFILL,LRDATE,FFILL,ACOM
  1. 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
  1. ; p715 Use last release date instead of last dispense date
  1. S LRDATE=$$RXRLDT^PSOBPSUT(RXIEN),LRDATE=$$FMTE^XLFDT(LRDATE,"2D")
  1. S FFILL=$$GET1^DIQ(52,RXIEN,22,"I"),FFILL=$$FMTE^XLFDT(FFILL,"2D")
  1. S ACOM="First Fill:"_FFILL_", Last Fill:"_$S(LRDATE:LRDATE,1:" ")_", Refills Remaining:"_REFL
  1. Q ACOM
  1. ; find the newRx related to a message
  1. FINDNRX(ERXIEN) ;
  1. N DONE,I,PREVIEN
  1. S DONE=0,PREVIEN=0
  1. I '$D(^PS(52.49,ERXIEN,201)) Q 0
  1. F I=1:1 D Q:DONE
  1. .S PREVIEN=$$RESOLV^PSOERXU2(ERXIEN)
  1. .I 'PREVIEN S DONE=1 Q
  1. .I PREVIEN S ERXIEN=PREVIEN
  1. .I $$GET1^DIQ(52.49,PREVIEN,.08,"I")="N" S DONE=1 Q
  1. Q PREVIEN
  1. JTQ(ERXIEN) ;
  1. N MEDA,XQY0,DFN,PATVAL,PSOFIN,POERR,PSOSORT,PTNM,PSODFN,PAT,MTYPE,PSOFINY,PSOLST,MTYPE,RESVAL
  1. N REVLN,HIGHLN,UNDERLN,BLINKLN,HIGUNDLN
  1. D FULL^VALM1
  1. S VALMBCK="R"
  1. I $G(PSOJUMP) S VALMSG="Cannot jump back, please use '^'" W $C(7) Q
  1. S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
  1. S RESVAL=$$GET1^DIQ(52.49,ERXIEN,52.1,"I")
  1. I MTYPE'="N",((MTYPE'="RE")&(RESVAL'="R")),MTYPE'="CX" D Q
  1. .W !,"Jumping can only be done on 'NewRx', 'Renewal Response - Replace' and fillable 'RxChange Response' messages." D DIRE^PSOERXX1 Q
  1. S XQY0="PSO LMOE FINISH"
  1. I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
  1. S DFN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
  1. S PATVAL=$$GET1^DIQ(52.49,ERXIEN,1.14,"I") ;LAL
  1. I 'DFN W !,"Vista patient has not been matched. Cannot jump to outpatient." D DIRE^PSOERXX1 Q
  1. I '$G(PATVAL) W !,"Vista patient has not been validated. Cannot jump to outpatient." D DIRE^PSOERXX1 Q ;LAL
  1. S (PSOFIN,POERR)=1
  1. S PSOSORT="PATIENT"
  1. S PTNM=$$GET1^DIQ(2,DFN,.01,"E")
  1. S (PSODFN,PAT)=DFN,PSOFINY=DFN_U_PTNM
  1. ;PSO*7.0*672: Check for any pending Rx's. Do not restrict based on variable PSNPINST.
  1. ;I '$D(^PS(52.41,"AOR",PAT)) W !,"Patient has no pending prescriptions." D DIRE^PSOERXX1 Q
  1. W !,"Patient: "_PTNM,!
  1. ; new line SPAT2^PSOORFIN has been created to jump right into pending orders with the patient pre-selected
  1. S PSOJUMP=1
  1. D SPAT2^PSOORFIN,EX^PSOORFI1
  1. ;S X=PAT D ULP^PSOORFIN
  1. K PSORX,PSOJUMP
  1. Q
  1. ;
  1. PN(ERXIEN) ; Enter VistA Patient Progress Notes
  1. ;Input: ERXIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
  1. ;
  1. N PSODFN S VALMBCK="R"
  1. S PSODFN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
  1. I 'PSODFN D Q
  1. . S VALMSG="Vista patient has not been matched"
  1. I '$$GET1^DIQ(52.49,+$G(ERXIEN),1.14,"I") D Q
  1. . S VALMSG="Vista patient has not been validated"
  1. ;
  1. D PRONTE^PSOORUT3 S VALMBCK="R"
  1. Q
  1. ;
  1. VARENEW(OPIEN) ;
  1. N FORORD,VARENEW,PON
  1. S VARENEW=0
  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. Q VARENEW
  1. SH(ERXIEN) ;
  1. N SIEN,IENS,F,LINE,SDTTM,ISTAT,ESTAT,EBY,SCOMM,CARY,ALOOP,STDESC,SDAT,UNACC,HFFDT
  1. D FULL^VALM1 S VALMBCK="R"
  1. S $P(LINE,"-",80)="" W !,LINE
  1. S F=52.4919
  1. I '$O(^PS(52.49,ERXIEN,19,0)) W !,"No Status History Available." D DIRE^PSOERXX1 Q
  1. S SIEN=0 F S SIEN=$O(^PS(52.49,ERXIEN,19,SIEN)) Q:'SIEN D
  1. .S IENS=SIEN_","_ERXIEN_","
  1. .D GETS^DIQ(F,IENS,"**","IE","SDAT")
  1. .S SDTTM=$$GET1^DIQ(52.4919,IENS,.01,"I"),SDTTM=$$FMTE^XLFDT(SDTTM,"2Z")
  1. .S ISTAT=$G(SDAT(F,IENS,.02,"I"))
  1. .S ESTAT=$G(SDAT(F,IENS,.02,"E"))
  1. .S STDESC=$$GET1^DIQ(52.45,ISTAT,.02,"E")
  1. .S EBY=$G(SDAT(F,IENS,.03,"E"))
  1. .S UNACC=$G(SDAT(F,IENS,.04,"I"))
  1. .S HFFDT=$G(SDAT(F,IENS,.05,"E"))
  1. .S SCOMM=$G(SDAT(F,IENS,1,"E")),SCOMM="Comments: "_SCOMM
  1. .K CARY
  1. .D TXT2ARY^PSOERXD1(.CARY,SCOMM,,80)
  1. .W !,SDTTM,?19,ESTAT,?26,STDESC_$S(UNACC:" (eRx Un-Accepted)",HFFDT'="":" ("_HFFDT_")",1:""),!,"Entered By: "_EBY ;"Comments: "_SCOMM,!
  1. .S ALOOP=0 F S ALOOP=$O(CARY(ALOOP)) Q:'ALOOP D
  1. ..W !,$G(CARY(ALOOP))
  1. .W !
  1. D DIRE^PSOERXX1
  1. Q
  1. LSIG(SIG) ;
  1. N P,SGY
  1. S SGY="" F P=1:1:$L(SIG," ") S X=$P(SIG," ",P) D:X]"" ;
  1. .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)
  1. .S SGY=SGY_" "_X
  1. Q $$UP^XLFSTR(SGY)