PXRMORCH ;SLC/AGP - Reminder Order Checks API;05/14/2014
;;2.0;CLINICAL REMINDERS;**16,22,26**;Feb 04, 2005;Build 404
;
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,"ADRUGR",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)
;get drug information DBIA 4533
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)
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,"AOIR",OI,IEN)) Q:IEN'>0 S LIST(IEN)=""
Q
;
GETRULES(OI,DRUG,LIST) ;
;get rules for OI
N DRGIEN,IEN,OIID
I OI>0 S IEN=0 F S IEN=$O(^PXD(801,"AOIR",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" Q
K ^TMP($J,"PXRM DRUG LIST"),^TMP($J,"PXRM DRUG")
I DRUG>0 D GETDRUG(DRUG,OI,.LIST) G GETRULEX
;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)
GETRULEX ;
K ^TMP($J,"PXRM DRUG LIST"),^TMP($J,"PXRM DRUG")
Q
;
ORDERCHK(DFN,OI,TEST,DRUG,TESTER) ;
;main order check API
;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
;
;K ^TMP($J,OI)
N CNT,FLAG,IEN,IENOI,IENR,NODE,NUM,OIREM,PNAME,RIEN,RNAME
N RULES,REMEVLST,RSTAT,SEV,SUB,TEXTTYPE,TIEN,TNAME,TSTAT
;
;loop through AOIR xref to find the group IEN and the corresponding
;Rules assigned to the orderable item
;
S SUB=$S(DRUG>0:DRUG,1:OI)
K ^TMP($J,SUB)
D GETRULES(OI,DRUG,.RULES)
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=IEN_U_$P(NODE,U,2)
.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")
..S CNT=0
..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,3,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)
.;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,TEXTTYE,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
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 TESTER=1 D
.S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)="INTERNAL: Reminder Definition: "_RNAME_" Status: "_STATUS
.;S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)=" "
;if not valid status return error message
I (STATUS="CNBD")!(STATUS="ERROR") D Q
.S CNT=CNT+1,^TMP($J,SUB,3,PNAME,CNT)="Clinical Reminder evaluation is currently disabled; this order check cannot"
.S CNT=CNT+1,^TMP($J,SUB,3,PNAME,CNT)="be processed."
;if Reminder Status does not match status field quit.
I $$STATMTCH(STATUS,RSTAT)=0 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)=" "
;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" Q
;
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))
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" Q 1
I RULESTAT="N",$E(REMSTAT,1)="N" Q 1
Q 0
;
PXRMORCH ;SLC/AGP - Reminder Order Checks API;05/14/2014
+1 ;;2.0;CLINICAL REMINDERS;**16,22,26**;Feb 04, 2005;Build 404
+2 ;
+3 QUIT
+4 ;
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,"ADRUGR",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 ;get drug information DBIA 4533
+4 DO DATA^PSS50(DRGIEN,,DT,,,"PXRM DRUG")
+5 IF $GET(^TMP($JOB,"PXRM DRUG",0))'>0
QUIT
+6 ;add rules assigned to VA Generic
+7 DO ADDRULES("DG",$PIECE($GET(^TMP($JOB,"PXRM DRUG",DRGIEN,20)),U),.LIST)
+8 ;add rules assigned to VA Drug Class
+9 DO ADDRULES("DC",$PIECE($GET(^TMP($JOB,"PXRM DRUG",DRGIEN,25)),U),.LIST)
+10 IF OI>0
QUIT
+11 ;get OI from DRUG
+12 NEW IEN,PSOI
+13 SET PSOI=+$GET(^TMP($JOB,"PXRM DRUG",DRGIEN,2.1))
IF PSOI'>0
QUIT
+14 SET OI=$$OITM^ORX8(PSOI,"99PSP")
IF OI'>0
QUIT
+15 SET IEN=0
FOR
SET IEN=$ORDER(^PXD(801,"AOIR",OI,IEN))
IF IEN'>0
QUIT
SET LIST(IEN)=""
+16 QUIT
+17 ;
GETRULES(OI,DRUG,LIST) ;
+1 ;get rules for OI
+2 NEW DRGIEN,IEN,OIID
+3 IF OI>0
SET IEN=0
FOR
SET IEN=$ORDER(^PXD(801,"AOIR",OI,IEN))
IF IEN'>0
QUIT
SET LIST(IEN)=""
+4 ;detemine if pharmacy OI
+5 IF OI>0
SET OIID=$PIECE($GET(^ORD(101.43,OI,0)),U,2)
IF OIID'["PSP"
QUIT
+6 KILL ^TMP($JOB,"PXRM DRUG LIST"),^TMP($JOB,"PXRM DRUG")
+7 IF DRUG>0
DO GETDRUG(DRUG,OI,.LIST)
GOTO GETRULEX
+8 ;get drug(s) assocaited with the OI DBIA 4662
+9 DO DRGIEN^PSS50P7(+OIID,DT,"PXRM DRUG LIST")
+10 IF $GET(^TMP($JOB,"PXRM DRUG LIST",0))'>0
QUIT
+11 SET DRGIEN=0
+12 FOR
SET DRGIEN=$ORDER(^TMP($JOB,"PXRM DRUG LIST",DRGIEN))
IF DRGIEN'>0
QUIT
DO GETDRUG(DRGIEN,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
+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 ;K ^TMP($J,OI)
+13 NEW CNT,FLAG,IEN,IENOI,IENR,NODE,NUM,OIREM,PNAME,RIEN,RNAME
+14 NEW RULES,REMEVLST,RSTAT,SEV,SUB,TEXTTYPE,TIEN,TNAME,TSTAT
+15 ;
+16 ;loop through AOIR xref to find the group IEN and the corresponding
+17 ;Rules assigned to the orderable item
+18 ;
+19 SET SUB=$SELECT(DRUG>0:DRUG,1:OI)
+20 KILL ^TMP($JOB,SUB)
+21 DO GETRULES(OI,DRUG,.RULES)
+22 SET IEN=0
FOR
SET IEN=$ORDER(RULES(IEN))
IF IEN'>0
QUIT
Begin DoDot:1
+23 SET NODE=$GET(^PXD(801.1,IEN,0))
+24 SET FLAG=$PIECE(NODE,U,3)
+25 IF FLAG="I"
QUIT
+26 IF TEST=1
IF FLAG="P"
QUIT
+27 IF TEST=0
IF FLAG="T"
QUIT
+28 ;S PNAME=IEN_U_$P(NODE,U,2)
+29 SET PNAME=$PIECE(NODE,U,2)
+30 SET SEV=$PIECE(NODE,U,5)
+31 SET TIEN=$PIECE($GET(^PXD(801.1,IEN,2)),U)
+32 ;
+33 ;Reminder Term defined used branching logic code
+34 IF TIEN>0
Begin DoDot:2
+35 SET TSTAT=$$TERM^PXRMDLLB(TIEN,DFN,IEN,"O")
+36 SET CNT=0
+37 IF $DATA(^XTMP("PXRM_DISEV",0))
Begin DoDot:3
+38 SET CNT=CNT+1
SET ^TMP($JOB,SUB,SEV,PNAME,CNT)="Clinical Reminder evaluation is currently disabled; this order check cannot"
+39 SET CNT=CNT+1
SET ^TMP($JOB,SUB,SEV,PNAME,CNT)="be processed."
QUIT
End DoDot:3
QUIT
+40 IF TESTER=1
Begin DoDot:3
+41 SET TNAME=$PIECE(^PXRMD(811.5,TIEN,0),U)
+42 SET CNT=CNT+1
SET ^TMP($JOB,SUB,3,PNAME,CNT)="INTERNAL: Reminder Term: "_TNAME_" Status: "_$SELECT(TSTAT=1:"True",1:"False")
+43 ;S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)=" "
End DoDot:3
+44 IF TSTAT'=$PIECE(^PXD(801.1,IEN,2),U,2)
Begin DoDot:3
+45 IF TESTER=1
Begin DoDot:4
+46 SET CNT=CNT+1
SET ^TMP($JOB,SUB,SEV,PNAME,CNT)="RULE FAILED"
+47 SET CNT=CNT+1
SET ^TMP($JOB,SUB,SEV,PNAME,CNT)=" "
End DoDot:4
End DoDot:3
QUIT
+48 ;load order check text needs to be converted
+49 DO GETOCTXT(DFN,IEN,OI,SEV,PNAME,SUB,.CNT)
End DoDot:2
QUIT
+50 ;if not TERM do reminder evaluation
+51 SET NODE=$GET(^PXD(801.1,IEN,3))
+52 SET RIEN=$PIECE(NODE,U)
SET RSTAT=$PIECE(NODE,U,2)
SET TEXTTYPE=$PIECE(NODE,U,3)
+53 SET NODE=$GET(^PXD(811.9,RIEN,0))
+54 ;
+55 SET RNAME=$SELECT($PIECE(NODE,U,3)'="":$PIECE(NODE,U,3),1:$PIECE(NODE,U))
+56 DO REMEVAL(DFN,OI,RIEN,PNAME,IEN,RNAME,TEXTTYPE,RSTAT,SEV,SUB,TESTER)
End DoDot:1
+57 QUIT
+58 ;
+59 ;
REMEVAL(DFN,OI,RIEN,PNAME,IEN,RNAME,TEXTTYE,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
+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 TESTER=1
Begin DoDot:1
+13 SET CNT=CNT+1
SET ^TMP($JOB,SUB,SEV,PNAME,CNT)="INTERNAL: Reminder Definition: "_RNAME_" Status: "_STATUS
+14 ;S CNT=CNT+1,^TMP($J,SUB,SEV,PNAME,CNT)=" "
End DoDot:1
+15 ;if not valid status return error message
+16 IF (STATUS="CNBD")!(STATUS="ERROR")
Begin DoDot:1
+17 SET CNT=CNT+1
SET ^TMP($JOB,SUB,3,PNAME,CNT)="Clinical Reminder evaluation is currently disabled; this order check cannot"
+18 SET CNT=CNT+1
SET ^TMP($JOB,SUB,3,PNAME,CNT)="be processed."
End DoDot:1
QUIT
+19 ;if Reminder Status does not match status field quit.
+20 IF $$STATMTCH(STATUS,RSTAT)=0
Begin DoDot:1
+21 IF TESTER=1
Begin DoDot:2
+22 SET CNT=CNT+1
SET ^TMP($JOB,SUB,SEV,PNAME,CNT)="RULE FAILED"
+23 SET CNT=CNT+1
SET ^TMP($JOB,SUB,SEV,PNAME,CNT)=" "
End DoDot:2
End DoDot:1
QUIT
+24 ;save off the evaluation temp global into another global. This
+25 ;prevent a problem with TIU Objects for reminder evaluation
+26 MERGE ^TMP("PXRMORTMP",$JOB)=^TMP("PXRHM",$JOB)
+27 ;
+28 SET NUM=0
+29 ;load order check text if requested
+30 IF TEXTTYPE="O"!(TEXTTYPE="B")
DO GETOCTXT(DFN,IEN,OI,SEV,PNAME,SUB,.CNT)
+31 IF TEXTTYPE="O"
QUIT
+32 ;
+33 IF TEXTTYPE="B"
SET CNT=CNT+1
SET ^TMP($JOB,SUB,SEV,PNAME,CNT)=""
+34 ;build reminder text if requested
+35 FOR
SET NUM=$ORDER(^TMP("PXRMORTMP",$JOB,RIEN,RNAME,"TXT",NUM))
IF NUM'>0
QUIT
Begin DoDot:1
+36 SET CNT=CNT+1
+37 SET ^TMP($JOB,SUB,SEV,PNAME,CNT)=$GET(^TMP("PXRMORTMP",$JOB,RIEN,RNAME,"TXT",NUM))
End DoDot:1
+38 KILL ^TMP("PXRHM",$JOB),^TMP("PXRMORTMP",$JOB)
+39 QUIT
+40 ;
STATMTCH(REMSTAT,RULESTAT) ;
+1 IF RULESTAT="D"
IF REMSTAT["DUE"
QUIT 1
+2 IF RULESTAT="A"
IF REMSTAT'="N/A"
IF REMSTAT'="NEVER"
QUIT 1
+3 IF RULESTAT="N"
IF $EXTRACT(REMSTAT,1)="N"
QUIT 1
+4 QUIT 0
+5 ;
