PSORXED1 ;BHAM ISC/SAB - Edit prescription utility #2 ;29-May-2012 15:12;PLS
;;7.0;OUTPATIENT PHARMACY;**2,16,21,1002,289,1015**;DEC 1997;Build 62
;show edits on last refill
; Modified - IHS/CIA/PLS - 12/21/03 - PSORXED1+6
; IHS/CIA/PLS - 01/26/04 - Added set for RX19999999 node
; IHS/CIA/PLS - 12/13/04 - Line APCOM+17
;F ZDL=0:0 S ZDL=$O(^PSRX(DA,1,ZDL)) Q:'ZDL S:$P($G(^PSRX(DA,1,ZDL,0)),"^") ZD(DA)=$P($G(^PSRX(DA,1,ZDL,0)),"^")
F ZDL=0:0 S ZDL=$O(^PSRX(DA,1,ZDL)) Q:'ZDL S:$P($G(^PSRX(DA,1,ZDL,0)),"^") ZD(DA)=$P($G(^PSRX(DA,1,ZDL,0)),"^") S PSORXED("RX19999999")=$G(^(9999999))
G:'$O(^PSRX(DA,1,0))!($G(^PSRX(DA,1,RFED,0))']"") SUS S (PSRX1,RX1)=PSORXED("RX1"),QTY=$P(RX1,"^",4),QTY=QTY-$P(^PSRX(DA,1,RFED,0),"^",4)
;S COM1="" F I=1:1:6,9:1:11,17 I $P(PSRX1,"^",I)'=$P(^PSRX(DA,1,RFED,0),"^",I) D
;.S PSI=$S(I=1:.01,I=4:1,I=5:4,I=6:5,I=9:8,I=10:1.1,I=11:1.2,I=17:15,1:I),COM1=COM1_$P(^DD(52.1,PSI,0),"^")_" ("_$P(PSRX1,"^",I)_"),"
; IHS/CIA/PLS - 12/21/03 - Need NDC for refill
S COM1="" F I=1:1:6,9:1:11,13,17 I $P(PSRX1,"^",I)'=$P(^PSRX(DA,1,RFED,0),"^",I) D
.S PSI=$S(I=1:.01,I=4:1,I=5:4,I=6:5,I=9:8,I=10:1.1,I=11:1.2,I=13:17,I=17:15,1:I),COM1=COM1_$P(^DD(52.1,PSI,0),"^")_" ("_$P(PSRX1,"^",I)_"),"
; IHS/CIA/PLS - 12/21/03 - Need AWP on refill
I $P(PSORXED("RX19999999"),U,6)'=$P($G(^PSRX(DA,1,RFD,9999999)),U,6) D
.S COM1=COM1_$P(^DD(52.1,9999999.06,0),U)_" ("_$P(PSORXED("RX19999999"),U,6)_"),"
; IHS/CIA/PLS - 12/21/03 - Guarantee printing and billing of refill note in OVERRIDE^APSQBRES
S:$G(APSQCOMR)]"" COM1=COM1_APSQCOMR K APSQCOMR
N PSOTRIC,PSOECMES,PSOERFL S (PSOTRIC,PSOERFL,PSOECMES)="",PSOERFL=$$LSTRFL^PSOBPSU1(DA),PSOECMES=$$FIND^PSOREJUT(DA,PSOERFL)
S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(DA,PSOERFL,.PSOTRIC)
I COM1=""&('$G(PSOTRIC)) K COM1 G SUS
I COM1=""&($G(PSOTRIC)) G:'PSOECMES SKPTRIC I PSOECMES K COM1 G SUS
;
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^"_DUZ_"^"_$S(RFED'<0&(RFED<6):RFED,1:(RFED+1))_"^"_COM1
SKPTRIC ;
I QTY,$P(^PSRX(DA,1,RFED,0),"^",18) S ^PSDRUG($P(^PSRX(DA,0),"^",6),660.1)=$S($D(^PSDRUG(+$P(^PSRX(DA,0),"^",6),660.1)):^(660.1)+QTY,1:QTY)
G:RFD'=RFED EX
D FILL^PSORXED S PSOEDITL=$S($G(PSOEDITF)'=$G(RFED):1,$G(PSOEDITF)=$G(RFED)&('$G(PSOEDITR)):0,1:2)
I $G(PSOTRIC)&(PSOECMES) S PSOEDITL=0 G SUS
I $G(PSOEDITL)=2,'$G(RXRP(DA)),$P($G(^PSRX(DA,"STA")),"^")'=5,'$G(PSOSIGFL) D ASKL^PSORXED
G:+$P(^PSRX(DA,"STA"),"^")!($G(PSOEDITL)=1&('$G(PSOTRIC))) SUS I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSORXED("IRXN")_"," S RXFL(DA)=RFED D SETRP^PSORXED G SUS
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 ELSE
.I PSORX("PSOL",PSOX2)'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSORXED("IRXN")_"," D SETRP^PSORXED
E I PSORX("PSOL",PSOX2)'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2+1)=PSORXED("IRXN")_"," D SETRP^PSORXED
ELSE S RXFL(DA)=RFED
K COM1
SUS ;update suspense file
K PSOEDITF,PSOEDITR,PSOEDITL
S RXS=$O(^PS(52.5,"B",DA,0)) I RXS,$G(^PS(52.5,RXS,"P"))=1 S ZD=$P(^PSRX(DA,3),"^") Q
G:'RXS EX
N PSOSITE I RFDT,$G(^PSRX(DA,1,RFED,0))]"",RFDT'=+$G(^PSRX(DA,1,RFED,0))!($P(PSORXED("RX1"),"^",9)'=$P(^(0),"^",9)) S SD=$P(^PSRX(DA,1,RFED,0),"^"),PSOSITE=$P(^(0),"^",9) D SUP Q
I 'RFED,$P(PSORXED("RX2"),"^",2)'=$P(^PSRX(DA,2),"^",2)!($P(PSORXED("RX2"),"^",9)'=$P(^(2),"^",9)) S SD=$P(^PSRX(DA,2),"^",2),PSOSITE=$P(^(2),"^",9) D SUP
EX K COM1,DIK,K,PSORXED("RX1"),RX1,RXS,SD,IR,FDA,RXN,RFDT,COPIES,J,PSPOP,COM,RX0,RX2,D1,IOP,%,%Y,D0,DA,D1
K DIC,DIE,DIG,DQ,DR,DRUG,I,II,N,PHYS,PS,QTY,RFDATE,RFL,RFL1,RXF,SIG,ST,ST0,Z,Z0,Z1,X,Y,ZDL
Q
SUP I $P($G(^PS(52.5,RXS,0)),"^",7)="Q" D SUS^PSOCMOPB Q
S RXN=DA,RX0=^PSRX(DA,0),DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN
S DIC="^PS(52.5,",DIC(0)="L",X=RXN,DLAYGO=52.5
S DIC("DR")=".02///"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///0;.06////"_PSOSITE_";2///0" K DD,DO D FILE^DICN I +$G(Y),$G(RFED)'="" S $P(^PS(52.5,+Y,0),"^",13)=$G(RFED)
S IR=0,DA=RXN F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA
S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^E^"_DUZ_"^"_$S(RFED'<0&(RFED<6):RFED,1:(RFED+1))_"^RX Placed on Suspense until "_$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3)
W !,"RX# "_$P(RX0,"^")_" has been Suspended until "_$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3)_".",!
Q
;
DIE W !,"Now Editing Rx # ",$P(PSORXED("RX0"),"^") K DIE,DA,DIC,DR S DIE="^PSRX(",DA=PSORXED("IRXN")
; IHS/CIA/PLS - 12/21/03 - Adjust field list for edit
;S DR="1;22R;3;Q;4;5"_$S($P(PSOPAR,"^",3):";6",1:"")_";6.5:8;Q;17;9:10;10.6;11;"_$S($P(PSOPAR,"^",12):"35;",1:"")_"12;20" S:RFD DR=DR_";52" S DR=DR_";23;24",DR(2,52.1)=".01:5;8;15"
S DR="1;22R;"_$S('$G(RFD):"3;",1:"")_"Q;4;5"_$S($P(PSOPAR,"^",3):";6",1:"")_";6.5:8;Q;17;9:10;10.6;11;"_$S($P(PSOPAR,"^",12):"35;",1:"")_"12;20;9999999.02" S DR=DR_";23"
S DR(2,52.1)="I +D'=$G(APSREFD) S Y=0 W ""ONLY THE LAST REFILL CAN BE EDITED"";1:4;8;15"
S DR=DR_";27;S APSAZNDC=X;W !,""DELETE AWP FIELD TO RECALCUATE"";9999999.06//^S X=$$AWP^APSQDAWP($G(APSAZNDC),APSAZIEN,.MESS);I X="""" S Y=9999999.06;W !,$G(MESS) K MESS;9999999.07"
S DR(2,52.1)=DR(2,52.1)_";11;S APSARNDC=X;W !,""DELETE REFILL AWP FIELD TO RECALCULATE"";9999999.06//^S X=$$AWP^APSQDAWP($G(APSARNDC),APSAZIEN,.MESS);I X="""" S Y=9999999.06;W !,$G(MESS) K MESS;9999999.07"
S (APSREFF,APSREFD,I)=0 F S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'+I S APSREFF=APSREFF+1
S:APSREFF APSREFD=+(^PSRX(PSORXED("IRXN"),1,APSREFF,0))
I APSPMAN=1&(RFD) S DR(2,52.1)=DR(2,52.1)_";5;12;13"
I APSPMAN=2&(RFD) S DR(2,52.1)=DR(2,52.1)_";13"
I APSPMAN=1&'$G(RFD) S DR=DR_";24;28;29"
I APSPMAN=2&'$G(RFD) S DR=DR_";29"
S:RFD DR=DR_";52" ; Refill prompt last
S PSOBXIEN=$P($G(^PSRX(PSORXED("IRXN"),9999999)),"^",12) ;Insurer field of Rx
S:RFD PSOBRIEN=$P($G(^PSRX(PSORXED("IRXN"),1,RFD,9999999)),"^",12) ; Insurer of last refill
S:'RFD DR=DR_";W !,""DO YOU WANT TO EDIT RX INSURER INFO"" S %=2 D YN^DICN S:%'=1 Y=0;9999999.12///^S X=$$OVERRIDE^APSQBRES(PSOBXIEN)" ;If no refill
S:RFD DR(2,52.1)=DR(2,52.1)_";W !,""DO YOU WANT TO EDIT REFILL INSURER INFO"" S %=2 D YN^DICN S:%'=1 Y=0;9999999.12///^S X=$$OVERRIDE^APSQBRES(PSOBRIEN)" ;If refill exists
; IHS/CIA/PLS - 12/21/03 - End of Changes
D ^DIE K DIE,DR,DA,X,Y L -^PSRX(PSORXED("IRXN")) I RFD,$G(^PSRX(PSORXED("IRXN"),1,RFD,0))]"" D
.S:$P(PSORXED("RX1"),"^",17)'=$P(^PSRX(PSORXED("IRXN"),1,RFD,0),"^",17) PSONEW("PROVIDER NAME")=$P(^VA(200,$P(^PSRX(PSORXED("IRXN"),1,RFD,0),"^",17),0),"^")
; IHS/CIA/PLS - 12/21/03 - Begin modifications
APCOM ;
S COM=""
I APSPMAN=""!(APSPMAN=3) S PSONEW("EXPIRATION DATE")="",PSONEW("MANUFACTURER")="",PSONEW("LOT #")=""
; Setup COM variable for MFG data
I APSPMAN=1&'$G(RFD) S APSP91=^PSRX(PSORXED("IRXN"),2),PSONEW("EXPIRATION DATE")=$P($G(APSP91),"^",11),PSONEW("MANUFACTURER")=$P($G(APSP91),"^",8),PSONEW("LOT #")=$P($G(APSP91),"^",4) D
.I PSONEW("EXPIRATION DATE")'=$P($G(PSORXED("RX2")),"^",11) S COM=COM_$P(^DD(52,29,0),"^")_" ("_PSONEW("EXPIRATION DATE")_"),"
.I PSONEW("MANUFACTURER")'=$P($G(PSORXED("RX2")),"^",8) S COM=COM_$P(^DD(52,28,0),"^")_" ("_PSONEW("MANUFACTURER")_"),"
.I PSONEW("LOT #")'=$P($G(PSORXED("RX2")),"^",4) S COM=COM_$P(^DD(52,24,0),"^")_" ("_PSONEW("LOT #")_"),"
I APSPMAN=2&'$G(RFD) S APSP91=^PSRX(PSORXED("IRXN"),2),PSONEW("EXPIRATION DATE")=$P($G(APSP91),"^",11)
; Setup COM variable for refill MFG data
I APSPMAN=1&(RFD) S APSP92=$G(^PSRX(PSORXED("IRXN"),1,RFD,0)),APSP44("EXP DATE")=$P($G(APSP92),"^",15),APSP44("MFG")=$P($G(APSP92),"^",14),APSP44("LOT #")=$P($G(APSP92),"^",6) D
.S PSONEW("EXPIRATION DATE")=APSP44("EXP DATE"),PSONEW("MANUFACTURER")=APSP44("MFG"),PSONEW("LOT #")=APSP44("LOT #")
.I APSP44("EXP DATE")'=$P($G(PSORXED("RX1")),"^",15) S COM=COM_$P(^DD(52.1,13,0),"^")_" ("_APSP44("EXP DATE")_"),"
.I APSP44("MFG")'=$P($G(PSORXED("RX1")),"^",14) S COM=COM_$P(^DD(52.1,12,0),"^")_" ("_APSP44("MFG")_"),"
.I APSP44("LOT #")'=$P($G(PSORXED("RX1")),"^",6) S COM=COM_$P(^DD(52.1,5,0),"^")_" ("_APSP44("LOT #")_"),"
I APSPMAN=2&(RFD) S APSP92=$G(^PSRX(PSORXED("IRXN"),1,RFD,0)),APSP44("EXP DATE")=$P($G(APSP92),"^",15),PSONEW("EXPIRATION DATE")=APSP44("EXP DATE") D
.I APSP44("EXP DATE")'=$P($G(PSORXED("RX1")),"^",15) S COM=COM_$P(^DD(52.1,13,0),"^")_" ("_APSP44("EXP DATE")_"),"
;S:$G(APSPCP) PSORXED("CM")=$$GET1^DIQ(52,PSORXED("IRXN"),9999999.02)
S:$G(APSPCP) PSORXED("CM")=$$GET1^DIQ(52,PSORXED("IRXN"),9999999.02,"I") ; CIA/IHS/PLS - 12/13/04 - Added internal flag
S PSORXED("NDC")=$P($G(^PSRX(PSORXED("IRXN"),2)),"^",7),PSORXED("AWP")=$P($G(^(9999999)),"^",6) ; Data displayed at line EN1^PSONEW2
I $G(RFD) S PSORXED("NDC")=$P($G(^PSRX(PSORXED("IRXN"),1,RFD,0)),"^",13),PSORXED("AWP")=$P($G(^PSRX(PSORXED("IRXN"),1,RFD,9999999)),"^",6) ; Data displayed at line EN1^PSONEW2
D EN1^PSONEW2(.PSORXED) I PSORXED("DFLG") S PSORXED("QFLG")=1 G DIEX
G:'PSORXED("QFLG") DIE S PSORXED("QFLG")=0
DIEX Q
PSORXED1 ;BHAM ISC/SAB - Edit prescription utility #2 ;29-May-2012 15:12;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**2,16,21,1002,289,1015**;DEC 1997;Build 62
+2 ;show edits on last refill
+3 ; Modified - IHS/CIA/PLS - 12/21/03 - PSORXED1+6
+4 ; IHS/CIA/PLS - 01/26/04 - Added set for RX19999999 node
+5 ; IHS/CIA/PLS - 12/13/04 - Line APCOM+17
+6 ;F ZDL=0:0 S ZDL=$O(^PSRX(DA,1,ZDL)) Q:'ZDL S:$P($G(^PSRX(DA,1,ZDL,0)),"^") ZD(DA)=$P($G(^PSRX(DA,1,ZDL,0)),"^")
+7 FOR ZDL=0:0
SET ZDL=$ORDER(^PSRX(DA,1,ZDL))
IF 'ZDL
QUIT
IF $PIECE($GET(^PSRX(DA,1,ZDL,0)),"^")
SET ZD(DA)=$PIECE($GET(^PSRX(DA,1,ZDL,0)),"^")
SET PSORXED("RX19999999")=$GET(^(9999999))
+8 IF '$ORDER(^PSRX(DA,1,0))!($GET(^PSRX(DA,1,RFED,0))']"")
GOTO SUS
SET (PSRX1,RX1)=PSORXED("RX1")
SET QTY=$PIECE(RX1,"^",4)
SET QTY=QTY-$PIECE(^PSRX(DA,1,RFED,0),"^",4)
+9 ;S COM1="" F I=1:1:6,9:1:11,17 I $P(PSRX1,"^",I)'=$P(^PSRX(DA,1,RFED,0),"^",I) D
+10 ;.S PSI=$S(I=1:.01,I=4:1,I=5:4,I=6:5,I=9:8,I=10:1.1,I=11:1.2,I=17:15,1:I),COM1=COM1_$P(^DD(52.1,PSI,0),"^")_" ("_$P(PSRX1,"^",I)_"),"
+11 ; IHS/CIA/PLS - 12/21/03 - Need NDC for refill
+12 SET COM1=""
FOR I=1:1:6,9:1:11,13,17
IF $PIECE(PSRX1,"^",I)'=$PIECE(^PSRX(DA,1,RFED,0),"^",I)
Begin DoDot:1
+13 SET PSI=$SELECT(I=1:.01,I=4:1,I=5:4,I=6:5,I=9:8,I=10:1.1,I=11:1.2,I=13:17,I=17:15,1:I)
SET COM1=COM1_$PIECE(^DD(52.1,PSI,0),"^")_" ("_$PIECE(PSRX1,"^",I)_"),"
End DoDot:1
+14 ; IHS/CIA/PLS - 12/21/03 - Need AWP on refill
+15 IF $PIECE(PSORXED("RX19999999"),U,6)'=$PIECE($GET(^PSRX(DA,1,RFD,9999999)),U,6)
Begin DoDot:1
+16 SET COM1=COM1_$PIECE(^DD(52.1,9999999.06,0),U)_" ("_$PIECE(PSORXED("RX19999999"),U,6)_"),"
End DoDot:1
+17 ; IHS/CIA/PLS - 12/21/03 - Guarantee printing and billing of refill note in OVERRIDE^APSQBRES
+18 IF $GET(APSQCOMR)]""
SET COM1=COM1_APSQCOMR
KILL APSQCOMR
+19 NEW PSOTRIC,PSOECMES,PSOERFL
SET (PSOTRIC,PSOERFL,PSOECMES)=""
SET PSOERFL=$$LSTRFL^PSOBPSU1(DA)
SET PSOECMES=$$FIND^PSOREJUT(DA,PSOERFL)
+20 SET PSOTRIC=""
SET PSOTRIC=$$TRIC^PSOREJP1(DA,PSOERFL,.PSOTRIC)
+21 IF COM1=""&('$GET(PSOTRIC))
KILL COM1
GOTO SUS
+22 IF COM1=""&($GET(PSOTRIC))
IF 'PSOECMES
GOTO SKPTRIC
IF PSOECMES
KILL COM1
GOTO SUS
+23 ;
+24 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
+25 SET D1=D1+1
IF '($DATA(^PSRX(DA,"A",0))#2)
SET ^(0)="^52.3DA^^^"
SET ^(0)=$PIECE(^(0),"^",1,2)_"^"_D1_"^"_K
+26 SET ^PSRX(DA,"A",D1,0)=DT_"^E^"_DUZ_"^"_$SELECT(RFED'<0&(RFED<6):RFED,1:(RFED+1))_"^"_COM1
SKPTRIC ;
+1 IF QTY
IF $PIECE(^PSRX(DA,1,RFED,0),"^",18)
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 RFD'=RFED
GOTO EX
+3 DO FILL^PSORXED
SET PSOEDITL=$SELECT($GET(PSOEDITF)'=$GET(RFED):1,$GET(PSOEDITF)=$GET(RFED)&('$GET(PSOEDITR)):0,1:2)
+4 IF $GET(PSOTRIC)&(PSOECMES)
SET PSOEDITL=0
GOTO SUS
+5 IF $GET(PSOEDITL)=2
IF '$GET(RXRP(DA))
IF $PIECE($GET(^PSRX(DA,"STA")),"^")'=5
IF '$GET(PSOSIGFL)
DO ASKL^PSORXED
+6 IF +$PIECE(^PSRX(DA,"STA"),"^")!($GET(PSOEDITL)=1&('$GET(PSOTRIC)))
GOTO SUS
IF $GET(PSORX("PSOL",1))']""
SET PSORX("PSOL",1)=PSORXED("IRXN")_","
SET RXFL(DA)=RFED
DO SETRP^PSORXED
GOTO SUS
+7 FOR PSOX1=0:0
SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
IF 'PSOX1
QUIT
SET PSOX2=PSOX1
+8 IF $LENGTH(PSORX("PSOL",PSOX2))+$LENGTH(PSORXED("IRXN"))<220
Begin DoDot:1
+9 IF PSORX("PSOL",PSOX2)'[PSORXED("IRXN")_","
SET PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSORXED("IRXN")_","
DO SETRP^PSORXED
End DoDot:1
GOTO ELSE
+10 IF '$TEST
IF PSORX("PSOL",PSOX2)'[PSORXED("IRXN")_","
SET PSORX("PSOL",PSOX2+1)=PSORXED("IRXN")_","
DO SETRP^PSORXED
ELSE SET RXFL(DA)=RFED
+1 KILL COM1
SUS ;update suspense file
+1 KILL PSOEDITF,PSOEDITR,PSOEDITL
+2 SET RXS=$ORDER(^PS(52.5,"B",DA,0))
IF RXS
IF $GET(^PS(52.5,RXS,"P"))=1
SET ZD=$PIECE(^PSRX(DA,3),"^")
QUIT
+3 IF 'RXS
GOTO EX
+4 NEW PSOSITE
IF RFDT
IF $GET(^PSRX(DA,1,RFED,0))]""
IF RFDT'=+$GET(^PSRX(DA,1,RFED,0))!($PIECE(PSORXED("RX1"),"^",9)'=$PIECE(^(0),"^",9))
SET SD=$PIECE(^PSRX(DA,1,RFED,0),"^")
SET PSOSITE=$PIECE(^(0),"^",9)
DO SUP
QUIT
+5 IF 'RFED
IF $PIECE(PSORXED("RX2"),"^",2)'=$PIECE(^PSRX(DA,2),"^",2)!($PIECE(PSORXED("RX2"),"^",9)'=$PIECE(^(2),"^",9))
SET SD=$PIECE(^PSRX(DA,2),"^",2)
SET PSOSITE=$PIECE(^(2),"^",9)
DO SUP
EX KILL COM1,DIK,K,PSORXED("RX1"),RX1,RXS,SD,IR,FDA,RXN,RFDT,COPIES,J,PSPOP,COM,RX0,RX2,D1,IOP,%,%Y,D0,DA,D1
+1 KILL DIC,DIE,DIG,DQ,DR,DRUG,I,II,N,PHYS,PS,QTY,RFDATE,RFL,RFL1,RXF,SIG,ST,ST0,Z,Z0,Z1,X,Y,ZDL
+2 QUIT
SUP IF $PIECE($GET(^PS(52.5,RXS,0)),"^",7)="Q"
DO SUS^PSOCMOPB
QUIT
+1 SET RXN=DA
SET RX0=^PSRX(DA,0)
SET DA=RXS
SET DIK="^PS(52.5,"
DO ^DIK
SET DA=RXN
+2 SET DIC="^PS(52.5,"
SET DIC(0)="L"
SET X=RXN
SET DLAYGO=52.5
+3 SET DIC("DR")=".02///"_SD_";.03////"_$PIECE(^PSRX(DA,0),"^",2)_";.04///M;.05///0;.06////"_PSOSITE_";2///0"
KILL DD,DO
DO FILE^DICN
IF +$GET(Y)
IF $GET(RFED)'=""
SET $PIECE(^PS(52.5,+Y,0),"^",13)=$GET(RFED)
+4 SET IR=0
SET DA=RXN
FOR FDA=0:0
SET FDA=$ORDER(^PSRX(DA,"A",FDA))
IF 'FDA
QUIT
SET IR=FDA
+5 SET IR=IR+1
SET ^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
+6 DO NOW^%DTC
SET ^PSRX(DA,"A",IR,0)=%_"^E^"_DUZ_"^"_$SELECT(RFED'<0&(RFED<6):RFED,1:(RFED+1))_"^RX Placed on Suspense until "_$EXTRACT(SD,4,5)_"-"_$EXTRACT(SD,6,7)_"-"_$EXTRACT(SD,2,3)
+7 WRITE !,"RX# "_$PIECE(RX0,"^")_" has been Suspended until "_$EXTRACT(SD,4,5)_"-"_$EXTRACT(SD,6,7)_"-"_$EXTRACT(SD,2,3)_".",!
+8 QUIT
+9 ;
DIE WRITE !,"Now Editing Rx # ",$PIECE(PSORXED("RX0"),"^")
KILL DIE,DA,DIC,DR
SET DIE="^PSRX("
SET DA=PSORXED("IRXN")
+1 ; IHS/CIA/PLS - 12/21/03 - Adjust field list for edit
+2 ;S DR="1;22R;3;Q;4;5"_$S($P(PSOPAR,"^",3):";6",1:"")_";6.5:8;Q;17;9:10;10.6;11;"_$S($P(PSOPAR,"^",12):"35;",1:"")_"12;20" S:RFD DR=DR_";52" S DR=DR_";23;24",DR(2,52.1)=".01:5;8;15"
+3 SET DR="1;22R;"_$SELECT('$GET(RFD):"3;",1:"")_"Q;4;5"_$SELECT($PIECE(PSOPAR,"^",3):";6",1:"")_";6.5:8;Q;17;9:10;10.6;11;"_$SELECT($PIECE(PSOPAR,"^",12):"35;",1:"")_"12;20;9999999.02"
SET DR=DR_";23"
+4 SET DR(2,52.1)="I +D'=$G(APSREFD) S Y=0 W ""ONLY THE LAST REFILL CAN BE EDITED"";1:4;8;15"
+5 SET DR=DR_";27;S APSAZNDC=X;W !,""DELETE AWP FIELD TO RECALCUATE"";9999999.06//^S X=$$AWP^APSQDAWP($G(APSAZNDC),APSAZIEN,.MESS);I X="""" S Y=9999999.06;W !,$G(MESS) K MESS;9999999.07"
+6 SET DR(2,52.1)=DR(2,52.1)_";11;S APSARNDC=X;W !,""DELETE REFILL AWP FIELD TO RECALCULATE"";9999999.06//^S X=$$AWP^APSQDAWP($G(APSARNDC),APSAZIEN,.MESS);I X="""" S Y=9999999.06;W !,$G(MESS) K MESS;9999999.07"
+7 SET (APSREFF,APSREFD,I)=0
FOR
SET I=$ORDER(^PSRX(PSORXED("IRXN"),1,I))
IF '+I
QUIT
SET APSREFF=APSREFF+1
+8 IF APSREFF
SET APSREFD=+(^PSRX(PSORXED("IRXN"),1,APSREFF,0))
+9 IF APSPMAN=1&(RFD)
SET DR(2,52.1)=DR(2,52.1)_";5;12;13"
+10 IF APSPMAN=2&(RFD)
SET DR(2,52.1)=DR(2,52.1)_";13"
+11 IF APSPMAN=1&'$GET(RFD)
SET DR=DR_";24;28;29"
+12 IF APSPMAN=2&'$GET(RFD)
SET DR=DR_";29"
+13 ; Refill prompt last
IF RFD
SET DR=DR_";52"
+14 ;Insurer field of Rx
SET PSOBXIEN=$PIECE($GET(^PSRX(PSORXED("IRXN"),9999999)),"^",12)
+15 ; Insurer of last refill
IF RFD
SET PSOBRIEN=$PIECE($GET(^PSRX(PSORXED("IRXN"),1,RFD,9999999)),"^",12)
+16 ;If no refill
IF 'RFD
SET DR=DR_";W !,""DO YOU WANT TO EDIT RX INSURER INFO"" S %=2 D YN^DICN S:%'=1 Y=0;9999999.12///^S X=$$OVERRIDE^APSQBRES(PSOBXIEN)"
+17 ;If refill exists
IF RFD
SET DR(2,52.1)=DR(2,52.1)_";W !,""DO YOU WANT TO EDIT REFILL INSURER INFO"" S %=2 D YN^DICN S:%'=1 Y=0;9999999.12///^S X=$$OVERRIDE^APSQBRES(PSOBRIEN)"
+18 ; IHS/CIA/PLS - 12/21/03 - End of Changes
+19 DO ^DIE
KILL DIE,DR,DA,X,Y
LOCK -^PSRX(PSORXED("IRXN"))
IF RFD
IF $GET(^PSRX(PSORXED("IRXN"),1,RFD,0))]""
Begin DoDot:1
+20 IF $PIECE(PSORXED("RX1"),"^",17)'=$PIECE(^PSRX(PSORXED("IRXN"),1,RFD,0),"^",17)
SET PSONEW("PROVIDER NAME")=$PIECE(^VA(200,$PIECE(^PSRX(PSORXED("IRXN"),1,RFD,0),"^",17),0),"^")
End DoDot:1
+21 ; IHS/CIA/PLS - 12/21/03 - Begin modifications
APCOM ;
+1 SET COM=""
+2 IF APSPMAN=""!(APSPMAN=3)
SET PSONEW("EXPIRATION DATE")=""
SET PSONEW("MANUFACTURER")=""
SET PSONEW("LOT #")=""
+3 ; Setup COM variable for MFG data
+4 IF APSPMAN=1&'$GET(RFD)
SET APSP91=^PSRX(PSORXED("IRXN"),2)
SET PSONEW("EXPIRATION DATE")=$PIECE($GET(APSP91),"^",11)
SET PSONEW("MANUFACTURER")=$PIECE($GET(APSP91),"^",8)
SET PSONEW("LOT #")=$PIECE($GET(APSP91),"^",4)
Begin DoDot:1
+5 IF PSONEW("EXPIRATION DATE")'=$PIECE($GET(PSORXED("RX2")),"^",11)
SET COM=COM_$PIECE(^DD(52,29,0),"^")_" ("_PSONEW("EXPIRATION DATE")_"),"
+6 IF PSONEW("MANUFACTURER")'=$PIECE($GET(PSORXED("RX2")),"^",8)
SET COM=COM_$PIECE(^DD(52,28,0),"^")_" ("_PSONEW("MANUFACTURER")_"),"
+7 IF PSONEW("LOT #")'=$PIECE($GET(PSORXED("RX2")),"^",4)
SET COM=COM_$PIECE(^DD(52,24,0),"^")_" ("_PSONEW("LOT #")_"),"
End DoDot:1
+8 IF APSPMAN=2&'$GET(RFD)
SET APSP91=^PSRX(PSORXED("IRXN"),2)
SET PSONEW("EXPIRATION DATE")=$PIECE($GET(APSP91),"^",11)
+9 ; Setup COM variable for refill MFG data
+10 IF APSPMAN=1&(RFD)
SET APSP92=$GET(^PSRX(PSORXED("IRXN"),1,RFD,0))
SET APSP44("EXP DATE")=$PIECE($GET(APSP92),"^",15)
SET APSP44("MFG")=$PIECE($GET(APSP92),"^",14)
SET APSP44("LOT #")=$PIECE($GET(APSP92),"^",6)
Begin DoDot:1
+11 SET PSONEW("EXPIRATION DATE")=APSP44("EXP DATE")
SET PSONEW("MANUFACTURER")=APSP44("MFG")
SET PSONEW("LOT #")=APSP44("LOT #")
+12 IF APSP44("EXP DATE")'=$PIECE($GET(PSORXED("RX1")),"^",15)
SET COM=COM_$PIECE(^DD(52.1,13,0),"^")_" ("_APSP44("EXP DATE")_"),"
+13 IF APSP44("MFG")'=$PIECE($GET(PSORXED("RX1")),"^",14)
SET COM=COM_$PIECE(^DD(52.1,12,0),"^")_" ("_APSP44("MFG")_"),"
+14 IF APSP44("LOT #")'=$PIECE($GET(PSORXED("RX1")),"^",6)
SET COM=COM_$PIECE(^DD(52.1,5,0),"^")_" ("_APSP44("LOT #")_"),"
End DoDot:1
+15 IF APSPMAN=2&(RFD)
SET APSP92=$GET(^PSRX(PSORXED("IRXN"),1,RFD,0))
SET APSP44("EXP DATE")=$PIECE($GET(APSP92),"^",15)
SET PSONEW("EXPIRATION DATE")=APSP44("EXP DATE")
Begin DoDot:1
+16 IF APSP44("EXP DATE")'=$PIECE($GET(PSORXED("RX1")),"^",15)
SET COM=COM_$PIECE(^DD(52.1,13,0),"^")_" ("_APSP44("EXP DATE")_"),"
End DoDot:1
+17 ;S:$G(APSPCP) PSORXED("CM")=$$GET1^DIQ(52,PSORXED("IRXN"),9999999.02)
+18 ; CIA/IHS/PLS - 12/13/04 - Added internal flag
IF $GET(APSPCP)
SET PSORXED("CM")=$$GET1^DIQ(52,PSORXED("IRXN"),9999999.02,"I")
+19 ; Data displayed at line EN1^PSONEW2
SET PSORXED("NDC")=$PIECE($GET(^PSRX(PSORXED("IRXN"),2)),"^",7)
SET PSORXED("AWP")=$PIECE($GET(^(9999999)),"^",6)
+20 ; Data displayed at line EN1^PSONEW2
IF $GET(RFD)
SET PSORXED("NDC")=$PIECE($GET(^PSRX(PSORXED("IRXN"),1,RFD,0)),"^",13)
SET PSORXED("AWP")=$PIECE($GET(^PSRX(PSORXED("IRXN"),1,RFD,9999999)),"^",6)
+21 DO EN1^PSONEW2(.PSORXED)
IF PSORXED("DFLG")
SET PSORXED("QFLG")=1
GOTO DIEX
+22 IF 'PSORXED("QFLG")
GOTO DIE
SET PSORXED("QFLG")=0
DIEX QUIT
