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

PSOERXON.m

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