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

PSOERXU8.m

Go to the documentation of this file.
  1. PSOERXU8 ;ALB/BLB - eRx Utilities/RPC's ; 08/18/2020 10:02am
  1. ;;7.0;OUTPATIENT PHARMACY;**581,617,700,743,746**;DEC 1997;Build 106
  1. ;
  1. ; Reference to ^XTV(8991.9) in ICR #7002
  1. ; Reference to ^VA(200 supported by ICR #10060
  1. Q
  1. BPROC(PSOIEN,BTYPE,MVFLD,VBFLD,VBDTTMF,VDTTM) ;
  1. N MBMSITE,ERXPAT,ERXSTAT,ERESTAT,ERXDT,ERXIEN,ERXARY,DIR,Y,L,LINE,CNT,EHID,EDRUG,EPROV,EPAT,ERXRDT,ERXRECDT,ERXEDT,I,FLG
  1. N REXEDT,EEPROV,ERXPROV,EXARY,MTYPE,RESTYPE,CSMSG,ERXID
  1. S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
  1. S MTYPE=$$GET1^DIQ(52.49,PSOIEN,.08,"I")
  1. S RESTYPE=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
  1. I MTYPE="CX" Q
  1. I MTYPE="RE",RESTYPE="R" Q
  1. S ERXPAT=$$GET1^DIQ(52.49,PSOIEN,.04,"I") Q:'ERXPAT
  1. S ERXPROV=$$GET1^DIQ(52.49,PSOIEN,2.1,"I")
  1. S ERXRECDT=$P($$GET1^DIQ(52.49,PSOIEN,.03,"I"),".")
  1. S ERXEDT=ERXRECDT_".2359"
  1. S ERXDT=ERXRECDT-.0001
  1. F S ERXDT=$O(^PS(52.49,"PAT2",ERXPAT,ERXDT)) Q:ERXDT>ERXEDT!(ERXDT="") D
  1. . S ERXIEN=0 F S ERXIEN=$O(^PS(52.49,"PAT2",ERXPAT,ERXDT,ERXIEN)) Q:'ERXIEN D
  1. . . I '$G(MBMSITE),$$GET1^DIQ(52.49,ERXIEN,24.1,"I")'=PSNPINST Q
  1. . . S ERESTAT=$$GET1^DIQ(52.49,ERXIEN,1)
  1. . . I (",PR,RM,RJ,CAN,CXQ,"[(","_ERESTAT_","))!(",E,"[(","_$E(ERESTAT)_",")) Q
  1. . . ; do not process any rx's that are not a 'newRx'.
  1. . . I $$GET1^DIQ(52.49,ERXIEN,.08,"I")'="N" Q
  1. . . ; eRx Provider already validated
  1. . . I BTYPE="PR",$$GET1^DIQ(52.49,ERXIEN,1.8,"I") Q
  1. . . Q:PSOIEN=ERXIEN
  1. . . I BTYPE="PR",$$GET1^DIQ(52.49,ERXIEN,2.1,"I")'=ERXPROV Q
  1. . . S EXARY(ERXIEN)=""
  1. I '$O(EXARY(0)) Q
  1. W !!
  1. I BTYPE="PA" D
  1. . W !,"This patient has other prescriptions for: "_$$FMTE^XLFDT(ERXRECDT)
  1. . W !,"Patient: "_$$GET1^DIQ(52.46,ERXPAT,.01,"E")
  1. I BTYPE="PR" D
  1. . W !,"There are other prescriptions for this patient, written by this provider on"
  1. . W !,$$FMTE^XLFDT(ERXRECDT)
  1. . W !,"Provider: "_$$GET1^DIQ(52.48,ERXPROV,.01,"E")
  1. . W !,"Patient: "_$$GET1^DIQ(52.46,ERXPAT,.01,"E")
  1. W !!,?4,"DRUG",?42,"PROVIDER",?67,"STA",?71,"REC DATE" ;P700 Adding Status
  1. S $P(LINE,"-",80)="" W !,LINE
  1. S L=0,CNT=0 F S L=$O(EXARY(L)) Q:'L D
  1. . S CNT=CNT+1
  1. . S EHID=$$GET1^DIQ(52.49,L,.01,"E")
  1. . S EDRUG=$$GET1^DIQ(52.49,L,3.1,"E")
  1. . S EEPROV=$$GET1^DIQ(52.49,L,2.1,"I")
  1. . S EPROV=$$GET1^DIQ(52.48,EEPROV,.01,"E")
  1. . S EPAT=$$GET1^DIQ(52.46,ERXPAT,.01,"E")
  1. . S ERXRDT=$P($$GET1^DIQ(52.49,L,.03,"I"),".") ;P700
  1. . W !,CNT_".) "_$E(EDRUG,1,37),?42,$E(EPROV,1,24),?67,$E(RXSTAT,1,3),?71,$$FMTE^XLFDT(ERXRDT,"2Z") ;P700
  1. W !!,"Would you like to apply the above validation to these prescriptions?"
  1. K Y S DIR(0)="YO"
  1. S DIR("B")="N" D ^DIR K DIR
  1. I Y="^"!(Y=0) Q
  1. S (CNT,CSMSG,ERXID)=0
  1. F S ERXID=$O(EXARY(ERXID)) Q:'ERXID D
  1. . S CNT=$G(CNT)+1
  1. . I $$GET1^DIQ(52.49,ERXID,95.1,"I") D
  1. . . I BTYPE="PA",'$$VALPTADD^PSOERXUT(+$$GET1^DIQ(52.49,PSOIEN,.05,"I")) D
  1. . . . W !,CNT,". ERX#: ",$$GET1^DIQ(52.49,ERXID,.01)," ERX DRUG: ",$$GET1^DIQ(52.49,ERXID,3.1)
  1. . . . W !,"Unable to validate - VistA Patient does not have a current mailing",!,"or residential address on file.",!
  1. . . . K EXARY(ERXID) S CSMSG=1
  1. . . I BTYPE="PR" D
  1. . . . K ERXMSG D PRDRVAL^PSOERXUT(.ERXMSG,"VP",ERXID,$$GET1^DIQ(52.49,PSOIEN,2.3,"I"))
  1. . . . I +ERXMSG!($P(ERXMSG,"^",2)="W") Q
  1. . . . W !,CNT,". ERX#: ",$$GET1^DIQ(52.49,ERXID,.01)," ERX DRUG: ",$$GET1^DIQ(52.49,ERXID,3.1)
  1. . . . S I=0 F S I=$O(ERXMSG(I)) Q:'I D
  1. . . . . W !,"Unable to validate - ",$P(ERXMSG(I),"^"),! K EXARY(ERXID) S CSMSG=1
  1. . I '$O(EXARY(ERXID)),$G(CSMSG) S DIR(0)="E" D ^DIR
  1. S I=0 F S I=$O(EXARY(I)) Q:'I D
  1. . I BTYPE="PA" S FDA(52.49,I_",",.05)=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
  1. . I BTYPE="PR" S FDA(52.49,I_",",2.3)=$$GET1^DIQ(52.49,PSOIEN,2.3,"I")
  1. . S FDA(52.49,I_",",MVFLD)=1,FDA(52.49,I_",",VBFLD)=$G(DUZ),FDA(52.49,I_",",VBDTTMF)=VDTTM
  1. . D FILE^DIE(,"FDA") K FDA
  1. . I $$GET1^DIQ(52.49,I,1,"E")="N" D UPDSTAT^PSOERXU1(I,"I")
  1. . I $$GET1^DIQ(52.49,I,1.3,"I"),$$GET1^DIQ(52.49,I,1.5,"I"),$$GET1^DIQ(52.49,I,1.7,"I") D
  1. . . D UPDSTAT^PSOERXU1(I,"W")
  1. Q
  1. ;
  1. VADEA(NPIEN,ERXIEN) ; Get Provider's VA DEA Matching DEATXT if possible. If no match, get default USER FOR INPATIENT DEA#.
  1. N ERXPROV,ERXPRDEA,RXWRDATE,VADEASUF,RXDEADT,VADEA,VADEADSP
  1. Q:'$G(ERXIEN) ""
  1. Q:'$D(^PS(52.49,ERXIEN,0)) ""
  1. Q:'$G(NPIEN) ""
  1. S ERXPROV=$$GET1^DIQ(52.49,ERXIEN,2.1,"I") ; eRx Provider IEN
  1. S ERXPRDEA=$$UP^XLFSTR($$GET1^DIQ(52.48,ERXPROV,1.6)) ; eRx Provider DEA#
  1. S RXWRDATE=$$GET1^DIQ(52.49,ERXIEN,5.9,"I") ; eRx Written Date
  1. S RXDEADT=$$FMADD^XLFDT(RXWRDATE,-3650)
  1. ;
  1. S VADEA=$$UP^XLFSTR($$DEA^XUSER(0,NPIEN,RXDEADT,$P(ERXPRDEA,"-"))),VADEADSP=$P(VADEA,"^")
  1. I VADEA="" S VADEA=$$PRDEA^XUPSPRA(NPIEN),VADEADSP=VADEA
  1. I VADEA="",$O(^VA(200,NPIEN,"PS4",0)) D
  1. . N DEACNT,DEAVAIEN,DEAXUIEN,DEAXTV S DEAVAIEN=0 F DEACNT=0:1 S DEAVAIEN=$O(^VA(200,NPIEN,"PS4",DEAVAIEN)) Q:'DEAVAIEN D
  1. . . S DEAXUIEN=$P(^VA(200,NPIEN,"PS4",DEAVAIEN,0),"^",3),VADEADSP=$P(^VA(200,NPIEN,"PS4",DEAVAIEN,0),"^")
  1. . . I DEAXUIEN,$D(^XTV(8991.9,DEAXUIEN,0)),(VADEADSP=$P(^XTV(8991.9,DEAXUIEN,0),"^")) S VADEA=VADEADSP
  1. I $L(VADEADSP)>8 D
  1. . S VADEASUF=$$VADEASUF(VADEADSP,NPIEN) Q:VADEASUF=""
  1. . S VADEA=$P(VADEA,"-")_"-"_VADEASUF,VADEADSP=VADEA
  1. Q VADEA_"^"_VADEADSP
  1. ;
  1. VADEASUF(DEATXT,NPIEN) ; Get Provider's VA DEA Suffix
  1. N NPDEAIEN,IENS,DNDEAIEN
  1. K DEASUFF S DEASUFF=""
  1. S DNDEAIEN=$$FIND1^DIC(8991.9,,,DEATXT) Q:'DNDEAIEN ""
  1. Q:$$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")'=1 ""
  1. S NPDEAIEN=$$FIND1^DIC(200.5321,","_NPIEN_",",,DEATXT)
  1. S IENS=NPDEAIEN_","_NPIEN_","
  1. S DEASUFF=$$GET1^DIQ(200.5321,IENS,.02,"E")
  1. Q DEASUFF
  1. ;
  1. DEAFOUND(DEATXT,NPIEN) ; Is DEA=DEATXT found on profile=NPIEN profile in ^VA(200,NPIEN,"PS4"?
  1. I '$L($G(DEATXT))!'$G(NPIEN)!'$D(^VA(200,+$G(NPIEN),"PS4")) Q 0
  1. Q $D(^VA(200,NPIEN,"PS4","B",$P(DEATXT,"-")))
  1. ;
  1. ERXSIG(ERXIEN) ; Returns the eRx SIG
  1. ; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49)
  1. ;Output: ERXSIG - eRx SIG in one string
  1. ;
  1. N ERXSIG,SIG,I,S2017,MSGTYPE,RESTYPE,MEDIEN
  1. S ERXSIG=""
  1. I '$D(^PS(52.49,+$G(ERXIEN),0)) Q ERXSIG
  1. S S2017=+$G(^PS(52.49,ERXIEN,312))
  1. S MSGTYPE=$P($G(^PS(52.49,ERXIEN,0)),"^",8)
  1. S RESTYPE=$P($G(^PS(52.49,ERXIEN,52)),"^")
  1. I S2017 D
  1. . I MSGTYPE="CX" S MEDIEN=$O(^PS(52.49,ERXIEN,311,"C","P",0))
  1. . I MSGTYPE="RE",(RESTYPE="R") S MEDIEN=$O(^PS(52.49,ERXIEN,311,"C","MR",0))
  1. . I MSGTYPE="N"!'$G(MEDIEN) S MEDIEN=$O(^PS(52.49,ERXIEN,311,0))
  1. . I '$G(MEDIEN) Q
  1. . F I=1:1 Q:'$D(^PS(52.49,ERXIEN,311,MEDIEN,8,I)) D
  1. . . S ERXSIG=ERXSIG_$G(^PS(52.49,ERXIEN,311,MEDIEN,8,I,0))_" "
  1. . S $E(ERXSIG,$L(ERXSIG))=""
  1. I 'S2017 D
  1. . S ERXSIG=$P($G(^PS(52.49,ERXIEN,7)),"^")
  1. Q ERXSIG
  1. ;
  1. VISTASIG(ERXIEN) ; Returns the VistA SIG, if present
  1. ; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49)
  1. ;Output: VISTASIG - VistA SIG in one string
  1. ;
  1. N VISTASIG,SIG
  1. S VISTASIG=""
  1. S SIG=0 F S SIG=$O(^PS(52.49,ERXIEN,"SIG",SIG)) Q:'SIG D
  1. . S VISTASIG=VISTASIG_$G(^PS(52.49,ERXIEN,"SIG",SIG,0))
  1. ; VA Patient Instructions
  1. I $$GET1^DIQ(52.49,ERXIEN,27)'="" D
  1. . S VISTASIG=VISTASIG_$S($E(VISTASIG,$L(VISTASIG))=" ":"",1:" ")_$$GET1^DIQ(52.49,ERXIEN,27)
  1. Q VISTASIG
  1. ;
  1. RENEWALS(ERXIEN) ; Returns whether Renewals are Prohibited or no
  1. ; Input: ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49)
  1. ;Output: RENEWALS - 1: Renewals are Allowed | 0 - Renewals are Prohibited
  1. N RENEWALS,MTYPE,CHGMESRQ,CHGMESRI,RESPVAL
  1. S RENEWALS=0,MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
  1. S CHGMESRQ=$$GET1^DIQ(52.49,ERXIEN,315.1,"I")
  1. S CHGMESRI=$$GET1^DIQ(52.45,CHGMESRQ,.01,"I")
  1. S RESPVAL=$$GET1^DIQ(52.49,ERXIEN,52.1,"E")
  1. I MTYPE="N"!((MTYPE="CX")&($$PROHIBIT^PSOERX1D(RESPVAL,CHGMESRI))) D
  1. . S RENEWALS=$S($$GET1^DIQ(52.49,ERXIEN,301.3,"I"):0,1:1)
  1. Q RENEWALS
  1. ;
  1. SUFCHK(RESULT,ERXPRDEA,VADEADFL,ERXSUFF) ; Check for matching DEA, mismatched suffix
  1. I ERXPRDEA'="",($L(VADEADFL)>8),(ERXPRDEA'=VADEADFL),($P(ERXPRDEA,"-")=$P(VADEADFL,"-")),'$G(ERXSUFF) D ; PSO*7*743
  1. . D SUFFWARN^PSOERXUT(.RESULT,ERXPRDEA,$S($L($G(VADEADFL)>8):VADEADFL,1:VADEANUM),0)
  1. . S RESULT=$S($G(RESULT)="0^B":RESULT,1:"0^W")
  1. Q