PSOERXU1 ;ALB/BWF - eRx utilities ; 1/27/2019 11:03am
;;7.0;OUTPATIENT PHARMACY;**467,520,508,551,565,581,617,651,700,746,770**;DEC 1997;Build 145
;
Q
; OR0 - OR0 FROM PENDING OUTPATIENT ORDERS OR BACKDOOR ORDERS
; OR0 can also be just the order number
CHKERX(OR0) ;
N ORIEN,ERXIEN
S ORIEN=$P(OR0,U) Q:'ORIEN 0
I '$D(^PS(52.49,"ORN",ORIEN)) Q 0
S ERXIEN=$O(^PS(52.49,"ORN",ORIEN,0))
I 'ERXIEN Q 0
Q ERXIEN
PROVPMT(ERXIEN) ;
N ERXPHYS,ERXPHNM,ERXCON,DIR,Y,OLDQUIT,NEWQUIT,COMMIEN,PHONECHK
S OLDQUIT=0,NEWQUIT=0
S $P(LINE,"*",80)="" W !!,LINE
S S2017=$$GET1^DIQ(52.49,ERXIEN,312.1)
W !!,"This prescription is an inbound electronic prescription (eRx)."
W !,"Please contact the original provider for approval to renew.",$C(7)
D PAUSE^PSOSPMU1
S ERXPHYS=$$GET1^DIQ(52.49,ERXIEN,2.1,"I")
S ERXPHNM=$$GET1^DIQ(52.48,ERXPHYS,.01,"E") W !,ERXPHNM
I '$G(S2017) D
.I '$D(^PS(52.48,ERXPHYS,3,"C","TE")) W !!,"No telephone information on file for this provider." D
..S OLDQUIT=1
I OLDQUIT=1 Q 0
I $G(S2017) D
.S PHONECHK=$$COMMVAL^PSOERXU5(ERXPHYS,52.48,11,"PT")
.I '$G(PHONECHK) S NEWQUIT=1
I NEWQUIT=1 Q 0
W !
S ERXCON=0 F S ERXCON=$O(^PS(52.48,ERXPHYS,3,"C","TE",ERXCON)) Q:'ERXCON D
.W !,"Telephone: "_$$GET1^DIQ(52.483,ERXCON_","_ERXPHYS_",",.01,"E")
W !!,"Answering 'Yes' indicates you have contacted the prescribing physician"
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Would you like to proceed with renewing this prescription" D ^DIR K DIR
I Y=1 Q 1
Q 0
DERX1(GL,PSOIEN,DFLG,IEN,CALLER) ;
;Input:(r) GL - ListMan global/variable where the eRx data should be set (e.g., $NA(^TMP("PSOAO",$J)))
; (r) PSOIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
; (o) DFLG - Skip Additional Drug Information (Unit of Measure, Form, Strenght, etc...)? (1: YES | 0: NO)
; (o) IEN - Last line used (start after this line)
; (o) CALLER - Calling functionality ("P" - Pending Order, "A" - Active Rx, "H" - Holding Queue, etc.)
; Note: Variables PKID and PKIE are utilized outside this routine
N EDRG,ERXDAT,ESIG,COMM,SUBS,DFORM,DSTR,QQUAL,POTUC,QTY,DAYS,REFILL,PSOIENS,LINE,LINETXT,ADLINE,ADARY,ALOOP,COMMARY
N ERXPAT,ERXPIEN,ERXPDOB,ERXPSSN,ERXPROV,ERXPRIEN,ERXPRDEA,ERXPRNPI,ERXPRSA1,ERXPRSA2,ERXPRCTY,ERXPRST,ERXPRZIP,I,PROVPHON
N PROVDAT,SIGARY,STHIS,STAT,ACBY,FOUND,ACDTTM,DRGARY,DLP,CTYSTZIP,ADLINE1,MTYPE,ERXDSUB,S2017,PHW,MIEN,ERXEFFDT,ERXWDATE
N PROHIBIT,SGLOOP
Q:'$G(PSOIEN)
S PSOIENS=PSOIEN_","
D GETS^DIQ(52.49,PSOIENS,".04;.08;2.1;3.1;4.6;4.8;5.1;5.2;5.4;5.5;5.6;5.7;5.8;7;8;41;42;43;312.1","IE","ERXDAT")
S S2017=$G(ERXDAT(52.49,PSOIENS,312.1,"I"))
S DFLG=$G(DFLG,"")
S EDRG=$G(ERXDAT(52.49,PSOIENS,3.1,"E"))
S ESIG=$G(ERXDAT(52.49,PSOIENS,7,"E"))
S COMM=$G(ERXDAT(52.49,PSOIENS,8,"E"))
S SUBS=$G(ERXDAT(52.49,PSOIENS,5.8,"E"))
S DFORM=$G(ERXDAT(52.49,PSOIENS,41,"E"))
S DSTR=$G(ERXDAT(52.49,PSOIENS,43,"E"))
S MTYPE=$G(ERXDAT(52.49,PSOIENS,.08,"I"))
I 'S2017 D
.S QQUAL=$G(ERXDAT(52.49,PSOIENS,5.2,"E"))
I S2017 D
.I MTYPE'="RE" S MIEN=$O(^PS(52.49,PSOIEN,311,"C","P",0))
.I MTYPE="RE" S MIEN=$O(^PS(52.49,PSOIEN,311,"C","MR",0))
.S QQUAL=$$GET1^DIQ(52.49311,MIEN_","_PSOIEN_",",2.2,"I"),QQUAL=$$GET1^DIQ(52.45,QQUAL,.02,"E")
S POTUC=$G(ERXDAT(52.49,PSOIENS,42,"E"))
S QTY=$G(ERXDAT(52.49,PSOIENS,5.1,"E"))
S DAYS=$G(ERXDAT(52.49,PSOIENS,5.5,"E"))
S REFILL=$G(ERXDAT(52.49,PSOIENS,5.6,"E"))
I MTYPE="RE",REFILL>0 S REFILL=REFILL-1
I '$$GET1^DIQ(52.49,PSOIEN,312.1) D
.I REFILL="" D
..S REFILL=$G(ERXDAT(52.49,PSOIENS,5.7,"I"))
S ERXPAT=$G(ERXDAT(52.49,PSOIENS,.04,"E"))
S ERXPIEN=$G(ERXDAT(52.49,PSOIENS,.04,"I"))
S ERXPDOB=$$GET1^DIQ(52.46,ERXPIEN,.08,"E")
S ERXPSSN=$$GET1^DIQ(52.46,ERXPIEN,$S(S2017:18.2,1:1.4),"E")
S ERXPROV=$G(ERXDAT(52.49,PSOIENS,2.1,"E"))
S ERXPRIEN=$G(ERXDAT(52.49,PSOIENS,2.1,"I"))
S PROVPHON=$$COMMVAL^PSOERXU5(ERXPRIEN,52.48,11,"PT",1)
N FIELDS
S FIELDS=$S(2017:"14.5;15.1",1:"1.5;1.6")_";4.1;4.2;4.3;4.4;4.5"
D GETS^DIQ(52.48,ERXPRIEN_",",FIELDS,"E","PROVDAT")
I S2017 D
.S ERXPRDEA=$G(PROVDAT(52.48,ERXPRIEN_",",14.5,"E"))
.S ERXPRNPI=$G(PROVDAT(52.48,ERXPRIEN_",",15.1,"E"))
I 'S2017 D
.S ERXPRDEA=$G(PROVDAT(52.48,ERXPRIEN_",",1.6,"E"))
.S ERXPRNPI=$G(PROVDAT(52.48,ERXPRIEN_",",1.5,"E"))
S ERXPRSA1=$G(PROVDAT(52.48,ERXPRIEN_",",4.1,"E"))
S ERXPRSA2=$G(PROVDAT(52.48,ERXPRIEN_",",4.2,"E"))
S ERXPRCTY=$G(PROVDAT(52.48,ERXPRIEN_",",4.3,"E"))
S ERXPRST=$G(PROVDAT(52.48,ERXPRIEN_",",4.4,"E"))
S ERXPRZIP=$G(PROVDAT(52.48,ERXPRIEN_",",4.5,"E"))
D TXT2ARY^PSOERXD1(.SIGARY,ESIG,,69)
D TXT2ARY^PSOERXD1(.COMMARY,COMM,,65)
S STHIS=99999,FOUND=0
F S STHIS=$O(^PS(52.49,PSOIEN,19,STHIS),-1) Q:'STHIS!(FOUND) D
.S STAT=$$GET1^DIQ(52.4919,STHIS_","_PSOIENS,.02,"I")
.I ",PR,RXP,CXP,"[(","_$$GET1^DIQ(52.45,STAT,.01,"E")_",") D
..S ACDTTM=$$GET1^DIQ(52.4919,STHIS_","_PSOIENS,.01,"E")
..S ACBY=$$GET1^DIQ(52.4919,STHIS_","_PSOIENS,.03,"E"),FOUND=1
S PKID=0,PKIE=""
I $G(CALLER)="P",$$GET1^DIQ(52.49,PSOIEN,95.1,"I"),$$CS^PSOERXA0($$GET1^DIQ(52.49,PSOIEN,3.2,"I")) D
. S IEN=IEN+1,@GL@(IEN,0)="Processing Digitally Signed eRx order"
. S PKID=1,PKIE="Processing Digitally Signed eRx order"
I $L($G(ACBY)) S IEN=IEN+1,@GL@(IEN,0)="eRx Accepted By: "_ACBY_" ("_ACDTTM_")"
S LINETXT=""
D ADDITEM^PSOERX1A(.LINETXT,"eRx Patient: ",ERXPAT,1,55)
D ADDITEM^PSOERX1A(.LINETXT,"SSN: ",ERXPSSN,57,20)
S IEN=IEN+1,@GL@(IEN,0)=LINETXT
S LINETXT=""
I $L(ERXPAT)>42 D ADDITEM^PSOERX1A(.LINETXT," ",$E(ERXPAT,43,84),1,55)
D ADDITEM^PSOERX1A(.LINETXT,"DOB: ",ERXPDOB,57,20)
S IEN=IEN+1,@GL@(IEN,0)=LINETXT
I $L(ERXPAT)>84 D
.S IEN=IEN+1,@GL@(IEN,0)=" "_$E(ERXPAT,85,117)
I $L(ERXPAT)>117 D
.S IEN=IEN+1,@GL@(IEN,0)=" "_$E(ERXPAT,118,135)
S IEN=IEN+1,@GL@(IEN,0)=""
I S2017 D
.S PHW=$$BHW^PSOERXIU(PSOIEN) S IEN=IEN+1,@GL@(IEN,0)=PHW
S LINETXT=""
D ADDITEM^PSOERX1A(.LINETXT,"eRx Provider: ",$E(ERXPROV,1,55),1,55)
D ADDITEM^PSOERX1A(.LINETXT,"DEA: ",ERXPRDEA,57,20)
S IEN=IEN+1,@GL@(IEN,0)=LINETXT,LINETXT=""
I $L(ERXPROV)>55 D ADDITEM^PSOERX1A(.LINETXT," ",$E(ERXPROV,56,96),1,55)
D ADDITEM^PSOERX1A(.LINETXT,"eRx Phone: ",PROVPHON,1,40)
D ADDITEM^PSOERX1A(.LINETXT,"NPI: ",ERXPRNPI,57,20)
S IEN=IEN+1,@GL@(IEN,0)=LINETXT,LINETXT=""
I $L(ERXPROV)>96 D ADDITEM^PSOERX1A(.LINETXT," ",$E(ERXPROV,97,135),1,55)
S IEN=IEN+1,@GL@(IEN,0)=LINETXT,LINETXT=""
S ADLINE1=$S($L(ERXPRSA1):ERXPRSA1,1:"ADDRESS UNKNOWN ")
S CTYSTZIP=$S($L(ERXPRCTY):ERXPRCTY_",",1:"")
S CTYSTZIP=CTYSTZIP_$S($L(ERXPRST):ERXPRST_" ",1:"")
S CTYSTZIP=" "_CTYSTZIP_$S($L(ERXPRZIP):ERXPRZIP,1:"")
S IEN=IEN+1,@GL@(IEN,0)="Address: "_ADLINE1
S IEN=IEN+1,@GL@(IEN,0)=CTYSTZIP
I $L(ERXPRSA2) D
.S IEN=IEN+1,@GL@(IEN,0)="Address Line 2: "_ERXPRSA2
I $O(ADARY(0)) D
.S ALOOP=1 F S ALOOP=$O(ADARY(ALOOP)) Q:'ALOOP D
..S IEN=IEN+1,@GL@(IEN,0)=" "_ADARY(ALOOP)
S IEN=IEN+1,@GL@(IEN,0)=""
D TXT2ARY^PSOERXD1(.DRGARY,EDRG,,70)
S IEN=IEN+1,@GL@(IEN,0)="eRx Drug: "_$G(DRGARY(1))_" "_$P($$ERXDRSCH^PSOERXUT(PSOIEN),"^",2)
S DLP=1
F S DLP=$O(DRGARY(DLP)) Q:'DLP D
.S IEN=IEN+1,@GL@(IEN,0)=" "_$G(DRGARY(DLP))
S LINETXT=""
D ADDITEM^PSOERX1A(.LINETXT,"Qty: ",QTY,1,25)
D ADDITEM^PSOERX1A(.LINETXT,"Days Supply: ",DAYS,27,16)
D ADDITEM^PSOERX1A(.LINETXT,"Refills: ",REFILL,58,20)
S IEN=IEN+1,@GL@(IEN,0)=LINETXT
I 'S2017 D
.S IEN=IEN+1,@GL@(IEN,0)="eRx Written Date: "_$$FMTE^XLFDT($P($$GET1^DIQ(52.49,PSOIEN,5.9,"I"),"@"),"2D")_" eRx Received Date: "_$$FMTE^XLFDT($P($$GET1^DIQ(52.49,PSOIEN,.03,"I"),"@"),"2D")
I S2017 D
.S MIEN=$O(^PS(52.49,PSOIEN,311,0))
.S ERXEFFDT=$$EFFDATE^PSOERXU5(PSOIEN,MIEN)
.S ERXWDATE=$$GET1^DIQ(52.49,PSOIEN,5.9,"I")
.W !,"eRx Written Date: "_$$FMTE^XLFDT($P(ERXWDATE,"."),1)_" eRx Issue Date: "_ERXEFFDT
S ERXDSUB=$$GET1^DIQ(52.49,PSOIEN,5.8,"I")
S ERXDSUB=$S(ERXDSUB=1:"NO",ERXDSUB=0:"YES",1:"")
S LINETXT=""
D ADDITEM^PSOERX1A(.LINETXT,"Substitutions? :",ERXDSUB,1,25)
S IEN=IEN+1,@GL@(IEN,0)=LINETXT
I 'S2017 D
.S IEN=IEN+1,@GL@(IEN,0)="eRx Sig: "
.S I=0 F S I=$O(SIGARY(I)) Q:'I D
..I I=1 S @GL@(IEN,0)=@GL@(IEN,0)_SIGARY(I) Q
..S IEN=IEN+1,@GL@(IEN,0)=$S(I>1:" "_SIGARY(I),1:SIGARY(I))
.I '$L(ESIG) S IEN=IEN+1,@GL@(IEN,0)=""
I S2017,MTYPE?1(1"N",1"RE",1"CX") D
.I MTYPE?1(1"N",1"CX") D
..S PROHIBIT=$$GET1^DIQ(52.49,PSOIEN,301.3,"I")
..S PROHIBIT=$S(PROHIBIT=1:"Yes",1:"No")
..S IEN=IEN+1,@GL@(IEN,0)="Prohibit Renewals: "_PROHIBIT
..S IEN=IEN+1,@GL@(IEN,0)=""
.S IEN=IEN+1,@GL@(IEN,0)="eRx Sig:"
.S SGLOOP=0 F S SGLOOP=$O(^PS(52.49,PSOIEN,311,MIEN,8,SGLOOP)) Q:'SGLOOP D
..S IEN=IEN+1,@GL@(IEN,0)=$G(^PS(52.49,PSOIEN,311,MIEN,8,SGLOOP,0))
.S IEN=IEN+1,@GL@(IEN,0)=""
S IEN=IEN+1,@GL@(IEN,0)="eRx Notes: "
S I=0 F S I=$O(COMMARY(I)) Q:'I D
.I I=1 S @GL@(IEN,0)=@GL@(IEN,0)_$S(I>1:" "_COMMARY(I),1:COMMARY(I)) Q
.S IEN=IEN+1,@GL@(IEN,0)=$S(I>1:" "_COMMARY(I),1:COMMARY(I))
I '$L(COMM) S IEN=IEN+1,@GL@(IEN,0)=""
Q:DFLG=1
S LINETXT=""
S IEN=IEN+1,@GL@(IEN,0)=""
S IEN=IEN+1,@GL@(IEN,0)="Drug Form: "_DFORM
S IEN=IEN+1,@GL@(IEN,0)="Strength: "_DSTR
S LINETXT=""
S IEN=IEN+1,@GL@(IEN,0)="Code List Qualifier: "_QQUAL
S IEN=IEN+1,@GL@(IEN,0)="Quantity Unit of Measure: "_POTUC
S IEN=IEN+1,@GL@(IEN,0)=LINETXT
S ERXDSUB=$$GET1^DIQ(52.49,PSOIEN,5.8,"I")
S ERXDSUB=$S(ERXDSUB=1:"NO",ERXDSUB=0:"YES",1:"")
S IEN=IEN+1,@GL@(IEN,0)="Substitutions?: "_ERXDSUB
S IEN=IEN+1,@GL@(IEN,0)=""
I '$G(S2017) D DIAG(PSOIEN,.IEN,.GL)
I $G(S2017),MIEN D DIAG2017^PSOERXU5(PSOIEN,.IEN,.GL,MIEN)
S $P(LINE,"-",80)=""
S IEN=IEN+1,@GL@(IEN,0)=LINE
Q
; diagnosis information
DIAG(PSOIEN,LINE,GL) ;
N DIAGIEN,DIAGDAT,DIAGSEQ,PDIAGQ,PDIAGV,SDIAGQ,SDIAGV,DIAGDAT,DIACIC,DRES,SDRES,PDIAGTXT,SDIAGTXT
N SDRESL,SDRESDAT,DRESL,DRESDAT,PDIAGARY,SDIAGARY,PDFRST,SDFRST,PDLOOP,SDLOOP,DIENS
S DIAGIEN=0 F S DIAGIEN=$O(^PS(52.49,PSOIEN,9,DIAGIEN)) Q:'DIAGIEN D
.S DIENS=DIAGIEN_","_PSOIEN_"," K PDIAGARY,SDIAGARY,DIAGDAT
.D GETS^DIQ(52.499,DIENS,".01:.06","IE","DIAGDAT")
.S DIAGSEQ=$G(DIAGDAT(52.499,DIENS,.01,"E"))
.S DIACIC=$G(DIAGDAT(52.499,DIENS,.02,"E"))
.S PDIAGQ=$G(DIAGDAT(52.499,DIENS,.03,"E"))
.S PDIAGV=$G(DIAGDAT(52.499,DIENS,.04,"E"))
.I PDIAGQ["ICD" D
..K DRES,PDIAGARY
..D ICDDESC^ICDXCODE(PDIAGQ,PDIAGV,,.DRES)
..I '$O(DRES(0)) D TXT2ARY^PSOERXD1(.PDIAGARY,"Primary Dx: ("_PDIAGQ_" - "_PDIAGV_")"," ",78) Q
..S PDIAGTXT="Primary Dx: ("_PDIAGQ_" "_PDIAGV_") "
..S DRESL=0 F S DRESL=$O(DRES(DRESL)) Q:'DRESL D
...S DRESDAT=$G(DRES(DRESL)) Q:DRESDAT=""
...S PDIAGTXT=$G(PDIAGTXT)_" "_DRESDAT
..D TXT2ARY^PSOERXD1(.PDIAGARY,PDIAGTXT," ",78)
.S SDIAGQ=$G(DIAGDAT(52.499,DIENS,.05,"E"))
.S SDIAGV=$G(DIAGDAT(52.499,DIENS,.06,"E"))
.I SDIAGQ["ICD" D
..K SDRES,SDIAGARY
..D ICDDESC^ICDXCODE(SDIAGQ,SDIAGV,,.SDRES)
..I '$O(DRES(0)) D TXT2ARY^PSOERXD1(.SDIAGARY,"Secondary Dx: ("_SDIAGQ_" - "_SDIAGV_")"," ",78) Q
..S SDIAGTXT="Secondary Dx: ("_SDIAGQ_" "_SDIAGV_") "
..S SDRESL=0 F S SDRESL=$O(SDRES(SDRESL)) Q:'SDRESL D
...S SDRESDAT=$G(SDRES(SDRESL)) Q:SDRESDAT=""
...S SDIAGTXT=$G(SDIAGTXT)_" "_SDRESDAT
..D TXT2ARY^PSOERXD1(.SDIAGARY,SDIAGTXT," ",78)
.I '$D(PDIAGARY) D TXT2ARY^PSOERXD1(.PDIAGARY,"Primary Dx: ("_PDIAGQ_" - "_PDIAGV_")"," ",78)
.S PDFRST=$O(PDIAGARY(0))
.S LINE=LINE+1
.I $D(GL) D SETGL(LINE,PDIAGARY(PDFRST))
.I '$D(GL) D SETLOC(LINE,$G(PDIAGARY(PDFRST)))
.S PDLOOP=PDFRST F S PDLOOP=$O(PDIAGARY(PDLOOP)) Q:'PDLOOP D
..S LINE=LINE+1
..I $D(GL) D SETGL(LINE," "_$G(PDIAGARY(PDLOOP)))
..I '$D(GL) D SETLOC(LINE," "_$G(PDIAGARY(PDLOOP)))
.S LINE=LINE+1
.I $D(GL) D SETGL(LINE,"")
.I '$D(GL) D SETLOC(LINE,"")
.I '$D(SDIAGARY) D TXT2ARY^PSOERXD1(.SDIAGARY,"Secondary Dx: ("_SDIAGQ_" - "_SDIAGV_")"," ",78)
.S SDFRST=$O(SDIAGARY(0))
.S LINE=LINE+1
.I $D(GL) D SETGL(LINE,$G(SDIAGARY(SDFRST)))
.I '$D(GL) D SETLOC(LINE,$G(SDIAGARY(SDFRST)))
.S SDLOOP=SDFRST F S SDLOOP=$O(SDIAGARY(SDLOOP)) Q:'SDLOOP D
..S LINE=LINE+1
..I $D(GL) D SETGL(LINE," "_$G(SDIAGARY(SDLOOP)))
..I '$D(GL) D SETLOC(LINE," "_$G(SDIAGARY(SDLOOP)))
.I $O(^PS(52.49,PSOIEN,9,DIAGIEN)) D
..S LINE=LINE+1
..I $D(GL) D SETGL(LINE,"")
..I '$D(GL) D SETLOC(LINE,"")
Q
SETLOC(LINE,TEXT) ;
D SET^VALM10(LINE,TEXT)
Q
SETGL(IEN,TEXT) ;
S @GL@(IEN,0)=TEXT
Q
OPACCESS(OPTION,DUZ,ERXIEN) ;
N ERXIEN2
S ERXIEN2=$G(ERXIEN)
Q $$OPACCESS^PSOERXU7(OPTION,DUZ,ERXIEN2)
; update the status of an eRx
; PSOIEN - ien for file 52.49 (required)
; STAT - The status value to change the eRx to (required)
; SCOMM - status comments (optional)
; UNACC - (o) eRx Un-Accepted at the Pending Queue 1-YES/0-NO (Optional - Default: NO)
; ALTDUZ - (o) Alternative DUZ (Used for Proxy user for automatic un-holds)
; HFFDT - (o) Hold Future Fill Date
UPDSTAT(PSOIEN,STAT,SCOMM,UNACC,ALTDUZ,HFFDT) ;
N MBMSITE,DIE,NSTAT,DA,DR,FDA,TYPE
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
Q:'PSOIEN!(STAT="")
I '$G(MBMSITE) D
. I '$D(^PS(52.45,"C","ERX",STAT)) Q
. S NSTAT=$O(^PS(52.45,"C","ERX",STAT,0))
; Exception for MbM sites to treat REMOVAL Reasons as Statuses
I $G(MBMSITE) D
. S TYPE=$S($E(STAT,1,3)="REM":"REM",1:"ERX")
. I '$D(^PS(52.45,"C",TYPE,STAT)) Q
. S NSTAT=$O(^PS(52.45,"C",TYPE,STAT,0))
I $G(NSTAT)="" Q
S DIE="^PS(52.49,",DA=+PSOIEN,DR="1///"_NSTAT D ^DIE
S FDA(52.4919,"+1,"_PSOIEN_",",.01)=$$NOW^XLFDT
S FDA(52.4919,"+1,"_PSOIEN_",",.02)=NSTAT
S FDA(52.4919,"+1,"_PSOIEN_",",.03)=$S($G(ALTDUZ):ALTDUZ,1:$G(DUZ))
S FDA(52.4919,"+1,"_PSOIEN_",",1)=$G(SCOMM)
I $G(UNACC) S FDA(52.4919,"+1,"_PSOIEN_",",.04)=+UNACC
I STAT="HFF",$G(HFFDT) S FDA(52.4919,"+1,"_PSOIEN_",",.05)=HFFDT
D UPDATE^DIE(,"FDA") K FDA
; Updating Future Fill Hold Date (if any)
I STAT="HFF",$G(HFFDT) D
. K DIE S DIE="52.49",DA=PSOIEN,DR="6.7///"_HFFDT
. ; If no Effective Date and No Refills on the eRx, HFFDT is more than 30 days from Written Date, set Effective Date with HFFDT (if not past limits for CS and Non-CS exp. Dates)
. I '$$GET1^DIQ(52.49,ERXIEN,6.3,"I"),'$$GET1^DIQ(52.49,ERXIEN,5.6,"I"),$$FMDIFF^XLFDT(HFFDT,$$GET1^DIQ(52.49,ERXIEN,5.9,"I"))>30 D
. . S DR=DR_";6.3///"_HFFDT
. D ^DIE K DIE
; Force a Refresh of the mail list
S PSORFRSH=1
Q
ERRSEQ(EIEN) ;
N SEQ
I '$O(^PS(52.49,EIEN,100,0)) S SEQ=1
I '$G(SEQ) S SEQ=$O(^PS(52.49,EIEN,100,999999),-1)+1
Q SEQ
;
; IENS - ien of the erx holding queue entry
; SEQ - sequence number of the error
; TYPE - type (d-drug, pr-provider, pa-patient, a-allergy, o-order check, t-transfer)
; SRC - v - vista, e - erx processing hub
; TXT - error text
FILERR(IENS,SEQ,TYPE,SRC,TXT) ;
N FDA
S FDA(52.49101,"+1,"_IENS,.01)=SEQ
S FDA(52.49101,"+1,"_IENS,.02)=TYPE
S FDA(52.49101,"+1,"_IENS,.03)=SRC
; all new errors are set to pending
S FDA(52.49101,"+1,"_IENS,.04)="P"
S FDA(52.49101,"+1,"_IENS,1)=TXT
D UPDATE^DIE(,"FDA") K FDA
; now set the eRx entry status to error
Q
MSGDIR(MSG) ;
N DIR,MLOOP,MTXT
S VALMBCK="R"
D FULL^VALM1
W !!,"Errors encountered during processing:",!
S MLOOP=0 F S MLOOP=$O(MSG(MLOOP)) Q:'MLOOP D
.S MTXT=$P($G(MSG(MLOOP)),"^") W !,MLOOP_".) ",MTXT
W !!,"Cannot process eRx.",!
I DUZ'=+$$PROXYDUZ^PSOERXUT() S DIR(0)="E" D ^DIR
Q
; provider change screen on refill response
CHPRCHG(ERXIEN) ;
N REQIEN,RESIEN,DELTA,MTYPE,RESVAL,MSTAT
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
S MSTAT=$$GET1^DIQ(52.49,ERXIEN,1,"E")
S RESVAL=$$GET1^DIQ(52.49,ERXIEN,52.1,"I")
I MTYPE="RE",((RESVAL="D")!(RESVAL="DNP")) Q 0
I MTYPE="RR"!(MTYPE="CA")!(MTYPE="CN")!(MTYPE="IE") Q 0
I MTYPE'="RE" Q 1
I MTYPE="RE",RESVAL="R",MSTAT'="RXP" Q 1
I MTYPE="RE",MSTAT="RXW"!(MSTAT="RXI") Q 1
I RESVAL'="AWC",MTYPE="RE",",RXP,RXC,RXD,"[MSTAT Q 0
I MTYPE="RE",($$GET1^DIQ(52.49,ERXIEN,52.1,"I")'["A") Q 0
S RESIEN=ERXIEN,REQIEN=$$GETREQ^PSOERXU2(ERXIEN)
D RRDELTA^PSOERXU2(.DELTA,REQIEN,RESIEN) Q:'$D(DELTA) 0
I $D(DELTA(52.49,"EXTERNAL PROVIDER")) Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXU1 16258 printed Sep 23, 2025@20:05:27 Page 2
PSOERXU1 ;ALB/BWF - eRx utilities ; 1/27/2019 11:03am
+1 ;;7.0;OUTPATIENT PHARMACY;**467,520,508,551,565,581,617,651,700,746,770**;DEC 1997;Build 145
+2 ;
+3 QUIT
+4 ; OR0 - OR0 FROM PENDING OUTPATIENT ORDERS OR BACKDOOR ORDERS
+5 ; OR0 can also be just the order number
CHKERX(OR0) ;
+1 NEW ORIEN,ERXIEN
+2 SET ORIEN=$PIECE(OR0,U)
if 'ORIEN
QUIT 0
+3 IF '$DATA(^PS(52.49,"ORN",ORIEN))
QUIT 0
+4 SET ERXIEN=$ORDER(^PS(52.49,"ORN",ORIEN,0))
+5 IF 'ERXIEN
QUIT 0
+6 QUIT ERXIEN
PROVPMT(ERXIEN) ;
+1 NEW ERXPHYS,ERXPHNM,ERXCON,DIR,Y,OLDQUIT,NEWQUIT,COMMIEN,PHONECHK
+2 SET OLDQUIT=0
SET NEWQUIT=0
+3 SET $PIECE(LINE,"*",80)=""
WRITE !!,LINE
+4 SET S2017=$$GET1^DIQ(52.49,ERXIEN,312.1)
+5 WRITE !!,"This prescription is an inbound electronic prescription (eRx)."
+6 WRITE !,"Please contact the original provider for approval to renew.",$CHAR(7)
+7 DO PAUSE^PSOSPMU1
+8 SET ERXPHYS=$$GET1^DIQ(52.49,ERXIEN,2.1,"I")
+9 SET ERXPHNM=$$GET1^DIQ(52.48,ERXPHYS,.01,"E")
WRITE !,ERXPHNM
+10 IF '$GET(S2017)
Begin DoDot:1
+11 IF '$DATA(^PS(52.48,ERXPHYS,3,"C","TE"))
WRITE !!,"No telephone information on file for this provider."
Begin DoDot:2
+12 SET OLDQUIT=1
End DoDot:2
End DoDot:1
+13 IF OLDQUIT=1
QUIT 0
+14 IF $GET(S2017)
Begin DoDot:1
+15 SET PHONECHK=$$COMMVAL^PSOERXU5(ERXPHYS,52.48,11,"PT")
+16 IF '$GET(PHONECHK)
SET NEWQUIT=1
End DoDot:1
+17 IF NEWQUIT=1
QUIT 0
+18 WRITE !
+19 SET ERXCON=0
FOR
SET ERXCON=$ORDER(^PS(52.48,ERXPHYS,3,"C","TE",ERXCON))
if 'ERXCON
QUIT
Begin DoDot:1
+20 WRITE !,"Telephone: "_$$GET1^DIQ(52.483,ERXCON_","_ERXPHYS_",",.01,"E")
End DoDot:1
+21 WRITE !!,"Answering 'Yes' indicates you have contacted the prescribing physician"
+22 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Would you like to proceed with renewing this prescription"
DO ^DIR
KILL DIR
+23 IF Y=1
QUIT 1
+24 QUIT 0
DERX1(GL,PSOIEN,DFLG,IEN,CALLER) ;
+1 ;Input:(r) GL - ListMan global/variable where the eRx data should be set (e.g., $NA(^TMP("PSOAO",$J)))
+2 ; (r) PSOIEN - Pointer to the ERX HOLDING QUEUE file (#52.49)
+3 ; (o) DFLG - Skip Additional Drug Information (Unit of Measure, Form, Strenght, etc...)? (1: YES | 0: NO)
+4 ; (o) IEN - Last line used (start after this line)
+5 ; (o) CALLER - Calling functionality ("P" - Pending Order, "A" - Active Rx, "H" - Holding Queue, etc.)
+6 ; Note: Variables PKID and PKIE are utilized outside this routine
+7 NEW EDRG,ERXDAT,ESIG,COMM,SUBS,DFORM,DSTR,QQUAL,POTUC,QTY,DAYS,REFILL,PSOIENS,LINE,LINETXT,ADLINE,ADARY,ALOOP,COMMARY
+8 NEW ERXPAT,ERXPIEN,ERXPDOB,ERXPSSN,ERXPROV,ERXPRIEN,ERXPRDEA,ERXPRNPI,ERXPRSA1,ERXPRSA2,ERXPRCTY,ERXPRST,ERXPRZIP,I,PROVPHON
+9 NEW PROVDAT,SIGARY,STHIS,STAT,ACBY,FOUND,ACDTTM,DRGARY,DLP,CTYSTZIP,ADLINE1,MTYPE,ERXDSUB,S2017,PHW,MIEN,ERXEFFDT,ERXWDATE
+10 NEW PROHIBIT,SGLOOP
+11 if '$GET(PSOIEN)
QUIT
+12 SET PSOIENS=PSOIEN_","
+13 DO GETS^DIQ(52.49,PSOIENS,".04;.08;2.1;3.1;4.6;4.8;5.1;5.2;5.4;5.5;5.6;5.7;5.8;7;8;41;42;43;312.1","IE","ERXDAT")
+14 SET S2017=$GET(ERXDAT(52.49,PSOIENS,312.1,"I"))
+15 SET DFLG=$GET(DFLG,"")
+16 SET EDRG=$GET(ERXDAT(52.49,PSOIENS,3.1,"E"))
+17 SET ESIG=$GET(ERXDAT(52.49,PSOIENS,7,"E"))
+18 SET COMM=$GET(ERXDAT(52.49,PSOIENS,8,"E"))
+19 SET SUBS=$GET(ERXDAT(52.49,PSOIENS,5.8,"E"))
+20 SET DFORM=$GET(ERXDAT(52.49,PSOIENS,41,"E"))
+21 SET DSTR=$GET(ERXDAT(52.49,PSOIENS,43,"E"))
+22 SET MTYPE=$GET(ERXDAT(52.49,PSOIENS,.08,"I"))
+23 IF 'S2017
Begin DoDot:1
+24 SET QQUAL=$GET(ERXDAT(52.49,PSOIENS,5.2,"E"))
End DoDot:1
+25 IF S2017
Begin DoDot:1
+26 IF MTYPE'="RE"
SET MIEN=$ORDER(^PS(52.49,PSOIEN,311,"C","P",0))
+27 IF MTYPE="RE"
SET MIEN=$ORDER(^PS(52.49,PSOIEN,311,"C","MR",0))
+28 SET QQUAL=$$GET1^DIQ(52.49311,MIEN_","_PSOIEN_",",2.2,"I")
SET QQUAL=$$GET1^DIQ(52.45,QQUAL,.02,"E")
End DoDot:1
+29 SET POTUC=$GET(ERXDAT(52.49,PSOIENS,42,"E"))
+30 SET QTY=$GET(ERXDAT(52.49,PSOIENS,5.1,"E"))
+31 SET DAYS=$GET(ERXDAT(52.49,PSOIENS,5.5,"E"))
+32 SET REFILL=$GET(ERXDAT(52.49,PSOIENS,5.6,"E"))
+33 IF MTYPE="RE"
IF REFILL>0
SET REFILL=REFILL-1
+34 IF '$$GET1^DIQ(52.49,PSOIEN,312.1)
Begin DoDot:1
+35 IF REFILL=""
Begin DoDot:2
+36 SET REFILL=$GET(ERXDAT(52.49,PSOIENS,5.7,"I"))
End DoDot:2
End DoDot:1
+37 SET ERXPAT=$GET(ERXDAT(52.49,PSOIENS,.04,"E"))
+38 SET ERXPIEN=$GET(ERXDAT(52.49,PSOIENS,.04,"I"))
+39 SET ERXPDOB=$$GET1^DIQ(52.46,ERXPIEN,.08,"E")
+40 SET ERXPSSN=$$GET1^DIQ(52.46,ERXPIEN,$SELECT(S2017:18.2,1:1.4),"E")
+41 SET ERXPROV=$GET(ERXDAT(52.49,PSOIENS,2.1,"E"))
+42 SET ERXPRIEN=$GET(ERXDAT(52.49,PSOIENS,2.1,"I"))
+43 SET PROVPHON=$$COMMVAL^PSOERXU5(ERXPRIEN,52.48,11,"PT",1)
+44 NEW FIELDS
+45 SET FIELDS=$SELECT(2017:"14.5;15.1",1:"1.5;1.6")_";4.1;4.2;4.3;4.4;4.5"
+46 DO GETS^DIQ(52.48,ERXPRIEN_",",FIELDS,"E","PROVDAT")
+47 IF S2017
Begin DoDot:1
+48 SET ERXPRDEA=$GET(PROVDAT(52.48,ERXPRIEN_",",14.5,"E"))
+49 SET ERXPRNPI=$GET(PROVDAT(52.48,ERXPRIEN_",",15.1,"E"))
End DoDot:1
+50 IF 'S2017
Begin DoDot:1
+51 SET ERXPRDEA=$GET(PROVDAT(52.48,ERXPRIEN_",",1.6,"E"))
+52 SET ERXPRNPI=$GET(PROVDAT(52.48,ERXPRIEN_",",1.5,"E"))
End DoDot:1
+53 SET ERXPRSA1=$GET(PROVDAT(52.48,ERXPRIEN_",",4.1,"E"))
+54 SET ERXPRSA2=$GET(PROVDAT(52.48,ERXPRIEN_",",4.2,"E"))
+55 SET ERXPRCTY=$GET(PROVDAT(52.48,ERXPRIEN_",",4.3,"E"))
+56 SET ERXPRST=$GET(PROVDAT(52.48,ERXPRIEN_",",4.4,"E"))
+57 SET ERXPRZIP=$GET(PROVDAT(52.48,ERXPRIEN_",",4.5,"E"))
+58 DO TXT2ARY^PSOERXD1(.SIGARY,ESIG,,69)
+59 DO TXT2ARY^PSOERXD1(.COMMARY,COMM,,65)
+60 SET STHIS=99999
SET FOUND=0
+61 FOR
SET STHIS=$ORDER(^PS(52.49,PSOIEN,19,STHIS),-1)
if 'STHIS!(FOUND)
QUIT
Begin DoDot:1
+62 SET STAT=$$GET1^DIQ(52.4919,STHIS_","_PSOIENS,.02,"I")
+63 IF ",PR,RXP,CXP,"[(","_$$GET1^DIQ(52.45,STAT,.01,"E")_",")
Begin DoDot:2
+64 SET ACDTTM=$$GET1^DIQ(52.4919,STHIS_","_PSOIENS,.01,"E")
+65 SET ACBY=$$GET1^DIQ(52.4919,STHIS_","_PSOIENS,.03,"E")
SET FOUND=1
End DoDot:2
End DoDot:1
+66 SET PKID=0
SET PKIE=""
+67 IF $GET(CALLER)="P"
IF $$GET1^DIQ(52.49,PSOIEN,95.1,"I")
IF $$CS^PSOERXA0($$GET1^DIQ(52.49,PSOIEN,3.2,"I"))
Begin DoDot:1
+68 SET IEN=IEN+1
SET @GL@(IEN,0)="Processing Digitally Signed eRx order"
+69 SET PKID=1
SET PKIE="Processing Digitally Signed eRx order"
End DoDot:1
+70 IF $LENGTH($GET(ACBY))
SET IEN=IEN+1
SET @GL@(IEN,0)="eRx Accepted By: "_ACBY_" ("_ACDTTM_")"
+71 SET LINETXT=""
+72 DO ADDITEM^PSOERX1A(.LINETXT,"eRx Patient: ",ERXPAT,1,55)
+73 DO ADDITEM^PSOERX1A(.LINETXT,"SSN: ",ERXPSSN,57,20)
+74 SET IEN=IEN+1
SET @GL@(IEN,0)=LINETXT
+75 SET LINETXT=""
+76 IF $LENGTH(ERXPAT)>42
DO ADDITEM^PSOERX1A(.LINETXT," ",$EXTRACT(ERXPAT,43,84),1,55)
+77 DO ADDITEM^PSOERX1A(.LINETXT,"DOB: ",ERXPDOB,57,20)
+78 SET IEN=IEN+1
SET @GL@(IEN,0)=LINETXT
+79 IF $LENGTH(ERXPAT)>84
Begin DoDot:1
+80 SET IEN=IEN+1
SET @GL@(IEN,0)=" "_$EXTRACT(ERXPAT,85,117)
End DoDot:1
+81 IF $LENGTH(ERXPAT)>117
Begin DoDot:1
+82 SET IEN=IEN+1
SET @GL@(IEN,0)=" "_$EXTRACT(ERXPAT,118,135)
End DoDot:1
+83 SET IEN=IEN+1
SET @GL@(IEN,0)=""
+84 IF S2017
Begin DoDot:1
+85 SET PHW=$$BHW^PSOERXIU(PSOIEN)
SET IEN=IEN+1
SET @GL@(IEN,0)=PHW
End DoDot:1
+86 SET LINETXT=""
+87 DO ADDITEM^PSOERX1A(.LINETXT,"eRx Provider: ",$EXTRACT(ERXPROV,1,55),1,55)
+88 DO ADDITEM^PSOERX1A(.LINETXT,"DEA: ",ERXPRDEA,57,20)
+89 SET IEN=IEN+1
SET @GL@(IEN,0)=LINETXT
SET LINETXT=""
+90 IF $LENGTH(ERXPROV)>55
DO ADDITEM^PSOERX1A(.LINETXT," ",$EXTRACT(ERXPROV,56,96),1,55)
+91 DO ADDITEM^PSOERX1A(.LINETXT,"eRx Phone: ",PROVPHON,1,40)
+92 DO ADDITEM^PSOERX1A(.LINETXT,"NPI: ",ERXPRNPI,57,20)
+93 SET IEN=IEN+1
SET @GL@(IEN,0)=LINETXT
SET LINETXT=""
+94 IF $LENGTH(ERXPROV)>96
DO ADDITEM^PSOERX1A(.LINETXT," ",$EXTRACT(ERXPROV,97,135),1,55)
+95 SET IEN=IEN+1
SET @GL@(IEN,0)=LINETXT
SET LINETXT=""
+96 SET ADLINE1=$SELECT($LENGTH(ERXPRSA1):ERXPRSA1,1:"ADDRESS UNKNOWN ")
+97 SET CTYSTZIP=$SELECT($LENGTH(ERXPRCTY):ERXPRCTY_",",1:"")
+98 SET CTYSTZIP=CTYSTZIP_$SELECT($LENGTH(ERXPRST):ERXPRST_" ",1:"")
+99 SET CTYSTZIP=" "_CTYSTZIP_$SELECT($LENGTH(ERXPRZIP):ERXPRZIP,1:"")
+100 SET IEN=IEN+1
SET @GL@(IEN,0)="Address: "_ADLINE1
+101 SET IEN=IEN+1
SET @GL@(IEN,0)=CTYSTZIP
+102 IF $LENGTH(ERXPRSA2)
Begin DoDot:1
+103 SET IEN=IEN+1
SET @GL@(IEN,0)="Address Line 2: "_ERXPRSA2
End DoDot:1
+104 IF $ORDER(ADARY(0))
Begin DoDot:1
+105 SET ALOOP=1
FOR
SET ALOOP=$ORDER(ADARY(ALOOP))
if 'ALOOP
QUIT
Begin DoDot:2
+106 SET IEN=IEN+1
SET @GL@(IEN,0)=" "_ADARY(ALOOP)
End DoDot:2
End DoDot:1
+107 SET IEN=IEN+1
SET @GL@(IEN,0)=""
+108 DO TXT2ARY^PSOERXD1(.DRGARY,EDRG,,70)
+109 SET IEN=IEN+1
SET @GL@(IEN,0)="eRx Drug: "_$GET(DRGARY(1))_" "_$PIECE($$ERXDRSCH^PSOERXUT(PSOIEN),"^",2)
+110 SET DLP=1
+111 FOR
SET DLP=$ORDER(DRGARY(DLP))
if 'DLP
QUIT
Begin DoDot:1
+112 SET IEN=IEN+1
SET @GL@(IEN,0)=" "_$GET(DRGARY(DLP))
End DoDot:1
+113 SET LINETXT=""
+114 DO ADDITEM^PSOERX1A(.LINETXT,"Qty: ",QTY,1,25)
+115 DO ADDITEM^PSOERX1A(.LINETXT,"Days Supply: ",DAYS,27,16)
+116 DO ADDITEM^PSOERX1A(.LINETXT,"Refills: ",REFILL,58,20)
+117 SET IEN=IEN+1
SET @GL@(IEN,0)=LINETXT
+118 IF 'S2017
Begin DoDot:1
+119 SET IEN=IEN+1
SET @GL@(IEN,0)="eRx Written Date: "_$$FMTE^XLFDT($PIECE($$GET1^DIQ(52.49,PSOIEN,5.9,"I"),"@"),"2D")_" eRx Received Date: "_$$FMTE^XLFDT($PIECE($$GET1^DIQ(52.49,PSOIEN,.03,"I"),"@"),"2D")
End DoDot:1
+120 IF S2017
Begin DoDot:1
+121 SET MIEN=$ORDER(^PS(52.49,PSOIEN,311,0))
+122 SET ERXEFFDT=$$EFFDATE^PSOERXU5(PSOIEN,MIEN)
+123 SET ERXWDATE=$$GET1^DIQ(52.49,PSOIEN,5.9,"I")
+124 WRITE !,"eRx Written Date: "_$$FMTE^XLFDT($PIECE(ERXWDATE,"."),1)_" eRx Issue Date: "_ERXEFFDT
End DoDot:1
+125 SET ERXDSUB=$$GET1^DIQ(52.49,PSOIEN,5.8,"I")
+126 SET ERXDSUB=$SELECT(ERXDSUB=1:"NO",ERXDSUB=0:"YES",1:"")
+127 SET LINETXT=""
+128 DO ADDITEM^PSOERX1A(.LINETXT,"Substitutions? :",ERXDSUB,1,25)
+129 SET IEN=IEN+1
SET @GL@(IEN,0)=LINETXT
+130 IF 'S2017
Begin DoDot:1
+131 SET IEN=IEN+1
SET @GL@(IEN,0)="eRx Sig: "
+132 SET I=0
FOR
SET I=$ORDER(SIGARY(I))
if 'I
QUIT
Begin DoDot:2
+133 IF I=1
SET @GL@(IEN,0)=@GL@(IEN,0)_SIGARY(I)
QUIT
+134 SET IEN=IEN+1
SET @GL@(IEN,0)=$SELECT(I>1:" "_SIGARY(I),1:SIGARY(I))
End DoDot:2
+135 IF '$LENGTH(ESIG)
SET IEN=IEN+1
SET @GL@(IEN,0)=""
End DoDot:1
+136 IF S2017
IF MTYPE?1(1"N",1"RE",1"CX")
Begin DoDot:1
+137 IF MTYPE?1(1"N",1"CX")
Begin DoDot:2
+138 SET PROHIBIT=$$GET1^DIQ(52.49,PSOIEN,301.3,"I")
+139 SET PROHIBIT=$SELECT(PROHIBIT=1:"Yes",1:"No")
+140 SET IEN=IEN+1
SET @GL@(IEN,0)="Prohibit Renewals: "_PROHIBIT
+141 SET IEN=IEN+1
SET @GL@(IEN,0)=""
End DoDot:2
+142 SET IEN=IEN+1
SET @GL@(IEN,0)="eRx Sig:"
+143 SET SGLOOP=0
FOR
SET SGLOOP=$ORDER(^PS(52.49,PSOIEN,311,MIEN,8,SGLOOP))
if 'SGLOOP
QUIT
Begin DoDot:2
+144 SET IEN=IEN+1
SET @GL@(IEN,0)=$GET(^PS(52.49,PSOIEN,311,MIEN,8,SGLOOP,0))
End DoDot:2
+145 SET IEN=IEN+1
SET @GL@(IEN,0)=""
End DoDot:1
+146 SET IEN=IEN+1
SET @GL@(IEN,0)="eRx Notes: "
+147 SET I=0
FOR
SET I=$ORDER(COMMARY(I))
if 'I
QUIT
Begin DoDot:1
+148 IF I=1
SET @GL@(IEN,0)=@GL@(IEN,0)_$SELECT(I>1:" "_COMMARY(I),1:COMMARY(I))
QUIT
+149 SET IEN=IEN+1
SET @GL@(IEN,0)=$SELECT(I>1:" "_COMMARY(I),1:COMMARY(I))
End DoDot:1
+150 IF '$LENGTH(COMM)
SET IEN=IEN+1
SET @GL@(IEN,0)=""
+151 if DFLG=1
QUIT
+152 SET LINETXT=""
+153 SET IEN=IEN+1
SET @GL@(IEN,0)=""
+154 SET IEN=IEN+1
SET @GL@(IEN,0)="Drug Form: "_DFORM
+155 SET IEN=IEN+1
SET @GL@(IEN,0)="Strength: "_DSTR
+156 SET LINETXT=""
+157 SET IEN=IEN+1
SET @GL@(IEN,0)="Code List Qualifier: "_QQUAL
+158 SET IEN=IEN+1
SET @GL@(IEN,0)="Quantity Unit of Measure: "_POTUC
+159 SET IEN=IEN+1
SET @GL@(IEN,0)=LINETXT
+160 SET ERXDSUB=$$GET1^DIQ(52.49,PSOIEN,5.8,"I")
+161 SET ERXDSUB=$SELECT(ERXDSUB=1:"NO",ERXDSUB=0:"YES",1:"")
+162 SET IEN=IEN+1
SET @GL@(IEN,0)="Substitutions?: "_ERXDSUB
+163 SET IEN=IEN+1
SET @GL@(IEN,0)=""
+164 IF '$GET(S2017)
DO DIAG(PSOIEN,.IEN,.GL)
+165 IF $GET(S2017)
IF MIEN
DO DIAG2017^PSOERXU5(PSOIEN,.IEN,.GL,MIEN)
+166 SET $PIECE(LINE,"-",80)=""
+167 SET IEN=IEN+1
SET @GL@(IEN,0)=LINE
+168 QUIT
+169 ; diagnosis information
DIAG(PSOIEN,LINE,GL) ;
+1 NEW DIAGIEN,DIAGDAT,DIAGSEQ,PDIAGQ,PDIAGV,SDIAGQ,SDIAGV,DIAGDAT,DIACIC,DRES,SDRES,PDIAGTXT,SDIAGTXT
+2 NEW SDRESL,SDRESDAT,DRESL,DRESDAT,PDIAGARY,SDIAGARY,PDFRST,SDFRST,PDLOOP,SDLOOP,DIENS
+3 SET DIAGIEN=0
FOR
SET DIAGIEN=$ORDER(^PS(52.49,PSOIEN,9,DIAGIEN))
if 'DIAGIEN
QUIT
Begin DoDot:1
+4 SET DIENS=DIAGIEN_","_PSOIEN_","
KILL PDIAGARY,SDIAGARY,DIAGDAT
+5 DO GETS^DIQ(52.499,DIENS,".01:.06","IE","DIAGDAT")
+6 SET DIAGSEQ=$GET(DIAGDAT(52.499,DIENS,.01,"E"))
+7 SET DIACIC=$GET(DIAGDAT(52.499,DIENS,.02,"E"))
+8 SET PDIAGQ=$GET(DIAGDAT(52.499,DIENS,.03,"E"))
+9 SET PDIAGV=$GET(DIAGDAT(52.499,DIENS,.04,"E"))
+10 IF PDIAGQ["ICD"
Begin DoDot:2
+11 KILL DRES,PDIAGARY
+12 DO ICDDESC^ICDXCODE(PDIAGQ,PDIAGV,,.DRES)
+13 IF '$ORDER(DRES(0))
DO TXT2ARY^PSOERXD1(.PDIAGARY,"Primary Dx: ("_PDIAGQ_" - "_PDIAGV_")"," ",78)
QUIT
+14 SET PDIAGTXT="Primary Dx: ("_PDIAGQ_" "_PDIAGV_") "
+15 SET DRESL=0
FOR
SET DRESL=$ORDER(DRES(DRESL))
if 'DRESL
QUIT
Begin DoDot:3
+16 SET DRESDAT=$GET(DRES(DRESL))
if DRESDAT=""
QUIT
+17 SET PDIAGTXT=$GET(PDIAGTXT)_" "_DRESDAT
End DoDot:3
+18 DO TXT2ARY^PSOERXD1(.PDIAGARY,PDIAGTXT," ",78)
End DoDot:2
+19 SET SDIAGQ=$GET(DIAGDAT(52.499,DIENS,.05,"E"))
+20 SET SDIAGV=$GET(DIAGDAT(52.499,DIENS,.06,"E"))
+21 IF SDIAGQ["ICD"
Begin DoDot:2
+22 KILL SDRES,SDIAGARY
+23 DO ICDDESC^ICDXCODE(SDIAGQ,SDIAGV,,.SDRES)
+24 IF '$ORDER(DRES(0))
DO TXT2ARY^PSOERXD1(.SDIAGARY,"Secondary Dx: ("_SDIAGQ_" - "_SDIAGV_")"," ",78)
QUIT
+25 SET SDIAGTXT="Secondary Dx: ("_SDIAGQ_" "_SDIAGV_") "
+26 SET SDRESL=0
FOR
SET SDRESL=$ORDER(SDRES(SDRESL))
if 'SDRESL
QUIT
Begin DoDot:3
+27 SET SDRESDAT=$GET(SDRES(SDRESL))
if SDRESDAT=""
QUIT
+28 SET SDIAGTXT=$GET(SDIAGTXT)_" "_SDRESDAT
End DoDot:3
+29 DO TXT2ARY^PSOERXD1(.SDIAGARY,SDIAGTXT," ",78)
End DoDot:2
+30 IF '$DATA(PDIAGARY)
DO TXT2ARY^PSOERXD1(.PDIAGARY,"Primary Dx: ("_PDIAGQ_" - "_PDIAGV_")"," ",78)
+31 SET PDFRST=$ORDER(PDIAGARY(0))
+32 SET LINE=LINE+1
+33 IF $DATA(GL)
DO SETGL(LINE,PDIAGARY(PDFRST))
+34 IF '$DATA(GL)
DO SETLOC(LINE,$GET(PDIAGARY(PDFRST)))
+35 SET PDLOOP=PDFRST
FOR
SET PDLOOP=$ORDER(PDIAGARY(PDLOOP))
if 'PDLOOP
QUIT
Begin DoDot:2
+36 SET LINE=LINE+1
+37 IF $DATA(GL)
DO SETGL(LINE," "_$GET(PDIAGARY(PDLOOP)))
+38 IF '$DATA(GL)
DO SETLOC(LINE," "_$GET(PDIAGARY(PDLOOP)))
End DoDot:2
+39 SET LINE=LINE+1
+40 IF $DATA(GL)
DO SETGL(LINE,"")
+41 IF '$DATA(GL)
DO SETLOC(LINE,"")
+42 IF '$DATA(SDIAGARY)
DO TXT2ARY^PSOERXD1(.SDIAGARY,"Secondary Dx: ("_SDIAGQ_" - "_SDIAGV_")"," ",78)
+43 SET SDFRST=$ORDER(SDIAGARY(0))
+44 SET LINE=LINE+1
+45 IF $DATA(GL)
DO SETGL(LINE,$GET(SDIAGARY(SDFRST)))
+46 IF '$DATA(GL)
DO SETLOC(LINE,$GET(SDIAGARY(SDFRST)))
+47 SET SDLOOP=SDFRST
FOR
SET SDLOOP=$ORDER(SDIAGARY(SDLOOP))
if 'SDLOOP
QUIT
Begin DoDot:2
+48 SET LINE=LINE+1
+49 IF $DATA(GL)
DO SETGL(LINE," "_$GET(SDIAGARY(SDLOOP)))
+50 IF '$DATA(GL)
DO SETLOC(LINE," "_$GET(SDIAGARY(SDLOOP)))
End DoDot:2
+51 IF $ORDER(^PS(52.49,PSOIEN,9,DIAGIEN))
Begin DoDot:2
+52 SET LINE=LINE+1
+53 IF $DATA(GL)
DO SETGL(LINE,"")
+54 IF '$DATA(GL)
DO SETLOC(LINE,"")
End DoDot:2
End DoDot:1
+55 QUIT
SETLOC(LINE,TEXT) ;
+1 DO SET^VALM10(LINE,TEXT)
+2 QUIT
SETGL(IEN,TEXT) ;
+1 SET @GL@(IEN,0)=TEXT
+2 QUIT
OPACCESS(OPTION,DUZ,ERXIEN) ;
+1 NEW ERXIEN2
+2 SET ERXIEN2=$GET(ERXIEN)
+3 QUIT $$OPACCESS^PSOERXU7(OPTION,DUZ,ERXIEN2)
+4 ; update the status of an eRx
+5 ; PSOIEN - ien for file 52.49 (required)
+6 ; STAT - The status value to change the eRx to (required)
+7 ; SCOMM - status comments (optional)
+8 ; UNACC - (o) eRx Un-Accepted at the Pending Queue 1-YES/0-NO (Optional - Default: NO)
+9 ; ALTDUZ - (o) Alternative DUZ (Used for Proxy user for automatic un-holds)
+10 ; HFFDT - (o) Hold Future Fill Date
UPDSTAT(PSOIEN,STAT,SCOMM,UNACC,ALTDUZ,HFFDT) ;
+1 NEW MBMSITE,DIE,NSTAT,DA,DR,FDA,TYPE
+2 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+3 if 'PSOIEN!(STAT="")
QUIT
+4 IF '$GET(MBMSITE)
Begin DoDot:1
+5 IF '$DATA(^PS(52.45,"C","ERX",STAT))
QUIT
+6 SET NSTAT=$ORDER(^PS(52.45,"C","ERX",STAT,0))
End DoDot:1
+7 ; Exception for MbM sites to treat REMOVAL Reasons as Statuses
+8 IF $GET(MBMSITE)
Begin DoDot:1
+9 SET TYPE=$SELECT($EXTRACT(STAT,1,3)="REM":"REM",1:"ERX")
+10 IF '$DATA(^PS(52.45,"C",TYPE,STAT))
QUIT
+11 SET NSTAT=$ORDER(^PS(52.45,"C",TYPE,STAT,0))
End DoDot:1
+12 IF $GET(NSTAT)=""
QUIT
+13 SET DIE="^PS(52.49,"
SET DA=+PSOIEN
SET DR="1///"_NSTAT
DO ^DIE
+14 SET FDA(52.4919,"+1,"_PSOIEN_",",.01)=$$NOW^XLFDT
+15 SET FDA(52.4919,"+1,"_PSOIEN_",",.02)=NSTAT
+16 SET FDA(52.4919,"+1,"_PSOIEN_",",.03)=$SELECT($GET(ALTDUZ):ALTDUZ,1:$GET(DUZ))
+17 SET FDA(52.4919,"+1,"_PSOIEN_",",1)=$GET(SCOMM)
+18 IF $GET(UNACC)
SET FDA(52.4919,"+1,"_PSOIEN_",",.04)=+UNACC
+19 IF STAT="HFF"
IF $GET(HFFDT)
SET FDA(52.4919,"+1,"_PSOIEN_",",.05)=HFFDT
+20 DO UPDATE^DIE(,"FDA")
KILL FDA
+21 ; Updating Future Fill Hold Date (if any)
+22 IF STAT="HFF"
IF $GET(HFFDT)
Begin DoDot:1
+23 KILL DIE
SET DIE="52.49"
SET DA=PSOIEN
SET DR="6.7///"_HFFDT
+24 ; If no Effective Date and No Refills on the eRx, HFFDT is more than 30 days from Written Date, set Effective Date with HFFDT (if not past limits for CS and Non-CS exp. Dates)
+25 IF '$$GET1^DIQ(52.49,ERXIEN,6.3,"I")
IF '$$GET1^DIQ(52.49,ERXIEN,5.6,"I")
IF $$FMDIFF^XLFDT(HFFDT,$$GET1^DIQ(52.49,ERXIEN,5.9,"I"))>30
Begin DoDot:2
+26 SET DR=DR_";6.3///"_HFFDT
End DoDot:2
+27 DO ^DIE
KILL DIE
End DoDot:1
+28 ; Force a Refresh of the mail list
+29 SET PSORFRSH=1
+30 QUIT
ERRSEQ(EIEN) ;
+1 NEW SEQ
+2 IF '$ORDER(^PS(52.49,EIEN,100,0))
SET SEQ=1
+3 IF '$GET(SEQ)
SET SEQ=$ORDER(^PS(52.49,EIEN,100,999999),-1)+1
+4 QUIT SEQ
+5 ;
+6 ; IENS - ien of the erx holding queue entry
+7 ; SEQ - sequence number of the error
+8 ; TYPE - type (d-drug, pr-provider, pa-patient, a-allergy, o-order check, t-transfer)
+9 ; SRC - v - vista, e - erx processing hub
+10 ; TXT - error text
FILERR(IENS,SEQ,TYPE,SRC,TXT) ;
+1 NEW FDA
+2 SET FDA(52.49101,"+1,"_IENS,.01)=SEQ
+3 SET FDA(52.49101,"+1,"_IENS,.02)=TYPE
+4 SET FDA(52.49101,"+1,"_IENS,.03)=SRC
+5 ; all new errors are set to pending
+6 SET FDA(52.49101,"+1,"_IENS,.04)="P"
+7 SET FDA(52.49101,"+1,"_IENS,1)=TXT
+8 DO UPDATE^DIE(,"FDA")
KILL FDA
+9 ; now set the eRx entry status to error
+10 QUIT
MSGDIR(MSG) ;
+1 NEW DIR,MLOOP,MTXT
+2 SET VALMBCK="R"
+3 DO FULL^VALM1
+4 WRITE !!,"Errors encountered during processing:",!
+5 SET MLOOP=0
FOR
SET MLOOP=$ORDER(MSG(MLOOP))
if 'MLOOP
QUIT
Begin DoDot:1
+6 SET MTXT=$PIECE($GET(MSG(MLOOP)),"^")
WRITE !,MLOOP_".) ",MTXT
End DoDot:1
+7 WRITE !!,"Cannot process eRx.",!
+8 IF DUZ'=+$$PROXYDUZ^PSOERXUT()
SET DIR(0)="E"
DO ^DIR
+9 QUIT
+10 ; provider change screen on refill response
CHPRCHG(ERXIEN) ;
+1 NEW REQIEN,RESIEN,DELTA,MTYPE,RESVAL,MSTAT
+2 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+3 SET MSTAT=$$GET1^DIQ(52.49,ERXIEN,1,"E")
+4 SET RESVAL=$$GET1^DIQ(52.49,ERXIEN,52.1,"I")
+5 IF MTYPE="RE"
IF ((RESVAL="D")!(RESVAL="DNP"))
QUIT 0
+6 IF MTYPE="RR"!(MTYPE="CA")!(MTYPE="CN")!(MTYPE="IE")
QUIT 0
+7 IF MTYPE'="RE"
QUIT 1
+8 IF MTYPE="RE"
IF RESVAL="R"
IF MSTAT'="RXP"
QUIT 1
+9 IF MTYPE="RE"
IF MSTAT="RXW"!(MSTAT="RXI")
QUIT 1
+10 IF RESVAL'="AWC"
IF MTYPE="RE"
IF ",RXP,RXC,RXD,"[MSTAT
QUIT 0
+11 IF MTYPE="RE"
IF ($$GET1^DIQ(52.49,ERXIEN,52.1,"I")'["A")
QUIT 0
+12 SET RESIEN=ERXIEN
SET REQIEN=$$GETREQ^PSOERXU2(ERXIEN)
+13 DO RRDELTA^PSOERXU2(.DELTA,REQIEN,RESIEN)
if '$DATA(DELTA)
QUIT 0
+14 IF $DATA(DELTA(52.49,"EXTERNAL PROVIDER"))
QUIT 1
+15 QUIT 0
