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.
  1. 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
  1. ;
  1. Q
  1. DERX1(PSOIEN,PSOIENS,DFLAG) ;
  1. N EDRG,ERXDAT,ESIG,COMM,SUBS,DFORM,DSTR,QQUAL,POTUC,QTY,DAYS,REFILL,COMMARY,SIGARY,ERXRFLS,I,ERXDSUB
  1. N S2017,MIEN,MTYPE,SGLOOP,RESVAL,DFLG
  1. S S2017=$$GET1^DIQ(52.49,PSOIEN,312.1,"I")
  1. 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")
  1. S DFLG=$G(DFLAG,"")
  1. S MTYPE=$$GET1^DIQ(52.49,PSOIEN,.08,"I")
  1. S RESVAL=$$GET1^DIQ(52.49,PSOIEN,52.1,"I")
  1. S EDRG=$G(ERXDAT(52.49,PSOIENS,3.1,"E"))
  1. S ESIG=$G(ERXDAT(52.49,PSOIENS,7,"E"))
  1. S COMM=$G(ERXDAT(52.49,PSOIENS,8,"E"))
  1. S SUBS=$G(ERXDAT(52.49,PSOIENS,5.8,"E"))
  1. S DFORM=$G(ERXDAT(52.49,PSOIENS,41,"E"))
  1. S DSTR=$G(ERXDAT(52.49,PSOIENS,43,"E"))
  1. I 'S2017 S QQUAL=$G(ERXDAT(52.49,PSOIENS,5.2,"E"))
  1. I S2017 D
  1. .S MIEN=$O(^PS(52.49,PSOIEN,311,0))
  1. .S QQUAL=$$GET1^DIQ(52.49311,MIEN_","_PSOIEN_",",2.2,"I"),QQUAL=$$GET1^DIQ(52.45,QQUAL,.02,"E")
  1. S POTUC=$G(ERXDAT(52.49,PSOIENS,42,"E"))
  1. S QTY=$G(ERXDAT(52.49,PSOIENS,5.1,"E"))
  1. S DAYS=$G(ERXDAT(52.49,PSOIENS,5.5,"E"))
  1. S REFILL=$G(ERXDAT(52.49,PSOIENS,5.6,"E"))
  1. I 'S2017 D
  1. .I REFILL="" D
  1. ..S REFILL=$G(ERXDAT(52.49,PSOIENS,5.7,"I"))
  1. I MTYPE="RE",RESVAL="R",REFILL>0 S REFILL=REFILL-1
  1. D TXT2ARY^PSOERXD1(.SIGARY,ESIG,,69)
  1. D TXT2ARY^PSOERXD1(.COMMARY,COMM,,65)
  1. W !,"eRx Drug: "_EDRG_" "_$P($$ERXDRSCH^PSOERXUT(PSOIENS),"^",2)
  1. I 'S2017 D
  1. .W !,"eRx Sig: "
  1. .S I=0 F S I=$O(SIGARY(I)) Q:'I D
  1. ..W $S(I>1:" "_SIGARY(I),1:SIGARY(I)),!
  1. I '$L(ESIG) W !
  1. I S2017 D
  1. .W !,"eRx Sig:"
  1. .S SGLOOP=0 F S SGLOOP=$O(^PS(52.49,PSOIEN,311,MIEN,8,SGLOOP)) Q:'SGLOOP D
  1. ..W !,$G(^PS(52.49,PSOIEN,311,MIEN,8,SGLOOP,0))
  1. W !!,"eRx Notes: "
  1. S I=0 F S I=$O(COMMARY(I)) Q:'I D
  1. .W $S(I>1:" "_COMMARY(I),1:COMMARY(I)),!
  1. I '$L(COMM) W !
  1. Q:DFLG=1
  1. W "Drug Form: "_DFORM,?40,"Strength: "_DSTR
  1. W !,"Code List Qualifier: "_QQUAL,?40,"Quantity Unit of Measure: "_POTUC
  1. S ERXDSUB=$$GET1^DIQ(52.49,PSOIEN,5.8,"I")
  1. S ERXDSUB=$S(ERXDSUB=1:"NO",ERXDSUB=0:"YES",1:"")
  1. W !,"Substitutions? :"_ERXDSUB
  1. W !,"Qty: "_QTY,?25,"Days Supply: "_DAYS,?55,"Refills: "_REFILL,!
  1. Q
  1. REM ;
  1. N MBMSITE,DIR,Y,PSSRET,PSOIENS,REMIEN,REMSTA,REMTXT,ERXRMIEN,DIC,X,RXSTAT,FDA
  1. S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
  1. D FULL^VALM1
  1. S PSOIENS=PSOIEN_","
  1. S VALMBCK="R"
  1. 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
  1. .W !!,"Cannot remove a prescription with a status of 'Rejected', 'Removed',",!,"or 'Processed",!
  1. .S DIR(0)="E" D ^DIR
  1. 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: "
  1. D ^DIC K DIC
  1. I $P(Y,U)<1 Q
  1. S REMIEN=$P(Y,U),REMSTA=$P(Y,U,2)
  1. I +$G(REMIEN)<1 W !,"Removal reason code required!" S DIR(0)="E" D ^DIR K DIR Q
  1. K X,Y S DIR(0)="FO^1:70",DIR("A")="Additional Comments (Optional)" D ^DIR K DIR
  1. Q:Y="^"
  1. S REMTXT=$G(Y)
  1. 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
  1. Q:'Y
  1. I '$G(MBMSITE) D
  1. . K FDA S FDA(52.4919,"+1,"_PSOIENS,.01)=$$NOW^XLFDT,FDA(52.4919,"+1,"_PSOIENS,.02)=REMIEN
  1. . S FDA(52.4919,"+1,"_PSOIENS,.03)=DUZ,FDA(52.4919,"+1,"_PSOIENS,1)=REMTXT
  1. . D UPDATE^DIE(,"FDA") K FDA
  1. ; SET THE ERX STATUS TO THE REMOVAL REASON
  1. D UPDSTAT^PSOERXU1(PSOIEN,$S('$G(MBMSITE):"RM",1:REMSTA),REMTXT)
  1. ;allow user to perform a batch removal of eRx for a patient with the same provider if it comes in on the same day
  1. D BATCHREM^PSOERX1H(PSOIEN,REMIEN,REMTXT,"R") ; "R"-remove
  1. K @VALMAR D REF^PSOERSE1
  1. Q
  1. ; unremove eRx
  1. UNREM ;
  1. N DIR,Y,DA,DIE,DR,HCOMM,PSSRET,PSOIENS,REMIEN,REMSTA,REMTXT,ERXRMIEN,DIC,X,RXSTAT,SEQ,NEWSTA
  1. D FULL^VALM1
  1. S PSOIENS=PSOIEN_","
  1. S VALMBCK="R"
  1. D CHKSTA I RXSTAT'="RM" D Q
  1. .W !!,"Cannot Un-Remove a prescription that the status is not 'Removed'"
  1. .S DIR(0)="E" D ^DIR
  1. HLD W !
  1. S DIC="^PS(52.45,",DIC(0)="AEMQ",DIC("S")="I $E($P(^PS(52.45,+Y,0),U))=""H""",DIC("B")="HUR"
  1. S DIC("A")="Select HOLD reason code: " D ^DIC K DIC
  1. I $P(Y,U)<1 Q ;if user ^
  1. S REMIEN=$P(Y,U)
  1. I +$G(REMIEN)<0 W !,"HOLD reason code required!" S DIR(0)="E" D ^DIR K DIR G HLD
  1. ; Add comment in 52.4919
  1. S DIR(0)="52.4919,1",DIR("A")="Additional Comments (Optional)" D ^DIR K DIR
  1. I Y="^" Q
  1. S HCOMM=$G(Y)
  1. S DIR(0)="YO",DIR("A")="Would you like to 'Un-Remove' eRx #"_$$GET1^DIQ(52.49,PSOIEN,.01,"E")
  1. S DIR("B")="Y" D ^DIR K DIR
  1. Q:'Y
  1. D UPDSTAT^PSOERXU1(PSOIEN,$$GET1^DIQ(52.45,REMIEN,.01),HCOMM)
  1. S DR="1///"_REMIEN,DIE="^PS(52.49,",DA=PSOIEN D ^DIE
  1. D BATCHREM^PSOERX1H(PSOIEN,REMIEN,HCOMM,"U") ; "U" - Un-remove
  1. K @VALMAR D REF^PSOERSE1 ;Refresh screen
  1. Q
  1. CHKSTA ; check if status is RM or type is "REM"
  1. S STAIEN=+$G(^PS(52.49,PSOIEN,1)),RXSTAT=$P(^PS(52.45,STAIEN,0),"^",1)
  1. I RXSTAT="RM" K STAIEN Q
  1. S RXSTAT=$S($P(^PS(52.45,STAIEN,0),"^",3)="REM":"RM",1:"") K STAIEN
  1. Q
  1. ; reject eRx
  1. REJ ;
  1. N MBMSITE,DIR,DIC,Y,PSSRET,PSOIENS,REMTXT,REJSTA,FULLTXT,ERXRJIEN,REJDESC,REJIEN,REJTXT,X,RXSTAT
  1. S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
  1. D FULL^VALM1
  1. S PSOIENS=PSOIEN_","
  1. S VALMBCK="R"
  1. 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
  1. .W !!,"Cannot reject a prescription with a status of 'Rejected', 'Removed',",!,"or 'Processed",!
  1. .S DIR(0)="E" D ^DIR
  1. 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
  1. Q:'Y
  1. S DIC="^PS(52.45,",DIC(0)="AEMQ",DIC("S")="I $D(^PS(52.45,""TYPE"",""REJ"",Y))",DIC("A")="Select REJECT reason code: "
  1. D ^DIC K DIC
  1. I $P(Y,U)<1 W !,"Reject reason required! eRx NOT rejected." S DIR(0)="E" D ^DIR K DIR Q
  1. S REJIEN=$P(Y,U),REJSTA=$P(Y,U,2)
  1. K X,Y,DIR
  1. S DIR(0)="FO^1:200",DIR("A")="Additional Comments (Optional)" D ^DIR K DIR
  1. Q:Y="^"
  1. ; if reject reason was entered, log the activity.
  1. S REJTXT=Y
  1. S REJDESC=$$GET1^DIQ(52.45,REJIEN,.02,"E")
  1. S FULLTXT=REJSTA_" "_REJDESC_" - Additional Comments: "_REJTXT
  1. D POST^PSOERXO1(PSOIEN,.PSSRET,900,"",$E(FULLTXT,1,295))
  1. ; if the post was unsuccessful, inform the user and quit.
  1. I $P(PSSRET(0),U)<1 W !,$P(PSSRET(0),U,2) S DIR(0)="E" D ^DIR K DIR Q
  1. I $D(PSSRET("errorMessage")) W !,PSSRET("errorMessage") S DIR(0)="E" D ^DIR K DIR Q
  1. W !!,"Rejection message sent." S DIR(0)="E" D ^DIR K DIR
  1. ; if post is successful, change the eRx status and log the status activity.
  1. S FDA(52.4919,"+1,"_PSOIENS,.01)=$$NOW^XLFDT
  1. S FDA(52.4919,"+1,"_PSOIENS,.02)=REJIEN
  1. S FDA(52.4919,"+1,"_PSOIENS,.03)=DUZ
  1. S FDA(52.4919,"+1,"_PSOIENS,1)=REJTXT
  1. D UPDATE^DIE(,"FDA") K FDA
  1. ; SET THE ERX STATUS TO THE REJECT REASON
  1. D UPDSTAT^PSOERXU1(PSOIEN,"RJ")
  1. Q
  1. QTYDSRFL(ERXIEN,EDTYP) ;
  1. ; ERXIEN - ien from 52.49
  1. ; EDTYP:
  1. ; 1 - DAYS SUPPLY
  1. ; 2 - QUANTITY
  1. ; 3 - REFILLS
  1. ; 4 - SCHEDULE/DOSAGE EDIT
  1. N PSODRUG,PSODIR,ERXDRUG,PSODFN,ERXIENS,FDA,CLOZPAT,PSOY,PATSTAT,Y,DONE,DIR,ANS,NWDAYSUP,NEWQTY,PSODRG,PSONEW,PQUIT
  1. S ERXIENS=ERXIEN_","
  1. ; setup drug array
  1. S ERXDRUG=$$GET1^DIQ(52.49,ERXIEN,3.2,"I") Q:'ERXDRUG 0
  1. S PSOY=ERXDRUG,PSOY(0)=$G(^PSDRUG(ERXDRUG,0))
  1. D SET^PSODRG
  1. S PSODRG=ERXDRUG
  1. ; set quanity, days supply, refill, and patient information
  1. S PSODFN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
  1. S PSODIR("QTY")=$$GET1^DIQ(52.49,ERXIEN,20.1,"E")
  1. S PSODIR("DAYS SUPPLY")=$$GET1^DIQ(52.49,ERXIEN,20.2,"E")
  1. S PSODIR("# OF REFILLS")=$$GET1^DIQ(52.49,ERXIEN,20.5,"E")
  1. ; Decrement # of refills if this is a RxRenewalResponse with a response type of 'Replace'
  1. ; only decrement if field 20.5 and 5.6 are the same.
  1. I PSODIR("# OF REFILLS")>0,$$GET1^DIQ(52.49,ERXIEN,.08,"I")="RE",$$GET1^DIQ(52.49,ERXIEN,52.1,"I")="R" D
  1. .I PSODIR("# OF REFILLS")=$$GET1^DIQ(52.49,ERXIEN,5.6,"E") D
  1. ..S PSODIR("# OF REFILLS")=$G(PSODIR("# OF REFILLS"))-1
  1. S PSODIR("DFLG")=0
  1. S PATSTAT=$$GET1^DIQ(55,PSODFN,3,"E")
  1. I '$L(PATSTAT) D
  1. .S DONE=0
  1. .F D Q:DONE
  1. ..W !,"This is a required response. Enter '^' to exit"
  1. ..K DA S DIR(0)="55,3",DIR("A")="PATIENT STATUS" D ^DIR K DIR
  1. ..I +Y S DONE=1 Q
  1. ..I Y["^" S PQUIT=1,DONE=1 Q
  1. .S ANS=$P(Y,"^",1)
  1. .S FDA(55,PSODFN_",",3)=ANS
  1. .D FILE^DIE(,"FDA","ERR") K FDA,ERR
  1. S PSODIR("PATIENT STATUS")=$P($G(^PS(55,PSODFN,"PS")),U)
  1. S X=$G(PSODIR("PATIENT STATUS"))
  1. I X D
  1. .S DIC=53,DIC(0)="QXZ" D ^DIC K DIC
  1. .S:+Y>0 PSODIR("PTST NODE")=Y(0)
  1. I $P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1" D
  1. .S CLOZPAT=$O(^YSCL(603.01,"C",PSODFN,0)) Q:'CLOZPAT
  1. .S CLOZPAT=$P(^YSCL(603.01,CLOZPAT,0),"^",3)
  1. .S CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
  1. I EDTYP=1 D
  1. .S:'$G(PSODIR("DAYS SUPPLY")) NWDAYSUP=$$DAYSCHK(.PSODRUG,.PSODIR)
  1. .I $G(NWDAYSUP) S PSODIR("DAYS SUPPLY")=NWDAYSUP
  1. .D DAYS^PSODIR1(.PSODIR) D FILE
  1. .K QTYDSRFL
  1. I EDTYP=2 S PSONEW("FLD")=7 D
  1. .I $$GET1^DIQ(52.49,PSOIEN,20.1)'="" D
  1. ..S PSODIR("QTY")=$$GET1^DIQ(52.49,PSOIEN,20.1)
  1. .E S NEWQTY=$$QTYCHECK,PSODIR("QTY")=NEWQTY
  1. .D QTY^PSODIR1(.PSODIR),FILE
  1. .K QTYARY
  1. I EDTYP=3 S PSONEW("FLD")=9 D REFILL^PSODIR1(.PSODIR)
  1. I $G(PSODIR("DFLG"))=1 Q 1
  1. S QTYDSRFL("QTY")=$G(PSODIR("QTY"))
  1. D FILE
  1. Q 0
  1. FILE ;
  1. N NEWVAL
  1. S FDA(52.49,ERXIENS,20.1)=$G(PSODIR("QTY"))
  1. S FDA(52.49,ERXIENS,20.2)=$G(PSODIR("DAYS SUPPLY"))
  1. S FDA(52.49,ERXIENS,20.5)=$G(PSODIR("# OF REFILLS"))
  1. D FILE^DIE(,"FDA") K FDA
  1. ;Saving the eRx Audit Log for QTY, DAYS SUPPLY & # OF REFILLS
  1. I $G(PSODIR("QTY"))'="" S NEWVAL(1)=$G(PSODIR("QTY")) D AUDLOG^PSOERXUT(+PSOIEN,"QTY",DUZ,.NEWVAL)
  1. I $G(PSODIR("DAYS SUPPLY"))'="" S NEWVAL(1)=$G(PSODIR("DAYS SUPPLY")) D AUDLOG^PSOERXUT(+PSOIEN,"DAYS SUPPLY",DUZ,.NEWVAL)
  1. I $G(PSODIR("# OF REFILLS"))'="" S NEWVAL(1)=$G(PSODIR("# OF REFILLS")) D AUDLOG^PSOERXUT(+PSOIEN,"# OF REFILLS",DUZ,.NEWVAL)
  1. Q
  1. DAYSCHK(PSODRUG,PSODIR) ; auto calculate days supply based off quantity.
  1. N QTYDSRFL,DAYSUP,I,ADUR,IENS
  1. N QTYDSRFL,VAL,DOSE
  1. F DOSE=1:1 Q:'$D(^PS(52.49,PSOIEN,21,DOSE)) D
  1. . S QTYDSRFL("DOSE ORDERED",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",9,"E")_"^"
  1. . S QTYDSRFL("SCHEDULE",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",1,"E")
  1. . S QTYDSRFL("DURATION",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",2,"E")
  1. . S QTYDSRFL("CONJUNCTION",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",6,"E")
  1. I '$G(QTYDSRFL("DOSE ORDERED",1)) Q 0
  1. S QTYDSRFL("PATIENT")=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
  1. S QTYDSRFL("DRUG")=$G(PSODRUG("IEN"))
  1. S QTYDSRFL("QTY")=$G(PSODIR("QTY"))
  1. D QTYX^PSOSIG(.QTYDSRFL)
  1. S DAYSUP=$G(QTYDSRFL("DAYS SUPPLY"))
  1. Q DAYSUP
  1. ;
  1. QTYCHECK(PSODRUG,PSODIR) ; return qty for days supply
  1. ; VAL: quantity
  1. N QTYARY,VAL,DOSE
  1. F DOSE=1:1 Q:'$D(^PS(52.49,PSOIEN,21,DOSE)) D
  1. . S QTYARY("DOSE ORDERED",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",9,"E")_"^"
  1. . S QTYARY("SCHEDULE",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",1,"E")
  1. . S QTYARY("DURATION",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",2,"E")
  1. . S QTYARY("CONJUNCTION",DOSE)=$$GET1^DIQ(52.4921,DOSE_","_PSOIEN_",",6,"E")
  1. I '$G(QTYARY("DOSE ORDERED",1)) Q ""
  1. S QTYARY("PATIENT")=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
  1. S QTYARY("DRUG")=$G(PSODRUG("IEN"))
  1. S QTYARY("DAYS SUPPLY")=$$GET1^DIQ(52.49,PSOIEN,20.2,"E")
  1. D QTYX^PSOSIG(.QTYARY)
  1. S VAL=$G(QTYARY("QTY"))
  1. Q VAL