PSOERX1F ;ALB/MR - Accept/Un-Accept eRx function ; 8/18/2020 5:14pm
;;7.0;OUTPATIENT PHARMACY;**617,651,700**;DEC 1997;Build 261
;
Q
;PSOHY("LOC")=IEN of hospital location file (#44) - NOT USED,
;PSOHY("CHNUM")=EXTERNAL PLACER ORDER NUMBER (NEED TO FIND OUT HOW WE SHOULD SET THIS) (25)
;PSOHY("PICK")=MAIL/WINDOW (20.4)
;PSOHY("ENTER")=ENTERED BY IEN (2.1)
;PSOHY("PROV")=PROVIDER IEN (2.3)
;PSOHY("SDT")=EFFECTIVE DATE (6.3)
;PSOHY("ITEM")=PHARMACY ORDERABLE ITEM (DERIVED FROM THE DRUG IEN) - NO MAPPING TO 52.49
;PSOHY("DRUG")=DRUG IEN (3.2)
;PSOHY("QTY")=QUANTITY (20.1)
;PSOHY("REF")=# OF REFILLS (20.5)
;PSOHY("PAT")=PATIENT IEN (.05)
;PSOHY("OCC")=ORDER TYPE (ALWAYS 'NW') - NO MAPPING TO 52.49
;PSOHY("EDT")=LOGIN DATE/TIME (ERX MSG DATE/TIME #.03)
;PSOHY("PRIOR")=PRIORITY (SET OF CODES, 52.41,25 - STAT, EMERGENCY, ROUTINE)
;PSOHY("EXAPP")=EXTERNAL APPLICATION (FREE TEXT), LIKELY "PSO" - NO MAPPING TO 52.49
;PSOHY("PRCOM",#)=PROVIDER COMMENTS (8- NOTES)
;PSOHY("SIG",#)=SIG (52.4911 (STRUCTURED SIG), FIELD 1 (SIG FREE TEXT)
;PSOHY("QTSUB",CNT)=QUANTITY TIMING SUBFILE DATA. MERGED IN, FULL SUBFILE DATA
; QUANTITY/TIMING MAPS DIRECTLY TO QUANTITY TIMING IN 52.41
SETUP ;
N MBMSITE,PSOIENS,PSODAT,F,PATIEN,PROVIEN,OC,VQTY,EFFDT,VADRUG,VAOI,VAREF,VAROUT,VAPRIOR,PSOHY,LOC,ERXNUM,PRVARY,PRVCOMM
N PLOOP,PCNT,QTLOOP,QTCNT,PSOEXMS,DIR,ORDERTYP,PSOEXCNT,SCNT,SIGDAT,SLOOP,POORD,PMVAL,PRMVAL,DMVAL,PATINST,RXSTAT
N VADAYS,UNEXPI,PINARY,WRITDT,SLOOP2,MTYPE,REQIEN,ORXIEN,RESTYPE,DELTAS,RXIEN,ERXMSG,I,CSERRMSG,PSOQUIT,DIC
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
S F=52.49
Q:'$G(PSOIEN)
D FULL^VALM1 I MBMSITE S VALMBCK="R"
I $$DONOTFIL^PSOERXUT(PSOIEN) Q
S RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
I RXSTAT="RJ"!(RXSTAT="RM")!($E(RXSTAT,1,3)="REM")!(RXSTAT="PR")!(RXSTAT="CXP")!(RXSTAT="RXP") D Q
. W !!,"Cannot accept a prescription with a status of 'Rejected', 'Removed',",!,"or 'Processed",!
. S DIR(0)="E" D ^DIR
S PSOIENS=PSOIEN_","
D GETS^DIQ(F,PSOIENS,".01;.05;.07;.08;1;1.3;1.5;1.7;2.1;2.3;3.2;5.9;6.2;6.3;8;20.1;20.2;20.4;20.5;20.6;25;25.2;27;30;52.1","IE","PSODAT")
S PSOEXCNT=0
S MTYPE=$G(PSODAT(F,PSOIENS,.08,"I"))
S RESTYPE=$G(PSODAT(F,PSOIENS,52.1,"I"))
I MTYPE="RE",RESTYPE'="R" D Q
.S REQIEN=$$GETREQ^PSOERXU2(PSOIEN)
.I REQIEN S RXIEN=$$GET1^DIQ(52.49,REQIEN,.13,"I")
.D PREFRES^PSOERXU3(PSOIEN,.PSOHY,.PSOEXCNT,.PSOEXMS,.PSODAT)
.D RRDELTA^PSOERXU2(.DELTAS,REQIEN,PSOIEN)
.I $O(PSOEXMS(0)),RESTYPE="AWC",$D(DELTAS(52.49,"EXTERNAL PROVIDER")) D Q
..D MSGDIR^PSOERXU1(.PSOEXMS)
.I $O(PSOEXMS(0)),$E(RESTYPE)="A",'$D(DELTAS(52.49,"EXTERNAL PROVIDER")) D Q
..D UPDSTAT^PSOERXU1(PSOIEN,"RXF","Unable to add order to Pending file.") Q
.I $D(DELTAS(52.49,"EXTERNAL PROVIDER")) D ADD Q
.; call using silent mode if this is auto-processing
.D ADD(1)
S ERXSTA=$G(PSODAT(F,PSOIENS,1,"E")) I ERXSTA="E"!($E(ERXSTA)="H") S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="eRx is in a 'Hold' status." D MSGDIR^PSOERXU1(.PSOEXMS) Q
I MTYPE="N"!(MTYPE="RE"&(RESTYPE="R")!(MTYPE="CX")) D
.S PMVAL=$G(PSODAT(F,PSOIENS,1.7,"I")) I 'PMVAL S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Patient has not been manually validated."
.S PRMVAL=$G(PSODAT(F,PSOIENS,1.3,"I")) I 'PRMVAL S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Provider has not been manually validated."
.S DMVAL=$G(PSODAT(F,PSOIENS,1.5,"I")) I 'DMVAL S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Drug has not been manually validated."
; for now, if validations have not occurred, do not check the other fields.
I $O(PSOEXMS(0)) D MSGDIR^PSOERXU1(.PSOEXMS) Q
; CS eRx Validations
D PRDRVAL^PSOERXUT(.CSERRMSG,"AC",PSOIEN)
I '$G(CSERRMSG),$P(CSERRMSG,"^",2)="B" D MSGDIR^PSOERXU1(.CSERRMSG) Q
I $$GET1^DIQ(52.49,PSOIEN,95.1,"I"),'$$VALPTADD^PSOERXUT(+$G(PSODAT(F,PSOIENS,.05,"I"))) D Q
. S CSERRMSG(1)="Patient does not have a current mailing or residential address on file."
. D MSGDIR^PSOERXU1(.CSERRMSG)
;
S POORD=$G(PSODAT(F,PSOIENS,25.2,"I")) I POORD S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Pending outpatient order already exists."
S PATIEN=$G(PSODAT(F,PSOIENS,.05,"I")) I 'PATIEN S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="No matched vista patient."
S PROVIEN=$G(PSODAT(F,PSOIENS,2.3,"I")) I 'PROVIEN S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Provider not matched to a vista provider."
S VADRUG=$G(PSODAT(F,PSOIENS,3.2,"I")) I 'VADRUG S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Drug not matched to a vista drug."
S ERXNUM=$G(PSODAT(F,PSOIENS,.01,"E")) I 'ERXNUM S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="eRx number missing."
S VQTY=$G(PSODAT(F,PSOIENS,20.1,"E")) I 'VQTY S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Quantity missing."
S EFFDT=$G(PSODAT(F,PSOIENS,6.3,"I")),WRITDT=$G(PSODAT(F,PSOIENS,5.9,"I"))
S LOC=$G(PSODAT(F,PSOIENS,20.6,"I")) I 'LOC S LOC=$$GET1^DIQ(59,PSOSITE,10,"I")
; if the effective date is passed in and there is no time, add .000001 to the date
I EFFDT]"" S EFFDT=$P(EFFDT,".")
I '$L(EFFDT) S EFFDT=WRITDT
S VADAYS=$G(PSODAT(F,PSOIENS,20.2,"E"))
S VAOI=$$GET1^DIQ(50,VADRUG,2.1,"I") I 'VAOI S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Orderable item not associated with drug."
S VAREF=$G(PSODAT(F,PSOIENS,20.5,"E"))
S VAROUT=$G(PSODAT(F,PSOIENS,20.4,"I")) I '$L(VAROUT) S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Pickup routing missing."
S PATINST=$G(PSODAT(F,PSOIENS,27,"E"))
; CALL TO AVOID SPACE CONCATENATION
D TXT2ARY^PSOERXD1(.PINARY,$$LSIG^PSOERXU6(PATINST))
; get provider comments from VA PROVIDER COMMENTS field
S PRVCOMM=$G(PSODAT(F,PSOIENS,30,"E"))
D TXT2ARY^PSOERXD1(.PRVARY,$$LSIG^PSOERXU6(PRVCOMM))
S (PLOOP,PCNT)=0 F S PLOOP=$O(PRVARY(PLOOP)) Q:'PLOOP D
.S PCNT=PCNT+1,PSOHY("PRCOM",PCNT)=$G(PRVARY(PLOOP))
I '$O(^PS(52.49,PSOIEN,21,0)) S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Dosing information missing."
S (QTLOOP,QTCNT)=0 F S QTLOOP=$O(^PS(52.49,PSOIEN,21,QTLOOP)) Q:'QTLOOP D
.S QTCNT=QTCNT+1 M PSOHY("QTSUB",QTCNT)=^PS(52.49,PSOIEN,21,QTLOOP)
;
; Assigning Clinic which the User is logged into
S PSOQUIT=0
I $G(MBMSITE),+$$GET1^DIQ(52.49,PSOIEN,20.6,"I")'=+$G(PSOCLNC) D I $G(PSOQUIT) Q
. W !!,"Current Clinic assigned to the eRx: ",$$GET1^DIQ(52.49,PSOIEN,20.6),!
. K DIC S DIC(0)="AEMQ",DIC=44,DIC("S")="I '$P($G(^(""I"")),U,1)!$P($G(^(""I"")),U,2)"
. S DIC("A")="Send to eRx Clinic: "
. I $G(PSOCLNC) S DIC("B")=$$GET1^DIQ(44,PSOCLNC,.01)
. D ^DIC I Y="^"!$D(DTOUT)!$D(DUOUT) S PSOQUIT=1 Q
. I $G(Y)>0 S LOC=+Y
; always 'routine' for now
S VAPRIOR="R"
; always 'new' for this version
I '$L($G(ORDERTYP)) S ORDERTYP="NW"
S PSOHY("LOC")=LOC,PSOHY("CHNUM")=$G(ERXNUM)
S PSOHY("PICK")=VAROUT ;,PSOHY("ENTER")=PROVIEN
S PSOHY("ENTER")=DUZ
S PSOHY("PROV")=PROVIEN,PSOHY("SDT")=EFFDT
S PSOHY("ITEM")=VAOI,PSOHY("DRUG")=VADRUG
S PSOHY("QTY")=VQTY,PSOHY("REF")=VAREF
S (PSOHY("PAT"),DFN)=PATIEN,PSOHY("OCC")=ORDERTYP
; Login date will always be the Message Received Date/Time
S PSOHY("EDT")=$$GET1^DIQ(52.49,PSOIEN,.03,"I"),PSOHY("PRIOR")=VAPRIOR
; ALWAYS PSO as the external application
S PSOHY("EXAPP")="PHARMACY"
S PSOHY("DAYS")=VADAYS
; sig from eRx
S (SLOOP,SCNT)=0 F S SLOOP=$O(^PS(52.49,PSOIEN,"SIG",SLOOP)) Q:'SLOOP D
.S SIGDAT=$G(^PS(52.49,PSOIEN,"SIG",SLOOP,0))
.S SCNT=SCNT+1,PSOHY("SIG",SCNT)=SIGDAT
S SLOOP2=0 F S SLOOP2=$O(PINARY(SLOOP2)) Q:'SLOOP2 D
.S SCNT=SCNT+1,PSOHY("SIG",SCNT)=$G(PINARY(SLOOP2))
; if provider, patient or drug is missing, no need to continue.
D ADD
I $G(PSOEXMS)]"" W !,PSOEXMS S DIR(0)="E" D ^DIR K DIR
K DFN
Q
ADD(QUIET) ;Add CHCS message to Outpatient Pending Orders file
N MBMSITE,PSOHQ,PSOHQT,PSOCPEND,PSOHINI,PSOHINLO,ERXSTA,ORDNUM,ILOOP,IARY,PSSRET
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
I '$G(PSOHY("DRUG")) D Q
. S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Invalid Dispense Drug" Q
S (PSOHINI,PSOHINLO)=0 D
.I $G(PSOHY("LOC")) S PSOHINLO=$P($G(^SC(PSOHY("LOC"),0)),"^",4) I PSOHINLO Q
; get institution from 52.49 if clinic was not passed in
S RESTYPE=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
I $G(PSOHINLO)<1 S PSOHINLO=$$GET1^DIQ(52.49,PSOIEN,24.1,"I")
I +$G(PSOHINLO)<1 S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Unable to derive Institution from Clinic." Q
K DD,DO,DIC S X=PSOHY("CHNUM"),DIC="^PS(52.41,",DIC(0)="L"
S:$G(PSOHY("PICK"))="" PSOHY("PICK")="M"
S DIC("DR")="4////"_$G(PSOHY("ENTER"))_";5////"_PSOHY("PROV")_";6////"_$G(PSOHY("SDT"))_";8////"_PSOHY("ITEM")_";11////"_PSOHY("DRUG")
S DIC("DR")=$G(DIC("DR"))_";12////"_$G(PSOHY("QTY"))_";13////"_$G(PSOHY("REF"))_";22.1////"_$G(PSOHY("PREVORD"))_";101////"_$G(PSOHY("DAYS"))
D FILE^DICN K DD,DIC,DO I Y<0 D Q
.S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Unable to add order to Pending file."
.I MTYPE="RE" D UPDSTAT^PSOERXU1(PSOIEN,"RXF",PSOEXMS(PSOEXCNT))
.S REQIEN=$$GETREQ^PSOERXU2(PSOIEN) I REQIEN D UPDSTAT^PSOERXU1(PSOIEN,"RRF",PSOEXMS)
S PSOCPEND=+Y
S $P(^PS(52.41,PSOCPEND,0),"^",2)=PSOHY("PAT"),$P(^(0),"^",3)=PSOHY("OCC"),$P(^(0),"^",12)=$G(PSOHY("EDT")),$P(^(0),"^",13)=$G(PSOHY("LOC"))
S $P(^PS(52.41,PSOCPEND,0),"^",14)=$G(PSOHY("PRIOR")),$P(^(0),"^",17)=$G(PSOHY("PICK"))
S $P(^PS(52.41,PSOCPEND,"EXT"),"^")=PSOHY("CHNUM"),$P(^("EXT"),"^",2)=0,$P(^("EXT"),"^",3)=PSOHY("EXAPP")
S DIE="^PS(52.41,",DA=PSOCPEND,DR="104.1///1" D ^DIE K DIE,DA,DR
; PSO*7*506
S FDA(52.41,PSOCPEND_",",104)=$G(PATINST) D FILE^DIE(,"FDA") K FDA
N DA,DIK S DA=PSOCPEND,DIK="^PS(52.41,",DIK(1)="114^C" D EN1^DIK
I $O(PSOHY("PRCOM",0)) D I PSOHQT S ^PS(52.41,PSOCPEND,3,0)="^^"_PSOHQT_"^"_PSOHQT_"^"_DT_"^"
.S PSOHQ="",PSOHQT=0 F S PSOHQ=$O(PSOHY("PRCOM",PSOHQ)) Q:PSOHQ="" I $G(PSOHY("PRCOM",PSOHQ))'="" S PSOHQT=PSOHQT+1,^PS(52.41,PSOCPEND,3,PSOHQT,0)=$G(PSOHY("PRCOM",PSOHQ))
I $O(PSOHY("SIG",0)) D I PSOHQT S ^PS(52.41,PSOCPEND,"SIG",0)="^52.4124A^"_PSOHQT_"^"_PSOHQT
.S PSOHQ="",PSOHQT=0 F S PSOHQ=$O(PSOHY("SIG",PSOHQ)) Q:PSOHQ="" I $G(PSOHY("SIG",PSOHQ))'="" S PSOHQT=PSOHQT+1,^PS(52.41,PSOCPEND,"SIG",PSOHQT,0)=$G(PSOHY("SIG",PSOHQ))
S $P(^PS(52.41,PSOCPEND,"INI"),"^")=$G(PSOHINLO)
; add quantity/timing subfile information
I $O(PSOHY("QTSUB",0)) D I PSOHQT S ^PS(52.41,PSOCPEND,1,0)="^52.413^"_PSOHQT_"^"_PSOHQT
.S PSOHQ="",PSOHQT=0 F S PSOHQ=$O(PSOHY("QTSUB",PSOHQ)) Q:PSOHQ="" D
..I $O(PSOHY("QTSUB",PSOHQ,0)) S PSOHQT=PSOHQT+1
..S ^PS(52.41,PSOCPEND,1,PSOHQT,0)=PSOHY("QTSUB",PSOHQ,0)
..S ^PS(52.41,PSOCPEND,1,PSOHQT,1)=PSOHY("QTSUB",PSOHQ,1)
..S ^PS(52.41,PSOCPEND,1,PSOHQT,2)=PSOHY("QTSUB",PSOHQ,2)
I $O(PINARY(0)) D WP^DIE(52.41,PSOCPEND_",",105,"K","PINARY")
;Cross references not set yet preventing Pharmacy from finishing order
D EN^PSOHLSNC(PSOCPEND,"SN","IP")
D FULL^VALM1
;Just set to DC, don't delete because 52.41 entry would be re-used
I '$P($G(^PS(52.41,PSOCPEND,"EXT")),"^",2) D S $P(^PS(52.41,PSOCPEND,0),"^",3)="DC" S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="Unable to send CHCS order to CPRS." Q
.;x-ref shouldn't be set, but we'll kill them just in case
.K ^PS(52.41,"AOR",$P(^PS(52.41,PSOCPEND,0),"^",2),+$P($G(^("INI")),"^"),PSOCPEND),^PS(52.41,"AD",$P(^PS(52.41,PSOCPEND,0),"^",12),+$P($G(^("INI")),"^"),PSOCPEND)
.K ^PS(52.41,"ACL",+$P(^PS(52.41,PSOCPEND,0),"^",13),$P(^(0),"^",12),PSOCPEND),^PS(52.41,"AQ",+$P($G(^PS(52.41,PSOCPEND,0)),"^",21),PSOCPEND)
.S $P(^PS(52.41,PSOCPEND,4),"^")="External order, unable to successfully transmit to CPRS."
.I $D(QUIET) S PSOEXCNT=PSOEXCNT+1,PSOEXMS(PSOEXCNT)="External order, unable to successfully transmit to CPRS."
.I '$D(QUIET) W !!,"External order, unable to successfully transmit to CPRS."
.I '$D(QUIET) S DIR(0)="E" D ^DIR
;Successful transmission to CPRS
S DA=PSOCPEND,DIK="^PS(52.41," D IX^DIK
; add the pending outpatient order number to 52.49 and update status of eRx to PR (Processed)
S ERXSTA=$O(^PS(52.45,"C","ERX","PR",0))
S ORDNUM=$P($G(^PS(52.41,PSOCPEND,0)),U)
S DIE="^PS(52.49,",DR="25.2///"_PSOCPEND_";.12///"_ORDNUM,DA=PSOIEN D ^DIE K DIE,DA,DR
; PSO*7*508 - add checks to update refill requests and responses
; add activity to status history
I MTYPE="N" D UPDSTAT^PSOERXU1(PSOIEN,"PR")
I MTYPE="RE" D UPDSTAT^PSOERXU1(PSOIEN,"RXP")
;B3S4
I MTYPE="CX" D
.D UPDSTAT^PSOERXU1(PSOIEN,"CXP")
.S RTHID=$$GET1^DIQ(52.49,PSOIEN,.14),RTHIEN=$O(^PS(52.49,"FMID",RTHID,0))
.D UPDSTAT^PSOERXU1(RTHIEN,"CRP")
S REQIEN=$$GETREQ^PSOERXU2(PSOIEN) I REQIEN,$$GET1^DIQ(52.49,REQIEN,.08,"I")="RR" D UPDSTAT^PSOERXU1(REQIEN,"RRP")
; PSO*7*508 - end
;
; Saves the Actual eRx SIG (from outside provider) into the PROVIDER COMMENTS field (P-651/14)
N UNEXINS S UNEXINS(1)=$$ERXSIG^PSOERXUT(PSOIEN)
I $L($G(UNEXINS(1))) D WP^DIE(52.41,PSOCPEND_",",9,"K","UNEXINS")
;
I '$D(QUIET) D
. W !!,"eRx #"_PSOHY("CHNUM")_" sent to PENDING ORDERS Queue."
. W:$G(MBMSITE) " (Clinic: "_$$GET1^DIQ(44,+$G(PSOHY("LOC")),.01)_")"
;PSO*7*520 - add sending and warning/information related to RxVerify Message.
I '$$UNACCBEF(PSOIEN),MTYPE="N"!((MTYPE="RE")&(RESTYPE="R"))!(MTYPE="CX") D
.W !!,"Sending rxVerify Message to prescriber."
.D POST^PSOERXO1(PSOIEN,.PSSRET,,,,1)
.; if the post was unsuccessful, inform the user and quit.
.I $P(PSSRET(0),U)<1 W !,$P(PSSRET(0),U,2) S DIR(0)="E" D ^DIR K DIR Q
.I $D(PSSRET("errorMessage")) W !,PSSRET("errorMessage") S DIR(0)="E" D ^DIR K DIR Q
;PSO*7*520 - end rxVerify changes
;
K QUIET
Q
;
UNACC ; Un-Accept eRx from Pending Queue back into the Holding Queue
N ORDNUM,ERXIEN,PSOIEN,DIE,DA,DR,DIC,PSOHOLD,PSOQUIT,DIR,X,Y,DTOUT,DUOUT,HOLDCOMM,POERR
S VALMBCK="R"
I '$G(ORD)!'$D(^PS(52.41,+$G(ORD),0)) S VALMSG="Invalid Pending Order" W $C(7) Q
I $$GET1^DIQ(52.41,ORD,2,"I")'="NW" S VALMSG="eRx has already been finished or un-accepted." W $C(7) Q
S ORDNUM=$$GET1^DIQ(52.41,+ORD,.01) I 'ORDNUM S VALMSG="Invalid Pending Order" W $C(7) Q
S (ERXIEN,PSOIEN)=$$CHKERX^PSOERXU1(ORDNUM) I 'PSOIEN S VALMSG="This Pending Order is not related to an eRx" W $C(7) Q
I '$G(ERXIEN) S VALMSG="This is not an eRx Prescription" W $C(7) Q
D FULL^VALM1
;
K DIC W ! S DIC("A")="Select HOLD reason code: "
S DIC="^PS(52.45,",DIC(0)="AEMQ",DIC("B")="HOLD FOR RX EDIT"
S DIC("S")="I $D(^PS(52.45,""TYPE"",""ERX"",Y)),$E($P(^PS(52.45,Y,0),U),1)=""H"""
S (PSOHOLD,PSOQUIT)=0
F D ^DIC D I PSOHOLD!PSOQUIT Q
. I $G(DUOUT)!$G(DTOUT) S PSOQUIT=1 Q
. I X="" W !,"HOLD Reason is required",!,$C(7) Q
. S PSOHOLD=Y
I PSOQUIT Q
;
K DIR S DIR(0)="52.4919,1",DIR("A")="Comments (Optional)"
D ^DIR K DIR I Y="^" Q
S HOLDCOMM=$G(Y)
;
K DIR W ! S DIR("A",1)="This eRx will be Un-Accepted and sent back to the eRx Holding Queue."
S DIR("A",2)="",DIR("A")="Confirm",DIR(0)="Y",DIR("B")="N"
D ^DIR I $G(DIRUT)!$G(DUOUT)!'Y Q
W ?40,"Please wait..."
;
; Chaning eRx Order Status to Hold
D UPDSTAT^PSOERXU1(ERXIEN,$P(PSOHOLD,"^",2),HOLDCOMM,1)
; Removing pointer to the Pending Order entry
I $P($G(^PS(52.49,ERXIEN,25)),"^",2) S $P(^PS(52.49,ERXIEN,25),"^",2)=""
;
Q:'$D(^PS(52.41,ORD,0))
K ^PS(52.41,"AOR",$P(^PS(52.41,ORD,0),"^",2),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD)
K ^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")="eRx Un-Accepted: "_$$GET1^DIQ(52.45,+PSOHOLD,.02)_$S(HOLDCOMM'="":" - "_HOLDCOMM,1:"")
S $P(^PS(52.41,ORD,4),"^")=POERR("COMM")
D EN^PSOHLSN(POERR("PLACER"),POERR("STAT"),POERR("COMM"),"W")
;
W !!,"eRx successfully un-accepted and placed back on the eRx Holding Queue."
K DIR D PAUSE^VALM1
;
D JUMP2ERX K VALMBCK
Q
;
JUMP2ERX ; Jump to the eRx Holding Queue for the specific order after Un-Accepting eRx
N ORDNUM,PSOIEN,ERXIEN
D FULL^VALM1
S VALMBCK="R"
I $G(PSOJUMP) S VALMSG="Cannot jump back to the Holding Queue, use ^" W $C(7) Q
S ORDNUM=+$$ORDNUM() I 'ORDNUM S VALMSG="Invalid Order" W $C(7) Q
S (ERXIEN,PSOIEN)=$$CHKERX^PSOERXU1(ORDNUM) I 'PSOIEN S VALMSG="This Order is not related to an eRx" W $C(7) Q
X "N (DUZ,IO,U,DT,DILOCKTM,DTIME,PSOIEN,ERXIEN,PSOSITE,PSOJUMP,PSNPINST)"
K ^TMP("PSOERXPO",$J) M ^TMP("PSOERXPO",$J)=^TMP("XQORS",$J)
S PSOJUMP=1
D EN^VALM("PSO ERX HQ DISPLAY")
K ^TMP("XQORS",$J) M ^TMP("XQORS",$J)=^TMP("PSOERXPO",$J)
S PSOJUMP=0
Q
;
ORDNUM() ; Returns the correct IEN for the ORDER file (#100) for the Rx
I $P(XQY0,"^")="PSO LM BACKDOOR ORDERS"!($P(XQY0,"^")="PSO LMOE FINISH"),$P(VALMKEY,"^",2)="PSO HIDDEN ACTIONS",$G(RXN) Q +$$GET1^DIQ(52,RXN,39.3,"I")
I $P(XQY0,"^")="PSO LM BACKDOOR ORDERS"!($P(XQY0,"^")="PSO LMOE FINISH")!($P(XQY0,"^")="PSO PMP"),$P(VALMKEY,"^",2)="PSO HIDDEN ACTIONS #3"!($P(VALMKEY,"^",2)="PSO HIDDEN ACTIONS #4"),$G(ORD) Q +$$GET1^DIQ(52.41,+ORD,.01)
I $P(XQY0,"^")="PSO VIEW"!($P(XQY0,"^")="PSO PMP"),$P(VALMKEY,"^",2)="PSO PMP HIDDEN ACTIONS MENU #2",$G(RXN) Q +$$GET1^DIQ(52,RXN,39.3,"I")
Q 0
;
UNACCBEF(ERXIEN) ; Determines if the eRx has been Un-Accepted Before
; Input: (r)ERXIEN - Pointer to ERX HOLDING QUEUE (#52.49)
;Output: 1 - eRx has been Un-Accepted Before | 0 - Exclude the eRx
N UNACCBEF,STSHST
S UNACCBEF=0
S STSHST=9999 F S STSHST=$O(^PS(52.49,ERXIEN,19,STSHST),-1) Q:'STSHST D I UNACCBEF Q
. S UNACCBEF=+$$GET1^DIQ(52.4919,STSHST_","_ERXIEN,.04,"I")
Q UNACCBEF
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERX1F 17352 printed Apr 09, 2024@21:38:15 Page 2
PSOERX1F ;ALB/MR - Accept/Un-Accept eRx function ; 8/18/2020 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**617,651,700**;DEC 1997;Build 261
+2 ;
+3 QUIT
+4 ;PSOHY("LOC")=IEN of hospital location file (#44) - NOT USED,
+5 ;PSOHY("CHNUM")=EXTERNAL PLACER ORDER NUMBER (NEED TO FIND OUT HOW WE SHOULD SET THIS) (25)
+6 ;PSOHY("PICK")=MAIL/WINDOW (20.4)
+7 ;PSOHY("ENTER")=ENTERED BY IEN (2.1)
+8 ;PSOHY("PROV")=PROVIDER IEN (2.3)
+9 ;PSOHY("SDT")=EFFECTIVE DATE (6.3)
+10 ;PSOHY("ITEM")=PHARMACY ORDERABLE ITEM (DERIVED FROM THE DRUG IEN) - NO MAPPING TO 52.49
+11 ;PSOHY("DRUG")=DRUG IEN (3.2)
+12 ;PSOHY("QTY")=QUANTITY (20.1)
+13 ;PSOHY("REF")=# OF REFILLS (20.5)
+14 ;PSOHY("PAT")=PATIENT IEN (.05)
+15 ;PSOHY("OCC")=ORDER TYPE (ALWAYS 'NW') - NO MAPPING TO 52.49
+16 ;PSOHY("EDT")=LOGIN DATE/TIME (ERX MSG DATE/TIME #.03)
+17 ;PSOHY("PRIOR")=PRIORITY (SET OF CODES, 52.41,25 - STAT, EMERGENCY, ROUTINE)
+18 ;PSOHY("EXAPP")=EXTERNAL APPLICATION (FREE TEXT), LIKELY "PSO" - NO MAPPING TO 52.49
+19 ;PSOHY("PRCOM",#)=PROVIDER COMMENTS (8- NOTES)
+20 ;PSOHY("SIG",#)=SIG (52.4911 (STRUCTURED SIG), FIELD 1 (SIG FREE TEXT)
+21 ;PSOHY("QTSUB",CNT)=QUANTITY TIMING SUBFILE DATA. MERGED IN, FULL SUBFILE DATA
+22 ; QUANTITY/TIMING MAPS DIRECTLY TO QUANTITY TIMING IN 52.41
SETUP ;
+1 NEW MBMSITE,PSOIENS,PSODAT,F,PATIEN,PROVIEN,OC,VQTY,EFFDT,VADRUG,VAOI,VAREF,VAROUT,VAPRIOR,PSOHY,LOC,ERXNUM,PRVARY,PRVCOMM
+2 NEW PLOOP,PCNT,QTLOOP,QTCNT,PSOEXMS,DIR,ORDERTYP,PSOEXCNT,SCNT,SIGDAT,SLOOP,POORD,PMVAL,PRMVAL,DMVAL,PATINST,RXSTAT
+3 NEW VADAYS,UNEXPI,PINARY,WRITDT,SLOOP2,MTYPE,REQIEN,ORXIEN,RESTYPE,DELTAS,RXIEN,ERXMSG,I,CSERRMSG,PSOQUIT,DIC
+4 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+5 SET F=52.49
+6 if '$GET(PSOIEN)
QUIT
+7 DO FULL^VALM1
IF MBMSITE
SET VALMBCK="R"
+8 IF $$DONOTFIL^PSOERXUT(PSOIEN)
QUIT
+9 SET RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
+10 IF RXSTAT="RJ"!(RXSTAT="RM")!($EXTRACT(RXSTAT,1,3)="REM")!(RXSTAT="PR")!(RXSTAT="CXP")!(RXSTAT="RXP")
Begin DoDot:1
+11 WRITE !!,"Cannot accept a prescription with a status of 'Rejected', 'Removed',",!,"or 'Processed",!
+12 SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
+13 SET PSOIENS=PSOIEN_","
+14 DO GETS^DIQ(F,PSOIENS,".01;.05;.07;.08;1;1.3;1.5;1.7;2.1;2.3;3.2;5.9;6.2;6.3;8;20.1;20.2;20.4;20.5;20.6;25;25.2;27;30;52.1","IE","PSODAT")
+15 SET PSOEXCNT=0
+16 SET MTYPE=$GET(PSODAT(F,PSOIENS,.08,"I"))
+17 SET RESTYPE=$GET(PSODAT(F,PSOIENS,52.1,"I"))
+18 IF MTYPE="RE"
IF RESTYPE'="R"
Begin DoDot:1
+19 SET REQIEN=$$GETREQ^PSOERXU2(PSOIEN)
+20 IF REQIEN
SET RXIEN=$$GET1^DIQ(52.49,REQIEN,.13,"I")
+21 DO PREFRES^PSOERXU3(PSOIEN,.PSOHY,.PSOEXCNT,.PSOEXMS,.PSODAT)
+22 DO RRDELTA^PSOERXU2(.DELTAS,REQIEN,PSOIEN)
+23 IF $ORDER(PSOEXMS(0))
IF RESTYPE="AWC"
IF $DATA(DELTAS(52.49,"EXTERNAL PROVIDER"))
Begin DoDot:2
+24 DO MSGDIR^PSOERXU1(.PSOEXMS)
End DoDot:2
QUIT
+25 IF $ORDER(PSOEXMS(0))
IF $EXTRACT(RESTYPE)="A"
IF '$DATA(DELTAS(52.49,"EXTERNAL PROVIDER"))
Begin DoDot:2
+26 DO UPDSTAT^PSOERXU1(PSOIEN,"RXF","Unable to add order to Pending file.")
QUIT
End DoDot:2
QUIT
+27 IF $DATA(DELTAS(52.49,"EXTERNAL PROVIDER"))
DO ADD
QUIT
+28 ; call using silent mode if this is auto-processing
+29 DO ADD(1)
End DoDot:1
QUIT
+30 SET ERXSTA=$GET(PSODAT(F,PSOIENS,1,"E"))
IF ERXSTA="E"!($EXTRACT(ERXSTA)="H")
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="eRx is in a 'Hold' status."
DO MSGDIR^PSOERXU1(.PSOEXMS)
QUIT
+31 IF MTYPE="N"!(MTYPE="RE"&(RESTYPE="R")!(MTYPE="CX"))
Begin DoDot:1
+32 SET PMVAL=$GET(PSODAT(F,PSOIENS,1.7,"I"))
IF 'PMVAL
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Patient has not been manually validated."
+33 SET PRMVAL=$GET(PSODAT(F,PSOIENS,1.3,"I"))
IF 'PRMVAL
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Provider has not been manually validated."
+34 SET DMVAL=$GET(PSODAT(F,PSOIENS,1.5,"I"))
IF 'DMVAL
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Drug has not been manually validated."
End DoDot:1
+35 ; for now, if validations have not occurred, do not check the other fields.
+36 IF $ORDER(PSOEXMS(0))
DO MSGDIR^PSOERXU1(.PSOEXMS)
QUIT
+37 ; CS eRx Validations
+38 DO PRDRVAL^PSOERXUT(.CSERRMSG,"AC",PSOIEN)
+39 IF '$GET(CSERRMSG)
IF $PIECE(CSERRMSG,"^",2)="B"
DO MSGDIR^PSOERXU1(.CSERRMSG)
QUIT
+40 IF $$GET1^DIQ(52.49,PSOIEN,95.1,"I")
IF '$$VALPTADD^PSOERXUT(+$GET(PSODAT(F,PSOIENS,.05,"I")))
Begin DoDot:1
+41 SET CSERRMSG(1)="Patient does not have a current mailing or residential address on file."
+42 DO MSGDIR^PSOERXU1(.CSERRMSG)
End DoDot:1
QUIT
+43 ;
+44 SET POORD=$GET(PSODAT(F,PSOIENS,25.2,"I"))
IF POORD
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Pending outpatient order already exists."
+45 SET PATIEN=$GET(PSODAT(F,PSOIENS,.05,"I"))
IF 'PATIEN
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="No matched vista patient."
+46 SET PROVIEN=$GET(PSODAT(F,PSOIENS,2.3,"I"))
IF 'PROVIEN
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Provider not matched to a vista provider."
+47 SET VADRUG=$GET(PSODAT(F,PSOIENS,3.2,"I"))
IF 'VADRUG
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Drug not matched to a vista drug."
+48 SET ERXNUM=$GET(PSODAT(F,PSOIENS,.01,"E"))
IF 'ERXNUM
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="eRx number missing."
+49 SET VQTY=$GET(PSODAT(F,PSOIENS,20.1,"E"))
IF 'VQTY
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Quantity missing."
+50 SET EFFDT=$GET(PSODAT(F,PSOIENS,6.3,"I"))
SET WRITDT=$GET(PSODAT(F,PSOIENS,5.9,"I"))
+51 SET LOC=$GET(PSODAT(F,PSOIENS,20.6,"I"))
IF 'LOC
SET LOC=$$GET1^DIQ(59,PSOSITE,10,"I")
+52 ; if the effective date is passed in and there is no time, add .000001 to the date
+53 IF EFFDT]""
SET EFFDT=$PIECE(EFFDT,".")
+54 IF '$LENGTH(EFFDT)
SET EFFDT=WRITDT
+55 SET VADAYS=$GET(PSODAT(F,PSOIENS,20.2,"E"))
+56 SET VAOI=$$GET1^DIQ(50,VADRUG,2.1,"I")
IF 'VAOI
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Orderable item not associated with drug."
+57 SET VAREF=$GET(PSODAT(F,PSOIENS,20.5,"E"))
+58 SET VAROUT=$GET(PSODAT(F,PSOIENS,20.4,"I"))
IF '$LENGTH(VAROUT)
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Pickup routing missing."
+59 SET PATINST=$GET(PSODAT(F,PSOIENS,27,"E"))
+60 ; CALL TO AVOID SPACE CONCATENATION
+61 DO TXT2ARY^PSOERXD1(.PINARY,$$LSIG^PSOERXU6(PATINST))
+62 ; get provider comments from VA PROVIDER COMMENTS field
+63 SET PRVCOMM=$GET(PSODAT(F,PSOIENS,30,"E"))
+64 DO TXT2ARY^PSOERXD1(.PRVARY,$$LSIG^PSOERXU6(PRVCOMM))
+65 SET (PLOOP,PCNT)=0
FOR
SET PLOOP=$ORDER(PRVARY(PLOOP))
if 'PLOOP
QUIT
Begin DoDot:1
+66 SET PCNT=PCNT+1
SET PSOHY("PRCOM",PCNT)=$GET(PRVARY(PLOOP))
End DoDot:1
+67 IF '$ORDER(^PS(52.49,PSOIEN,21,0))
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Dosing information missing."
+68 SET (QTLOOP,QTCNT)=0
FOR
SET QTLOOP=$ORDER(^PS(52.49,PSOIEN,21,QTLOOP))
if 'QTLOOP
QUIT
Begin DoDot:1
+69 SET QTCNT=QTCNT+1
MERGE PSOHY("QTSUB",QTCNT)=^PS(52.49,PSOIEN,21,QTLOOP)
End DoDot:1
+70 ;
+71 ; Assigning Clinic which the User is logged into
+72 SET PSOQUIT=0
+73 IF $GET(MBMSITE)
IF +$$GET1^DIQ(52.49,PSOIEN,20.6,"I")'=+$GET(PSOCLNC)
Begin DoDot:1
+74 WRITE !!,"Current Clinic assigned to the eRx: ",$$GET1^DIQ(52.49,PSOIEN,20.6),!
+75 KILL DIC
SET DIC(0)="AEMQ"
SET DIC=44
SET DIC("S")="I '$P($G(^(""I"")),U,1)!$P($G(^(""I"")),U,2)"
+76 SET DIC("A")="Send to eRx Clinic: "
+77 IF $GET(PSOCLNC)
SET DIC("B")=$$GET1^DIQ(44,PSOCLNC,.01)
+78 DO ^DIC
IF Y="^"!$DATA(DTOUT)!$DATA(DUOUT)
SET PSOQUIT=1
QUIT
+79 IF $GET(Y)>0
SET LOC=+Y
End DoDot:1
IF $GET(PSOQUIT)
QUIT
+80 ; always 'routine' for now
+81 SET VAPRIOR="R"
+82 ; always 'new' for this version
+83 IF '$LENGTH($GET(ORDERTYP))
SET ORDERTYP="NW"
+84 SET PSOHY("LOC")=LOC
SET PSOHY("CHNUM")=$GET(ERXNUM)
+85 ;,PSOHY("ENTER")=PROVIEN
SET PSOHY("PICK")=VAROUT
+86 SET PSOHY("ENTER")=DUZ
+87 SET PSOHY("PROV")=PROVIEN
SET PSOHY("SDT")=EFFDT
+88 SET PSOHY("ITEM")=VAOI
SET PSOHY("DRUG")=VADRUG
+89 SET PSOHY("QTY")=VQTY
SET PSOHY("REF")=VAREF
+90 SET (PSOHY("PAT"),DFN)=PATIEN
SET PSOHY("OCC")=ORDERTYP
+91 ; Login date will always be the Message Received Date/Time
+92 SET PSOHY("EDT")=$$GET1^DIQ(52.49,PSOIEN,.03,"I")
SET PSOHY("PRIOR")=VAPRIOR
+93 ; ALWAYS PSO as the external application
+94 SET PSOHY("EXAPP")="PHARMACY"
+95 SET PSOHY("DAYS")=VADAYS
+96 ; sig from eRx
+97 SET (SLOOP,SCNT)=0
FOR
SET SLOOP=$ORDER(^PS(52.49,PSOIEN,"SIG",SLOOP))
if 'SLOOP
QUIT
Begin DoDot:1
+98 SET SIGDAT=$GET(^PS(52.49,PSOIEN,"SIG",SLOOP,0))
+99 SET SCNT=SCNT+1
SET PSOHY("SIG",SCNT)=SIGDAT
End DoDot:1
+100 SET SLOOP2=0
FOR
SET SLOOP2=$ORDER(PINARY(SLOOP2))
if 'SLOOP2
QUIT
Begin DoDot:1
+101 SET SCNT=SCNT+1
SET PSOHY("SIG",SCNT)=$GET(PINARY(SLOOP2))
End DoDot:1
+102 ; if provider, patient or drug is missing, no need to continue.
+103 DO ADD
+104 IF $GET(PSOEXMS)]""
WRITE !,PSOEXMS
SET DIR(0)="E"
DO ^DIR
KILL DIR
+105 KILL DFN
+106 QUIT
ADD(QUIET) ;Add CHCS message to Outpatient Pending Orders file
+1 NEW MBMSITE,PSOHQ,PSOHQT,PSOCPEND,PSOHINI,PSOHINLO,ERXSTA,ORDNUM,ILOOP,IARY,PSSRET
+2 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+3 IF '$GET(PSOHY("DRUG"))
Begin DoDot:1
+4 SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Invalid Dispense Drug"
QUIT
End DoDot:1
QUIT
+5 SET (PSOHINI,PSOHINLO)=0
Begin DoDot:1
+6 IF $GET(PSOHY("LOC"))
SET PSOHINLO=$PIECE($GET(^SC(PSOHY("LOC"),0)),"^",4)
IF PSOHINLO
QUIT
End DoDot:1
+7 ; get institution from 52.49 if clinic was not passed in
+8 SET RESTYPE=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
+9 IF $GET(PSOHINLO)<1
SET PSOHINLO=$$GET1^DIQ(52.49,PSOIEN,24.1,"I")
+10 IF +$GET(PSOHINLO)<1
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Unable to derive Institution from Clinic."
QUIT
+11 KILL DD,DO,DIC
SET X=PSOHY("CHNUM")
SET DIC="^PS(52.41,"
SET DIC(0)="L"
+12 if $GET(PSOHY("PICK"))=""
SET PSOHY("PICK")="M"
+13 SET DIC("DR")="4////"_$GET(PSOHY("ENTER"))_";5////"_PSOHY("PROV")_";6////"_$GET(PSOHY("SDT"))_";8////"_PSOHY("ITEM")_";11////"_PSOHY("DRUG")
+14 SET DIC("DR")=$GET(DIC("DR"))_";12////"_$GET(PSOHY("QTY"))_";13////"_$GET(PSOHY("REF"))_";22.1////"_$GET(PSOHY("PREVORD"))_";101////"_$GET(PSOHY("DAYS"))
+15 DO FILE^DICN
KILL DD,DIC,DO
IF Y<0
Begin DoDot:1
+16 SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Unable to add order to Pending file."
+17 IF MTYPE="RE"
DO UPDSTAT^PSOERXU1(PSOIEN,"RXF",PSOEXMS(PSOEXCNT))
+18 SET REQIEN=$$GETREQ^PSOERXU2(PSOIEN)
IF REQIEN
DO UPDSTAT^PSOERXU1(PSOIEN,"RRF",PSOEXMS)
End DoDot:1
QUIT
+19 SET PSOCPEND=+Y
+20 SET $PIECE(^PS(52.41,PSOCPEND,0),"^",2)=PSOHY("PAT")
SET $PIECE(^(0),"^",3)=PSOHY("OCC")
SET $PIECE(^(0),"^",12)=$GET(PSOHY("EDT"))
SET $PIECE(^(0),"^",13)=$GET(PSOHY("LOC"))
+21 SET $PIECE(^PS(52.41,PSOCPEND,0),"^",14)=$GET(PSOHY("PRIOR"))
SET $PIECE(^(0),"^",17)=$GET(PSOHY("PICK"))
+22 SET $PIECE(^PS(52.41,PSOCPEND,"EXT"),"^")=PSOHY("CHNUM")
SET $PIECE(^("EXT"),"^",2)=0
SET $PIECE(^("EXT"),"^",3)=PSOHY("EXAPP")
+23 SET DIE="^PS(52.41,"
SET DA=PSOCPEND
SET DR="104.1///1"
DO ^DIE
KILL DIE,DA,DR
+24 ; PSO*7*506
+25 SET FDA(52.41,PSOCPEND_",",104)=$GET(PATINST)
DO FILE^DIE(,"FDA")
KILL FDA
+26 NEW DA,DIK
SET DA=PSOCPEND
SET DIK="^PS(52.41,"
SET DIK(1)="114^C"
DO EN1^DIK
+27 IF $ORDER(PSOHY("PRCOM",0))
Begin DoDot:1
+28 SET PSOHQ=""
SET PSOHQT=0
FOR
SET PSOHQ=$ORDER(PSOHY("PRCOM",PSOHQ))
if PSOHQ=""
QUIT
IF $GET(PSOHY("PRCOM",PSOHQ))'=""
SET PSOHQT=PSOHQT+1
SET ^PS(52.41,PSOCPEND,3,PSOHQT,0)=$GET(PSOHY("PRCOM",PSOHQ))
End DoDot:1
IF PSOHQT
SET ^PS(52.41,PSOCPEND,3,0)="^^"_PSOHQT_"^"_PSOHQT_"^"_DT_"^"
+29 IF $ORDER(PSOHY("SIG",0))
Begin DoDot:1
+30 SET PSOHQ=""
SET PSOHQT=0
FOR
SET PSOHQ=$ORDER(PSOHY("SIG",PSOHQ))
if PSOHQ=""
QUIT
IF $GET(PSOHY("SIG",PSOHQ))'=""
SET PSOHQT=PSOHQT+1
SET ^PS(52.41,PSOCPEND,"SIG",PSOHQT,0)=$GET(PSOHY("SIG",PSOHQ))
End DoDot:1
IF PSOHQT
SET ^PS(52.41,PSOCPEND,"SIG",0)="^52.4124A^"_PSOHQT_"^"_PSOHQT
+31 SET $PIECE(^PS(52.41,PSOCPEND,"INI"),"^")=$GET(PSOHINLO)
+32 ; add quantity/timing subfile information
+33 IF $ORDER(PSOHY("QTSUB",0))
Begin DoDot:1
+34 SET PSOHQ=""
SET PSOHQT=0
FOR
SET PSOHQ=$ORDER(PSOHY("QTSUB",PSOHQ))
if PSOHQ=""
QUIT
Begin DoDot:2
+35 IF $ORDER(PSOHY("QTSUB",PSOHQ,0))
SET PSOHQT=PSOHQT+1
+36 SET ^PS(52.41,PSOCPEND,1,PSOHQT,0)=PSOHY("QTSUB",PSOHQ,0)
+37 SET ^PS(52.41,PSOCPEND,1,PSOHQT,1)=PSOHY("QTSUB",PSOHQ,1)
+38 SET ^PS(52.41,PSOCPEND,1,PSOHQT,2)=PSOHY("QTSUB",PSOHQ,2)
End DoDot:2
End DoDot:1
IF PSOHQT
SET ^PS(52.41,PSOCPEND,1,0)="^52.413^"_PSOHQT_"^"_PSOHQT
+39 IF $ORDER(PINARY(0))
DO WP^DIE(52.41,PSOCPEND_",",105,"K","PINARY")
+40 ;Cross references not set yet preventing Pharmacy from finishing order
+41 DO EN^PSOHLSNC(PSOCPEND,"SN","IP")
+42 DO FULL^VALM1
+43 ;Just set to DC, don't delete because 52.41 entry would be re-used
+44 IF '$PIECE($GET(^PS(52.41,PSOCPEND,"EXT")),"^",2)
Begin DoDot:1
+45 ;x-ref shouldn't be set, but we'll kill them just in case
+46 KILL ^PS(52.41,"AOR",$PIECE(^PS(52.41,PSOCPEND,0),"^",2),+$PIECE($GET(^("INI")),"^"),PSOCPEND),^PS(52.41,"AD",$PIECE(^PS(52.41,PSOCPEND,0),"^",12),+$PIECE($GET(^("INI")),"^"),PSOCPEND)
+47 KILL ^PS(52.41,"ACL",+$PIECE(^PS(52.41,PSOCPEND,0),"^",13),$PIECE(^(0),"^",12),PSOCPEND),^PS(52.41,"AQ",+$PIECE($GET(^PS(52.41,PSOCPEND,0)),"^",21),PSOCPEND)
+48 SET $PIECE(^PS(52.41,PSOCPEND,4),"^")="External order, unable to successfully transmit to CPRS."
+49 IF $DATA(QUIET)
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="External order, unable to successfully transmit to CPRS."
+50 IF '$DATA(QUIET)
WRITE !!,"External order, unable to successfully transmit to CPRS."
+51 IF '$DATA(QUIET)
SET DIR(0)="E"
DO ^DIR
End DoDot:1
SET $PIECE(^PS(52.41,PSOCPEND,0),"^",3)="DC"
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Unable to send CHCS order to CPRS."
QUIT
+52 ;Successful transmission to CPRS
+53 SET DA=PSOCPEND
SET DIK="^PS(52.41,"
DO IX^DIK
+54 ; add the pending outpatient order number to 52.49 and update status of eRx to PR (Processed)
+55 SET ERXSTA=$ORDER(^PS(52.45,"C","ERX","PR",0))
+56 SET ORDNUM=$PIECE($GET(^PS(52.41,PSOCPEND,0)),U)
+57 SET DIE="^PS(52.49,"
SET DR="25.2///"_PSOCPEND_";.12///"_ORDNUM
SET DA=PSOIEN
DO ^DIE
KILL DIE,DA,DR
+58 ; PSO*7*508 - add checks to update refill requests and responses
+59 ; add activity to status history
+60 IF MTYPE="N"
DO UPDSTAT^PSOERXU1(PSOIEN,"PR")
+61 IF MTYPE="RE"
DO UPDSTAT^PSOERXU1(PSOIEN,"RXP")
+62 ;B3S4
+63 IF MTYPE="CX"
Begin DoDot:1
+64 DO UPDSTAT^PSOERXU1(PSOIEN,"CXP")
+65 SET RTHID=$$GET1^DIQ(52.49,PSOIEN,.14)
SET RTHIEN=$ORDER(^PS(52.49,"FMID",RTHID,0))
+66 DO UPDSTAT^PSOERXU1(RTHIEN,"CRP")
End DoDot:1
+67 SET REQIEN=$$GETREQ^PSOERXU2(PSOIEN)
IF REQIEN
IF $$GET1^DIQ(52.49,REQIEN,.08,"I")="RR"
DO UPDSTAT^PSOERXU1(REQIEN,"RRP")
+68 ; PSO*7*508 - end
+69 ;
+70 ; Saves the Actual eRx SIG (from outside provider) into the PROVIDER COMMENTS field (P-651/14)
+71 NEW UNEXINS
SET UNEXINS(1)=$$ERXSIG^PSOERXUT(PSOIEN)
+72 IF $LENGTH($GET(UNEXINS(1)))
DO WP^DIE(52.41,PSOCPEND_",",9,"K","UNEXINS")
+73 ;
+74 IF '$DATA(QUIET)
Begin DoDot:1
+75 WRITE !!,"eRx #"_PSOHY("CHNUM")_" sent to PENDING ORDERS Queue."
+76 if $GET(MBMSITE)
WRITE " (Clinic: "_$$GET1^DIQ(44,+$GET(PSOHY("LOC")),.01)_")"
End DoDot:1
+77 ;PSO*7*520 - add sending and warning/information related to RxVerify Message.
+78 IF '$$UNACCBEF(PSOIEN)
IF MTYPE="N"!((MTYPE="RE")&(RESTYPE="R"))!(MTYPE="CX")
Begin DoDot:1
+79 WRITE !!,"Sending rxVerify Message to prescriber."
+80 DO POST^PSOERXO1(PSOIEN,.PSSRET,,,,1)
+81 ; if the post was unsuccessful, inform the user and quit.
+82 IF $PIECE(PSSRET(0),U)<1
WRITE !,$PIECE(PSSRET(0),U,2)
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+83 IF $DATA(PSSRET("errorMessage"))
WRITE !,PSSRET("errorMessage")
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
End DoDot:1
+84 ;PSO*7*520 - end rxVerify changes
+85 ;
+86 KILL QUIET
+87 QUIT
+88 ;
UNACC ; Un-Accept eRx from Pending Queue back into the Holding Queue
+1 NEW ORDNUM,ERXIEN,PSOIEN,DIE,DA,DR,DIC,PSOHOLD,PSOQUIT,DIR,X,Y,DTOUT,DUOUT,HOLDCOMM,POERR
+2 SET VALMBCK="R"
+3 IF '$GET(ORD)!'$DATA(^PS(52.41,+$GET(ORD),0))
SET VALMSG="Invalid Pending Order"
WRITE $CHAR(7)
QUIT
+4 IF $$GET1^DIQ(52.41,ORD,2,"I")'="NW"
SET VALMSG="eRx has already been finished or un-accepted."
WRITE $CHAR(7)
QUIT
+5 SET ORDNUM=$$GET1^DIQ(52.41,+ORD,.01)
IF 'ORDNUM
SET VALMSG="Invalid Pending Order"
WRITE $CHAR(7)
QUIT
+6 SET (ERXIEN,PSOIEN)=$$CHKERX^PSOERXU1(ORDNUM)
IF 'PSOIEN
SET VALMSG="This Pending Order is not related to an eRx"
WRITE $CHAR(7)
QUIT
+7 IF '$GET(ERXIEN)
SET VALMSG="This is not an eRx Prescription"
WRITE $CHAR(7)
QUIT
+8 DO FULL^VALM1
+9 ;
+10 KILL DIC
WRITE !
SET DIC("A")="Select HOLD reason code: "
+11 SET DIC="^PS(52.45,"
SET DIC(0)="AEMQ"
SET DIC("B")="HOLD FOR RX EDIT"
+12 SET DIC("S")="I $D(^PS(52.45,""TYPE"",""ERX"",Y)),$E($P(^PS(52.45,Y,0),U),1)=""H"""
+13 SET (PSOHOLD,PSOQUIT)=0
+14 FOR
DO ^DIC
Begin DoDot:1
+15 IF $GET(DUOUT)!$GET(DTOUT)
SET PSOQUIT=1
QUIT
+16 IF X=""
WRITE !,"HOLD Reason is required",!,$CHAR(7)
QUIT
+17 SET PSOHOLD=Y
End DoDot:1
IF PSOHOLD!PSOQUIT
QUIT
+18 IF PSOQUIT
QUIT
+19 ;
+20 KILL DIR
SET DIR(0)="52.4919,1"
SET DIR("A")="Comments (Optional)"
+21 DO ^DIR
KILL DIR
IF Y="^"
QUIT
+22 SET HOLDCOMM=$GET(Y)
+23 ;
+24 KILL DIR
WRITE !
SET DIR("A",1)="This eRx will be Un-Accepted and sent back to the eRx Holding Queue."
+25 SET DIR("A",2)=""
SET DIR("A")="Confirm"
SET DIR(0)="Y"
SET DIR("B")="N"
+26 DO ^DIR
IF $GET(DIRUT)!$GET(DUOUT)!'Y
QUIT
+27 WRITE ?40,"Please wait..."
+28 ;
+29 ; Chaning eRx Order Status to Hold
+30 DO UPDSTAT^PSOERXU1(ERXIEN,$PIECE(PSOHOLD,"^",2),HOLDCOMM,1)
+31 ; Removing pointer to the Pending Order entry
+32 IF $PIECE($GET(^PS(52.49,ERXIEN,25)),"^",2)
SET $PIECE(^PS(52.49,ERXIEN,25),"^",2)=""
+33 ;
+34 if '$DATA(^PS(52.41,ORD,0))
QUIT
+35 KILL ^PS(52.41,"AOR",$PIECE(^PS(52.41,ORD,0),"^",2),+$PIECE($GET(^PS(52.41,ORD,"INI")),"^"),ORD)
+36 KILL ^PS(52.41,"AD",$PIECE(^PS(52.41,ORD,0),"^",12),+$PIECE($GET(^PS(52.41,ORD,"INI")),"^"),ORD)
+37 SET $PIECE(^PS(52.41,ORD,0),"^",3)="DC"
SET POERR("PLACER")=$PIECE(^(0),"^")
SET POERR("STAT")="OC"
+38 SET POERR("COMM")="eRx Un-Accepted: "_$$GET1^DIQ(52.45,+PSOHOLD,.02)_$SELECT(HOLDCOMM'="":" - "_HOLDCOMM,1:"")
+39 SET $PIECE(^PS(52.41,ORD,4),"^")=POERR("COMM")
+40 DO EN^PSOHLSN(POERR("PLACER"),POERR("STAT"),POERR("COMM"),"W")
+41 ;
+42 WRITE !!,"eRx successfully un-accepted and placed back on the eRx Holding Queue."
+43 KILL DIR
DO PAUSE^VALM1
+44 ;
+45 DO JUMP2ERX
KILL VALMBCK
+46 QUIT
+47 ;
JUMP2ERX ; Jump to the eRx Holding Queue for the specific order after Un-Accepting eRx
+1 NEW ORDNUM,PSOIEN,ERXIEN
+2 DO FULL^VALM1
+3 SET VALMBCK="R"
+4 IF $GET(PSOJUMP)
SET VALMSG="Cannot jump back to the Holding Queue, use ^"
WRITE $CHAR(7)
QUIT
+5 SET ORDNUM=+$$ORDNUM()
IF 'ORDNUM
SET VALMSG="Invalid Order"
WRITE $CHAR(7)
QUIT
+6 SET (ERXIEN,PSOIEN)=$$CHKERX^PSOERXU1(ORDNUM)
IF 'PSOIEN
SET VALMSG="This Order is not related to an eRx"
WRITE $CHAR(7)
QUIT
+7 XECUTE "N (DUZ,IO,U,DT,DILOCKTM,DTIME,PSOIEN,ERXIEN,PSOSITE,PSOJUMP,PSNPINST)"
+8 KILL ^TMP("PSOERXPO",$JOB)
MERGE ^TMP("PSOERXPO",$JOB)=^TMP("XQORS",$JOB)
+9 SET PSOJUMP=1
+10 DO EN^VALM("PSO ERX HQ DISPLAY")
+11 KILL ^TMP("XQORS",$JOB)
MERGE ^TMP("XQORS",$JOB)=^TMP("PSOERXPO",$JOB)
+12 SET PSOJUMP=0
+13 QUIT
+14 ;
ORDNUM() ; Returns the correct IEN for the ORDER file (#100) for the Rx
+1 IF $PIECE(XQY0,"^")="PSO LM BACKDOOR ORDERS"!($PIECE(XQY0,"^")="PSO LMOE FINISH")
IF $PIECE(VALMKEY,"^",2)="PSO HIDDEN ACTIONS"
IF $GET(RXN)
QUIT +$$GET1^DIQ(52,RXN,39.3,"I")
+2 IF $PIECE(XQY0,"^")="PSO LM BACKDOOR ORDERS"!($PIECE(XQY0,"^")="PSO LMOE FINISH")!($PIECE(XQY0,"^")="PSO PMP")
IF $PIECE(VALMKEY,"^",2)="PSO HIDDEN ACTIONS #3"!($PIECE(VALMKEY,"^",2)="PSO HIDDEN ACTIONS #4")
IF $GET(ORD)
QUIT +$$GET1^DIQ(52.41,+ORD,.01)
+3 IF $PIECE(XQY0,"^")="PSO VIEW"!($PIECE(XQY0,"^")="PSO PMP")
IF $PIECE(VALMKEY,"^",2)="PSO PMP HIDDEN ACTIONS MENU #2"
IF $GET(RXN)
QUIT +$$GET1^DIQ(52,RXN,39.3,"I")
+4 QUIT 0
+5 ;
UNACCBEF(ERXIEN) ; Determines if the eRx has been Un-Accepted Before
+1 ; Input: (r)ERXIEN - Pointer to ERX HOLDING QUEUE (#52.49)
+2 ;Output: 1 - eRx has been Un-Accepted Before | 0 - Exclude the eRx
+3 NEW UNACCBEF,STSHST
+4 SET UNACCBEF=0
+5 SET STSHST=9999
FOR
SET STSHST=$ORDER(^PS(52.49,ERXIEN,19,STSHST),-1)
if 'STSHST
QUIT
Begin DoDot:1
+6 SET UNACCBEF=+$$GET1^DIQ(52.4919,STSHST_","_ERXIEN,.04,"I")
End DoDot:1
IF UNACCBEF
QUIT
+7 QUIT UNACCBEF
