PSOERXU8 ;ALB/BLB - eRx Utilities/RPC's ; 08/18/2020 10:02am
;;7.0;OUTPATIENT PHARMACY;**581,617,700**;DEC 1997;Build 261
;
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,H,"[(","_$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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXU8 3912 printed Apr 09, 2024@21:35:46 Page 2
PSOERXU8 ;ALB/BLB - eRx Utilities/RPC's ; 08/18/2020 10:02am
+1 ;;7.0;OUTPATIENT PHARMACY;**581,617,700**;DEC 1997;Build 261
+2 ;
+3 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,H,"[(","_$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
