PXRMGEVA ;SLC/AGP,RFR - Generic entry point to run different Reminder Evaluation ;Jan 13, 2023@17:06
;;2.0;CLINICAL REMINDERS;**45,71,84**;Feb 04, 2005;Build 2
;
; Reference to OIS^ORX8 in ICR #2467
; Reference to EN^ORQ1 in ICR #3154
; Reference to EN^ORX8 in ICR #871
; Reference to PKGID^ORX8 in ICR #3071
; Reference to VALUE^ORX8 in ICR #2467
; Reference to ^ORD(100.98,"B", in ICR #873
;
ERROR(RESULT,MSG) ;
S @RESULT@(0)=-1_U_MSG
Q
;
FINDDGS(RESULT,INPUT) ;
N FAIL,IEN,NAME
S NAME="",FAIL=0 F S NAME=$O(INPUT("ROC DISPLAY GROUPS",NAME)) Q:NAME=""!(FAIL>0) D
.S IEN=$O(^ORD(100.98,"B",NAME,"")) I IEN'>0 D ERROR(.RESULT,"Could not find Display Group: "_NAME) S FAIL=1
.S INPUT("DG IEN",IEN)=""
.S INPUT("DG IEN",IEN,"START")=+$G(INPUT("ROC DISPLAY GROUPS",NAME,"START"))
.S INPUT("DG IEN",IEN,"STOP")=+$G(INPUT("ROC DISPLAY GROUPS",NAME,"STOP"))
Q
;
GETOIS(INPUT) ; find orderable items for each order
N CNT,NUM,ARRAY,OI,ORDIEN,POS,PXRMOIS
S ORDIEN=0 F S ORDIEN=$O(INPUT("ROC ORDERS",ORDIEN)) Q:ORDIEN'>0 D
.K PXRMOIS D OIS^ORX8(.PXRMOIS,ORDIEN) I '$D(PXRMOIS) Q
.M INPUT("ROC ORDERS",ORDIEN,"OI")=PXRMOIS
Q
;
GTORDERS(INPUT) ;
N DIEN,DATE,END,NODE,PAT,ORDIEN,ORN,PXRMOIS,START,STOP,ORLIST,MOD,PXRMINST,ORUPCHUK
S PAT=$G(INPUT("DFN"))
S DIEN=0 F S DIEN=$O(INPUT("DG IEN",DIEN)) Q:DIEN'>0 D
.K ^TMP("ORR",$J)
.S START=$S(INPUT("DG IEN",DIEN,"START")>0:INPUT("DG IEN",DIEN,"START"),1:$G(INPUT("ROC START")))
.S STOP=$S(INPUT("DG IEN",DIEN,"STOP")>0:INPUT("DG IEN",DIEN,"STOP"),1:$G(INPUT("ROC STOP")))
.;call for current activities
.D EN^ORQ1(PAT_";DPT(",DIEN,1,,START,STOP,1)
.S DATE="" F S DATE=$O(^TMP("ORR",$J,DATE)) Q:DATE="" D
..F ORN=1:1:$G(^TMP("ORR",$J,DATE,"TOT")) D
...S NODE=$G(^TMP("ORR",$J,DATE,ORN))
...I $D(INPUT("ROC ORDERS",+$P(NODE,U))) Q
...I ('$D(INPUT("ROC STATUS","*"))&('$D(INPUT("ROC STATUS",$P(NODE,U,6))))) Q
...I $D(INPUT("ROC ORDERED WITHIN"))&(($P(NODE,U,3)<START)!($P(NODE,U,3)>STOP)) Q
...S ORDIEN=+$P(NODE,U)
...D EN^ORX8(ORDIEN)
...S NODE=NODE_U_$P(ORUPCHUK("ORNP"),U)
...K ORUPCHUK
...S INPUT("ROC ORDERS",ORDIEN)=NODE
...M INPUT("ROC ORDERS",ORDIEN,"TX")=^TMP("ORR",$J,DATE,ORN,"TX")
...S INPUT("ROC ORDERS",ORDIEN,"PKG ID")=$$PKGID^ORX8(ORDIEN)
...F PXRMINST=1:1 S MOD=$$VALUE^ORX8(ORDIEN,"MODIFIER",PXRMINST,"E") Q:MOD="" D
....S INPUT("ROC ORDERS",ORDIEN,"MODIFIERS",PXRMINST)=MOD
...K PXRMOIS D OIS^ORX8(.PXRMOIS,ORDIEN)
...I $D(PXRMOIS) M INPUT("ROC ORDERS",ORDIEN,"OI")=PXRMOIS
K ^TMP("ORR",$J)
Q
;
GETVAL(INPUT,TYPE) ;
Q $G(INPUT("VARIABLES",TYPE))
;
REM(RESULT,INPUT) ; controller for reminder evaluation types
I $D(INPUT("LR")) D REMLIST(.RESULT,.INPUT) Q
I $D(INPUT("REMINDERS")) D REMEVAL(.RESULT,.INPUT) Q
D REMOC(.RESULT,.INPUT)
Q
;
REMMDEF(INPUT,DEFARR) ; update DEFARR with modifiers
N ITEM,NUM,SUB,PIECE,TEMP,VALUE
S NUM=0 F S NUM=$O(DEFARR(20,NUM)) Q:NUM'>0 D
.S ITEM=$P($G(DEFARR(20,NUM,0)),U) I ITEM="" Q
.I '$D(INPUT("EVAL","FINDINGS",ITEM)) Q
.S SUB="" F S SUB=$O(INPUT("EVAL","FINDINGS",ITEM,SUB)) Q:SUB="" D
..S PIECE=0 F S PIECE=$O(INPUT("EVAL","FINDINGS",ITEM,SUB,PIECE)) Q:PIECE'>0 D
...S VALUE=$G(INPUT("EVAL","FINDINGS",ITEM,SUB,PIECE)) I VALUE="" Q
...I VALUE["$$" S TEMP="S VALUE="_VALUE X TEMP
...S $P(DEFARR(20,NUM,SUB),U,PIECE)=VALUE
I $G(INPUT("EVAL","EVAL DATE"))["$$" D Q
.S TEMP="S VALUE="_INPUT("EVAL","EVAL DATE") X TEMP
.S INPUT("EVAL","NEW EVAL DATE")=VALUE
Q
;
REMEVAL(RESULT,INPUT) ;
N RIEN,FIEVAL,TODAY,OUTTYPE,PNAME,ONAME,PXRMSRCFF
S PXRMSRCFF=1
K ^TMP("PXRHM",$J)
S RIEN=0 F S RIEN=$O(INPUT("REMINDERS",RIEN)) Q:'+RIEN D
.S ONAME=$P(INPUT("REMINDERS",RIEN),U),FIEVAL=$P(INPUT("REMINDERS",RIEN),U,2)
.S OUTTYPE=+$P(INPUT("REMINDERS",RIEN),U,3),TODAY=+$P(INPUT("REMINDERS",RIEN),U,4)
.D MAINDF(INPUT("DFN"),RIEN,OUTTYPE,TODAY,FIEVAL)
.S PNAME=$P($G(^PXD(811.9,RIEN,0)),U,3)
.I PNAME="" S PNAME=$P($G(^PXD(811.9,RIEN,0)),U)
.S @RESULT@(ONAME)=$G(^TMP("PXRHM",$J,RIEN,PNAME))
.S @RESULT@(ONAME,"PRINT NAME")=PNAME
.I FIEVAL M @RESULT@(ONAME,"FIEVAL")=^TMP("PXRHM",$J,RIEN,"FIEVAL")
.I OUTTYPE>0 M @RESULT@(ONAME,"MAINTENANCE")=^TMP("PXRHM",$J,RIEN,PNAME,"TXT")
.K ^TMP("PXRHM",$J)
.I $D(^TMP("PXRM BL DATA",$J)) D
..S RIEN("C")=$G(^TMP("PXRM BL DATA",$J,"REMINDER IEN"))
..S PNAME=$G(^TMP("PXRM BL DATA",$J,"REMINDER NAME"))
..I RIEN("C")=""!(PNAME="") Q
..S @RESULT@(ONAME,"FINDINGS",PNAME)=$G(^TMP("PXRM BL DATA",$J,"PXRHM",RIEN("C"),PNAME))
..I FIEVAL M @RESULT@(ONAME,"FINDINGS",PNAME,"FIEVAL")=^TMP("PXRM BL DATA",$J,"FIEVAL")
..I OUTTYPE>0 M @RESULT@(ONAME,"FINDINGS",PNAME,"MAINTENANCE")=^TMP("PXRM BL DATA",$J,"PXRHM",RIEN("C"),PNAME,"TXT")
..K ^TMP("PXRM BL DATA",$J)
Q
;
MAINDF(DFN,PXRMITEM,OUTTYPE,EVALDT,SAVEFIE) ;
N DEFARR,FIEVAL,REMCFIEN,MESSAGE,FINDING
D DEF^PXRMLDR(PXRMITEM,.DEFARR)
I OUTTYPE>0 D
.S REMCFIEN=+$O(^PXRMD(811.4,"B","VA-REMINDER DEFINITION","")) Q:REMCFIEN<1
.S FINDING=0 F S FINDING=+$O(DEFARR("E","PXRMD(811.4,",REMCFIEN,FINDING)) Q:'+FINDING S $P(DEFARR(20,FINDING,15),U,4)=OUTTYPE
I $G(EVALDT)?7N S SAVEFIE=1 ;MAINDF^PXRM, which allows passing evaluation date, always saved the FIEVAL array
E S EVALDT=$$NOW^XLFDT
D EVAL^PXRM(DFN,.DEFARR,OUTTYPE,0,.FIEVAL,EVALDT)
I $G(SAVEFIE) M ^TMP("PXRHM",$J,PXRMITEM,"FIEVAL")=FIEVAL
Q
;
REMLIST(RESULT,INPUT) ;
N BEG,END,CNT,DATA,DATANAM,DATAVAL,FAIL,INC,LIEN,LNAME,NODE,NUM,OVER,PAT,PFNAME,PNAME,PLIST,PATCREAT,RETDATA,SECURE
S LNAME="",FAIL=0 F S LNAME=$O(INPUT("LR",LNAME)) Q:LNAME=""!(FAIL=1) D
.K BEG,END,LIEN,PFNAME,PNAME,PLIST,SECURE,OVER,RETDATA
.S LIEN=+$O(^PXRM(810.4,"B",LNAME,"")) I LIEN'>0 D ERROR(.RESULT,"List Rule: "_LNAME_" not found") S FAIL=1 Q
.S NODE=$G(INPUT("LR",LNAME)),PNAME=$P(NODE,U),BEG=$P(NODE,U,2),END=$P(NODE,U,3),SECURE=$P(NODE,U,4),OVER=$P(NODE,U,5),RETDATA=+$P(NODE,U,6)
.S PLIST=$$REMPLCRE(PNAME,SECURE,OVER) I +PLIST'>0 D ERROR(.RESULT,"Error could not find or create patient list "_PLNAME) S FAIL=1 Q
.S PFNAME=$P(PLIST,U,2)
.D RUN^PXRMLCR(LIEN,+PLIST,"PXRMRULE",BEG,END,0,1)
.I '$D(^PXRMXP(810.5,+PLIST,30)) Q
.S NUM=0 F S NUM=$O(^PXRMXP(810.5,+PLIST,30,NUM)) Q:NUM'>0 D
..S PAT=$P($G(^PXRMXP(810.5,+PLIST,30,NUM,0)),U) I PAT="" Q
..S @RESULT@(LNAME,PAT)=""
..I RETDATA=0 Q
..S CNT=0 F S CNT=$O(^PXRMXP(810.5,+PLIST,30,NUM,"DATA",CNT)) Q:CNT'>0 D
...S DATA=$G(^PXRMXP(810.5,+PLIST,30,NUM,"DATA",CNT,0)) I DATA="" Q
...S DATANAM=$P($P(DATA,U),",",2),DATAVAL=$P(DATA,U,2) I DATANAM="" Q
...S @RESULT@(LNAME,PAT,"DATA",DATANAM)=DATAVAL
.S @RESULT@(LNAME,"PATIENT LIST CREATED")=PFNAME
.S @RESULT@(0)=1
Q
;
REMPLCRE(PLNAME,SECURE,OVER) ;
N FDA,IENS,NAME,NUM,RESULT,UNIQUE
S (NUM,RESULT,UNIQUE)=0
;if overwrite check to see if the list exist
I OVER=1 S RESULT=$O(^PXRMXP(810.5,"B",PLNAME,""))
I RESULT>0 Q RESULT
S NAME=PLNAME
;if not overwrite find unique and name exist create unique name
I OVER=0,$D(^PXRMXP(810.5,"B",NAME))>0 D
.F Q:UNIQUE=1 D
..S NAME=PLNAME_" ("_$$NOW^XLFDT()_")"
..I $D(^PXRMXP(810.5,"B",NAME))=0 S UNIQUE=1 Q
..H 1
;create stub in 810.5
S IENS="?+1,"
S FDA(810.5,IENS,.01)=NAME,FDA(810.5,IENS,100)="L",FDA(810.5,IENS,.07)=DUZ,FDA(810.5,IENS,.08)=$S(SECURE=0:"PUB",1:"PVT")
D UPDATE^DIE("","FDA","","MSG")
;if error display message and quit
I $D(MSG) Q 0
S RESULT=$O(^PXRMXP(810.5,"B",NAME,""))
Q RESULT_U_NAME
;
REMOC(RESULT,INPUT) ; controller for reminder order checks
N DISPLAY,FOUND,GROUPS,NUM,OI,OINAME,ORDIEN,PAT,PNAME,SEV,STATUS,RNAME,RIEN,GNAME,OIGROUPS
I '$D(INPUT("ROC","ALL")) M GROUPS=INPUT("ROC")
I '$D(INPUT("ROC ORDERS")) Q
S PAT=$G(INPUT("DFN"))
S STATUS=0
;loop through orders
S ORDIEN=0,FOUND=0 F S ORDIEN=$O(INPUT("ROC ORDERS",ORDIEN)) Q:ORDIEN'>0 D
.;loop through orderable items for each order
.S OI=0 F S OI=$O(INPUT("ROC ORDERS",ORDIEN,"OI",OI)) Q:OI'>0 D
..S OINAME=$P($G(INPUT("ROC ORDERS",ORDIEN,"OI",OI)),U)
..I $D(INPUT("ROC RETURN TYPE","GROUPS")) D
...D GETGRPS^PXRMORCH(OI,.OIGROUPS) Q:'$D(OIGROUPS)
...S @RESULT@(0)=1
...M @RESULT@(ORDIEN,"GROUPS")=OIGROUPS
..;does not process reminder order checks
..I '$D(INPUT("ROC RETURN TYPE","RULES")) Q
..;Process OI against all Production Reminder Order checks Rule
..I '$D(GROUPS) D ORDERCHK^PXRMORCH(PAT,OI,STATUS,0,0)
..;Process OI against Production Reminder Order Checks only found in the array of groups
..I $D(GROUPS) D ORDERGRP^PXRMORCH(PAT,OI,STATUS,0,.GROUPS)
..;quit if no order checks found
..I '$D(^TMP($J,OI)) Q
..S @RESULT@(0)=1
..S SEV=0 F S SEV=$O(^TMP($J,OI,SEV)) Q:SEV'>0 D
...S DISPLAY="" F S DISPLAY=$O(^TMP($J,OI,SEV,DISPLAY)) Q:DISPLAY="" D
....S RIEN=$O(^PXD(801.1,"D",DISPLAY,0)) I RIEN>0 S RNAME=$P($G(^PXD(801.1,RIEN,0)),U)
....I RNAME="" S RNAME=DISPLAY
....S @RESULT@(ORDIEN,"RULES",RNAME)=""
..K ^TMP($J,OI)
.I '(($D(@RESULT@(ORDIEN,"RULES")))!($D(@RESULT@(ORDIEN,"GROUPS")))) Q
.S @RESULT@(ORDIEN)=$G(INPUT("ROC ORDERS",ORDIEN))
.M @RESULT@(ORDIEN,"TX")=INPUT("ROC ORDERS",ORDIEN,"TX")
.I $D(INPUT("ROC RETURN TYPE","OI")) M @RESULT@(ORDIEN,"OI")=INPUT("ROC ORDERS",ORDIEN,"OI")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMGEVA 9229 printed Dec 13, 2024@01:46:01 Page 2
PXRMGEVA ;SLC/AGP,RFR - Generic entry point to run different Reminder Evaluation ;Jan 13, 2023@17:06
+1 ;;2.0;CLINICAL REMINDERS;**45,71,84**;Feb 04, 2005;Build 2
+2 ;
+3 ; Reference to OIS^ORX8 in ICR #2467
+4 ; Reference to EN^ORQ1 in ICR #3154
+5 ; Reference to EN^ORX8 in ICR #871
+6 ; Reference to PKGID^ORX8 in ICR #3071
+7 ; Reference to VALUE^ORX8 in ICR #2467
+8 ; Reference to ^ORD(100.98,"B", in ICR #873
+9 ;
ERROR(RESULT,MSG) ;
+1 SET @RESULT@(0)=-1_U_MSG
+2 QUIT
+3 ;
FINDDGS(RESULT,INPUT) ;
+1 NEW FAIL,IEN,NAME
+2 SET NAME=""
SET FAIL=0
FOR
SET NAME=$ORDER(INPUT("ROC DISPLAY GROUPS",NAME))
if NAME=""!(FAIL>0)
QUIT
Begin DoDot:1
+3 SET IEN=$ORDER(^ORD(100.98,"B",NAME,""))
IF IEN'>0
DO ERROR(.RESULT,"Could not find Display Group: "_NAME)
SET FAIL=1
+4 SET INPUT("DG IEN",IEN)=""
+5 SET INPUT("DG IEN",IEN,"START")=+$GET(INPUT("ROC DISPLAY GROUPS",NAME,"START"))
+6 SET INPUT("DG IEN",IEN,"STOP")=+$GET(INPUT("ROC DISPLAY GROUPS",NAME,"STOP"))
End DoDot:1
+7 QUIT
+8 ;
GETOIS(INPUT) ; find orderable items for each order
+1 NEW CNT,NUM,ARRAY,OI,ORDIEN,POS,PXRMOIS
+2 SET ORDIEN=0
FOR
SET ORDIEN=$ORDER(INPUT("ROC ORDERS",ORDIEN))
if ORDIEN'>0
QUIT
Begin DoDot:1
+3 KILL PXRMOIS
DO OIS^ORX8(.PXRMOIS,ORDIEN)
IF '$DATA(PXRMOIS)
QUIT
+4 MERGE INPUT("ROC ORDERS",ORDIEN,"OI")=PXRMOIS
End DoDot:1
+5 QUIT
+6 ;
GTORDERS(INPUT) ;
+1 NEW DIEN,DATE,END,NODE,PAT,ORDIEN,ORN,PXRMOIS,START,STOP,ORLIST,MOD,PXRMINST,ORUPCHUK
+2 SET PAT=$GET(INPUT("DFN"))
+3 SET DIEN=0
FOR
SET DIEN=$ORDER(INPUT("DG IEN",DIEN))
if DIEN'>0
QUIT
Begin DoDot:1
+4 KILL ^TMP("ORR",$JOB)
+5 SET START=$SELECT(INPUT("DG IEN",DIEN,"START")>0:INPUT("DG IEN",DIEN,"START"),1:$GET(INPUT("ROC START")))
+6 SET STOP=$SELECT(INPUT("DG IEN",DIEN,"STOP")>0:INPUT("DG IEN",DIEN,"STOP"),1:$GET(INPUT("ROC STOP")))
+7 ;call for current activities
+8 DO EN^ORQ1(PAT_";DPT(",DIEN,1,,START,STOP,1)
+9 SET DATE=""
FOR
SET DATE=$ORDER(^TMP("ORR",$JOB,DATE))
if DATE=""
QUIT
Begin DoDot:2
+10 FOR ORN=1:1:$GET(^TMP("ORR",$JOB,DATE,"TOT"))
Begin DoDot:3
+11 SET NODE=$GET(^TMP("ORR",$JOB,DATE,ORN))
+12 IF $DATA(INPUT("ROC ORDERS",+$PIECE(NODE,U)))
QUIT
+13 IF ('$DATA(INPUT("ROC STATUS","*"))&('$DATA(INPUT("ROC STATUS",$PIECE(NODE,U,6)))))
QUIT
+14 IF $DATA(INPUT("ROC ORDERED WITHIN"))&(($PIECE(NODE,U,3)<START)!($PIECE(NODE,U,3)>STOP))
QUIT
+15 SET ORDIEN=+$PIECE(NODE,U)
+16 DO EN^ORX8(ORDIEN)
+17 SET NODE=NODE_U_$PIECE(ORUPCHUK("ORNP"),U)
+18 KILL ORUPCHUK
+19 SET INPUT("ROC ORDERS",ORDIEN)=NODE
+20 MERGE INPUT("ROC ORDERS",ORDIEN,"TX")=^TMP("ORR",$JOB,DATE,ORN,"TX")
+21 SET INPUT("ROC ORDERS",ORDIEN,"PKG ID")=$$PKGID^ORX8(ORDIEN)
+22 FOR PXRMINST=1:1
SET MOD=$$VALUE^ORX8(ORDIEN,"MODIFIER",PXRMINST,"E")
if MOD=""
QUIT
Begin DoDot:4
+23 SET INPUT("ROC ORDERS",ORDIEN,"MODIFIERS",PXRMINST)=MOD
End DoDot:4
+24 KILL PXRMOIS
DO OIS^ORX8(.PXRMOIS,ORDIEN)
+25 IF $DATA(PXRMOIS)
MERGE INPUT("ROC ORDERS",ORDIEN,"OI")=PXRMOIS
End DoDot:3
End DoDot:2
End DoDot:1
+26 KILL ^TMP("ORR",$JOB)
+27 QUIT
+28 ;
GETVAL(INPUT,TYPE) ;
+1 QUIT $GET(INPUT("VARIABLES",TYPE))
+2 ;
REM(RESULT,INPUT) ; controller for reminder evaluation types
+1 IF $DATA(INPUT("LR"))
DO REMLIST(.RESULT,.INPUT)
QUIT
+2 IF $DATA(INPUT("REMINDERS"))
DO REMEVAL(.RESULT,.INPUT)
QUIT
+3 DO REMOC(.RESULT,.INPUT)
+4 QUIT
+5 ;
REMMDEF(INPUT,DEFARR) ; update DEFARR with modifiers
+1 NEW ITEM,NUM,SUB,PIECE,TEMP,VALUE
+2 SET NUM=0
FOR
SET NUM=$ORDER(DEFARR(20,NUM))
if NUM'>0
QUIT
Begin DoDot:1
+3 SET ITEM=$PIECE($GET(DEFARR(20,NUM,0)),U)
IF ITEM=""
QUIT
+4 IF '$DATA(INPUT("EVAL","FINDINGS",ITEM))
QUIT
+5 SET SUB=""
FOR
SET SUB=$ORDER(INPUT("EVAL","FINDINGS",ITEM,SUB))
if SUB=""
QUIT
Begin DoDot:2
+6 SET PIECE=0
FOR
SET PIECE=$ORDER(INPUT("EVAL","FINDINGS",ITEM,SUB,PIECE))
if PIECE'>0
QUIT
Begin DoDot:3
+7 SET VALUE=$GET(INPUT("EVAL","FINDINGS",ITEM,SUB,PIECE))
IF VALUE=""
QUIT
+8 IF VALUE["$$"
SET TEMP="S VALUE="_VALUE
XECUTE TEMP
+9 SET $PIECE(DEFARR(20,NUM,SUB),U,PIECE)=VALUE
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF $GET(INPUT("EVAL","EVAL DATE"))["$$"
Begin DoDot:1
+11 SET TEMP="S VALUE="_INPUT("EVAL","EVAL DATE")
XECUTE TEMP
+12 SET INPUT("EVAL","NEW EVAL DATE")=VALUE
End DoDot:1
QUIT
+13 QUIT
+14 ;
REMEVAL(RESULT,INPUT) ;
+1 NEW RIEN,FIEVAL,TODAY,OUTTYPE,PNAME,ONAME,PXRMSRCFF
+2 SET PXRMSRCFF=1
+3 KILL ^TMP("PXRHM",$JOB)
+4 SET RIEN=0
FOR
SET RIEN=$ORDER(INPUT("REMINDERS",RIEN))
if '+RIEN
QUIT
Begin DoDot:1
+5 SET ONAME=$PIECE(INPUT("REMINDERS",RIEN),U)
SET FIEVAL=$PIECE(INPUT("REMINDERS",RIEN),U,2)
+6 SET OUTTYPE=+$PIECE(INPUT("REMINDERS",RIEN),U,3)
SET TODAY=+$PIECE(INPUT("REMINDERS",RIEN),U,4)
+7 DO MAINDF(INPUT("DFN"),RIEN,OUTTYPE,TODAY,FIEVAL)
+8 SET PNAME=$PIECE($GET(^PXD(811.9,RIEN,0)),U,3)
+9 IF PNAME=""
SET PNAME=$PIECE($GET(^PXD(811.9,RIEN,0)),U)
+10 SET @RESULT@(ONAME)=$GET(^TMP("PXRHM",$JOB,RIEN,PNAME))
+11 SET @RESULT@(ONAME,"PRINT NAME")=PNAME
+12 IF FIEVAL
MERGE @RESULT@(ONAME,"FIEVAL")=^TMP("PXRHM",$JOB,RIEN,"FIEVAL")
+13 IF OUTTYPE>0
MERGE @RESULT@(ONAME,"MAINTENANCE")=^TMP("PXRHM",$JOB,RIEN,PNAME,"TXT")
+14 KILL ^TMP("PXRHM",$JOB)
+15 IF $DATA(^TMP("PXRM BL DATA",$JOB))
Begin DoDot:2
+16 SET RIEN("C")=$GET(^TMP("PXRM BL DATA",$JOB,"REMINDER IEN"))
+17 SET PNAME=$GET(^TMP("PXRM BL DATA",$JOB,"REMINDER NAME"))
+18 IF RIEN("C")=""!(PNAME="")
QUIT
+19 SET @RESULT@(ONAME,"FINDINGS",PNAME)=$GET(^TMP("PXRM BL DATA",$JOB,"PXRHM",RIEN("C"),PNAME))
+20 IF FIEVAL
MERGE @RESULT@(ONAME,"FINDINGS",PNAME,"FIEVAL")=^TMP("PXRM BL DATA",$JOB,"FIEVAL")
+21 IF OUTTYPE>0
MERGE @RESULT@(ONAME,"FINDINGS",PNAME,"MAINTENANCE")=^TMP("PXRM BL DATA",$JOB,"PXRHM",RIEN("C"),PNAME,"TXT")
+22 KILL ^TMP("PXRM BL DATA",$JOB)
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
MAINDF(DFN,PXRMITEM,OUTTYPE,EVALDT,SAVEFIE) ;
+1 NEW DEFARR,FIEVAL,REMCFIEN,MESSAGE,FINDING
+2 DO DEF^PXRMLDR(PXRMITEM,.DEFARR)
+3 IF OUTTYPE>0
Begin DoDot:1
+4 SET REMCFIEN=+$ORDER(^PXRMD(811.4,"B","VA-REMINDER DEFINITION",""))
if REMCFIEN<1
QUIT
+5 SET FINDING=0
FOR
SET FINDING=+$ORDER(DEFARR("E","PXRMD(811.4,",REMCFIEN,FINDING))
if '+FINDING
QUIT
SET $PIECE(DEFARR(20,FINDING,15),U,4)=OUTTYPE
End DoDot:1
+6 ;MAINDF^PXRM, which allows passing evaluation date, always saved the FIEVAL array
IF $GET(EVALDT)?7N
SET SAVEFIE=1
+7 IF '$TEST
SET EVALDT=$$NOW^XLFDT
+8 DO EVAL^PXRM(DFN,.DEFARR,OUTTYPE,0,.FIEVAL,EVALDT)
+9 IF $GET(SAVEFIE)
MERGE ^TMP("PXRHM",$JOB,PXRMITEM,"FIEVAL")=FIEVAL
+10 QUIT
+11 ;
REMLIST(RESULT,INPUT) ;
+1 NEW BEG,END,CNT,DATA,DATANAM,DATAVAL,FAIL,INC,LIEN,LNAME,NODE,NUM,OVER,PAT,PFNAME,PNAME,PLIST,PATCREAT,RETDATA,SECURE
+2 SET LNAME=""
SET FAIL=0
FOR
SET LNAME=$ORDER(INPUT("LR",LNAME))
if LNAME=""!(FAIL=1)
QUIT
Begin DoDot:1
+3 KILL BEG,END,LIEN,PFNAME,PNAME,PLIST,SECURE,OVER,RETDATA
+4 SET LIEN=+$ORDER(^PXRM(810.4,"B",LNAME,""))
IF LIEN'>0
DO ERROR(.RESULT,"List Rule: "_LNAME_" not found")
SET FAIL=1
QUIT
+5 SET NODE=$GET(INPUT("LR",LNAME))
SET PNAME=$PIECE(NODE,U)
SET BEG=$PIECE(NODE,U,2)
SET END=$PIECE(NODE,U,3)
SET SECURE=$PIECE(NODE,U,4)
SET OVER=$PIECE(NODE,U,5)
SET RETDATA=+$PIECE(NODE,U,6)
+6 SET PLIST=$$REMPLCRE(PNAME,SECURE,OVER)
IF +PLIST'>0
DO ERROR(.RESULT,"Error could not find or create patient list "_PLNAME)
SET FAIL=1
QUIT
+7 SET PFNAME=$PIECE(PLIST,U,2)
+8 DO RUN^PXRMLCR(LIEN,+PLIST,"PXRMRULE",BEG,END,0,1)
+9 IF '$DATA(^PXRMXP(810.5,+PLIST,30))
QUIT
+10 SET NUM=0
FOR
SET NUM=$ORDER(^PXRMXP(810.5,+PLIST,30,NUM))
if NUM'>0
QUIT
Begin DoDot:2
+11 SET PAT=$PIECE($GET(^PXRMXP(810.5,+PLIST,30,NUM,0)),U)
IF PAT=""
QUIT
+12 SET @RESULT@(LNAME,PAT)=""
+13 IF RETDATA=0
QUIT
+14 SET CNT=0
FOR
SET CNT=$ORDER(^PXRMXP(810.5,+PLIST,30,NUM,"DATA",CNT))
if CNT'>0
QUIT
Begin DoDot:3
+15 SET DATA=$GET(^PXRMXP(810.5,+PLIST,30,NUM,"DATA",CNT,0))
IF DATA=""
QUIT
+16 SET DATANAM=$PIECE($PIECE(DATA,U),",",2)
SET DATAVAL=$PIECE(DATA,U,2)
IF DATANAM=""
QUIT
+17 SET @RESULT@(LNAME,PAT,"DATA",DATANAM)=DATAVAL
End DoDot:3
End DoDot:2
+18 SET @RESULT@(LNAME,"PATIENT LIST CREATED")=PFNAME
+19 SET @RESULT@(0)=1
End DoDot:1
+20 QUIT
+21 ;
REMPLCRE(PLNAME,SECURE,OVER) ;
+1 NEW FDA,IENS,NAME,NUM,RESULT,UNIQUE
+2 SET (NUM,RESULT,UNIQUE)=0
+3 ;if overwrite check to see if the list exist
+4 IF OVER=1
SET RESULT=$ORDER(^PXRMXP(810.5,"B",PLNAME,""))
+5 IF RESULT>0
QUIT RESULT
+6 SET NAME=PLNAME
+7 ;if not overwrite find unique and name exist create unique name
+8 IF OVER=0
IF $DATA(^PXRMXP(810.5,"B",NAME))>0
Begin DoDot:1
+9 FOR
if UNIQUE=1
QUIT
Begin DoDot:2
+10 SET NAME=PLNAME_" ("_$$NOW^XLFDT()_")"
+11 IF $DATA(^PXRMXP(810.5,"B",NAME))=0
SET UNIQUE=1
QUIT
+12 HANG 1
End DoDot:2
End DoDot:1
+13 ;create stub in 810.5
+14 SET IENS="?+1,"
+15 SET FDA(810.5,IENS,.01)=NAME
SET FDA(810.5,IENS,100)="L"
SET FDA(810.5,IENS,.07)=DUZ
SET FDA(810.5,IENS,.08)=$SELECT(SECURE=0:"PUB",1:"PVT")
+16 DO UPDATE^DIE("","FDA","","MSG")
+17 ;if error display message and quit
+18 IF $DATA(MSG)
QUIT 0
+19 SET RESULT=$ORDER(^PXRMXP(810.5,"B",NAME,""))
+20 QUIT RESULT_U_NAME
+21 ;
REMOC(RESULT,INPUT) ; controller for reminder order checks
+1 NEW DISPLAY,FOUND,GROUPS,NUM,OI,OINAME,ORDIEN,PAT,PNAME,SEV,STATUS,RNAME,RIEN,GNAME,OIGROUPS
+2 IF '$DATA(INPUT("ROC","ALL"))
MERGE GROUPS=INPUT("ROC")
+3 IF '$DATA(INPUT("ROC ORDERS"))
QUIT
+4 SET PAT=$GET(INPUT("DFN"))
+5 SET STATUS=0
+6 ;loop through orders
+7 SET ORDIEN=0
SET FOUND=0
FOR
SET ORDIEN=$ORDER(INPUT("ROC ORDERS",ORDIEN))
if ORDIEN'>0
QUIT
Begin DoDot:1
+8 ;loop through orderable items for each order
+9 SET OI=0
FOR
SET OI=$ORDER(INPUT("ROC ORDERS",ORDIEN,"OI",OI))
if OI'>0
QUIT
Begin DoDot:2
+10 SET OINAME=$PIECE($GET(INPUT("ROC ORDERS",ORDIEN,"OI",OI)),U)
+11 IF $DATA(INPUT("ROC RETURN TYPE","GROUPS"))
Begin DoDot:3
+12 DO GETGRPS^PXRMORCH(OI,.OIGROUPS)
if '$DATA(OIGROUPS)
QUIT
+13 SET @RESULT@(0)=1
+14 MERGE @RESULT@(ORDIEN,"GROUPS")=OIGROUPS
End DoDot:3
+15 ;does not process reminder order checks
+16 IF '$DATA(INPUT("ROC RETURN TYPE","RULES"))
QUIT
+17 ;Process OI against all Production Reminder Order checks Rule
+18 IF '$DATA(GROUPS)
DO ORDERCHK^PXRMORCH(PAT,OI,STATUS,0,0)
+19 ;Process OI against Production Reminder Order Checks only found in the array of groups
+20 IF $DATA(GROUPS)
DO ORDERGRP^PXRMORCH(PAT,OI,STATUS,0,.GROUPS)
+21 ;quit if no order checks found
+22 IF '$DATA(^TMP($JOB,OI))
QUIT
+23 SET @RESULT@(0)=1
+24 SET SEV=0
FOR
SET SEV=$ORDER(^TMP($JOB,OI,SEV))
if SEV'>0
QUIT
Begin DoDot:3
+25 SET DISPLAY=""
FOR
SET DISPLAY=$ORDER(^TMP($JOB,OI,SEV,DISPLAY))
if DISPLAY=""
QUIT
Begin DoDot:4
+26 SET RIEN=$ORDER(^PXD(801.1,"D",DISPLAY,0))
IF RIEN>0
SET RNAME=$PIECE($GET(^PXD(801.1,RIEN,0)),U)
+27 IF RNAME=""
SET RNAME=DISPLAY
+28 SET @RESULT@(ORDIEN,"RULES",RNAME)=""
End DoDot:4
End DoDot:3
+29 KILL ^TMP($JOB,OI)
End DoDot:2
+30 IF '(($DATA(@RESULT@(ORDIEN,"RULES")))!($DATA(@RESULT@(ORDIEN,"GROUPS"))))
QUIT
+31 SET @RESULT@(ORDIEN)=$GET(INPUT("ROC ORDERS",ORDIEN))
+32 MERGE @RESULT@(ORDIEN,"TX")=INPUT("ROC ORDERS",ORDIEN,"TX")
+33 IF $DATA(INPUT("ROC RETURN TYPE","OI"))
MERGE @RESULT@(ORDIEN,"OI")=INPUT("ROC ORDERS",ORDIEN,"OI")
End DoDot:1
+34 QUIT
+35 ;
