PSOORED6 ;BHAM ISC/SAB-edit orders from backdoor ;05-Sep-2013 15:44;DU
;;7.0;OUTPATIENT PHARMACY;**78,104,117,133,1005,1013,1014,143,219,148,247,268,260,269,1015,1016**;DEC 1997;Build 74
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^PS(50.7 supported by DBIA 2223
;External reference ^PS(50.606 supported by DBIA 2174
; Modified - IHS/CIA/PLS - 06/15/04 - Line DRG+20 (Mod removed in 1015)
; 09/07/04 - Line UPDATE+25
; 09/15/06 - Line UPDATE+7 added
; 10/14/11 - Line UPDATE+11 and UPDATE+28
; 05/22/12 - Line UPDATE+19, UPDATE+56
; 05/31/12 - Line UPDATE+13, UPDATE+38
; 06/21/12 - Line UPDATE+12, UPDATE+40
DRG ;select drug
S PSORX("EDIT")=1,RX0HLD=RX0
S PSODRUG("IEN")=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),1:$P(RX0,"^",6)),PSODRUG("NAME")=$S($G(PSODRUG("NAME"))]"":PSODRUG("NAME"),1:$P(^PSDRUG($P(RX0,"^",6),0),"^"))
D ^PSODRG I PSODRUG("IEN")=$P(RX0,"^",6) K PSORXED("FLD",6)
D:PSODRUG("IEN")'=$P(RX0,"^",6) I $G(PSORX("DFLG")) K PSORXED("FLD",6) S PSORXED("DFLG")=1 Q
.D POST^PSODRG
.I '$O(^PSRX(PSORXED("IRXN"),1,0)) S PSORXED("FLD",17)=$G(PSODRUG("COST"))
.I $G(PSORX("DFLG")) K PSORXED("FLD",6),PSODRUG,PSOOIFLG,PSOSIGFL,VALMSG Q
.D KV S DIR(0)="Y",DIR("B")="YES"
.S DIR("A",1)="You have changed the dispense drug from"
.S DIR("A",2)=$P(^PSDRUG($P(PSORXED("RX0"),"^",6),0),"^")_" to "_$P(^PSDRUG(PSODRUG("IEN"),0),"^")_"."
.I $P($G(^PSRX(PSORXED("IRXN"),"SIG")),"^",2),$O(^PSRX(PSORXED("IRXN"),"SIG1",0)) S DIR("A",3)="" D
..F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"SIG1",I)) Q:'I S DIR("A",3+I)=$S(I=1:"Current SIG: ",1:"")_$G(^PSRX(PSORXED("IRXN"),"SIG1",I,0))
.S DIR("A")="Do You want to Edit the SIG"
.D ^DIR K DIR I $D(DIRUT) S PSORX("DFLG")=1 D M1
.Q:$D(DIRUT)!('Y)
.S PSOREEDQ=1 D DOLST^PSOORED3,DOSE^PSOORED3 K PSOREEDQ
.I '$O(PSORXED("DOSE",0)) S PSORX("DFLG")=1 Q
.D:$G(PSOSIGFL) M2
S RX0=RX0HLD K RX0HLD I $G(PSODRUG("OI"))=$G(PSOI) D Q
.D:$O(^TMP("PSORXDC",$J,0))
..W !!,"This edit will discontinue the duplicate Rx & change the dispensed drug!"
..K DIR,X,Y S DIR("A")="Do You Want to Proceed",DIR("B")="NO",DIR(0)="Y"
..D ^DIR K DIR S:'Y!($D(DIRUT)) PSORXED("DFLG")=1 D:Y DCORD^PSONEW2
.Q:$G(PSORXED("DFLG"))
.I PSODRUG("IEN")'=$P(RX0,"^",6) D
..S PSORXED("FLD",6)=PSODRUG("IEN"),PSORXED("FLD",39.2)=PSOI
.S:$G(PSODRUG("TRADE NAME"))]"" PSORXED("FLD",6.5)=PSODRUG("TRADE NAME")
.S:$G(PSODRUG("NDC"))]"" PSORXED("FLD",27)=PSODRUG("NDC")
.S:$G(PSODRUG("DAW"))]"" PSORXED("FLD",81)=PSODRUG("DAW")
W !!,"New Orderable Item selected. This edit will create a new prescription!",! D PAUSE^VALM1 S VALMSG="New Orderable Item selected. This edit will create a new prescription!" S (PSOOIFLG,PSOSIGFL)=1
Q
PSOCOU ;patient counseling
K DIC,DIQ S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED",DR=41 D EN^DIQ1 K DIC,DIQ
D KV S DIR(0)="52,41" S:$G(PSORXED(52,DA,DR))]"" DIR("B")=PSORXED(52,DA,DR) D ^DIR K DIR,PSORXED(52,DA,DR)
I $D(DIRUT) K PSORXED("FLD",41) D KV Q
S PSORXED("FLD",DR)=Y D K DIRUT
.I Y D Q
..K DIC,DIQ S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED",DR=42 D EN^DIQ1 K DIC,DIQ
..K DIR,DIRUT S DIR(0)="52,42" S:$G(PSORXED(52,DA,DR))]"" DIR("B")=PSORXED(52,DA,DR) D ^DIR K DIR,PSORXED(52,DA,DR)
..I $D(DIRUT) K PSORXED("FLD",41),DUOUT,DTOUT Q
..S PSORXED("FLD",42)=Y
.S PSORXED("FLD",41)=0,PSORXED("FLD",42)="@"
Q
PSOI ;select orderable item
W !!,"Current Orderable Item: "_$P(^PS(50.7,PSOI,0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")
S DIC("B")=$P(^PS(50.7,PSOI,0),"^"),DIC="^PS(50.7,",DIC(0)="AEMQZ"
S DIC("S")="I '$P(^PS(50.7,+Y,0),""^"",4)!($P(^(0),""^"",4)'<DT) N PSOF,PSOL S (PSOF,PSOL)=0 F S PSOL=$O(^PSDRUG(""ASP"",+Y,PSOL)) Q:PSOF!'PSOL "
S DIC("S")=DIC("S")_"I $P($G(^PSDRUG(PSOL,2)),U,3)[""O"",'$G(^(""I""))!($G(^(""I""))'<DT) S PSOF=1"
;BHW;PSO*7*269;Modify ^DIC call to call MIX^DIC to use only the B and C Cross-References.
S D="B^C" D MIX^DIC1 I "^"[X S PSORXED("DFLG")=1 Q
G:Y<1 PSOI Q:PSOI=+Y
S PSODRUG("OI")=+Y,PSODRUG("OIN")=Y(0,0) K DIC
I PSOI'=PSODRUG("OI") W !!,"New Orderable Item selected. This edit will create a new prescription!",! D K PSHOLDD Q
.D PAUSE^VALM1,M2
.S PSHOLDD=$G(PSODRUG("IEN")) K PSODRUG("IEN"),PSODRUG("NAME") S PSODRUG("DEA")="",(PSOOIFLG,PSOSIGFL)=1
.D DREN^PSOORNW2
.I $G(PSHOLDD),$G(PSODRUG("IEN")),$G(PSHOLDD)'=$G(PSODRUG("IEN")) D Q:$G(PSORX("DFLG"))
..D FULL^VALM1,POST^PSODRG S VALMBCK="R"
..I $G(PSORX("DFLG")) K PSODRUG S PSODRUG("IEN")=$G(PSHOLDD),PSODRUG("NAME")=$P($G(^PSDRUG(PSODRUG("IEN"),0)),"^") K PSOOIFLG,PSOSIGFL S VALMSG=""
.I '$G(PSODRUG("IEN")) W !!,"DRUG NAME REQUIRED!" D 2^PSOORNW1
.I '$G(PSODRUG("IEN")) K PSORXED("FLD"),INDEL,^TMP($J,"INS1"),PSOSIGFL,VALMSG S PSORXED("DFLG")=1,VALMSG="Dispense Drug NOT Selected!" Q
.D KV S DIR(0)="Y",DIR("B")="NO",DIR("A",1)="You have changed the Orderable Item from",DIR("A",2)=$P(^PS(50.7,PSOI,0),"^")_" to "_PSODRUG("OIN")_".",DIR("A")="Do You want to Edit the SIG"
.D ^DIR K DIR I $D(DIRUT) K PSODRUG("OIN"),PSOOIFLG,PSOSIGFL S PSODRUG("OI")=PSOI,VALMSG="",PSORX("DFLG")=1 Q
.I 'Y S PSORX("DFLG")=1 Q
.S PSOREEDQ=1 D DOLST^PSOORED3,DOSE^PSOORED3 K PSOREEDQ
.I '$O(PSORXED("DOSE",0)) S PSORX("DFLG")=1 Q
.D:$G(PSOSIGFL) M2
S PSORXED("FLD",39.2)=PSOI
Q
NCPDP ;Reverse previously billed Rx on an edited orderable item or drug.
N RX,NPSOY
S RX=$G(PSORXED("IRXN")) I RX="" D
. S NPSOY=$O(PSONEW("OLD LAST RX#","")),NPSOY=$G(PSONEW("OLD LAST RX#",NPSOY)),RX=$O(^PSRX("B",NPSOY,RX))
I 'RX Q
D REVERSE^PSOBPSU1(RX,,"DC",7) S NCPDPFLG=0
Q
UPDATE ;add new data to file
;
N RXREF,UPDATE,FLDS,CHGNDC
N APSPRCHK,APSPRFLG S APSPRCHK=0,APSPRFLG=0
Q:'$G(PSORXED("IRXN"))
I $O(PSORXED("FLD",0))!($G(^TMP($J,"INS1",0))]"")!($G(INSDEL))!($O(PSORXED("ODOSE",0))) D G:'Y UPDX
.K DIR,DIRUT,DTOUT,DUOUT
.S DIR(0)="Y",DIR("A")="Are You Sure You Want to Update Rx "_$P(^PSRX(PSORXED("IRXN"),0),"^"),DIR("B")="Yes"
.D ^DIR K DIR I 'Y D M1 Q
.I $D(^PSRX(PSORXED("IRXN"),1,0)) D
..S RXREF=$P(^PSRX(PSORXED("IRXN"),0),"^",9)-$P(^PSRX(PSORXED("IRXN"),1,0),"^",4)
.E S RXREF=0
.K X,DIRUT,DUOUT,DTOUT
UPDATE1 ;IHS/MSC/MGH separated for reissue code
S:$O(PSORXED("FLD",0)) ^TMP("APSPPOS",$J,PSORXED("IRXN"))=1 ;IHS/MSC/PLS - 09/15/06
I $D(PSORXED("FLD",39.3)) D UPDATE^PSODIAG ;update ICD's after edit
; - Retrieving fields before changes that are relevant for 3rd Party Billing
D GETS^DIQ(52,PSORXED("IRXN")_",","4;7;8;20;22;27;81","I","FLDS")
K Y S DA=PSORXED("IRXN"),DIE="^PSRX(",FLD=0
F S FLD=$O(PSORXED("FLD",FLD)) Q:'FLD D
.I FLD=1 S APSPRCHK=1 ;IHS/MSC/PLS - 05/22/2012
.I FLD=8 D ;IHS/MSC/PLS - 06/21/2012
..Q:$$RMNRFL^APSPFUNC(PSORXED("IRXN"))
..S APSPRCHK=4
.;I FLD=9,PSORXED("FLD",FLD)>$P(PSORXED("RX0"),U,9) S APSPRCHK=2 ;IHS/MSC/PLS - 10/14/2011 - Change for update to expiration date
.I FLD=9 D ;IHS/MSC/PLS - 05/31/2012 - APSP 1014
..Q:PSORXED("FLD",FLD)=$P(PSORXED("RX0"),U,9) ;no change in value
..I PSORXED("FLD",FLD)>$P(PSORXED("RX0"),U,9) S APSPRCHK=2 Q
..I PSORXED("FLD",FLD)<$P(PSORXED("RX0"),U,9) S APSPRFLG=1 Q
.I FLD=12!(FLD=24)!(FLD=35) D Q
..I FLD=12,PSORXED("FLD",12)="@" S $P(^PSRX(DA,3),"^",7)="" Q
..I FLD=12,PSORXED("FLD",12)]"" S $P(^PSRX(DA,3),"^",7)=PSORXED("FLD",12) Q
..I FLD=24,PSORXED("FLD",24)="@" S $P(^PSRX(DA,2),"^",4)="" Q
..I FLD=24,PSORXED("FLD",24)]"" S $P(^PSRX(DA,2),"^",4)=PSORXED("FLD",24) Q
..I FLD=35,PSORXED("FLD",35)="@" S $P(^PSRX(DA,"MP"),"^")="" Q
..I FLD=35,PSORXED("FLD",35)]"" S $P(^PSRX(DA,"MP"),"^")=PSORXED("FLD",35) Q
.I FLD=114 D Q
..I PSORXED("FLD",114)="@" K ^PSRX(DA,"INS"),^PSRX(DA,"INS1")
..I PSORXED("FLD",114)'="@" D
...S ^PSRX(DA,"INS")=PSORXED("FLD",114)
...S X=PSORXED("FLD",114) D SIG^PSOHELP Q:$G(INS1)']""
...S PSORXED("SIG",1)=$E(INS1,2,9999999) K ^PSRX(DA,"INS1")
...S ^PSRX(DA,"INS1",0)="^52.0115^1^1^"_DT_"^^"
...S ^PSRX(DA,"INS1",1,0)=PSORXED("SIG",1)
..D DOLST^PSOORED3 K:PSORXED("FLD",114)="@" PSORXED("SIG") D EN^PSOFSIG(.PSORXED),UPDSIG^PSOORED3
.; IHS/CIA/PLS - 09/07/04 - Fix for Man Expiration Date
.I FLD=29,PSORXED("FLD",29)="" S $P(^PSRX(DA,2),"^",11)="" Q
.I FLD=27 D Q
..I PSORXED("FLD",27)'=$$GETNDC^PSONDCUT(DA,0) D
...S CHGNDC=1 D RXACT^PSOBPSU2(DA,0,"NDC changed from "_$$GETNDC^PSONDCUT(DA,0)_" to "_PSORXED("FLD",27)_".","E")
..D SAVNDC^PSONDCUT(DA,0,PSORXED("FLD",27),0,1)
.I FLD=81 D SAVDAW^PSODAWUT(DA,0,PSORXED("FLD",81)) Q
.S DR=FLD_"////"_PSORXED("FLD",FLD) D ^DIE
.I FLD=4 D UDPROV^PSOOREDT Q
.I APSPRCHK=4 D
..I '$P($G(PSORXED("RX2")),U,13) S APSPRCHK=0 Q ;Original dispense not released
..N LASTRFL
..S LASTRFL=$O(^PSRX(PSORXED("IRXN"),1,$C(1)),-1)
..I 'LASTRFL S APSPRCHK=4_U_$P($G(PSORXED("RX2")),U,13) Q
..I '$P($G(^PSRX(PSORXED("IRXN"),1,LASTRFL,0)),U,18) S APSPRCHK=0 Q ;Last refill not released
..S APSPRCHK=4_U_$P($G(^PSRX(PSORXED("IRXN"),1,LASTRFL,0)),U,18)
.I FLD=9,APSPRFLG D ;IHS/MSC/PLS - 05/31/2012
..Q:$$RMNRFL^APSPFUNC(PSORXED("IRXN")) ;remaining fills no action required
..I '$$RMNRFL^APSPFUNC(PSORXED("IRXN")) D
...Q:'$P($G(PSORXED("RX2")),U,13) ;Original dispense not released
...N LASTRFL
...S LASTRFL=$O(^PSRX(PSORXED("IRXN"),1,$C(1)),-1)
...I 'LASTRFL S APSPRCHK=3_U_$P($G(PSORXED("RX2")),U,13) Q
...Q:'$P($G(^PSRX(PSORXED("IRXN"),1,LASTRFL,0)),U,18) ;Last refill not released
...S APSPRCHK=3_U_$P($G(^PSRX(PSORXED("IRXN"),1,LASTRFL,0)),U,18)
.S APSPRFLG=0
;
; - Re-submitting Rx to ECME due to edits
D RESUB^PSOORED7
;
I $G(INSDEL) K ^PSRX(DA,"INS"),^PSRX(DA,"INS1") D DOLST^PSOORED3 K PSORXED("SIG") D EN^PSOFSIG(.PSORXED),UPDSIG^PSOORED3 G UPDX
I $O(^TMP($J,"INS1",0)) D
.K ^PSRX(DA,"INS"),^PSRX(DA,"INS1"),DD,PSORXED("SIG")
.F I=0:0 S I=$O(^TMP($J,"INS1",I)) Q:'I S (PSORXED("SIG",I),^PSRX(DA,"INS1",I,0))=^TMP($J,"INS1",I,0),DD=$G(DD)+1
.S ^PSRX(DA,"INS1",0)=^TMP($J,"INS1",0)
.I DD=1 S ^PSRX(DA,"INS")=^PSRX(DA,"INS1",1,0)
.D DOLST^PSOORED3,EN^PSOFSIG(.PSORXED),UPDSIG^PSOORED3
;IHS/MSC/PLS - 10/14/2011 - Update expiration date when more fills are added
I APSPRCHK D
.N CS,DE,EXTEXP,X2,NEXPDT,DA,DIE,ISSDT,DRG
.S CS=0
.;IHS/MSC/PLS - 05/22/2012 - Change made to support Issue Date edit
.;S DE=+$E(PSODRUG("DEA"),1)
.;I DE>1,DE<6 S CS=1 S:DE=2 $P(CS,U,2)=1
.S DRG=$P(PSORXED("RX0"),U,6)
.S CS=$$ISSCH^APSPFNC2(DRG,"2345")
.S $P(CS,U,2)=$$ISSCH^APSPFNC2(DRG,"2")
.S EXTEXP=$$GET1^DIQ(50,DRG,9999999.08)
.S ISSDT=$P(^PSRX(PSORXED("IRXN"),0),U,13)
.S X2=$S(EXTEXP:EXTEXP,$P(CS,U,2):184,CS:184,1:366)
.;IHS/MSC/PLS - 05/22/2012
.;S NEXPDT=$$FMADD^XLFDT($P(PSORXED("RX0",U,13),X2)
.S NEXPDT=$$FMADD^XLFDT(ISSDT,X2)
.;IHS/MSC/PLS - 05/22/2012 - Quit if Issue Date edited, prescription has been released and no remaining dispenses
.I +APSPRCHK=1,$P(PSORXED("RX2"),U,13),'$$RMNRFL^APSPFUNC(PSORXED("IRXN")) Q
.I +APSPRCHK=3,$$EXPDT^APSPAUTO(PSORXED("IRXN"),1,+$P($P(APSPRCHK,U,2),".")) S NEXPDT=$$EXPDT^APSPAUTO(PSORXED("IRXN"),1,+$P($P(APSPRCHK,U,2),"."))
.I +APSPRCHK=4,$$EXPDT^APSPAUTO(PSORXED("IRXN"),1,+$P($P(APSPRCHK,U,2),".")) S NEXPDT=$$EXPDT^APSPAUTO(PSORXED("IRXN"),1,+$P($P(APSPRCHK,U,2),".")) ;IHS/MSC/PLS - 06/21/2012
.S DA=PSORXED("IRXN"),DIE="^PSRX("
.S DR="26///"_NEXPDT D ^DIE
.S APSPRCHK=0
UPDX ;
K DIE,DA,DR,FLD,X,Y,PSORXED("FLD"),DD,^TMP($J,"INS1")
KV K DIR,DIRUT,DTOUT,DUOUT
Q
UPD ;updates dosing array
S HENT=ENT
UPD1 ;
I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" S PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1)) D G UPD
.K PSORXED("CONJUNCTION",(HENT+1))
.I $D(PSORXED("DOSE",(HENT+2))) D
..S PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2))
..S PSORXED("ODOSE",(HENT+1))=$G(PSORXED("ODOSE",(HENT+2)))
..S PSORXED("DOSE ORDERED",(HENT+1))=$G(PSORXED("DOSE ORDERED",(HENT+2)))
..S PSORXED("UNITS",(HENT+1))=$G(PSORXED("UNITS",(HENT+2)))
..S PSORXED("NOUN",(HENT+1))=$G(PSORXED("NOUN",(HENT+2)))
..S PSORXED("DURATION",(HENT+1))=$G(PSORXED("DURATION",(HENT+2)))
..S PSORXED("CONJUNCTION",(HENT+1))=$G(PSORXED("CONJUNCTION",(HENT+2)))
..S PSORXED("ROUTE",(HENT+1))=$G(PSORXED("ROUTE",(HENT+2)))
..S PSORXED("SCHEDULE",(HENT+1))=$G(PSORXED("SCHEDULE",(HENT+2)))
..S PSORXED("VERB",(HENT+1))=$G(PSORXED("VERB",(HENT+2)))
..K PSORXED("DOSE",(HENT+2)),PSORXED("ODOSE",(HENT+2)),PSORXED("DOSE ORDERED",(HENT+2))
..K PSORXED("UNITS",(HENT+2)),PSORXED("NOUN",(HENT+2)),PSORXED("DURATION",(HENT+2)),PSORXED("ROUTE",(HENT+2)),PSORXED("SCHEDULE",(HENT+2)),PSORXED("VERB",(HENT+2))
.S HENT=HENT+1
F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I S SENT=$G(SENT)+1
Q
;
M1 D M1^PSOOREDX
Q
M2 D M2^PSOOREDX
Q
PSOORED6 ;BHAM ISC/SAB-edit orders from backdoor ;05-Sep-2013 15:44;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**78,104,117,133,1005,1013,1014,143,219,148,247,268,260,269,1015,1016**;DEC 1997;Build 74
+2 ;External reference to ^PSDRUG supported by DBIA 221
+3 ;External reference to ^PS(50.7 supported by DBIA 2223
+4 ;External reference ^PS(50.606 supported by DBIA 2174
+5 ; Modified - IHS/CIA/PLS - 06/15/04 - Line DRG+20 (Mod removed in 1015)
+6 ; 09/07/04 - Line UPDATE+25
+7 ; 09/15/06 - Line UPDATE+7 added
+8 ; 10/14/11 - Line UPDATE+11 and UPDATE+28
+9 ; 05/22/12 - Line UPDATE+19, UPDATE+56
+10 ; 05/31/12 - Line UPDATE+13, UPDATE+38
+11 ; 06/21/12 - Line UPDATE+12, UPDATE+40
DRG ;select drug
+1 SET PSORX("EDIT")=1
SET RX0HLD=RX0
+2 SET PSODRUG("IEN")=$SELECT($GET(PSODRUG("IEN"))]"":PSODRUG("IEN"),1:$PIECE(RX0,"^",6))
SET PSODRUG("NAME")=$SELECT($GET(PSODRUG("NAME"))]"":PSODRUG("NAME"),1:$PIECE(^PSDRUG($PIECE(RX0,"^",6),0),"^"))
+3 DO ^PSODRG
IF PSODRUG("IEN")=$PIECE(RX0,"^",6)
KILL PSORXED("FLD",6)
+4 IF PSODRUG("IEN")'=$PIECE(RX0,"^",6)
Begin DoDot:1
+5 DO POST^PSODRG
+6 IF '$ORDER(^PSRX(PSORXED("IRXN"),1,0))
SET PSORXED("FLD",17)=$GET(PSODRUG("COST"))
+7 IF $GET(PSORX("DFLG"))
KILL PSORXED("FLD",6),PSODRUG,PSOOIFLG,PSOSIGFL,VALMSG
QUIT
+8 DO KV
SET DIR(0)="Y"
SET DIR("B")="YES"
+9 SET DIR("A",1)="You have changed the dispense drug from"
+10 SET DIR("A",2)=$PIECE(^PSDRUG($PIECE(PSORXED("RX0"),"^",6),0),"^")_" to "_$PIECE(^PSDRUG(PSODRUG("IEN"),0),"^")_"."
+11 IF $PIECE($GET(^PSRX(PSORXED("IRXN"),"SIG")),"^",2)
IF $ORDER(^PSRX(PSORXED("IRXN"),"SIG1",0))
SET DIR("A",3)=""
Begin DoDot:2
+12 FOR I=0:0
SET I=$ORDER(^PSRX(PSORXED("IRXN"),"SIG1",I))
IF 'I
QUIT
SET DIR("A",3+I)=$SELECT(I=1:"Current SIG: ",1:"")_$GET(^PSRX(PSORXED("IRXN"),"SIG1",I,0))
End DoDot:2
+13 SET DIR("A")="Do You want to Edit the SIG"
+14 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET PSORX("DFLG")=1
DO M1
+15 IF $DATA(DIRUT)!('Y)
QUIT
+16 SET PSOREEDQ=1
DO DOLST^PSOORED3
DO DOSE^PSOORED3
KILL PSOREEDQ
+17 IF '$ORDER(PSORXED("DOSE",0))
SET PSORX("DFLG")=1
QUIT
+18 IF $GET(PSOSIGFL)
DO M2
End DoDot:1
IF $GET(PSORX("DFLG"))
KILL PSORXED("FLD",6)
SET PSORXED("DFLG")=1
QUIT
+19 SET RX0=RX0HLD
KILL RX0HLD
IF $GET(PSODRUG("OI"))=$GET(PSOI)
Begin DoDot:1
+20 IF $ORDER(^TMP("PSORXDC",$JOB,0))
Begin DoDot:2
+21 WRITE !!,"This edit will discontinue the duplicate Rx & change the dispensed drug!"
+22 KILL DIR,X,Y
SET DIR("A")="Do You Want to Proceed"
SET DIR("B")="NO"
SET DIR(0)="Y"
+23 DO ^DIR
KILL DIR
IF 'Y!($DATA(DIRUT))
SET PSORXED("DFLG")=1
IF Y
DO DCORD^PSONEW2
End DoDot:2
+24 IF $GET(PSORXED("DFLG"))
QUIT
+25 IF PSODRUG("IEN")'=$PIECE(RX0,"^",6)
Begin DoDot:2
+26 SET PSORXED("FLD",6)=PSODRUG("IEN")
SET PSORXED("FLD",39.2)=PSOI
End DoDot:2
+27 IF $GET(PSODRUG("TRADE NAME"))]""
SET PSORXED("FLD",6.5)=PSODRUG("TRADE NAME")
+28 IF $GET(PSODRUG("NDC"))]""
SET PSORXED("FLD",27)=PSODRUG("NDC")
+29 IF $GET(PSODRUG("DAW"))]""
SET PSORXED("FLD",81)=PSODRUG("DAW")
End DoDot:1
QUIT
+30 WRITE !!,"New Orderable Item selected. This edit will create a new prescription!",!
DO PAUSE^VALM1
SET VALMSG="New Orderable Item selected. This edit will create a new prescription!"
SET (PSOOIFLG,PSOSIGFL)=1
+31 QUIT
PSOCOU ;patient counseling
+1 KILL DIC,DIQ
SET DIC=52
SET DA=PSORXED("IRXN")
SET DIQ="PSORXED"
SET DR=41
DO EN^DIQ1
KILL DIC,DIQ
+2 DO KV
SET DIR(0)="52,41"
IF $GET(PSORXED(52,DA,DR))]""
SET DIR("B")=PSORXED(52,DA,DR)
DO ^DIR
KILL DIR,PSORXED(52,DA,DR)
+3 IF $DATA(DIRUT)
KILL PSORXED("FLD",41)
DO KV
QUIT
+4 SET PSORXED("FLD",DR)=Y
Begin DoDot:1
+5 IF Y
Begin DoDot:2
+6 KILL DIC,DIQ
SET DIC=52
SET DA=PSORXED("IRXN")
SET DIQ="PSORXED"
SET DR=42
DO EN^DIQ1
KILL DIC,DIQ
+7 KILL DIR,DIRUT
SET DIR(0)="52,42"
IF $GET(PSORXED(52,DA,DR))]""
SET DIR("B")=PSORXED(52,DA,DR)
DO ^DIR
KILL DIR,PSORXED(52,DA,DR)
+8 IF $DATA(DIRUT)
KILL PSORXED("FLD",41),DUOUT,DTOUT
QUIT
+9 SET PSORXED("FLD",42)=Y
End DoDot:2
QUIT
+10 SET PSORXED("FLD",41)=0
SET PSORXED("FLD",42)="@"
End DoDot:1
KILL DIRUT
+11 QUIT
PSOI ;select orderable item
+1 WRITE !!,"Current Orderable Item: "_$PIECE(^PS(50.7,PSOI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^(0),"^",2),0),"^")
+2 SET DIC("B")=$PIECE(^PS(50.7,PSOI,0),"^")
SET DIC="^PS(50.7,"
SET DIC(0)="AEMQZ"
+3 SET DIC("S")="I '$P(^PS(50.7,+Y,0),""^"",4)!($P(^(0),""^"",4)'<DT) N PSOF,PSOL S (PSOF,PSOL)=0 F S PSOL=$O(^PSDRUG(""ASP"",+Y,PSOL)) Q:PSOF!'PSOL "
+4 SET DIC("S")=DIC("S")_"I $P($G(^PSDRUG(PSOL,2)),U,3)[""O"",'$G(^(""I""))!($G(^(""I""))'<DT) S PSOF=1"
+5 ;BHW;PSO*7*269;Modify ^DIC call to call MIX^DIC to use only the B and C Cross-References.
+6 SET D="B^C"
DO MIX^DIC1
IF "^"[X
SET PSORXED("DFLG")=1
QUIT
+7 IF Y<1
GOTO PSOI
IF PSOI=+Y
QUIT
+8 SET PSODRUG("OI")=+Y
SET PSODRUG("OIN")=Y(0,0)
KILL DIC
+9 IF PSOI'=PSODRUG("OI")
WRITE !!,"New Orderable Item selected. This edit will create a new prescription!",!
Begin DoDot:1
+10 DO PAUSE^VALM1
DO M2
+11 SET PSHOLDD=$GET(PSODRUG("IEN"))
KILL PSODRUG("IEN"),PSODRUG("NAME")
SET PSODRUG("DEA")=""
SET (PSOOIFLG,PSOSIGFL)=1
+12 DO DREN^PSOORNW2
+13 IF $GET(PSHOLDD)
IF $GET(PSODRUG("IEN"))
IF $GET(PSHOLDD)'=$GET(PSODRUG("IEN"))
Begin DoDot:2
+14 DO FULL^VALM1
DO POST^PSODRG
SET VALMBCK="R"
+15 IF $GET(PSORX("DFLG"))
KILL PSODRUG
SET PSODRUG("IEN")=$GET(PSHOLDD)
SET PSODRUG("NAME")=$PIECE($GET(^PSDRUG(PSODRUG("IEN"),0)),"^")
KILL PSOOIFLG,PSOSIGFL
SET VALMSG=""
End DoDot:2
IF $GET(PSORX("DFLG"))
QUIT
+16 IF '$GET(PSODRUG("IEN"))
WRITE !!,"DRUG NAME REQUIRED!"
DO 2^PSOORNW1
+17 IF '$GET(PSODRUG("IEN"))
KILL PSORXED("FLD"),INDEL,^TMP($JOB,"INS1"),PSOSIGFL,VALMSG
SET PSORXED("DFLG")=1
SET VALMSG="Dispense Drug NOT Selected!"
QUIT
+18 DO KV
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A",1)="You have changed the Orderable Item from"
SET DIR("A",2)=$PIECE(^PS(50.7,PSOI,0),"^")_" to "_PSODRUG("OIN")_"."
SET DIR("A")="Do You want to Edit the SIG"
+19 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
KILL PSODRUG("OIN"),PSOOIFLG,PSOSIGFL
SET PSODRUG("OI")=PSOI
SET VALMSG=""
SET PSORX("DFLG")=1
QUIT
+20 IF 'Y
SET PSORX("DFLG")=1
QUIT
+21 SET PSOREEDQ=1
DO DOLST^PSOORED3
DO DOSE^PSOORED3
KILL PSOREEDQ
+22 IF '$ORDER(PSORXED("DOSE",0))
SET PSORX("DFLG")=1
QUIT
+23 IF $GET(PSOSIGFL)
DO M2
End DoDot:1
KILL PSHOLDD
QUIT
+24 SET PSORXED("FLD",39.2)=PSOI
+25 QUIT
NCPDP ;Reverse previously billed Rx on an edited orderable item or drug.
+1 NEW RX,NPSOY
+2 SET RX=$GET(PSORXED("IRXN"))
IF RX=""
Begin DoDot:1
+3 SET NPSOY=$ORDER(PSONEW("OLD LAST RX#",""))
SET NPSOY=$GET(PSONEW("OLD LAST RX#",NPSOY))
SET RX=$ORDER(^PSRX("B",NPSOY,RX))
End DoDot:1
+4 IF 'RX
QUIT
+5 DO REVERSE^PSOBPSU1(RX,,"DC",7)
SET NCPDPFLG=0
+6 QUIT
UPDATE ;add new data to file
+1 ;
+2 NEW RXREF,UPDATE,FLDS,CHGNDC
+3 NEW APSPRCHK,APSPRFLG
SET APSPRCHK=0
SET APSPRFLG=0
+4 IF '$GET(PSORXED("IRXN"))
QUIT
+5 IF $ORDER(PSORXED("FLD",0))!($GET(^TMP($JOB,"INS1",0))]"")!($GET(INSDEL))!($ORDER(PSORXED("ODOSE",0)))
Begin DoDot:1
+6 KILL DIR,DIRUT,DTOUT,DUOUT
+7 SET DIR(0)="Y"
SET DIR("A")="Are You Sure You Want to Update Rx "_$PIECE(^PSRX(PSORXED("IRXN"),0),"^")
SET DIR("B")="Yes"
+8 DO ^DIR
KILL DIR
IF 'Y
DO M1
QUIT
+9 IF $DATA(^PSRX(PSORXED("IRXN"),1,0))
Begin DoDot:2
+10 SET RXREF=$PIECE(^PSRX(PSORXED("IRXN"),0),"^",9)-$PIECE(^PSRX(PSORXED("IRXN"),1,0),"^",4)
End DoDot:2
+11 IF '$TEST
SET RXREF=0
+12 KILL X,DIRUT,DUOUT,DTOUT
End DoDot:1
IF 'Y
GOTO UPDX
UPDATE1 ;IHS/MSC/MGH separated for reissue code
+1 ;IHS/MSC/PLS - 09/15/06
IF $ORDER(PSORXED("FLD",0))
SET ^TMP("APSPPOS",$JOB,PSORXED("IRXN"))=1
+2 ;update ICD's after edit
IF $DATA(PSORXED("FLD",39.3))
DO UPDATE^PSODIAG
+3 ; - Retrieving fields before changes that are relevant for 3rd Party Billing
+4 DO GETS^DIQ(52,PSORXED("IRXN")_",","4;7;8;20;22;27;81","I","FLDS")
+5 KILL Y
SET DA=PSORXED("IRXN")
SET DIE="^PSRX("
SET FLD=0
+6 FOR
SET FLD=$ORDER(PSORXED("FLD",FLD))
IF 'FLD
QUIT
Begin DoDot:1
+7 ;IHS/MSC/PLS - 05/22/2012
IF FLD=1
SET APSPRCHK=1
+8 ;IHS/MSC/PLS - 06/21/2012
IF FLD=8
Begin DoDot:2
+9 IF $$RMNRFL^APSPFUNC(PSORXED("IRXN"))
QUIT
+10 SET APSPRCHK=4
End DoDot:2
+11 ;I FLD=9,PSORXED("FLD",FLD)>$P(PSORXED("RX0"),U,9) S APSPRCHK=2 ;IHS/MSC/PLS - 10/14/2011 - Change for update to expiration date
+12 ;IHS/MSC/PLS - 05/31/2012 - APSP 1014
IF FLD=9
Begin DoDot:2
+13 ;no change in value
IF PSORXED("FLD",FLD)=$PIECE(PSORXED("RX0"),U,9)
QUIT
+14 IF PSORXED("FLD",FLD)>$PIECE(PSORXED("RX0"),U,9)
SET APSPRCHK=2
QUIT
+15 IF PSORXED("FLD",FLD)<$PIECE(PSORXED("RX0"),U,9)
SET APSPRFLG=1
QUIT
End DoDot:2
+16 IF FLD=12!(FLD=24)!(FLD=35)
Begin DoDot:2
+17 IF FLD=12
IF PSORXED("FLD",12)="@"
SET $PIECE(^PSRX(DA,3),"^",7)=""
QUIT
+18 IF FLD=12
IF PSORXED("FLD",12)]""
SET $PIECE(^PSRX(DA,3),"^",7)=PSORXED("FLD",12)
QUIT
+19 IF FLD=24
IF PSORXED("FLD",24)="@"
SET $PIECE(^PSRX(DA,2),"^",4)=""
QUIT
+20 IF FLD=24
IF PSORXED("FLD",24)]""
SET $PIECE(^PSRX(DA,2),"^",4)=PSORXED("FLD",24)
QUIT
+21 IF FLD=35
IF PSORXED("FLD",35)="@"
SET $PIECE(^PSRX(DA,"MP"),"^")=""
QUIT
+22 IF FLD=35
IF PSORXED("FLD",35)]""
SET $PIECE(^PSRX(DA,"MP"),"^")=PSORXED("FLD",35)
QUIT
End DoDot:2
QUIT
+23 IF FLD=114
Begin DoDot:2
+24 IF PSORXED("FLD",114)="@"
KILL ^PSRX(DA,"INS"),^PSRX(DA,"INS1")
+25 IF PSORXED("FLD",114)'="@"
Begin DoDot:3
+26 SET ^PSRX(DA,"INS")=PSORXED("FLD",114)
+27 SET X=PSORXED("FLD",114)
DO SIG^PSOHELP
IF $GET(INS1)']""
QUIT
+28 SET PSORXED("SIG",1)=$EXTRACT(INS1,2,9999999)
KILL ^PSRX(DA,"INS1")
+29 SET ^PSRX(DA,"INS1",0)="^52.0115^1^1^"_DT_"^^"
+30 SET ^PSRX(DA,"INS1",1,0)=PSORXED("SIG",1)
End DoDot:3
+31 DO DOLST^PSOORED3
IF PSORXED("FLD",114)="@"
KILL PSORXED("SIG")
DO EN^PSOFSIG(.PSORXED)
DO UPDSIG^PSOORED3
End DoDot:2
QUIT
+32 ; IHS/CIA/PLS - 09/07/04 - Fix for Man Expiration Date
+33 IF FLD=29
IF PSORXED("FLD",29)=""
SET $PIECE(^PSRX(DA,2),"^",11)=""
QUIT
+34 IF FLD=27
Begin DoDot:2
+35 IF PSORXED("FLD",27)'=$$GETNDC^PSONDCUT(DA,0)
Begin DoDot:3
+36 SET CHGNDC=1
DO RXACT^PSOBPSU2(DA,0,"NDC changed from "_$$GETNDC^PSONDCUT(DA,0)_" to "_PSORXED("FLD",27)_".","E")
End DoDot:3
+37 DO SAVNDC^PSONDCUT(DA,0,PSORXED("FLD",27),0,1)
End DoDot:2
QUIT
+38 IF FLD=81
DO SAVDAW^PSODAWUT(DA,0,PSORXED("FLD",81))
QUIT
+39 SET DR=FLD_"////"_PSORXED("FLD",FLD)
DO ^DIE
+40 IF FLD=4
DO UDPROV^PSOOREDT
QUIT
+41 IF APSPRCHK=4
Begin DoDot:2
+42 ;Original dispense not released
IF '$PIECE($GET(PSORXED("RX2")),U,13)
SET APSPRCHK=0
QUIT
+43 NEW LASTRFL
+44 SET LASTRFL=$ORDER(^PSRX(PSORXED("IRXN"),1,$CHAR(1)),-1)
+45 IF 'LASTRFL
SET APSPRCHK=4_U_$PIECE($GET(PSORXED("RX2")),U,13)
QUIT
+46 ;Last refill not released
IF '$PIECE($GET(^PSRX(PSORXED("IRXN"),1,LASTRFL,0)),U,18)
SET APSPRCHK=0
QUIT
+47 SET APSPRCHK=4_U_$PIECE($GET(^PSRX(PSORXED("IRXN"),1,LASTRFL,0)),U,18)
End DoDot:2
+48 ;IHS/MSC/PLS - 05/31/2012
IF FLD=9
IF APSPRFLG
Begin DoDot:2
+49 ;remaining fills no action required
IF $$RMNRFL^APSPFUNC(PSORXED("IRXN"))
QUIT
+50 IF '$$RMNRFL^APSPFUNC(PSORXED("IRXN"))
Begin DoDot:3
+51 ;Original dispense not released
IF '$PIECE($GET(PSORXED("RX2")),U,13)
QUIT
+52 NEW LASTRFL
+53 SET LASTRFL=$ORDER(^PSRX(PSORXED("IRXN"),1,$CHAR(1)),-1)
+54 IF 'LASTRFL
SET APSPRCHK=3_U_$PIECE($GET(PSORXED("RX2")),U,13)
QUIT
+55 ;Last refill not released
IF '$PIECE($GET(^PSRX(PSORXED("IRXN"),1,LASTRFL,0)),U,18)
QUIT
+56 SET APSPRCHK=3_U_$PIECE($GET(^PSRX(PSORXED("IRXN"),1,LASTRFL,0)),U,18)
End DoDot:3
End DoDot:2
+57 SET APSPRFLG=0
End DoDot:1
+58 ;
+59 ; - Re-submitting Rx to ECME due to edits
+60 DO RESUB^PSOORED7
+61 ;
+62 IF $GET(INSDEL)
KILL ^PSRX(DA,"INS"),^PSRX(DA,"INS1")
DO DOLST^PSOORED3
KILL PSORXED("SIG")
DO EN^PSOFSIG(.PSORXED)
DO UPDSIG^PSOORED3
GOTO UPDX
+63 IF $ORDER(^TMP($JOB,"INS1",0))
Begin DoDot:1
+64 KILL ^PSRX(DA,"INS"),^PSRX(DA,"INS1"),DD,PSORXED("SIG")
+65 FOR I=0:0
SET I=$ORDER(^TMP($JOB,"INS1",I))
IF 'I
QUIT
SET (PSORXED("SIG",I),^PSRX(DA,"INS1",I,0))=^TMP($JOB,"INS1",I,0)
SET DD=$GET(DD)+1
+66 SET ^PSRX(DA,"INS1",0)=^TMP($JOB,"INS1",0)
+67 IF DD=1
SET ^PSRX(DA,"INS")=^PSRX(DA,"INS1",1,0)
+68 DO DOLST^PSOORED3
DO EN^PSOFSIG(.PSORXED)
DO UPDSIG^PSOORED3
End DoDot:1
+69 ;IHS/MSC/PLS - 10/14/2011 - Update expiration date when more fills are added
+70 IF APSPRCHK
Begin DoDot:1
+71 NEW CS,DE,EXTEXP,X2,NEXPDT,DA,DIE,ISSDT,DRG
+72 SET CS=0
+73 ;IHS/MSC/PLS - 05/22/2012 - Change made to support Issue Date edit
+74 ;S DE=+$E(PSODRUG("DEA"),1)
+75 ;I DE>1,DE<6 S CS=1 S:DE=2 $P(CS,U,2)=1
+76 SET DRG=$PIECE(PSORXED("RX0"),U,6)
+77 SET CS=$$ISSCH^APSPFNC2(DRG,"2345")
+78 SET $PIECE(CS,U,2)=$$ISSCH^APSPFNC2(DRG,"2")
+79 SET EXTEXP=$$GET1^DIQ(50,DRG,9999999.08)
+80 SET ISSDT=$PIECE(^PSRX(PSORXED("IRXN"),0),U,13)
+81 SET X2=$SELECT(EXTEXP:EXTEXP,$PIECE(CS,U,2):184,CS:184,1:366)
+82 ;IHS/MSC/PLS - 05/22/2012
+83 ;S NEXPDT=$$FMADD^XLFDT($P(PSORXED("RX0",U,13),X2)
+84 SET NEXPDT=$$FMADD^XLFDT(ISSDT,X2)
+85 ;IHS/MSC/PLS - 05/22/2012 - Quit if Issue Date edited, prescription has been released and no remaining dispenses
+86 IF +APSPRCHK=1
IF $PIECE(PSORXED("RX2"),U,13)
IF '$$RMNRFL^APSPFUNC(PSORXED("IRXN"))
QUIT
+87 IF +APSPRCHK=3
IF $$EXPDT^APSPAUTO(PSORXED("IRXN"),1,+$PIECE($PIECE(APSPRCHK,U,2),"."))
SET NEXPDT=$$EXPDT^APSPAUTO(PSORXED("IRXN"),1,+$PIECE($PIECE(APSPRCHK,U,2),"."))
+88 ;IHS/MSC/PLS - 06/21/2012
IF +APSPRCHK=4
IF $$EXPDT^APSPAUTO(PSORXED("IRXN"),1,+$PIECE($PIECE(APSPRCHK,U,2),"."))
SET NEXPDT=$$EXPDT^APSPAUTO(PSORXED("IRXN"),1,+$PIECE($PIECE(APSPRCHK,U,2),"."))
+89 SET DA=PSORXED("IRXN")
SET DIE="^PSRX("
+90 SET DR="26///"_NEXPDT
DO ^DIE
+91 SET APSPRCHK=0
End DoDot:1
UPDX ;
+1 KILL DIE,DA,DR,FLD,X,Y,PSORXED("FLD"),DD,^TMP($JOB,"INS1")
KV KILL DIR,DIRUT,DTOUT,DUOUT
+1 QUIT
UPD ;updates dosing array
+1 SET HENT=ENT
UPD1 ;
+1 IF $GET(PSORXED("CONJUNCTION",(HENT+1)))]""
SET PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1))
Begin DoDot:1
+2 KILL PSORXED("CONJUNCTION",(HENT+1))
+3 IF $DATA(PSORXED("DOSE",(HENT+2)))
Begin DoDot:2
+4 SET PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2))
+5 SET PSORXED("ODOSE",(HENT+1))=$GET(PSORXED("ODOSE",(HENT+2)))
+6 SET PSORXED("DOSE ORDERED",(HENT+1))=$GET(PSORXED("DOSE ORDERED",(HENT+2)))
+7 SET PSORXED("UNITS",(HENT+1))=$GET(PSORXED("UNITS",(HENT+2)))
+8 SET PSORXED("NOUN",(HENT+1))=$GET(PSORXED("NOUN",(HENT+2)))
+9 SET PSORXED("DURATION",(HENT+1))=$GET(PSORXED("DURATION",(HENT+2)))
+10 SET PSORXED("CONJUNCTION",(HENT+1))=$GET(PSORXED("CONJUNCTION",(HENT+2)))
+11 SET PSORXED("ROUTE",(HENT+1))=$GET(PSORXED("ROUTE",(HENT+2)))
+12 SET PSORXED("SCHEDULE",(HENT+1))=$GET(PSORXED("SCHEDULE",(HENT+2)))
+13 SET PSORXED("VERB",(HENT+1))=$GET(PSORXED("VERB",(HENT+2)))
+14 KILL PSORXED("DOSE",(HENT+2)),PSORXED("ODOSE",(HENT+2)),PSORXED("DOSE ORDERED",(HENT+2))
+15 KILL PSORXED("UNITS",(HENT+2)),PSORXED("NOUN",(HENT+2)),PSORXED("DURATION",(HENT+2)),PSORXED("ROUTE",(HENT+2)),PSORXED("SCHEDULE",(HENT+2)),PSORXED("VERB",(HENT+2))
End DoDot:2
+16 SET HENT=HENT+1
End DoDot:1
GOTO UPD
+17 FOR I=0:0
SET I=$ORDER(PSORXED("DOSE",I))
IF 'I
QUIT
SET SENT=$GET(SENT)+1
+18 QUIT
+19 ;
M1 DO M1^PSOOREDX
+1 QUIT
M2 DO M2^PSOOREDX
+1 QUIT
