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

PSOERX1H.m

Go to the documentation of this file.
  1. PSOERX1H ;ALB/MFR - eRx Utilities ;Aug 14, 2020@12:43:34
  1. ;;7.0;OUTPATIENT PHARMACY;**700,746**;DEC 1997;Build 106
  1. ;
  1. ;Reference to NEW^TIUPNAPI in ICR #1911
  1. ;Reference to UPDATE^TIUSRVP in ICR #3535
  1. ;
  1. DEANOTE ; DEA Note for CS Digitally Signed eRx records
  1. S LINE=LINE+1 D SET^VALM10(LINE,"")
  1. S LINE=LINE+1 D SET^VALM10(LINE,"This prescription meets the requirements of the Drug Enforcement Administration")
  1. S LINE=LINE+1 D SET^VALM10(LINE,"(DEA) electronic prescribing for controlled substances rules (21 CFR Parts 1300,")
  1. S LINE=LINE+1 D SET^VALM10(LINE,"1304, 1306, & 1311).")
  1. Q
  1. ;
  1. BATCHREM(ERXIEN,REMVIEN,REMCOMM,TYPE) ; Batch Remove/Un-Remove for Additional eRx (Received Same Day, Patient and Provider)
  1. ;Input: ERXIEN - eRx IEN (Pointer to #52.49)
  1. ; REMVIEN - Remove Code IEN (Pointer to #52.45)
  1. ; REMCOMM - Remove/Un-Remove Comments
  1. ; TYPE - R: Remove | U:Un-Remove
  1. ;Output: Marked eRx either Remove/Un-Remove
  1. N MSGDTTM,EPRVIEN,EPATIEN,RECDAT,REMOVERX,REMVARR,MTYPE,NEWSTS,MSGTYPE,MBMSITE,RXSTAT,SKIPRX,TMPPSOIEN
  1. S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
  1. S MSGDTTM=$$GET1^DIQ(52.49,ERXIEN,.03,"I")
  1. S EPRVIEN=+$$GET1^DIQ(52.49,ERXIEN,2.1,"I")
  1. S EPATIEN=+$$GET1^DIQ(52.49,ERXIEN,.04,"I")
  1. S TMPPSOIEN=$G(PSOIEN)
  1. S RECDAT=MSGDTTM\1
  1. F S RECDAT=$O(^PS(52.49,"PAT2",EPATIEN,RECDAT)) Q:'RECDAT!((RECDAT\1)'=(MSGDTTM\1)) D
  1. . S SKIPRX=0,REMOVERX=0 F S REMOVERX=$O(^PS(52.49,"PAT2",EPATIEN,RECDAT,REMOVERX)) Q:'REMOVERX D
  1. . . I ERXIEN=REMOVERX Q
  1. . . I TYPE="R" D Q:$G(SKIPRX)
  1. . . . S RXSTAT=$$GET1^DIQ(52.49,REMOVERX,1,"E")
  1. . . . I RXSTAT="RJ"!(RXSTAT="RM")!($G(MBMSITE)&($E(RXSTAT,1,3)="REM"))!(RXSTAT="PR") S SKIPRX=1 Q
  1. . . . S PSOIEN=REMOVERX I '$$OPACCESS^PSOERXU7("PSO ERX REMOVE",DUZ,REMOVERX) S SKIPRX=1
  1. . . I TYPE="U" D Q:$G(SKIPRX)
  1. . . . I REMVIEN=$$GET1^DIQ(52.49,REMOVERX,1,"I") S SKIPRX=1 Q
  1. . . . D CHKSTA(REMOVERX) I RXSTAT'="RM" S SKIPRX=1
  1. . . I EPRVIEN'=$$GET1^DIQ(52.49,REMOVERX,2.1,"I") Q
  1. . . S REMVARR(REMOVERX)=REMOVERX
  1. I '$D(REMVARR) Q
  1. ;
  1. W !!,"The following prescriptions are from the same provider and received on the"
  1. W !,"same day:",!
  1. W !,"PROVIDER: "_$$GET1^DIQ(52.49,ERXIEN,2.1),?40,"eRx RECEIVED DATE: "_$$GET1^DIQ(52.49,ERXIEN,.03)
  1. D LSTERXS^PSOERPT1(.REMVARR,0,0)
  1. W !
  1. N X,Y,DIR,DTOUT,DUOUT,DIROUT,DIRUT
  1. S DIR(0)="Y",DIR("A")="Do you want to "
  1. I TYPE="R" S DIR("A")=DIR("A")_"'Remove' them - "_$$GET1^DIQ(52.45,REMVIEN,.01)
  1. I TYPE="U" S DIR("A")=DIR("A")_"'Un-Remove' them"
  1. S DIR("B")="No" D ^DIR I '$G(Y) Q
  1. ;
  1. W !,"Updating..."
  1. S REMOVERX=0
  1. F S REMOVERX=$O(REMVARR(REMOVERX)) Q:'REMOVERX D
  1. . S NEWSTS=REMVIEN
  1. . I TYPE="R" D UPDSTAT^PSOERXU1(REMOVERX,$S('$G(MBMSITE):"RM",1:$$GET1^DIQ(52.45,NEWSTS,.01)),REMCOMM)
  1. . I TYPE="U" D UPDSTAT^PSOERXU1(REMOVERX,$$GET1^DIQ(52.45,NEWSTS,.01),REMCOMM)
  1. H .5 W "done.",$C(7) H 1
  1. I $G(TMPPSOIEN) S PSOIEN=TMPPSOIEN
  1. Q
  1. ;
  1. CHKSTA(REMOVERX) ; check if status is RM or type is "REM"
  1. S STAIEN=+$G(^PS(52.49,REMOVERX,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. CREATEPN(PSOIEN,CRERXIEN,PNCOMM,CRMEDS,TIUTITLE) ;CREATE A PROGRESS NOTE FOR PATIENT
  1. ;Input : PSOIEN - Original eRx IEN (Pointer to #52.49)
  1. ; CRERXIEN - Change Request eRx IEN (Pointer to #52.49)
  1. ; PNCOMM - Additional Progress Note Comments
  1. ; Example: This is a sample addtional VA Pharmacy Progress Note Comments.
  1. ; CRMEDS - Input array passed by reference.
  1. ; This is an array of the eRx change request medication list.
  1. ; TIUTITLE - The TIU Document Definitiona name in File #8925.1
  1. ;Output: Update existing TIU Document for the Patient
  1. N TARGET,PSODFN,PSOPTNM,PSOTITL,PSOTIUDA,CRFDA
  1. ;
  1. I $G(PSOIEN)=""!($G(CRERXIEN)="")!($G(TIUTITLE)="") Q
  1. Q:",CX,CR,"'[(","_$P($$ERXMTYPE^PSOERSE1(CRERXIEN),"^")_",")
  1. S TARGET=$NA(^TMP("TIUP",$J)) K @TARGET
  1. I $$GET1^DIQ(52.49,CRERXIEN,.08,"I")="CR" W !,"Creating a new Progress Note..."
  1. D BUILDLST^PSOERSE4(TARGET,CRERXIEN,$G(PNCOMM))
  1. S PSOTITL=$$FIND1^DIC(8925.1,"","X",TIUTITLE,"B")
  1. Q:'+PSOTITL ;IF NO TITLE ON SYSTEM
  1. S PSODFN=$$GET1^DIQ(52.49,PSOIEN,.05,"I")
  1. S PSOPTNM=$P($G(^DPT(PSODFN,0)),U,1)
  1. D NEW^TIUPNAPI(.PSOTIUDA,PSODFN,DUZ,$$NOW^XLFDT,PSOTITL,$G(PSOCLNC))
  1. I +$G(PSOTIUDA)<0 D Q
  1. . I $$GET1^DIQ(52.49,CRERXIEN,.08,"I")="CR" W !,$G(IOINHI),"A problem was encountered while creating the Progress Note.",$G(IOINORM),!
  1. D UPDATEPN(+$G(PSOTIUDA),PSOIEN,.CRMEDS)
  1. S CRFDA(52.49,CRERXIEN_",",320.1)=+$G(PSOTIUDA) ;parent TIU IEN reference number for eRx Change Request
  1. I $G(PNCOMM)'="" S CRFDA(52.49,CRERXIEN_",",320.2)=$G(PNCOMM) ;VA Pharmacy Progress Notes
  1. D FILE^DIE(,"CRFDA") K CRFDA
  1. I $$GET1^DIQ(52.49,CRERXIEN,.08,"I")="CR" W "Done." H .5
  1. Q
  1. ;
  1. UPDATEPN(PSOTIUDA,PSOIEN,CRMEDS) ;Update existing patient progress notes
  1. ;Input : PSOTIUDA - TIU IEN (Pointer to #8925)
  1. ; PSOIEN - Original eRx IEN (Pointer to #52.49)
  1. ; CRMEDS - Input array passed by reference.
  1. ; This is an array of the eRx change request medication list.
  1. ;Output: Update existing TIU Document for the Patient
  1. ;
  1. N ERXRET,TIUX,SUBJECT,CNTR,ERXDRUG,DRUGNAME
  1. Q:$G(PSOTIUDA)=""
  1. S ERXDRUG=$$GET1^DIQ(52.49,PSOIEN,3.1,"E") ;get the drugname first from the original erx
  1. I '$L(ERXDRUG) S ERXDRUG=$$GETDRUG^PSOERXU5(PSOIEN)
  1. S SUBJECT=$P(ERXDRUG," ")
  1. I $O(CRMEDS(0)) D
  1. . S CNTR=0,SUBJECT=SUBJECT_":"
  1. . F S CNTR=$O(CRMEDS(CNTR)) Q:CNTR="" D
  1. . . S DRUGNAME=$P($P(CRMEDS(CNTR),U,2)," ")
  1. . . I $P(SUBJECT,":",2)'[DRUGNAME S SUBJECT=SUBJECT_DRUGNAME_","
  1. . S $E(SUBJECT,$L(SUBJECT))=""
  1. . I $L(SUBJECT)>80 S SUBJECT=$E(SUBJECT,1,77)_"..."
  1. ;
  1. S TIUX(.05)=$$FIND1^DIC(8925.6,"","X","COMPLETED","B")
  1. S TIUX(1501)=$$NOW^XLFDT()
  1. S TIUX(1502)=DUZ
  1. S TIUX(1503)=$$GET1^DIQ(200,+DUZ,20.2)
  1. S TIUX(1504)=$$GET1^DIQ(200,+DUZ,20.3)
  1. S TIUX(1505)="E"
  1. S TIUX(1701)=$S($L(SUBJECT)>80:$E(SUBJECT,1,61)_"...",1:SUBJECT)
  1. D UPDATE^TIUSRVP(.ERXRET,PSOTIUDA,.TIUX)
  1. Q
  1. ;
  1. DRUGHDR ;
  1. ; - Drug Matching Header Line
  1. I $G(SDERXFLG) D ;SDERXFLG is set in the PSOERSE1 routine
  1. . S AMATCH=$$GET1^DIQ(52.49,ERXIEN,1.4,"I")
  1. . S VALUSER=$$GET1^DIQ(52.49,ERXIEN,1.11,"E"),VALDTTM=$$GET1^DIQ(52.49,ERXIEN,1.12,"I")
  1. . I $$GET1^DIQ(52.49,ERXIEN,.08,"I")="RE",'VALDTTM D
  1. . . S MATCH="PREVIOUSLY MATCHED/VALIDATED (RENEWAL)"
  1. . E D
  1. . . S MATCH=$S(AMATCH=1:"AUTO-MATCHED",AMATCH=2:"AUTO-MATCHED/EDITED",VADRGIEN:"MANUALLY-MATCHED",1:"")
  1. . . I VALUSER'="",MATCH'="" S MATCH=MATCH_" | VALIDATED by "_$E(VALUSER,1,19)_" on "_$$FMTE^XLFDT(VALDTTM,"2Y")
  1. . . I MATCH="" S MATCH="NOT MATCHED"
  1. . S MATCH="DRUG "_MATCH I $L(MATCH)>78 S MATCH=$E(MATCH,1,78)
  1. . S HDR="",$E(HDR,(80-$L(MATCH))\2+1)=MATCH,$E(HDR,81)=""
  1. . S $E(MATCH,81)=""
  1. . S UNDERLN(LINE,1)=100 I HDR["/EDITED" S BLINKLN(LINE,$F(HDR,"/EDITED")-6)=6
  1. . D ADDLINE^PSOERUT0("LM",NMSPC,HDR,"")
  1. Q
  1. ;
  1. ADDPNOTE(LINE,PNCOMM) ;
  1. N DUZTITLE
  1. S LINE=LINE+1 S @TMPGBL@(LINE,0)=""
  1. S LINE=LINE+1 S @TMPGBL@(LINE,0)=PNCOMM
  1. S LINE=LINE+1 S @TMPGBL@(LINE,0)=""
  1. S LINE=LINE+1 S @TMPGBL@(LINE,0)="Provider's feedback pending."
  1. S LINE=LINE+1 S @TMPGBL@(LINE,0)=""
  1. Q
  1. ;
  1. CHECKREC(RECARY) ;check if there are any change requests made for this original eRx.
  1. ;Input : RECARY - A pass by reference variable name of the array that contain all eRx already been sent
  1. ;Output: SELCTREC - Selected option: N for New or R for Resend
  1. ; If R, it will be concatenated with the entry # to resend.
  1. N RECCNT,RECIEN,DDASH,ERXHUBID,ERXTYPE,ERXSTAT,ERXDTM,CNTR,RECENTRY
  1. I $D(RECARY) D
  1. . W !,"#",?5,"ERX ID",?21,"ERX TYPE",?40,"STATUS",?50,"DATE/TIME"
  1. . S $P(DDASH,"-",81)="" W !,DDASH
  1. . S CNTR=0
  1. . F S CNTR=$O(RECARY(CNTR)) Q:'CNTR D
  1. . . S RECIEN=RECARY(CNTR)
  1. . . S ERXHUBID=$P($G(^PS(52.49,RECIEN,0)),"^",1)
  1. . . S ERXTYPE=$$GET1^DIQ(52.49,RECIEN,.08,"E")
  1. . . S ERXSTAT=$$GET1^DIQ(52.49,RECIEN,1,"E")
  1. . . S ERXDTM=$$GET1^DIQ(52.49,RECIEN,.03,"I"),ERXDTM=$$FMTE^XLFDT(ERXDTM,1)
  1. . . W !,CNTR,?5,ERXHUBID,?21,ERXTYPE,?40,ERXSTAT,?50,ERXDTM
  1. . . S RECCNT=CNTR
  1. . S SELCTREC=$$SELCTREC
  1. . I SELCTREC="R" D
  1. . . K DIR S DIR(0)="LO^1:"_RECCNT,DIR("A")="Select Entry # to Resend"
  1. . . W ! D ^DIR I $D(DIRUT)!$D(DIROUT) Q
  1. . . S RECENTRY=+Y
  1. Q $G(SELCTREC)_$S($G(SELCTREC)="R":$G(RECENTRY),1:"")
  1. ;
  1. SELCTREC() ;prompt user to select REC
  1. ; N - New
  1. ; R - Resend existing REC
  1. N PSOASK,PSODIRA,PSODIRB,PSODIRH,PSODIR0
  1. W !
  1. S PSODIRA="Select Suggestion Option: (N)EW (R)ESEND: "
  1. S PSODIRB=""
  1. S PSODIRH="^D HELP^PSOERX1H"
  1. S PSODIR0="SOA^N:NEW;R:RESEND"
  1. S PSOASK=$$ANSWER(PSODIRA,PSODIRB,PSODIR0,PSODIRH)
  1. Q $G(PSOASK)
  1. ;
  1. ANSWER(PSODIRA,PSODIRB,PSODIR0,PSODIRH) ;
  1. ; Input:
  1. ; PSODIR0 - DIR(0) string
  1. ; PSODIRA - DIR("A") string
  1. ; PSODIRB - DIR("B") string
  1. ; PSODIRH - DIR("?") string
  1. ; Output:
  1. ; Function Value - Internal value returned from ^DIR or -1 if user
  1. ; up-arrows, double up-arrows or the read times out.
  1. N X,Y,Z,DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1. I $D(PSODIR0) S DIR(0)=PSODIR0
  1. I $D(PSODIRA) S DIR("A")=PSODIRA
  1. I $G(PSODIRB)]"" S DIR("B")=PSODIRB
  1. I $D(PSODIRH) S DIR("?")=PSODIRH,DIR("??")=PSODIRH
  1. D ^DIR
  1. S Z=$S($D(DTOUT):-2,$D(DUOUT):-1,$D(DIROUT):-1,1:"")
  1. I Z="" S Z=$S(Y=-1:"",X="@":"@",1:$P(Y,U)) Q Z
  1. I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1
  1. Q $S(X="@":"@",1:$P(Y,U))
  1. ;
  1. HELP ;REC help
  1. I X="?"!(X="??") D
  1. . W !!,"NEW - Adds a new Drug/SIG/Qty/Refills/Days Supply suggestion be sent to"
  1. . W " the prescriber as an alternative for this Change Request.",!
  1. . W !,"RESEND - Allow users to edit and resend an eRx Change Request."
  1. Q
  1. ;
  1. BUILDSUM(ERXIEN) ;Build the existing record of the erx that the user selected
  1. ;Input - eRx IEN (Pointer to #52.49)
  1. ;Output - None
  1. N IENS,RSNTXT,X,RET,INDEX,CODE,Y
  1. K INDEX S CODE=0
  1. F S CODE=$O(^PS(52.45,"TYPE","MRC",CODE)) Q:'CODE S INDEX($$GET1^DIQ(52.45,CODE,.01))=CODE
  1. S REACODE=$$GET1^DIQ(52.49,ERXIEN,315.1,"I"),Y=$$GET1^DIQ(52.49,ERXIEN,315.1,"E")
  1. I $G(REACODE)'=+$G(INDEX(Y)) S REASCODE=0,EXTSCODE="" K REATXT
  1. S REACODE=+$G(INDEX(Y)),EXTRCODE=$$GET1^DIQ(52.45,REACODE,.01)
  1. S IENS=$O(^PS(52.49,ERXIEN,316,0))
  1. I IENS D
  1. . S IENS=IENS_","_ERXIEN_","
  1. . S REASCODE=$$GET1^DIQ(52.49316,IENS,1,"I")
  1. . S EXTSCODE=$$GET1^DIQ(52.45,REASCODE,.01)
  1. . S EXTRCODE=$$GET1^DIQ(52.45,REACODE,.01)
  1. I '$G(IENS) S EXTSCODE=""
  1. S RSNTXT=$$GET1^DIQ(52.49,ERXIEN,317,,"REATXT")
  1. I $G(REATXT(1))'="" D
  1. . S X=REATXT(1) K RET D TXT2ARY^PSOERXD1(.RET,X," ",80)
  1. . K REATXT M REATXT=RET
  1. D MEDREQ(ERXIEN)
  1. Q
  1. ;
  1. MEDREQ(ERXIEN) ;Existing Medication Requested
  1. ;Input - eRx IEN (Pointer to #52.49)
  1. ;Output - CRMEDS array containing the medication requested
  1. N FILE,I,II,IENS,MEDREQ,DRUG,DRUGCODE,DRUGCODQ,SUBS,NOTE,QTYQUAL,QTY,NUMREFS,QUOM,CRMED
  1. K ^TMP("PSOCRSIG",$J),CRMEDS
  1. S II=0
  1. F S II=$O(^PS(52.49,ERXIEN,311,II)) Q:'II D ;Only requested medications
  1. . S FILE=52.49311,IENS=II_","_ERXIEN_","
  1. . K MEDREQ D GETS^DIQ(FILE,IENS,"**","IE","MEDREQ")
  1. . I $G(MEDREQ(FILE,IENS,.02,"I"))="R" D
  1. . . S DRUG=$G(MEDREQ(FILE,IENS,.03,"E"))
  1. . . S DRUGTYPE=$S($G(MEDREQ(FILE,IENS,1.2,"E"))="ND":"V",1:"E")
  1. . . S DRUGCODE=$G(MEDREQ(FILE,IENS,1.1,"E"))
  1. . . S DRUGCODQ=$G(MEDREQ(FILE,IENS,1.2,"E"))
  1. . . S SUBS=$G(MEDREQ(FILE,IENS,2.7,"I"))
  1. . . S NOTE=$G(MEDREQ(FILE,IENS,5,"E"))
  1. . . S QTYQUAL=$G(MEDREQ(FILE,IENS,5.2,"E"))
  1. . . S QTYUM=$G(MEDREQ(FILE,IENS,5.4,"E"))
  1. . . S QTY=$G(MEDREQ(FILE,IENS,2.1,"E"))
  1. . . S NUMREFS=$G(MEDREQ(FILE,IENS,2.8,"E"))
  1. . . S DAYSSUP=$G(MEDREQ(FILE,IENS,2.4,"E"))
  1. . . S QUOM=$G(MEDREQ(FILE,IENS,2.3,"I"))
  1. . . S QUOM=$$GET1^DIQ(52.45,QUOM,.02,"E")
  1. . . S CRMED=$O(CRMEDS(99),-1)+1
  1. . . S CRMEDS(CRMED)=DRUGTYPE_"^"_DRUG_"^"_DRUGCODE_"^"_DRUGCODQ_"^"_SUBS_"^"_QTY_"^"_QTYQUAL_"^"_QTYUM_"^"_DAYSSUP_"^"_NUMREFS
  1. . . S CRMEDS(CRMED,"NOTE")=NOTE
  1. . . S X=$$GET1^DIQ(FILE,IENS,8,,"ERXSIG")
  1. . . F I=1:1 Q:'$D(ERXSIG(I)) S ^TMP("PSOCRSIG",$J,I,0)=ERXSIG(I)
  1. . . M CRMEDS(CRMED,"SIG")=^TMP("PSOCRSIG",$J)
  1. Q
  1. ;
  1. ASKCONT ; display "Press <Enter> or '^' to exit" prompt
  1. N Z
  1. W !,$$CJ^XLFSTR("Press <Enter> or '^' to exit.",1)
  1. R Z:DTIME
  1. Q