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

PSORWRAP.m

Go to the documentation of this file.
PSORWRAP ;AITC/BWF - Remote RX API wrapper ;12/12/16 3:21pm
 ;;7.0;OUTPATIENT PHARMACY;**454,475,541,559**;DEC 1997;Build 2
 ;
 Q
PROCESS ;
 N I,NUM,HLQUIT,DONE,ORCS,ORRS,ORES,ORSS,RXFTYP,RXNUM,RXFDATE,PHINFO,PHDUZ,PHLN,PHFN,RFSITE,RPHONE,RPHARM,QTY,MW,DSUPP,REMARKS
 N HLFS,RET,RXIEN,ZD,RX0,RX2,RXSTA,RPROV,SIG,RPAR0,RREF0,RREF0,ROR1,RX3
 S (QTY,MW,DSUPP,RX0,RX2,RX3,RXSTA,RPROV,SIG,RPAR0,RREF0,RREF0,ROR1,RXFTYP)=""
 S $ETRAP="D ^%ZTER Q"
 S HLFS=HL("FS")
 S ORCS=$E($G(HL("ECH")),1),ORRS=$E($G(HL("ECH")),2),ORES=$E($G(HL("ECH")),3),ORSS=$E($G(HL("ECH")),4)
 S (I,DONE,HLQUIT)=0
 F  X HLNEXT Q:DONE!HLQUIT'>0  D
 .I '$L($G(HLNODE)) S DONE=1 Q
 .N LOOP
 .S LOOP=0 F  S LOOP=$O(HLNODE(LOOP)) Q:LOOP=""  S HLNODE=HLNODE_HLNODE(LOOP)
 .I $E(HLNODE,1,3)="ORC" D
 ..S RXFTYP=$P(HLNODE,HLFS,2),RXNUM=$P($P(HLNODE,HLFS,3),ORCS),RXFDATE=$P(HLNODE,HLFS,10),PHINFO=$P(HLNODE,HLFS,11)
 ..S PHDUZ=$P(PHINFO,ORCS),PHLN=$P(PHINFO,ORCS,2),PHFN=$P(PHINFO,ORCS,3),RFSITE=$P($P(HLNODE,HLFS,14),ORCS,4),RPHONE=$P(HLNODE,HLFS,15)
 ..S RPHARM=PHLN_","_PHFN
 .I $E(HLNODE,1,3)="RXO" D
 ..S QTY=$P(HLNODE,HLFS,3),MW=$P($P(HLNODE,HLFS,9),ORCS),DSUPP=$P(HLNODE,HLFS,12)
 .I $E(HLNODE,1,3)="NTE" D
 ..S REMARKS=$P(HLNODE,HLFS,4)
 .S I=I+1
 I $G(RXNUM)'="" S RXIEN=$O(^PSRX("B",RXNUM,0))
 ; HL7 Request message apparently came to the wrong Rx Host site 
 I '$G(RXIEN) D  Q
 .S RET(0)=0_U_$G(RXNUM)_U_0_U_U_$G(RXFDATE),$P(RET(0),U,15)=$G(RPHARM),$P(RET(0),U,16)=$G(RPHONE),$P(RET(0),U,17)=$G(RSITE)
 .S RET(1)="The Rx #"_RXNUM_" does not belong to this facility ("_$P($$SITE^VASITE(),"^",2)_"). Please,"
 .S RET(2)="try to place the fill request again. It may take up to 4 attempts to get a"
 .S RET(3)="successful response. If the issue continues, please contact IT Support for"
 .S RET(4)="assistance."
 .S RET(5)=""
 .D BLDACK(.RET,0,RXFTYP,RX0,RX2,RXSTA,RPROV,SIG,RREF0,RPAR0,ROR1,RX3)
 ;
 S DFN=$$GET1^DIQ(52,RXIEN,2,"I")
 I RXFTYP="RF" D
 .D REMREF^PSORREF(.RET,RXNUM,RXFDATE,MW,RPHARM,RPHONE,RFSITE,.RX0,.RX2,.RXSTA,.RPROV,.SIG,.RREF0,.ROR1,.RX3)
 .D BLDACK(.RET,DFN,RXFTYP,RX0,RX2,RXSTA,RPROV,SIG,RREF0,"",ROR1,RX3)
 I RXFTYP="PF" D
 .D PAR^PSORRPA1(.RET,RXNUM,RXFDATE,MW,QTY,DSUPP,REMARKS,RPHARM,RPHONE,RFSITE,.RX0,.RX2,.RXSTA,.RPROV,.SIG,.RPAR0,.ROR1,.RX3,.RREF0)
 .D BLDACK(.RET,DFN,RXFTYP,RX0,RX2,RXSTA,RPROV,SIG,RREF0,RPAR0,ROR1,RX3)
 Q
 ;
 ;Build Acknowlegement to show Rx was filled or in error
BLDACK(DAT,DFN,TYPE,RX0,RX2,RXSTA,RPROV,SIG,RREF0,RPAR0,ROR1,RX3) ;
 N CNT,PIDLP,DONE,PSOHCNT,PNAME,PLNAME,PFNAME,PSOIEN,LBLGLB,LBLOOP,NTECNT,DATLP,ERR,LBLGBL,LBLOVF,LBTXT,PSACKERR,PSORRDAT
 N NODE,HSITE,T,HSNAM,HMFSADD,HACODE,HPHONE,HMFSZIP,HSNUM,HCITY,HSTATE,OFNAME,OFADD,OFPHONE,NODEDAT
 S (NTECNT,CNT)=0
 ; MSA segment
 K ^TMP("HLA",$J)
 S CNT=CNT+1,^TMP("HLA",$J,CNT)="MSA"_HLFS_"AA"_HLFS_$G(HL("MID"))
 ; ERR segment if error
 I $E($G(DAT(0)))=0 D
 .N ERRSEG
 .S $P(ERRSEG,HLFS)="ERR"
 .S $P(ERRSEG,HLFS,4)=207  ; error code - application internal error
 .S $P(ERRSEG,HLFS,5)="E"  ; severity - "E"rror
 .S $P(ERRSEG,HLFS,9)="Unable to complete transaction" ; User Message
 .S CNT=CNT+1
 .S ^TMP("HLA",$J,CNT)=ERRSEG
 ; NTE segment
 S DATLP=0 F  S DATLP=$O(DAT(DATLP)) Q:'DATLP  D
 .S CNT=CNT+1,NTECNT=NTECNT+1,^TMP("HLA",$J,CNT)="NTE"_HLFS_NTECNT_HLFS_"L"_HLFS_$G(DAT(DATLP))
 S LBLGBL=$P($G(DAT(0)),U,18)
 ; build label data into NTE segments
 I $L(LBLGBL) D
 .S LBLGBL=U_LBLGBL
 .S LBLOOP=0 F  S LBLOOP=$O(@LBLGBL@(LBLOOP)) Q:'LBLOOP  D
 ..S LBTXT=$G(@LBLGBL@(LBLOOP,0))
 ..I $D(@LBLGBL@(LBLOOP,"OVF")) D
 ...S LBLOVF=0 F  S LBLOVF=$O(@LBLGBL@(LBLOOP,"OVF",LBLOVF)) Q:'LBLOVF  D
 ....S LBTXT=$G(LBTXT)_$G(@LBLGBL@(LBLOOP,"OVF",LBLOVF,0))
 ..S CNT=CNT+1,NTECNT=NTECNT+1,^TMP("HLA",$J,CNT)="NTE"_HLFS_NTECNT_HLFS_"O"_HLFS_$G(LBTXT)
 ; end label build
 D BLDPID^PSOTPHL2(DFN,"",.PSORRDAT,.HL,.ERR)
 S PSOIEN=$P(DAT(0),U,3)
 S PNAME=$$GET1^DIQ(52,PSOIEN,2,"E")
 S PLNAME=$P(PNAME,","),PFNAME=$P($P(PNAME,",",2)," ")
 S DONE=0
 S CNT=CNT+1
 ; build PID segment
 F PSOHCNT=1:1 D  Q:DONE
 .I '$D(PSORRDAT(PSOHCNT)) S DONE=1 Q
 .S ^TMP("HLA",$J,CNT)=$G(^TMP("HLA",$J,CNT))_PSORRDAT(PSOHCNT)
 S CNT=CNT+1
 S HSITE=$P(RX2,U,9)
 S HSNAM=$$GET1^DIQ(59,HSITE,.01,"E")
 S HMFSADD=$$GET1^DIQ(59,HSITE,.02,"E")
 S HACODE=$$GET1^DIQ(59,HSITE,.03,"E")
 S HPHONE=$$GET1^DIQ(59,HSITE,.04,"E")
 S HMFSZIP=$$GET1^DIQ(59,HSITE,.05,"E")
 S HSNUM=$$GET1^DIQ(59,HSITE,.06,"E")
 S HCITY=$$GET1^DIQ(59,HSITE,.07,"E")
 S HSTATE=$$GET1^DIQ(59,HSITE,.08,"I"),HSTATE=$$GET1^DIQ(5,HSTATE,1,"E")
 S T="~"
 S OFNAME=HSNAM
 S OFADD=HMFSADD_T_T_HCITY_T_HSTATE_T_HMFSZIP
 S OFPHONE=HACODE_"-"_HPHONE
 ;
 ; build ORC segment
 ;S ^TMP("HLA",$J,CNT)="ORC"_HLFS_TYPE_HLFS_$P(DAT(0),U,2)_ORCS_$P(DAT(0),U,17)_ORCS_$$GET1^DIQ(4,$P(DAT(0),U,17),60,"E")
 S $P(^TMP("HLA",$J,CNT),HLFS,1)="ORC"
 S $P(^TMP("HLA",$J,CNT),HLFS,2)=TYPE
 S $P(^TMP("HLA",$J,CNT),HLFS,3)=$P(DAT(0),U,2)_ORCS_$P(DAT(0),U,17)_ORCS_$$FQDN(,$P(DAT(0),U,17))
 S $P(^TMP("HLA",$J,CNT),HLFS,10)=$P(DAT(0),U,5)
 S $P(^TMP("HLA",$J,CNT),HLFS,11)=DFN_ORCS_PLNAME_ORCS_PFNAME
 S $P(^TMP("HLA",$J,CNT),HLFS,14)=ORCS_ORCS_ORCS_$P($$SITE^VASITE(),U,3)
 S $P(^TMP("HLA",$J,CNT),HLFS,16)=$P(RX0,U,13) ; Issue Date
 S $P(^TMP("HLA",$J,CNT),HLFS,20)="P"_ORCS_$$GET1^DIQ(200,$P(RX0,U,16),.01)   ; seq #1
 S $P(^TMP("HLA",$J,CNT),HLFS,20)=$P(^TMP("HLA",$J,CNT),HLFS,20)_ORRS_"VP"_ORCS_$$GET1^DIQ(200,$P(RX2,U,10),.01)  ; seq #2
 ;
 I $G(RREF0)]"" D
 .S $P(^TMP("HLA",$J,CNT),HLFS,20)=$P(^TMP("HLA",$J,CNT),HLFS,20)_ORRS_"C"_ORCS_$$GET1^DIQ(200,$P(RREF0,U,7),.01)  ; seq #3
 .S $P(^TMP("HLA",$J,CNT),HLFS,20)=$P(^TMP("HLA",$J,CNT),HLFS,20)_ORRS_"RP"_ORCS_$$GET1^DIQ(200,$P(RREF0,U,17),.01)   ; seq #4
 ;
 I $G(RPAR0)]"" D
 .S $P(^TMP("HLA",$J,CNT),HLFS,20)=$P(^TMP("HLA",$J,CNT),HLFS,20)_ORRS_"C"_ORCS_$$GET1^DIQ(200,$P(RPAR0,U,7),.01)  ; seq #3
 .S $P(^TMP("HLA",$J,CNT),HLFS,20)=$P(^TMP("HLA",$J,CNT),HLFS,20)_ORRS_"PP"_ORCS_$$GET1^DIQ(200,$P(RPAR0,U,17),.01)   ; seq #4
 ;
 S $P(^TMP("HLA",$J,CNT),HLFS,20)=$P(^TMP("HLA",$J,CNT),HLFS,20)_ORRS_"FP"_ORCS_$$GET1^DIQ(200,$P(ROR1,U,5),.01)   ; seq #5
 N DATA
 S $P(DATA,ORSS,2)=$$GET1^DIQ(44,$P(RX0,U,5),.01)  ; Clinic 
 S $P(OFNAME,ORCS,8)=DATA
 S $P(^TMP("HLA",$J,CNT),HLFS,22)=OFNAME
 S $P(^TMP("HLA",$J,CNT),HLFS,23)=OFADD
 S $P(^TMP("HLA",$J,CNT),HLFS,24)=OFPHONE
 S $P(^TMP("HLA",$J,CNT),HLFS,26)=$$GET1^DIQ(52,PSOIEN,100,"I")_ORCS_$$GET1^DIQ(52,PSOIEN,100,"E")_ORCS_ORCS_$$GET1^DIQ(53,$P(RX0,U,3),2)_ORCS_$$GET1^DIQ(53,$P(RX0,U,3),.01)  ; Rx Status (ex - 1 ACTIVE)
 S $P(^TMP("HLA",$J,CNT),HLFS,28)=$P(RX3,U)  ; Last dispense date in ORC-27 Fillers expected availability date
 S CNT=CNT+1
 ;
 ; build RXD segment
 ;S ^TMP("HLA",$J,CNT)="RXD"_HLFS_1_HLFS_$P(DAT(0),U,6)_ORCS_"NDC"_HLFS_$P(DAT(0),U,5)_HLFS_$P(DAT(0),U,7)
 S $P(^TMP("HLA",$J,CNT),HLFS,1)="RXD"
 S $P(^TMP("HLA",$J,CNT),HLFS,2)=1
 S $P(^TMP("HLA",$J,CNT),HLFS,3)=$P(DAT(0),U,6)_ORCS_"NDC"
 S $P(^TMP("HLA",$J,CNT),HLFS,4)=$P(DAT(0),U,5) ; Fill date
 S $P(^TMP("HLA",$J,CNT),HLFS,5)=$P(DAT(0),U,7) ; Quantity
 S $P(^TMP("HLA",$J,CNT),HLFS,8)=$P(DAT(0),U,3)_"::"_$P(DAT(0),U,4)
 S $P(^TMP("HLA",$J,CNT),HLFS,9)=$$GET1^DIQ(52,PSOIEN,9,"I") ; # of refills remaining
 S $P(^TMP("HLA",$J,CNT),HLFS,11)=$P(DAT(0),U,15) ; Dispensing Pharmacy
 S $P(^TMP("HLA",$J,CNT),HLFS,13)=$P(DAT(0),U,8) ; Days Supply
 S $P(^TMP("HLA",$J,CNT),HLFS,16)=$$GET1^DIQ(52,PSOIEN,10.1,"I")_ORCS_$$GET1^DIQ(52,PSOIEN,10,"I") ; SIGs
 I $D(^PSRX(PSOIEN,"SIG1",1)) D
 .N SIG1CNT
 .S SIG1CNT=0 F  S SIG1CNT=$O(^PSRX(PSOIEN,"SIG1",SIG1CNT)) Q:'SIG1CNT  D
 ..S DATA="SIG1_"_SIG1CNT_ORCS_$G(^PSRX(PSOIEN,"SIG1",SIG1CNT,0))
 ..S $P(^TMP("HLA",$J,CNT),HLFS,16)=$P(^TMP("HLA",$J,CNT),HLFS,16)_ORRS_DATA
 S $P(^TMP("HLA",$J,CNT),HLFS,20)=$P(RX2,U,6)  ; Rx expiration date
 ;
 S $P(^TMP("HLA",$J,CNT),HLFS,23)=$P(RX0,U,18) ; Number of copies into DISPENSE PACKAGE SIZE
 ;
 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PSACKERR)
 K ^TMP("HLA",$J)
 Q
LABEL(RX,PSOLAP,PSOSITE,DUZ,PSOTRAMT,FNAME) ; Print the label.
 ;  Input:        RX  --  Pointer to the prescription in file #52
 ;            PSOLAP  --  Label printer
 ;           PSOSITE  --  Pointer to the Pharmacy in file #59
 ;               DUZ  --  Pointer to the use in file #200
 ;          PSOTRAMT  --  Amount to be paid
 ;
 ;
 Q:PSOLAP["LAT-TERM"
 Q:'$D(^PSRX(RX,0))
 Q:'$D(^PS(59,PSOSITE,0))
 N CT,II,III,NOW,RXFF,X,Y,PSOSYS,PSOPAR,PSOBARS,PDUZ,PSOBAR0,PSOBAR1,REPRINT,PSOCHAMP,PSHRX,DIQUIET
 S DIQUIET=1 D DT^DICRW
 I '$G(DT) S DT=$$DT^XLFDT
 S:$P($G(^PSRX(RX,"STA")),"^")'=3 REPRINT=""
 ;
IO D SAVDEV^%ZISUTL("ONEVAHLIO")
 N PAR S PAR="0"
 S PAR("HFSNAME")=FNAME,PAR("HFSMODE")="W"
 D OPEN^%ZISUTL("ONEVALABEL",PSOLAP,.PAR)
 Q:POP
 ;
 N PSOONEVA
 D USE^%ZISUTL("ONEVALABEL")
 N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
 S PSOSYS=$G(^PS(59,PSOSITE,1))
 S PSOPAR=$G(^PS(59,PSOSITE,1)),PDUZ=DUZ
 S PPL=RX
 ; The PSOONEVA variable will identify a OneVA Pharmacy label request from a Remote Site
 S (PSOCHAMP,PSOONEVA)=1
 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&($P(PSOPAR,"^",19))
 D DQ^PSOLBL
 D CLOSE^%ZISUTL("ONEVALABEL")
 D RMDEV^%ZISUTL("ONEVALABEL")
 K PPL
 ;
 Q
 ; log information about the refill or partial fill locally for reporting
 ;HLDAT(1)=MESSAGE^PATIENT DFN^RX NUMBER^REMOTE SITE#^FILL/PARTIAL DATE^PHARMACIST NAME^QUANTITY^DISPENSE DATE^DRUG NAME^DAYS SUPPLY
LOGDATA(HLDAT,TYPE,LOCDRUG,LBLGBL,PSOIEN) ;
 N F,ERR,FDA,DATA,FILERR,NIEN,MSG,LBL,TMPIEN,REFREM,LIEN,LDCOST,TCOST,DSAV,DSAV2,RRFTYP,RRXPR,RRXFL,RPPL
 N RX0,RX2,RX3,RXSTA,HINFO,RSIG,ROR1,RPAR0,RREF0,RFIEN,PARIEN,RIEN,PATST,RSIG1
 S DATA=$G(@HLDAT@(1))
 ;
 ;Q:'+$P(DATA,U,7)  ; no quantity dispensed. WCJ
 ;
 I '$G(PSODFN) S PSODFN=$$GET1^DIQ(52,PSOIEN,2,"I")
 S F=52.09
 ;set up FDA and file data
 S FDA(F,"+1,",.01)=$$NOW^XLFDT
 S FDA(F,"+1,",.02)=PSODFN
 S FDA(F,"+1,",.03)=$P(@HLDAT@(1),U,3)
 S FDA(F,"+1,",.04)=$$FIND1^DIC(4,,"X",$P(@HLDAT@(1),U,4),"D","I $P(^(0),U,11)=""N"",'$P($G(^(99)),U,4)")
 S FDA(F,"+1,",.05)=TYPE
 I TYPE="PR"!(TYPE="RF") S FDA(F,"+1,",.06)=$G(DUZ)
 I TYPE="OR"!(TYPE="OP") S FDA(F,"+1,",.061)=$P(@HLDAT@(1),U,11)
 S FDA(F,"+1,",.07)=$P(@HLDAT@(1),U,7)
 S FDA(F,"+1,",.08)=$P(@HLDAT@(1),U,10)
 S FDA(F,"+1,",.09)=$P(@HLDAT@(1),U,12)
 S FDA(F,"+1,",.1)=$P(@HLDAT@(1),U,8)
 S FDA(F,"+1,",1)=$P(@HLDAT@(1),U,9)
 ; local drug will not be passed in if this is an OF or OR type.
 I $G(LOCDRUG) D
 .S FDA(F,"+1,",1.1)=LOCDRUG
 .S QTY=$P(@HLDAT@(1),U,7) Q:'QTY
 .S LDCOST=$$GET1^DIQ(50,LOCDRUG,16,"I") Q:LDCOST=""
 .S TCOST=QTY*LDCOST
 .S FDA(F,"+1,",1.2)=TCOST
 .S FDA(F,"+1,",1.3)=$$GET1^DIQ(50,LOCDRUG,22,"I")
 D UPDATE^DIE(,"FDA","NIEN","FILERR")
 ;I $D(FILERR) D  Q
 ;.; display error
 S NIEN=$G(NIEN(1))
 S MSG(1)=$P(@HLDAT@(1),U)
 D WP^DIE(52.09,NIEN_",",2,"K","MSG")
 S RRFTYP=TYPE
 I $G(PSORXMM) Q  ;*541
 ;
 ; if you have a label, store it in the log and print it out.
 I $D(@HLDAT@("LBL")) D
 .M LBL=@HLDAT@("LBL")
 .D WP^DIE(52.09,NIEN_",",3,"K","LBL")
 N %ZIS,ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK,ZTREQ,RRXPR,RRXFL,RPPL
 I TYPE="PR" S RRXPR($G(@HLDAT@("RIEN")))=1
 I TYPE="RF" S RRXFL($G(@HLDAT@("RIEN")))=1
 S RPPL=$G(@HLDAT@("RIEN"))
 I 'RPPL Q
 S RPPL=RPPL_","
 N IOP S IOP="Q"  ; default to Queueing this
 W ! K POP S %ZIS("B")="",%ZIS("S")="I $$GET1^DIQ(3.5,Y,3,""I""),$D(^%ZIS(2,$$GET1^DIQ(3.5,Y,3,""I""),55,""B"",""LL""))",%ZIS="QMN",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS
 Q:POP  ; do not pass GO, do not collect $200 - User wants out - sad cause RX was already filled
 ;I '$G(IO("Q")) D RRXLBL Q  ; user really didn't want to queue it and overrode that
 ;I $P(RSIG,U)="" S $P(RSIG,U)=$G(RSIGSTR)
 F DSAV="RX0","RX2","RX3","RXSTA","HINFO","RSIG","PSODFN","LOCDRUG","ROR1","RPAR0","RREF0","RFIEN","PARIEN","RIEN","PATST" D
 .M @DSAV=@HLDAT@(DSAV)
 .S ZTSAVE(DSAV)=""
 M RSIG1=@HLDAT@("RSIG1")
 F DSAV2="PSOSITE","PSODFN","PSOPAR","PSOSYS","RRFTYP","RRXFL(","RRXPR(","RSIG1(","RPPL" D
 .S ZTSAVE(DSAV2)=""
 ;I '$G(IO("Q")) K ZTSAVE D DQ^PSORLLLI,^%ZISC Q
 ; if you made it here, they picked a queueable device to queue this to
 ;S ZTRTN="RRXLBL^PSORWRAP"
 S ZTDESC="OneVA label print",ZTDTH=$H
 S ZTRTN="DQ^PSORLLLI"
 D ^%ZTLOAD
 I $D(ZTSK)[0 W !!?5,"Problems queuing label!"
 E  W !!?5,"Label queued!"
 D HOME^%ZIS K IO("Q") Q
 Q
 ;
RRXLBL ;Remote RX Label print
 N LBLLOOP,LBLTXT
 U IO
 S LBLOOP=0 F  S LBLOOP=$O(LBL(LBLOOP)) Q:'LBLOOP  D
 .S LBTXT=$G(LBL(LBLOOP))
 .W !,LBTXT
 D ^%ZISC
 S:$D(ZTQUEUED) ZTREQ="@"
 Q
 ;
FQDN(SITE,IEN4) ; get Fully Qualified Domain Name
 ;
 I $G(IEN4)="",$G(SITE)="" Q ""  ; Need site # or institution file IEN
 ;
 I $G(IEN4)="" D  Q:$G(IEN4)="" ""
 .S IEN4=$$FIND1^DIC(4,,"X",SITE,"D","I $P(^(0),U,11)=""N"",'$P($G(^(99)),U,4)")
 ;
 N PSOHLNK,RMSDOM
 S PSOHLNK=$O(^HLCS(870,"C",IEN4,0)) ; get first entry (should only be one but you never know) IA#3550
 Q:'$G(PSOHLNK) ""
 ;
 S RMSDOM=$$GET1^DIQ(870,PSOHLNK,.03,"E")  ; get domain name IA#3335
 Q:$G(RMSDOM)="" ""
 ;
 S:$$PROD^XUPROD() RMSDOM="HL7."_RMSDOM   ; prefix domain name
 Q RMSDOM