PSOERX1E ;ALB/JSG - eRx Utilities ; 11/27/2019 11:02am
;;7.0;OUTPATIENT PHARMACY;**581,700,746**;DEC 1997;Build 106
;
PHCHREQ(PSOIEN,RULE,LINE,PRTVIEW) ; Pharmacy Change Request Note
S PRTVIEW=+$G(PRTVIEW)
N I,NEWRXNOT,NOTEARY,PHCHRQNT,RELERX,RELHUB,REQIEN
S REQIEN=$S(RULE?1(1"1059",1"1060",1"1062".E):$$RESOLV^PSOERXU2(PSOIEN),1:PSOIEN) I '$G(REQIEN) Q
S RELHUB=$$GET1^DIQ(52.49,REQIEN,.14)
S RELERX=$O(^PS(52.49,"FMID",RELHUB,0))
S PHCHRQNT=$$GET1^DIQ(52.49,REQIEN,8,"I")
S NEWRXNOT=$$GET1^DIQ(52.49,RELERX,8,"I")
S:NEWRXNOT=PHCHRQNT PHCHRQNT=""
I 'PRTVIEW D
.S LINE=LINE+1 D SET^VALM10(LINE,"")
.S LINE=LINE+1 D SET^VALM10(LINE,"Pharmacy Change Request Note: ")
.I PHCHRQNT]"" D
..K NOTEARY
..D TXT2ARY^PSOERXD1(.NOTEARY,PHCHRQNT," ",80)
..S I=0 F S I=$O(NOTEARY(I)) Q:'I D
...S LINE=LINE+1 D SET^VALM10(LINE,NOTEARY(I)),CNTRL^VALM10(LINE,1,80,IOINHI,IOINORM)
.I PHCHRQNT="" D
..S LINE=LINE+1 D SET^VALM10(LINE,PHCHRQNT)
I PRTVIEW D
.W !!,"Pharmacy Change Request Note: "
.W !,PHCHRQNT
Q
;
AUTOHOLD(TYPE,ERXIEN,VPATIEN,EPATIEN) ; Checks whether the VistA Patient has an Allergy Assessment or is Eligibile for
; ChampVA Rx Benefit, if not, put all eRx's on Hold (HAL or HEL) - Used by MbM only
;Input: r TYPE - Type of Hold: "A": Allergy | "E": Eligibility
; r ERXIEN - Poiter to the ERX HOLDING QUEUE file (#52.49)
; r VPATIEN - Poiter to the VISTA PATIENT file (#2)
; o EPATIEN - Poiter to the ERX PATIENT file (#42.56)
;
N RECDATE,OERXIEN,HAHLDCOD,ERXLST,HDR,XX,CNT,DIR,PSOIEN
I '$G(EPATIEN) S EPATIEN=$$GET1^DIQ(52.49,ERXIEN,.04,"I") I 'EPATIEN Q
S HAHLDCOD=$O(^PS(52.45,"B",$S(TYPE="A":"HAL",1:"HEL"),0)) I 'HAHLDCOD Q
S RECDATE=0 F S RECDATE=$O(^PS(52.49,"PAT2",EPATIEN,RECDATE)) Q:'RECDATE D
. S OERXIEN=0 F S OERXIEN=$O(^PS(52.49,"PAT2",EPATIEN,RECDATE,OERXIEN)) Q:'OERXIEN D
. . I $G(ERXIEN)=OERXIEN Q
. . S ERXSTS=$$GET1^DIQ(52.49,OERXIEN,1,"E")
. . I ",N,I,W,RXI,RXN,RXW,RXR,CXI,CXN,CXW,"'[(","_ERXSTS_",") Q
. . ; DO NOT FILL record
. . I $$GET1^DIQ(52.49,+$G(OERXIEN),10.5,"I")=2 Q
. . ; eRx/user not eligible for Hold
. . S PSOIEN=OERXIEN
. . I '$$OPACCESS^PSOERXU7("PSO ERX HOLD",DUZ,OERXIEN) Q
. . I TYPE="A" D UPDSTAT^PSOERXU1(OERXIEN,"HAL","Hold for Allergy Assessment")
. . I TYPE="E" D UPDSTAT^PSOERXU1(OERXIEN,"HEL","Hold due to Eligibility Issue")
. . S ERXLST(OERXIEN)=""
. . ; Updating the VistA Patient for other eRx record for the same patient (if not already matched)
. . K FDA
. . I '$$GET1^DIQ(52.49,OERXIEN,.05,"I") S FDA(52.49,OERXIEN_",",.05)=VPATIEN
. . S FDA(52.49,OERXIEN_",",1.7)="",FDA(52.49,OERXIEN_",",1.13)="",FDA(52.49,OERXIEN_",",1.14)=""
. . D FILE^DIE(,"FDA") K FDA
;
I '$D(ERXLST) Q
;
W !!,"The following eRx record(s) have been put on Hold ("_$S(TYPE="A":"HAL",1:"HEL")_") because the VistA"
W !,"Patient ("_$$GET1^DIQ(2,VPATIEN,.01)_") "
W:TYPE="A" "does not have an Allergy Assessment."
W:TYPE="E" "is not Eligible for ChampVA Rx Benefit."
;
S HDR="ERX ID",$E(HDR,17)="DRUG NAME",$E(HDR,48)="PROVIDER",$E(HDR,77)="STS"
S $P(XX,"-",80)="" W !,HDR,!,XX
S (OERXIEN,CNT)=0 F S OERXIEN=$O(ERXLST(OERXIEN)) Q:'OERXIEN D
. W !,$$GET1^DIQ(52.49,OERXIEN,.01),?16,$E($S($$GETDRUG^PSOERXU5(OERXIEN)'="":$$GETDRUG^PSOERXU5(OERXIEN),1:"N/A"),1,30)
. W ?47,$E($$GET1^DIQ(52.49,OERXIEN,2.1),1,23)
. W ?76,$$GET1^DIQ(52.49,OERXIEN,1)
. S CNT=CNT+1 I '(CNT#18),$O(ERXLST(OERXIEN)) K DIR D PAUSE^VALM1 W !,HDR,!,XX
;
K DIR D PAUSE^VALM1
Q
;
DUPVPAT(DFN,LIST) ; Checks whether a VistA Patient has potential duplicate records
; Input: DFN - Pointer to the PATIENT file (#2)
;Output: LIST - List of duplicate patient(s), Defined if any OR Undefined ('$D)
;
N FULLNAME,FLFN,LASTNAME,DOB,OPATNAME,DUPPAT
K LIST S FULLNAME=$$GET1^DIQ(2,DFN,.01),FLFN=$E($P(FULLNAME,",",2))
S LASTNAME=$P(FULLNAME,",") I LASTNAME="" Q
S DOB=$$GET1^DIQ(2,DFN,.03,"I")
;
S OPATNAME=LASTNAME
F S OPATNAME=$O(^DPT("B",OPATNAME)) Q:($P(OPATNAME,",")'=LASTNAME) D
. S DUPPAT=0 F S DUPPAT=$O(^DPT("B",OPATNAME,DUPPAT)) Q:'DUPPAT D
. . I DUPPAT=DFN Q
. . I $$DEAD^PSONVARP(DUPPAT) Q
. . ; If full names matches OR last names + First Letter of first names + Dates of Birth matches, then it's a match
. . I OPATNAME=FULLNAME!($E($P(OPATNAME,",",2))=FLFN&($$GET1^DIQ(2,DUPPAT,.03,"I")=DOB)) D
. . . S LIST(DUPPAT)=OPATNAME_" "_$$GET1^DIQ(2,DUPPAT,.03)_" "_$$GET1^DIQ(2,DUPPAT,.09)
. . . S LIST(DUPPAT)=LIST(DUPPAT)_" "_$$GET1^DIQ(2,DUPPAT,.114)_","_$$STATEABB^PSOERUT(2,DUPPAT)
Q
;
CXRES ;
N CODEIEN,COMM,COMMARY,COMMBY,COMMDTTM,DATE,DELTA,DRCVGST,ERESCODE,ERXDAT,FLG,FN,I
N ID,IENS,IENS2,J,MIEN,MTYPE,NOTE,NOTEARY,PRIAUTH,PRAUTHST,RECODE,REQIEN,RESCODE
N RESDESC,RESDTTM,RESIEN,RESTEXT,RESVAL,SFIEN,STATUS,STR1,STR1ARY,STR2,STR2ARY
N TXT,XLINE
I (","_RULES_",")[(","_$E(RULE,1,4)_",") D
.S RESIEN=ERXIEN,REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
.S FLG=1
I (","_RULES_",")'[(","_$E(RULE,1,4)_",") D
.S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
.I MTYPE="CR" D Q
..S RESIEN=$$GETRESP^PSOERXU2(ERXIEN)
..I RESIEN D Q
...S REQIEN=ERXIEN
...S FLG=1
..S FLG=0
.S FLG=0
Q:'FLG
S IENS=RESIEN_","
D GETS^DIQ(52.49,RESIEN,".03;50;50.1;50.2;52.1;52.2;319.5;324","IE","ERXDAT")
S RESDTTM=$G(ERXDAT(52.49,IENS,.03,"E"))
S RESVAL=$G(ERXDAT(52.49,IENS,52.1,"E"))
S RESCODE=$G(ERXDAT(52.49,IENS,52.1,"I"))
S NOTE=$G(ERXDAT(52.49,IENS,52.2,"E"))
S ID=$G(ERXDAT(52.49,IENS,319.5,"E"))
S DATE=$G(ERXDAT(52.49,IENS,324,"I"))
I $D(^PS(52.49,ERXIEN,311)) D
.S SFIEN=$O(^PS(52.49,ERXIEN,311,"C","P",0))
.Q:'SFIEN
.S IENS2=SFIEN_","_IENS
.D GETS^DIQ(52.49311,IENS2,"4.1;4.2;5","IE","ERXDAT")
.S PRIAUTH=$G(ERXDAT(52.49311,IENS2,4.1,"E"))
.S PRAUTHST=$G(ERXDAT(52.49311,IENS2,4.2,"E"))
.S I=$O(^PS(52.49,RESIEN,311,SFIEN,7,0))
.I I D
..S DRCVGST=$$GET1^DIQ(52.493117,I_","_IENS2,.02,"I")
..S DRCVGST=$$GET1^DIQ(52.45,DRCVGST,.02,"E")
.I 'I S DRCVGST=""
.F I="PRIAUTH","PRAUTHST","DRCVGST" S:@I="" @I=" "
I '$D(^PS(52.49,ERXIEN,311)) D
.S (PRIAUTH,PRAUTHST,DRCVGST)=" "
S LINE=LINE+1
I $G(SDERXFLG) D
.D SET^VALM10(LINE," RXCHANGE RESPONSE INFORMATION "),CNTRL^VALM10(LINE,1,80,IOUON_IOINHI,IOUOFF_IOINORM)
E D
.D SET^VALM10(LINE,"")
.S LINE=LINE+1 D SET^VALM10(LINE,"*************************RXCHANGE RESPONSE INFORMATION**************************")
S LINE=LINE+1 D SET^VALM10(LINE,RESVAL),CNTRL^VALM10(LINE,1,$L(RESVAL),IORVON,IORVOFF)
D SET^PSOERX1D(.LINE,"Response Date/Time: ",RESDTTM),CNTRL^VALM10(LINE,21,$L(RESDTTM),IOINHI,IOINORM)
I NOTE]"" D
.K NOTEARY
.D TXT2ARY^PSOERXD1(.NOTEARY,NOTE," ",74)
.S I=0 F S I=$O(NOTEARY(I)) Q:'I D
..S LINE=LINE+1 D SET^VALM10(LINE,$S(I=1:"Note: ",1:$J("",6))_NOTEARY(I)),CNTRL^VALM10(LINE,6,$L(NOTEARY(I))+1,IOINHI,IOINORM)
I '$G(SDERXFLG) S LINE=LINE+1 D SET^VALM10(LINE,"")
I ((RULE=1059)&(RESPVAL="APPROVED"))!(RULE?1"1062PA".E) D
.S XLINE=LINE
.D SET^PSOERX1D(.LINE,"Prior Authorization: ",PRIAUTH),CNTRL^VALM10(.LINE,22,$L(PRIAUTH),IOINHI,IOINORM)
.D SET^PSOERX1D(.LINE,"Prior Authorization Status: ",PRAUTHST),CNTRL^VALM10(.LINE,29,$L(PRAUTHST),IOINHI,IOINORM)
.K NOTEARY D TXT2ARY^PSOERXD1(.NOTEARY,DRCVGST," ",58)
.I $D(NOTEARY) D
..S I=0 F S I=$O(NOTEARY(I)) Q:'I D
...S TXT=$S(I=1:"Drug Coverage Status: ",1:$J("",22))_NOTEARY(I)
...S LINE=LINE+1 D SET^VALM10(LINE,TXT),CNTRL^VALM10(LINE,22,$L(NOTEARY(I)),IOINHI,IOINORM)
.I '$D(NOTEARY) S LINE=LINE+1 D SET^VALM10(LINE,"Drug Coverage Status:")
.I LINE>XLINE S LINE=LINE+1 D SET^VALM10(LINE,"")
I ((RULE=1060)&(RESPVAL="VALIDATED"))!(RULE?1"1062UV".E) D
.S XLINE=LINE
.D SET^PSOERX1D(.LINE,"ID: ",ID),CNTRL^VALM10(LINE,5,$L(ID),IOINHI,IOINORM)
.D SET^PSOERX1D(.LINE,"Date: ",DATE),CNTRL^VALM10(LINE,6,$L(DATE),IOINHI,IOINORM)
.I LINE>XLINE S LINE=LINE+1 D SET^VALM10(LINE,"")
S COMM=$$GET1^DIQ(52.49,RESIEN,50,"E")
K COMMARY D TXT2ARY^PSOERXD1(.COMMARY,COMM," ",52)
I $D(COMMARY) D
.S I=0 F S I=$O(COMMARY(I)) Q:'I D
..S TXT=$S(I=1:"RxChange Response Comments: ",1:$J("",28))_COMMARY(I)
..S LINE=LINE+1 D SET^VALM10(LINE,TXT),CNTRL^VALM10(LINE,28,$L(COMMARY(I)),IOINHI,IOINORM)
I '$D(COMMARY) D
.S LINE=LINE+1 D SET^VALM10(LINE,"RxChange Response Comments:")
S COMMBY=$$GET1^DIQ(52.49,RESIEN,50.1,"E")
S COMMDTTM=$$GET1^DIQ(52.49,RESIEN,50.2,"E")
S LINE=LINE+1 D SET^VALM10(LINE,"Comments By: "_COMMBY),CNTRL^VALM10(LINE,13,$L(COMMBY),IOINHI,IOINORM)
S LINE=LINE+1 D SET^VALM10(LINE,"Comments Date/Time: "_COMMDTTM),CNTRL^VALM10(LINE,20,$L(COMMDTTM),IOINHI,IOINORM)
S LINE=LINE+1 D SET^VALM10(LINE,"") S XLINE=LINE
S I=0 F S I=$O(^PS(52.49,RESIEN,55,I)) Q:'I D
.S ERESCODE=$$GET1^DIQ(52.4955,I_","_IENS,.01,"E")
.S CODEIEN=$$GET1^DIQ(52.4955,I_","_IENS,.01,"I")
.S RESDESC=$$GET1^DIQ(52.45,CODEIEN,.02,"E")
.D
..S FLG=0
..I RULE=1058 S FLG=1 Q
..I RULE=1059,RESPVAL="DENIED" S FLG=1 Q
..I RULE=1060 S FLG=1 Q
..I RULE=1061 S FLG=1 Q
..I RULE?1"1062"1(1"PD",1"U").E S FLG=1
.I FLG D
..S RESTEXT=RESVAL_" reason code: "_ERESCODE
..S LINE=LINE+1 D SET^VALM10(LINE,RESTEXT),CNTRL^VALM10(LINE,1,$L(RESTEXT),IORVON,IORVOFF)
..D SET^PSOERX1D(.LINE,"Code Description: ",RESDESC),CNTRL^VALM10(LINE,1,$L(RESDESC),IORVON,IORVOFF)
I XLINE<LINE S LINE=LINE+1 D SET^VALM10(LINE,"")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERX1E 9452 printed Dec 13, 2024@02:28:15 Page 2
PSOERX1E ;ALB/JSG - eRx Utilities ; 11/27/2019 11:02am
+1 ;;7.0;OUTPATIENT PHARMACY;**581,700,746**;DEC 1997;Build 106
+2 ;
PHCHREQ(PSOIEN,RULE,LINE,PRTVIEW) ; Pharmacy Change Request Note
+1 SET PRTVIEW=+$GET(PRTVIEW)
+2 NEW I,NEWRXNOT,NOTEARY,PHCHRQNT,RELERX,RELHUB,REQIEN
+3 SET REQIEN=$SELECT(RULE?1(1"1059",1"1060",1"1062".E):$$RESOLV^PSOERXU2(PSOIEN),1:PSOIEN)
IF '$GET(REQIEN)
QUIT
+4 SET RELHUB=$$GET1^DIQ(52.49,REQIEN,.14)
+5 SET RELERX=$ORDER(^PS(52.49,"FMID",RELHUB,0))
+6 SET PHCHRQNT=$$GET1^DIQ(52.49,REQIEN,8,"I")
+7 SET NEWRXNOT=$$GET1^DIQ(52.49,RELERX,8,"I")
+8 if NEWRXNOT=PHCHRQNT
SET PHCHRQNT=""
+9 IF 'PRTVIEW
Begin DoDot:1
+10 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+11 SET LINE=LINE+1
DO SET^VALM10(LINE,"Pharmacy Change Request Note: ")
+12 IF PHCHRQNT]""
Begin DoDot:2
+13 KILL NOTEARY
+14 DO TXT2ARY^PSOERXD1(.NOTEARY,PHCHRQNT," ",80)
+15 SET I=0
FOR
SET I=$ORDER(NOTEARY(I))
if 'I
QUIT
Begin DoDot:3
+16 SET LINE=LINE+1
DO SET^VALM10(LINE,NOTEARY(I))
DO CNTRL^VALM10(LINE,1,80,IOINHI,IOINORM)
End DoDot:3
End DoDot:2
+17 IF PHCHRQNT=""
Begin DoDot:2
+18 SET LINE=LINE+1
DO SET^VALM10(LINE,PHCHRQNT)
End DoDot:2
End DoDot:1
+19 IF PRTVIEW
Begin DoDot:1
+20 WRITE !!,"Pharmacy Change Request Note: "
+21 WRITE !,PHCHRQNT
End DoDot:1
+22 QUIT
+23 ;
AUTOHOLD(TYPE,ERXIEN,VPATIEN,EPATIEN) ; Checks whether the VistA Patient has an Allergy Assessment or is Eligibile for
+1 ; ChampVA Rx Benefit, if not, put all eRx's on Hold (HAL or HEL) - Used by MbM only
+2 ;Input: r TYPE - Type of Hold: "A": Allergy | "E": Eligibility
+3 ; r ERXIEN - Poiter to the ERX HOLDING QUEUE file (#52.49)
+4 ; r VPATIEN - Poiter to the VISTA PATIENT file (#2)
+5 ; o EPATIEN - Poiter to the ERX PATIENT file (#42.56)
+6 ;
+7 NEW RECDATE,OERXIEN,HAHLDCOD,ERXLST,HDR,XX,CNT,DIR,PSOIEN
+8 IF '$GET(EPATIEN)
SET EPATIEN=$$GET1^DIQ(52.49,ERXIEN,.04,"I")
IF 'EPATIEN
QUIT
+9 SET HAHLDCOD=$ORDER(^PS(52.45,"B",$SELECT(TYPE="A":"HAL",1:"HEL"),0))
IF 'HAHLDCOD
QUIT
+10 SET RECDATE=0
FOR
SET RECDATE=$ORDER(^PS(52.49,"PAT2",EPATIEN,RECDATE))
if 'RECDATE
QUIT
Begin DoDot:1
+11 SET OERXIEN=0
FOR
SET OERXIEN=$ORDER(^PS(52.49,"PAT2",EPATIEN,RECDATE,OERXIEN))
if 'OERXIEN
QUIT
Begin DoDot:2
+12 IF $GET(ERXIEN)=OERXIEN
QUIT
+13 SET ERXSTS=$$GET1^DIQ(52.49,OERXIEN,1,"E")
+14 IF ",N,I,W,RXI,RXN,RXW,RXR,CXI,CXN,CXW,"'[(","_ERXSTS_",")
QUIT
+15 ; DO NOT FILL record
+16 IF $$GET1^DIQ(52.49,+$GET(OERXIEN),10.5,"I")=2
QUIT
+17 ; eRx/user not eligible for Hold
+18 SET PSOIEN=OERXIEN
+19 IF '$$OPACCESS^PSOERXU7("PSO ERX HOLD",DUZ,OERXIEN)
QUIT
+20 IF TYPE="A"
DO UPDSTAT^PSOERXU1(OERXIEN,"HAL","Hold for Allergy Assessment")
+21 IF TYPE="E"
DO UPDSTAT^PSOERXU1(OERXIEN,"HEL","Hold due to Eligibility Issue")
+22 SET ERXLST(OERXIEN)=""
+23 ; Updating the VistA Patient for other eRx record for the same patient (if not already matched)
+24 KILL FDA
+25 IF '$$GET1^DIQ(52.49,OERXIEN,.05,"I")
SET FDA(52.49,OERXIEN_",",.05)=VPATIEN
+26 SET FDA(52.49,OERXIEN_",",1.7)=""
SET FDA(52.49,OERXIEN_",",1.13)=""
SET FDA(52.49,OERXIEN_",",1.14)=""
+27 DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:2
End DoDot:1
+28 ;
+29 IF '$DATA(ERXLST)
QUIT
+30 ;
+31 WRITE !!,"The following eRx record(s) have been put on Hold ("_$SELECT(TYPE="A":"HAL",1:"HEL")_") because the VistA"
+32 WRITE !,"Patient ("_$$GET1^DIQ(2,VPATIEN,.01)_") "
+33 if TYPE="A"
WRITE "does not have an Allergy Assessment."
+34 if TYPE="E"
WRITE "is not Eligible for ChampVA Rx Benefit."
+35 ;
+36 SET HDR="ERX ID"
SET $EXTRACT(HDR,17)="DRUG NAME"
SET $EXTRACT(HDR,48)="PROVIDER"
SET $EXTRACT(HDR,77)="STS"
+37 SET $PIECE(XX,"-",80)=""
WRITE !,HDR,!,XX
+38 SET (OERXIEN,CNT)=0
FOR
SET OERXIEN=$ORDER(ERXLST(OERXIEN))
if 'OERXIEN
QUIT
Begin DoDot:1
+39 WRITE !,$$GET1^DIQ(52.49,OERXIEN,.01),?16,$EXTRACT($SELECT($$GETDRUG^PSOERXU5(OERXIEN)'="":$$GETDRUG^PSOERXU5(OERXIEN),1:"N/A"),1,30)
+40 WRITE ?47,$EXTRACT($$GET1^DIQ(52.49,OERXIEN,2.1),1,23)
+41 WRITE ?76,$$GET1^DIQ(52.49,OERXIEN,1)
+42 SET CNT=CNT+1
IF '(CNT#18)
IF $ORDER(ERXLST(OERXIEN))
KILL DIR
DO PAUSE^VALM1
WRITE !,HDR,!,XX
End DoDot:1
+43 ;
+44 KILL DIR
DO PAUSE^VALM1
+45 QUIT
+46 ;
DUPVPAT(DFN,LIST) ; Checks whether a VistA Patient has potential duplicate records
+1 ; Input: DFN - Pointer to the PATIENT file (#2)
+2 ;Output: LIST - List of duplicate patient(s), Defined if any OR Undefined ('$D)
+3 ;
+4 NEW FULLNAME,FLFN,LASTNAME,DOB,OPATNAME,DUPPAT
+5 KILL LIST
SET FULLNAME=$$GET1^DIQ(2,DFN,.01)
SET FLFN=$EXTRACT($PIECE(FULLNAME,",",2))
+6 SET LASTNAME=$PIECE(FULLNAME,",")
IF LASTNAME=""
QUIT
+7 SET DOB=$$GET1^DIQ(2,DFN,.03,"I")
+8 ;
+9 SET OPATNAME=LASTNAME
+10 FOR
SET OPATNAME=$ORDER(^DPT("B",OPATNAME))
if ($PIECE(OPATNAME,",")'=LASTNAME)
QUIT
Begin DoDot:1
+11 SET DUPPAT=0
FOR
SET DUPPAT=$ORDER(^DPT("B",OPATNAME,DUPPAT))
if 'DUPPAT
QUIT
Begin DoDot:2
+12 IF DUPPAT=DFN
QUIT
+13 IF $$DEAD^PSONVARP(DUPPAT)
QUIT
+14 ; If full names matches OR last names + First Letter of first names + Dates of Birth matches, then it's a match
+15 IF OPATNAME=FULLNAME!($EXTRACT($PIECE(OPATNAME,",",2))=FLFN&($$GET1^DIQ(2,DUPPAT,.03,"I")=DOB))
Begin DoDot:3
+16 SET LIST(DUPPAT)=OPATNAME_" "_$$GET1^DIQ(2,DUPPAT,.03)_" "_$$GET1^DIQ(2,DUPPAT,.09)
+17 SET LIST(DUPPAT)=LIST(DUPPAT)_" "_$$GET1^DIQ(2,DUPPAT,.114)_","_$$STATEABB^PSOERUT(2,DUPPAT)
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
CXRES ;
+1 NEW CODEIEN,COMM,COMMARY,COMMBY,COMMDTTM,DATE,DELTA,DRCVGST,ERESCODE,ERXDAT,FLG,FN,I
+2 NEW ID,IENS,IENS2,J,MIEN,MTYPE,NOTE,NOTEARY,PRIAUTH,PRAUTHST,RECODE,REQIEN,RESCODE
+3 NEW RESDESC,RESDTTM,RESIEN,RESTEXT,RESVAL,SFIEN,STATUS,STR1,STR1ARY,STR2,STR2ARY
+4 NEW TXT,XLINE
+5 IF (","_RULES_",")[(","_$EXTRACT(RULE,1,4)_",")
Begin DoDot:1
+6 SET RESIEN=ERXIEN
SET REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
+7 SET FLG=1
End DoDot:1
+8 IF (","_RULES_",")'[(","_$EXTRACT(RULE,1,4)_",")
Begin DoDot:1
+9 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+10 IF MTYPE="CR"
Begin DoDot:2
+11 SET RESIEN=$$GETRESP^PSOERXU2(ERXIEN)
+12 IF RESIEN
Begin DoDot:3
+13 SET REQIEN=ERXIEN
+14 SET FLG=1
End DoDot:3
QUIT
+15 SET FLG=0
End DoDot:2
QUIT
+16 SET FLG=0
End DoDot:1
+17 if 'FLG
QUIT
+18 SET IENS=RESIEN_","
+19 DO GETS^DIQ(52.49,RESIEN,".03;50;50.1;50.2;52.1;52.2;319.5;324","IE","ERXDAT")
+20 SET RESDTTM=$GET(ERXDAT(52.49,IENS,.03,"E"))
+21 SET RESVAL=$GET(ERXDAT(52.49,IENS,52.1,"E"))
+22 SET RESCODE=$GET(ERXDAT(52.49,IENS,52.1,"I"))
+23 SET NOTE=$GET(ERXDAT(52.49,IENS,52.2,"E"))
+24 SET ID=$GET(ERXDAT(52.49,IENS,319.5,"E"))
+25 SET DATE=$GET(ERXDAT(52.49,IENS,324,"I"))
+26 IF $DATA(^PS(52.49,ERXIEN,311))
Begin DoDot:1
+27 SET SFIEN=$ORDER(^PS(52.49,ERXIEN,311,"C","P",0))
+28 if 'SFIEN
QUIT
+29 SET IENS2=SFIEN_","_IENS
+30 DO GETS^DIQ(52.49311,IENS2,"4.1;4.2;5","IE","ERXDAT")
+31 SET PRIAUTH=$GET(ERXDAT(52.49311,IENS2,4.1,"E"))
+32 SET PRAUTHST=$GET(ERXDAT(52.49311,IENS2,4.2,"E"))
+33 SET I=$ORDER(^PS(52.49,RESIEN,311,SFIEN,7,0))
+34 IF I
Begin DoDot:2
+35 SET DRCVGST=$$GET1^DIQ(52.493117,I_","_IENS2,.02,"I")
+36 SET DRCVGST=$$GET1^DIQ(52.45,DRCVGST,.02,"E")
End DoDot:2
+37 IF 'I
SET DRCVGST=""
+38 FOR I="PRIAUTH","PRAUTHST","DRCVGST"
if @I=""
SET @I=" "
End DoDot:1
+39 IF '$DATA(^PS(52.49,ERXIEN,311))
Begin DoDot:1
+40 SET (PRIAUTH,PRAUTHST,DRCVGST)=" "
End DoDot:1
+41 SET LINE=LINE+1
+42 IF $GET(SDERXFLG)
Begin DoDot:1
+43 DO SET^VALM10(LINE," RXCHANGE RESPONSE INFORMATION ")
DO CNTRL^VALM10(LINE,1,80,IOUON_IOINHI,IOUOFF_IOINORM)
End DoDot:1
+44 IF '$TEST
Begin DoDot:1
+45 DO SET^VALM10(LINE,"")
+46 SET LINE=LINE+1
DO SET^VALM10(LINE,"*************************RXCHANGE RESPONSE INFORMATION**************************")
End DoDot:1
+47 SET LINE=LINE+1
DO SET^VALM10(LINE,RESVAL)
DO CNTRL^VALM10(LINE,1,$LENGTH(RESVAL),IORVON,IORVOFF)
+48 DO SET^PSOERX1D(.LINE,"Response Date/Time: ",RESDTTM)
DO CNTRL^VALM10(LINE,21,$LENGTH(RESDTTM),IOINHI,IOINORM)
+49 IF NOTE]""
Begin DoDot:1
+50 KILL NOTEARY
+51 DO TXT2ARY^PSOERXD1(.NOTEARY,NOTE," ",74)
+52 SET I=0
FOR
SET I=$ORDER(NOTEARY(I))
if 'I
QUIT
Begin DoDot:2
+53 SET LINE=LINE+1
DO SET^VALM10(LINE,$SELECT(I=1:"Note: ",1:$JUSTIFY("",6))_NOTEARY(I))
DO CNTRL^VALM10(LINE,6,$LENGTH(NOTEARY(I))+1,IOINHI,IOINORM)
End DoDot:2
End DoDot:1
+54 IF '$GET(SDERXFLG)
SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+55 IF ((RULE=1059)&(RESPVAL="APPROVED"))!(RULE?1"1062PA".E)
Begin DoDot:1
+56 SET XLINE=LINE
+57 DO SET^PSOERX1D(.LINE,"Prior Authorization: ",PRIAUTH)
DO CNTRL^VALM10(.LINE,22,$LENGTH(PRIAUTH),IOINHI,IOINORM)
+58 DO SET^PSOERX1D(.LINE,"Prior Authorization Status: ",PRAUTHST)
DO CNTRL^VALM10(.LINE,29,$LENGTH(PRAUTHST),IOINHI,IOINORM)
+59 KILL NOTEARY
DO TXT2ARY^PSOERXD1(.NOTEARY,DRCVGST," ",58)
+60 IF $DATA(NOTEARY)
Begin DoDot:2
+61 SET I=0
FOR
SET I=$ORDER(NOTEARY(I))
if 'I
QUIT
Begin DoDot:3
+62 SET TXT=$SELECT(I=1:"Drug Coverage Status: ",1:$JUSTIFY("",22))_NOTEARY(I)
+63 SET LINE=LINE+1
DO SET^VALM10(LINE,TXT)
DO CNTRL^VALM10(LINE,22,$LENGTH(NOTEARY(I)),IOINHI,IOINORM)
End DoDot:3
End DoDot:2
+64 IF '$DATA(NOTEARY)
SET LINE=LINE+1
DO SET^VALM10(LINE,"Drug Coverage Status:")
+65 IF LINE>XLINE
SET LINE=LINE+1
DO SET^VALM10(LINE,"")
End DoDot:1
+66 IF ((RULE=1060)&(RESPVAL="VALIDATED"))!(RULE?1"1062UV".E)
Begin DoDot:1
+67 SET XLINE=LINE
+68 DO SET^PSOERX1D(.LINE,"ID: ",ID)
DO CNTRL^VALM10(LINE,5,$LENGTH(ID),IOINHI,IOINORM)
+69 DO SET^PSOERX1D(.LINE,"Date: ",DATE)
DO CNTRL^VALM10(LINE,6,$LENGTH(DATE),IOINHI,IOINORM)
+70 IF LINE>XLINE
SET LINE=LINE+1
DO SET^VALM10(LINE,"")
End DoDot:1
+71 SET COMM=$$GET1^DIQ(52.49,RESIEN,50,"E")
+72 KILL COMMARY
DO TXT2ARY^PSOERXD1(.COMMARY,COMM," ",52)
+73 IF $DATA(COMMARY)
Begin DoDot:1
+74 SET I=0
FOR
SET I=$ORDER(COMMARY(I))
if 'I
QUIT
Begin DoDot:2
+75 SET TXT=$SELECT(I=1:"RxChange Response Comments: ",1:$JUSTIFY("",28))_COMMARY(I)
+76 SET LINE=LINE+1
DO SET^VALM10(LINE,TXT)
DO CNTRL^VALM10(LINE,28,$LENGTH(COMMARY(I)),IOINHI,IOINORM)
End DoDot:2
End DoDot:1
+77 IF '$DATA(COMMARY)
Begin DoDot:1
+78 SET LINE=LINE+1
DO SET^VALM10(LINE,"RxChange Response Comments:")
End DoDot:1
+79 SET COMMBY=$$GET1^DIQ(52.49,RESIEN,50.1,"E")
+80 SET COMMDTTM=$$GET1^DIQ(52.49,RESIEN,50.2,"E")
+81 SET LINE=LINE+1
DO SET^VALM10(LINE,"Comments By: "_COMMBY)
DO CNTRL^VALM10(LINE,13,$LENGTH(COMMBY),IOINHI,IOINORM)
+82 SET LINE=LINE+1
DO SET^VALM10(LINE,"Comments Date/Time: "_COMMDTTM)
DO CNTRL^VALM10(LINE,20,$LENGTH(COMMDTTM),IOINHI,IOINORM)
+83 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
SET XLINE=LINE
+84 SET I=0
FOR
SET I=$ORDER(^PS(52.49,RESIEN,55,I))
if 'I
QUIT
Begin DoDot:1
+85 SET ERESCODE=$$GET1^DIQ(52.4955,I_","_IENS,.01,"E")
+86 SET CODEIEN=$$GET1^DIQ(52.4955,I_","_IENS,.01,"I")
+87 SET RESDESC=$$GET1^DIQ(52.45,CODEIEN,.02,"E")
+88 Begin DoDot:2
+89 SET FLG=0
+90 IF RULE=1058
SET FLG=1
QUIT
+91 IF RULE=1059
IF RESPVAL="DENIED"
SET FLG=1
QUIT
+92 IF RULE=1060
SET FLG=1
QUIT
+93 IF RULE=1061
SET FLG=1
QUIT
+94 IF RULE?1"1062"1(1"PD",1"U").E
SET FLG=1
End DoDot:2
+95 IF FLG
Begin DoDot:2
+96 SET RESTEXT=RESVAL_" reason code: "_ERESCODE
+97 SET LINE=LINE+1
DO SET^VALM10(LINE,RESTEXT)
DO CNTRL^VALM10(LINE,1,$LENGTH(RESTEXT),IORVON,IORVOFF)
+98 DO SET^PSOERX1D(.LINE,"Code Description: ",RESDESC)
DO CNTRL^VALM10(LINE,1,$LENGTH(RESDESC),IORVON,IORVOFF)
End DoDot:2
End DoDot:1
+99 IF XLINE<LINE
SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+100 QUIT
+101 ;
