PSORXED ;IHS/DSD/JCM - edit rx utility ;Dec 03, 2020@10:39:54
;;7.0;OUTPATIENT PHARMACY;**2,16,21,26,56,71,125,201,246,289,298,366,385,403,421,482,512,621,441,673**;DEC 1997;Build 1
;External reference to ^PSXEDIT supported by DBIA 2209
;External reference to ^DD(52 supported by DBIA 999
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^PS(55 supported by DBIA 2228
;
START ;this entry point is no longer used.
;D INIT,LKUP G:PSORXED("QFLG") END D PARSE,EOJ G START
;
END D EOJ
Q
;
INIT S PSORXED("QFLG")=0 Q
;
LKUP ; this line of code is no longer used S PSONUM="RX",PSONUM("A")="EDIT",PSOQFLG=0 D EN1^PSONUM I PSOQFLG!($Q(PSOLIST)']"") S PSORXED("QFLG")=1
K PSOQFLG Q
;
PARSE F PSORXED("LIST")=1:1 Q:'$D(PSOLIST(PSORXED("LIST")))!PSORXED("QFLG") F PSORXED("I")=1:1:$L(PSOLIST(PSORXED("LIST"))) S PSORXED("IRXN")=$P(PSOLIST(PSORXED("LIST")),",",PSORXED("I")) D:+PSORXED("IRXN") PROCESS
Q
;
PROCESS S PSORXED("DFLG")=0 G:$G(^PSRX(PSORXED("IRXN"),0))']"" PROCESSX
;*298 Track PI and Oth Lang PI
S PSORXED("RX0")=^PSRX(PSORXED("IRXN"),0),PSORXED("RX2")=^(2),PSORXED("RX3")=^(3)
S PSOSIG=$G(^PSRX(PSORXED("IRXN"),"SIG"))
S PSODAYS=$P(PSORXED("RX0"),"^",8)
S PSOPINS=$G(^PSRX(PSORXED("IRXN"),"INS"))
S PSOOINS=$G(^PSRX(PSORXED("IRXN"),"INSS"))
S (I,RFED,RFDT)=0
F S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I D
. S RFED=I
. S PSORXED("RX1")=^PSRX(PSORXED("IRXN"),1,I,0),RFDT=$P(^(0),"^"),PSODAYS=$P(^(0),"^",10) S:$P(^(0),"^",17) PSONEW("PROVIDER NAME")=$P(^VA(200,$P(^(0),"^",17),0),"^")
S PSORXST=+$P($G(^PS(53,+$P(PSORXED("RX0"),"^",3),0)),"^",7)
N DA
S DA=PSORXED("IRXN")
D EN^PSORXPR
D CHECK G:PSORXED("DFLG") PROCESSX
N X
S X="PSXEDIT" X ^%ZOSF("TEST") K X I $T D ^PSXEDIT I $G(PSXOUT) K PSXOUT G L1
D DIE^PSORXED1
;
L1 D LOG,POST
;
PROCESSX Q
;
CHECK Q L +^PSRX(PSORXED("IRXN")):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W $C(7),!!,"Rx Number is Locked by Another User!",! S PSORXED("DFLG")=1 H 5 Q
I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")<DT D G CHECKX
. W !,$C(7),"This drug has been inactivated. ",! S PSORXED("DFLG")=1 Q
;
K PSPOP I $G(PSODIV),$P(PSORXED("RX2"),"^",9)'=PSOSITE S PSPRXN=PSORXED("IRXN") D CHK1^PSOUTLA I $G(PSPOP)=1 S PSORXED("DFLG")=1 G CHECKX
;
I $P(^PSRX(PSORXED("IRXN"),"STA"),"^")=14!($P(^("STA"),"^")=15) S PSORXED("DFLG")=1 W !!,$C(7),"Discontinued prescriptions cannot be edited.",! G CHECKX
I $D(^PS(52.4,"B",PSORXED("IRXN"))) S PSORXED("DFLG")=1 W !!,$C(7),"Non-verified prescriptions cannot be edited.",!
;
CHECKX K PSPOP,DIR,DTOUT,DUOUT,Y,X Q
;
LOG K PSFROM S DA=PSORXED("IRXN"),(PSRX0,RX0)=PSORXED("RX0"),QTY=$P(RX0,"^",7),QTY=QTY-$P(^PSRX(DA,0),"^",7) K ZD(DA) S:'$O(^PSRX(DA,1,0)) ZD(DA)=$P(^PSRX(DA,2),"^",2)
;
; PSOBPS and PSOTRIC are used to check eligibility. Eligibility checking
; is only needed for non-billable Rxs (ie PSOBPS'="e")
N PSOBPS,PSOTRIC
S PSOBPS=$$ECME^PSOBPSUT(PSORXED("IRXN"))
S PSOTRIC=$$TRIC^PSOREJP1(PSORXED("IRXN"),0,.PSOTRIC)
;
;p673 Issue date (field 13) log update
S COM="" F I=3,4,5:1:12,17 I $P(PSRX0,"^",I)'=$P(^PSRX(DA,0),"^",I) S COM=COM_$P(^DD(52,I,0),"^")_" ("_$P(PSRX0,"^",I)_"),"
I $P(PSRX0,"^",13)'=$P(^PSRX(DA,0),"^",13) D
. N PSONISDT S PSONISDT=$P(PSRX0,"^",13) S PSONISDT=$E(PSONISDT,4,5)_"/"_$E(PSONISDT,6,7)_"/"_$E(PSONISDT,2,3)
. S COM=COM_$P(^DD(52,1,0),"^")_" ("_PSONISDT_")," K PSONISDT
;
N PSOFILDAT
S PSOFILDAT=0 ; fill date edit flag
;
;p673 fill date log update
I $P(PSORXED("RX2"),"^",2)'=$P(^PSRX(DA,2),"^",2) D
. N PSONISDT S PSONISDT=$P(PSORXED("RX2"),"^",2) S PSONISDT=$E(PSONISDT,4,5)_"/"_$E(PSONISDT,6,7)_"/"_$E(PSONISDT,2,3)
. S COM=COM_$P(^DD(52,22,0),"^")_" ("_PSONISDT_"),",PSOFILDAT=1 ; set flag indicating the original fill date was edited
I $P(PSORXED("RX3"),"^",7)'=$P(^PSRX(DA,3),"^",7) S COM=COM_$P(^DD(52,12,0),"^")_" ("_$P(PSORXED("RX3"),"^",7)_"),"
I PSOSIG'=$P($G(^PSRX(DA,"SIG")),"^") S COM=COM_$P(^DD(52,10,0),"^")_" ("_PSOSIG_"),"
;*298 Track PI and Oth Lang PI
I PSOPINS'=$G(^PSRX(DA,"INS")) S COM=COM_$P(^DD(52,114,0),"^")_" ("_PSOPINS_"),"
I PSOOINS'=$G(^PSRX(DA,"INSS")) S COM=COM_$P(^DD(52,114.1,0),"^")_" ("_PSOOINS_"),"
I PSOPIND'=$P($G(^PSRX(DA,"IND")),"^") S COM=COM_$P(^DD(52,128,0),"^")_" ("_PSOPIND_")," ;*441-IND
I PSOPINDF'=$P($G(^PSRX(DA,"IND")),"^",2) S COM=COM_$P(^DD(52,129,0),"^")_" ("_PSOPINDF_")," ;*441-IND
I PSOTRN'=$G(^PSRX(DA,"TN")) S COM=COM_$P(^DD(52,6.5,0),"^")_" ("_PSOTRN_"),"
D FILL
I '$$RXRLDT^PSOBPSUT(PSORXED("IRXN"),PSOEDITF),COM="",PSOBPS="e" D LBLCHK G:'PSOEDITL LOGX G LOG1
I PSOTRIC&('$$RXRLDT^PSOBPSUT(PSORXED("IRXN"),PSOEDITF)),COM="",PSOBPS'="e" D LBLCHK G LOGX ; labels for unreleased TRICARE/CHAMPVA resolved claims; when COM'="" label always printed
I PSOTRIC&(COM=""),PSOBPS'="e" D LBL D ASKL:PSOEDITL G:'PSOEDITL LOGX G LOG1
I COM="" S RX0=^PSRX(DA,0),RX2=^(2),J=DA,OEXDT=+$P(RX2,"^",6) D ^PSOEXDT G LOGX
K PSRX0 S X=$S($D(PSOCLC):PSOCLC,1:DUZ)
S K=1,D1=0 F Z=0:0 S Z=$O(^PSRX(DA,"A",Z)) Q:'Z S D1=Z,K=K+1
S D1=D1+1 S:'($D(^PSRX(DA,"A",0))#2) ^(0)="^52.3DA^^^" S ^(0)=$P(^(0),"^",1,2)_"^"_D1_"^"_K
;
N COMEDT S COMEDT=COM S:$E(COM,$L(COM))="," COMEDT=$E(COM,1,$L(COM)-1) ;p673 strip end comma
;PSO*7*366
D NOW^%DTC S ^PSRX(DA,"A",D1,0)=%_"^E^"_$G(DUZ)_"^0^"_COMEDT
;
LOG1 ;
I QTY,$P(^PSRX(DA,2),"^",13) S ^PSDRUG($P(^PSRX(DA,0),"^",6),660.1)=$S($D(^PSDRUG(+$P(^PSRX(DA,0),"^",6),660.1)):^(660.1)+QTY,1:QTY)
S:$P(RX0,"^",6)'=$P(^PSRX(DA,0),"^",6) ^PSDRUG(+$P(^PSRX(DA,0),"^",6),660.1)=$S($D(^PSDRUG(+$P(RX0,"^",6),660.1)):^(660.1)+$P(RX0,"^",7),1:$P(RX0,"^",7))
S RX0=^PSRX(DA,0),RX2=^(2),J=DA,OEXDT=+$P(RX2,"^",6) D ^PSOEXDT S NEXDT=+$P(RX2,"^",6) I OEXDT'=NEXDT D
.K ^PSRX("AG",OEXDT,DA) S ^PSRX("AG",NEXDT,DA)=""
.S D=+$P(RX0,"^",2) K ^PS(55,D,"P","A",OEXDT,DA) S ^PS(55,D,"P","A",NEXDT,DA)=""
K D,OEXDT,NEXDT
;
; Do not add RX to the label list when there are:
; 1) Unresolved DUR/Refill Too Soon/RRR rejects
; 2) Unresolved TRICARE/CHAMPVA rejects
; 3) TRICARE/CHAMPVA claims that are IN PROGRESS
; 4) Being edited from Mail or Window to Park ;ADDED PAPI LINE OF CODE
; But if the Fill Date was modified then bypass these checks and allow to update the label list - PSO*7*403
I 'PSOFILDAT,$$ECMECHK^PSOREJU3(DA,$G(PSOEDITF)) G LOGX
;
; If Rx is non-billable
I PSOBPS'="e" G:+$P(^PSRX(J,"STA"),"^")!($G(PSOEDITL)=1&('$G(PSOTRIC))) LOGX S RXFL(PSORXED("IRXN"))=$S($G(PSOEDITF):$G(PSOEDITF),1:0) I $G(PSORX("PSOL",1))']"",'$G(PSOTOPK) S PSORX("PSOL",1)=PSORXED("IRXN")_"," D SETRP G LOGX
I PSOBPS'="e" G:$G(PSOEDITL)=1&('$G(PSOTRIC)) LOGX
;
; If Rx is billable
I PSOBPS="e",$$RXRLDT^PSOBPSUT(DA,$G(PSOEDITF)) G LOGX
I PSOBPS="e" D I 'PTLBL G LOGX
. S PTLBL=1,PSOACT=0
. F S PSOACT=$O(^PSRX(DA,"A",PSOACT)) Q:'PSOACT D Q:'PTLBL
. . I $$GET1^DIQ(52.3,PSOACT_","_DA,.05,"E")["CMOP Suspense Label Printed" S PTLBL=0
I $G(PSOTOPK) G LOGX ;ADDED PAPI
;
I PSOBPS="e" G:+$P(^PSRX(J,"STA"),"^")!($G(PSOEDITL)=1&('$G(PSOTRIC))) LOGX S RXFL(PSORXED("IRXN"))=$S($G(PSOEDITF):$G(PSOEDITF),1:0) I $G(PSORX("PSOL",1))']"" I '$G(PSOTOPK) S PSORX("PSOL",1)=PSORXED("IRXN")_"," D SETRP G LOGX
;
F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
I $L(PSORX("PSOL",PSOX2))+$L(PSORXED("IRXN"))<220 D G LOGX
.I PSORX("PSOL",PSOX2)'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSORXED("IRXN")_"," D SETRP
E I $G(PSORX("PSOL",PSOX2+1))'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2+1)=PSORXED("IRXN")_"," D SETRP ;;PSO*7*246
;
LOGX K PSOEDITF,PSOEDITR,PSOEDITL D:$G(RFED) ^PSORXED1
K PSOTOPK,PSOFRPK ;ADDED PAPI LINE OF CODE
Q
;
POST ; D NEXT D:$G(^PSRX(PSORXED("IRXN"),"IB"))]"" COPAY K PSODAYS,PSORXST
D NEXT D COPAY K PSODAYS,PSORXST
Q
;
COPAY S DA=PSORXED("IRXN") I 'RFD,PSODAYS'=+$P(^PSRX(DA,0),"^",8) I +$G(^PSRX(DA,"IB"))!($P($G(^PSRX(DA,"PFS")),"^",2)) D CPCK G RXST
I RFD,+$G(^PSRX(DA,1,RFD,0)),PSODAYS'=$P($G(^PSRX(DA,1,RFD,0)),"^",10) I +$G(^PSRX(DA,"IB"))!($P($G(^PSRX(DA,1,RFD,"PFS")),"^",2)) D CPCK
;
RXST G:PSORXST=+$P($G(^PS(53,+$P(^PSRX(DA,0),"^",3),0)),"^",7) COPAYX
W !,$C(7),"Patient Status field for this Rx has been changed from a ",$S(PSORXST=0:"COPAYMENT ELIGIBLE",PSORXST=1:"COPAYMENT EXEMPT",1:"")
W !,"patient status."
W " The copay status for this Rx will be automatically adjusted."
W !,"If action needs to be taken to adjust charges you MUST use the"
W !,"Reset Copay Status/Cancel Charges option."
W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
I +$P($G(^PS(53,+$P(^PSRX(DA,0),"^",3),0)),"^",7)=1 D ; SET TO NO COPAY AND AUDIT CHANGE
. I '$D(^PSRX(DA,"IB")) S ^PSRX(DA,"IB")=""
. S $P(^PSRX(DA,"IB"),"^",1)=""
. S PSODA=DA
. S PSOREF=RFD
. S PSOCOMM="Rx Patient Status Change"
. S PSOOLD="Copay"
. S PSONW="No Copay"
. S PREA="R"
. D ACTLOG^PSOCPA
;
COPAYX K DA,PSODAYS,PSO,PSODA,PSOFLAG,PSORXST,RFD,PSOREF,PSOCOMM,PSOOLD,PSONW
Q
;
CPCK ;update COPAY
I 'RFD,'$D(^PSRX(DA,"PFS")) G CPCK1
I RFD,'$D(^PSRX(DA,1,RFD,"PFS")) G CPCK1
N PSOPFS S PSOPFS=$P($S('RFD:^PSRX(DA,"PFS"),1:^PSRX(DA,1,RFD,"PFS")),"^",1,2)
I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q
I +$G(PSOPFS)<1 K PSOPFS
E S PSOPFS="1^"_PSOPFS
;
CPCK1 N TYPE S PSO=2,PSODA=DA,PSOFLAG=1,PSOPAR7=$G(^PS(59,PSOSITE,"IB")),TYPE=RFD D RXED^PSOCPA K TYPE
Q
;
NEXT D NEXT^PSOUTIL(.PSORXED) K DIE,DR,DA S DIE="^PSRX(",DA=PSORXED("IRXN")
S DR="101///"_$P(PSORXED("RX3"),"^")_";102///"_$P(PSORXED("RX3"),"^",2) D ^DIE K DIE,DR,DA,X,Y
Q
;
EOJ K PSOSIG,PSORXED,PSOLIST,END,PSRX0,PSOPINS,PSOOINS
D EX^PSORXED1
Q
;
FILL ;
K PSOEDITF,PSOEDITR,PSOERF
F PSOEZ=0:0 S PSOEZ=$O(^PSRX(DA,1,PSOEZ)) Q:'PSOEZ S:$D(^PSRX(DA,1,PSOEZ,0)) PSOERF=PSOEZ
S PSOEDITF=$S($G(PSOERF):+$G(PSOERF),1:0)
I PSOEDITF S PSOEDITR=$S($P($G(^PSRX(DA,1,PSOEDITF,0)),"^",18):1,1:0) G FILLX
S PSOEDITR=$S($P($G(^PSRX(DA,2)),"^",13):1,1:0)
;
FILLX K PSOERF,PSOEZ
Q
;
LBL ;
S PSOEDITL=0 N PSOECMES S PSOECMES="",PSOECMES=$$STATUS^PSOBPSUT(PSORXED("IRXN"),PSOEDITF)
I PSOTRIC D Q:'PSOEDITL
. I PSOECMES["IN PROGRESS"!(PSOECMES["REJECTED") S PSOEDITL=0 Q
. I $$FIND^PSOREJUT(PSORXED("IRXN"),PSOEDITF,,,1) S PSOEDITL=0 Q
. I ",12,14,15,"[(","_$P($G(^PSRX(PSORXED("IRXN"),"STA")),"^")_",") S PSOEDITL=0 Q
. I COM="" S:'$G(PSOEDITF)&$G(PSOEDITR) PSOEDITL=2 Q
Q:PSOEDITL=2&($G(PSOTRIC))&(COM="")
I COM["PROV"!(COM["QTY")!(COM["DAYS")!(COM["MAIL")!(COM["UNIT")!(COM["FILL DATE")!(COM["REMARKS") I COM'["STATUS",COM'["CLINIC",COM'["DRUG",COM'["REFILLS",COM'["ISSUE",COM'["SIG",COM'["TRADE" D Q
.I $G(PSOEDITF) S PSOEDITL=1 Q
.I '$G(PSOEDITF),'$G(PSOEDITR),PSOTRIC S PSOEDITL=2 Q
.I '$G(PSOEDITF),$G(PSOEDITR) S PSOEDITL=2
I '$G(PSOEDITF),$G(PSOEDITR) S PSOEDITL=2 Q
I '$G(PSOEDITF),'$G(PSOEDITR) S PSOEDITL=0 Q
I $G(RXRP(DA)) S PSOEDITL=1 Q
I '$G(RXRP(DA)),$G(PSOEDITR) S PSOEDITL=2 Q
S PSOEDITL=0
Q
;
LBLCHK ;
;
; If Rx is non-billable perform checks and quit
I PSOBPS'="e" D Q
. I '$$RXRLDT^PSOBPSUT(PSORXED("IRXN"),PSOEDITF) D
. . I $$PTLBL^PSOREJP2(PSORXED("IRXN"),PSOEDITF) D PRINT^PSOREJP3(PSORXED("IRXN"),PSOEDITF)
;
; Rx is billable
;
; If the PSOEDITL flag is set to 1, the user will be given the QUEUE
; prompt; if set to 0, the QUEUE prompt is suppressed.
; PSORX("NOLABEL") is used to determine if the Label Prompt should
; be displayed to the user by calling routine.
;
S PSOEDITL=0
S PSORX("NOLABEL")=1
;
I $$RXRLDT^PSOBPSUT(PSORXED("IRXN"),PSOEDITF) Q
;
I $$PTLBL^PSOREJP2(PSORXED("IRXN"),PSOEDITF) D
. S PSORX("NOLABEL")=0
. I $D(PSORX("QFLG")) S PSOEDITL=1
. E D PRINT^PSOREJP3(PSORXED("IRXN"),PSOEDITF)
Q
;
ASKL ;
W ! K DIR S DIR("?",1)="You have edited a fill that has already been released. Do you want to",DIR("?",2)="include this prescription as one of the prescriptions to be acted upon",DIR("?",3)="at the label prompt."
S DIR("?")="Enter 'Yes' to generate a reprint label request."
S DIR(0)="Y",DIR("A")="The last fill has been released, do you want a reprint label",DIR("B")="Y" D ^DIR K DIR I Y'=1 S PSOEDITL=0 Q ; User did not reply as "YES" - don't prompt for label device
S PSOEDITL=1
Q
;
SETRP I '$G(PSOTOPK),$P($G(^PSRX(PSORXED("IRXN"),"STA")),"^")'=5,$G(PSOEDITL)=0 S RXRP(PSORXED("IRXN"))="1^^^1",VALMSG="Label will reprint due to Edit"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORXED 12460 printed Sep 23, 2025@20:10:54 Page 2
PSORXED ;IHS/DSD/JCM - edit rx utility ;Dec 03, 2020@10:39:54
+1 ;;7.0;OUTPATIENT PHARMACY;**2,16,21,26,56,71,125,201,246,289,298,366,385,403,421,482,512,621,441,673**;DEC 1997;Build 1
+2 ;External reference to ^PSXEDIT supported by DBIA 2209
+3 ;External reference to ^DD(52 supported by DBIA 999
+4 ;External reference to ^PSDRUG supported by DBIA 221
+5 ;External reference to ^PS(55 supported by DBIA 2228
+6 ;
START ;this entry point is no longer used.
+1 ;D INIT,LKUP G:PSORXED("QFLG") END D PARSE,EOJ G START
+2 ;
END DO EOJ
+1 QUIT
+2 ;
INIT SET PSORXED("QFLG")=0
QUIT
+1 ;
LKUP ; this line of code is no longer used S PSONUM="RX",PSONUM("A")="EDIT",PSOQFLG=0 D EN1^PSONUM I PSOQFLG!($Q(PSOLIST)']"") S PSORXED("QFLG")=1
+1 KILL PSOQFLG
QUIT
+2 ;
PARSE FOR PSORXED("LIST")=1:1
if '$DATA(PSOLIST(PSORXED("LIST")))!PSORXED("QFLG")
QUIT
FOR PSORXED("I")=1:1:$LENGTH(PSOLIST(PSORXED("LIST")))
SET PSORXED("IRXN")=$PIECE(PSOLIST(PSORXED("LIST")),",",PSORXED("I"))
if +PSORXED("IRXN")
DO PROCESS
+1 QUIT
+2 ;
PROCESS SET PSORXED("DFLG")=0
if $GET(^PSRX(PSORXED("IRXN"),0))']""
GOTO PROCESSX
+1 ;*298 Track PI and Oth Lang PI
+2 SET PSORXED("RX0")=^PSRX(PSORXED("IRXN"),0)
SET PSORXED("RX2")=^(2)
SET PSORXED("RX3")=^(3)
+3 SET PSOSIG=$GET(^PSRX(PSORXED("IRXN"),"SIG"))
+4 SET PSODAYS=$PIECE(PSORXED("RX0"),"^",8)
+5 SET PSOPINS=$GET(^PSRX(PSORXED("IRXN"),"INS"))
+6 SET PSOOINS=$GET(^PSRX(PSORXED("IRXN"),"INSS"))
+7 SET (I,RFED,RFDT)=0
+8 FOR
SET I=$ORDER(^PSRX(PSORXED("IRXN"),1,I))
if 'I
QUIT
Begin DoDot:1
+9 SET RFED=I
+10 SET PSORXED("RX1")=^PSRX(PSORXED("IRXN"),1,I,0)
SET RFDT=$PIECE(^(0),"^")
SET PSODAYS=$PIECE(^(0),"^",10)
if $PIECE(^(0),"^",17)
SET PSONEW("PROVIDER NAME")=$PIECE(^VA(200,$PIECE(^(0),"^",17),0),"^")
End DoDot:1
+11 SET PSORXST=+$PIECE($GET(^PS(53,+$PIECE(PSORXED("RX0"),"^",3),0)),"^",7)
+12 NEW DA
+13 SET DA=PSORXED("IRXN")
+14 DO EN^PSORXPR
+15 DO CHECK
if PSORXED("DFLG")
GOTO PROCESSX
+16 NEW X
+17 SET X="PSXEDIT"
XECUTE ^%ZOSF("TEST")
KILL X
IF $TEST
DO ^PSXEDIT
IF $GET(PSXOUT)
KILL PSXOUT
GOTO L1
+18 DO DIE^PSORXED1
+19 ;
L1 DO LOG
DO POST
+1 ;
PROCESSX QUIT
+1 ;
CHECK QUIT
LOCK +^PSRX(PSORXED("IRXN")):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
WRITE $CHAR(7),!!,"Rx Number is Locked by Another User!",!
SET PSORXED("DFLG")=1
HANG 5
QUIT
+1 IF $GET(^PSDRUG($PIECE(PSORXED("RX0"),"^",6),"I"))]""
IF ^("I")<DT
Begin DoDot:1
+2 WRITE !,$CHAR(7),"This drug has been inactivated. ",!
SET PSORXED("DFLG")=1
QUIT
End DoDot:1
GOTO CHECKX
+3 ;
+4 KILL PSPOP
IF $GET(PSODIV)
IF $PIECE(PSORXED("RX2"),"^",9)'=PSOSITE
SET PSPRXN=PSORXED("IRXN")
DO CHK1^PSOUTLA
IF $GET(PSPOP)=1
SET PSORXED("DFLG")=1
GOTO CHECKX
+5 ;
+6 IF $PIECE(^PSRX(PSORXED("IRXN"),"STA"),"^")=14!($PIECE(^("STA"),"^")=15)
SET PSORXED("DFLG")=1
WRITE !!,$CHAR(7),"Discontinued prescriptions cannot be edited.",!
GOTO CHECKX
+7 IF $DATA(^PS(52.4,"B",PSORXED("IRXN")))
SET PSORXED("DFLG")=1
WRITE !!,$CHAR(7),"Non-verified prescriptions cannot be edited.",!
+8 ;
CHECKX KILL PSPOP,DIR,DTOUT,DUOUT,Y,X
QUIT
+1 ;
LOG KILL PSFROM
SET DA=PSORXED("IRXN")
SET (PSRX0,RX0)=PSORXED("RX0")
SET QTY=$PIECE(RX0,"^",7)
SET QTY=QTY-$PIECE(^PSRX(DA,0),"^",7)
KILL ZD(DA)
if '$ORDER(^PSRX(DA,1,0))
SET ZD(DA)=$PIECE(^PSRX(DA,2),"^",2)
+1 ;
+2 ; PSOBPS and PSOTRIC are used to check eligibility. Eligibility checking
+3 ; is only needed for non-billable Rxs (ie PSOBPS'="e")
+4 NEW PSOBPS,PSOTRIC
+5 SET PSOBPS=$$ECME^PSOBPSUT(PSORXED("IRXN"))
+6 SET PSOTRIC=$$TRIC^PSOREJP1(PSORXED("IRXN"),0,.PSOTRIC)
+7 ;
+8 ;p673 Issue date (field 13) log update
+9 SET COM=""
FOR I=3,4,5:1:12,17
IF $PIECE(PSRX0,"^",I)'=$PIECE(^PSRX(DA,0),"^",I)
SET COM=COM_$PIECE(^DD(52,I,0),"^")_" ("_$PIECE(PSRX0,"^",I)_"),"
+10 IF $PIECE(PSRX0,"^",13)'=$PIECE(^PSRX(DA,0),"^",13)
Begin DoDot:1
+11 NEW PSONISDT
SET PSONISDT=$PIECE(PSRX0,"^",13)
SET PSONISDT=$EXTRACT(PSONISDT,4,5)_"/"_$EXTRACT(PSONISDT,6,7)_"/"_$EXTRACT(PSONISDT,2,3)
+12 SET COM=COM_$PIECE(^DD(52,1,0),"^")_" ("_PSONISDT_"),"
KILL PSONISDT
End DoDot:1
+13 ;
+14 NEW PSOFILDAT
+15 ; fill date edit flag
SET PSOFILDAT=0
+16 ;
+17 ;p673 fill date log update
+18 IF $PIECE(PSORXED("RX2"),"^",2)'=$PIECE(^PSRX(DA,2),"^",2)
Begin DoDot:1
+19 NEW PSONISDT
SET PSONISDT=$PIECE(PSORXED("RX2"),"^",2)
SET PSONISDT=$EXTRACT(PSONISDT,4,5)_"/"_$EXTRACT(PSONISDT,6,7)_"/"_$EXTRACT(PSONISDT,2,3)
+20 ; set flag indicating the original fill date was edited
SET COM=COM_$PIECE(^DD(52,22,0),"^")_" ("_PSONISDT_"),"
SET PSOFILDAT=1
End DoDot:1
+21 IF $PIECE(PSORXED("RX3"),"^",7)'=$PIECE(^PSRX(DA,3),"^",7)
SET COM=COM_$PIECE(^DD(52,12,0),"^")_" ("_$PIECE(PSORXED("RX3"),"^",7)_"),"
+22 IF PSOSIG'=$PIECE($GET(^PSRX(DA,"SIG")),"^")
SET COM=COM_$PIECE(^DD(52,10,0),"^")_" ("_PSOSIG_"),"
+23 ;*298 Track PI and Oth Lang PI
+24 IF PSOPINS'=$GET(^PSRX(DA,"INS"))
SET COM=COM_$PIECE(^DD(52,114,0),"^")_" ("_PSOPINS_"),"
+25 IF PSOOINS'=$GET(^PSRX(DA,"INSS"))
SET COM=COM_$PIECE(^DD(52,114.1,0),"^")_" ("_PSOOINS_"),"
+26 ;*441-IND
IF PSOPIND'=$PIECE($GET(^PSRX(DA,"IND")),"^")
SET COM=COM_$PIECE(^DD(52,128,0),"^")_" ("_PSOPIND_"),"
+27 ;*441-IND
IF PSOPINDF'=$PIECE($GET(^PSRX(DA,"IND")),"^",2)
SET COM=COM_$PIECE(^DD(52,129,0),"^")_" ("_PSOPINDF_"),"
+28 IF PSOTRN'=$GET(^PSRX(DA,"TN"))
SET COM=COM_$PIECE(^DD(52,6.5,0),"^")_" ("_PSOTRN_"),"
+29 DO FILL
+30 IF '$$RXRLDT^PSOBPSUT(PSORXED("IRXN"),PSOEDITF)
IF COM=""
IF PSOBPS="e"
DO LBLCHK
if 'PSOEDITL
GOTO LOGX
GOTO LOG1
+31 ; labels for unreleased TRICARE/CHAMPVA resolved claims; when COM'="" label always printed
IF PSOTRIC&('$$RXRLDT^PSOBPSUT(PSORXED("IRXN"),PSOEDITF))
IF COM=""
IF PSOBPS'="e"
DO LBLCHK
GOTO LOGX
+32 IF PSOTRIC&(COM="")
IF PSOBPS'="e"
DO LBL
if PSOEDITL
DO ASKL
if 'PSOEDITL
GOTO LOGX
GOTO LOG1
+33 IF COM=""
SET RX0=^PSRX(DA,0)
SET RX2=^(2)
SET J=DA
SET OEXDT=+$PIECE(RX2,"^",6)
DO ^PSOEXDT
GOTO LOGX
+34 KILL PSRX0
SET X=$SELECT($DATA(PSOCLC):PSOCLC,1:DUZ)
+35 SET K=1
SET D1=0
FOR Z=0:0
SET Z=$ORDER(^PSRX(DA,"A",Z))
if 'Z
QUIT
SET D1=Z
SET K=K+1
+36 SET D1=D1+1
if '($DATA(^PSRX(DA,"A",0))#2)
SET ^(0)="^52.3DA^^^"
SET ^(0)=$PIECE(^(0),"^",1,2)_"^"_D1_"^"_K
+37 ;
+38 ;p673 strip end comma
NEW COMEDT
SET COMEDT=COM
if $EXTRACT(COM,$LENGTH(COM))=","
SET COMEDT=$EXTRACT(COM,1,$LENGTH(COM)-1)
+39 ;PSO*7*366
+40 DO NOW^%DTC
SET ^PSRX(DA,"A",D1,0)=%_"^E^"_$GET(DUZ)_"^0^"_COMEDT
+41 ;
LOG1 ;
+1 IF QTY
IF $PIECE(^PSRX(DA,2),"^",13)
SET ^PSDRUG($PIECE(^PSRX(DA,0),"^",6),660.1)=$SELECT($DATA(^PSDRUG(+$PIECE(^PSRX(DA,0),"^",6),660.1)):^(660.1)+QTY,1:QTY)
+2 if $PIECE(RX0,"^",6)'=$PIECE(^PSRX(DA,0),"^",6)
SET ^PSDRUG(+$PIECE(^PSRX(DA,0),"^",6),660.1)=$SELECT($DATA(^PSDRUG(+$PIECE(RX0,"^",6),660.1)):^(660.1)+$PIECE(RX0,"^",7),1:$PIECE(RX0,"^",7))
+3 SET RX0=^PSRX(DA,0)
SET RX2=^(2)
SET J=DA
SET OEXDT=+$PIECE(RX2,"^",6)
DO ^PSOEXDT
SET NEXDT=+$PIECE(RX2,"^",6)
IF OEXDT'=NEXDT
Begin DoDot:1
+4 KILL ^PSRX("AG",OEXDT,DA)
SET ^PSRX("AG",NEXDT,DA)=""
+5 SET D=+$PIECE(RX0,"^",2)
KILL ^PS(55,D,"P","A",OEXDT,DA)
SET ^PS(55,D,"P","A",NEXDT,DA)=""
End DoDot:1
+6 KILL D,OEXDT,NEXDT
+7 ;
+8 ; Do not add RX to the label list when there are:
+9 ; 1) Unresolved DUR/Refill Too Soon/RRR rejects
+10 ; 2) Unresolved TRICARE/CHAMPVA rejects
+11 ; 3) TRICARE/CHAMPVA claims that are IN PROGRESS
+12 ; 4) Being edited from Mail or Window to Park ;ADDED PAPI LINE OF CODE
+13 ; But if the Fill Date was modified then bypass these checks and allow to update the label list - PSO*7*403
+14 IF 'PSOFILDAT
IF $$ECMECHK^PSOREJU3(DA,$GET(PSOEDITF))
GOTO LOGX
+15 ;
+16 ; If Rx is non-billable
+17 IF PSOBPS'="e"
if +$PIECE(^PSRX(J,"STA"),"^")!($GET(PSOEDITL)=1&('$GET(PSOTRIC)))
GOTO LOGX
SET RXFL(PSORXED("IRXN"))=$SELECT($GET(PSOEDITF):$GET(PSOEDITF),1:0)
IF $GET(PSORX("PSOL",1))']""
IF '$GET(PSOTOPK)
SET PSORX("PSOL",1)=PSORXED("IRXN")_","
DO SETRP
GOTO LOGX
+18 IF PSOBPS'="e"
if $GET(PSOEDITL)=1&('$GET(PSOTRIC))
GOTO LOGX
+19 ;
+20 ; If Rx is billable
+21 IF PSOBPS="e"
IF $$RXRLDT^PSOBPSUT(DA,$GET(PSOEDITF))
GOTO LOGX
+22 IF PSOBPS="e"
Begin DoDot:1
+23 SET PTLBL=1
SET PSOACT=0
+24 FOR
SET PSOACT=$ORDER(^PSRX(DA,"A",PSOACT))
if 'PSOACT
QUIT
Begin DoDot:2
+25 IF $$GET1^DIQ(52.3,PSOACT_","_DA,.05,"E")["CMOP Suspense Label Printed"
SET PTLBL=0
End DoDot:2
if 'PTLBL
QUIT
End DoDot:1
IF 'PTLBL
GOTO LOGX
+26 ;ADDED PAPI
IF $GET(PSOTOPK)
GOTO LOGX
+27 ;
+28 IF PSOBPS="e"
if +$PIECE(^PSRX(J,"STA"),"^")!($GET(PSOEDITL)=1&('$GET(PSOTRIC)))
GOTO LOGX
SET RXFL(PSORXED("IRXN"))=$SELECT($GET(PSOEDITF):$GET(PSOEDITF),1:0)
IF $GET(PSORX("PSOL",1))']""
IF '$GET(PSOTOPK)
SET PSORX("PSOL",1)=PSORXED("IRXN")_","
DO SETRP
GOTO LOGX
+29 ;
+30 FOR PSOX1=0:0
SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
if 'PSOX1
QUIT
SET PSOX2=PSOX1
+31 IF $LENGTH(PSORX("PSOL",PSOX2))+$LENGTH(PSORXED("IRXN"))<220
Begin DoDot:1
+32 IF PSORX("PSOL",PSOX2)'[PSORXED("IRXN")_","
SET PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSORXED("IRXN")_","
DO SETRP
End DoDot:1
GOTO LOGX
+33 ;;PSO*7*246
IF '$TEST
IF $GET(PSORX("PSOL",PSOX2+1))'[PSORXED("IRXN")_","
SET PSORX("PSOL",PSOX2+1)=PSORXED("IRXN")_","
DO SETRP
+34 ;
LOGX KILL PSOEDITF,PSOEDITR,PSOEDITL
if $GET(RFED)
DO ^PSORXED1
+1 ;ADDED PAPI LINE OF CODE
KILL PSOTOPK,PSOFRPK
+2 QUIT
+3 ;
POST ; D NEXT D:$G(^PSRX(PSORXED("IRXN"),"IB"))]"" COPAY K PSODAYS,PSORXST
+1 DO NEXT
DO COPAY
KILL PSODAYS,PSORXST
+2 QUIT
+3 ;
COPAY SET DA=PSORXED("IRXN")
IF 'RFD
IF PSODAYS'=+$PIECE(^PSRX(DA,0),"^",8)
IF +$GET(^PSRX(DA,"IB"))!($PIECE($GET(^PSRX(DA,"PFS")),"^",2))
DO CPCK
GOTO RXST
+1 IF RFD
IF +$GET(^PSRX(DA,1,RFD,0))
IF PSODAYS'=$PIECE($GET(^PSRX(DA,1,RFD,0)),"^",10)
IF +$GET(^PSRX(DA,"IB"))!($PIECE($GET(^PSRX(DA,1,RFD,"PFS")),"^",2))
DO CPCK
+2 ;
RXST if PSORXST=+$PIECE($GET(^PS(53,+$PIECE(^PSRX(DA,0),"^",3),0)),"^",7)
GOTO COPAYX
+1 WRITE !,$CHAR(7),"Patient Status field for this Rx has been changed from a ",$SELECT(PSORXST=0:"COPAYMENT ELIGIBLE",PSORXST=1:"COPAYMENT EXEMPT",1:"")
+2 WRITE !,"patient status."
+3 WRITE " The copay status for this Rx will be automatically adjusted."
+4 WRITE !,"If action needs to be taken to adjust charges you MUST use the"
+5 WRITE !,"Reset Copay Status/Cancel Charges option."
+6 WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+7 ; SET TO NO COPAY AND AUDIT CHANGE
IF +$PIECE($GET(^PS(53,+$PIECE(^PSRX(DA,0),"^",3),0)),"^",7)=1
Begin DoDot:1
+8 IF '$DATA(^PSRX(DA,"IB"))
SET ^PSRX(DA,"IB")=""
+9 SET $PIECE(^PSRX(DA,"IB"),"^",1)=""
+10 SET PSODA=DA
+11 SET PSOREF=RFD
+12 SET PSOCOMM="Rx Patient Status Change"
+13 SET PSOOLD="Copay"
+14 SET PSONW="No Copay"
+15 SET PREA="R"
+16 DO ACTLOG^PSOCPA
End DoDot:1
+17 ;
COPAYX KILL DA,PSODAYS,PSO,PSODA,PSOFLAG,PSORXST,RFD,PSOREF,PSOCOMM,PSOOLD,PSONW
+1 QUIT
+2 ;
CPCK ;update COPAY
+1 IF 'RFD
IF '$DATA(^PSRX(DA,"PFS"))
GOTO CPCK1
+2 IF RFD
IF '$DATA(^PSRX(DA,1,RFD,"PFS"))
GOTO CPCK1
+3 NEW PSOPFS
SET PSOPFS=$PIECE($SELECT('RFD:^PSRX(DA,"PFS"),1:^PSRX(DA,1,RFD,"PFS")),"^",1,2)
+4 IF +$GET(PSOPFS)>0&('$PIECE($GET(PSOPFS),"^",2))
KILL PSOPFS
QUIT
+5 IF +$GET(PSOPFS)<1
KILL PSOPFS
+6 IF '$TEST
SET PSOPFS="1^"_PSOPFS
+7 ;
CPCK1 NEW TYPE
SET PSO=2
SET PSODA=DA
SET PSOFLAG=1
SET PSOPAR7=$GET(^PS(59,PSOSITE,"IB"))
SET TYPE=RFD
DO RXED^PSOCPA
KILL TYPE
+1 QUIT
+2 ;
NEXT DO NEXT^PSOUTIL(.PSORXED)
KILL DIE,DR,DA
SET DIE="^PSRX("
SET DA=PSORXED("IRXN")
+1 SET DR="101///"_$PIECE(PSORXED("RX3"),"^")_";102///"_$PIECE(PSORXED("RX3"),"^",2)
DO ^DIE
KILL DIE,DR,DA,X,Y
+2 QUIT
+3 ;
EOJ KILL PSOSIG,PSORXED,PSOLIST,END,PSRX0,PSOPINS,PSOOINS
+1 DO EX^PSORXED1
+2 QUIT
+3 ;
FILL ;
+1 KILL PSOEDITF,PSOEDITR,PSOERF
+2 FOR PSOEZ=0:0
SET PSOEZ=$ORDER(^PSRX(DA,1,PSOEZ))
if 'PSOEZ
QUIT
if $DATA(^PSRX(DA,1,PSOEZ,0))
SET PSOERF=PSOEZ
+3 SET PSOEDITF=$SELECT($GET(PSOERF):+$GET(PSOERF),1:0)
+4 IF PSOEDITF
SET PSOEDITR=$SELECT($PIECE($GET(^PSRX(DA,1,PSOEDITF,0)),"^",18):1,1:0)
GOTO FILLX
+5 SET PSOEDITR=$SELECT($PIECE($GET(^PSRX(DA,2)),"^",13):1,1:0)
+6 ;
FILLX KILL PSOERF,PSOEZ
+1 QUIT
+2 ;
LBL ;
+1 SET PSOEDITL=0
NEW PSOECMES
SET PSOECMES=""
SET PSOECMES=$$STATUS^PSOBPSUT(PSORXED("IRXN"),PSOEDITF)
+2 IF PSOTRIC
Begin DoDot:1
+3 IF PSOECMES["IN PROGRESS"!(PSOECMES["REJECTED")
SET PSOEDITL=0
QUIT
+4 IF $$FIND^PSOREJUT(PSORXED("IRXN"),PSOEDITF,,,1)
SET PSOEDITL=0
QUIT
+5 IF ",12,14,15,"[(","_$PIECE($GET(^PSRX(PSORXED("IRXN"),"STA")),"^")_",")
SET PSOEDITL=0
QUIT
+6 IF COM=""
if '$GET(PSOEDITF)&$GET(PSOEDITR)
SET PSOEDITL=2
QUIT
End DoDot:1
if 'PSOEDITL
QUIT
+7 if PSOEDITL=2&($GET(PSOTRIC))&(COM="")
QUIT
+8 IF COM["PROV"!(COM["QTY")!(COM["DAYS")!(COM["MAIL")!(COM["UNIT")!(COM["FILL DATE")!(COM["REMARKS")
IF COM'["STATUS"
IF COM'["CLINIC"
IF COM'["DRUG"
IF COM'["REFILLS"
IF COM'["ISSUE"
IF COM'["SIG"
IF COM'["TRADE"
Begin DoDot:1
+9 IF $GET(PSOEDITF)
SET PSOEDITL=1
QUIT
+10 IF '$GET(PSOEDITF)
IF '$GET(PSOEDITR)
IF PSOTRIC
SET PSOEDITL=2
QUIT
+11 IF '$GET(PSOEDITF)
IF $GET(PSOEDITR)
SET PSOEDITL=2
End DoDot:1
QUIT
+12 IF '$GET(PSOEDITF)
IF $GET(PSOEDITR)
SET PSOEDITL=2
QUIT
+13 IF '$GET(PSOEDITF)
IF '$GET(PSOEDITR)
SET PSOEDITL=0
QUIT
+14 IF $GET(RXRP(DA))
SET PSOEDITL=1
QUIT
+15 IF '$GET(RXRP(DA))
IF $GET(PSOEDITR)
SET PSOEDITL=2
QUIT
+16 SET PSOEDITL=0
+17 QUIT
+18 ;
LBLCHK ;
+1 ;
+2 ; If Rx is non-billable perform checks and quit
+3 IF PSOBPS'="e"
Begin DoDot:1
+4 IF '$$RXRLDT^PSOBPSUT(PSORXED("IRXN"),PSOEDITF)
Begin DoDot:2
+5 IF $$PTLBL^PSOREJP2(PSORXED("IRXN"),PSOEDITF)
DO PRINT^PSOREJP3(PSORXED("IRXN"),PSOEDITF)
End DoDot:2
End DoDot:1
QUIT
+6 ;
+7 ; Rx is billable
+8 ;
+9 ; If the PSOEDITL flag is set to 1, the user will be given the QUEUE
+10 ; prompt; if set to 0, the QUEUE prompt is suppressed.
+11 ; PSORX("NOLABEL") is used to determine if the Label Prompt should
+12 ; be displayed to the user by calling routine.
+13 ;
+14 SET PSOEDITL=0
+15 SET PSORX("NOLABEL")=1
+16 ;
+17 IF $$RXRLDT^PSOBPSUT(PSORXED("IRXN"),PSOEDITF)
QUIT
+18 ;
+19 IF $$PTLBL^PSOREJP2(PSORXED("IRXN"),PSOEDITF)
Begin DoDot:1
+20 SET PSORX("NOLABEL")=0
+21 IF $DATA(PSORX("QFLG"))
SET PSOEDITL=1
+22 IF '$TEST
DO PRINT^PSOREJP3(PSORXED("IRXN"),PSOEDITF)
End DoDot:1
+23 QUIT
+24 ;
ASKL ;
+1 WRITE !
KILL DIR
SET DIR("?",1)="You have edited a fill that has already been released. Do you want to"
SET DIR("?",2)="include this prescription as one of the prescriptions to be acted upon"
SET DIR("?",3)="at the label prompt."
+2 SET DIR("?")="Enter 'Yes' to generate a reprint label request."
+3 ; User did not reply as "YES" - don't prompt for label device
SET DIR(0)="Y"
SET DIR("A")="The last fill has been released, do you want a reprint label"
SET DIR("B")="Y"
DO ^DIR
KILL DIR
IF Y'=1
SET PSOEDITL=0
QUIT
+4 SET PSOEDITL=1
+5 QUIT
+6 ;
SETRP IF '$GET(PSOTOPK)
IF $PIECE($GET(^PSRX(PSORXED("IRXN"),"STA")),"^")'=5
IF $GET(PSOEDITL)=0
SET RXRP(PSORXED("IRXN"))="1^^^1"
SET VALMSG="Label will reprint due to Edit"
+1 QUIT
