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

PXRMORCH.m

Go to the documentation of this file. 
  1. PXRMORCH ;SLC/AGP - Reminder Order Checks API ;Jan 13, 2023@19:26
  1.  ;;2.0;CLINICAL REMINDERS;**16,22,26,47,45,71,65,84**;Feb 04, 2005;Build 2
  1.  ;
  1.  ;SAC EXEMPTION 20030908-01 : Use proper variable scoping instead of
  1.  ;                            namespace variable scoping
  1.  ;
  1.  ;Reference to $$OITM^ORX8 in ICR #3071
  1.  ;Reference to DATA^PSS50 in ICR #4533
  1.  ;Reference to DRGIEN^PSS50P7 in ICR #4662
  1.  ;Reference to FILE #79.2 in ICR #3505
  1.  ;Reference to ^ORD(101.43 in ICR #2843
  1.  ;Reference to FIELD #71.3 IN FILE #101.43 in ICR #7130
  1.  ;
  1.  Q
  1.  ;
  1. GETOCTXT(DFN,IEN,OI,SEV,PNAME,SUB,CNT) ;Get the Order Check text from
  1.  ;rule IEN.
  1.  N LC,NFL,NIN,NOUT,PXRMRM,TEXTIN,TEXTOUT
  1.  ;If formatted text is stored just copy it.
  1.  S NFL=$P(^PXD(801.1,IEN,5),U,2)
  1.  I NFL>0 D  Q
  1.  . F LC=1:1:NFL S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)=^PXD(801.1,IEN,6,LC,0)
  1.  ;
  1.  ;If there is no formatted text then the Order Check Text contains a
  1.  ;TIU Object so call the Found/Not Found Text expansion.
  1.  S NIN=$P(^PXD(801.1,IEN,5),U,1)
  1.  F LC=1:1:NIN S TEXTIN(LC)=^PXD(801.1,IEN,4,LC,0)
  1.  S PXRMRM=80,NOUT=0
  1.  D FNFTXTO^PXRMFNFT(1,NIN,.TEXTIN,DFN,"",.NOUT,.TEXTOUT)
  1.  F LC=1:1:NOUT S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)=TEXTOUT(LC)
  1.  Q
  1.  ;
  1. ADDRULES(TYPE,ITEM,LIST) ;
  1.  I ITEM'>0 Q
  1.  N IEN S IEN=0
  1.  F  S IEN=$O(^PXD(801,"AITEM",TYPE,ITEM,IEN)) Q:IEN'>0  S LIST(IEN)=""
  1.  Q
  1.  ;
  1. GETDRUG(DRGIEN,OI,LIST) ;
  1.  ;add rules assigned to the drug
  1.  D ADDRULES("DR",DRGIEN,.LIST)
  1.  D DATA^PSS50(DRGIEN,,DT,,,"PXRM DRUG")
  1.  I $G(^TMP($J,"PXRM DRUG",0))'>0 Q
  1.  ;add rules assigned to VA Generic
  1.  D ADDRULES("DG",$P($G(^TMP($J,"PXRM DRUG",DRGIEN,20)),U),.LIST)
  1.  ;add rules assigned to VA Drug Class
  1.  D ADDRULES("DC",$P($G(^TMP($J,"PXRM DRUG",DRGIEN,25)),U),.LIST)
  1.  ;add rules assigned to VA Product
  1.  D ADDRULES("DP",$P($G(^TMP($J,"PXRM DRUG",DRGIEN,22)),U),.LIST)
  1.  I OI>0 Q
  1.  ;get OI from DRUG
  1.  N IEN,PSOI
  1.  S PSOI=+$G(^TMP($J,"PXRM DRUG",DRGIEN,2.1)) I PSOI'>0 Q
  1.  S OI=$$OITM^ORX8(PSOI,"99PSP") I OI'>0 Q
  1.  S IEN=0 F  S IEN=$O(^PXD(801,"AITEM","OI",OI,IEN)) Q:IEN'>0  S LIST(IEN)=""
  1.  Q
  1.  ;
  1. GETRAD(OI,LIST) ;
  1.  N ITEMS,TYPE,TYPEIEN,RIEN,ERR,X
  1.  K ^TMP("DILIST",$J)
  1.  S TYPE=$$GET1^DIQ(101.43,OI,71.3) I TYPE="" Q
  1.  I TYPE="RADIOLOGY" S TYPE="GENERAL RADIOLOGY"
  1.  D FIND^DIC(79.2,"","@","BXU",TYPE,"","","","","ITEMS","ERR")
  1.  S X=0 F  S X=$O(ITEMS("DILIST",2,X)) Q:X'>0  D
  1.  .S TYPEIEN=+$G(ITEMS("DILIST",2,X))
  1.  .S RIEN=0 F  S RIEN=$O(^PXD(801,"AITEM","RA",TYPEIEN,RIEN)) Q:RIEN=""  S LIST(RIEN)=""
  1.  K ^TMP("DILIST",$J)
  1.  Q
  1.  ;
  1. GETRULES(OI,DRUG,LIST) ;
  1.  ;get rules for OI
  1.  N DRGIEN,IEN,OIID
  1.  S OIID=""
  1.  I OI>0 S IEN=0 F  S IEN=$O(^PXD(801,"AITEM","OI",OI,IEN)) Q:IEN'>0  S LIST(IEN)=""
  1.  ;detemine if pharmacy OI
  1.  I OI>0 S OIID=$P($G(^ORD(101.43,OI,0)),U,2) I OIID'["PSP",OIID'["RAP" Q
  1.  K ^TMP($J,"PXRM DRUG LIST"),^TMP($J,"PXRM DRUG")
  1.  I DRUG>0 D GETDRUG(DRUG,OI,.LIST) G GETRULEX
  1.  I OIID["PSP" D
  1.  .;get drug(s) assocaited with the OI DBIA 4662
  1.  .D DRGIEN^PSS50P7(+OIID,DT,"PXRM DRUG LIST")
  1.  .I $G(^TMP($J,"PXRM DRUG LIST",0))'>0 Q
  1.  .S DRGIEN=0
  1.  .F  S DRGIEN=$O(^TMP($J,"PXRM DRUG LIST",DRGIEN)) Q:DRGIEN'>0  D GETDRUG(DRGIEN,OI,.LIST)
  1.  I OIID["RAP" D GETRAD(OI,.LIST)
  1. GETRULEX ;
  1.  K ^TMP($J,"PXRM DRUG LIST"),^TMP($J,"PXRM DRUG")
  1.  Q
  1.  ;
  1. ORDERCHK(DFN,OI,TEST,DRUG,TESTER) ;
  1.  ;main order check API check for order checks for all Order Check Groups
  1.  ;Input
  1.  ;  OI=IEN of Orderable Item from file 101.43
  1.  ;  DFN=Patient DFN
  1.  ;  TEST=Value that matches the Testing Flag either 1 or 0
  1.  ;
  1.  ;Output
  1.  ;  ^TMP($J,OI,SEV,DISPLAY NAME,n)=TEXT
  1.  ;  SEV=is the value assigned to the severity field
  1.  ;  DISPLAY NAME=is the value assigned to the Display Field Name
  1.  ;
  1.  N RULES,SUB
  1.  ;
  1.  ;
  1.  S SUB=$S(DRUG>0:DRUG,1:OI)
  1.  I +SUB=0 Q
  1.  K ^TMP($J,SUB)
  1.  D GETRULES(OI,DRUG,.RULES)
  1.  D PROCESS(SUB,OI,TEST,TESTER,.RULES)
  1.  Q
  1.  ;
  1.  ; entry point used to look for groups for a specific orderable item
  1. GETGRPS(OI,GROUPS) ;
  1.  N OIID,DRGIEN,TYPE,TYPEIEN,ERR
  1.  I $G(OI)'?1.N Q
  1.  K GROUPS
  1.  ;add groups containing orderable item
  1.  D OLOOP(OI_";ORD(101.43,",.GROUPS)
  1.  ;determine type of item, quit if not pharmacy or radiology
  1.  S OIID=$P($G(^ORD(101.43,OI,0)),U,2) I OIID'["PSP",OIID'["RAP" Q
  1.  I OIID["PSP" D
  1.  .;get drug(s) associated with the OI DBIA 4662
  1.  .D DRGIEN^PSS50P7(+OIID,DT,"PXRM DRUG LIST")
  1.  .I $G(^TMP($J,"PXRM DRUG LIST",0))'>0 Q
  1.  .S DRGIEN=0
  1.  .F  S DRGIEN=$O(^TMP($J,"PXRM DRUG LIST",DRGIEN)) Q:DRGIEN'>0  D
  1.  ..;get drug information DBIA 4533
  1.  ..D DATA^PSS50(DRGIEN,,DT,,,"PXRM DRUG")
  1.  ..I $G(^TMP($J,"PXRM DRUG",0))'>0 Q
  1.  ..;add groups containing VA Generic
  1.  ..D OLOOP($P($G(^TMP($J,"PXRM DRUG",DRGIEN,20)),U)_";PSNDF(50.6,",.GROUPS)
  1.  ..;add groups containing VA Drug Class
  1.  ..D OLOOP($P($G(^TMP($J,"PXRM DRUG",DRGIEN,25)),U)_";PS(50.605,",.GROUPS)
  1.  ..;add groups containing VA Product
  1.  ..D OLOOP($P($G(^TMP($J,"PXRM DRUG",DRGIEN,22)),U)_";PSNDF(50.68,",.GROUPS)
  1.  .K ^TMP($J,"PXRM DRUG LIST"),^TMP($J,"PXRM DRUG")
  1.  I OIID["RAP" D
  1.  .S TYPE=$$GET1^DIQ(101.43,OI,71.3) I TYPE="" Q
  1.  .I TYPE="RADIOLOGY" S TYPE="GENERAL RADIOLOGY"
  1.  .S TYPEIEN=$$FIND1^DIC(79.2,"","X",TYPE,"","","ERR")
  1.  .;add groups containing radiology procedure
  1.  .D OLOOP(TYPEIEN_";RA(79.2,",.GROUPS)
  1.  Q
  1.  ;
  1.  ; entry point used to loop through O index
  1. OLOOP(VPOINTER,GROUPS) ;
  1.  N IEN,GNAME
  1.  S IEN=0 F  S IEN=$O(^PXD(801,"O",VPOINTER,IEN)) Q:'+IEN  D
  1.  .S GNAME=$P($G(^PXD(801,IEN,0)),U) Q:GNAME=""
  1.  .S GROUPS(GNAME)=""
  1.  Q
  1.  ;
  1.  ; entry point used to look for order checks for a specific list of groups.
  1.  ;INPUT and OUTPUT defined ORDERCHK
  1. ORDERGRP(DFN,OI,TEST,DRUG,GROUPS) ;
  1.  N GIEN,GROUP,GRULES,RULE,RULES,SUB
  1.  S SUB=$S(DRUG>0:DRUG,1:OI)
  1.  K ^TMP($J,SUB)
  1.  S GROUP="" F  S GROUP=$O(GROUPS(GROUP)) Q:GROUP=""  D
  1.  .I GROUP=+GROUP,($D(^PXD(801,GROUP,0))) S GIEN=GROUP
  1.  .E  S GIEN=+$O(^PXD(801,"B",GROUP,""))
  1.  .Q:GIEN=0
  1.  .S RULE=0 F  S RULE=$O(^PXD(801,GIEN,3,"B",RULE)) Q:RULE'>0  S GRULES(RULE,GROUP)=""
  1.  D GETRULES(OI,DRUG,.RULES)
  1.  S RULE=0 F  S RULE=$O(RULES(RULE)) Q:RULE'>0  I '$D(GRULES(RULE)) K RULES(RULE)
  1.  D PROCESS(SUB,OI,TEST,0,.RULES)
  1.  Q
  1.  ;
  1. PROCESS(SUB,OI,TEST,TESTER,RULES) ;
  1.  N CNT,FIEVAL,FLAG,IEN,IENOI,IENR,NODE,NUM,OIREM,PNAME,RIEN,RNAME
  1.  N REMEVLST,RSTAT,SEV,TEXTTYPE,TIEN,TNAME,TSTAT,PXRMSRCFF
  1.  S PXRMSRCFF=1
  1.  S IEN=0 F  S IEN=$O(RULES(IEN)) Q:IEN'>0  D
  1.  .S NODE=$G(^PXD(801.1,IEN,0))
  1.  .S FLAG=$P(NODE,U,3)
  1.  .I FLAG="I" Q
  1.  .I TEST=1,FLAG="P" Q
  1.  .I TEST=0,FLAG="T" Q
  1.  .S PNAME=$P(NODE,U,2)
  1.  .S SEV=$P(NODE,U,5)
  1.  .S TIEN=$P($G(^PXD(801.1,IEN,2)),U)
  1.  .;
  1.  .;Reminder Term defined used branching logic code
  1.  .I TIEN>0 D  Q
  1.  ..S TSTAT=$$TERM^PXRMDLLB(TIEN,DFN,IEN,"O",.FIEVAL)
  1.  ..S CNT=0
  1.  ..I TSTAT=-1 D  Q
  1.  ...S CNT=CNT+1,^TMP($J,SUB,3,PNAME,CNT)="Clinical Reminder evaluation error; this order check cannot be processed."
  1.  ...S CNT=CNT+1,^TMP($J,SUB,3,PNAME,CNT)="Please contact the reminder manager for assistance."
  1.  ...I TESTER=0 D SENDMSG(DFN,"order check rule",PNAME,"term",TIEN)
  1.  ..I $D(^XTMP("PXRM_DISEV",0)) D  Q
  1.  ...S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)="Clinical Reminder evaluation is currently disabled; this order check cannot"
  1.  ...S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)="be processed." Q
  1.  ..I TESTER=1 D
  1.  ...S TNAME=$P(^PXRMD(811.5,TIEN,0),U)
  1.  ...S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)="INTERNAL: Reminder Term: "_TNAME_" Status: "_$S(TSTAT=1:"True",1:"False")
  1.  ...;S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)=" "
  1.  ..I TSTAT'=$P(^PXD(801.1,IEN,2),U,2) D  Q
  1.  ...I TESTER=1 D
  1.  ....S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)="RULE FAILED"
  1.  ....S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)=" "
  1.  ..;load order check text needs to be converted
  1.  ..D GETOCTXT(DFN,IEN,OI,SEV,PNAME,SUB,.CNT)
  1.  ..K ^TMP("PXRM BL DATA",$J)
  1.  .;if not TERM do reminder evaluation
  1.  .S NODE=$G(^PXD(801.1,IEN,3))
  1.  .S RIEN=$P(NODE,U),RSTAT=$P(NODE,U,2),TEXTTYPE=$P(NODE,U,3)
  1.  .S NODE=$G(^PXD(811.9,RIEN,0))
  1.  .;
  1.  .S RNAME=$S($P(NODE,U,3)'="":$P(NODE,U,3),1:$P(NODE,U))
  1.  .D REMEVAL(DFN,OI,RIEN,PNAME,IEN,RNAME,TEXTTYPE,RSTAT,SEV,SUB,TESTER)
  1.  Q
  1.  ;
  1.  ;
  1. REMEVAL(DFN,OI,RIEN,PNAME,IEN,RNAME,TEXTTYPE,RSTAT,SEV,SUB,TESTER) ;
  1.  ;used by ORDECHK this does the reminder evaluation and put the
  1.  ;reminder text in the temp global
  1.  K ^TMP("PXRHM",$J),^TMP("PXRMORTMP",$J)
  1.  N CNT,NUM,STATUS,PXRMDEFS
  1.  S CNT=0
  1.  ;
  1.  ;standard reminder evaluation results, final output like the
  1.  ;HS COMPONENT REMINDER FINDINGS
  1.  ;
  1.  D MAIN^PXRM(DFN,RIEN,55,1)
  1.  S STATUS=$P($G(^TMP("PXRHM",$J,RIEN,RNAME)),U)
  1.  I STATUS="ERROR" D  G REMEVALX
  1.  .S CNT=CNT+1,^TMP($J,SUB,3,PNAME,CNT)="Clinical Reminder evaluation error; this order check cannot be processed."
  1.  .S CNT=CNT+1,^TMP($J,SUB,3,PNAME,CNT)="Please contact the reminder manager for assistance."
  1.  .I TESTER=0 D SENDMSG(DFN,"order check rule",PNAME,"definition",RIEN)
  1.  I (STATUS="CNBD") D  G REMEVALX
  1.  .S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)="Clinical Reminder evaluation is currently disabled; this order check cannot"
  1.  .S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)="be processed."
  1.  I TESTER=1 D
  1.  .S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)="INTERNAL: Reminder Definition: "_RNAME_" Status: "_STATUS
  1.  ;if not valid status return error message
  1.  ;if Reminder Status does not match status field quit.
  1.  I $$STATMTCH(STATUS,RSTAT)=0 D  G REMEVALX
  1.  .I TESTER=1 D
  1.  ..S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)="RULE FAILED"
  1.  ..S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)=" "
  1.  ;save off the evaluation temp global into another global. This
  1.  ;prevent a problem with TIU Objects for reminder evaluation
  1.  M ^TMP("PXRMORTMP",$J)=^TMP("PXRHM",$J)
  1.  ;
  1.  S NUM=0
  1.  ;load order check text if requested
  1.  I TEXTTYPE="O"!(TEXTTYPE="B") D GETOCTXT(DFN,IEN,OI,SEV,PNAME,SUB,.CNT)
  1.  I TEXTTYPE="O" G REMEVALX
  1.  ;
  1.  I TEXTTYPE="B" S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)=""
  1.  ;build reminder text if requested
  1.  F  S NUM=$O(^TMP("PXRMORTMP",$J,RIEN,RNAME,"TXT",NUM)) Q:NUM'>0  D
  1.  .S CNT=CNT+1
  1.  .S ^TMP($J,SUB,SEV,PNAME,CNT)=$G(^TMP("PXRMORTMP",$J,RIEN,RNAME,"TXT",NUM))
  1. REMEVALX ;EXIT AND CLEAN UP ^TMP
  1.  K ^TMP("PXRHM",$J),^TMP("PXRMORTMP",$J)
  1.  Q
  1.  ;
  1. STATMTCH(REMSTAT,RULESTAT) ;
  1.  I RULESTAT="D",REMSTAT["DUE" Q 1
  1.  I RULESTAT="A",REMSTAT'="N/A",REMSTAT'="NEVER",REMSTAT'="CONTRA",REMSTAT'="REFUSED" Q 1
  1.  I RULESTAT="N",$E(REMSTAT,1)="N"!(REMSTAT="CONTRA")!(REMSTAT="REFUSED") Q 1
  1.  I RULESTAT="R",REMSTAT["RESOLVE" Q 1
  1.  Q 0
  1.  ;
  1. SENDMSG(PAT,TYPE,NAME,ITYPE,IIEN) ;
  1.  K ^TMP("PXRMXMZ",$J)
  1.  N CNT,ERRORTXT,GBL,HEADER,ITEM,PNAME
  1.  S PNAME=$$GET1^DIQ(2,PAT,.01)
  1.  S HEADER="Evaluation error in a Reminder "_TYPE
  1.  S GBL=$S(ITYPE["def":"^PXD(811.9)",ITYPE["dial":"^PXRMD(801.41)",ITYPE["order":"^PXD(801.1)",ITYPE["term":"^PXRMD(811.5)",1:"")
  1.  S ITEM=$S(GBL'="":$P($G(@GBL@(IIEN,0)),U),1:"")
  1.  S CNT=1,^TMP("PXRMXMZ",$J,CNT,0)="Error evaluating a reminder "_ITYPE_" "_ITEM
  1.  S CNT=CNT+1,^TMP("PXRMXMZ",$J,CNT,0)="on patient "_PNAME_" (DFN: "_PAT_")."
  1.  S CNT=CNT+1,^TMP("PXRMXMZ",$J,CNT,0)="This error was found when processing a Reminder "_TYPE_" "_NAME_"."
  1.  D SEND^PXRMMSG("PXRMXMZ",HEADER,"",DUZ)
  1.  K ^TMP("PXRMXMZ",$J)
  1.  Q
  1.  ;