PSOERX1E ;ALB/JSG - eRx Utilities ; 11/27/2019 11:02am
;;7.0;OUTPATIENT PHARMACY;**581,700**;DEC 1997;Build 261
;
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)
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))
.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 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)
. . I $$GET1^DIQ(52.49,OERXIEN,.05,"I") Q
. . K FDA
. . 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERX1E 4574 printed Apr 09, 2024@21:38:12 Page 2
PSOERX1E ;ALB/JSG - eRx Utilities ; 11/27/2019 11:02am
+1 ;;7.0;OUTPATIENT PHARMACY;**581,700**;DEC 1997;Build 261
+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)
+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))
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
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 IF $$GET1^DIQ(52.49,OERXIEN,.05,"I")
QUIT
+25 KILL FDA
+26 SET FDA(52.49,OERXIEN_",",.05)=VPATIEN
+27 SET FDA(52.49,OERXIEN_",",1.7)=""
SET FDA(52.49,OERXIEN_",",1.13)=""
SET FDA(52.49,OERXIEN_",",1.14)=""
+28 DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:2
End DoDot:1
+29 ;
+30 IF '$DATA(ERXLST)
QUIT
+31 ;
+32 WRITE !!,"The following eRx record(s) have been put on Hold ("_$SELECT(TYPE="A":"HAL",1:"HEL")_") because the VistA"
+33 WRITE !,"Patient ("_$$GET1^DIQ(2,VPATIEN,.01)_") "
+34 if TYPE="A"
WRITE "does not have an Allergy Assessment."
+35 if TYPE="E"
WRITE "is not Eligible for ChampVA Rx Benefit."
+36 ;
+37 SET HDR="ERX ID"
SET $EXTRACT(HDR,17)="DRUG NAME"
SET $EXTRACT(HDR,48)="PROVIDER"
SET $EXTRACT(HDR,77)="STS"
+38 SET $PIECE(XX,"-",80)=""
WRITE !,HDR,!,XX
+39 SET (OERXIEN,CNT)=0
FOR
SET OERXIEN=$ORDER(ERXLST(OERXIEN))
if 'OERXIEN
QUIT
Begin DoDot:1
+40 WRITE !,$$GET1^DIQ(52.49,OERXIEN,.01),?16,$EXTRACT($SELECT($$GETDRUG^PSOERXU5(OERXIEN)'="":$$GETDRUG^PSOERXU5(OERXIEN),1:"N/A"),1,30)
+41 WRITE ?47,$EXTRACT($$GET1^DIQ(52.49,OERXIEN,2.1),1,23)
+42 WRITE ?76,$$GET1^DIQ(52.49,OERXIEN,1)
+43 SET CNT=CNT+1
IF '(CNT#18)
IF $ORDER(ERXLST(OERXIEN))
KILL DIR
DO PAUSE^VALM1
WRITE !,HDR,!,XX
End DoDot:1
+44 ;
+45 KILL DIR
DO PAUSE^VALM1
+46 QUIT
+47 ;
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
