PSOERX1B ;ALB/BWF - Accept eRx function ; 8/3/2016 5:14pm
;;7.0;OUTPATIENT PHARMACY;**467,506,520,527,508,551,591,606,581,617,700**;DEC 1997;Build 261
;
Q
ACVAL(PSOIEN,TYPE) ; NEW MTYPE, GET IT OFF FIELD .08, IF NOT DEFINED,
;Input: PSOIEN - eRx IEN (Pointer to #52.49)
; TYPE - Validation Type (P: Patient, PR: Provider, D: Drug)
N MBMSITE,F,VBFLD,VBDTTMF,DIR,TAG,VALPAR,VAL,CURVAL,MVFLD,VBFLD,VBDTTMF,PSOIENS,RXSTAT,QFLG,VDTTM,ERXMMFLG,MTYPE,Y
N RESTYPE,GMRA,GMRAL,ERXPTIEN,DFN
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
S F=52.49,PSOIENS=PSOIEN_","
D FULL^VALM1
S VALMBCK="R"
; first check to see if the entry exists. cannot validate something that has no value
S MTYPE=$$GET1^DIQ(52.49,PSOIEN,.08,"I") ;mtype
S RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E") I RXSTAT="RJ"!(RXSTAT="RM")!($E(RXSTAT,1,3)="REM")!(RXSTAT="PR")!(RXSTAT="CRP")!(RXSTAT="CXP")!(RXSTAT="RRP") D Q
. W !!,"Cannot accept validation for a prescription with a status of 'Rejected',",!,"'Removed',or 'Processed",!
. S DIR(0)="E" D ^DIR
Q:TYPE']""
S TAG=$S(TYPE="P":"patient",TYPE="PR":"provider",TYPE="D":"drug",1:"")
S VALPAR=$S(TYPE="P":.05,TYPE="PR":2.3,TYPE="D":3.2,1:"") Q:VALPAR=""
S VAL=$$GET1^DIQ(F,PSOIEN,VALPAR,"I") I 'VAL D Q
. W !,"Vista "_TAG_" has not been matched. Cannot manually validate."
. S DIR(0)="E" D ^DIR
S MVFLD=$S(TYPE="P":1.7,TYPE="PR":1.3,TYPE="D":1.5,1:"")
S VBFLD=$S(TYPE="P":1.13,TYPE="PR":1.8,TYPE="D":1.11,1:"")
S VBDTTMF=$S(TYPE="P":1.14,TYPE="PR":1.9,TYPE="D":1.12,1:"")
; check if Patient has a valid adress - CS prescriptions only
I TYPE="P",$$GET1^DIQ(52.49,PSOIEN,95.1,"I"),'$$VALPTADD^PSOERXUT(+$G(VAL)) D Q
. W !!,"Unable to validate - VistA Patient does not have a current mailing"
. W !,"or residential address on file.",$C(7),!
. S DIR(0)="E" D ^DIR
; check to see if this is already validated
I MVFLD S CURVAL=$$GET1^DIQ(F,PSOIEN,MVFLD,"I")
I CURVAL D Q
. W !!,"This "_TAG_" has already been "_$S(TYPE="PR"&$$GET1^DIQ(52.49,PSOIEN,2.7,"I"):"automatically",1:"manually")_" validated."
. W !,"Validated By: "_$$GET1^DIQ(F,PSOIEN,VBFLD,"E")
. W !,"Validated Date/Time: "_$$GET1^DIQ(F,PSOIEN,VBDTTMF,"E"),!
. S DIR(0)="E" D ^DIR
S QFLG=0
I TYPE="D" D
. W !
. I '$O(^PS(52.49,PSOIEN,21,0)) W !,"Dosing information missing.",$C(7) S QFLG=1
. I $$GET1^DIQ(52.49,PSOIEN,20.1,"E")="" W !,"Quantity missing.",$C(7) S QFLG=1
. I $$GET1^DIQ(52.49,PSOIEN,20.2,"E")="" W !,"Days supply missing.",$C(7) S QFLG=1
I $G(QFLG) W ! S DIR(0)="E" D ^DIR K DIR Q
I TYPE="D" D
. N ERXMSG,I
. D PRDRVAL^PSOERXUT(.ERXMSG,"VD",PSOIEN) I $P(ERXMSG,"^",2)="B" S QFLG=1
. I $O(ERXMSG(0)) D
. . W !!,"*********************************",$S($P(ERXMSG,"^",2)="W":" WARNING(S) ",1:"INVALID DRUG"),"***********************************"
. . S I=0 F S I=$O(ERXMSG(I)) Q:'I W !,$P(ERXMSG(I),"^")
. . W !,"********************************************************************************",$C(7)
I $G(QFLG) W ! S DIR(0)="E" D ^DIR K DIR Q
;
I TYPE="P" D I '$G(ERXMMFLG) S DIR(0)="E" D ^DIR K DIR
. S ERXMMFLG=$$PATWARN^PSOERX1A("VP",PSOIEN)
;
S DFN=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
; VistA Patient ChampVA Eligibility Check (MbM Only)
I $G(MBMSITE),TYPE="P",'$$CHVAELIG^PSOERXU9(DFN) D Q
. I ",N,I,W,RXI,RXN,RXW,RXR,CXI,CXN,CXW,"[(","_$G(RXSTAT)_",") D
. . D UPDSTAT^PSOERXU1(PSOIEN,"HEL","Hold due to Eligibility Issue")
. . W !!,"This eRx has been put on Hold (HEL) because the VistA Patient ("_$$GET1^DIQ(2,DFN,.01)_") is not Eligible for ChampVA Rx Benefit."
. . K DIR D PAUSE^VALM1
. D AUTOHOLD^PSOERX1E("E",PSOIEN,DFN)
;
; VistA Patient Allergy Check (MbM Only)
I $G(MBMSITE),TYPE="P" D I $G(GMRAL)="" Q
. S GMRA="0^0^111" D EN1^GMRADPT I $G(GMRAL)'="" Q
. I ",N,I,W,RXI,RXN,RXW,RXR,CXI,CXN,CXW,"[(","_$G(RXSTAT)_",") D
. . D UPDSTAT^PSOERXU1(PSOIEN,"HAL","Hold for Allergy Assessment")
. . W !!,"This eRx has been put on Hold (HAL) because the VistA Patient ("_$$GET1^DIQ(2,DFN,.01)_") does not have an Allergy Assessment.."
. . K DIR D PAUSE^VALM1
. D AUTOHOLD^PSOERX1E("A",PSOIEN,DFN)
;
I TYPE="P",'$G(ERXMMFLG) Q
;
I TYPE="PR" S ERXMMFLG=$$PRVWARN^PSOERX1A("VP",PSOIEN) I 'ERXMMFLG S DIR(0)="E" D ^DIR K DIR Q
W !,"Would you like to mark this "_TAG_" as VALIDATED?"
S DIR(0)="Y",DIR("B")=$S($G(ERXMMFLG):"NO",1:"YES") D ^DIR Q:Y'=1
K FDA,DIR
S VDTTM=$$NOW^XLFDT I MVFLD S FDA(F,PSOIENS,MVFLD)=1
I VBFLD S FDA(F,PSOIENS,VBFLD)=$G(DUZ)
I VBDTTMF S FDA(F,PSOIENS,VBDTTMF)=VDTTM
I $D(FDA) D FILE^DIE(,"FDA") K FDA
W !,"Validation Updated!!"
; check validations and update status to 'wait' if all validations have occured.
I MTYPE="N" D
. I $$GET1^DIQ(52.49,PSOIEN,1.3,"I"),$$GET1^DIQ(52.49,PSOIEN,1.5,"I"),$$GET1^DIQ(52.49,PSOIEN,1.7,"I") D UPDSTAT^PSOERXU1(PSOIEN,"W") Q
. D UPDSTAT^PSOERXU1(PSOIEN,"I")
I MTYPE="RE" D
. S RESTYPE=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
. I RESTYPE'="R" D UPDSTAT^PSOERXU1(PSOIEN,"RXW") Q
. I $$GET1^DIQ(52.49,PSOIEN,1.3,"I"),$$GET1^DIQ(52.49,PSOIEN,1.5,"I"),$$GET1^DIQ(52.49,PSOIEN,1.7,"I") D UPDSTAT^PSOERXU1(PSOIEN,"RXW") Q
. D UPDSTAT^PSOERXU1(PSOIEN,"RXI")
I MTYPE="CX" D
. I $$GET1^DIQ(52.49,PSOIEN,1.3,"I"),$$GET1^DIQ(52.49,PSOIEN,1.5,"I"),$$GET1^DIQ(52.49,PSOIEN,1.7,"I") D UPDSTAT^PSOERXU1(PSOIEN,"CXW") Q
. D UPDSTAT^PSOERXU1(PSOIEN,"CXI")
I TYPE="P" D BPROC^PSOERXU8(PSOIEN,"PA",MVFLD,VBFLD,VBDTTMF,VDTTM) K @VALMAR D INIT^PSOERXP1
I TYPE="PR" D BPROC^PSOERXU8(PSOIEN,"PR",MVFLD,VBFLD,VBDTTMF,VDTTM) K @VALMAR D INIT^PSOERXR1
I TYPE="D" K @VALMAR D INIT^PSOERXD1
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
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
S F=52.49
Q:'$G(PSOIEN)
D FULL^VALM1
S RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E") I RXSTAT="RJ"!(RXSTAT="RM")!($G(MBMSITE)&($E(RXSTAT,1,3)="REM"))!(RXSTAT="PR")!(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
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 LOC=$G(PSODAT(F,PSOIENS,20.6,"I"))
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"))
; 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"))
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)
; 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("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.
; future consideration - do we need to check more fields?
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 PSOHQ,PSOHQT,PSOCPEND,PSOHINI,PSOHINLO,ERXSTA,ORDNUM,ILOOP,IARY,PSSRET,RESTYPE,RTHIEN,RTHID,X
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
; gather the unexpanded sig and file in 52.41
S ILOOP=0 F S ILOOP=$O(^PS(52.49,PSOIEN,31,ILOOP)) Q:'ILOOP D
.S IARY(ILOOP)=$G(^PS(52.49,PSOIEN,31,ILOOP,0))
I $D(IARY) D WP^DIE(52.41,PSOCPEND_",",9,"K","IARY","IERR")
I '$D(QUIET) W !!,"eRx #"_PSOHY("CHNUM")_" sent to PENDING OUTPATIENT ORDERS!"
;PSO*7*520 - add sending and warning/information related to RxVerify Message.
I 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
; remove eRx from holding queue
REM ;
D REM^PSOERXU4
Q
; unremove eRx from holding queue
UNREM ;
D UNREM^PSOERXU4
Q
; reject eRx
REJ ;
D REJ^PSOERXU4
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERX1B 17847 printed Oct 16, 2024@18:28:51 Page 2
PSOERX1B ;ALB/BWF - Accept eRx function ; 8/3/2016 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**467,506,520,527,508,551,591,606,581,617,700**;DEC 1997;Build 261
+2 ;
+3 QUIT
ACVAL(PSOIEN,TYPE) ; NEW MTYPE, GET IT OFF FIELD .08, IF NOT DEFINED,
+1 ;Input: PSOIEN - eRx IEN (Pointer to #52.49)
+2 ; TYPE - Validation Type (P: Patient, PR: Provider, D: Drug)
+3 NEW MBMSITE,F,VBFLD,VBDTTMF,DIR,TAG,VALPAR,VAL,CURVAL,MVFLD,VBFLD,VBDTTMF,PSOIENS,RXSTAT,QFLG,VDTTM,ERXMMFLG,MTYPE,Y
+4 NEW RESTYPE,GMRA,GMRAL,ERXPTIEN,DFN
+5 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+6 SET F=52.49
SET PSOIENS=PSOIEN_","
+7 DO FULL^VALM1
+8 SET VALMBCK="R"
+9 ; first check to see if the entry exists. cannot validate something that has no value
+10 ;mtype
SET MTYPE=$$GET1^DIQ(52.49,PSOIEN,.08,"I")
+11 SET RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
IF RXSTAT="RJ"!(RXSTAT="RM")!($EXTRACT(RXSTAT,1,3)="REM")!(RXSTAT="PR")!(RXSTAT="CRP")!(RXSTAT="CXP")!(RXSTAT="RRP")
Begin DoDot:1
+12 WRITE !!,"Cannot accept validation for a prescription with a status of 'Rejected',",!,"'Removed',or 'Processed",!
+13 SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
+14 if TYPE']""
QUIT
+15 SET TAG=$SELECT(TYPE="P":"patient",TYPE="PR":"provider",TYPE="D":"drug",1:"")
+16 SET VALPAR=$SELECT(TYPE="P":.05,TYPE="PR":2.3,TYPE="D":3.2,1:"")
if VALPAR=""
QUIT
+17 SET VAL=$$GET1^DIQ(F,PSOIEN,VALPAR,"I")
IF 'VAL
Begin DoDot:1
+18 WRITE !,"Vista "_TAG_" has not been matched. Cannot manually validate."
+19 SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
+20 SET MVFLD=$SELECT(TYPE="P":1.7,TYPE="PR":1.3,TYPE="D":1.5,1:"")
+21 SET VBFLD=$SELECT(TYPE="P":1.13,TYPE="PR":1.8,TYPE="D":1.11,1:"")
+22 SET VBDTTMF=$SELECT(TYPE="P":1.14,TYPE="PR":1.9,TYPE="D":1.12,1:"")
+23 ; check if Patient has a valid adress - CS prescriptions only
+24 IF TYPE="P"
IF $$GET1^DIQ(52.49,PSOIEN,95.1,"I")
IF '$$VALPTADD^PSOERXUT(+$GET(VAL))
Begin DoDot:1
+25 WRITE !!,"Unable to validate - VistA Patient does not have a current mailing"
+26 WRITE !,"or residential address on file.",$CHAR(7),!
+27 SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
+28 ; check to see if this is already validated
+29 IF MVFLD
SET CURVAL=$$GET1^DIQ(F,PSOIEN,MVFLD,"I")
+30 IF CURVAL
Begin DoDot:1
+31 WRITE !!,"This "_TAG_" has already been "_$SELECT(TYPE="PR"&$$GET1^DIQ(52.49,PSOIEN,2.7,"I"):"automatically",1:"manually")_" validated."
+32 WRITE !,"Validated By: "_$$GET1^DIQ(F,PSOIEN,VBFLD,"E")
+33 WRITE !,"Validated Date/Time: "_$$GET1^DIQ(F,PSOIEN,VBDTTMF,"E"),!
+34 SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
+35 SET QFLG=0
+36 IF TYPE="D"
Begin DoDot:1
+37 WRITE !
+38 IF '$ORDER(^PS(52.49,PSOIEN,21,0))
WRITE !,"Dosing information missing.",$CHAR(7)
SET QFLG=1
+39 IF $$GET1^DIQ(52.49,PSOIEN,20.1,"E")=""
WRITE !,"Quantity missing.",$CHAR(7)
SET QFLG=1
+40 IF $$GET1^DIQ(52.49,PSOIEN,20.2,"E")=""
WRITE !,"Days supply missing.",$CHAR(7)
SET QFLG=1
End DoDot:1
+41 IF $GET(QFLG)
WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+42 IF TYPE="D"
Begin DoDot:1
+43 NEW ERXMSG,I
+44 DO PRDRVAL^PSOERXUT(.ERXMSG,"VD",PSOIEN)
IF $PIECE(ERXMSG,"^",2)="B"
SET QFLG=1
+45 IF $ORDER(ERXMSG(0))
Begin DoDot:2
+46 WRITE !!,"*********************************",$SELECT($PIECE(ERXMSG,"^",2)="W":" WARNING(S) ",1:"INVALID DRUG"),"***********************************"
+47 SET I=0
FOR
SET I=$ORDER(ERXMSG(I))
if 'I
QUIT
WRITE !,$PIECE(ERXMSG(I),"^")
+48 WRITE !,"********************************************************************************",$CHAR(7)
End DoDot:2
End DoDot:1
+49 IF $GET(QFLG)
WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+50 ;
+51 IF TYPE="P"
Begin DoDot:1
+52 SET ERXMMFLG=$$PATWARN^PSOERX1A("VP",PSOIEN)
End DoDot:1
IF '$GET(ERXMMFLG)
SET DIR(0)="E"
DO ^DIR
KILL DIR
+53 ;
+54 SET DFN=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
+55 ; VistA Patient ChampVA Eligibility Check (MbM Only)
+56 IF $GET(MBMSITE)
IF TYPE="P"
IF '$$CHVAELIG^PSOERXU9(DFN)
Begin DoDot:1
+57 IF ",N,I,W,RXI,RXN,RXW,RXR,CXI,CXN,CXW,"[(","_$GET(RXSTAT)_",")
Begin DoDot:2
+58 DO UPDSTAT^PSOERXU1(PSOIEN,"HEL","Hold due to Eligibility Issue")
+59 WRITE !!,"This eRx has been put on Hold (HEL) because the VistA Patient ("_$$GET1^DIQ(2,DFN,.01)_") is not Eligible for ChampVA Rx Benefit."
+60 KILL DIR
DO PAUSE^VALM1
End DoDot:2
+61 DO AUTOHOLD^PSOERX1E("E",PSOIEN,DFN)
End DoDot:1
QUIT
+62 ;
+63 ; VistA Patient Allergy Check (MbM Only)
+64 IF $GET(MBMSITE)
IF TYPE="P"
Begin DoDot:1
+65 SET GMRA="0^0^111"
DO EN1^GMRADPT
IF $GET(GMRAL)'=""
QUIT
+66 IF ",N,I,W,RXI,RXN,RXW,RXR,CXI,CXN,CXW,"[(","_$GET(RXSTAT)_",")
Begin DoDot:2
+67 DO UPDSTAT^PSOERXU1(PSOIEN,"HAL","Hold for Allergy Assessment")
+68 WRITE !!,"This eRx has been put on Hold (HAL) because the VistA Patient ("_$$GET1^DIQ(2,DFN,.01)_") does not have an Allergy Assessment.."
+69 KILL DIR
DO PAUSE^VALM1
End DoDot:2
+70 DO AUTOHOLD^PSOERX1E("A",PSOIEN,DFN)
End DoDot:1
IF $GET(GMRAL)=""
QUIT
+71 ;
+72 IF TYPE="P"
IF '$GET(ERXMMFLG)
QUIT
+73 ;
+74 IF TYPE="PR"
SET ERXMMFLG=$$PRVWARN^PSOERX1A("VP",PSOIEN)
IF 'ERXMMFLG
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+75 WRITE !,"Would you like to mark this "_TAG_" as VALIDATED?"
+76 SET DIR(0)="Y"
SET DIR("B")=$SELECT($GET(ERXMMFLG):"NO",1:"YES")
DO ^DIR
if Y'=1
QUIT
+77 KILL FDA,DIR
+78 SET VDTTM=$$NOW^XLFDT
IF MVFLD
SET FDA(F,PSOIENS,MVFLD)=1
+79 IF VBFLD
SET FDA(F,PSOIENS,VBFLD)=$GET(DUZ)
+80 IF VBDTTMF
SET FDA(F,PSOIENS,VBDTTMF)=VDTTM
+81 IF $DATA(FDA)
DO FILE^DIE(,"FDA")
KILL FDA
+82 WRITE !,"Validation Updated!!"
+83 ; check validations and update status to 'wait' if all validations have occured.
+84 IF MTYPE="N"
Begin DoDot:1
+85 IF $$GET1^DIQ(52.49,PSOIEN,1.3,"I")
IF $$GET1^DIQ(52.49,PSOIEN,1.5,"I")
IF $$GET1^DIQ(52.49,PSOIEN,1.7,"I")
DO UPDSTAT^PSOERXU1(PSOIEN,"W")
QUIT
+86 DO UPDSTAT^PSOERXU1(PSOIEN,"I")
End DoDot:1
+87 IF MTYPE="RE"
Begin DoDot:1
+88 SET RESTYPE=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
+89 IF RESTYPE'="R"
DO UPDSTAT^PSOERXU1(PSOIEN,"RXW")
QUIT
+90 IF $$GET1^DIQ(52.49,PSOIEN,1.3,"I")
IF $$GET1^DIQ(52.49,PSOIEN,1.5,"I")
IF $$GET1^DIQ(52.49,PSOIEN,1.7,"I")
DO UPDSTAT^PSOERXU1(PSOIEN,"RXW")
QUIT
+91 DO UPDSTAT^PSOERXU1(PSOIEN,"RXI")
End DoDot:1
+92 IF MTYPE="CX"
Begin DoDot:1
+93 IF $$GET1^DIQ(52.49,PSOIEN,1.3,"I")
IF $$GET1^DIQ(52.49,PSOIEN,1.5,"I")
IF $$GET1^DIQ(52.49,PSOIEN,1.7,"I")
DO UPDSTAT^PSOERXU1(PSOIEN,"CXW")
QUIT
+94 DO UPDSTAT^PSOERXU1(PSOIEN,"CXI")
End DoDot:1
+95 IF TYPE="P"
DO BPROC^PSOERXU8(PSOIEN,"PA",MVFLD,VBFLD,VBDTTMF,VDTTM)
KILL @VALMAR
DO INIT^PSOERXP1
+96 IF TYPE="PR"
DO BPROC^PSOERXU8(PSOIEN,"PR",MVFLD,VBFLD,VBDTTMF,VDTTM)
KILL @VALMAR
DO INIT^PSOERXR1
+97 IF TYPE="D"
KILL @VALMAR
DO INIT^PSOERXD1
+98 QUIT
+99 ;PSOHY("LOC")=IEN of hospital location file (#44) - NOT USED,
+100 ;PSOHY("CHNUM")=EXTERNAL PLACER ORDER NUMBER (NEED TO FIND OUT HOW WE SHOULD SET THIS) (25)
+101 ;PSOHY("PICK")=MAIL/WINDOW (20.4)
+102 ;PSOHY("ENTER")=ENTERED BY IEN (2.1)
+103 ;PSOHY("PROV")=PROVIDER IEN (2.3)
+104 ;PSOHY("SDT")=EFFECTIVE DATE (6.3)
+105 ;PSOHY("ITEM")=PHARMACY ORDERABLE ITEM (DERIVED FROM THE DRUG IEN) - NO MAPPING TO 52.49
+106 ;PSOHY("DRUG")=DRUG IEN (3.2)
+107 ;PSOHY("QTY")=QUANTITY (20.1)
+108 ;PSOHY("REF")=# OF REFILLS (20.5)
+109 ;PSOHY("PAT")=PATIENT IEN (.05)
+110 ;PSOHY("OCC")=ORDER TYPE (ALWAYS 'NW') - NO MAPPING TO 52.49
+111 ;PSOHY("EDT")=LOGIN DATE/TIME (ERX MSG DATE/TIME #.03)
+112 ;PSOHY("PRIOR")=PRIORITY (SET OF CODES, 52.41,25 - STAT, EMERGENCY, ROUTINE)
+113 ;PSOHY("EXAPP")=EXTERNAL APPLICATION (FREE TEXT), LIKELY "PSO" - NO MAPPING TO 52.49
+114 ;PSOHY("PRCOM",#)=PROVIDER COMMENTS (8- NOTES)
+115 ;PSOHY("SIG",#)=SIG (52.4911 (STRUCTURED SIG), FIELD 1 (SIG FREE TEXT)
+116 ;PSOHY("QTSUB",CNT)=QUANTITY TIMING SUBFILE DATA. MERGED IN, FULL SUBFILE DATA
+117 ; 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
+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
+8 SET RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
IF RXSTAT="RJ"!(RXSTAT="RM")!($GET(MBMSITE)&($EXTRACT(RXSTAT,1,3)="REM"))!(RXSTAT="PR")!(RXSTAT="RXP")
Begin DoDot:1
+9 WRITE !!,"Cannot accept a prescription with a status of 'Rejected', 'Removed',",!,"or 'Processed",!
+10 SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
+11 SET PSOIENS=PSOIEN_","
+12 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")
+13 SET PSOEXCNT=0
+14 SET MTYPE=$GET(PSODAT(F,PSOIENS,.08,"I"))
+15 SET RESTYPE=$GET(PSODAT(F,PSOIENS,52.1,"I"))
+16 IF MTYPE="RE"
IF RESTYPE'="R"
Begin DoDot:1
+17 SET REQIEN=$$GETREQ^PSOERXU2(PSOIEN)
+18 IF REQIEN
SET RXIEN=$$GET1^DIQ(52.49,REQIEN,.13,"I")
+19 DO PREFRES^PSOERXU3(PSOIEN,.PSOHY,.PSOEXCNT,.PSOEXMS,.PSODAT)
+20 DO RRDELTA^PSOERXU2(.DELTAS,REQIEN,PSOIEN)
+21 IF $ORDER(PSOEXMS(0))
IF RESTYPE="AWC"
IF $DATA(DELTAS(52.49,"EXTERNAL PROVIDER"))
Begin DoDot:2
+22 DO MSGDIR^PSOERXU1(.PSOEXMS)
End DoDot:2
QUIT
+23 IF $ORDER(PSOEXMS(0))
IF $EXTRACT(RESTYPE)="A"
IF '$DATA(DELTAS(52.49,"EXTERNAL PROVIDER"))
Begin DoDot:2
+24 DO UPDSTAT^PSOERXU1(PSOIEN,"RXF","Unable to add order to Pending file.")
QUIT
End DoDot:2
QUIT
+25 IF $DATA(DELTAS(52.49,"EXTERNAL PROVIDER"))
DO ADD
QUIT
+26 ; call using silent mode if this is auto-processing
+27 DO ADD(1)
End DoDot:1
QUIT
+28 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
+29 IF MTYPE="N"!(MTYPE="RE"&(RESTYPE="R")!(MTYPE="CX"))
Begin DoDot:1
+30 SET PMVAL=$GET(PSODAT(F,PSOIENS,1.7,"I"))
IF 'PMVAL
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Patient has not been manually validated."
+31 SET PRMVAL=$GET(PSODAT(F,PSOIENS,1.3,"I"))
IF 'PRMVAL
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Provider has not been manually validated."
+32 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
+33 ; for now, if validations have not occurred, do not check the other fields.
+34 IF $ORDER(PSOEXMS(0))
DO MSGDIR^PSOERXU1(.PSOEXMS)
QUIT
+35 SET POORD=$GET(PSODAT(F,PSOIENS,25.2,"I"))
IF POORD
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Pending outpatient order already exists."
+36 SET PATIEN=$GET(PSODAT(F,PSOIENS,.05,"I"))
IF 'PATIEN
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="No matched vista patient."
+37 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."
+38 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."
+39 SET LOC=$GET(PSODAT(F,PSOIENS,20.6,"I"))
+40 SET ERXNUM=$GET(PSODAT(F,PSOIENS,.01,"E"))
IF 'ERXNUM
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="eRx number missing."
+41 SET VQTY=$GET(PSODAT(F,PSOIENS,20.1,"E"))
IF 'VQTY
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Quantity missing."
+42 SET EFFDT=$GET(PSODAT(F,PSOIENS,6.3,"I"))
SET WRITDT=$GET(PSODAT(F,PSOIENS,5.9,"I"))
+43 ; if the effective date is passed in and there is no time, add .000001 to the date
+44 IF EFFDT]""
SET EFFDT=$PIECE(EFFDT,".")
+45 IF '$LENGTH(EFFDT)
SET EFFDT=WRITDT
+46 SET VADAYS=$GET(PSODAT(F,PSOIENS,20.2,"E"))
+47 SET VAOI=$$GET1^DIQ(50,VADRUG,2.1,"I")
IF 'VAOI
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Orderable item not associated with drug."
+48 SET VAREF=$GET(PSODAT(F,PSOIENS,20.5,"E"))
+49 SET VAROUT=$GET(PSODAT(F,PSOIENS,20.4,"I"))
IF '$LENGTH(VAROUT)
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Pickup routing missing."
+50 SET PATINST=$GET(PSODAT(F,PSOIENS,27,"E"))
+51 DO TXT2ARY^PSOERXD1(.PINARY,$$LSIG^PSOERXU6(PATINST))
+52 ; get provider comments from VA PROVIDER COMMENTS field
+53 SET PRVCOMM=$GET(PSODAT(F,PSOIENS,30,"E"))
+54 DO TXT2ARY^PSOERXD1(.PRVARY,$$LSIG^PSOERXU6(PRVCOMM))
+55 SET (PLOOP,PCNT)=0
FOR
SET PLOOP=$ORDER(PRVARY(PLOOP))
if 'PLOOP
QUIT
Begin DoDot:1
+56 SET PCNT=PCNT+1
SET PSOHY("PRCOM",PCNT)=$GET(PRVARY(PLOOP))
End DoDot:1
+57 IF '$ORDER(^PS(52.49,PSOIEN,21,0))
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Dosing information missing."
+58 SET (QTLOOP,QTCNT)=0
FOR
SET QTLOOP=$ORDER(^PS(52.49,PSOIEN,21,QTLOOP))
if 'QTLOOP
QUIT
Begin DoDot:1
+59 SET QTCNT=QTCNT+1
MERGE PSOHY("QTSUB",QTCNT)=^PS(52.49,PSOIEN,21,QTLOOP)
End DoDot:1
+60 ; always 'routine' for now
+61 SET VAPRIOR="R"
+62 ; always 'new' for this version
+63 IF '$LENGTH($GET(ORDERTYP))
SET ORDERTYP="NW"
+64 SET PSOHY("LOC")=LOC
SET PSOHY("CHNUM")=$GET(ERXNUM)
+65 SET PSOHY("PICK")=VAROUT
SET PSOHY("ENTER")=PROVIEN
+66 SET PSOHY("PROV")=PROVIEN
SET PSOHY("SDT")=EFFDT
+67 SET PSOHY("ITEM")=VAOI
SET PSOHY("DRUG")=VADRUG
+68 SET PSOHY("QTY")=VQTY
SET PSOHY("REF")=VAREF
+69 SET (PSOHY("PAT"),DFN)=PATIEN
SET PSOHY("OCC")=ORDERTYP
+70 ; Login date will always be the Message Received Date/Time
+71 SET PSOHY("EDT")=$$GET1^DIQ(52.49,PSOIEN,.03,"I")
SET PSOHY("PRIOR")=VAPRIOR
+72 ; ALWAYS PSO as the external application
+73 SET PSOHY("EXAPP")="PHARMACY"
+74 SET PSOHY("DAYS")=VADAYS
+75 ; sig from eRx
+76 SET (SLOOP,SCNT)=0
FOR
SET SLOOP=$ORDER(^PS(52.49,PSOIEN,"SIG",SLOOP))
if 'SLOOP
QUIT
Begin DoDot:1
+77 SET SIGDAT=$GET(^PS(52.49,PSOIEN,"SIG",SLOOP,0))
+78 SET SCNT=SCNT+1
SET PSOHY("SIG",SCNT)=SIGDAT
End DoDot:1
+79 SET SLOOP2=0
FOR
SET SLOOP2=$ORDER(PINARY(SLOOP2))
if 'SLOOP2
QUIT
Begin DoDot:1
+80 SET SCNT=SCNT+1
SET PSOHY("SIG",SCNT)=$GET(PINARY(SLOOP2))
End DoDot:1
+81 ; if provider, patient or drug is missing, no need to continue.
+82 ; future consideration - do we need to check more fields?
+83 DO ADD
+84 IF $GET(PSOEXMS)]""
WRITE !,PSOEXMS
SET DIR(0)="E"
DO ^DIR
KILL DIR
+85 KILL DFN
+86 QUIT
ADD(QUIET) ;Add CHCS message to Outpatient Pending Orders file
+1 NEW PSOHQ,PSOHQT,PSOCPEND,PSOHINI,PSOHINLO,ERXSTA,ORDNUM,ILOOP,IARY,PSSRET,RESTYPE,RTHIEN,RTHID,X
+2 SET (PSOHINI,PSOHINLO)=0
Begin DoDot:1
+3 IF $GET(PSOHY("LOC"))
SET PSOHINLO=$PIECE($GET(^SC(PSOHY("LOC"),0)),"^",4)
IF PSOHINLO
QUIT
End DoDot:1
+4 ; get institution from 52.49 if clinic was not passed in
+5 SET RESTYPE=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
+6 IF $GET(PSOHINLO)<1
SET PSOHINLO=$$GET1^DIQ(52.49,PSOIEN,24.1,"I")
+7 IF +$GET(PSOHINLO)<1
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Unable to derive Institution from Clinic."
QUIT
+8 KILL DD,DO,DIC
SET X=PSOHY("CHNUM")
SET DIC="^PS(52.41,"
SET DIC(0)="L"
+9 if $GET(PSOHY("PICK"))=""
SET PSOHY("PICK")="M"
+10 SET DIC("DR")="4////"_$GET(PSOHY("ENTER"))_";5////"_PSOHY("PROV")_";6////"_$GET(PSOHY("SDT"))_";8////"_PSOHY("ITEM")_";11////"_PSOHY("DRUG")
+11 SET DIC("DR")=$GET(DIC("DR"))_";12////"_$GET(PSOHY("QTY"))_";13////"_$GET(PSOHY("REF"))_";22.1////"_$GET(PSOHY("PREVORD"))_";101////"_$GET(PSOHY("DAYS"))
+12 DO FILE^DICN
KILL DD,DIC,DO
IF Y<0
Begin DoDot:1
+13 SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="Unable to add order to Pending file."
+14 IF MTYPE="RE"
DO UPDSTAT^PSOERXU1(PSOIEN,"RXF",PSOEXMS(PSOEXCNT))
+15 SET REQIEN=$$GETREQ^PSOERXU2(PSOIEN)
IF REQIEN
DO UPDSTAT^PSOERXU1(PSOIEN,"RRF",PSOEXMS)
End DoDot:1
QUIT
+16 SET PSOCPEND=+Y
+17 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"))
+18 SET $PIECE(^PS(52.41,PSOCPEND,0),"^",14)=$GET(PSOHY("PRIOR"))
SET $PIECE(^(0),"^",17)=$GET(PSOHY("PICK"))
+19 SET $PIECE(^PS(52.41,PSOCPEND,"EXT"),"^")=PSOHY("CHNUM")
SET $PIECE(^("EXT"),"^",2)=0
SET $PIECE(^("EXT"),"^",3)=PSOHY("EXAPP")
+20 SET DIE="^PS(52.41,"
SET DA=PSOCPEND
SET DR="104.1///1"
DO ^DIE
KILL DIE,DA,DR
+21 ; PSO*7*506
+22 SET FDA(52.41,PSOCPEND_",",104)=$GET(PATINST)
DO FILE^DIE(,"FDA")
KILL FDA
+23 NEW DA,DIK
SET DA=PSOCPEND
SET DIK="^PS(52.41,"
SET DIK(1)="114^C"
DO EN1^DIK
+24 IF $ORDER(PSOHY("PRCOM",0))
Begin DoDot:1
+25 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_"^"
+26 IF $ORDER(PSOHY("SIG",0))
Begin DoDot:1
+27 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
+28 SET $PIECE(^PS(52.41,PSOCPEND,"INI"),"^")=$GET(PSOHINLO)
+29 ; add quantity/timing subfile information
+30 IF $ORDER(PSOHY("QTSUB",0))
Begin DoDot:1
+31 SET PSOHQ=""
SET PSOHQT=0
FOR
SET PSOHQ=$ORDER(PSOHY("QTSUB",PSOHQ))
if PSOHQ=""
QUIT
Begin DoDot:2
+32 IF $ORDER(PSOHY("QTSUB",PSOHQ,0))
SET PSOHQT=PSOHQT+1
+33 SET ^PS(52.41,PSOCPEND,1,PSOHQT,0)=PSOHY("QTSUB",PSOHQ,0)
+34 SET ^PS(52.41,PSOCPEND,1,PSOHQT,1)=PSOHY("QTSUB",PSOHQ,1)
+35 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
+36 IF $ORDER(PINARY(0))
DO WP^DIE(52.41,PSOCPEND_",",105,"K","PINARY")
+37 ;Cross references not set yet preventing Pharmacy from finishing order
+38 DO EN^PSOHLSNC(PSOCPEND,"SN","IP")
+39 DO FULL^VALM1
+40 ;Just set to DC, don't delete because 52.41 entry would be re-used
+41 IF '$PIECE($GET(^PS(52.41,PSOCPEND,"EXT")),"^",2)
Begin DoDot:1
+42 ;x-ref shouldn't be set, but we'll kill them just in case
+43 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)
+44 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)
+45 SET $PIECE(^PS(52.41,PSOCPEND,4),"^")="External order, unable to successfully transmit to CPRS."
+46 IF $DATA(QUIET)
SET PSOEXCNT=PSOEXCNT+1
SET PSOEXMS(PSOEXCNT)="External order, unable to successfully transmit to CPRS."
+47 IF '$DATA(QUIET)
WRITE !!,"External order, unable to successfully transmit to CPRS."
+48 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
+49 ;Successful transmission to CPRS
+50 SET DA=PSOCPEND
SET DIK="^PS(52.41,"
DO IX^DIK
+51 ; add the pending outpatient order number to 52.49 and update status of eRx to PR (Processed)
+52 SET ERXSTA=$ORDER(^PS(52.45,"C","ERX","PR",0))
+53 SET ORDNUM=$PIECE($GET(^PS(52.41,PSOCPEND,0)),U)
+54 SET DIE="^PS(52.49,"
SET DR="25.2///"_PSOCPEND_";.12///"_ORDNUM
SET DA=PSOIEN
DO ^DIE
KILL DIE,DA,DR
+55 ; PSO*7*508 - add checks to update refill requests and responses
+56 ; add activity to status history
+57 IF MTYPE="N"
DO UPDSTAT^PSOERXU1(PSOIEN,"PR")
+58 IF MTYPE="RE"
DO UPDSTAT^PSOERXU1(PSOIEN,"RXP")
+59 ;B3S4
+60 IF MTYPE="CX"
Begin DoDot:1
+61 DO UPDSTAT^PSOERXU1(PSOIEN,"CXP")
+62 SET RTHID=$$GET1^DIQ(52.49,PSOIEN,.14)
SET RTHIEN=$ORDER(^PS(52.49,"FMID",RTHID,0))
+63 DO UPDSTAT^PSOERXU1(RTHIEN,"CRP")
End DoDot:1
+64 SET REQIEN=$$GETREQ^PSOERXU2(PSOIEN)
IF REQIEN
IF $$GET1^DIQ(52.49,REQIEN,.08,"I")="RR"
DO UPDSTAT^PSOERXU1(REQIEN,"RRP")
+65 ; PSO*7*508 - end
+66 ; gather the unexpanded sig and file in 52.41
+67 SET ILOOP=0
FOR
SET ILOOP=$ORDER(^PS(52.49,PSOIEN,31,ILOOP))
if 'ILOOP
QUIT
Begin DoDot:1
+68 SET IARY(ILOOP)=$GET(^PS(52.49,PSOIEN,31,ILOOP,0))
End DoDot:1
+69 IF $DATA(IARY)
DO WP^DIE(52.41,PSOCPEND_",",9,"K","IARY","IERR")
+70 IF '$DATA(QUIET)
WRITE !!,"eRx #"_PSOHY("CHNUM")_" sent to PENDING OUTPATIENT ORDERS!"
+71 ;PSO*7*520 - add sending and warning/information related to RxVerify Message.
+72 IF MTYPE="N"!((MTYPE="RE")&(RESTYPE="R"))!(MTYPE="CX")
Begin DoDot:1
+73 WRITE !!,"Sending rxVerify Message to prescriber."
+74 DO POST^PSOERXO1(PSOIEN,.PSSRET,,,,1)
+75 ; if the post was unsuccessful, inform the user and quit.
+76 IF $PIECE(PSSRET(0),U)<1
WRITE !,$PIECE(PSSRET(0),U,2)
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+77 IF $DATA(PSSRET("errorMessage"))
WRITE !,PSSRET("errorMessage")
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
End DoDot:1
+78 ;PSO*7*520 - end rxVerify changes
+79 KILL QUIET
+80 QUIT
+81 ; remove eRx from holding queue
REM ;
+1 DO REM^PSOERXU4
+2 QUIT
+3 ; unremove eRx from holding queue
UNREM ;
+1 DO UNREM^PSOERXU4
+2 QUIT
+3 ; reject eRx
REJ ;
+1 DO REJ^PSOERXU4
