PSOORED2 ;ISC-BHAM/SAB-edit orders from backdoor con't ;29-May-2012 14:56;PLS
;;7.0;OUTPATIENT PHARMACY;**2,51,46,78,102,114,117,133,1005,159,148,247,260,281,289,1015**;DEC 1997;Build 62
;Reference to $$DIVNCPDP^BPSBUTL supported by IA 4719
;Reference to $$ECMEON^BPSUTIL supported by IA 4410
;called from psooredt. cmop edit checks.
; Modified - IHS/CIA/PLS - 01/26/04 - Line RFX+3
; 05/27/10 - Line RFE+9
Q
ISDT D CHK K RF I $G(CMRL) W !,"Released by CMOP. No editing allowed on Issue Date." D PAUSE^VALM1 K CMRL Q
S %DT="AEX",%DT(0)=-$P(^PSRX(DA,2),"^",2),Y=$P(RX0,"^",13) X ^DD("DD") S %DT("A")="ISSUE DATE: ",%DT("B")=Y D ^%DT I "^"[$E(X) K X,Y,%DT,DTOUT,DUOUT Q
G:Y=-1 ISDT S PSORXED("FLD",1)=Y
;S DR="1///"_Y,DIE=52 D ^DIE
D KV K X,Y,%DT
Q
FLDT D CHK K RF I $G(CMRL) W !,"Released by CMOP. No editing allowed on Fill Date." D PAUSE^VALM1 K CMRL Q
D KV S Y=$P(^PSRX(DA,2),"^",2) X ^DD("DD") S DIR("A")="FILL DATE",DIR("B")=Y
S DIR(0)="D^"_$P(RX0,"^",13)_":"_$P(PSORXED("RX2"),"^",6)_":EX"
S DIR("?",1)="The earliest fill date allowed is determined by the Issue Date,",DIR("?",2)="the Fill Date cannot be before the Issue Date or past the Expiration Date."
S DIR("?")="Both the month and day are required." D ^DIR
I $D(DIRUT) D KV K PSORXED("FLD",22),X,Y Q
S PSORXED("FLD",22)=Y ;S DR="22R///"_Y,DIE=52 D ^DIE
K X,Y
KV K DIR,DUOUT,DTOUT,DIRUT
Q
CHK I $D(^PSRX("AR",+$P(PSORXED("RX2"),"^",13),PSORXED("IRXN"))) S CMRL=1 Q
F RF=0:0 S RF=$O(^PSRX(PSORXED("IRXN"),1,RF)) Q:'RF I $D(^PSRX("AR",+$P(^PSRX(PSORXED("IRXN"),1,RF,0),"^",18),PSORXED("IRXN"))) S CMRL=1
Q
CHK1 I +^PSRX(PSORXED("IRXN"),"STA")=5 D Q:'$G(CMRL)
.S SURX=$O(^PS(52.5,PSORXED("IRXN"),0)) Q:'SURX I $P(^PS(52.5,SURX,0),"^",7)']""!($P(^(0),"^",7)="Q") S CMRL=1
.E S CMRL=0
F FEV=0:0 S FEV=$O(^PSRX(PSORXED("IRXN"),4,FEV)) Q:'FEV I '$P(^PSRX(PSORXED("IRXN"),4,FEV,0),"^",3),$P(^(0),"^",4)<3 S CMRL=0
Q
REF ;shows refill info
S RFN=0 F N=0:0 S N=$O(^PSRX(PSORXED("IRXN"),1,N)) Q:'N S RFM=N,RFN=RFN+1
;G:RFM=1 SRF
W ! K DA,DR D KV S DIR(0)="Y",DIR("B")="No",DIR("A")="There "_$S(RFN>1:"are ",1:"is ")_RFN_" refill"_$S(RFN>1:"s.",1:".")_" Do you want to edit"
D ^DIR D KV Q:'Y
SRF W !!,"# Log Date Refill Date Qty Routing Lot # Pharmacist",! F I=1:1:80 W "="
F N=0:0 S N=$O(^PSRX(PSORXED("IRXN"),1,N)) Q:'N S P1=^(N,0) D
.S DTT=$P(P1,"^",8)\1 D DAT S LOG=DAT,DTT=$P(P1,"^"),$P(RN," ",10)=" " D DAT
.W !,N_" "_LOG_" "_DAT_" "_$P(P1,"^",4)_$E(" ",$L($P(P1,"^",4))+1,15)_" "_$S($P(P1,"^",2)="M":"MAIL ",1:"WINDOW")_" "_$P(P1,"^",6)_$E(RN,$L($P(P1,"^",6))+1,12)
.W $E($S($D(^VA(200,+$P(P1,"^",5),0)):$P(^(0),"^"),1:""),1,16)
.S PSDIV=$S($D(^PS(59,+$P(P1,"^",9),0)):$P(^(0),"^",6),1:"Unknown") W !,"Division: "_PSDIV_$E(" ",$L(PSDIV)+1,8)_" "
.W "Dispensed: "_$S($P(P1,"^",19):$E($P(P1,"^",19),4,5)_"/"_$E($P(P1,"^",19),6,7)_"/"_$E($P(P1,"^",19),2,3),1:"")_" "
.S RTS=$S($P(P1,"^",16):" Returned to Stock: "_$E($P(P1,"^",16),4,5)_"/"_$E($P(P1,"^",16),6,7)_"/"_$E($P(P1,"^",16),2,3),1:" Released: "_$S($P(P1,"^",18):$E($P(P1,"^",18),4,5)_"/"_$E($P(P1,"^",18),6,7)_"/"_$E($P(P1,"^",18),2,3),1:""))
.W RTS W:$P(P1,"^",3)]"" !," Remarks: "_$P(P1,"^",3)
S DA(1)=PSORXED("IRXN") I RFN=1 S Y=RFM G RFM
W ! D KV S DIR("A")="Select a Refill",DIR(0)="NO^1:"_RFM_":0" D ^DIR Q:$D(DIRUT)
RFM I '$D(^PSRX(PSORXED("IRXN"),1,Y,0)) W !,$C(7),"Invalid selection.",! G SRF
S CMRL=0 I $D(^PSRX("AR",+$P(^PSRX(PSORXED("IRXN"),1,Y,0),"^",18),PSORXED("IRXN"),Y)) S CMRL=1 G RFX
F FEV=0:0 S FEV=$O(^PSRX(PSORXED("IRXN"),4,FEV)) Q:'FEV I $P(^PSRX(PSORXED("IRXN"),4,FEV,0),"^",3)=Y,$P(^(0),"^",4)<3 S CMRL=1
RFX N RFL,NDC,DAW,FLDS,QUIT,CHGNDC,CHANGED
W ! S DA=Y,DIE="^PSRX("_DA(1)_",1,",DR=$S('CMRL:".01;1.1",1:"1.2:5;8")
D GETS^DIQ(52.1,DA_","_DA(1)_",",".01;1;1.1;8;11;81","I","FLDS")
S:$D(^PSRX(DA(1),1,DA,0)) PSORXED("RX1")=^PSRX(DA(1),1,DA,0),(RFED,RFL)=DA
I $G(ST)=11!($G(ST)=12)!($G(ST)=14)!($G(ST)=15),$$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'="" S QUIT=0 D RFE Q ;short circuit for DC'd/Expired ECME RXs
D ^DIE S QUIT=$D(Y) K FEV,RFN,RFM,X,Y,DR
I '$G(DA) D REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DE",5) K CMRL,RFED D:$D(PSORX("PSOL"))&($G(DI)=.01) RFD Q
; IHS/CIA/PLS - 01/26/04 - Re-worked code for IHS Fields
;I 'CMRL,'QUIT S DR="1;1.2:5;8" D ^DIE S QUIT=$D(Y)
I 'CMRL,'QUIT S DR="1;1.2:5;8;11;12;13;9999999.06" D ^DIE S QUIT=$D(Y)
RFE I '$D(^PSRX(PSORXED("IRXN"),1,RFL)) Q
I 'QUIT,$$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'="" D
. S NDC=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)
. D EDTDAW^PSODAWUT(PSORXED("IRXN"),RFL,.DAW) I $G(DAW)="^" Q
. D SAVDAW^PSODAWUT(PSORXED("IRXN"),RFL,+$G(DAW))
. D NDC^PSODRG(PSORXED("IRXN"),RFL,,.NDC) I $G(NDC)="^",$G(NDC)="" Q
. I NDC'=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL) D
. . S CHGNDC=1 D RXACT^PSOBPSU2(PSORXED("IRXN"),RFL,"NDC changed from "_$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)_" to "_NDC_".","E")
. D SAVNDC^PSONDCUT(PSORXED("IRXN"),RFL,NDC)
;IHS/MSC/PLS - 05/27/2010
S CHANGED=0 ;$$CHANGED(PSORXED("IRXN"),RFL,.FLDS)
I CHANGED D
. I $P(CHANGED,"^",2),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(PSORXED("IRXN"),RFL)) D Q
. . D REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DC",99,"REFILL DIVISION CHANGED",1)
. I $$SUBMIT^PSOBPSUT(PSORXED("IRXN"),RFL,1,1) D
. . N RX S RX=PSORXED("IRXN")
. . I '$P(CHANGED,"^",2),$$STATUS^PSOBPSUT(RX,RFL)="" Q
. . D ECMESND^PSOBPSU1(RX,RFL,,"ED",$$GETNDC^PSONDCUT(RX,RFL),,$S($P(CHANGED,"^",2):"REFILL DIVISION CHANGED",1:"REFILL EDITED"),,+$G(CHGNDC))
. . ;- Checking/Handling DUR/79 Rejects
. . I $$FIND^PSOREJUT(RX,RFL) S X=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q")
K DIE,CMRL,DA,DR
Q
CHANGED(RX,RFL,PRIOR) ; - Check if fields have changed and should for 3rd Party Claim resubmission
;Input: (r) RX - Rx IEN
; (r) RFL - Refill #
; (r) PRIOR - Array with fields
;Output: CHANGED - 0 - Not changed / 1 - Refill field changed ^ Rx Division changed (1 - YES)
N CHANGED,SAVED
S CHANGED=0 D GETS^DIQ(52.1,RFL_","_RX_",",".01;1;1.1;8;11;81","I","SAVED")
F I=.01,1,1.1,11,81 I $G(PRIOR(52.1,RFL_","_RX_",",I,"I"))'=$G(SAVED(52.1,RFL_","_RX_",",I,"I")) S CHANGED=1 Q
I $$DIVNCPDP^BPSBUTL(+$G(PRIOR(52.1,RFL_","_RX_",",8,"I")))'=$$DIVNCPDP^BPSBUTL(+$G(SAVED(52.1,RFL_","_RX_",",8,"I"))) S CHANGED="1^1"
Q CHANGED
;
DAT S DAT="",DTT=DTT\1 Q:DTT'?7N S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3)
Q
DIE S DIE=52 D ^DIE I $D(Y) S PSORXED("DFLG")=1
K DIE,DR,X,Y
Q
RFD ;check for deleted refill
M PSOZ1("PSOL")=PSORX("PSOL") N I,J,K,PSOX2,PSOX3,PSOX9 S (I,K)=0 D
.F S I=$O(PSOZ1("PSOL",I)) Q:'I!(K) S PSOX2=PSOZ1("PSOL",I) I PSOX2[(PSORXED("IRXN")_",") S PSOX9="" D
..F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3 D
...I 'K,PSOX3=PSORXED("IRXN") S K=1
...E S PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3
..I K S:PSOX9]"" PSORX("PSOL",I)=PSOX9_"," K:PSOX9="" PSORX("PSOL",I)
K PSOZ1("PSOL")
Q
EDTDOSE ;edit med instructions fields
I '$O(^PSRX(PSORXED("IRXN"),6,0)) D DOSE^PSOORED5 Q
D ^PSOORED3
Q
UPD ;updates dosing array
S HENT=ENT
UPD1 I $G(PSORXED("CONJUNCTION",(HENT+1)))]"",'$D(PSORXED("DOSE",(HENT+2))) K PSORXED("CONJUNCTION",(HENT+1)) Q
I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" S PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1)) D G UPD1
.K PSORXED("CONJUNCTION",(HENT+1))
.F Q:'$D(PSORXED("DOSE",(HENT+2))) D
..S PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(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("ODOSE",(HENT+1))=$G(PSORXED("ODOSE",(HENT+2)))
..S HENT=HENT+1
..I $G(PSORXED("CONJUNCTION",(HENT+2)))]"" Q
..K PSORXED("UNITS",(HENT+1)),PSORXED("NOUN",(HENT+1)),PSORXED("DURATION",(HENT+1)),PSORXED("CONJUNCTION",(HENT+1)),PSORXED("ROUTE",(HENT+1)),PSORXED("SCHEDULE",(HENT+1)),PSORXED("DOSE",(HENT+1)),PSORXED("DOSE ORDERED",(HENT+1))
..K PSORXED("VERB",(HENT+1)),PSORXED("ODOSE",(HENT+1))
S PSORXED("ENT")=HENT K HENT,SENT D EN^PSOFSIG(.PSORXED)
Q
UPD2 I $G(PSORXED("CONJUNCTION",(HENT+1)))]"",'$D(PSORXED("DOSE",(HENT+2))) K PSORXED("CONJUNCTION",(HENT+1)) Q
I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" S PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1)) D G UPD1
.K PSORXED("CONJUNCTION",(HENT+1)) I $D(PSORXED("DOSE",(HENT+2))) D
..S PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(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("VERB",(HENT+1))=$G(PSORXED("VERB",(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("ODOSE",(HENT+1))=$G(PSORXED("ODOSE",(HENT+2)))
..S HENT=HENT+1
..I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" Q
..K PSORXED("UNITS",(HENT+1)),PSORXED("NOUN",(HENT+1)),PSORXED("DURATION",(HENT+1)),PSORXED("ROUTE",(HENT+1)),PSORXED("SCHEDULE",(HENT+1)),PSORXED("DOSE",(HENT+1)),PSORXED("DOSE ORDERED",(HENT+1)),PSORXED("VERB",(HENT+1))
..K PSORXED("ODOSE",(HENT+1))
F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I S SENT=$G(SENT)+1
S PSORXED("ENT")=SENT K HENT,SENT D EN^PSOFSIG(.PSORXED)
Q
PSOORED2 ;ISC-BHAM/SAB-edit orders from backdoor con't ;29-May-2012 14:56;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**2,51,46,78,102,114,117,133,1005,159,148,247,260,281,289,1015**;DEC 1997;Build 62
+2 ;Reference to $$DIVNCPDP^BPSBUTL supported by IA 4719
+3 ;Reference to $$ECMEON^BPSUTIL supported by IA 4410
+4 ;called from psooredt. cmop edit checks.
+5 ; Modified - IHS/CIA/PLS - 01/26/04 - Line RFX+3
+6 ; 05/27/10 - Line RFE+9
+7 QUIT
ISDT DO CHK
KILL RF
IF $GET(CMRL)
WRITE !,"Released by CMOP. No editing allowed on Issue Date."
DO PAUSE^VALM1
KILL CMRL
QUIT
+1 SET %DT="AEX"
SET %DT(0)=-$PIECE(^PSRX(DA,2),"^",2)
SET Y=$PIECE(RX0,"^",13)
XECUTE ^DD("DD")
SET %DT("A")="ISSUE DATE: "
SET %DT("B")=Y
DO ^%DT
IF "^"[$EXTRACT(X)
KILL X,Y,%DT,DTOUT,DUOUT
QUIT
+2 IF Y=-1
GOTO ISDT
SET PSORXED("FLD",1)=Y
+3 ;S DR="1///"_Y,DIE=52 D ^DIE
+4 DO KV
KILL X,Y,%DT
+5 QUIT
FLDT DO CHK
KILL RF
IF $GET(CMRL)
WRITE !,"Released by CMOP. No editing allowed on Fill Date."
DO PAUSE^VALM1
KILL CMRL
QUIT
+1 DO KV
SET Y=$PIECE(^PSRX(DA,2),"^",2)
XECUTE ^DD("DD")
SET DIR("A")="FILL DATE"
SET DIR("B")=Y
+2 SET DIR(0)="D^"_$PIECE(RX0,"^",13)_":"_$PIECE(PSORXED("RX2"),"^",6)_":EX"
+3 SET DIR("?",1)="The earliest fill date allowed is determined by the Issue Date,"
SET DIR("?",2)="the Fill Date cannot be before the Issue Date or past the Expiration Date."
+4 SET DIR("?")="Both the month and day are required."
DO ^DIR
+5 IF $DATA(DIRUT)
DO KV
KILL PSORXED("FLD",22),X,Y
QUIT
+6 ;S DR="22R///"_Y,DIE=52 D ^DIE
SET PSORXED("FLD",22)=Y
+7 KILL X,Y
KV KILL DIR,DUOUT,DTOUT,DIRUT
+1 QUIT
CHK IF $DATA(^PSRX("AR",+$PIECE(PSORXED("RX2"),"^",13),PSORXED("IRXN")))
SET CMRL=1
QUIT
+1 FOR RF=0:0
SET RF=$ORDER(^PSRX(PSORXED("IRXN"),1,RF))
IF 'RF
QUIT
IF $DATA(^PSRX("AR",+$PIECE(^PSRX(PSORXED("IRXN"),1,RF,0),"^",18),PSORXED("IRXN")))
SET CMRL=1
+2 QUIT
CHK1 IF +^PSRX(PSORXED("IRXN"),"STA")=5
Begin DoDot:1
+1 SET SURX=$ORDER(^PS(52.5,PSORXED("IRXN"),0))
IF 'SURX
QUIT
IF $PIECE(^PS(52.5,SURX,0),"^",7)']""!($PIECE(^(0),"^",7)="Q")
SET CMRL=1
+2 IF '$TEST
SET CMRL=0
End DoDot:1
IF '$GET(CMRL)
QUIT
+3 FOR FEV=0:0
SET FEV=$ORDER(^PSRX(PSORXED("IRXN"),4,FEV))
IF 'FEV
QUIT
IF '$PIECE(^PSRX(PSORXED("IRXN"),4,FEV,0),"^",3)
IF $PIECE(^(0),"^",4)<3
SET CMRL=0
+4 QUIT
REF ;shows refill info
+1 SET RFN=0
FOR N=0:0
SET N=$ORDER(^PSRX(PSORXED("IRXN"),1,N))
IF 'N
QUIT
SET RFM=N
SET RFN=RFN+1
+2 ;G:RFM=1 SRF
+3 WRITE !
KILL DA,DR
DO KV
SET DIR(0)="Y"
SET DIR("B")="No"
SET DIR("A")="There "_$SELECT(RFN>1:"are ",1:"is ")_RFN_" refill"_$SELECT(RFN>1:"s.",1:".")_" Do you want to edit"
+4 DO ^DIR
DO KV
IF 'Y
QUIT
SRF WRITE !!,"# Log Date Refill Date Qty Routing Lot # Pharmacist",!
FOR I=1:1:80
WRITE "="
+1 FOR N=0:0
SET N=$ORDER(^PSRX(PSORXED("IRXN"),1,N))
IF 'N
QUIT
SET P1=^(N,0)
Begin DoDot:1
+2 SET DTT=$PIECE(P1,"^",8)\1
DO DAT
SET LOG=DAT
SET DTT=$PIECE(P1,"^")
SET $PIECE(RN," ",10)=" "
DO DAT
+3 WRITE !,N_" "_LOG_" "_DAT_" "_$PIECE(P1,"^",4)_$EXTRACT(" ",$LENGTH($PIECE(P1,"^",4))+1,15)_" "_$SELECT($PIECE(P1,"^",2)="M":"MAIL ",1:"WINDOW")_" "_$PIECE(P1,"^",6)_$EXTRACT(RN,$LENGTH($PIECE(P1,"^",6))+1,12)
+4 WRITE $EXTRACT($SELECT($DATA(^VA(200,+$PIECE(P1,"^",5),0)):$PIECE(^(0),"^"),1:""),1,16)
+5 SET PSDIV=$SELECT($DATA(^PS(59,+$PIECE(P1,"^",9),0)):$PIECE(^(0),"^",6),1:"Unknown")
WRITE !,"Division: "_PSDIV_$EXTRACT(" ",$LENGTH(PSDIV)+1,8)_" "
+6 WRITE "Dispensed: "_$SELECT($PIECE(P1,"^",19):$EXTRACT($PIECE(P1,"^",19),4,5)_"/"_$EXTRACT($PIECE(P1,"^",19),6,7)_"/"_$EXTRACT($PIECE(P1,"^",19),2,3),1:"")_" "
+7 SET RTS=$SELECT($PIECE(P1,"^",16):" Returned to Stock: "_$EXTRACT(...
... $PIECE(P1,"^",16),4,5)_"/"_$EXTRACT($PIECE(P1,"^",16),6,7)_"/"_$EXTRACT($PIECE(P1,"^",16),2,3),1:" Released: "_$SELECT($PIECE(P1,"^",18):$EXTRACT($PIECE(P1,"^",18),4,5)_"/"_$EXTRACT($PIECE(P1,"^",18),6,7)_"/"_$EXTRACT($PIECE(P1,"^",
18),2,3),1:""))
+8 WRITE RTS
IF $PIECE(P1,"^",3)]""
WRITE !," Remarks: "_$PIECE(P1,"^",3)
End DoDot:1
+9 SET DA(1)=PSORXED("IRXN")
IF RFN=1
SET Y=RFM
GOTO RFM
+10 WRITE !
DO KV
SET DIR("A")="Select a Refill"
SET DIR(0)="NO^1:"_RFM_":0"
DO ^DIR
IF $DATA(DIRUT)
QUIT
RFM IF '$DATA(^PSRX(PSORXED("IRXN"),1,Y,0))
WRITE !,$CHAR(7),"Invalid selection.",!
GOTO SRF
+1 SET CMRL=0
IF $DATA(^PSRX("AR",+$PIECE(^PSRX(PSORXED("IRXN"),1,Y,0),"^",18),PSORXED("IRXN"),Y))
SET CMRL=1
GOTO RFX
+2 FOR FEV=0:0
SET FEV=$ORDER(^PSRX(PSORXED("IRXN"),4,FEV))
IF 'FEV
QUIT
IF $PIECE(^PSRX(PSORXED("IRXN"),4,FEV,0),"^",3)=Y
IF $PIECE(^(0),"^",4)<3
SET CMRL=1
RFX NEW RFL,NDC,DAW,FLDS,QUIT,CHGNDC,CHANGED
+1 WRITE !
SET DA=Y
SET DIE="^PSRX("_DA(1)_",1,"
SET DR=$SELECT('CMRL:".01;1.1",1:"1.2:5;8")
+2 DO GETS^DIQ(52.1,DA_","_DA(1)_",",".01;1;1.1;8;11;81","I","FLDS")
+3 IF $DATA(^PSRX(DA(1),1,DA,0))
SET PSORXED("RX1")=^PSRX(DA(1),1,DA,0)
SET (RFED,RFL)=DA
+4 ;short circuit for DC'd/Expired ECME RXs
IF $GET(ST)=11!($GET(ST)=12)!($GET(ST)=14)!($GET(ST)=15)
IF $$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'=""
SET QUIT=0
DO RFE
QUIT
+5 DO ^DIE
SET QUIT=$DATA(Y)
KILL FEV,RFN,RFM,X,Y,DR
+6 IF '$GET(DA)
DO REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DE",5)
KILL CMRL,RFED
IF $DATA(PSORX("PSOL"))&($GET(DI)=.01)
DO RFD
QUIT
+7 ; IHS/CIA/PLS - 01/26/04 - Re-worked code for IHS Fields
+8 ;I 'CMRL,'QUIT S DR="1;1.2:5;8" D ^DIE S QUIT=$D(Y)
+9 IF 'CMRL
IF 'QUIT
SET DR="1;1.2:5;8;11;12;13;9999999.06"
DO ^DIE
SET QUIT=$DATA(Y)
RFE IF '$DATA(^PSRX(PSORXED("IRXN"),1,RFL))
QUIT
+1 IF 'QUIT
IF $$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'=""
Begin DoDot:1
+2 SET NDC=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)
+3 DO EDTDAW^PSODAWUT(PSORXED("IRXN"),RFL,.DAW)
IF $GET(DAW)="^"
QUIT
+4 DO SAVDAW^PSODAWUT(PSORXED("IRXN"),RFL,+$GET(DAW))
+5 DO NDC^PSODRG(PSORXED("IRXN"),RFL,,.NDC)
IF $GET(NDC)="^"
IF $GET(NDC)=""
QUIT
+6 IF NDC'=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)
Begin DoDot:2
+7 SET CHGNDC=1
DO RXACT^PSOBPSU2(PSORXED("IRXN"),RFL,"NDC changed from "_$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)_" to "_NDC_".","E")
End DoDot:2
+8 DO SAVNDC^PSONDCUT(PSORXED("IRXN"),RFL,NDC)
End DoDot:1
+9 ;IHS/MSC/PLS - 05/27/2010
+10 ;$$CHANGED(PSORXED("IRXN"),RFL,.FLDS)
SET CHANGED=0
+11 IF CHANGED
Begin DoDot:1
+12 IF $PIECE(CHANGED,"^",2)
IF '$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(PSORXED("IRXN"),RFL))
Begin DoDot:2
+13 DO REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DC",99,"REFILL DIVISION CHANGED",1)
End DoDot:2
QUIT
+14 IF $$SUBMIT^PSOBPSUT(PSORXED("IRXN"),RFL,1,1)
Begin DoDot:2
+15 NEW RX
SET RX=PSORXED("IRXN")
+16 IF '$PIECE(CHANGED,"^",2)
IF $$STATUS^PSOBPSUT(RX,RFL)=""
QUIT
+17 DO ECMESND^PSOBPSU1(RX,RFL,,"ED",$$GETNDC^PSONDCUT(RX,RFL),,$SELECT($PIECE(CHANGED,"^",2):"REFILL DIVISION CHANGED",1:"REFILL EDITED"),,+$GET(CHGNDC))
+18 ;- Checking/Handling DUR/79 Rejects
+19 IF $$FIND^PSOREJUT(RX,RFL)
SET X=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q")
End DoDot:2
End DoDot:1
+20 KILL DIE,CMRL,DA,DR
+21 QUIT
CHANGED(RX,RFL,PRIOR) ; - Check if fields have changed and should for 3rd Party Claim resubmission
+1 ;Input: (r) RX - Rx IEN
+2 ; (r) RFL - Refill #
+3 ; (r) PRIOR - Array with fields
+4 ;Output: CHANGED - 0 - Not changed / 1 - Refill field changed ^ Rx Division changed (1 - YES)
+5 NEW CHANGED,SAVED
+6 SET CHANGED=0
DO GETS^DIQ(52.1,RFL_","_RX_",",".01;1;1.1;8;11;81","I","SAVED")
+7 FOR I=.01,1,1.1,11,81
IF $GET(PRIOR(52.1,RFL_","_RX_",",I,"I"))'=$GET(SAVED(52.1,RFL_","_RX_",",I,"I"))
SET CHANGED=1
QUIT
+8 IF $$DIVNCPDP^BPSBUTL(+$GET(PRIOR(52.1,RFL_","_RX_",",8,"I")))'=$$DIVNCPDP^BPSBUTL(+$GET(SAVED(52.1,RFL_","_RX_",",8,"I")))
SET CHANGED="1^1"
+9 QUIT CHANGED
+10 ;
DAT SET DAT=""
SET DTT=DTT\1
IF DTT'?7N
QUIT
SET DAT=$EXTRACT(DTT,4,5)_"/"_$EXTRACT(DTT,6,7)_"/"_$EXTRACT(DTT,2,3)
+1 QUIT
DIE SET DIE=52
DO ^DIE
IF $DATA(Y)
SET PSORXED("DFLG")=1
+1 KILL DIE,DR,X,Y
+2 QUIT
RFD ;check for deleted refill
+1 MERGE PSOZ1("PSOL")=PSORX("PSOL")
NEW I,J,K,PSOX2,PSOX3,PSOX9
SET (I,K)=0
Begin DoDot:1
+2 FOR
SET I=$ORDER(PSOZ1("PSOL",I))
IF 'I!(K)
QUIT
SET PSOX2=PSOZ1("PSOL",I)
IF PSOX2[(PSORXED("IRXN")_",")
SET PSOX9=""
Begin DoDot:2
+3 FOR J=1:1
SET PSOX3=$PIECE(PSOX2,",",J)
IF 'PSOX3
QUIT
Begin DoDot:3
+4 IF 'K
IF PSOX3=PSORXED("IRXN")
SET K=1
+5 IF '$TEST
SET PSOX9=PSOX9_$SELECT('PSOX9:"",1:",")_PSOX3
End DoDot:3
+6 IF K
IF PSOX9]""
SET PSORX("PSOL",I)=PSOX9_","
IF PSOX9=""
KILL PSORX("PSOL",I)
End DoDot:2
End DoDot:1
+7 KILL PSOZ1("PSOL")
+8 QUIT
EDTDOSE ;edit med instructions fields
+1 IF '$ORDER(^PSRX(PSORXED("IRXN"),6,0))
DO DOSE^PSOORED5
QUIT
+2 DO ^PSOORED3
+3 QUIT
UPD ;updates dosing array
+1 SET HENT=ENT
UPD1 IF $GET(PSORXED("CONJUNCTION",(HENT+1)))]""
IF '$DATA(PSORXED("DOSE",(HENT+2)))
KILL PSORXED("CONJUNCTION",(HENT+1))
QUIT
+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 FOR
IF '$DATA(PSORXED("DOSE",(HENT+2)))
QUIT
Begin DoDot:2
+4 SET PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2))
+5 SET PSORXED("DOSE ORDERED",(HENT+1))=$GET(PSORXED("DOSE ORDERED",(HENT+2)))
+6 SET PSORXED("UNITS",(HENT+1))=$GET(PSORXED("UNITS",(HENT+2)))
+7 SET PSORXED("NOUN",(HENT+1))=$GET(PSORXED("NOUN",(HENT+2)))
+8 SET PSORXED("DURATION",(HENT+1))=$GET(PSORXED("DURATION",(HENT+2)))
+9 SET PSORXED("CONJUNCTION",(HENT+1))=$GET(PSORXED("CONJUNCTION",(HENT+2)))
+10 SET PSORXED("ROUTE",(HENT+1))=$GET(PSORXED("ROUTE",(HENT+2)))
+11 SET PSORXED("SCHEDULE",(HENT+1))=$GET(PSORXED("SCHEDULE",(HENT+2)))
+12 SET PSORXED("ODOSE",(HENT+1))=$GET(PSORXED("ODOSE",(HENT+2)))
+13 SET HENT=HENT+1
+14 IF $GET(PSORXED("CONJUNCTION",(HENT+2)))]""
QUIT
+15 KILL PSORXED("UNITS",(HENT+1)),PSORXED("NOUN",(HENT+1)),PSORXED("DURATION",(HENT+1)),PSORXED("CONJUNCTION",(HENT+1)),PSORXED("ROUTE",(HENT+1)),PSORXED("SCHEDULE",(HENT+1)),PSORXED("DOSE",(HENT+1)),PSORXED("DOSE ORDERED",(HENT+1)
)
+16 KILL PSORXED("VERB",(HENT+1)),PSORXED("ODOSE",(HENT+1))
End DoDot:2
End DoDot:1
GOTO UPD1
+17 SET PSORXED("ENT")=HENT
KILL HENT,SENT
DO EN^PSOFSIG(.PSORXED)
+18 QUIT
UPD2 IF $GET(PSORXED("CONJUNCTION",(HENT+1)))]""
IF '$DATA(PSORXED("DOSE",(HENT+2)))
KILL PSORXED("CONJUNCTION",(HENT+1))
QUIT
+1 IF $GET(PSORXED("CONJUNCTION",(HENT+1)))]""
SET PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1))
Begin DoDot:1
+2 KILL PSORXED("CONJUNCTION",(HENT+1))
IF $DATA(PSORXED("DOSE",(HENT+2)))
Begin DoDot:2
+3 SET PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2))
+4 SET PSORXED("DOSE ORDERED",(HENT+1))=$GET(PSORXED("DOSE ORDERED",(HENT+2)))
+5 SET PSORXED("UNITS",(HENT+1))=$GET(PSORXED("UNITS",(HENT+2)))
+6 SET PSORXED("NOUN",(HENT+1))=$GET(PSORXED("NOUN",(HENT+2)))
+7 SET PSORXED("VERB",(HENT+1))=$GET(PSORXED("VERB",(HENT+2)))
+8 SET PSORXED("DURATION",(HENT+1))=$GET(PSORXED("DURATION",(HENT+2)))
+9 SET PSORXED("CONJUNCTION",(HENT+1))=$GET(PSORXED("CONJUNCTION",(HENT+2)))
+10 SET PSORXED("ROUTE",(HENT+1))=$GET(PSORXED("ROUTE",(HENT+2)))
+11 SET PSORXED("SCHEDULE",(HENT+1))=$GET(PSORXED("SCHEDULE",(HENT+2)))
+12 SET PSORXED("ODOSE",(HENT+1))=$GET(PSORXED("ODOSE",(HENT+2)))
+13 SET HENT=HENT+1
+14 IF $GET(PSORXED("CONJUNCTION",(HENT+1)))]""
QUIT
+15 KILL PSORXED("UNITS",(HENT+1)),PSORXED("NOUN",(HENT+1)),PSORXED("DURATION",(HENT+1)),PSORXED("ROUTE",(HENT+1)),PSORXED("SCHEDULE",(HENT+1)),PSORXED("DOSE",(HENT+1)),PSORXED("DOSE ORDERED",(HENT+1)),PSORXED("VERB",(HENT+1))
+16 KILL PSORXED("ODOSE",(HENT+1))
End DoDot:2
End DoDot:1
GOTO UPD1
+17 FOR I=0:0
SET I=$ORDER(PSORXED("DOSE",I))
IF 'I
QUIT
SET SENT=$GET(SENT)+1
+18 SET PSORXED("ENT")=SENT
KILL HENT,SENT
DO EN^PSOFSIG(.PSORXED)
+19 QUIT
