PSOERXU4 ;ALB/BLB - eRx utilities ; 3/18/2021 14:03pm
;;7.0;OUTPATIENT PHARMACY;**520,508,551,581,635**;DEC 1997;Build 19
;
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
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 DIR,Y,PSSRET,PSOIENS,REMIEN,REMSTA,REMTXT,ERXRMIEN,DIC,X,RXSTAT
D FULL^VALM1
S PSOIENS=PSOIEN_","
S VALMBCK="R"
S RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E") I RXSTAT="RJ"!(RXSTAT="RM")!(RXSTAT="PR") D Q
.W !!,"Cannot remove 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 'Remove' 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"",""REM"",Y))",DIC("A")="Select REMOVAL reason code: "
D ^DIC K DIC
I $P(Y,U)<1 W !,"Removal reason code required!" S DIR(0)="E" D ^DIR K DIR Q
S REMIEN=$P(Y,U),REMSTA=$P(Y,U,2)
K X,Y S DIR(0)="FO^1:70",DIR("A")="Additional Comments (Optional)" D ^DIR K DIR
Q:Y="^"
S REMTXT=Y
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,"RM")
Q
; reject eRx
REJ ;
N DIR,DIC,Y,PSSRET,PSOIENS,REMTXT,REJSTA,FULLTXT,ERXRJIEN,REJDESC,REJIEN,REJTXT,X,RXSTAT
D FULL^VALM1
S PSOIENS=PSOIEN_","
S VALMBCK="R"
S RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E") I RXSTAT="RJ"!(RXSTAT="RM")!(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
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")
; PSO*7*635, 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("PATIENT STATUS")=$P(^PS(55,PSODFN,"PS"),U)
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"
..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(^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 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 S NWDAYSUP=$$DAYSCHK(.PSODRUG,.PSODIR) D
.I $G(NWDAYSUP) S PSODIR("DAYS SUPPLY")=NWDAYSUP
.I PSODIR("DAYS SUPPLY")>$P($G(PSODIR("PTST NODE")),"^",3) S PSODIR("DAYS SUPPLY")=$P($G(PSODIR("PTST NODE")),"^",3)
.D DAYS^PSODIR1(.PSODIR) D FILE
.K QTYDSRFL
I EDTYP=2 S PSONEW("FLD")=7 D
.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 ;
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
Q
DAYSCHK(PSODRUG,PSODIR) ; auto calculate days supply based off quantity.
N QTYDSRFL,DAYSUP,I,ADUR,IENS
S IENS=1_","_PSOIEN_","
S QTYDSRFL("SCHEDULE")=$$GET1^DIQ(52.4921,IENS,1,"E")
S QTYDSRFL("DOSE ORDERED")=$$GET1^DIQ(52.4921,IENS,9,"E")_"^"
I 'QTYDSRFL("DOSE ORDERED") Q 0
S QTYDSRFL("DURATION")=$$GET1^DIQ(52.4921,IENS,2,"E")
S QTYDSRFL("PATIENT")=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
S QTYDSRFL("DRUG")=$G(PSODRUG("IEN"))
S QTYDSRFL("QTY")=$G(PSODIR("QTY"))
F I=1:1:$L(QTYDSRFL("DOSE ORDERED"),U)-1 D
.S QTYDSRFL("DOSE ORDERED",I)=$P(QTYDSRFL("DOSE ORDERED"),U,I)
.S QTYDSRFL("SCHEDULE",I)=$P(QTYDSRFL("SCHEDULE"),U,I)
.S ADUR=$P(QTYDSRFL("DURATION"),U,I),X=+ADUR_$E($P(ADUR," ",2))
.I $L(X) S QTYDSRFL("DURATION",I)=X
.S X=$E($P(ADUR,"~",2))
.I $L(X) S QTYDSRFL("CONJUNCTION",I)=X
D QTYX^PSOSIG(.QTYDSRFL)
S DAYSUP=$G(QTYDSRFL("DAYS SUPPLY"))
Q DAYSUP
QTYCHECK(PSODRUG,PSODIR) ; return qty for days supply
; VAL: quantity
N QTYARY,I,X,ADUR,ADURNM,IENS,VAL
S IENS=1_","_PSOIEN_","
S QTYARY("DOSE ORDERED")=$$GET1^DIQ(52.4921,IENS,9,"E")_"^"
S QTYARY("DURATION")=$$GET1^DIQ(52.4921,IENS,2,"E")
S QTYARY("SCHEDULE")=$$GET1^DIQ(52.4921,IENS,1,"E")
S QTYARY("DAYS SUPPLY")=$$GET1^DIQ(52.49,ERXIEN,20.2,"E")
S QTYARY("PATIENT")=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
;I $G(DRG) S QTYARY("DRUG")=DRG
S QTYARY("DRUG")=$G(PSODRUG("IEN"))
F I=1:1:$L(QTYARY("DOSE ORDERED"),U)-1 D
. S QTYARY("DOSE ORDERED",I)=$P(QTYARY("DOSE ORDERED"),U,I)_"^"
. S QTYARY("SCHEDULE",I)=$P(QTYARY("SCHEDULE"),U,I)
. S ADUR=$P(QTYARY("DURATION"),U,I),ADURNM=$P($P(ADUR," ",2),"~")
. S:ADURNM="MONTHS" X=+ADUR_"L"
. S:ADURNM'="MONTHS" X=+ADUR_$E($P(ADUR," ",2))
. I $L(X) S QTYARY("DURATION",I)=X
. S X=$E($P(ADUR,"~",2))
. I $L(X) S QTYARY("CONJUNCTION",I)=X
D QTYX^PSOSIG(.QTYARY)
S VAL=$G(QTYARY("QTY"))
Q VAL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXU4 9532 printed Aug 15, 2021@00:05:10 Page 2
PSOERXU4 ;ALB/BLB - eRx utilities ; 3/18/2021 14:03pm
+1 ;;7.0;OUTPATIENT PHARMACY;**520,508,551,581,635**;DEC 1997;Build 19
+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
+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 DIR,Y,PSSRET,PSOIENS,REMIEN,REMSTA,REMTXT,ERXRMIEN,DIC,X,RXSTAT
+2 DO FULL^VALM1
+3 SET PSOIENS=PSOIEN_","
+4 SET VALMBCK="R"
+5 SET RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
IF RXSTAT="RJ"!(RXSTAT="RM")!(RXSTAT="PR")
Begin DoDot:1
+6 WRITE !!,"Cannot remove a prescription with a status of 'Rejected', 'Removed',",!,"or 'Processed",!
+7 SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
+8 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
+9 if 'Y
QUIT
+10 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: "
+11 DO ^DIC
KILL DIC
+12 IF $PIECE(Y,U)<1
WRITE !,"Removal reason code required!"
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+13 SET REMIEN=$PIECE(Y,U)
SET REMSTA=$PIECE(Y,U,2)
+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=Y
+17 SET FDA(52.4919,"+1,"_PSOIENS,.01)=$$NOW^XLFDT
SET FDA(52.4919,"+1,"_PSOIENS,.02)=REMIEN
+18 SET FDA(52.4919,"+1,"_PSOIENS,.03)=DUZ
SET FDA(52.4919,"+1,"_PSOIENS,1)=REMTXT
+19 DO UPDATE^DIE(,"FDA")
KILL FDA
+20 ; SET THE ERX STATUS TO THE REMOVAL REASON
+21 DO UPDSTAT^PSOERXU1(PSOIEN,"RM")
+22 QUIT
+23 ; reject eRx
REJ ;
+1 NEW DIR,DIC,Y,PSSRET,PSOIENS,REMTXT,REJSTA,FULLTXT,ERXRJIEN,REJDESC,REJIEN,REJTXT,X,RXSTAT
+2 DO FULL^VALM1
+3 SET PSOIENS=PSOIEN_","
+4 SET VALMBCK="R"
+5 SET RXSTAT=$$GET1^DIQ(52.49,PSOIEN,1,"E")
IF RXSTAT="RJ"!(RXSTAT="RM")!(RXSTAT="PR")
Begin DoDot:1
+6 WRITE !!,"Cannot reject a prescription with a status of 'Rejected', 'Removed',",!,"or 'Processed",!
+7 SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
+8 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
+9 if 'Y
QUIT
+10 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: "
+11 DO ^DIC
KILL DIC
+12 IF $PIECE(Y,U)<1
WRITE !,"Reject reason required! eRx NOT rejected."
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+13 SET REJIEN=$PIECE(Y,U)
SET REJSTA=$PIECE(Y,U,2)
+14 KILL X,Y,DIR
+15 SET DIR(0)="FO^1:200"
SET DIR("A")="Additional Comments (Optional)"
DO ^DIR
KILL DIR
+16 if Y="^"
QUIT
+17 ; if reject reason was entered, log the activity.
+18 SET REJTXT=Y
+19 SET REJDESC=$$GET1^DIQ(52.45,REJIEN,.02,"E")
+20 SET FULLTXT=REJSTA_" "_REJDESC_" - Additional Comments: "_REJTXT
+21 DO POST^PSOERXO1(PSOIEN,.PSSRET,900,"",$EXTRACT(FULLTXT,1,295))
+22 ; if the post was unsuccessful, inform the user and quit.
+23 IF $PIECE(PSSRET(0),U)<1
WRITE !,$PIECE(PSSRET(0),U,2)
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+24 IF $DATA(PSSRET("errorMessage"))
WRITE !,PSSRET("errorMessage")
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+25 WRITE !!,"Rejection message sent."
SET DIR(0)="E"
DO ^DIR
KILL DIR
+26 ; if post is successful, change the eRx status and log the status activity.
+27 SET FDA(52.4919,"+1,"_PSOIENS,.01)=$$NOW^XLFDT
+28 SET FDA(52.4919,"+1,"_PSOIENS,.02)=REJIEN
+29 SET FDA(52.4919,"+1,"_PSOIENS,.03)=DUZ
+30 SET FDA(52.4919,"+1,"_PSOIENS,1)=REJTXT
+31 DO UPDATE^DIE(,"FDA")
KILL FDA
+32 ; SET THE ERX STATUS TO THE REJECT REASON
+33 DO UPDSTAT^PSOERXU1(PSOIEN,"RJ")
+34 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
+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 ; PSO*7*635, 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 ;S PSODIR("PATIENT STATUS")=$P(^PS(55,PSODFN,"PS"),U)
+25 SET PSODIR("DFLG")=0
+26 SET PATSTAT=$$GET1^DIQ(55,PSODFN,3,"E")
+27 IF '$LENGTH(PATSTAT)
Begin DoDot:1
+28 SET DONE=0
+29 FOR
Begin DoDot:2
+30 WRITE !,"This is a required response. Enter '^' to exit"
+31 SET DIR(0)="55,3"
SET DIR("A")="PATIENT STATUS"
DO ^DIR
KILL DIR
+32 IF +Y
SET DONE=1
QUIT
+33 IF Y["^"
SET PQUIT=1
SET DONE=1
QUIT
End DoDot:2
if DONE
QUIT
+34 SET ANS=$PIECE(Y,"^",1)
+35 SET FDA(55,PSODFN_",",3)=ANS
+36 DO FILE^DIE(,"FDA","ERR")
KILL FDA,ERR
End DoDot:1
+37 SET PSODIR("PATIENT STATUS")=$PIECE(^PS(55,PSODFN,"PS"),U)
+38 SET X=$GET(PSODIR("PATIENT STATUS"))
+39 IF X
Begin DoDot:1
+40 SET DIC=53
SET DIC(0)="QXZ"
DO ^DIC
KILL DIC
+41 if +Y
SET PSODIR("PTST NODE")=Y(0)
End DoDot:1
+42 IF $PIECE($GET(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1"
Begin DoDot:1
+43 SET CLOZPAT=$ORDER(^YSCL(603.01,"C",PSODFN,0))
if 'CLOZPAT
QUIT
+44 SET CLOZPAT=$PIECE(^YSCL(603.01,CLOZPAT,0),"^",3)
+45 SET CLOZPAT=$SELECT(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
End DoDot:1
+46 IF EDTYP=1
SET NWDAYSUP=$$DAYSCHK(.PSODRUG,.PSODIR)
Begin DoDot:1
+47 IF $GET(NWDAYSUP)
SET PSODIR("DAYS SUPPLY")=NWDAYSUP
+48 IF PSODIR("DAYS SUPPLY")>$PIECE($GET(PSODIR("PTST NODE")),"^",3)
SET PSODIR("DAYS SUPPLY")=$PIECE($GET(PSODIR("PTST NODE")),"^",3)
+49 DO DAYS^PSODIR1(.PSODIR)
DO FILE
+50 KILL QTYDSRFL
End DoDot:1
+51 IF EDTYP=2
SET PSONEW("FLD")=7
Begin DoDot:1
+52 SET NEWQTY=$$QTYCHECK
SET PSODIR("QTY")=NEWQTY
+53 DO QTY^PSODIR1(.PSODIR)
DO FILE
+54 KILL QTYARY
End DoDot:1
+55 IF EDTYP=3
SET PSONEW("FLD")=9
DO REFILL^PSODIR1(.PSODIR)
+56 IF $GET(PSODIR("DFLG"))=1
QUIT 1
+57 SET QTYDSRFL("QTY")=$GET(PSODIR("QTY"))
+58 DO FILE
+59 QUIT 0
FILE ;
+1 SET FDA(52.49,ERXIENS,20.1)=$GET(PSODIR("QTY"))
+2 SET FDA(52.49,ERXIENS,20.2)=$GET(PSODIR("DAYS SUPPLY"))
+3 SET FDA(52.49,ERXIENS,20.5)=$GET(PSODIR("# OF REFILLS"))
+4 DO FILE^DIE(,"FDA")
KILL FDA
+5 QUIT
DAYSCHK(PSODRUG,PSODIR) ; auto calculate days supply based off quantity.
+1 NEW QTYDSRFL,DAYSUP,I,ADUR,IENS
+2 SET IENS=1_","_PSOIEN_","
+3 SET QTYDSRFL("SCHEDULE")=$$GET1^DIQ(52.4921,IENS,1,"E")
+4 SET QTYDSRFL("DOSE ORDERED")=$$GET1^DIQ(52.4921,IENS,9,"E")_"^"
+5 IF 'QTYDSRFL("DOSE ORDERED")
QUIT 0
+6 SET QTYDSRFL("DURATION")=$$GET1^DIQ(52.4921,IENS,2,"E")
+7 SET QTYDSRFL("PATIENT")=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
+8 SET QTYDSRFL("DRUG")=$GET(PSODRUG("IEN"))
+9 SET QTYDSRFL("QTY")=$GET(PSODIR("QTY"))
+10 FOR I=1:1:$LENGTH(QTYDSRFL("DOSE ORDERED"),U)-1
Begin DoDot:1
+11 SET QTYDSRFL("DOSE ORDERED",I)=$PIECE(QTYDSRFL("DOSE ORDERED"),U,I)
+12 SET QTYDSRFL("SCHEDULE",I)=$PIECE(QTYDSRFL("SCHEDULE"),U,I)
+13 SET ADUR=$PIECE(QTYDSRFL("DURATION"),U,I)
SET X=+ADUR_$EXTRACT($PIECE(ADUR," ",2))
+14 IF $LENGTH(X)
SET QTYDSRFL("DURATION",I)=X
+15 SET X=$EXTRACT($PIECE(ADUR,"~",2))
+16 IF $LENGTH(X)
SET QTYDSRFL("CONJUNCTION",I)=X
End DoDot:1
+17 DO QTYX^PSOSIG(.QTYDSRFL)
+18 SET DAYSUP=$GET(QTYDSRFL("DAYS SUPPLY"))
+19 QUIT DAYSUP
QTYCHECK(PSODRUG,PSODIR) ; return qty for days supply
+1 ; VAL: quantity
+2 NEW QTYARY,I,X,ADUR,ADURNM,IENS,VAL
+3 SET IENS=1_","_PSOIEN_","
+4 SET QTYARY("DOSE ORDERED")=$$GET1^DIQ(52.4921,IENS,9,"E")_"^"
+5 SET QTYARY("DURATION")=$$GET1^DIQ(52.4921,IENS,2,"E")
+6 SET QTYARY("SCHEDULE")=$$GET1^DIQ(52.4921,IENS,1,"E")
+7 SET QTYARY("DAYS SUPPLY")=$$GET1^DIQ(52.49,ERXIEN,20.2,"E")
+8 SET QTYARY("PATIENT")=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
+9 ;I $G(DRG) S QTYARY("DRUG")=DRG
+10 SET QTYARY("DRUG")=$GET(PSODRUG("IEN"))
+11 FOR I=1:1:$LENGTH(QTYARY("DOSE ORDERED"),U)-1
Begin DoDot:1
+12 SET QTYARY("DOSE ORDERED",I)=$PIECE(QTYARY("DOSE ORDERED"),U,I)_"^"
+13 SET QTYARY("SCHEDULE",I)=$PIECE(QTYARY("SCHEDULE"),U,I)
+14 SET ADUR=$PIECE(QTYARY("DURATION"),U,I)
SET ADURNM=$PIECE($PIECE(ADUR," ",2),"~")
+15 if ADURNM="MONTHS"
SET X=+ADUR_"L"
+16 if ADURNM'="MONTHS"
SET X=+ADUR_$EXTRACT($PIECE(ADUR," ",2))
+17 IF $LENGTH(X)
SET QTYARY("DURATION",I)=X
+18 SET X=$EXTRACT($PIECE(ADUR,"~",2))
+19 IF $LENGTH(X)
SET QTYARY("CONJUNCTION",I)=X
End DoDot:1
+20 DO QTYX^PSOSIG(.QTYARY)
+21 SET VAL=$GET(QTYARY("QTY"))
+22 QUIT VAL
