PSOERCR0 ;BHAM/MR - eRx Change Request Functionality ; 11/14/2019 3:46pm
;;7.0;OUTPATIENT PHARMACY;**746**;DEC 1997;Build 106
;
EN ; Action Entry Point
N ERXSTS,CRMEDS,CRMED,MED,MEDCNT,DIR,Y,X,INDEX,CODE,HLP,DESC,I,REACODE,EXTRCODE,REASCODE,EXTSCODE,LINE,DIRUT,DIROUT,DUOUT,SELCTREC,FDAPNCOM
N REATXT,DIC,DWLW,DWPK,DIWESUB,X,DELMED,TMPARR,WRPHELP,HELP,DESC,LINE,PSOQUIT,ERROR,FINISH,PSSRET,HUBID,VADAT,NPIINST,GBL,RECARY,RTHID
N INSTNAME,STATION,INSTNPI,DIV,NOTE2PRV,REASONTXT,RELERX,CRFOUND,PNCOMM,CODETYPE,DDWFLAGS,MESSID,CRERXIEN,NPLEN,RECFOUND,ORGRXIEN,TMPIEN
I '$G(ERXIEN) Q
D FULL^VALM1 S VALMBCK="R"
;
S NPIINST=$$GET1^DIQ(59,PSOSITE,101,"I"),INSTNAME=$$NAME^XUAF4(NPIINST),STATION=$$WHAT^XUAF4(NPIINST,99)
S INSTNPI=$$NPI^XUSNPI("Organization_ID",NPIINST) I $P(INSTNPI,U)<1 D
. S INSTNPI=$$WHAT^XUAF4(NPIINST,41.99)
I '$G(INSTNPI) W !!,"Institution NPI Number could not be found. Cannot create Change Request." D DIRE^PSOERXX1 Q
;
I '$D(^XUSEC("PSDRPH",DUZ)),'($D(^XUSEC("PSO ERX ADV TECH",DUZ))) D Q
. W !!,$G(IOINHI),"You do not have the appropriate key to access this option.",!,$G(IOINORM) D DIRE^PSOERXX1
;
S SELCTREC=""
I $G(RESEND) S RECFOUND=0,ORGRXIEN="" D RESENDEC K RECFOUND Q ;entry point for PSO ERX RESEND CHANGE REQUEST Protocol action
;
S ERXSTS=$$GET1^DIQ(52.49,ERXIEN,1,"E")
I $$GET1^DIQ(52.49,ERXIEN,.08,"I")'="N"!(ERXSTS="RJ")!(ERXSTS="RM")!(ERXSTS="CAN")!(ERXSTS="CAC")!($E(ERXSTS)="H")!(ERXSTS="CXQ") D Q
. W !!,$G(IOINHI),"Change Request may not be used for this record type.",!,$G(IOINORM) D DIRE^PSOERXX1
;
I '$$GET1^DIQ(52.49,ERXIEN,1.7,"I") D Q
. W !!,$G(IOINHI),"The VistA Patient must be matched and validated first.",!,$G(IOINORM) D DIRE^PSOERXX1
;
D DSPERX^PSOERUT(ERXIEN)
;
S (RELERX,CRFOUND)=0 F S RELERX=$O(^PS(52.49,ERXIEN,201,"B",RELERX)) Q:'RELERX D
. I $$GET1^DIQ(52.49,RELERX,.08,"I")="CR" S CRFOUND=CRFOUND+1,RECARY(CRFOUND)=RELERX
I CRFOUND>0 D Q:($G(SELCTREC)'="N")&($G(SELCTREC)'="R")
. W !!,$G(IOINHI),CRFOUND," Rx Change Request",$S(CRFOUND>1:"s have",1:" has")," already been sent for this eRx.",$G(IOINORM)
. W !
. ;Display any change requests made for this original eRx, so they can either create a brand new ERX change request or resend the existing one.
. S SELCTREC=$$CHECKREC^PSOERX1H(.RECARY)
. I $E(SELCTREC,1)="R" S RECENTRY=$E(SELCTREC,2),SELCTREC=$E(SELCTREC,1)
I $G(SELCTREC)="R" D Q:+$G(RECENTRY)<1!(+$G(RECFOUND))
. I +$G(RECENTRY)>0 S RECFOUND=0,ORGRXIEN="",ERXIEN=$G(RECARY(RECENTRY)) D RESENDEC
;
EN1 ; Loop Entry Point
K INDEX S CODE=0 K DIR S DIR(0)="SO^",HLP=0,DIR("?")=" "
F S CODE=$O(^PS(52.45,"TYPE","MRC",CODE)) Q:'CODE D
. S INDEX($$GET1^DIQ(52.45,CODE,.01))=CODE
. S DIR(0)=DIR(0)_$$GET1^DIQ(52.45,CODE,.01)_":"_$$GET1^DIQ(52.45,CODE,.02)_";"
. S HLP=HLP+1,DIR("?",HLP)=" "_$$GET1^DIQ(52.45,CODE,.01)_" - "
. K DESC S X=$$GET1^DIQ(52.45,CODE,1,"","DESC") I '$D(DESC) Q
. S HELP=$G(DESC(1)) F I=2:1 Q:'$D(DESC(I)) S HELP=HELP_" "_DESC(I)
. K WRPHELP D WRAP^PSOERUT(HELP,70,.WRPHELP)
. F I=1:1 Q:'$D(WRPHELP(I)) S:I>1 HLP=HLP+1 S $E(DIR("?",HLP),10)=$G(WRPHELP(I,0))
S DIR("A")="CHANGE REQUEST CODE" I $G(REACODE) S DIR("B")=$$GET1^DIQ(52.45,REACODE,.01)
D ^DIR I $D(DIRUT)!$D(DIROUT) Q
I Y="G",'$$GET1^DIQ(52.49,ERXIEN,5.8,"I") D G EN1
. W !!,$G(IOINHI),"Substitutions are already allowed by prescriber for this eRx.",$G(IOINORM),$C(7)
I $G(REACODE)'=+$G(INDEX(Y)) S REASCODE=0,EXTSCODE="" K REATXT
S REACODE=+$G(INDEX(Y)),EXTRCODE=$$GET1^DIQ(52.45,REACODE,.01)
W ! I '$D(REATXT) S X=$$GET1^DIQ(52.45,REACODE,20,,"REATXT")
;
S PSOQUIT=0
I (" D U "[(" "_EXTRCODE_" ")) D I $G(PSOQUIT) G EXIT
. K INDEX K DIR S DIR(0)="SO^",DIR("L",1)=" Select one of the following:",DIR("L",2)=" "
. S HLP=0,LINE=2,DIR("L")=" "_$S(EXTRCODE="D":"Type '?' for the full list. ",1:"")
. S DIR("?")="^D HELP^PSOERCR0"
. S CODETYPE=$S(EXTRCODE="D":"REA",1:"MRSC")
. F S CODE=$O(^PS(52.45,"TYPE",CODETYPE,CODE)) Q:'CODE D
. . S INDEX($$GET1^DIQ(52.45,CODE,.01))=CODE
. . S DIR(0)=DIR(0)_$$GET1^DIQ(52.45,CODE,.01)_":"_$$GET1^DIQ(52.45,CODE,.02)_";"
. . I EXTRCODE="U"!(EXTRCODE="D"&(",DA,DD,HD,LD,MS,TD,AR,DI,DR,ID,UD,PS,SX,TP,"[(","_$$GET1^DIQ(52.45,CODE,.01)_","))) D
. . . S LINE=LINE+1,DIR("L",LINE)=" "_$S(EXTRCODE="D":" ",1:"")_$$GET1^DIQ(52.45,CODE,.01)_" - "_$$GET1^DIQ(52.45,CODE,.02)
. . S HLP=HLP+1,DIR("?",HLP)=" "_$S(EXTRCODE="D":" ",1:"")_$$GET1^DIQ(52.45,CODE,.01)_" - "_$$GET1^DIQ(52.45,CODE,.02)
. I EXTRCODE="D" S LINE=LINE+1,DIR("L",LINE)=" "
. S DIR("A")="CHANGE REQUEST SUB-CODE" I $G(REASCODE) S DIR("B")=$$GET1^DIQ(52.45,REASCODE,.01)
. D ^DIR I $D(DIRUT)!$D(DIROUT) S PSOQUIT=1 Q
. I $G(REASCODE)'=+$G(INDEX(Y)) K REATXT
. S REASCODE=+$G(INDEX(Y)),EXTSCODE=$$GET1^DIQ(52.45,REASCODE,.01)
. W ! I '$D(REATXT) S X=$$GET1^DIQ(52.45,REASCODE,20,,"REATXT")
;
NOTES ; NOTE TO PROVIDER Prompt (Max 260 characters)
K ^TMP("PSOERN2P",$J)
F I=1:1 Q:'$D(REATXT(I)) S ^TMP("PSOERN2P",$J,I,0)=REATXT(I)
S PSOQUIT=0
F I=1:1 S FINISH=1 D I FINISH!PSOQUIT Q
. S NPLEN=0,DIC="^TMP(""PSOERN2P"""_",$J,"
. S DWLW=80,DWPK=1
. S DIWESUB="NOTE TO PROVIDER" W !,DIWESUB,":"
. D EN^DIWE I $G(DUOUT) S PSOQUIT=1 Q
. F I=1:1 Q:'$D(^TMP("PSOERN2P",$J,I)) D I 'FINISH Q
. . S X=^TMP("PSOERN2P",$J,I,0)
. . S NPLEN=NPLEN+$L(X) I NPLEN>260 W !!,$G(IOINHI),"The maximum length for this note is 260 characters.",$G(IOINORM),$C(7) S FINISH=0 D PAUSE^PSOSPMU1 Q
. . I X["[DRUG_NAME]" W !!,$G(IOINHI),"The place holder [DRUG_NAME] must be replaced before proceeding.",$G(IOINORM),$C(7) S FINISH=0 D PAUSE^PSOSPMU1 Q
. . I X["[ADD_TEXT_HERE]" W !!,$G(IOINHI),"The place holder [ADD_TEXT_HERE] must be replaced before proceeding.",$G(IOINORM),$C(7) S FINISH=0 D PAUSE^PSOSPMU1 Q
I PSOQUIT G EXIT
K REATXT F I=1:1 Q:'$D(^TMP("PSOERN2P",$J,I)) S REATXT(I)=$G(^TMP("PSOERN2P",$J,I,0))
;
I (" P U "'[(" "_EXTRCODE_" ")) D I $G(PSOQUIT) G EXIT
. S (LINE,FINISH,ERROR,PSOQUIT)=0 W !
. F I=1:1 D I FINISH!PSOQUIT Q
. . S (MED,MEDCNT)=0 F S MED=$O(CRMEDS(MED)) Q:'MED S MEDCNT=MEDCNT+1
. . D:'$G(ERROR) LISTMEDS S ERROR=0
. . K DIR S DIR(0)="SOA^N:NEW;"_$S(MEDCNT>0:"E:EDIT;D:DELETE;",1:"")_"F:FINISH"
. . S DIR("A")="Select Drug Suggestion Option: (N)EW "_$S(MEDCNT>0:"(E)DIT (D)ELETE ",1:"")_"(F)INISH: "
. . S II=0
. . S II=II+1,DIR("?",II)=" NEW - Adds a new Drug/SIG/Qty/Refills/Days Supply suggestion be sent to"
. . S II=II+1,DIR("?",II)=" the prescriber as an alternative for this Change Request."
. . I MEDCNT D
. . . S II=II+1,DIR("?",II)=" EDIT - Edits a previously entered suggestion"
. . . S II=II+1,DIR("?",II)=" DELETE - Deletes a previously entered suggestion"
. . S II=II+1,DIR("?",II)=" FINISH - Finishes entering suggestions and continue on to sending the"
. . S DIR("?")=" Change Request."
. . D ^DIR I X="^" S PSOQUIT=1 Q
. . I $D(DIROUT)!$G(DIRUT) S FINISH=1 Q
. . I Y="N" D Q
. . . S CRMED=$O(CRMEDS(99),-1)+1 I CRMED>9 W !!,"A maximum of 9 Drug Suggestion can be entered!",!,$C(7) S ERROR=1 Q
. . . W ! D DSPERX^PSOERUT(ERXIEN) D EN^PSOERCR1
. . I Y="E" D W ! Q
. . . K DIR S DIR(0)="L^1:"_MEDCNT,DIR("A")="Select Entry # to Edit"
. . . W ! D ^DIR I $D(DIRUT)!$D(DIROUT) Q
. . . S CRMED=+Y D EN^PSOERCR1
. . I Y="F" S FINISH=1 Q
. . I Y="D" D W ! Q
. . . K DIR S DIR(0)="L^1:"_MEDCNT,DIR("A")="Select Entry # to Delete"
. . . W ! D ^DIR I $D(DIRUT)!$D(DIROUT) Q
. . . S DELMED=+Y
. . . K DIR S DIR(0)="SA^Y:YES;N:NO",DIR("B")="NO"
. . . S DIR("A")="Confirm? "
. . . W ! D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y="N") W ! Q
. . . W !?64,"Deleting..." K CRMEDS(DELMED) H .5 W "Ok.",! H .5
. . . K TMPARR M TMPARR=CRMEDS K CRMEDS S MED=0 F I=1:1 S MED=$O(TMPARR(MED)) Q:'MED M CRMEDS(I)=TMPARR(MED)
;
PNCOMM ; Patient Progress Note Comments
K DIR,DIRUT S DIR(0)="FO^1:210",DIR("A")="VA PROGRESS NOTE COMMENTS (Optional)" I $G(PNCOMM)'="" S DIR("B")=PNCOMM
S DIR("?")="This text will be appended at the bottom of the Patient Progress Notes that will be created after this Rx Change Request is submitted."
W ! D ^DIR I Y="^" G EXIT
S PNCOMM=Y
;
I EXTRCODE'="U",'$D(REATXT),'$O(CRMEDS(0)) D G NOTES
. W !!,$G(IOINHI),"You must enter either Notes to Provider or at least one Drug Suggestion",$G(IOINORM),$C(7)
. W !,$G(IOINHI),"before proceeding.",$G(IOINORM),$C(7) D PAUSE^PSOSPMU1
;
RESENDEC ;Allows a user to resend an eRx Change request in the Inbound eRx application
I $G(RESEND)!($G(SELCTREC)="R") D Q:'$G(RECFOUND)
. Q:RECFOUND ;only build existing record once
. I $$GET1^DIQ(52.49,ERXIEN,.08,"I")="CR" D Q ;resend eRx ONLY if message type is 'CR' FOR RXCHANGEREQUEST
. . S ORGRXIEN=$P(^PS(52.49,ERXIEN,0),"^",14),ORGRXIEN=$O(^PS(52.49,"B",ORGRXIEN,0)),TMPIEN=PSOIEN
. . S RECFOUND=1,PNCOMM=""
. . D BUILDSUM^PSOERX1H(ERXIEN)
. . K PNCOMM S PNCOMM=$$GET1^DIQ(52.49,ERXIEN,320.2) ;CH REQ PROGRESS NOTE COMMENT
. W !!,$G(IOINHI),"Resend Change Request may not be used for this record type.",$G(IOINORM),! D ASKCONT^PSOERX1H
D SUMMARY
;
W ! K DIR S DIR(0)="SA^Y:YES;N:NO",DIR("B")="NO"
S DIR("A")="Would you like to edit this Rx Change Request before sending it? "
D ^DIR I $D(DIRUT)!$D(DIROUT) G EXIT
I $G(Y)="Y" G EN1
;
W ! K DIR S DIR(0)="SA^Y:YES;N:NO",DIR("B")="YES"
S DIR("A")="Would you like to send this Rx Change Request? "
D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y="N") G EXIT
;
W !!,"Sending Request to Provider..."
; Building & Sending RxChangeRequest Message to the Provider
S GBL=$NA(^TMP("PSOERCR0",$J)) K @GBL
S CNT=0
;
I $G(RESEND)!($G(SELCTREC)="R") S ERXIEN=$G(ORGRXIEN) ;send the original erx instead of the new CRN type eRx.
;
D MSG^PSOERXOA(.GBL,1)
; Header
S MESSID=$$HEADER^PSOERXOA(.GBL,ERXIEN)
; Body Header
D BHF^PSOERXOA(.GBL,1)
; Request Type Header
D RTYPE^PSOERXOA(.GBL,"RxChangeRequest",1)
; RxChangeRequest Code/Sub-Code
D BL^PSOERXOA(GBL,.CNT,"MessageRequestCode",EXTRCODE)
D BL^PSOERXOA(GBL,.CNT,"MessageRequestSubCode",EXTSCODE)
S REASONTXT="" F I=1:1 Q:'$D(REATXT(I)) S REASONTXT=REASONTXT_" "_REATXT(I)
S $E(REASONTXT,1)=""
D BL^PSOERXOA(GBL,.CNT,"ChangeReasonText",REASONTXT)
;
; call prompting logic
; RETURN RECEIPT, REQUESTREFERENCENUMBER, URGENCY INDICATOR CODE, FOLLLOWUP REQUEST
D OALLERGY^PSOERXOB(GBL,.CNT,ERXIEN) ;(ONLY 1 INSTANCE - XSD IS 0..1)
D OBENEFIT^PSOERXOB(GBL,.CNT,ERXIEN) ;outbound benefits coordination section
D OFAC^PSOERXOB(GBL,.CNT,ERXIEN) ;outbound facility segment
D PATIENT^PSOERXOC(GBL,.CNT,PSOSITE,ERXIEN) ;outbound patient segment
D OPHARM^PSOERXOD(GBL,.CNT,PSOSITE,ERXIEN) ; brad/steve
D PERSON^PSOERXOE(GBL,.CNT,PSOSITE,ERXIEN,"PR") ; PRESCRIBER - brad/steve
D OOBSERVE^PSOERXOB(GBL,.CNT,ERXIEN) ;outbound observation segment
; Bulding the <MedicationPrescribed> Segment
D MEDS^PSOERXOG(GBL,.CNT,ERXIEN,"P")
; Bulding the <MedicationRequested> Segment
I $O(CRMEDS(0)) D MEDREQ^PSOERXON(GBL,.CNT,.CRMEDS)
D PERSON^PSOERXOE(GBL,.CNT,PSOSITE,ERXIEN,"FU") ; FOLLOW UP PRESCRIBER
D RTYPE^PSOERXOA(GBL,"RxChangeRequest",2)
D BHF^PSOERXOA(.GBL,2)
D MSG^PSOERXOA(.GBL,2)
;
; send message
S DIV=INSTNAME_"^"_INSTNPI
S RXIEN=$$GET1^DIQ(52.49,ERXIEN,.13,"I")
S PSSRET=$$RESTPOST^PSOERXO1(.PSSRET,.GBL)
; if the post was unsuccessful, inform the user and quit.
K DIR 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") K DIR S DIR(0)="E" D ^DIR K DIR Q
S HUBID=$G(PSSRET("outboundMsgId")) I 'HUBID W !,"The eRx Processing hub did not return a Hub identification number." S DIR(0)="E" D ^DIR K DIR Q 0
; vista generated message will be V12345 (V concatenated to the hubId)
S HUBID="V"_HUBID
N RES,I,XXL1
S I=0 F S I=$O(@GBL@(I)) Q:'I D
. S XXL1=$G(XXL1)_$G(@GBL@(I,0))
S VADAT=DUZ
S RTHID=$$GET1^DIQ(52.49,ERXIEN,.01,"E")
S HUBID=HUBID_U_U_RTHID
W "Done." H .5
D INCERX^PSOERXI1(.RES,.XXL1,"","","",STATION,DIV,HUBID,"","",VADAT,"")
I $P(RES,U)=0 D
. W !,"A problem was encountered while trying to file the RxChange request."
. W !,"RxChange Request was not filed in vista."
. W !!,"ERROR: "_$P(RES,U,2)
. K DIR S DIR(0)="E" D ^DIR K DIR
I '$G(RESEND)!($G(SELCTREC)'="R") D UPDSTAT^PSOERXU1(ERXIEN,"HC")
;
; Creating Patient Progress Note
I $P(HUBID,"^")'="" D
. S CRERXIEN=$O(^PS(52.49,"B",$P(HUBID,"^"),0))
. D CREATEPN^PSOERX1H(ERXIEN,CRERXIEN,PNCOMM,.CRMEDS,"ERX RX CHANGE REQUEST NOTE")
I $G(RESEND)!($G(SELCTREC)="R") S ERXIEN=TMPIEN ;put back the ERXIEN used during the entry point
;
K @GBL
;
W ! D DIRE^PSOERXX1
;
D REF^PSOERSE1
;
Q
;
EXIT ; Exit the action
I $G(SELCTREC)="R"!($G(RESEND)) S ERXIEN=TMPIEN ;put back the ERXIEN used during the entry point
I '$O(CRMEDS(0)) Q
W ! K DIR S DIR(0)="SA^Y:YES;N:NO",DIR("B")="YES"
S DIR("A")="Are you sure you want to exit (ALL INFORMATION ENTERED WILL BE LOST)? "
D ^DIR I Y="N" G EN1
Q
;
DEFREA(REACODE) ; Returns the Default Change Request Reason Text
; Input: REACODE - Pointer to the ERX SERVICE REASON CODES (#52.45)
;Output: DEFREA - Default Change Request Reason Text for the Code passed in
N DEFREA,I,X,REATXT
S DEFREA="",X=$$GET1^DIQ(52.45,REACODE,20,,"REATXT")
F I=1:1 Q:'$D(REATXT(I)) S DEFREA=DEFREA_" "_$G(REATXT(I))
S $E(DEFREA)=""
Q DEFREA
;
HELP ; Sub-Code List
N I,XX W !," Complete List of Change Request Sub-Codes:",!
F I=1:1 Q:'$D(DIR("?",I)) W !,DIR("?",I) I '(I#20) R !,"Type <Enter> to continue or '^' to exit:",XX:DTIME I XX="^" Q
D:(I#20) PAUSE^PSOSPMU1
Q
;
LISTMEDS ; Display Meds Already entered
N XX,Z,MED,Y,SIG
;D DSPERX^PSOERUT(ERXIEN)
I '$O(CRMEDS(0)) Q
;
S LINE=1 D PAUSE W ! W:$D(IOUON) IOUON W "# DRUG",?50,"QTY",?55,"# REFS",?63,"DAYS SUPPLY",?76,"SUBS" W:$D(IOUOFF) IOUOFF
I '$D(IOUON) S $P(XX,"-",81)="" D PAUSE W !,XX,! S LINE=2
S MED=0 F S MED=$O(CRMEDS(MED)) Q:'MED D
. S Z=$G(CRMEDS(MED))
. I MED=1 W !
. D PAUSE W MED,?3,"(",$P(Z,"^"),")",$E($P(Z,"^",2),1,43),?50,$J($P(Z,"^",6),3),?57,$J($P(Z,"^",10),2)
. W ?65,$J($P(Z,"^",9),4),?76,$S($P(Z,"^",5):"NO",1:"YES"),!
. I $O(CRMEDS(MED,"SIG",0)) D
. . D PAUSE W ?3 W:$D(IOUON) IOUON W "Sig :" W:$D(IOUOFF) IOUOFF
. . S SIG="" F I=1:1 Q:'$D(CRMEDS(MED,"SIG",I)) S SIG=SIG_CRMEDS(MED,"SIG",I,0)_" "
. . F I=1:1 Q:(SIG="") W ?9,$E(SIG,1,70),! S SIG=$E(SIG,71,999) D PAUSE
. I $G(CRMEDS(MED,"NOTE"))'="" D
. . D PAUSE W ?3 W:$D(IOUON) IOUON W "Note:" W:$D(IOUOFF) IOUOFF S NOTE=CRMEDS(MED,"NOTE")
. . F I=1:1 Q:NOTE="" W ?9,$E(NOTE,1,71),! S NOTE=$E(NOTE,72,999) D PAUSE
Q
;
SUMMARY ; Displays a Summary of the RxChangeRequest
N HIGH,NORM,XX,ERXSIG,NOTES,MEDIEN,QTYQUAL
;
W @IOF S LINE=0
S HIGH=$G(IOINHI),NORM=$G(IOINORM)
W ! D PAUSE S $P(XX,$S($D(IOUON):" ",1:"-"),81)="",$E(XX,27,51)="RX CHANGE REQUEST SUMMARY" W !,$G(IOUON),XX,$G(IOUOFF)
W ! D PAUSE W "Change Request Reason Code: ",HIGH,$$GET1^DIQ(52.45,+$G(REACODE),.01)," - ",$$GET1^DIQ(52.45,+$G(REACODE),.02),NORM
I $G(REASCODE) D
. W ! D PAUSE W "Change Request Reason Sub-Code: ",HIGH,$$GET1^DIQ(52.45,+$G(REASCODE),.01)," - ",$$GET1^DIQ(52.45,+$G(REASCODE),.02),NORM
;
W ! D PAUSE W "Note to Provider: " F I=1:1 Q:'$D(REATXT(I)) W !,HIGH,REATXT(I),NORM
;
W ! D LISTMEDS
;
I ($G(PNCOMM)'="")!($G(RESEND))!($G(SELCTREC)="R") W ! D PAUSE W "VA Progress Note Comment: ",!,HIGH,PNCOMM,NORM,!
;
S XX="",$P(XX,$S($D(IOUON):" ",1:"-"),81)="" W $G(IOUON),XX,$G(IOUOFF)
Q
;
PAUSE ; Decides whether to pause the listing or not
N XX,I,Y,X
S LINE=LINE+1
S Y=$S($G(IOSL):IOSL,1:24)-3 I (LINE#Y) Q
W "Press Return to continue" R X:60
F I=1:1:26 W $C(8)
S $P(XX," ",26)="" W XX
F I=1:1:26 W $C(8)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERCR0 15875 printed Sep 15, 2024@21:51:42 Page 2
PSOERCR0 ;BHAM/MR - eRx Change Request Functionality ; 11/14/2019 3:46pm
+1 ;;7.0;OUTPATIENT PHARMACY;**746**;DEC 1997;Build 106
+2 ;
EN ; Action Entry Point
+1 NEW ERXSTS,CRMEDS,CRMED,MED,MEDCNT,DIR,Y,X,INDEX,CODE,HLP,DESC,I,REACODE,EXTRCODE,REASCODE,EXTSCODE,LINE,DIRUT,DIROUT,DUOUT,SELCTREC,FDAPNCOM
+2 NEW REATXT,DIC,DWLW,DWPK,DIWESUB,X,DELMED,TMPARR,WRPHELP,HELP,DESC,LINE,PSOQUIT,ERROR,FINISH,PSSRET,HUBID,VADAT,NPIINST,GBL,RECARY,RTHID
+3 NEW INSTNAME,STATION,INSTNPI,DIV,NOTE2PRV,REASONTXT,RELERX,CRFOUND,PNCOMM,CODETYPE,DDWFLAGS,MESSID,CRERXIEN,NPLEN,RECFOUND,ORGRXIEN,TMPIEN
+4 IF '$GET(ERXIEN)
QUIT
+5 DO FULL^VALM1
SET VALMBCK="R"
+6 ;
+7 SET NPIINST=$$GET1^DIQ(59,PSOSITE,101,"I")
SET INSTNAME=$$NAME^XUAF4(NPIINST)
SET STATION=$$WHAT^XUAF4(NPIINST,99)
+8 SET INSTNPI=$$NPI^XUSNPI("Organization_ID",NPIINST)
IF $PIECE(INSTNPI,U)<1
Begin DoDot:1
+9 SET INSTNPI=$$WHAT^XUAF4(NPIINST,41.99)
End DoDot:1
+10 IF '$GET(INSTNPI)
WRITE !!,"Institution NPI Number could not be found. Cannot create Change Request."
DO DIRE^PSOERXX1
QUIT
+11 ;
+12 IF '$DATA(^XUSEC("PSDRPH",DUZ))
IF '($DATA(^XUSEC("PSO ERX ADV TECH",DUZ)))
Begin DoDot:1
+13 WRITE !!,$GET(IOINHI),"You do not have the appropriate key to access this option.",!,$GET(IOINORM)
DO DIRE^PSOERXX1
End DoDot:1
QUIT
+14 ;
+15 SET SELCTREC=""
+16 ;entry point for PSO ERX RESEND CHANGE REQUEST Protocol action
IF $GET(RESEND)
SET RECFOUND=0
SET ORGRXIEN=""
DO RESENDEC
KILL RECFOUND
QUIT
+17 ;
+18 SET ERXSTS=$$GET1^DIQ(52.49,ERXIEN,1,"E")
+19 IF $$GET1^DIQ(52.49,ERXIEN,.08,"I")'="N"!(ERXSTS="RJ")!(ERXSTS="RM")!(ERXSTS="CAN")!(ERXSTS="CAC")!($EXTRACT(ERXSTS)="H")!(ERXSTS="CXQ")
Begin DoDot:1
+20 WRITE !!,$GET(IOINHI),"Change Request may not be used for this record type.",!,$GET(IOINORM)
DO DIRE^PSOERXX1
End DoDot:1
QUIT
+21 ;
+22 IF '$$GET1^DIQ(52.49,ERXIEN,1.7,"I")
Begin DoDot:1
+23 WRITE !!,$GET(IOINHI),"The VistA Patient must be matched and validated first.",!,$GET(IOINORM)
DO DIRE^PSOERXX1
End DoDot:1
QUIT
+24 ;
+25 DO DSPERX^PSOERUT(ERXIEN)
+26 ;
+27 SET (RELERX,CRFOUND)=0
FOR
SET RELERX=$ORDER(^PS(52.49,ERXIEN,201,"B",RELERX))
if 'RELERX
QUIT
Begin DoDot:1
+28 IF $$GET1^DIQ(52.49,RELERX,.08,"I")="CR"
SET CRFOUND=CRFOUND+1
SET RECARY(CRFOUND)=RELERX
End DoDot:1
+29 IF CRFOUND>0
Begin DoDot:1
+30 WRITE !!,$GET(IOINHI),CRFOUND," Rx Change Request",$SELECT(CRFOUND>1:"s have",1:" has")," already been sent for this eRx.",$GET(IOINORM)
+31 WRITE !
+32 ;Display any change requests made for this original eRx, so they can either create a brand new ERX change request or resend the existing one.
+33 SET SELCTREC=$$CHECKREC^PSOERX1H(.RECARY)
+34 IF $EXTRACT(SELCTREC,1)="R"
SET RECENTRY=$EXTRACT(SELCTREC,2)
SET SELCTREC=$EXTRACT(SELCTREC,1)
End DoDot:1
if ($GET(SELCTREC)'="N")&($GET(SELCTREC)'="R")
QUIT
+35 IF $GET(SELCTREC)="R"
Begin DoDot:1
+36 IF +$GET(RECENTRY)>0
SET RECFOUND=0
SET ORGRXIEN=""
SET ERXIEN=$GET(RECARY(RECENTRY))
DO RESENDEC
End DoDot:1
if +$GET(RECENTRY)<1!(+$GET(RECFOUND))
QUIT
+37 ;
EN1 ; Loop Entry Point
+1 KILL INDEX
SET CODE=0
KILL DIR
SET DIR(0)="SO^"
SET HLP=0
SET DIR("?")=" "
+2 FOR
SET CODE=$ORDER(^PS(52.45,"TYPE","MRC",CODE))
if 'CODE
QUIT
Begin DoDot:1
+3 SET INDEX($$GET1^DIQ(52.45,CODE,.01))=CODE
+4 SET DIR(0)=DIR(0)_$$GET1^DIQ(52.45,CODE,.01)_":"_$$GET1^DIQ(52.45,CODE,.02)_";"
+5 SET HLP=HLP+1
SET DIR("?",HLP)=" "_$$GET1^DIQ(52.45,CODE,.01)_" - "
+6 KILL DESC
SET X=$$GET1^DIQ(52.45,CODE,1,"","DESC")
IF '$DATA(DESC)
QUIT
+7 SET HELP=$GET(DESC(1))
FOR I=2:1
if '$DATA(DESC(I))
QUIT
SET HELP=HELP_" "_DESC(I)
+8 KILL WRPHELP
DO WRAP^PSOERUT(HELP,70,.WRPHELP)
+9 FOR I=1:1
if '$DATA(WRPHELP(I))
QUIT
if I>1
SET HLP=HLP+1
SET $EXTRACT(DIR("?",HLP),10)=$GET(WRPHELP(I,0))
End DoDot:1
+10 SET DIR("A")="CHANGE REQUEST CODE"
IF $GET(REACODE)
SET DIR("B")=$$GET1^DIQ(52.45,REACODE,.01)
+11 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+12 IF Y="G"
IF '$$GET1^DIQ(52.49,ERXIEN,5.8,"I")
Begin DoDot:1
+13 WRITE !!,$GET(IOINHI),"Substitutions are already allowed by prescriber for this eRx.",$GET(IOINORM),$CHAR(7)
End DoDot:1
GOTO EN1
+14 IF $GET(REACODE)'=+$GET(INDEX(Y))
SET REASCODE=0
SET EXTSCODE=""
KILL REATXT
+15 SET REACODE=+$GET(INDEX(Y))
SET EXTRCODE=$$GET1^DIQ(52.45,REACODE,.01)
+16 WRITE !
IF '$DATA(REATXT)
SET X=$$GET1^DIQ(52.45,REACODE,20,,"REATXT")
+17 ;
+18 SET PSOQUIT=0
+19 IF (" D U "[(" "_EXTRCODE_" "))
Begin DoDot:1
+20 KILL INDEX
KILL DIR
SET DIR(0)="SO^"
SET DIR("L",1)=" Select one of the following:"
SET DIR("L",2)=" "
+21 SET HLP=0
SET LINE=2
SET DIR("L")=" "_$SELECT(EXTRCODE="D":"Type '?' for the full list. ",1:"")
+22 SET DIR("?")="^D HELP^PSOERCR0"
+23 SET CODETYPE=$SELECT(EXTRCODE="D":"REA",1:"MRSC")
+24 FOR
SET CODE=$ORDER(^PS(52.45,"TYPE",CODETYPE,CODE))
if 'CODE
QUIT
Begin DoDot:2
+25 SET INDEX($$GET1^DIQ(52.45,CODE,.01))=CODE
+26 SET DIR(0)=DIR(0)_$$GET1^DIQ(52.45,CODE,.01)_":"_$$GET1^DIQ(52.45,CODE,.02)_";"
+27 IF EXTRCODE="U"!(EXTRCODE="D"&(",DA,DD,HD,LD,MS,TD,AR,DI,DR,ID,UD,PS,SX,TP,"[(","_$$GET1^DIQ(52.45,CODE,.01)_",")))
Begin DoDot:3
+28 SET LINE=LINE+1
SET DIR("L",LINE)=" "_$SELECT(EXTRCODE="D":" ",1:"")_$$GET1^DIQ(52.45,CODE,.01)_" - "_$$GET1^DIQ(52.45,CODE,.02)
End DoDot:3
+29 SET HLP=HLP+1
SET DIR("?",HLP)=" "_$SELECT(EXTRCODE="D":" ",1:"")_$$GET1^DIQ(52.45,CODE,.01)_" - "_$$GET1^DIQ(52.45,CODE,.02)
End DoDot:2
+30 IF EXTRCODE="D"
SET LINE=LINE+1
SET DIR("L",LINE)=" "
+31 SET DIR("A")="CHANGE REQUEST SUB-CODE"
IF $GET(REASCODE)
SET DIR("B")=$$GET1^DIQ(52.45,REASCODE,.01)
+32 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
SET PSOQUIT=1
QUIT
+33 IF $GET(REASCODE)'=+$GET(INDEX(Y))
KILL REATXT
+34 SET REASCODE=+$GET(INDEX(Y))
SET EXTSCODE=$$GET1^DIQ(52.45,REASCODE,.01)
+35 WRITE !
IF '$DATA(REATXT)
SET X=$$GET1^DIQ(52.45,REASCODE,20,,"REATXT")
End DoDot:1
IF $GET(PSOQUIT)
GOTO EXIT
+36 ;
NOTES ; NOTE TO PROVIDER Prompt (Max 260 characters)
+1 KILL ^TMP("PSOERN2P",$JOB)
+2 FOR I=1:1
if '$DATA(REATXT(I))
QUIT
SET ^TMP("PSOERN2P",$JOB,I,0)=REATXT(I)
+3 SET PSOQUIT=0
+4 FOR I=1:1
SET FINISH=1
Begin DoDot:1
+5 SET NPLEN=0
SET DIC="^TMP(""PSOERN2P"""_",$J,"
+6 SET DWLW=80
SET DWPK=1
+7 SET DIWESUB="NOTE TO PROVIDER"
WRITE !,DIWESUB,":"
+8 DO EN^DIWE
IF $GET(DUOUT)
SET PSOQUIT=1
QUIT
+9 FOR I=1:1
if '$DATA(^TMP("PSOERN2P",$JOB,I))
QUIT
Begin DoDot:2
+10 SET X=^TMP("PSOERN2P",$JOB,I,0)
+11 SET NPLEN=NPLEN+$LENGTH(X)
IF NPLEN>260
WRITE !!,$GET(IOINHI),"The maximum length for this note is 260 characters.",$GET(IOINORM),$CHAR(7)
SET FINISH=0
DO PAUSE^PSOSPMU1
QUIT
+12 IF X["[DRUG_NAME]"
WRITE !!,$GET(IOINHI),"The place holder [DRUG_NAME] must be replaced before proceeding.",$GET(IOINORM),$CHAR(7)
SET FINISH=0
DO PAUSE^PSOSPMU1
QUIT
+13 IF X["[ADD_TEXT_HERE]"
WRITE !!,$GET(IOINHI),"The place holder [ADD_TEXT_HERE] must be replaced before proceeding.",$GET(IOINORM),$CHAR(7)
SET FINISH=0
DO PAUSE^PSOSPMU1
QUIT
End DoDot:2
IF 'FINISH
QUIT
End DoDot:1
IF FINISH!PSOQUIT
QUIT
+14 IF PSOQUIT
GOTO EXIT
+15 KILL REATXT
FOR I=1:1
if '$DATA(^TMP("PSOERN2P",$JOB,I))
QUIT
SET REATXT(I)=$GET(^TMP("PSOERN2P",$JOB,I,0))
+16 ;
+17 IF (" P U "'[(" "_EXTRCODE_" "))
Begin DoDot:1
+18 SET (LINE,FINISH,ERROR,PSOQUIT)=0
WRITE !
+19 FOR I=1:1
Begin DoDot:2
+20 SET (MED,MEDCNT)=0
FOR
SET MED=$ORDER(CRMEDS(MED))
if 'MED
QUIT
SET MEDCNT=MEDCNT+1
+21 if '$GET(ERROR)
DO LISTMEDS
SET ERROR=0
+22 KILL DIR
SET DIR(0)="SOA^N:NEW;"_$SELECT(MEDCNT>0:"E:EDIT;D:DELETE;",1:"")_"F:FINISH"
+23 SET DIR("A")="Select Drug Suggestion Option: (N)EW "_$SELECT(MEDCNT>0:"(E)DIT (D)ELETE ",1:"")_"(F)INISH: "
+24 SET II=0
+25 SET II=II+1
SET DIR("?",II)=" NEW - Adds a new Drug/SIG/Qty/Refills/Days Supply suggestion be sent to"
+26 SET II=II+1
SET DIR("?",II)=" the prescriber as an alternative for this Change Request."
+27 IF MEDCNT
Begin DoDot:3
+28 SET II=II+1
SET DIR("?",II)=" EDIT - Edits a previously entered suggestion"
+29 SET II=II+1
SET DIR("?",II)=" DELETE - Deletes a previously entered suggestion"
End DoDot:3
+30 SET II=II+1
SET DIR("?",II)=" FINISH - Finishes entering suggestions and continue on to sending the"
+31 SET DIR("?")=" Change Request."
+32 DO ^DIR
IF X="^"
SET PSOQUIT=1
QUIT
+33 IF $DATA(DIROUT)!$GET(DIRUT)
SET FINISH=1
QUIT
+34 IF Y="N"
Begin DoDot:3
+35 SET CRMED=$ORDER(CRMEDS(99),-1)+1
IF CRMED>9
WRITE !!,"A maximum of 9 Drug Suggestion can be entered!",!,$CHAR(7)
SET ERROR=1
QUIT
+36 WRITE !
DO DSPERX^PSOERUT(ERXIEN)
DO EN^PSOERCR1
End DoDot:3
QUIT
+37 IF Y="E"
Begin DoDot:3
+38 KILL DIR
SET DIR(0)="L^1:"_MEDCNT
SET DIR("A")="Select Entry # to Edit"
+39 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+40 SET CRMED=+Y
DO EN^PSOERCR1
End DoDot:3
WRITE !
QUIT
+41 IF Y="F"
SET FINISH=1
QUIT
+42 IF Y="D"
Begin DoDot:3
+43 KILL DIR
SET DIR(0)="L^1:"_MEDCNT
SET DIR("A")="Select Entry # to Delete"
+44 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+45 SET DELMED=+Y
+46 KILL DIR
SET DIR(0)="SA^Y:YES;N:NO"
SET DIR("B")="NO"
+47 SET DIR("A")="Confirm? "
+48 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y="N")
WRITE !
QUIT
+49 WRITE !?64,"Deleting..."
KILL CRMEDS(DELMED)
HANG .5
WRITE "Ok.",!
HANG .5
+50 KILL TMPARR
MERGE TMPARR=CRMEDS
KILL CRMEDS
SET MED=0
FOR I=1:1
SET MED=$ORDER(TMPARR(MED))
if 'MED
QUIT
MERGE CRMEDS(I)=TMPARR(MED)
End DoDot:3
WRITE !
QUIT
End DoDot:2
IF FINISH!PSOQUIT
QUIT
End DoDot:1
IF $GET(PSOQUIT)
GOTO EXIT
+51 ;
PNCOMM ; Patient Progress Note Comments
+1 KILL DIR,DIRUT
SET DIR(0)="FO^1:210"
SET DIR("A")="VA PROGRESS NOTE COMMENTS (Optional)"
IF $GET(PNCOMM)'=""
SET DIR("B")=PNCOMM
+2 SET DIR("?")="This text will be appended at the bottom of the Patient Progress Notes that will be created after this Rx Change Request is submitted."
+3 WRITE !
DO ^DIR
IF Y="^"
GOTO EXIT
+4 SET PNCOMM=Y
+5 ;
+6 IF EXTRCODE'="U"
IF '$DATA(REATXT)
IF '$ORDER(CRMEDS(0))
Begin DoDot:1
+7 WRITE !!,$GET(IOINHI),"You must enter either Notes to Provider or at least one Drug Suggestion",$GET(IOINORM),$CHAR(7)
+8 WRITE !,$GET(IOINHI),"before proceeding.",$GET(IOINORM),$CHAR(7)
DO PAUSE^PSOSPMU1
End DoDot:1
GOTO NOTES
+9 ;
RESENDEC ;Allows a user to resend an eRx Change request in the Inbound eRx application
+1 IF $GET(RESEND)!($GET(SELCTREC)="R")
Begin DoDot:1
+2 ;only build existing record once
if RECFOUND
QUIT
+3 ;resend eRx ONLY if message type is 'CR' FOR RXCHANGEREQUEST
IF $$GET1^DIQ(52.49,ERXIEN,.08,"I")="CR"
Begin DoDot:2
+4 SET ORGRXIEN=$PIECE(^PS(52.49,ERXIEN,0),"^",14)
SET ORGRXIEN=$ORDER(^PS(52.49,"B",ORGRXIEN,0))
SET TMPIEN=PSOIEN
+5 SET RECFOUND=1
SET PNCOMM=""
+6 DO BUILDSUM^PSOERX1H(ERXIEN)
+7 ;CH REQ PROGRESS NOTE COMMENT
KILL PNCOMM
SET PNCOMM=$$GET1^DIQ(52.49,ERXIEN,320.2)
End DoDot:2
QUIT
+8 WRITE !!,$GET(IOINHI),"Resend Change Request may not be used for this record type.",$GET(IOINORM),!
DO ASKCONT^PSOERX1H
End DoDot:1
if '$GET(RECFOUND)
QUIT
+9 DO SUMMARY
+10 ;
+11 WRITE !
KILL DIR
SET DIR(0)="SA^Y:YES;N:NO"
SET DIR("B")="NO"
+12 SET DIR("A")="Would you like to edit this Rx Change Request before sending it? "
+13 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO EXIT
+14 IF $GET(Y)="Y"
GOTO EN1
+15 ;
+16 WRITE !
KILL DIR
SET DIR(0)="SA^Y:YES;N:NO"
SET DIR("B")="YES"
+17 SET DIR("A")="Would you like to send this Rx Change Request? "
+18 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y="N")
GOTO EXIT
+19 ;
+20 WRITE !!,"Sending Request to Provider..."
+21 ; Building & Sending RxChangeRequest Message to the Provider
+22 SET GBL=$NAME(^TMP("PSOERCR0",$JOB))
KILL @GBL
+23 SET CNT=0
+24 ;
+25 ;send the original erx instead of the new CRN type eRx.
IF $GET(RESEND)!($GET(SELCTREC)="R")
SET ERXIEN=$GET(ORGRXIEN)
+26 ;
+27 DO MSG^PSOERXOA(.GBL,1)
+28 ; Header
+29 SET MESSID=$$HEADER^PSOERXOA(.GBL,ERXIEN)
+30 ; Body Header
+31 DO BHF^PSOERXOA(.GBL,1)
+32 ; Request Type Header
+33 DO RTYPE^PSOERXOA(.GBL,"RxChangeRequest",1)
+34 ; RxChangeRequest Code/Sub-Code
+35 DO BL^PSOERXOA(GBL,.CNT,"MessageRequestCode",EXTRCODE)
+36 DO BL^PSOERXOA(GBL,.CNT,"MessageRequestSubCode",EXTSCODE)
+37 SET REASONTXT=""
FOR I=1:1
if '$DATA(REATXT(I))
QUIT
SET REASONTXT=REASONTXT_" "_REATXT(I)
+38 SET $EXTRACT(REASONTXT,1)=""
+39 DO BL^PSOERXOA(GBL,.CNT,"ChangeReasonText",REASONTXT)
+40 ;
+41 ; call prompting logic
+42 ; RETURN RECEIPT, REQUESTREFERENCENUMBER, URGENCY INDICATOR CODE, FOLLLOWUP REQUEST
+43 ;(ONLY 1 INSTANCE - XSD IS 0..1)
DO OALLERGY^PSOERXOB(GBL,.CNT,ERXIEN)
+44 ;outbound benefits coordination section
DO OBENEFIT^PSOERXOB(GBL,.CNT,ERXIEN)
+45 ;outbound facility segment
DO OFAC^PSOERXOB(GBL,.CNT,ERXIEN)
+46 ;outbound patient segment
DO PATIENT^PSOERXOC(GBL,.CNT,PSOSITE,ERXIEN)
+47 ; brad/steve
DO OPHARM^PSOERXOD(GBL,.CNT,PSOSITE,ERXIEN)
+48 ; PRESCRIBER - brad/steve
DO PERSON^PSOERXOE(GBL,.CNT,PSOSITE,ERXIEN,"PR")
+49 ;outbound observation segment
DO OOBSERVE^PSOERXOB(GBL,.CNT,ERXIEN)
+50 ; Bulding the <MedicationPrescribed> Segment
+51 DO MEDS^PSOERXOG(GBL,.CNT,ERXIEN,"P")
+52 ; Bulding the <MedicationRequested> Segment
+53 IF $ORDER(CRMEDS(0))
DO MEDREQ^PSOERXON(GBL,.CNT,.CRMEDS)
+54 ; FOLLOW UP PRESCRIBER
DO PERSON^PSOERXOE(GBL,.CNT,PSOSITE,ERXIEN,"FU")
+55 DO RTYPE^PSOERXOA(GBL,"RxChangeRequest",2)
+56 DO BHF^PSOERXOA(.GBL,2)
+57 DO MSG^PSOERXOA(.GBL,2)
+58 ;
+59 ; send message
+60 SET DIV=INSTNAME_"^"_INSTNPI
+61 SET RXIEN=$$GET1^DIQ(52.49,ERXIEN,.13,"I")
+62 SET PSSRET=$$RESTPOST^PSOERXO1(.PSSRET,.GBL)
+63 ; if the post was unsuccessful, inform the user and quit.
+64 KILL DIR
IF $PIECE(PSSRET(0),U)<1
WRITE !,$PIECE(PSSRET(0),U,2)
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+65 IF $DATA(PSSRET("errorMessage"))
WRITE !,PSSRET("errorMessage")
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+66 SET HUBID=$GET(PSSRET("outboundMsgId"))
IF 'HUBID
WRITE !,"The eRx Processing hub did not return a Hub identification number."
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT 0
+67 ; vista generated message will be V12345 (V concatenated to the hubId)
+68 SET HUBID="V"_HUBID
+69 NEW RES,I,XXL1
+70 SET I=0
FOR
SET I=$ORDER(@GBL@(I))
if 'I
QUIT
Begin DoDot:1
+71 SET XXL1=$GET(XXL1)_$GET(@GBL@(I,0))
End DoDot:1
+72 SET VADAT=DUZ
+73 SET RTHID=$$GET1^DIQ(52.49,ERXIEN,.01,"E")
+74 SET HUBID=HUBID_U_U_RTHID
+75 WRITE "Done."
HANG .5
+76 DO INCERX^PSOERXI1(.RES,.XXL1,"","","",STATION,DIV,HUBID,"","",VADAT,"")
+77 IF $PIECE(RES,U)=0
Begin DoDot:1
+78 WRITE !,"A problem was encountered while trying to file the RxChange request."
+79 WRITE !,"RxChange Request was not filed in vista."
+80 WRITE !!,"ERROR: "_$PIECE(RES,U,2)
+81 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
+82 IF '$GET(RESEND)!($GET(SELCTREC)'="R")
DO UPDSTAT^PSOERXU1(ERXIEN,"HC")
+83 ;
+84 ; Creating Patient Progress Note
+85 IF $PIECE(HUBID,"^")'=""
Begin DoDot:1
+86 SET CRERXIEN=$ORDER(^PS(52.49,"B",$PIECE(HUBID,"^"),0))
+87 DO CREATEPN^PSOERX1H(ERXIEN,CRERXIEN,PNCOMM,.CRMEDS,"ERX RX CHANGE REQUEST NOTE")
End DoDot:1
+88 ;put back the ERXIEN used during the entry point
IF $GET(RESEND)!($GET(SELCTREC)="R")
SET ERXIEN=TMPIEN
+89 ;
+90 KILL @GBL
+91 ;
+92 WRITE !
DO DIRE^PSOERXX1
+93 ;
+94 DO REF^PSOERSE1
+95 ;
+96 QUIT
+97 ;
EXIT ; Exit the action
+1 ;put back the ERXIEN used during the entry point
IF $GET(SELCTREC)="R"!($GET(RESEND))
SET ERXIEN=TMPIEN
+2 IF '$ORDER(CRMEDS(0))
QUIT
+3 WRITE !
KILL DIR
SET DIR(0)="SA^Y:YES;N:NO"
SET DIR("B")="YES"
+4 SET DIR("A")="Are you sure you want to exit (ALL INFORMATION ENTERED WILL BE LOST)? "
+5 DO ^DIR
IF Y="N"
GOTO EN1
+6 QUIT
+7 ;
DEFREA(REACODE) ; Returns the Default Change Request Reason Text
+1 ; Input: REACODE - Pointer to the ERX SERVICE REASON CODES (#52.45)
+2 ;Output: DEFREA - Default Change Request Reason Text for the Code passed in
+3 NEW DEFREA,I,X,REATXT
+4 SET DEFREA=""
SET X=$$GET1^DIQ(52.45,REACODE,20,,"REATXT")
+5 FOR I=1:1
if '$DATA(REATXT(I))
QUIT
SET DEFREA=DEFREA_" "_$GET(REATXT(I))
+6 SET $EXTRACT(DEFREA)=""
+7 QUIT DEFREA
+8 ;
HELP ; Sub-Code List
+1 NEW I,XX
WRITE !," Complete List of Change Request Sub-Codes:",!
+2 FOR I=1:1
if '$DATA(DIR("?",I))
QUIT
WRITE !,DIR("?",I)
IF '(I#20)
READ !,"Type <Enter> to continue or '^' to exit:",XX:DTIME
IF XX="^"
QUIT
+3 if (I#20)
DO PAUSE^PSOSPMU1
+4 QUIT
+5 ;
LISTMEDS ; Display Meds Already entered
+1 NEW XX,Z,MED,Y,SIG
+2 ;D DSPERX^PSOERUT(ERXIEN)
+3 IF '$ORDER(CRMEDS(0))
QUIT
+4 ;
+5 SET LINE=1
DO PAUSE
WRITE !
if $DATA(IOUON)
WRITE IOUON
WRITE "# DRUG",?50,"QTY",?55,"# REFS",?63,"DAYS SUPPLY",?76,"SUBS"
if $DATA(IOUOFF)
WRITE IOUOFF
+6 IF '$DATA(IOUON)
SET $PIECE(XX,"-",81)=""
DO PAUSE
WRITE !,XX,!
SET LINE=2
+7 SET MED=0
FOR
SET MED=$ORDER(CRMEDS(MED))
if 'MED
QUIT
Begin DoDot:1
+8 SET Z=$GET(CRMEDS(MED))
+9 IF MED=1
WRITE !
+10 DO PAUSE
WRITE MED,?3,"(",$PIECE(Z,"^"),")",$EXTRACT($PIECE(Z,"^",2),1,43),?50,$JUSTIFY($PIECE(Z,"^",6),3),?57,$JUSTIFY($PIECE(Z,"^",10),2)
+11 WRITE ?65,$JUSTIFY($PIECE(Z,"^",9),4),?76,$SELECT($PIECE(Z,"^",5):"NO",1:"YES"),!
+12 IF $ORDER(CRMEDS(MED,"SIG",0))
Begin DoDot:2
+13 DO PAUSE
WRITE ?3
if $DATA(IOUON)
WRITE IOUON
WRITE "Sig :"
if $DATA(IOUOFF)
WRITE IOUOFF
+14 SET SIG=""
FOR I=1:1
if '$DATA(CRMEDS(MED,"SIG",I))
QUIT
SET SIG=SIG_CRMEDS(MED,"SIG",I,0)_" "
+15 FOR I=1:1
if (SIG="")
QUIT
WRITE ?9,$EXTRACT(SIG,1,70),!
SET SIG=$EXTRACT(SIG,71,999)
DO PAUSE
End DoDot:2
+16 IF $GET(CRMEDS(MED,"NOTE"))'=""
Begin DoDot:2
+17 DO PAUSE
WRITE ?3
if $DATA(IOUON)
WRITE IOUON
WRITE "Note:"
if $DATA(IOUOFF)
WRITE IOUOFF
SET NOTE=CRMEDS(MED,"NOTE")
+18 FOR I=1:1
if NOTE=""
QUIT
WRITE ?9,$EXTRACT(NOTE,1,71),!
SET NOTE=$EXTRACT(NOTE,72,999)
DO PAUSE
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
SUMMARY ; Displays a Summary of the RxChangeRequest
+1 NEW HIGH,NORM,XX,ERXSIG,NOTES,MEDIEN,QTYQUAL
+2 ;
+3 WRITE @IOF
SET LINE=0
+4 SET HIGH=$GET(IOINHI)
SET NORM=$GET(IOINORM)
+5 WRITE !
DO PAUSE
SET $PIECE(XX,$SELECT($DATA(IOUON):" ",1:"-"),81)=""
SET $EXTRACT(XX,27,51)="RX CHANGE REQUEST SUMMARY"
WRITE !,$GET(IOUON),XX,$GET(IOUOFF)
+6 WRITE !
DO PAUSE
WRITE "Change Request Reason Code: ",HIGH,$$GET1^DIQ(52.45,+$GET(REACODE),.01)," - ",$$GET1^DIQ(52.45,+$GET(REACODE),.02),NORM
+7 IF $GET(REASCODE)
Begin DoDot:1
+8 WRITE !
DO PAUSE
WRITE "Change Request Reason Sub-Code: ",HIGH,$$GET1^DIQ(52.45,+$GET(REASCODE),.01)," - ",$$GET1^DIQ(52.45,+$GET(REASCODE),.02),NORM
End DoDot:1
+9 ;
+10 WRITE !
DO PAUSE
WRITE "Note to Provider: "
FOR I=1:1
if '$DATA(REATXT(I))
QUIT
WRITE !,HIGH,REATXT(I),NORM
+11 ;
+12 WRITE !
DO LISTMEDS
+13 ;
+14 IF ($GET(PNCOMM)'="")!($GET(RESEND))!($GET(SELCTREC)="R")
WRITE !
DO PAUSE
WRITE "VA Progress Note Comment: ",!,HIGH,PNCOMM,NORM,!
+15 ;
+16 SET XX=""
SET $PIECE(XX,$SELECT($DATA(IOUON):" ",1:"-"),81)=""
WRITE $GET(IOUON),XX,$GET(IOUOFF)
+17 QUIT
+18 ;
PAUSE ; Decides whether to pause the listing or not
+1 NEW XX,I,Y,X
+2 SET LINE=LINE+1
+3 SET Y=$SELECT($GET(IOSL):IOSL,1:24)-3
IF (LINE#Y)
QUIT
+4 WRITE "Press Return to continue"
READ X:60
+5 FOR I=1:1:26
WRITE $CHAR(8)
+6 SET $PIECE(XX," ",26)=""
WRITE XX
+7 FOR I=1:1:26
WRITE $CHAR(8)
+8 QUIT
