- 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 Jan 18, 2025@03:30:18 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