PSOERXX2 ;ALB/BWF - eRx xml utilities ; 8/3/2016 5:14pm
;;7.0;OUTPATIENT PHARMACY;**467,508,581**;DEC 1997;Build 126
;
Q
MSG(GBL,HF) ;
Q:'HF
I HF=1 D C S @GBL@(CNT,0)="<?xml version=""1.0"" encoding=""UTF-8""?><Message version=""010"" release=""006"" HighestVersionSupported="""" xmlns=""http://www.ncpdp.org/schema/SCRIPT"">" Q
I HF=2 D C S @GBL@(CNT,0)="</Message>"
Q
HDR(GBL,IEN) ;
N F,TOQUAL,TOVAL,FRQUAL,FRVAL,MID,STIME,STERTID,RTERTID,PON,RETREC,REQREF,PSDAT,INST,SSECID,RSECID,ERXHID
N RTMID
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_"."_PSOIEN_"."_$$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 RTERTID="ERXPAD"
D C S @GBL@(CNT,0)="<Header><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
I $L(RTMID) D C S @GBL@(CNT,0)="<RelatesToMessageID>"_RTMID_"</RelatesToMessageID>"
D C S @GBL@(CNT,0)="<SentTime>"_$$EXTIME^PSOERXO1()_"</SentTime>"
D C S @GBL@(CNT,0)="<Security>"
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>"
I $L(STERTID) D C S @GBL@(CNT,0)="<TertiaryIdentification>"_STERTID_"</TertiaryIdentification>"
D C S @GBL@(CNT,0)="</Sender>"
D C S @GBL@(CNT,0)="<Receiver>"
;I $L(RSECID) D C S @GBL@(CNT,0)="<SecondaryIdentification>"_RSECID_"</SecondaryIdentification>"
I $L(RTERTID) D C S @GBL@(CNT,0)="<TertiaryIdentification>"_RTERTID_"</TertiaryIdentification>"
D C S @GBL@(CNT,0)="</Receiver>"
D C S @GBL@(CNT,0)="</Security>"
; missing 'Mailbox' - note for future enhancement. Was not needed for CH certification.
D C S @GBL@(CNT,0)="<RxReferenceNumber>"_ERXHID_"</RxReferenceNumber>"
I $L(PON) D C S @GBL@(CNT,0)="<PrescriberOrderNumber>"_PON_"</PrescriberOrderNumber>"
D C S @GBL@(CNT,0)="</Header>"
Q MID
; body header/footer
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
RTYPE(GBL,RTYPE,HF) ;
Q:'HF
D C
S @GBL@(CNT,0)=$S(HF=1:"<"_RTYPE_">",HF=2:"</"_RTYPE_">",1:"")
Q
REQUEST(GBL,RETREC,REQREF) ;
D C S @GBL@(CNT,0)="<Request>"
D C S @GBL@(CNT,0)="<ReturnReceipt>"_RETREC_"</ReturnReceipt>"
D C S @GBL@(CNT,0)="<RequestReferenceNumber>"_REQREF_"</RequestReferenceNumber>"
D C S @GBL@(CNT,0)="</Request>"
Q
VAPHARM(GBL,PSOSITE,PSOIEN) ;
N F,F2,NCPID,NPI,SPEC,LNAME,FNAME,MNAME,SUFF,PREF,STNM,ADDL1,ADDL2,CITY,STATE,PLQ,TELE,UIENS
N PHIEN,PHIENS,EXPHIEN,EXPHIENS,PHARDAT,PHARDAT,PSDAT,AREA,FTELE,FULLNM,PDAT,PHRMCIST,SIENS
N EIEN,EIENS,CMNUM,ID,IDTYP,IDVAL,CMVAL,CMQUAL
S F=52.47,F2=52.48
; this is the vista pharmacy/pharmacist
S EIEN=$$GET1^DIQ(52.49,PSOIEN,2.5,"I")
S EIENS=EIEN_","
S PHIEN=$$GET1^DIQ(52.49,PSOIEN,2.2,"I")
S PHIENS=PHIEN_","
D GETS^DIQ(F,EIENS,"**","IE","PHARDAT")
S NCPID=$G(PHARDAT(F,EIENS,.02,"E"))
D GETS^DIQ(F2,PHIENS,"**","IE","PHRMCIST")
D CONVXML^PSOERXX1("PHARDAT"),CONVXML^PSOERXX1("PHRMCIST")
;S FULLNM=$G(PHRMCIST(F2,UIENS,.01,"E"))
S LNAME=$G(PHRMCIST(F2,PHIENS,.02,"E"))
S FNAME=$G(PHRMCIST(F2,PHIENS,.03,"E"))
S MNAME=$G(PHRMCIST(F2,PHIENS,.04,"E"))
S SUFF=$G(PHRMCIST(F2,PHIENS,.05,"E"))
S PREF=$G(PHRMCIST(F2,PHIENS,.06,"E"))
S NPI=$G(PHRMCIST(F2,PHIENS,1.5,"E"))
S STNM=$G(PHARDAT(F,EIENS,.01,"E"))
S ADDL1=$G(PHARDAT(F,EIENS,1.1,"E"))
S ADDL2=$G(PHARDAT(F,EIENS,1.2,"E"))
S CITY=$G(PHARDAT(F,EIENS,1.3,"E"))
S STATE=$G(PHARDAT(F,EIENS,1.4,"I"))
S STATE=$$STRES(STATE,PSOSITE)
S ZIP=$G(PHARDAT(F,EIENS,1.5,"E")),ZIP=$TR(ZIP,"-","")
; address missing from NewRx
I '$L(ADDL1) D
.S ADDL1=$$GET1^DIQ(59,PSOSITE,.02,"E")
.S ADDL2=""
.S CITY=$$GET1^DIQ(59,PSOSITE,.07,"E")
.S STATE=$$GET1^DIQ(59,PSOSITE,.08,"I")
.I STATE S STATE=$$GET1^DIQ(5,STATE,1,"E")
.S ZIP=$E($$GET1^DIQ(59,PSOSITE,.05,"E"),1,5)
D C S @GBL@(CNT,0)="<Pharmacy>"
I $O(^PS(52.47,EIEN,2,0)) D
.D C S @GBL@(CNT,0)="<Identification>"
.S ID=0 F S ID=$O(^PS(52.47,EIEN,2,ID)) Q:'ID D
..S IDTYP=$$GET1^DIQ(52.472,ID_","_EIEN_",",.01,"E")
..S IDVAL=$$GET1^DIQ(52.472,ID_","_EIEN_",",.02,"E")
..F VAR="IDTYP","IDVAL" S @VAR=$$SYMENC^MXMLUTL(@VAR)
..D C S @GBL@(CNT,0)="<"_IDTYP_">"_IDVAL_"</"_IDTYP_">"
.D C S @GBL@(CNT,0)="</Identification>"
;D C S @GBL@(CNT,0)="<Specialty>"_SPEC_"</Specialty>"
I $L(LNAME) D
.D C S @GBL@(CNT,0)="<Pharmacist>"
.I $L(LNAME) D C S @GBL@(CNT,0)="<LastName>"_LNAME_"</LastName>"
.I $L(FNAME) D C S @GBL@(CNT,0)="<FirstName>"_FNAME_"</FirstName>"
.I $L(MNAME) D C S @GBL@(CNT,0)="<MiddleName>"_MNAME_"</MiddleName>"
.I $L(SUFF) D C S @GBL@(CNT,0)="<Suffix>"_SUFF_"</Suffix>"
.I $L(PREF) D C S @GBL@(CNT,0)="<Prefix>"_PREF_"</Prefix>"
.D C S @GBL@(CNT,0)="</Pharmacist>"
I $L(STNM) D C S @GBL@(CNT,0)="<StoreName>"_STNM_"</StoreName>"
I $L(ADDL1)!($L(ADDL2))!($L(CITY))!($L(STATE))!($L(ZIP)) D
.D C S @GBL@(CNT,0)="<Address>"
.I $L(ADDL1) D C S @GBL@(CNT,0)="<AddressLine1>"_ADDL1_"</AddressLine1>"
.I $L(ADDL2) D C S @GBL@(CNT,0)="<AddressLine2>"_ADDL2_"</AddressLine2>"
.I $L(CITY) D C S @GBL@(CNT,0)="<City>"_CITY_"</City>"
.I $L(STATE) D C S @GBL@(CNT,0)="<State>"_STATE_"</State>"
.I $L(ZIP) D C S @GBL@(CNT,0)="<ZipCode>"_ZIP_"</ZipCode>"
.;D C S @GBL@(CNT,0)="<PlaceLocationQualifier>"_PLQ_"</PlaceLocationQualifier>"
.D C S @GBL@(CNT,0)="</Address>"
I '$O(^PS(52.47,EIEN,3,0)) D
.S CMVAL=$$GET1^DIQ(59,PSOIEN,.03,"E")
.S CMVAL=CMVAL_$$GET1^DIQ(59,PSOIEN,.04,"E")
.I '$L(CMVAL) S CMVAL="0000000000"
.S CMVAL=$TR(CMVAL,"-","")
.S CMQUAL="TE"
.D C S @GBL@(CNT,0)="<CommunicationNumbers>"
.D COMMNUM(.GBL,CMVAL,CMQUAL)
.D COMMNUM(.GBL,"0000000000","FX")
.D C S @GBL@(CNT,0)="</CommunicationNumbers>"
I $O(^PS(52.47,EIEN,3,0)) D
.D C S @GBL@(CNT,0)="<CommunicationNumbers>"
.S CMNUM=0 F S CMNUM=$O(^PS(52.47,EIEN,3,CMNUM)) Q:'CMNUM D
..S CMVAL=$$GET1^DIQ(52.473,CMNUM_","_EIEN_",",.01,"E")
..S CMQUAL=$$GET1^DIQ(52.473,CMNUM_","_EIEN_",",.02,"I")
..D COMMNUM(.GBL,CMVAL,CMQUAL)
.D C S @GBL@(CNT,0)="</CommunicationNumbers>"
D C S @GBL@(CNT,0)="</Pharmacy>"
Q
; GBL - global for xml storage
; IENS - ien string for the current entry
; FIL - top level file number
; SUBFIL - subfile number
COMMNUM(GBL,COMMNUM,QUAL) ;
D C S @GBL@(CNT,0)="<Communication>"
D C S @GBL@(CNT,0)="<Number>"_$$SYMENC^MXMLUTL(COMMNUM)_"</Number>"
D C S @GBL@(CNT,0)="<Qualifier>"_$$SYMENC^MXMLUTL(QUAL)_"</Qualifier>"
D C S @GBL@(CNT,0)="</Communication>"
Q
IDENT(GBL,TYPE,VAL) ;
N VAR
F VAR="TYPE","VAL" S @VAR=$$SYMENC^MXMLUTL(@VAR)
D C S @GBL@(CNT,0)="<"_TYPE_">"_VAL_"</"_TYPE_">"
Q
; GBL - GLOBAL WHERE DATA IS STORED
; IEN - IEN TO 52.49
PRESCRIB(GBL,PSOSITE,IEN) ;
N F,DEAN,NPI,SPEC,CLINIC,LNAME,FNAME,MNAME,SUFF,PREF,ADDL1,ADDL2,CITY,STATE,ZIP,PLQ,ALNAME,AFNAME,AMNAME,ASUFF,APREF
N PSDAT,CLOOP,CNUM,CQUAL,ILOOP,ITYP,IVAL,PIEN,PIENS
S F=52.48,IENS=IEN_","
S PIEN=$$GET1^DIQ(52.49,IEN,2.1,"I") Q:'PIEN
S PIENS=PIEN_","
D GETS^DIQ(F,PIENS,"**","IE","PSDAT")
D CONVXML^PSOERXX1("PSDAT")
S DEAN=$G(PSDAT(F,PIENS,1.6,"E"))
S NPI=$G(PSDAT(F,PIENS,1.5,"E"))
S SPEC=$G(PSDAT(F,PIENS,1.2,"E"))
S CLINIC=$G(PSDAT(F,PIENS,2.1,"E"))
S LNAME=$G(PSDAT(F,PIENS,.02,"E"))
S FNAME=$G(PSDAT(F,PIENS,.03,"E"))
S MNAME=$G(PSDAT(F,PIENS,.04,"E"))
S SUFF=$G(PSDAT(F,PIENS,.05,"E"))
S PREF=$G(PSDAT(F,PIENS,.06,"E"))
S ADDL1=$G(PSDAT(F,PIENS,4.1,"E"))
S ADDL2=$G(PSDAT(F,PIENS,4.2,"E"))
S CITY=$G(PSDAT(F,PIENS,4.3,"E"))
S STATE=$G(PSDAT(F,PIENS,4.4,"I"))
S STATE=$$STRES(STATE,PSOSITE)
S ZIP=$G(PSDAT(F,PIENS,4.5,"E"))
S PLQ=$G(PSDAT(F,PIENS,2.2,"E"))
S ALNAME=$G(PSDAT(F,PIENS,5.1,"E"))
S AFNAME=$G(PSDAT(F,PIENS,5.2,"E"))
S AMNAME=$G(PSDAT(F,PIENS,5.3,"E"))
S ASUFF=$G(PSDAT(F,PIENS,5.4,"E"))
S APREF=$G(PSDAT(F,PIENS,5.5,"E"))
D C S @GBL@(CNT,0)="<Prescriber>"
I $O(^PS(52.48,PIEN,6,0)) D
.D C S @GBL@(CNT,0)="<Identification>"
.S ILOOP=0 F S ILOOP=$O(^PS(52.48,PIEN,6,ILOOP)) Q:'ILOOP D
..S ITYP=$$GET1^DIQ(52.486,ILOOP_","_PIENS,.01,"E")
..S IVAL=$$GET1^DIQ(52.486,ILOOP_","_PIENS,.02,"E")
..D IDENT(.GBL,ITYP,IVAL)
.D C S @GBL@(CNT,0)="</Identification>"
I $L(SPEC) D C S @GBL@(CNT,0)="<Specialty>"_SPEC_"</Specialty>" ; ***SLASH AT THE END???
I $L(CLINIC) D C S @GBL@(CNT,0)="<ClinicName>"_CLINIC_"</ClinicName>" ; ***SLASH AT THE END???
D C S @GBL@(CNT,0)="<Name>"
I $L(LNAME) D C S @GBL@(CNT,0)="<LastName>"_LNAME_"</LastName>"
I $L(FNAME) D C S @GBL@(CNT,0)="<FirstName>"_FNAME_"</FirstName>"
I $L(MNAME) D C S @GBL@(CNT,0)="<MiddleName>"_MNAME_"</MiddleName>"
I $L(SUFF) D C S @GBL@(CNT,0)="<Suffix>"_SUFF_"</Suffix>"
I $L(PREF) D C S @GBL@(CNT,0)="<Prefix>"_PREF_"</Prefix>"
D C S @GBL@(CNT,0)="</Name>"
D C S @GBL@(CNT,0)="<Address>"
I $L(ADDL1) D C S @GBL@(CNT,0)="<AddressLine1>"_ADDL1_"</AddressLine1>"
I $L(ADDL2) D C S @GBL@(CNT,0)="<AddressLine2>"_ADDL2_"</AddressLine2>"
I $L(CITY) D C S @GBL@(CNT,0)="<City>"_CITY_"</City>"
I $L(STATE) D C S @GBL@(CNT,0)="<State>"_STATE_"</State>"
I $L(ZIP) D C S @GBL@(CNT,0)="<ZipCode>"_ZIP_"</ZipCode>"
I $L(PLQ) D C S @GBL@(CNT,0)="<PlaceLocationQualifier>"_PLQ_"</PlaceLocationQualifier>"
D C S @GBL@(CNT,0)="</Address>"
I $O(^PS(52.48,PIEN,3,0)) D
.D C S @GBL@(CNT,0)="<CommunicationNumbers>"
.S CLOOP=0 F S CLOOP=$O(^PS(52.48,PIEN,3,CLOOP)) Q:'CLOOP D
..S CNUM=$$GET1^DIQ(52.483,CLOOP_","_PIENS,.01,"E")
..S CQUAL=$$GET1^DIQ(52.483,CLOOP_","_PIENS,.02,"I")
..D COMMNUM(.GBL,CNUM,CQUAL)
.D C S @GBL@(CNT,0)="</CommunicationNumbers>"
I $L(ALNAME) D
.D C S @GBL@(CNT,0)="<PrescriberAgent>"
.I $L(ALNAME) D C S @GBL@(CNT,0)="<LastName>"_ALNAME_"</LastName>"
.I $L(AFNAME) D C S @GBL@(CNT,0)="<FirstName>"_AFNAME_"</FirstName>"
.I $L(AMNAME) D C S @GBL@(CNT,0)="<MiddleName>"_AMNAME_"</MiddleName>"
.I $L(ASUFF) D C S @GBL@(CNT,0)="<Suffix>"_ASUFF_"</Suffix>"
.I $L(APREF) D C S @GBL@(CNT,0)="<Prefix>"_APREF_"</Prefix>"
.D C S @GBL@(CNT,0)="</PrescriberAgent>"
D C S @GBL@(CNT,0)="</Prescriber>"
Q
SUPERVIS(GBL,PSOSITE,IEN) ;
N F,SLN,DEAN,SPEC,LNAME,FNAME,MNAME,SUFF,PREF,CLNAME,ADDL1,ADDL2,CITY,STATE,ZIP,PLQ,PSDAT,ILOOP,ITYP,IVAL
N SIEN,SIENS
S F=52.48
S IENS=IEN_","
S SIEN=$$GET1^DIQ(52.49,IEN,2.6,"I") Q:'SIEN
S SIENS=SIEN_","
D GETS^DIQ(F,SIENS,"**","IE","PSDAT")
D CONVXML^PSOERXX1("PSDAT")
S SLN=$G(PSDAT(F,SIENS,1.8,"E"))
S DEAN=$G(PSDAT(F,SIENS,1.6,"E"))
S SPEC=$G(PSDAT(F,SIENS,1.2,"E"))
S LNAME=$G(PSDAT(F,SIENS,.02,"E"))
S FNAME=$G(PSDAT(F,SIENS,.03,"E"))
S MNAME=$G(PSDAT(F,SIENS,.04,"E"))
S SUFF=$G(PSDAT(F,SIENS,.05,"E"))
S PREF=$G(PSDAT(F,SIENS,.06,"E"))
S CLNAME=$G(PSDAT(F,SIENS,2.1,"E"))
S ADDL1=$G(PSDAT(F,SIENS,4.1,"E"))
S ADDL2=$G(PSDAT(F,SIENS,4.2,"E"))
S CITY=$G(PSDAT(F,SIENS,4.3,"E"))
S STATE=$G(PSDAT(F,SIENS,4.4,"I"))
S STATE=$$STRES(STATE)
S ZIP=$G(PSDAT(F,SIENS,4.5,"E"))
S PLQ=$G(PSDAT(F,SIENS,2.2,"E"))
D C S @GBL@(CNT,0)="<Supervisor>"
I $O(^PS(52.48,SIEN,6,0)) D
.D C S @GBL@(CNT,0)="<Identification>"
.S ILOOP=0 F S ILOOP=$O(^PS(52.48,SIEN,6,ILOOP)) Q:'ILOOP D
..S ITYP=$$GET1^DIQ(52.486,ILOOP_","_SIENS,.01,"E")
..S IVAL=$$GET1^DIQ(52.486,ILOOP_","_SIENS,.02,"E")
..D IDENT(.GBL,ITYP,IVAL)
.D C S @GBL@(CNT,0)="</Identification>"
D C S @GBL@(CNT,0)="<Specialty>"_SPEC_"</Specialty>"
D C S @GBL@(CNT,0)="<Name>"
D C S @GBL@(CNT,0)="<LastName>"_LNAME_"</LastName>"
D C S @GBL@(CNT,0)="<FirstName>"_FNAME_"</FirstName>"
D C S @GBL@(CNT,0)="<MiddleName>"_MNAME_"</MiddleName>"
D C S @GBL@(CNT,0)="<Suffix>"_SUFF_"</Suffix>"
D C S @GBL@(CNT,0)="<Prefix>"_PREF_"</Prefix>"
D C S @GBL@(CNT,0)="</Name>"
D C S @GBL@(CNT,0)="<ClinicName>"_CLNAME_"</ClinicName>"
D C S @GBL@(CNT,0)="<Address>"
D C S @GBL@(CNT,0)="<AddressLine1>"_ADDL1_"</AddressLine1>"
D C S @GBL@(CNT,0)="<AddressLine2>"_ADDL2_"</AddressLine2>"
D C S @GBL@(CNT,0)="<City>"_CITY_"</City>"
D C S @GBL@(CNT,0)="<State>"_STATE_"</State>"
I $L(ZIP) D C S @GBL@(CNT,0)="<ZipCode>"_ZIP_"</ZipCode>"
D C S @GBL@(CNT,0)="<PlaceLocationQualifier>"_PLQ_"</PlaceLocationQualifier>"
D C S @GBL@(CNT,0)="</Address>"
D C S @GBL@(CNT,0)="<CommunicationNumbers>"
S CLOOP=0 F S CLOOP=$O(^PS(52.48,SIEN,3,CLOOP)) Q:'CLOOP D
.S CNUM=$$GET1^DIQ(52.483,CLOOP_","_SIENS,.01,"E")
.S CQUAL=$$GET1^DIQ(52.483,CLOOP_","_SIENS,.02,"I")
.D COMMNUM(.GBL,CNUM,CQUAL)
; ***COMMUNICATION NUMBERS***
D C S @GBL@(CNT,0)="</CommunicationNumbers>"
D C S @GBL@(CNT,0)="</Supervisor>"
Q
FACIL(GBL,PSOSITE,IENS) ;
N F,NPI,NAME,ADDL1,ADDL2,CITY,STATE,ZIP,PLQ,PSDAT
S F=52.49
; FOR NOW, JUST BUILD HEADER AND FOOTER
Q
D C S @GBL@(CNT,0)="<Facility>"
D C S @GBL@(CNT,0)="</Facility>"
Q
; complete this as a future enhancement
D GETS^DIQ(F,IENS,"**","IE","PSDAT")
D CONVXML^PSOERXX1("PSDAT")
S NPI=$G(PSDAT(F,IENS,1,"E"))
S NAME=$G(PSDAT(F,IENS,1,"E"))
S ADDL1=$G(PSDAT(F,IENS,1,"E"))
S ADDL2=$G(PSDAT(F,IENS,1,"E"))
S CITY=$G(PSDAT(F,IENS,1,"E"))
S STATE=$G(PSDAT(F,IENS,1,"I"))
S STATE=$$STRES(STATE)
S ZIP=$G(PSDAT(F,IENS,1,"E"))
S PLQ=$G(PSDAT(F,IENS,1,"E"))
D C S @GBL@(CNT,0)="<Facility>"
I $L(NPI) D
.D C S @GBL@(CNT,0)="<Identification>"
.D C S @GBL@(CNT,0)="<NPI>"_NPI_"<NPI>"
.D C S @GBL@(CNT,0)="</Identification>"
D C S @GBL@(CNT,0)="<FacilityName>"_NAME_"</FacilityName>"
D C S @GBL@(CNT,0)="<Address>"
D C S @GBL@(CNT,0)="<AddressLine1>"_ADDL1_"</AddressLine1>"
D C S @GBL@(CNT,0)="<AddressLine2>"_ADDL2_"</AddressLine2>"
D C S @GBL@(CNT,0)="<City>"_CITY_"</City>"
D C S @GBL@(CNT,0)="<State>"_STATE_"</State>"
I $L(ZIP) D C S @GBL@(CNT,0)="<ZipCode>"_ZIP_"</ZipCode>"
D C S @GBL@(CNT,0)="<PlaceLocationQualifier>"_PLQ_"</PlaceLocationQualifier>"
D C S @GBL@(CNT,0)="</Address>"
;***COMMUNICATION NUMBERS
D C S @GBL@(CNT,0)="</Facility>"
Q
C ;
S CNT=$G(CNT)+1
Q
STRES(STATE,PSOSITE) ;
N SIEN
S SIEN=""
I STATE S SIEN=$$GET1^DIQ(5,STATE,1,"E") Q SIEN
; if the state cannot be resolved, use the state from file 59
I 'SIEN S SIEN=$$GET1^DIQ(59,PSOSITE,.08,"I")
; if there is still no state, use the state from the physical address of the institution: IA 2171
I 'SIEN S SIEN=$P($$PADD^XUAF4(DUZ(2)),U,3)
Q SIEN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXX2 15365 printed Sep 15, 2024@21:53:16 Page 2
PSOERXX2 ;ALB/BWF - eRx xml utilities ; 8/3/2016 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**467,508,581**;DEC 1997;Build 126
+2 ;
+3 QUIT
MSG(GBL,HF) ;
+1 if 'HF
QUIT
+2 IF HF=1
DO C
SET @GBL@(CNT,0)="<?xml version=""1.0"" encoding=""UTF-8""?><Message version=""010"" release=""006"" HighestVersionSupported="""" xmlns=""http://www.ncpdp.org/schema/SCRIPT"">"
QUIT
+3 IF HF=2
DO C
SET @GBL@(CNT,0)="</Message>"
+4 QUIT
HDR(GBL,IEN) ;
+1 NEW F,TOQUAL,TOVAL,FRQUAL,FRVAL,MID,STIME,STERTID,RTERTID,PON,RETREC,REQREF,PSDAT,INST,SSECID,RSECID,ERXHID
+2 NEW RTMID
+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_"."_PSOIEN_"."_$$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 RTERTID="ERXPAD"
+30 DO C
SET @GBL@(CNT,0)="<Header><To Qualifier="""_TOQUAL_""">"_TOVAL_"</To>"
+31 DO C
SET @GBL@(CNT,0)="<From Qualifier="""_FRQUAL_""">"_FRVAL_"</From>"
+32 DO C
SET @GBL@(CNT,0)="<MessageID>"_MID_"</MessageID>"
+33 ; relatesToMessageID is the CH messageID - FIELD 25
+34 IF $LENGTH(RTMID)
DO C
SET @GBL@(CNT,0)="<RelatesToMessageID>"_RTMID_"</RelatesToMessageID>"
+35 DO C
SET @GBL@(CNT,0)="<SentTime>"_$$EXTIME^PSOERXO1()_"</SentTime>"
+36 DO C
SET @GBL@(CNT,0)="<Security>"
+37 DO C
SET @GBL@(CNT,0)="<Sender>"
+38 ; for now we are not using secondary identifications, this will stay in place for future activation.
+39 ;I $L(SSECID) D C S @GBL@(CNT,0)="<SecondaryIdentification>"_SSECID_"</SecondaryIdentification>"
+40 IF $LENGTH(STERTID)
DO C
SET @GBL@(CNT,0)="<TertiaryIdentification>"_STERTID_"</TertiaryIdentification>"
+41 DO C
SET @GBL@(CNT,0)="</Sender>"
+42 DO C
SET @GBL@(CNT,0)="<Receiver>"
+43 ;I $L(RSECID) D C S @GBL@(CNT,0)="<SecondaryIdentification>"_RSECID_"</SecondaryIdentification>"
+44 IF $LENGTH(RTERTID)
DO C
SET @GBL@(CNT,0)="<TertiaryIdentification>"_RTERTID_"</TertiaryIdentification>"
+45 DO C
SET @GBL@(CNT,0)="</Receiver>"
+46 DO C
SET @GBL@(CNT,0)="</Security>"
+47 ; missing 'Mailbox' - note for future enhancement. Was not needed for CH certification.
+48 DO C
SET @GBL@(CNT,0)="<RxReferenceNumber>"_ERXHID_"</RxReferenceNumber>"
+49 IF $LENGTH(PON)
DO C
SET @GBL@(CNT,0)="<PrescriberOrderNumber>"_PON_"</PrescriberOrderNumber>"
+50 DO C
SET @GBL@(CNT,0)="</Header>"
+51 QUIT MID
+52 ; body header/footer
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
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
REQUEST(GBL,RETREC,REQREF) ;
+1 DO C
SET @GBL@(CNT,0)="<Request>"
+2 DO C
SET @GBL@(CNT,0)="<ReturnReceipt>"_RETREC_"</ReturnReceipt>"
+3 DO C
SET @GBL@(CNT,0)="<RequestReferenceNumber>"_REQREF_"</RequestReferenceNumber>"
+4 DO C
SET @GBL@(CNT,0)="</Request>"
+5 QUIT
VAPHARM(GBL,PSOSITE,PSOIEN) ;
+1 NEW F,F2,NCPID,NPI,SPEC,LNAME,FNAME,MNAME,SUFF,PREF,STNM,ADDL1,ADDL2,CITY,STATE,PLQ,TELE,UIENS
+2 NEW PHIEN,PHIENS,EXPHIEN,EXPHIENS,PHARDAT,PHARDAT,PSDAT,AREA,FTELE,FULLNM,PDAT,PHRMCIST,SIENS
+3 NEW EIEN,EIENS,CMNUM,ID,IDTYP,IDVAL,CMVAL,CMQUAL
+4 SET F=52.47
SET F2=52.48
+5 ; this is the vista pharmacy/pharmacist
+6 SET EIEN=$$GET1^DIQ(52.49,PSOIEN,2.5,"I")
+7 SET EIENS=EIEN_","
+8 SET PHIEN=$$GET1^DIQ(52.49,PSOIEN,2.2,"I")
+9 SET PHIENS=PHIEN_","
+10 DO GETS^DIQ(F,EIENS,"**","IE","PHARDAT")
+11 SET NCPID=$GET(PHARDAT(F,EIENS,.02,"E"))
+12 DO GETS^DIQ(F2,PHIENS,"**","IE","PHRMCIST")
+13 DO CONVXML^PSOERXX1("PHARDAT")
DO CONVXML^PSOERXX1("PHRMCIST")
+14 ;S FULLNM=$G(PHRMCIST(F2,UIENS,.01,"E"))
+15 SET LNAME=$GET(PHRMCIST(F2,PHIENS,.02,"E"))
+16 SET FNAME=$GET(PHRMCIST(F2,PHIENS,.03,"E"))
+17 SET MNAME=$GET(PHRMCIST(F2,PHIENS,.04,"E"))
+18 SET SUFF=$GET(PHRMCIST(F2,PHIENS,.05,"E"))
+19 SET PREF=$GET(PHRMCIST(F2,PHIENS,.06,"E"))
+20 SET NPI=$GET(PHRMCIST(F2,PHIENS,1.5,"E"))
+21 SET STNM=$GET(PHARDAT(F,EIENS,.01,"E"))
+22 SET ADDL1=$GET(PHARDAT(F,EIENS,1.1,"E"))
+23 SET ADDL2=$GET(PHARDAT(F,EIENS,1.2,"E"))
+24 SET CITY=$GET(PHARDAT(F,EIENS,1.3,"E"))
+25 SET STATE=$GET(PHARDAT(F,EIENS,1.4,"I"))
+26 SET STATE=$$STRES(STATE,PSOSITE)
+27 SET ZIP=$GET(PHARDAT(F,EIENS,1.5,"E"))
SET ZIP=$TRANSLATE(ZIP,"-","")
+28 ; address missing from NewRx
+29 IF '$LENGTH(ADDL1)
Begin DoDot:1
+30 SET ADDL1=$$GET1^DIQ(59,PSOSITE,.02,"E")
+31 SET ADDL2=""
+32 SET CITY=$$GET1^DIQ(59,PSOSITE,.07,"E")
+33 SET STATE=$$GET1^DIQ(59,PSOSITE,.08,"I")
+34 IF STATE
SET STATE=$$GET1^DIQ(5,STATE,1,"E")
+35 SET ZIP=$EXTRACT($$GET1^DIQ(59,PSOSITE,.05,"E"),1,5)
End DoDot:1
+36 DO C
SET @GBL@(CNT,0)="<Pharmacy>"
+37 IF $ORDER(^PS(52.47,EIEN,2,0))
Begin DoDot:1
+38 DO C
SET @GBL@(CNT,0)="<Identification>"
+39 SET ID=0
FOR
SET ID=$ORDER(^PS(52.47,EIEN,2,ID))
if 'ID
QUIT
Begin DoDot:2
+40 SET IDTYP=$$GET1^DIQ(52.472,ID_","_EIEN_",",.01,"E")
+41 SET IDVAL=$$GET1^DIQ(52.472,ID_","_EIEN_",",.02,"E")
+42 FOR VAR="IDTYP","IDVAL"
SET @VAR=$$SYMENC^MXMLUTL(@VAR)
+43 DO C
SET @GBL@(CNT,0)="<"_IDTYP_">"_IDVAL_"</"_IDTYP_">"
End DoDot:2
+44 DO C
SET @GBL@(CNT,0)="</Identification>"
End DoDot:1
+45 ;D C S @GBL@(CNT,0)="<Specialty>"_SPEC_"</Specialty>"
+46 IF $LENGTH(LNAME)
Begin DoDot:1
+47 DO C
SET @GBL@(CNT,0)="<Pharmacist>"
+48 IF $LENGTH(LNAME)
DO C
SET @GBL@(CNT,0)="<LastName>"_LNAME_"</LastName>"
+49 IF $LENGTH(FNAME)
DO C
SET @GBL@(CNT,0)="<FirstName>"_FNAME_"</FirstName>"
+50 IF $LENGTH(MNAME)
DO C
SET @GBL@(CNT,0)="<MiddleName>"_MNAME_"</MiddleName>"
+51 IF $LENGTH(SUFF)
DO C
SET @GBL@(CNT,0)="<Suffix>"_SUFF_"</Suffix>"
+52 IF $LENGTH(PREF)
DO C
SET @GBL@(CNT,0)="<Prefix>"_PREF_"</Prefix>"
+53 DO C
SET @GBL@(CNT,0)="</Pharmacist>"
End DoDot:1
+54 IF $LENGTH(STNM)
DO C
SET @GBL@(CNT,0)="<StoreName>"_STNM_"</StoreName>"
+55 IF $LENGTH(ADDL1)!($LENGTH(ADDL2))!($LENGTH(CITY))!($LENGTH(STATE))!($LENGTH(ZIP))
Begin DoDot:1
+56 DO C
SET @GBL@(CNT,0)="<Address>"
+57 IF $LENGTH(ADDL1)
DO C
SET @GBL@(CNT,0)="<AddressLine1>"_ADDL1_"</AddressLine1>"
+58 IF $LENGTH(ADDL2)
DO C
SET @GBL@(CNT,0)="<AddressLine2>"_ADDL2_"</AddressLine2>"
+59 IF $LENGTH(CITY)
DO C
SET @GBL@(CNT,0)="<City>"_CITY_"</City>"
+60 IF $LENGTH(STATE)
DO C
SET @GBL@(CNT,0)="<State>"_STATE_"</State>"
+61 IF $LENGTH(ZIP)
DO C
SET @GBL@(CNT,0)="<ZipCode>"_ZIP_"</ZipCode>"
+62 ;D C S @GBL@(CNT,0)="<PlaceLocationQualifier>"_PLQ_"</PlaceLocationQualifier>"
+63 DO C
SET @GBL@(CNT,0)="</Address>"
End DoDot:1
+64 IF '$ORDER(^PS(52.47,EIEN,3,0))
Begin DoDot:1
+65 SET CMVAL=$$GET1^DIQ(59,PSOIEN,.03,"E")
+66 SET CMVAL=CMVAL_$$GET1^DIQ(59,PSOIEN,.04,"E")
+67 IF '$LENGTH(CMVAL)
SET CMVAL="0000000000"
+68 SET CMVAL=$TRANSLATE(CMVAL,"-","")
+69 SET CMQUAL="TE"
+70 DO C
SET @GBL@(CNT,0)="<CommunicationNumbers>"
+71 DO COMMNUM(.GBL,CMVAL,CMQUAL)
+72 DO COMMNUM(.GBL,"0000000000","FX")
+73 DO C
SET @GBL@(CNT,0)="</CommunicationNumbers>"
End DoDot:1
+74 IF $ORDER(^PS(52.47,EIEN,3,0))
Begin DoDot:1
+75 DO C
SET @GBL@(CNT,0)="<CommunicationNumbers>"
+76 SET CMNUM=0
FOR
SET CMNUM=$ORDER(^PS(52.47,EIEN,3,CMNUM))
if 'CMNUM
QUIT
Begin DoDot:2
+77 SET CMVAL=$$GET1^DIQ(52.473,CMNUM_","_EIEN_",",.01,"E")
+78 SET CMQUAL=$$GET1^DIQ(52.473,CMNUM_","_EIEN_",",.02,"I")
+79 DO COMMNUM(.GBL,CMVAL,CMQUAL)
End DoDot:2
+80 DO C
SET @GBL@(CNT,0)="</CommunicationNumbers>"
End DoDot:1
+81 DO C
SET @GBL@(CNT,0)="</Pharmacy>"
+82 QUIT
+83 ; GBL - global for xml storage
+84 ; IENS - ien string for the current entry
+85 ; FIL - top level file number
+86 ; SUBFIL - subfile number
COMMNUM(GBL,COMMNUM,QUAL) ;
+1 DO C
SET @GBL@(CNT,0)="<Communication>"
+2 DO C
SET @GBL@(CNT,0)="<Number>"_$$SYMENC^MXMLUTL(COMMNUM)_"</Number>"
+3 DO C
SET @GBL@(CNT,0)="<Qualifier>"_$$SYMENC^MXMLUTL(QUAL)_"</Qualifier>"
+4 DO C
SET @GBL@(CNT,0)="</Communication>"
+5 QUIT
IDENT(GBL,TYPE,VAL) ;
+1 NEW VAR
+2 FOR VAR="TYPE","VAL"
SET @VAR=$$SYMENC^MXMLUTL(@VAR)
+3 DO C
SET @GBL@(CNT,0)="<"_TYPE_">"_VAL_"</"_TYPE_">"
+4 QUIT
+5 ; GBL - GLOBAL WHERE DATA IS STORED
+6 ; IEN - IEN TO 52.49
PRESCRIB(GBL,PSOSITE,IEN) ;
+1 NEW F,DEAN,NPI,SPEC,CLINIC,LNAME,FNAME,MNAME,SUFF,PREF,ADDL1,ADDL2,CITY,STATE,ZIP,PLQ,ALNAME,AFNAME,AMNAME,ASUFF,APREF
+2 NEW PSDAT,CLOOP,CNUM,CQUAL,ILOOP,ITYP,IVAL,PIEN,PIENS
+3 SET F=52.48
SET IENS=IEN_","
+4 SET PIEN=$$GET1^DIQ(52.49,IEN,2.1,"I")
if 'PIEN
QUIT
+5 SET PIENS=PIEN_","
+6 DO GETS^DIQ(F,PIENS,"**","IE","PSDAT")
+7 DO CONVXML^PSOERXX1("PSDAT")
+8 SET DEAN=$GET(PSDAT(F,PIENS,1.6,"E"))
+9 SET NPI=$GET(PSDAT(F,PIENS,1.5,"E"))
+10 SET SPEC=$GET(PSDAT(F,PIENS,1.2,"E"))
+11 SET CLINIC=$GET(PSDAT(F,PIENS,2.1,"E"))
+12 SET LNAME=$GET(PSDAT(F,PIENS,.02,"E"))
+13 SET FNAME=$GET(PSDAT(F,PIENS,.03,"E"))
+14 SET MNAME=$GET(PSDAT(F,PIENS,.04,"E"))
+15 SET SUFF=$GET(PSDAT(F,PIENS,.05,"E"))
+16 SET PREF=$GET(PSDAT(F,PIENS,.06,"E"))
+17 SET ADDL1=$GET(PSDAT(F,PIENS,4.1,"E"))
+18 SET ADDL2=$GET(PSDAT(F,PIENS,4.2,"E"))
+19 SET CITY=$GET(PSDAT(F,PIENS,4.3,"E"))
+20 SET STATE=$GET(PSDAT(F,PIENS,4.4,"I"))
+21 SET STATE=$$STRES(STATE,PSOSITE)
+22 SET ZIP=$GET(PSDAT(F,PIENS,4.5,"E"))
+23 SET PLQ=$GET(PSDAT(F,PIENS,2.2,"E"))
+24 SET ALNAME=$GET(PSDAT(F,PIENS,5.1,"E"))
+25 SET AFNAME=$GET(PSDAT(F,PIENS,5.2,"E"))
+26 SET AMNAME=$GET(PSDAT(F,PIENS,5.3,"E"))
+27 SET ASUFF=$GET(PSDAT(F,PIENS,5.4,"E"))
+28 SET APREF=$GET(PSDAT(F,PIENS,5.5,"E"))
+29 DO C
SET @GBL@(CNT,0)="<Prescriber>"
+30 IF $ORDER(^PS(52.48,PIEN,6,0))
Begin DoDot:1
+31 DO C
SET @GBL@(CNT,0)="<Identification>"
+32 SET ILOOP=0
FOR
SET ILOOP=$ORDER(^PS(52.48,PIEN,6,ILOOP))
if 'ILOOP
QUIT
Begin DoDot:2
+33 SET ITYP=$$GET1^DIQ(52.486,ILOOP_","_PIENS,.01,"E")
+34 SET IVAL=$$GET1^DIQ(52.486,ILOOP_","_PIENS,.02,"E")
+35 DO IDENT(.GBL,ITYP,IVAL)
End DoDot:2
+36 DO C
SET @GBL@(CNT,0)="</Identification>"
End DoDot:1
+37 ; ***SLASH AT THE END???
IF $LENGTH(SPEC)
DO C
SET @GBL@(CNT,0)="<Specialty>"_SPEC_"</Specialty>"
+38 ; ***SLASH AT THE END???
IF $LENGTH(CLINIC)
DO C
SET @GBL@(CNT,0)="<ClinicName>"_CLINIC_"</ClinicName>"
+39 DO C
SET @GBL@(CNT,0)="<Name>"
+40 IF $LENGTH(LNAME)
DO C
SET @GBL@(CNT,0)="<LastName>"_LNAME_"</LastName>"
+41 IF $LENGTH(FNAME)
DO C
SET @GBL@(CNT,0)="<FirstName>"_FNAME_"</FirstName>"
+42 IF $LENGTH(MNAME)
DO C
SET @GBL@(CNT,0)="<MiddleName>"_MNAME_"</MiddleName>"
+43 IF $LENGTH(SUFF)
DO C
SET @GBL@(CNT,0)="<Suffix>"_SUFF_"</Suffix>"
+44 IF $LENGTH(PREF)
DO C
SET @GBL@(CNT,0)="<Prefix>"_PREF_"</Prefix>"
+45 DO C
SET @GBL@(CNT,0)="</Name>"
+46 DO C
SET @GBL@(CNT,0)="<Address>"
+47 IF $LENGTH(ADDL1)
DO C
SET @GBL@(CNT,0)="<AddressLine1>"_ADDL1_"</AddressLine1>"
+48 IF $LENGTH(ADDL2)
DO C
SET @GBL@(CNT,0)="<AddressLine2>"_ADDL2_"</AddressLine2>"
+49 IF $LENGTH(CITY)
DO C
SET @GBL@(CNT,0)="<City>"_CITY_"</City>"
+50 IF $LENGTH(STATE)
DO C
SET @GBL@(CNT,0)="<State>"_STATE_"</State>"
+51 IF $LENGTH(ZIP)
DO C
SET @GBL@(CNT,0)="<ZipCode>"_ZIP_"</ZipCode>"
+52 IF $LENGTH(PLQ)
DO C
SET @GBL@(CNT,0)="<PlaceLocationQualifier>"_PLQ_"</PlaceLocationQualifier>"
+53 DO C
SET @GBL@(CNT,0)="</Address>"
+54 IF $ORDER(^PS(52.48,PIEN,3,0))
Begin DoDot:1
+55 DO C
SET @GBL@(CNT,0)="<CommunicationNumbers>"
+56 SET CLOOP=0
FOR
SET CLOOP=$ORDER(^PS(52.48,PIEN,3,CLOOP))
if 'CLOOP
QUIT
Begin DoDot:2
+57 SET CNUM=$$GET1^DIQ(52.483,CLOOP_","_PIENS,.01,"E")
+58 SET CQUAL=$$GET1^DIQ(52.483,CLOOP_","_PIENS,.02,"I")
+59 DO COMMNUM(.GBL,CNUM,CQUAL)
End DoDot:2
+60 DO C
SET @GBL@(CNT,0)="</CommunicationNumbers>"
End DoDot:1
+61 IF $LENGTH(ALNAME)
Begin DoDot:1
+62 DO C
SET @GBL@(CNT,0)="<PrescriberAgent>"
+63 IF $LENGTH(ALNAME)
DO C
SET @GBL@(CNT,0)="<LastName>"_ALNAME_"</LastName>"
+64 IF $LENGTH(AFNAME)
DO C
SET @GBL@(CNT,0)="<FirstName>"_AFNAME_"</FirstName>"
+65 IF $LENGTH(AMNAME)
DO C
SET @GBL@(CNT,0)="<MiddleName>"_AMNAME_"</MiddleName>"
+66 IF $LENGTH(ASUFF)
DO C
SET @GBL@(CNT,0)="<Suffix>"_ASUFF_"</Suffix>"
+67 IF $LENGTH(APREF)
DO C
SET @GBL@(CNT,0)="<Prefix>"_APREF_"</Prefix>"
+68 DO C
SET @GBL@(CNT,0)="</PrescriberAgent>"
End DoDot:1
+69 DO C
SET @GBL@(CNT,0)="</Prescriber>"
+70 QUIT
SUPERVIS(GBL,PSOSITE,IEN) ;
+1 NEW F,SLN,DEAN,SPEC,LNAME,FNAME,MNAME,SUFF,PREF,CLNAME,ADDL1,ADDL2,CITY,STATE,ZIP,PLQ,PSDAT,ILOOP,ITYP,IVAL
+2 NEW SIEN,SIENS
+3 SET F=52.48
+4 SET IENS=IEN_","
+5 SET SIEN=$$GET1^DIQ(52.49,IEN,2.6,"I")
if 'SIEN
QUIT
+6 SET SIENS=SIEN_","
+7 DO GETS^DIQ(F,SIENS,"**","IE","PSDAT")
+8 DO CONVXML^PSOERXX1("PSDAT")
+9 SET SLN=$GET(PSDAT(F,SIENS,1.8,"E"))
+10 SET DEAN=$GET(PSDAT(F,SIENS,1.6,"E"))
+11 SET SPEC=$GET(PSDAT(F,SIENS,1.2,"E"))
+12 SET LNAME=$GET(PSDAT(F,SIENS,.02,"E"))
+13 SET FNAME=$GET(PSDAT(F,SIENS,.03,"E"))
+14 SET MNAME=$GET(PSDAT(F,SIENS,.04,"E"))
+15 SET SUFF=$GET(PSDAT(F,SIENS,.05,"E"))
+16 SET PREF=$GET(PSDAT(F,SIENS,.06,"E"))
+17 SET CLNAME=$GET(PSDAT(F,SIENS,2.1,"E"))
+18 SET ADDL1=$GET(PSDAT(F,SIENS,4.1,"E"))
+19 SET ADDL2=$GET(PSDAT(F,SIENS,4.2,"E"))
+20 SET CITY=$GET(PSDAT(F,SIENS,4.3,"E"))
+21 SET STATE=$GET(PSDAT(F,SIENS,4.4,"I"))
+22 SET STATE=$$STRES(STATE)
+23 SET ZIP=$GET(PSDAT(F,SIENS,4.5,"E"))
+24 SET PLQ=$GET(PSDAT(F,SIENS,2.2,"E"))
+25 DO C
SET @GBL@(CNT,0)="<Supervisor>"
+26 IF $ORDER(^PS(52.48,SIEN,6,0))
Begin DoDot:1
+27 DO C
SET @GBL@(CNT,0)="<Identification>"
+28 SET ILOOP=0
FOR
SET ILOOP=$ORDER(^PS(52.48,SIEN,6,ILOOP))
if 'ILOOP
QUIT
Begin DoDot:2
+29 SET ITYP=$$GET1^DIQ(52.486,ILOOP_","_SIENS,.01,"E")
+30 SET IVAL=$$GET1^DIQ(52.486,ILOOP_","_SIENS,.02,"E")
+31 DO IDENT(.GBL,ITYP,IVAL)
End DoDot:2
+32 DO C
SET @GBL@(CNT,0)="</Identification>"
End DoDot:1
+33 DO C
SET @GBL@(CNT,0)="<Specialty>"_SPEC_"</Specialty>"
+34 DO C
SET @GBL@(CNT,0)="<Name>"
+35 DO C
SET @GBL@(CNT,0)="<LastName>"_LNAME_"</LastName>"
+36 DO C
SET @GBL@(CNT,0)="<FirstName>"_FNAME_"</FirstName>"
+37 DO C
SET @GBL@(CNT,0)="<MiddleName>"_MNAME_"</MiddleName>"
+38 DO C
SET @GBL@(CNT,0)="<Suffix>"_SUFF_"</Suffix>"
+39 DO C
SET @GBL@(CNT,0)="<Prefix>"_PREF_"</Prefix>"
+40 DO C
SET @GBL@(CNT,0)="</Name>"
+41 DO C
SET @GBL@(CNT,0)="<ClinicName>"_CLNAME_"</ClinicName>"
+42 DO C
SET @GBL@(CNT,0)="<Address>"
+43 DO C
SET @GBL@(CNT,0)="<AddressLine1>"_ADDL1_"</AddressLine1>"
+44 DO C
SET @GBL@(CNT,0)="<AddressLine2>"_ADDL2_"</AddressLine2>"
+45 DO C
SET @GBL@(CNT,0)="<City>"_CITY_"</City>"
+46 DO C
SET @GBL@(CNT,0)="<State>"_STATE_"</State>"
+47 IF $LENGTH(ZIP)
DO C
SET @GBL@(CNT,0)="<ZipCode>"_ZIP_"</ZipCode>"
+48 DO C
SET @GBL@(CNT,0)="<PlaceLocationQualifier>"_PLQ_"</PlaceLocationQualifier>"
+49 DO C
SET @GBL@(CNT,0)="</Address>"
+50 DO C
SET @GBL@(CNT,0)="<CommunicationNumbers>"
+51 SET CLOOP=0
FOR
SET CLOOP=$ORDER(^PS(52.48,SIEN,3,CLOOP))
if 'CLOOP
QUIT
Begin DoDot:1
+52 SET CNUM=$$GET1^DIQ(52.483,CLOOP_","_SIENS,.01,"E")
+53 SET CQUAL=$$GET1^DIQ(52.483,CLOOP_","_SIENS,.02,"I")
+54 DO COMMNUM(.GBL,CNUM,CQUAL)
End DoDot:1
+55 ; ***COMMUNICATION NUMBERS***
+56 DO C
SET @GBL@(CNT,0)="</CommunicationNumbers>"
+57 DO C
SET @GBL@(CNT,0)="</Supervisor>"
+58 QUIT
FACIL(GBL,PSOSITE,IENS) ;
+1 NEW F,NPI,NAME,ADDL1,ADDL2,CITY,STATE,ZIP,PLQ,PSDAT
+2 SET F=52.49
+3 ; FOR NOW, JUST BUILD HEADER AND FOOTER
+4 QUIT
+5 DO C
SET @GBL@(CNT,0)="<Facility>"
+6 DO C
SET @GBL@(CNT,0)="</Facility>"
+7 QUIT
+8 ; complete this as a future enhancement
+9 DO GETS^DIQ(F,IENS,"**","IE","PSDAT")
+10 DO CONVXML^PSOERXX1("PSDAT")
+11 SET NPI=$GET(PSDAT(F,IENS,1,"E"))
+12 SET NAME=$GET(PSDAT(F,IENS,1,"E"))
+13 SET ADDL1=$GET(PSDAT(F,IENS,1,"E"))
+14 SET ADDL2=$GET(PSDAT(F,IENS,1,"E"))
+15 SET CITY=$GET(PSDAT(F,IENS,1,"E"))
+16 SET STATE=$GET(PSDAT(F,IENS,1,"I"))
+17 SET STATE=$$STRES(STATE)
+18 SET ZIP=$GET(PSDAT(F,IENS,1,"E"))
+19 SET PLQ=$GET(PSDAT(F,IENS,1,"E"))
+20 DO C
SET @GBL@(CNT,0)="<Facility>"
+21 IF $LENGTH(NPI)
Begin DoDot:1
+22 DO C
SET @GBL@(CNT,0)="<Identification>"
+23 DO C
SET @GBL@(CNT,0)="<NPI>"_NPI_"<NPI>"
+24 DO C
SET @GBL@(CNT,0)="</Identification>"
End DoDot:1
+25 DO C
SET @GBL@(CNT,0)="<FacilityName>"_NAME_"</FacilityName>"
+26 DO C
SET @GBL@(CNT,0)="<Address>"
+27 DO C
SET @GBL@(CNT,0)="<AddressLine1>"_ADDL1_"</AddressLine1>"
+28 DO C
SET @GBL@(CNT,0)="<AddressLine2>"_ADDL2_"</AddressLine2>"
+29 DO C
SET @GBL@(CNT,0)="<City>"_CITY_"</City>"
+30 DO C
SET @GBL@(CNT,0)="<State>"_STATE_"</State>"
+31 IF $LENGTH(ZIP)
DO C
SET @GBL@(CNT,0)="<ZipCode>"_ZIP_"</ZipCode>"
+32 DO C
SET @GBL@(CNT,0)="<PlaceLocationQualifier>"_PLQ_"</PlaceLocationQualifier>"
+33 DO C
SET @GBL@(CNT,0)="</Address>"
+34 ;***COMMUNICATION NUMBERS
+35 DO C
SET @GBL@(CNT,0)="</Facility>"
+36 QUIT
C ;
+1 SET CNT=$GET(CNT)+1
+2 QUIT
STRES(STATE,PSOSITE) ;
+1 NEW SIEN
+2 SET SIEN=""
+3 IF STATE
SET SIEN=$$GET1^DIQ(5,STATE,1,"E")
QUIT SIEN
+4 ; if the state cannot be resolved, use the state from file 59
+5 IF 'SIEN
SET SIEN=$$GET1^DIQ(59,PSOSITE,.08,"I")
+6 ; if there is still no state, use the state from the physical address of the institution: IA 2171
+7 IF 'SIEN
SET SIEN=$PIECE($$PADD^XUAF4(DUZ(2)),U,3)
+8 QUIT SIEN