PSORXED ;IHS/DSD/JCM-edit rx utility ;29-May-2012 15:11;PLS
;;7.0;OUTPATIENT PHARMACY;**2,16,21,26,56,71,125,1005,201,246,289,1015**;DEC 1997;Build 62
;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
; Modified - IHS/CIA/PLS - 12/21/2003 PROCESS+2
; 03/31/2004 LOG+12 and POS API
; 08/29/06 POS+2
; 09/15/06 - reworked the POS API logic
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
S PSORXED("RX0")=^PSRX(PSORXED("IRXN"),0),PSORXED("RX2")=^(2),PSORXED("RX3")=^(3),PSOSIG=$G(^PSRX(PSORXED("IRXN"),"SIG")),PSODAYS=$P(PSORXED("RX0"),"^",8)
S PSORXED("RX9999999")=$G(^(9999999)) ; IHS/CIA/PLS 12/21/03 - Need 999999 Node
; IHS/CIA/PLS - 12/21/03 - Restructured next line to allow setting of RX19999999 Refill Node
;S (I,RFED,RFDT)=0 F S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I S RFED=I,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 (I,RFED,RFDT)=0 F S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I D
.S RFED=I,PSORXED("RX1")=^PSRX(PSORXED("IRXN"),1,I,0)
.S PSORXED("RX19999999")=$G(^(9999999))
.S 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)
N PSOTRIC S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(PSORXED("IRXN"),0,.PSOTRIC)
S COM="" F I=3,4,5:1:13,17 I $P(PSRX0,"^",I)'=$P(^PSRX(DA,0),"^",I) S PSI=$S(I=13:1,1:I),COM=COM_$P(^DD(52,PSI,0),"^")_" ("_$P(PSRX0,"^",I)_"),"
I $P(PSORXED("RX2"),"^",2)'=$P(^PSRX(DA,2),"^",2) S COM=COM_$P(^DD(52,22,0),"^")_" ("_$P(PSORXED("RX2"),"^",2)_"),"
; IHS/CIA/PLS - 12/21/03 - Added field data
I $P(PSORXED("RX2"),"^",7)'=$P($G(^PSRX(DA,2)),"^",7) S COM=COM_$P(^DD(52,27,0),"^")_" ("_$P(PSORXED("RX2"),"^",7)_")," ; Set NDC value
I $P(PSORXED("RX3"),"^",7)'=$P(^PSRX(DA,3),"^",7) S COM=COM_$P(^DD(52,12,0),"^")_" ("_$P(PSORXED("RX3"),"^",7)_"),"
I $P($G(PSORXED("RX9999999")),"^",6)'=$P($G(^PSRX(DA,9999999)),"^",6) S COM=COM_$P(^DD(52,9999999.06,0),"^")_" ("_$P($G(PSORXED("RX9999999")),"^",6)_")," ; Set AWP value
I $G(APSQCOM)]"" S COM=COM_APSQCOM K APSQCOM ; Guarantees printing and billing set in call to OVERRIDE^APSQBRES
; IHS/CIA/PLS - 12/21/03 - End of changes
I PSOSIG'=$P($G(^PSRX(DA,"SIG")),"^") S COM=COM_$P(^DD(52,10,0),"^")_" ("_PSOSIG_"),"
I PSOTRN'=$G(^PSRX(DA,"TN")) S COM=COM_$P(^DD(52,6.5,0),"^")_" ("_PSOTRN_"),"
D FILL
I PSOTRIC&('$$RXRLDT^PSOBPSUT(PSORXED("IRXN"),PSOEDITF)),COM="" D LBLCHK G LOGX ; labels for unrelease Tricare resolved claims; when COM'="" label always printed
I PSOTRIC&(COM="") D LBL D ASKL:PSOEDITL G:'PSOEDITL LOGX G LOG1
G:COM="" LOGX K PSRX0 S X=$S($D(PSOCLC):PSOCLC,1:DUZ)
S COM=COM_$$POS(DA) ;IHS/CIA/PLS - 03/31/04 - Add answer from POS
D LBL D:$G(PSOEDITL)=2&($P($G(^PSRX(DA,"STA")),"^")'=5)&('$G(RXRP(DA)))&('$G(PSOSIGFL)) ASKL
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
S ^PSRX(DA,"A",D1,0)=DT_"^E^"_$G(DUZ)_"^0^"_COM
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
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))']"" S PSORX("PSOL",1)=PSORXED("IRXN")_"," D SETRP G LOGX
G:$G(PSOEDITL)=1&('$G(PSOTRIC)) 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
Q
; Return POS status
POS(RIEN) ; EP
S ANS=""
I '$$TEST^APSQBRES("ABSPOSRX"),$G(^TMP("APSPPOS",$J,RIEN)) D
.N APSQPOS,APSQPOST,APSQIT
.S APSQIT=0
.S ANS="CLAIM WAS NOT RESUBMITTED TO POS"
.S APSQPOS=$$IEN59^ABSPOSRX(RIEN,$G(RFIEN,0)) ; Get IEN in POS File
.I $G(APSQPOS) S APSQPOST=$O(^ABSPTL("B",APSQPOS,"A"),-1) ; Last entry in ^ABSPTBL global
.I $G(APSQPOST),+$$GET1^DIQ(9002313.57,+APSQPOST_",",.15) D ; >0 indicates entry in Accounts Receivable
..S DIR("A",1)="There is an entry for this prescription in the Accounts Receivable Package"
..S DIR("A")="Do you really want to reverse this entry and resend it to the insurer and put another entry in the Accounts Receivable Package"
..S DIR("B")="YES"
..S DIR(0)="Y"
..D ^DIR
..S:'Y APSQIT=1
.E D ; Block added 9/14/06 pls
..S DIR("A")="Do you want to reverse the POS claim?"
..S DIR("B")="No"
..S DIR(0)="Y"
..D ^DIR
..S:'Y APSQIT=1
.I 'APSQIT D
..S ANS="CLAIM WAS RESUBMITTED TO POS"
..N APSQPST,RFIEN
..S RFIEN=$O(^PSRX(RIEN,1,$C(1)),-1)
..D CALLPOS^APSPFUNC(RIEN,$S(RFIEN:RFIEN,1:""),"A")
K ^TMP("APSPPOS",$J,RIEN)
Q ANS
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
; IHS/CIA/PLS - 12/21/03
K APSP,APSP1,APSP2,APSPDZ,APSPLTYP,APSPM0,APSPPDY,APSPPLOT,APSPPMF,APSPRXX,PSOREF,APSP91,APSPMM,APSPL
K APSREFF,APSREFD
K APSAZNDC,APSAZIEN,APSARNDC
K PSOBXIEN,PSOBRIEN
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) 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 ;
I '$$RXRLDT^PSOBPSUT(PSORXED("IRXN"),PSOEDITF) D
.I $$PTLBL^PSOREJP2(PSORXED("IRXN"),PSOEDITF) 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=$S($G(PSOTRIC)&(Y'=1):1,1:0) Q
S PSOEDITL=1
Q
SETRP I $P($G(^PSRX(PSORXED("IRXN"),"STA")),"^")'=5,$G(PSOEDITL)=0 S RXRP(PSORXED("IRXN"))="1^^^1",VALMSG="Label will reprint due to Edit"
Q
PSORXED ;IHS/DSD/JCM-edit rx utility ;29-May-2012 15:11;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**2,16,21,26,56,71,125,1005,201,246,289,1015**;DEC 1997;Build 62
+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 ; Modified - IHS/CIA/PLS - 12/21/2003 PROCESS+2
+7 ; 03/31/2004 LOG+12 and POS API
+8 ; 08/29/06 POS+2
+9 ; 09/15/06 - reworked the POS API logic
START ;this entry point is no longer used.
+1 ;D INIT,LKUP G:PSORXED("QFLG") END D PARSE,EOJ G START
END DO EOJ
+1 QUIT
INIT SET PSORXED("QFLG")=0
QUIT
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
PROCESS SET PSORXED("DFLG")=0
IF $GET(^PSRX(PSORXED("IRXN"),0))']""
GOTO PROCESSX
+1 SET PSORXED("RX0")=^PSRX(PSORXED("IRXN"),0)
SET PSORXED("RX2")=^(2)
SET PSORXED("RX3")=^(3)
SET PSOSIG=$GET(^PSRX(PSORXED("IRXN"),"SIG"))
SET PSODAYS=$PIECE(PSORXED("RX0"),"^",8)
+2 ; IHS/CIA/PLS 12/21/03 - Need 999999 Node
SET PSORXED("RX9999999")=$GET(^(9999999))
+3 ; IHS/CIA/PLS - 12/21/03 - Restructured next line to allow setting of RX19999999 Refill Node
+4 ;S (I,RFED,RFDT)=0 F S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I S RFED=I,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),"^")
+5 SET (I,RFED,RFDT)=0
FOR
SET I=$ORDER(^PSRX(PSORXED("IRXN"),1,I))
IF 'I
QUIT
Begin DoDot:1
+6 SET RFED=I
SET PSORXED("RX1")=^PSRX(PSORXED("IRXN"),1,I,0)
+7 SET PSORXED("RX19999999")=$GET(^(9999999))
+8 SET RFDT=$PIECE(^(0),"^")
SET PSODAYS=$PIECE(^(0),"^",10)
+9 IF $PIECE(^(0),"^",17)
SET PSONEW("PROVIDER NAME")=$PIECE(^VA(200,$PIECE(^(0),"^",17),0),"^")
End DoDot:1
+10 SET PSORXST=+$PIECE($GET(^PS(53,+$PIECE(PSORXED("RX0"),"^",3),0)),"^",7)
NEW DA
SET DA=PSORXED("IRXN")
DO EN^PSORXPR
+11 DO CHECK
IF PSORXED("DFLG")
GOTO PROCESSX
+12 NEW X
SET X="PSXEDIT"
XECUTE ^%ZOSF("TEST")
KILL X
IF $TEST
DO ^PSXEDIT
IF $GET(PSXOUT)
KILL PSXOUT
GOTO L1
+13 DO DIE^PSORXED1
L1 DO LOG
DO POST
PROCESSX QUIT
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 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
+4 ;
+5 IF $PIECE(^PSRX(PSORXED("IRXN"),"STA"),"^")=14!($PIECE(^("STA"),"^")=15)
SET PSORXED("DFLG")=1
WRITE !!,$CHAR(7),"Discontinued prescriptions cannot be edited.",!
GOTO CHECKX
+6 IF $DATA(^PS(52.4,"B",PSORXED("IRXN")))
SET PSORXED("DFLG")=1
WRITE !!,$CHAR(7),"Non-verified prescriptions cannot be edited.",!
CHECKX KILL PSPOP,DIR,DTOUT,DUOUT,Y,X
QUIT
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 NEW PSOTRIC
SET PSOTRIC=""
SET PSOTRIC=$$TRIC^PSOREJP1(PSORXED("IRXN"),0,.PSOTRIC)
+2 SET COM=""
FOR I=3,4,5:1:13,17
IF $PIECE(PSRX0,"^",I)'=$PIECE(^PSRX(DA,0),"^",I)
SET PSI=$SELECT(I=13:1,1:I)
SET COM=COM_$PIECE(^DD(52,PSI,0),"^")_" ("_$PIECE(PSRX0,"^",I)_"),"
+3 IF $PIECE(PSORXED("RX2"),"^",2)'=$PIECE(^PSRX(DA,2),"^",2)
SET COM=COM_$PIECE(^DD(52,22,0),"^")_" ("_$PIECE(PSORXED("RX2"),"^",2)_"),"
+4 ; IHS/CIA/PLS - 12/21/03 - Added field data
+5 ; Set NDC value
IF $PIECE(PSORXED("RX2"),"^",7)'=$PIECE($GET(^PSRX(DA,2)),"^",7)
SET COM=COM_$PIECE(^DD(52,27,0),"^")_" ("_$PIECE(PSORXED("RX2"),"^",7)_"),"
+6 IF $PIECE(PSORXED("RX3"),"^",7)'=$PIECE(^PSRX(DA,3),"^",7)
SET COM=COM_$PIECE(^DD(52,12,0),"^")_" ("_$PIECE(PSORXED("RX3"),"^",7)_"),"
+7 ; Set AWP value
IF $PIECE($GET(PSORXED("RX9999999")),"^",6)'=$PIECE($GET(^PSRX(DA,9999999)),"^",6)
SET COM=COM_$PIECE(^DD(52,9999999.06,0),"^")_" ("_$PIECE($GET(PSORXED("RX9999999")),"^",6)_"),"
+8 ; Guarantees printing and billing set in call to OVERRIDE^APSQBRES
IF $GET(APSQCOM)]""
SET COM=COM_APSQCOM
KILL APSQCOM
+9 ; IHS/CIA/PLS - 12/21/03 - End of changes
+10 IF PSOSIG'=$PIECE($GET(^PSRX(DA,"SIG")),"^")
SET COM=COM_$PIECE(^DD(52,10,0),"^")_" ("_PSOSIG_"),"
+11 IF PSOTRN'=$GET(^PSRX(DA,"TN"))
SET COM=COM_$PIECE(^DD(52,6.5,0),"^")_" ("_PSOTRN_"),"
+12 DO FILL
+13 ; labels for unrelease Tricare resolved claims; when COM'="" label always printed
IF PSOTRIC&('$$RXRLDT^PSOBPSUT(PSORXED("IRXN"),PSOEDITF))
IF COM=""
DO LBLCHK
GOTO LOGX
+14 IF PSOTRIC&(COM="")
DO LBL
IF PSOEDITL
DO ASKL
IF 'PSOEDITL
GOTO LOGX
GOTO LOG1
+15 IF COM=""
GOTO LOGX
KILL PSRX0
SET X=$SELECT($DATA(PSOCLC):PSOCLC,1:DUZ)
+16 ;IHS/CIA/PLS - 03/31/04 - Add answer from POS
SET COM=COM_$$POS(DA)
+17 DO LBL
IF $GET(PSOEDITL)=2&($PIECE($GET(^PSRX(DA,"STA")),"^")'=5)&('$GET(RXRP(DA)))&('$GET(PSOSIGFL))
DO ASKL
+18 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
+19 SET D1=D1+1
IF '($DATA(^PSRX(DA,"A",0))#2)
SET ^(0)="^52.3DA^^^"
SET ^(0)=$PIECE(^(0),"^",1,2)_"^"_D1_"^"_K
+20 SET ^PSRX(DA,"A",D1,0)=DT_"^E^"_$GET(DUZ)_"^0^"_COM
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 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))']""
SET PSORX("PSOL",1)=PSORXED("IRXN")_","
DO SETRP
GOTO LOGX
+8 IF $GET(PSOEDITL)=1&('$GET(PSOTRIC))
GOTO LOGX
+9 FOR PSOX1=0:0
SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
IF 'PSOX1
QUIT
SET PSOX2=PSOX1
+10 IF $LENGTH(PSORX("PSOL",PSOX2))+$LENGTH(PSORXED("IRXN"))<220
Begin DoDot:1
+11 IF PSORX("PSOL",PSOX2)'[PSORXED("IRXN")_","
SET PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSORXED("IRXN")_","
DO SETRP
End DoDot:1
GOTO LOGX
+12 ;;PSO*7*246
IF '$TEST
IF $GET(PSORX("PSOL",PSOX2+1))'[PSORXED("IRXN")_","
SET PSORX("PSOL",PSOX2+1)=PSORXED("IRXN")_","
DO SETRP
LOGX KILL PSOEDITF,PSOEDITR,PSOEDITL
IF $GET(RFED)
DO ^PSORXED1
+1 QUIT
+2 ; Return POS status
POS(RIEN) ; EP
+1 SET ANS=""
+2 IF '$$TEST^APSQBRES("ABSPOSRX")
IF $GET(^TMP("APSPPOS",$JOB,RIEN))
Begin DoDot:1
+3 NEW APSQPOS,APSQPOST,APSQIT
+4 SET APSQIT=0
+5 SET ANS="CLAIM WAS NOT RESUBMITTED TO POS"
+6 ; Get IEN in POS File
SET APSQPOS=$$IEN59^ABSPOSRX(RIEN,$GET(RFIEN,0))
+7 ; Last entry in ^ABSPTBL global
IF $GET(APSQPOS)
SET APSQPOST=$ORDER(^ABSPTL("B",APSQPOS,"A"),-1)
+8 ; >0 indicates entry in Accounts Receivable
IF $GET(APSQPOST)
IF +$$GET1^DIQ(9002313.57,+APSQPOST_",",.15)
Begin DoDot:2
+9 SET DIR("A",1)="There is an entry for this prescription in the Accounts Receivable Package"
+10 SET DIR("A")="Do you really want to reverse this entry and resend it to the insurer and put another entry in the Accounts Receivable Package"
+11 SET DIR("B")="YES"
+12 SET DIR(0)="Y"
+13 DO ^DIR
+14 IF 'Y
SET APSQIT=1
End DoDot:2
+15 ; Block added 9/14/06 pls
IF '$TEST
Begin DoDot:2
+16 SET DIR("A")="Do you want to reverse the POS claim?"
+17 SET DIR("B")="No"
+18 SET DIR(0)="Y"
+19 DO ^DIR
+20 IF 'Y
SET APSQIT=1
End DoDot:2
+21 IF 'APSQIT
Begin DoDot:2
+22 SET ANS="CLAIM WAS RESUBMITTED TO POS"
+23 NEW APSQPST,RFIEN
+24 SET RFIEN=$ORDER(^PSRX(RIEN,1,$CHAR(1)),-1)
+25 DO CALLPOS^APSPFUNC(RIEN,$SELECT(RFIEN:RFIEN,1:""),"A")
End DoDot:2
End DoDot:1
+26 KILL ^TMP("APSPPOS",$JOB,RIEN)
+27 QUIT ANS
POST ; D NEXT D:$G(^PSRX(PSORXED("IRXN"),"IB"))]"" COPAY K PSODAYS,PSORXST
+1 DO NEXT
DO COPAY
KILL PSODAYS,PSORXST
+2 QUIT
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
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
COPAYX KILL DA,PSODAYS,PSO,PSODA,PSOFLAG,PSORXST,RFD,PSOREF,PSOCOMM,PSOOLD,PSONW
+1 QUIT
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
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
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
EOJ KILL PSOSIG,PSORXED,PSOLIST,END,PSRX0
+1 ; IHS/CIA/PLS - 12/21/03
+2 KILL APSP,APSP1,APSP2,APSPDZ,APSPLTYP,APSPM0,APSPPDY,APSPPLOT,APSPPMF,APSPRXX,PSOREF,APSP91,APSPMM,APSPL
+3 KILL APSREFF,APSREFD
+4 KILL APSAZNDC,APSAZIEN,APSARNDC
+5 KILL PSOBXIEN,PSOBRIEN
+6 DO EX^PSORXED1
+7 QUIT
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)
FILLX KILL PSOERF,PSOEZ
+1 QUIT
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)
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
LBLCHK ;
+1 IF '$$RXRLDT^PSOBPSUT(PSORXED("IRXN"),PSOEDITF)
Begin DoDot:1
+2 IF $$PTLBL^PSOREJP2(PSORXED("IRXN"),PSOEDITF)
DO PRINT^PSOREJP3(PSORXED("IRXN"),PSOEDITF)
End DoDot:1
+3 QUIT
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 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=$SELECT($GET(PSOTRIC)&(Y'=1):1,1:0)
QUIT
+4 SET PSOEDITL=1
+5 QUIT
SETRP 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
