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