PSOERXON ;ALB/BWF - eRx parsing Utilities ; 11/14/2019 3:46pm
;;7.0;OUTPATIENT PHARMACY;**581,746**;DEC 1997;Build 106
;
Q
;
MEDCODES(GL,CNT,DATA) ;
N MRC,MRSC
S MRC=$G(DATA("MRCODE"))
D BL(GL,.CNT,"MessageRequestCode",MRC)
S MRSC=$G(DATA("MRSCODE"))
D BL(GL,.CNT,"MessageRequestSubCode",MRSC)
Q
;
MEDREQ(GL,CNT,DATA) ;
N REQ,DRUGDAT,DRUG,DNDC,DNDCQ,ODATA,REF,DAYS,QTY,CLQ,QUOM,SIG,ODATA,NOTE,S
S REQ=0 F S REQ=$O(DATA(REQ)) Q:'REQ D
. S DRUG=$P(DATA(REQ),"^",2)
. S DNDC=$P(DATA(REQ),"^",3)
. S DNDCQ=$P(DATA(REQ),"^",4)
. S SIG=""
. S S=0 F S S=$O(DATA(REQ,"SIG",S)) Q:'S D
. . S SIG=$G(SIG)_$G(DATA(REQ,"SIG",S,0))_" "
. S $E(SIG,$L(SIG))=""
.S REF=$P(DATA(REQ),"^",10)+1
.S DAYS=$P(DATA(REQ),"^",9)
.S QTY=$P(DATA(REQ),"^",6)
.S CLQ=$P(DATA(REQ),"^",7)
.S QUOM=$P(DATA(REQ),"^",8)
.S SUBS=$P(DATA(REQ),"^",5)
.S NOTE=$G(DATA(REQ,"NOTE"))
.D C S @GL@(CNT,0)="<MedicationRequested>"
.D BL(GL,.CNT,"DrugDescription",DRUG)
.D C S @GL@(CNT,0)="<DrugCoded>"
.D C S @GL@(CNT,0)="<ProductCode>"
.D BL(GL,.CNT,"Code",DNDC)
.D BL(GL,.CNT,"Qualifier",DNDCQ)
.D C S @GL@(CNT,0)="</ProductCode>"
.D C S @GL@(CNT,0)="</DrugCoded>"
.I QTY D
..D C S @GL@(CNT,0)="<Quantity>"
..D BL(GL,.CNT,"Value",QTY)
..D BL(GL,.CNT,"CodeListQualifier",CLQ)
..I $L(QUOM) D
...D C S @GL@(CNT,0)="<QuantityUnitOfMeasure>"
...D BL(GL,.CNT,"Code",QUOM)
...D C S @GL@(CNT,0)="</QuantityUnitOfMeasure>"
..D C S @GL@(CNT,0)="</Quantity>"
.D BL(GL,.CNT,"DaysSupply",DAYS)
.D BL(GL,.CNT,"Substitutions",SUBS)
.D BL(GL,.CNT,"NumberOfRefills",REF)
.D BL(GL,.CNT,"Note",NOTE)
.I $L(SIG) D
..D C S @GL@(CNT,0)="<Sig>"
..D BL(GL,.CNT,"SigText",SIG)
..D C S @GL@(CNT,0)="</Sig>"
.D C S @GL@(CNT,0)="</MedicationRequested>"
Q
;
GETCODES(ERXIEN,MCODES) ;
N ERXIENS,MRC,MRCC,MRSC,NOTE,I,CONT
S ERXIENS=ERXIEN_","
D DERX1^PSOERXD2(ERXIEN,ERXIENS,1)
S MRC=$$MRC(ERXIEN) Q:'MRC!(MRC<0) ""
I MRC=U Q ""
S MRCC=$P(MRC,U,2)
; if the message request code us 'U' - Prescriber Authorization, message request subcode is required
S MCODES("MRCODE")=MRCC
I "PU"'[MRCC Q 1
I MRCC="U" D
.S MRSC=$$MRSC()
.S MCODES("MRSCODE")=$P(MRSC,U,2)
I MRCC="U",(MRSC<0) Q ""
I MRCC="P"!(MRCC="U") D
.S NOTE=$$GNOTE()
.S MCODES("NOTE")=NOTE
Q:NOTE=U ""
S CONT=$$CONFIRM("Would you like to send this Rx Change Request?")
Q CONT
;
CRALLOW(ERXIEN) ;
N ESTAT
I $$GET1^DIQ(52.49,ERXIEN,.08,"I")'="N" Q 0
S ESTAT=$$GET1^DIQ(52.49,ERXIEN,1,"E")
I ESTAT="RJ"!(ESTAT="RM")!(ESTAT="CAN")!(ESTAT="CAC") Q 0
I $$GET1^DIQ(52.49,ERXIEN,312.1,"I")'=1 Q 0
Q 1
CHREQ(GL,ERXIEN,CNT,MEDREQ,MRC) ;
N DIR,DIC,Y,X,DONE,NDC,NDCQ,SUBS,NOTE,REF,DAYS,QTY,CLQ,QUOM,SIG,SEQ,DNAME,QUOMINFO,CLQCODE,QTYDSRFL,MCNT,CLQARY
N PSODRUG,NDC,DOSE,VERB,TSIG,UPD,QTYDSRFL,AGAIN,NOTEARY,RESP,PRCODE,PRCQUAL,CONTINUE,I,CRFOUND,MRCIEN,CL,ENDONE,NDCQUIT,NL,SL
S CRFOUND=0
S MRCIEN=$$PRESOLV^PSOERXA1(MRC,"MRC")
; TYPES P AND U are confirmed above.
I MRC="P"!(MRC="U") Q 1
S ERXIENS=ERXIEN_","
D DERX1^PSOERXD2(ERXIEN,ERXIENS,1)
S (ENDONE,DONE)=0,MCNT=1
F I=1:1 D Q:DONE!(MCNT>3)!(ENDONE)
.S NDCQUIT=0 K ^TMP("PSOERXA6",$J)
.; initialize variables to ensure they do not fall through to the next entry
.S (NOTE,DNAME,NDC,NDCQ,SUBS,QTY,CLQ,CLQCODE,QUOM,QUOMINFO,DAYS,REF,MEDREQ)=""
.K NOTEARY,CLARY
.S NOTE=$$GNOTE() I NOTE=U S DONE=1 Q
.S MEDREQ=$$SDRG(ERXIEN) I MEDREQ=U S DONE=1 Q
.S DNAME=$P(MEDREQ,U,2)
.I $P(MEDREQ,U)="E" S PRCODE=$P(MEDREQ,U,3),PRCQUAL=$P(MEDREQ,U,4)
.S MEDREQ=$P(MEDREQ,U) I MEDREQ="" S DONE=1 Q
.I MEDREQ'="E" D Q:NDCQUIT
..;Reference to $$GETNDC^PSSNDCUT supported by IA 4707
..S NDC=$$GETNDC^PSSNDCUT(MEDREQ,$G(PSOSITE)),NDC=$TR(NDC,"-","")
..I NDC']"" S NDCQUIT=1 W !!,"Missing NDC. Please select a different drug.",! Q
..; VA eRx will always be using NDC for the code and ND for the product code qualifier, hence the hard-coded value
..S NDCQ="ND"
.S SUBS=$$GSUBS() I SUBS=U S DONE=1 Q
.S SUBS=$S(SUBS="Y":0,1:1)
.D TXT2ARY^PSOERXD1(.NOTEARY,"Note: "_NOTE)
.S QTY=$$GQTY() I QTY=U S DONE=1 Q
.I QTY D
..S CLQ=$$GCLQ() I CLQ=U S DONE=1 Q
..S CLQCODE=$P(CLQ,U,2)_" - "_$$GET1^DIQ(52.45,$P(CLQ,U),.02,"E")
..D TXT2ARY^PSOERXD1(.CLQARY,"Code List Qualifier: "_CLQCODE)
..S QUOM=$$GQUOM() I QUOM=U S DONE=1 Q
..S QUOMINFO=$P(QUOM,U,2)_" - "_$$GET1^DIQ(52.45,$P(QUOM,U),.02,"E")
.;/JSG/ PSO*7.0*581 - BEGIN CHANGE (INITIALIZE VARIABLES)
.I 'QTY D
..S (CLQ,CLQCODE,QUOM,QUOMINFO)="" K CLQARY
.;/JSG/ - END CHANGE
.Q:DONE
.S DAYS=$$GDAYS() I DAYS=U S DONE=1 Q
.S REF=$$GREF() I REF=U S DONE=1 Q
.D GSIG
.W !!,"*************************** DETAILS ***************************"
.W !,"Message Request Code: "_MRC_" - "_$$GET1^DIQ(52.45,MRCIEN,.02,"E")
.W !,"Drug: "_DNAME
.I MEDREQ'="E" W !,"NDC: "_NDC
.I MEDREQ="E" D
..W !,"Product Code: "_PRCODE
..W !,"Product Code Qualifier: "_PRCQUAL
.W !,"Substitutions? "_$S(SUBS=0:"Yes",1:"No")
.S NL=0 F S NL=$O(NOTEARY(NL)) Q:'NL D
..W !,NOTEARY(NL)
.W !,"Refills: "_$G(REF),?25,"Days Supply: "_$G(DAYS),?55,"Quantity: "_$G(QTY)
.;/JSG/ PSO*7.0*581 - BEGIN CHANGE (Allow for empty Code List Qualifier)
.I $D(CLQARY)\10 D
..S CL=0 F S CL=$O(CLQARY(CL)) Q:'CL D
...W !,$G(CLQARY(CL))
.I $D(CLQARY)<10 D
..W !,"Code List Qualifier:"
.;/JSG/ - END CHANGE
.W !,"Quantity Unit Of Measure: "_$G(QUOMINFO)
.W !!,"Sig: "
.S SL=0 F S SL=$O(^TMP("PSOERXA6",$J,SL)) Q:'SL D
..W !,^TMP("PSOERXA6",$J,SL,0)
.W !!,"****************************************************************",!!
.S RESP=$$CONFIRM("Would you like to use the requested medication?") I RESP=U S DONE=1 Q
.Q:'RESP
.I MEDREQ'="E" S MEDREQ(MCNT,"MEDICATION")=DNAME_U_NDC_U_NDCQ
.I MEDREQ="E" S MEDREQ(MCNT,"MEDICATION")=DNAME_U_PRCODE_U_PRCQUAL
.S MEDREQ(MCNT,"NOTE")=NOTE
.S MEDREQ(MCNT,"OTHER")=REF_U_DAYS_U_QTY_U_$P($G(CLQ),U,2)_U_$P($G(QUOM),U,2)_U_SUBS
.M MEDREQ(MCNT,"SIG")=^TMP("PSOERXA6",$J) K ^TMP("PSOERXA6",$J)
.S MCNT=MCNT+1 Q:MCNT>3
.S AGAIN=$$CONFIRM("Would you like to enter another requested medication?") I AGAIN=U!(AGAIN=0) S ENDONE=1 Q
.W !!,"Now Entering a New Medication Requested:"
I DONE=1 Q 0
S CONTINUE=$$CONFIRM("Would you like to send this Rx Change Request?")
I 'CONTINUE W !,"RxChangeRequest Cancelled." D DIRE^PSOERXX1 Q 0
D MEDREQ(GL,.CNT,.MEDREQ)
K ^TMP("PSOERXA6",$J)
Q 1
MRC(ERXIEN) ;
N DIR,DIC,Y,X,DONE,MRC,MRCO,ESUBS,MIEN
S DIC("A")="Select RX change message request code: "
S DIC="^PS(52.45,",DIC(0)="AEMQ"
; Surescripts
; "G" (Generic Substitution), may be used to request a prescriber allow the dispensing of a generic
; medication when substitution is not allowed by prescriber or regulations.
; substitutions = 0 - do not allow G
; = 1 - allow G
S MIEN=$O(^PS(52.49,ERXIEN,311,"C","P",0))
S ESUBS=$$GET1^DIQ(52.49311,MIEN_","_ERXIEN_",",2.7,"I")
I 'ESUBS S DIC("S")="I $D(^PS(52.45,""TYPE"",""MRC"",Y)),$P(^PS(52.45,Y,0),U)'=""G"""
I ESUBS S DIC("S")="I $D(^PS(52.45,""TYPE"",""MRC"",Y))"
D ^DIC K DIC
I $D(DUOUT)!(Y<1) Q Y
S MRC=Y,MRCO=$$GET1^DIQ(52.45,MRC,.01,"E"),DONE=1
I $G(MRC) Q MRC_U_MRCO
I $D(DUOUT) Q U
Q Y
MRSC() ;
N DIR,DIC,Y,X,DONE,MRC,MRCO
S DIC("A")="Select RX change message request sub-code: "
S DIC="^PS(52.45,",DIC(0)="AEMQ",DIC("S")="I $D(^PS(52.45,""TYPE"",""MRSC"",Y))"
D ^DIC K DIC
I $D(DUOUT)!(Y<1) Q Y
S MRC=Y,MRCO=$$GET1^DIQ(52.45,MRC,.01,"E"),DONE=1
I $G(MRC) Q MRC_U_MRCO
I $D(DUOUT) Q U
Q Y
SDRG(ERXIEN) ;
N DIC,DIR,MPIEN,ERXDRUG,DPRCODE,DPRCQUAL,ERET,Y,DUOUT,MPIENS
S MPIEN=$O(^PS(52.49,ERXIEN,311,"C","P",0)) Q:'MPIEN ""
S MPIENS=MPIEN_","_ERXIEN_","
I MPIEN S ERXDRUG=$$GET1^DIQ(52.49311,MPIENS,.03,"E")
W !!,"eRx Drug: "_ERXDRUG
S DIR(0)="S^E:Use eRx Drug;S:Select from drug file" D ^DIR
I $D(DUOUT) Q U
I Y="E" D Q ERET
.S DPRCODE=$$GET1^DIQ(52.49311,MPIENS,1.1,"E")
.S DPRCQUAL=$$GET1^DIQ(52.49311,MPIENS,1.2,"E")
.S ERET="E"_U_ERXDRUG_U_DPRCODE_U_DPRCQUAL
S DIC(0)="AEMQ",DIC=50,DIC("S")="I $$ACTIVE^PSOERXA0(Y),($$OUTPAT^PSOERXA0(Y)),('$$INVCOMP^PSOERXA0(Y)),('$$CS^PSOERXA0(Y))"
D ^DIC K DIC
I $D(DUOUT) Q U
Q Y
GSUBS() ;
N DIR,Y
S DIR(0)="S^Y:YES;N:NO",DIR("A")="Substitutions?"
S DIR("B")="N"
D ^DIR
I $D(DUOUT) Q U
Q Y
GNOTE() ;
N DIR,Y
S DIR(0)="FO^1:210",DIR("A")="Note"
D ^DIR
I $D(DUOUT) Q U
Q Y
PATSTATS(ERXIEN) ;
N PATIEN,Y,DIE,DR,DA,FDA,ANS,PATSTAT,DONE,PSODFN,STAT
S PATIEN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
I 'PATIEN W !!,"Patient has not been validated, cannot edit patient status",! Q ""
S PSODFN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
S PATSTAT=$$GET1^DIQ(55,ERXIEN,3,"E")
S DIR("B")=PATSTAT
S DONE=0 K DA
F D Q:DONE
.S DIR(0)="55,3",DIR("A")="PATIENT STATUS" D ^DIR K DIR
.I Y="" W !,"This is a required response. Enter '^' to exit" Q
.I +Y S DONE=1 Q
.I Y["^" S DONE=1 Q
S STAT=$P(Y,"^",1)
Q STAT
GQTY() ;
N DIR,Y
S DIR(0)="NO^1:99999",DIR("A")="Quantity"
D ^DIR
I $D(DUOUT) Q U
Q Y
GDAYS() ;
N DIR,Y
S DIR(0)="NO^1:365",DIR("A")="Days Supply"
D ^DIR
I $D(DUOUT) Q U
Q Y
GREF() ;
N DIR,Y
S DIR(0)="NO^1:99",DIR("A")="Refills"
D ^DIR
I $D(DUOUT) Q U
Q Y
GCLQ() ;
GCLQA N DIR,DIC,Y,X,DONE,MRC,MRCO
S DIC(0)="A"
S DIC("A")="Quantity Code List Qualifier: "
S DIC="^PS(52.45,",DIC(0)="AEMQ",DIC("S")="I $D(^PS(52.45,""TYPE"",""QCQ"",Y))"
D ^DIC K DIC
I $D(DUOUT) Q U
I Y<0 W !,"Response is required. Enter a value or '^' to quit." G GCLQA
S MRC=Y,MRCO=$$GET1^DIQ(52.45,MRC,.01,"E"),DONE=1
I $G(MRC) Q MRC_U_MRCO
Q Y
GQUOM() ;
GQUOMA N DIR,DIC,Y,X,DONE,MRC,MRCO
S DIC(0)="A"
S DIC("A")="Quantity Unit Of Measure: "
S DIC="^PS(52.45,",DIC(0)="AEMQ",DIC("S")="I $$CODES^PSOERXON(Y)"
D ^DIC K DIC
I $D(DUOUT) Q U
I Y<0 W !,"Response is required. Enter a value or '^' to quit." G GQUOMA
S MRC=Y,MRCO=$$GET1^DIQ(52.45,MRC,.01,"E"),DONE=1
I $G(MRC) Q MRC_U_MRCO
Q Y
CODES(IEN) ;
N DESC
; must be an NCI code
I '$D(^PS(52.45,"TYPE","NCI",IEN)) Q 0
; codes Milliliter, Unspecified, and Gram are stored with a subtype of StrengthUnitOfMeasure, but need to be included.
S DESC=$$GET1^DIQ(52.45,IEN,.02,"E"),DESC=$$UP^XLFSTR(DESC)
I $D(^PS(52.45,"TYPE","NCI",IEN)),"UNSPECIFIED,GRAM"[DESC Q 1
I $D(^PS(52.45,"TYPE","NCI",IEN)),DESC="MILLILITER" Q 1
I '$D(^PS(52.45,"E","QuantityUnitOfMeasure",IEN)) Q 0
Q 1
GSIG ;
N DIC,DWLW,DWPK,DWDISABL,DIWESUB,TLEN,EDIT,X
S EDIT=0
S DIC="^TMP(""PSOERXA6"""_",$J,"
S DWLW=80,DWPK=1,DWDISABL="P"
S DIWESUB="Enter Sig Text"
D EN^DIWE
S X=0 F S X=$O(^TMP("PSOERXA6",$J,X)) Q:'X D
.S TLEN=$G(TLEN)+$L(^TMP("PSOERXA6",$J,X,0))
.I TLEN>1000 S EDIT=1
I EDIT W !,"Sig must be 1000 characters or less.",! D DIRE^PSOERXX1 G GSIG
Q
CONFIRM(TEXT) ;
N DIR,Y
S DIR(0)="Y"
S DIR("A")=TEXT
D ^DIR
I $D(DUOUT) Q U
Q Y
BL(GBL,CNT,TAG,VAR) ;
Q:VAR=""
D C S @GBL@(CNT,0)="<"_TAG_">"_$$SYMENC^MXMLUTL(VAR)_"</"_TAG_">"
Q
;
C ;
S CNT=$G(CNT)+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXON 11076 printed Nov 22, 2024@17:38:58 Page 2
PSOERXON ;ALB/BWF - eRx parsing Utilities ; 11/14/2019 3:46pm
+1 ;;7.0;OUTPATIENT PHARMACY;**581,746**;DEC 1997;Build 106
+2 ;
+3 QUIT
+4 ;
MEDCODES(GL,CNT,DATA) ;
+1 NEW MRC,MRSC
+2 SET MRC=$GET(DATA("MRCODE"))
+3 DO BL(GL,.CNT,"MessageRequestCode",MRC)
+4 SET MRSC=$GET(DATA("MRSCODE"))
+5 DO BL(GL,.CNT,"MessageRequestSubCode",MRSC)
+6 QUIT
+7 ;
MEDREQ(GL,CNT,DATA) ;
+1 NEW REQ,DRUGDAT,DRUG,DNDC,DNDCQ,ODATA,REF,DAYS,QTY,CLQ,QUOM,SIG,ODATA,NOTE,S
+2 SET REQ=0
FOR
SET REQ=$ORDER(DATA(REQ))
if 'REQ
QUIT
Begin DoDot:1
+3 SET DRUG=$PIECE(DATA(REQ),"^",2)
+4 SET DNDC=$PIECE(DATA(REQ),"^",3)
+5 SET DNDCQ=$PIECE(DATA(REQ),"^",4)
+6 SET SIG=""
+7 SET S=0
FOR
SET S=$ORDER(DATA(REQ,"SIG",S))
if 'S
QUIT
Begin DoDot:2
+8 SET SIG=$GET(SIG)_$GET(DATA(REQ,"SIG",S,0))_" "
End DoDot:2
+9 SET $EXTRACT(SIG,$LENGTH(SIG))=""
+10 SET REF=$PIECE(DATA(REQ),"^",10)+1
+11 SET DAYS=$PIECE(DATA(REQ),"^",9)
+12 SET QTY=$PIECE(DATA(REQ),"^",6)
+13 SET CLQ=$PIECE(DATA(REQ),"^",7)
+14 SET QUOM=$PIECE(DATA(REQ),"^",8)
+15 SET SUBS=$PIECE(DATA(REQ),"^",5)
+16 SET NOTE=$GET(DATA(REQ,"NOTE"))
+17 DO C
SET @GL@(CNT,0)="<MedicationRequested>"
+18 DO BL(GL,.CNT,"DrugDescription",DRUG)
+19 DO C
SET @GL@(CNT,0)="<DrugCoded>"
+20 DO C
SET @GL@(CNT,0)="<ProductCode>"
+21 DO BL(GL,.CNT,"Code",DNDC)
+22 DO BL(GL,.CNT,"Qualifier",DNDCQ)
+23 DO C
SET @GL@(CNT,0)="</ProductCode>"
+24 DO C
SET @GL@(CNT,0)="</DrugCoded>"
+25 IF QTY
Begin DoDot:2
+26 DO C
SET @GL@(CNT,0)="<Quantity>"
+27 DO BL(GL,.CNT,"Value",QTY)
+28 DO BL(GL,.CNT,"CodeListQualifier",CLQ)
+29 IF $LENGTH(QUOM)
Begin DoDot:3
+30 DO C
SET @GL@(CNT,0)="<QuantityUnitOfMeasure>"
+31 DO BL(GL,.CNT,"Code",QUOM)
+32 DO C
SET @GL@(CNT,0)="</QuantityUnitOfMeasure>"
End DoDot:3
+33 DO C
SET @GL@(CNT,0)="</Quantity>"
End DoDot:2
+34 DO BL(GL,.CNT,"DaysSupply",DAYS)
+35 DO BL(GL,.CNT,"Substitutions",SUBS)
+36 DO BL(GL,.CNT,"NumberOfRefills",REF)
+37 DO BL(GL,.CNT,"Note",NOTE)
+38 IF $LENGTH(SIG)
Begin DoDot:2
+39 DO C
SET @GL@(CNT,0)="<Sig>"
+40 DO BL(GL,.CNT,"SigText",SIG)
+41 DO C
SET @GL@(CNT,0)="</Sig>"
End DoDot:2
+42 DO C
SET @GL@(CNT,0)="</MedicationRequested>"
End DoDot:1
+43 QUIT
+44 ;
GETCODES(ERXIEN,MCODES) ;
+1 NEW ERXIENS,MRC,MRCC,MRSC,NOTE,I,CONT
+2 SET ERXIENS=ERXIEN_","
+3 DO DERX1^PSOERXD2(ERXIEN,ERXIENS,1)
+4 SET MRC=$$MRC(ERXIEN)
if 'MRC!(MRC<0)
QUIT ""
+5 IF MRC=U
QUIT ""
+6 SET MRCC=$PIECE(MRC,U,2)
+7 ; if the message request code us 'U' - Prescriber Authorization, message request subcode is required
+8 SET MCODES("MRCODE")=MRCC
+9 IF "PU"'[MRCC
QUIT 1
+10 IF MRCC="U"
Begin DoDot:1
+11 SET MRSC=$$MRSC()
+12 SET MCODES("MRSCODE")=$PIECE(MRSC,U,2)
End DoDot:1
+13 IF MRCC="U"
IF (MRSC<0)
QUIT ""
+14 IF MRCC="P"!(MRCC="U")
Begin DoDot:1
+15 SET NOTE=$$GNOTE()
+16 SET MCODES("NOTE")=NOTE
End DoDot:1
+17 if NOTE=U
QUIT ""
+18 SET CONT=$$CONFIRM("Would you like to send this Rx Change Request?")
+19 QUIT CONT
+20 ;
CRALLOW(ERXIEN) ;
+1 NEW ESTAT
+2 IF $$GET1^DIQ(52.49,ERXIEN,.08,"I")'="N"
QUIT 0
+3 SET ESTAT=$$GET1^DIQ(52.49,ERXIEN,1,"E")
+4 IF ESTAT="RJ"!(ESTAT="RM")!(ESTAT="CAN")!(ESTAT="CAC")
QUIT 0
+5 IF $$GET1^DIQ(52.49,ERXIEN,312.1,"I")'=1
QUIT 0
+6 QUIT 1
CHREQ(GL,ERXIEN,CNT,MEDREQ,MRC) ;
+1 NEW DIR,DIC,Y,X,DONE,NDC,NDCQ,SUBS,NOTE,REF,DAYS,QTY,CLQ,QUOM,SIG,SEQ,DNAME,QUOMINFO,CLQCODE,QTYDSRFL,MCNT,CLQARY
+2 NEW PSODRUG,NDC,DOSE,VERB,TSIG,UPD,QTYDSRFL,AGAIN,NOTEARY,RESP,PRCODE,PRCQUAL,CONTINUE,I,CRFOUND,MRCIEN,CL,ENDONE,NDCQUIT,NL,SL
+3 SET CRFOUND=0
+4 SET MRCIEN=$$PRESOLV^PSOERXA1(MRC,"MRC")
+5 ; TYPES P AND U are confirmed above.
+6 IF MRC="P"!(MRC="U")
QUIT 1
+7 SET ERXIENS=ERXIEN_","
+8 DO DERX1^PSOERXD2(ERXIEN,ERXIENS,1)
+9 SET (ENDONE,DONE)=0
SET MCNT=1
+10 FOR I=1:1
Begin DoDot:1
+11 SET NDCQUIT=0
KILL ^TMP("PSOERXA6",$JOB)
+12 ; initialize variables to ensure they do not fall through to the next entry
+13 SET (NOTE,DNAME,NDC,NDCQ,SUBS,QTY,CLQ,CLQCODE,QUOM,QUOMINFO,DAYS,REF,MEDREQ)=""
+14 KILL NOTEARY,CLARY
+15 SET NOTE=$$GNOTE()
IF NOTE=U
SET DONE=1
QUIT
+16 SET MEDREQ=$$SDRG(ERXIEN)
IF MEDREQ=U
SET DONE=1
QUIT
+17 SET DNAME=$PIECE(MEDREQ,U,2)
+18 IF $PIECE(MEDREQ,U)="E"
SET PRCODE=$PIECE(MEDREQ,U,3)
SET PRCQUAL=$PIECE(MEDREQ,U,4)
+19 SET MEDREQ=$PIECE(MEDREQ,U)
IF MEDREQ=""
SET DONE=1
QUIT
+20 IF MEDREQ'="E"
Begin DoDot:2
+21 ;Reference to $$GETNDC^PSSNDCUT supported by IA 4707
+22 SET NDC=$$GETNDC^PSSNDCUT(MEDREQ,$GET(PSOSITE))
SET NDC=$TRANSLATE(NDC,"-","")
+23 IF NDC']""
SET NDCQUIT=1
WRITE !!,"Missing NDC. Please select a different drug.",!
QUIT
+24 ; VA eRx will always be using NDC for the code and ND for the product code qualifier, hence the hard-coded value
+25 SET NDCQ="ND"
End DoDot:2
if NDCQUIT
QUIT
+26 SET SUBS=$$GSUBS()
IF SUBS=U
SET DONE=1
QUIT
+27 SET SUBS=$SELECT(SUBS="Y":0,1:1)
+28 DO TXT2ARY^PSOERXD1(.NOTEARY,"Note: "_NOTE)
+29 SET QTY=$$GQTY()
IF QTY=U
SET DONE=1
QUIT
+30 IF QTY
Begin DoDot:2
+31 SET CLQ=$$GCLQ()
IF CLQ=U
SET DONE=1
QUIT
+32 SET CLQCODE=$PIECE(CLQ,U,2)_" - "_$$GET1^DIQ(52.45,$PIECE(CLQ,U),.02,"E")
+33 DO TXT2ARY^PSOERXD1(.CLQARY,"Code List Qualifier: "_CLQCODE)
+34 SET QUOM=$$GQUOM()
IF QUOM=U
SET DONE=1
QUIT
+35 SET QUOMINFO=$PIECE(QUOM,U,2)_" - "_$$GET1^DIQ(52.45,$PIECE(QUOM,U),.02,"E")
End DoDot:2
+36 ;/JSG/ PSO*7.0*581 - BEGIN CHANGE (INITIALIZE VARIABLES)
+37 IF 'QTY
Begin DoDot:2
+38 SET (CLQ,CLQCODE,QUOM,QUOMINFO)=""
KILL CLQARY
End DoDot:2
+39 ;/JSG/ - END CHANGE
+40 if DONE
QUIT
+41 SET DAYS=$$GDAYS()
IF DAYS=U
SET DONE=1
QUIT
+42 SET REF=$$GREF()
IF REF=U
SET DONE=1
QUIT
+43 DO GSIG
+44 WRITE !!,"*************************** DETAILS ***************************"
+45 WRITE !,"Message Request Code: "_MRC_" - "_$$GET1^DIQ(52.45,MRCIEN,.02,"E")
+46 WRITE !,"Drug: "_DNAME
+47 IF MEDREQ'="E"
WRITE !,"NDC: "_NDC
+48 IF MEDREQ="E"
Begin DoDot:2
+49 WRITE !,"Product Code: "_PRCODE
+50 WRITE !,"Product Code Qualifier: "_PRCQUAL
End DoDot:2
+51 WRITE !,"Substitutions? "_$SELECT(SUBS=0:"Yes",1:"No")
+52 SET NL=0
FOR
SET NL=$ORDER(NOTEARY(NL))
if 'NL
QUIT
Begin DoDot:2
+53 WRITE !,NOTEARY(NL)
End DoDot:2
+54 WRITE !,"Refills: "_$GET(REF),?25,"Days Supply: "_$GET(DAYS),?55,"Quantity: "_$GET(QTY)
+55 ;/JSG/ PSO*7.0*581 - BEGIN CHANGE (Allow for empty Code List Qualifier)
+56 IF $DATA(CLQARY)\10
Begin DoDot:2
+57 SET CL=0
FOR
SET CL=$ORDER(CLQARY(CL))
if 'CL
QUIT
Begin DoDot:3
+58 WRITE !,$GET(CLQARY(CL))
End DoDot:3
End DoDot:2
+59 IF $DATA(CLQARY)<10
Begin DoDot:2
+60 WRITE !,"Code List Qualifier:"
End DoDot:2
+61 ;/JSG/ - END CHANGE
+62 WRITE !,"Quantity Unit Of Measure: "_$GET(QUOMINFO)
+63 WRITE !!,"Sig: "
+64 SET SL=0
FOR
SET SL=$ORDER(^TMP("PSOERXA6",$JOB,SL))
if 'SL
QUIT
Begin DoDot:2
+65 WRITE !,^TMP("PSOERXA6",$JOB,SL,0)
End DoDot:2
+66 WRITE !!,"****************************************************************",!!
+67 SET RESP=$$CONFIRM("Would you like to use the requested medication?")
IF RESP=U
SET DONE=1
QUIT
+68 if 'RESP
QUIT
+69 IF MEDREQ'="E"
SET MEDREQ(MCNT,"MEDICATION")=DNAME_U_NDC_U_NDCQ
+70 IF MEDREQ="E"
SET MEDREQ(MCNT,"MEDICATION")=DNAME_U_PRCODE_U_PRCQUAL
+71 SET MEDREQ(MCNT,"NOTE")=NOTE
+72 SET MEDREQ(MCNT,"OTHER")=REF_U_DAYS_U_QTY_U_$PIECE($GET(CLQ),U,2)_U_$PIECE($GET(QUOM),U,2)_U_SUBS
+73 MERGE MEDREQ(MCNT,"SIG")=^TMP("PSOERXA6",$JOB)
KILL ^TMP("PSOERXA6",$JOB)
+74 SET MCNT=MCNT+1
if MCNT>3
QUIT
+75 SET AGAIN=$$CONFIRM("Would you like to enter another requested medication?")
IF AGAIN=U!(AGAIN=0)
SET ENDONE=1
QUIT
+76 WRITE !!,"Now Entering a New Medication Requested:"
End DoDot:1
if DONE!(MCNT>3)!(ENDONE)
QUIT
+77 IF DONE=1
QUIT 0
+78 SET CONTINUE=$$CONFIRM("Would you like to send this Rx Change Request?")
+79 IF 'CONTINUE
WRITE !,"RxChangeRequest Cancelled."
DO DIRE^PSOERXX1
QUIT 0
+80 DO MEDREQ(GL,.CNT,.MEDREQ)
+81 KILL ^TMP("PSOERXA6",$JOB)
+82 QUIT 1
MRC(ERXIEN) ;
+1 NEW DIR,DIC,Y,X,DONE,MRC,MRCO,ESUBS,MIEN
+2 SET DIC("A")="Select RX change message request code: "
+3 SET DIC="^PS(52.45,"
SET DIC(0)="AEMQ"
+4 ; Surescripts
+5 ; "G" (Generic Substitution), may be used to request a prescriber allow the dispensing of a generic
+6 ; medication when substitution is not allowed by prescriber or regulations.
+7 ; substitutions = 0 - do not allow G
+8 ; = 1 - allow G
+9 SET MIEN=$ORDER(^PS(52.49,ERXIEN,311,"C","P",0))
+10 SET ESUBS=$$GET1^DIQ(52.49311,MIEN_","_ERXIEN_",",2.7,"I")
+11 IF 'ESUBS
SET DIC("S")="I $D(^PS(52.45,""TYPE"",""MRC"",Y)),$P(^PS(52.45,Y,0),U)'=""G"""
+12 IF ESUBS
SET DIC("S")="I $D(^PS(52.45,""TYPE"",""MRC"",Y))"
+13 DO ^DIC
KILL DIC
+14 IF $DATA(DUOUT)!(Y<1)
QUIT Y
+15 SET MRC=Y
SET MRCO=$$GET1^DIQ(52.45,MRC,.01,"E")
SET DONE=1
+16 IF $GET(MRC)
QUIT MRC_U_MRCO
+17 IF $DATA(DUOUT)
QUIT U
+18 QUIT Y
MRSC() ;
+1 NEW DIR,DIC,Y,X,DONE,MRC,MRCO
+2 SET DIC("A")="Select RX change message request sub-code: "
+3 SET DIC="^PS(52.45,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $D(^PS(52.45,""TYPE"",""MRSC"",Y))"
+4 DO ^DIC
KILL DIC
+5 IF $DATA(DUOUT)!(Y<1)
QUIT Y
+6 SET MRC=Y
SET MRCO=$$GET1^DIQ(52.45,MRC,.01,"E")
SET DONE=1
+7 IF $GET(MRC)
QUIT MRC_U_MRCO
+8 IF $DATA(DUOUT)
QUIT U
+9 QUIT Y
SDRG(ERXIEN) ;
+1 NEW DIC,DIR,MPIEN,ERXDRUG,DPRCODE,DPRCQUAL,ERET,Y,DUOUT,MPIENS
+2 SET MPIEN=$ORDER(^PS(52.49,ERXIEN,311,"C","P",0))
if 'MPIEN
QUIT ""
+3 SET MPIENS=MPIEN_","_ERXIEN_","
+4 IF MPIEN
SET ERXDRUG=$$GET1^DIQ(52.49311,MPIENS,.03,"E")
+5 WRITE !!,"eRx Drug: "_ERXDRUG
+6 SET DIR(0)="S^E:Use eRx Drug;S:Select from drug file"
DO ^DIR
+7 IF $DATA(DUOUT)
QUIT U
+8 IF Y="E"
Begin DoDot:1
+9 SET DPRCODE=$$GET1^DIQ(52.49311,MPIENS,1.1,"E")
+10 SET DPRCQUAL=$$GET1^DIQ(52.49311,MPIENS,1.2,"E")
+11 SET ERET="E"_U_ERXDRUG_U_DPRCODE_U_DPRCQUAL
End DoDot:1
QUIT ERET
+12 SET DIC(0)="AEMQ"
SET DIC=50
SET DIC("S")="I $$ACTIVE^PSOERXA0(Y),($$OUTPAT^PSOERXA0(Y)),('$$INVCOMP^PSOERXA0(Y)),('$$CS^PSOERXA0(Y))"
+13 DO ^DIC
KILL DIC
+14 IF $DATA(DUOUT)
QUIT U
+15 QUIT Y
GSUBS() ;
+1 NEW DIR,Y
+2 SET DIR(0)="S^Y:YES;N:NO"
SET DIR("A")="Substitutions?"
+3 SET DIR("B")="N"
+4 DO ^DIR
+5 IF $DATA(DUOUT)
QUIT U
+6 QUIT Y
GNOTE() ;
+1 NEW DIR,Y
+2 SET DIR(0)="FO^1:210"
SET DIR("A")="Note"
+3 DO ^DIR
+4 IF $DATA(DUOUT)
QUIT U
+5 QUIT Y
PATSTATS(ERXIEN) ;
+1 NEW PATIEN,Y,DIE,DR,DA,FDA,ANS,PATSTAT,DONE,PSODFN,STAT
+2 SET PATIEN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
+3 IF 'PATIEN
WRITE !!,"Patient has not been validated, cannot edit patient status",!
QUIT ""
+4 SET PSODFN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
+5 SET PATSTAT=$$GET1^DIQ(55,ERXIEN,3,"E")
+6 SET DIR("B")=PATSTAT
+7 SET DONE=0
KILL DA
+8 FOR
Begin DoDot:1
+9 SET DIR(0)="55,3"
SET DIR("A")="PATIENT STATUS"
DO ^DIR
KILL DIR
+10 IF Y=""
WRITE !,"This is a required response. Enter '^' to exit"
QUIT
+11 IF +Y
SET DONE=1
QUIT
+12 IF Y["^"
SET DONE=1
QUIT
End DoDot:1
if DONE
QUIT
+13 SET STAT=$PIECE(Y,"^",1)
+14 QUIT STAT
GQTY() ;
+1 NEW DIR,Y
+2 SET DIR(0)="NO^1:99999"
SET DIR("A")="Quantity"
+3 DO ^DIR
+4 IF $DATA(DUOUT)
QUIT U
+5 QUIT Y
GDAYS() ;
+1 NEW DIR,Y
+2 SET DIR(0)="NO^1:365"
SET DIR("A")="Days Supply"
+3 DO ^DIR
+4 IF $DATA(DUOUT)
QUIT U
+5 QUIT Y
GREF() ;
+1 NEW DIR,Y
+2 SET DIR(0)="NO^1:99"
SET DIR("A")="Refills"
+3 DO ^DIR
+4 IF $DATA(DUOUT)
QUIT U
+5 QUIT Y
GCLQ() ;
GCLQA NEW DIR,DIC,Y,X,DONE,MRC,MRCO
+1 SET DIC(0)="A"
+2 SET DIC("A")="Quantity Code List Qualifier: "
+3 SET DIC="^PS(52.45,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $D(^PS(52.45,""TYPE"",""QCQ"",Y))"
+4 DO ^DIC
KILL DIC
+5 IF $DATA(DUOUT)
QUIT U
+6 IF Y<0
WRITE !,"Response is required. Enter a value or '^' to quit."
GOTO GCLQA
+7 SET MRC=Y
SET MRCO=$$GET1^DIQ(52.45,MRC,.01,"E")
SET DONE=1
+8 IF $GET(MRC)
QUIT MRC_U_MRCO
+9 QUIT Y
GQUOM() ;
GQUOMA NEW DIR,DIC,Y,X,DONE,MRC,MRCO
+1 SET DIC(0)="A"
+2 SET DIC("A")="Quantity Unit Of Measure: "
+3 SET DIC="^PS(52.45,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $$CODES^PSOERXON(Y)"
+4 DO ^DIC
KILL DIC
+5 IF $DATA(DUOUT)
QUIT U
+6 IF Y<0
WRITE !,"Response is required. Enter a value or '^' to quit."
GOTO GQUOMA
+7 SET MRC=Y
SET MRCO=$$GET1^DIQ(52.45,MRC,.01,"E")
SET DONE=1
+8 IF $GET(MRC)
QUIT MRC_U_MRCO
+9 QUIT Y
CODES(IEN) ;
+1 NEW DESC
+2 ; must be an NCI code
+3 IF '$DATA(^PS(52.45,"TYPE","NCI",IEN))
QUIT 0
+4 ; codes Milliliter, Unspecified, and Gram are stored with a subtype of StrengthUnitOfMeasure, but need to be included.
+5 SET DESC=$$GET1^DIQ(52.45,IEN,.02,"E")
SET DESC=$$UP^XLFSTR(DESC)
+6 IF $DATA(^PS(52.45,"TYPE","NCI",IEN))
IF "UNSPECIFIED,GRAM"[DESC
QUIT 1
+7 IF $DATA(^PS(52.45,"TYPE","NCI",IEN))
IF DESC="MILLILITER"
QUIT 1
+8 IF '$DATA(^PS(52.45,"E","QuantityUnitOfMeasure",IEN))
QUIT 0
+9 QUIT 1
GSIG ;
+1 NEW DIC,DWLW,DWPK,DWDISABL,DIWESUB,TLEN,EDIT,X
+2 SET EDIT=0
+3 SET DIC="^TMP(""PSOERXA6"""_",$J,"
+4 SET DWLW=80
SET DWPK=1
SET DWDISABL="P"
+5 SET DIWESUB="Enter Sig Text"
+6 DO EN^DIWE
+7 SET X=0
FOR
SET X=$ORDER(^TMP("PSOERXA6",$JOB,X))
if 'X
QUIT
Begin DoDot:1
+8 SET TLEN=$GET(TLEN)+$LENGTH(^TMP("PSOERXA6",$JOB,X,0))
+9 IF TLEN>1000
SET EDIT=1
End DoDot:1
+10 IF EDIT
WRITE !,"Sig must be 1000 characters or less.",!
DO DIRE^PSOERXX1
GOTO GSIG
+11 QUIT
CONFIRM(TEXT) ;
+1 NEW DIR,Y
+2 SET DIR(0)="Y"
+3 SET DIR("A")=TEXT
+4 DO ^DIR
+5 IF $DATA(DUOUT)
QUIT U
+6 QUIT Y
BL(GBL,CNT,TAG,VAR) ;
+1 if VAR=""
QUIT
+2 DO C
SET @GBL@(CNT,0)="<"_TAG_">"_$$SYMENC^MXMLUTL(VAR)_"</"_TAG_">"
+3 QUIT
+4 ;
C ;
+1 SET CNT=$GET(CNT)+1
+2 QUIT
