Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOERX1E

PSOERX1E.m

Go to the documentation of this file. 
  1. PSOERX1E ;ALB/JSG - eRx Utilities ; 11/27/2019 11:02am
  1.  ;;7.0;OUTPATIENT PHARMACY;**581,700,746**;DEC 1997;Build 106
  1.  ;
  1. PHCHREQ(PSOIEN,RULE,LINE,PRTVIEW) ; Pharmacy Change Request Note
  1.  S PRTVIEW=+$G(PRTVIEW)
  1.  N I,NEWRXNOT,NOTEARY,PHCHRQNT,RELERX,RELHUB,REQIEN
  1.  S REQIEN=$S(RULE?1(1"1059",1"1060",1"1062".E):$$RESOLV^PSOERXU2(PSOIEN),1:PSOIEN) I '$G(REQIEN) Q
  1.  S RELHUB=$$GET1^DIQ(52.49,REQIEN,.14)
  1.  S RELERX=$O(^PS(52.49,"FMID",RELHUB,0))
  1.  S PHCHRQNT=$$GET1^DIQ(52.49,REQIEN,8,"I")
  1.  S NEWRXNOT=$$GET1^DIQ(52.49,RELERX,8,"I")
  1.  S:NEWRXNOT=PHCHRQNT PHCHRQNT=""
  1.  I 'PRTVIEW D
  1.  .S LINE=LINE+1 D SET^VALM10(LINE,"")
  1.  .S LINE=LINE+1 D SET^VALM10(LINE,"Pharmacy Change Request Note: ")
  1.  .I PHCHRQNT]"" D
  1.  ..K NOTEARY
  1.  ..D TXT2ARY^PSOERXD1(.NOTEARY,PHCHRQNT," ",80)
  1.  ..S I=0 F  S I=$O(NOTEARY(I)) Q:'I  D
  1.  ...S LINE=LINE+1 D SET^VALM10(LINE,NOTEARY(I)),CNTRL^VALM10(LINE,1,80,IOINHI,IOINORM)
  1.  .I PHCHRQNT="" D
  1.  ..S LINE=LINE+1 D SET^VALM10(LINE,PHCHRQNT)
  1.  I PRTVIEW D
  1.  .W !!,"Pharmacy Change Request Note: "
  1.  .W !,PHCHRQNT
  1.  Q
  1.  ;
  1. 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
  1.  ;Input: r TYPE    - Type of Hold: "A": Allergy | "E": Eligibility
  1.  ;       r ERXIEN  - Poiter to the ERX HOLDING QUEUE file (#52.49)
  1.  ;       r VPATIEN - Poiter to the VISTA PATIENT file (#2)
  1.  ;       o EPATIEN - Poiter to the ERX PATIENT file (#42.56)
  1.  ;
  1.  N RECDATE,OERXIEN,HAHLDCOD,ERXLST,HDR,XX,CNT,DIR,PSOIEN
  1.  I '$G(EPATIEN) S EPATIEN=$$GET1^DIQ(52.49,ERXIEN,.04,"I") I 'EPATIEN Q
  1.  S HAHLDCOD=$O(^PS(52.45,"B",$S(TYPE="A":"HAL",1:"HEL"),0)) I 'HAHLDCOD Q
  1.  S RECDATE=0 F  S RECDATE=$O(^PS(52.49,"PAT2",EPATIEN,RECDATE)) Q:'RECDATE  D
  1.  . S OERXIEN=0 F  S OERXIEN=$O(^PS(52.49,"PAT2",EPATIEN,RECDATE,OERXIEN)) Q:'OERXIEN  D
  1.  . . I $G(ERXIEN)=OERXIEN Q
  1.  . . S ERXSTS=$$GET1^DIQ(52.49,OERXIEN,1,"E")
  1.  . . I ",N,I,W,RXI,RXN,RXW,RXR,CXI,CXN,CXW,"'[(","_ERXSTS_",") Q
  1.  . . ; DO NOT FILL record
  1.  . . I $$GET1^DIQ(52.49,+$G(OERXIEN),10.5,"I")=2 Q
  1.  . . ; eRx/user not eligible for Hold
  1.  . . S PSOIEN=OERXIEN
  1.  . . I '$$OPACCESS^PSOERXU7("PSO ERX HOLD",DUZ,OERXIEN) Q
  1.  . . I TYPE="A" D UPDSTAT^PSOERXU1(OERXIEN,"HAL","Hold for Allergy Assessment")
  1.  . . I TYPE="E" D UPDSTAT^PSOERXU1(OERXIEN,"HEL","Hold due to Eligibility Issue")
  1.  . . S ERXLST(OERXIEN)=""
  1.  . . ; Updating the VistA Patient for other eRx record for the same patient (if not already matched)
  1.  . . K FDA
  1.  . . I '$$GET1^DIQ(52.49,OERXIEN,.05,"I") S FDA(52.49,OERXIEN_",",.05)=VPATIEN
  1.  . . S FDA(52.49,OERXIEN_",",1.7)="",FDA(52.49,OERXIEN_",",1.13)="",FDA(52.49,OERXIEN_",",1.14)=""
  1.  . . D FILE^DIE(,"FDA") K FDA
  1.  ;
  1.  I '$D(ERXLST) Q
  1.  ;
  1.  W !!,"The following eRx record(s) have been put on Hold ("_$S(TYPE="A":"HAL",1:"HEL")_") because the VistA"
  1.  W !,"Patient ("_$$GET1^DIQ(2,VPATIEN,.01)_") "
  1.  W:TYPE="A" "does not have an Allergy Assessment."
  1.  W:TYPE="E" "is not Eligible for ChampVA Rx Benefit."
  1.  ;
  1.  S HDR="ERX ID",$E(HDR,17)="DRUG NAME",$E(HDR,48)="PROVIDER",$E(HDR,77)="STS"
  1.  S $P(XX,"-",80)="" W !,HDR,!,XX
  1.  S (OERXIEN,CNT)=0 F  S OERXIEN=$O(ERXLST(OERXIEN)) Q:'OERXIEN  D
  1.  . W !,$$GET1^DIQ(52.49,OERXIEN,.01),?16,$E($S($$GETDRUG^PSOERXU5(OERXIEN)'="":$$GETDRUG^PSOERXU5(OERXIEN),1:"N/A"),1,30)
  1.  . W ?47,$E($$GET1^DIQ(52.49,OERXIEN,2.1),1,23)
  1.  . W ?76,$$GET1^DIQ(52.49,OERXIEN,1)
  1.  . S CNT=CNT+1 I '(CNT#18),$O(ERXLST(OERXIEN)) K DIR D PAUSE^VALM1 W !,HDR,!,XX
  1.  ;
  1.  K DIR D PAUSE^VALM1
  1.  Q
  1.  ;
  1. DUPVPAT(DFN,LIST) ; Checks whether a VistA Patient has potential duplicate records
  1.  ; Input: DFN  - Pointer to the PATIENT file (#2)
  1.  ;Output: LIST - List of duplicate patient(s), Defined if any OR Undefined ('$D)
  1.  ;
  1.  N FULLNAME,FLFN,LASTNAME,DOB,OPATNAME,DUPPAT
  1.  K LIST S FULLNAME=$$GET1^DIQ(2,DFN,.01),FLFN=$E($P(FULLNAME,",",2))
  1.  S LASTNAME=$P(FULLNAME,",") I LASTNAME="" Q
  1.  S DOB=$$GET1^DIQ(2,DFN,.03,"I")
  1.  ;
  1.  S OPATNAME=LASTNAME
  1.  F  S OPATNAME=$O(^DPT("B",OPATNAME)) Q:($P(OPATNAME,",")'=LASTNAME)  D
  1.  . S DUPPAT=0 F  S DUPPAT=$O(^DPT("B",OPATNAME,DUPPAT)) Q:'DUPPAT  D
  1.  . . I DUPPAT=DFN Q
  1.  . . I $$DEAD^PSONVARP(DUPPAT) Q
  1.  . . ; If full names matches OR last names + First Letter of first names + Dates of Birth matches, then it's a match
  1.  . . I OPATNAME=FULLNAME!($E($P(OPATNAME,",",2))=FLFN&($$GET1^DIQ(2,DUPPAT,.03,"I")=DOB)) D
  1.  . . . S LIST(DUPPAT)=OPATNAME_"  "_$$GET1^DIQ(2,DUPPAT,.03)_"  "_$$GET1^DIQ(2,DUPPAT,.09)
  1.  . . . S LIST(DUPPAT)=LIST(DUPPAT)_"  "_$$GET1^DIQ(2,DUPPAT,.114)_","_$$STATEABB^PSOERUT(2,DUPPAT)
  1.  Q
  1.  ;
  1. CXRES ;
  1.  N CODEIEN,COMM,COMMARY,COMMBY,COMMDTTM,DATE,DELTA,DRCVGST,ERESCODE,ERXDAT,FLG,FN,I
  1.  N ID,IENS,IENS2,J,MIEN,MTYPE,NOTE,NOTEARY,PRIAUTH,PRAUTHST,RECODE,REQIEN,RESCODE
  1.  N RESDESC,RESDTTM,RESIEN,RESTEXT,RESVAL,SFIEN,STATUS,STR1,STR1ARY,STR2,STR2ARY
  1.  N TXT,XLINE
  1.  I (","_RULES_",")[(","_$E(RULE,1,4)_",") D
  1.  .S RESIEN=ERXIEN,REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
  1.  .S FLG=1
  1.  I (","_RULES_",")'[(","_$E(RULE,1,4)_",") D
  1.  .S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
  1.  .I MTYPE="CR" D  Q
  1.  ..S RESIEN=$$GETRESP^PSOERXU2(ERXIEN)
  1.  ..I RESIEN D  Q
  1.  ...S REQIEN=ERXIEN
  1.  ...S FLG=1
  1.  ..S FLG=0
  1.  .S FLG=0
  1.  Q:'FLG
  1.  S IENS=RESIEN_","
  1.  D GETS^DIQ(52.49,RESIEN,".03;50;50.1;50.2;52.1;52.2;319.5;324","IE","ERXDAT")
  1.  S RESDTTM=$G(ERXDAT(52.49,IENS,.03,"E"))
  1.  S RESVAL=$G(ERXDAT(52.49,IENS,52.1,"E"))
  1.  S RESCODE=$G(ERXDAT(52.49,IENS,52.1,"I"))
  1.  S NOTE=$G(ERXDAT(52.49,IENS,52.2,"E"))
  1.  S ID=$G(ERXDAT(52.49,IENS,319.5,"E"))
  1.  S DATE=$G(ERXDAT(52.49,IENS,324,"I"))
  1.  I $D(^PS(52.49,ERXIEN,311)) D
  1.  .S SFIEN=$O(^PS(52.49,ERXIEN,311,"C","P",0))
  1.  .Q:'SFIEN
  1.  .S IENS2=SFIEN_","_IENS
  1.  .D GETS^DIQ(52.49311,IENS2,"4.1;4.2;5","IE","ERXDAT")
  1.  .S PRIAUTH=$G(ERXDAT(52.49311,IENS2,4.1,"E"))
  1.  .S PRAUTHST=$G(ERXDAT(52.49311,IENS2,4.2,"E"))
  1.  .S I=$O(^PS(52.49,RESIEN,311,SFIEN,7,0))
  1.  .I I D
  1.  ..S DRCVGST=$$GET1^DIQ(52.493117,I_","_IENS2,.02,"I")
  1.  ..S DRCVGST=$$GET1^DIQ(52.45,DRCVGST,.02,"E")
  1.  .I 'I S DRCVGST=""
  1.  .F I="PRIAUTH","PRAUTHST","DRCVGST" S:@I="" @I=" "
  1.  I '$D(^PS(52.49,ERXIEN,311)) D
  1.  .S (PRIAUTH,PRAUTHST,DRCVGST)=" "
  1.  S LINE=LINE+1
  1.  I $G(SDERXFLG) D
  1.  .D SET^VALM10(LINE,"                         RXCHANGE RESPONSE INFORMATION                          "),CNTRL^VALM10(LINE,1,80,IOUON_IOINHI,IOUOFF_IOINORM)
  1.  E  D
  1.  .D SET^VALM10(LINE,"")
  1.  .S LINE=LINE+1 D SET^VALM10(LINE,"*************************RXCHANGE RESPONSE INFORMATION**************************")
  1.  S LINE=LINE+1 D SET^VALM10(LINE,RESVAL),CNTRL^VALM10(LINE,1,$L(RESVAL),IORVON,IORVOFF)
  1.  D SET^PSOERX1D(.LINE,"Response Date/Time: ",RESDTTM),CNTRL^VALM10(LINE,21,$L(RESDTTM),IOINHI,IOINORM)
  1.  I NOTE]"" D
  1.  .K NOTEARY
  1.  .D TXT2ARY^PSOERXD1(.NOTEARY,NOTE," ",74)
  1.  .S I=0 F  S I=$O(NOTEARY(I)) Q:'I  D
  1.  ..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)
  1.  I '$G(SDERXFLG) S LINE=LINE+1 D SET^VALM10(LINE,"")
  1.  I ((RULE=1059)&(RESPVAL="APPROVED"))!(RULE?1"1062PA".E) D
  1.  .S XLINE=LINE
  1.  .D SET^PSOERX1D(.LINE,"Prior Authorization: ",PRIAUTH),CNTRL^VALM10(.LINE,22,$L(PRIAUTH),IOINHI,IOINORM)
  1.  .D SET^PSOERX1D(.LINE,"Prior Authorization Status: ",PRAUTHST),CNTRL^VALM10(.LINE,29,$L(PRAUTHST),IOINHI,IOINORM)
  1.  .K NOTEARY D TXT2ARY^PSOERXD1(.NOTEARY,DRCVGST," ",58)
  1.  .I $D(NOTEARY) D
  1.  ..S I=0 F  S I=$O(NOTEARY(I)) Q:'I  D
  1.  ...S TXT=$S(I=1:"Drug Coverage Status: ",1:$J("",22))_NOTEARY(I)
  1.  ...S LINE=LINE+1 D SET^VALM10(LINE,TXT),CNTRL^VALM10(LINE,22,$L(NOTEARY(I)),IOINHI,IOINORM)
  1.  .I '$D(NOTEARY) S LINE=LINE+1 D SET^VALM10(LINE,"Drug Coverage Status:")
  1.  .I LINE>XLINE S LINE=LINE+1 D SET^VALM10(LINE,"")
  1.  I ((RULE=1060)&(RESPVAL="VALIDATED"))!(RULE?1"1062UV".E) D
  1.  .S XLINE=LINE
  1.  .D SET^PSOERX1D(.LINE,"ID: ",ID),CNTRL^VALM10(LINE,5,$L(ID),IOINHI,IOINORM)
  1.  .D SET^PSOERX1D(.LINE,"Date: ",DATE),CNTRL^VALM10(LINE,6,$L(DATE),IOINHI,IOINORM)
  1.  .I LINE>XLINE S LINE=LINE+1 D SET^VALM10(LINE,"")
  1.  S COMM=$$GET1^DIQ(52.49,RESIEN,50,"E")
  1.  K COMMARY D TXT2ARY^PSOERXD1(.COMMARY,COMM," ",52)
  1.  I $D(COMMARY) D
  1.  .S I=0 F  S I=$O(COMMARY(I)) Q:'I  D
  1.  ..S TXT=$S(I=1:"RxChange Response Comments: ",1:$J("",28))_COMMARY(I)
  1.  ..S LINE=LINE+1 D SET^VALM10(LINE,TXT),CNTRL^VALM10(LINE,28,$L(COMMARY(I)),IOINHI,IOINORM)
  1.  I '$D(COMMARY) D
  1.  .S LINE=LINE+1 D SET^VALM10(LINE,"RxChange Response Comments:")
  1.  S COMMBY=$$GET1^DIQ(52.49,RESIEN,50.1,"E")
  1.  S COMMDTTM=$$GET1^DIQ(52.49,RESIEN,50.2,"E")
  1.  S LINE=LINE+1 D SET^VALM10(LINE,"Comments By: "_COMMBY),CNTRL^VALM10(LINE,13,$L(COMMBY),IOINHI,IOINORM)
  1.  S LINE=LINE+1 D SET^VALM10(LINE,"Comments Date/Time: "_COMMDTTM),CNTRL^VALM10(LINE,20,$L(COMMDTTM),IOINHI,IOINORM)
  1.  S LINE=LINE+1 D SET^VALM10(LINE,"") S XLINE=LINE
  1.  S I=0 F  S I=$O(^PS(52.49,RESIEN,55,I)) Q:'I  D
  1.  .S ERESCODE=$$GET1^DIQ(52.4955,I_","_IENS,.01,"E")
  1.  .S CODEIEN=$$GET1^DIQ(52.4955,I_","_IENS,.01,"I")
  1.  .S RESDESC=$$GET1^DIQ(52.45,CODEIEN,.02,"E")
  1.  .D
  1.  ..S FLG=0
  1.  ..I RULE=1058 S FLG=1 Q
  1.  ..I RULE=1059,RESPVAL="DENIED" S FLG=1 Q
  1.  ..I RULE=1060 S FLG=1 Q
  1.  ..I RULE=1061 S FLG=1 Q
  1.  ..I RULE?1"1062"1(1"PD",1"U").E S FLG=1
  1.  .I FLG D
  1.  ..S RESTEXT=RESVAL_" reason code: "_ERESCODE
  1.  ..S LINE=LINE+1 D SET^VALM10(LINE,RESTEXT),CNTRL^VALM10(LINE,1,$L(RESTEXT),IORVON,IORVOFF)
  1.  ..D SET^PSOERX1D(.LINE,"Code Description: ",RESDESC),CNTRL^VALM10(LINE,1,$L(RESDESC),IORVON,IORVOFF)
  1.  I XLINE<LINE S LINE=LINE+1 D SET^VALM10(LINE,"")
  1.  Q
  1.  ;