PSOERXU8 ;ALB/BLB - eRx Utilities/RPC's ; 08/18/2020 10:02am
;;7.0;OUTPATIENT PHARMACY;**581,617,700,743,746**;DEC 1997;Build 106
;
; Reference to ^XTV(8991.9) in ICR #7002
; Reference to ^VA(200 supported by ICR #10060
Q
BPROC(PSOIEN,BTYPE,MVFLD,VBFLD,VBDTTMF,VDTTM) ;
N MBMSITE,ERXPAT,ERXSTAT,ERESTAT,ERXDT,ERXIEN,ERXARY,DIR,Y,L,LINE,CNT,EHID,EDRUG,EPROV,EPAT,ERXRDT,ERXRECDT,ERXEDT,I,FLG
N REXEDT,EEPROV,ERXPROV,EXARY,MTYPE,RESTYPE,CSMSG,ERXID
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
S MTYPE=$$GET1^DIQ(52.49,PSOIEN,.08,"I")
S RESTYPE=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
I MTYPE="CX" Q
I MTYPE="RE",RESTYPE="R" Q
S ERXPAT=$$GET1^DIQ(52.49,PSOIEN,.04,"I") Q:'ERXPAT
S ERXPROV=$$GET1^DIQ(52.49,PSOIEN,2.1,"I")
S ERXRECDT=$P($$GET1^DIQ(52.49,PSOIEN,.03,"I"),".")
S ERXEDT=ERXRECDT_".2359"
S ERXDT=ERXRECDT-.0001
F S ERXDT=$O(^PS(52.49,"PAT2",ERXPAT,ERXDT)) Q:ERXDT>ERXEDT!(ERXDT="") D
. S ERXIEN=0 F S ERXIEN=$O(^PS(52.49,"PAT2",ERXPAT,ERXDT,ERXIEN)) Q:'ERXIEN D
. . I '$G(MBMSITE),$$GET1^DIQ(52.49,ERXIEN,24.1,"I")'=PSNPINST Q
. . S ERESTAT=$$GET1^DIQ(52.49,ERXIEN,1)
. . I (",PR,RM,RJ,CAN,CXQ,"[(","_ERESTAT_","))!(",E,"[(","_$E(ERESTAT)_",")) Q
. . ; do not process any rx's that are not a 'newRx'.
. . I $$GET1^DIQ(52.49,ERXIEN,.08,"I")'="N" Q
. . ; eRx Provider already validated
. . I BTYPE="PR",$$GET1^DIQ(52.49,ERXIEN,1.8,"I") Q
. . Q:PSOIEN=ERXIEN
. . I BTYPE="PR",$$GET1^DIQ(52.49,ERXIEN,2.1,"I")'=ERXPROV Q
. . S EXARY(ERXIEN)=""
I '$O(EXARY(0)) Q
W !!
I BTYPE="PA" D
. W !,"This patient has other prescriptions for: "_$$FMTE^XLFDT(ERXRECDT)
. W !,"Patient: "_$$GET1^DIQ(52.46,ERXPAT,.01,"E")
I BTYPE="PR" D
. W !,"There are other prescriptions for this patient, written by this provider on"
. W !,$$FMTE^XLFDT(ERXRECDT)
. W !,"Provider: "_$$GET1^DIQ(52.48,ERXPROV,.01,"E")
. W !,"Patient: "_$$GET1^DIQ(52.46,ERXPAT,.01,"E")
W !!,?4,"DRUG",?42,"PROVIDER",?67,"STA",?71,"REC DATE" ;P700 Adding Status
S $P(LINE,"-",80)="" W !,LINE
S L=0,CNT=0 F S L=$O(EXARY(L)) Q:'L D
. S CNT=CNT+1
. S EHID=$$GET1^DIQ(52.49,L,.01,"E")
. S EDRUG=$$GET1^DIQ(52.49,L,3.1,"E")
. S EEPROV=$$GET1^DIQ(52.49,L,2.1,"I")
. S EPROV=$$GET1^DIQ(52.48,EEPROV,.01,"E")
. S EPAT=$$GET1^DIQ(52.46,ERXPAT,.01,"E")
. S ERXRDT=$P($$GET1^DIQ(52.49,L,.03,"I"),".") ;P700
. W !,CNT_".) "_$E(EDRUG,1,37),?42,$E(EPROV,1,24),?67,$E(RXSTAT,1,3),?71,$$FMTE^XLFDT(ERXRDT,"2Z") ;P700
W !!,"Would you like to apply the above validation to these prescriptions?"
K Y S DIR(0)="YO"
S DIR("B")="N" D ^DIR K DIR
I Y="^"!(Y=0) Q
S (CNT,CSMSG,ERXID)=0
F S ERXID=$O(EXARY(ERXID)) Q:'ERXID D
. S CNT=$G(CNT)+1
. I $$GET1^DIQ(52.49,ERXID,95.1,"I") D
. . I BTYPE="PA",'$$VALPTADD^PSOERXUT(+$$GET1^DIQ(52.49,PSOIEN,.05,"I")) D
. . . W !,CNT,". ERX#: ",$$GET1^DIQ(52.49,ERXID,.01)," ERX DRUG: ",$$GET1^DIQ(52.49,ERXID,3.1)
. . . W !,"Unable to validate - VistA Patient does not have a current mailing",!,"or residential address on file.",!
. . . K EXARY(ERXID) S CSMSG=1
. . I BTYPE="PR" D
. . . K ERXMSG D PRDRVAL^PSOERXUT(.ERXMSG,"VP",ERXID,$$GET1^DIQ(52.49,PSOIEN,2.3,"I"))
. . . I +ERXMSG!($P(ERXMSG,"^",2)="W") Q
. . . W !,CNT,". ERX#: ",$$GET1^DIQ(52.49,ERXID,.01)," ERX DRUG: ",$$GET1^DIQ(52.49,ERXID,3.1)
. . . S I=0 F S I=$O(ERXMSG(I)) Q:'I D
. . . . W !,"Unable to validate - ",$P(ERXMSG(I),"^"),! K EXARY(ERXID) S CSMSG=1
. I '$O(EXARY(ERXID)),$G(CSMSG) S DIR(0)="E" D ^DIR
S I=0 F S I=$O(EXARY(I)) Q:'I D
. I BTYPE="PA" S FDA(52.49,I_",",.05)=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
. I BTYPE="PR" S FDA(52.49,I_",",2.3)=$$GET1^DIQ(52.49,PSOIEN,2.3,"I")
. S FDA(52.49,I_",",MVFLD)=1,FDA(52.49,I_",",VBFLD)=$G(DUZ),FDA(52.49,I_",",VBDTTMF)=VDTTM
. D FILE^DIE(,"FDA") K FDA
. I $$GET1^DIQ(52.49,I,1,"E")="N" D UPDSTAT^PSOERXU1(I,"I")
. 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
. . D UPDSTAT^PSOERXU1(I,"W")
Q
;
VADEA(NPIEN,ERXIEN) ; Get Provider's VA DEA Matching DEATXT if possible. If no match, get default USER FOR INPATIENT DEA#.
N ERXPROV,ERXPRDEA,RXWRDATE,VADEASUF,RXDEADT,VADEA,VADEADSP
Q:'$G(ERXIEN) ""
Q:'$D(^PS(52.49,ERXIEN,0)) ""
Q:'$G(NPIEN) ""
S ERXPROV=$$GET1^DIQ(52.49,ERXIEN,2.1,"I") ; eRx Provider IEN
S ERXPRDEA=$$UP^XLFSTR($$GET1^DIQ(52.48,ERXPROV,1.6)) ; eRx Provider DEA#
S RXWRDATE=$$GET1^DIQ(52.49,ERXIEN,5.9,"I") ; eRx Written Date
S RXDEADT=$$FMADD^XLFDT(RXWRDATE,-3650)
;
S VADEA=$$UP^XLFSTR($$DEA^XUSER(0,NPIEN,RXDEADT,$P(ERXPRDEA,"-"))),VADEADSP=$P(VADEA,"^")
I VADEA="" S VADEA=$$PRDEA^XUPSPRA(NPIEN),VADEADSP=VADEA
I VADEA="",$O(^VA(200,NPIEN,"PS4",0)) D
. N DEACNT,DEAVAIEN,DEAXUIEN,DEAXTV S DEAVAIEN=0 F DEACNT=0:1 S DEAVAIEN=$O(^VA(200,NPIEN,"PS4",DEAVAIEN)) Q:'DEAVAIEN D
. . S DEAXUIEN=$P(^VA(200,NPIEN,"PS4",DEAVAIEN,0),"^",3),VADEADSP=$P(^VA(200,NPIEN,"PS4",DEAVAIEN,0),"^")
. . I DEAXUIEN,$D(^XTV(8991.9,DEAXUIEN,0)),(VADEADSP=$P(^XTV(8991.9,DEAXUIEN,0),"^")) S VADEA=VADEADSP
I $L(VADEADSP)>8 D
. S VADEASUF=$$VADEASUF(VADEADSP,NPIEN) Q:VADEASUF=""
. S VADEA=$P(VADEA,"-")_"-"_VADEASUF,VADEADSP=VADEA
Q VADEA_"^"_VADEADSP
;
VADEASUF(DEATXT,NPIEN) ; Get Provider's VA DEA Suffix
N NPDEAIEN,IENS,DNDEAIEN
K DEASUFF S DEASUFF=""
S DNDEAIEN=$$FIND1^DIC(8991.9,,,DEATXT) Q:'DNDEAIEN ""
Q:$$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")'=1 ""
S NPDEAIEN=$$FIND1^DIC(200.5321,","_NPIEN_",",,DEATXT)
S IENS=NPDEAIEN_","_NPIEN_","
S DEASUFF=$$GET1^DIQ(200.5321,IENS,.02,"E")
Q DEASUFF
;
DEAFOUND(DEATXT,NPIEN) ; Is DEA=DEATXT found on profile=NPIEN profile in ^VA(200,NPIEN,"PS4"?
I '$L($G(DEATXT))!'$G(NPIEN)!'$D(^VA(200,+$G(NPIEN),"PS4")) Q 0
Q $D(^VA(200,NPIEN,"PS4","B",$P(DEATXT,"-")))
;
ERXSIG(ERXIEN) ; Returns the eRx SIG
; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49)
;Output: ERXSIG - eRx SIG in one string
;
N ERXSIG,SIG,I,S2017,MSGTYPE,RESTYPE,MEDIEN
S ERXSIG=""
I '$D(^PS(52.49,+$G(ERXIEN),0)) Q ERXSIG
S S2017=+$G(^PS(52.49,ERXIEN,312))
S MSGTYPE=$P($G(^PS(52.49,ERXIEN,0)),"^",8)
S RESTYPE=$P($G(^PS(52.49,ERXIEN,52)),"^")
I S2017 D
. I MSGTYPE="CX" S MEDIEN=$O(^PS(52.49,ERXIEN,311,"C","P",0))
. I MSGTYPE="RE",(RESTYPE="R") S MEDIEN=$O(^PS(52.49,ERXIEN,311,"C","MR",0))
. I MSGTYPE="N"!'$G(MEDIEN) S MEDIEN=$O(^PS(52.49,ERXIEN,311,0))
. I '$G(MEDIEN) Q
. F I=1:1 Q:'$D(^PS(52.49,ERXIEN,311,MEDIEN,8,I)) D
. . S ERXSIG=ERXSIG_$G(^PS(52.49,ERXIEN,311,MEDIEN,8,I,0))_" "
. S $E(ERXSIG,$L(ERXSIG))=""
I 'S2017 D
. S ERXSIG=$P($G(^PS(52.49,ERXIEN,7)),"^")
Q ERXSIG
;
VISTASIG(ERXIEN) ; Returns the VistA SIG, if present
; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49)
;Output: VISTASIG - VistA SIG in one string
;
N VISTASIG,SIG
S VISTASIG=""
S SIG=0 F S SIG=$O(^PS(52.49,ERXIEN,"SIG",SIG)) Q:'SIG D
. S VISTASIG=VISTASIG_$G(^PS(52.49,ERXIEN,"SIG",SIG,0))
; VA Patient Instructions
I $$GET1^DIQ(52.49,ERXIEN,27)'="" D
. S VISTASIG=VISTASIG_$S($E(VISTASIG,$L(VISTASIG))=" ":"",1:" ")_$$GET1^DIQ(52.49,ERXIEN,27)
Q VISTASIG
;
RENEWALS(ERXIEN) ; Returns whether Renewals are Prohibited or no
; Input: ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49)
;Output: RENEWALS - 1: Renewals are Allowed | 0 - Renewals are Prohibited
N RENEWALS,MTYPE,CHGMESRQ,CHGMESRI,RESPVAL
S RENEWALS=0,MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
S CHGMESRQ=$$GET1^DIQ(52.49,ERXIEN,315.1,"I")
S CHGMESRI=$$GET1^DIQ(52.45,CHGMESRQ,.01,"I")
S RESPVAL=$$GET1^DIQ(52.49,ERXIEN,52.1,"E")
I MTYPE="N"!((MTYPE="CX")&($$PROHIBIT^PSOERX1D(RESPVAL,CHGMESRI))) D
. S RENEWALS=$S($$GET1^DIQ(52.49,ERXIEN,301.3,"I"):0,1:1)
Q RENEWALS
;
SUFCHK(RESULT,ERXPRDEA,VADEADFL,ERXSUFF) ; Check for matching DEA, mismatched suffix
I ERXPRDEA'="",($L(VADEADFL)>8),(ERXPRDEA'=VADEADFL),($P(ERXPRDEA,"-")=$P(VADEADFL,"-")),'$G(ERXSUFF) D ; PSO*7*743
. D SUFFWARN^PSOERXUT(.RESULT,ERXPRDEA,$S($L($G(VADEADFL)>8):VADEADFL,1:VADEANUM),0)
. S RESULT=$S($G(RESULT)="0^B":RESULT,1:"0^W")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXU8 8108 printed Dec 13, 2024@02:29:09 Page 2
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
+2 ;
+3 ; Reference to ^XTV(8991.9) in ICR #7002
+4 ; Reference to ^VA(200 supported by ICR #10060
+5 QUIT
BPROC(PSOIEN,BTYPE,MVFLD,VBFLD,VBDTTMF,VDTTM) ;
+1 NEW MBMSITE,ERXPAT,ERXSTAT,ERESTAT,ERXDT,ERXIEN,ERXARY,DIR,Y,L,LINE,CNT,EHID,EDRUG,EPROV,EPAT,ERXRDT,ERXRECDT,ERXEDT,I,FLG
+2 NEW REXEDT,EEPROV,ERXPROV,EXARY,MTYPE,RESTYPE,CSMSG,ERXID
+3 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+4 SET MTYPE=$$GET1^DIQ(52.49,PSOIEN,.08,"I")
+5 SET RESTYPE=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
+6 IF MTYPE="CX"
QUIT
+7 IF MTYPE="RE"
IF RESTYPE="R"
QUIT
+8 SET ERXPAT=$$GET1^DIQ(52.49,PSOIEN,.04,"I")
if 'ERXPAT
QUIT
+9 SET ERXPROV=$$GET1^DIQ(52.49,PSOIEN,2.1,"I")
+10 SET ERXRECDT=$PIECE($$GET1^DIQ(52.49,PSOIEN,.03,"I"),".")
+11 SET ERXEDT=ERXRECDT_".2359"
+12 SET ERXDT=ERXRECDT-.0001
+13 FOR
SET ERXDT=$ORDER(^PS(52.49,"PAT2",ERXPAT,ERXDT))
if ERXDT>ERXEDT!(ERXDT="")
QUIT
Begin DoDot:1
+14 SET ERXIEN=0
FOR
SET ERXIEN=$ORDER(^PS(52.49,"PAT2",ERXPAT,ERXDT,ERXIEN))
if 'ERXIEN
QUIT
Begin DoDot:2
+15 IF '$GET(MBMSITE)
IF $$GET1^DIQ(52.49,ERXIEN,24.1,"I")'=PSNPINST
QUIT
+16 SET ERESTAT=$$GET1^DIQ(52.49,ERXIEN,1)
+17 IF (",PR,RM,RJ,CAN,CXQ,"[(","_ERESTAT_","))!(",E,"[(","_$EXTRACT(ERESTAT)_","))
QUIT
+18 ; do not process any rx's that are not a 'newRx'.
+19 IF $$GET1^DIQ(52.49,ERXIEN,.08,"I")'="N"
QUIT
+20 ; eRx Provider already validated
+21 IF BTYPE="PR"
IF $$GET1^DIQ(52.49,ERXIEN,1.8,"I")
QUIT
+22 if PSOIEN=ERXIEN
QUIT
+23 IF BTYPE="PR"
IF $$GET1^DIQ(52.49,ERXIEN,2.1,"I")'=ERXPROV
QUIT
+24 SET EXARY(ERXIEN)=""
End DoDot:2
End DoDot:1
+25 IF '$ORDER(EXARY(0))
QUIT
+26 WRITE !!
+27 IF BTYPE="PA"
Begin DoDot:1
+28 WRITE !,"This patient has other prescriptions for: "_$$FMTE^XLFDT(ERXRECDT)
+29 WRITE !,"Patient: "_$$GET1^DIQ(52.46,ERXPAT,.01,"E")
End DoDot:1
+30 IF BTYPE="PR"
Begin DoDot:1
+31 WRITE !,"There are other prescriptions for this patient, written by this provider on"
+32 WRITE !,$$FMTE^XLFDT(ERXRECDT)
+33 WRITE !,"Provider: "_$$GET1^DIQ(52.48,ERXPROV,.01,"E")
+34 WRITE !,"Patient: "_$$GET1^DIQ(52.46,ERXPAT,.01,"E")
End DoDot:1
+35 ;P700 Adding Status
WRITE !!,?4,"DRUG",?42,"PROVIDER",?67,"STA",?71,"REC DATE"
+36 SET $PIECE(LINE,"-",80)=""
WRITE !,LINE
+37 SET L=0
SET CNT=0
FOR
SET L=$ORDER(EXARY(L))
if 'L
QUIT
Begin DoDot:1
+38 SET CNT=CNT+1
+39 SET EHID=$$GET1^DIQ(52.49,L,.01,"E")
+40 SET EDRUG=$$GET1^DIQ(52.49,L,3.1,"E")
+41 SET EEPROV=$$GET1^DIQ(52.49,L,2.1,"I")
+42 SET EPROV=$$GET1^DIQ(52.48,EEPROV,.01,"E")
+43 SET EPAT=$$GET1^DIQ(52.46,ERXPAT,.01,"E")
+44 ;P700
SET ERXRDT=$PIECE($$GET1^DIQ(52.49,L,.03,"I"),".")
+45 ;P700
WRITE !,CNT_".) "_$EXTRACT(EDRUG,1,37),?42,$EXTRACT(EPROV,1,24),?67,$EXTRACT(RXSTAT,1,3),?71,$$FMTE^XLFDT(ERXRDT,"2Z")
End DoDot:1
+46 WRITE !!,"Would you like to apply the above validation to these prescriptions?"
+47 KILL Y
SET DIR(0)="YO"
+48 SET DIR("B")="N"
DO ^DIR
KILL DIR
+49 IF Y="^"!(Y=0)
QUIT
+50 SET (CNT,CSMSG,ERXID)=0
+51 FOR
SET ERXID=$ORDER(EXARY(ERXID))
if 'ERXID
QUIT
Begin DoDot:1
+52 SET CNT=$GET(CNT)+1
+53 IF $$GET1^DIQ(52.49,ERXID,95.1,"I")
Begin DoDot:2
+54 IF BTYPE="PA"
IF '$$VALPTADD^PSOERXUT(+$$GET1^DIQ(52.49,PSOIEN,.05,"I"))
Begin DoDot:3
+55 WRITE !,CNT,". ERX#: ",$$GET1^DIQ(52.49,ERXID,.01)," ERX DRUG: ",$$GET1^DIQ(52.49,ERXID,3.1)
+56 WRITE !,"Unable to validate - VistA Patient does not have a current mailing",!,"or residential address on file.",!
+57 KILL EXARY(ERXID)
SET CSMSG=1
End DoDot:3
+58 IF BTYPE="PR"
Begin DoDot:3
+59 KILL ERXMSG
DO PRDRVAL^PSOERXUT(.ERXMSG,"VP",ERXID,$$GET1^DIQ(52.49,PSOIEN,2.3,"I"))
+60 IF +ERXMSG!($PIECE(ERXMSG,"^",2)="W")
QUIT
+61 WRITE !,CNT,". ERX#: ",$$GET1^DIQ(52.49,ERXID,.01)," ERX DRUG: ",$$GET1^DIQ(52.49,ERXID,3.1)
+62 SET I=0
FOR
SET I=$ORDER(ERXMSG(I))
if 'I
QUIT
Begin DoDot:4
+63 WRITE !,"Unable to validate - ",$PIECE(ERXMSG(I),"^"),!
KILL EXARY(ERXID)
SET CSMSG=1
End DoDot:4
End DoDot:3
End DoDot:2
+64 IF '$ORDER(EXARY(ERXID))
IF $GET(CSMSG)
SET DIR(0)="E"
DO ^DIR
End DoDot:1
+65 SET I=0
FOR
SET I=$ORDER(EXARY(I))
if 'I
QUIT
Begin DoDot:1
+66 IF BTYPE="PA"
SET FDA(52.49,I_",",.05)=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
+67 IF BTYPE="PR"
SET FDA(52.49,I_",",2.3)=$$GET1^DIQ(52.49,PSOIEN,2.3,"I")
+68 SET FDA(52.49,I_",",MVFLD)=1
SET FDA(52.49,I_",",VBFLD)=$GET(DUZ)
SET FDA(52.49,I_",",VBDTTMF)=VDTTM
+69 DO FILE^DIE(,"FDA")
KILL FDA
+70 IF $$GET1^DIQ(52.49,I,1,"E")="N"
DO UPDSTAT^PSOERXU1(I,"I")
+71 IF $$GET1^DIQ(52.49,I,1.3,"I")
IF $$GET1^DIQ(52.49,I,1.5,"I")
IF $$GET1^DIQ(52.49,I,1.7,"I")
Begin DoDot:2
+72 DO UPDSTAT^PSOERXU1(I,"W")
End DoDot:2
End DoDot:1
+73 QUIT
+74 ;
VADEA(NPIEN,ERXIEN) ; Get Provider's VA DEA Matching DEATXT if possible. If no match, get default USER FOR INPATIENT DEA#.
+1 NEW ERXPROV,ERXPRDEA,RXWRDATE,VADEASUF,RXDEADT,VADEA,VADEADSP
+2 if '$GET(ERXIEN)
QUIT ""
+3 if '$DATA(^PS(52.49,ERXIEN,0))
QUIT ""
+4 if '$GET(NPIEN)
QUIT ""
+5 ; eRx Provider IEN
SET ERXPROV=$$GET1^DIQ(52.49,ERXIEN,2.1,"I")
+6 ; eRx Provider DEA#
SET ERXPRDEA=$$UP^XLFSTR($$GET1^DIQ(52.48,ERXPROV,1.6))
+7 ; eRx Written Date
SET RXWRDATE=$$GET1^DIQ(52.49,ERXIEN,5.9,"I")
+8 SET RXDEADT=$$FMADD^XLFDT(RXWRDATE,-3650)
+9 ;
+10 SET VADEA=$$UP^XLFSTR($$DEA^XUSER(0,NPIEN,RXDEADT,$PIECE(ERXPRDEA,"-")))
SET VADEADSP=$PIECE(VADEA,"^")
+11 IF VADEA=""
SET VADEA=$$PRDEA^XUPSPRA(NPIEN)
SET VADEADSP=VADEA
+12 IF VADEA=""
IF $ORDER(^VA(200,NPIEN,"PS4",0))
Begin DoDot:1
+13 NEW DEACNT,DEAVAIEN,DEAXUIEN,DEAXTV
SET DEAVAIEN=0
FOR DEACNT=0:1
SET DEAVAIEN=$ORDER(^VA(200,NPIEN,"PS4",DEAVAIEN))
if 'DEAVAIEN
QUIT
Begin DoDot:2
+14 SET DEAXUIEN=$PIECE(^VA(200,NPIEN,"PS4",DEAVAIEN,0),"^",3)
SET VADEADSP=$PIECE(^VA(200,NPIEN,"PS4",DEAVAIEN,0),"^")
+15 IF DEAXUIEN
IF $DATA(^XTV(8991.9,DEAXUIEN,0))
IF (VADEADSP=$PIECE(^XTV(8991.9,DEAXUIEN,0),"^"))
SET VADEA=VADEADSP
End DoDot:2
End DoDot:1
+16 IF $LENGTH(VADEADSP)>8
Begin DoDot:1
+17 SET VADEASUF=$$VADEASUF(VADEADSP,NPIEN)
if VADEASUF=""
QUIT
+18 SET VADEA=$PIECE(VADEA,"-")_"-"_VADEASUF
SET VADEADSP=VADEA
End DoDot:1
+19 QUIT VADEA_"^"_VADEADSP
+20 ;
VADEASUF(DEATXT,NPIEN) ; Get Provider's VA DEA Suffix
+1 NEW NPDEAIEN,IENS,DNDEAIEN
+2 KILL DEASUFF
SET DEASUFF=""
+3 SET DNDEAIEN=$$FIND1^DIC(8991.9,,,DEATXT)
if 'DNDEAIEN
QUIT ""
+4 if $$GET1^DIQ(8991.9,DNDEAIEN,.07,"I")'=1
QUIT ""
+5 SET NPDEAIEN=$$FIND1^DIC(200.5321,","_NPIEN_",",,DEATXT)
+6 SET IENS=NPDEAIEN_","_NPIEN_","
+7 SET DEASUFF=$$GET1^DIQ(200.5321,IENS,.02,"E")
+8 QUIT DEASUFF
+9 ;
DEAFOUND(DEATXT,NPIEN) ; Is DEA=DEATXT found on profile=NPIEN profile in ^VA(200,NPIEN,"PS4"?
+1 IF '$LENGTH($GET(DEATXT))!'$GET(NPIEN)!'$DATA(^VA(200,+$GET(NPIEN),"PS4"))
QUIT 0
+2 QUIT $DATA(^VA(200,NPIEN,"PS4","B",$PIECE(DEATXT,"-")))
+3 ;
ERXSIG(ERXIEN) ; Returns the eRx SIG
+1 ; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49)
+2 ;Output: ERXSIG - eRx SIG in one string
+3 ;
+4 NEW ERXSIG,SIG,I,S2017,MSGTYPE,RESTYPE,MEDIEN
+5 SET ERXSIG=""
+6 IF '$DATA(^PS(52.49,+$GET(ERXIEN),0))
QUIT ERXSIG
+7 SET S2017=+$GET(^PS(52.49,ERXIEN,312))
+8 SET MSGTYPE=$PIECE($GET(^PS(52.49,ERXIEN,0)),"^",8)
+9 SET RESTYPE=$PIECE($GET(^PS(52.49,ERXIEN,52)),"^")
+10 IF S2017
Begin DoDot:1
+11 IF MSGTYPE="CX"
SET MEDIEN=$ORDER(^PS(52.49,ERXIEN,311,"C","P",0))
+12 IF MSGTYPE="RE"
IF (RESTYPE="R")
SET MEDIEN=$ORDER(^PS(52.49,ERXIEN,311,"C","MR",0))
+13 IF MSGTYPE="N"!'$GET(MEDIEN)
SET MEDIEN=$ORDER(^PS(52.49,ERXIEN,311,0))
+14 IF '$GET(MEDIEN)
QUIT
+15 FOR I=1:1
if '$DATA(^PS(52.49,ERXIEN,311,MEDIEN,8,I))
QUIT
Begin DoDot:2
+16 SET ERXSIG=ERXSIG_$GET(^PS(52.49,ERXIEN,311,MEDIEN,8,I,0))_" "
End DoDot:2
+17 SET $EXTRACT(ERXSIG,$LENGTH(ERXSIG))=""
End DoDot:1
+18 IF 'S2017
Begin DoDot:1
+19 SET ERXSIG=$PIECE($GET(^PS(52.49,ERXIEN,7)),"^")
End DoDot:1
+20 QUIT ERXSIG
+21 ;
VISTASIG(ERXIEN) ; Returns the VistA SIG, if present
+1 ; Input: (r) ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49)
+2 ;Output: VISTASIG - VistA SIG in one string
+3 ;
+4 NEW VISTASIG,SIG
+5 SET VISTASIG=""
+6 SET SIG=0
FOR
SET SIG=$ORDER(^PS(52.49,ERXIEN,"SIG",SIG))
if 'SIG
QUIT
Begin DoDot:1
+7 SET VISTASIG=VISTASIG_$GET(^PS(52.49,ERXIEN,"SIG",SIG,0))
End DoDot:1
+8 ; VA Patient Instructions
+9 IF $$GET1^DIQ(52.49,ERXIEN,27)'=""
Begin DoDot:1
+10 SET VISTASIG=VISTASIG_$SELECT($EXTRACT(VISTASIG,$LENGTH(VISTASIG))=" ":"",1:" ")_$$GET1^DIQ(52.49,ERXIEN,27)
End DoDot:1
+11 QUIT VISTASIG
+12 ;
RENEWALS(ERXIEN) ; Returns whether Renewals are Prohibited or no
+1 ; Input: ERXIEN - Pointer to ERX HOLDING QUEUE File (#52.49)
+2 ;Output: RENEWALS - 1: Renewals are Allowed | 0 - Renewals are Prohibited
+3 NEW RENEWALS,MTYPE,CHGMESRQ,CHGMESRI,RESPVAL
+4 SET RENEWALS=0
SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+5 SET CHGMESRQ=$$GET1^DIQ(52.49,ERXIEN,315.1,"I")
+6 SET CHGMESRI=$$GET1^DIQ(52.45,CHGMESRQ,.01,"I")
+7 SET RESPVAL=$$GET1^DIQ(52.49,ERXIEN,52.1,"E")
+8 IF MTYPE="N"!((MTYPE="CX")&($$PROHIBIT^PSOERX1D(RESPVAL,CHGMESRI)))
Begin DoDot:1
+9 SET RENEWALS=$SELECT($$GET1^DIQ(52.49,ERXIEN,301.3,"I"):0,1:1)
End DoDot:1
+10 QUIT RENEWALS
+11 ;
SUFCHK(RESULT,ERXPRDEA,VADEADFL,ERXSUFF) ; Check for matching DEA, mismatched suffix
+1 ; PSO*7*743
IF ERXPRDEA'=""
IF ($LENGTH(VADEADFL)>8)
IF (ERXPRDEA'=VADEADFL)
IF ($PIECE(ERXPRDEA,"-")=$PIECE(VADEADFL,"-"))
IF '$GET(ERXSUFF)
Begin DoDot:1
+2 DO SUFFWARN^PSOERXUT(.RESULT,ERXPRDEA,$SELECT($LENGTH($GET(VADEADFL)>8):VADEADFL,1:VADEANUM),0)
+3 SET RESULT=$SELECT($GET(RESULT)="0^B":RESULT,1:"0^W")
End DoDot:1
+4 QUIT
