Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOERXU4

PSOERXU4.m

Go to the documentation of this file.
PSOERXU4 ;ALB/BLB - eRx utilities ; 12/21/2020
 ;;7.0;OUTPATIENT PHARMACY;**520,508,551,581,635,617,651,700**;DEC 1997;Build 261
 ;
 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
 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 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=$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
 ; SET THE ERX STATUS TO THE REMOVAL REASON
 D UPDSTAT^PSOERXU1(PSOIEN,$S('$G(MBMSITE):"RM",1:REMSTA),REMTXT)
 K @VALMAR D INIT^PSOERX1
 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 W !,"HOLD reason code required!" S DIR(0)="E" D ^DIR K DIR G HLD
 S REMIEN=$P(Y,U)
 ; 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
 K @VALMAR D INIT^PSOERX1
 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")
 ; 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("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($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 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