- PSOERXU1 ;ALB/BWF - eRx utilities ; 1/27/2019 11:03am
- ;;7.0;OUTPATIENT PHARMACY;**467,520,508,551,565,581,617,651,700,746**;DEC 1997;Build 106
- ;
- 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
- 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"))
- 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,"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 $G(HFFDT) S FDA(52.4919,"+1,"_PSOIEN_",",.05)=HFFDT
- D UPDATE^DIE(,"FDA") K FDA
- ; 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.",!
- 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" 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
- ALG(LINE) ;
- N ALGINFO,ALGLINE,DFN,IEN,X,LDAT,GMRAL,PSONOAL
- S ALGLINE=""
- S DFN=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
- D EN1^GMRADPT
- S IEN=1
- I 'GMRAL D
- .S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)="Allergies: "_$S(GMRAL=0:"NKA",1:"")
- .I GMRAL'=0 S PSONOAL="" D ALLERGY^PSOORUT2 I PSONOAL'="" S ^TMP("PSOPI",$J,IEN,0)="Allergies: "_PSONOAL K PSONOAL
- .S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=" "
- .D REMOTE^PSOORUT2
- .S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)="Adverse Reactions:"
- D:$G(GMRAL) ^PSOORUT3
- ;S LINE=LINE+1
- S X=0 F S X=$O(^TMP("PSOPI",$J,X)) Q:'X D
- .S LDAT=$G(^TMP("PSOPI",$J,X,0))
- .S LINE=LINE+1
- .D SET^VALM10(LINE,LDAT)
- K ^TMP("PSOPI",$J)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXU1 16249 printed Jan 18, 2025@03:30:11 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**;DEC 1997;Build 106
- +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
- +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 NEW FIELDS
- +44 SET FIELDS=$SELECT(2017:"14.5;15.1",1:"1.5;1.6")_";4.1;4.2;4.3;4.4;4.5"
- +45 DO GETS^DIQ(52.48,ERXPRIEN_",",FIELDS,"E","PROVDAT")
- +46 IF S2017
- Begin DoDot:1
- +47 SET ERXPRDEA=$GET(PROVDAT(52.48,ERXPRIEN_",",14.5,"E"))
- +48 SET ERXPRNPI=$GET(PROVDAT(52.48,ERXPRIEN_",",15.1,"E"))
- End DoDot:1
- +49 IF 'S2017
- Begin DoDot:1
- +50 SET ERXPRDEA=$GET(PROVDAT(52.48,ERXPRIEN_",",1.6,"E"))
- +51 SET ERXPRNPI=$GET(PROVDAT(52.48,ERXPRIEN_",",1.5,"E"))
- End DoDot:1
- +52 SET ERXPRSA1=$GET(PROVDAT(52.48,ERXPRIEN_",",4.1,"E"))
- +53 SET ERXPRSA2=$GET(PROVDAT(52.48,ERXPRIEN_",",4.2,"E"))
- +54 SET ERXPRCTY=$GET(PROVDAT(52.48,ERXPRIEN_",",4.3,"E"))
- +55 SET ERXPRST=$GET(PROVDAT(52.48,ERXPRIEN_",",4.4,"E"))
- +56 SET ERXPRZIP=$GET(PROVDAT(52.48,ERXPRIEN_",",4.5,"E"))
- +57 DO TXT2ARY^PSOERXD1(.SIGARY,ESIG,,69)
- +58 DO TXT2ARY^PSOERXD1(.COMMARY,COMM,,65)
- +59 SET STHIS=99999
- SET FOUND=0
- +60 FOR
- SET STHIS=$ORDER(^PS(52.49,PSOIEN,19,STHIS),-1)
- if 'STHIS!(FOUND)
- QUIT
- Begin DoDot:1
- +61 SET STAT=$$GET1^DIQ(52.4919,STHIS_","_PSOIENS,.02,"I")
- +62 IF ",PR,RXP,CXP,"[(","_$$GET1^DIQ(52.45,STAT,.01,"E")_",")
- Begin DoDot:2
- +63 SET ACDTTM=$$GET1^DIQ(52.4919,STHIS_","_PSOIENS,.01,"E")
- +64 SET ACBY=$$GET1^DIQ(52.4919,STHIS_","_PSOIENS,.03,"E")
- SET FOUND=1
- End DoDot:2
- End DoDot:1
- +65 SET PKID=0
- SET PKIE=""
- +66 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
- +67 SET IEN=IEN+1
- SET @GL@(IEN,0)="Processing Digitally Signed eRx order"
- +68 SET PKID=1
- SET PKIE="Processing Digitally Signed eRx order"
- End DoDot:1
- +69 IF $LENGTH($GET(ACBY))
- SET IEN=IEN+1
- SET @GL@(IEN,0)="eRx Accepted By: "_ACBY_" ("_ACDTTM_")"
- +70 SET LINETXT=""
- +71 DO ADDITEM^PSOERX1A(.LINETXT,"eRx Patient: ",ERXPAT,1,55)
- +72 DO ADDITEM^PSOERX1A(.LINETXT,"SSN: ",ERXPSSN,57,20)
- +73 SET IEN=IEN+1
- SET @GL@(IEN,0)=LINETXT
- +74 SET LINETXT=""
- +75 IF $LENGTH(ERXPAT)>42
- DO ADDITEM^PSOERX1A(.LINETXT," ",$EXTRACT(ERXPAT,43,84),1,55)
- +76 DO ADDITEM^PSOERX1A(.LINETXT,"DOB: ",ERXPDOB,57,20)
- +77 SET IEN=IEN+1
- SET @GL@(IEN,0)=LINETXT
- +78 IF $LENGTH(ERXPAT)>84
- Begin DoDot:1
- +79 SET IEN=IEN+1
- SET @GL@(IEN,0)=" "_$EXTRACT(ERXPAT,85,117)
- End DoDot:1
- +80 IF $LENGTH(ERXPAT)>117
- Begin DoDot:1
- +81 SET IEN=IEN+1
- SET @GL@(IEN,0)=" "_$EXTRACT(ERXPAT,118,135)
- End DoDot:1
- +82 SET IEN=IEN+1
- SET @GL@(IEN,0)=""
- +83 IF S2017
- Begin DoDot:1
- +84 SET PHW=$$BHW^PSOERXIU(PSOIEN)
- SET IEN=IEN+1
- SET @GL@(IEN,0)=PHW
- End DoDot:1
- +85 SET LINETXT=""
- +86 DO ADDITEM^PSOERX1A(.LINETXT,"eRx Provider: ",$EXTRACT(ERXPROV,1,55),1,55)
- +87 DO ADDITEM^PSOERX1A(.LINETXT,"DEA: ",ERXPRDEA,57,20)
- +88 SET IEN=IEN+1
- SET @GL@(IEN,0)=LINETXT
- SET LINETXT=""
- +89 IF $LENGTH(ERXPROV)>55
- DO ADDITEM^PSOERX1A(.LINETXT," ",$EXTRACT(ERXPROV,56,96),1,55)
- +90 DO ADDITEM^PSOERX1A(.LINETXT,"NPI: ",ERXPRNPI,57,20)
- +91 SET IEN=IEN+1
- SET @GL@(IEN,0)=LINETXT
- SET LINETXT=""
- +92 IF $LENGTH(ERXPROV)>96
- DO ADDITEM^PSOERX1A(.LINETXT," ",$EXTRACT(ERXPROV,97,135),1,55)
- +93 SET IEN=IEN+1
- SET @GL@(IEN,0)=LINETXT
- SET LINETXT=""
- +94 SET ADLINE1=$SELECT($LENGTH(ERXPRSA1):ERXPRSA1,1:"ADDRESS UNKNOWN ")
- +95 SET CTYSTZIP=$SELECT($LENGTH(ERXPRCTY):ERXPRCTY_",",1:"")
- +96 SET CTYSTZIP=CTYSTZIP_$SELECT($LENGTH(ERXPRST):ERXPRST_" ",1:"")
- +97 SET CTYSTZIP=" "_CTYSTZIP_$SELECT($LENGTH(ERXPRZIP):ERXPRZIP,1:"")
- +98 SET IEN=IEN+1
- SET @GL@(IEN,0)="Address: "_ADLINE1
- +99 SET IEN=IEN+1
- SET @GL@(IEN,0)=CTYSTZIP
- +100 IF $LENGTH(ERXPRSA2)
- Begin DoDot:1
- +101 SET IEN=IEN+1
- SET @GL@(IEN,0)="Address Line 2: "_ERXPRSA2
- End DoDot:1
- +102 IF $ORDER(ADARY(0))
- Begin DoDot:1
- +103 SET ALOOP=1
- FOR
- SET ALOOP=$ORDER(ADARY(ALOOP))
- if 'ALOOP
- QUIT
- Begin DoDot:2
- +104 SET IEN=IEN+1
- SET @GL@(IEN,0)=" "_ADARY(ALOOP)
- End DoDot:2
- End DoDot:1
- +105 SET IEN=IEN+1
- SET @GL@(IEN,0)=""
- +106 DO TXT2ARY^PSOERXD1(.DRGARY,EDRG,,70)
- +107 SET IEN=IEN+1
- SET @GL@(IEN,0)="eRx Drug: "_$GET(DRGARY(1))_" "_$PIECE($$ERXDRSCH^PSOERXUT(PSOIEN),"^",2)
- +108 SET DLP=1
- +109 FOR
- SET DLP=$ORDER(DRGARY(DLP))
- if 'DLP
- QUIT
- Begin DoDot:1
- +110 SET IEN=IEN+1
- SET @GL@(IEN,0)=" "_$GET(DRGARY(DLP))
- End DoDot:1
- +111 SET LINETXT=""
- +112 DO ADDITEM^PSOERX1A(.LINETXT,"Qty: ",QTY,1,25)
- +113 DO ADDITEM^PSOERX1A(.LINETXT,"Days Supply: ",DAYS,27,16)
- +114 DO ADDITEM^PSOERX1A(.LINETXT,"Refills: ",REFILL,58,20)
- +115 SET IEN=IEN+1
- SET @GL@(IEN,0)=LINETXT
- +116 IF 'S2017
- Begin DoDot:1
- +117 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
- +118 IF S2017
- Begin DoDot:1
- +119 SET MIEN=$ORDER(^PS(52.49,PSOIEN,311,0))
- +120 SET ERXEFFDT=$$EFFDATE^PSOERXU5(PSOIEN,MIEN)
- +121 SET ERXWDATE=$$GET1^DIQ(52.49,PSOIEN,5.9,"I")
- +122 WRITE !,"eRx Written Date: "_$$FMTE^XLFDT($PIECE(ERXWDATE,"."),1)_" eRx Issue Date: "_ERXEFFDT
- End DoDot:1
- +123 SET ERXDSUB=$$GET1^DIQ(52.49,PSOIEN,5.8,"I")
- +124 SET ERXDSUB=$SELECT(ERXDSUB=1:"NO",ERXDSUB=0:"YES",1:"")
- +125 SET LINETXT=""
- +126 DO ADDITEM^PSOERX1A(.LINETXT,"Substitutions? :",ERXDSUB,1,25)
- +127 SET IEN=IEN+1
- SET @GL@(IEN,0)=LINETXT
- +128 IF 'S2017
- Begin DoDot:1
- +129 SET IEN=IEN+1
- SET @GL@(IEN,0)="eRx Sig: "
- +130 SET I=0
- FOR
- SET I=$ORDER(SIGARY(I))
- if 'I
- QUIT
- Begin DoDot:2
- +131 IF I=1
- SET @GL@(IEN,0)=@GL@(IEN,0)_SIGARY(I)
- QUIT
- +132 SET IEN=IEN+1
- SET @GL@(IEN,0)=$SELECT(I>1:" "_SIGARY(I),1:SIGARY(I))
- End DoDot:2
- +133 IF '$LENGTH(ESIG)
- SET IEN=IEN+1
- SET @GL@(IEN,0)=""
- End DoDot:1
- +134 IF S2017
- IF MTYPE?1(1"N",1"RE",1"CX")
- Begin DoDot:1
- +135 IF MTYPE?1(1"N",1"CX")
- Begin DoDot:2
- +136 SET PROHIBIT=$$GET1^DIQ(52.49,PSOIEN,301.3,"I")
- +137 SET PROHIBIT=$SELECT(PROHIBIT=1:"Yes",1:"No")
- +138 SET IEN=IEN+1
- SET @GL@(IEN,0)="Prohibit Renewals: "_PROHIBIT
- +139 SET IEN=IEN+1
- SET @GL@(IEN,0)=""
- End DoDot:2
- +140 SET IEN=IEN+1
- SET @GL@(IEN,0)="eRx Sig:"
- +141 SET SGLOOP=0
- FOR
- SET SGLOOP=$ORDER(^PS(52.49,PSOIEN,311,MIEN,8,SGLOOP))
- if 'SGLOOP
- QUIT
- Begin DoDot:2
- +142 SET IEN=IEN+1
- SET @GL@(IEN,0)=$GET(^PS(52.49,PSOIEN,311,MIEN,8,SGLOOP,0))
- End DoDot:2
- +143 SET IEN=IEN+1
- SET @GL@(IEN,0)=""
- End DoDot:1
- +144 SET IEN=IEN+1
- SET @GL@(IEN,0)="eRx Notes: "
- +145 SET I=0
- FOR
- SET I=$ORDER(COMMARY(I))
- if 'I
- QUIT
- Begin DoDot:1
- +146 IF I=1
- SET @GL@(IEN,0)=@GL@(IEN,0)_$SELECT(I>1:" "_COMMARY(I),1:COMMARY(I))
- QUIT
- +147 SET IEN=IEN+1
- SET @GL@(IEN,0)=$SELECT(I>1:" "_COMMARY(I),1:COMMARY(I))
- End DoDot:1
- +148 IF '$LENGTH(COMM)
- SET IEN=IEN+1
- SET @GL@(IEN,0)=""
- +149 if DFLG=1
- QUIT
- +150 SET LINETXT=""
- +151 SET IEN=IEN+1
- SET @GL@(IEN,0)=""
- +152 SET IEN=IEN+1
- SET @GL@(IEN,0)="Drug Form: "_DFORM
- +153 SET IEN=IEN+1
- SET @GL@(IEN,0)="Strength: "_DSTR
- +154 SET LINETXT=""
- +155 SET IEN=IEN+1
- SET @GL@(IEN,0)="Code List Qualifier: "_QQUAL
- +156 SET IEN=IEN+1
- SET @GL@(IEN,0)="Quantity Unit of Measure: "_POTUC
- +157 SET IEN=IEN+1
- SET @GL@(IEN,0)=LINETXT
- +158 SET ERXDSUB=$$GET1^DIQ(52.49,PSOIEN,5.8,"I")
- +159 SET ERXDSUB=$SELECT(ERXDSUB=1:"NO",ERXDSUB=0:"YES",1:"")
- +160 SET IEN=IEN+1
- SET @GL@(IEN,0)="Substitutions?: "_ERXDSUB
- +161 SET IEN=IEN+1
- SET @GL@(IEN,0)=""
- +162 IF '$GET(S2017)
- DO DIAG(PSOIEN,.IEN,.GL)
- +163 IF $GET(S2017)
- IF MIEN
- DO DIAG2017^PSOERXU5(PSOIEN,.IEN,.GL,MIEN)
- +164 SET $PIECE(LINE,"-",80)=""
- +165 SET IEN=IEN+1
- SET @GL@(IEN,0)=LINE
- +166 QUIT
- +167 ; 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 $GET(HFFDT)
- SET FDA(52.4919,"+1,"_PSOIEN_",",.05)=HFFDT
- +20 DO UPDATE^DIE(,"FDA")
- KILL FDA
- +21 ; Force a Refresh of the mail list
- +22 SET PSORFRSH=1
- +23 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 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"
- 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
- ALG(LINE) ;
- +1 NEW ALGINFO,ALGLINE,DFN,IEN,X,LDAT,GMRAL,PSONOAL
- +2 SET ALGLINE=""
- +3 SET DFN=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
- +4 DO EN1^GMRADPT
- +5 SET IEN=1
- +6 IF 'GMRAL
- Begin DoDot:1
- +7 SET IEN=IEN+1
- SET ^TMP("PSOPI",$JOB,IEN,0)="Allergies: "_$SELECT(GMRAL=0:"NKA",1:"")
- +8 IF GMRAL'=0
- SET PSONOAL=""
- DO ALLERGY^PSOORUT2
- IF PSONOAL'=""
- SET ^TMP("PSOPI",$JOB,IEN,0)="Allergies: "_PSONOAL
- KILL PSONOAL
- +9 SET IEN=IEN+1
- SET ^TMP("PSOPI",$JOB,IEN,0)=" "
- +10 DO REMOTE^PSOORUT2
- +11 SET IEN=IEN+1
- SET ^TMP("PSOPI",$JOB,IEN,0)="Adverse Reactions:"
- End DoDot:1
- +12 if $GET(GMRAL)
- DO ^PSOORUT3
- +13 ;S LINE=LINE+1
- +14 SET X=0
- FOR
- SET X=$ORDER(^TMP("PSOPI",$JOB,X))
- if 'X
- QUIT
- Begin DoDot:1
- +15 SET LDAT=$GET(^TMP("PSOPI",$JOB,X,0))
- +16 SET LINE=LINE+1
- +17 DO SET^VALM10(LINE,LDAT)
- End DoDot:1
- +18 KILL ^TMP("PSOPI",$JOB)
- +19 QUIT