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

PSOERXOA.m

Go to the documentation of this file. 
  1. PSOERXOA ;ALB/BWF - eRx parsing Utilities ; 11/14/2019 3:46pm
  1.  ;;7.0;OUTPATIENT PHARMACY;**581,617**;DEC 1997;Build 110
  1.  ;
  1.  Q
  1. RENEWREQ(PSOIEN,RXIEN,ORNUM,PSOSITE,MESSID,REFREQ) ;Renewal request
  1.  ;return receipt,request reference #, urgency indicator code, follow up req in header
  1.  N ERXIEN,GBL,PSOIENS,CNT,SUPIEN,FUPRES,PRESIEN,PATIEN,MTYPE,RESVAL
  1.  Q:'PSOIEN ""
  1.  S MTYPE=$$GET1^DIQ(52.49,PSOIEN,.08,"I"),RESVAL=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
  1.  S GBL=$NA(^TMP("RENEWREQ^PSOERXOA",$J)) K @GBL
  1.  S CNT=0
  1.  D MSG(.GBL,1)
  1.  ; header
  1.  S MESSID=$$HEADER(.GBL,PSOIEN)
  1.  ; body header
  1.  D BHF(.GBL,1)
  1.   ; request type header
  1.  D RTYPE(GBL,"RxRenewalRequest",1)
  1.  D OBENEFIT^PSOERXOB(GBL,.CNT,PSOIEN) ;outbound benefits coordination section
  1.  D OFAC^PSOERXOB(GBL,.CNT,PSOIEN) ;outbound facility segment
  1.  D PATIENT^PSOERXOC(GBL,.CNT,PSOSITE,PSOIEN) ;outbound patient segment
  1.  D OPHARM^PSOERXOD(GBL,.CNT,PSOSITE,PSOIEN)
  1.  D PERSON^PSOERXOE(GBL,.CNT,PSOSITE,PSOIEN,"PR") ; PRESCRIBER
  1.  D OOBSERVE^PSOERXOB(GBL,.CNT,PSOIEN) ;outbound observation segment
  1.  D MEDDIS^PSOERXOF(GBL,.CNT,PSOIEN,RXIEN,ORNUM,REFREQ) ; outbound medication DISPENSED segment
  1.  I MTYPE'="RE" D MEDS^PSOERXOG(GBL,.CNT,PSOIEN,"P") ; outbound medication PRESCRIBED segment
  1.  I MTYPE="RE" D MEDS^PSOERXOG(GBL,.CNT,PSOIEN,"MR") ; outbound medication PRESCRIBED segment
  1.  D PERSON^PSOERXOE(GBL,.CNT,PSOSITE,PSOIEN,"S") ; SUPERVISOR
  1.  D PERSON^PSOERXOE(GBL,.CNT,PSOSITE,PSOIEN,"FU") ; FOLLOW UP PRESCRIBER
  1.  D RTYPE(GBL,"RxRenewalRequest",2)
  1.  D BHF(.GBL,2)
  1.  D MSG(.GBL,2)
  1.  Q GBL
  1. RXCHREQ(PSOIEN,PSOSITE) ;RxChange request
  1.  ;return receipt,request reference #, urgency indicator code, follow up req in header
  1.  N GBL,PSOIENS,CNT,CONTINUE,REQCODE,REQNOTE,CODES,MEDREQ,CONTINUE,CONT2,X,CRFOUND,S2017,ESTAT,RTHID
  1.  I '$D(^XUSEC("PSDRPH",DUZ)),'($D(^XUSEC("PSO ERX ADV TECH",DUZ))) D  Q
  1.  .W !,"You do not have the appropriate key to access this option." S DIR(0)="E" D ^DIR K DIR
  1.  Q:'PSOIEN ""
  1.  S S2017=$$GET1^DIQ(52.49,ERXIEN,312.1,"I")
  1.  S ESTAT=$$GET1^DIQ(52.49,ERXIEN,1,"E")
  1.  S GBL=$NA(^TMP("CREQ^PSOERXOA",$J)) K @GBL
  1.  S X=0 F  S X=$O(^PS(52.49,PSOIEN,201,"B",X)) Q:'X  D
  1.  .I $$GET1^DIQ(52.49,X,.08,"I")="CR" S CRFOUND=1 Q
  1.  I $G(CRFOUND) D  Q
  1.  .W !,"An RxChange Request has already been sent for this eRx.",!,"A second change request cannot be sent.",!
  1.  .D DIRE^PSOERXX1
  1.  I $$GET1^DIQ(52.49,ERXIEN,.08,"I")'="N"!('S2017)!(ESTAT="RJ")!(ESTAT="RM")!(ESTAT="CAN")!(ESTAT="CAC")!($E(ESTAT)="H") D  Q
  1.  .W !,"Change Request may not be used for this record type." D DIRE^PSOERXX1
  1.  .S VALMBCK="R"
  1.  S CNT=0
  1.  D FULL^VALM1
  1.  S VALMBCK="R"
  1.  D MSG(.GBL,1)
  1.  ; header
  1.  S MESSID=$$HEADER(.GBL,PSOIEN)
  1.  ; body header
  1.  D BHF(.GBL,1)
  1.   ; request type header
  1.  D RTYPE(.GBL,"RxChangeRequest",1)
  1.  ; body goes here
  1.  ; MESSAGE REQUEST CODE/SUBCODES
  1.  S CONTINUE=$$GETCODES^PSOERXON(PSOIEN,.CODES)
  1.  I 'CONTINUE W !,"RxChangeRequest cancelled." D DIRE^PSOERXX1 Q
  1.  S REQCODE=$G(CODES("MRCODE"))
  1.  I REQCODE="P"!(REQCODE="U") S REQNOTE=$G(CODES("NOTE"))
  1.  D MEDCODES^PSOERXON(GBL,.CNT,.CODES)
  1.  ; call prompting logic
  1.  ; RETURN RECEIPT, REQUESTREFERENCENUMBER, URGENCY INDICATOR CODE, FOLLLOWUP REQUEST (DO WE ADD THESE?)
  1.  D OALLERGY^PSOERXOB(GBL,.CNT,PSOIEN) ;(ONLY 1 INSTANCE - XSD IS 0..1)
  1.  D OBENEFIT^PSOERXOB(GBL,.CNT,PSOIEN) ;outbound benefits coordination section
  1.  D OFAC^PSOERXOB(GBL,.CNT,PSOIEN) ;outbound facility segment
  1.  D PATIENT^PSOERXOC(GBL,.CNT,PSOSITE,PSOIEN) ;outbound patient segment
  1.  D OPHARM^PSOERXOD(GBL,.CNT,PSOSITE,PSOIEN) ; brad/steve
  1.  D PERSON^PSOERXOE(GBL,.CNT,PSOSITE,PSOIEN,"PR") ; PRESCRIBER - brad/steve
  1.  D OOBSERVE^PSOERXOB(GBL,.CNT,PSOIEN) ;outbound observation segment
  1.  ; reqnote is used for P and U types, and over-rides the medication prescribed note, per Surescripts
  1.  ; this is due to the lack of a medication requested segment for these 2 request types.
  1.  I $G(REQNOTE)]"" D MEDS^PSOERXOG(GBL,.CNT,PSOIEN,"P",$G(REQNOTE)) ; outbound medication PRESCRIBED segment
  1.  I $G(REQNOTE)']"" D MEDS^PSOERXOG(GBL,.CNT,PSOIEN,"P")
  1.  ; medication request, [0..9]
  1.  S CONT2=$$CHREQ^PSOERXON(GBL,PSOIEN,.CNT,.MEDREQ,REQCODE)
  1.  I 'CONT2 K @GBL Q
  1.  I REQCODE'="P",REQCODE'="U",'$O(MEDREQ(0)) Q
  1.  D PERSON^PSOERXOE(GBL,.CNT,PSOSITE,PSOIEN,"FU") ; FOLLOW UP PRESCRIBER - brad/steve
  1.  D RTYPE(GBL,"RxChangeRequest",2)
  1.  D BHF(.GBL,2)
  1.  D MSG(.GBL,2)
  1.  ; send message
  1.  N PSSRET,HUBID,VADAT,NPIINST,INNAME,STATION,NPI,DIV
  1.  S NPIINST=$$GET1^DIQ(59,PSOSITE,101,"I")
  1.  S INNAME=$$NAME^XUAF4(NPIINST)
  1.  S STATION=$$WHAT^XUAF4(NPIINST,99)
  1.  S NPI=$$NPI^XUSNPI("Organization_ID",NPIINST) I $P(NPI,U)<1 D
  1.  .S NPI=$$WHAT^XUAF4(NPIINST,41.99)
  1.  I '$G(NPI) W !!,"NPI could not be established. Cannot create renewal request." D DIRE^PSOERXX1 Q
  1.  S DIV=INNAME_U_NPI
  1.  S RXIEN=$$GET1^DIQ(52.49,PSOIEN,.13,"I")
  1.  S PSSRET=$$RESTPOST^PSOERXO1(.PSSRET,.GBL)
  1.  ; if the post was unsuccessful, inform the user and quit.
  1.  I $P(PSSRET(0),U)<1 W !,$P(PSSRET(0),U,2) S DIR(0)="E" D ^DIR K DIR Q
  1.  I $D(PSSRET("errorMessage")) W !,PSSRET("errorMessage") S DIR(0)="E" D ^DIR K DIR Q
  1.  S HUBID=$G(PSSRET("outboundMsgId")) I 'HUBID W !,"The eRx Processing hub did not return a Hub identification number." S DIR(0)="E" D ^DIR K DIR Q
  1.  ; vista generated message will be V12345 (V concatenated to the hubId)
  1.  S HUBID="V"_HUBID
  1.  N RES,I,XXL1
  1.  S I=0 F  S I=$O(@GBL@(I)) Q:'I  D
  1.  .S XXL1=$G(XXL1)_$G(@GBL@(I,0))
  1.  S VADAT=DUZ
  1.  S RTHID=$$GET1^DIQ(52.49,PSOIEN,.01,"E")
  1.  S HUBID=HUBID_U_U_RTHID
  1.  D INCERX^PSOERXI1(.RES,.XXL1,"","","",STATION,DIV,HUBID,"","",VADAT,"")
  1.  I $P(RES,U)=0 D
  1.  .W !,"A problem was encountered while trying to file the RxChange request."
  1.  .W !,"RxChange Request was not filed in vista."
  1.  .W !!,"ERROR: "_$P(RES,U,2)
  1.  .S DIR(0)="E" D ^DIR K DIR
  1.  W !,"eRx Change Request sent." D DIRE^PSOERXX1
  1.  D UPDSTAT^PSOERXU1(PSOIEN,"HC")
  1.  K @GBL
  1.  Q
  1. MSG(GBL,HF) ; 2017071 MSG segment
  1.  N XL1,XL2
  1.  Q:'HF
  1.  I HF=1 D
  1.  .S XL1="<?xml version=""1.0"" encoding=""UTF-8""?><Message DatatypesVersion=""20170715"" TransportVersion=""20170715"" TransactionDomain=""SCRIPT"" TransactionVersion=""20170715"" "
  1.  .S XL2="StructuresVersion=""20170715"" ECLVersion=""20170715"" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"">"
  1.  .D C S @GBL@(CNT,0)=XL1_XL2
  1.  I HF=2 D C S @GBL@(CNT,0)="</Message>"
  1.  Q
  1.  ;
  1.  N ERXHID,F,FRQUAL,FRVAL,IENS,INST,MID,PON,PSDAT,REQREF,RETREC,RSECID,RTERTID,RTMID,SSECID
  1.  N SENTTIME,STERTID,STIME,TOQUAL,TOVAL,TXT
  1.  S F=52.49
  1.  S IENS=IEN_","
  1.  D GETS^DIQ(F,IENS,"**","IE","PSDAT")
  1.  D CONVXML^PSOERXX1("PSDAT")
  1.  S ERXHID=$G(PSDAT(F,IENS,.01,"E"))
  1.  ; 'TO' values come from the 'FROM' fields of the eRx.
  1.  S TOQUAL=$G(PSDAT(F,IENS,22.2,"I"))
  1.  S TOVAL=$G(PSDAT(F,IENS,22.1,"E"))
  1.  ; 'FROM' values come from the 'TO' fields of the eRx.
  1.  S FRQUAL=$G(PSDAT(F,IENS,22.4,"I"))
  1.  S FRVAL=$G(PSDAT(F,IENS,22.3,"E"))
  1.  S INST=DUZ(2)
  1.  ; message ID needs to be unique from vista - Site#.erxIEN.date.time
  1.  S MID=INST_"."_IEN_"."_$$NOW^XLFDT
  1.  S RTMID=$G(PSDAT(F,IENS,25,"E"))
  1.  ;
  1.  S PON=$G(PSDAT(F,IENS,.09,"E"))
  1.  ; return receipt and request reference # currenly not stored. Do we need to add a field in 52.49?
  1.  S RETREC=$G(PSDAT(F,IENS,1,"E"))
  1.  S REQREF=$G(PSDAT(F,IENS,1,"E"))
  1.  S RETREC="ACA",REQREF=""
  1.  S SSECID=$G(PSDAT(F,IENS,24.5,"E"))
  1.  ; leaving this in place for now CH wanted the tertiary ID to be TECHNATOMY. I suspect this will
  1.  ; need to be something different in the long run
  1.  S STERTID="TECHNATOMY"
  1.  S RSECID=$G(PSDAT(F,IENS,24.3,"E"))
  1.  S SENTTIME=$$EXTIME^PSOERXO1()
  1.  S RTERTID="ERXPAD"
  1.  I TOQUAL'="",TOVAL'="",FRQUAL'="",FRVAL'="",MID'="",SENTTIME'="" D
  1.  .D C S @GBL@(CNT,0)="<Header>"
  1.  .D C S @GBL@(CNT,0)="<To Qualifier="""_TOQUAL_""">"_TOVAL_"</To>"
  1.  .D C S @GBL@(CNT,0)="<From Qualifier="""_FRQUAL_""">"_FRVAL_"</From>"
  1.  .D C S @GBL@(CNT,0)="<MessageID>"_MID_"</MessageID>"
  1.  .; relatesToMessageID is the CH messageID - FIELD 25
  1.  .D BL(GBL,.CNT,"RelatesToMessageID",RTMID)
  1.  .D C S @GBL@(CNT,0)="<SentTime>"_SENTTIME_"</SentTime>"
  1.  .I $L(STERTID_RTERTID) D
  1.  ..D C S @GBL@(CNT,0)="<Security>"
  1.  ..; bwf -  missing UsernameToken - consider as part of v4 if needed
  1.  ..I STERTID'="" D
  1.  ...D C S @GBL@(CNT,0)="<Sender>"
  1.  ...; for now we are not using secondary identifications, this will stay in place for future activation.
  1.  ...;I $L(SSECID) D C S @GBL@(CNT,0)="<SecondaryIdentification>"_SSECID_"</SecondaryIdentification>"
  1.  ...D C S @GBL@(CNT,0)="<TertiaryIdentification>"_STERTID_"</TertiaryIdentification>"
  1.  ...D C S @GBL@(CNT,0)="</Sender>"
  1.  ..I RTERTID'="" D
  1.  ...D C S @GBL@(CNT,0)="<Receiver>"
  1.  ...;I $L(RSECID) D C S @GBL@(CNT,0)="<SecondaryIdentification>"_RSECID_"</SecondaryIdentification>"
  1.  ...D C S @GBL@(CNT,0)="<TertiaryIdentification>"_RTERTID_"</TertiaryIdentification>"
  1.  ...D C S @GBL@(CNT,0)="</Receiver>"
  1.  ..D C S @GBL@(CNT,0)="</Security>"
  1.  .D C S @GBL@(CNT,0)="<SenderSoftware>"
  1.  .D BL(GBL,.CNT,"SenderSoftwareDeveloper","VA")
  1.  .D BL(GBL,.CNT,"SenderSoftwareProduct","VA-Inbound eRx")
  1.  .D BL(GBL,.CNT,"SenderSoftwareVersionRelease","V5.0")
  1.  .D C S @GBL@(CNT,0)="</SenderSoftware>"
  1.  .; missing 'Mailbox' - note for future enhancement. Was not needed for CH certification.
  1.  .D BL(GBL,.CNT,"RxReferenceNumber",ERXHID)
  1.  .D BL(GBL,.CNT,"PrescriberOrderNumber",PON)
  1.  .D C S @GBL@(CNT,0)="</Header>"
  1.  Q MID
  1.  ;
  1. BHF(GBL,HF) ;
  1.  Q:'$D(HF)
  1.  D C
  1.  S @GBL@(CNT,0)=$S(HF=1:"<Body>",HF=2:"</Body>",1:"")
  1.  Q
  1.  ;HF   1 - header
  1.  ;     2 - footer
  1. BL(GBL,CNT,TAG,VAR) ;
  1.  Q:VAR=""
  1.  D C S @GBL@(CNT,0)="<"_TAG_">"_$$SYMENC^MXMLUTL(VAR)_"</"_TAG_">"
  1.  Q
  1. C ;
  1.  S CNT=$G(CNT)+1
  1.  Q
  1. RTYPE(GBL,RTYPE,HF) ;
  1.  Q:'HF
  1.  D C
  1.  S @GBL@(CNT,0)=$S(HF=1:"<"_RTYPE_">",HF=2:"</"_RTYPE_">",1:"")
  1.  Q