PSORWRAP ;AITC/BWF - Remote RX API wrapper ;12/12/16 3:21pm
;;7.0;OUTPATIENT PHARMACY;**454,475,541,559,643**;DEC 1997;Build 35
;External reference to ^HLCS(870 supported by DBIA 3550
;
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,PSO52P09,PSOROPAI
S (QTY,MW,DSUPP,RX0,RX2,RX3,RXSTA,RPROV,SIG,RPAR0,RREF0,RREF0,ROR1,RXFTYP)=""
S $ETRAP="D ^%ZTER Q"
S HLFS="^"
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),PSOROPAI=$P($P(HLNODE,HLFS,9),ORCS,2)
.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 Acknowledgement 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,PSOXSITE
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)
; build NTE for narrative from 59
S PSOXSITE=""
I ($G(TYPE)="RF"),($G(RREF0)]"") S PSOXSITE=$P(RREF0,U,9)
I ($G(TYPE)="PF"),($G(RPAR0)]"") S PSOXSITE=$P(RPAR0,U,9)
I (PSOXSITE=""),($G(RX2)]"") S PSOXSITE=$P(RX2,U,9)
I +PSOXSITE D NTE2SV^PSOHLDS5(.CNT,.NTECNT,PSOXSITE)
; build NTE for patch install flag (PSO*7*643 installed at Host site)
S CNT=CNT+1,NTECNT=NTECNT+1,^TMP("HLA",$J,CNT)="NTE"_HLFS_NTECNT_HLFS_HLFS_"PATCH INSTALLED FLAG"
; end label build
D BLDPID^PSOTPHL2(DFN,"",.PSORRDAT,.HL,.ERR)
S PSOIEN=$P(DAT(0),U,3)
S:'+$G(PSODFN) PSODFN=$$GET1^DIQ(52,PSOIEN,2,"I")
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,12)="~"_$G(RPROV) ; Provider
S $P(^TMP("HLA",$J,CNT),HLFS,14)=ORCS_ORCS_ORCS_$P($$SITE^VASITE(),U,3)
S $P(^TMP("HLA",$J,CNT),HLFS,15)=$P(RX2,U,2) ; Fill Date
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)_"::"_$G(PSO52P09) ;PSOIEN :: REFILL/PARTIAL IEN :: 52.09 IEN
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,12)=$P(DAT(0),U,8) ; Days Supply
S $P(^TMP("HLA",$J,CNT),HLFS,13)=$$GET1^DIQ(52,PSOIEN,11,"E") ; Routing (M/W)
S $P(^TMP("HLA",$J,CNT),HLFS,15)="~"_$$GET1^DIQ(55,$G(PSODFN),.02,"E") ; Safety Cap
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,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,PSORFIEN,PSOPFIEN) ;
;PSOIEN available when processing at the host site
N F,ERR,FDA,DATA,FILERR,NIEN,MSG,LBL,NARR,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,PSOONLAP,PSOOAP,PSOQPRT,PSODPRT,PSOSITE8,PSOPRANY,PSOLONLY
S DATA=$G(@HLDAT@(1))
I $D(@HLDAT@("FLAG")) S PSOHLSV("PATCH INSTALLED FLAG")=1
;
;Q:'+$P(DATA,U,7) ; no quantity dispensed. WCJ
;
I +$G(PSOIEN),'$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),PSOHLSV("LOG DATE/TIME"))=$$NOW^XLFDT
S (FDA(F,"+1,",.02),PSOHLSV("PATIENT DFN"))=$G(PSODFN)
S (FDA(F,"+1,",.03),PSOHLSV("RX NUMBER"))=$P(@HLDAT@(1),U,3)
S (FDA(F,"+1,",.04),PSOHLSV("SITE NUMBER"))=$$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),PSOHLSV("REQUEST TYPE"))=TYPE
I TYPE="PR"!(TYPE="RF") S (FDA(F,"+1,",.06),PSOHLSV("L_PHARMACIST"),PSOHLSV("OUT REQ PHARMACIST"))=$G(DUZ)
I TYPE="OR"!(TYPE="OP") S FDA(F,"+1,",.061)=$P(@HLDAT@(1),U,11)
I +$G(PSOHLSV("PATCH INSTALLED FLAG")) D
.S:TYPE="RF" (FDA(F,"+1,",.063))=$G(PSORFIEN)
.S:TYPE="PR" (FDA(F,"+1,",.064))=$G(PSOPFIEN)
I $G(PSOIEN)="" S FDA(F,"+1,",.065)=$G(PSOHLSV("HOST RX LOG IEN")) K PSOHLSV("HOST RX LOG IEN") ;Set 52.09 IEN of the Host at the Dispensing site only.
S (FDA(F,"+1,",.07),PSOHLSV("QUANTITY"))=$P(@HLDAT@(1),U,7)
S (FDA(F,"+1,",.08),PSOHLSV("DAYS SUPPLY"))=$P(@HLDAT@(1),U,10)
S FDA(F,"+1,",.09)=$P(@HLDAT@(1),U,12)
S:TYPE="RF" PSOHLSV("REFILL DT")=$P(@HLDAT@(1),U,12)
S:TYPE="PR" PSOHLSV("PARTIAL DT")=$P(@HLDAT@(1),U,12)
S FDA(F,"+1,",.1)=$P(@HLDAT@(1),U,8)
S (FDA(F,"+1,",1),PSOHLSV("REMOTE DRUG NAME"))=$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),PSOHLSV("L_DRUGIEN"))=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),PSOHLSV("VA PRODUCT ID"))=$$GET1^DIQ(50,LOCDRUG,22,"I")
I +$G(PSOHLSV("PATCH INSTALLED FLAG")),$G(DOMOVR) S FDA(F,"+1,",4.1)=DOMOVR ;only set at the dispensing site when host also had PSO*7*643 installed
D UPDATE^DIE(,"FDA","NIEN","FILERR")
;I $D(FILERR) D Q
;.; display error
S (NIEN,PSO52P09)=$G(NIEN(1)) S:$G(PSOIEN)="" PSOHLSV("RX LOG IEN")=NIEN
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 HLSAVE^PSOHLDS5(.LBL)
.D WP^DIE(52.09,NIEN_",",3,"K","LBL")
I $D(@HLDAT@("NARR")) D
.M NARR=@HLDAT@("NARR")
.D HLSVNTE^PSOHLDS5(.NARR)
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
S (PSOQPRT,PSOPRANY,PSOLONLY)=0 W ! K POP S %ZIS("B")="",%ZIS="QMN",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS
Q:POP ; User '^' out, Host site fill information has already been updated
S PSODPRT=IOS F PSOOAP=0:0 S PSOOAP=$O(^PS(59,PSOSITE,"P",PSOOAP)) Q:'PSOOAP!(PSOQPRT) S PSOPRANY=1 I +$P(^PS(59,PSOSITE,"P",PSOOAP,0),"^")=PSODPRT S PSOQPRT=1
I 'PSOQPRT D
.I 'PSOPRANY D Q
..S PSOSITE8=$G(^PS(59,PSOSITE,8))
..I $P(PSOSITE8,"^",5)'="",$P(PSOSITE8,"^",6)'="" Q
..S PSOLONLY=1
.S PSOLONLY=1
S PSOONLAP=$G(ION)
F DSAV="RX0","RX2","RX3","RXSTA","HINFO","RSIG","PSODFN","LOCDRUG","ROR1","RPAR0","RREF0","RFIEN","PARIEN","RIEN","PATST","PSOONLAP","PSOLONLY" 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)=""
S ZTSAVE("PSOHLSV(")=""
;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORWRAP 15495 printed Nov 22, 2024@17:44:22 Page 2
PSORWRAP ;AITC/BWF - Remote RX API wrapper ;12/12/16 3:21pm
+1 ;;7.0;OUTPATIENT PHARMACY;**454,475,541,559,643**;DEC 1997;Build 35
+2 ;External reference to ^HLCS(870 supported by DBIA 3550
+3 ;
+4 QUIT
PROCESS ;
+1 NEW I,NUM,HLQUIT,DONE,ORCS,ORRS,ORES,ORSS,RXFTYP,RXNUM,RXFDATE,PHINFO,PHDUZ,PHLN,PHFN,RFSITE,RPHONE,RPHARM,QTY,MW,DSUPP,REMARKS
+2 NEW HLFS,RET,RXIEN,ZD,RX0,RX2,RXSTA,RPROV,SIG,RPAR0,RREF0,RREF0,ROR1,RX3,PSO52P09,PSOROPAI
+3 SET (QTY,MW,DSUPP,RX0,RX2,RX3,RXSTA,RPROV,SIG,RPAR0,RREF0,RREF0,ROR1,RXFTYP)=""
+4 SET $ETRAP="D ^%ZTER Q"
+5 SET HLFS="^"
+6 SET ORCS=$EXTRACT($GET(HL("ECH")),1)
SET ORRS=$EXTRACT($GET(HL("ECH")),2)
SET ORES=$EXTRACT($GET(HL("ECH")),3)
SET ORSS=$EXTRACT($GET(HL("ECH")),4)
+7 SET (I,DONE,HLQUIT)=0
+8 FOR
XECUTE HLNEXT
if DONE!HLQUIT'>0
QUIT
Begin DoDot:1
+9 IF '$LENGTH($GET(HLNODE))
SET DONE=1
QUIT
+10 NEW LOOP
+11 SET LOOP=0
FOR
SET LOOP=$ORDER(HLNODE(LOOP))
if LOOP=""
QUIT
SET HLNODE=HLNODE_HLNODE(LOOP)
+12 IF $EXTRACT(HLNODE,1,3)="ORC"
Begin DoDot:2
+13 SET RXFTYP=$PIECE(HLNODE,HLFS,2)
SET RXNUM=$PIECE($PIECE(HLNODE,HLFS,3),ORCS)
SET RXFDATE=$PIECE(HLNODE,HLFS,10)
SET PHINFO=$PIECE(HLNODE,HLFS,11)
+14 SET PHDUZ=$PIECE(PHINFO,ORCS)
SET PHLN=$PIECE(PHINFO,ORCS,2)
SET PHFN=$PIECE(PHINFO,ORCS,3)
SET RFSITE=$PIECE($PIECE(HLNODE,HLFS,14),ORCS,4)
SET RPHONE=$PIECE(HLNODE,HLFS,15)
+15 SET RPHARM=PHLN_","_PHFN
End DoDot:2
+16 IF $EXTRACT(HLNODE,1,3)="RXO"
Begin DoDot:2
+17 SET QTY=$PIECE(HLNODE,HLFS,3)
SET MW=$PIECE($PIECE(HLNODE,HLFS,9),ORCS)
SET DSUPP=$PIECE(HLNODE,HLFS,12)
SET PSOROPAI=$PIECE($PIECE(HLNODE,HLFS,9),ORCS,2)
End DoDot:2
+18 IF $EXTRACT(HLNODE,1,3)="NTE"
Begin DoDot:2
+19 SET REMARKS=$PIECE(HLNODE,HLFS,4)
End DoDot:2
+20 SET I=I+1
End DoDot:1
+21 IF $GET(RXNUM)'=""
SET RXIEN=$ORDER(^PSRX("B",RXNUM,0))
+22 ; HL7 Request message apparently came to the wrong Rx Host site
+23 IF '$GET(RXIEN)
Begin DoDot:1
+24 SET RET(0)=0_U_$GET(RXNUM)_U_0_U_U_$GET(RXFDATE)
SET $PIECE(RET(0),U,15)=$GET(RPHARM)
SET $PIECE(RET(0),U,16)=$GET(RPHONE)
SET $PIECE(RET(0),U,17)=$GET(RSITE)
+25 SET RET(1)="The Rx #"_RXNUM_" does not belong to this facility ("_$PIECE($$SITE^VASITE(),"^",2)_"). Please,"
+26 SET RET(2)="try to place the fill request again. It may take up to 4 attempts to get a"
+27 SET RET(3)="successful response. If the issue continues, please contact IT Support for"
+28 SET RET(4)="assistance."
+29 SET RET(5)=""
+30 DO BLDACK(.RET,0,RXFTYP,RX0,RX2,RXSTA,RPROV,SIG,RREF0,RPAR0,ROR1,RX3)
End DoDot:1
QUIT
+31 ;
+32 SET DFN=$$GET1^DIQ(52,RXIEN,2,"I")
+33 IF RXFTYP="RF"
Begin DoDot:1
+34 DO REMREF^PSORREF(.RET,RXNUM,RXFDATE,MW,RPHARM,RPHONE,RFSITE,.RX0,.RX2,.RXSTA,.RPROV,.SIG,.RREF0,.ROR1,.RX3)
+35 DO BLDACK(.RET,DFN,RXFTYP,RX0,RX2,RXSTA,RPROV,SIG,RREF0,"",ROR1,RX3)
End DoDot:1
+36 IF RXFTYP="PF"
Begin DoDot:1
+37 DO PAR^PSORRPA1(.RET,RXNUM,RXFDATE,MW,QTY,DSUPP,REMARKS,RPHARM,RPHONE,RFSITE,.RX0,.RX2,.RXSTA,.RPROV,.SIG,.RPAR0,.ROR1,.RX3,.RREF0)
+38 DO BLDACK(.RET,DFN,RXFTYP,RX0,RX2,RXSTA,RPROV,SIG,RREF0,RPAR0,ROR1,RX3)
End DoDot:1
+39 QUIT
+40 ;
+41 ;Build Acknowledgement to show Rx was filled or in error
BLDACK(DAT,DFN,TYPE,RX0,RX2,RXSTA,RPROV,SIG,RREF0,RPAR0,ROR1,RX3) ;
+1 NEW CNT,PIDLP,DONE,PSOHCNT,PNAME,PLNAME,PFNAME,PSOIEN,LBLGLB,LBLOOP,NTECNT,DATLP,ERR,LBLGBL,LBLOVF,LBTXT,PSACKERR,PSORRDAT
+2 NEW NODE,HSITE,T,HSNAM,HMFSADD,HACODE,HPHONE,HMFSZIP,HSNUM,HCITY,HSTATE,OFNAME,OFADD,OFPHONE,NODEDAT,PSOXSITE
+3 SET (NTECNT,CNT)=0
+4 ; MSA segment
+5 KILL ^TMP("HLA",$JOB)
+6 SET CNT=CNT+1
SET ^TMP("HLA",$JOB,CNT)="MSA"_HLFS_"AA"_HLFS_$GET(HL("MID"))
+7 ; ERR segment if error
+8 IF $EXTRACT($GET(DAT(0)))=0
Begin DoDot:1
+9 NEW ERRSEG
+10 SET $PIECE(ERRSEG,HLFS)="ERR"
+11 ; error code - application internal error
SET $PIECE(ERRSEG,HLFS,4)=207
+12 ; severity - "E"rror
SET $PIECE(ERRSEG,HLFS,5)="E"
+13 ; User Message
SET $PIECE(ERRSEG,HLFS,9)="Unable to complete transaction"
+14 SET CNT=CNT+1
+15 SET ^TMP("HLA",$JOB,CNT)=ERRSEG
End DoDot:1
+16 ; NTE segment
+17 SET DATLP=0
FOR
SET DATLP=$ORDER(DAT(DATLP))
if 'DATLP
QUIT
Begin DoDot:1
+18 SET CNT=CNT+1
SET NTECNT=NTECNT+1
SET ^TMP("HLA",$JOB,CNT)="NTE"_HLFS_NTECNT_HLFS_"L"_HLFS_$GET(DAT(DATLP))
End DoDot:1
+19 SET LBLGBL=$PIECE($GET(DAT(0)),U,18)
+20 ; build label data into NTE segments
+21 IF $LENGTH(LBLGBL)
Begin DoDot:1
+22 SET LBLGBL=U_LBLGBL
+23 SET LBLOOP=0
FOR
SET LBLOOP=$ORDER(@LBLGBL@(LBLOOP))
if 'LBLOOP
QUIT
Begin DoDot:2
+24 SET LBTXT=$GET(@LBLGBL@(LBLOOP,0))
+25 IF $DATA(@LBLGBL@(LBLOOP,"OVF"))
Begin DoDot:3
+26 SET LBLOVF=0
FOR
SET LBLOVF=$ORDER(@LBLGBL@(LBLOOP,"OVF",LBLOVF))
if 'LBLOVF
QUIT
Begin DoDot:4
+27 SET LBTXT=$GET(LBTXT)_$GET(@LBLGBL@(LBLOOP,"OVF",LBLOVF,0))
End DoDot:4
End DoDot:3
+28 SET CNT=CNT+1
SET NTECNT=NTECNT+1
SET ^TMP("HLA",$JOB,CNT)="NTE"_HLFS_NTECNT_HLFS_"O"_HLFS_$GET(LBTXT)
End DoDot:2
End DoDot:1
+29 ; build NTE for narrative from 59
+30 SET PSOXSITE=""
+31 IF ($GET(TYPE)="RF")
IF ($GET(RREF0)]"")
SET PSOXSITE=$PIECE(RREF0,U,9)
+32 IF ($GET(TYPE)="PF")
IF ($GET(RPAR0)]"")
SET PSOXSITE=$PIECE(RPAR0,U,9)
+33 IF (PSOXSITE="")
IF ($GET(RX2)]"")
SET PSOXSITE=$PIECE(RX2,U,9)
+34 IF +PSOXSITE
DO NTE2SV^PSOHLDS5(.CNT,.NTECNT,PSOXSITE)
+35 ; build NTE for patch install flag (PSO*7*643 installed at Host site)
+36 SET CNT=CNT+1
SET NTECNT=NTECNT+1
SET ^TMP("HLA",$JOB,CNT)="NTE"_HLFS_NTECNT_HLFS_HLFS_"PATCH INSTALLED FLAG"
+37 ; end label build
+38 DO BLDPID^PSOTPHL2(DFN,"",.PSORRDAT,.HL,.ERR)
+39 SET PSOIEN=$PIECE(DAT(0),U,3)
+40 if '+$GET(PSODFN)
SET PSODFN=$$GET1^DIQ(52,PSOIEN,2,"I")
+41 SET PNAME=$$GET1^DIQ(52,PSOIEN,2,"E")
+42 SET PLNAME=$PIECE(PNAME,",")
SET PFNAME=$PIECE($PIECE(PNAME,",",2)," ")
+43 SET DONE=0
+44 SET CNT=CNT+1
+45 ; build PID segment
+46 FOR PSOHCNT=1:1
Begin DoDot:1
+47 IF '$DATA(PSORRDAT(PSOHCNT))
SET DONE=1
QUIT
+48 SET ^TMP("HLA",$JOB,CNT)=$GET(^TMP("HLA",$JOB,CNT))_PSORRDAT(PSOHCNT)
End DoDot:1
if DONE
QUIT
+49 SET CNT=CNT+1
+50 SET HSITE=$PIECE(RX2,U,9)
+51 SET HSNAM=$$GET1^DIQ(59,HSITE,.01,"E")
+52 SET HMFSADD=$$GET1^DIQ(59,HSITE,.02,"E")
+53 SET HACODE=$$GET1^DIQ(59,HSITE,.03,"E")
+54 SET HPHONE=$$GET1^DIQ(59,HSITE,.04,"E")
+55 SET HMFSZIP=$$GET1^DIQ(59,HSITE,.05,"E")
+56 SET HSNUM=$$GET1^DIQ(59,HSITE,.06,"E")
+57 SET HCITY=$$GET1^DIQ(59,HSITE,.07,"E")
+58 SET HSTATE=$$GET1^DIQ(59,HSITE,.08,"I")
SET HSTATE=$$GET1^DIQ(5,HSTATE,1,"E")
+59 SET T="~"
+60 SET OFNAME=HSNAM
+61 SET OFADD=HMFSADD_T_T_HCITY_T_HSTATE_T_HMFSZIP
+62 SET OFPHONE=HACODE_"-"_HPHONE
+63 ;
+64 ; build ORC segment
+65 ;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")
+66 SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,1)="ORC"
+67 SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,2)=TYPE
+68 SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,3)=$PIECE(DAT(0),U,2)_ORCS_$PIECE(DAT(0),U,17)_ORCS_$$FQDN(,$PIECE(DAT(0),U,17))
+69 SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,10)=$PIECE(DAT(0),U,5)
+70 SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,11)=DFN_ORCS_PLNAME_ORCS_PFNAME
+71 ; Provider
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,12)="~"_$GET(RPROV)
+72 SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,14)=ORCS_ORCS_ORCS_$PIECE($$SITE^VASITE(),U,3)
+73 ; Fill Date
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,15)=$PIECE(RX2,U,2)
+74 ; Issue Date
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,16)=$PIECE(RX0,U,13)
+75 ; seq #1
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,20)="P"_ORCS_$$GET1^DIQ(200,$PIECE(RX0,U,16),.01)
+76 ; seq #2
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,20)=$PIECE(^TMP("HLA",$JOB,CNT),HLFS,20)_ORRS_"VP"_ORCS_$$GET1^DIQ(200,$PIECE(RX2,U,10),.01)
+77 ;
+78 IF $GET(RREF0)]""
Begin DoDot:1
+79 ; seq #3
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,20)=$PIECE(^TMP("HLA",$JOB,CNT),HLFS,20)_ORRS_"C"_ORCS_$$GET1^DIQ(200,$PIECE(RREF0,U,7),.01)
+80 ; seq #4
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,20)=$PIECE(^TMP("HLA",$JOB,CNT),HLFS,20)_ORRS_"RP"_ORCS_$$GET1^DIQ(200,$PIECE(RREF0,U,17),.01)
End DoDot:1
+81 ;
+82 IF $GET(RPAR0)]""
Begin DoDot:1
+83 ; seq #3
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,20)=$PIECE(^TMP("HLA",$JOB,CNT),HLFS,20)_ORRS_"C"_ORCS_$$GET1^DIQ(200,$PIECE(RPAR0,U,7),.01)
+84 ; seq #4
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,20)=$PIECE(^TMP("HLA",$JOB,CNT),HLFS,20)_ORRS_"PP"_ORCS_$$GET1^DIQ(200,$PIECE(RPAR0,U,17),.01)
End DoDot:1
+85 ;
+86 ; seq #5
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,20)=$PIECE(^TMP("HLA",$JOB,CNT),HLFS,20)_ORRS_"FP"_ORCS_$$GET1^DIQ(200,$PIECE(ROR1,U,5),.01)
+87 NEW DATA
+88 ; Clinic
SET $PIECE(DATA,ORSS,2)=$$GET1^DIQ(44,$PIECE(RX0,U,5),.01)
+89 SET $PIECE(OFNAME,ORCS,8)=DATA
+90 SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,22)=OFNAME
+91 SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,23)=OFADD
+92 SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,24)=OFPHONE
+93 ; Rx Status (ex - 1 ACTIVE)
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,26)=$$GET1^DIQ(52,PSOIEN,100,"I")_ORCS_$$GET1^DIQ(52,PSOIEN,100,"E")_ORCS_ORCS_$$GET1^DIQ(53,$PIECE(RX0,U,3),2)_ORCS_$$GET1^DIQ(53,$PIECE(RX0,U,3),.01)
+94 ; Last dispense date in ORC-27 Fillers expected availability date
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,28)=$PIECE(RX3,U)
+95 SET CNT=CNT+1
+96 ;
+97 ; build RXD segment
+98 ;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)
+99 SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,1)="RXD"
+100 SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,2)=1
+101 SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,3)=$PIECE(DAT(0),U,6)_ORCS_"NDC"
+102 ; Fill date
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,4)=$PIECE(DAT(0),U,5)
+103 ; Quantity
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,5)=$PIECE(DAT(0),U,7)
+104 ;PSOIEN :: REFILL/PARTIAL IEN :: 52.09 IEN
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,8)=$PIECE(DAT(0),U,3)_"::"_$PIECE(DAT(0),U,4)_"::"_$GET(PSO52P09)
+105 ; # of refills remaining
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,9)=$$GET1^DIQ(52,PSOIEN,9,"I")
+106 ; Dispensing Pharmacy
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,11)=$PIECE(DAT(0),U,15)
+107 ; Days Supply
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,12)=$PIECE(DAT(0),U,8)
+108 ; Routing (M/W)
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,13)=$$GET1^DIQ(52,PSOIEN,11,"E")
+109 ; Safety Cap
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,15)="~"_$$GET1^DIQ(55,$GET(PSODFN),.02,"E")
+110 ; SIGs
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,16)=$$GET1^DIQ(52,PSOIEN,10.1,"I")_ORCS_$$GET1^DIQ(52,PSOIEN,10,"I")
+111 IF $DATA(^PSRX(PSOIEN,"SIG1",1))
Begin DoDot:1
+112 NEW SIG1CNT
+113 SET SIG1CNT=0
FOR
SET SIG1CNT=$ORDER(^PSRX(PSOIEN,"SIG1",SIG1CNT))
if 'SIG1CNT
QUIT
Begin DoDot:2
+114 SET DATA="SIG1_"_SIG1CNT_ORCS_$GET(^PSRX(PSOIEN,"SIG1",SIG1CNT,0))
+115 SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,16)=$PIECE(^TMP("HLA",$JOB,CNT),HLFS,16)_ORRS_DATA
End DoDot:2
End DoDot:1
+116 ; Rx expiration date
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,20)=$PIECE(RX2,U,6)
+117 ;
+118 ; Number of copies into DISPENSE PACKAGE SIZE
SET $PIECE(^TMP("HLA",$JOB,CNT),HLFS,23)=$PIECE(RX0,U,18)
+119 ;
+120 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PSACKERR)
+121 KILL ^TMP("HLA",$JOB)
+122 QUIT
LABEL(RX,PSOLAP,PSOSITE,DUZ,PSOTRAMT,FNAME) ; Print the label.
+1 ; Input: RX -- Pointer to the prescription in file #52
+2 ; PSOLAP -- Label printer
+3 ; PSOSITE -- Pointer to the Pharmacy in file #59
+4 ; DUZ -- Pointer to the use in file #200
+5 ; PSOTRAMT -- Amount to be paid
+6 ;
+7 ;
+8 if PSOLAP["LAT-TERM"
QUIT
+9 if '$DATA(^PSRX(RX,0))
QUIT
+10 if '$DATA(^PS(59,PSOSITE,0))
QUIT
+11 NEW CT,II,III,NOW,RXFF,X,Y,PSOSYS,PSOPAR,PSOBARS,PDUZ,PSOBAR0,PSOBAR1,PSOCHAMP,PSHRX,DIQUIET
+12 SET DIQUIET=1
DO DT^DICRW
+13 IF '$GET(DT)
SET DT=$$DT^XLFDT
+14 ;S:$P($G(^PSRX(RX,"STA")),"^")'=3 REPRINT=""
+15 ;
IO DO SAVDEV^%ZISUTL("ONEVAHLIO")
+1 NEW PAR
SET PAR="0"
+2 SET PAR("HFSNAME")=FNAME
SET PAR("HFSMODE")="W"
+3 DO OPEN^%ZISUTL("ONEVALABEL",PSOLAP,.PAR)
+4 if POP
QUIT
+5 ;
+6 NEW PSOONEVA
+7 DO USE^%ZISUTL("ONEVALABEL")
+8 NEW PSOIOS
SET PSOIOS=IOS
DO DEVBAR^PSOBMST
+9 SET PSOSYS=$GET(^PS(59,PSOSITE,1))
+10 SET PSOPAR=$GET(^PS(59,PSOSITE,1))
SET PDUZ=DUZ
+11 SET PPL=RX
+12 ; The PSOONEVA variable will identify a OneVA Pharmacy label request from a Remote Site
+13 SET (PSOCHAMP,PSOONEVA)=1
+14 SET PSOBARS=PSOBAR1]""&(PSOBAR0]"")&($PIECE(PSOPAR,"^",19))
+15 DO DQ^PSOLBL
+16 DO CLOSE^%ZISUTL("ONEVALABEL")
+17 DO RMDEV^%ZISUTL("ONEVALABEL")
+18 KILL PPL
+19 ;
+20 QUIT
+21 ; log information about the refill or partial fill locally for reporting
+22 ;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,PSORFIEN,PSOPFIEN) ;
+1 ;PSOIEN available when processing at the host site
+2 NEW F,ERR,FDA,DATA,FILERR,NIEN,MSG,LBL,NARR,TMPIEN,REFREM,LIEN,LDCOST,TCOST,DSAV,DSAV2,RRFTYP,RRXPR,RRXFL,RPPL
+3 NEW RX0,RX2,RX3,RXSTA,HINFO,RSIG,ROR1,RPAR0,RREF0,RFIEN,PARIEN,RIEN,PATST,RSIG1,PSOONLAP,PSOOAP,PSOQPRT,PSODPRT,PSOSITE8,PSOPRANY,PSOLONLY
+4 SET DATA=$GET(@HLDAT@(1))
+5 IF $DATA(@HLDAT@("FLAG"))
SET PSOHLSV("PATCH INSTALLED FLAG")=1
+6 ;
+7 ;Q:'+$P(DATA,U,7) ; no quantity dispensed. WCJ
+8 ;
+9 IF +$GET(PSOIEN)
IF '$GET(PSODFN)
SET PSODFN=$$GET1^DIQ(52,PSOIEN,2,"I")
+10 SET F=52.09
+11 ;set up FDA and file data
+12 SET (FDA(F,"+1,",.01),PSOHLSV("LOG DATE/TIME"))=$$NOW^XLFDT
+13 SET (FDA(F,"+1,",.02),PSOHLSV("PATIENT DFN"))=$GET(PSODFN)
+14 SET (FDA(F,"+1,",.03),PSOHLSV("RX NUMBER"))=$PIECE(@HLDAT@(1),U,3)
+15 SET (FDA(F,"+1,",.04),PSOHLSV("SITE NUMBER"))=$$FIND1^DIC(4,,"X",$PIECE(@HLDAT@(1),U,4),"D","I $P(^(0),U,11)=""N"",'$P($G(^(99)),U,4)")
+16 SET (FDA(F,"+1,",.05),PSOHLSV("REQUEST TYPE"))=TYPE
+17 IF TYPE="PR"!(TYPE="RF")
SET (FDA(F,"+1,",.06),PSOHLSV("L_PHARMACIST"),PSOHLSV("OUT REQ PHARMACIST"))=$GET(DUZ)
+18 IF TYPE="OR"!(TYPE="OP")
SET FDA(F,"+1,",.061)=$PIECE(@HLDAT@(1),U,11)
+19 IF +$GET(PSOHLSV("PATCH INSTALLED FLAG"))
Begin DoDot:1
+20 if TYPE="RF"
SET (FDA(F,"+1,",.063))=$GET(PSORFIEN)
+21 if TYPE="PR"
SET (FDA(F,"+1,",.064))=$GET(PSOPFIEN)
End DoDot:1
+22 ;Set 52.09 IEN of the Host at the Dispensing site only.
IF $GET(PSOIEN)=""
SET FDA(F,"+1,",.065)=$GET(PSOHLSV("HOST RX LOG IEN"))
KILL PSOHLSV("HOST RX LOG IEN")
+23 SET (FDA(F,"+1,",.07),PSOHLSV("QUANTITY"))=$PIECE(@HLDAT@(1),U,7)
+24 SET (FDA(F,"+1,",.08),PSOHLSV("DAYS SUPPLY"))=$PIECE(@HLDAT@(1),U,10)
+25 SET FDA(F,"+1,",.09)=$PIECE(@HLDAT@(1),U,12)
+26 if TYPE="RF"
SET PSOHLSV("REFILL DT")=$PIECE(@HLDAT@(1),U,12)
+27 if TYPE="PR"
SET PSOHLSV("PARTIAL DT")=$PIECE(@HLDAT@(1),U,12)
+28 SET FDA(F,"+1,",.1)=$PIECE(@HLDAT@(1),U,8)
+29 SET (FDA(F,"+1,",1),PSOHLSV("REMOTE DRUG NAME"))=$PIECE(@HLDAT@(1),U,9)
+30 ; local drug will not be passed in if this is an OF or OR type.
+31 IF $GET(LOCDRUG)
Begin DoDot:1
+32 SET (FDA(F,"+1,",1.1),PSOHLSV("L_DRUGIEN"))=LOCDRUG
+33 SET QTY=$PIECE(@HLDAT@(1),U,7)
if 'QTY
QUIT
+34 SET LDCOST=$$GET1^DIQ(50,LOCDRUG,16,"I")
if LDCOST=""
QUIT
+35 SET TCOST=QTY*LDCOST
+36 SET FDA(F,"+1,",1.2)=TCOST
+37 SET (FDA(F,"+1,",1.3),PSOHLSV("VA PRODUCT ID"))=$$GET1^DIQ(50,LOCDRUG,22,"I")
End DoDot:1
+38 ;only set at the dispensing site when host also had PSO*7*643 installed
IF +$GET(PSOHLSV("PATCH INSTALLED FLAG"))
IF $GET(DOMOVR)
SET FDA(F,"+1,",4.1)=DOMOVR
+39 DO UPDATE^DIE(,"FDA","NIEN","FILERR")
+40 ;I $D(FILERR) D Q
+41 ;.; display error
+42 SET (NIEN,PSO52P09)=$GET(NIEN(1))
if $GET(PSOIEN)=""
SET PSOHLSV("RX LOG IEN")=NIEN
+43 SET MSG(1)=$PIECE(@HLDAT@(1),U)
+44 DO WP^DIE(52.09,NIEN_",",2,"K","MSG")
+45 SET RRFTYP=TYPE
+46 ;*541
IF $GET(PSORXMM)
QUIT
+47 ; if you have a label, store it in the log and print it out.
+48 IF $DATA(@HLDAT@("LBL"))
Begin DoDot:1
+49 MERGE LBL=@HLDAT@("LBL")
+50 DO HLSAVE^PSOHLDS5(.LBL)
+51 DO WP^DIE(52.09,NIEN_",",3,"K","LBL")
End DoDot:1
+52 IF $DATA(@HLDAT@("NARR"))
Begin DoDot:1
+53 MERGE NARR=@HLDAT@("NARR")
+54 DO HLSVNTE^PSOHLDS5(.NARR)
End DoDot:1
+55 NEW %ZIS,ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK,ZTREQ,RRXPR,RRXFL,RPPL
+56 IF TYPE="PR"
SET RRXPR($GET(@HLDAT@("RIEN")))=1
+57 IF TYPE="RF"
SET RRXFL($GET(@HLDAT@("RIEN")))=1
+58 SET RPPL=$GET(@HLDAT@("RIEN"))
+59 IF 'RPPL
QUIT
+60 SET RPPL=RPPL_","
+61 ; default to Queueing this
NEW IOP
SET IOP="Q"
+62 SET (PSOQPRT,PSOPRANY,PSOLONLY)=0
WRITE !
KILL POP
SET %ZIS("B")=""
SET %ZIS="QMN"
SET %ZIS("A")="Select LABEL DEVICE: "
DO ^%ZIS
+63 ; User '^' out, Host site fill information has already been updated
if POP
QUIT
+64 SET PSODPRT=IOS
FOR PSOOAP=0:0
SET PSOOAP=$ORDER(^PS(59,PSOSITE,"P",PSOOAP))
if 'PSOOAP!(PSOQPRT)
QUIT
SET PSOPRANY=1
IF +$PIECE(^PS(59,PSOSITE,"P",PSOOAP,0),"^")=PSODPRT
SET PSOQPRT=1
+65 IF 'PSOQPRT
Begin DoDot:1
+66 IF 'PSOPRANY
Begin DoDot:2
+67 SET PSOSITE8=$GET(^PS(59,PSOSITE,8))
+68 IF $PIECE(PSOSITE8,"^",5)'=""
IF $PIECE(PSOSITE8,"^",6)'=""
QUIT
+69 SET PSOLONLY=1
End DoDot:2
QUIT
+70 SET PSOLONLY=1
End DoDot:1
+71 SET PSOONLAP=$GET(ION)
+72 FOR DSAV="RX0","RX2","RX3","RXSTA","HINFO","RSIG","PSODFN","LOCDRUG","ROR1","RPAR0","RREF0","RFIEN","PARIEN","RIEN","PATST","PSOONLAP","PSOLONLY"
Begin DoDot:1
+73 MERGE @DSAV=@HLDAT@(DSAV)
+74 SET ZTSAVE(DSAV)=""
End DoDot:1
+75 MERGE RSIG1=@HLDAT@("RSIG1")
+76 FOR DSAV2="PSOSITE","PSODFN","PSOPAR","PSOSYS","RRFTYP","RRXFL(","RRXPR(","RSIG1(","RPPL"
Begin DoDot:1
+77 SET ZTSAVE(DSAV2)=""
End DoDot:1
+78 SET ZTSAVE("PSOHLSV(")=""
+79 ;I '$G(IO("Q")) K ZTSAVE D DQ^PSORLLLI,^%ZISC Q
+80 ; if you made it here, they picked a queueable device to queue this to
+81 ;S ZTRTN="RRXLBL^PSORWRAP"
+82 SET ZTDESC="OneVA label print"
SET ZTDTH=$HOROLOG
+83 SET ZTRTN="DQ^PSORLLLI"
+84 DO ^%ZTLOAD
+85 IF $DATA(ZTSK)[0
WRITE !!?5,"Problems queuing label!"
+86 IF '$TEST
WRITE !!?5,"Label queued!"
+87 DO HOME^%ZIS
KILL IO("Q")
QUIT
+88 QUIT
+89 ;
RRXLBL ;Remote RX Label print
+1 NEW LBLLOOP,LBLTXT
+2 USE IO
+3 SET LBLOOP=0
FOR
SET LBLOOP=$ORDER(LBL(LBLOOP))
if 'LBLOOP
QUIT
Begin DoDot:1
+4 SET LBTXT=$GET(LBL(LBLOOP))
+5 WRITE !,LBTXT
End DoDot:1
+6 DO ^%ZISC
+7 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+8 QUIT
+9 ;
FQDN(SITE,IEN4) ; get Fully Qualified Domain Name
+1 ;
+2 ; Need site # or institution file IEN
IF $GET(IEN4)=""
IF $GET(SITE)=""
QUIT ""
+3 ;
+4 IF $GET(IEN4)=""
Begin DoDot:1
+5 SET IEN4=$$FIND1^DIC(4,,"X",SITE,"D","I $P(^(0),U,11)=""N"",'$P($G(^(99)),U,4)")
End DoDot:1
if $GET(IEN4)=""
QUIT ""
+6 ;
+7 NEW PSOHLNK,RMSDOM
+8 ; get first entry (should only be one but you never know) IA#3550
SET PSOHLNK=$ORDER(^HLCS(870,"C",IEN4,0))
+9 if '$GET(PSOHLNK)
QUIT ""
+10 ;
+11 ; get domain name IA#3335
SET RMSDOM=$$GET1^DIQ(870,PSOHLNK,.03,"E")
+12 if $GET(RMSDOM)=""
QUIT ""
+13 ;
+14 ; prefix domain name
if $$PROD^XUPROD()
SET RMSDOM="HL7."_RMSDOM
+15 QUIT RMSDOM
