PSOERCR1 ;BHAM/MR - eRx Change Request Functionality - Add Drug ; 11/14/2019 3:46pm
;;7.0;OUTPATIENT PHARMACY;**746,769,770**;DEC 1997;Build 145
;
; Add New Medication Suggestion for Change Request
; Input: ERXIEN - Pointer the ERX HOLDING QUEUE file (#52.49)
;Output:
;
EN ; Add Medication Suggestion to eRx Change Request Entry point
N DIC,DIR,DIRUT,DIROUT,DUOUT,X,Y,I,J,MPIEN,MPIENS,ERXDRUG,DRUGTYPE,DRUGCODE,DRUGCODQ,DRUG,DAYSSUP,SUBS
N QTY,QTYQUAL,QTYUM,NUMREFS,MRC,MRCO,CODE,DWLW,DWPK,DWDISABL,DIWESUB,TXTLEN,X,QUIT,PSOQUIT,FINISH
;
I '$G(CRMED) S CRMED=$O(CRMEDS(99),-1)+1
D LOADMED
;
DRUG ; Use eRx OR VistA drug?
I '$G(ERXBTCHFLG) D I $D(DIRUT)!$D(DIROUT) W ! G @$$GOTO(X,"DRUG")
. D DSPERX^PSOERUT(ERXIEN)
. K DIR S DIR(0)="S^E:USE ERX DRUG;V:CHOOSE A VISTA DRUG"
. S DIR("A")="DRUG SELECTION" I $G(DRUGTYPE)'="" S DIR("B")=DRUGTYPE
. D ^DIR I $D(DIRUT)!$D(DIROUT) Q
. I Y="V",$G(DRUGTYPE)="E" S (DRUG,DRUGCODE,DRUGCODQ)=""
. S DRUGTYPE=Y
I $G(ERXBTCHFLG) S DRUGTYPE="V"
;
K DIC,DUOUT S QUIT=0
I DRUGTYPE="E" D
. I $P($G(CRMEDS(+CRMED)),"^")'="V" D
. . D LOADMED
. E D
. . S DRUG=$$GET1^DIQ(52.49,ERXIEN,3.1)
. . S DRUGCODE=$$GET1^DIQ(52.49,ERXIEN,4.1) I DRUGCODE="" S DRUGCODE=$$GET1^DIQ(52.49311,"1,"_ERXIEN_",",1.1,"I")
. . S DRUGCODQ=$$GET1^DIQ(52.49,ERXIEN,4.2) I DRUGCODQ="",DRUGCODE'="" S DRUGCODQ="ND"
. W !!,"eRx Drug: ",DRUG," ",$S(DRUGCODQ="ND":"NDC",1:"UPN")_": ",DRUGCODE,!
E D W ! G EXIT:$G(QUIT) I X["^" G @$$GOTO(X,"DRUG")
. I DRUGTYPE="E" K DRUG,DRUGCODE,DRUGCODQ
. W ! S DIC(0)="AEMQ",DIC=50 I $G(DRUG)'="" S DIC("B")=DRUG
. S DIC("S")="I $$ACTIVE^PSOERXA0(Y),($$OUTPAT^PSOERXA0(Y))"
. S FINISH=0
. F D ^DIC D I FINISH!QUIT Q
. . I X="^"!(X["^"&($$GOTO(X,"DRUG")'["?")) S QUIT=1 Q
. . I Y'>0 W !!,"VistA Drug is required",!,$C(7) Q
. . I $$GETNDC^PSSNDCUT(+Y,$G(PSOSITE))="" W !!,"VistA Drug is missing the NDC Code, please select a different drug.",!,$C(7) Q
. . S DRUG=$$GET1^DIQ(50,+Y,.01),DRUGCODE=$$GETNDC^PSSNDCUT(+Y,$G(PSOSITE)),DRUGCODQ="ND",FINISH=1
;
SUBS ; SUBSTITUTIONS? Prompt
K DIR S DIR(0)="SA^Y:YES;N:NO",DIR("A")="SUBSTITUTIONS? "
S DIR("B")="YES" I $G(SUBS) S DIR("B")="NO"
D ^DIR I $D(DIRUT)!$D(DIROUT) G @$$GOTO(X,"SUBS")
S SUBS=$S(Y="Y":0,1:1) ;,$P(CRMEDS(CRMED),"^",5)=SUBS
;
QTY ; QUANTITY Prompt
K DIR S DIR(0)="52.49,5.1",DIR("A")="QUANTITY" I $G(QTY) S DIR("B")=QTY
D ^DIR I $D(DIRUT)!$D(DIROUT) G @$$GOTO(X,"QTY")
I X="" W !!,"Quantity is required!",!,$C(7) G QTY
S QTY=Y
;
QTYQUAL ; QTY QUALIFIER Prompt
K DIR S DIR(0)="SO^"
S CODE=0 F S CODE=$O(^PS(52.45,"TYPE","QCQ",CODE)) Q:'CODE D
. S DIR(0)=DIR(0)_$$GET1^DIQ(52.45,CODE,.01)_":"_$$GET1^DIQ(52.45,CODE,.02)_";"
S DIR("A")="QTY QUALIFIER",DIR("B")=38 I $G(QTYQUAL)'="" S DIR("B")=QTYQUAL
D ^DIR I $D(DIRUT)!$D(DIROUT) G @$$GOTO(X,"QTYQUAL")
S QTYQUAL=Y ;,$P(CRMEDS(CRMED),"^",7)=QTYQUAL
;
QTYUM ; QTY UNIT OF MEASURE Prompt
K DIC S DIC("A")="QTY UNIT OF MEASURE: " I $G(QTYUM)'="" S DIC("B")=QTYUM
S DIC="^PS(52.45,",DIC(0)="AEMQ",DIC("S")="I $$CODES^PSOERXON(Y)"
D ^DIC I $D(DUOUT) G @$$GOTO(X,"QTYUM")
I X="" W !!,"Quantity Unit of Measure is required!",!,$C(7) G QTYUM
S MRC=Y,MRCO=$$GET1^DIQ(52.45,MRC,.01,"E")
I $G(MRC) S QTYUM=MRC_U_MRCO
S QTYUM=$P(Y,"^",2) ;,$P(CRMEDS(CRMED),"^",8)=QTYUM
;
DAYSSUP ; DAYS SUPPLY Prompt
K DIR S DIR(0)="NO^1:365",DIR("A")="DAYS SUPPLY" I $G(DAYSSUP) S DIR("B")=DAYSSUP
D ^DIR I $D(DIROUT) G @$$GOTO(X,"DAYSUP")
S DAYSSUP=Y
;
NUMREFS ; # OF REFILLS Prompt
K DIR S DIR(0)="NO^0:11",DIR("A")="# OF REFILLS" I $G(NUMREFS)'="" S DIR("B")=NUMREFS
D ^DIR I $D(DIROUT) G @$$GOTO(X,"NUMREFS")
I X="" W !!,"# of Refills is required.",! G NUMREFS
S NUMREFS=Y
;
SIG ; SIG Prompt
K DIC,DWLW,DWPK,DWDISABL,DIWESUB,SIGLEN,X,TXTLEN
S DIC="^TMP(""PSOCRSIG"""_",$J,"
S DWLW=70,DWPK=1,DWDISABL="P"
S DIWESUB="SIG Text"
W !,"SIG Text: " D EN^DIWE
S X=0 F S X=$O(^TMP("PSOCRSIG",$J,X)) Q:'X D
. S TXTLEN=$G(TXTLEN)+$L(^TMP("PSOCRSIG",$J,X,0))
I $G(TXTLEN)>1000 D G SIG
. W !,"Sig must be 1000 characters or less.",!
. D DIRE^PSOERXX1
G NOTE
;
NOTE ; NOTE TO PROVIDER Prompt
K DIR,DIRUT S DIR(0)="FO^1:210",DIR("A")="SUGGESTED PROVIDER NOTE (FOR RESPONSE RX)"
I $G(NOTE2PRV)'="" S DIR("B")=NOTE2PRV
S DIR("?")="This is the suggested Provider Note that will be sent back with Rx Response if this drug option is selected by the outside Provider. It may be edited/removed by the Provider before sending the response back."
D ^DIR I $D(DIROUT) G @$$GOTO(X,"NOTE")
S NOTE2PRV=Y
;
I $G(DRUG)="" W !,"Drug is Required!" G DRUG
I $G(SUBS)="" W !,"Substitution is Required!" G SUBS
I '$G(QTY) W !,"Quantity is Required!" G QTY
I $G(QTYQUAL)="" W !,"Quantity Qualifier is Required!" G QTYQUAL
I $G(QTYUM)="" W !,"Quantity Unit of Measure is Required!" G QTYUM
I $G(NUMREFS)="" W !,"Days Supply is Required!" G NUMREFS
;
W !?65,"Updating..."
K CRMEDS(CRMED)
S CRMEDS(CRMED)=DRUGTYPE_"^"_DRUG_"^"_DRUGCODE_"^"_DRUGCODQ_"^"_SUBS_"^"_QTY_"^"_QTYQUAL_"^"_QTYUM_"^"_DAYSSUP_"^"_NUMREFS
S CRMEDS(CRMED,"NOTE")=NOTE2PRV
M CRMEDS(CRMED,"SIG")=^TMP("PSOCRSIG",$J)
W "OK"
;
EXIT ; Quit
Q
;
LOADMED ; Load Default Values for an existing Medication Suggestion
N Z,MPIEN,MPIENS,ERXSIG
K ^TMP("PSOCRSIG",$J) S (DRUG,DRUGCODE,DRUGCODQ,SUBS,QTY,QTYQUAL,QTYUM,DAYSSUP,NOTE2PRV)=""
I $G(DRUGTYPE)="E" D
. S DRUG=$$GET1^DIQ(52.49,ERXIEN,3.1) I DRUG="" S DRUG=$$GETDRUG^PSOERXU5(ERXIEN)
. S DRUGCODE=$$GET1^DIQ(52.49,ERXIEN,4.1) I DRUGCODE="" S DRUGCODE=$$GET1^DIQ(52.49311,"1,"_ERXIEN_",",1.1,"I")
. S DRUGCODQ=$$GET1^DIQ(52.49,ERXIEN,4.2) I DRUGCODQ="",DRUGCODE'="" S DRUGCODQ="ND"
. S MPIEN=$O(^PS(52.49,ERXIEN,311,"C","P",0))
. I MPIEN D
. . S MPIENS=MPIEN_","_ERXIEN_","
. . S DRUG=$$GET1^DIQ(52.49311,MPIENS,.03)
. . S DRUGCODE=$$GET1^DIQ(52.49311,MPIENS,1.1)
. . S DRUGCODQ=$$GET1^DIQ(52.49311,MPIENS,1.2)
. . S X=$$GET1^DIQ(52.49311,MPIENS,8,,"ERXSIG")
. . F I=1:1 Q:'$D(ERXSIG(I)) S ^TMP("PSOCRSIG",$J,I,0)=ERXSIG(I)
. S QTY=$$GET1^DIQ(52.49,ERXIEN,5.1)
. S QTYQUAL=$$GET1^DIQ(52.49,ERXIEN,5.2,"I")
. S QTYUM=$$GET1^DIQ(52.49,ERXIEN,5.4)
. S DAYSSUP=$$GET1^DIQ(52.49,ERXIEN,5.5)
. S NUMREFS=$$GET1^DIQ(52.49,ERXIEN,5.6)
. ;S NOTE2PRV=$$GET1^DIQ(52.49,ERXIEN,8)
I '$G(CRMED)!'$D(CRMEDS(+$G(CRMED))) Q
; - Loading an existing entry
S Z=CRMEDS(CRMED),DRUGTYPE=$P(Z,"^")
I $G(DRUGTYPE)'="E" D
. S DRUG=$P(Z,"^",2)
. S DRUGCODE=$P(Z,"^",3)
. S DRUGCODQ=$P(Z,"^",4)
S SUBS=$P(Z,"^",5)
S QTY=$P(Z,"^",6)
S QTYQUAL=$P(Z,"^",7)
S QTYUM=$P(Z,"^",8)
S DAYSSUP=$P(Z,"^",9)
S NUMREFS=$P(Z,"^",10)
S NOTE2PRV=$G(CRMEDS(CRMED,"NOTE"))
M ^TMP("PSOCRSIG",$J)=CRMEDS(CRMED,"SIG")
Q
;
GOTO(INPUT,HOME) ; - Directed up-arrow
N GOTO,TAG,TRGT
I $P(INPUT,"^",2)="" S PSOQUIT=1 Q "EXIT"
;
S TRGT=$P(INPUT,"^",2)
S TAG("DRUG SELECTION")="EORV"
S TAG("DRUG")="DRUG"
S TAG("SUBSTITUTION")="SUBS"
S TAG("QUANTITY")="QTY"
S TAG("QTY QUALIFIER")="QTYQUAL"
S TAG("QTY UNIT OF MEASURE")="QTYUM"
S TAG("DAYS SUPPLY")="DAYSSUP"
S TAG("# OF REFILLS")="NUMREFS"
S TAG("SIG")="SIG"
S TAG("NOTE")="NOTE"
;
S GOTO=HOME
S TAG="" F S TAG=$O(TAG(TAG)) Q:TAG="" I $E(TAG,1,$L(TRGT))=TRGT S GOTO=TAG(TAG) Q
I GOTO=HOME W " ??",$C(7)
;
Q GOTO
;
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
;
SUMMARY ; Displays a Summary of the RxChangeRequest
N HIGH,NORM,XX,ERXSIG,NOTES,MEDIEN,QTYQUAL,X
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
; When sending a Batch, option #2, Meds are different but Sug. Provider Notes is the same
I $G(ERXBTCHFLG),$G(CHRQTYPE)=2 D
. W ! D PAUSE W "Suggested Medication: ",HIGH,"[VARIES FOR EACH eRx]",NORM,!
. W ! D PAUSE W "Suggested Provider Note (For RESPONSE eRx) - SAME FOR ALL eRx's:"
. S X=NOTE2PRV F Q:X="" W !,HIGH,$E(X,1,80),NORM S X=$E(X,81,999)
. W !
;
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
;
LISTMEDS ; Display Meds Already entered
N XX,Z,MED,Y,SIG,NOTE,UON,UOFF
;
I '$O(CRMEDS(0)) Q
S UON=$G(IOUON),UOFF=$G(IOUOFF)
S LINE=1 D PAUSE W ! W UON,"# DRUG",?50,"QTY",?55,"# REFS",?63,"DAYS SUPPLY",?76,"SUBS",UOFF
I UON="" 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 UON,"Sig :",UOFF
. . 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 UON,"Note:",UOFF 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
;
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[HPSOERCR1 10448 printed Aug 26, 2025@22:43:44 Page 2
PSOERCR1 ;BHAM/MR - eRx Change Request Functionality - Add Drug ; 11/14/2019 3:46pm
+1 ;;7.0;OUTPATIENT PHARMACY;**746,769,770**;DEC 1997;Build 145
+2 ;
+3 ; Add New Medication Suggestion for Change Request
+4 ; Input: ERXIEN - Pointer the ERX HOLDING QUEUE file (#52.49)
+5 ;Output:
+6 ;
EN ; Add Medication Suggestion to eRx Change Request Entry point
+1 NEW DIC,DIR,DIRUT,DIROUT,DUOUT,X,Y,I,J,MPIEN,MPIENS,ERXDRUG,DRUGTYPE,DRUGCODE,DRUGCODQ,DRUG,DAYSSUP,SUBS
+2 NEW QTY,QTYQUAL,QTYUM,NUMREFS,MRC,MRCO,CODE,DWLW,DWPK,DWDISABL,DIWESUB,TXTLEN,X,QUIT,PSOQUIT,FINISH
+3 ;
+4 IF '$GET(CRMED)
SET CRMED=$ORDER(CRMEDS(99),-1)+1
+5 DO LOADMED
+6 ;
DRUG ; Use eRx OR VistA drug?
+1 IF '$GET(ERXBTCHFLG)
Begin DoDot:1
+2 DO DSPERX^PSOERUT(ERXIEN)
+3 KILL DIR
SET DIR(0)="S^E:USE ERX DRUG;V:CHOOSE A VISTA DRUG"
+4 SET DIR("A")="DRUG SELECTION"
IF $GET(DRUGTYPE)'=""
SET DIR("B")=DRUGTYPE
+5 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT
+6 IF Y="V"
IF $GET(DRUGTYPE)="E"
SET (DRUG,DRUGCODE,DRUGCODQ)=""
+7 SET DRUGTYPE=Y
End DoDot:1
IF $DATA(DIRUT)!$DATA(DIROUT)
WRITE !
GOTO @$$GOTO(X,"DRUG")
+8 IF $GET(ERXBTCHFLG)
SET DRUGTYPE="V"
+9 ;
+10 KILL DIC,DUOUT
SET QUIT=0
+11 IF DRUGTYPE="E"
Begin DoDot:1
+12 IF $PIECE($GET(CRMEDS(+CRMED)),"^")'="V"
Begin DoDot:2
+13 DO LOADMED
End DoDot:2
+14 IF '$TEST
Begin DoDot:2
+15 SET DRUG=$$GET1^DIQ(52.49,ERXIEN,3.1)
+16 SET DRUGCODE=$$GET1^DIQ(52.49,ERXIEN,4.1)
IF DRUGCODE=""
SET DRUGCODE=$$GET1^DIQ(52.49311,"1,"_ERXIEN_",",1.1,"I")
+17 SET DRUGCODQ=$$GET1^DIQ(52.49,ERXIEN,4.2)
IF DRUGCODQ=""
IF DRUGCODE'=""
SET DRUGCODQ="ND"
End DoDot:2
+18 WRITE !!,"eRx Drug: ",DRUG," ",$SELECT(DRUGCODQ="ND":"NDC",1:"UPN")_": ",DRUGCODE,!
End DoDot:1
+19 IF '$TEST
Begin DoDot:1
+20 IF DRUGTYPE="E"
KILL DRUG,DRUGCODE,DRUGCODQ
+21 WRITE !
SET DIC(0)="AEMQ"
SET DIC=50
IF $GET(DRUG)'=""
SET DIC("B")=DRUG
+22 SET DIC("S")="I $$ACTIVE^PSOERXA0(Y),($$OUTPAT^PSOERXA0(Y))"
+23 SET FINISH=0
+24 FOR
DO ^DIC
Begin DoDot:2
+25 IF X="^"!(X["^"&($$GOTO(X,"DRUG")'["?"))
SET QUIT=1
QUIT
+26 IF Y'>0
WRITE !!,"VistA Drug is required",!,$CHAR(7)
QUIT
+27 IF $$GETNDC^PSSNDCUT(+Y,$GET(PSOSITE))=""
WRITE !!,"VistA Drug is missing the NDC Code, please select a different drug.",!,$CHAR(7)
QUIT
+28 SET DRUG=$$GET1^DIQ(50,+Y,.01)
SET DRUGCODE=$$GETNDC^PSSNDCUT(+Y,$GET(PSOSITE))
SET DRUGCODQ="ND"
SET FINISH=1
End DoDot:2
IF FINISH!QUIT
QUIT
End DoDot:1
WRITE !
if $GET(QUIT)
GOTO EXIT
IF X["^"
GOTO @$$GOTO(X,"DRUG")
+29 ;
SUBS ; SUBSTITUTIONS? Prompt
+1 KILL DIR
SET DIR(0)="SA^Y:YES;N:NO"
SET DIR("A")="SUBSTITUTIONS? "
+2 SET DIR("B")="YES"
IF $GET(SUBS)
SET DIR("B")="NO"
+3 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO @$$GOTO(X,"SUBS")
+4 ;,$P(CRMEDS(CRMED),"^",5)=SUBS
SET SUBS=$SELECT(Y="Y":0,1:1)
+5 ;
QTY ; QUANTITY Prompt
+1 KILL DIR
SET DIR(0)="52.49,5.1"
SET DIR("A")="QUANTITY"
IF $GET(QTY)
SET DIR("B")=QTY
+2 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO @$$GOTO(X,"QTY")
+3 IF X=""
WRITE !!,"Quantity is required!",!,$CHAR(7)
GOTO QTY
+4 SET QTY=Y
+5 ;
QTYQUAL ; QTY QUALIFIER Prompt
+1 KILL DIR
SET DIR(0)="SO^"
+2 SET CODE=0
FOR
SET CODE=$ORDER(^PS(52.45,"TYPE","QCQ",CODE))
if 'CODE
QUIT
Begin DoDot:1
+3 SET DIR(0)=DIR(0)_$$GET1^DIQ(52.45,CODE,.01)_":"_$$GET1^DIQ(52.45,CODE,.02)_";"
End DoDot:1
+4 SET DIR("A")="QTY QUALIFIER"
SET DIR("B")=38
IF $GET(QTYQUAL)'=""
SET DIR("B")=QTYQUAL
+5 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO @$$GOTO(X,"QTYQUAL")
+6 ;,$P(CRMEDS(CRMED),"^",7)=QTYQUAL
SET QTYQUAL=Y
+7 ;
QTYUM ; QTY UNIT OF MEASURE Prompt
+1 KILL DIC
SET DIC("A")="QTY UNIT OF MEASURE: "
IF $GET(QTYUM)'=""
SET DIC("B")=QTYUM
+2 SET DIC="^PS(52.45,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $$CODES^PSOERXON(Y)"
+3 DO ^DIC
IF $DATA(DUOUT)
GOTO @$$GOTO(X,"QTYUM")
+4 IF X=""
WRITE !!,"Quantity Unit of Measure is required!",!,$CHAR(7)
GOTO QTYUM
+5 SET MRC=Y
SET MRCO=$$GET1^DIQ(52.45,MRC,.01,"E")
+6 IF $GET(MRC)
SET QTYUM=MRC_U_MRCO
+7 ;,$P(CRMEDS(CRMED),"^",8)=QTYUM
SET QTYUM=$PIECE(Y,"^",2)
+8 ;
DAYSSUP ; DAYS SUPPLY Prompt
+1 KILL DIR
SET DIR(0)="NO^1:365"
SET DIR("A")="DAYS SUPPLY"
IF $GET(DAYSSUP)
SET DIR("B")=DAYSSUP
+2 DO ^DIR
IF $DATA(DIROUT)
GOTO @$$GOTO(X,"DAYSUP")
+3 SET DAYSSUP=Y
+4 ;
NUMREFS ; # OF REFILLS Prompt
+1 KILL DIR
SET DIR(0)="NO^0:11"
SET DIR("A")="# OF REFILLS"
IF $GET(NUMREFS)'=""
SET DIR("B")=NUMREFS
+2 DO ^DIR
IF $DATA(DIROUT)
GOTO @$$GOTO(X,"NUMREFS")
+3 IF X=""
WRITE !!,"# of Refills is required.",!
GOTO NUMREFS
+4 SET NUMREFS=Y
+5 ;
SIG ; SIG Prompt
+1 KILL DIC,DWLW,DWPK,DWDISABL,DIWESUB,SIGLEN,X,TXTLEN
+2 SET DIC="^TMP(""PSOCRSIG"""_",$J,"
+3 SET DWLW=70
SET DWPK=1
SET DWDISABL="P"
+4 SET DIWESUB="SIG Text"
+5 WRITE !,"SIG Text: "
DO EN^DIWE
+6 SET X=0
FOR
SET X=$ORDER(^TMP("PSOCRSIG",$JOB,X))
if 'X
QUIT
Begin DoDot:1
+7 SET TXTLEN=$GET(TXTLEN)+$LENGTH(^TMP("PSOCRSIG",$JOB,X,0))
End DoDot:1
+8 IF $GET(TXTLEN)>1000
Begin DoDot:1
+9 WRITE !,"Sig must be 1000 characters or less.",!
+10 DO DIRE^PSOERXX1
End DoDot:1
GOTO SIG
+11 GOTO NOTE
+12 ;
NOTE ; NOTE TO PROVIDER Prompt
+1 KILL DIR,DIRUT
SET DIR(0)="FO^1:210"
SET DIR("A")="SUGGESTED PROVIDER NOTE (FOR RESPONSE RX)"
+2 IF $GET(NOTE2PRV)'=""
SET DIR("B")=NOTE2PRV
+3 SET DIR("?")="This is the suggested Provider Note that will be sent back with Rx Response if this drug option is selected by the outside Provider. It may be edited/removed by the Provider before sending the response back."
+4 DO ^DIR
IF $DATA(DIROUT)
GOTO @$$GOTO(X,"NOTE")
+5 SET NOTE2PRV=Y
+6 ;
+7 IF $GET(DRUG)=""
WRITE !,"Drug is Required!"
GOTO DRUG
+8 IF $GET(SUBS)=""
WRITE !,"Substitution is Required!"
GOTO SUBS
+9 IF '$GET(QTY)
WRITE !,"Quantity is Required!"
GOTO QTY
+10 IF $GET(QTYQUAL)=""
WRITE !,"Quantity Qualifier is Required!"
GOTO QTYQUAL
+11 IF $GET(QTYUM)=""
WRITE !,"Quantity Unit of Measure is Required!"
GOTO QTYUM
+12 IF $GET(NUMREFS)=""
WRITE !,"Days Supply is Required!"
GOTO NUMREFS
+13 ;
+14 WRITE !?65,"Updating..."
+15 KILL CRMEDS(CRMED)
+16 SET CRMEDS(CRMED)=DRUGTYPE_"^"_DRUG_"^"_DRUGCODE_"^"_DRUGCODQ_"^"_SUBS_"^"_QTY_"^"_QTYQUAL_"^"_QTYUM_"^"_DAYSSUP_"^"_NUMREFS
+17 SET CRMEDS(CRMED,"NOTE")=NOTE2PRV
+18 MERGE CRMEDS(CRMED,"SIG")=^TMP("PSOCRSIG",$JOB)
+19 WRITE "OK"
+20 ;
EXIT ; Quit
+1 QUIT
+2 ;
LOADMED ; Load Default Values for an existing Medication Suggestion
+1 NEW Z,MPIEN,MPIENS,ERXSIG
+2 KILL ^TMP("PSOCRSIG",$JOB)
SET (DRUG,DRUGCODE,DRUGCODQ,SUBS,QTY,QTYQUAL,QTYUM,DAYSSUP,NOTE2PRV)=""
+3 IF $GET(DRUGTYPE)="E"
Begin DoDot:1
+4 SET DRUG=$$GET1^DIQ(52.49,ERXIEN,3.1)
IF DRUG=""
SET DRUG=$$GETDRUG^PSOERXU5(ERXIEN)
+5 SET DRUGCODE=$$GET1^DIQ(52.49,ERXIEN,4.1)
IF DRUGCODE=""
SET DRUGCODE=$$GET1^DIQ(52.49311,"1,"_ERXIEN_",",1.1,"I")
+6 SET DRUGCODQ=$$GET1^DIQ(52.49,ERXIEN,4.2)
IF DRUGCODQ=""
IF DRUGCODE'=""
SET DRUGCODQ="ND"
+7 SET MPIEN=$ORDER(^PS(52.49,ERXIEN,311,"C","P",0))
+8 IF MPIEN
Begin DoDot:2
+9 SET MPIENS=MPIEN_","_ERXIEN_","
+10 SET DRUG=$$GET1^DIQ(52.49311,MPIENS,.03)
+11 SET DRUGCODE=$$GET1^DIQ(52.49311,MPIENS,1.1)
+12 SET DRUGCODQ=$$GET1^DIQ(52.49311,MPIENS,1.2)
+13 SET X=$$GET1^DIQ(52.49311,MPIENS,8,,"ERXSIG")
+14 FOR I=1:1
if '$DATA(ERXSIG(I))
QUIT
SET ^TMP("PSOCRSIG",$JOB,I,0)=ERXSIG(I)
End DoDot:2
+15 SET QTY=$$GET1^DIQ(52.49,ERXIEN,5.1)
+16 SET QTYQUAL=$$GET1^DIQ(52.49,ERXIEN,5.2,"I")
+17 SET QTYUM=$$GET1^DIQ(52.49,ERXIEN,5.4)
+18 SET DAYSSUP=$$GET1^DIQ(52.49,ERXIEN,5.5)
+19 SET NUMREFS=$$GET1^DIQ(52.49,ERXIEN,5.6)
+20 ;S NOTE2PRV=$$GET1^DIQ(52.49,ERXIEN,8)
End DoDot:1
+21 IF '$GET(CRMED)!'$DATA(CRMEDS(+$GET(CRMED)))
QUIT
+22 ; - Loading an existing entry
+23 SET Z=CRMEDS(CRMED)
SET DRUGTYPE=$PIECE(Z,"^")
+24 IF $GET(DRUGTYPE)'="E"
Begin DoDot:1
+25 SET DRUG=$PIECE(Z,"^",2)
+26 SET DRUGCODE=$PIECE(Z,"^",3)
+27 SET DRUGCODQ=$PIECE(Z,"^",4)
End DoDot:1
+28 SET SUBS=$PIECE(Z,"^",5)
+29 SET QTY=$PIECE(Z,"^",6)
+30 SET QTYQUAL=$PIECE(Z,"^",7)
+31 SET QTYUM=$PIECE(Z,"^",8)
+32 SET DAYSSUP=$PIECE(Z,"^",9)
+33 SET NUMREFS=$PIECE(Z,"^",10)
+34 SET NOTE2PRV=$GET(CRMEDS(CRMED,"NOTE"))
+35 MERGE ^TMP("PSOCRSIG",$JOB)=CRMEDS(CRMED,"SIG")
+36 QUIT
+37 ;
GOTO(INPUT,HOME) ; - Directed up-arrow
+1 NEW GOTO,TAG,TRGT
+2 IF $PIECE(INPUT,"^",2)=""
SET PSOQUIT=1
QUIT "EXIT"
+3 ;
+4 SET TRGT=$PIECE(INPUT,"^",2)
+5 SET TAG("DRUG SELECTION")="EORV"
+6 SET TAG("DRUG")="DRUG"
+7 SET TAG("SUBSTITUTION")="SUBS"
+8 SET TAG("QUANTITY")="QTY"
+9 SET TAG("QTY QUALIFIER")="QTYQUAL"
+10 SET TAG("QTY UNIT OF MEASURE")="QTYUM"
+11 SET TAG("DAYS SUPPLY")="DAYSSUP"
+12 SET TAG("# OF REFILLS")="NUMREFS"
+13 SET TAG("SIG")="SIG"
+14 SET TAG("NOTE")="NOTE"
+15 ;
+16 SET GOTO=HOME
+17 SET TAG=""
FOR
SET TAG=$ORDER(TAG(TAG))
if TAG=""
QUIT
IF $EXTRACT(TAG,1,$LENGTH(TRGT))=TRGT
SET GOTO=TAG(TAG)
QUIT
+18 IF GOTO=HOME
WRITE " ??",$CHAR(7)
+19 ;
+20 QUIT GOTO
+21 ;
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 ;
SUMMARY ; Displays a Summary of the RxChangeRequest
+1 NEW HIGH,NORM,XX,ERXSIG,NOTES,MEDIEN,QTYQUAL,X
+2 WRITE @IOF
SET LINE=0
+3 SET HIGH=$GET(IOINHI)
SET NORM=$GET(IOINORM)
+4 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)
+5 WRITE !
DO PAUSE
WRITE "Change Request Reason Code: ",HIGH,$$GET1^DIQ(52.45,+$GET(REACODE),.01)," - ",$$GET1^DIQ(52.45,+$GET(REACODE),.02),NORM
+6 IF $GET(REASCODE)
Begin DoDot:1
+7 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
+8 ;
+9 WRITE !
DO PAUSE
WRITE "Note to Provider: "
FOR I=1:1
if '$DATA(REATXT(I))
QUIT
WRITE !,HIGH,REATXT(I),NORM
+10 WRITE !
DO LISTMEDS
+11 ; When sending a Batch, option #2, Meds are different but Sug. Provider Notes is the same
+12 IF $GET(ERXBTCHFLG)
IF $GET(CHRQTYPE)=2
Begin DoDot:1
+13 WRITE !
DO PAUSE
WRITE "Suggested Medication: ",HIGH,"[VARIES FOR EACH eRx]",NORM,!
+14 WRITE !
DO PAUSE
WRITE "Suggested Provider Note (For RESPONSE eRx) - SAME FOR ALL eRx's:"
+15 SET X=NOTE2PRV
FOR
if X=""
QUIT
WRITE !,HIGH,$EXTRACT(X,1,80),NORM
SET X=$EXTRACT(X,81,999)
+16 WRITE !
End DoDot:1
+17 ;
+18 IF ($GET(PNCOMM)'="")!($GET(RESEND))!($GET(SELCTREC)="R")
WRITE !
DO PAUSE
WRITE "VA Progress Note Comment: ",!,HIGH,PNCOMM,NORM,!
+19 ;
+20 SET XX=""
SET $PIECE(XX,$SELECT($DATA(IOUON):" ",1:"-"),81)=""
WRITE $GET(IOUON),XX,$GET(IOUOFF)
+21 QUIT
+22 ;
LISTMEDS ; Display Meds Already entered
+1 NEW XX,Z,MED,Y,SIG,NOTE,UON,UOFF
+2 ;
+3 IF '$ORDER(CRMEDS(0))
QUIT
+4 SET UON=$GET(IOUON)
SET UOFF=$GET(IOUOFF)
+5 SET LINE=1
DO PAUSE
WRITE !
WRITE UON,"# DRUG",?50,"QTY",?55,"# REFS",?63,"DAYS SUPPLY",?76,"SUBS",UOFF
+6 IF UON=""
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
WRITE UON,"Sig :",UOFF
+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
WRITE UON,"Note:",UOFF
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 ;
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
