PSOERXU4 ;ALB/BLB - eRx utilities ; 12/21/2020
;;7.0;OUTPATIENT PHARMACY;**520,508,551,581,635,617,651,700,746**;DEC 1997;Build 106
;
Q
DERX1(PSOIEN,PSOIENS,DFLAG) ;
N EDRG,ERXDAT,ESIG,COMM,SUBS,DFORM,DSTR,QQUAL,POTUC,QTY,DAYS,REFILL,COMMARY,SIGARY,ERXRFLS,I,ERXDSUB
N S2017,MIEN,MTYPE,SGLOOP,RESVAL,DFLG
S S2017=$$GET1^DIQ(52.49,PSOIEN,312.1,"I")
D GETS^DIQ(52.49,PSOIENS,".03;.08;3.1;4.6;4.8;5.1;5.2;5.4;5.5;5.6;5.7;5.8;7;8;41;42;43","E","ERXDAT")
S DFLG=$G(DFLAG,"")
S MTYPE=$$GET1^DIQ(52.49,PSOIEN,.08,"I")
S RESVAL=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
S EDRG=$G(ERXDAT(52.49,PSOIENS,3.1,"E"))
S ESIG=$G(ERXDAT(52.49,PSOIENS,7,"E"))
S COMM=$G(ERXDAT(52.49,PSOIENS,8,"E"))
S SUBS=$G(ERXDAT(52.49,PSOIENS,5.8,"E"))
S DFORM=$G(ERXDAT(52.49,PSOIENS,41,"E"))
S DSTR=$G(ERXDAT(52.49,PSOIENS,43,"E"))
I 'S2017 S QQUAL=$G(ERXDAT(52.49,PSOIENS,5.2,"E"))
I S2017 D
.S MIEN=$O(^PS(52.49,PSOIEN,311,0))
.S QQUAL=$$GET1^DIQ(52.49311,MIEN_","_PSOIEN_",",2.2,"I"),QQUAL=$$GET1^DIQ(52.45,QQUAL,.02,"E")
S POTUC=$G(ERXDAT(52.49,PSOIENS,42,"E"))
S QTY=$G(ERXDAT(52.49,PSOIENS,5.1,"E"))
S DAYS=$G(ERXDAT(52.49,PSOIENS,5.5,"E"))
S REFILL=$G(ERXDAT(52.49,PSOIENS,5.6,"E"))
I 'S2017 D
.I REFILL="" D
..S REFILL=$G(ERXDAT(52.49,PSOIENS,5.7,"I"))
I MTYPE="RE",RESVAL="R",REFILL>0 S REFILL=REFILL-1
D TXT2ARY^PSOERXD1(.SIGARY,ESIG,,69)
D TXT2ARY^PSOERXD1(.COMMARY,COMM,,65)
W !,"eRx Drug: "_EDRG_" "_$P($$ERXDRSCH^PSOERXUT(PSOIENS),"^",2)
I 'S2017 D
.W !,"eRx Sig: "
.S I=0 F S I=$O(SIGARY(I)) Q:'I D
..W $S(I>1:" "_SIGARY(I),1:SIGARY(I)),!
I '$L(ESIG) W !
I S2017 D
.W !,"eRx Sig:"
.S SGLOOP=0 F S SGLOOP=$O(^PS(52.49,PSOIEN,311,MIEN,8,SGLOOP)) Q:'SGLOOP D
..W !,$G(^PS(52.49,PSOIEN,311,MIEN,8,SGLOOP,0))
W !!,"eRx Notes: "
S I=0 F S I=$O(COMMARY(I)) Q:'I D
.W $S(I>1:" "_COMMARY(I),1:COMMARY(I)),!
I '$L(COMM) W !
Q:DFLG=1
W "Drug Form: "_DFORM,?40,"Strength: "_DSTR
W !,"Code List Qualifier: "_QQUAL,?40,"Quantity Unit of Measure: "_POTUC
S ERXDSUB=$$GET1^DIQ(52.49,PSOIEN,5.8,"I")
S ERXDSUB=$S(ERXDSUB=1:"NO",ERXDSUB=0:"YES",1:"")
W !,"Substitutions? :"_ERXDSUB
W !,"Qty: "_QTY,?25,"Days Supply: "_DAYS,?55,"Refills: "_REFILL,!
Q
REM ;
N MBMSITE,DIR,Y,PSSRET,PSOIENS,REMIEN,REMSTA,REMTXT,ERXRMIEN,DIC,X,RXSTAT,FDA
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
D FULL^VALM1
S PSOIENS=PSOIEN_","
S VALMBCK="R"
S RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E") I RXSTAT="RJ"!(RXSTAT="RM")!($G(MBMSITE)&($E(RXSTAT,1,3)="REM"))!(RXSTAT="PR") D Q
.W !!,"Cannot remove a prescription with a status of 'Rejected', 'Removed',",!,"or 'Processed",!
.S DIR(0)="E" D ^DIR
W ! S DIC="^PS(52.45,",DIC(0)="AEMQ",DIC("S")="I $D(^PS(52.45,""TYPE"",""REM"",Y))",DIC("A")="Select REMOVAL reason code: "
D ^DIC K DIC
I $P(Y,U)<1 Q
S REMIEN=$P(Y,U),REMSTA=$P(Y,U,2)
I +$G(REMIEN)<1 W !,"Removal reason code required!" S DIR(0)="E" D ^DIR K DIR Q
K X,Y S DIR(0)="FO^1:70",DIR("A")="Additional Comments (Optional)" D ^DIR K DIR
Q:Y="^"
S REMTXT=$G(Y)
W ! S DIR(0)="YO",DIR("A")="Would you like to 'Remove' eRx #"_$$GET1^DIQ(52.49,PSOIEN,.01,"E"),DIR("B")="Y" D ^DIR K DIR
Q:'Y
I '$G(MBMSITE) D
. K FDA S FDA(52.4919,"+1,"_PSOIENS,.01)=$$NOW^XLFDT,FDA(52.4919,"+1,"_PSOIENS,.02)=REMIEN
. S FDA(52.4919,"+1,"_PSOIENS,.03)=DUZ,FDA(52.4919,"+1,"_PSOIENS,1)=REMTXT
. D UPDATE^DIE(,"FDA") K FDA
; SET THE ERX STATUS TO THE REMOVAL REASON
D UPDSTAT^PSOERXU1(PSOIEN,$S('$G(MBMSITE):"RM",1:REMSTA),REMTXT)
;allow user to perform a batch removal of eRx for a patient with the same provider if it comes in on the same day
D BATCHREM^PSOERX1H(PSOIEN,REMIEN,REMTXT,"R") ; "R"-remove
K @VALMAR D REF^PSOERSE1
Q
; unremove eRx
UNREM ;
N DIR,Y,DA,DIE,DR,HCOMM,PSSRET,PSOIENS,REMIEN,REMSTA,REMTXT,ERXRMIEN,DIC,X,RXSTAT,SEQ,NEWSTA
D FULL^VALM1
S PSOIENS=PSOIEN_","
S VALMBCK="R"
D CHKSTA I RXSTAT'="RM" D Q
.W !!,"Cannot Un-Remove a prescription that the status is not 'Removed'"
.S DIR(0)="E" D ^DIR
HLD W !
S DIC="^PS(52.45,",DIC(0)="AEMQ",DIC("S")="I $E($P(^PS(52.45,+Y,0),U))=""H""",DIC("B")="HUR"
S DIC("A")="Select HOLD reason code: " D ^DIC K DIC
I $P(Y,U)<1 Q ;if user ^
S REMIEN=$P(Y,U)
I +$G(REMIEN)<0 W !,"HOLD reason code required!" S DIR(0)="E" D ^DIR K DIR G HLD
; Add comment in 52.4919
S DIR(0)="52.4919,1",DIR("A")="Additional Comments (Optional)" D ^DIR K DIR
I Y="^" Q
S HCOMM=$G(Y)
S DIR(0)="YO",DIR("A")="Would you like to 'Un-Remove' eRx #"_$$GET1^DIQ(52.49,PSOIEN,.01,"E")
S DIR("B")="Y" D ^DIR K DIR
Q:'Y
D UPDSTAT^PSOERXU1(PSOIEN,$$GET1^DIQ(52.45,REMIEN,.01),HCOMM)
S DR="1///"_REMIEN,DIE="^PS(52.49,",DA=PSOIEN D ^DIE
D BATCHREM^PSOERX1H(PSOIEN,REMIEN,HCOMM,"U") ; "U" - Un-remove
K @VALMAR D REF^PSOERSE1 ;Refresh screen
Q
CHKSTA ; check if status is RM or type is "REM"
S STAIEN=+$G(^PS(52.49,PSOIEN,1)),RXSTAT=$P(^PS(52.45,STAIEN,0),"^",1)
I RXSTAT="RM" K STAIEN Q
S RXSTAT=$S($P(^PS(52.45,STAIEN,0),"^",3)="REM":"RM",1:"") K STAIEN
Q
; reject eRx
REJ ;
N MBMSITE,DIR,DIC,Y,PSSRET,PSOIENS,REMTXT,REJSTA,FULLTXT,ERXRJIEN,REJDESC,REJIEN,REJTXT,X,RXSTAT
S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
D FULL^VALM1
S PSOIENS=PSOIEN_","
S VALMBCK="R"
S RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E") I RXSTAT="RJ"!(RXSTAT="RM")!($G(MBMSITE)&($E(RXSTAT,1,3)="REM"))!(RXSTAT="PR") D Q
.W !!,"Cannot reject a prescription with a status of 'Rejected', 'Removed',",!,"or 'Processed",!
.S DIR(0)="E" D ^DIR
S DIR(0)="YO",DIR("A")="Would you like to 'Reject' eRx #"_$$GET1^DIQ(52.49,PSOIEN,.01,"E"),DIR("B")="Y" D ^DIR K DIR
Q:'Y
S DIC="^PS(52.45,",DIC(0)="AEMQ",DIC("S")="I $D(^PS(52.45,""TYPE"",""REJ"",Y))",DIC("A")="Select REJECT reason code: "
D ^DIC K DIC
I $P(Y,U)<1 W !,"Reject reason required! eRx NOT rejected." S DIR(0)="E" D ^DIR K DIR Q
S REJIEN=$P(Y,U),REJSTA=$P(Y,U,2)
K X,Y,DIR
S DIR(0)="FO^1:200",DIR("A")="Additional Comments (Optional)" D ^DIR K DIR
Q:Y="^"
; if reject reason was entered, log the activity.
S REJTXT=Y
S REJDESC=$$GET1^DIQ(52.45,REJIEN,.02,"E")
S FULLTXT=REJSTA_" "_REJDESC_" - Additional Comments: "_REJTXT
D POST^PSOERXO1(PSOIEN,.PSSRET,900,"",$E(FULLTXT,1,295))
; if the post was unsuccessful, inform the user and quit.
I $P(PSSRET(0),U)<1 W !,$P(PSSRET(0),U,2) S DIR(0)="E" D ^DIR K DIR Q
I $D(PSSRET("errorMessage")) W !,PSSRET("errorMessage") S DIR(0)="E" D ^DIR K DIR Q
W !!,"Rejection message sent." S DIR(0)="E" D ^DIR K DIR
; if post is successful, change the eRx status and log the status activity.
S FDA(52.4919,"+1,"_PSOIENS,.01)=$$NOW^XLFDT
S FDA(52.4919,"+1,"_PSOIENS,.02)=REJIEN
S FDA(52.4919,"+1,"_PSOIENS,.03)=DUZ
S FDA(52.4919,"+1,"_PSOIENS,1)=REJTXT
D UPDATE^DIE(,"FDA") K FDA
; SET THE ERX STATUS TO THE REJECT REASON
D UPDSTAT^PSOERXU1(PSOIEN,"RJ")
Q
QTYDSRFL(ERXIEN,EDTYP) ;
; ERXIEN - ien from 52.49
; EDTYP:
; 1 - DAYS SUPPLY
; 2 - QUANTITY
; 3 - REFILLS
; 4 - SCHEDULE/DOSAGE EDIT
N PSODRUG,PSODIR,ERXDRUG,PSODFN,ERXIENS,FDA,CLOZPAT,PSOY,PATSTAT,Y,DONE,DIR,ANS,NWDAYSUP,NEWQTY,PSODRG,PSONEW,PQUIT
S ERXIENS=ERXIEN_","
; setup drug array
S ERXDRUG=$$GET1^DIQ(52.49,ERXIEN,3.2,"I") Q:'ERXDRUG 0
S PSOY=ERXDRUG,PSOY(0)=$G(^PSDRUG(ERXDRUG,0))
D SET^PSODRG
S PSODRG=ERXDRUG
; set quanity, days supply, refill, and patient information
S PSODFN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
S PSODIR("QTY")=$$GET1^DIQ(52.49,ERXIEN,20.1,"E")
S PSODIR("DAYS SUPPLY")=$$GET1^DIQ(52.49,ERXIEN,20.2,"E")
S PSODIR("# OF REFILLS")=$$GET1^DIQ(52.49,ERXIEN,20.5,"E")
; Decrement # of refills if this is a RxRenewalResponse with a response type of 'Replace'
; only decrement if field 20.5 and 5.6 are the same.
I PSODIR("# OF REFILLS")>0,$$GET1^DIQ(52.49,ERXIEN,.08,"I")="RE",$$GET1^DIQ(52.49,ERXIEN,52.1,"I")="R" D
.I PSODIR("# OF REFILLS")=$$GET1^DIQ(52.49,ERXIEN,5.6,"E") D
..S PSODIR("# OF REFILLS")=$G(PSODIR("# OF REFILLS"))-1
S PSODIR("DFLG")=0
S PATSTAT=$$GET1^DIQ(55,PSODFN,3,"E")
I '$L(PATSTAT) D
.S DONE=0
.F D Q:DONE
..W !,"This is a required response. Enter '^' to exit"
..K DA S DIR(0)="55,3",DIR("A")="PATIENT STATUS" D ^DIR K DIR
..I +Y S DONE=1 Q
..I Y["^" S PQUIT=1,DONE=1 Q
.S ANS=$P(Y,"^",1)
.S FDA(55,PSODFN_",",3)=ANS
.D FILE^DIE(,"FDA","ERR") K FDA,ERR
S PSODIR("PATIENT STATUS")=$P($G(^PS(55,PSODFN,"PS")),U)
S X=$G(PSODIR("PATIENT STATUS"))
I X D
.S DIC=53,DIC(0)="QXZ" D ^DIC K DIC
.S:+Y>0 PSODIR("PTST NODE")=Y(0)
I $P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1" D
.S CLOZPAT=$O(^YSCL(603.01,"C",PSODFN,0)) Q:'CLOZPAT
.S CLOZPAT=$P(^YSCL(603.01,CLOZPAT,0),"^",3)
.S CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
I EDTYP=1 D
.S:'$G(PSODIR("DAYS SUPPLY")) NWDAYSUP=$$DAYSCHK(.PSODRUG,.PSODIR)
.I $G(NWDAYSUP) S PSODIR("DAYS SUPPLY")=NWDAYSUP
.D DAYS^PSODIR1(.PSODIR) D FILE
.K QTYDSRFL
I EDTYP=2 S PSONEW("FLD")=7 D
.I $$GET1^DIQ(52.49,PSOIEN,20.1)'="" D
..S PSODIR("QTY")=$$GET1^DIQ(52.49,PSOIEN,20.1)
.E S NEWQTY=$$QTYCHECK,PSODIR("QTY")=NEWQTY
.D QTY^PSODIR1(.PSODIR),FILE
.K QTYARY
I EDTYP=3 S PSONEW("FLD")=9 D REFILL^PSODIR1(.PSODIR)
I $G(PSODIR("DFLG"))=1 Q 1
S QTYDSRFL("QTY")=$G(PSODIR("QTY"))
D FILE
Q 0
FILE ;
N NEWVAL
S FDA(52.49,ERXIENS,20.1)=$G(PSODIR("QTY"))
S FDA(52.49,ERXIENS,20.2)=$G(PSODIR("DAYS SUPPLY"))
S FDA(52.49,ERXIENS,20.5)=$G(PSODIR("# OF REFILLS"))
D FILE^DIE(,"FDA") K FDA
;Saving the eRx Audit Log for QTY, DAYS SUPPLY & # OF REFILLS
I $G(PSODIR("QTY"))'="" S NEWVAL(1)=$G(PSODIR("QTY")) D AUDLOG^PSOERXUT(+PSOIEN,"QTY",DUZ,.NEWVAL)
I $G(PSODIR("DAYS SUPPLY"))'="" S NEWVAL(1)=$G(PSODIR("DAYS SUPPLY")) D AUDLOG^PSOERXUT(+PSOIEN,"DAYS SUPPLY",DUZ,.NEWVAL)
I $G(PSODIR("# OF REFILLS"))'="" S NEWVAL(1)=$G(PSODIR("# OF REFILLS")) D AUDLOG^PSOERXUT(+PSOIEN,"# OF REFILLS",DUZ,.NEWVAL)
Q
DAYSCHK(PSODRUG,PSODIR) ; auto calculate days supply based off quantity.
N QTYDSRFL,DAYSUP,I,ADUR,IENS
N QTYDSRFL,VAL,DOSE
F DOSE=1:1 Q:'$D(^PS(52.49,PSOIEN,21,DOSE)) D
. S QTYDSRFL("DOSE ORDERED",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",9,"E")_"^"
. S QTYDSRFL("SCHEDULE",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",1,"E")
. S QTYDSRFL("DURATION",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",2,"E")
. S QTYDSRFL("CONJUNCTION",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",6,"E")
I '$G(QTYDSRFL("DOSE ORDERED",1)) Q 0
S QTYDSRFL("PATIENT")=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
S QTYDSRFL("DRUG")=$G(PSODRUG("IEN"))
S QTYDSRFL("QTY")=$G(PSODIR("QTY"))
D QTYX^PSOSIG(.QTYDSRFL)
S DAYSUP=$G(QTYDSRFL("DAYS SUPPLY"))
Q DAYSUP
;
QTYCHECK(PSODRUG,PSODIR) ; return qty for days supply
; VAL: quantity
N QTYARY,VAL,DOSE
F DOSE=1:1 Q:'$D(^PS(52.49,PSOIEN,21,DOSE)) D
. S QTYARY("DOSE ORDERED",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",9,"E")_"^"
. S QTYARY("SCHEDULE",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",1,"E")
. S QTYARY("DURATION",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",2,"E")
. S QTYARY("CONJUNCTION",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",6,"E")
I '$G(QTYARY("DOSE ORDERED",1)) Q ""
S QTYARY("PATIENT")=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
S QTYARY("DRUG")=$G(PSODRUG("IEN"))
S QTYARY("DAYS SUPPLY")=$$GET1^DIQ(52.49,PSOIEN,20.2,"E")
D QTYX^PSOSIG(.QTYARY)
S VAL=$G(QTYARY("QTY"))
Q VAL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXU4 11385 printed Dec 13, 2024@02:29:05 Page 2
PSOERXU4 ;ALB/BLB - eRx utilities ; 12/21/2020
+1 ;;7.0;OUTPATIENT PHARMACY;**520,508,551,581,635,617,651,700,746**;DEC 1997;Build 106
+2 ;
+3 QUIT
DERX1(PSOIEN,PSOIENS,DFLAG) ;
+1 NEW EDRG,ERXDAT,ESIG,COMM,SUBS,DFORM,DSTR,QQUAL,POTUC,QTY,DAYS,REFILL,COMMARY,SIGARY,ERXRFLS,I,ERXDSUB
+2 NEW S2017,MIEN,MTYPE,SGLOOP,RESVAL,DFLG
+3 SET S2017=$$GET1^DIQ(52.49,PSOIEN,312.1,"I")
+4 DO GETS^DIQ(52.49,PSOIENS,".03;.08;3.1;4.6;4.8;5.1;5.2;5.4;5.5;5.6;5.7;5.8;7;8;41;42;43","E","ERXDAT")
+5 SET DFLG=$GET(DFLAG,"")
+6 SET MTYPE=$$GET1^DIQ(52.49,PSOIEN,.08,"I")
+7 SET RESVAL=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
+8 SET EDRG=$GET(ERXDAT(52.49,PSOIENS,3.1,"E"))
+9 SET ESIG=$GET(ERXDAT(52.49,PSOIENS,7,"E"))
+10 SET COMM=$GET(ERXDAT(52.49,PSOIENS,8,"E"))
+11 SET SUBS=$GET(ERXDAT(52.49,PSOIENS,5.8,"E"))
+12 SET DFORM=$GET(ERXDAT(52.49,PSOIENS,41,"E"))
+13 SET DSTR=$GET(ERXDAT(52.49,PSOIENS,43,"E"))
+14 IF 'S2017
SET QQUAL=$GET(ERXDAT(52.49,PSOIENS,5.2,"E"))
+15 IF S2017
Begin DoDot:1
+16 SET MIEN=$ORDER(^PS(52.49,PSOIEN,311,0))
+17 SET QQUAL=$$GET1^DIQ(52.49311,MIEN_","_PSOIEN_",",2.2,"I")
SET QQUAL=$$GET1^DIQ(52.45,QQUAL,.02,"E")
End DoDot:1
+18 SET POTUC=$GET(ERXDAT(52.49,PSOIENS,42,"E"))
+19 SET QTY=$GET(ERXDAT(52.49,PSOIENS,5.1,"E"))
+20 SET DAYS=$GET(ERXDAT(52.49,PSOIENS,5.5,"E"))
+21 SET REFILL=$GET(ERXDAT(52.49,PSOIENS,5.6,"E"))
+22 IF 'S2017
Begin DoDot:1
+23 IF REFILL=""
Begin DoDot:2
+24 SET REFILL=$GET(ERXDAT(52.49,PSOIENS,5.7,"I"))
End DoDot:2
End DoDot:1
+25 IF MTYPE="RE"
IF RESVAL="R"
IF REFILL>0
SET REFILL=REFILL-1
+26 DO TXT2ARY^PSOERXD1(.SIGARY,ESIG,,69)
+27 DO TXT2ARY^PSOERXD1(.COMMARY,COMM,,65)
+28 WRITE !,"eRx Drug: "_EDRG_" "_$PIECE($$ERXDRSCH^PSOERXUT(PSOIENS),"^",2)
+29 IF 'S2017
Begin DoDot:1
+30 WRITE !,"eRx Sig: "
+31 SET I=0
FOR
SET I=$ORDER(SIGARY(I))
if 'I
QUIT
Begin DoDot:2
+32 WRITE $SELECT(I>1:" "_SIGARY(I),1:SIGARY(I)),!
End DoDot:2
End DoDot:1
+33 IF '$LENGTH(ESIG)
WRITE !
+34 IF S2017
Begin DoDot:1
+35 WRITE !,"eRx Sig:"
+36 SET SGLOOP=0
FOR
SET SGLOOP=$ORDER(^PS(52.49,PSOIEN,311,MIEN,8,SGLOOP))
if 'SGLOOP
QUIT
Begin DoDot:2
+37 WRITE !,$GET(^PS(52.49,PSOIEN,311,MIEN,8,SGLOOP,0))
End DoDot:2
End DoDot:1
+38 WRITE !!,"eRx Notes: "
+39 SET I=0
FOR
SET I=$ORDER(COMMARY(I))
if 'I
QUIT
Begin DoDot:1
+40 WRITE $SELECT(I>1:" "_COMMARY(I),1:COMMARY(I)),!
End DoDot:1
+41 IF '$LENGTH(COMM)
WRITE !
+42 if DFLG=1
QUIT
+43 WRITE "Drug Form: "_DFORM,?40,"Strength: "_DSTR
+44 WRITE !,"Code List Qualifier: "_QQUAL,?40,"Quantity Unit of Measure: "_POTUC
+45 SET ERXDSUB=$$GET1^DIQ(52.49,PSOIEN,5.8,"I")
+46 SET ERXDSUB=$SELECT(ERXDSUB=1:"NO",ERXDSUB=0:"YES",1:"")
+47 WRITE !,"Substitutions? :"_ERXDSUB
+48 WRITE !,"Qty: "_QTY,?25,"Days Supply: "_DAYS,?55,"Refills: "_REFILL,!
+49 QUIT
REM ;
+1 NEW MBMSITE,DIR,Y,PSSRET,PSOIENS,REMIEN,REMSTA,REMTXT,ERXRMIEN,DIC,X,RXSTAT,FDA
+2 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+3 DO FULL^VALM1
+4 SET PSOIENS=PSOIEN_","
+5 SET VALMBCK="R"
+6 SET RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
IF RXSTAT="RJ"!(RXSTAT="RM")!($GET(MBMSITE)&($EXTRACT(RXSTAT,1,3)="REM"))!(RXSTAT="PR")
Begin DoDot:1
+7 WRITE !!,"Cannot remove a prescription with a status of 'Rejected', 'Removed',",!,"or 'Processed",!
+8 SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
+9 WRITE !
SET DIC="^PS(52.45,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $D(^PS(52.45,""TYPE"",""REM"",Y))"
SET DIC("A")="Select REMOVAL reason code: "
+10 DO ^DIC
KILL DIC
+11 IF $PIECE(Y,U)<1
QUIT
+12 SET REMIEN=$PIECE(Y,U)
SET REMSTA=$PIECE(Y,U,2)
+13 IF +$GET(REMIEN)<1
WRITE !,"Removal reason code required!"
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+14 KILL X,Y
SET DIR(0)="FO^1:70"
SET DIR("A")="Additional Comments (Optional)"
DO ^DIR
KILL DIR
+15 if Y="^"
QUIT
+16 SET REMTXT=$GET(Y)
+17 WRITE !
SET DIR(0)="YO"
SET DIR("A")="Would you like to 'Remove' eRx #"_$$GET1^DIQ(52.49,PSOIEN,.01,"E")
SET DIR("B")="Y"
DO ^DIR
KILL DIR
+18 if 'Y
QUIT
+19 IF '$GET(MBMSITE)
Begin DoDot:1
+20 KILL FDA
SET FDA(52.4919,"+1,"_PSOIENS,.01)=$$NOW^XLFDT
SET FDA(52.4919,"+1,"_PSOIENS,.02)=REMIEN
+21 SET FDA(52.4919,"+1,"_PSOIENS,.03)=DUZ
SET FDA(52.4919,"+1,"_PSOIENS,1)=REMTXT
+22 DO UPDATE^DIE(,"FDA")
KILL FDA
End DoDot:1
+23 ; SET THE ERX STATUS TO THE REMOVAL REASON
+24 DO UPDSTAT^PSOERXU1(PSOIEN,$SELECT('$GET(MBMSITE):"RM",1:REMSTA),REMTXT)
+25 ;allow user to perform a batch removal of eRx for a patient with the same provider if it comes in on the same day
+26 ; "R"-remove
DO BATCHREM^PSOERX1H(PSOIEN,REMIEN,REMTXT,"R")
+27 KILL @VALMAR
DO REF^PSOERSE1
+28 QUIT
+29 ; unremove eRx
UNREM ;
+1 NEW DIR,Y,DA,DIE,DR,HCOMM,PSSRET,PSOIENS,REMIEN,REMSTA,REMTXT,ERXRMIEN,DIC,X,RXSTAT,SEQ,NEWSTA
+2 DO FULL^VALM1
+3 SET PSOIENS=PSOIEN_","
+4 SET VALMBCK="R"
+5 DO CHKSTA
IF RXSTAT'="RM"
Begin DoDot:1
+6 WRITE !!,"Cannot Un-Remove a prescription that the status is not 'Removed'"
+7 SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
HLD WRITE !
+1 SET DIC="^PS(52.45,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $E($P(^PS(52.45,+Y,0),U))=""H"""
SET DIC("B")="HUR"
+2 SET DIC("A")="Select HOLD reason code: "
DO ^DIC
KILL DIC
+3 ;if user ^
IF $PIECE(Y,U)<1
QUIT
+4 SET REMIEN=$PIECE(Y,U)
+5 IF +$GET(REMIEN)<0
WRITE !,"HOLD reason code required!"
SET DIR(0)="E"
DO ^DIR
KILL DIR
GOTO HLD
+6 ; Add comment in 52.4919
+7 SET DIR(0)="52.4919,1"
SET DIR("A")="Additional Comments (Optional)"
DO ^DIR
KILL DIR
+8 IF Y="^"
QUIT
+9 SET HCOMM=$GET(Y)
+10 SET DIR(0)="YO"
SET DIR("A")="Would you like to 'Un-Remove' eRx #"_$$GET1^DIQ(52.49,PSOIEN,.01,"E")
+11 SET DIR("B")="Y"
DO ^DIR
KILL DIR
+12 if 'Y
QUIT
+13 DO UPDSTAT^PSOERXU1(PSOIEN,$$GET1^DIQ(52.45,REMIEN,.01),HCOMM)
+14 SET DR="1///"_REMIEN
SET DIE="^PS(52.49,"
SET DA=PSOIEN
DO ^DIE
+15 ; "U" - Un-remove
DO BATCHREM^PSOERX1H(PSOIEN,REMIEN,HCOMM,"U")
+16 ;Refresh screen
KILL @VALMAR
DO REF^PSOERSE1
+17 QUIT
CHKSTA ; check if status is RM or type is "REM"
+1 SET STAIEN=+$GET(^PS(52.49,PSOIEN,1))
SET RXSTAT=$PIECE(^PS(52.45,STAIEN,0),"^",1)
+2 IF RXSTAT="RM"
KILL STAIEN
QUIT
+3 SET RXSTAT=$SELECT($PIECE(^PS(52.45,STAIEN,0),"^",3)="REM":"RM",1:"")
KILL STAIEN
+4 QUIT
+5 ; reject eRx
REJ ;
+1 NEW MBMSITE,DIR,DIC,Y,PSSRET,PSOIENS,REMTXT,REJSTA,FULLTXT,ERXRJIEN,REJDESC,REJIEN,REJTXT,X,RXSTAT
+2 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
+3 DO FULL^VALM1
+4 SET PSOIENS=PSOIEN_","
+5 SET VALMBCK="R"
+6 SET RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
IF RXSTAT="RJ"!(RXSTAT="RM")!($GET(MBMSITE)&($EXTRACT(RXSTAT,1,3)="REM"))!(RXSTAT="PR")
Begin DoDot:1
+7 WRITE !!,"Cannot reject a prescription with a status of 'Rejected', 'Removed',",!,"or 'Processed",!
+8 SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
+9 SET DIR(0)="YO"
SET DIR("A")="Would you like to 'Reject' eRx #"_$$GET1^DIQ(52.49,PSOIEN,.01,"E")
SET DIR("B")="Y"
DO ^DIR
KILL DIR
+10 if 'Y
QUIT
+11 SET DIC="^PS(52.45,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $D(^PS(52.45,""TYPE"",""REJ"",Y))"
SET DIC("A")="Select REJECT reason code: "
+12 DO ^DIC
KILL DIC
+13 IF $PIECE(Y,U)<1
WRITE !,"Reject reason required! eRx NOT rejected."
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+14 SET REJIEN=$PIECE(Y,U)
SET REJSTA=$PIECE(Y,U,2)
+15 KILL X,Y,DIR
+16 SET DIR(0)="FO^1:200"
SET DIR("A")="Additional Comments (Optional)"
DO ^DIR
KILL DIR
+17 if Y="^"
QUIT
+18 ; if reject reason was entered, log the activity.
+19 SET REJTXT=Y
+20 SET REJDESC=$$GET1^DIQ(52.45,REJIEN,.02,"E")
+21 SET FULLTXT=REJSTA_" "_REJDESC_" - Additional Comments: "_REJTXT
+22 DO POST^PSOERXO1(PSOIEN,.PSSRET,900,"",$EXTRACT(FULLTXT,1,295))
+23 ; if the post was unsuccessful, inform the user and quit.
+24 IF $PIECE(PSSRET(0),U)<1
WRITE !,$PIECE(PSSRET(0),U,2)
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+25 IF $DATA(PSSRET("errorMessage"))
WRITE !,PSSRET("errorMessage")
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+26 WRITE !!,"Rejection message sent."
SET DIR(0)="E"
DO ^DIR
KILL DIR
+27 ; if post is successful, change the eRx status and log the status activity.
+28 SET FDA(52.4919,"+1,"_PSOIENS,.01)=$$NOW^XLFDT
+29 SET FDA(52.4919,"+1,"_PSOIENS,.02)=REJIEN
+30 SET FDA(52.4919,"+1,"_PSOIENS,.03)=DUZ
+31 SET FDA(52.4919,"+1,"_PSOIENS,1)=REJTXT
+32 DO UPDATE^DIE(,"FDA")
KILL FDA
+33 ; SET THE ERX STATUS TO THE REJECT REASON
+34 DO UPDSTAT^PSOERXU1(PSOIEN,"RJ")
+35 QUIT
QTYDSRFL(ERXIEN,EDTYP) ;
+1 ; ERXIEN - ien from 52.49
+2 ; EDTYP:
+3 ; 1 - DAYS SUPPLY
+4 ; 2 - QUANTITY
+5 ; 3 - REFILLS
+6 ; 4 - SCHEDULE/DOSAGE EDIT
+7 NEW PSODRUG,PSODIR,ERXDRUG,PSODFN,ERXIENS,FDA,CLOZPAT,PSOY,PATSTAT,Y,DONE,DIR,ANS,NWDAYSUP,NEWQTY,PSODRG,PSONEW,PQUIT
+8 SET ERXIENS=ERXIEN_","
+9 ; setup drug array
+10 SET ERXDRUG=$$GET1^DIQ(52.49,ERXIEN,3.2,"I")
if 'ERXDRUG
QUIT 0
+11 SET PSOY=ERXDRUG
SET PSOY(0)=$GET(^PSDRUG(ERXDRUG,0))
+12 DO SET^PSODRG
+13 SET PSODRG=ERXDRUG
+14 ; set quanity, days supply, refill, and patient information
+15 SET PSODFN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
+16 SET PSODIR("QTY")=$$GET1^DIQ(52.49,ERXIEN,20.1,"E")
+17 SET PSODIR("DAYS SUPPLY")=$$GET1^DIQ(52.49,ERXIEN,20.2,"E")
+18 SET PSODIR("# OF REFILLS")=$$GET1^DIQ(52.49,ERXIEN,20.5,"E")
+19 ; Decrement # of refills if this is a RxRenewalResponse with a response type of 'Replace'
+20 ; only decrement if field 20.5 and 5.6 are the same.
+21 IF PSODIR("# OF REFILLS")>0
IF $$GET1^DIQ(52.49,ERXIEN,.08,"I")="RE"
IF $$GET1^DIQ(52.49,ERXIEN,52.1,"I")="R"
Begin DoDot:1
+22 IF PSODIR("# OF REFILLS")=$$GET1^DIQ(52.49,ERXIEN,5.6,"E")
Begin DoDot:2
+23 SET PSODIR("# OF REFILLS")=$GET(PSODIR("# OF REFILLS"))-1
End DoDot:2
End DoDot:1
+24 SET PSODIR("DFLG")=0
+25 SET PATSTAT=$$GET1^DIQ(55,PSODFN,3,"E")
+26 IF '$LENGTH(PATSTAT)
Begin DoDot:1
+27 SET DONE=0
+28 FOR
Begin DoDot:2
+29 WRITE !,"This is a required response. Enter '^' to exit"
+30 KILL DA
SET DIR(0)="55,3"
SET DIR("A")="PATIENT STATUS"
DO ^DIR
KILL DIR
+31 IF +Y
SET DONE=1
QUIT
+32 IF Y["^"
SET PQUIT=1
SET DONE=1
QUIT
End DoDot:2
if DONE
QUIT
+33 SET ANS=$PIECE(Y,"^",1)
+34 SET FDA(55,PSODFN_",",3)=ANS
+35 DO FILE^DIE(,"FDA","ERR")
KILL FDA,ERR
End DoDot:1
+36 SET PSODIR("PATIENT STATUS")=$PIECE($GET(^PS(55,PSODFN,"PS")),U)
+37 SET X=$GET(PSODIR("PATIENT STATUS"))
+38 IF X
Begin DoDot:1
+39 SET DIC=53
SET DIC(0)="QXZ"
DO ^DIC
KILL DIC
+40 if +Y>0
SET PSODIR("PTST NODE")=Y(0)
End DoDot:1
+41 IF $PIECE($GET(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1"
Begin DoDot:1
+42 SET CLOZPAT=$ORDER(^YSCL(603.01,"C",PSODFN,0))
if 'CLOZPAT
QUIT
+43 SET CLOZPAT=$PIECE(^YSCL(603.01,CLOZPAT,0),"^",3)
+44 SET CLOZPAT=$SELECT(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
End DoDot:1
+45 IF EDTYP=1
Begin DoDot:1
+46 if '$GET(PSODIR("DAYS SUPPLY"))
SET NWDAYSUP=$$DAYSCHK(.PSODRUG,.PSODIR)
+47 IF $GET(NWDAYSUP)
SET PSODIR("DAYS SUPPLY")=NWDAYSUP
+48 DO DAYS^PSODIR1(.PSODIR)
DO FILE
+49 KILL QTYDSRFL
End DoDot:1
+50 IF EDTYP=2
SET PSONEW("FLD")=7
Begin DoDot:1
+51 IF $$GET1^DIQ(52.49,PSOIEN,20.1)'=""
Begin DoDot:2
+52 SET PSODIR("QTY")=$$GET1^DIQ(52.49,PSOIEN,20.1)
End DoDot:2
+53 IF '$TEST
SET NEWQTY=$$QTYCHECK
SET PSODIR("QTY")=NEWQTY
+54 DO QTY^PSODIR1(.PSODIR)
DO FILE
+55 KILL QTYARY
End DoDot:1
+56 IF EDTYP=3
SET PSONEW("FLD")=9
DO REFILL^PSODIR1(.PSODIR)
+57 IF $GET(PSODIR("DFLG"))=1
QUIT 1
+58 SET QTYDSRFL("QTY")=$GET(PSODIR("QTY"))
+59 DO FILE
+60 QUIT 0
FILE ;
+1 NEW NEWVAL
+2 SET FDA(52.49,ERXIENS,20.1)=$GET(PSODIR("QTY"))
+3 SET FDA(52.49,ERXIENS,20.2)=$GET(PSODIR("DAYS SUPPLY"))
+4 SET FDA(52.49,ERXIENS,20.5)=$GET(PSODIR("# OF REFILLS"))
+5 DO FILE^DIE(,"FDA")
KILL FDA
+6 ;Saving the eRx Audit Log for QTY, DAYS SUPPLY & # OF REFILLS
+7 IF $GET(PSODIR("QTY"))'=""
SET NEWVAL(1)=$GET(PSODIR("QTY"))
DO AUDLOG^PSOERXUT(+PSOIEN,"QTY",DUZ,.NEWVAL)
+8 IF $GET(PSODIR("DAYS SUPPLY"))'=""
SET NEWVAL(1)=$GET(PSODIR("DAYS SUPPLY"))
DO AUDLOG^PSOERXUT(+PSOIEN,"DAYS SUPPLY",DUZ,.NEWVAL)
+9 IF $GET(PSODIR("# OF REFILLS"))'=""
SET NEWVAL(1)=$GET(PSODIR("# OF REFILLS"))
DO AUDLOG^PSOERXUT(+PSOIEN,"# OF REFILLS",DUZ,.NEWVAL)
+10 QUIT
DAYSCHK(PSODRUG,PSODIR) ; auto calculate days supply based off quantity.
+1 NEW QTYDSRFL,DAYSUP,I,ADUR,IENS
+2 NEW QTYDSRFL,VAL,DOSE
+3 FOR DOSE=1:1
if '$DATA(^PS(52.49,PSOIEN,21,DOSE))
QUIT
Begin DoDot:1
+4 SET QTYDSRFL("DOSE ORDERED",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",9,"E")_"^"
+5 SET QTYDSRFL("SCHEDULE",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",1,"E")
+6 SET QTYDSRFL("DURATION",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",2,"E")
+7 SET QTYDSRFL("CONJUNCTION",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",6,"E")
End DoDot:1
+8 IF '$GET(QTYDSRFL("DOSE ORDERED",1))
QUIT 0
+9 SET QTYDSRFL("PATIENT")=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
+10 SET QTYDSRFL("DRUG")=$GET(PSODRUG("IEN"))
+11 SET QTYDSRFL("QTY")=$GET(PSODIR("QTY"))
+12 DO QTYX^PSOSIG(.QTYDSRFL)
+13 SET DAYSUP=$GET(QTYDSRFL("DAYS SUPPLY"))
+14 QUIT DAYSUP
+15 ;
QTYCHECK(PSODRUG,PSODIR) ; return qty for days supply
+1 ; VAL: quantity
+2 NEW QTYARY,VAL,DOSE
+3 FOR DOSE=1:1
if '$DATA(^PS(52.49,PSOIEN,21,DOSE))
QUIT
Begin DoDot:1
+4 SET QTYARY("DOSE ORDERED",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",9,"E")_"^"
+5 SET QTYARY("SCHEDULE",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",1,"E")
+6 SET QTYARY("DURATION",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",2,"E")
+7 SET QTYARY("CONJUNCTION",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",6,"E")
End DoDot:1
+8 IF '$GET(QTYARY("DOSE ORDERED",1))
QUIT ""
+9 SET QTYARY("PATIENT")=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
+10 SET QTYARY("DRUG")=$GET(PSODRUG("IEN"))
+11 SET QTYARY("DAYS SUPPLY")=$$GET1^DIQ(52.49,PSOIEN,20.2,"E")
+12 DO QTYX^PSOSIG(.QTYARY)
+13 SET VAL=$GET(QTYARY("QTY"))
+14 QUIT VAL
