PSORREF ;AITC/BWF,RBD - Remote RX retrieval API ;12 Dec 2024 4:27 PM
;;7.0;OUTPATIENT PHARMACY;**454,475,497,643,740,774**;DEC 1997;Build 15
;
Q
; RET - return data
; RXNUM - RX Number from remote system
; FDATE - Fill Date
; MW - Mail/Window - Default of 'W' for now.
; RPHARM - Pharmacist from remote site
; RPHONE - Contact number
; RSITE - Filling site number
;
REMREF(RET,RXNUM,FDATE,MW,RPHARM,RPHONE,RSITE,RX0,RX2,RXSTA,RPROV,RSIG,RREF0,ROR1,RX3) ;
;
N MSG,BACK,PSOPAR,RRXIEN,PSOSIEN,DSUPP,LASTREF,XTMPLOC,PASSLOC,HFSIEN,FULLPTH,HFSDONE,PTHDAT,PTHPIECE,FOUND,STRT,STATION,FTGOPEN,PPL1,PSOSITE
N PSOX,PTHFILE,SITENUM,X,X1,X2,HDRUG,CSVAL,PSISSDT,TFILLS,OFFSET,CHKDT,DINACT,DEL,FTGSTRT,PDIR,PFIL,PSODTCUT,PSOEXREP,PSOPHDUZ
N PSODFDIR,PSOFNAME,PAR,DELARR,RREFIEN
N PSOBBC,PSOBBC1,PSODIR,PSOMVH,CLOZVAL,NOONEVA
; check 3rd party payer rejects. Send message to initiating site if applicable.
S $ETRAP="D ^%ZTER Q"
S RET(0)=""
S RRXIEN=$O(^PSRX("B",RXNUM,0)),PSOSIEN=$$GET1^DIQ(52,RRXIEN,20,"I")
I '$$GET1^DIQ(59.7,1,101,"I") D Q
.S RET(1)="The OneVA pharmacy flag is turned 'OFF' at this facility."
.S RET(2)="Unable to process refill/partial fill requests."
.D RET0
; PSO*7*497 - trade name block/titration block
I $$GET1^DIQ(52,RRXIEN,6.5,"E")]"" D Q
.D RET0
.S RET(1)="This prescription cannot be refilled or partial filled because it has a value"
.S RET(2)="entered in the Rx trade name field. Please follow local policy for obtaining"
.S RET(3)="a new prescription."
I $$TITRX^PSOUTL(RRXIEN)="t" S RET(1)="Cannot refill prescription - type is Titration. You may request a partial fill." D RET0 Q
; PSO*7*497 - end trade name/titration block
N PSOOFILL S PSOOFILL=$$ORGFILL(RRXIEN) ; Set Orig. Fill Flag - RBD *774
S PSOPHDUZ=$$FIND1^DIC(200,,"M","PSOAPPLICATIONPROXY,PSO") I 'PSOPHDUZ S PSOPHDUZ=.5 ; RBD *774 Always set PSOPHDUZ to PSOAPPLICATIONPROXY,PSO
S HDRUG=$$GET1^DIQ(52,RRXIEN,6,"I")
I '$$VALIDDRUG(HDRUG) D RET0 Q ;Validate entry in file 50
S PSOPAR=$G(^PS(59,PSOSIEN,1)),PSOSITE=PSOSIEN
S RPHONE=$G(RPHONE,"")
; check to see if this action will throw the prescription into suspense. If so, quit and return a message
S DSUPP=$$GET1^DIQ(52,RRXIEN,8,"I")
S X2=-120,X1=DT D C^%DTC S PSODTCUT=X
S (PSODFN,PSOREF("PSODFN"))=$$GET1^DIQ(52,RRXIEN,2,"I") K PSOSD D ^PSOBUILD
N RXN K PSORX("FILL DATE") S PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$O(^PSRX("B",RXNUM,0)),PSOREF("QFLG")=0
I $$LMREJ^PSOREJU1(RXNUM,,.MSG,.BACK) S RET(1)=MSG D RET0 Q
S PSORX("FILL DATE")=FDATE
K PSOID D START^PSORREF1(FDATE) I PSOREF("DFLG") D EOJ Q
; check ability to refill given issue date/days supply
S PSISSDT=$$GET1^DIQ(52,RRXIEN,1,"I")
S TFILLS=$O(^PSRX(RRXIEN,1,"A"),-1)+1
S OFFSET=DSUPP*TFILLS,OFFSET=OFFSET-10
S CHKDT=$$FMADD^XLFDT(PSISSDT,OFFSET)
; First check if not Orig. Fill before checking Next Possible Fill Date - RBD *774
I 'PSOOFILL,PSORX("FILL DATE")<CHKDT D RET0 S RET(1)="Cannot refill Rx# "_RXNUM_". Next possible fill date is "_$$FMTE^XLFDT(CHKDT,"5D") Q
I PSORX("FILL DATE")>$$GET1^DIQ(52,RRXIEN,26,"I") D RET0 S RET(1)="Cannot refill Rx# "_RXNUM_".",RET(2)="Cannot refill after expiration date "_$$GET1^DIQ(52,RRXIEN,11,"E") Q
; For Original Fill, Check if Fill Date before Issue Date - RBD *774
I PSOOFILL,PSORX("FILL DATE")<PSISSDT D Q
. D RET0 S RET(1)="Cannot fill Rx# "_RXNUM_"."
. S RET(2)="Cannot fill before issue date "_$$GET1^DIQ(52,RRXIEN,1,"E")
D PROCESS^PSORREF0(.RET)
; make sure not errors are returned
I $D(RET(1)) D EOJ Q
; Persist Orig. Fill - RBD *774
I PSOOFILL D ; Use FILE^DIE in lieu of ^DIE - RBD *774
. K FDA N PSORXIENS S PSORXIENS=RRXIEN_",",FDA(52,PSORXIENS,22)=PSORX("FILL DATE")
. D FILE^DIE(,"FDA","PSOERR") K FDA N DA S DA=RRXIEN
. N PSOFLLDT S PSOFLLDT=$E(PSORX("FILL DATE"),4,5)_"/"_$E(PSORX("FILL DATE"),6,7)
. S PSOFLLDT=PSOFLLDT_"/"_$E(PSORX("FILL DATE"),2,3)
. N PSOCOM S PSOCOM=$P(^DD(52,22,0),"^")_" ("_PSOFLLDT_")"
. N PSOK,PSOD1,PSOZ S PSOK=1,PSOD1=0
. F PSOZ=0:0 S PSOZ=$O(^PSRX(DA,"A",PSOZ)) Q:'PSOZ S PSOD1=PSOZ,PSOK=PSOK+1
. S PSOD1=PSOD1+1
. S:'($D(^PSRX(DA,"A",0))#2) ^(0)="^52.3DA^^^" S ^(0)=$P(^(0),U,1,2)_U_PSOD1_U_PSOK
. D NOW^%DTC S ^PSRX(DA,"A",PSOD1,0)=$P(%,".")_"^E^"_$G(PSOPHDUZ)_"^0^"_PSOCOM ; RBD *774 Removed Timestamp
. K % N PSOX,PSOX1,X1,X2,X
. S PSOX("RX0")=^PSRX(DA,0),PSOX("RX2")=^PSRX(DA,2),PSOX("RX3")=^PSRX(DA,3)
. S PSOX1=$P(PSOX("RX2"),U,2),$P(PSOX("RX3"),U)=PSOX1,X1=PSOX1
. S X2=$P(PSOX("RX0"),U,8)-10\1 D C^%DTC
. S:'$P(PSOX("RX3"),U,8) $P(PSOX("RX3"),U,2)=X
. S FDA(52,PSORXIENS,101)=$P(PSOX("RX3"),U),FDA(52,PSORXIENS,102)=$P(PSOX("RX3"),U,2)
. S FDA(52,PSORXIENS,11)="W" ; RBD *774 Field 23 (PHARMACIST) no longer set to PSOPHDUZ (since it is a local field)
. D FILE^DIE(,"FDA","PSOERR") K FDA
. ; RBD *774 Call ECME for claims generation and transmission (emulate ECME code from PSON52)
. I $$SUBMIT^PSOBPSUT(RRXIEN,0) D
.. D ECMESND^PSOBPSU1(RRXIEN,0,"","OF")
.. ; Quit if there is an unresolved Tricare/CHAMPVA non-billable reject code
.. I $$PSOET^PSOREJP3(RRXIEN,0) Q
.. I $$STATUS^PSOBPSUT(RRXIEN,0)="E PAYABLE" D
... D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,RRXIEN,6,"I"),$G(PSOSITE),$$GETNDC^PSONDCUT(RRXIEN,0))
I '$D(RET(1)) D
.; bwf 8/14/14 - set up needed variables for label printing
.S PSODFN=$P(^PSRX(RRXIEN,0),U,2)
.S PSORX("IRXN")=RXNUM
.S PSORX("PSOL",1)=RRXIEN_","
.S PSORX("MAIL/WINDOW")="WINDOW"
.S PSORX("NAME")=$$GET1^DIQ(2,PSODFN,.01)
.S PSORX("QFLG")=0
.S PSORX("METHOD OF PICKUP")=""
.S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^")
.S PPL1=RRXIEN
.; bwf 8/14/14 - end setup for label printing.
.S PSODFDIR=$$DEFDIR^%ZISH()
.S PSOFNAME="PSOLBL_"_RXNUM_"_"_PSOSITE_"_"_DT_".DAT"
.S FULLPTH=PSODFDIR_PSOFNAME
.S HFSDONE=0,PTHDAT=""
.; preserve IO
.D SAVDEV^%ZISUTL("ONEVAHLIO")
.S DELARR("PSOLBL_"_RXNUM_"_"_PSOSITE_"_"_DT_".DAT")="" S DEL=$$DEL^%ZISH(PSODFDIR,$NA(DELARR))
.S PSOEXREP=1
.; call out to generate label
.D LABEL^PSORWRAP(RRXIEN,"HFS",PSOSITE,PSOPHDUZ,"",PSOFNAME)
.S XTMPLOC="^XTMP(""PSORLBL"","_HLINSTN_","_+RXNUM_",1,0)"
.S PASSLOC="XTMP(""PSORLBL"","_HLINSTN_","_+RXNUM_")"
.K ^XTMP("PSORLBL",HLINSTN,+RXNUM,0)
.S ^XTMP("PSORLBL",HLINSTN,+RXNUM,0)=DT_U_$$FMADD^XLFDT(DT,30)
.; looks like we have to wait a moment before the file shows up.
.S FTGSTRT=$$NOW^XLFDT,(FOUND,FTGOPEN)=0
.N PAR S PAR=0
.F D Q:$$NOW^XLFDT>$$FMADD^XLFDT(FTGSTRT,,,,15)!(FOUND)!(FTGOPEN)
..S FTGOPEN=$$FTG^%ZISH(PSODFDIR,PSOFNAME,XTMPLOC,4)
..I $O(^XTMP("PSORLBL",HLINSTN,+RXNUM,0)) S FOUND=1
.S DELARR("PSOLBL_"_RXNUM_"_"_PSOSITE_"_"_DT_".DAT")="" S DEL=$$DEL^%ZISH(PSODFDIR,$NA(DELARR))
.; restore IO
.D USE^%ZISUTL("ONEVAHLIO"),RMDEV^%ZISUTL("ONEVAHLIO")
.D:'PSOOFILL UPDREF(.RET,RRXIEN,RPHARM,RPHONE,RSITE,PASSLOC) ; Don't call UPDREF if not Orig. Fill - RBD *774
.I PSOOFILL D ; Emulate UPDREF specific to Orig. Fill - RBD *774
..N CLERK,DAT,DIEN,DISPDT,DNAME,DSUPP,EDIV,FILLDATA,FILLDT,IDIV,LOGDATE,NDC,QTY,REFIEN,RRXIENS
..N RXFLDS S REFIEN="" ; RSITE, RPHARM, RPHONE Set into Fields 91, 92, 93 of File 52 - RBD *774
..S RRXIENS=RRXIEN_"," N FDA
..S FDA(52,RRXIENS,91)=RSITE,FDA(52,RRXIENS,92)=RPHARM
..S FDA(52,RRXIENS,93)=RPHONE D FILE^DIE(,"FDA") K FDA
..S RXFLDS="6;7;8;16;20;21;22;25;27"
..D GETS^DIQ(52,RRXIEN,RXFLDS,"IE","FILLDATA")
..S DNAME=$G(FILLDATA(52,RRXIENS,6,"E")),DIEN=$G(FILLDATA(52,RRXIENS,6,"I"))
..S FILLDT=$G(FILLDATA(52,RRXIENS,22,"I")),QTY=$G(FILLDATA(52,RRXIENS,7,"I"))
..S DSUPP=$G(FILLDATA(52,RRXIENS,8,"I")),CLERK=$G(FILLDATA(52,RRXIENS,16,"E"))
..S LOGDATE=$G(FILLDATA(52,RRXIENS,21,"I")),IDIV=$G(FILLDATA(52,RRXIENS,20,"I"))
..S EDIV=$G(FILLDATA(52,RRXIENS,20,"E")),DISPDT=$G(FILLDATA(52,RRXIENS,25,"I"))
..S NDC=$G(FILLDATA(52,RRXIENS,27,"E")),$P(DAT(1),U,3)=RXNUM,$P(DAT(1),U,4)=RSITE
..S $P(DAT(1),U,7)=QTY,$P(DAT(1),U,8)=DISPDT,$P(DAT(1),U,9)=DNAME
..S $P(DAT(1),U,10)=DSUPP,$P(DAT(1),U,11)=RPHARM,$P(DAT(1),U,12)=FILLDT
..D LOGDATA^PSORWRAP($NA(DAT),"OR",,,RRXIEN,REFIEN)
..S RET(0)=1_U_RXNUM_U_RRXIEN_U_REFIEN_U_FILLDT_U_DNAME_U_QTY_U_DSUPP_U_CLERK_U
..S RET(0)=RET(0)_LOGDATE_U_IDIV_U_EDIV_U_DISPDT_U_NDC_U_RPHARM_U_RPHONE_U
..S RET(0)=RET(0)_RSITE_U_PASSLOC
.S RET(1)="Rx # "_RXNUM_" "_$S('PSOOFILL:"re",1:"")_"filled." ; Orig. Fill logic added - RBD *774
.S RX0=$G(^PSRX(RRXIEN,0)),RX2=$G(^PSRX(RRXIEN,2)),RX3=$G(^PSRX(RRXIEN,3))
.S RXSTA=$G(^PSRX(RRXIEN,"STA")),RPROV=$$GET1^DIQ(200,$P(RX0,U,4),.01,"E")_U_$$GET1^DIQ(200,$P(RX0,U,16),.01,"E")
.S RSIG=$G(^PSRX(RRXIEN,"SIG"))
.S RREFIEN=$O(^PSRX(RRXIEN,1,"A"),-1)
.I RREFIEN S RREF0=$G(^PSRX(RRXIEN,1,RREFIEN,0))
.S ROR1=$G(^PSRX(RRXIEN,"OR1"))
D EOJ
Q
ORGFILL(RX) ; Determine if Prescription is Orig. Fill - RBD *774
I $$GET1^DIQ(52,RX,22,"I")']"",'$$LSTRFL^PSOBPSU1(RX) Q 1
Q 0
VALIDDRUG(DRUGIEN) ;
S DINACT=$$GET1^DIQ(50,DRUGIEN,100,"I")
I DINACT>0,($$DT^XLFDT>DINACT) S RET(1)="Drug is inactive for Rx# "_RXNUM_". Cannot refill." D RET0 Q 0
S CSVAL=$$GET1^DIQ(50,DRUGIEN,3,"E"),CSVAL=$E(CSVAL,1)
I CSVAL,CSVAL>0,CSVAL<6 D RET0 S RET(1)="Rx #"_RXNUM_" cannot be refilled.",RET(2)="The associated drug is considered a controlled substance",RET(3)="at the host facility." Q 0
S CLOZVAL=$$GET1^DIQ(50,DRUGIEN,17.5) ; Clozapine Check PSO*7*740
I CLOZVAL="PSOCLO1" S RET(1)="This is a Clozapine prescription.",RET(2)="Cannot refill Rx # "_RXNUM_"." Q 0
;
S NOONEVA=$$GET1^DIQ(50,DRUGIEN,907)
I NOONEVA="YES" S RET(1)="Remote Site Drug is restricted from OneVA Pharmacy processing.",RET(2)="Cannot refill Rx # "_RXNUM_"." Q 0
Q 1
EOJ ;
D RET0
K PSOMSG,PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE")
K PSOFROM,PSODFN,PSORX
Q
; build ret(0) if needed
RET0 ;
I '$L(RET(0)) S RET(0)=0_U_RXNUM_U_RRXIEN_U_U_FDATE,$P(RET(0),U,15)=$G(RPHARM),$P(RET(0),U,16)=$G(RPHONE),$P(RET(0),U,17)=$G(RSITE)
Q
;
ULK ;
Q
; successful refill. Update data, and build response
UPDREF(PSOMSG,PSOIEN,RPHARM,RPHONE,RSITE,PASSLOC) ;
N REFIEN,REFIENS,REFDATA,FIL,RXNUM,RFILLDT,QTY,DSUPP,CLERK,LOGDATE,IDIV,EDIV,DISPDT,NDC,FDA,DNAME,DIEN,DAT
S FIL=52.1
; get last refill data node
S REFIEN=$O(^PSRX(PSOIEN,1,"B",DT,""),-1)
S RXNUM=$$GET1^DIQ(52,PSOIEN,.01,"E")
S DNAME=$$GET1^DIQ(52,PSOIEN,6,"E")
S DIEN=$$GET1^DIQ(52,PSOIEN,6,"I")
S REFIENS=REFIEN_","_PSOIEN_","
; first, set in the remote pharmacist data
S FDA(FIL,REFIENS,91)=RSITE
S FDA(FIL,REFIENS,92)=RPHARM
S FDA(FIL,REFIENS,93)=RPHONE
D FILE^DIE(,"FDA") K FDA
; now query data and build RET(0) holding accurate information from the refill multiple
D GETS^DIQ(FIL,REFIENS,"**","IE","REFDATA")
S RFILLDT=$G(REFDATA(FIL,REFIENS,.01,"I"))
S QTY=$G(REFDATA(FIL,REFIENS,1,"I"))
S DSUPP=$G(REFDATA(FIL,REFIENS,1.1,"I"))
S CLERK=$G(REFDATA(FIL,REFIENS,6,"E"))
S LOGDATE=$G(REFDATA(FIL,REFIENS,7,"I"))
; internal division number (IEN to PSO SITE file)
S IDIV=$G(REFDATA(FIL,REFIENS,8,"I"))
S EDIV=$G(REFDATA(FIL,REFIENS,8,"E"))
S DISPDT=$G(REFDATA(FIL,REFIENS,10.1,"I"))
S NDC=$G(REFDATA(FIL,REFIENS,11,"E"))
S RSITE=$G(REFDATA(FIL,REFIENS,91,"I"))
S RPHARM=$G(REFDATA(FIL,REFIENS,92,"E"))
S RPHONE=$G(REFDATA(FIL,REFIENS,93,"E"))
S $P(DAT(1),U,3)=RXNUM,$P(DAT(1),U,4)=RSITE,$P(DAT(1),U,7)=QTY,$P(DAT(1),U,8)=DISPDT,$P(DAT(1),U,9)=DNAME,$P(DAT(1),U,10)=DSUPP,$P(DAT(1),U,11)=RPHARM,$P(DAT(1),U,12)=RFILLDT
D LOGDATA^PSORWRAP($NA(DAT),"OR",,,PSOIEN,REFIEN)
S PSOMSG(0)=1_U_RXNUM_U_PSOIEN_U_REFIEN_U_RFILLDT_U_DNAME_U_QTY_U_DSUPP_U_CLERK_U_LOGDATE_U_IDIV_U_EDIV_U_DISPDT_U_NDC_U_RPHARM_U_RPHONE_U_RSITE_U_PASSLOC
Q
;
ACT(PSORTYPE,PSORIEN,PSORFILL) ;
;Add activity log entry at Host Site for Dispensing Site OPAI send
N PSOJ,PSOIR
S PSOIR=0 F PSOJ=0:0 S PSOJ=$O(^PSRX(PSORIEN,"A",PSOJ)) Q:'PSOJ S PSOIR=PSOJ
S PSOIR=PSOIR+1,^PSRX(PSORIEN,"A",0)="^52.3DA^"_PSOIR_"^"_PSOIR
N PSOCMNT S PSOCMNT=$S('PSORFILL:"Original Fill",PSORTYPE="R":"Refill",1:"Partial") ; RBD *774 Activity Log Comment now includes Original Fill
S ^PSRX(PSORIEN,"A",PSOIR,0)=DT_"^"_"X^^"_PSORFILL_"^"_PSOCMNT_" sent to external interface." ; RBD *774 Use PSOCMNT in Piece 5
Q
;
ACTD(PSOREASN,PSOMSG) ;Update Activity log at host site for OPAI Dispensed Fill, called from PSORLLLI
;PSOREASN - the actvity log reason (N - FOR DISPENSE COMPLETION or X - FOR INTERFACE)
N PSOJ,PSOIR
S PSOIR=0 F PSOJ=0:0 S PSOJ=$O(^PSRX(PSOHIENR,"A",PSOJ)) Q:'PSOJ S PSOIR=PSOJ
S PSOIR=PSOIR+1,^PSRX(PSOHIENR,"A",0)="^52.3DA^"_PSOIR_"^"_PSOIR
S ^PSRX(PSOHIENR,"A",PSOIR,0)=DT_"^"_$G(PSOREASN)_"^^"_$S(PSOHTPE="RF":PSOHSUBR,1:6)_"^"_$G(PSOMSG)
Q
;
UPDH ;continue update of Dispensing Information at Host Site, called from PSORLLLI
N FLL,FLLN,IRX S IRX=PSOHIENR ; RBD *774 - FLL (F - Fill, P - Partial), FLLN (Fill #), IRX (IEN into File 52)
; RBD *774 Handle filing for Original Fill
I 'PSOHSUB D Q
.S $P(^PSRX(PSOHIENR,"OF"),"^",4)=$G(PSOHCHEK)
.S $P(^PSRX(PSOHIENR,"OF"),"^",5)=$G(PSOHFILL)
.S $P(^PSRX(PSOHIENR,2),"^",4)=$G(PSOHFLOT)
.S $P(^PSRX(PSOHIENR,2),"^",8)=$G(PSOHSMAN)
.S $P(^PSRX(PSOHIENR,2),"^",11)=$G(PSOHSEXP)
.S FLL="F",FLLN=0 D UPDHREL^PSOHLDS6 ; RBD *774 - Call UPDHREL for Auto-Release logic
I PSOHTPE="RF" D Q
.Q:'$D(^PSRX(PSOHIENR,1,PSOHSUB,0))
.S $P(^PSRX(PSOHIENR,1,PSOHSUB,"RF"),"^",5)=$G(PSOHCHEK)
.S $P(^PSRX(PSOHIENR,1,PSOHSUB,"RF"),"^",6)=$G(PSOHFILL)
.S $P(^PSRX(PSOHIENR,1,PSOHSUB,0),"^",6)=$G(PSOHFLOT)
.S $P(^PSRX(PSOHIENR,1,PSOHSUB,0),"^",14)=$G(PSOHSMAN)
.S $P(^PSRX(PSOHIENR,1,PSOHSUB,0),"^",15)=$G(PSOHSEXP)
.S FLL="F",FLLN=PSOHSUB D UPDHREL^PSOHLDS6 ; RBD *774 - Call UPDHREL for Auto-Release logic
Q:'$D(^PSRX(PSOHIENR,"P",PSOHSUB,0))
S $P(^PSRX(PSOHIENR,"P",PSOHSUB,"PF"),"^",5)=$G(PSOHCHEK)
S $P(^PSRX(PSOHIENR,"P",PSOHSUB,"PF"),"^",6)=$G(PSOHFILL)
S $P(^PSRX(PSOHIENR,"P",PSOHSUB,0),"^",6)=$G(PSOHFLOT)
S $P(^PSRX(PSOHIENR,"P",PSOHSUB,0),"^",12)=$G(PSOHSNDC)
S $P(^PSRX(PSOHIENR,"P",PSOHSUB,1),"^")=$G(PSOHSMAN)
S $P(^PSRX(PSOHIENR,"P",PSOHSUB,1),"^",5)=$G(PSOHSEXP)
S FLL="P",FLLN=PSOHSUB D UPDHREL^PSOHLDS6 ; RBD *774 - Call UPDHREL for Auto-Release logic
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORREF 14339 printed Sep 23, 2025@20:10:41 Page 2
PSORREF ;AITC/BWF,RBD - Remote RX retrieval API ;12 Dec 2024 4:27 PM
+1 ;;7.0;OUTPATIENT PHARMACY;**454,475,497,643,740,774**;DEC 1997;Build 15
+2 ;
+3 QUIT
+4 ; RET - return data
+5 ; RXNUM - RX Number from remote system
+6 ; FDATE - Fill Date
+7 ; MW - Mail/Window - Default of 'W' for now.
+8 ; RPHARM - Pharmacist from remote site
+9 ; RPHONE - Contact number
+10 ; RSITE - Filling site number
+11 ;
REMREF(RET,RXNUM,FDATE,MW,RPHARM,RPHONE,RSITE,RX0,RX2,RXSTA,RPROV,RSIG,RREF0,ROR1,RX3) ;
+1 ;
+2 NEW MSG,BACK,PSOPAR,RRXIEN,PSOSIEN,DSUPP,LASTREF,XTMPLOC,PASSLOC,HFSIEN,FULLPTH,HFSDONE,PTHDAT,PTHPIECE,FOUND,STRT,STATION,FTGOPEN,PPL1,PSOSITE
+3 NEW PSOX,PTHFILE,SITENUM,X,X1,X2,HDRUG,CSVAL,PSISSDT,TFILLS,OFFSET,CHKDT,DINACT,DEL,FTGSTRT,PDIR,PFIL,PSODTCUT,PSOEXREP,PSOPHDUZ
+4 NEW PSODFDIR,PSOFNAME,PAR,DELARR,RREFIEN
+5 NEW PSOBBC,PSOBBC1,PSODIR,PSOMVH,CLOZVAL,NOONEVA
+6 ; check 3rd party payer rejects. Send message to initiating site if applicable.
+7 SET $ETRAP="D ^%ZTER Q"
+8 SET RET(0)=""
+9 SET RRXIEN=$ORDER(^PSRX("B",RXNUM,0))
SET PSOSIEN=$$GET1^DIQ(52,RRXIEN,20,"I")
+10 IF '$$GET1^DIQ(59.7,1,101,"I")
Begin DoDot:1
+11 SET RET(1)="The OneVA pharmacy flag is turned 'OFF' at this facility."
+12 SET RET(2)="Unable to process refill/partial fill requests."
+13 DO RET0
End DoDot:1
QUIT
+14 ; PSO*7*497 - trade name block/titration block
+15 IF $$GET1^DIQ(52,RRXIEN,6.5,"E")]""
Begin DoDot:1
+16 DO RET0
+17 SET RET(1)="This prescription cannot be refilled or partial filled because it has a value"
+18 SET RET(2)="entered in the Rx trade name field. Please follow local policy for obtaining"
+19 SET RET(3)="a new prescription."
End DoDot:1
QUIT
+20 IF $$TITRX^PSOUTL(RRXIEN)="t"
SET RET(1)="Cannot refill prescription - type is Titration. You may request a partial fill."
DO RET0
QUIT
+21 ; PSO*7*497 - end trade name/titration block
+22 ; Set Orig. Fill Flag - RBD *774
NEW PSOOFILL
SET PSOOFILL=$$ORGFILL(RRXIEN)
+23 ; RBD *774 Always set PSOPHDUZ to PSOAPPLICATIONPROXY,PSO
SET PSOPHDUZ=$$FIND1^DIC(200,,"M","PSOAPPLICATIONPROXY,PSO")
IF 'PSOPHDUZ
SET PSOPHDUZ=.5
+24 SET HDRUG=$$GET1^DIQ(52,RRXIEN,6,"I")
+25 ;Validate entry in file 50
IF '$$VALIDDRUG(HDRUG)
DO RET0
QUIT
+26 SET PSOPAR=$GET(^PS(59,PSOSIEN,1))
SET PSOSITE=PSOSIEN
+27 SET RPHONE=$GET(RPHONE,"")
+28 ; check to see if this action will throw the prescription into suspense. If so, quit and return a message
+29 SET DSUPP=$$GET1^DIQ(52,RRXIEN,8,"I")
+30 SET X2=-120
SET X1=DT
DO C^%DTC
SET PSODTCUT=X
+31 SET (PSODFN,PSOREF("PSODFN"))=$$GET1^DIQ(52,RRXIEN,2,"I")
KILL PSOSD
DO ^PSOBUILD
+32 NEW RXN
KILL PSORX("FILL DATE")
SET PSOFROM="REFILL"
SET PSOREF("DFLG")=0
SET PSOREF("IRXN")=$ORDER(^PSRX("B",RXNUM,0))
SET PSOREF("QFLG")=0
+33 IF $$LMREJ^PSOREJU1(RXNUM,,.MSG,.BACK)
SET RET(1)=MSG
DO RET0
QUIT
+34 SET PSORX("FILL DATE")=FDATE
+35 KILL PSOID
DO START^PSORREF1(FDATE)
IF PSOREF("DFLG")
DO EOJ
QUIT
+36 ; check ability to refill given issue date/days supply
+37 SET PSISSDT=$$GET1^DIQ(52,RRXIEN,1,"I")
+38 SET TFILLS=$ORDER(^PSRX(RRXIEN,1,"A"),-1)+1
+39 SET OFFSET=DSUPP*TFILLS
SET OFFSET=OFFSET-10
+40 SET CHKDT=$$FMADD^XLFDT(PSISSDT,OFFSET)
+41 ; First check if not Orig. Fill before checking Next Possible Fill Date - RBD *774
+42 IF 'PSOOFILL
IF PSORX("FILL DATE")<CHKDT
DO RET0
SET RET(1)="Cannot refill Rx# "_RXNUM_". Next possible fill date is "_$$FMTE^XLFDT(CHKDT,"5D")
QUIT
+43 IF PSORX("FILL DATE")>$$GET1^DIQ(52,RRXIEN,26,"I")
DO RET0
SET RET(1)="Cannot refill Rx# "_RXNUM_"."
SET RET(2)="Cannot refill after expiration date "_$$GET1^DIQ(52,RRXIEN,11,"E")
QUIT
+44 ; For Original Fill, Check if Fill Date before Issue Date - RBD *774
+45 IF PSOOFILL
IF PSORX("FILL DATE")<PSISSDT
Begin DoDot:1
+46 DO RET0
SET RET(1)="Cannot fill Rx# "_RXNUM_"."
+47 SET RET(2)="Cannot fill before issue date "_$$GET1^DIQ(52,RRXIEN,1,"E")
End DoDot:1
QUIT
+48 DO PROCESS^PSORREF0(.RET)
+49 ; make sure not errors are returned
+50 IF $DATA(RET(1))
DO EOJ
QUIT
+51 ; Persist Orig. Fill - RBD *774
+52 ; Use FILE^DIE in lieu of ^DIE - RBD *774
IF PSOOFILL
Begin DoDot:1
+53 KILL FDA
NEW PSORXIENS
SET PSORXIENS=RRXIEN_","
SET FDA(52,PSORXIENS,22)=PSORX("FILL DATE")
+54 DO FILE^DIE(,"FDA","PSOERR")
KILL FDA
NEW DA
SET DA=RRXIEN
+55 NEW PSOFLLDT
SET PSOFLLDT=$EXTRACT(PSORX("FILL DATE"),4,5)_"/"_$EXTRACT(PSORX("FILL DATE"),6,7)
+56 SET PSOFLLDT=PSOFLLDT_"/"_$EXTRACT(PSORX("FILL DATE"),2,3)
+57 NEW PSOCOM
SET PSOCOM=$PIECE(^DD(52,22,0),"^")_" ("_PSOFLLDT_")"
+58 NEW PSOK,PSOD1,PSOZ
SET PSOK=1
SET PSOD1=0
+59 FOR PSOZ=0:0
SET PSOZ=$ORDER(^PSRX(DA,"A",PSOZ))
if 'PSOZ
QUIT
SET PSOD1=PSOZ
SET PSOK=PSOK+1
+60 SET PSOD1=PSOD1+1
+61 if '($DATA(^PSRX(DA,"A",0))#2)
SET ^(0)="^52.3DA^^^"
SET ^(0)=$PIECE(^(0),U,1,2)_U_PSOD1_U_PSOK
+62 ; RBD *774 Removed Timestamp
DO NOW^%DTC
SET ^PSRX(DA,"A",PSOD1,0)=$PIECE(%,".")_"^E^"_$GET(PSOPHDUZ)_"^0^"_PSOCOM
+63 KILL %
NEW PSOX,PSOX1,X1,X2,X
+64 SET PSOX("RX0")=^PSRX(DA,0)
SET PSOX("RX2")=^PSRX(DA,2)
SET PSOX("RX3")=^PSRX(DA,3)
+65 SET PSOX1=$PIECE(PSOX("RX2"),U,2)
SET $PIECE(PSOX("RX3"),U)=PSOX1
SET X1=PSOX1
+66 SET X2=$PIECE(PSOX("RX0"),U,8)-10\1
DO C^%DTC
+67 if '$PIECE(PSOX("RX3"),U,8)
SET $PIECE(PSOX("RX3"),U,2)=X
+68 SET FDA(52,PSORXIENS,101)=$PIECE(PSOX("RX3"),U)
SET FDA(52,PSORXIENS,102)=$PIECE(PSOX("RX3"),U,2)
+69 ; RBD *774 Field 23 (PHARMACIST) no longer set to PSOPHDUZ (since it is a local field)
SET FDA(52,PSORXIENS,11)="W"
+70 DO FILE^DIE(,"FDA","PSOERR")
KILL FDA
+71 ; RBD *774 Call ECME for claims generation and transmission (emulate ECME code from PSON52)
+72 IF $$SUBMIT^PSOBPSUT(RRXIEN,0)
Begin DoDot:2
+73 DO ECMESND^PSOBPSU1(RRXIEN,0,"","OF")
+74 ; Quit if there is an unresolved Tricare/CHAMPVA non-billable reject code
+75 IF $$PSOET^PSOREJP3(RRXIEN,0)
QUIT
+76 IF $$STATUS^PSOBPSUT(RRXIEN,0)="E PAYABLE"
Begin DoDot:3
+77 DO SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,RRXIEN,6,"I"),$GET(PSOSITE),$$GETNDC^PSONDCUT(RRXIEN,0))
End DoDot:3
End DoDot:2
End DoDot:1
+78 IF '$DATA(RET(1))
Begin DoDot:1
+79 ; bwf 8/14/14 - set up needed variables for label printing
+80 SET PSODFN=$PIECE(^PSRX(RRXIEN,0),U,2)
+81 SET PSORX("IRXN")=RXNUM
+82 SET PSORX("PSOL",1)=RRXIEN_","
+83 SET PSORX("MAIL/WINDOW")="WINDOW"
+84 SET PSORX("NAME")=$$GET1^DIQ(2,PSODFN,.01)
+85 SET PSORX("QFLG")=0
+86 SET PSORX("METHOD OF PICKUP")=""
+87 SET PSOX=$GET(^PS(55,PSODFN,"PS"))
IF PSOX]""
SET PSORX("PATIENT STATUS")=$PIECE($GET(^PS(53,PSOX,0)),"^")
+88 SET PPL1=RRXIEN
+89 ; bwf 8/14/14 - end setup for label printing.
+90 SET PSODFDIR=$$DEFDIR^%ZISH()
+91 SET PSOFNAME="PSOLBL_"_RXNUM_"_"_PSOSITE_"_"_DT_".DAT"
+92 SET FULLPTH=PSODFDIR_PSOFNAME
+93 SET HFSDONE=0
SET PTHDAT=""
+94 ; preserve IO
+95 DO SAVDEV^%ZISUTL("ONEVAHLIO")
+96 SET DELARR("PSOLBL_"_RXNUM_"_"_PSOSITE_"_"_DT_".DAT")=""
SET DEL=$$DEL^%ZISH(PSODFDIR,$NAME(DELARR))
+97 SET PSOEXREP=1
+98 ; call out to generate label
+99 DO LABEL^PSORWRAP(RRXIEN,"HFS",PSOSITE,PSOPHDUZ,"",PSOFNAME)
+100 SET XTMPLOC="^XTMP(""PSORLBL"","_HLINSTN_","_+RXNUM_",1,0)"
+101 SET PASSLOC="XTMP(""PSORLBL"","_HLINSTN_","_+RXNUM_")"
+102 KILL ^XTMP("PSORLBL",HLINSTN,+RXNUM,0)
+103 SET ^XTMP("PSORLBL",HLINSTN,+RXNUM,0)=DT_U_$$FMADD^XLFDT(DT,30)
+104 ; looks like we have to wait a moment before the file shows up.
+105 SET FTGSTRT=$$NOW^XLFDT
SET (FOUND,FTGOPEN)=0
+106 NEW PAR
SET PAR=0
+107 FOR
Begin DoDot:2
+108 SET FTGOPEN=$$FTG^%ZISH(PSODFDIR,PSOFNAME,XTMPLOC,4)
+109 IF $ORDER(^XTMP("PSORLBL",HLINSTN,+RXNUM,0))
SET FOUND=1
End DoDot:2
if $$NOW^XLFDT>$$FMADD^XLFDT(FTGSTRT,,,,15)!(FOUND)!(FTGOPEN)
QUIT
+110 SET DELARR("PSOLBL_"_RXNUM_"_"_PSOSITE_"_"_DT_".DAT")=""
SET DEL=$$DEL^%ZISH(PSODFDIR,$NAME(DELARR))
+111 ; restore IO
+112 DO USE^%ZISUTL("ONEVAHLIO")
DO RMDEV^%ZISUTL("ONEVAHLIO")
+113 ; Don't call UPDREF if not Orig. Fill - RBD *774
if 'PSOOFILL
DO UPDREF(.RET,RRXIEN,RPHARM,RPHONE,RSITE,PASSLOC)
+114 ; Emulate UPDREF specific to Orig. Fill - RBD *774
IF PSOOFILL
Begin DoDot:2
+115 NEW CLERK,DAT,DIEN,DISPDT,DNAME,DSUPP,EDIV,FILLDATA,FILLDT,IDIV,LOGDATE,NDC,QTY,REFIEN,RRXIENS
+116 ; RSITE, RPHARM, RPHONE Set into Fields 91, 92, 93 of File 52 - RBD *774
NEW RXFLDS
SET REFIEN=""
+117 SET RRXIENS=RRXIEN_","
NEW FDA
+118 SET FDA(52,RRXIENS,91)=RSITE
SET FDA(52,RRXIENS,92)=RPHARM
+119 SET FDA(52,RRXIENS,93)=RPHONE
DO FILE^DIE(,"FDA")
KILL FDA
+120 SET RXFLDS="6;7;8;16;20;21;22;25;27"
+121 DO GETS^DIQ(52,RRXIEN,RXFLDS,"IE","FILLDATA")
+122 SET DNAME=$GET(FILLDATA(52,RRXIENS,6,"E"))
SET DIEN=$GET(FILLDATA(52,RRXIENS,6,"I"))
+123 SET FILLDT=$GET(FILLDATA(52,RRXIENS,22,"I"))
SET QTY=$GET(FILLDATA(52,RRXIENS,7,"I"))
+124 SET DSUPP=$GET(FILLDATA(52,RRXIENS,8,"I"))
SET CLERK=$GET(FILLDATA(52,RRXIENS,16,"E"))
+125 SET LOGDATE=$GET(FILLDATA(52,RRXIENS,21,"I"))
SET IDIV=$GET(FILLDATA(52,RRXIENS,20,"I"))
+126 SET EDIV=$GET(FILLDATA(52,RRXIENS,20,"E"))
SET DISPDT=$GET(FILLDATA(52,RRXIENS,25,"I"))
+127 SET NDC=$GET(FILLDATA(52,RRXIENS,27,"E"))
SET $PIECE(DAT(1),U,3)=RXNUM
SET $PIECE(DAT(1),U,4)=RSITE
+128 SET $PIECE(DAT(1),U,7)=QTY
SET $PIECE(DAT(1),U,8)=DISPDT
SET $PIECE(DAT(1),U,9)=DNAME
+129 SET $PIECE(DAT(1),U,10)=DSUPP
SET $PIECE(DAT(1),U,11)=RPHARM
SET $PIECE(DAT(1),U,12)=FILLDT
+130 DO LOGDATA^PSORWRAP($NAME(DAT),"OR",,,RRXIEN,REFIEN)
+131 SET RET(0)=1_U_RXNUM_U_RRXIEN_U_REFIEN_U_FILLDT_U_DNAME_U_QTY_U_DSUPP_U_CLERK_U
+132 SET RET(0)=RET(0)_LOGDATE_U_IDIV_U_EDIV_U_DISPDT_U_NDC_U_RPHARM_U_RPHONE_U
+133 SET RET(0)=RET(0)_RSITE_U_PASSLOC
End DoDot:2
+134 ; Orig. Fill logic added - RBD *774
SET RET(1)="Rx # "_RXNUM_" "_$SELECT('PSOOFILL:"re",1:"")_"filled."
+135 SET RX0=$GET(^PSRX(RRXIEN,0))
SET RX2=$GET(^PSRX(RRXIEN,2))
SET RX3=$GET(^PSRX(RRXIEN,3))
+136 SET RXSTA=$GET(^PSRX(RRXIEN,"STA"))
SET RPROV=$$GET1^DIQ(200,$PIECE(RX0,U,4),.01,"E")_U_$$GET1^DIQ(200,$PIECE(RX0,U,16),.01,"E")
+137 SET RSIG=$GET(^PSRX(RRXIEN,"SIG"))
+138 SET RREFIEN=$ORDER(^PSRX(RRXIEN,1,"A"),-1)
+139 IF RREFIEN
SET RREF0=$GET(^PSRX(RRXIEN,1,RREFIEN,0))
+140 SET ROR1=$GET(^PSRX(RRXIEN,"OR1"))
End DoDot:1
+141 DO EOJ
+142 QUIT
ORGFILL(RX) ; Determine if Prescription is Orig. Fill - RBD *774
+1 IF $$GET1^DIQ(52,RX,22,"I")']""
IF '$$LSTRFL^PSOBPSU1(RX)
QUIT 1
+2 QUIT 0
VALIDDRUG(DRUGIEN) ;
+1 SET DINACT=$$GET1^DIQ(50,DRUGIEN,100,"I")
+2 IF DINACT>0
IF ($$DT^XLFDT>DINACT)
SET RET(1)="Drug is inactive for Rx# "_RXNUM_". Cannot refill."
DO RET0
QUIT 0
+3 SET CSVAL=$$GET1^DIQ(50,DRUGIEN,3,"E")
SET CSVAL=$EXTRACT(CSVAL,1)
+4 IF CSVAL
IF CSVAL>0
IF CSVAL<6
DO RET0
SET RET(1)="Rx #"_RXNUM_" cannot be refilled."
SET RET(2)="The associated drug is considered a controlled substance"
SET RET(3)="at the host facility."
QUIT 0
+5 ; Clozapine Check PSO*7*740
SET CLOZVAL=$$GET1^DIQ(50,DRUGIEN,17.5)
+6 IF CLOZVAL="PSOCLO1"
SET RET(1)="This is a Clozapine prescription."
SET RET(2)="Cannot refill Rx # "_RXNUM_"."
QUIT 0
+7 ;
+8 SET NOONEVA=$$GET1^DIQ(50,DRUGIEN,907)
+9 IF NOONEVA="YES"
SET RET(1)="Remote Site Drug is restricted from OneVA Pharmacy processing."
SET RET(2)="Cannot refill Rx # "_RXNUM_"."
QUIT 0
+10 QUIT 1
EOJ ;
+1 DO RET0
+2 KILL PSOMSG,PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE")
+3 KILL PSOFROM,PSODFN,PSORX
+4 QUIT
+5 ; build ret(0) if needed
RET0 ;
+1 IF '$LENGTH(RET(0))
SET RET(0)=0_U_RXNUM_U_RRXIEN_U_U_FDATE
SET $PIECE(RET(0),U,15)=$GET(RPHARM)
SET $PIECE(RET(0),U,16)=$GET(RPHONE)
SET $PIECE(RET(0),U,17)=$GET(RSITE)
+2 QUIT
+3 ;
ULK ;
+1 QUIT
+2 ; successful refill. Update data, and build response
UPDREF(PSOMSG,PSOIEN,RPHARM,RPHONE,RSITE,PASSLOC) ;
+1 NEW REFIEN,REFIENS,REFDATA,FIL,RXNUM,RFILLDT,QTY,DSUPP,CLERK,LOGDATE,IDIV,EDIV,DISPDT,NDC,FDA,DNAME,DIEN,DAT
+2 SET FIL=52.1
+3 ; get last refill data node
+4 SET REFIEN=$ORDER(^PSRX(PSOIEN,1,"B",DT,""),-1)
+5 SET RXNUM=$$GET1^DIQ(52,PSOIEN,.01,"E")
+6 SET DNAME=$$GET1^DIQ(52,PSOIEN,6,"E")
+7 SET DIEN=$$GET1^DIQ(52,PSOIEN,6,"I")
+8 SET REFIENS=REFIEN_","_PSOIEN_","
+9 ; first, set in the remote pharmacist data
+10 SET FDA(FIL,REFIENS,91)=RSITE
+11 SET FDA(FIL,REFIENS,92)=RPHARM
+12 SET FDA(FIL,REFIENS,93)=RPHONE
+13 DO FILE^DIE(,"FDA")
KILL FDA
+14 ; now query data and build RET(0) holding accurate information from the refill multiple
+15 DO GETS^DIQ(FIL,REFIENS,"**","IE","REFDATA")
+16 SET RFILLDT=$GET(REFDATA(FIL,REFIENS,.01,"I"))
+17 SET QTY=$GET(REFDATA(FIL,REFIENS,1,"I"))
+18 SET DSUPP=$GET(REFDATA(FIL,REFIENS,1.1,"I"))
+19 SET CLERK=$GET(REFDATA(FIL,REFIENS,6,"E"))
+20 SET LOGDATE=$GET(REFDATA(FIL,REFIENS,7,"I"))
+21 ; internal division number (IEN to PSO SITE file)
+22 SET IDIV=$GET(REFDATA(FIL,REFIENS,8,"I"))
+23 SET EDIV=$GET(REFDATA(FIL,REFIENS,8,"E"))
+24 SET DISPDT=$GET(REFDATA(FIL,REFIENS,10.1,"I"))
+25 SET NDC=$GET(REFDATA(FIL,REFIENS,11,"E"))
+26 SET RSITE=$GET(REFDATA(FIL,REFIENS,91,"I"))
+27 SET RPHARM=$GET(REFDATA(FIL,REFIENS,92,"E"))
+28 SET RPHONE=$GET(REFDATA(FIL,REFIENS,93,"E"))
+29 SET $PIECE(DAT(1),U,3)=RXNUM
SET $PIECE(DAT(1),U,4)=RSITE
SET $PIECE(DAT(1),U,7)=QTY
SET $PIECE(DAT(1),U,8)=DISPDT
SET $PIECE(DAT(1),U,9)=DNAME
SET $PIECE(DAT(1),U,10)=DSUPP
SET $PIECE(DAT(1),U,11)=RPHARM
SET $PIECE(DAT(1),U,12)=RFILLDT
+30 DO LOGDATA^PSORWRAP($NAME(DAT),"OR",,,PSOIEN,REFIEN)
+31 SET PSOMSG(0)=1_U_RXNUM_U_PSOIEN_U_REFIEN_U_RFILLDT_U_DNAME_U_QTY_U_DSUPP_U_CLERK_U_LOGDATE_U_IDIV_U_EDIV_U_DISPDT_U_NDC_U_RPHARM_U_RPHONE_U_RSITE_U_PASSLOC
+32 QUIT
+33 ;
ACT(PSORTYPE,PSORIEN,PSORFILL) ;
+1 ;Add activity log entry at Host Site for Dispensing Site OPAI send
+2 NEW PSOJ,PSOIR
+3 SET PSOIR=0
FOR PSOJ=0:0
SET PSOJ=$ORDER(^PSRX(PSORIEN,"A",PSOJ))
if 'PSOJ
QUIT
SET PSOIR=PSOJ
+4 SET PSOIR=PSOIR+1
SET ^PSRX(PSORIEN,"A",0)="^52.3DA^"_PSOIR_"^"_PSOIR
+5 ; RBD *774 Activity Log Comment now includes Original Fill
NEW PSOCMNT
SET PSOCMNT=$SELECT('PSORFILL:"Original Fill",PSORTYPE="R":"Refill",1:"Partial")
+6 ; RBD *774 Use PSOCMNT in Piece 5
SET ^PSRX(PSORIEN,"A",PSOIR,0)=DT_"^"_"X^^"_PSORFILL_"^"_PSOCMNT_" sent to external interface."
+7 QUIT
+8 ;
ACTD(PSOREASN,PSOMSG) ;Update Activity log at host site for OPAI Dispensed Fill, called from PSORLLLI
+1 ;PSOREASN - the actvity log reason (N - FOR DISPENSE COMPLETION or X - FOR INTERFACE)
+2 NEW PSOJ,PSOIR
+3 SET PSOIR=0
FOR PSOJ=0:0
SET PSOJ=$ORDER(^PSRX(PSOHIENR,"A",PSOJ))
if 'PSOJ
QUIT
SET PSOIR=PSOJ
+4 SET PSOIR=PSOIR+1
SET ^PSRX(PSOHIENR,"A",0)="^52.3DA^"_PSOIR_"^"_PSOIR
+5 SET ^PSRX(PSOHIENR,"A",PSOIR,0)=DT_"^"_$GET(PSOREASN)_"^^"_$SELECT(PSOHTPE="RF":PSOHSUBR,1:6)_"^"_$GET(PSOMSG)
+6 QUIT
+7 ;
UPDH ;continue update of Dispensing Information at Host Site, called from PSORLLLI
+1 ; RBD *774 - FLL (F - Fill, P - Partial), FLLN (Fill #), IRX (IEN into File 52)
NEW FLL,FLLN,IRX
SET IRX=PSOHIENR
+2 ; RBD *774 Handle filing for Original Fill
+3 IF 'PSOHSUB
Begin DoDot:1
+4 SET $PIECE(^PSRX(PSOHIENR,"OF"),"^",4)=$GET(PSOHCHEK)
+5 SET $PIECE(^PSRX(PSOHIENR,"OF"),"^",5)=$GET(PSOHFILL)
+6 SET $PIECE(^PSRX(PSOHIENR,2),"^",4)=$GET(PSOHFLOT)
+7 SET $PIECE(^PSRX(PSOHIENR,2),"^",8)=$GET(PSOHSMAN)
+8 SET $PIECE(^PSRX(PSOHIENR,2),"^",11)=$GET(PSOHSEXP)
+9 ; RBD *774 - Call UPDHREL for Auto-Release logic
SET FLL="F"
SET FLLN=0
DO UPDHREL^PSOHLDS6
End DoDot:1
QUIT
+10 IF PSOHTPE="RF"
Begin DoDot:1
+11 if '$DATA(^PSRX(PSOHIENR,1,PSOHSUB,0))
QUIT
+12 SET $PIECE(^PSRX(PSOHIENR,1,PSOHSUB,"RF"),"^",5)=$GET(PSOHCHEK)
+13 SET $PIECE(^PSRX(PSOHIENR,1,PSOHSUB,"RF"),"^",6)=$GET(PSOHFILL)
+14 SET $PIECE(^PSRX(PSOHIENR,1,PSOHSUB,0),"^",6)=$GET(PSOHFLOT)
+15 SET $PIECE(^PSRX(PSOHIENR,1,PSOHSUB,0),"^",14)=$GET(PSOHSMAN)
+16 SET $PIECE(^PSRX(PSOHIENR,1,PSOHSUB,0),"^",15)=$GET(PSOHSEXP)
+17 ; RBD *774 - Call UPDHREL for Auto-Release logic
SET FLL="F"
SET FLLN=PSOHSUB
DO UPDHREL^PSOHLDS6
End DoDot:1
QUIT
+18 if '$DATA(^PSRX(PSOHIENR,"P",PSOHSUB,0))
QUIT
+19 SET $PIECE(^PSRX(PSOHIENR,"P",PSOHSUB,"PF"),"^",5)=$GET(PSOHCHEK)
+20 SET $PIECE(^PSRX(PSOHIENR,"P",PSOHSUB,"PF"),"^",6)=$GET(PSOHFILL)
+21 SET $PIECE(^PSRX(PSOHIENR,"P",PSOHSUB,0),"^",6)=$GET(PSOHFLOT)
+22 SET $PIECE(^PSRX(PSOHIENR,"P",PSOHSUB,0),"^",12)=$GET(PSOHSNDC)
+23 SET $PIECE(^PSRX(PSOHIENR,"P",PSOHSUB,1),"^")=$GET(PSOHSMAN)
+24 SET $PIECE(^PSRX(PSOHIENR,"P",PSOHSUB,1),"^",5)=$GET(PSOHSEXP)
+25 ; RBD *774 - Call UPDHREL for Auto-Release logic
SET FLL="P"
SET FLLN=PSOHSUB
DO UPDHREL^PSOHLDS6
+26 QUIT
