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