PSORRPA1 ;AITC/BWF - remote partial prescriptions ;12/12/16 3:21pm
;;7.0;OUTPATIENT PHARMACY;**454,475,497,643**;DEC 1997;Build 35
;
;External references L,UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^DD(52 supported by DBIA 999
; bwf - Modified copy of PSORXPA1
; bwf - 2/24/14 adding PAR refill tag for API usage.
; VALMSG - return data for remote facility
; RXNUM - rx number
; PFDATE - Partial Fill Date
; MW - Mail or Window
; QTY - Quantity
; DSUPP - Days Supply
; REMARKS - Remarks entered by 'remote' (filling) facility.
; PHARM - Remote pharmacist's name
; PHONE - remote pharmacists phone number
; SITE - remote filling site.
;
PAR(VALMSG,RXNUM,PFDATE,MW,QTY,DSUPP,REMARKS,PHARM,PHONE,SITE,RX0,RX2,RXSTA,RPROV,RSIG,RPAR0,ROR1,RX3,RREF0) ;
N RRXIEN,PSOPAR,ORN,PSOLST,XTMPLOC,PASSLOC,HFSIEN,FULLPTH,HFSDONE,PTHDAT,PTHPIECE,DEL,DELARR,FTGOPEN,FOUND,FTGSTRT,FTGOPEN,STATION,HDRUG
N PERR,PDIR,PFIL,CSVAL,C,D,E,NEWPFIEN,PFIEN,PFIENS,PSOEXREP,PSOFROM,DINACT,PSOPHDUZ,PSODFDIR,PSOFNAME,PSOZ1,RREFIEN
S $ETRAP="D ^%ZTER Q"
S (RRXIEN,RXN)=$O(^PSRX("B",RXNUM,0)),PSOSIEN=$$GET1^DIQ(52,RRXIEN,20,"I")
I '$$GET1^DIQ(59.7,1,101,"I") D Q
.S VALMSG(1)="The OneVA pharmacy flag is turned 'OFF' at this facility."
.S VALMSG(2)="Unable to process refill/partial fill requests."
.D PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE)
; PSO*7*497 - trade name block
I $$GET1^DIQ(52,RRXIEN,6.5,"E")]"" D Q
.D PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE)
.S VALMSG(1)="This prescription cannot be refilled or partial filled because it has a value"
.S VALMSG(2)="entered in the Rx trade name field. Please follow local policy for obtaining"
.S VALMSG(3)="a new prescription."
; PSO*7*497 - end trade name block
S HDRUG=$$GET1^DIQ(52,RRXIEN,6,"I")
S DINACT=$$GET1^DIQ(50,HDRUG,100,"I")
I DINACT>0,DINACT<$$NOW^XLFDT S VALMSG(1)="Drug is inactive for Rx# "_RXNUM_". Cannot process partial fill." D PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE) Q
S CSVAL=$$GET1^DIQ(50,HDRUG,3,"E"),CSVAL=$E(CSVAL,1)
I CSVAL,CSVAL>0,CSVAL<6 D PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE) S VALMSG(1)="Rx #"_RXNUM_" cannot be partially filled. The associated drug is considered a controlled substance at the host facility." Q
I $D(^PSRX(RRXIEN,"ADP",PFDATE,RRXIEN)) S VALMSG(1)="A partial fill already exists for "_$$FMTE^XLFDT(PFDATE,"5D")_".",VALMSG(2)="Partial cannot be processed" D PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE) Q
S PSOPAR=$G(^PS(59,PSOSIEN,1)),PSOSITE=PSOSIEN
; set up PSOLST
S ORN=1,PSOLST(ORN)=52_U_RRXIEN_U_U
S PSOPHDUZ=$$GET1^DIQ(52,RRXIEN,23,"I") I 'PSOPHDUZ S PSOPHDUZ=.5
S PSORPDFN=+$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^",2)
S DA=$P(PSOLST(ORN),"^",2),RX0=^PSRX(DA,0),J=DA,RX2=$G(^(2)),R3=$G(^(3)) S:'$G(BBFLG) BBRX(1)=""
N PSORF,PSOTRIC D TRIC^PSORXL1(DA) I PSOTRIC&($$STATUS^PSOBPSUT(DA,PSORF)'["PAYABLE") D Q
. S VALMSG(1)="Partial cannot be filled on Tricare non-payable Rx."
. D PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE)
I +$P($G(^PSRX(DA,2)),"^",6)<DT D
.S:$P($G(^PSRX(DA,"STA")),"^")<12 $P(^PSRX(DA,"STA"),"^")=11
.S COMM="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"/"_$E($P(^(2),"^",6),6,7)_"/"_$E($P(^(2),"^",6),2,3)
.S STAT="SC",PHARMST="ZE" D EN^PSOHLSN1(DA,STAT,PHARMST,COMM) K STAT,PHARMST,COMM,RX0,J,RX2,R3
I +^PSRX(DA,"STA"),+^("STA")'=5,+^("STA")'=11 D K DA D ULK Q
.S C=";"_+^PSRX(DA,"STA")_":",X=$P(^DD(52,100,0),"^",3),E=$F(X,C),D=$P($E(X,E,999),";") ;IA#999
.S VALMSG(1)="Prescription is in a "_D_" status."
.D PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE)
I $G(PSXSYS),($O(^PS(52.5,"B",DA,""))) S PSOZ1=$O(^PS(52.5,"B",DA,"")) D
.I $P($G(^PS(52.5,PSOZ1,0)),"^",7)="Q"!($P($G(^(0)),"^",7)="L") D
..S VALMSG(1)="A partial entered for this Rx cannot be suspended."
..S VALMSG(2)="A fill for this Rx is already suspended for CMOP transmission."
..S VALMSG(3)="You may pull this fill from suspense or enter a partial and print the label."
..D PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE)
CLC S PSOCLC=PSOPHDUZ,PHYS=$P(^PSRX(DA,0),"^",4),DRG=$P(^(0),"^",6)
I 'PHYS,$O(^PSRX(DA,1,0)) F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S PHYS=$S($P(^PSRX(DA,1,I,0),"^",17):$P(^PSRX(DA,1,I,0),"^",17),1:PHYS)
S PSOPRZ=0 I $O(^PSRX(DA,"P",0)) N Z2 F Z2=0:0 S Z2=$O(^PSRX(DA,"P",Z2)) Q:'Z2 S PSOPRZ=Z2
I $D(RXPR(DA)),'$D(^PSRX(DA,"P",$G(RXPR(DA)))) D RMP^PSOCAN3
; bwf - save information into database, just as it would be through ^DIE
S FDA(52.2,"+1,"_RRXIEN_",",.01)=PFDATE D UPDATE^DIE(,"FDA","NEWPFIEN","PERR") K FDA
I $D(PERR) M VALMSG=PERR
S PFIEN=$O(NEWPFIEN(0)),PFIEN=$G(NEWPFIEN(PFIEN))
; set Z1 variable as was done in the ^DIE call for later use.
S Z1=PFIEN
S PFIENS=PFIEN_","_RRXIEN_","
; set PM variable as was done in the ^DIE call for later use.
I MW="M"!('$P($G(PSOPAR),U,12)) S PM=1
S FDA(52.2,PFIENS,.02)=MW
S FDA(52.2,PFIENS,.04)=QTY
S FDA(52.2,PFIENS,.041)=DSUPP
; currently we have no local pharmacist. May need to add entry to file 200 for 'REMOTE,PHARMACIST' or 'PHARMACIST,REMOTE'
S FDA(52.2,PFIENS,.05)=PSOPHDUZ
; can we use DUZ as the clerk code, or will this need another value??
S FDA(52.2,PFIENS,.07)=PSOPHDUZ
S FDA(52.2,PFIENS,6)=PHYS
S FDA(52.2,PFIENS,.08)=$$NOW^XLFDT
S FDA(52.2,PFIENS,.09)=PSOSITE
S FDA(52.2,PFIENS,.03)=REMARKS
;
; setting the partial fill date to the dispense date to match the
; HL7 response
S FDA(52.2,PFIENS,7.5)=PFDATE
;
S RXPR(RRXIEN)=PFIEN,PSOZZ=1,PRMK=REMARKS
; file the rest of the data onto the newly created multiple.
D FILE^DIE(,"FDA") K FDA
I Z1,$G(PRMK)]"" D D:$T(EN^PSOHDR)]"" EN^PSOHDR("PPAR",RXN) K DIE,RXN,RXF
.D ACT
.S ZD(RXN)=+^PSRX(RXN,"P",Z1,0),^PSRX(RXN,"TYPE")=Z1,$P(^PSRX(RXN,"P",Z1,0),"^",11)=$P($G(^PSDRUG(DRG,660)),"^",6)
S:'$D(PSOFROM) PSOFROM="PARTIAL" S BINGCRT=1 ;D:$D(BINGRTE)&($D(DISGROUP)) ^PSOBING1 K BINGRTE,TM,TM1
; bwf 8/14/14 - set up needed variables for label printing
S PSODFN=$P(^PSRX(RRXIEN,0),U,2)
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)),"^")
N PPL1
S PPL1=RRXIEN
S HFSDONE=0,PTHDAT=""
S PSODFDIR=$$DEFDIR^%ZISH()
S PSOFNAME="PSOLBL_"_RXNUM_"_"_PSOSITE_"_"_DT_".DAT"
S FULLPTH=PSODFDIR_PSOFNAME
; bwf 8/14/14 - end setup for label printing.
; preserve IO
D SAVDEV^%ZISUTL("ONEVAHLIO")
; delete the file first to ensure there isn't one lingering around
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)
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 UPDPAR(.VALMSG,RRXIEN,PHARM,PHONE,SITE,PASSLOC)
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 RPAR0=$G(^PSRX(RRXIEN,"P",PFIEN,0))
S ROR1=$G(^PSRX(RRXIEN,"OR1"))
S RREFIEN=$O(^PSRX(RRXIEN,1,"A"),-1)
I RREFIEN S RREF0=$G(^PSRX(RRXIEN,1,RREFIEN,0))
CLCX D ULK K DR,DIE,DRG,PPL,RXP,IOP,DA,PHYS,PSOPRZ,PSORX,PSOSIEN,PSOSITE,PSOX,PSOZZ,PSXSYS,RXPR,ZD Q
;
KILL S DA=Z1,DIK="^PSRX("_RXN_",""P""," D ^DIK S ^PSRX(RXN,"TYPE")=0
D ULK S VALMSG(1)="No Partial Fill Dispensed" D PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE) Q
KL K DFN,RFDAT,RLL,%,PRMK,PM,%Y,%X,D0,D1,DA,DI,DIC,DIE,DLAYGO,DQ,DR,I,II,J,JJJ,N,PHYS,PS,PSDATE,RFL,RFL1,RXF,ST,ST0,Z,Z1,X,Y,PDT,PSL,PSNP
K PSOM,PSOP,PSOD,PSOU,DIK,DUOUT,IFN,RXN,DRG,HRX,I1,PSOCLC,PSOLIST,PSOLST,PSPAR,RXP D KVA^VADPT Q
ACT ;adds activity info for partial rx
S RXF=0 F I=0:0 S I=$O(^PSRX(RRXIEN,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1
S DA=0 F FDA=0:0 S FDA=$O(^PSRX(RRXIEN,"A",FDA)) Q:'FDA S DA=FDA
S DA=DA+1,^PSRX(RRXIEN,"A",0)="^52.3DA^"_DA_"^"_DA,^PSRX(RRXIEN,"A",DA,0)=DT_"^"_"P"_"^"_PSOPHDUZ_"^"_RXF_"^"_PRMK
EX K RXF,I,FDA S DA=RXN
Q
ULK ;
K PSOMSG,PSOPLCK,PSORPDFN
Q
PARFAIL(PSOMSG,PSOIEN,RPHARM,RPHONE,RSITE) ;
S PSOMSG(0)=0_U_$$GET1^DIQ(52,PSOIEN,.01,"I")_U_PSOIEN,$P(PSOMSG(0),U,15)=RPHARM,$P(PSOMSG(0),U,16)=RPHONE,$P(PSOMSG(0),U,17)=RSITE
Q
UPDPAR(PSOMSG,PSOIEN,RPHARM,RPHONE,RSITE,PASSLOC) ;
N PARIEN,PARIENS,PARDATA,FIL,RXNUM,RFILLDT,QTY,DSUPP,CLERK,LOGDATE,IDIV,EDIV,DISPDT,NDC,FDA,DNAME,DIEN
S FIL=52.2
; get last partial data node
S PARIEN=$O(^PSRX(PSOIEN,"P",""),-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 PARIENS=PARIEN_","_PSOIEN_","
; first, set in the remote pharmacist data
S FDA(52.2,PARIENS,91)=RSITE
S FDA(52.2,PARIENS,92)=RPHARM
S FDA(52.2,PARIENS,93)=RPHONE
D FILE^DIE(,"FDA","MSG") K FDA,RPHARM,RPHONE,RSITE
; now query data and build RET(0) holding accurate information from the refill multiple
D GETS^DIQ(FIL,PARIENS,"**","IE","PARDATA")
S RFILLDT=$G(PARDATA(FIL,PARIENS,.01,"I"))
S QTY=$G(PARDATA(FIL,PARIENS,.04,"I"))
S DSUPP=$G(PARDATA(FIL,PARIENS,.041,"I"))
S CLERK=$G(PARDATA(FIL,PARIENS,.07,"E"))
S LOGDATE=$G(PARDATA(FIL,PARIENS,.08,"I"))
; internal division number (IEN to PSO SITE file)
S IDIV=$G(PARDATA(FIL,PARIENS,.09,"I"))
S EDIV=$G(PARDATA(FIL,PARIENS,.09,"E"))
;
; there is nothing in this field.
; HL7 is returning refill date in the RXD
; but trying to log the blank dispense date from file 52.2 into 52.09
S DISPDT=$G(PARDATA(FIL,PARIENS,7.5,"I"))
;
S NDC=$G(PARDATA(FIL,PARIENS,1,"E"))
S RSITE=$G(PARDATA(FIL,PARIENS,91,"I"))
S RPHARM=$G(PARDATA(FIL,PARIENS,92,"E"))
S RPHONE=$G(PARDATA(FIL,PARIENS,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),"OP",,,PSOIEN,,PARIEN)
S PSOMSG(0)=1_U_RXNUM_U_PSOIEN_U_PARIEN_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
I '$L($G(PSOMSG(1))) S PSOMSG(1)="Partial complete for RX #"_RXNUM_"."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORRPA1 10952 printed Apr 09, 2024@21:28:22 Page 2
PSORRPA1 ;AITC/BWF - remote partial prescriptions ;12/12/16 3:21pm
+1 ;;7.0;OUTPATIENT PHARMACY;**454,475,497,643**;DEC 1997;Build 35
+2 ;
+3 ;External references L,UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
+4 ;External reference to ^PSDRUG supported by DBIA 221
+5 ;External reference to ^DD(52 supported by DBIA 999
+6 ; bwf - Modified copy of PSORXPA1
+7 ; bwf - 2/24/14 adding PAR refill tag for API usage.
+8 ; VALMSG - return data for remote facility
+9 ; RXNUM - rx number
+10 ; PFDATE - Partial Fill Date
+11 ; MW - Mail or Window
+12 ; QTY - Quantity
+13 ; DSUPP - Days Supply
+14 ; REMARKS - Remarks entered by 'remote' (filling) facility.
+15 ; PHARM - Remote pharmacist's name
+16 ; PHONE - remote pharmacists phone number
+17 ; SITE - remote filling site.
+18 ;
PAR(VALMSG,RXNUM,PFDATE,MW,QTY,DSUPP,REMARKS,PHARM,PHONE,SITE,RX0,RX2,RXSTA,RPROV,RSIG,RPAR0,ROR1,RX3,RREF0) ;
+1 NEW RRXIEN,PSOPAR,ORN,PSOLST,XTMPLOC,PASSLOC,HFSIEN,FULLPTH,HFSDONE,PTHDAT,PTHPIECE,DEL,DELARR,FTGOPEN,FOUND,FTGSTRT,FTGOPEN,STATION,HDRUG
+2 NEW PERR,PDIR,PFIL,CSVAL,C,D,E,NEWPFIEN,PFIEN,PFIENS,PSOEXREP,PSOFROM,DINACT,PSOPHDUZ,PSODFDIR,PSOFNAME,PSOZ1,RREFIEN
+3 SET $ETRAP="D ^%ZTER Q"
+4 SET (RRXIEN,RXN)=$ORDER(^PSRX("B",RXNUM,0))
SET PSOSIEN=$$GET1^DIQ(52,RRXIEN,20,"I")
+5 IF '$$GET1^DIQ(59.7,1,101,"I")
Begin DoDot:1
+6 SET VALMSG(1)="The OneVA pharmacy flag is turned 'OFF' at this facility."
+7 SET VALMSG(2)="Unable to process refill/partial fill requests."
+8 DO PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE)
End DoDot:1
QUIT
+9 ; PSO*7*497 - trade name block
+10 IF $$GET1^DIQ(52,RRXIEN,6.5,"E")]""
Begin DoDot:1
+11 DO PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE)
+12 SET VALMSG(1)="This prescription cannot be refilled or partial filled because it has a value"
+13 SET VALMSG(2)="entered in the Rx trade name field. Please follow local policy for obtaining"
+14 SET VALMSG(3)="a new prescription."
End DoDot:1
QUIT
+15 ; PSO*7*497 - end trade name block
+16 SET HDRUG=$$GET1^DIQ(52,RRXIEN,6,"I")
+17 SET DINACT=$$GET1^DIQ(50,HDRUG,100,"I")
+18 IF DINACT>0
IF DINACT<$$NOW^XLFDT
SET VALMSG(1)="Drug is inactive for Rx# "_RXNUM_". Cannot process partial fill."
DO PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE)
QUIT
+19 SET CSVAL=$$GET1^DIQ(50,HDRUG,3,"E")
SET CSVAL=$EXTRACT(CSVAL,1)
+20 IF CSVAL
IF CSVAL>0
IF CSVAL<6
DO PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE)
SET VALMSG(1)="Rx #"_RXNUM_" cannot be partially filled. The associated drug is considered a controlled substance at the host facility."
QUIT
+21 IF $DATA(^PSRX(RRXIEN,"ADP",PFDATE,RRXIEN))
SET VALMSG(1)="A partial fill already exists for "_$$FMTE^XLFDT(PFDATE,"5D")_"."
SET VALMSG(2)="Partial cannot be processed"
DO PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE)
QUIT
+22 SET PSOPAR=$GET(^PS(59,PSOSIEN,1))
SET PSOSITE=PSOSIEN
+23 ; set up PSOLST
+24 SET ORN=1
SET PSOLST(ORN)=52_U_RRXIEN_U_U
+25 SET PSOPHDUZ=$$GET1^DIQ(52,RRXIEN,23,"I")
IF 'PSOPHDUZ
SET PSOPHDUZ=.5
+26 SET PSORPDFN=+$PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),0)),"^",2)
+27 SET DA=$PIECE(PSOLST(ORN),"^",2)
SET RX0=^PSRX(DA,0)
SET J=DA
SET RX2=$GET(^(2))
SET R3=$GET(^(3))
if '$GET(BBFLG)
SET BBRX(1)=""
+28 NEW PSORF,PSOTRIC
DO TRIC^PSORXL1(DA)
IF PSOTRIC&($$STATUS^PSOBPSUT(DA,PSORF)'["PAYABLE")
Begin DoDot:1
+29 SET VALMSG(1)="Partial cannot be filled on Tricare non-payable Rx."
+30 DO PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE)
End DoDot:1
QUIT
+31 IF +$PIECE($GET(^PSRX(DA,2)),"^",6)<DT
Begin DoDot:1
+32 if $PIECE($GET(^PSRX(DA,"STA")),"^")<12
SET $PIECE(^PSRX(DA,"STA"),"^")=11
+33 SET COMM="Medication Expired on "_$EXTRACT($PIECE(^PSRX(DA,2),"^",6),4,5)_"/"_$EXTRACT($PIECE(^(2),"^",6),6,7)_"/"_$EXTRACT($PIECE(^(2),"^",6),2,3)
+34 SET STAT="SC"
SET PHARMST="ZE"
DO EN^PSOHLSN1(DA,STAT,PHARMST,COMM)
KILL STAT,PHARMST,COMM,RX0,J,RX2,R3
End DoDot:1
+35 IF +^PSRX(DA,"STA")
IF +^("STA")'=5
IF +^("STA")'=11
Begin DoDot:1
+36 ;IA#999
SET C=";"_+^PSRX(DA,"STA")_":"
SET X=$PIECE(^DD(52,100,0),"^",3)
SET E=$FIND(X,C)
SET D=$PIECE($EXTRACT(X,E,999),";")
+37 SET VALMSG(1)="Prescription is in a "_D_" status."
+38 DO PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE)
End DoDot:1
KILL DA
DO ULK
QUIT
+39 IF $GET(PSXSYS)
IF ($ORDER(^PS(52.5,"B",DA,"")))
SET PSOZ1=$ORDER(^PS(52.5,"B",DA,""))
Begin DoDot:1
+40 IF $PIECE($GET(^PS(52.5,PSOZ1,0)),"^",7)="Q"!($PIECE($GET(^(0)),"^",7)="L")
Begin DoDot:2
+41 SET VALMSG(1)="A partial entered for this Rx cannot be suspended."
+42 SET VALMSG(2)="A fill for this Rx is already suspended for CMOP transmission."
+43 SET VALMSG(3)="You may pull this fill from suspense or enter a partial and print the label."
+44 DO PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE)
End DoDot:2
End DoDot:1
CLC SET PSOCLC=PSOPHDUZ
SET PHYS=$PIECE(^PSRX(DA,0),"^",4)
SET DRG=$PIECE(^(0),"^",6)
+1 IF 'PHYS
IF $ORDER(^PSRX(DA,1,0))
FOR I=0:0
SET I=$ORDER(^PSRX(DA,1,I))
if 'I
QUIT
SET PHYS=$SELECT($PIECE(^PSRX(DA,1,I,0),"^",17):$PIECE(^PSRX(DA,1,I,0),"^",17),1:PHYS)
+2 SET PSOPRZ=0
IF $ORDER(^PSRX(DA,"P",0))
NEW Z2
FOR Z2=0:0
SET Z2=$ORDER(^PSRX(DA,"P",Z2))
if 'Z2
QUIT
SET PSOPRZ=Z2
+3 IF $DATA(RXPR(DA))
IF '$DATA(^PSRX(DA,"P",$GET(RXPR(DA))))
DO RMP^PSOCAN3
+4 ; bwf - save information into database, just as it would be through ^DIE
+5 SET FDA(52.2,"+1,"_RRXIEN_",",.01)=PFDATE
DO UPDATE^DIE(,"FDA","NEWPFIEN","PERR")
KILL FDA
+6 IF $DATA(PERR)
MERGE VALMSG=PERR
+7 SET PFIEN=$ORDER(NEWPFIEN(0))
SET PFIEN=$GET(NEWPFIEN(PFIEN))
+8 ; set Z1 variable as was done in the ^DIE call for later use.
+9 SET Z1=PFIEN
+10 SET PFIENS=PFIEN_","_RRXIEN_","
+11 ; set PM variable as was done in the ^DIE call for later use.
+12 IF MW="M"!('$PIECE($GET(PSOPAR),U,12))
SET PM=1
+13 SET FDA(52.2,PFIENS,.02)=MW
+14 SET FDA(52.2,PFIENS,.04)=QTY
+15 SET FDA(52.2,PFIENS,.041)=DSUPP
+16 ; currently we have no local pharmacist. May need to add entry to file 200 for 'REMOTE,PHARMACIST' or 'PHARMACIST,REMOTE'
+17 SET FDA(52.2,PFIENS,.05)=PSOPHDUZ
+18 ; can we use DUZ as the clerk code, or will this need another value??
+19 SET FDA(52.2,PFIENS,.07)=PSOPHDUZ
+20 SET FDA(52.2,PFIENS,6)=PHYS
+21 SET FDA(52.2,PFIENS,.08)=$$NOW^XLFDT
+22 SET FDA(52.2,PFIENS,.09)=PSOSITE
+23 SET FDA(52.2,PFIENS,.03)=REMARKS
+24 ;
+25 ; setting the partial fill date to the dispense date to match the
+26 ; HL7 response
+27 SET FDA(52.2,PFIENS,7.5)=PFDATE
+28 ;
+29 SET RXPR(RRXIEN)=PFIEN
SET PSOZZ=1
SET PRMK=REMARKS
+30 ; file the rest of the data onto the newly created multiple.
+31 DO FILE^DIE(,"FDA")
KILL FDA
+32 IF Z1
IF $GET(PRMK)]""
Begin DoDot:1
+33 DO ACT
+34 SET ZD(RXN)=+^PSRX(RXN,"P",Z1,0)
SET ^PSRX(RXN,"TYPE")=Z1
SET $PIECE(^PSRX(RXN,"P",Z1,0),"^",11)=$PIECE($GET(^PSDRUG(DRG,660)),"^",6)
End DoDot:1
if $TEXT(EN^PSOHDR)]""
DO EN^PSOHDR("PPAR",RXN)
KILL DIE,RXN,RXF
+35 ;D:$D(BINGRTE)&($D(DISGROUP)) ^PSOBING1 K BINGRTE,TM,TM1
if '$DATA(PSOFROM)
SET PSOFROM="PARTIAL"
SET BINGCRT=1
+36 ; bwf 8/14/14 - set up needed variables for label printing
+37 SET PSODFN=$PIECE(^PSRX(RRXIEN,0),U,2)
+38 SET PSORX("PSOL",1)=RRXIEN_","
+39 SET PSORX("MAIL/WINDOW")="WINDOW"
+40 SET PSORX("NAME")=$$GET1^DIQ(2,PSODFN,.01)
+41 SET PSORX("QFLG")=0
+42 SET PSORX("METHOD OF PICKUP")=""
+43 SET PSOX=$GET(^PS(55,PSODFN,"PS"))
IF PSOX]""
SET PSORX("PATIENT STATUS")=$PIECE($GET(^PS(53,PSOX,0)),"^")
+44 NEW PPL1
+45 SET PPL1=RRXIEN
+46 SET HFSDONE=0
SET PTHDAT=""
+47 SET PSODFDIR=$$DEFDIR^%ZISH()
+48 SET PSOFNAME="PSOLBL_"_RXNUM_"_"_PSOSITE_"_"_DT_".DAT"
+49 SET FULLPTH=PSODFDIR_PSOFNAME
+50 ; bwf 8/14/14 - end setup for label printing.
+51 ; preserve IO
+52 DO SAVDEV^%ZISUTL("ONEVAHLIO")
+53 ; delete the file first to ensure there isn't one lingering around
+54 SET DELARR("PSOLBL_"_RXNUM_"_"_PSOSITE_"_"_DT_".DAT")=""
SET DEL=$$DEL^%ZISH(PSODFDIR,$NAME(DELARR))
+55 SET PSOEXREP=1
+56 ; call out to generate label
+57 DO LABEL^PSORWRAP(RRXIEN,"HFS",PSOSITE,PSOPHDUZ,"",PSOFNAME)
+58 SET XTMPLOC="^XTMP(""PSORLBL"","_HLINSTN_","_+RXNUM_",1,0)"
+59 SET PASSLOC="XTMP(""PSORLBL"","_HLINSTN_","_+RXNUM_")"
+60 KILL ^XTMP("PSORLBL",HLINSTN,+RXNUM)
+61 SET ^XTMP("PSORLBL",HLINSTN,+RXNUM,0)=DT_U_$$FMADD^XLFDT(DT,30)
+62 ; looks like we have to wait a moment before the file shows up.
+63 SET FTGSTRT=$$NOW^XLFDT
SET (FOUND,FTGOPEN)=0
+64 NEW PAR
SET PAR=0
+65 FOR
Begin DoDot:1
+66 SET FTGOPEN=$$FTG^%ZISH(PSODFDIR,PSOFNAME,XTMPLOC,4)
+67 IF $ORDER(^XTMP("PSORLBL",HLINSTN,+RXNUM,0))
SET FOUND=1
End DoDot:1
if $$NOW^XLFDT>$$FMADD^XLFDT(FTGSTRT,,,,15)!(FOUND)!(FTGOPEN)
QUIT
+68 SET DELARR("PSOLBL_"_RXNUM_"_"_PSOSITE_"_"_DT_".DAT")=""
SET DEL=$$DEL^%ZISH(PSODFDIR,$NAME(DELARR))
+69 ; restore IO
+70 DO USE^%ZISUTL("ONEVAHLIO")
DO RMDEV^%ZISUTL("ONEVAHLIO")
+71 DO UPDPAR(.VALMSG,RRXIEN,PHARM,PHONE,SITE,PASSLOC)
+72 SET RX0=$GET(^PSRX(RRXIEN,0))
SET RX2=$GET(^PSRX(RRXIEN,2))
SET RX3=$GET(^PSRX(RRXIEN,3))
+73 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")
+74 SET RSIG=$GET(^PSRX(RRXIEN,"SIG"))
+75 SET RPAR0=$GET(^PSRX(RRXIEN,"P",PFIEN,0))
+76 SET ROR1=$GET(^PSRX(RRXIEN,"OR1"))
+77 SET RREFIEN=$ORDER(^PSRX(RRXIEN,1,"A"),-1)
+78 IF RREFIEN
SET RREF0=$GET(^PSRX(RRXIEN,1,RREFIEN,0))
CLCX DO ULK
KILL DR,DIE,DRG,PPL,RXP,IOP,DA,PHYS,PSOPRZ,PSORX,PSOSIEN,PSOSITE,PSOX,PSOZZ,PSXSYS,RXPR,ZD
QUIT
+1 ;
KILL SET DA=Z1
SET DIK="^PSRX("_RXN_",""P"","
DO ^DIK
SET ^PSRX(RXN,"TYPE")=0
+1 DO ULK
SET VALMSG(1)="No Partial Fill Dispensed"
DO PARFAIL(.VALMSG,RRXIEN,PHARM,PHONE,SITE)
QUIT
KL KILL DFN,RFDAT,RLL,%,PRMK,PM,%Y,%X,D0,D1,DA,DI,DIC,DIE,DLAYGO,DQ,DR,I,II,J,JJJ,N,PHYS,PS,PSDATE,RFL,RFL1,RXF,ST,ST0,Z,Z1,X,Y,PDT,PSL,PSNP
+1 KILL PSOM,PSOP,PSOD,PSOU,DIK,DUOUT,IFN,RXN,DRG,HRX,I1,PSOCLC,PSOLIST,PSOLST,PSPAR,RXP
DO KVA^VADPT
QUIT
ACT ;adds activity info for partial rx
+1 SET RXF=0
FOR I=0:0
SET I=$ORDER(^PSRX(RRXIEN,1,I))
if 'I
QUIT
SET RXF=I
if I>5
SET RXF=I+1
+2 SET DA=0
FOR FDA=0:0
SET FDA=$ORDER(^PSRX(RRXIEN,"A",FDA))
if 'FDA
QUIT
SET DA=FDA
+3 SET DA=DA+1
SET ^PSRX(RRXIEN,"A",0)="^52.3DA^"_DA_"^"_DA
SET ^PSRX(RRXIEN,"A",DA,0)=DT_"^"_"P"_"^"_PSOPHDUZ_"^"_RXF_"^"_PRMK
EX KILL RXF,I,FDA
SET DA=RXN
+1 QUIT
ULK ;
+1 KILL PSOMSG,PSOPLCK,PSORPDFN
+2 QUIT
PARFAIL(PSOMSG,PSOIEN,RPHARM,RPHONE,RSITE) ;
+1 SET PSOMSG(0)=0_U_$$GET1^DIQ(52,PSOIEN,.01,"I")_U_PSOIEN
SET $PIECE(PSOMSG(0),U,15)=RPHARM
SET $PIECE(PSOMSG(0),U,16)=RPHONE
SET $PIECE(PSOMSG(0),U,17)=RSITE
+2 QUIT
UPDPAR(PSOMSG,PSOIEN,RPHARM,RPHONE,RSITE,PASSLOC) ;
+1 NEW PARIEN,PARIENS,PARDATA,FIL,RXNUM,RFILLDT,QTY,DSUPP,CLERK,LOGDATE,IDIV,EDIV,DISPDT,NDC,FDA,DNAME,DIEN
+2 SET FIL=52.2
+3 ; get last partial data node
+4 SET PARIEN=$ORDER(^PSRX(PSOIEN,"P",""),-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 PARIENS=PARIEN_","_PSOIEN_","
+9 ; first, set in the remote pharmacist data
+10 SET FDA(52.2,PARIENS,91)=RSITE
+11 SET FDA(52.2,PARIENS,92)=RPHARM
+12 SET FDA(52.2,PARIENS,93)=RPHONE
+13 DO FILE^DIE(,"FDA","MSG")
KILL FDA,RPHARM,RPHONE,RSITE
+14 ; now query data and build RET(0) holding accurate information from the refill multiple
+15 DO GETS^DIQ(FIL,PARIENS,"**","IE","PARDATA")
+16 SET RFILLDT=$GET(PARDATA(FIL,PARIENS,.01,"I"))
+17 SET QTY=$GET(PARDATA(FIL,PARIENS,.04,"I"))
+18 SET DSUPP=$GET(PARDATA(FIL,PARIENS,.041,"I"))
+19 SET CLERK=$GET(PARDATA(FIL,PARIENS,.07,"E"))
+20 SET LOGDATE=$GET(PARDATA(FIL,PARIENS,.08,"I"))
+21 ; internal division number (IEN to PSO SITE file)
+22 SET IDIV=$GET(PARDATA(FIL,PARIENS,.09,"I"))
+23 SET EDIV=$GET(PARDATA(FIL,PARIENS,.09,"E"))
+24 ;
+25 ; there is nothing in this field.
+26 ; HL7 is returning refill date in the RXD
+27 ; but trying to log the blank dispense date from file 52.2 into 52.09
+28 SET DISPDT=$GET(PARDATA(FIL,PARIENS,7.5,"I"))
+29 ;
+30 SET NDC=$GET(PARDATA(FIL,PARIENS,1,"E"))
+31 SET RSITE=$GET(PARDATA(FIL,PARIENS,91,"I"))
+32 SET RPHARM=$GET(PARDATA(FIL,PARIENS,92,"E"))
+33 SET RPHONE=$GET(PARDATA(FIL,PARIENS,93,"E"))
+34 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
+35 DO LOGDATA^PSORWRAP($NAME(DAT),"OP",,,PSOIEN,,PARIEN)
+36 SET PSOMSG(0)=1_U_RXNUM_U_PSOIEN_U_PARIEN_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
+37 IF '$LENGTH($GET(PSOMSG(1)))
SET PSOMSG(1)="Partial complete for RX #"_RXNUM_"."
+38 QUIT
