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