PSOORED2 ;ISC-BHAM/SAB - edit orders from backdoor con't ;Jan 20, 2022@11:19:32
;;7.0;OUTPATIENT PHARMACY;**2,51,46,78,102,114,117,133,159,148,247,260,281,289,276,358,251,385,427,538,574,562,441**;DEC 1997;Build 208
;Reference to $$DIVNCPDP^BPSBUTL supported by IA 4719
;Reference to $$ECMEON^BPSUTIL supported by IA 4410
;called from psooredt. cmop edit checks.
; PSO*7*538/INC1491667 Modification to review Issue Date During Rx Edit
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
; PSO*7*538 Modified Next Line (Added Call to PSOUTL)
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 D CID^PSOUTL I "^"[$E(X) K X,Y,%DT,DTOUT,DUOUT Q
; PSO*7*538 Added Next Line
I Y=-1 W ! D CIDH^PSOUTL W ! G ISDT
G:Y=-1 ISDT S PSORXED("FLD",1)=Y
; Added Clozapine check to modify Expires date ; PSO*574
I $$ISCLOZ^PSJCLOZ(,,,,$G(PSODRUG("IEN"))) D EXPDT^PSOCLO1(.PSORXED,.CLOZPAT)
;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 ",$P(P1,"^",2)="P":"PARK ",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
N PSORFILL S PSORFILL=DA ;*276
D ^DIE S QUIT=$D(Y)
;*276
I '$D(^PSRX(PSORXED("IRXN"),1,PSORFILL)),'$G(PSOSFN) D
.N DA,NOW,IR,FDA
.S DA=$G(PSORXED("IRXN")) Q:'DA
.S (FDA,IR)=0 F 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 NOW=%
.S ^PSRX(DA,"A",IR,0)=NOW_"^D^"_DUZ_"^"_$S(PSORFILL>0&(PSORFILL<6):PSORFILL,1:PSORFILL+1)_"^Refill deleted during Rx edit"
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
S PREVMWP=$P($G(^PSRX(PSORXED("IRXN"),1,PSORFILL,0)),"^",2) ;PAPI 441 BEG
I 'CMRL,'QUIT S DR="1;1.2:5;8" D ^DIE S QUIT=$D(Y) ;THIS LINE NOT PAPI CODE
S PRKMW=$P($G(^PSRX(PSORXED("IRXN"),1,PSORFILL,0)),"^",2)
I PRKMW="P",PREVMWP'="P" S PSOTOPK=1 ; SET VARIABLE FOR CALLING ROUTINE TO FILE PARK LEVEL,"APARK" XREF, AND REMOVE FROM SUSPENSE AND UPDT ACT. LOG RELATED TO PARKING
I PREVMWP="P",PRKMW'="P" S PSOFRPK=1 ; CHANGED "FROM" PARK
I $G(PSOFRPK)!$G(PSOTOPK) K SAVDA M SAVDA=DA S SAVDIE=DIE,SAVFLD=$G(FLD)
I $G(PSOFRPK) K DA S (DA,PSDA)=PSORXED("IRXN") D UNPARK^PSOPRK K DA M DA=SAVDA K Y S DIE=SAVDIE,FLD=SAVFLD
I $G(PSOTOPK) K DA S DA=PSORXED("IRXN") D PRK^PSOPRK(DA) K DA M DA=SAVDA K Y S DIE=SAVDIE,FLD=SAVFLD ;PAPI 441 END
RFE I '$D(^PSRX(PSORXED("IRXN"),1,RFL)) Q
;
I 'QUIT,$$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'="" D
. D EDTDAW^PSODAWUT(PSORXED("IRXN"),RFL,.DAW) I $G(DAW)="^" Q
. D SAVDAW^PSODAWUT(PSORXED("IRXN"),RFL,+$G(DAW))
. Q
;
; PSO*7*427 - NDC edit checks are in NDC^PSODRG
I 'QUIT D
. S NDC=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)
. 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)
. Q
;
S CHANGED=$$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))
. . ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358
. . I $$PSOET^PSOREJP3(RX,RFL) S X="Q" Q
. . ;- Checking/Handling DUR/79 Rejects
. . I $$FIND^PSOREJUT(RX,RFL) S X=$$HDLG^PSOREJU1(RX,RFL,"79,88,943","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
S PSOEDDOS=1 ; identifies origin of call to PSOORED3 for dosing
I '$O(^PSRX(PSORXED("IRXN"),6,0)) D DOSE^PSOORED5 Q
D ^PSOORED3
K PSOEDDOS
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOORED2 11411 printed Apr 09, 2024@21:38:44 Page 2
PSOORED2 ;ISC-BHAM/SAB - edit orders from backdoor con't ;Jan 20, 2022@11:19:32
+1 ;;7.0;OUTPATIENT PHARMACY;**2,51,46,78,102,114,117,133,159,148,247,260,281,289,276,358,251,385,427,538,574,562,441**;DEC 1997;Build 208
+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 ; PSO*7*538/INC1491667 Modification to review Issue Date During Rx Edit
+6 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 ; PSO*7*538 Modified Next Line (Added Call to PSOUTL)
+2 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
DO CID^PSOUTL
IF "^"[$EXTRACT(X)
KILL X,Y,%DT,DTOUT,DUOUT
QUIT
+3 ; PSO*7*538 Added Next Line
+4 IF Y=-1
WRITE !
DO CIDH^PSOUTL
WRITE !
GOTO ISDT
+5 if Y=-1
GOTO ISDT
SET PSORXED("FLD",1)=Y
+6 ; Added Clozapine check to modify Expires date ; PSO*574
+7 IF $$ISCLOZ^PSJCLOZ(,,,,$GET(PSODRUG("IEN")))
DO EXPDT^PSOCLO1(.PSORXED,.CLOZPAT)
+8 ;S DR="1///"_Y,DIE=52 D ^DIE
+9 DO KV
KILL X,Y,%DT
+10 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 ",$PIECE(P1,"^",2)="P":"PARK ",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 ;*276
NEW PSORFILL
SET PSORFILL=DA
+6 DO ^DIE
SET QUIT=$DATA(Y)
+7 ;*276
+8 IF '$DATA(^PSRX(PSORXED("IRXN"),1,PSORFILL))
IF '$GET(PSOSFN)
Begin DoDot:1
+9 NEW DA,NOW,IR,FDA
+10 SET DA=$GET(PSORXED("IRXN"))
if 'DA
QUIT
+11 SET (FDA,IR)=0
FOR
SET FDA=$ORDER(^PSRX(DA,"A",FDA))
if 'FDA
QUIT
SET IR=FDA
+12 SET IR=IR+1
SET ^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
+13 DO NOW^%DTC
SET NOW=%
+14 SET ^PSRX(DA,"A",IR,0)=NOW_"^D^"_DUZ_"^"_$SELECT(PSORFILL>0&(PSORFILL<6):PSORFILL,1:PSORFILL+1)_"^Refill deleted during Rx edit"
End DoDot:1
+15 KILL FEV,RFN,RFM,X,Y,DR
+16 IF '$GET(DA)
DO REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DE",5)
KILL CMRL,RFED
if $DATA(PSORX("PSOL"))&($GET(DI)=.01)
DO RFD
QUIT
+17 ;PAPI 441 BEG
SET PREVMWP=$PIECE($GET(^PSRX(PSORXED("IRXN"),1,PSORFILL,0)),"^",2)
+18 ;THIS LINE NOT PAPI CODE
IF 'CMRL
IF 'QUIT
SET DR="1;1.2:5;8"
DO ^DIE
SET QUIT=$DATA(Y)
+19 SET PRKMW=$PIECE($GET(^PSRX(PSORXED("IRXN"),1,PSORFILL,0)),"^",2)
+20 ; SET VARIABLE FOR CALLING ROUTINE TO FILE PARK LEVEL,"APARK" XREF, AND REMOVE FROM SUSPENSE AND UPDT ACT. LOG RELATED TO PARKING
IF PRKMW="P"
IF PREVMWP'="P"
SET PSOTOPK=1
+21 ; CHANGED "FROM" PARK
IF PREVMWP="P"
IF PRKMW'="P"
SET PSOFRPK=1
+22 IF $GET(PSOFRPK)!$GET(PSOTOPK)
KILL SAVDA
MERGE SAVDA=DA
SET SAVDIE=DIE
SET SAVFLD=$GET(FLD)
+23 IF $GET(PSOFRPK)
KILL DA
SET (DA,PSDA)=PSORXED("IRXN")
DO UNPARK^PSOPRK
KILL DA
MERGE DA=SAVDA
KILL Y
SET DIE=SAVDIE
SET FLD=SAVFLD
+24 ;PAPI 441 END
IF $GET(PSOTOPK)
KILL DA
SET DA=PSORXED("IRXN")
DO PRK^PSOPRK(DA)
KILL DA
MERGE DA=SAVDA
KILL Y
SET DIE=SAVDIE
SET FLD=SAVFLD
RFE IF '$DATA(^PSRX(PSORXED("IRXN"),1,RFL))
QUIT
+1 ;
+2 IF 'QUIT
IF $$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'=""
Begin DoDot:1
+3 DO EDTDAW^PSODAWUT(PSORXED("IRXN"),RFL,.DAW)
IF $GET(DAW)="^"
QUIT
+4 DO SAVDAW^PSODAWUT(PSORXED("IRXN"),RFL,+$GET(DAW))
+5 QUIT
End DoDot:1
+6 ;
+7 ; PSO*7*427 - NDC edit checks are in NDC^PSODRG
+8 IF 'QUIT
Begin DoDot:1
+9 SET NDC=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)
+10 DO NDC^PSODRG(PSORXED("IRXN"),RFL,,.NDC)
IF $GET(NDC)="^"!($GET(NDC)="")
QUIT
+11 IF NDC'=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)
Begin DoDot:2
+12 SET CHGNDC=1
DO RXACT^PSOBPSU2(PSORXED("IRXN"),RFL,"NDC changed from "_$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)_" to "_NDC_".","E")
End DoDot:2
+13 DO SAVNDC^PSONDCUT(PSORXED("IRXN"),RFL,NDC)
+14 QUIT
End DoDot:1
+15 ;
+16 SET CHANGED=$$CHANGED(PSORXED("IRXN"),RFL,.FLDS)
+17 IF CHANGED
Begin DoDot:1
+18 IF $PIECE(CHANGED,"^",2)
IF '$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(PSORXED("IRXN"),RFL))
Begin DoDot:2
+19 DO REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DC",99,"REFILL DIVISION CHANGED",1)
End DoDot:2
QUIT
+20 IF $$SUBMIT^PSOBPSUT(PSORXED("IRXN"),RFL,1,1)
Begin DoDot:2
+21 NEW RX
SET RX=PSORXED("IRXN")
+22 IF '$PIECE(CHANGED,"^",2)
IF $$STATUS^PSOBPSUT(RX,RFL)=""
QUIT
+23 DO ECMESND^PSOBPSU1(RX,RFL,,"ED",$$GETNDC^PSONDCUT(RX,RFL),,$SELECT($PIECE(CHANGED,"^",2):"REFILL DIVISION CHANGED",1:"REFILL EDITED"),,+$GET(CHGNDC))
+24 ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358
+25 IF $$PSOET^PSOREJP3(RX,RFL)
SET X="Q"
QUIT
+26 ;- Checking/Handling DUR/79 Rejects
+27 IF $$FIND^PSOREJUT(RX,RFL)
SET X=$$HDLG^PSOREJU1(RX,RFL,"79,88,943","ED","IOQ","Q")
End DoDot:2
End DoDot:1
+28 KILL DIE,CMRL,DA,DR
+29 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 ; identifies origin of call to PSOORED3 for dosing
SET PSOEDDOS=1
+2 IF '$ORDER(^PSRX(PSORXED("IRXN"),6,0))
DO DOSE^PSOORED5
QUIT
+3 DO ^PSOORED3
+4 KILL PSOEDDOS
+5 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
